Mercurial > octave-nkf
changeset 15043:fabc0e37ead1 gui
maint: periodic merge of default to gui
| author | Jordi Gutiérrez Hermoso <jordigh@octave.org> |
|---|---|
| date | Sat, 28 Jul 2012 12:06:34 -0400 |
| parents | 7c14e3e6fc6b (current diff) 4328e28414aa (diff) |
| children | b7b1ffc88086 |
| files | NEWS configure.ac scripts/pkg/private/absolute_pathname.m src/DLD-FUNCTIONS/__contourc__.cc src/DLD-FUNCTIONS/__dispatch__.cc src/DLD-FUNCTIONS/__lin_interpn__.cc src/DLD-FUNCTIONS/__pchip_deriv__.cc src/DLD-FUNCTIONS/__qp__.cc src/DLD-FUNCTIONS/balance.cc src/DLD-FUNCTIONS/besselj.cc src/DLD-FUNCTIONS/betainc.cc src/DLD-FUNCTIONS/bsxfun.cc src/DLD-FUNCTIONS/cellfun.cc src/DLD-FUNCTIONS/colloc.cc src/DLD-FUNCTIONS/conv2.cc src/DLD-FUNCTIONS/daspk.cc src/DLD-FUNCTIONS/dasrt.cc src/DLD-FUNCTIONS/dassl.cc src/DLD-FUNCTIONS/det.cc src/DLD-FUNCTIONS/dlmread.cc src/DLD-FUNCTIONS/dot.cc src/DLD-FUNCTIONS/eig.cc src/DLD-FUNCTIONS/fft.cc src/DLD-FUNCTIONS/fft2.cc src/DLD-FUNCTIONS/fftn.cc src/DLD-FUNCTIONS/filter.cc src/DLD-FUNCTIONS/find.cc src/DLD-FUNCTIONS/gammainc.cc src/DLD-FUNCTIONS/gcd.cc src/DLD-FUNCTIONS/getgrent.cc src/DLD-FUNCTIONS/getpwent.cc src/DLD-FUNCTIONS/getrusage.cc src/DLD-FUNCTIONS/givens.cc src/DLD-FUNCTIONS/hess.cc src/DLD-FUNCTIONS/hex2num.cc src/DLD-FUNCTIONS/inv.cc src/DLD-FUNCTIONS/kron.cc src/DLD-FUNCTIONS/lookup.cc src/DLD-FUNCTIONS/lsode.cc src/DLD-FUNCTIONS/lu.cc src/DLD-FUNCTIONS/luinc.cc src/DLD-FUNCTIONS/matrix_type.cc src/DLD-FUNCTIONS/max.cc src/DLD-FUNCTIONS/md5sum.cc src/DLD-FUNCTIONS/mgorth.cc src/DLD-FUNCTIONS/nproc.cc src/DLD-FUNCTIONS/pinv.cc src/DLD-FUNCTIONS/quad.cc src/DLD-FUNCTIONS/quadcc.cc src/DLD-FUNCTIONS/qz.cc src/DLD-FUNCTIONS/rand.cc src/DLD-FUNCTIONS/rcond.cc src/DLD-FUNCTIONS/regexp.cc src/DLD-FUNCTIONS/schur.cc src/DLD-FUNCTIONS/spparms.cc src/DLD-FUNCTIONS/sqrtm.cc src/DLD-FUNCTIONS/str2double.cc src/DLD-FUNCTIONS/strfind.cc src/DLD-FUNCTIONS/sub2ind.cc src/DLD-FUNCTIONS/svd.cc src/DLD-FUNCTIONS/syl.cc src/DLD-FUNCTIONS/time.cc src/DLD-FUNCTIONS/tril.cc src/DLD-FUNCTIONS/typecast.cc src/symtab.h |
| diffstat | 295 files changed, 41403 insertions(+), 33270 deletions(-) [+] |
line wrap: on
line diff
--- a/NEWS Sat Jul 28 15:17:57 2012 +0200 +++ b/NEWS Sat Jul 28 12:06:34 2012 -0400 @@ -79,10 +79,13 @@ ** Other new functions added in 3.8.0: - betaincinv lines tetramesh - colorcube rgbplot - erfcinv shrinkfaces - findfigs splinefit + betaincinv erfcinv splinefit + cmpermute findfigs tetramesh + cmunique fminsearch rgbplot + colorcube lines shrinkfaces + + ** The default name of the Octave crash dump file is now called + octave-workspace instead of octave-core. ** Deprecated functions.
--- a/build-aux/common.mk Sat Jul 28 15:17:57 2012 +0200 +++ b/build-aux/common.mk Sat Jul 28 12:06:34 2012 -0400 @@ -181,6 +181,10 @@ Z_LDFLAGS = @Z_LDFLAGS@ Z_LIBS = @Z_LIBS@ +LLVM_CPPFLAGS = @LLVM_CPPFLAGS@ +LLVM_LDFLAGS = @LLVM_LDFLAGS@ +LLVM_LIBS = @LLVM_LIBS@ + GRAPHICS_LIBS = @GRAPHICS_LIBS@ QHULL_CPPFLAGS = @QHULL_CPPFLAGS@ @@ -252,7 +256,7 @@ DL_LIBS = @DL_LIBS@ LIBS = @LIBS@ -ALL_CPPFLAGS = $(CPPFLAGS) $(HDF5_CPPFLAGS) $(Z_CPPFLAGS) +ALL_CPPFLAGS = $(CPPFLAGS) $(HDF5_CPPFLAGS) $(Z_CPPFLAGS) $(LLVM_CPPFLAGS) SPARSE_XCPPFLAGS = \ $(CHOLMOD_CPPFLAGS) $(UMFPACK_CPPFLAGS) \ @@ -544,6 +548,9 @@ -e "s|%OCTAVE_CONF_MAGICK_CPPFLAGS%|\"${MAGICK_CPPFLAGS}\"|" \ -e "s|%OCTAVE_CONF_MAGICK_LDFLAGS%|\"${MAGICK_LDFLAGS}\"|" \ -e "s|%OCTAVE_CONF_MAGICK_LIBS%|\"${MAGICK_LIBS}\"|" \ + -e "s|%OCTAVE_CONF_LLVM_CPPFLAGS%|\"${LLVM_CPPFLAGS}\"|" \ + -e "s|%OCTAVE_CONF_LLVM_LDFLAGS%|\"${LLVM_LDFLAGS}\"|" \ + -e "s|%OCTAVE_CONF_LLVM_LIBS%|\"${LLVM_LIBS}\"|" \ -e 's|%OCTAVE_CONF_MKOCTFILE_DL_LDFLAGS%|\"@MKOCTFILE_DL_LDFLAGS@\"|' \ -e "s|%OCTAVE_CONF_OCTAVE_LINK_DEPS%|\"${OCTAVE_LINK_DEPS}\"|" \ -e "s|%OCTAVE_CONF_OCTAVE_LINK_OPTS%|\"${OCTAVE_LINK_OPTS}\"|" \
--- a/build-aux/mk-opts.pl Sat Jul 28 15:17:57 2012 +0200 +++ b/build-aux/mk-opts.pl Sat Jul 28 12:06:34 2012 -0400 @@ -513,7 +513,7 @@ #include "$header" -#include "defun-dld.h" +#include "defun.h" #include "pr-output.h" #include "oct-obj.h" @@ -909,11 +909,11 @@ sub emit_options_function { print <<"_END_EMIT_OPTIONS_FUNCTION_HDR_"; -DEFUN_DLD ($OPT_FCN_NAME, args, , +DEFUN ($OPT_FCN_NAME, args, , "-*- texinfo -*-\\n\\ -\@deftypefn {Loadable Function} {} $OPT_FCN_NAME ()\\n\\ -\@deftypefnx {Loadable Function} {val =} $OPT_FCN_NAME (\@var{opt})\\n\\ -\@deftypefnx {Loadable Function} {} $OPT_FCN_NAME (\@var{opt}, \@var{val})\\n\\ +\@deftypefn {Built-in Function} {} $OPT_FCN_NAME ()\\n\\ +\@deftypefnx {Built-in Function} {val =} $OPT_FCN_NAME (\@var{opt})\\n\\ +\@deftypefnx {Built-in Function} {} $OPT_FCN_NAME (\@var{opt}, \@var{val})\\n\\ $DOC_STRING\\n\\ \\n\\ Options include\\n\\
--- a/configure.ac Sat Jul 28 15:17:57 2012 +0200 +++ b/configure.ac Sat Jul 28 12:06:34 2012 -0400 @@ -715,6 +715,96 @@ [ZLIB library not found. Octave will not be able to save or load compressed data files or HDF5 files.], [zlib.h], [gzclearerr]) +### Check for the llvm library +dnl +dnl +dnl llvm is odd and has its own pkg-config like script. We should probably check +dnl for existance and +dnl +save_CPPFLAGS="$CPPFLAGS" +save_CXXFLAGS="$CXXFLAGS" +save_LIBS="$LIBS" +save_LDFLAGS="$LDFLAGS" + +warn_llvm="LLVM library fails tests. JIT compilation will be disabled." + +AC_ARG_VAR(LLVM_CONFIG, [path to llvm-config utility]) + +AC_ARG_ENABLE([jit-debug], + AS_HELP_STRING([--enable-jit-debug], [Enable debug printing of jit IRs])) + +AS_IF([test "x$enable_jit_debug" = "xyes"], [ + AC_DEFINE(OCTAVE_JIT_DEBUG, 1, [Define for jit debug printing]) +]) + +LLVM_CXXFLAGS= +LLVM_CPPFLAGS= +LLVM_LDFLAGS= +LLVM_LIBS= + +if test "x$ac_cv_env_LLVM_CONFIG_set" = "xset"; then + # We use -isystem if avaiable because we do not want to see warnings in llvm + LLVM_INCLUDE_FLAG=-I + OCTAVE_CC_FLAG(-isystem ., [ + LLVM_INCLUDE_FLAG=-isystem + AC_MSG_NOTICE([using -isystem for llvm headers])]) + + LLVM_LDFLAGS="-L`$LLVM_CONFIG --libdir`" + LLVM_LIBS=`$LLVM_CONFIG --libs` + dnl Use -isystem so we don't get warnings from llvm headers + LLVM_CPPFLAGS="$LLVM_INCLUDE_FLAG `$LLVM_CONFIG --includedir`" + LLVM_CXXFLAGS= + + dnl + dnl We define some extra flags that llvm requires in order to include headers. + dnl Idealy we should get these from llvm-config, but llvm-config isn't very + dnl helpful. + dnl + CPPFLAGS="-D__STDC_CONSTANT_MACROS -D__STDC_LIMIT_MACROS $LLVM_CPPFLAGS $CPPFLAGS" + CXXFLAGS="$LLVM_CXXFLAGS $CXXFLAGS" + LIBS="$LLVM_LIBS $LIBS" + LDFLAGS="$LLVM_LDFLAGS $LDFLAGS" + + AC_LANG_PUSH(C++) + AC_CHECK_HEADER([llvm/LLVMContext.h], [ + AC_MSG_CHECKING([for llvm::getGlobalContext in llvm/LLVMContext.h]) + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[#include <llvm/LLVMContext.h>]], + [[llvm::LLVMContext& ctx = llvm::getGlobalContext ();]])], + [ + AC_MSG_RESULT([yes]) + warn_llvm= + XTRA_CXXFLAGS="$XTRA_CXXFLAGS $LLVM_CXXFLAGS $LLVM_CPPFLAGS" + ], + [AC_MSG_RESULT([no]) + ]) + ]) + AC_LANG_POP(C++) + +else + warn_llvm="LLVM_CONFIG not set. JIT compilation will be disabled." +fi + +if test -z "$warn_llvm"; then + AC_DEFINE(HAVE_LLVM, 1, [Define if LLVM is available]) +else + LLVM_CXXFLAGS= + LLVM_CPPFLAGS= + LLVM_LDFLAGS= + LLVM_LIBS= + OCTAVE_CONFIGURE_WARNING([warn_llvm]) +fi + +AC_SUBST(LLVM_CXXFLAGS) +AC_SUBST(LLVM_CPPFLAGS) +AC_SUBST(LLVM_LDFLAGS) +AC_SUBST(LLVM_LIBS) + +CPPFLAGS="$save_CPPFLAGS" +CXXFLAGS="$save_CXXFLAGS" +LIBS="$save_LIBS" +LDFLAGS="$save_LDFLAGS" + ### Check for HDF5 library. save_CPPFLAGS="$CPPFLAGS" @@ -2748,17 +2838,20 @@ FFTW3F LDFLAGS: $FFTW3F_LDFLAGS FFTW3F libraries: $FFTW3F_LIBS fontconfig CFLAGS: $FONTCONFIG_CFLAGS - fontconfig LIBS: $FONTCONFIG_LIBS - FT2_CFLAGS: $FT2_CFLAGS - FT2_LIBS: $FT2_LIBS + fontconfig libraries: $FONTCONFIG_LIBS + FreeType2 CFLAGS: $FT2_CFLAGS + FreeType2 libraries: $FT2_LIBS GLPK CPPFLAGS: $GLPK_CPPFLAGS GLPK LDFLAGS: $GLPK_LDFLAGS GLPK libraries: $GLPK_LIBS graphics CFLAGS: $GRAPHICS_CFLAGS - graphics LIBS: $GRAPHICS_LIBS + graphics libraries: $GRAPHICS_LIBS Magick++ CPPFLAGS: $MAGICK_CPPFLAGS Magick++ LDFLAGS: $MAGICK_LDFLAGS Magick++ libraries: $MAGICK_LIBS + LLVM CPPFLAGS: $LLVM_CPPFLAGS + LLVM LDFLAGS: $LLVM_LDFLAGS + LLVM libraries: $LLVM_LIBS HDF5 CPPFLAGS: $HDF5_CPPFLAGS HDF5 LDFLAGS: $HDF5_LDFLAGS HDF5 libraries: $HDF5_LIBS
--- a/doc/interpreter/arith.txi Sat Jul 28 15:17:57 2012 +0200 +++ b/doc/interpreter/arith.txi Sat Jul 28 12:06:34 2012 -0400 @@ -309,6 +309,10 @@ @DOCSTRING(pi) +@c Provide a Seealso link location for these objects in the documentation +@anchor{doc-i} +@anchor{doc-j} +@anchor{doc-J} @DOCSTRING(I) @DOCSTRING(Inf)
--- a/doc/interpreter/contrib.txi Sat Jul 28 15:17:57 2012 +0200 +++ b/doc/interpreter/contrib.txi Sat Jul 28 12:06:34 2012 -0400 @@ -135,7 +135,11 @@ @section Basics of Generating a Changeset The preferable form of contribution is creating a Mercurial changeset -and sending it via e-mail to the octave-maintainers mailing list. +and submit it to the @uref{http://savannah.gnu.org/bugs/?group=octave, bug} or +@uref{http://savannah.gnu.org/patch/?func=additem&group=octave, patch} +trackers@footnote{Please use the patch tracker only for patches which add new +features. If you have a patch to submit that fixes a bug, you should use the +bug tracker instead.}. Mercurial is the source code management system currently used to develop Octave. Other forms of contributions (e.g., simple diff patches) are also acceptable, but they slow down the review process. If you want to @@ -159,15 +163,14 @@ hg export -o ../cool.diff tip # export the changeset to a diff # file -# send ../cool.diff via email +# attach ../cool.diff to your bug report @end group @end example You may want to get familiar with Mercurial queues to manage your changesets. Here is a slightly more complex example using Mercurial queues, where work on two unrelated changesets is done in parallel and -one of the changesets is updated after discussion on the maintainers -mailing list: +one of the changesets is updated after discussion on the bug tracker: @example hg qnew nasty_bug # create a new patch @@ -178,7 +181,7 @@ # save again with commit message hg export -o ../nasty.diff tip # export the patch -# send ../nasty.diff via email +# attach ../nasty.diff to your bug report hg qpop # undo the application of the patch # and remove the changes from the # source tree @@ -188,14 +191,14 @@ # save the changes into the patch hg export -o ../doc.diff tip # export the second patch -# send ../doc.diff tip via email +# attach ../doc.diff to your bug report hg qpop -# discussion in the maintainers mailing list @dots{} +# discussion in the bug tracker @dots{} hg qpush nasty_bug # apply the patch again # change sources yet again @dots{} hg qref hg export -o ../nasty2.diff tip -# send ../nasty2.diff via email +# attach ../nasty2.diff to your bug report @end example @node General Guidelines
--- a/doc/interpreter/doccheck/aspell-octave.en.pws Sat Jul 28 15:17:57 2012 +0200 +++ b/doc/interpreter/doccheck/aspell-octave.en.pws Sat Jul 28 12:06:34 2012 -0400 @@ -450,6 +450,7 @@ isreal issparse isvector +iter ith iy Jacobian @@ -611,6 +612,7 @@ nd ndgrid ne +Nelder neq Neudecker Neumann
--- a/doc/interpreter/image.txi Sat Jul 28 15:17:57 2012 +0200 +++ b/doc/interpreter/image.txi Sat Jul 28 12:06:34 2012 -0400 @@ -60,7 +60,7 @@ @group I = imread ("my_input_image.img"); J = process_my_image (I); -imwrite ("my_output_image.img", J); +imwrite (J, "my_output_image.img"); @end group @end example @@ -93,15 +93,15 @@ @node Representing Images @section Representing Images -In general Octave supports four different kinds of images, gray-scale -images, RGB images, binary images, and indexed images. A gray-scale +In general Octave supports four different kinds of images, grayscale +images, RGB images, binary images, and indexed images. A grayscale image is represented with an M-by-N matrix in which each element corresponds to the intensity of a pixel. An RGB image is represented with an M-by-N-by-3 array where each 3-vector corresponds to the red, green, and blue intensities of each pixel. -The actual meaning of the value of a pixel in a gray-scale or RGB +The actual meaning of the value of a pixel in a grayscale or RGB image depends on the class of the matrix. If the matrix is of class @code{double} pixel intensities are between 0 and 1, if it is of class @code{uint8} intensities are between 0 and 255, and if it is of class @@ -187,6 +187,12 @@ @DOCSTRING(whitebg) +The following functions can be used to manipulate colormaps. + +@DOCSTRING(cmunique) + +@DOCSTRING(cmpermute) + @node Plotting on top of Images @section Plotting on top of Images
--- a/doc/interpreter/io.txi Sat Jul 28 15:17:57 2012 +0200 +++ b/doc/interpreter/io.txi Sat Jul 28 12:06:34 2012 -0400 @@ -239,7 +239,7 @@ If Octave for some reason exits unexpectedly it will by default save the variables available in the workspace to a file in the current directory. -By default this file is named @samp{octave-core} and can be loaded +By default this file is named @samp{octave-workspace} and can be loaded into memory with the @code{load} command. While the default behavior most often is reasonable it can be changed through the following functions.
--- a/doc/interpreter/nonlin.txi Sat Jul 28 15:17:57 2012 +0200 +++ b/doc/interpreter/nonlin.txi Sat Jul 28 12:06:34 2012 -0400 @@ -172,7 +172,11 @@ the zeroes where it crosses the x-axis. @code{fminbnd} is designed for the simpler, but very common, case of a univariate function where the interval to search is bounded. For unbounded minimization of a function with -potentially many variables use @code{fminunc}. @xref{Optimization}, for +potentially many variables use @code{fminunc} or @code{fminsearch}. The two +functions use different internal algorithms and some knowledge of the objective +function is required. For functions which can be differentiated, @code{fminunc} +is appropriate. For functions with discontinuities, or for which a gradient +search would fail, use @code{fminsearch}. @xref{Optimization}, for minimization with the presence of constraint functions. Note that searches can be made for maxima by simply inverting the objective function @tex @@ -186,3 +190,5 @@ @DOCSTRING(fminunc) +@DOCSTRING(fminsearch) +
--- a/liboctave/Array-util.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/Array-util.cc Sat Jul 28 12:06:34 2012 -0400 @@ -426,7 +426,7 @@ { int ial = ia.length (), rhdvl = rhdv.length (); dim_vector rdv = dim_vector::alloc (ial); - bool *scalar = new bool[ial], *colon = new bool[ial]; + bool *scalar = new bool [ial], *colon = new bool [ial]; // Mark scalars and colons, count non-scalar indices. int nonsc = 0; bool all_colons = true; @@ -445,7 +445,7 @@ if (all_colons) { rdv = rhdv; - rdv.resize(ial, 1); + rdv.resize (ial, 1); } else if (nonsc == rhdvl) { @@ -466,7 +466,7 @@ { if (scalar[i]) continue; if (colon[i]) - rdv(i) = (j < rhdv0l) ? rhdv0(j++) : 1; + rdv(i) = (j < rhdv0l) ? rhdv0(j++) : 1; } }
--- a/liboctave/Array.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/Array.cc Sat Jul 28 12:06:34 2012 -0400 @@ -649,7 +649,7 @@ int i = 0; for (; i < l-1 && ndv(i) == odv(i); i++) ld *= ndv(i); n = l - i; - cext = new octave_idx_type[3*n]; + cext = new octave_idx_type [3*n]; // Trick to avoid three allocations sext = cext + n; dext = sext + n; @@ -723,17 +723,17 @@ // FIXME -- this is for Matlab compatibility. Matlab 2007 given // - // b = ones(3,1) + // b = ones (3,1) // // yields the following: // - // b(zeros(0,0)) gives [] - // b(zeros(1,0)) gives zeros(0,1) - // b(zeros(0,1)) gives zeros(0,1) - // b(zeros(0,m)) gives zeros(0,m) - // b(zeros(m,0)) gives zeros(m,0) - // b(1:2) gives ones(2,1) - // b(ones(2)) gives ones(2) etc. + // b(zeros (0,0)) gives [] + // b(zeros (1,0)) gives zeros (0,1) + // b(zeros (0,1)) gives zeros (0,1) + // b(zeros (0,m)) gives zeros (0,m) + // b(zeros (m,0)) gives zeros (m,0) + // b(1:2) gives ones (2,1) + // b(ones (2)) gives ones (2) etc. // // As you can see, the behaviour is weird, but the tests end up pretty // simple. Nah, I don't want to suggest that this is ad hoc :) @@ -2223,13 +2223,13 @@ } // Fixup return dimensions, for Matlab compatibility. - // find(zeros(0,0)) -> zeros(0,0) - // find(zeros(1,0)) -> zeros(1,0) - // find(zeros(0,1)) -> zeros(0,1) - // find(zeros(0,X)) -> zeros(0,1) - // find(zeros(1,1)) -> zeros(0,0) !!!! WHY? - // find(zeros(0,1,0)) -> zeros(0,0) - // find(zeros(0,1,0,1)) -> zeros(0,0) etc + // find (zeros (0,0)) -> zeros (0,0) + // find (zeros (1,0)) -> zeros (1,0) + // find (zeros (0,1)) -> zeros (0,1) + // find (zeros (0,X)) -> zeros (0,1) + // find (zeros (1,1)) -> zeros (0,0) !!!! WHY? + // find (zeros (0,1,0)) -> zeros (0,0) + // find (zeros (0,1,0,1)) -> zeros (0,0) etc if ((numel () == 1 && retval.is_empty ()) || (rows () == 0 && dims ().numel (1) == 0)) @@ -2741,7 +2741,7 @@ for (octave_idx_type k = 0; k < cols; k++) { ra_idx(1) = k; - os << " " << a.elem(ra_idx); + os << " " << a.elem (ra_idx); } os << "\n"; } @@ -2753,7 +2753,7 @@ for (octave_idx_type k = 0; k < rows; k++) { ra_idx(0) = k; - os << " " << a.elem(ra_idx); + os << " " << a.elem (ra_idx); } break; } @@ -2781,7 +2781,7 @@ for (octave_idx_type k = 0; k < cols; k++) { ra_idx(1) = k; - os << " " << a.elem(ra_idx); + os << " " << a.elem (ra_idx); } os << "\n";
--- a/liboctave/Array.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/Array.h Sat Jul 28 12:06:34 2012 -0400 @@ -164,6 +164,14 @@ return &nr; } +protected: + + // For jit support + Array (T *sdata, octave_idx_type slen, octave_idx_type *adims, void *arep) + : dimensions (adims), + rep (reinterpret_cast<typename Array<T>::ArrayRep *> (arep)), + slice_data (sdata), slice_len (slen) {} + public: // Empty ctor (0x0). @@ -324,8 +332,8 @@ // No checking, even for multiple references, ever. - T& xelem (octave_idx_type n) { return slice_data [n]; } - crefT xelem (octave_idx_type n) const { return slice_data [n]; } + T& xelem (octave_idx_type n) { return slice_data[n]; } + crefT xelem (octave_idx_type n) const { return slice_data[n]; } T& xelem (octave_idx_type i, octave_idx_type j) { return xelem (dim1 ()*j+i); } crefT xelem (octave_idx_type i, octave_idx_type j) const { return xelem (dim1 ()*j+i); } @@ -693,6 +701,16 @@ // supposedly equal dimensions (e.g. structs in the interpreter). bool optimize_dimensions (const dim_vector& dv); + // WARNING: Only call these functions from jit + + int *jit_ref_count (void) { return rep->count.get (); } + + T *jit_slice_data (void) const { return slice_data; } + + octave_idx_type *jit_dimensions (void) const { return dimensions.to_jit (); } + + void *jit_array_rep (void) const { return rep; } + private: void resize2 (octave_idx_type nr, octave_idx_type nc, const T& rfv);
--- a/liboctave/CMatrix.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/CMatrix.cc Sat Jul 28 12:06:34 2012 -0400 @@ -1079,7 +1079,7 @@ F77_XFCN (zgetri, ZGETRI, (nc, tmp_data, nr, pipvt, z.fortran_vec (), lwork, info)); - lwork = static_cast<octave_idx_type> (std::real(z(0))); + lwork = static_cast<octave_idx_type> (std::real (z(0))); lwork = (lwork < 2 *nc ? 2*nc : lwork); z.resize (dim_vector (lwork, 1)); Complex *pz = z.fortran_vec (); @@ -1089,7 +1089,7 @@ // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = retval.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = retval.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (zgetrf, ZGETRF, (nc, nc, tmp_data, nr, pipvt, info)); @@ -1163,7 +1163,7 @@ } if (!mattype.is_hermitian ()) - ret = finverse(mattype, info, rcon, force, calc_cond); + ret = finverse (mattype, info, rcon, force, calc_cond); if ((mattype.is_hermitian () || calc_cond) && rcon == 0.) ret = ComplexMatrix (rows (), columns (), Complex (octave_Inf, 0.)); @@ -1832,7 +1832,7 @@ Array<octave_idx_type> ipvt (dim_vector (nr, 1)); octave_idx_type *pipvt = ipvt.fortran_vec (); - if(anorm < 0.) + if (anorm < 0.) anorm = atmp.abs ().sum (). row(static_cast<octave_idx_type>(0)).max (); @@ -2100,7 +2100,7 @@ char job = 'L'; ComplexMatrix atmp = *this; Complex *tmp_data = atmp.fortran_vec (); - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (zpotrf, ZPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr, tmp_data, nr, info @@ -2184,7 +2184,7 @@ // Calculate the norm of the matrix, for later use. if (anorm < 0.) - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (zgetrf, ZGETRF, (nr, nr, tmp_data, nr, pipvt, info)); @@ -2410,7 +2410,7 @@ ComplexMatrix tmp (b); tmp = solve (typ, tmp, info, rcon, sing_handler, true, transt); - return tmp.column(static_cast<octave_idx_type> (0)); + return tmp.column (static_cast<octave_idx_type> (0)); } ComplexMatrix
--- a/liboctave/CNDArray.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/CNDArray.cc Sat Jul 28 12:06:34 2012 -0400 @@ -240,7 +240,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (zfftf, ZFFTF) (npts, tmp, pwsave); @@ -287,7 +287,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (zfftb, ZFFTB) (npts, tmp, pwsave);
--- a/liboctave/CSparse.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/CSparse.cc Sat Jul 28 12:06:34 2012 -0400 @@ -172,7 +172,7 @@ } } for (octave_idx_type i = l; i <= a.cols (); i++) - cidx(i) = j; + cidx (i) = j; } bool SparseComplexMatrix::operator == (const SparseComplexMatrix& a) const @@ -188,11 +188,11 @@ return false; for (octave_idx_type i = 0; i < nc + 1; i++) - if (cidx(i) != a.cidx(i)) + if (cidx (i) != a.cidx (i)) return false; for (octave_idx_type i = 0; i < nz; i++) - if (data(i) != a.data(i) || ridx(i) != a.ridx(i)) + if (data (i) != a.data (i) || ridx (i) != a.ridx (i)) return false; return true; @@ -214,19 +214,19 @@ { for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - { - octave_idx_type ri = ridx(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + { + octave_idx_type ri = ridx (i); if (ri != j) { bool found = false; - for (octave_idx_type k = cidx(ri); k < cidx(ri+1); k++) + for (octave_idx_type k = cidx (ri); k < cidx (ri+1); k++) { - if (ridx(k) == j) + if (ridx (k) == j) { - if (data(i) == conj(data(k))) + if (data (i) == conj (data (k))) found = true; break; } @@ -277,9 +277,9 @@ Complex tmp_max; double abs_max = octave_NaN; octave_idx_type idx_j = 0; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - { - if (ridx(i) != idx_j) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + { + if (ridx (i) != idx_j) break; else idx_j++; @@ -291,7 +291,7 @@ abs_max = 0.; } - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { Complex tmp = data (i); @@ -332,30 +332,30 @@ { idx_arg.resize (dim_vector (nr, 1), 0); - for (octave_idx_type i = cidx(0); i < cidx(1); i++) - idx_arg.elem(ridx(i)) = -1; + for (octave_idx_type i = cidx (0); i < cidx (1); i++) + idx_arg.elem (ridx (i)) = -1; for (octave_idx_type j = 0; j < nc; j++) for (octave_idx_type i = 0; i < nr; i++) { - if (idx_arg.elem(i) != -1) + if (idx_arg.elem (i) != -1) continue; bool found = false; - for (octave_idx_type k = cidx(j); k < cidx(j+1); k++) - if (ridx(k) == i) + for (octave_idx_type k = cidx (j); k < cidx (j+1); k++) + if (ridx (k) == i) { found = true; break; } if (!found) - idx_arg.elem(i) = j; + idx_arg.elem (i) = j; } for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ir = ridx (i); octave_idx_type ix = idx_arg.elem (ir); @@ -363,14 +363,14 @@ if (xisnan (tmp)) continue; - else if (ix == -1 || std::abs(tmp) > std::abs(elem (ir, ix))) + else if (ix == -1 || std::abs (tmp) > std::abs (elem (ir, ix))) idx_arg.elem (ir) = j; } } octave_idx_type nel = 0; for (octave_idx_type j = 0; j < nr; j++) - if (idx_arg.elem(j) == -1 || elem (j, idx_arg.elem (j)) != 0.) + if (idx_arg.elem (j) == -1 || elem (j, idx_arg.elem (j)) != 0.) nel++; result = SparseComplexMatrix (nr, 1, nel); @@ -432,9 +432,9 @@ Complex tmp_min; double abs_min = octave_NaN; octave_idx_type idx_j = 0; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - { - if (ridx(i) != idx_j) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + { + if (ridx (i) != idx_j) break; else idx_j++; @@ -446,7 +446,7 @@ abs_min = 0.; } - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { Complex tmp = data (i); @@ -487,30 +487,30 @@ { idx_arg.resize (dim_vector (nr, 1), 0); - for (octave_idx_type i = cidx(0); i < cidx(1); i++) - idx_arg.elem(ridx(i)) = -1; + for (octave_idx_type i = cidx (0); i < cidx (1); i++) + idx_arg.elem (ridx (i)) = -1; for (octave_idx_type j = 0; j < nc; j++) for (octave_idx_type i = 0; i < nr; i++) { - if (idx_arg.elem(i) != -1) + if (idx_arg.elem (i) != -1) continue; bool found = false; - for (octave_idx_type k = cidx(j); k < cidx(j+1); k++) - if (ridx(k) == i) + for (octave_idx_type k = cidx (j); k < cidx (j+1); k++) + if (ridx (k) == i) { found = true; break; } if (!found) - idx_arg.elem(i) = j; + idx_arg.elem (i) = j; } for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ir = ridx (i); octave_idx_type ix = idx_arg.elem (ir); @@ -518,14 +518,14 @@ if (xisnan (tmp)) continue; - else if (ix == -1 || std::abs(tmp) < std::abs(elem (ir, ix))) + else if (ix == -1 || std::abs (tmp) < std::abs (elem (ir, ix))) idx_arg.elem (ir) = j; } } octave_idx_type nel = 0; for (octave_idx_type j = 0; j < nr; j++) - if (idx_arg.elem(j) == -1 || elem (j, idx_arg.elem (j)) != 0.) + if (idx_arg.elem (j) == -1 || elem (j, idx_arg.elem (j)) != 0.) nel++; result = SparseComplexMatrix (nr, 1, nel); @@ -663,7 +663,7 @@ // retval.xcidx[1:nr] holds row entry *start* offsets for rows 0:(nr-1) for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type k = cidx(j); k < cidx(j+1); k++) + for (octave_idx_type k = cidx (j); k < cidx (j+1); k++) { octave_idx_type q = retval.xcidx (ridx (k) + 1)++; retval.xridx (q) = j; @@ -755,7 +755,7 @@ double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nr; i++) { - double tmp = std::abs(v[i]); + double tmp = std::abs (v[i]); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -805,8 +805,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -831,9 +831,9 @@ retval.change_capacity (nz2); } - retval.xcidx(i) = cx; - retval.xridx(cx) = i; - retval.xdata(cx) = 1.0; + retval.xcidx (i) = cx; + retval.xridx (cx) = i; + retval.xdata (cx) = 1.0; cx++; // iterate accross columns of input matrix @@ -841,11 +841,11 @@ { Complex v = 0.; // iterate to calculate sum - octave_idx_type colXp = retval.xcidx(i); - octave_idx_type colUp = cidx(j); + octave_idx_type colXp = retval.xcidx (i); + octave_idx_type colUp = cidx (j); octave_idx_type rpX, rpU; - if (cidx(j) == cidx(j+1)) + if (cidx (j) == cidx (j+1)) { (*current_liboctave_error_handler) ("division by zero"); @@ -855,8 +855,8 @@ do { octave_quit (); - rpX = retval.xridx(colXp); - rpU = ridx(colUp); + rpX = retval.xridx (colXp); + rpU = ridx (colUp); if (rpX < rpU) colXp++; @@ -864,7 +864,7 @@ colUp++; else { - v -= retval.xdata(colXp) * data(colUp); + v -= retval.xdata (colXp) * data (colUp); colXp++; colUp++; } @@ -874,11 +874,11 @@ // get A(m,m) if (typ == MatrixType::Upper) - colUp = cidx(j+1) - 1; + colUp = cidx (j+1) - 1; else - colUp = cidx(j); - Complex pivot = data(colUp); - if (pivot == 0. || ridx(colUp) != j) + colUp = cidx (j); + Complex pivot = data (colUp); + if (pivot == 0. || ridx (colUp) != j) { (*current_liboctave_error_handler) ("division by zero"); @@ -893,8 +893,8 @@ retval.change_capacity (nz2); } - retval.xridx(cx) = j; - retval.xdata(cx) = v / pivot; + retval.xridx (cx) = j; + retval.xdata (cx) = v / pivot; cx++; } } @@ -902,11 +902,11 @@ // get A(m,m) octave_idx_type colUp; if (typ == MatrixType::Upper) - colUp = cidx(i+1) - 1; + colUp = cidx (i+1) - 1; else - colUp = cidx(i); - Complex pivot = data(colUp); - if (pivot == 0. || ridx(colUp) != i) + colUp = cidx (i); + Complex pivot = data (colUp); + if (pivot == 0. || ridx (colUp) != i) { (*current_liboctave_error_handler) ("division by zero"); goto inverse_singular; @@ -914,9 +914,9 @@ if (pivot != 1.0) for (octave_idx_type j = cx_colstart; j < cx; j++) - retval.xdata(j) /= pivot; - } - retval.xcidx(nr) = cx; + retval.xdata (j) /= pivot; + } + retval.xcidx (nr) = cx; retval.maybe_compress (); } else @@ -960,19 +960,19 @@ Complex v = 0.; octave_idx_type jidx = perm[j]; // iterate to calculate sum - for (octave_idx_type k = cidx(jidx); - k < cidx(jidx+1); k++) + for (octave_idx_type k = cidx (jidx); + k < cidx (jidx+1); k++) { octave_quit (); - v -= work[ridx(k)] * data(k); + v -= work[ridx (k)] * data (k); } // get A(m,m) Complex pivot; if (typ == MatrixType::Permuted_Upper) - pivot = data(cidx(jidx+1) - 1); + pivot = data (cidx (jidx+1) - 1); else - pivot = data(cidx(jidx)); + pivot = data (cidx (jidx)); if (pivot == 0.) { (*current_liboctave_error_handler) @@ -986,11 +986,11 @@ // get A(m,m) octave_idx_type colUp; if (typ == MatrixType::Permuted_Upper) - colUp = cidx(perm[iidx]+1) - 1; + colUp = cidx (perm[iidx]+1) - 1; else - colUp = cidx(perm[iidx]); - - Complex pivot = data(colUp); + colUp = cidx (perm[iidx]); + + Complex pivot = data (colUp); if (pivot == 0.) { (*current_liboctave_error_handler) @@ -1013,16 +1013,16 @@ retval.change_capacity (nz2); } - retval.xcidx(i) = cx; + retval.xcidx (i) = cx; for (octave_idx_type j = iidx; j < nr; j++) if (work[j] != 0.) { - retval.xridx(cx) = j; - retval.xdata(cx++) = work[j]; + retval.xridx (cx) = j; + retval.xdata (cx++) = work[j]; } } - retval.xcidx(nr) = cx; + retval.xcidx (nr) = cx; retval.maybe_compress (); } @@ -1032,9 +1032,9 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = retval.cidx(j); - i < retval.cidx(j+1); i++) - atmp += std::abs(retval.data(i)); + for (octave_idx_type i = retval.cidx (j); + i < retval.cidx (j+1); i++) + atmp += std::abs (retval.data (i)); if (atmp > ainvnorm) ainvnorm = atmp; } @@ -1083,7 +1083,7 @@ double rcond2; SparseMatrix Q = fact.Q (); SparseComplexMatrix InvL = fact.L ().transpose (). - tinverse(tmp_typ, info, rcond2, true, false); + tinverse (tmp_typ, info, rcond2, true, false); ret = Q * InvL.hermitian () * InvL * Q.transpose (); } else @@ -1106,9 +1106,9 @@ rcond = fact.rcond (); double rcond2; SparseComplexMatrix InvL = fact.L ().transpose (). - tinverse(tmp_typ, info, rcond2, true, false); + tinverse (tmp_typ, info, rcond2, true, false); SparseComplexMatrix InvU = fact.U (). - tinverse(tmp_typ, info, rcond2, true, false).transpose (); + tinverse (tmp_typ, info, rcond2, true, false).transpose (); ret = fact.Pc ().transpose () * InvU * InvL * fact.Pr (); } } @@ -1279,7 +1279,7 @@ if (typ == MatrixType::Diagonal || typ == MatrixType::Permuted_Diagonal) { - retval.resize (nc, b.cols (), Complex(0.,0.)); + retval.resize (nc, b.cols (), Complex (0.,0.)); if (typ == MatrixType::Diagonal) for (octave_idx_type j = 0; j < b.cols (); j++) for (octave_idx_type i = 0; i < nm; i++) @@ -1287,15 +1287,15 @@ else for (octave_idx_type j = 0; j < b.cols (); j++) for (octave_idx_type k = 0; k < nc; k++) - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - retval(k,j) = b(ridx(i),j) / data (i); + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + retval(k,j) = b(ridx (i),j) / data (i); if (calc_cond) { double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nm; i++) { - double tmp = std::abs(data(i)); + double tmp = std::abs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1344,30 +1344,30 @@ octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; if (typ == MatrixType::Diagonal) for (octave_idx_type j = 0; j < b.cols (); j++) { - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) { - if (b.ridx(i) >= nm) + if (b.ridx (i) >= nm) break; - retval.xridx (ii) = b.ridx(i); - retval.xdata (ii++) = b.data(i) / data (b.ridx (i)); + retval.xridx (ii) = b.ridx (i); + retval.xdata (ii++) = b.data (i) / data (b.ridx (i)); } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } else for (octave_idx_type j = 0; j < b.cols (); j++) { for (octave_idx_type l = 0; l < nc; l++) - for (octave_idx_type i = cidx(l); i < cidx(l+1); i++) + for (octave_idx_type i = cidx (l); i < cidx (l+1); i++) { bool found = false; octave_idx_type k; - for (k = b.cidx(j); k < b.cidx(j+1); k++) - if (ridx(i) == b.ridx(k)) + for (k = b.cidx (j); k < b.cidx (j+1); k++) + if (ridx (i) == b.ridx (k)) { found = true; break; @@ -1375,10 +1375,10 @@ if (found) { retval.xridx (ii) = l; - retval.xdata (ii++) = b.data(k) / data (i); + retval.xdata (ii++) = b.data (k) / data (i); } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } if (calc_cond) @@ -1386,7 +1386,7 @@ double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nm; i++) { - double tmp = std::abs(data(i)); + double tmp = std::abs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1431,7 +1431,7 @@ if (typ == MatrixType::Diagonal || typ == MatrixType::Permuted_Diagonal) { - retval.resize (nc, b.cols (), Complex(0.,0.)); + retval.resize (nc, b.cols (), Complex (0.,0.)); if (typ == MatrixType::Diagonal) for (octave_idx_type j = 0; j < b.cols (); j++) for (octave_idx_type i = 0; i < nm; i++) @@ -1439,15 +1439,15 @@ else for (octave_idx_type j = 0; j < b.cols (); j++) for (octave_idx_type k = 0; k < nc; k++) - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - retval(k,j) = b(ridx(i),j) / data (i); + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + retval(k,j) = b(ridx (i),j) / data (i); if (calc_cond) { double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nr; i++) { - double tmp = std::abs(data(i)); + double tmp = std::abs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1496,30 +1496,30 @@ octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; if (typ == MatrixType::Diagonal) for (octave_idx_type j = 0; j < b.cols (); j++) { - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) { - if (b.ridx(i) >= nm) + if (b.ridx (i) >= nm) break; - retval.xridx (ii) = b.ridx(i); - retval.xdata (ii++) = b.data(i) / data (b.ridx (i)); + retval.xridx (ii) = b.ridx (i); + retval.xdata (ii++) = b.data (i) / data (b.ridx (i)); } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } else for (octave_idx_type j = 0; j < b.cols (); j++) { for (octave_idx_type l = 0; l < nc; l++) - for (octave_idx_type i = cidx(l); i < cidx(l+1); i++) + for (octave_idx_type i = cidx (l); i < cidx (l+1); i++) { bool found = false; octave_idx_type k; - for (k = b.cidx(j); k < b.cidx(j+1); k++) - if (ridx(i) == b.ridx(k)) + for (k = b.cidx (j); k < b.cidx (j+1); k++) + if (ridx (i) == b.ridx (k)) { found = true; break; @@ -1527,10 +1527,10 @@ if (found) { retval.xridx (ii) = l; - retval.xdata (ii++) = b.data(k) / data (i); + retval.xdata (ii++) = b.data (k) / data (i); } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } if (calc_cond) @@ -1538,7 +1538,7 @@ double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nm; i++) { - double tmp = std::abs(data(i)); + double tmp = std::abs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1594,8 +1594,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -1620,20 +1620,20 @@ if (work[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(kidx+1)-1); + Complex tmp = work[k] / data (cidx (kidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -1658,20 +1658,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(iidx+1)-1); + Complex tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -1696,19 +1696,19 @@ { if (work[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -1731,20 +1731,20 @@ { if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -1829,8 +1829,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -1839,7 +1839,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -1856,8 +1856,8 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = nc-1; k >= 0; k--) { @@ -1865,20 +1865,20 @@ if (work[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(kidx+1)-1); + Complex tmp = work[k] / data (cidx (kidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -1901,10 +1901,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[rperm[i]] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[rperm[i]]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[rperm[i]]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -1925,20 +1925,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(iidx+1)-1); + Complex tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -1955,26 +1955,26 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = nc-1; k >= 0; k--) { if (work[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -1997,10 +1997,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2019,20 +2019,20 @@ { if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2117,8 +2117,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2143,20 +2143,20 @@ if (work[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(kidx+1)-1); + Complex tmp = work[k] / data (cidx (kidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2181,20 +2181,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(iidx+1)-1); + Complex tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2219,19 +2219,19 @@ { if (work[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2254,20 +2254,20 @@ { if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2352,8 +2352,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2362,7 +2362,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -2379,8 +2379,8 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = nc-1; k >= 0; k--) { @@ -2388,20 +2388,20 @@ if (work[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(kidx+1)-1); + Complex tmp = work[k] / data (cidx (kidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2424,10 +2424,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[rperm[i]] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[rperm[i]]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[rperm[i]]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2448,20 +2448,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(iidx+1)-1); + Complex tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2478,26 +2478,26 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = nr-1; k >= 0; k--) { if (work[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2520,10 +2520,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2542,20 +2542,20 @@ { if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k+1)-1); + Complex tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2641,8 +2641,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2668,10 +2668,10 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } @@ -2681,15 +2681,15 @@ goto triangular_error; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2715,24 +2715,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2740,7 +2740,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2764,19 +2764,19 @@ { if (work[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2799,20 +2799,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2897,8 +2897,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2907,7 +2907,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -2920,8 +2920,8 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[perm[b.ridx(i)]] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[perm[b.ridx (i)]] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { @@ -2930,10 +2930,10 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } @@ -2943,15 +2943,15 @@ goto triangular_error; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2974,10 +2974,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2999,24 +2999,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3024,7 +3024,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3041,26 +3041,26 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { if (work[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3083,10 +3083,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -3106,20 +3106,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3205,8 +3205,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -3232,10 +3232,10 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } @@ -3245,15 +3245,15 @@ goto triangular_error; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3279,24 +3279,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3304,7 +3304,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3330,19 +3330,19 @@ { if (work[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3366,20 +3366,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3464,8 +3464,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -3474,7 +3474,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -3487,8 +3487,8 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[perm[b.ridx(i)]] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[perm[b.ridx (i)]] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { @@ -3497,10 +3497,10 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } @@ -3510,15 +3510,15 @@ goto triangular_error; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3541,10 +3541,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -3566,24 +3566,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - Complex tmp = work[k] / data(mini); + Complex tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3591,7 +3591,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3608,26 +3608,26 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { if (work[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3650,10 +3650,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -3673,20 +3673,20 @@ if (work[k] != 0.) { - Complex tmp = work[k] / data(cidx(k)); + Complex tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += std::abs(work[i]); + atmp += std::abs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3771,11 +3771,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = std::real(data(ii++)); - DL[j] = data(ii); + D[j] = std::real (data (ii++)); + DL[j] = data (ii); ii += 2; } - D[nc-1] = std::real(data(ii)); + D[nc-1] = std::real (data (ii)); } else { @@ -3787,12 +3787,12 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = std::real(data(i)); - else if (ridx(i) == j + 1) - DL[j] = data(i); + if (ridx (i) == j) + D[j] = std::real (data (i)); + else if (ridx (i) == j + 1) + DL[j] = data (i); } } @@ -3825,11 +3825,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -3842,14 +3842,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -3928,11 +3928,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -3945,14 +3945,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -3979,7 +3979,7 @@ volatile octave_idx_type x_nz = b.nnz (); octave_idx_type b_nc = b.cols (); retval = SparseComplexMatrix (nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; volatile octave_idx_type ii = 0; rcond = 1.0; @@ -3989,8 +3989,8 @@ { for (octave_idx_type i = 0; i < nr; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); F77_XFCN (zgttrs, ZGTTRS, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -4016,10 +4016,10 @@ for (octave_idx_type i = 0; i < nr; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -4069,11 +4069,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = std::real(data(ii++)); - DL[j] = data(ii); + D[j] = std::real (data (ii++)); + DL[j] = data (ii); ii += 2; } - D[nc-1] = std::real(data(ii)); + D[nc-1] = std::real (data (ii)); } else { @@ -4085,12 +4085,12 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = std::real (data(i)); - else if (ridx(i) == j + 1) - DL[j] = data(i); + if (ridx (i) == j) + D[j] = std::real (data (i)); + else if (ridx (i) == j + 1) + DL[j] = data (i); } } @@ -4124,11 +4124,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -4141,14 +4141,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -4228,11 +4228,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -4245,14 +4245,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -4286,7 +4286,7 @@ volatile octave_idx_type ii = 0; retval = SparseComplexMatrix (b_nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (volatile octave_idx_type j = 0; j < b_nc; j++) { @@ -4326,11 +4326,11 @@ for (octave_idx_type i = 0; i < nr; i++) if (Bx[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = Bx[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = Bx[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -4383,17 +4383,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (zpbtrf, ZPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -4490,8 +4490,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -4500,8 +4500,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -4632,17 +4632,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (zpbtrf, ZPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -4706,7 +4706,7 @@ volatile octave_idx_type ii = 0; retval = SparseComplexMatrix (b_nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (volatile octave_idx_type j = 0; j < b_nc; j++) { for (octave_idx_type i = 0; i < b_nr; i++) @@ -4740,11 +4740,11 @@ retval.change_capacity (sz); x_nz = sz; } - retval.xdata(ii) = tmp; - retval.xridx(ii++) = i; + retval.xdata (ii) = tmp; + retval.xridx (ii++) = i; } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -4772,8 +4772,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -4782,8 +4782,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -4855,7 +4855,7 @@ volatile octave_idx_type x_nz = b.nnz (); octave_idx_type b_nc = b.cols (); retval = SparseComplexMatrix (nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; volatile octave_idx_type ii = 0; OCTAVE_LOCAL_BUFFER (Complex, work, nr); @@ -4864,9 +4864,9 @@ { for (octave_idx_type i = 0; i < nr; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); - i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); + i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); F77_XFCN (zgbtrs, ZGBTRS, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -4892,10 +4892,10 @@ for (octave_idx_type i = 0; i < nr; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -4950,17 +4950,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (zpbtrf, ZPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -5057,8 +5057,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -5067,8 +5067,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -5196,17 +5196,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (zpbtrf, ZPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -5273,7 +5273,7 @@ volatile octave_idx_type ii = 0; retval = SparseComplexMatrix (b_nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (volatile octave_idx_type j = 0; j < b_nc; j++) { @@ -5312,11 +5312,11 @@ for (octave_idx_type i = 0; i < nr; i++) if (Bx[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = Bx[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = Bx[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -5344,8 +5344,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -5354,8 +5354,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += std::abs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += std::abs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -5427,7 +5427,7 @@ volatile octave_idx_type x_nz = b.nnz (); octave_idx_type b_nc = b.cols (); retval = SparseComplexMatrix (nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; volatile octave_idx_type ii = 0; OCTAVE_LOCAL_BUFFER (Complex, Bx, nr); @@ -5437,9 +5437,9 @@ for (octave_idx_type i = 0; i < nr; i++) Bx[i] = 0.; - for (octave_idx_type i = b.cidx(j); - i < b.cidx(j+1); i++) - Bx[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); + i < b.cidx (j+1); i++) + Bx[b.ridx (i)] = b.data (i); F77_XFCN (zgbtrs, ZGBTRS, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -5465,10 +5465,10 @@ for (octave_idx_type i = 0; i < nr; i++) if (Bx[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = Bx[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = Bx[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -5736,7 +5736,7 @@ { octave_idx_type jr = j * b.rows (); for (octave_idx_type i = 0; i < b.rows (); i++) - retval.xelem(i,j) = static_cast<Complex *>(X->x)[jr + i]; + retval.xelem (i,j) = static_cast<Complex *>(X->x)[jr + i]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -5990,12 +5990,12 @@ static_cast<octave_idx_type>(X->nzmax)); for (octave_idx_type j = 0; j <= static_cast<octave_idx_type>(X->ncol); j++) - retval.xcidx(j) = static_cast<octave_idx_type *>(X->p)[j]; + retval.xcidx (j) = static_cast<octave_idx_type *>(X->p)[j]; for (octave_idx_type j = 0; j < static_cast<octave_idx_type>(X->nzmax); j++) { - retval.xridx(j) = static_cast<octave_idx_type *>(X->i)[j]; - retval.xdata(j) = static_cast<Complex *>(X->x)[j]; + retval.xridx (j) = static_cast<octave_idx_type *>(X->i)[j]; + retval.xdata (j) = static_cast<Complex *>(X->x)[j]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -6050,7 +6050,7 @@ OCTAVE_LOCAL_BUFFER (Complex, Xx, b_nr); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (octave_idx_type j = 0; j < b_nc; j++) { @@ -6105,11 +6105,11 @@ retval.change_capacity (sz); x_nz = sz; } - retval.xdata(ii) = tmp; - retval.xridx(ii++) = i; + retval.xdata (ii) = tmp; + retval.xridx (ii++) = i; } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -6270,7 +6270,7 @@ { octave_idx_type jr = j * b.rows (); for (octave_idx_type i = 0; i < b.rows (); i++) - retval.xelem(i,j) = static_cast<Complex *>(X->x)[jr + i]; + retval.xelem (i,j) = static_cast<Complex *>(X->x)[jr + i]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -6503,12 +6503,12 @@ static_cast<octave_idx_type>(X->nzmax)); for (octave_idx_type j = 0; j <= static_cast<octave_idx_type>(X->ncol); j++) - retval.xcidx(j) = static_cast<octave_idx_type *>(X->p)[j]; + retval.xcidx (j) = static_cast<octave_idx_type *>(X->p)[j]; for (octave_idx_type j = 0; j < static_cast<octave_idx_type>(X->nzmax); j++) { - retval.xridx(j) = static_cast<octave_idx_type *>(X->i)[j]; - retval.xdata(j) = static_cast<Complex *>(X->x)[j]; + retval.xridx (j) = static_cast<octave_idx_type *>(X->i)[j]; + retval.xdata (j) = static_cast<Complex *>(X->x)[j]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -6556,7 +6556,7 @@ OCTAVE_LOCAL_BUFFER (Complex, Xx, b_nr); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (octave_idx_type j = 0; j < b_nc; j++) { for (octave_idx_type i = 0; i < b_nr; i++) @@ -6596,11 +6596,11 @@ retval.change_capacity (sz); x_nz = sz; } - retval.xdata(ii) = tmp; - retval.xridx(ii++) = i; + retval.xdata (ii) = tmp; + retval.xridx (ii++) = i; } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -6694,7 +6694,7 @@ return ComplexMatrix (); } - if (singular_fallback && mattype.type(false) == MatrixType::Rectangular) + if (singular_fallback && mattype.type (false) == MatrixType::Rectangular) { rcond = 1.; #ifdef USE_QRSOLVE @@ -6762,7 +6762,7 @@ return SparseComplexMatrix (); } - if (singular_fallback && mattype.type(false) == MatrixType::Rectangular) + if (singular_fallback && mattype.type (false) == MatrixType::Rectangular) { rcond = 1.; #ifdef USE_QRSOLVE @@ -6830,7 +6830,7 @@ return ComplexMatrix (); } - if (singular_fallback && mattype.type(false) == MatrixType::Rectangular) + if (singular_fallback && mattype.type (false) == MatrixType::Rectangular) { rcond = 1.; #ifdef USE_QRSOLVE @@ -6899,7 +6899,7 @@ return SparseComplexMatrix (); } - if (singular_fallback && mattype.type(false) == MatrixType::Rectangular) + if (singular_fallback && mattype.type (false) == MatrixType::Rectangular) { rcond = 1.; #ifdef USE_QRSOLVE @@ -7177,12 +7177,12 @@ { for (octave_idx_type j = 0; j < nr; j++) { - if (jj < cidx(i+1) && ridx(jj) == j) + if (jj < cidx (i+1) && ridx (jj) == j) jj++; else { - r.data(ii) = true; - r.ridx(ii++) = j; + r.data (ii) = true; + r.ridx (ii++) = j; } } r.cidx (i+1) = ii; @@ -7267,8 +7267,8 @@ if (nel == 0) return false; - max_val = std::real(data (0)); - min_val = std::real(data (0)); + max_val = std::real (data (0)); + min_val = std::real (data (0)); for (octave_idx_type i = 0; i < nel; i++) { @@ -7353,7 +7353,7 @@ else { SPARSE_REDUCTION_OP (SparseComplexMatrix, Complex, *=, - (cidx(j+1) - cidx(j) < nr ? 0.0 : 1.0), 1.0); + (cidx (j+1) - cidx (j) < nr ? 0.0 : 1.0), 1.0); } } @@ -7368,11 +7368,11 @@ { #define ROW_EXPR \ Complex d = data (i); \ - tmp [ridx(i)] += d * conj (d) + tmp[ridx (i)] += d * conj (d) #define COL_EXPR \ Complex d = data (i); \ - tmp [j] += d * conj (d) + tmp[j] += d * conj (d) SPARSE_BASE_REDUCTION_OP (SparseComplexMatrix, Complex, ROW_EXPR, COL_EXPR, 0.0, 0.0); @@ -7416,10 +7416,10 @@ for (octave_idx_type j = 0; j < nc; j++) { octave_quit (); - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) { - os << a.ridx(i) + 1 << " " << j + 1 << " "; - octave_write_complex (os, a.data(i)); + os << a.ridx (i) + 1 << " " << j + 1 << " "; + octave_write_complex (os, a.data (i)); os << "\n"; } } @@ -7640,15 +7640,15 @@ EMPTY_RETURN_CHECK (SparseComplexMatrix); - if (abs(c) == 0.) + if (abs (c) == 0.) return SparseComplexMatrix (nr, nc); else { result = SparseComplexMatrix (m); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) - result.data(i) = xmin(c, m.data(i)); + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) + result.data (i) = xmin (c, m.data (i)); } return result; @@ -7686,38 +7686,38 @@ r.cidx (0) = 0; for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { - Complex tmp = xmin (a.data(ja), 0.); + Complex tmp = xmin (a.data (ja), 0.); if (tmp != 0.) { - r.ridx(jx) = a.ridx(ja); - r.data(jx) = tmp; + r.ridx (jx) = a.ridx (ja); + r.data (jx) = tmp; jx++; } ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { - Complex tmp = xmin (0., b.data(jb)); + Complex tmp = xmin (0., b.data (jb)); if (tmp != 0.) { - r.ridx(jx) = b.ridx(jb); - r.data(jx) = tmp; + r.ridx (jx) = b.ridx (jb); + r.data (jx) = tmp; jx++; } jb++; @@ -7725,11 +7725,11 @@ } else { - Complex tmp = xmin (a.data(ja), b.data(jb)); + Complex tmp = xmin (a.data (ja), b.data (jb)); if (tmp != 0.) { - r.data(jx) = tmp; - r.ridx(jx) = a.ridx(ja); + r.data (jx) = tmp; + r.ridx (jx) = a.ridx (ja); jx++; } ja++; @@ -7738,7 +7738,7 @@ jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } r.maybe_compress (); @@ -7761,12 +7761,12 @@ EMPTY_RETURN_CHECK (SparseComplexMatrix); // Count the number of non-zero elements - if (xmax(c, 0.) != 0.) + if (xmax (c, 0.) != 0.) { result = SparseComplexMatrix (nr, nc, c); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) - result.xdata(m.ridx(i) + j * nr) = xmax (c, m.data(i)); + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) + result.xdata (m.ridx (i) + j * nr) = xmax (c, m.data (i)); } else result = SparseComplexMatrix (m); @@ -7810,38 +7810,38 @@ r.cidx (0) = 0; for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { - Complex tmp = xmax (a.data(ja), 0.); + Complex tmp = xmax (a.data (ja), 0.); if (tmp != 0.) { - r.ridx(jx) = a.ridx(ja); - r.data(jx) = tmp; + r.ridx (jx) = a.ridx (ja); + r.data (jx) = tmp; jx++; } ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { - Complex tmp = xmax (0., b.data(jb)); + Complex tmp = xmax (0., b.data (jb)); if (tmp != 0.) { - r.ridx(jx) = b.ridx(jb); - r.data(jx) = tmp; + r.ridx (jx) = b.ridx (jb); + r.data (jx) = tmp; jx++; } jb++; @@ -7849,11 +7849,11 @@ } else { - Complex tmp = xmax (a.data(ja), b.data(jb)); + Complex tmp = xmax (a.data (ja), b.data (jb)); if (tmp != 0.) { - r.data(jx) = tmp; - r.ridx(jx) = a.ridx(ja); + r.data (jx) = tmp; + r.ridx (jx) = a.ridx (ja); jx++; } ja++; @@ -7862,7 +7862,7 @@ jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } r.maybe_compress ();
--- a/liboctave/CmplxQR.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/CmplxQR.cc Sat Jul 28 12:06:34 2012 -0400 @@ -469,7 +469,7 @@ if (u.length () == m && v.length () == n) { - init(q*r + ComplexMatrix (u) * ComplexMatrix (v).hermitian (), get_type ()); + init (q*r + ComplexMatrix (u) * ComplexMatrix (v).hermitian (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch"); @@ -485,7 +485,7 @@ if (u.rows () == m && v.rows () == n && u.cols () == v.cols ()) { - init(q*r + u * v.hermitian (), get_type ()); + init (q*r + u * v.hermitian (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch");
--- a/liboctave/CollocWt.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/CollocWt.cc Sat Jul 28 12:06:34 2012 -0400 @@ -212,7 +212,7 @@ xn1 = xp1; } - double zc = 1.0; + double zc = 1.0; double z = xn / xn1; if (i != 0)
--- a/liboctave/DASPK.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/DASPK.cc Sat Jul 28 12:06:34 2012 -0400 @@ -83,8 +83,8 @@ for (octave_idx_type i = 0; i < nn; i++) { - tmp_deriv.elem (i) = deriv [i]; - tmp_state.elem (i) = state [i]; + tmp_deriv.elem (i) = deriv[i]; + tmp_state.elem (i) = state[i]; } tmp_delta = user_fun (tmp_state, tmp_deriv, time, ires); @@ -96,7 +96,7 @@ else { for (octave_idx_type i = 0; i < nn; i++) - delta [i] = tmp_delta.elem (i); + delta[i] = tmp_delta.elem (i); } } @@ -137,15 +137,15 @@ for (octave_idx_type i = 0; i < nn; i++) { - tmp_deriv.elem (i) = deriv [i]; - tmp_state.elem (i) = state [i]; + tmp_deriv.elem (i) = deriv[i]; + tmp_state.elem (i) = state[i]; } Matrix tmp_pd = user_jac (tmp_state, tmp_deriv, time, cj); for (octave_idx_type j = 0; j < nn; j++) for (octave_idx_type i = 0; i < nn; i++) - pd [nn * j + i] = tmp_pd.elem (i, j); + pd[nn * j + i] = tmp_pd.elem (i, j); END_INTERRUPT_WITH_EXCEPTIONS;
--- a/liboctave/DASRT.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/DASRT.cc Sat Jul 28 12:06:34 2012 -0400 @@ -113,15 +113,15 @@ for (octave_idx_type i = 0; i < nn; i++) { - tmp_deriv.elem (i) = deriv [i]; - tmp_state.elem (i) = state [i]; + tmp_deriv.elem (i) = deriv[i]; + tmp_state.elem (i) = state[i]; } Matrix tmp_pd = (*user_jsub) (tmp_state, tmp_deriv, time, cj); for (octave_idx_type j = 0; j < nn; j++) for (octave_idx_type i = 0; i < nn; i++) - pd [nn * j + i] = tmp_pd.elem (i, j); + pd[nn * j + i] = tmp_pd.elem (i, j); END_INTERRUPT_WITH_EXCEPTIONS;
--- a/liboctave/DASSL.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/DASSL.cc Sat Jul 28 12:06:34 2012 -0400 @@ -76,8 +76,8 @@ for (octave_idx_type i = 0; i < nn; i++) { - tmp_deriv.elem (i) = deriv [i]; - tmp_state.elem (i) = state [i]; + tmp_deriv.elem (i) = deriv[i]; + tmp_state.elem (i) = state[i]; } tmp_delta = user_fun (tmp_state, tmp_deriv, time, ires); @@ -89,7 +89,7 @@ else { for (octave_idx_type i = 0; i < nn; i++) - delta [i] = tmp_delta.elem (i); + delta[i] = tmp_delta.elem (i); } } @@ -111,15 +111,15 @@ for (octave_idx_type i = 0; i < nn; i++) { - tmp_deriv.elem (i) = deriv [i]; - tmp_state.elem (i) = state [i]; + tmp_deriv.elem (i) = deriv[i]; + tmp_state.elem (i) = state[i]; } Matrix tmp_pd = user_jac (tmp_state, tmp_deriv, time, cj); for (octave_idx_type j = 0; j < nn; j++) for (octave_idx_type i = 0; i < nn; i++) - pd [nn * j + i] = tmp_pd.elem (i, j); + pd[nn * j + i] = tmp_pd.elem (i, j); END_INTERRUPT_WITH_EXCEPTIONS;
--- a/liboctave/EIG.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/EIG.cc Sat Jul 28 12:06:34 2012 -0400 @@ -230,8 +230,8 @@ return -1; } - lambda.elem(j) = Complex (wr.elem(j), wi.elem(j)); - lambda.elem(j+1) = Complex (wr.elem(j+1), wi.elem(j+1)); + lambda.elem (j) = Complex (wr.elem (j), wi.elem (j)); + lambda.elem (j+1) = Complex (wr.elem (j+1), wi.elem (j+1)); for (octave_idx_type i = 0; i < nvr; i++) { @@ -581,10 +581,10 @@ return -1; } - lambda.elem(j) = Complex (ar.elem(j) / beta.elem (j), - ai.elem(j) / beta.elem (j)); - lambda.elem(j+1) = Complex (ar.elem(j+1) / beta.elem (j+1), - ai.elem(j+1) / beta.elem (j+1)); + lambda.elem (j) = Complex (ar.elem (j) / beta.elem (j), + ai.elem (j) / beta.elem (j)); + lambda.elem (j+1) = Complex (ar.elem (j+1) / beta.elem (j+1), + ai.elem (j+1) / beta.elem (j+1)); for (octave_idx_type i = 0; i < nvr; i++) { @@ -780,7 +780,7 @@ lambda.resize (n); for (octave_idx_type j = 0; j < n; j++) - lambda.elem (j) = alpha.elem (j) / beta.elem(j); + lambda.elem (j) = alpha.elem (j) / beta.elem (j); v = vtmp; }
--- a/liboctave/LSODE.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/LSODE.cc Sat Jul 28 12:06:34 2012 -0400 @@ -79,7 +79,7 @@ else { for (octave_idx_type i = 0; i < neq; i++) - deriv [i] = tmp_deriv.elem (i); + deriv[i] = tmp_deriv.elem (i); } END_INTERRUPT_WITH_EXCEPTIONS; @@ -103,7 +103,7 @@ for (octave_idx_type j = 0; j < neq; j++) for (octave_idx_type i = 0; i < neq; i++) - pd [nrowpd * j + i] = tmp_jac (i, j); + pd[nrowpd * j + i] = tmp_jac (i, j); END_INTERRUPT_WITH_EXCEPTIONS;
--- a/liboctave/MArray.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/MArray.h Sat Jul 28 12:06:34 2012 -0400 @@ -39,6 +39,12 @@ class MArray : public Array<T> { +protected: + + // For jit support + MArray (T *sdata, octave_idx_type slen, octave_idx_type *adims, void *arep) + : Array<T> (sdata, slen, adims, arep) { } + public: MArray (void) : Array<T> () {}
--- a/liboctave/MSparse.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/MSparse.cc Sat Jul 28 12:06:34 2012 -0400 @@ -60,41 +60,41 @@ octave_idx_type jx = 0; for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { - r.ridx(jx) = a.ridx(ja); - r.data(jx) = op (a.data(ja), 0.); + r.ridx (jx) = a.ridx (ja); + r.data (jx) = op (a.data (ja), 0.); jx++; ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { - r.ridx(jx) = b.ridx(jb); - r.data(jx) = op (0., b.data(jb)); + r.ridx (jx) = b.ridx (jb); + r.data (jx) = op (0., b.data (jb)); jx++; jb++; jb_lt_max= jb < jb_max; } else { - if (op (a.data(ja), b.data(jb)) != 0.) + if (op (a.data (ja), b.data (jb)) != 0.) { - r.data(jx) = op (a.data(ja), b.data(jb)); - r.ridx(jx) = a.ridx(ja); + r.data (jx) = op (a.data (ja), b.data (jb)); + r.ridx (jx) = a.ridx (ja); jx++; } ja++; @@ -103,7 +103,7 @@ jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } a = r.maybe_compress (); @@ -139,7 +139,7 @@ MArray<T> r (dim_vector (nr, nc), op (0.0, s)); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) r.elem (a.ridx (i), j) = op (a.data (i), s); return r; } @@ -171,11 +171,11 @@ for (octave_idx_type i = 0; i < nz; i++) { - r.data(i) = op (a.data(i), s); - r.ridx(i) = a.ridx(i); + r.data (i) = op (a.data (i), s); + r.ridx (i) = a.ridx (i); } for (octave_idx_type i = 0; i < nc + 1; i++) - r.cidx(i) = a.cidx(i); + r.cidx (i) = a.cidx (i); r.maybe_compress (true); return r; } @@ -207,7 +207,7 @@ MArray<T> r (dim_vector (nr, nc), op (s, 0.0)); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) r.elem (a.ridx (i), j) = op (s, a.data (i)); return r; } @@ -238,11 +238,11 @@ for (octave_idx_type i = 0; i < nz; i++) { - r.data(i) = op (s, a.data(i)); - r.ridx(i) = a.ridx(i); + r.data (i) = op (s, a.data (i)); + r.ridx (i) = a.ridx (i); } for (octave_idx_type i = 0; i < nc + 1; i++) - r.cidx(i) = a.cidx(i); + r.cidx (i) = a.cidx (i); r.maybe_compress (true); return r; } @@ -279,23 +279,23 @@ if (a_nr == 1 && a_nc == 1) { - if (a.elem(0,0) == 0.) + if (a.elem (0,0) == 0.) if (negate) r = -MSparse<T> (b); else r = MSparse<T> (b); else { - r = MSparse<T> (b_nr, b_nc, op (a.data(0), 0.)); + r = MSparse<T> (b_nr, b_nc, op (a.data (0), 0.)); for (octave_idx_type j = 0 ; j < b_nc ; j++) { octave_quit (); octave_idx_type idxj = j * b_nr; - for (octave_idx_type i = b.cidx(j) ; i < b.cidx(j+1) ; i++) + for (octave_idx_type i = b.cidx (j) ; i < b.cidx (j+1) ; i++) { octave_quit (); - r.data(idxj + b.ridx(i)) = op (a.data(0), b.data(i)); + r.data (idxj + b.ridx (i)) = op (a.data (0), b.data (i)); } } r.maybe_compress (); @@ -303,20 +303,20 @@ } else if (b_nr == 1 && b_nc == 1) { - if (b.elem(0,0) == 0.) + if (b.elem (0,0) == 0.) r = MSparse<T> (a); else { - r = MSparse<T> (a_nr, a_nc, op (0.0, b.data(0))); + r = MSparse<T> (a_nr, a_nc, op (0.0, b.data (0))); for (octave_idx_type j = 0 ; j < a_nc ; j++) { octave_quit (); octave_idx_type idxj = j * a_nr; - for (octave_idx_type i = a.cidx(j) ; i < a.cidx(j+1) ; i++) + for (octave_idx_type i = a.cidx (j) ; i < a.cidx (j+1) ; i++) { octave_quit (); - r.data(idxj + a.ridx(i)) = op (a.data(i), b.data(0)); + r.data (idxj + a.ridx (i)) = op (a.data (i), b.data (0)); } } r.maybe_compress (); @@ -332,41 +332,41 @@ r.cidx (0) = 0; for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { - r.ridx(jx) = a.ridx(ja); - r.data(jx) = op (a.data(ja), 0.); + r.ridx (jx) = a.ridx (ja); + r.data (jx) = op (a.data (ja), 0.); jx++; ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { - r.ridx(jx) = b.ridx(jb); - r.data(jx) = op (0., b.data(jb)); + r.ridx (jx) = b.ridx (jb); + r.data (jx) = op (0., b.data (jb)); jx++; jb++; jb_lt_max= jb < jb_max; } else { - if (op (a.data(ja), b.data(jb)) != 0.) + if (op (a.data (ja), b.data (jb)) != 0.) { - r.data(jx) = op (a.data(ja), b.data(jb)); - r.ridx(jx) = a.ridx(ja); + r.data (jx) = op (a.data (ja), b.data (jb)); + r.ridx (jx) = a.ridx (ja); jx++; } ja++; @@ -375,7 +375,7 @@ jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } r.maybe_compress (); @@ -412,7 +412,7 @@ if (a_nr == 1 && a_nc == 1) { - if (a.elem(0,0) == 0.) + if (a.elem (0,0) == 0.) r = MSparse<T> (b_nr, b_nc); else { @@ -422,14 +422,14 @@ for (octave_idx_type i = 0 ; i < b_nnz ; i++) { octave_quit (); - r.data (i) = a.data(0) * r.data(i); + r.data (i) = a.data (0) * r.data (i); } r.maybe_compress (); } } else if (b_nr == 1 && b_nc == 1) { - if (b.elem(0,0) == 0.) + if (b.elem (0,0) == 0.) r = MSparse<T> (a_nr, a_nc); else { @@ -439,7 +439,7 @@ for (octave_idx_type i = 0 ; i < a_nnz ; i++) { octave_quit (); - r.data (i) = r.data(i) * b.data(0); + r.data (i) = r.data (i) * b.data (0); } r.maybe_compress (); } @@ -454,40 +454,40 @@ r.cidx (0) = 0; for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { jb++; jb_lt_max= jb < jb_max; } else { - if ((a.data(ja) * b.data(jb)) != 0.) + if ((a.data (ja) * b.data (jb)) != 0.) { - r.data(jx) = a.data(ja) * b.data(jb); - r.ridx(jx) = a.ridx(ja); + r.data (jx) = a.data (ja) * b.data (jb); + r.ridx (jx) = a.ridx (ja); jx++; } ja++; ja_lt_max= ja < ja_max; jb++; jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } r.maybe_compress (); @@ -518,7 +518,7 @@ octave_idx_type b_nnz = b.nnz (); r = MSparse<T> (b); for (octave_idx_type i = 0 ; i < b_nnz ; i++) - r.data (i) = val / r.data(i); + r.data (i) = val / r.data (i); r.maybe_compress (); } else @@ -528,10 +528,10 @@ { octave_quit (); octave_idx_type idxj = j * b_nr; - for (octave_idx_type i = b.cidx(j) ; i < b.cidx(j+1) ; i++) + for (octave_idx_type i = b.cidx (j) ; i < b.cidx (j+1) ; i++) { octave_quit (); - r.data(idxj + b.ridx(i)) = val / b.data(i); + r.data (idxj + b.ridx (i)) = val / b.data (i); } } r.maybe_compress (); @@ -546,7 +546,7 @@ octave_idx_type a_nnz = a.nnz (); r = MSparse<T> (a); for (octave_idx_type i = 0 ; i < a_nnz ; i++) - r.data (i) = r.data(i) / val; + r.data (i) = r.data (i) / val; r.maybe_compress (); } else @@ -556,10 +556,10 @@ { octave_quit (); octave_idx_type idxj = j * a_nr; - for (octave_idx_type i = a.cidx(j) ; i < a.cidx(j+1) ; i++) + for (octave_idx_type i = a.cidx (j) ; i < a.cidx (j+1) ; i++) { octave_quit (); - r.data(idxj + a.ridx(i)) = a.data(i) / val; + r.data (idxj + a.ridx (i)) = a.data (i) / val; } } r.maybe_compress (); @@ -573,32 +573,32 @@ for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { - r.elem (a.ridx(ja),i) = a.data(ja) / Zero; + r.elem (a.ridx (ja),i) = a.data (ja) / Zero; ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { - r.elem (b.ridx(jb),i) = Zero / b.data(jb); + r.elem (b.ridx (jb),i) = Zero / b.data (jb); jb++; jb_lt_max= jb < jb_max; } else { - r.elem (a.ridx(ja),i) = a.data(ja) / b.data(jb); + r.elem (a.ridx (ja),i) = a.data (ja) / b.data (jb); ja++; ja_lt_max= ja < ja_max; jb++; jb_lt_max= jb < jb_max; } @@ -629,6 +629,6 @@ MSparse<T> retval (a); octave_idx_type nz = a.nnz (); for (octave_idx_type i = 0; i < nz; i++) - retval.data(i) = - retval.data(i); + retval.data (i) = - retval.data (i); return retval; }
--- a/liboctave/MatrixType.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/MatrixType.cc Sat Jul 28 12:06:34 2012 -0400 @@ -74,7 +74,7 @@ bool hermitian = true; // do the checks for lower/upper/hermitian all in one pass. - OCTAVE_LOCAL_BUFFER(T, diag, ncols); + OCTAVE_LOCAL_BUFFER (T, diag, ncols); for (octave_idx_type j = 0; j < ncols && upper; j++) @@ -132,7 +132,7 @@ bool hermitian = true; // do the checks for lower/upper/hermitian all in one pass. - OCTAVE_LOCAL_BUFFER(T, diag, ncols); + OCTAVE_LOCAL_BUFFER (T, diag, ncols); for (octave_idx_type j = 0; j < ncols && upper; j++) @@ -231,12 +231,12 @@ // Maybe the matrix is diagonal for (i = 0; i < nm; i++) { - if (a.cidx(i+1) != a.cidx(i) + 1) + if (a.cidx (i+1) != a.cidx (i) + 1) { tmp_typ = MatrixType::Full; break; } - if (a.ridx(i) != i) + if (a.ridx (i) != i) { tmp_typ = MatrixType::Permuted_Diagonal; break; @@ -248,19 +248,19 @@ std::vector<bool> found (nrows); for (octave_idx_type j = 0; j < i; j++) - found [j] = true; + found[j] = true; for (octave_idx_type j = i; j < nrows; j++) - found [j] = false; + found[j] = false; for (octave_idx_type j = i; j < nm; j++) { - if ((a.cidx(j+1) > a.cidx(j) + 1) || - ((a.cidx(j+1) == a.cidx(j) + 1) && found [a.ridx(j)])) + if ((a.cidx (j+1) > a.cidx (j) + 1) || + ((a.cidx (j+1) == a.cidx (j) + 1) && found[a.ridx (j)])) { tmp_typ = MatrixType::Full; break; } - found [a.ridx(j)] = true; + found[a.ridx (j)] = true; } } typ = tmp_typ; @@ -278,8 +278,8 @@ if (j < nrows) { zero_on_diagonal = true; - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) - if (a.ridx(i) == j) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) + if (a.ridx (i) == j) { zero_on_diagonal = false; break; @@ -292,10 +292,10 @@ break; } - if (a.cidx(j+1) != a.cidx(j)) + if (a.cidx (j+1) != a.cidx (j)) { - octave_idx_type ru = a.ridx(a.cidx(j)); - octave_idx_type rl = a.ridx(a.cidx(j+1)-1); + octave_idx_type ru = a.ridx (a.cidx (j)); + octave_idx_type rl = a.ridx (a.cidx (j+1)-1); if (j - ru > upper_band) upper_band = j - ru; @@ -351,7 +351,7 @@ perm = new octave_idx_type [ncols]; for (octave_idx_type i = 0; i < ncols; i++) - perm [i] = -1; + perm[i] = -1; for (octave_idx_type i = 0; i < nm; i++) { @@ -359,10 +359,10 @@ for (octave_idx_type j = 0; j < ncols; j++) { - if ((a.cidx(j+1) - a.cidx(j)) > 0 && - (a.ridx(a.cidx(j+1)-1) == i)) + if ((a.cidx (j+1) - a.cidx (j)) > 0 && + (a.ridx (a.cidx (j+1)-1) == i)) { - perm [i] = j; + perm[i] = j; found = true; break; } @@ -379,11 +379,11 @@ { octave_idx_type k = nrows; for (octave_idx_type i = 0; i < ncols; i++) - if (perm [i] == -1) + if (perm[i] == -1) perm[i] = k++; } } - else if (a.cidx(nm) == a.cidx(ncols)) + else if (a.cidx (nm) == a.cidx (ncols)) { nperm = nrows; delete [] perm; @@ -392,13 +392,13 @@ for (octave_idx_type i = 0; i < nrows; i++) { - perm [i] = -1; - tmp [i] = -1; + perm[i] = -1; + tmp[i] = -1; } for (octave_idx_type j = 0; j < ncols; j++) - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) - perm [a.ridx(i)] = j; + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) + perm[a.ridx (i)] = j; found = true; for (octave_idx_type i = 0; i < nm; i++) @@ -478,11 +478,11 @@ for (octave_idx_type j = 0; is_herm && j < ncols; j++) { is_herm = false; - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) { - if (a.ridx(i) == j) + if (a.ridx (i) == j) { - double d = a.data(i); + double d = a.data (i); is_herm = d > 0.; diag(j) = d; break; @@ -494,20 +494,20 @@ // next, check symmetry and 2x2 positiveness for (octave_idx_type j = 0; is_herm && j < ncols; j++) - for (octave_idx_type i = a.cidx(j); is_herm && i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); is_herm && i < a.cidx (j+1); i++) { - octave_idx_type k = a.ridx(i); + octave_idx_type k = a.ridx (i); is_herm = k == j; if (is_herm) continue; - double d = a.data(i); + double d = a.data (i); if (d*d < diag(j)*diag(k)) { - for (octave_idx_type l = a.cidx(k); l < a.cidx(k+1); l++) + for (octave_idx_type l = a.cidx (k); l < a.cidx (k+1); l++) { - if (a.ridx(l) == j) + if (a.ridx (l) == j) { - is_herm = a.data(l) == d; + is_herm = a.data (l) == d; break; } } @@ -552,12 +552,12 @@ // Maybe the matrix is diagonal for (i = 0; i < nm; i++) { - if (a.cidx(i+1) != a.cidx(i) + 1) + if (a.cidx (i+1) != a.cidx (i) + 1) { tmp_typ = MatrixType::Full; break; } - if (a.ridx(i) != i) + if (a.ridx (i) != i) { tmp_typ = MatrixType::Permuted_Diagonal; break; @@ -569,19 +569,19 @@ std::vector<bool> found (nrows); for (octave_idx_type j = 0; j < i; j++) - found [j] = true; + found[j] = true; for (octave_idx_type j = i; j < nrows; j++) - found [j] = false; + found[j] = false; for (octave_idx_type j = i; j < nm; j++) { - if ((a.cidx(j+1) > a.cidx(j) + 1) || - ((a.cidx(j+1) == a.cidx(j) + 1) && found [a.ridx(j)])) + if ((a.cidx (j+1) > a.cidx (j) + 1) || + ((a.cidx (j+1) == a.cidx (j) + 1) && found[a.ridx (j)])) { tmp_typ = MatrixType::Full; break; } - found [a.ridx(j)] = true; + found[a.ridx (j)] = true; } } typ = tmp_typ; @@ -599,8 +599,8 @@ if (j < nrows) { zero_on_diagonal = true; - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) - if (a.ridx(i) == j) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) + if (a.ridx (i) == j) { zero_on_diagonal = false; break; @@ -613,10 +613,10 @@ break; } - if (a.cidx(j+1) != a.cidx(j)) + if (a.cidx (j+1) != a.cidx (j)) { - octave_idx_type ru = a.ridx(a.cidx(j)); - octave_idx_type rl = a.ridx(a.cidx(j+1)-1); + octave_idx_type ru = a.ridx (a.cidx (j)); + octave_idx_type rl = a.ridx (a.cidx (j+1)-1); if (j - ru > upper_band) upper_band = j - ru; @@ -672,7 +672,7 @@ perm = new octave_idx_type [ncols]; for (octave_idx_type i = 0; i < ncols; i++) - perm [i] = -1; + perm[i] = -1; for (octave_idx_type i = 0; i < nm; i++) { @@ -680,10 +680,10 @@ for (octave_idx_type j = 0; j < ncols; j++) { - if ((a.cidx(j+1) - a.cidx(j)) > 0 && - (a.ridx(a.cidx(j+1)-1) == i)) + if ((a.cidx (j+1) - a.cidx (j)) > 0 && + (a.ridx (a.cidx (j+1)-1) == i)) { - perm [i] = j; + perm[i] = j; found = true; break; } @@ -700,11 +700,11 @@ { octave_idx_type k = nrows; for (octave_idx_type i = 0; i < ncols; i++) - if (perm [i] == -1) + if (perm[i] == -1) perm[i] = k++; } } - else if (a.cidx(nm) == a.cidx(ncols)) + else if (a.cidx (nm) == a.cidx (ncols)) { nperm = nrows; delete [] perm; @@ -713,13 +713,13 @@ for (octave_idx_type i = 0; i < nrows; i++) { - perm [i] = -1; - tmp [i] = -1; + perm[i] = -1; + tmp[i] = -1; } for (octave_idx_type j = 0; j < ncols; j++) - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) - perm [a.ridx(i)] = j; + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) + perm[a.ridx (i)] = j; found = true; for (octave_idx_type i = 0; i < nm; i++) @@ -799,11 +799,11 @@ for (octave_idx_type j = 0; is_herm && j < ncols; j++) { is_herm = false; - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) { - if (a.ridx(i) == j) + if (a.ridx (i) == j) { - Complex d = a.data(i); + Complex d = a.data (i); is_herm = d.real () > 0. && d.imag () == 0.; diag(j) = d.real (); break; @@ -814,21 +814,21 @@ // next, check symmetry and 2x2 positiveness for (octave_idx_type j = 0; is_herm && j < ncols; j++) - for (octave_idx_type i = a.cidx(j); is_herm && i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); is_herm && i < a.cidx (j+1); i++) { - octave_idx_type k = a.ridx(i); + octave_idx_type k = a.ridx (i); is_herm = k == j; if (is_herm) continue; - Complex d = a.data(i); + Complex d = a.data (i); if (std::norm (d) < diag(j)*diag(k)) { d = std::conj (d); - for (octave_idx_type l = a.cidx(k); l < a.cidx(k+1); l++) + for (octave_idx_type l = a.cidx (k); l < a.cidx (k+1); l++) { - if (a.ridx(l) == j) + if (a.ridx (l) == j) { - is_herm = a.data(l) == d; + is_herm = a.data (l) == d; break; } }
--- a/liboctave/Sparse-op-defs.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/Sparse-op-defs.h Sat Jul 28 12:06:34 2012 -0400 @@ -74,11 +74,11 @@ \ for (octave_idx_type i = 0; i < nz; i++) \ { \ - r.xdata(i) = m.data(i) OP s; \ - r.xridx(i) = m.ridx(i); \ + r.xdata (i) = m.data (i) OP s; \ + r.xridx (i) = m.ridx (i); \ } \ for (octave_idx_type i = 0; i < nc + 1; i++) \ - r.xcidx(i) = m.cidx(i); \ + r.xcidx (i) = m.cidx (i); \ \ r.maybe_compress (true); \ return r; \ @@ -114,7 +114,7 @@ { \ r = SparseBoolMatrix (nr, nc, true); \ for (octave_idx_type j = 0; j < nc; j++) \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ if (! (MC (m.data (i)) OP SC (s))) \ r.data (m.ridx (i) + j * nr) = false; \ r.maybe_compress (true); \ @@ -126,7 +126,7 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < nc; j++) \ { \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ if (MC (m.data (i)) OP SC (s)) \ { \ r.ridx (nel) = m.ridx (i); \ @@ -169,8 +169,8 @@ { \ r = SparseBoolMatrix (nr, nc, true); \ for (octave_idx_type j = 0; j < nc; j++) \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ - if (! ((m.data(i) != LHS_ZERO) OP (s != RHS_ZERO))) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ + if (! ((m.data (i) != LHS_ZERO) OP (s != RHS_ZERO))) \ r.data (m.ridx (i) + j * nr) = false; \ r.maybe_compress (true); \ } \ @@ -181,8 +181,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < nc; j++) \ { \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ - if ((m.data(i) != LHS_ZERO) OP (s != RHS_ZERO)) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ + if ((m.data (i) != LHS_ZERO) OP (s != RHS_ZERO)) \ { \ r.ridx (nel) = m.ridx (i); \ r.data (nel++) = true; \ @@ -243,11 +243,11 @@ \ for (octave_idx_type i = 0; i < nz; i++) \ { \ - r.xdata(i) = s OP m.data(i); \ - r.xridx(i) = m.ridx(i); \ + r.xdata (i) = s OP m.data (i); \ + r.xridx (i) = m.ridx (i); \ } \ for (octave_idx_type i = 0; i < nc + 1; i++) \ - r.xcidx(i) = m.cidx(i); \ + r.xcidx (i) = m.cidx (i); \ \ r.maybe_compress(true); \ return r; \ @@ -283,7 +283,7 @@ { \ r = SparseBoolMatrix (nr, nc, true); \ for (octave_idx_type j = 0; j < nc; j++) \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ if (! (SC (s) OP MC (m.data (i)))) \ r.data (m.ridx (i) + j * nr) = false; \ r.maybe_compress (true); \ @@ -295,7 +295,7 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < nc; j++) \ { \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ if (SC (s) OP MC (m.data (i))) \ { \ r.ridx (nel) = m.ridx (i); \ @@ -338,8 +338,8 @@ { \ r = SparseBoolMatrix (nr, nc, true); \ for (octave_idx_type j = 0; j < nc; j++) \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ - if (! ((s != LHS_ZERO) OP (m.data(i) != RHS_ZERO))) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ + if (! ((s != LHS_ZERO) OP (m.data (i) != RHS_ZERO))) \ r.data (m.ridx (i) + j * nr) = false; \ r.maybe_compress (true); \ } \ @@ -350,8 +350,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < nc; j++) \ { \ - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) \ - if ((s != LHS_ZERO) OP (m.data(i) != RHS_ZERO)) \ + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) \ + if ((s != LHS_ZERO) OP (m.data (i) != RHS_ZERO)) \ { \ r.ridx (nel) = m.ridx (i); \ r.data (nel++) = true; \ @@ -398,20 +398,20 @@ \ if (m1_nr == 1 && m1_nc == 1) \ { \ - if (m1.elem(0,0) == 0.) \ + if (m1.elem (0,0) == 0.) \ r = OP R (m2); \ else \ { \ - r = R (m2_nr, m2_nc, m1.data(0) OP 0.); \ + r = R (m2_nr, m2_nc, m1.data (0) OP 0.); \ \ for (octave_idx_type j = 0 ; j < m2_nc ; j++) \ { \ octave_quit (); \ octave_idx_type idxj = j * m2_nr; \ - for (octave_idx_type i = m2.cidx(j) ; i < m2.cidx(j+1) ; i++) \ + for (octave_idx_type i = m2.cidx (j) ; i < m2.cidx (j+1) ; i++) \ { \ octave_quit (); \ - r.data(idxj + m2.ridx(i)) = m1.data(0) OP m2.data(i); \ + r.data (idxj + m2.ridx (i)) = m1.data (0) OP m2.data (i); \ } \ } \ r.maybe_compress (); \ @@ -419,20 +419,20 @@ } \ else if (m2_nr == 1 && m2_nc == 1) \ { \ - if (m2.elem(0,0) == 0.) \ + if (m2.elem (0,0) == 0.) \ r = R (m1); \ else \ { \ - r = R (m1_nr, m1_nc, 0. OP m2.data(0)); \ + r = R (m1_nr, m1_nc, 0. OP m2.data (0)); \ \ for (octave_idx_type j = 0 ; j < m1_nc ; j++) \ { \ octave_quit (); \ octave_idx_type idxj = j * m1_nr; \ - for (octave_idx_type i = m1.cidx(j) ; i < m1.cidx(j+1) ; i++) \ + for (octave_idx_type i = m1.cidx (j) ; i < m1.cidx (j+1) ; i++) \ { \ octave_quit (); \ - r.data(idxj + m1.ridx(i)) = m1.data(i) OP m2.data(0); \ + r.data (idxj + m1.ridx (i)) = m1.data (i) OP m2.data (0); \ } \ } \ r.maybe_compress (); \ @@ -448,41 +448,41 @@ r.cidx (0) = 0; \ for (octave_idx_type i = 0 ; i < m1_nc ; i++) \ { \ - octave_idx_type ja = m1.cidx(i); \ - octave_idx_type ja_max = m1.cidx(i+1); \ + octave_idx_type ja = m1.cidx (i); \ + octave_idx_type ja_max = m1.cidx (i+1); \ bool ja_lt_max= ja < ja_max; \ \ - octave_idx_type jb = m2.cidx(i); \ - octave_idx_type jb_max = m2.cidx(i+1); \ + octave_idx_type jb = m2.cidx (i); \ + octave_idx_type jb_max = m2.cidx (i+1); \ bool jb_lt_max = jb < jb_max; \ \ while (ja_lt_max || jb_lt_max ) \ { \ octave_quit (); \ if ((! jb_lt_max) || \ - (ja_lt_max && (m1.ridx(ja) < m2.ridx(jb)))) \ + (ja_lt_max && (m1.ridx (ja) < m2.ridx (jb)))) \ { \ - r.ridx(jx) = m1.ridx(ja); \ - r.data(jx) = m1.data(ja) OP 0.; \ + r.ridx (jx) = m1.ridx (ja); \ + r.data (jx) = m1.data (ja) OP 0.; \ jx++; \ ja++; \ ja_lt_max= ja < ja_max; \ } \ else if (( !ja_lt_max ) || \ - (jb_lt_max && (m2.ridx(jb) < m1.ridx(ja)) ) ) \ + (jb_lt_max && (m2.ridx (jb) < m1.ridx (ja)) ) ) \ { \ - r.ridx(jx) = m2.ridx(jb); \ - r.data(jx) = 0. OP m2.data(jb); \ + r.ridx (jx) = m2.ridx (jb); \ + r.data (jx) = 0. OP m2.data (jb); \ jx++; \ jb++; \ jb_lt_max= jb < jb_max; \ } \ else \ { \ - if ((m1.data(ja) OP m2.data(jb)) != 0.) \ + if ((m1.data (ja) OP m2.data (jb)) != 0.) \ { \ - r.data(jx) = m1.data(ja) OP m2.data(jb); \ - r.ridx(jx) = m1.ridx(ja); \ + r.data (jx) = m1.data (ja) OP m2.data (jb); \ + r.ridx (jx) = m1.ridx (ja); \ jx++; \ } \ ja++; \ @@ -491,7 +491,7 @@ jb_lt_max= jb < jb_max; \ } \ } \ - r.cidx(i+1) = jx; \ + r.cidx (i+1) = jx; \ } \ \ r.maybe_compress (); \ @@ -514,7 +514,7 @@ \ if (m1_nr == 1 && m1_nc == 1) \ { \ - if (m1.elem(0,0) == 0.) \ + if (m1.elem (0,0) == 0.) \ r = R (m2_nr, m2_nc); \ else \ { \ @@ -524,14 +524,14 @@ for (octave_idx_type i = 0 ; i < m2_nnz ; i++) \ { \ octave_quit (); \ - r.data (i) = m1.data(0) OP r.data(i); \ + r.data (i) = m1.data (0) OP r.data (i); \ } \ r.maybe_compress (); \ } \ } \ else if (m2_nr == 1 && m2_nc == 1) \ { \ - if (m2.elem(0,0) == 0.) \ + if (m2.elem (0,0) == 0.) \ r = R (m1_nr, m1_nc); \ else \ { \ @@ -541,7 +541,7 @@ for (octave_idx_type i = 0 ; i < m1_nnz ; i++) \ { \ octave_quit (); \ - r.data (i) = r.data(i) OP m2.data(0); \ + r.data (i) = r.data (i) OP m2.data (0); \ } \ r.maybe_compress (); \ } \ @@ -556,40 +556,40 @@ r.cidx (0) = 0; \ for (octave_idx_type i = 0 ; i < m1_nc ; i++) \ { \ - octave_idx_type ja = m1.cidx(i); \ - octave_idx_type ja_max = m1.cidx(i+1); \ + octave_idx_type ja = m1.cidx (i); \ + octave_idx_type ja_max = m1.cidx (i+1); \ bool ja_lt_max= ja < ja_max; \ \ - octave_idx_type jb = m2.cidx(i); \ - octave_idx_type jb_max = m2.cidx(i+1); \ + octave_idx_type jb = m2.cidx (i); \ + octave_idx_type jb_max = m2.cidx (i+1); \ bool jb_lt_max = jb < jb_max; \ \ while (ja_lt_max || jb_lt_max ) \ { \ octave_quit (); \ if ((! jb_lt_max) || \ - (ja_lt_max && (m1.ridx(ja) < m2.ridx(jb)))) \ + (ja_lt_max && (m1.ridx (ja) < m2.ridx (jb)))) \ { \ ja++; ja_lt_max= ja < ja_max; \ } \ else if (( !ja_lt_max ) || \ - (jb_lt_max && (m2.ridx(jb) < m1.ridx(ja)) ) ) \ + (jb_lt_max && (m2.ridx (jb) < m1.ridx (ja)) ) ) \ { \ jb++; jb_lt_max= jb < jb_max; \ } \ else \ { \ - if ((m1.data(ja) OP m2.data(jb)) != 0.) \ + if ((m1.data (ja) OP m2.data (jb)) != 0.) \ { \ - r.data(jx) = m1.data(ja) OP m2.data(jb); \ - r.ridx(jx) = m1.ridx(ja); \ + r.data (jx) = m1.data (ja) OP m2.data (jb); \ + r.ridx (jx) = m1.ridx (ja); \ jx++; \ } \ ja++; ja_lt_max= ja < ja_max; \ jb++; jb_lt_max= jb < jb_max; \ } \ } \ - r.cidx(i+1) = jx; \ + r.cidx (i+1) = jx; \ } \ \ r.maybe_compress (); \ @@ -617,20 +617,20 @@ octave_idx_type m2_nnz = m2.nnz (); \ r = R (m2); \ for (octave_idx_type i = 0 ; i < m2_nnz ; i++) \ - r.data (i) = m1.elem(0,0) OP r.data(i); \ + r.data (i) = m1.elem (0,0) OP r.data (i); \ r.maybe_compress (); \ } \ else \ { \ - r = R (m2_nr, m2_nc, m1.elem(0,0) OP Complex ()); \ + r = R (m2_nr, m2_nc, m1.elem (0,0) OP Complex ()); \ for (octave_idx_type j = 0 ; j < m2_nc ; j++) \ { \ octave_quit (); \ octave_idx_type idxj = j * m2_nr; \ - for (octave_idx_type i = m2.cidx(j) ; i < m2.cidx(j+1) ; i++) \ + for (octave_idx_type i = m2.cidx (j) ; i < m2.cidx (j+1) ; i++) \ { \ octave_quit (); \ - r.data(idxj + m2.ridx(i)) = m1.elem(0,0) OP m2.data(i); \ + r.data (idxj + m2.ridx (i)) = m1.elem (0,0) OP m2.data (i); \ } \ } \ r.maybe_compress (); \ @@ -643,20 +643,20 @@ octave_idx_type m1_nnz = m1.nnz (); \ r = R (m1); \ for (octave_idx_type i = 0 ; i < m1_nnz ; i++) \ - r.data (i) = r.data(i) OP m2.elem(0,0); \ + r.data (i) = r.data (i) OP m2.elem (0,0); \ r.maybe_compress (); \ } \ else \ { \ - r = R (m1_nr, m1_nc, Complex () OP m2.elem(0,0)); \ + r = R (m1_nr, m1_nc, Complex () OP m2.elem (0,0)); \ for (octave_idx_type j = 0 ; j < m1_nc ; j++) \ { \ octave_quit (); \ octave_idx_type idxj = j * m1_nr; \ - for (octave_idx_type i = m1.cidx(j) ; i < m1.cidx(j+1) ; i++) \ + for (octave_idx_type i = m1.cidx (j) ; i < m1.cidx (j+1) ; i++) \ { \ octave_quit (); \ - r.data(idxj + m1.ridx(i)) = m1.data(i) OP m2.elem(0,0); \ + r.data (idxj + m1.ridx (i)) = m1.data (i) OP m2.elem (0,0); \ } \ } \ r.maybe_compress (); \ @@ -672,36 +672,36 @@ \ for (octave_idx_type i = 0 ; i < m1_nc ; i++) \ { \ - octave_idx_type ja = m1.cidx(i); \ - octave_idx_type ja_max = m1.cidx(i+1); \ + octave_idx_type ja = m1.cidx (i); \ + octave_idx_type ja_max = m1.cidx (i+1); \ bool ja_lt_max= ja < ja_max; \ \ - octave_idx_type jb = m2.cidx(i); \ - octave_idx_type jb_max = m2.cidx(i+1); \ + octave_idx_type jb = m2.cidx (i); \ + octave_idx_type jb_max = m2.cidx (i+1); \ bool jb_lt_max = jb < jb_max; \ \ while (ja_lt_max || jb_lt_max ) \ { \ octave_quit (); \ if ((! jb_lt_max) || \ - (ja_lt_max && (m1.ridx(ja) < m2.ridx(jb)))) \ + (ja_lt_max && (m1.ridx (ja) < m2.ridx (jb)))) \ { \ /* keep those kludges coming */ \ - r.elem(m1.ridx(ja),i) = m1.data(ja) OP Complex (); \ + r.elem (m1.ridx (ja),i) = m1.data (ja) OP Complex (); \ ja++; \ ja_lt_max= ja < ja_max; \ } \ else if (( !ja_lt_max ) || \ - (jb_lt_max && (m2.ridx(jb) < m1.ridx(ja)) ) ) \ + (jb_lt_max && (m2.ridx (jb) < m1.ridx (ja)) ) ) \ { \ /* keep those kludges coming */ \ - r.elem(m2.ridx(jb),i) = Complex () OP m2.data(jb); \ + r.elem (m2.ridx (jb),i) = Complex () OP m2.data (jb); \ jb++; \ jb_lt_max= jb < jb_max; \ } \ else \ { \ - r.elem(m1.ridx(ja),i) = m1.data(ja) OP m2.data(jb); \ + r.elem (m1.ridx (ja),i) = m1.data (ja) OP m2.data (jb); \ ja++; \ ja_lt_max= ja < ja_max; \ jb++; \ @@ -755,12 +755,12 @@ \ if (m1_nr == 1 && m1_nc == 1) \ { \ - if (C1 (m1.elem(0,0)) OP C2 (Z2)) \ + if (C1 (m1.elem (0,0)) OP C2 (Z2)) \ { \ r = SparseBoolMatrix (m2_nr, m2_nc, true); \ for (octave_idx_type j = 0; j < m2_nc; j++) \ - for (octave_idx_type i = m2.cidx(j); i < m2.cidx(j+1); i++) \ - if (! (C1 (m1.elem (0,0)) OP C2 (m2.data(i)))) \ + for (octave_idx_type i = m2.cidx (j); i < m2.cidx (j+1); i++) \ + if (! (C1 (m1.elem (0,0)) OP C2 (m2.data (i)))) \ r.data (m2.ridx (i) + j * m2_nr) = false; \ r.maybe_compress (true); \ } \ @@ -771,8 +771,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m2_nc; j++) \ { \ - for (octave_idx_type i = m2.cidx(j); i < m2.cidx(j+1); i++) \ - if (C1 (m1.elem (0,0)) OP C2 (m2.data(i))) \ + for (octave_idx_type i = m2.cidx (j); i < m2.cidx (j+1); i++) \ + if (C1 (m1.elem (0,0)) OP C2 (m2.data (i))) \ { \ r.ridx (nel) = m2.ridx (i); \ r.data (nel++) = true; \ @@ -788,8 +788,8 @@ { \ r = SparseBoolMatrix (m1_nr, m1_nc, true); \ for (octave_idx_type j = 0; j < m1_nc; j++) \ - for (octave_idx_type i = m1.cidx(j); i < m1.cidx(j+1); i++) \ - if (! (C1 (m1.data (i)) OP C2 (m2.elem(0,0)))) \ + for (octave_idx_type i = m1.cidx (j); i < m1.cidx (j+1); i++) \ + if (! (C1 (m1.data (i)) OP C2 (m2.elem (0,0)))) \ r.data (m1.ridx (i) + j * m1_nr) = false; \ r.maybe_compress (true); \ } \ @@ -800,8 +800,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m1_nc; j++) \ { \ - for (octave_idx_type i = m1.cidx(j); i < m1.cidx(j+1); i++) \ - if (C1 (m1.data (i)) OP C2 (m2.elem(0,0))) \ + for (octave_idx_type i = m1.cidx (j); i < m1.cidx (j+1); i++) \ + if (C1 (m1.data (i)) OP C2 (m2.elem (0,0))) \ { \ r.ridx (nel) = m1.ridx (i); \ r.data (nel++) = true; \ @@ -826,13 +826,13 @@ octave_idx_type e2 = m2.cidx (j+1); \ while (i1 < e1 || i2 < e2) \ { \ - if (i1 == e1 || (i2 < e2 && m1.ridx(i1) > m2.ridx(i2))) \ + if (i1 == e1 || (i2 < e2 && m1.ridx (i1) > m2.ridx (i2))) \ { \ if (! (C1 (Z1) OP C2 (m2.data (i2)))) \ r.data (m2.ridx (i2) + j * m1_nr) = false; \ i2++; \ } \ - else if (i2 == e2 || m1.ridx(i1) < m2.ridx(i2)) \ + else if (i2 == e2 || m1.ridx (i1) < m2.ridx (i2)) \ { \ if (! (C1 (m1.data (i1)) OP C2 (Z2))) \ r.data (m1.ridx (i1) + j * m1_nr) = false; \ @@ -862,7 +862,7 @@ octave_idx_type e2 = m2.cidx (j+1); \ while (i1 < e1 || i2 < e2) \ { \ - if (i1 == e1 || (i2 < e2 && m1.ridx(i1) > m2.ridx(i2))) \ + if (i1 == e1 || (i2 < e2 && m1.ridx (i1) > m2.ridx (i2))) \ { \ if (C1 (Z1) OP C2 (m2.data (i2))) \ { \ @@ -871,7 +871,7 @@ } \ i2++; \ } \ - else if (i2 == e2 || m1.ridx(i1) < m2.ridx(i2)) \ + else if (i2 == e2 || m1.ridx (i1) < m2.ridx (i2)) \ { \ if (C1 (m1.data (i1)) OP C2 (Z2)) \ { \ @@ -941,12 +941,12 @@ { \ if (m2_nr > 0 && m2_nc > 0) \ { \ - if ((m1.elem(0,0) != LHS_ZERO) OP RHS_ZERO) \ + if ((m1.elem (0,0) != LHS_ZERO) OP RHS_ZERO) \ { \ r = SparseBoolMatrix (m2_nr, m2_nc, true); \ for (octave_idx_type j = 0; j < m2_nc; j++) \ - for (octave_idx_type i = m2.cidx(j); i < m2.cidx(j+1); i++) \ - if (! ((m1.elem(0,0) != LHS_ZERO) OP (m2.data(i) != RHS_ZERO))) \ + for (octave_idx_type i = m2.cidx (j); i < m2.cidx (j+1); i++) \ + if (! ((m1.elem (0,0) != LHS_ZERO) OP (m2.data (i) != RHS_ZERO))) \ r.data (m2.ridx (i) + j * m2_nr) = false; \ r.maybe_compress (true); \ } \ @@ -957,8 +957,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m2_nc; j++) \ { \ - for (octave_idx_type i = m2.cidx(j); i < m2.cidx(j+1); i++) \ - if ((m1.elem(0,0) != LHS_ZERO) OP (m2.data(i) != RHS_ZERO)) \ + for (octave_idx_type i = m2.cidx (j); i < m2.cidx (j+1); i++) \ + if ((m1.elem (0,0) != LHS_ZERO) OP (m2.data (i) != RHS_ZERO)) \ { \ r.ridx (nel) = m2.ridx (i); \ r.data (nel++) = true; \ @@ -973,12 +973,12 @@ { \ if (m1_nr > 0 && m1_nc > 0) \ { \ - if (LHS_ZERO OP (m2.elem(0,0) != RHS_ZERO)) \ + if (LHS_ZERO OP (m2.elem (0,0) != RHS_ZERO)) \ { \ r = SparseBoolMatrix (m1_nr, m1_nc, true); \ for (octave_idx_type j = 0; j < m1_nc; j++) \ - for (octave_idx_type i = m1.cidx(j); i < m1.cidx(j+1); i++) \ - if (! ((m1.data(i) != LHS_ZERO) OP (m2.elem(0,0) != RHS_ZERO))) \ + for (octave_idx_type i = m1.cidx (j); i < m1.cidx (j+1); i++) \ + if (! ((m1.data (i) != LHS_ZERO) OP (m2.elem (0,0) != RHS_ZERO))) \ r.data (m1.ridx (i) + j * m1_nr) = false; \ r.maybe_compress (true); \ } \ @@ -989,8 +989,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m1_nc; j++) \ { \ - for (octave_idx_type i = m1.cidx(j); i < m1.cidx(j+1); i++) \ - if ((m1.data(i) != LHS_ZERO) OP (m2.elem(0,0) != RHS_ZERO)) \ + for (octave_idx_type i = m1.cidx (j); i < m1.cidx (j+1); i++) \ + if ((m1.data (i) != LHS_ZERO) OP (m2.elem (0,0) != RHS_ZERO)) \ { \ r.ridx (nel) = m1.ridx (i); \ r.data (nel++) = true; \ @@ -1016,7 +1016,7 @@ octave_idx_type e2 = m2.cidx (j+1); \ while (i1 < e1 || i2 < e2) \ { \ - if (i1 == e1 || (i2 < e2 && m1.ridx(i1) > m2.ridx(i2))) \ + if (i1 == e1 || (i2 < e2 && m1.ridx (i1) > m2.ridx (i2))) \ { \ if (LHS_ZERO OP m2.data (i2) != RHS_ZERO) \ { \ @@ -1025,7 +1025,7 @@ } \ i2++; \ } \ - else if (i2 == e2 || m1.ridx(i1) < m2.ridx(i2)) \ + else if (i2 == e2 || m1.ridx (i1) < m2.ridx (i2)) \ { \ if (m1.data (i1) != LHS_ZERO OP RHS_ZERO) \ { \ @@ -1036,7 +1036,7 @@ } \ else \ { \ - if (m1.data (i1) != LHS_ZERO OP m2.data(i2) != RHS_ZERO) \ + if (m1.data (i1) != LHS_ZERO OP m2.data (i2) != RHS_ZERO) \ { \ r.ridx (nel) = m1.ridx (i1); \ r.data (nel++) = true; \ @@ -1091,7 +1091,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m2_nr == 1 && m2_nc == 1) \ - r = R (m1 OP m2.elem(0,0)); \ + r = R (m1 OP m2.elem (0,0)); \ else if (m1_nr != m2_nr || m1_nc != m2_nc) \ gripe_nonconformant (#F, m1_nr, m1_nc, m2_nr, m2_nc); \ else \ @@ -1114,7 +1114,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m2_nr == 1 && m2_nc == 1) \ - r = R (m1 OP m2.elem(0,0)); \ + r = R (m1 OP m2.elem (0,0)); \ else if (m1_nr != m2_nr || m1_nc != m2_nc) \ gripe_nonconformant (#F, m1_nr, m1_nc, m2_nr, m2_nc); \ else \ @@ -1127,18 +1127,18 @@ for (octave_idx_type j = 0, k = 0; j < m2_nc; j++) \ { \ octave_quit (); \ - for (octave_idx_type i = m2.cidx(j); i < m2.cidx(j+1); i++) \ + for (octave_idx_type i = m2.cidx (j); i < m2.cidx (j+1); i++) \ { \ - octave_idx_type mri = m2.ridx(i); \ - R::element_type x = m1(mri, j) OP m2.data(i); \ + octave_idx_type mri = m2.ridx (i); \ + R::element_type x = m1(mri, j) OP m2.data (i); \ if (x != 0.0) \ { \ - r.xdata(k) = x; \ - r.xridx(k) = m2.ridx(i); \ + r.xdata (k) = x; \ + r.xridx (k) = m2.ridx (i); \ k++; \ } \ } \ - r.xcidx(j+1) = k; \ + r.xcidx (j+1) = k; \ } \ r.maybe_compress (false); \ return r; \ @@ -1182,7 +1182,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m2_nr == 1 && m2_nc == 1) \ - r = SparseBoolMatrix (F (m1, m2.elem(0,0))); \ + r = SparseBoolMatrix (F (m1, m2.elem (0,0))); \ else if (m1_nr == m2_nr && m1_nc == m2_nc) \ { \ if (m1_nr != 0 || m1_nc != 0) \ @@ -1191,7 +1191,7 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m1_nc; j++) \ for (octave_idx_type i = 0; i < m1_nr; i++) \ - if (C1 (m1.elem(i, j)) OP C2 (m2.elem(i, j))) \ + if (C1 (m1.elem (i, j)) OP C2 (m2.elem (i, j))) \ nel++; \ \ r = SparseBoolMatrix (m1_nr, m1_nc, nel); \ @@ -1202,14 +1202,14 @@ { \ for (octave_idx_type i = 0; i < m1_nr; i++) \ { \ - bool el = C1 (m1.elem(i, j)) OP C2 (m2.elem(i, j)); \ + bool el = C1 (m1.elem (i, j)) OP C2 (m2.elem (i, j)); \ if (el) \ { \ - r.data(ii) = el; \ - r.ridx(ii++) = i; \ + r.data (ii) = el; \ + r.ridx (ii++) = i; \ } \ } \ - r.cidx(j+1) = ii; \ + r.cidx (j+1) = ii; \ } \ } \ } \ @@ -1250,7 +1250,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m2_nr == 1 && m2_nc == 1) \ - r = SparseBoolMatrix (F (m1, m2.elem(0,0))); \ + r = SparseBoolMatrix (F (m1, m2.elem (0,0))); \ else if (m1_nr == m2_nr && m1_nc == m2_nc) \ { \ if (m1_nr != 0 || m1_nc != 0) \ @@ -1259,8 +1259,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m1_nc; j++) \ for (octave_idx_type i = 0; i < m1_nr; i++) \ - if ((m1.elem(i, j) != LHS_ZERO) \ - OP (m2.elem(i, j) != RHS_ZERO)) \ + if ((m1.elem (i, j) != LHS_ZERO) \ + OP (m2.elem (i, j) != RHS_ZERO)) \ nel++; \ \ r = SparseBoolMatrix (m1_nr, m1_nc, nel); \ @@ -1271,15 +1271,15 @@ { \ for (octave_idx_type i = 0; i < m1_nr; i++) \ { \ - bool el = (m1.elem(i, j) != LHS_ZERO) \ - OP (m2.elem(i, j) != RHS_ZERO); \ + bool el = (m1.elem (i, j) != LHS_ZERO) \ + OP (m2.elem (i, j) != RHS_ZERO); \ if (el) \ { \ - r.data(ii) = el; \ - r.ridx(ii++) = i; \ + r.data (ii) = el; \ + r.ridx (ii++) = i; \ } \ } \ - r.cidx(j+1) = ii; \ + r.cidx (j+1) = ii; \ } \ } \ } \ @@ -1324,7 +1324,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m1_nr == 1 && m1_nc == 1) \ - r = R (m1.elem(0,0) OP m2); \ + r = R (m1.elem (0,0) OP m2); \ else if (m1_nr != m2_nr || m1_nc != m2_nc) \ gripe_nonconformant (#F, m1_nr, m1_nc, m2_nr, m2_nc); \ else \ @@ -1355,7 +1355,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m1_nr == 1 && m1_nc == 1) \ - r = R (m1.elem(0,0) OP m2); \ + r = R (m1.elem (0,0) OP m2); \ else if (m1_nr != m2_nr || m1_nc != m2_nc) \ gripe_nonconformant (#F, m1_nr, m1_nc, m2_nr, m2_nc); \ else \ @@ -1368,18 +1368,18 @@ for (octave_idx_type j = 0, k = 0; j < m1_nc; j++) \ { \ octave_quit (); \ - for (octave_idx_type i = m1.cidx(j); i < m1.cidx(j+1); i++) \ + for (octave_idx_type i = m1.cidx (j); i < m1.cidx (j+1); i++) \ { \ - octave_idx_type mri = m1.ridx(i); \ - R::element_type x = m1.data(i) OP m2(mri, j); \ + octave_idx_type mri = m1.ridx (i); \ + R::element_type x = m1.data (i) OP m2 (mri, j); \ if (x != 0.0) \ { \ - r.xdata(k) = x; \ - r.xridx(k) = m1.ridx(i); \ + r.xdata (k) = x; \ + r.xridx (k) = m1.ridx (i); \ k++; \ } \ } \ - r.xcidx(j+1) = k; \ + r.xcidx (j+1) = k; \ } \ r.maybe_compress (false); \ return r; \ @@ -1422,7 +1422,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m1_nr == 1 && m1_nc == 1) \ - r = SparseBoolMatrix (F (m1.elem(0,0), m2)); \ + r = SparseBoolMatrix (F (m1.elem (0,0), m2)); \ else if (m1_nr == m2_nr && m1_nc == m2_nc) \ { \ if (m1_nr != 0 || m1_nc != 0) \ @@ -1431,7 +1431,7 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m1_nc; j++) \ for (octave_idx_type i = 0; i < m1_nr; i++) \ - if (C1 (m1.elem(i, j)) OP C2 (m2.elem(i, j))) \ + if (C1 (m1.elem (i, j)) OP C2 (m2.elem (i, j))) \ nel++; \ \ r = SparseBoolMatrix (m1_nr, m1_nc, nel); \ @@ -1442,14 +1442,14 @@ { \ for (octave_idx_type i = 0; i < m1_nr; i++) \ { \ - bool el = C1 (m1.elem(i, j)) OP C2 (m2.elem(i, j)); \ + bool el = C1 (m1.elem (i, j)) OP C2 (m2.elem (i, j)); \ if (el) \ { \ - r.data(ii) = el; \ - r.ridx(ii++) = i; \ + r.data (ii) = el; \ + r.ridx (ii++) = i; \ } \ } \ - r.cidx(j+1) = ii; \ + r.cidx (j+1) = ii; \ } \ } \ } \ @@ -1490,7 +1490,7 @@ octave_idx_type m2_nc = m2.cols (); \ \ if (m1_nr == 1 && m1_nc == 1) \ - r = SparseBoolMatrix (F (m1.elem(0,0), m2)); \ + r = SparseBoolMatrix (F (m1.elem (0,0), m2)); \ else if (m1_nr == m2_nr && m1_nc == m2_nc) \ { \ if (m1_nr != 0 || m1_nc != 0) \ @@ -1499,8 +1499,8 @@ octave_idx_type nel = 0; \ for (octave_idx_type j = 0; j < m1_nc; j++) \ for (octave_idx_type i = 0; i < m1_nr; i++) \ - if ((m1.elem(i, j) != LHS_ZERO) \ - OP (m2.elem(i, j) != RHS_ZERO)) \ + if ((m1.elem (i, j) != LHS_ZERO) \ + OP (m2.elem (i, j) != RHS_ZERO)) \ nel++; \ \ r = SparseBoolMatrix (m1_nr, m1_nc, nel); \ @@ -1511,15 +1511,15 @@ { \ for (octave_idx_type i = 0; i < m1_nr; i++) \ { \ - bool el = (m1.elem(i, j) != LHS_ZERO) \ - OP (m2.elem(i, j) != RHS_ZERO); \ + bool el = (m1.elem (i, j) != LHS_ZERO) \ + OP (m2.elem (i, j) != RHS_ZERO); \ if (el) \ { \ - r.data(ii) = el; \ - r.ridx(ii++) = i; \ + r.data (ii) = el; \ + r.ridx (ii++) = i; \ } \ } \ - r.cidx(j+1) = ii; \ + r.cidx (j+1) = ii; \ } \ } \ } \ @@ -1565,30 +1565,30 @@ ELT_TYPE t = ELT_TYPE (); \ for (octave_idx_type j = cidx (i); j < cidx (i+1); j++) \ { \ - t += data(j); \ + t += data (j); \ if (t != ELT_TYPE ()) \ { \ - if (j == cidx(i+1) - 1) \ - nel += nr - ridx(j); \ + if (j == cidx (i+1) - 1) \ + nel += nr - ridx (j); \ else \ - nel += ridx(j+1) - ridx(j); \ + nel += ridx (j+1) - ridx (j); \ } \ } \ } \ retval = RET_TYPE (nr, nc, nel); \ - retval.cidx(0) = 0; \ + retval.cidx (0) = 0; \ octave_idx_type ii = 0; \ for (octave_idx_type i = 0; i < nc; i++) \ { \ ELT_TYPE t = ELT_TYPE (); \ for (octave_idx_type j = cidx (i); j < cidx (i+1); j++) \ { \ - t += data(j); \ + t += data (j); \ if (t != ELT_TYPE ()) \ { \ - if (j == cidx(i+1) - 1) \ + if (j == cidx (i+1) - 1) \ { \ - for (octave_idx_type k = ridx(j); k < nr; k++) \ + for (octave_idx_type k = ridx (j); k < nr; k++) \ { \ retval.data (ii) = t; \ retval.ridx (ii++) = k; \ @@ -1596,7 +1596,7 @@ } \ else \ { \ - for (octave_idx_type k = ridx(j); k < ridx(j+1); k++) \ + for (octave_idx_type k = ridx (j); k < ridx (j+1); k++) \ { \ retval.data (ii) = t; \ retval.ridx (ii++) = k; \ @@ -1604,7 +1604,7 @@ } \ } \ } \ - retval.cidx(i+1) = ii; \ + retval.cidx (i+1) = ii; \ } \ } \ } \ @@ -1634,7 +1634,7 @@ octave_idx_type jj = 0; \ for (octave_idx_type j = cidx (i); j < cidx (i+1); j++) \ { \ - if (jj == ridx(j)) \ + if (jj == ridx (j)) \ { \ nel++; \ jj++; \ @@ -1644,7 +1644,7 @@ } \ } \ retval = RET_TYPE (nr, nc, nel); \ - retval.cidx(0) = 0; \ + retval.cidx (0) = 0; \ octave_idx_type ii = 0; \ for (octave_idx_type i = 0; i < nc; i++) \ { \ @@ -1652,16 +1652,16 @@ octave_idx_type jj = 0; \ for (octave_idx_type j = cidx (i); j < cidx (i+1); j++) \ { \ - if (jj == ridx(j)) \ + if (jj == ridx (j)) \ { \ - t *= data(j); \ - retval.data(ii) = t; \ - retval.ridx(ii++) = jj++; \ + t *= data (j); \ + retval.data (ii) = t; \ + retval.ridx (ii++) = jj++; \ } \ else \ break; \ } \ - retval.cidx(i+1) = ii; \ + retval.cidx (i+1) = ii; \ } \ } \ } \ @@ -1690,7 +1690,7 @@ tmp[i] = INIT_VAL; \ for (j = 0; j < nc; j++) \ { \ - for (octave_idx_type i = cidx(j); i < cidx(j + 1); i++) \ + for (octave_idx_type i = cidx (j); i < cidx (j + 1); i++) \ { \ ROW_EXPR; \ } \ @@ -1700,14 +1700,14 @@ if (tmp[i] != EL_TYPE ()) \ nel++ ; \ retval = RET_TYPE (nr, static_cast<octave_idx_type> (1), nel); \ - retval.cidx(0) = 0; \ - retval.cidx(1) = nel; \ + retval.cidx (0) = 0; \ + retval.cidx (1) = nel; \ nel = 0; \ for (octave_idx_type i = 0; i < nr; i++) \ if (tmp[i] != EL_TYPE ()) \ { \ - retval.data(nel) = tmp[i]; \ - retval.ridx(nel++) = i; \ + retval.data (nel) = tmp[i]; \ + retval.ridx (nel++) = i; \ } \ } \ else \ @@ -1717,7 +1717,7 @@ for (octave_idx_type j = 0; j < nc; j++) \ { \ tmp[j] = INIT_VAL; \ - for (octave_idx_type i = cidx(j); i < cidx(j + 1); i++) \ + for (octave_idx_type i = cidx (j); i < cidx (j + 1); i++) \ { \ COL_EXPR; \ } \ @@ -1727,17 +1727,17 @@ if (tmp[i] != EL_TYPE ()) \ nel++ ; \ retval = RET_TYPE (static_cast<octave_idx_type> (1), nc, nel); \ - retval.cidx(0) = 0; \ + retval.cidx (0) = 0; \ nel = 0; \ for (octave_idx_type i = 0; i < nc; i++) \ if (tmp[i] != EL_TYPE ()) \ { \ - retval.data(nel) = tmp[i]; \ - retval.ridx(nel++) = 0; \ - retval.cidx(i+1) = retval.cidx(i) + 1; \ + retval.data (nel) = tmp[i]; \ + retval.ridx (nel++) = 0; \ + retval.cidx (i+1) = retval.cidx (i) + 1; \ } \ else \ - retval.cidx(i+1) = retval.cidx(i); \ + retval.cidx (i+1) = retval.cidx (i); \ } \ } \ else if (nc == 0 && (nr == 0 || (nr == 1 && dim == -1))) \ @@ -1747,10 +1747,10 @@ retval = RET_TYPE (static_cast<octave_idx_type> (1), \ static_cast<octave_idx_type> (1), \ static_cast<octave_idx_type> (1)); \ - retval.cidx(0) = 0; \ - retval.cidx(1) = 1; \ - retval.ridx(0) = 0; \ - retval.data(0) = MT_RESULT; \ + retval.cidx (0) = 0; \ + retval.cidx (1) = 1; \ + retval.ridx (0) = 0; \ + retval.data (0) = MT_RESULT; \ } \ else \ retval = RET_TYPE (static_cast<octave_idx_type> (1), \ @@ -1779,12 +1779,12 @@ if (MT_RESULT) \ { \ retval = RET_TYPE (nr, static_cast<octave_idx_type> (1), nr); \ - retval.cidx(0) = 0; \ - retval.cidx(1) = nr; \ + retval.cidx (0) = 0; \ + retval.cidx (1) = nr; \ for (octave_idx_type i = 0; i < nr; i++) \ { \ - retval.ridx(i) = i; \ - retval.data(i) = MT_RESULT; \ + retval.ridx (i) = i; \ + retval.data (i) = MT_RESULT; \ } \ } \ else \ @@ -1797,7 +1797,7 @@ return retval #define SPARSE_REDUCTION_OP_ROW_EXPR(OP) \ - tmp[ridx(i)] OP data (i) + tmp[ridx (i)] OP data (i) #define SPARSE_REDUCTION_OP_COL_EXPR(OP) \ tmp[j] OP data (i) @@ -1814,7 +1814,7 @@ // loop. #define SPARSE_ANY_ALL_OP_ROW_CODE(TEST_OP, TEST_TRUE_VAL) \ if (data (i) TEST_OP 0.0) \ - tmp[ridx(i)] = TEST_TRUE_VAL; \ + tmp[ridx (i)] = TEST_TRUE_VAL; \ #define SPARSE_ANY_ALL_OP_COL_CODE(TEST_OP, TEST_TRUE_VAL) \ if (data (i) TEST_OP 0.0) \ @@ -1834,7 +1834,7 @@ return transpose (). all (0). transpose (); \ else \ { \ - SPARSE_ANY_ALL_OP (DIM, (cidx(j+1) - cidx(j) < nr ? false : true), \ + SPARSE_ANY_ALL_OP (DIM, (cidx (j+1) - cidx (j) < nr ? false : true), \ true, ==, false); \ } @@ -1849,20 +1849,20 @@ \ if (nr == 1 && nc == 1) \ { \ - RET_EL_TYPE s = m.elem(0,0); \ + RET_EL_TYPE s = m.elem (0,0); \ octave_idx_type nz = a.nnz (); \ RET_TYPE r (a_nr, a_nc, nz); \ \ for (octave_idx_type i = 0; i < nz; i++) \ { \ octave_quit (); \ - r.data(i) = s * a.data(i); \ - r.ridx(i) = a.ridx(i); \ + r.data (i) = s * a.data (i); \ + r.ridx (i) = a.ridx (i); \ } \ for (octave_idx_type i = 0; i < a_nc + 1; i++) \ { \ octave_quit (); \ - r.cidx(i) = a.cidx(i); \ + r.cidx (i) = a.cidx (i); \ } \ \ r.maybe_compress (true); \ @@ -1870,20 +1870,20 @@ } \ else if (a_nr == 1 && a_nc == 1) \ { \ - RET_EL_TYPE s = a.elem(0,0); \ + RET_EL_TYPE s = a.elem (0,0); \ octave_idx_type nz = m.nnz (); \ RET_TYPE r (nr, nc, nz); \ \ for (octave_idx_type i = 0; i < nz; i++) \ { \ octave_quit (); \ - r.data(i) = m.data(i) * s; \ - r.ridx(i) = m.ridx(i); \ + r.data (i) = m.data (i) * s; \ + r.ridx (i) = m.ridx (i); \ } \ for (octave_idx_type i = 0; i < nc + 1; i++) \ { \ octave_quit (); \ - r.cidx(i) = m.cidx(i); \ + r.cidx (i) = m.cidx (i); \ } \ \ r.maybe_compress (true); \ @@ -1900,26 +1900,26 @@ RET_TYPE retval (nr, a_nc, static_cast<octave_idx_type> (0)); \ for (octave_idx_type i = 0; i < nr; i++) \ w[i] = 0; \ - retval.xcidx(0) = 0; \ + retval.xcidx (0) = 0; \ \ octave_idx_type nel = 0; \ \ for (octave_idx_type i = 0; i < a_nc; i++) \ { \ - for (octave_idx_type j = a.cidx(i); j < a.cidx(i+1); j++) \ + for (octave_idx_type j = a.cidx (i); j < a.cidx (i+1); j++) \ { \ - octave_idx_type col = a.ridx(j); \ - for (octave_idx_type k = m.cidx(col) ; k < m.cidx(col+1); k++) \ + octave_idx_type col = a.ridx (j); \ + for (octave_idx_type k = m.cidx (col) ; k < m.cidx (col+1); k++) \ { \ - if (w[m.ridx(k)] < i + 1) \ + if (w[m.ridx (k)] < i + 1) \ { \ - w[m.ridx(k)] = i + 1; \ + w[m.ridx (k)] = i + 1; \ nel++; \ } \ octave_quit (); \ } \ } \ - retval.xcidx(i+1) = nel; \ + retval.xcidx (i+1) = nel; \ } \ \ if (nel == 0) \ @@ -1951,57 +1951,57 @@ \ for (octave_idx_type i = 0; i < a_nc ; i++) \ { \ - if (retval.xcidx(i+1) - retval.xcidx(i) > n_per_col) \ + if (retval.xcidx (i+1) - retval.xcidx (i) > n_per_col) \ { \ - for (octave_idx_type j = a.cidx(i); j < a.cidx(i+1); j++) \ + for (octave_idx_type j = a.cidx (i); j < a.cidx (i+1); j++) \ { \ - octave_idx_type col = a.ridx(j); \ - EL_TYPE tmpval = a.data(j); \ - for (octave_idx_type k = m.cidx(col) ; \ - k < m.cidx(col+1); k++) \ + octave_idx_type col = a.ridx (j); \ + EL_TYPE tmpval = a.data (j); \ + for (octave_idx_type k = m.cidx (col) ; \ + k < m.cidx (col+1); k++) \ { \ octave_quit (); \ - octave_idx_type row = m.ridx(k); \ + octave_idx_type row = m.ridx (k); \ if (w[row] < i + 1) \ { \ w[row] = i + 1; \ - Xcol[row] = tmpval * m.data(k); \ + Xcol[row] = tmpval * m.data (k); \ } \ else \ - Xcol[row] += tmpval * m.data(k); \ + Xcol[row] += tmpval * m.data (k); \ } \ } \ for (octave_idx_type k = 0; k < nr; k++) \ if (w[k] == i + 1) \ { \ - retval.xdata(ii) = Xcol[k]; \ - retval.xridx(ii++) = k; \ + retval.xdata (ii) = Xcol[k]; \ + retval.xridx (ii++) = k; \ } \ } \ else \ { \ - for (octave_idx_type j = a.cidx(i); j < a.cidx(i+1); j++) \ + for (octave_idx_type j = a.cidx (i); j < a.cidx (i+1); j++) \ { \ - octave_idx_type col = a.ridx(j); \ - EL_TYPE tmpval = a.data(j); \ - for (octave_idx_type k = m.cidx(col) ; \ - k < m.cidx(col+1); k++) \ + octave_idx_type col = a.ridx (j); \ + EL_TYPE tmpval = a.data (j); \ + for (octave_idx_type k = m.cidx (col) ; \ + k < m.cidx (col+1); k++) \ { \ octave_quit (); \ - octave_idx_type row = m.ridx(k); \ + octave_idx_type row = m.ridx (k); \ if (w[row] < i + 1) \ { \ w[row] = i + 1; \ - retval.xridx(ii++) = row;\ - Xcol[row] = tmpval * m.data(k); \ + retval.xridx (ii++) = row;\ + Xcol[row] = tmpval * m.data (k); \ } \ else \ - Xcol[row] += tmpval * m.data(k); \ + Xcol[row] += tmpval * m.data (k); \ } \ } \ - sort.sort (ri + retval.xcidx(i), ii - retval.xcidx(i)); \ - for (octave_idx_type k = retval.xcidx(i); k < ii; k++) \ - retval.xdata(k) = Xcol[retval.xridx(k)]; \ + sort.sort (ri + retval.xcidx (i), ii - retval.xcidx (i)); \ + for (octave_idx_type k = retval.xcidx (i); k < ii; k++) \ + retval.xdata (k) = Xcol[retval.xridx (k)]; \ } \ } \ retval.maybe_compress (true);\ @@ -2036,9 +2036,9 @@ { \ octave_quit (); \ \ - EL_TYPE tmpval = a.elem(j,i); \ - for (octave_idx_type k = m.cidx(j) ; k < m.cidx(j+1); k++) \ - retval.elem (m.ridx(k),i) += tmpval * m.data(k); \ + EL_TYPE tmpval = a.elem (j,i); \ + for (octave_idx_type k = m.cidx (j) ; k < m.cidx (j+1); k++) \ + retval.elem (m.ridx (k),i) += tmpval * m.data (k); \ } \ } \ return retval; \ @@ -2053,7 +2053,7 @@ \ if (nr == 1 && nc == 1) \ { \ - RET_TYPE retval = CONJ_OP (m.elem(0,0)) * a; \ + RET_TYPE retval = CONJ_OP (m.elem (0,0)) * a; \ return retval; \ } \ else if (nr != a_nr) \ @@ -2072,8 +2072,8 @@ octave_quit (); \ \ EL_TYPE acc = ZERO; \ - for (octave_idx_type k = m.cidx(j) ; k < m.cidx(j+1); k++) \ - acc += a.elem (m.ridx(k),i) * CONJ_OP (m.data(k)); \ + for (octave_idx_type k = m.cidx (j) ; k < m.cidx (j+1); k++) \ + acc += a.elem (m.ridx (k),i) * CONJ_OP (m.data (k)); \ retval.xelem (j,i) = acc; \ } \ } \ @@ -2104,13 +2104,13 @@ for (octave_idx_type i = 0; i < a_nc ; i++) \ { \ octave_quit (); \ - for (octave_idx_type j = a.cidx(i); j < a.cidx(i+1); j++) \ + for (octave_idx_type j = a.cidx (i); j < a.cidx (i+1); j++) \ { \ - octave_idx_type col = a.ridx(j); \ - EL_TYPE tmpval = a.data(j); \ + octave_idx_type col = a.ridx (j); \ + EL_TYPE tmpval = a.data (j); \ \ for (octave_idx_type k = 0 ; k < nr; k++) \ - retval.xelem (k,i) += tmpval * m.elem(k,col); \ + retval.xelem (k,i) += tmpval * m.elem (k,col); \ } \ } \ return retval; \ @@ -2125,7 +2125,7 @@ \ if (a_nr == 1 && a_nc == 1) \ { \ - RET_TYPE retval = m * CONJ_OP (a.elem(0,0)); \ + RET_TYPE retval = m * CONJ_OP (a.elem (0,0)); \ return retval; \ } \ else if (nc != a_nc) \ @@ -2140,12 +2140,12 @@ for (octave_idx_type i = 0; i < a_nc ; i++) \ { \ octave_quit (); \ - for (octave_idx_type j = a.cidx(i); j < a.cidx(i+1); j++) \ + for (octave_idx_type j = a.cidx (i); j < a.cidx (i+1); j++) \ { \ - octave_idx_type col = a.ridx(j); \ - EL_TYPE tmpval = CONJ_OP (a.data(j)); \ + octave_idx_type col = a.ridx (j); \ + EL_TYPE tmpval = CONJ_OP (a.data (j)); \ for (octave_idx_type k = 0 ; k < nr; k++) \ - retval.xelem (k,col) += tmpval * m.elem(k,i); \ + retval.xelem (k,col) += tmpval * m.elem (k,i); \ } \ } \ return retval; \
--- a/liboctave/Sparse-perm-op-defs.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/Sparse-perm-op-defs.h Sat Jul 28 12:06:34 2012 -0400 @@ -43,15 +43,15 @@ { octave_quit (); - OCTAVE_LOCAL_BUFFER (octave_idx_type, sidx, r.xcidx(j+1) - r.xcidx(j)); - for (octave_idx_type i = r.xcidx(j), ii = 0; i < r.xcidx(j+1); i++) + OCTAVE_LOCAL_BUFFER (octave_idx_type, sidx, r.xcidx (j+1) - r.xcidx (j)); + for (octave_idx_type i = r.xcidx (j), ii = 0; i < r.xcidx (j+1); i++) { sidx[ii++]=i; r.xridx (i) = pcol[a.ridx (i)]; } - sort.sort (r.xridx () + r.xcidx(j), sidx, r.xcidx(j+1) - r.xcidx(j)); - for (octave_idx_type i = r.xcidx(j), ii = 0; i < r.xcidx(j+1); i++) - r.xdata(i) = a.data (sidx[ii++]); + sort.sort (r.xridx () + r.xcidx (j), sidx, r.xcidx (j+1) - r.xcidx (j)); + for (octave_idx_type i = r.xcidx (j), ii = 0; i < r.xcidx (j+1); i++) + r.xdata (i) = a.data (sidx[ii++]); } return r; @@ -71,7 +71,7 @@ { // Form the column permutation and then call the colpm_sm routine. const octave_idx_type *prow = p.pvec ().data (); - OCTAVE_LOCAL_BUFFER(octave_idx_type, pcol, nr); + OCTAVE_LOCAL_BUFFER (octave_idx_type, pcol, nr); for (octave_idx_type i = 0; i < nr; ++i) pcol[prow[i]] = i; return octinternal_do_mul_colpm_sm (pcol, a);
--- a/liboctave/Sparse.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/Sparse.cc Sat Jul 28 12:06:34 2012 -0400 @@ -66,12 +66,12 @@ if (a.is_row_perm ()) { for (octave_idx_type i = 0; i < n; i++) - ridx (pv (i)) = i; + ridx (pv(i)) = i; } else { for (octave_idx_type i = 0; i < n; i++) - ridx (i) = pv (i); + ridx (i) = pv(i); } for (octave_idx_type i = 0; i < n; i++) @@ -223,7 +223,7 @@ { rep = new typename Sparse<T>::SparseRep (nr, nc, 0); for (octave_idx_type j = 0; j < nc+1; j++) - xcidx(j) = 0; + xcidx (j) = 0; } } @@ -264,21 +264,21 @@ rep = new typename Sparse<T>::SparseRep (new_nr, new_nc, new_nzmx); octave_idx_type kk = 0; - xcidx(0) = 0; + xcidx (0) = 0; for (octave_idx_type i = 0; i < old_nc; i++) - for (octave_idx_type j = a.cidx(i); j < a.cidx(i+1); j++) + for (octave_idx_type j = a.cidx (i); j < a.cidx (i+1); j++) { - octave_idx_type tmp = i * old_nr + a.ridx(j); + octave_idx_type tmp = i * old_nr + a.ridx (j); octave_idx_type ii = tmp % new_nr; octave_idx_type jj = (tmp - ii) / new_nr; for (octave_idx_type k = kk; k < jj; k++) - xcidx(k+1) = j; + xcidx (k+1) = j; kk = jj; - xdata(j) = a.data(j); - xridx(j) = ii; + xdata (j) = a.data (j); + xridx (j) = ii; } for (octave_idx_type k = kk; k < new_nc; k++) - xcidx(k+1) = new_nzmx; + xcidx (k+1) = new_nzmx; } } @@ -323,11 +323,11 @@ if (n == 1 && a(0) != T ()) { change_capacity (nzm > 1 ? nzm : 1); - xcidx(0) = 0; - xridx(0) = r(0); - xdata(0) = a(0); + xcidx (0) = 0; + xridx (0) = r(0); + xdata (0) = a(0); for (octave_idx_type j = 0; j < nc; j++) - xcidx(j+1) = j >= c(0); + xcidx (j+1) = j >= c(0); } } else if (a_scalar) @@ -419,7 +419,7 @@ sidx[ci[cd[i]+1]++] = rd[i]; // Subsorts. We don't need a stable sort, all values are equal. - xcidx(0) = 0; + xcidx (0) = 0; for (octave_idx_type j = 0; j < nc; j++) { std::sort (sidx + ci[j], sidx + ci[j+1]); @@ -435,7 +435,7 @@ } } // Set column pointer. - xcidx(j+1) = xcidx(j) + nzj; + xcidx (j+1) = xcidx (j) + nzj; } change_capacity (nzm > xcidx (nc) ? nzm : xcidx (nc)); @@ -495,8 +495,8 @@ new_nz += rd[i-1] != rd[i]; // Allocate result. change_capacity (nzm > new_nz ? nzm : new_nz); - xcidx(0) = 0; - xcidx(1) = new_nz; + xcidx (0) = 0; + xcidx (1) = new_nz; octave_idx_type *rri = ridx (); T *rrd = data (); @@ -566,7 +566,7 @@ } // Subsorts. We don't need a stable sort, the second index stabilizes it. - xcidx(0) = 0; + xcidx (0) = 0; for (octave_idx_type j = 0; j < nc; j++) { std::sort (spairs + ci[j], spairs + ci[j+1]); @@ -582,7 +582,7 @@ } } // Set column pointer. - xcidx(j+1) = xcidx(j) + nzj; + xcidx (j+1) = xcidx (j) + nzj; } change_capacity (nzm > xcidx (nc) ? nzm : xcidx (nc)); @@ -652,16 +652,16 @@ rep = new typename Sparse<T>::SparseRep (nr, nc, new_nzmx); octave_idx_type ii = 0; - xcidx(0) = 0; + xcidx (0) = 0; for (octave_idx_type j = 0; j < nc; j++) { for (octave_idx_type i = 0; i < nr; i++) if (a.elem (i,j) != T ()) { - xdata(ii) = a.elem (i,j); - xridx(ii++) = i; + xdata (ii) = a.elem (i,j); + xridx (ii++) = i; } - xcidx(j+1) = ii; + xcidx (j+1) = ii; } } } @@ -833,21 +833,21 @@ retval = Sparse<T> (new_nr, new_nc, new_nnz); octave_idx_type kk = 0; - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (octave_idx_type i = 0; i < old_nc; i++) - for (octave_idx_type j = cidx(i); j < cidx(i+1); j++) + for (octave_idx_type j = cidx (i); j < cidx (i+1); j++) { - octave_idx_type tmp = i * old_nr + ridx(j); + octave_idx_type tmp = i * old_nr + ridx (j); octave_idx_type ii = tmp % new_nr; octave_idx_type jj = (tmp - ii) / new_nr; for (octave_idx_type k = kk; k < jj; k++) - retval.xcidx(k+1) = j; + retval.xcidx (k+1) = j; kk = jj; - retval.xdata(j) = data(j); - retval.xridx(j) = ii; + retval.xdata (j) = data (j); + retval.xridx (j) = ii; } for (octave_idx_type k = kk; k < new_nc; k++) - retval.xcidx(k+1) = new_nnz; + retval.xcidx (k+1) = new_nnz; } else { @@ -949,14 +949,14 @@ octave_idx_type i = 0, k = 0; for (octave_idx_type j = 1; j <= rep->ncols; j++) { - octave_idx_type u = xcidx(j); + octave_idx_type u = xcidx (j); for (i = i; i < u; i++) - if (xridx(i) < r) + if (xridx (i) < r) { - xdata(k) = xdata(i); - xridx(k++) = xridx(i); + xdata (k) = xdata (i); + xridx (k++) = xridx (i); } - xcidx(j) = k; + xcidx (j) = k; } } @@ -994,69 +994,69 @@ } // First count the number of elements in the final array - octave_idx_type nel = cidx(c) + a.nnz (); + octave_idx_type nel = cidx (c) + a.nnz (); if (c + a_cols < nc) - nel += cidx(nc) - cidx(c + a_cols); + nel += cidx (nc) - cidx (c + a_cols); for (octave_idx_type i = c; i < c + a_cols; i++) - for (octave_idx_type j = cidx(i); j < cidx(i+1); j++) - if (ridx(j) < r || ridx(j) >= r + a_rows) + for (octave_idx_type j = cidx (i); j < cidx (i+1); j++) + if (ridx (j) < r || ridx (j) >= r + a_rows) nel++; Sparse<T> tmp (*this); --rep->count; rep = new typename Sparse<T>::SparseRep (nr, nc, nel); - for (octave_idx_type i = 0; i < tmp.cidx(c); i++) + for (octave_idx_type i = 0; i < tmp.cidx (c); i++) { - data(i) = tmp.data(i); - ridx(i) = tmp.ridx(i); + data (i) = tmp.data (i); + ridx (i) = tmp.ridx (i); } for (octave_idx_type i = 0; i < c + 1; i++) - cidx(i) = tmp.cidx(i); + cidx (i) = tmp.cidx (i); - octave_idx_type ii = cidx(c); + octave_idx_type ii = cidx (c); for (octave_idx_type i = c; i < c + a_cols; i++) { octave_quit (); - for (octave_idx_type j = tmp.cidx(i); j < tmp.cidx(i+1); j++) - if (tmp.ridx(j) < r) + for (octave_idx_type j = tmp.cidx (i); j < tmp.cidx (i+1); j++) + if (tmp.ridx (j) < r) { - data(ii) = tmp.data(j); - ridx(ii++) = tmp.ridx(j); + data (ii) = tmp.data (j); + ridx (ii++) = tmp.ridx (j); } octave_quit (); - for (octave_idx_type j = a.cidx(i-c); j < a.cidx(i-c+1); j++) + for (octave_idx_type j = a.cidx (i-c); j < a.cidx (i-c+1); j++) { - data(ii) = a.data(j); - ridx(ii++) = r + a.ridx(j); + data (ii) = a.data (j); + ridx (ii++) = r + a.ridx (j); } octave_quit (); - for (octave_idx_type j = tmp.cidx(i); j < tmp.cidx(i+1); j++) - if (tmp.ridx(j) >= r + a_rows) + for (octave_idx_type j = tmp.cidx (i); j < tmp.cidx (i+1); j++) + if (tmp.ridx (j) >= r + a_rows) { - data(ii) = tmp.data(j); - ridx(ii++) = tmp.ridx(j); + data (ii) = tmp.data (j); + ridx (ii++) = tmp.ridx (j); } - cidx(i+1) = ii; + cidx (i+1) = ii; } for (octave_idx_type i = c + a_cols; i < nc; i++) { - for (octave_idx_type j = tmp.cidx(i); j < tmp.cidx(i+1); j++) + for (octave_idx_type j = tmp.cidx (i); j < tmp.cidx (i+1); j++) { - data(ii) = tmp.data(j); - ridx(ii++) = tmp.ridx(j); + data (ii) = tmp.data (j); + ridx (ii++) = tmp.ridx (j); } - cidx(i+1) = ii; + cidx (i+1) = ii; } return *this; @@ -1100,7 +1100,7 @@ // retval.xcidx[1:nr] holds row entry *start* offsets for rows 0:(nr-1) for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type k = cidx(j); k < cidx(j+1); k++) + for (octave_idx_type k = cidx (j); k < cidx (j+1); k++) { octave_idx_type q = retval.xcidx (ridx (k) + 1)++; retval.xridx (q) = j; @@ -1170,7 +1170,7 @@ copy_or_memcpy (li, tmp.ridx (), xridx ()); copy_or_memcpy (nz - ui, tmp.data () + ui, xdata () + li); mx_inline_sub (nz - ui, xridx () + li, tmp.ridx () + ui, ub - lb); - xcidx(1) = nz_new; + xcidx (1) = nz_new; } else { @@ -1181,11 +1181,11 @@ octave_idx_type sl = sidx.length (nel), nz_new = 0, j = 0; for (octave_idx_type i = 0; i < nz; i++) { - octave_idx_type r = tmp.ridx(i); + octave_idx_type r = tmp.ridx (i); for (;j < sl && sj[j] < r; j++) ; if (j == sl || sj[j] > r) { - data_new[nz_new] = tmp.data(i); + data_new[nz_new] = tmp.data (i); ridx_new[nz_new++] = r - j; } } @@ -1193,7 +1193,7 @@ *this = Sparse<T> (nr - sl, 1, nz_new); copy_or_memcpy (nz_new, ridx_new, ridx ()); copy_or_memcpy (nz_new, data_new, xdata ()); - xcidx(1) = nz_new; + xcidx (1) = nz_new; } } else if (nr == 1) @@ -1203,7 +1203,7 @@ if (idx.is_cont_range (nc, lb, ub)) { const Sparse<T> tmp = *this; - octave_idx_type lbi = tmp.cidx(lb), ubi = tmp.cidx(ub), new_nz = nz - (ubi - lbi); + octave_idx_type lbi = tmp.cidx (lb), ubi = tmp.cidx (ub), new_nz = nz - (ubi - lbi); *this = Sparse<T> (1, nc - (ub - lb), new_nz); copy_or_memcpy (lbi, tmp.data (), data ()); copy_or_memcpy (nz - ubi, tmp.data () + ubi, xdata () + lbi); @@ -1253,7 +1253,7 @@ else { const Sparse<T> tmp = *this; - octave_idx_type lbi = tmp.cidx(lb), ubi = tmp.cidx(ub), + octave_idx_type lbi = tmp.cidx (lb), ubi = tmp.cidx (ub), new_nz = nz - (ubi - lbi); *this = Sparse<T> (nr, nc - (ub - lb), new_nz); @@ -1296,20 +1296,20 @@ tmpl.nnz () + tmpu.nnz ()); for (octave_idx_type j = 0, k = 0; j < nc; j++) { - for (octave_idx_type i = tmpl.cidx(j); i < tmpl.cidx(j+1); + for (octave_idx_type i = tmpl.cidx (j); i < tmpl.cidx (j+1); i++) { - xdata(k) = tmpl.data(i); - xridx(k++) = tmpl.ridx(i); + xdata (k) = tmpl.data (i); + xridx (k++) = tmpl.ridx (i); } - for (octave_idx_type i = tmpu.cidx(j); i < tmpu.cidx(j+1); + for (octave_idx_type i = tmpu.cidx (j); i < tmpu.cidx (j+1); i++) { - xdata(k) = tmpu.data(i); - xridx(k++) = tmpu.ridx(i) + lb; + xdata (k) = tmpu.data (i); + xridx (k++) = tmpu.ridx (i) + lb; } - xcidx(j+1) = k; + xcidx (j+1) = k; } } } @@ -1373,15 +1373,15 @@ for (octave_idx_type i = 0; i < nc; i++) { - for (octave_idx_type j = cidx(i); j < cidx(i+1); j++) + for (octave_idx_type j = cidx (i); j < cidx (i+1); j++) { - retval.xdata(j) = data(j); - retval.xridx(j) = ridx(j) + i * nr; + retval.xdata (j) = data (j); + retval.xridx (j) = ridx (j) + i * nr; } } - retval.xcidx(0) = 0; - retval.xcidx(1) = nz; + retval.xcidx (0) = 0; + retval.xcidx (1) = nz; } } else if (idx.extent (nel) > nel) @@ -1404,7 +1404,7 @@ // then want to make a dense matrix with sparse // representation. Ok, we'll do it, but you deserve what // you get!! - retval = Sparse<T> (idx_dims(0), idx_dims(1), nz ? data(0) : T ()); + retval = Sparse<T> (idx_dims(0), idx_dims(1), nz ? data (0) : T ()); } else if (nc == 1) { @@ -1415,8 +1415,8 @@ { // Scalar index - just a binary lookup. octave_idx_type i = lblookup (ridx (), nz, idx(0)); - if (i < nz && ridx(i) == idx(0)) - retval = Sparse (1, 1, data(i)); + if (i < nz && ridx (i) == idx(0)) + retval = Sparse (1, 1, data (i)); else retval = Sparse (1, 1); } @@ -1431,7 +1431,7 @@ retval = Sparse<T> (ub - lb, 1, nz_new); copy_or_memcpy (nz_new, data () + li, retval.data ()); mx_inline_sub (nz_new, retval.xridx (), ridx () + li, lb); - retval.xcidx(1) = nz_new; + retval.xcidx (1) = nz_new; } else if (idx.is_permutation (nel) && idx.is_vector ()) { @@ -1477,15 +1477,15 @@ for (octave_idx_type i = 0; i < new_nr; i++) { octave_idx_type l = lidx(i, j); - if (l < nz && ridx(l) == idxa(i, j)) + if (l < nz && ridx (l) == idxa(i, j)) nzj++; else lidx(i, j) = nz; } - retval.xcidx(j+1) = retval.xcidx(j) + nzj; + retval.xcidx (j+1) = retval.xcidx (j) + nzj; } - retval.change_capacity (retval.xcidx(new_nc)); + retval.change_capacity (retval.xcidx (new_nc)); // Copy data and set row indices. octave_idx_type k = 0; @@ -1495,8 +1495,8 @@ octave_idx_type l = lidx(i, j); if (l < nz) { - retval.data(k) = data(l); - retval.xridx(k++) = i; + retval.data (k) = data (l); + retval.xridx (k++) = i; } } } @@ -1505,11 +1505,11 @@ { octave_idx_type lb, ub; if (idx.is_scalar ()) - retval = Sparse<T> (1, 1, elem(0, idx(0))); + retval = Sparse<T> (1, 1, elem (0, idx(0))); else if (idx.is_cont_range (nel, lb, ub)) { // Special-case a contiguous range. - octave_idx_type lbi = cidx(lb), ubi = cidx(ub), new_nz = ubi - lbi; + octave_idx_type lbi = cidx (lb), ubi = cidx (ub), new_nz = ubi - lbi; retval = Sparse<T> (1, ub - lb, new_nz); copy_or_memcpy (new_nz, data () + lbi, retval.data ()); fill_or_memset (new_nz, static_cast<octave_idx_type> (0), retval.ridx ()); @@ -1583,7 +1583,7 @@ else if (idx_j.is_cont_range (nc, lb, ub)) { // Special-case a contiguous range. - octave_idx_type lbi = cidx(lb), ubi = cidx(ub), new_nz = ubi - lbi; + octave_idx_type lbi = cidx (lb), ubi = cidx (ub), new_nz = ubi - lbi; retval = Sparse<T> (nr, ub - lb, new_nz); copy_or_memcpy (new_nz, data () + lbi, retval.data ()); copy_or_memcpy (new_nz, ridx () + lbi, retval.ridx ()); @@ -1596,7 +1596,7 @@ for (octave_idx_type j = 0; j < m; j++) { octave_idx_type jj = idx_j(j); - retval.xcidx(j+1) = retval.xcidx(j) + (cidx(jj+1) - cidx(jj)); + retval.xcidx (j+1) = retval.xcidx (j) + (cidx (jj+1) - cidx (jj)); } retval.change_capacity (retval.xcidx (m)); @@ -1604,8 +1604,8 @@ // Copy data & indices. for (octave_idx_type j = 0; j < m; j++) { - octave_idx_type ljj = cidx(idx_j(j)); - octave_idx_type lj = retval.xcidx(j), nzj = retval.xcidx(j+1) - lj; + octave_idx_type ljj = cidx (idx_j(j)); + octave_idx_type lj = retval.xcidx (j), nzj = retval.xcidx (j+1) - lj; copy_or_memcpy (nzj, data () + ljj, retval.data () + lj); copy_or_memcpy (nzj, ridx () + ljj, retval.ridx () + lj); } @@ -1628,28 +1628,28 @@ for (octave_idx_type j = 0; j < m; j++) { octave_quit (); - octave_idx_type jj = idx_j(j), lj = cidx(jj), nzj = cidx(jj+1) - cidx(jj); + octave_idx_type jj = idx_j(j), lj = cidx (jj), nzj = cidx (jj+1) - cidx (jj); // Scalar index - just a binary lookup. octave_idx_type i = lblookup (ridx () + lj, nzj, ii); - if (i < nzj && ridx(i+lj) == ii) + if (i < nzj && ridx (i+lj) == ii) { ij[j] = i + lj; - retval.xcidx(j+1) = retval.xcidx(j) + 1; + retval.xcidx (j+1) = retval.xcidx (j) + 1; } else - retval.xcidx(j+1) = retval.xcidx(j); + retval.xcidx (j+1) = retval.xcidx (j); } - retval.change_capacity (retval.xcidx(m)); + retval.change_capacity (retval.xcidx (m)); // Copy data, adjust row indices. for (octave_idx_type j = 0; j < m; j++) { - octave_idx_type i = retval.xcidx(j); - if (retval.xcidx(j+1) > i) + octave_idx_type i = retval.xcidx (j); + if (retval.xcidx (j+1) > i) { - retval.xridx(i) = 0; - retval.xdata(i) = data(ij[j]); + retval.xridx (i) = 0; + retval.xdata (i) = data (ij[j]); } } } @@ -1661,15 +1661,15 @@ for (octave_idx_type j = 0; j < m; j++) { octave_quit (); - octave_idx_type jj = idx_j(j), lj = cidx(jj), nzj = cidx(jj+1) - cidx(jj); + octave_idx_type jj = idx_j(j), lj = cidx (jj), nzj = cidx (jj+1) - cidx (jj); octave_idx_type lij, uij; // Lookup indices. li[j] = lij = lblookup (ridx () + lj, nzj, lb) + lj; ui[j] = uij = lblookup (ridx () + lj, nzj, ub) + lj; - retval.xcidx(j+1) = retval.xcidx(j) + ui[j] - li[j]; + retval.xcidx (j+1) = retval.xcidx (j) + ui[j] - li[j]; } - retval.change_capacity (retval.xcidx(m)); + retval.change_capacity (retval.xcidx (m)); // Copy data, adjust row indices. for (octave_idx_type j = 0, k = 0; j < m; j++) @@ -1677,8 +1677,8 @@ octave_quit (); for (octave_idx_type i = li[j]; i < ui[j]; i++) { - retval.xdata(k) = data(i); - retval.xridx(k++) = ridx(i) - lb; + retval.xdata (k) = data (i); + retval.xridx (k++) = ridx (i) - lb; } } } @@ -1690,7 +1690,7 @@ for (octave_idx_type j = 0; j < m; j++) { octave_idx_type jj = idx_j(j); - retval.xcidx(j+1) = retval.xcidx(j) + (cidx(jj+1) - cidx(jj)); + retval.xcidx (j+1) = retval.xcidx (j) + (cidx (jj+1) - cidx (jj)); } retval.change_capacity (retval.xcidx (m)); @@ -1703,12 +1703,12 @@ for (octave_idx_type j = 0; j < m; j++) { octave_quit (); - octave_idx_type jj = idx_j(j), lj = cidx(jj), nzj = cidx(jj+1) - cidx(jj); - octave_idx_type li = retval.xcidx(j), uj = lj + nzj - 1; + octave_idx_type jj = idx_j(j), lj = cidx (jj), nzj = cidx (jj+1) - cidx (jj); + octave_idx_type li = retval.xcidx (j), uj = lj + nzj - 1; for (octave_idx_type i = 0; i < nzj; i++) { - retval.xdata(li + i) = data(uj - i); // Copy in reverse order. - retval.xridx(li + i) = nr - 1 - ridx(uj - i); // Ditto with transform. + retval.xdata (li + i) = data (uj - i); // Copy in reverse order. + retval.xridx (li + i) = nr - 1 - ridx (uj - i); // Ditto with transform. } } } @@ -1725,11 +1725,11 @@ for (octave_idx_type j = 0; j < m; j++) { octave_quit (); - octave_idx_type jj = idx_j(j), lj = cidx(jj), nzj = cidx(jj+1) - cidx(jj); - octave_idx_type li = retval.xcidx(j); + octave_idx_type jj = idx_j(j), lj = cidx (jj), nzj = cidx (jj+1) - cidx (jj); + octave_idx_type li = retval.xcidx (j); // Scatter the column, transform indices. for (octave_idx_type i = 0; i < nzj; i++) - scb[rri[li + i] = iinv[ridx(lj + i)]] = data(lj + i); + scb[rri[li + i] = iinv[ridx (lj + i)]] = data (lj + i); octave_quit (); @@ -1738,7 +1738,7 @@ // Gather. for (octave_idx_type i = 0; i < nzj; i++) - retval.xdata(li + i) = scb[rri[li + i]]; + retval.xdata (li + i) = scb[rri[li + i]]; } } @@ -1846,7 +1846,7 @@ copy_or_memcpy (nz - ui, tmp.ridx () + ui, ridx () + li + rnz); } - cidx(1) = new_nz; + cidx (1) = new_nz; } else if (idx.is_range () && idx.increment () == -1) { @@ -1866,7 +1866,7 @@ octave_idx_type iidx = idx(i); octave_idx_type li = lblookup (ri, nz, iidx); if (li != nz && ri[li] == iidx) - xdata(li) = T (); + xdata (li) = T (); } maybe_compress (true); @@ -1985,7 +1985,7 @@ else if (idx_j.is_cont_range (nc, lb, ub)) { // Special-case a contiguous range. - octave_idx_type li = cidx(lb), ui = cidx(ub); + octave_idx_type li = cidx (lb), ui = cidx (ub); octave_idx_type rnz = rhs.nnz (), new_nz = nz - (ui - li) + rnz; if (new_nz >= nz && new_nz <= capacity ()) @@ -2051,36 +2051,36 @@ // Assemble column lengths. for (octave_idx_type i = 0; i < nc; i++) - xcidx(i+1) = tmp.cidx(i+1) - tmp.cidx(i); + xcidx (i+1) = tmp.cidx (i+1) - tmp.cidx (i); for (octave_idx_type i = 0; i < m; i++) { octave_idx_type j =idx_j(i); jsav[j] = i; - xcidx(j+1) = rhs.cidx(i+1) - rhs.cidx(i); + xcidx (j+1) = rhs.cidx (i+1) - rhs.cidx (i); } // Make cumulative. for (octave_idx_type i = 0; i < nc; i++) - xcidx(i+1) += xcidx(i); + xcidx (i+1) += xcidx (i); change_capacity (nnz ()); // Merge columns. for (octave_idx_type i = 0; i < nc; i++) { - octave_idx_type l = xcidx(i), u = xcidx(i+1), j = jsav[i]; + octave_idx_type l = xcidx (i), u = xcidx (i+1), j = jsav[i]; if (j >= 0) { // from rhs - octave_idx_type k = rhs.cidx(j); + octave_idx_type k = rhs.cidx (j); copy_or_memcpy (u - l, rhs.data () + k, xdata () + l); copy_or_memcpy (u - l, rhs.ridx () + k, xridx () + l); } else { // original - octave_idx_type k = tmp.cidx(i); + octave_idx_type k = tmp.cidx (i); copy_or_memcpy (u - l, tmp.data () + k, xdata () + l); copy_or_memcpy (u - l, tmp.ridx () + k, xridx () + l); } @@ -2183,26 +2183,26 @@ for (octave_idx_type j = 0; j < nc; j++) { - octave_idx_type ns = mcidx [j + 1] - mcidx [j]; + octave_idx_type ns = mcidx[j + 1] - mcidx[j]; lsort.sort (v, ns); octave_idx_type i; if (mode == ASCENDING) { for (i = 0; i < ns; i++) - if (sparse_ascending_compare<T> (static_cast<T> (0), v [i])) + if (sparse_ascending_compare<T> (static_cast<T> (0), v[i])) break; } else { for (i = 0; i < ns; i++) - if (sparse_descending_compare<T> (static_cast<T> (0), v [i])) + if (sparse_descending_compare<T> (static_cast<T> (0), v[i])) break; } for (octave_idx_type k = 0; k < i; k++) - mridx [k] = k; + mridx[k] = k; for (octave_idx_type k = i; k < ns; k++) - mridx [k] = k - ns + nr; + mridx[k] = k - ns + nr; v += ns; mridx += ns; @@ -2255,7 +2255,7 @@ for (octave_idx_type j = 0; j < nc; j++) { - octave_idx_type ns = mcidx [j + 1] - mcidx [j]; + octave_idx_type ns = mcidx[j + 1] - mcidx[j]; octave_idx_type offset = j * nr; if (ns == 0) @@ -2296,14 +2296,14 @@ for (octave_idx_type k = 0; k < i; k++) { - sidx (k + offset) = vi [k]; - mridx [k] = k; + sidx (k + offset) = vi[k]; + mridx[k] = k; } for (octave_idx_type k = i; k < ns; k++) { - sidx (k - ns + nr + offset) = vi [k]; - mridx [k] = k - ns + nr; + sidx (k - ns + nr + offset) = vi[k]; + mridx[k] = k - ns + nr; } v += ns; @@ -2437,12 +2437,12 @@ for (octave_idx_type j = 0; j < nnc; j++) { - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { d.xdata (i) = data (i); d.xridx (i) = j + roff; } - d.xcidx (j + coff + 1) = cidx(j+1); + d.xcidx (j + coff + 1) = cidx (j+1); } for (octave_idx_type i = nnc + coff + 1; i < n + 1; i++) @@ -2459,7 +2459,7 @@ if (nnz () > 0) { octave_idx_type ii = 0; - octave_idx_type ir = ridx(0); + octave_idx_type ir = ridx (0); for (octave_idx_type i = 0; i < coff+1; i++) d.xcidx (i) = 0; @@ -2545,17 +2545,17 @@ if (spi.is_empty ()) continue; - octave_idx_type kl = spi.cidx(j), ku = spi.cidx(j+1); + octave_idx_type kl = spi.cidx (j), ku = spi.cidx (j+1); for (octave_idx_type k = kl; k < ku; k++, l++) { - retval.xridx(l) = spi.ridx(k) + rcum; - retval.xdata(l) = spi.data(k); + retval.xridx (l) = spi.ridx (k) + rcum; + retval.xdata (l) = spi.data (k); } rcum += spi.rows (); } - retval.xcidx(j+1) = l; + retval.xcidx (j+1) = l; } break; @@ -2595,15 +2595,15 @@ octave_idx_type i = 0; for (octave_idx_type j = 0, nc = cols (); j < nc; j++) { - if (cidx(j+1) > i) + if (cidx (j+1) > i) retval(j) = data (i++); } } else { for (octave_idx_type j = 0, nc = cols (); j < nc; j++) - for (octave_idx_type i = cidx(j), iu = cidx(j+1); i < iu; i++) - retval(ridx(i), j) = data (i); + for (octave_idx_type i = cidx (j), iu = cidx (j+1); i < iu; i++) + retval(ridx (i), j) = data (i); } return retval; @@ -2643,12 +2643,12 @@ %! x = ones (size); %! s = set_slice (sparse (x), dim, slice); %! f = set_slice (x, dim, slice); -%! assert (nnz(s), nnz(f)); -%! assert (full(s), f); -%! s = set_slice2 (sparse(x), dim, slice); +%! assert (nnz (s), nnz (f)); +%! assert (full (s), f); +%! s = set_slice2 (sparse (x), dim, slice); %! f = set_slice2 (x, dim, slice); -%! assert (nnz(s), nnz(f)); -%! assert (full(s), f); +%! assert (nnz (s), nnz (f)); +%! assert (full (s), f); %!endfunction #### 1d indexing @@ -2780,7 +2780,7 @@ %! assert (s, sparse (magic (5)(:, [1,5]))); %!test -%! s = sparse([], [], [], 1, 1); +%! s = sparse ([], [], [], 1, 1); %! s(1,:) = []; %! assert (s, sparse ([], [], [], 0, 1));
--- a/liboctave/Sparse.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/Sparse.h Sat Jul 28 12:06:34 2012 -0400 @@ -111,7 +111,7 @@ octave_idx_type length (void) const { return nzmx; } - octave_idx_type nnz (void) const { return c [ncols]; } + octave_idx_type nnz (void) const { return c[ncols]; } T& elem (octave_idx_type _r, octave_idx_type _c); @@ -268,7 +268,7 @@ octave_idx_type get_col_index (octave_idx_type k) { octave_idx_type ret = 0; - while (cidx(ret+1) < k) + while (cidx (ret+1) < k) ret++; return ret; } @@ -599,11 +599,11 @@ result = Sparse<U> (nr, nc, f_zero); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx (j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_quit (); /* Use data instead of elem for better performance. */ - result.data (ridx (i) + j * nr) = fcn (data(i)); + result.data (ridx (i) + j * nr) = fcn (data (i)); } result.maybe_compress (true); @@ -620,7 +620,7 @@ for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = cidx(j); i < cidx (j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { U val = fcn (data (i)); if (val != 0.0) @@ -709,7 +709,7 @@ else if (jtmp > jold) { for (octave_idx_type j = jold; j < jtmp; j++) - a.cidx(j+1) = ii; + a.cidx (j+1) = ii; } else if (itmp < iold) { @@ -734,7 +734,7 @@ } for (octave_idx_type j = jold; j < nc; j++) - a.cidx(j+1) = ii; + a.cidx (j+1) = ii; } done:
--- a/liboctave/SparseCmplxCHOL.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/SparseCmplxCHOL.cc Sat Jul 28 12:06:34 2012 -0400 @@ -51,12 +51,12 @@ if (typ == MatrixType::Upper) { - rinv = r.inverse(mattype, info, rcond, true, false); + rinv = r.inverse (mattype, info, rcond, true, false); retval = rinv.transpose () * rinv; } else if (typ == MatrixType::Lower) { - rinv = r.transpose ().inverse(mattype, info, rcond, true, false); + rinv = r.transpose ().inverse (mattype, info, rcond, true, false); retval = rinv.transpose () * rinv; } else
--- a/liboctave/SparseCmplxLU.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/SparseCmplxLU.cc Sat Jul 28 12:06:34 2012 -0400 @@ -326,7 +326,7 @@ OCTAVE_LOCAL_BUFFER (octave_idx_type, qinit, nc); for (octave_idx_type i = 0; i < nc; i++) - qinit [i] = static_cast<octave_idx_type> (Qinit (i)); + qinit[i] = static_cast<octave_idx_type> (Qinit (i)); status = UMFPACK_ZNAME (qsymbolic) (nr, nc, Ap, Ai, reinterpret_cast<const double *> (Ax),
--- a/liboctave/SparseCmplxQR.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/SparseCmplxQR.cc Sat Jul 28 12:06:34 2012 -0400 @@ -69,7 +69,7 @@ (a.data ())); A.nz = -1; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) S = CXSPARSE_ZNAME (_sqr) (order, &A, 1); #else S = CXSPARSE_ZNAME (_sqr) (&A, order - 1, 1); @@ -130,10 +130,10 @@ #ifdef HAVE_CXSPARSE ColumnVector ret(N->L->m); for (octave_idx_type i = 0; i < N->L->m; i++) -#if defined(CS_VER) && (CS_VER >= 2) - ret.xelem(i) = S->pinv[i]; +#if defined (CS_VER) && (CS_VER >= 2) + ret.xelem (i) = S->pinv[i]; #else - ret.xelem(i) = S->Pinv[i]; + ret.xelem (i) = S->Pinv[i]; #endif return ret; #else @@ -147,10 +147,10 @@ #ifdef HAVE_CXSPARSE ColumnVector ret(N->L->m); for (octave_idx_type i = 0; i < N->L->m; i++) -#if defined(CS_VER) && (CS_VER >= 2) - ret.xelem(S->pinv[i]) = i; +#if defined (CS_VER) && (CS_VER >= 2) + ret.xelem (S->pinv[i]) = i; #else - ret.xelem(S->Pinv[i]) = i; + ret.xelem (S->Pinv[i]) = i; #endif return ret; #else @@ -212,7 +212,7 @@ octave_quit (); volatile octave_idx_type nm = (nr < nc ? nr : nc); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (S->pinv, bvec + idx, reinterpret_cast<cs_complex_t *>(buf), b_nr); #else @@ -262,7 +262,7 @@ bvec[j] = OCTAVE_C99_ONE; volatile octave_idx_type nm = (nr < nc ? nr : nc); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (S->pinv, bvec, reinterpret_cast<cs_complex_t *>(buf), nr); #else @@ -290,7 +290,7 @@ } ComplexMatrix -qrsolve(const SparseComplexMatrix&a, const Matrix &b, octave_idx_type &info) +qrsolve (const SparseComplexMatrix&a, const Matrix &b, octave_idx_type &info) { info = -1; #ifdef HAVE_CXSPARSE @@ -310,7 +310,7 @@ SparseComplexQR q (a, 2); if (! q.ok ()) return ComplexMatrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); cs_complex_t *vec = reinterpret_cast<cs_complex_t *> (x.fortran_vec ()); OCTAVE_C99_COMPLEX (buf, q.S ()->m2); @@ -319,11 +319,11 @@ { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->pinv, reinterpret_cast<cs_complex_t *>(Xx), buf, nr); #else @@ -340,7 +340,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_ZNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->q, buf, vec + idx, nc); #else CXSPARSE_ZNAME (_ipvec) (nc, q.S ()->Q, buf, vec + idx); @@ -355,30 +355,30 @@ SparseComplexQR q (at, 2); if (! q.ok ()) return ComplexMatrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); cs_complex_t *vec = reinterpret_cast<cs_complex_t *> (x.fortran_vec ()); volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); OCTAVE_C99_COMPLEX (buf, nbuf); OCTAVE_LOCAL_BUFFER (Complex, Xx, b_nr); -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) OCTAVE_LOCAL_BUFFER (double, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = q.N ()->B [i]; + B[i] = q.N ()->B[i]; #else OCTAVE_LOCAL_BUFFER (Complex, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B) [i]); + B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B)[i]); #endif for (volatile octave_idx_type i = 0, idx = 0; i < b_nc; i++, idx+=nc) { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->q, reinterpret_cast<cs_complex_t *>(Xx), buf, nr); #else @@ -392,7 +392,7 @@ octave_quit (); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) CXSPARSE_ZNAME (_happly) (q.N ()->L, j, B[j], buf); #else CXSPARSE_ZNAME (_happly) @@ -401,7 +401,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->pinv, buf, vec + idx, nc); #else CXSPARSE_ZNAME (_pvec) (nc, q.S ()->Pinv, buf, vec + idx); @@ -418,7 +418,7 @@ } SparseComplexMatrix -qrsolve(const SparseComplexMatrix&a, const SparseMatrix &b, octave_idx_type &info) +qrsolve (const SparseComplexMatrix&a, const SparseMatrix &b, octave_idx_type &info) { info = -1; #ifdef HAVE_CXSPARSE @@ -440,7 +440,7 @@ if (! q.ok ()) return SparseComplexMatrix (); x = SparseComplexMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; OCTAVE_LOCAL_BUFFER (Complex, Xx, (b_nr > nc ? b_nr : nc)); @@ -449,11 +449,11 @@ { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->pinv, reinterpret_cast<cs_complex_t *>(Xx), buf, nr); #else @@ -470,7 +470,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_ZNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->q, buf, reinterpret_cast<cs_complex_t *>(Xx), nc); #else @@ -492,11 +492,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; } @@ -507,31 +507,31 @@ if (! q.ok ()) return SparseComplexMatrix (); x = SparseComplexMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); OCTAVE_LOCAL_BUFFER (Complex, Xx, (b_nr > nc ? b_nr : nc)); OCTAVE_C99_COMPLEX (buf, nbuf); -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) OCTAVE_LOCAL_BUFFER (double, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = q.N ()->B [i]; + B[i] = q.N ()->B[i]; #else OCTAVE_LOCAL_BUFFER (Complex, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B) [i]); + B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B)[i]); #endif for (volatile octave_idx_type i = 0, idx = 0; i < b_nc; i++, idx+=nc) { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->q, reinterpret_cast<cs_complex_t *>(Xx), buf, nr); #else @@ -544,7 +544,7 @@ { octave_quit (); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) CXSPARSE_ZNAME (_happly) (q.N ()->L, j, B[j], buf); #else CXSPARSE_ZNAME (_happly) @@ -553,7 +553,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->pinv, buf, reinterpret_cast<cs_complex_t *>(Xx), nc); #else @@ -575,11 +575,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; } @@ -592,7 +592,7 @@ } ComplexMatrix -qrsolve(const SparseComplexMatrix&a, const ComplexMatrix &b, octave_idx_type &info) +qrsolve (const SparseComplexMatrix&a, const ComplexMatrix &b, octave_idx_type &info) { info = -1; #ifdef HAVE_CXSPARSE @@ -614,7 +614,7 @@ SparseComplexQR q (a, 2); if (! q.ok ()) return ComplexMatrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); cs_complex_t *vec = reinterpret_cast<cs_complex_t *> (x.fortran_vec ()); OCTAVE_C99_COMPLEX (buf, q.S ()->m2); @@ -625,7 +625,7 @@ for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->pinv, bvec + bidx, buf, nr); #else CXSPARSE_ZNAME (_ipvec) (nr, q.S ()->Pinv, bvec + bidx, buf); @@ -640,7 +640,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_ZNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->q, buf, vec + idx, nc); #else CXSPARSE_ZNAME (_ipvec) (nc, q.S ()->Q, buf, vec + idx); @@ -655,19 +655,19 @@ SparseComplexQR q (at, 2); if (! q.ok ()) return ComplexMatrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); cs_complex_t *vec = reinterpret_cast<cs_complex_t *> (x.fortran_vec ()); volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); OCTAVE_C99_COMPLEX (buf, nbuf); -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) OCTAVE_LOCAL_BUFFER (double, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = q.N ()->B [i]; + B[i] = q.N ()->B[i]; #else OCTAVE_LOCAL_BUFFER (Complex, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B) [i]); + B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B)[i]); #endif for (volatile octave_idx_type i = 0, idx = 0, bidx = 0; i < b_nc; i++, idx+=nc, bidx+=b_nr) @@ -676,7 +676,7 @@ for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->q, bvec + bidx, buf, nr); #else CXSPARSE_ZNAME (_pvec) (nr, q.S ()->Q, bvec + bidx, buf); @@ -687,7 +687,7 @@ { octave_quit (); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) CXSPARSE_ZNAME (_happly) (q.N ()->L, j, B[j], buf); #else CXSPARSE_ZNAME (_happly) @@ -696,7 +696,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->pinv, buf, vec + idx, nc); #else CXSPARSE_ZNAME (_pvec) (nc, q.S ()->Pinv, buf, vec + idx); @@ -713,7 +713,7 @@ } SparseComplexMatrix -qrsolve(const SparseComplexMatrix&a, const SparseComplexMatrix &b, octave_idx_type &info) +qrsolve (const SparseComplexMatrix&a, const SparseComplexMatrix &b, octave_idx_type &info) { info = -1; #ifdef HAVE_CXSPARSE @@ -735,7 +735,7 @@ if (! q.ok ()) return SparseComplexMatrix (); x = SparseComplexMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; OCTAVE_LOCAL_BUFFER (Complex, Xx, (b_nr > nc ? b_nr : nc)); @@ -744,11 +744,11 @@ { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->pinv, reinterpret_cast<cs_complex_t *>(Xx), buf, nr); #else @@ -765,7 +765,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_ZNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_ipvec) (q.S ()->q, buf, reinterpret_cast<cs_complex_t *>(Xx), nc); #else @@ -787,11 +787,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; } @@ -802,30 +802,30 @@ if (! q.ok ()) return SparseComplexMatrix (); x = SparseComplexMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); OCTAVE_LOCAL_BUFFER (Complex, Xx, (b_nr > nc ? b_nr : nc)); OCTAVE_C99_COMPLEX (buf, nbuf); -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) OCTAVE_LOCAL_BUFFER (double, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = q.N ()->B [i]; + B[i] = q.N ()->B[i]; #else OCTAVE_LOCAL_BUFFER (Complex, B, nr); for (octave_idx_type i = 0; i < nr; i++) - B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B) [i]); + B[i] = conj (reinterpret_cast<Complex *>(q.N ()->B)[i]); #endif for (volatile octave_idx_type i = 0, idx = 0; i < b_nc; i++, idx+=nc) { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = OCTAVE_C99_ZERO; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->q, reinterpret_cast<cs_complex_t *>(Xx), buf, nr); #else @@ -838,7 +838,7 @@ { octave_quit (); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) +#if defined (CS_VER) && (((CS_VER == 2) && (CS_SUBVER >= 2)) || (CS_VER > 2)) CXSPARSE_ZNAME (_happly) (q.N ()->L, j, B[j], buf); #else CXSPARSE_ZNAME (_happly) @@ -847,7 +847,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_ZNAME (_pvec) (q.S ()->pinv, buf, reinterpret_cast<cs_complex_t *>(Xx), nc); #else @@ -869,11 +869,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; }
--- a/liboctave/SparseQR.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/SparseQR.cc Sat Jul 28 12:06:34 2012 -0400 @@ -48,7 +48,7 @@ A.x = const_cast<double *>(a.data ()); A.nz = -1; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) S = CXSPARSE_DNAME (_sqr) (order, &A, 1); #else S = CXSPARSE_DNAME (_sqr) (&A, order - 1, 1); @@ -110,10 +110,10 @@ #ifdef HAVE_CXSPARSE ColumnVector ret(N->L->m); for (octave_idx_type i = 0; i < N->L->m; i++) -#if defined(CS_VER) && (CS_VER >= 2) - ret.xelem(i) = S->pinv[i]; +#if defined (CS_VER) && (CS_VER >= 2) + ret.xelem (i) = S->pinv[i]; #else - ret.xelem(i) = S->Pinv[i]; + ret.xelem (i) = S->Pinv[i]; #endif return ret; #else @@ -127,10 +127,10 @@ #ifdef HAVE_CXSPARSE ColumnVector ret(N->L->m); for (octave_idx_type i = 0; i < N->L->m; i++) -#if defined(CS_VER) && (CS_VER >= 2) - ret.xelem(S->pinv[i]) = i; +#if defined (CS_VER) && (CS_VER >= 2) + ret.xelem (S->pinv[i]) = i; #else - ret.xelem(S->Pinv[i]) = i; + ret.xelem (S->Pinv[i]) = i; #endif return ret; #else @@ -195,7 +195,7 @@ buf[i] = 0.; volatile octave_idx_type nm = (nr < nc ? nr : nc); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (S->pinv, bvec + idx, buf, b_nr); #else CXSPARSE_DNAME (_ipvec) (b_nr, S->Pinv, bvec + idx, buf); @@ -245,7 +245,7 @@ buf[i] = 0.; volatile octave_idx_type nm = (nr < nc ? nr : nc); BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (S->pinv, bvec, buf, nr); #else CXSPARSE_DNAME (_ipvec) (nr, S->Pinv, bvec, buf); @@ -271,7 +271,7 @@ } Matrix -qrsolve(const SparseMatrix&a, const Matrix &b, octave_idx_type& info) +qrsolve (const SparseMatrix&a, const Matrix &b, octave_idx_type& info) { info = -1; #ifdef HAVE_CXSPARSE @@ -292,7 +292,7 @@ SparseQR q (a, 3); if (! q.ok ()) return Matrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); double *vec = x.fortran_vec (); OCTAVE_LOCAL_BUFFER (double, buf, q.S ()->m2); for (volatile octave_idx_type i = 0, idx = 0, bidx = 0; i < b_nc; @@ -302,7 +302,7 @@ for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->pinv, bvec + bidx, buf, nr); #else CXSPARSE_DNAME (_ipvec) (nr, q.S ()->Pinv, bvec + bidx, buf); @@ -317,7 +317,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_DNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->q, buf, vec + idx, nc); #else CXSPARSE_DNAME (_ipvec) (nc, q.S ()->Q, buf, vec + idx); @@ -332,7 +332,7 @@ SparseQR q (at, 3); if (! q.ok ()) return Matrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); double *vec = x.fortran_vec (); volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); OCTAVE_LOCAL_BUFFER (double, buf, nbuf); @@ -343,7 +343,7 @@ for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->q, bvec + bidx, buf, nr); #else CXSPARSE_DNAME (_pvec) (nr, q.S ()->Q, bvec + bidx, buf); @@ -358,7 +358,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->pinv, buf, vec + idx, nc); #else CXSPARSE_DNAME (_pvec) (nc, q.S ()->Pinv, buf, vec + idx); @@ -375,7 +375,7 @@ } SparseMatrix -qrsolve(const SparseMatrix&a, const SparseMatrix &b, octave_idx_type &info) +qrsolve (const SparseMatrix&a, const SparseMatrix &b, octave_idx_type &info) { info = -1; #ifdef HAVE_CXSPARSE @@ -397,7 +397,7 @@ if (! q.ok ()) return SparseMatrix (); x = SparseMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; OCTAVE_LOCAL_BUFFER (double, Xx, (b_nr > nc ? b_nr : nc)); @@ -406,11 +406,11 @@ { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->pinv, Xx, buf, nr); #else CXSPARSE_DNAME (_ipvec) (nr, q.S ()->Pinv, Xx, buf); @@ -425,7 +425,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_DNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->q, buf, Xx, nc); #else CXSPARSE_DNAME (_ipvec) (nc, q.S ()->Q, buf, Xx); @@ -445,11 +445,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; } @@ -460,7 +460,7 @@ if (! q.ok ()) return SparseMatrix (); x = SparseMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); @@ -470,11 +470,11 @@ { octave_quit (); for (octave_idx_type j = 0; j < b_nr; j++) - Xx[j] = b.xelem(j,i); + Xx[j] = b.xelem (j,i); for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->q, Xx, buf, nr); #else CXSPARSE_DNAME (_pvec) (nr, q.S ()->Q, Xx, buf); @@ -489,7 +489,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->pinv, buf, Xx, nc); #else CXSPARSE_DNAME (_pvec) (nc, q.S ()->Pinv, buf, Xx); @@ -509,11 +509,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; } @@ -526,7 +526,7 @@ } ComplexMatrix -qrsolve(const SparseMatrix&a, const ComplexMatrix &b, octave_idx_type &info) +qrsolve (const SparseMatrix&a, const ComplexMatrix &b, octave_idx_type &info) { info = -1; #ifdef HAVE_CXSPARSE @@ -546,7 +546,7 @@ SparseQR q (a, 3); if (! q.ok ()) return ComplexMatrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); Complex *vec = x.fortran_vec (); OCTAVE_LOCAL_BUFFER (double, Xx, (b_nr > nc ? b_nr : nc)); OCTAVE_LOCAL_BUFFER (double, Xz, (b_nr > nc ? b_nr : nc)); @@ -563,7 +563,7 @@ for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->pinv, Xx, buf, nr); #else CXSPARSE_DNAME (_ipvec) (nr, q.S ()->Pinv, Xx, buf); @@ -578,14 +578,14 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_DNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->q, buf, Xx, nc); #else CXSPARSE_DNAME (_ipvec) (nc, q.S ()->Q, buf, Xx); #endif for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = 0.; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->pinv, Xz, buf, nr); #else CXSPARSE_DNAME (_ipvec) (nr, q.S ()->Pinv, Xz, buf); @@ -600,7 +600,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_DNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->q, buf, Xz, nc); #else CXSPARSE_DNAME (_ipvec) (nc, q.S ()->Q, buf, Xz); @@ -617,7 +617,7 @@ SparseQR q (at, 3); if (! q.ok ()) return ComplexMatrix (); - x.resize(nc, b_nc); + x.resize (nc, b_nc); Complex *vec = x.fortran_vec (); volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); OCTAVE_LOCAL_BUFFER (double, Xx, (b_nr > nc ? b_nr : nc)); @@ -635,7 +635,7 @@ for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->q, Xx, buf, nr); #else CXSPARSE_DNAME (_pvec) (nr, q.S ()->Q, Xx, buf); @@ -650,7 +650,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->pinv, buf, Xx, nc); #else CXSPARSE_DNAME (_pvec) (nc, q.S ()->Pinv, buf, Xx); @@ -659,7 +659,7 @@ for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->q, Xz, buf, nr); #else CXSPARSE_DNAME (_pvec) (nr, q.S ()->Q, Xz, buf); @@ -674,7 +674,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->pinv, buf, Xz, nc); #else CXSPARSE_DNAME (_pvec) (nc, q.S ()->Pinv, buf, Xz); @@ -693,7 +693,7 @@ } SparseComplexMatrix -qrsolve(const SparseMatrix&a, const SparseComplexMatrix &b, octave_idx_type &info) +qrsolve (const SparseMatrix&a, const SparseComplexMatrix &b, octave_idx_type &info) { info = -1; #ifdef HAVE_CXSPARSE @@ -715,7 +715,7 @@ if (! q.ok ()) return SparseComplexMatrix (); x = SparseComplexMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; OCTAVE_LOCAL_BUFFER (double, Xx, (b_nr > nc ? b_nr : nc)); @@ -733,7 +733,7 @@ for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->pinv, Xx, buf, nr); #else CXSPARSE_DNAME (_ipvec) (nr, q.S ()->Pinv, Xx, buf); @@ -748,7 +748,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_DNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->q, buf, Xx, nc); #else CXSPARSE_DNAME (_ipvec) (nc, q.S ()->Q, buf, Xx); @@ -757,7 +757,7 @@ for (octave_idx_type j = nr; j < q.S ()->m2; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->pinv, Xz, buf, nr); #else CXSPARSE_DNAME (_ipvec) (nr, q.S ()->Pinv, Xz, buf); @@ -772,7 +772,7 @@ } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; CXSPARSE_DNAME (_usolve) (q.N ()->U, buf); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_ipvec) (q.S ()->q, buf, Xz, nc); #else CXSPARSE_DNAME (_ipvec) (nc, q.S ()->Q, buf, Xz); @@ -792,11 +792,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; } @@ -807,7 +807,7 @@ if (! q.ok ()) return SparseComplexMatrix (); x = SparseComplexMatrix (nc, b_nc, b.nnz ()); - x.xcidx(0) = 0; + x.xcidx (0) = 0; x_nz = b.nnz (); ii = 0; volatile octave_idx_type nbuf = (nc > q.S ()->m2 ? nc : q.S ()->m2); @@ -826,7 +826,7 @@ for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->q, Xx, buf, nr); #else CXSPARSE_DNAME (_pvec) (nr, q.S ()->Q, Xx, buf); @@ -841,7 +841,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->pinv, buf, Xx, nc); #else CXSPARSE_DNAME (_pvec) (nc, q.S ()->Pinv, buf, Xx); @@ -850,7 +850,7 @@ for (octave_idx_type j = nr; j < nbuf; j++) buf[j] = 0.; BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->q, Xz, buf, nr); #else CXSPARSE_DNAME (_pvec) (nr, q.S ()->Q, Xz, buf); @@ -865,7 +865,7 @@ END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (_pvec) (q.S ()->pinv, buf, Xz, nc); #else CXSPARSE_DNAME (_pvec) (nc, q.S ()->Pinv, buf, Xz); @@ -885,11 +885,11 @@ x.change_capacity (sz); x_nz = sz; } - x.xdata(ii) = tmp; - x.xridx(ii++) = j; + x.xdata (ii) = tmp; + x.xridx (ii++) = j; } } - x.xcidx(i+1) = ii; + x.xcidx (i+1) = ii; } info = 0; } @@ -902,15 +902,15 @@ } Matrix -qrsolve(const SparseMatrix &a, const MArray<double> &b, - octave_idx_type &info) +qrsolve (const SparseMatrix &a, const MArray<double> &b, + octave_idx_type &info) { return qrsolve (a, Matrix (b), info); } ComplexMatrix -qrsolve(const SparseMatrix &a, const MArray<Complex> &b, - octave_idx_type &info) +qrsolve (const SparseMatrix &a, const MArray<Complex> &b, + octave_idx_type &info) { return qrsolve (a, ComplexMatrix (b), info); }
--- a/liboctave/SparsedbleCHOL.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/SparsedbleCHOL.cc Sat Jul 28 12:06:34 2012 -0400 @@ -51,12 +51,12 @@ if (typ == MatrixType::Upper) { - rinv = r.inverse(mattype, info, rcond, true, false); + rinv = r.inverse (mattype, info, rcond, true, false); retval = rinv.transpose () * rinv; } else if (typ == MatrixType::Lower) { - rinv = r.transpose ().inverse(mattype, info, rcond, true, false); + rinv = r.transpose ().inverse (mattype, info, rcond, true, false); retval = rinv.transpose () * rinv; } else
--- a/liboctave/SparsedbleLU.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/SparsedbleLU.cc Sat Jul 28 12:06:34 2012 -0400 @@ -311,7 +311,7 @@ OCTAVE_LOCAL_BUFFER (octave_idx_type, qinit, nc); for (octave_idx_type i = 0; i < nc; i++) - qinit [i] = static_cast<octave_idx_type> (Qinit (i)); + qinit[i] = static_cast<octave_idx_type> (Qinit (i)); status = UMFPACK_DNAME (qsymbolic) (nr, nc, Ap, Ai, Ax, qinit, &Symbolic, control, info);
--- a/liboctave/boolSparse.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/boolSparse.cc Sat Jul 28 12:06:34 2012 -0400 @@ -55,11 +55,11 @@ return false; for (octave_idx_type i = 0; i < nc + 1; i++) - if (cidx(i) != a.cidx(i)) + if (cidx (i) != a.cidx (i)) return false; for (octave_idx_type i = 0; i < nz; i++) - if (data(i) != a.data(i) || ridx(i) != a.ridx(i)) + if (data (i) != a.data (i) || ridx (i) != a.ridx (i)) return false; return true; @@ -113,12 +113,12 @@ { for (octave_idx_type j = 0; j < nr; j++) { - if (jj < cidx(i+1) && ridx(jj) == j) + if (jj < cidx (i+1) && ridx (jj) == j) jj++; else { - r.data(ii) = true; - r.ridx(ii++) = j; + r.data (ii) = true; + r.ridx (ii++) = j; } } r.cidx (i+1) = ii; @@ -150,10 +150,10 @@ { // Result is a row vector. retval = Sparse<bool> (1, nc); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (octave_idx_type i = 0; i < nc; i++) - retval.xcidx(i+1) = retval.xcidx(i) + (cidx(i+1) > cidx(i)); - octave_idx_type new_nz = retval.xcidx(nc); + retval.xcidx (i+1) = retval.xcidx (i) + (cidx (i+1) > cidx (i)); + octave_idx_type new_nz = retval.xcidx (nc); retval.change_capacity (new_nz); fill_or_memset (new_nz, static_cast<octave_idx_type> (0), retval.ridx ()); fill_or_memset (new_nz, true, retval.data ()); @@ -166,7 +166,7 @@ // We can use O(nr) memory. Array<bool> tmp (dim_vector (nr, 1), false); for (octave_idx_type i = 0; i < nz; i++) - tmp.xelem(ridx(i)) = true; + tmp.xelem (ridx (i)) = true; retval = tmp; } else @@ -195,16 +195,16 @@ { // Result is a row vector. retval = Sparse<double> (1, nc); - for(octave_idx_type i = 0; i < nc; i++) - retval.xcidx(i+1) = retval.xcidx(i) + (cidx(i+1) > cidx(i)); - octave_idx_type new_nz = retval.xcidx(nc); + for (octave_idx_type i = 0; i < nc; i++) + retval.xcidx (i+1) = retval.xcidx (i) + (cidx (i+1) > cidx (i)); + octave_idx_type new_nz = retval.xcidx (nc); retval.change_capacity (new_nz); fill_or_memset (new_nz, static_cast<octave_idx_type> (0), retval.ridx ()); - for(octave_idx_type i = 0, k = 0; i < nc; i++) + for (octave_idx_type i = 0, k = 0; i < nc; i++) { - octave_idx_type c = cidx(i+1) - cidx(i); + octave_idx_type c = cidx (i+1) - cidx (i); if (c > 0) - retval.xdata(k++) = c; + retval.xdata (k++) = c; } } else if (dim == 1) @@ -215,7 +215,7 @@ // We can use O(nr) memory. Array<double> tmp (dim_vector (nr, 1), 0); for (octave_idx_type i = 0; i < nz; i++) - tmp.xelem(ridx(i)) += 1.0; + tmp.xelem (ridx (i)) += 1.0; retval = tmp; } else @@ -246,8 +246,8 @@ boolMatrix retval (nr, nc, false); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - retval.elem (ridx(i), j) = data (i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + retval.elem (ridx (i), j) = data (i); return retval; } @@ -262,8 +262,8 @@ for (octave_idx_type j = 0; j < nc; j++) { octave_quit (); - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) - os << a.ridx(i) + 1 << " " << j + 1 << " " << a.data(i) << "\n"; + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) + os << a.ridx (i) + 1 << " " << j + 1 << " " << a.data (i) << "\n"; } return os;
--- a/liboctave/cmd-hist.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/cmd-hist.cc Sat Jul 28 12:06:34 2012 -0400 @@ -535,7 +535,7 @@ command_history::process_histcontrol (const std::string& control_arg) { if (instance_ok ()) - instance->do_process_histcontrol(control_arg); + instance->do_process_histcontrol (control_arg); } std::string
--- a/liboctave/dDiagMatrix.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dDiagMatrix.cc Sat Jul 28 12:06:34 2012 -0400 @@ -362,7 +362,7 @@ double DiagMatrix::rcond (void) const { - ColumnVector av = diag (0).map<double> (fabs); + ColumnVector av = diag (0).map<double> (fabs); double amx = av.max (), amn = av.min (); return amx == 0 ? 0.0 : amn / amx; }
--- a/liboctave/dMatrix.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dMatrix.cc Sat Jul 28 12:06:34 2012 -0400 @@ -763,7 +763,7 @@ // Calculate the norm of the matrix, for later use. double anorm = 0; if (calc_cond) - anorm = retval.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = retval.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (dgetrf, DGETRF, (nc, nc, tmp_data, nr, pipvt, info)); @@ -838,7 +838,7 @@ } if (!mattype.is_hermitian ()) - ret = finverse(mattype, info, rcon, force, calc_cond); + ret = finverse (mattype, info, rcon, force, calc_cond); if ((mattype.is_hermitian () || calc_cond) && rcon == 0.) ret = Matrix (rows (), columns (), octave_Inf); @@ -1498,7 +1498,7 @@ Array<octave_idx_type> ipvt (dim_vector (nr, 1)); octave_idx_type *pipvt = ipvt.fortran_vec (); - if(anorm < 0.) + if (anorm < 0.) anorm = atmp.abs ().sum (). row(static_cast<octave_idx_type>(0)).max (); @@ -1762,7 +1762,7 @@ char job = 'L'; Matrix atmp = *this; double *tmp_data = atmp.fortran_vec (); - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (dpotrf, DPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr, tmp_data, nr, info @@ -1838,8 +1838,8 @@ Matrix atmp = *this; double *tmp_data = atmp.fortran_vec (); - if(anorm < 0.) - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + if (anorm < 0.) + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); Array<double> z (dim_vector (4 * nc, 1)); double *pz = z.fortran_vec (); @@ -2062,7 +2062,7 @@ { Matrix tmp (b); tmp = solve (typ, tmp, info, rcon, sing_handler, true, transt); - return tmp.column(static_cast<octave_idx_type> (0)); + return tmp.column (static_cast<octave_idx_type> (0)); } ComplexColumnVector @@ -2094,7 +2094,7 @@ solve_singularity_handler sing_handler, blas_trans_type transt) const { ComplexMatrix tmp (*this); - return tmp.solve(typ, b, info, rcon, sing_handler, transt); + return tmp.solve (typ, b, info, rcon, sing_handler, transt); } Matrix
--- a/liboctave/dNDArray.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dNDArray.cc Sat Jul 28 12:06:34 2012 -0400 @@ -281,7 +281,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (zfftf, ZFFTF) (npts, tmp, pwsave); @@ -328,7 +328,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (zfftb, ZFFTB) (npts, tmp, pwsave);
--- a/liboctave/dNDArray.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dNDArray.h Sat Jul 28 12:06:34 2012 -0400 @@ -64,6 +64,10 @@ NDArray (const charNDArray&); + // For jit support only + NDArray (double *sdata, octave_idx_type slen, octave_idx_type *adims, void *arep) + : MArray<double> (sdata, slen, adims, arep) { } + NDArray& operator = (const NDArray& a) { MArray<double>::operator = (a);
--- a/liboctave/dSparse.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dSparse.cc Sat Jul 28 12:06:34 2012 -0400 @@ -177,7 +177,7 @@ } } for (octave_idx_type i = l; i <= a.cols (); i++) - cidx(i) = j; + cidx (i) = j; } bool @@ -194,11 +194,11 @@ return false; for (octave_idx_type i = 0; i < nc + 1; i++) - if (cidx(i) != a.cidx(i)) + if (cidx (i) != a.cidx (i)) return false; for (octave_idx_type i = 0; i < nz; i++) - if (data(i) != a.data(i) || ridx(i) != a.ridx(i)) + if (data (i) != a.data (i) || ridx (i) != a.ridx (i)) return false; return true; @@ -220,19 +220,19 @@ { for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - { - octave_idx_type ri = ridx(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + { + octave_idx_type ri = ridx (i); if (ri != j) { bool found = false; - for (octave_idx_type k = cidx(ri); k < cidx(ri+1); k++) + for (octave_idx_type k = cidx (ri); k < cidx (ri+1); k++) { - if (ridx(k) == j) + if (ridx (k) == j) { - if (data(i) == data(k)) + if (data (i) == data (k)) found = true; break; } @@ -294,9 +294,9 @@ { double tmp_max = octave_NaN; octave_idx_type idx_j = 0; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - { - if (ridx(i) != idx_j) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + { + if (ridx (i) != idx_j) break; else idx_j++; @@ -305,7 +305,7 @@ if (idx_j != nr) tmp_max = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { double tmp = data (i); @@ -344,30 +344,30 @@ { idx_arg.resize (dim_vector (nr, 1), 0); - for (octave_idx_type i = cidx(0); i < cidx(1); i++) - idx_arg.elem(ridx(i)) = -1; + for (octave_idx_type i = cidx (0); i < cidx (1); i++) + idx_arg.elem (ridx (i)) = -1; for (octave_idx_type j = 0; j < nc; j++) for (octave_idx_type i = 0; i < nr; i++) { - if (idx_arg.elem(i) != -1) + if (idx_arg.elem (i) != -1) continue; bool found = false; - for (octave_idx_type k = cidx(j); k < cidx(j+1); k++) - if (ridx(k) == i) + for (octave_idx_type k = cidx (j); k < cidx (j+1); k++) + if (ridx (k) == i) { found = true; break; } if (!found) - idx_arg.elem(i) = j; + idx_arg.elem (i) = j; } for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ir = ridx (i); octave_idx_type ix = idx_arg.elem (ir); @@ -382,7 +382,7 @@ octave_idx_type nel = 0; for (octave_idx_type j = 0; j < nr; j++) - if (idx_arg.elem(j) == -1 || elem (j, idx_arg.elem (j)) != 0.) + if (idx_arg.elem (j) == -1 || elem (j, idx_arg.elem (j)) != 0.) nel++; result = SparseMatrix (nr, 1, nel); @@ -443,9 +443,9 @@ { double tmp_min = octave_NaN; octave_idx_type idx_j = 0; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - { - if (ridx(i) != idx_j) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + { + if (ridx (i) != idx_j) break; else idx_j++; @@ -454,7 +454,7 @@ if (idx_j != nr) tmp_min = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { double tmp = data (i); @@ -493,30 +493,30 @@ { idx_arg.resize (dim_vector (nr, 1), 0); - for (octave_idx_type i = cidx(0); i < cidx(1); i++) - idx_arg.elem(ridx(i)) = -1; + for (octave_idx_type i = cidx (0); i < cidx (1); i++) + idx_arg.elem (ridx (i)) = -1; for (octave_idx_type j = 0; j < nc; j++) for (octave_idx_type i = 0; i < nr; i++) { - if (idx_arg.elem(i) != -1) + if (idx_arg.elem (i) != -1) continue; bool found = false; - for (octave_idx_type k = cidx(j); k < cidx(j+1); k++) - if (ridx(k) == i) + for (octave_idx_type k = cidx (j); k < cidx (j+1); k++) + if (ridx (k) == i) { found = true; break; } if (!found) - idx_arg.elem(i) = j; + idx_arg.elem (i) = j; } for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ir = ridx (i); octave_idx_type ix = idx_arg.elem (ir); @@ -531,7 +531,7 @@ octave_idx_type nel = 0; for (octave_idx_type j = 0; j < nr; j++) - if (idx_arg.elem(j) == -1 || elem (j, idx_arg.elem (j)) != 0.) + if (idx_arg.elem (j) == -1 || elem (j, idx_arg.elem (j)) != 0.) nel++; result = SparseMatrix (nr, 1, nel); @@ -620,12 +620,12 @@ SparseMatrix r (nr, nc, nz); for (octave_idx_type i = 0; i < nc +1; i++) - r.cidx(i) = a.cidx(i); + r.cidx (i) = a.cidx (i); for (octave_idx_type i = 0; i < nz; i++) { - r.data(i) = std::real (a.data(i)); - r.ridx(i) = a.ridx(i); + r.data (i) = std::real (a.data (i)); + r.ridx (i) = a.ridx (i); } return r; @@ -640,12 +640,12 @@ SparseMatrix r (nr, nc, nz); for (octave_idx_type i = 0; i < nc +1; i++) - r.cidx(i) = a.cidx(i); + r.cidx (i) = a.cidx (i); for (octave_idx_type i = 0; i < nz; i++) { - r.data(i) = std::imag (a.data(i)); - r.ridx(i) = a.ridx(i); + r.data (i) = std::imag (a.data (i)); + r.ridx (i) = a.ridx (i); } return r; @@ -667,7 +667,7 @@ for (octave_idx_type j = 0; j < nc; j++) for (octave_idx_type i = y.cidx (j); i < y.cidx (j+1); i++) - tmp.elem (y.ridx(i), j) = atan2 (x, y.data(i)); + tmp.elem (y.ridx (i), j) = atan2 (x, y.data (i)); return SparseMatrix (tmp); } @@ -683,12 +683,12 @@ SparseMatrix retval (nr, nc, nz); octave_idx_type ii = 0; - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (octave_idx_type i = 0; i < nc; i++) { - for (octave_idx_type j = x.cidx(i); j < x.cidx(i+1); j++) + for (octave_idx_type j = x.cidx (i); j < x.cidx (i+1); j++) { - double tmp = atan2 (x.data(j), y); + double tmp = atan2 (x.data (j), y); if (tmp != 0.) { retval.xdata (ii) = tmp; @@ -737,39 +737,39 @@ r.cidx (0) = 0; for (octave_idx_type i = 0 ; i < x_nc ; i++) { - octave_idx_type ja = x.cidx(i); - octave_idx_type ja_max = x.cidx(i+1); + octave_idx_type ja = x.cidx (i); + octave_idx_type ja_max = x.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = y.cidx(i); - octave_idx_type jb_max = y.cidx(i+1); + octave_idx_type jb = y.cidx (i); + octave_idx_type jb_max = y.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (x.ridx(ja) < y.ridx(jb)))) + (ja_lt_max && (x.ridx (ja) < y.ridx (jb)))) { - r.ridx(jx) = x.ridx(ja); - r.data(jx) = atan2 (x.data(ja), 0.); + r.ridx (jx) = x.ridx (ja); + r.data (jx) = atan2 (x.data (ja), 0.); jx++; ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (y.ridx(jb) < x.ridx(ja)) ) ) + (jb_lt_max && (y.ridx (jb) < x.ridx (ja)) ) ) { jb++; jb_lt_max= jb < jb_max; } else { - double tmp = atan2 (x.data(ja), y.data(jb)); + double tmp = atan2 (x.data (ja), y.data (jb)); if (tmp != 0.) { - r.data(jx) = tmp; - r.ridx(jx) = x.ridx(ja); + r.data (jx) = tmp; + r.ridx (jx) = x.ridx (ja); jx++; } ja++; @@ -778,7 +778,7 @@ jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } r.maybe_compress (); @@ -849,7 +849,7 @@ double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nr; i++) { - double tmp = fabs(v[i]); + double tmp = fabs (v[i]); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -899,8 +899,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -925,9 +925,9 @@ retval.change_capacity (nz2); } - retval.xcidx(i) = cx; - retval.xridx(cx) = i; - retval.xdata(cx) = 1.0; + retval.xcidx (i) = cx; + retval.xridx (cx) = i; + retval.xdata (cx) = 1.0; cx++; // iterate accross columns of input matrix @@ -935,11 +935,11 @@ { double v = 0.; // iterate to calculate sum - octave_idx_type colXp = retval.xcidx(i); - octave_idx_type colUp = cidx(j); + octave_idx_type colXp = retval.xcidx (i); + octave_idx_type colUp = cidx (j); octave_idx_type rpX, rpU; - if (cidx(j) == cidx(j+1)) + if (cidx (j) == cidx (j+1)) { (*current_liboctave_error_handler) ("division by zero"); @@ -949,8 +949,8 @@ do { octave_quit (); - rpX = retval.xridx(colXp); - rpU = ridx(colUp); + rpX = retval.xridx (colXp); + rpU = ridx (colUp); if (rpX < rpU) colXp++; @@ -958,7 +958,7 @@ colUp++; else { - v -= retval.xdata(colXp) * data(colUp); + v -= retval.xdata (colXp) * data (colUp); colXp++; colUp++; } @@ -967,11 +967,11 @@ // get A(m,m) if (typ == MatrixType::Upper) - colUp = cidx(j+1) - 1; + colUp = cidx (j+1) - 1; else - colUp = cidx(j); - double pivot = data(colUp); - if (pivot == 0. || ridx(colUp) != j) + colUp = cidx (j); + double pivot = data (colUp); + if (pivot == 0. || ridx (colUp) != j) { (*current_liboctave_error_handler) ("division by zero"); @@ -986,8 +986,8 @@ retval.change_capacity (nz2); } - retval.xridx(cx) = j; - retval.xdata(cx) = v / pivot; + retval.xridx (cx) = j; + retval.xdata (cx) = v / pivot; cx++; } } @@ -995,11 +995,11 @@ // get A(m,m) octave_idx_type colUp; if (typ == MatrixType::Upper) - colUp = cidx(i+1) - 1; + colUp = cidx (i+1) - 1; else - colUp = cidx(i); - double pivot = data(colUp); - if (pivot == 0. || ridx(colUp) != i) + colUp = cidx (i); + double pivot = data (colUp); + if (pivot == 0. || ridx (colUp) != i) { (*current_liboctave_error_handler) ("division by zero"); goto inverse_singular; @@ -1007,9 +1007,9 @@ if (pivot != 1.0) for (octave_idx_type j = cx_colstart; j < cx; j++) - retval.xdata(j) /= pivot; - } - retval.xcidx(nr) = cx; + retval.xdata (j) /= pivot; + } + retval.xcidx (nr) = cx; retval.maybe_compress (); } else @@ -1053,19 +1053,19 @@ double v = 0.; octave_idx_type jidx = perm[j]; // iterate to calculate sum - for (octave_idx_type k = cidx(jidx); - k < cidx(jidx+1); k++) + for (octave_idx_type k = cidx (jidx); + k < cidx (jidx+1); k++) { octave_quit (); - v -= work[ridx(k)] * data(k); + v -= work[ridx (k)] * data (k); } // get A(m,m) double pivot; if (typ == MatrixType::Permuted_Upper) - pivot = data(cidx(jidx+1) - 1); + pivot = data (cidx (jidx+1) - 1); else - pivot = data(cidx(jidx)); + pivot = data (cidx (jidx)); if (pivot == 0.) { (*current_liboctave_error_handler) @@ -1079,11 +1079,11 @@ // get A(m,m) octave_idx_type colUp; if (typ == MatrixType::Permuted_Upper) - colUp = cidx(perm[iidx]+1) - 1; + colUp = cidx (perm[iidx]+1) - 1; else - colUp = cidx(perm[iidx]); - - double pivot = data(colUp); + colUp = cidx (perm[iidx]); + + double pivot = data (colUp); if (pivot == 0.) { (*current_liboctave_error_handler) @@ -1106,16 +1106,16 @@ retval.change_capacity (nz2); } - retval.xcidx(i) = cx; + retval.xcidx (i) = cx; for (octave_idx_type j = iidx; j < nr; j++) if (work[j] != 0.) { - retval.xridx(cx) = j; - retval.xdata(cx++) = work[j]; + retval.xridx (cx) = j; + retval.xdata (cx++) = work[j]; } } - retval.xcidx(nr) = cx; + retval.xcidx (nr) = cx; retval.maybe_compress (); } @@ -1125,9 +1125,9 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = retval.cidx(j); - i < retval.cidx(j+1); i++) - atmp += fabs(retval.data(i)); + for (octave_idx_type i = retval.cidx (j); + i < retval.cidx (j+1); i++) + atmp += fabs (retval.data (i)); if (atmp > ainvnorm) ainvnorm = atmp; } @@ -1175,7 +1175,7 @@ { double rcond2; SparseMatrix Q = fact.Q (); - SparseMatrix InvL = fact.L ().transpose ().tinverse(tmp_typ, + SparseMatrix InvL = fact.L ().transpose ().tinverse (tmp_typ, info, rcond2, true, false); ret = Q * InvL.transpose () * InvL * Q.transpose (); } @@ -1198,9 +1198,9 @@ SparseLU fact (*this, Qinit, Matrix (), false, false); rcond = fact.rcond (); double rcond2; - SparseMatrix InvL = fact.L ().transpose ().tinverse(tmp_typ, + SparseMatrix InvL = fact.L ().transpose ().tinverse (tmp_typ, info, rcond2, true, false); - SparseMatrix InvU = fact.U ().tinverse(tmp_typ, info, rcond2, + SparseMatrix InvU = fact.U ().tinverse (tmp_typ, info, rcond2, true, false).transpose (); ret = fact.Pc ().transpose () * InvU * InvL * fact.Pr (); } @@ -1374,15 +1374,15 @@ else for (octave_idx_type j = 0; j < b.cols (); j++) for (octave_idx_type k = 0; k < nc; k++) - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - retval(k,j) = b(ridx(i),j) / data (i); + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + retval(k,j) = b(ridx (i),j) / data (i); if (calc_cond) { double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nm; i++) { - double tmp = fabs(data(i)); + double tmp = fabs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1430,30 +1430,30 @@ octave_idx_type b_nz = b.nnz (); retval = SparseMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; if (typ == MatrixType::Diagonal) for (octave_idx_type j = 0; j < b_nc; j++) { - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) { - if (b.ridx(i) >= nm) + if (b.ridx (i) >= nm) break; - retval.xridx (ii) = b.ridx(i); - retval.xdata (ii++) = b.data(i) / data (b.ridx (i)); + retval.xridx (ii) = b.ridx (i); + retval.xdata (ii++) = b.data (i) / data (b.ridx (i)); } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } else for (octave_idx_type j = 0; j < b_nc; j++) { for (octave_idx_type l = 0; l < nc; l++) - for (octave_idx_type i = cidx(l); i < cidx(l+1); i++) + for (octave_idx_type i = cidx (l); i < cidx (l+1); i++) { bool found = false; octave_idx_type k; - for (k = b.cidx(j); k < b.cidx(j+1); k++) - if (ridx(i) == b.ridx(k)) + for (k = b.cidx (j); k < b.cidx (j+1); k++) + if (ridx (i) == b.ridx (k)) { found = true; break; @@ -1461,10 +1461,10 @@ if (found) { retval.xridx (ii) = l; - retval.xdata (ii++) = b.data(k) / data (i); + retval.xdata (ii++) = b.data (k) / data (i); } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } if (calc_cond) @@ -1472,7 +1472,7 @@ double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nm; i++) { - double tmp = fabs(data(i)); + double tmp = fabs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1524,15 +1524,15 @@ else for (octave_idx_type j = 0; j < b.cols (); j++) for (octave_idx_type k = 0; k < nc; k++) - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - retval(k,j) = b(ridx(i),j) / data (i); + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + retval(k,j) = b(ridx (i),j) / data (i); if (calc_cond) { double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nm; i++) { - double tmp = fabs(data(i)); + double tmp = fabs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1580,30 +1580,30 @@ octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; if (typ == MatrixType::Diagonal) for (octave_idx_type j = 0; j < b.cols (); j++) { - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) { - if (b.ridx(i) >= nm) + if (b.ridx (i) >= nm) break; - retval.xridx (ii) = b.ridx(i); - retval.xdata (ii++) = b.data(i) / data (b.ridx (i)); + retval.xridx (ii) = b.ridx (i); + retval.xdata (ii++) = b.data (i) / data (b.ridx (i)); } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } else for (octave_idx_type j = 0; j < b.cols (); j++) { for (octave_idx_type l = 0; l < nc; l++) - for (octave_idx_type i = cidx(l); i < cidx(l+1); i++) + for (octave_idx_type i = cidx (l); i < cidx (l+1); i++) { bool found = false; octave_idx_type k; - for (k = b.cidx(j); k < b.cidx(j+1); k++) - if (ridx(i) == b.ridx(k)) + for (k = b.cidx (j); k < b.cidx (j+1); k++) + if (ridx (i) == b.ridx (k)) { found = true; break; @@ -1611,10 +1611,10 @@ if (found) { retval.xridx (ii) = l; - retval.xdata (ii++) = b.data(k) / data (i); + retval.xdata (ii++) = b.data (k) / data (i); } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } if (calc_cond) @@ -1622,7 +1622,7 @@ double dmax = 0., dmin = octave_Inf; for (octave_idx_type i = 0; i < nm; i++) { - double tmp = fabs(data(i)); + double tmp = fabs (data (i)); if (tmp > dmax) dmax = tmp; if (tmp < dmin) @@ -1678,8 +1678,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -1704,20 +1704,20 @@ if (work[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - double tmp = work[k] / data(cidx(kidx+1)-1); + double tmp = work[k] / data (cidx (kidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -1742,20 +1742,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(iidx+1)-1); + double tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -1780,19 +1780,19 @@ { if (work[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - double tmp = work[k] / data(cidx(k+1)-1); + double tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -1815,19 +1815,19 @@ { if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k+1)-1); + double tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -1912,8 +1912,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -1922,7 +1922,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -1939,8 +1939,8 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = nc-1; k >= 0; k--) { @@ -1948,20 +1948,20 @@ if (work[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - double tmp = work[k] / data(cidx(kidx+1)-1); + double tmp = work[k] / data (cidx (kidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -1984,10 +1984,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[rperm[i]] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[rperm[i]]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[rperm[i]]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2008,20 +2008,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(iidx+1)-1); + double tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2038,26 +2038,26 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = nc-1; k >= 0; k--) { if (work[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - double tmp = work[k] / data(cidx(k+1)-1); + double tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2080,10 +2080,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2102,20 +2102,20 @@ { if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k+1)-1); + double tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2200,8 +2200,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2226,20 +2226,20 @@ if (cwork[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(cidx(kidx+1)-1); + Complex tmp = cwork[k] / data (cidx (kidx+1)-1); cwork[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -2265,20 +2265,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(iidx+1)-1); + double tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2303,19 +2303,19 @@ { if (cwork[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(cidx(k+1)-1); + Complex tmp = cwork[k] / data (cidx (k+1)-1); cwork[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -2339,20 +2339,20 @@ { if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k+1)-1); + double tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2437,8 +2437,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2447,7 +2447,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -2464,8 +2464,8 @@ { for (octave_idx_type i = 0; i < nm; i++) cwork[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - cwork[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + cwork[b.ridx (i)] = b.data (i); for (octave_idx_type k = nc-1; k >= 0; k--) { @@ -2473,20 +2473,20 @@ if (cwork[k] != 0.) { - if (ridx(cidx(kidx+1)-1) != k || - data(cidx(kidx+1)-1) == 0.) + if (ridx (cidx (kidx+1)-1) != k || + data (cidx (kidx+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(cidx(kidx+1)-1); + Complex tmp = cwork[k] / data (cidx (kidx+1)-1); cwork[k] = tmp; - for (octave_idx_type i = cidx(kidx); - i < cidx(kidx+1)-1; i++) + for (octave_idx_type i = cidx (kidx); + i < cidx (kidx+1)-1; i++) { - octave_idx_type iidx = ridx(i); - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -2509,10 +2509,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (cwork[rperm[i]] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = cwork[rperm[i]]; + retval.xridx (ii) = i; + retval.xdata (ii++) = cwork[rperm[i]]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2534,20 +2534,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(iidx+1)-1); + double tmp = work[k] / data (cidx (iidx+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(iidx); - i < cidx(iidx+1)-1; i++) + for (octave_idx_type i = cidx (iidx); + i < cidx (iidx+1)-1; i++) { - octave_idx_type idx2 = ridx(i); - work[idx2] = work[idx2] - tmp * data(i); + octave_idx_type idx2 = ridx (i); + work[idx2] = work[idx2] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2564,26 +2564,26 @@ { for (octave_idx_type i = 0; i < nm; i++) cwork[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - cwork[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + cwork[b.ridx (i)] = b.data (i); for (octave_idx_type k = nc-1; k >= 0; k--) { if (cwork[k] != 0.) { - if (ridx(cidx(k+1)-1) != k || - data(cidx(k+1)-1) == 0.) + if (ridx (cidx (k+1)-1) != k || + data (cidx (k+1)-1) == 0.) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(cidx(k+1)-1); + Complex tmp = cwork[k] / data (cidx (k+1)-1); cwork[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -2606,10 +2606,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (cwork[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = cwork[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = cwork[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -2629,20 +2629,20 @@ { if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k+1)-1); + double tmp = work[k] / data (cidx (k+1)-1); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1)-1; i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1)-1; i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = 0; i < j+1; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2728,8 +2728,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2756,28 +2756,28 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - if (minr != k || data(mini) == 0) + if (minr != k || data (mini) == 0) { err = -2; goto triangular_error; } - double tmp = work[k] / data(mini); + double tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2803,24 +2803,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - double tmp = work[k] / data(mini); + double tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2828,7 +2828,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2852,20 +2852,20 @@ { if (work[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - double tmp = work[k] / data(cidx(k)); + double tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -2889,20 +2889,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k)); + double tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -2987,8 +2987,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -2997,7 +2997,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -3010,8 +3010,8 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[perm[b.ridx(i)]] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[perm[b.ridx (i)]] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { @@ -3020,28 +3020,28 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - if (minr != k || data(mini) == 0) + if (minr != k || data (mini) == 0) { err = -2; goto triangular_error; } - double tmp = work[k] / data(mini); + double tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3064,10 +3064,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -3089,24 +3089,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - double tmp = work[k] / data(mini); + double tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3114,7 +3114,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nr; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3131,26 +3131,26 @@ { for (octave_idx_type i = 0; i < nm; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { if (work[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - double tmp = work[k] / data(cidx(k)); + double tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3173,10 +3173,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -3196,20 +3196,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k)); + double tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3295,8 +3295,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -3322,28 +3322,28 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - if (minr != k || data(mini) == 0) + if (minr != k || data (mini) == 0) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(mini); + Complex tmp = cwork[k] / data (mini); cwork[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -3370,24 +3370,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - double tmp = work[k] / data(mini); + double tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3395,7 +3395,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3420,19 +3420,19 @@ { if (cwork[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(cidx(k)); + Complex tmp = cwork[k] / data (cidx (k)); cwork[k] = tmp; - for (octave_idx_type i = cidx(k)+1; i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -3457,20 +3457,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k)); + double tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3555,8 +3555,8 @@ for (octave_idx_type j = 0; j < nc; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -3565,7 +3565,7 @@ octave_idx_type b_nc = b.cols (); octave_idx_type b_nz = b.nnz (); retval = SparseComplexMatrix (nc, b_nc, b_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; octave_idx_type ii = 0; octave_idx_type x_nz = b_nz; @@ -3578,8 +3578,8 @@ { for (octave_idx_type i = 0; i < nm; i++) cwork[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - cwork[perm[b.ridx(i)]] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + cwork[perm[b.ridx (i)]] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { @@ -3588,28 +3588,28 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - if (minr != k || data(mini) == 0) + if (minr != k || data (mini) == 0) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(mini); + Complex tmp = cwork[k] / data (mini); cwork[k] = tmp; - for (octave_idx_type i = cidx(k); i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -3632,10 +3632,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (cwork[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = cwork[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = cwork[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -3658,24 +3658,24 @@ octave_idx_type minr = nr; octave_idx_type mini = 0; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) - if (perm[ridx(i)] < minr) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) + if (perm[ridx (i)] < minr) { - minr = perm[ridx(i)]; + minr = perm[ridx (i)]; mini = i; } - double tmp = work[k] / data(mini); + double tmp = work[k] / data (mini); work[k] = tmp; - for (octave_idx_type i = cidx(k); - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k); + i < cidx (k+1); i++) { if (i == mini) continue; - octave_idx_type iidx = perm[ridx(i)]; - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = perm[ridx (i)]; + work[iidx] = work[iidx] - tmp * data (i); } } } @@ -3683,7 +3683,7 @@ double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3700,26 +3700,26 @@ { for (octave_idx_type i = 0; i < nm; i++) cwork[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - cwork[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + cwork[b.ridx (i)] = b.data (i); for (octave_idx_type k = 0; k < nc; k++) { if (cwork[k] != 0.) { - if (ridx(cidx(k)) != k || - data(cidx(k)) == 0.) + if (ridx (cidx (k)) != k || + data (cidx (k)) == 0.) { err = -2; goto triangular_error; } - Complex tmp = cwork[k] / data(cidx(k)); + Complex tmp = cwork[k] / data (cidx (k)); cwork[k] = tmp; - for (octave_idx_type i = cidx(k)+1; i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - cwork[iidx] = cwork[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + cwork[iidx] = cwork[iidx] - tmp * data (i); } } } @@ -3742,10 +3742,10 @@ for (octave_idx_type i = 0; i < nc; i++) if (cwork[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = cwork[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = cwork[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -3766,20 +3766,20 @@ if (work[k] != 0.) { - double tmp = work[k] / data(cidx(k)); + double tmp = work[k] / data (cidx (k)); work[k] = tmp; - for (octave_idx_type i = cidx(k)+1; - i < cidx(k+1); i++) + for (octave_idx_type i = cidx (k)+1; + i < cidx (k+1); i++) { - octave_idx_type iidx = ridx(i); - work[iidx] = work[iidx] - tmp * data(i); + octave_idx_type iidx = ridx (i); + work[iidx] = work[iidx] - tmp * data (i); } } } double atmp = 0; for (octave_idx_type i = j; i < nc; i++) { - atmp += fabs(work[i]); + atmp += fabs (work[i]); work[i] = 0.; } if (atmp > ainvnorm) @@ -3864,11 +3864,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii); ii += 2; } - D[nc-1] = data(ii); + D[nc-1] = data (ii); } else { @@ -3880,12 +3880,12 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); } } @@ -3918,11 +3918,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -3935,14 +3935,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -4021,11 +4021,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -4038,14 +4038,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -4073,7 +4073,7 @@ volatile octave_idx_type x_nz = b.nnz (); octave_idx_type b_nc = b.cols (); retval = SparseMatrix (nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; volatile octave_idx_type ii = 0; OCTAVE_LOCAL_BUFFER (double, work, nr); @@ -4082,8 +4082,8 @@ { for (octave_idx_type i = 0; i < nr; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); F77_XFCN (dgttrs, DGTTRS, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -4109,10 +4109,10 @@ for (octave_idx_type i = 0; i < nr; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -4162,11 +4162,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii); ii += 2; } - D[nc-1] = data(ii); + D[nc-1] = data (ii); } else { @@ -4178,12 +4178,12 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); } } @@ -4217,11 +4217,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -4234,14 +4234,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -4320,11 +4320,11 @@ for (octave_idx_type j = 0; j < nc-1; j++) { - D[j] = data(ii++); - DL[j] = data(ii++); - DU[j] = data(ii++); - } - D[nc-1] = data(ii); + D[j] = data (ii++); + DL[j] = data (ii++); + DU[j] = data (ii++); + } + D[nc-1] = data (ii); } else { @@ -4337,14 +4337,14 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { - if (ridx(i) == j) - D[j] = data(i); - else if (ridx(i) == j + 1) - DL[j] = data(i); - else if (ridx(i) == j - 1) - DU[j-1] = data(i); + if (ridx (i) == j) + D[j] = data (i); + else if (ridx (i) == j + 1) + DL[j] = data (i); + else if (ridx (i) == j - 1) + DU[j-1] = data (i); } } @@ -4379,7 +4379,7 @@ volatile octave_idx_type ii = 0; retval = SparseComplexMatrix (b_nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (volatile octave_idx_type j = 0; j < b_nc; j++) { @@ -4438,12 +4438,12 @@ for (octave_idx_type i = 0; i < nr; i++) if (Bx[i] != 0. || Bz[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = + retval.xridx (ii) = i; + retval.xdata (ii++) = Complex (Bx[i], Bz[i]); } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -4496,17 +4496,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (dpbtrf, DPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -4603,8 +4603,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -4613,8 +4613,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -4746,17 +4746,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (dpbtrf, DPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -4820,7 +4820,7 @@ volatile octave_idx_type ii = 0; retval = SparseMatrix (b_nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (volatile octave_idx_type j = 0; j < b_nc; j++) { for (octave_idx_type i = 0; i < b_nr; i++) @@ -4854,11 +4854,11 @@ retval.change_capacity (sz); x_nz = sz; } - retval.xdata(ii) = tmp; - retval.xridx(ii++) = i; + retval.xdata (ii) = tmp; + retval.xridx (ii++) = i; } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -4886,8 +4886,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -4896,8 +4896,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -4969,7 +4969,7 @@ volatile octave_idx_type x_nz = b.nnz (); octave_idx_type b_nc = b.cols (); retval = SparseMatrix (nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; volatile octave_idx_type ii = 0; OCTAVE_LOCAL_BUFFER (double, work, nr); @@ -4978,9 +4978,9 @@ { for (octave_idx_type i = 0; i < nr; i++) work[i] = 0.; - for (octave_idx_type i = b.cidx(j); - i < b.cidx(j+1); i++) - work[b.ridx(i)] = b.data(i); + for (octave_idx_type i = b.cidx (j); + i < b.cidx (j+1); i++) + work[b.ridx (i)] = b.data (i); F77_XFCN (dgbtrs, DGBTRS, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -5006,10 +5006,10 @@ for (octave_idx_type i = 0; i < nr; i++) if (work[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = work[i]; + retval.xridx (ii) = i; + retval.xdata (ii++) = work[i]; } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -5064,17 +5064,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (dpbtrf, DPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -5202,8 +5202,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -5212,8 +5212,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -5363,17 +5363,17 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) { octave_idx_type ri = ridx (i); if (ri >= j) - m_band(ri - j, j) = data(i); + m_band(ri - j, j) = data (i); } // Calculate the norm of the matrix, for later use. double anorm; if (calc_cond) - anorm = m_band.abs ().sum ().row(0).max (); + anorm = m_band.abs ().sum ().row (0).max (); char job = 'L'; F77_XFCN (dpbtrf, DPBTRF, (F77_CONST_CHAR_ARG2 (&job, 1), @@ -5441,7 +5441,7 @@ volatile octave_idx_type ii = 0; retval = SparseComplexMatrix (b_nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (volatile octave_idx_type j = 0; j < b_nc; j++) { @@ -5499,12 +5499,12 @@ for (octave_idx_type i = 0; i < nr; i++) if (Bx[i] != 0. || Bz[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = + retval.xridx (ii) = i; + retval.xdata (ii++) = Complex (Bx[i], Bz[i]); } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -5532,8 +5532,8 @@ } for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - m_band(ridx(i) - j + n_lower + n_upper, j) = data(i); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + m_band(ridx (i) - j + n_lower + n_upper, j) = data (i); // Calculate the norm of the matrix, for later use. double anorm; @@ -5542,8 +5542,8 @@ for (octave_idx_type j = 0; j < nr; j++) { double atmp = 0.; - for (octave_idx_type i = cidx(j); i < cidx(j+1); i++) - atmp += fabs(data(i)); + for (octave_idx_type i = cidx (j); i < cidx (j+1); i++) + atmp += fabs (data (i)); if (atmp > anorm) anorm = atmp; } @@ -5615,7 +5615,7 @@ volatile octave_idx_type x_nz = b.nnz (); octave_idx_type b_nc = b.cols (); retval = SparseComplexMatrix (nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; volatile octave_idx_type ii = 0; OCTAVE_LOCAL_BUFFER (double, Bx, nr); @@ -5628,12 +5628,12 @@ Bx[i] = 0.; Bz[i] = 0.; } - for (octave_idx_type i = b.cidx(j); - i < b.cidx(j+1); i++) + for (octave_idx_type i = b.cidx (j); + i < b.cidx (j+1); i++) { - Complex c = b.data(i); - Bx[b.ridx(i)] = std::real (c); - Bz[b.ridx(i)] = std::imag (c); + Complex c = b.data (i); + Bx[b.ridx (i)] = std::real (c); + Bz[b.ridx (i)] = std::imag (c); } F77_XFCN (dgbtrs, DGBTRS, @@ -5666,11 +5666,11 @@ for (octave_idx_type i = 0; i < nr; i++) if (Bx[i] != 0. || Bz[i] != 0.) { - retval.xridx(ii) = i; - retval.xdata(ii++) = + retval.xridx (ii) = i; + retval.xdata (ii++) = Complex (Bx[i], Bz[i]); } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -5935,7 +5935,7 @@ { octave_idx_type jr = j * b.rows (); for (octave_idx_type i = 0; i < b.rows (); i++) - retval.xelem(i,j) = static_cast<double *>(X->x)[jr + i]; + retval.xelem (i,j) = static_cast<double *>(X->x)[jr + i]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -6160,12 +6160,12 @@ static_cast<octave_idx_type>(X->nzmax)); for (octave_idx_type j = 0; j <= static_cast<octave_idx_type>(X->ncol); j++) - retval.xcidx(j) = static_cast<octave_idx_type *>(X->p)[j]; + retval.xcidx (j) = static_cast<octave_idx_type *>(X->p)[j]; for (octave_idx_type j = 0; j < static_cast<octave_idx_type>(X->nzmax); j++) { - retval.xridx(j) = static_cast<octave_idx_type *>(X->i)[j]; - retval.xdata(j) = static_cast<double *>(X->x)[j]; + retval.xridx (j) = static_cast<octave_idx_type *>(X->i)[j]; + retval.xdata (j) = static_cast<double *>(X->x)[j]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -6212,7 +6212,7 @@ octave_idx_type ii = 0; retval = SparseMatrix (b_nr, b_nc, x_nz); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (octave_idx_type j = 0; j < b_nc; j++) { @@ -6247,11 +6247,11 @@ retval.change_capacity (sz); x_nz = sz; } - retval.xdata(ii) = tmp; - retval.xridx(ii++) = i; + retval.xdata (ii) = tmp; + retval.xridx (ii++) = i; } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -6412,7 +6412,7 @@ { octave_idx_type jr = j * b.rows (); for (octave_idx_type i = 0; i < b.rows (); i++) - retval.xelem(i,j) = static_cast<Complex *>(X->x)[jr + i]; + retval.xelem (i,j) = static_cast<Complex *>(X->x)[jr + i]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -6657,12 +6657,12 @@ static_cast<octave_idx_type>(X->nzmax)); for (octave_idx_type j = 0; j <= static_cast<octave_idx_type>(X->ncol); j++) - retval.xcidx(j) = static_cast<octave_idx_type *>(X->p)[j]; + retval.xcidx (j) = static_cast<octave_idx_type *>(X->p)[j]; for (octave_idx_type j = 0; j < static_cast<octave_idx_type>(X->nzmax); j++) { - retval.xridx(j) = static_cast<octave_idx_type *>(X->i)[j]; - retval.xdata(j) = static_cast<Complex *>(X->x)[j]; + retval.xridx (j) = static_cast<octave_idx_type *>(X->i)[j]; + retval.xdata (j) = static_cast<Complex *>(X->x)[j]; } BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; @@ -6712,7 +6712,7 @@ OCTAVE_LOCAL_BUFFER (double, Xx, b_nr); OCTAVE_LOCAL_BUFFER (double, Xz, b_nr); - retval.xcidx(0) = 0; + retval.xcidx (0) = 0; for (octave_idx_type j = 0; j < b_nc; j++) { for (octave_idx_type i = 0; i < b_nr; i++) @@ -6754,11 +6754,11 @@ retval.change_capacity (sz); x_nz = sz; } - retval.xdata(ii) = tmp; - retval.xridx(ii++) = i; + retval.xdata (ii) = tmp; + retval.xridx (ii++) = i; } } - retval.xcidx(j+1) = ii; + retval.xcidx (j+1) = ii; } retval.maybe_compress (); @@ -6970,7 +6970,7 @@ return ComplexMatrix (); } - if (singular_fallback && mattype.type(false) == MatrixType::Rectangular) + if (singular_fallback && mattype.type (false) == MatrixType::Rectangular) { rcond = 1.; #ifdef USE_QRSOLVE @@ -7038,7 +7038,7 @@ return SparseComplexMatrix (); } - if (singular_fallback && mattype.type(false) == MatrixType::Rectangular) + if (singular_fallback && mattype.type (false) == MatrixType::Rectangular) { rcond = 1.; #ifdef USE_QRSOLVE @@ -7451,12 +7451,12 @@ { for (octave_idx_type j = 0; j < nr; j++) { - if (jj < cidx(i+1) && ridx(jj) == j) + if (jj < cidx (i+1) && ridx (jj) == j) jj++; else { - r.data(ii) = true; - r.ridx(ii++) = j; + r.data (ii) = true; + r.ridx (ii++) = j; } } r.cidx (i+1) = ii; @@ -7500,7 +7500,7 @@ else { SPARSE_REDUCTION_OP (SparseMatrix, double, *=, - (cidx(j+1) - cidx(j) < nr ? 0.0 : 1.0), 1.0); + (cidx (j+1) - cidx (j) < nr ? 0.0 : 1.0), 1.0); } } @@ -7515,7 +7515,7 @@ { #define ROW_EXPR \ double d = data (i); \ - tmp[ridx(i)] += d * d + tmp[ridx (i)] += d * d #define COL_EXPR \ double d = data (i); \ @@ -7536,7 +7536,7 @@ SparseMatrix retval (*this); for (octave_idx_type i = 0; i < nz; i++) - retval.data(i) = fabs(retval.data(i)); + retval.data (i) = fabs (retval.data (i)); return retval; } @@ -7563,10 +7563,10 @@ for (octave_idx_type j = 0; j < nc; j++) { octave_quit (); - for (octave_idx_type i = a.cidx(j); i < a.cidx(j+1); i++) + for (octave_idx_type i = a.cidx (j); i < a.cidx (j+1); i++) { - os << a.ridx(i) + 1 << " " << j + 1 << " "; - octave_write_double (os, a.data(i)); + os << a.ridx (i) + 1 << " " << j + 1 << " "; + octave_write_double (os, a.data (i)); os << "\n"; } } @@ -7712,14 +7712,14 @@ { result = SparseMatrix (nr, nc, d); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) { double tmp = xmin (d, m.data (i)); if (tmp != 0.) { - octave_idx_type idx = m.ridx(i) + j * nr; - result.xdata(idx) = tmp; - result.xridx(idx) = m.ridx(i); + octave_idx_type idx = m.ridx (i) + j * nr; + result.xdata (idx) = tmp; + result.xridx (idx) = m.ridx (i); } } } @@ -7727,27 +7727,27 @@ { octave_idx_type nel = 0; for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) if (xmin (d, m.data (i)) != 0.) nel++; result = SparseMatrix (nr, nc, nel); octave_idx_type ii = 0; - result.xcidx(0) = 0; + result.xcidx (0) = 0; for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) { double tmp = xmin (d, m.data (i)); if (tmp != 0.) { - result.xdata(ii) = tmp; - result.xridx(ii++) = m.ridx(i); - } - } - result.xcidx(j+1) = ii; + result.xdata (ii) = tmp; + result.xridx (ii++) = m.ridx (i); + } + } + result.xcidx (j+1) = ii; } } @@ -7783,38 +7783,38 @@ r.cidx (0) = 0; for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { - double tmp = xmin (a.data(ja), 0.); + double tmp = xmin (a.data (ja), 0.); if (tmp != 0.) { - r.ridx(jx) = a.ridx(ja); - r.data(jx) = tmp; + r.ridx (jx) = a.ridx (ja); + r.data (jx) = tmp; jx++; } ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { - double tmp = xmin (0., b.data(jb)); + double tmp = xmin (0., b.data (jb)); if (tmp != 0.) { - r.ridx(jx) = b.ridx(jb); - r.data(jx) = tmp; + r.ridx (jx) = b.ridx (jb); + r.data (jx) = tmp; jx++; } jb++; @@ -7822,11 +7822,11 @@ } else { - double tmp = xmin (a.data(ja), b.data(jb)); + double tmp = xmin (a.data (ja), b.data (jb)); if (tmp != 0.) { - r.data(jx) = tmp; - r.ridx(jx) = a.ridx(ja); + r.data (jx) = tmp; + r.ridx (jx) = a.ridx (ja); jx++; } ja++; @@ -7835,7 +7835,7 @@ jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } r.maybe_compress (); @@ -7862,15 +7862,15 @@ { result = SparseMatrix (nr, nc, d); for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) { double tmp = xmax (d, m.data (i)); if (tmp != 0.) { - octave_idx_type idx = m.ridx(i) + j * nr; - result.xdata(idx) = tmp; - result.xridx(idx) = m.ridx(i); + octave_idx_type idx = m.ridx (i) + j * nr; + result.xdata (idx) = tmp; + result.xridx (idx) = m.ridx (i); } } } @@ -7878,26 +7878,26 @@ { octave_idx_type nel = 0; for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) if (xmax (d, m.data (i)) != 0.) nel++; result = SparseMatrix (nr, nc, nel); octave_idx_type ii = 0; - result.xcidx(0) = 0; + result.xcidx (0) = 0; for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) { double tmp = xmax (d, m.data (i)); if (tmp != 0.) { - result.xdata(ii) = tmp; - result.xridx(ii++) = m.ridx(i); - } - } - result.xcidx(j+1) = ii; + result.xdata (ii) = tmp; + result.xridx (ii++) = m.ridx (i); + } + } + result.xcidx (j+1) = ii; } } @@ -7933,38 +7933,38 @@ r.cidx (0) = 0; for (octave_idx_type i = 0 ; i < a_nc ; i++) { - octave_idx_type ja = a.cidx(i); - octave_idx_type ja_max = a.cidx(i+1); + octave_idx_type ja = a.cidx (i); + octave_idx_type ja_max = a.cidx (i+1); bool ja_lt_max= ja < ja_max; - octave_idx_type jb = b.cidx(i); - octave_idx_type jb_max = b.cidx(i+1); + octave_idx_type jb = b.cidx (i); + octave_idx_type jb_max = b.cidx (i+1); bool jb_lt_max = jb < jb_max; while (ja_lt_max || jb_lt_max ) { octave_quit (); if ((! jb_lt_max) || - (ja_lt_max && (a.ridx(ja) < b.ridx(jb)))) + (ja_lt_max && (a.ridx (ja) < b.ridx (jb)))) { - double tmp = xmax (a.data(ja), 0.); + double tmp = xmax (a.data (ja), 0.); if (tmp != 0.) { - r.ridx(jx) = a.ridx(ja); - r.data(jx) = tmp; + r.ridx (jx) = a.ridx (ja); + r.data (jx) = tmp; jx++; } ja++; ja_lt_max= ja < ja_max; } else if (( !ja_lt_max ) || - (jb_lt_max && (b.ridx(jb) < a.ridx(ja)) ) ) + (jb_lt_max && (b.ridx (jb) < a.ridx (ja)) ) ) { - double tmp = xmax (0., b.data(jb)); + double tmp = xmax (0., b.data (jb)); if (tmp != 0.) { - r.ridx(jx) = b.ridx(jb); - r.data(jx) = tmp; + r.ridx (jx) = b.ridx (jb); + r.data (jx) = tmp; jx++; } jb++; @@ -7972,11 +7972,11 @@ } else { - double tmp = xmax (a.data(ja), b.data(jb)); + double tmp = xmax (a.data (ja), b.data (jb)); if (tmp != 0.) { - r.data(jx) = tmp; - r.ridx(jx) = a.ridx(ja); + r.data (jx) = tmp; + r.ridx (jx) = a.ridx (ja); jx++; } ja++; @@ -7985,7 +7985,7 @@ jb_lt_max= jb < jb_max; } } - r.cidx(i+1) = jx; + r.cidx (i+1) = jx; } r.maybe_compress ();
--- a/liboctave/data-conv.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/data-conv.cc Sat Jul 28 12:06:34 2012 -0400 @@ -496,7 +496,7 @@ while (0) // Have to use copy here to avoid writing over data accessed via -// Matrix::data(). +// Matrix::data (). #define LS_DO_WRITE(TYPE, data, size, len, stream) \ do \
--- a/liboctave/dbleQR.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dbleQR.cc Sat Jul 28 12:06:34 2012 -0400 @@ -466,7 +466,7 @@ if (u.length () == m && v.length () == n) { - init(q*r + Matrix (u) * Matrix (v).transpose (), get_type ()); + init (q*r + Matrix (u) * Matrix (v).transpose (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch"); @@ -482,7 +482,7 @@ if (u.rows () == m && v.rows () == n && u.cols () == v.cols ()) { - init(q*r + u * v.transpose (), get_type ()); + init (q*r + u * v.transpose (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch");
--- a/liboctave/dbleSVD.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dbleSVD.cc Sat Jul 28 12:06:34 2012 -0400 @@ -135,7 +135,7 @@ double *u = left_sm.fortran_vec (); sigma.resize (nrow_s, ncol_s); - double *s_vec = sigma.fortran_vec (); + double *s_vec = sigma.fortran_vec (); if (! (jobv == 'N' || jobv == 'O')) right_sm.resize (nrow_vt, n);
--- a/liboctave/dim-vector.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dim-vector.cc Sat Jul 28 12:06:34 2012 -0400 @@ -157,16 +157,16 @@ } } else - new_dims.resize(k); + new_dims.resize (k); } return new_dims; } -// This is the rule for cat(). cat(dim, A, B) works if one +// This is the rule for cat(). cat (dim, A, B) works if one // of the following holds, in this order: // -// 1. size(A, k) == size(B, k) for all k != dim. +// 1. size (A, k) == size (B, k) for all k != dim. // In this case, size (C, dim) = size (A, dim) + size (B, dim) and // other sizes remain intact. // @@ -230,7 +230,7 @@ // horizontally (dim = 2) or vertically (dim = 1) if one of the // following holds, in this order: // -// 1. cat(dim, A, B) works +// 1. cat (dim, A, B) works // // 2. A, B are 2D and one of them is an empty vector, in which // case the result is the other one except if both of them
--- a/liboctave/dim-vector.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/dim-vector.h Sat Jul 28 12:06:34 2012 -0400 @@ -66,7 +66,7 @@ static octave_idx_type *newrep (int ndims) { - octave_idx_type *r = new octave_idx_type[ndims + 2]; + octave_idx_type *r = new octave_idx_type [ndims + 2]; *r++ = 1; *r++ = ndims; @@ -80,7 +80,7 @@ { int l = ndims (); - octave_idx_type *r = new octave_idx_type[l + 2]; + octave_idx_type *r = new octave_idx_type [l + 2]; *r++ = 1; *r++ = l; @@ -100,7 +100,7 @@ if (n < 2) n = 2; - octave_idx_type *r = new octave_idx_type[n + 2]; + octave_idx_type *r = new octave_idx_type [n + 2]; *r++ = 1; *r++ = n; @@ -212,6 +212,12 @@ void chop_all_singletons (void); + // WARNING: Only call by jit + octave_idx_type *to_jit (void) const + { + return rep; + } + private: static octave_idx_type *nil_rep (void) @@ -220,9 +226,6 @@ return zv.rep; } - explicit dim_vector (octave_idx_type *r) - : rep (r) { } - public: static octave_idx_type dim_max (void); @@ -233,6 +236,10 @@ dim_vector (const dim_vector& dv) : rep (dv.rep) { OCTREFCOUNT_ATOMIC_INCREMENT (&(count())); } + // FIXME: Should be private, but required by array constructor for jit + explicit dim_vector (octave_idx_type *r) + : rep (r) { } + static dim_vector alloc (int n) { return dim_vector (newrep (n < 2 ? 2 : n));
--- a/liboctave/eigs-base.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/eigs-base.cc Sat Jul 28 12:06:34 2012 -0400 @@ -241,8 +241,8 @@ for (octave_idx_type j = 0; j < b_nc; j++) { for (octave_idx_type i = 0; i < n; i++) - retval.elem(static_cast<octave_idx_type>(qv[i]), j) = - tmp.elem(i,j); + retval.elem (static_cast<octave_idx_type>(qv[i]), j) = + tmp.elem (i,j); } } @@ -264,7 +264,7 @@ for (octave_idx_type j = 0; j < b_nc; j++) { for (octave_idx_type i = 0; i < n; i++) - retval.elem(i,j) = m.elem(static_cast<octave_idx_type>(qv[i]), j); + retval.elem (i,j) = m.elem (static_cast<octave_idx_type>(qv[i]), j); } return U.solve (utyp, retval, err, rcond, 0); } @@ -278,8 +278,8 @@ y[j] = 0.; for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) - y[m.ridx(i)] += m.data(i) * x[j]; + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) + y[m.ridx (i)] += m.data (i) * x[j]; return true; } @@ -315,8 +315,8 @@ y[j] = 0.; for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx(j); i < m.cidx(j+1); i++) - y[m.ridx(i)] += m.data(i) * x[j]; + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) + y[m.ridx (i)] += m.data (i) * x[j]; return true; } @@ -354,8 +354,8 @@ else { bt = fact.chol_matrix (); - b = bt.transpose (); - permB = ColumnVector(n); + b = bt.transpose (); + permB = ColumnVector (n); for (octave_idx_type i = 0; i < n; i++) permB(i) = i; return true; @@ -391,8 +391,8 @@ else { bt = fact.chol_matrix (); - b = bt.hermitian (); - permB = ColumnVector(n); + b = bt.hermitian (); + permB = ColumnVector (n); for (octave_idx_type i = 0; i < n; i++) permB(i) = i; return true; @@ -438,12 +438,12 @@ SparseMatrix tmp(n,n,n); for (octave_idx_type i = 0; i < n; i++) { - tmp.xcidx(i) = i; - tmp.xridx(i) = + tmp.xcidx (i) = i; + tmp.xridx (i) = static_cast<octave_idx_type>(permB(i)); - tmp.xdata(i) = 1; + tmp.xdata (i) = 1; } - tmp.xcidx(n) = n; + tmp.xcidx (n) = n; AminusSigmaB = AminusSigmaB - sigma * tmp * b.transpose () * b * tmp.transpose (); @@ -459,13 +459,13 @@ { SparseMatrix sigmat (n, n, n); - // Create sigma * speye(n,n) + // Create sigma * speye (n,n) sigmat.xcidx (0) = 0; for (octave_idx_type i = 0; i < n; i++) { - sigmat.xdata(i) = sigma; - sigmat.xridx(i) = i; - sigmat.xcidx(i+1) = i + 1; + sigmat.xdata (i) = sigma; + sigmat.xridx (i) = i; + sigmat.xcidx (i+1) = i + 1; } AminusSigmaB = AminusSigmaB - sigmat; @@ -490,9 +490,9 @@ for (octave_idx_type j = 0; j < n; j++) { double d = 0.; - if (U.xcidx(j+1) > U.xcidx(j) && - U.xridx (U.xcidx(j+1)-1) == j) - d = std::abs (U.xdata (U.xcidx(j+1)-1)); + if (U.xcidx (j+1) > U.xcidx (j) && + U.xridx (U.xcidx (j+1)-1) == j) + d = std::abs (U.xdata (U.xcidx (j+1)-1)); if (xisnan (minU) || d < minU) minU = d; @@ -541,8 +541,8 @@ j < b.cols (); j++) for (octave_idx_type i = 0; i < b.rows (); i++) - *p++ -= tmp.xelem (static_cast<octave_idx_type>(pB[i]), - static_cast<octave_idx_type>(pB[j])); + *p++ -= tmp.xelem (static_cast<octave_idx_type>(pB[i]), + static_cast<octave_idx_type>(pB[j])); } else AminusSigmaB = AminusSigmaB - tmp; @@ -570,7 +570,7 @@ double maxU = octave_NaN; for (octave_idx_type j = 0; j < n; j++) { - double d = std::abs (U.xelem(j,j)); + double d = std::abs (U.xelem (j,j)); if (xisnan (minU) || d < minU) minU = d; @@ -613,12 +613,12 @@ SparseMatrix tmp(n,n,n); for (octave_idx_type i = 0; i < n; i++) { - tmp.xcidx(i) = i; - tmp.xridx(i) = + tmp.xcidx (i) = i; + tmp.xridx (i) = static_cast<octave_idx_type>(permB(i)); - tmp.xdata(i) = 1; + tmp.xdata (i) = 1; } - tmp.xcidx(n) = n; + tmp.xcidx (n) = n; AminusSigmaB = AminusSigmaB - tmp * b.hermitian () * b * tmp.transpose () * sigma; @@ -633,13 +633,13 @@ { SparseComplexMatrix sigmat (n, n, n); - // Create sigma * speye(n,n) + // Create sigma * speye (n,n) sigmat.xcidx (0) = 0; for (octave_idx_type i = 0; i < n; i++) { - sigmat.xdata(i) = sigma; - sigmat.xridx(i) = i; - sigmat.xcidx(i+1) = i + 1; + sigmat.xdata (i) = sigma; + sigmat.xridx (i) = i; + sigmat.xcidx (i+1) = i + 1; } AminusSigmaB = AminusSigmaB - sigmat; @@ -664,9 +664,9 @@ for (octave_idx_type j = 0; j < n; j++) { double d = 0.; - if (U.xcidx(j+1) > U.xcidx(j) && - U.xridx (U.xcidx(j+1)-1) == j) - d = std::abs (U.xdata (U.xcidx(j+1)-1)); + if (U.xcidx (j+1) > U.xcidx (j) && + U.xridx (U.xcidx (j+1)-1) == j) + d = std::abs (U.xdata (U.xcidx (j+1)-1)); if (xisnan (minU) || d < minU) minU = d; @@ -715,8 +715,8 @@ j < b.cols (); j++) for (octave_idx_type i = 0; i < b.rows (); i++) - *p++ -= tmp.xelem (static_cast<octave_idx_type>(pB[i]), - static_cast<octave_idx_type>(pB[j])); + *p++ -= tmp.xelem (static_cast<octave_idx_type>(pB[i]), + static_cast<octave_idx_type>(pB[j])); } else AminusSigmaB = AminusSigmaB - tmp; @@ -744,7 +744,7 @@ double maxU = octave_NaN; for (octave_idx_type j = 0; j < n; j++) { - double d = std::abs (U.xelem(j,j)); + double d = std::abs (U.xelem (j,j)); if (xisnan (minU) || d < minU) minU = d; @@ -800,9 +800,9 @@ if (resid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - resid = ColumnVector (octave_rand::vector(n)); - octave_rand::distribution(rand_dist); + octave_rand::distribution ("uniform"); + resid = ColumnVector (octave_rand::vector (n)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -827,7 +827,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -891,14 +891,14 @@ b = b.transpose (); if (permB.length () == 0) { - permB = ColumnVector(n); + permB = ColumnVector (n); for (octave_idx_type i = 0; i < n; i++) permB(i) = i; } } else { - if (! make_cholb(b, bt, permB)) + if (! make_cholb (b, bt, permB)) { (*current_liboctave_error_handler) ("eigs: The matrix B is not positive definite"); @@ -951,7 +951,7 @@ return -1; } - if (disp > 0 && !xisnan(workl[iptr(5)-1])) + if (disp > 0 && !xisnan (workl[iptr (5)-1])) { if (iter++) { @@ -979,7 +979,7 @@ for (octave_idx_type i = 0; i < n; i++) mtmp(i,0) = workd[i + iptr(0) - 1]; - mtmp = utsolve(bt, permB, m * ltsolve(b, permB, mtmp)); + mtmp = utsolve (bt, permB, m * ltsolve (b, permB, mtmp)); for (octave_idx_type i = 0; i < n; i++) workd[i+iptr(1)-1] = mtmp(i,0); @@ -1073,7 +1073,7 @@ } if (note3) - eig_vec = ltsolve(b, permB, eig_vec); + eig_vec = ltsolve (b, permB, eig_vec); } } else @@ -1124,9 +1124,9 @@ if (resid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - resid = ColumnVector (octave_rand::vector(n)); - octave_rand::distribution(rand_dist); + octave_rand::distribution ("uniform"); + resid = ColumnVector (octave_rand::vector (n)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -1140,7 +1140,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -1218,7 +1218,7 @@ OCTAVE_LOCAL_BUFFER (octave_idx_type, P, (have_b ? b.rows () : m.rows ())); OCTAVE_LOCAL_BUFFER (octave_idx_type, Q, (have_b ? b.cols () : m.cols ())); - if (! LuAminusSigmaB(m, b, cholB, permB, sigma, L, U, P, Q)) + if (! LuAminusSigmaB (m, b, cholB, permB, sigma, L, U, P, Q)) return -1; octave_idx_type lwork = p * (p + 8); @@ -1244,7 +1244,7 @@ return -1; } - if (disp > 0 && !xisnan(workl[iptr(5)-1])) + if (disp > 0 && !xisnan (workl[iptr (5)-1])) { if (iter++) { @@ -1433,9 +1433,9 @@ if (resid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - resid = ColumnVector (octave_rand::vector(n)); - octave_rand::distribution(rand_dist); + octave_rand::distribution ("uniform"); + resid = ColumnVector (octave_rand::vector (n)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -1460,7 +1460,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -1545,7 +1545,7 @@ return -1; } - if (disp > 0 && !xisnan(workl[iptr(5)-1])) + if (disp > 0 && !xisnan (workl[iptr (5)-1])) { if (iter++) { @@ -1714,9 +1714,9 @@ if (resid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - resid = ColumnVector (octave_rand::vector(n)); - octave_rand::distribution(rand_dist); + octave_rand::distribution ("uniform"); + resid = ColumnVector (octave_rand::vector (n)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -1741,7 +1741,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -1805,14 +1805,14 @@ b = b.transpose (); if (permB.length () == 0) { - permB = ColumnVector(n); + permB = ColumnVector (n); for (octave_idx_type i = 0; i < n; i++) permB(i) = i; } } else { - if (! make_cholb(b, bt, permB)) + if (! make_cholb (b, bt, permB)) { (*current_liboctave_error_handler) ("eigs: The matrix B is not positive definite"); @@ -1893,7 +1893,7 @@ for (octave_idx_type i = 0; i < n; i++) mtmp(i,0) = workd[i + iptr(0) - 1]; - mtmp = utsolve(bt, permB, m * ltsolve(b, permB, mtmp)); + mtmp = utsolve (bt, permB, m * ltsolve (b, permB, mtmp)); for (octave_idx_type i = 0; i < n; i++) workd[i+iptr(1)-1] = mtmp(i,0); @@ -1969,7 +1969,7 @@ if (dr[i] == 0.0 && di[i] == 0.0 && jj == 0) jj++; else - d [i-jj] = Complex (dr[i], di[i]); + d[i-jj] = Complex (dr[i], di[i]); } if (jj == 0 && !rvec) for (octave_idx_type i = 0; i < k; i++) @@ -1982,7 +1982,7 @@ d[i] = d[k - i - 1]; d[k - i - 1] = dtmp; } - eig_val.resize(k); + eig_val.resize (k); if (rvec) { @@ -2012,11 +2012,11 @@ { octave_idx_type off1 = i * n; octave_idx_type off2 = (i+1) * n; - if (std::imag(eig_val(i)) == 0) + if (std::imag (eig_val(i)) == 0) { for (octave_idx_type j = 0; j < n; j++) eig_vec(j,i) = - Complex(z[j+off1],0.); + Complex (z[j+off1],0.); i++; } else @@ -2024,17 +2024,17 @@ for (octave_idx_type j = 0; j < n; j++) { eig_vec(j,i) = - Complex(z[j+off1],z[j+off2]); + Complex (z[j+off1],z[j+off2]); if (i < k - 1) eig_vec(j,i+1) = - Complex(z[j+off1],-z[j+off2]); + Complex (z[j+off1],-z[j+off2]); } i+=2; } } if (note3) - eig_vec = ltsolve(M (b), permB, eig_vec); + eig_vec = ltsolve (M(b), permB, eig_vec); } } else @@ -2087,9 +2087,9 @@ if (resid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - resid = ColumnVector (octave_rand::vector(n)); - octave_rand::distribution(rand_dist); + octave_rand::distribution ("uniform"); + resid = ColumnVector (octave_rand::vector (n)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -2114,7 +2114,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -2181,7 +2181,7 @@ OCTAVE_LOCAL_BUFFER (octave_idx_type, P, (have_b ? b.rows () : m.rows ())); OCTAVE_LOCAL_BUFFER (octave_idx_type, Q, (have_b ? b.cols () : m.cols ())); - if (! LuAminusSigmaB(m, b, cholB, permB, sigmar, L, U, P, Q)) + if (! LuAminusSigmaB (m, b, cholB, permB, sigmar, L, U, P, Q)) return -1; octave_idx_type lwork = 3 * p * (p + 2); @@ -2207,7 +2207,7 @@ return -1; } - if (disp > 0 && !xisnan(workl[iptr(5)-1])) + if (disp > 0 && !xisnan (workl[iptr (5)-1])) { if (iter++) { @@ -2355,7 +2355,7 @@ if (dr[i] == 0.0 && di[i] == 0.0 && jj == 0) jj++; else - d [i-jj] = Complex (dr[i], di[i]); + d[i-jj] = Complex (dr[i], di[i]); } if (jj == 0 && !rvec) for (octave_idx_type i = 0; i < k; i++) @@ -2368,7 +2368,7 @@ d[i] = d[k - i - 1]; d[k - i - 1] = dtmp; } - eig_val.resize(k); + eig_val.resize (k); if (rvec) { @@ -2398,11 +2398,11 @@ { octave_idx_type off1 = i * n; octave_idx_type off2 = (i+1) * n; - if (std::imag(eig_val(i)) == 0) + if (std::imag (eig_val(i)) == 0) { for (octave_idx_type j = 0; j < n; j++) eig_vec(j,i) = - Complex(z[j+off1],0.); + Complex (z[j+off1],0.); i++; } else @@ -2410,10 +2410,10 @@ for (octave_idx_type j = 0; j < n; j++) { eig_vec(j,i) = - Complex(z[j+off1],z[j+off2]); + Complex (z[j+off1],z[j+off2]); if (i < k - 1) eig_vec(j,i+1) = - Complex(z[j+off1],-z[j+off2]); + Complex (z[j+off1],-z[j+off2]); } i+=2; } @@ -2450,9 +2450,9 @@ if (resid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - resid = ColumnVector (octave_rand::vector(n)); - octave_rand::distribution(rand_dist); + octave_rand::distribution ("uniform"); + resid = ColumnVector (octave_rand::vector (n)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -2477,7 +2477,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -2667,7 +2667,7 @@ if (dr[i] == 0.0 && di[i] == 0.0 && jj == 0) jj++; else - d [i-jj] = Complex (dr[i], di[i]); + d[i-jj] = Complex (dr[i], di[i]); } if (jj == 0 && !rvec) for (octave_idx_type i = 0; i < k; i++) @@ -2680,7 +2680,7 @@ d[i] = d[k - i - 1]; d[k - i - 1] = dtmp; } - eig_val.resize(k); + eig_val.resize (k); if (rvec) { @@ -2710,11 +2710,11 @@ { octave_idx_type off1 = i * n; octave_idx_type off2 = (i+1) * n; - if (std::imag(eig_val(i)) == 0) + if (std::imag (eig_val(i)) == 0) { for (octave_idx_type j = 0; j < n; j++) eig_vec(j,i) = - Complex(z[j+off1],0.); + Complex (z[j+off1],0.); i++; } else @@ -2722,10 +2722,10 @@ for (octave_idx_type j = 0; j < n; j++) { eig_vec(j,i) = - Complex(z[j+off1],z[j+off2]); + Complex (z[j+off1],z[j+off2]); if (i < k - 1) eig_vec(j,i+1) = - Complex(z[j+off1],-z[j+off2]); + Complex (z[j+off1],-z[j+off2]); } i+=2; } @@ -2778,13 +2778,13 @@ if (cresid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - Array<double> rr (octave_rand::vector(n)); - Array<double> ri (octave_rand::vector(n)); + octave_rand::distribution ("uniform"); + Array<double> rr (octave_rand::vector (n)); + Array<double> ri (octave_rand::vector (n)); cresid = ComplexColumnVector (n); for (octave_idx_type i = 0; i < n; i++) - cresid(i) = Complex(rr(i),ri(i)); - octave_rand::distribution(rand_dist); + cresid(i) = Complex (rr(i),ri(i)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -2809,7 +2809,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -2873,14 +2873,14 @@ b = b.hermitian (); if (permB.length () == 0) { - permB = ColumnVector(n); + permB = ColumnVector (n); for (octave_idx_type i = 0; i < n; i++) permB(i) = i; } } else { - if (! make_cholb(b, bt, permB)) + if (! make_cholb (b, bt, permB)) { (*current_liboctave_error_handler) ("eigs: The matrix B is not positive definite"); @@ -2934,7 +2934,7 @@ return -1; } - if (disp > 0 && !xisnan(workl[iptr(5)-1])) + if (disp > 0 && !xisnan (workl[iptr (5)-1])) { if (iter++) { @@ -2961,7 +2961,7 @@ ComplexMatrix mtmp (n,1); for (octave_idx_type i = 0; i < n; i++) mtmp(i,0) = workd[i + iptr(0) - 1]; - mtmp = utsolve(bt, permB, m * ltsolve(b, permB, mtmp)); + mtmp = utsolve (bt, permB, m * ltsolve (b, permB, mtmp)); for (octave_idx_type i = 0; i < n; i++) workd[i+iptr(1)-1] = mtmp(i,0); @@ -3026,7 +3026,7 @@ d[i] = d[k - i - 1]; d[k - i - 1] = ctmp; } - eig_val.resize(k); + eig_val.resize (k); if (rvec) { @@ -3051,7 +3051,7 @@ } if (note3) - eig_vec = ltsolve(b, permB, eig_vec); + eig_vec = ltsolve (b, permB, eig_vec); } } else @@ -3103,13 +3103,13 @@ if (cresid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - Array<double> rr (octave_rand::vector(n)); - Array<double> ri (octave_rand::vector(n)); + octave_rand::distribution ("uniform"); + Array<double> rr (octave_rand::vector (n)); + Array<double> ri (octave_rand::vector (n)); cresid = ComplexColumnVector (n); for (octave_idx_type i = 0; i < n; i++) - cresid(i) = Complex(rr(i),ri(i)); - octave_rand::distribution(rand_dist); + cresid(i) = Complex (rr(i),ri(i)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -3134,7 +3134,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -3201,7 +3201,7 @@ OCTAVE_LOCAL_BUFFER (octave_idx_type, P, (have_b ? b.rows () : m.rows ())); OCTAVE_LOCAL_BUFFER (octave_idx_type, Q, (have_b ? b.cols () : m.cols ())); - if (! LuAminusSigmaB(m, b, cholB, permB, sigma, L, U, P, Q)) + if (! LuAminusSigmaB (m, b, cholB, permB, sigma, L, U, P, Q)) return -1; octave_idx_type lwork = p * (3 * p + 5); @@ -3366,7 +3366,7 @@ d[i] = d[k - i - 1]; d[k - i - 1] = ctmp; } - eig_val.resize(k); + eig_val.resize (k); if (rvec) { @@ -3412,7 +3412,7 @@ int disp, int maxit) { std::string typ (_typ); - bool have_sigma = (std::abs(sigma) ? true : false); + bool have_sigma = (std::abs (sigma) ? true : false); char bmat = 'I'; octave_idx_type mode = 1; int err = 0; @@ -3420,13 +3420,13 @@ if (cresid.is_empty ()) { std::string rand_dist = octave_rand::distribution (); - octave_rand::distribution("uniform"); - Array<double> rr (octave_rand::vector(n)); - Array<double> ri (octave_rand::vector(n)); + octave_rand::distribution ("uniform"); + Array<double> rr (octave_rand::vector (n)); + Array<double> ri (octave_rand::vector (n)); cresid = ComplexColumnVector (n); for (octave_idx_type i = 0; i < n; i++) - cresid(i) = Complex(rr(i),ri(i)); - octave_rand::distribution(rand_dist); + cresid(i) = Complex (rr(i),ri(i)); + octave_rand::distribution (rand_dist); } if (n < 3) @@ -3451,7 +3451,7 @@ { (*current_liboctave_error_handler) ("eigs: Invalid number of eigenvalues to extract (must be 0 < k < n-1).\n" - " Use 'eig(full(A))' instead"); + " Use 'eig (full (A))' instead"); return -1; } @@ -3630,7 +3630,7 @@ d[i] = d[k - i - 1]; d[k - i - 1] = ctmp; } - eig_val.resize(k); + eig_val.resize (k); if (rvec) {
--- a/liboctave/f2c-main.c Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/f2c-main.c Sat Jul 28 12:06:34 2012 -0400 @@ -31,5 +31,5 @@ # ifdef __cplusplus extern "C" # endif -int F77_DUMMY_MAIN () { assert(0); return 1; } +int F77_DUMMY_MAIN () { assert (0); return 1; } #endif
--- a/liboctave/fCMatrix.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/fCMatrix.cc Sat Jul 28 12:06:34 2012 -0400 @@ -1081,7 +1081,7 @@ F77_XFCN (cgetri, CGETRI, (nc, tmp_data, nr, pipvt, z.fortran_vec (), lwork, info)); - lwork = static_cast<octave_idx_type> (std::real(z(0))); + lwork = static_cast<octave_idx_type> (std::real (z(0))); lwork = (lwork < 2 *nc ? 2*nc : lwork); z.resize (dim_vector (lwork, 1)); FloatComplex *pz = z.fortran_vec (); @@ -1091,7 +1091,7 @@ // Calculate the norm of the matrix, for later use. float anorm; if (calc_cond) - anorm = retval.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = retval.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (cgetrf, CGETRF, (nc, nc, tmp_data, nr, pipvt, info)); @@ -1165,7 +1165,7 @@ } if (!mattype.is_hermitian ()) - ret = finverse(mattype, info, rcon, force, calc_cond); + ret = finverse (mattype, info, rcon, force, calc_cond); if ((mattype.is_hermitian () || calc_cond) && rcon == 0.) ret = FloatComplexMatrix (rows (), columns (), FloatComplex (octave_Float_Inf, 0.)); @@ -1828,7 +1828,7 @@ Array<octave_idx_type> ipvt (dim_vector (nr, 1)); octave_idx_type *pipvt = ipvt.fortran_vec (); - if(anorm < 0.) + if (anorm < 0.) anorm = atmp.abs ().sum (). row(static_cast<octave_idx_type>(0)).max (); @@ -2096,7 +2096,7 @@ char job = 'L'; FloatComplexMatrix atmp = *this; FloatComplex *tmp_data = atmp.fortran_vec (); - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (cpotrf, CPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr, tmp_data, nr, info @@ -2180,7 +2180,7 @@ // Calculate the norm of the matrix, for later use. if (anorm < 0.) - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (cgetrf, CGETRF, (nr, nr, tmp_data, nr, pipvt, info)); @@ -2406,7 +2406,7 @@ FloatComplexMatrix tmp (b); tmp = solve (typ, tmp, info, rcon, sing_handler, true, transt); - return tmp.column(static_cast<octave_idx_type> (0)); + return tmp.column (static_cast<octave_idx_type> (0)); } FloatComplexMatrix
--- a/liboctave/fCNDArray.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/fCNDArray.cc Sat Jul 28 12:06:34 2012 -0400 @@ -237,7 +237,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (cfftf, CFFTF) (npts, tmp, pwsave); @@ -284,7 +284,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (cfftb, CFFTB) (npts, tmp, pwsave);
--- a/liboctave/fCmplxQR.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/fCmplxQR.cc Sat Jul 28 12:06:34 2012 -0400 @@ -471,7 +471,7 @@ if (u.length () == m && v.length () == n) { - init(q*r + FloatComplexMatrix (u) * FloatComplexMatrix (v).hermitian (), get_type ()); + init (q*r + FloatComplexMatrix (u) * FloatComplexMatrix (v).hermitian (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch"); @@ -487,7 +487,7 @@ if (u.rows () == m && v.rows () == n && u.cols () == v.cols ()) { - init(q*r + u * v.hermitian (), get_type ()); + init (q*r + u * v.hermitian (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch");
--- a/liboctave/fEIG.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/fEIG.cc Sat Jul 28 12:06:34 2012 -0400 @@ -226,8 +226,8 @@ return -1; } - lambda.elem(j) = FloatComplex (wr.elem(j), wi.elem(j)); - lambda.elem(j+1) = FloatComplex (wr.elem(j+1), wi.elem(j+1)); + lambda.elem (j) = FloatComplex (wr.elem (j), wi.elem (j)); + lambda.elem (j+1) = FloatComplex (wr.elem (j+1), wi.elem (j+1)); for (octave_idx_type i = 0; i < nvr; i++) { @@ -576,10 +576,10 @@ return -1; } - lambda.elem(j) = FloatComplex (ar.elem(j) / beta.elem (j), - ai.elem(j) / beta.elem (j)); - lambda.elem(j+1) = FloatComplex (ar.elem(j+1) / beta.elem (j+1), - ai.elem(j+1) / beta.elem (j+1)); + lambda.elem (j) = FloatComplex (ar.elem (j) / beta.elem (j), + ai.elem (j) / beta.elem (j)); + lambda.elem (j+1) = FloatComplex (ar.elem (j+1) / beta.elem (j+1), + ai.elem (j+1) / beta.elem (j+1)); for (octave_idx_type i = 0; i < nvr; i++) { @@ -775,7 +775,7 @@ lambda.resize (n); for (octave_idx_type j = 0; j < n; j++) - lambda.elem (j) = alpha.elem (j) / beta.elem(j); + lambda.elem (j) = alpha.elem (j) / beta.elem (j); v = vtmp; }
--- a/liboctave/fMatrix.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/fMatrix.cc Sat Jul 28 12:06:34 2012 -0400 @@ -763,7 +763,7 @@ // Calculate the norm of the matrix, for later use. float anorm = 0; if (calc_cond) - anorm = retval.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = retval.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (sgetrf, SGETRF, (nc, nc, tmp_data, nr, pipvt, info)); @@ -838,7 +838,7 @@ } if (!mattype.is_hermitian ()) - ret = finverse(mattype, info, rcon, force, calc_cond); + ret = finverse (mattype, info, rcon, force, calc_cond); if ((mattype.is_hermitian () || calc_cond) && rcon == 0.) ret = FloatMatrix (rows (), columns (), octave_Float_Inf); @@ -1462,7 +1462,7 @@ octave_idx_type info = 0; char job = 'L'; anorm = atmp.abs ().sum (). - row(static_cast<octave_idx_type>(0)).max (); + row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (spotrf, SPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr, tmp_data, nr, info @@ -1498,7 +1498,7 @@ Array<octave_idx_type> ipvt (dim_vector (nr, 1)); octave_idx_type *pipvt = ipvt.fortran_vec (); - if(anorm < 0.) + if (anorm < 0.) anorm = atmp.abs ().sum (). row(static_cast<octave_idx_type>(0)).max (); @@ -1762,7 +1762,7 @@ char job = 'L'; FloatMatrix atmp = *this; float *tmp_data = atmp.fortran_vec (); - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); F77_XFCN (spotrf, SPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr, tmp_data, nr, info @@ -1838,8 +1838,8 @@ FloatMatrix atmp = *this; float *tmp_data = atmp.fortran_vec (); - if(anorm < 0.) - anorm = atmp.abs ().sum ().row(static_cast<octave_idx_type>(0)).max (); + if (anorm < 0.) + anorm = atmp.abs ().sum ().row (static_cast<octave_idx_type>(0)).max (); Array<float> z (dim_vector (4 * nc, 1)); float *pz = z.fortran_vec (); @@ -2062,7 +2062,7 @@ { FloatMatrix tmp (b); tmp = solve (typ, tmp, info, rcon, sing_handler, true, transt); - return tmp.column(static_cast<octave_idx_type> (0)); + return tmp.column (static_cast<octave_idx_type> (0)); } FloatComplexColumnVector @@ -2094,7 +2094,7 @@ solve_singularity_handler sing_handler, blas_trans_type transt) const { FloatComplexMatrix tmp (*this); - return tmp.solve(typ, b, info, rcon, sing_handler, transt); + return tmp.solve (typ, b, info, rcon, sing_handler, transt); } FloatMatrix
--- a/liboctave/fNDArray.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/fNDArray.cc Sat Jul 28 12:06:34 2012 -0400 @@ -241,7 +241,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (cfftf, CFFTF) (npts, tmp, pwsave); @@ -288,7 +288,7 @@ octave_quit (); for (octave_idx_type i = 0; i < npts; i++) - tmp[i] = elem((i + k*npts)*stride + j*dist); + tmp[i] = elem ((i + k*npts)*stride + j*dist); F77_FUNC (cfftb, CFFTB) (npts, tmp, pwsave);
--- a/liboctave/floatQR.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/floatQR.cc Sat Jul 28 12:06:34 2012 -0400 @@ -464,7 +464,7 @@ if (u.length () == m && v.length () == n) { - init(q*r + FloatMatrix (u) * FloatMatrix (v).transpose (), get_type ()); + init (q*r + FloatMatrix (u) * FloatMatrix (v).transpose (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch"); @@ -480,7 +480,7 @@ if (u.rows () == m && v.rows () == n && u.cols () == v.cols ()) { - init(q*r + u * v.transpose (), get_type ()); + init (q*r + u * v.transpose (), get_type ()); } else (*current_liboctave_error_handler) ("qrupdate: dimensions mismatch");
--- a/liboctave/floatSVD.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/floatSVD.cc Sat Jul 28 12:06:34 2012 -0400 @@ -135,7 +135,7 @@ float *u = left_sm.fortran_vec (); sigma.resize (nrow_s, ncol_s); - float *s_vec = sigma.fortran_vec (); + float *s_vec = sigma.fortran_vec (); if (! (jobv == 'N' || jobv == 'O')) right_sm.resize (nrow_vt, n);
--- a/liboctave/idx-vector.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/idx-vector.cc Sat Jul 28 12:06:34 2012 -0400 @@ -108,7 +108,7 @@ idx_vector::idx_range_rep::idx_range_rep (octave_idx_type _start, octave_idx_type _limit, octave_idx_type _step) - : start(_start), len (_step ? std::max((_limit - _start) / _step, static_cast<octave_idx_type> (0)) : -1), step (_step) + : start(_start), len (_step ? std::max ((_limit - _start) / _step, static_cast<octave_idx_type> (0)) : -1), step (_step) { if (len < 0) { @@ -325,7 +325,7 @@ { if (len != 0) { - octave_idx_type *d = new octave_idx_type[len]; + octave_idx_type *d = new octave_idx_type [len]; for (octave_idx_type i = 0; i < len; i++) d[i] = convert_index (nda.xelem (i), err, ext); data = d; @@ -489,7 +489,7 @@ if (ext > len*xlog2 (1.0 + len)) { // Use standard sort via octave_sort. - octave_idx_type *new_data = new octave_idx_type[len]; + octave_idx_type *new_data = new octave_idx_type [len]; new_rep->data = new_data; std::copy (data, data + len, new_data); @@ -524,7 +524,7 @@ else new_rep->orig_dims = dim_vector (new_len, 1); - octave_idx_type *new_data = new octave_idx_type[new_len]; + octave_idx_type *new_data = new octave_idx_type [new_len]; new_rep->data = new_data; for (octave_idx_type i = 0, j = 0; i < ext; i++) @@ -538,7 +538,7 @@ for (octave_idx_type i = 0; i < len; i++) cnt[data[i]]++; - octave_idx_type *new_data = new octave_idx_type[len]; + octave_idx_type *new_data = new octave_idx_type [len]; new_rep->data = new_data; for (octave_idx_type i = 0, j = 0; i < ext; i++) @@ -1145,7 +1145,7 @@ if (is_colon_equiv (n)) retval = true; - else if (length (n) == n && extent(n) == n) + else if (length(n) == n && extent(n) == n) { OCTAVE_LOCAL_BUFFER_INIT (bool, left, n, true); @@ -1190,7 +1190,7 @@ const octave_idx_type *ri = r->get_data (); Array<octave_idx_type> idx (orig_dimensions ()); for (octave_idx_type i = 0; i < n; i++) - idx.xelem(ri[i]) = i; + idx.xelem (ri[i]) = i; retval = new idx_vector_rep (idx, r->extent (0), DIRECT); break; } @@ -1330,7 +1330,7 @@ /* -%!error id=Octave:index-out-of-bounds 1(find([1,1] != 0)) -%!assert ((1:3)(find([1,0,1] != 0)), [1,3]) +%!error id=Octave:index-out-of-bounds 1(find ([1,1] != 0)) +%!assert ((1:3)(find ([1,0,1] != 0)), [1,3]) */
--- a/liboctave/kpse.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/kpse.cc Sat Jul 28 12:06:34 2012 -0400 @@ -35,7 +35,7 @@ myself; if you do, I'd be grateful for any changes. --kb@mail.tug.org */ /* If we have either DOS or OS2, we are DOSISH. */ -#if defined (DOS) || defined (OS2) || defined (WIN32) || defined(__MSDOS__) +#if defined (DOS) || defined (OS2) || defined (WIN32) || defined (__MSDOS__) #define DOSISH #endif @@ -44,11 +44,11 @@ #endif extern "C" { -#if defined(__MINGW32__) +#if defined (__MINGW32__) #include <windows.h> #include <fcntl.h> #include <dirent.h> -#elif defined(WIN32) +#elif defined (WIN32) #ifndef _MSC_VER #define __STDC__ 1 #include "win32lib.h" @@ -76,7 +76,7 @@ /* If you want to find subdirectories in a directory with non-Unix semantics (specifically, if a directory with no subdirectories does not have exactly two links), define this. */ -#if defined(__DJGPP__) || ! defined (DOSISH) +#if defined (__DJGPP__) || ! defined (DOSISH) /* Surprise! DJGPP returns st_nlink exactly like on Unix. */ #define ST_NLINK_TRICK #endif /* either not DOSISH or __DJGPP__ */ @@ -99,7 +99,7 @@ #define DIR_SEP '/' #define DIR_SEP_STRING "/" #define IS_DEVICE_SEP(ch) ((ch) == ':') -#define NAME_BEGINS_WITH_DEVICE(name) ((name.length()>0) && IS_DEVICE_SEP((name)[1])) +#define NAME_BEGINS_WITH_DEVICE(name) ((name.length ()>0) && IS_DEVICE_SEP((name)[1])) /* On DOS, it's good to allow both \ and / between directories. */ #define IS_DIR_SEP(ch) ((ch) == '/' || (ch) == '\\') #else
--- a/liboctave/lo-macros.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/lo-macros.h Sat Jul 28 12:06:34 2012 -0400 @@ -92,4 +92,8 @@ #define OCT_MAKE_DECL_LIST(TYPE, PREFIX, NUM) \ OCT_ITERATE_PARAM_MACRO(OCT_MAKE_DECL_LIST_HELPER, TYPE PREFIX, NUM) +// expands to PREFIX0, PREFIX1, ..., PREFIX ## (NUM-1) +#define OCT_MAKE_ARG_LIST(PREFIX, NUM) \ + OCT_ITERATE_PARAM_MACRO(OCT_MAKE_DECL_LIST_HELPER, PREFIX, NUM) + #endif
--- a/liboctave/lo-specfun.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/lo-specfun.cc Sat Jul 28 12:06:34 2012 -0400 @@ -454,7 +454,7 @@ #endif Complex -expm1(const Complex& x) +expm1 (const Complex& x) { Complex retval; @@ -509,7 +509,7 @@ #endif FloatComplex -expm1(const FloatComplex& x) +expm1 (const FloatComplex& x) { FloatComplex retval; @@ -565,7 +565,7 @@ atan2 (1 + r, i)); } else - retval = std::log (Complex(1) + x); + retval = std::log (Complex (1) + x); return retval; } @@ -624,7 +624,7 @@ atan2 (1 + r, i)); } else - retval = std::log (FloatComplex(1) + x); + retval = std::log (FloatComplex (1) + x); return retval; } @@ -873,7 +873,7 @@ if (kode == 2) { // Compensate for different scaling factor of besk. - tmp2 *= exp(-z - std::abs(z.real ())); + tmp2 *= exp (-z - std::abs (z.real ())); } tmp += tmp2; @@ -1483,7 +1483,7 @@ if (kode == 2) { // Compensate for different scaling factor of besk. - tmp2 *= exp(-z - std::abs(z.real ())); + tmp2 *= exp (-z - std::abs (z.real ())); } tmp += tmp2; @@ -1893,7 +1893,7 @@ if (! scaled) { - Complex expz = exp (- 2.0 / 3.0 * z * sqrt(z)); + Complex expz = exp (- 2.0 / 3.0 * z * sqrt (z)); double rexpz = real (expz); double iexpz = imag (expz); @@ -2023,7 +2023,7 @@ if (! scaled) { - FloatComplex expz = exp (- static_cast<float> (2.0 / 3.0) * z * sqrt(z)); + FloatComplex expz = exp (- static_cast<float> (2.0 / 3.0) * z * sqrt (z)); float rexpz = real (expz); float iexpz = imag (expz); @@ -3130,7 +3130,7 @@ if (x < 0) { double y2 = ceil (x / 16.0) * 16.0, del = (x-y2)*(x+y2); - result = 2*(std::exp(y2*y2) * std::exp(del)) - result; + result = 2*(std::exp (y2*y2) * std::exp (del)) - result; } }
--- a/liboctave/mx-inlines.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/mx-inlines.cc Sat Jul 28 12:06:34 2012 -0400 @@ -483,12 +483,12 @@ #define OP_RED_SUMSQ(ac, el) ac += el*el #define OP_RED_SUMSQC(ac, el) ac += cabsq (el) -inline void op_dble_sum(double& ac, float el) +inline void op_dble_sum (double& ac, float el) { ac += el; } -inline void op_dble_sum(Complex& ac, const FloatComplex& el) +inline void op_dble_sum (Complex& ac, const FloatComplex& el) { ac += el; } // FIXME: guaranteed? template <class T> -inline void op_dble_sum(double& ac, const octave_int<T>& el) +inline void op_dble_sum (double& ac, const octave_int<T>& el) { ac += el.double_value (); } // The following two implement a simple short-circuiting. @@ -1177,7 +1177,7 @@ { octave_idx_type l, n, u; dim_vector dims = src.dims (); - // M*b inconsistency: sum([]) = 0 etc. + // M*b inconsistency: sum ([]) = 0 etc. if (dims.length () == 2 && dims(0) == 0 && dims(1) == 0) dims (1) = 1;
--- a/liboctave/mx-op-defs.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/mx-op-defs.h Sat Jul 28 12:06:34 2012 -0400 @@ -413,7 +413,7 @@ octave_idx_type len = dm.length (); \ \ for (octave_idx_type i = 0; i < len; i++) \ - r.elem(i, i) OPEQ dm.elem(i, i); \ + r.elem (i, i) OPEQ dm.elem (i, i); \ } \ } \ \ @@ -483,7 +483,7 @@ octave_idx_type len = dm.length (); \ \ for (octave_idx_type i = 0; i < len; i++) \ - r.elem(i, i) OPEQ dm.elem(i, i); \ + r.elem (i, i) OPEQ dm.elem (i, i); \ } \ else \ r.resize (m_nr, m_nc); \
--- a/liboctave/oct-binmap.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-binmap.h Sat Jul 28 12:06:34 2012 -0400 @@ -30,7 +30,7 @@ #include "bsxfun.h" // This source file implements a general binary maping function for -// arrays. The syntax is binmap<type> (a, b, f, [name]). type denotes +// arrays. The syntax is binmap<type> (a, b, f,[name]). type denotes // the expected return type of the operation. a, b, should be one of // the 6 combinations: // @@ -223,7 +223,7 @@ for (octave_idx_type i = 0; i < nz; i++) { octave_quit (); - retval.xdata(i) = fcn (x, ys.data(i)); + retval.xdata (i) = fcn (x, ys.data (i)); } octave_quit (); @@ -241,7 +241,7 @@ for (octave_idx_type i = 0; i < nz; i++) { octave_quit (); - retval.xdata(i) = fcn (xs.data(i), y); + retval.xdata (i) = fcn (xs.data (i), y); } octave_quit (); @@ -276,49 +276,49 @@ for (octave_idx_type j = 0; j < nc; j++) { octave_quit (); - octave_idx_type ix = xs.cidx(j), iy = ys.cidx(j); - octave_idx_type ux = xs.cidx(j+1), uy = ys.cidx(j+1); + octave_idx_type ix = xs.cidx (j), iy = ys.cidx (j); + octave_idx_type ux = xs.cidx (j+1), uy = ys.cidx (j+1); while (ix != ux || iy != uy) { - octave_idx_type rx = xs.ridx(ix), ry = ys.ridx(ix); + octave_idx_type rx = xs.ridx (ix), ry = ys.ridx (ix); ix += rx <= ry; iy += ry <= rx; nz++; } - retval.xcidx(j+1) = nz; + retval.xcidx (j+1) = nz; } // Allocate space. - retval.change_capacity (retval.xcidx(nc)); + retval.change_capacity (retval.xcidx (nc)); // Fill. nz = 0; for (octave_idx_type j = 0; j < nc; j++) { octave_quit (); - octave_idx_type ix = xs.cidx(j), iy = ys.cidx(j); - octave_idx_type ux = xs.cidx(j+1), uy = ys.cidx(j+1); + octave_idx_type ix = xs.cidx (j), iy = ys.cidx (j); + octave_idx_type ux = xs.cidx (j+1), uy = ys.cidx (j+1); while (ix != ux || iy != uy) { - octave_idx_type rx = xs.ridx(ix), ry = ys.ridx(ix); + octave_idx_type rx = xs.ridx (ix), ry = ys.ridx (ix); if (rx == ry) { - retval.xridx(nz) = rx; - retval.xdata(nz) = fcn (xs.data(ix), ys.data(iy)); + retval.xridx (nz) = rx; + retval.xdata (nz) = fcn (xs.data (ix), ys.data (iy)); ix++; iy++; } else if (rx < ry) { - retval.xridx(nz) = rx; - retval.xdata(nz) = fcn (xs.data(ix), yzero); + retval.xridx (nz) = rx; + retval.xdata (nz) = fcn (xs.data (ix), yzero); ix++; } else if (ry < rx) { - retval.xridx(nz) = ry; - retval.xdata(nz) = fcn (xzero, ys.data(iy)); + retval.xridx (nz) = ry; + retval.xdata (nz) = fcn (xzero, ys.data (iy)); iy++; }
--- a/liboctave/oct-fftw.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-fftw.cc Sat Jul 28 12:06:34 2012 -0400 @@ -723,7 +723,7 @@ for (size_t i = 0; i < nr; i++) for (size_t j = nc/2+1; j < nc; j++) - out[j*stride + i*dist] = conj(out[(nc - j)*stride + i*dist]); + out[j*stride + i*dist] = conj (out[(nc - j)*stride + i*dist]); octave_quit (); } @@ -758,10 +758,10 @@ { for (size_t j = 1; j < nr; j++) for (size_t k = nc/2+1; k < nc; k++) - out[k + (j + i*nr)*nc] = conj(out[nc - k + ((i+1)*nr - j)*nc]); + out[k + (j + i*nr)*nc] = conj (out[nc - k + ((i+1)*nr - j)*nc]); for (size_t j = nc/2+1; j < nc; j++) - out[j + i*nr*nc] = conj(out[(i*nr+1)*nc - j]); + out[j + i*nr*nc] = conj (out[(i*nr+1)*nc - j]); } octave_quit (); @@ -782,7 +782,7 @@ for (size_t l = nc/2+1; l < nc; l++) { T tmp = out[i+ j + k + l]; - out[i + j + k + l] = out[i + jj + k + l]; + out[i + j + k + l] = out[i + jj + k + l]; out[i + jj + k + l] = tmp; } jstart = jmax;
--- a/liboctave/oct-group.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-group.h Sat Jul 28 12:06:34 2012 -0400 @@ -48,7 +48,7 @@ { if (this != &gr) { - gr_name = gr.gr_name; + gr_name = gr.gr_name; gr_passwd = gr.gr_passwd; gr_gid = gr.gr_gid; gr_mem = gr.gr_mem;
--- a/liboctave/oct-inttypes.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-inttypes.cc Sat Jul 28 12:06:34 2012 -0400 @@ -272,7 +272,7 @@ INT_DOUBLE_BINOP_DECL (+, uint64) { - return (y < 0) ? x - octave_uint64(-y) : x + octave_uint64(y); + return (y < 0) ? x - octave_uint64 (-y) : x + octave_uint64 (y); } DOUBLE_INT_BINOP_DECL (+, uint64) @@ -288,7 +288,7 @@ // probably), the above will work as expected. If not, it's more // complicated - as long as y is within _twice_ the signed range, the // result may still be an integer. An instance of such an operation is - // 3*2**62 + (1+intmin('int64')) that should yield int64(2**62) + 1. So + // 3*2**62 + (1+intmin ('int64')) that should yield int64 (2**62) + 1. So // what we do is to try to convert y/2 and add it twice. Note that if y/2 // overflows, the result must overflow as well, and that y/2 cannot be a // fractional number. @@ -310,12 +310,12 @@ DOUBLE_INT_BINOP_DECL (-, uint64) { if (x <= static_cast<double> (octave_uint64::max ())) - return octave_uint64(x) - y; + return octave_uint64 (x) - y; else { // Again a trick to get the corner cases right. Things like - // 3**2**63 - intmax('uint64') should produce the correct result, i.e. - // int64(2**63) + 1. + // 3**2**63 - intmax ('uint64') should produce the correct result, i.e. + // int64 (2**63) + 1. const double p2_64 = std::pow (2.0, 64); if (y.bool_value ()) { @@ -340,7 +340,7 @@ // be eliminated at compile time. if (twosc && y.value () == std::numeric_limits<int64_t>::min ()) { - return octave_int64 (x + std::pow(2.0, 63)); + return octave_int64 (x + std::pow (2.0, 63)); } else return x + (-y);
--- a/liboctave/oct-inttypes.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-inttypes.h Sat Jul 28 12:06:34 2012 -0400 @@ -825,7 +825,7 @@ static int nbits (void) { return std::numeric_limits<T>::digits; } - static int byte_size (void) { return sizeof(T); } + static int byte_size (void) { return sizeof (T); } static const char *type_name ();
--- a/liboctave/oct-locbuf.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-locbuf.h Sat Jul 28 12:06:34 2012 -0400 @@ -38,7 +38,7 @@ : data (0) { if (size) - data = new T[size]; + data = new T [size]; } ~octave_local_buffer (void) { delete [] data; } operator T *() const { return data; } @@ -204,7 +204,7 @@ // about shadowed parameters. #define OCTAVE_LOCAL_BUFFER_INIT(T, buf, size, value) \ - OCTAVE_LOCAL_BUFFER(T, buf, size); \ + OCTAVE_LOCAL_BUFFER (T, buf, size); \ for (size_t _buf_iter = 0, _buf_size = size; \ _buf_iter < _buf_size; _buf_iter++) \ buf[_buf_iter] = value
--- a/liboctave/oct-md5.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-md5.cc Sat Jul 28 12:06:34 2012 -0400 @@ -36,7 +36,7 @@ static std::string oct_md5_result_to_str (const unsigned char *buf) { - char tmp [33]; + char tmp[33]; sprintf (tmp, "%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x",
--- a/liboctave/oct-mem.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-mem.h Sat Jul 28 12:06:34 2012 -0400 @@ -128,7 +128,7 @@ // Some systems let us allocate > 2GB memory even though size_t, which is either // buggy or completely cuckoo, so let's check here to stay safe. safe_size_comp (n, sizeof (T)); - return new T[n]; + return new T [n]; } template <class T> inline void no_ctor_delete (T *ptr) @@ -137,7 +137,7 @@ #define DEFINE_POD_NEW_DELETE(T) \ template <> \ inline T *no_ctor_new<T > (size_t n) \ -{ return reinterpret_cast<T *> (new char[safe_size_comp (n, sizeof (T))]); } \ +{ return reinterpret_cast<T *> (new char [safe_size_comp (n, sizeof (T))]); } \ template <> \ inline void no_ctor_delete<T > (T *ptr) \ { delete [] reinterpret_cast<char *> (ptr); }
--- a/liboctave/oct-rand.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-rand.cc Sat Jul 28 12:06:34 2012 -0400 @@ -360,7 +360,7 @@ break; case poisson_dist: - if (a < 0.0 || xisnan(a) || xisinf(a)) + if (a < 0.0 || xisnan (a) || xisinf (a)) retval = octave_NaN; else { @@ -371,7 +371,7 @@ break; case gamma_dist: - if (a <= 0.0 || xisnan(a) || xisinf(a)) + if (a <= 0.0 || xisnan (a) || xisinf (a)) retval = octave_NaN; else F77_FUNC (dgengam, DGENGAM) (1.0, a, retval); @@ -443,7 +443,7 @@ break; case poisson_dist: - if (da < 0.0 || xisnan(da) || xisinf(da)) + if (da < 0.0 || xisnan (da) || xisinf (da)) dretval = octave_NaN; else { @@ -454,7 +454,7 @@ break; case gamma_dist: - if (da <= 0.0 || xisnan(da) || xisinf(da)) + if (da <= 0.0 || xisnan (da) || xisinf (da)) retval = octave_NaN; else F77_FUNC (dgengam, DGENGAM) (1.0, da, dretval); @@ -630,7 +630,7 @@ oct_get_state (tmp); for (octave_idx_type i = 0; i <= MT_N; i++) - s.elem (i) = static_cast<double> (tmp [i]); + s.elem (i) = static_cast<double> (tmp[i]); return s; } @@ -672,7 +672,7 @@ OCTAVE_LOCAL_BUFFER (uint32_t, tmp, MT_N + 1); for (octave_idx_type i = 0; i < n; i++) - tmp[i] = static_cast<uint32_t> (s.elem(i)); + tmp[i] = static_cast<uint32_t> (s.elem (i)); if (len == MT_N + 1 && tmp[MT_N] <= MT_N && tmp[MT_N] > 0) oct_set_state (tmp); @@ -748,7 +748,7 @@ case poisson_dist: if (use_old_generators) { - if (a < 0.0 || xisnan(a) || xisinf(a)) + if (a < 0.0 || xisnan (a) || xisinf (a)) #define RAND_FUNC(x) x = octave_NaN; MAKE_RAND (len); #undef RAND_FUNC @@ -769,7 +769,7 @@ case gamma_dist: if (use_old_generators) { - if (a <= 0.0 || xisnan(a) || xisinf(a)) + if (a <= 0.0 || xisnan (a) || xisinf (a)) #define RAND_FUNC(x) x = octave_NaN; MAKE_RAND (len); #undef RAND_FUNC @@ -838,7 +838,7 @@ if (use_old_generators) { double da = a; - if (da < 0.0 || xisnan(da) || xisinf(da)) + if (da < 0.0 || xisnan (da) || xisinf (da)) #define RAND_FUNC(x) x = octave_NaN; MAKE_RAND (len); #undef RAND_FUNC @@ -860,7 +860,7 @@ if (use_old_generators) { double da = a; - if (da <= 0.0 || xisnan(da) || xisinf(da)) + if (da <= 0.0 || xisnan (da) || xisinf (da)) #define RAND_FUNC(x) x = octave_NaN; MAKE_RAND (len); #undef RAND_FUNC
--- a/liboctave/oct-refcount.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-refcount.h Sat Jul 28 12:06:34 2012 -0400 @@ -82,6 +82,11 @@ return static_cast<count_type const volatile&> (count); } + count_type *get (void) + { + return &count; + } + private: count_type count; };
--- a/liboctave/oct-sort.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-sort.cc Sat Jul 28 12:06:34 2012 -0400 @@ -542,7 +542,7 @@ */ delete [] a; delete [] ia; // Must do this or fool possible next getmemi. - a = new T[need]; + a = new T [need]; alloced = need; } @@ -561,8 +561,8 @@ delete [] a; delete [] ia; - a = new T[need]; - ia = new octave_idx_type[need]; + a = new T [need]; + ia = new octave_idx_type [need]; alloced = need; } @@ -1184,7 +1184,7 @@ return nb; /* Merge what remains of the runs, using a temp array with - * min(na, nb) elements. + * min (na, nb) elements. */ if (na <= nb) return merge_lo (pa, na, pb, nb, comp); @@ -1238,7 +1238,7 @@ return nb; /* Merge what remains of the runs, using a temp array with - * min(na, nb) elements. + * min (na, nb) elements. */ if (na <= nb) return merge_lo (pa, ipa, na, pb, ipb, nb, comp); @@ -1413,7 +1413,7 @@ goto fail; if (descending) std::reverse (data + lo, data + lo + n); - /* If short, extend to min(minrun, nremaining). */ + /* If short, extend to min (minrun, nremaining). */ if (n < minrun) { const octave_idx_type force = nremaining <= minrun ? nremaining : minrun; @@ -1475,7 +1475,7 @@ std::reverse (data + lo, data + lo + n); std::reverse (idx + lo, idx + lo + n); } - /* If short, extend to min(minrun, nremaining). */ + /* If short, extend to min (minrun, nremaining). */ if (n < minrun) { const octave_idx_type force = nremaining <= minrun ? nremaining : minrun; @@ -1610,9 +1610,9 @@ while (! runs.empty ()) { - octave_idx_type col = runs.top ().col; - octave_idx_type ofs = runs.top ().ofs; - octave_idx_type nel = runs.top ().nel; + octave_idx_type col = runs.top ().col; + octave_idx_type ofs = runs.top ().ofs; + octave_idx_type nel = runs.top ().nel; runs.pop (); assert (nel > 1);
--- a/liboctave/oct-syscalls.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-syscalls.cc Sat Jul 28 12:06:34 2012 -0400 @@ -358,7 +358,7 @@ (*current_liboctave_error_handler)(child_msg.c_str ()); - exit(0); + exit (0); } else { @@ -372,8 +372,8 @@ else #endif { - fildes[0] = child_stdin [1]; - fildes[1] = child_stdout [0]; + fildes[0] = child_stdin[1]; + fildes[1] = child_stdout[0]; return pid; } }
--- a/liboctave/oct-time.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/oct-time.cc Sat Jul 28 12:06:34 2012 -0400 @@ -175,7 +175,7 @@ while (chars_written == 0) { delete [] buf; - buf = new char[bufsize]; + buf = new char [bufsize]; buf[0] = '\0'; chars_written = nstrftime (buf, bufsize, fmt_str, &t, 0, 0);
--- a/liboctave/randgamma.c Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/randgamma.c Sat Jul 28 12:06:34 2012 -0400 @@ -25,8 +25,8 @@ /* -double randg(a) -void fill_randg(a,n,x) +double randg (a) +void fill_randg (a,n,x) Generate a series of standard gamma distributions. @@ -99,9 +99,9 @@ oct_fill_randg (double a, octave_idx_type n, double *r) { octave_idx_type i; - /* If a < 1, start by generating gamma(1+a) */ + /* If a < 1, start by generating gamma (1+a) */ const double d = (a < 1. ? 1.+a : a) - 1./3.; - const double c = 1./sqrt(9.*d); + const double c = 1./sqrt (9.*d); /* Handle invalid cases */ if (a <= 0 || INFINITE(a)) @@ -122,7 +122,7 @@ goto restart; /* rare, so don't bother moving up */ u = RUNI; xsq = x*x; - if (u >= 1.-0.0331*xsq*xsq && log(u) >= 0.5*xsq + d*(1-v+log(v))) + if (u >= 1.-0.0331*xsq*xsq && log (u) >= 0.5*xsq + d*(1-v+log (v))) goto restart; r[i] = d*v; } @@ -130,7 +130,7 @@ { /* Use gamma(a) = gamma(1+a)*U^(1/a) */ /* Given REXP = -log(U) then U^(1/a) = exp(-REXP/a) */ for (i = 0; i < n; i++) - r[i] *= exp(-REXP/a); + r[i] *= exp (-REXP/a); } } @@ -138,7 +138,7 @@ oct_randg (double a) { double ret; - oct_fill_randg(a,1,&ret); + oct_fill_randg (a,1,&ret); return ret; } @@ -157,7 +157,7 @@ octave_idx_type i; /* If a < 1, start by generating gamma(1+a) */ const float d = (a < 1. ? 1.+a : a) - 1./3.; - const float c = 1./sqrt(9.*d); + const float c = 1./sqrt (9.*d); /* Handle invalid cases */ if (a <= 0 || INFINITE(a)) @@ -178,7 +178,7 @@ goto frestart; /* rare, so don't bother moving up */ u = RUNI; xsq = x*x; - if (u >= 1.-0.0331*xsq*xsq && log(u) >= 0.5*xsq + d*(1-v+log(v))) + if (u >= 1.-0.0331*xsq*xsq && log (u) >= 0.5*xsq + d*(1-v+log (v))) goto frestart; r[i] = d*v; } @@ -186,7 +186,7 @@ { /* Use gamma(a) = gamma(1+a)*U^(1/a) */ /* Given REXP = -log(U) then U^(1/a) = exp(-REXP/a) */ for (i = 0; i < n; i++) - r[i] *= exp(-REXP/a); + r[i] *= exp (-REXP/a); } } @@ -194,6 +194,6 @@ oct_float_randg (float a) { float ret; - oct_fill_float_randg(a,1,&ret); + oct_fill_float_randg (a,1,&ret); return ret; }
--- a/liboctave/randmtzig.c Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/randmtzig.c Sat Jul 28 12:06:34 2012 -0400 @@ -117,39 +117,39 @@ All generators share the same state vector. === Mersenne Twister === - void oct_init_by_int(uint32_t s) 32-bit initial state - void oct_init_by_array(uint32_t k[],int m) m*32-bit initial state - void oct_init_by_entropy(void) random initial state - void oct_get_state(uint32_t save[MT_N+1]) saves state in array - void oct_set_state(uint32_t save[MT_N+1]) restores state from array - static uint32_t randmt(void) returns 32-bit unsigned int + void oct_init_by_int (uint32_t s) 32-bit initial state + void oct_init_by_array (uint32_t k[],int m) m*32-bit initial state + void oct_init_by_entropy (void) random initial state + void oct_get_state (uint32_t save[MT_N+1]) saves state in array + void oct_set_state (uint32_t save[MT_N+1]) restores state from array + static uint32_t randmt (void) returns 32-bit unsigned int === inline generators === - static uint32_t randi32(void) returns 32-bit unsigned int - static uint64_t randi53(void) returns 53-bit unsigned int - static uint64_t randi54(void) returns 54-bit unsigned int - static float randu32(void) returns 32-bit uniform in (0,1) - static double randu53(void) returns 53-bit uniform in (0,1) + static uint32_t randi32 (void) returns 32-bit unsigned int + static uint64_t randi53 (void) returns 53-bit unsigned int + static uint64_t randi54 (void) returns 54-bit unsigned int + static float randu32 (void) returns 32-bit uniform in (0,1) + static double randu53 (void) returns 53-bit uniform in (0,1) - double oct_randu(void) returns M-bit uniform in (0,1) - double oct_randn(void) returns M-bit standard normal - double oct_rande(void) returns N-bit standard exponential + double oct_randu (void) returns M-bit uniform in (0,1) + double oct_randn (void) returns M-bit standard normal + double oct_rande (void) returns N-bit standard exponential - float oct_float_randu(void) returns M-bit uniform in (0,1) - float oct_float_randn(void) returns M-bit standard normal - float oct_float_rande(void) returns N-bit standard exponential + float oct_float_randu (void) returns M-bit uniform in (0,1) + float oct_float_randn (void) returns M-bit standard normal + float oct_float_rande (void) returns N-bit standard exponential === Array generators === - void oct_fill_randi32(octave_idx_type, uint32_t []) - void oct_fill_randi64(octave_idx_type, uint64_t []) + void oct_fill_randi32 (octave_idx_type, uint32_t []) + void oct_fill_randi64 (octave_idx_type, uint64_t []) - void oct_fill_randu(octave_idx_type, double []) - void oct_fill_randn(octave_idx_type, double []) - void oct_fill_rande(octave_idx_type, double []) + void oct_fill_randu (octave_idx_type, double []) + void oct_fill_randn (octave_idx_type, double []) + void oct_fill_rande (octave_idx_type, double []) - void oct_fill_float_randu(octave_idx_type, float []) - void oct_fill_float_randn(octave_idx_type, float []) - void oct_fill_float_rande(octave_idx_type, float []) + void oct_fill_float_randu (octave_idx_type, float []) + void oct_fill_float_randn (octave_idx_type, float []) + void oct_fill_float_rande (octave_idx_type, float []) */ #if defined (HAVE_CONFIG_H) @@ -166,9 +166,9 @@ #include "lo-math.h" #include "randmtzig.h" -/* FIXME may want to suppress X86 if sizeof(long)>4 */ -#if !defined(USE_X86_32) -# if defined(i386) || defined(HAVE_X86_32) +/* FIXME may want to suppress X86 if sizeof(long) > 4 */ +#if !defined (USE_X86_32) +# if defined (i386) || defined (HAVE_X86_32) # define USE_X86_32 1 # else # define USE_X86_32 0 @@ -260,34 +260,34 @@ int n = 0; /* Look for entropy in /dev/urandom */ - FILE* urandom =fopen("/dev/urandom", "rb"); + FILE* urandom =fopen ("/dev/urandom", "rb"); if (urandom) { while (n < MT_N) { unsigned char word[4]; - if (fread(word, 4, 1, urandom) != 1) + if (fread (word, 4, 1, urandom) != 1) break; entropy[n++] = word[0]+(word[1]<<8)+(word[2]<<16)+(word[3]<<24); } - fclose(urandom); + fclose (urandom); } /* If there isn't enough entropy, gather some from various sources */ if (n < MT_N) - entropy[n++] = time(NULL); /* Current time in seconds */ + entropy[n++] = time (NULL); /* Current time in seconds */ if (n < MT_N) entropy[n++] = clock (); /* CPU time used (usec) */ #ifdef HAVE_GETTIMEOFDAY if (n < MT_N) { struct timeval tv; - if (gettimeofday(&tv, NULL) != -1) + if (gettimeofday (&tv, NULL) != -1) entropy[n++] = tv.tv_usec; /* Fractional part of current time */ } #endif /* Send all the entropy into the initial state vector */ - oct_init_by_array(entropy,n); + oct_init_by_array (entropy,n); } void @@ -506,7 +506,7 @@ /* New x is given by x = f^{-1}(v/x_{i+1} + f(x_{i+1})), thus * need inverse operator of y = exp(-0.5*x*x) -> x = sqrt(-2*ln(y)) */ - x = sqrt(-2. * log(NOR_SECTION_AREA / x1 + fi[i+1])); + x = sqrt (-2. * log (NOR_SECTION_AREA / x1 + fi[i+1])); ki[i+1] = (ZIGINT)(x / x1 * NMANTISSA); wi[i] = x / NMANTISSA; fi[i] = exp (-0.5 * x * x); @@ -534,7 +534,7 @@ /* New x is given by x = f^{-1}(v/x_{i+1} + f(x_{i+1})), thus * need inverse operator of y = exp(-x) -> x = -ln(y) */ - x = - log(EXP_SECTION_AREA / x1 + fe[i+1]); + x = - log (EXP_SECTION_AREA / x1 + fe[i+1]); ke[i+1] = (ZIGINT)(x / x1 * EMANTISSA); we[i] = x / EMANTISSA; fe[i] = exp (-x); @@ -620,7 +620,7 @@ while ( yy+yy <= xx*xx); return (rabs&0x100 ? -ZIGGURAT_NOR_R-xx : ZIGGURAT_NOR_R+xx); } - else if ((fi[idx-1] - fi[idx]) * RANDU + fi[idx] < exp(-0.5*x*x)) + else if ((fi[idx-1] - fi[idx]) * RANDU + fi[idx] < exp (-0.5*x*x)) return x; } } @@ -645,9 +645,9 @@ * For the exponential tail, the method of Marsaglia[5] provides: * x = r - ln(U); */ - return ZIGGURAT_EXP_R - log(RANDU); + return ZIGGURAT_EXP_R - log (RANDU); } - else if ((fe[idx-1] - fe[idx]) * RANDU + fe[idx] < exp(-x)) + else if ((fe[idx-1] - fe[idx]) * RANDU + fe[idx] < exp (-x)) return x; } } @@ -697,7 +697,7 @@ /* New x is given by x = f^{-1}(v/x_{i+1} + f(x_{i+1})), thus * need inverse operator of y = exp(-0.5*x*x) -> x = sqrt(-2*ln(y)) */ - x = sqrt(-2. * log(NOR_SECTION_AREA / x1 + ffi[i+1])); + x = sqrt (-2. * log (NOR_SECTION_AREA / x1 + ffi[i+1])); fki[i+1] = (ZIGINT)(x / x1 * NMANTISSA); fwi[i] = x / NMANTISSA; ffi[i] = exp (-0.5 * x * x); @@ -725,7 +725,7 @@ /* New x is given by x = f^{-1}(v/x_{i+1} + f(x_{i+1})), thus * need inverse operator of y = exp(-x) -> x = -ln(y) */ - x = - log(EXP_SECTION_AREA / x1 + ffe[i+1]); + x = - log (EXP_SECTION_AREA / x1 + ffe[i+1]); fke[i+1] = (ZIGINT)(x / x1 * EMANTISSA); fwe[i] = x / EMANTISSA; ffe[i] = exp (-x); @@ -787,7 +787,7 @@ while ( yy+yy <= xx*xx); return (rabs&0x100 ? -ZIGGURAT_NOR_R-xx : ZIGGURAT_NOR_R+xx); } - else if ((ffi[idx-1] - ffi[idx]) * RANDU + ffi[idx] < exp(-0.5*x*x)) + else if ((ffi[idx-1] - ffi[idx]) * RANDU + ffi[idx] < exp (-0.5*x*x)) return x; } } @@ -812,9 +812,9 @@ * For the exponential tail, the method of Marsaglia[5] provides: * x = r - ln(U); */ - return ZIGGURAT_EXP_R - log(RANDU); + return ZIGGURAT_EXP_R - log (RANDU); } - else if ((ffe[idx-1] - ffe[idx]) * RANDU + ffe[idx] < exp(-x)) + else if ((ffe[idx-1] - ffe[idx]) * RANDU + ffe[idx] < exp (-x)) return x; } }
--- a/liboctave/randpoisson.c Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/randpoisson.c Sat Jul 28 12:06:34 2012 -0400 @@ -105,7 +105,7 @@ { r = 1.0 / k; rr = r * r; - return ((k + 0.5)*log(k) - k + C0 + r*(C1 + rr*(C3 + rr*(C5 + rr*C7)))); + return ((k + 0.5)*log (k) - k + C0 + r*(C1 + rr*(C3 + rr*(C5 + rr*C7)))); } else return (logfak[(int)k]); @@ -146,7 +146,7 @@ static double f (double k, double l_nu, double c_pm) { - return exp(k * l_nu - flogfak(k) - c_pm); + return exp (k * l_nu - flogfak (k) - c_pm); } static double @@ -163,13 +163,13 @@ { /* set-up */ my_last = my; /* approximate deviation of reflection points k2, k4 from my - 1/2 */ - Ds = sqrt(my + 0.25); + Ds = sqrt (my + 0.25); /* mode m, reflection points k2 and k4, and points k1 and k5, */ /* which delimit the centre region of h(x) */ - m = floor(my); - k2 = ceil(my - 0.5 - Ds); - k4 = floor(my - 0.5 + Ds); + m = floor (my); + k2 = ceil (my - 0.5 - Ds); + k4 = floor (my - 0.5 + Ds); k1 = k2 + k2 - m + 1L; k5 = k4 + k4 - m; @@ -184,18 +184,18 @@ r5 = my / (k5 + 1.0); /* reciprocal values of the scale parameters of exp. tail envelope */ - ll = log(r1); /* expon. tail left */ - lr = -log(r5); /* expon. tail right*/ + ll = log (r1); /* expon. tail left */ + lr = -log (r5); /* expon. tail right*/ /* Poisson constants, necessary for computing function values f(k) */ - l_my = log(my); - c_pm = m * l_my - flogfak(m); + l_my = log (my); + c_pm = m * l_my - flogfak (m); /* function values f(k) = p(k)/p(m) at k = k2, k4, k1, k5 */ - f2 = f(k2, l_my, c_pm); - f4 = f(k4, l_my, c_pm); - f1 = f(k1, l_my, c_pm); - f5 = f(k5, l_my, c_pm); + f2 = f (k2, l_my, c_pm); + f4 = f (k4, l_my, c_pm); + f1 = f (k1, l_my, c_pm); + f5 = f (k5, l_my, c_pm); /* area of the two centre and the two exponential tail regions */ /* area of the two immediate acceptance regions between k2, k4 */ @@ -216,26 +216,26 @@ /* immediate acceptance region R2 = [k2, m) *[0, f2), X = k2, ... m -1 */ - if ((V = U - p1) < 0.0) return(k2 + floor(U/f2)); + if ((V = U - p1) < 0.0) return (k2 + floor (U/f2)); /* immediate acceptance region R1 = [k1, k2)*[0, f1), X = k1, ... k2-1 */ - if ((W = V / dl) < f1 ) return(k1 + floor(V/f1)); + if ((W = V / dl) < f1 ) return (k1 + floor (V/f1)); /* computation of candidate X < k2, and its counterpart Y > k2 */ /* either squeeze-acceptance of X or acceptance-rejection of Y */ - Dk = floor(dl * RUNI) + 1.0; + Dk = floor (dl * RUNI) + 1.0; if (W <= f2 - Dk * (f2 - f2/r2)) { /* quick accept of */ - return(k2 - Dk); /* X = k2 - Dk */ + return (k2 - Dk); /* X = k2 - Dk */ } if ((V = f2 + f2 - W) < 1.0) { /* quick reject of Y*/ Y = k2 + Dk; if (V <= f2 + Dk * (1.0 - f2)/(dl + 1.0)) { /* quick accept of */ - return(Y); /* Y = k2 + Dk */ + return (Y); /* Y = k2 + Dk */ } - if (V <= f(Y, l_my, c_pm)) return(Y); /* final accept of Y*/ + if (V <= f (Y, l_my, c_pm)) return (Y); /* final accept of Y*/ } X = k2 - Dk; } @@ -243,26 +243,26 @@ { /* centre right */ /* immediate acceptance region R3 = [m, k4+1)*[0, f4), X = m, ... k4 */ - if ((V = U - p3) < 0.0) return(k4 - floor((U - p2)/f4)); + if ((V = U - p3) < 0.0) return (k4 - floor ((U - p2)/f4)); /* immediate acceptance region R4 = [k4+1, k5+1)*[0, f5) */ - if ((W = V / dr) < f5 ) return(k5 - floor(V/f5)); + if ((W = V / dr) < f5 ) return (k5 - floor (V/f5)); /* computation of candidate X > k4, and its counterpart Y < k4 */ /* either squeeze-acceptance of X or acceptance-rejection of Y */ - Dk = floor(dr * RUNI) + 1.0; + Dk = floor (dr * RUNI) + 1.0; if (W <= f4 - Dk * (f4 - f4*r4)) { /* quick accept of */ - return(k4 + Dk); /* X = k4 + Dk */ + return (k4 + Dk); /* X = k4 + Dk */ } if ((V = f4 + f4 - W) < 1.0) { /* quick reject of Y*/ Y = k4 - Dk; if (V <= f4 + Dk * (1.0 - f4)/ dr) { /* quick accept of */ - return(Y); /* Y = k4 - Dk */ + return (Y); /* Y = k4 - Dk */ } - if (V <= f(Y, l_my, c_pm)) return(Y); /* final accept of Y*/ + if (V <= f (Y, l_my, c_pm)) return (Y); /* final accept of Y*/ } X = k4 + Dk; } @@ -271,26 +271,26 @@ W = RUNI; if (U < p5) { /* expon. tail left */ - Dk = floor(1.0 - log(W)/ll); + Dk = floor (1.0 - log (W)/ll); if ((X = k1 - Dk) < 0L) continue; /* 0 <= X <= k1 - 1 */ W *= (U - p4) * ll; /* W -- U(0, h(x)) */ if (W <= f1 - Dk * (f1 - f1/r1)) - return(X); /* quick accept of X*/ + return (X); /* quick accept of X*/ } else { /* expon. tail right*/ - Dk = floor(1.0 - log(W)/lr); + Dk = floor (1.0 - log (W)/lr); X = k5 + Dk; /* X >= k5 + 1 */ W *= (U - p5) * lr; /* W -- U(0, h(x)) */ if (W <= f5 - Dk * (f5 - f5*r5)) - return(X); /* quick accept of X*/ + return (X); /* quick accept of X*/ } } /* acceptance-rejection test of candidate X from the original area */ /* test, whether W <= f(k), with W = U*h(x) and U -- U(0, 1)*/ /* log f(X) = (X - m)*log(my) - log X! + log m! */ - if (log(W) <= X * l_my - flogfak(X) - c_pm) return(X); + if (log (W) <= X * l_my - flogfak (X) - c_pm) return (X); } } /* ---- pprsc.c end ------ */ @@ -300,7 +300,7 @@ /* Given uniform u, find x such that CDF(L,x)==u. Return x. */ static void -poisson_cdf_lookup(double lambda, double *p, size_t n) +poisson_cdf_lookup (double lambda, double *p, size_t n) { /* Table size is predicated on the maximum value of lambda * we want to store in the table, and the maximum value of @@ -316,12 +316,12 @@ /* Precompute the table for the u up to and including 0.458. * We will almost certainly need it. */ - int intlambda = (int)floor(lambda); + int intlambda = (int)floor (lambda); double P; int tableidx; size_t i = n; - t[0] = P = exp(-lambda); + t[0] = P = exp (-lambda); for (tableidx = 1; tableidx <= intlambda; tableidx++) { P = P*lambda/(double)tableidx; t[tableidx] = t[tableidx-1] + P; @@ -369,18 +369,18 @@ } static void -poisson_cdf_lookup_float(double lambda, float *p, size_t n) +poisson_cdf_lookup_float (double lambda, float *p, size_t n) { double t[TABLESIZE]; /* Precompute the table for the u up to and including 0.458. * We will almost certainly need it. */ - int intlambda = (int)floor(lambda); + int intlambda = (int)floor (lambda); double P; int tableidx; size_t i = n; - t[0] = P = exp(-lambda); + t[0] = P = exp (-lambda); for (tableidx = 1; tableidx <= intlambda; tableidx++) { P = P*lambda/(double)tableidx; t[tableidx] = t[tableidx-1] + P; @@ -412,8 +412,8 @@ static void poisson_rejection (double lambda, double *p, size_t n) { - double sq = sqrt(2.0*lambda); - double alxm = log(lambda); + double sq = sqrt (2.0*lambda); + double alxm = log (lambda); double g = lambda*alxm - LGAMMA(lambda+1.0); size_t i; @@ -425,8 +425,8 @@ y = tan(M_PI*RUNI); em = sq * y + lambda; } while (em < 0.0); - em = floor(em); - t = 0.9*(1.0+y*y)*exp(em*alxm-flogfak(em)-g); + em = floor (em); + t = 0.9*(1.0+y*y)*exp (em*alxm-flogfak (em)-g); } while (RUNI > t); p[i] = em; } @@ -436,8 +436,8 @@ static void poisson_rejection_float (double lambda, float *p, size_t n) { - double sq = sqrt(2.0*lambda); - double alxm = log(lambda); + double sq = sqrt (2.0*lambda); + double alxm = log (lambda); double g = lambda*alxm - LGAMMA(lambda+1.0); size_t i; @@ -446,11 +446,11 @@ double y, em, t; do { do { - y = tan(M_PI*RUNI); + y = tan (M_PI*RUNI); em = sq * y + lambda; } while (em < 0.0); - em = floor(em); - t = 0.9*(1.0+y*y)*exp(em*alxm-flogfak(em)-g); + em = floor (em); + t = 0.9*(1.0+y*y)*exp (em*alxm-flogfak (em)-g); } while (RUNI > t); p[i] = em; } @@ -477,20 +477,20 @@ } else if (L <= 10.0) { - poisson_cdf_lookup(L, p, n); + poisson_cdf_lookup (L, p, n); } else if (L <= 1e8) { for (i=0; i<n; i++) - p[i] = pprsc(L); + p[i] = pprsc (L); } else { /* normal approximation: from Phys. Rev. D (1994) v50 p1284 */ - const double sqrtL = sqrt(L); + const double sqrtL = sqrt (L); for (i = 0; i < n; i++) { - p[i] = floor(RNOR*sqrtL + L + 0.5); + p[i] = floor (RNOR*sqrtL + L + 0.5); if (p[i] < 0.0) p[i] = 0.0; /* will probably never happen */ } @@ -505,7 +505,7 @@ if (L < 0.0) ret = NAN; else if (L <= 12.0) { /* From Press, et al. Numerical recipes */ - double g = exp(-L); + double g = exp (-L); int em = -1; double t = 1.0; do { @@ -515,14 +515,14 @@ ret = em; } else if (L <= 1e8) { /* numerical recipes */ - poisson_rejection(L, &ret, 1); + poisson_rejection (L, &ret, 1); } else if (INFINITE(L)) { /* FIXME R uses NaN, but the normal approx. suggests that as * limit should be inf. Which is correct? */ ret = NAN; } else { /* normal approximation: from Phys. Rev. D (1994) v50 p1284 */ - ret = floor(RNOR*sqrt(L) + L + 0.5); + ret = floor (RNOR*sqrt (L) + L + 0.5); if (ret < 0.0) ret = 0.0; /* will probably never happen */ } return ret; @@ -541,20 +541,20 @@ } else if (L <= 10.0) { - poisson_cdf_lookup_float(L, p, n); + poisson_cdf_lookup_float (L, p, n); } else if (L <= 1e8) { for (i=0; i<n; i++) - p[i] = pprsc(L); + p[i] = pprsc (L); } else { /* normal approximation: from Phys. Rev. D (1994) v50 p1284 */ - const double sqrtL = sqrt(L); + const double sqrtL = sqrt (L); for (i = 0; i < n; i++) { - p[i] = floor(RNOR*sqrtL + L + 0.5); + p[i] = floor (RNOR*sqrtL + L + 0.5); if (p[i] < 0.0) p[i] = 0.0; /* will probably never happen */ } @@ -570,7 +570,7 @@ if (L < 0.0) ret = NAN; else if (L <= 12.0) { /* From Press, et al. Numerical recipes */ - double g = exp(-L); + double g = exp (-L); int em = -1; double t = 1.0; do { @@ -580,14 +580,14 @@ ret = em; } else if (L <= 1e8) { /* numerical recipes */ - poisson_rejection_float(L, &ret, 1); + poisson_rejection_float (L, &ret, 1); } else if (INFINITE(L)) { /* FIXME R uses NaN, but the normal approx. suggests that as * limit should be inf. Which is correct? */ ret = NAN; } else { /* normal approximation: from Phys. Rev. D (1994) v50 p1284 */ - ret = floor(RNOR*sqrt(L) + L + 0.5); + ret = floor (RNOR*sqrt (L) + L + 0.5); if (ret < 0.0) ret = 0.0; /* will probably never happen */ } return ret;
--- a/liboctave/sparse-base-chol.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/sparse-base-chol.cc Sat Jul 28 12:06:34 2012 -0400 @@ -56,24 +56,24 @@ for (k = 0; k < ncol; k++) { - p = Sp [k]; - pend = Sp [k+1]; - Sp [k] = pdest; + p = Sp[k]; + pend = Sp[k+1]; + Sp[k] = pdest; for (; p < pend; p++) { - sik = Sx [p]; + sik = Sx[p]; if (CHOLMOD_IS_NONZERO (sik)) { if (p != pdest) { - Si [pdest] = Si [p]; - Sx [pdest] = sik; + Si[pdest] = Si[p]; + Sx[pdest] = sik; } pdest++; } } } - Sp [ncol] = pdest; + Sp[ncol] = pdest; } #endif @@ -157,7 +157,7 @@ if (natural) { cm->nmethods = 1 ; - cm->method [0].ordering = CHOLMOD_NATURAL ; + cm->method[0].ordering = CHOLMOD_NATURAL ; cm->postorder = false ; } @@ -229,11 +229,11 @@ octave_idx_type nnz = m->nzmax; chol_type ret (m->nrow, nc, nnz); for (octave_idx_type j = 0; j < nc+1; j++) - ret.xcidx(j) = static_cast<octave_idx_type *>(m->p)[j]; + ret.xcidx (j) = static_cast<octave_idx_type *>(m->p)[j]; for (octave_idx_type i = 0; i < nnz; i++) { - ret.xridx(i) = static_cast<octave_idx_type *>(m->i)[i]; - ret.xdata(i) = static_cast<chol_elt *>(m->x)[i]; + ret.xridx (i) = static_cast<octave_idx_type *>(m->i)[i]; + ret.xdata (i) = static_cast<chol_elt *>(m->x)[i]; } return ret; #else @@ -252,11 +252,11 @@ for (octave_idx_type i = 0; i < n; i++) { - p.xcidx(i) = i; - p.xridx(i) = static_cast<octave_idx_type>(perms(i)); - p.xdata(i) = 1; + p.xcidx (i) = i; + p.xridx (i) = static_cast<octave_idx_type>(perms (i)); + p.xdata (i) = 1; } - p.xcidx(n) = n; + p.xcidx (n) = n; return p; #else @@ -277,7 +277,7 @@ double rcond2; octave_idx_type info; MatrixType mattype (MatrixType::Upper); - chol_type linv = L ().hermitian ().inverse(mattype, info, rcond2, 1, 0); + chol_type linv = L ().hermitian ().inverse (mattype, info, rcond2, 1, 0); if (perms.length () == n) {
--- a/liboctave/sparse-base-lu.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/sparse-base-lu.cc Sat Jul 28 12:06:34 2012 -0400 @@ -37,26 +37,26 @@ lu_type Yout (nr, nc, Lfact.nnz () + Ufact.nnz ()); octave_idx_type ii = 0; - Yout.xcidx(0) = 0; + Yout.xcidx (0) = 0; for (octave_idx_type j = 0; j < nc; j++) { - for (octave_idx_type i = Ufact.cidx (j); i < Ufact.cidx(j + 1); i++) + for (octave_idx_type i = Ufact.cidx (j); i < Ufact.cidx (j + 1); i++) { - Yout.xridx (ii) = Ufact.ridx(i); - Yout.xdata (ii++) = Ufact.data(i); + Yout.xridx (ii) = Ufact.ridx (i); + Yout.xdata (ii++) = Ufact.data (i); } if (j < rcmin) { // Note the +1 skips the 1.0 on the diagonal for (octave_idx_type i = Lfact.cidx (j) + 1; - i < Lfact.cidx(j +1); i++) + i < Lfact.cidx (j +1); i++) { - Yout.xridx (ii) = Lfact.ridx(i); - Yout.xdata (ii++) = Lfact.data(i); + Yout.xridx (ii) = Lfact.ridx (i); + Yout.xdata (ii++) = Lfact.data (i); } } - Yout.xcidx(j + 1) = ii; + Yout.xcidx (j + 1) = ii; } return Yout;
--- a/liboctave/sparse-dmsolve.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/sparse-dmsolve.cc Sat Jul 28 12:06:34 2012 -0400 @@ -33,6 +33,7 @@ #include "MatrixType.h" #include "oct-sort.h" #include "oct-locbuf.h" +#include "oct-inttypes.h" template <class T> static MSparse<T> @@ -42,9 +43,17 @@ octave_idx_type cend, octave_idx_type maxnz = -1, bool lazy = false) { - octave_idx_type nz = (rend - rst) * (cend - cst); + octave_idx_type nr = rend - rst, nc = cend - cst; maxnz = (maxnz < 0 ? A.nnz () : maxnz); - MSparse<T> B (rend - rst, cend - cst, (nz < maxnz ? nz : maxnz)); + octave_idx_type nz; + + // Cast to uint64 to handle overflow in this multiplication + if (octave_uint64 (nr)*octave_uint64 (nc) < octave_uint64 (maxnz)) + nz = nr*nc; + else + nz = maxnz; + + MSparse<T> B (nr, nc, (nz < maxnz ? nz : maxnz)); // Some sparse functions can support lazy indexing (where elements // in the row are in no particular order), even though octave in // general can't. For those functions that can using it is a big @@ -54,16 +63,16 @@ nz = 0; for (octave_idx_type j = cst ; j < cend ; j++) { - octave_idx_type qq = (Q ? Q [j] : j); + octave_idx_type qq = (Q ? Q[j] : j); B.xcidx (j - cst) = nz; - for (octave_idx_type p = A.cidx(qq) ; p < A.cidx (qq+1) ; p++) + for (octave_idx_type p = A.cidx (qq) ; p < A.cidx (qq+1) ; p++) { octave_quit (); - octave_idx_type r = (Pinv ? Pinv [A.ridx (p)] : A.ridx (p)); + octave_idx_type r = (Pinv ? Pinv[A.ridx (p)] : A.ridx (p)); if (r >= rst && r < rend) { B.xdata (nz) = A.data (p); - B.xridx (nz++) = r - rst ; + B.xridx (nz++) = r - rst ; } } } @@ -77,21 +86,21 @@ nz = 0; for (octave_idx_type j = cst ; j < cend ; j++) { - octave_idx_type qq = (Q ? Q [j] : j); + octave_idx_type qq = (Q ? Q[j] : j); B.xcidx (j - cst) = nz; - for (octave_idx_type p = A.cidx(qq) ; p < A.cidx (qq+1) ; p++) + for (octave_idx_type p = A.cidx (qq) ; p < A.cidx (qq+1) ; p++) { octave_quit (); - octave_idx_type r = (Pinv ? Pinv [A.ridx (p)] : A.ridx (p)); + octave_idx_type r = (Pinv ? Pinv[A.ridx (p)] : A.ridx (p)); if (r >= rst && r < rend) { - X [r-rst] = A.data (p); - B.xridx (nz++) = r - rst ; + X[r-rst] = A.data (p); + B.xridx (nz++) = r - rst ; } } sort.sort (ri + B.xcidx (j - cst), nz - B.xcidx (j - cst)); for (octave_idx_type p = B.cidx (j - cst); p < nz; p++) - B.xdata (p) = X [B.xridx (p)]; + B.xdata (p) = X[B.xridx (p)]; } B.xcidx (cend - cst) = nz ; } @@ -170,7 +179,7 @@ for (octave_idx_type i = 0; i < nr; i++) { octave_quit (); - ax [Q [r + i] + aoff] = bx [i + boff]; + ax[Q[r + i] + aoff] = bx[i + boff]; } } } @@ -197,17 +206,17 @@ OCTAVE_LOCAL_BUFFER (octave_idx_type, Qinv, nr); for (octave_idx_type i = 0; i < nr; i++) - Qinv [Q [i]] = i; + Qinv[Q[i]] = i; // First count the number of elements in the final array - octave_idx_type nel = a.xcidx(c) + b.nnz (); + octave_idx_type nel = a.xcidx (c) + b.nnz (); if (c + b_cols < nc) - nel += a.xcidx(nc) - a.xcidx(c + b_cols); + nel += a.xcidx (nc) - a.xcidx (c + b_cols); for (octave_idx_type i = c; i < c + b_cols; i++) - for (octave_idx_type j = a.xcidx(i); j < a.xcidx(i+1); j++) - if (Qinv [a.xridx(j)] < r || Qinv [a.xridx(j)] >= r + b_rows) + for (octave_idx_type j = a.xcidx (i); j < a.xcidx (i+1); j++) + if (Qinv[a.xridx (j)] < r || Qinv[a.xridx (j)] >= r + b_rows) nel++; OCTAVE_LOCAL_BUFFER (T, X, nr); @@ -216,49 +225,49 @@ a = MSparse<T> (nr, nc, nel); octave_idx_type *ri = a.xridx (); - for (octave_idx_type i = 0; i < tmp.cidx(c); i++) + for (octave_idx_type i = 0; i < tmp.cidx (c); i++) { - a.xdata(i) = tmp.xdata(i); - a.xridx(i) = tmp.xridx(i); + a.xdata (i) = tmp.xdata (i); + a.xridx (i) = tmp.xridx (i); } for (octave_idx_type i = 0; i < c + 1; i++) - a.xcidx(i) = tmp.xcidx(i); + a.xcidx (i) = tmp.xcidx (i); - octave_idx_type ii = a.xcidx(c); + octave_idx_type ii = a.xcidx (c); for (octave_idx_type i = c; i < c + b_cols; i++) { octave_quit (); - for (octave_idx_type j = tmp.xcidx(i); j < tmp.xcidx(i+1); j++) - if (Qinv [tmp.xridx(j)] < r || Qinv [tmp.xridx(j)] >= r + b_rows) + for (octave_idx_type j = tmp.xcidx (i); j < tmp.xcidx (i+1); j++) + if (Qinv[tmp.xridx (j)] < r || Qinv[tmp.xridx (j)] >= r + b_rows) { - X [tmp.xridx(j)] = tmp.xdata(j); - a.xridx(ii++) = tmp.xridx(j); + X[tmp.xridx (j)] = tmp.xdata (j); + a.xridx (ii++) = tmp.xridx (j); } octave_quit (); - for (octave_idx_type j = b.cidx(i-c); j < b.cidx(i-c+1); j++) + for (octave_idx_type j = b.cidx (i-c); j < b.cidx (i-c+1); j++) { - X [Q [r + b.ridx(j)]] = b.data(j); - a.xridx(ii++) = Q [r + b.ridx(j)]; + X[Q[r + b.ridx (j)]] = b.data (j); + a.xridx (ii++) = Q[r + b.ridx (j)]; } sort.sort (ri + a.xcidx (i), ii - a.xcidx (i)); for (octave_idx_type p = a.xcidx (i); p < ii; p++) - a.xdata (p) = X [a.xridx (p)]; - a.xcidx(i+1) = ii; + a.xdata (p) = X[a.xridx (p)]; + a.xcidx (i+1) = ii; } for (octave_idx_type i = c + b_cols; i < nc; i++) { - for (octave_idx_type j = tmp.xcidx(i); j < tmp.cidx(i+1); j++) + for (octave_idx_type j = tmp.xcidx (i); j < tmp.cidx (i+1); j++) { - a.xdata(ii) = tmp.xdata(j); - a.xridx(ii++) = tmp.xridx(j); + a.xdata (ii) = tmp.xdata (j); + a.xridx (ii++) = tmp.xridx (j); } - a.xcidx(i+1) = ii; + a.xcidx (i+1) = ii; } } @@ -287,7 +296,7 @@ for (octave_idx_type i = 0; i < b_nr; i++) { octave_quit (); - Btx [p [i] + off] = Bx [ i + off]; + Btx[p[i] + off] = Bx[ i + off]; } } } @@ -318,23 +327,23 @@ octave_sort<octave_idx_type> sort; octave_idx_type *ri = a.xridx (); OCTAVE_LOCAL_BUFFER (RT, X, b_nr); - a.xcidx(0) = 0; + a.xcidx (0) = 0; for (octave_idx_type j = 0; j < b_nc; j++) { - for (octave_idx_type i = b.cidx(j); i < b.cidx(j+1); i++) + for (octave_idx_type i = b.cidx (j); i < b.cidx (j+1); i++) { octave_quit (); - octave_idx_type r = p [b.ridx (i)]; - X [r] = b.data (i); - a.xridx(nz++) = p [b.ridx (i)]; + octave_idx_type r = p[b.ridx (i)]; + X[r] = b.data (i); + a.xridx (nz++) = p[b.ridx (i)]; } sort.sort (ri + a.xcidx (j), nz - a.xcidx (j)); for (octave_idx_type i = a.cidx (j); i < nz; i++) { octave_quit (); - a.xdata (i) = X [a.xridx (i)]; + a.xdata (i) = X[a.xridx (i)]; } - a.xcidx(j+1) = nz; + a.xcidx (j+1) = nz; } } @@ -389,7 +398,7 @@ csm.p = const_cast<octave_idx_type *>(a.cidx ()); csm.i = const_cast<octave_idx_type *>(a.ridx ()); -#if defined(CS_VER) && (CS_VER >= 2) +#if defined (CS_VER) && (CS_VER >= 2) CXSPARSE_DNAME (d) *dm = CXSPARSE_DNAME(_dmperm) (&csm, 0); octave_idx_type *p = dm->p; octave_idx_type *q = dm->q; @@ -400,26 +409,26 @@ #endif OCTAVE_LOCAL_BUFFER (octave_idx_type, pinv, nr); for (octave_idx_type i = 0; i < nr; i++) - pinv [p [i]] = i; + pinv[p[i]] = i; RT btmp; dmsolve_permute (btmp, b, pinv); info = 0; retval.resize (nc, b_nc); // Leading over-determined block - if (dm->rr [2] < nr && dm->cc [3] < nc) + if (dm->rr[2] < nr && dm->cc[3] < nc) { - ST m = dmsolve_extract (a, pinv, q, dm->rr [2], nr, dm->cc [3], nc, + ST m = dmsolve_extract (a, pinv, q, dm->rr[2], nr, dm->cc[3], nc, nnz_remaining, true); nnz_remaining -= m.nnz (); RT mtmp = qrsolve (m, dmsolve_extract (btmp, 0, 0, dm->rr[2], b_nr, 0, b_nc), info); - dmsolve_insert (retval, mtmp, q, dm->cc [3], 0); - if (dm->rr [2] > 0 && !info) + dmsolve_insert (retval, mtmp, q, dm->cc[3], 0); + if (dm->rr[2] > 0 && !info) { - m = dmsolve_extract (a, pinv, q, 0, dm->rr [2], - dm->cc [3], nc, nnz_remaining, true); + m = dmsolve_extract (a, pinv, q, 0, dm->rr[2], + dm->cc[3], nc, nnz_remaining, true); nnz_remaining -= m.nnz (); RT ctmp = dmsolve_extract (btmp, 0, 0, 0, dm->rr[2], 0, b_nc); @@ -429,12 +438,12 @@ // Structurally non-singular blocks // FIXME Should use fine Dulmange-Mendelsohn decomposition here. - if (dm->rr [1] < dm->rr [2] && dm->cc [2] < dm->cc [3] && !info) + if (dm->rr[1] < dm->rr[2] && dm->cc[2] < dm->cc[3] && !info) { - ST m = dmsolve_extract (a, pinv, q, dm->rr [1], dm->rr [2], - dm->cc [2], dm->cc [3], nnz_remaining, false); + ST m = dmsolve_extract (a, pinv, q, dm->rr[1], dm->rr[2], + dm->cc[2], dm->cc[3], nnz_remaining, false); nnz_remaining -= m.nnz (); - RT btmp2 = dmsolve_extract (btmp, 0, 0, dm->rr [1], dm->rr [2], + RT btmp2 = dmsolve_extract (btmp, 0, 0, dm->rr[1], dm->rr[2], 0, b_nc); double rcond = 0.0; MatrixType mtyp (MatrixType::Full); @@ -446,11 +455,11 @@ mtmp = qrsolve (m, btmp2, info); } - dmsolve_insert (retval, mtmp, q, dm->cc [2], 0); - if (dm->rr [1] > 0 && !info) + dmsolve_insert (retval, mtmp, q, dm->cc[2], 0); + if (dm->rr[1] > 0 && !info) { - m = dmsolve_extract (a, pinv, q, 0, dm->rr [1], dm->cc [2], - dm->cc [3], nnz_remaining, true); + m = dmsolve_extract (a, pinv, q, 0, dm->rr[1], dm->cc[2], + dm->cc[3], nnz_remaining, true); nnz_remaining -= m.nnz (); RT ctmp = dmsolve_extract (btmp, 0, 0, 0, dm->rr[1], 0, b_nc); @@ -459,13 +468,13 @@ } // Trailing under-determined block - if (dm->rr [1] > 0 && dm->cc [2] > 0 && !info) + if (dm->rr[1] > 0 && dm->cc[2] > 0 && !info) { - ST m = dmsolve_extract (a, pinv, q, 0, dm->rr [1], 0, - dm->cc [2], nnz_remaining, true); + ST m = dmsolve_extract (a, pinv, q, 0, dm->rr[1], 0, + dm->cc[2], nnz_remaining, true); RT mtmp = - qrsolve (m, dmsolve_extract(btmp, 0, 0, 0, dm->rr [1] , 0, - b_nc), info); + qrsolve (m, dmsolve_extract (btmp, 0, 0, 0, dm->rr[1] , 0, + b_nc), info); dmsolve_insert (retval, mtmp, q, 0, 0); }
--- a/liboctave/str-vec.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/str-vec.cc Sat Jul 28 12:06:34 2012 -0400 @@ -54,7 +54,7 @@ for (std::list<std::string>::const_iterator p = lst.begin (); p != lst.end (); p++) - elem(i++) = *p; + elem (i++) = *p; } string_vector::string_vector (const std::set<std::string>& lst) @@ -69,7 +69,7 @@ for (std::set<std::string>::const_iterator p = lst.begin (); p != lst.end (); p++) - elem(i++) = *p; + elem (i++) = *p; } // Create a string vector from a NULL terminated list of C strings. @@ -125,9 +125,9 @@ octave_idx_type k = 0; for (octave_idx_type i = 1; i < len; i++) - if (elem(i) != elem(k)) + if (elem (i) != elem (k)) if (++k != i) - elem(k) = elem(i); + elem (k) = elem (i); if (len != ++k) resize (k); @@ -143,7 +143,7 @@ resize (len + 1); - elem(len) = s; + elem (len) = s; return *this; } @@ -158,7 +158,7 @@ resize (new_len); for (octave_idx_type i = 0; i < sv_len; i++) - elem(len + i) = sv[i]; + elem (len + i) = sv[i]; return *this; } @@ -175,9 +175,9 @@ octave_idx_type i; for (i = 0; i < len - 1; i++) - retval += elem(i) + sep; + retval += elem (i) + sep; - retval += elem(i); + retval += elem (i); } return retval; @@ -190,10 +190,10 @@ char **retval = new char * [len + 1]; - retval [len] = 0; + retval[len] = 0; for (octave_idx_type i = 0; i < len; i++) - retval[i] = strsave (elem(i).c_str ()); + retval[i] = strsave (elem (i).c_str ()); return retval; }
--- a/liboctave/str-vec.h Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/str-vec.h Sat Jul 28 12:06:34 2012 -0400 @@ -79,7 +79,7 @@ for (octave_idx_type i = 0; i < n; i++) { - octave_idx_type tmp = elem(i).length (); + octave_idx_type tmp = elem (i).length (); if (tmp > longest) longest = tmp;
--- a/liboctave/tempnam.c Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/tempnam.c Sat Jul 28 12:06:34 2012 -0400 @@ -43,16 +43,16 @@ { size_t len; register char *s; - register char *t = __stdio_gen_tempname(dir, pfx, 1, &len, (FILE **) NULL); + register char *t = __stdio_gen_tempname (dir, pfx, 1, &len, (FILE **) NULL); if (t == NULL) return NULL; - s = (char *) malloc(len); + s = (char *) malloc (len); if (s == NULL) return NULL; - (void) memcpy(s, t, len); + (void) memcpy (s, t, len); return s; }
--- a/liboctave/tempname.c Sat Jul 28 15:17:57 2012 +0200 +++ b/liboctave/tempname.c Sat Jul 28 12:06:34 2012 -0400 @@ -112,14 +112,14 @@ if (dir_search) { - register const char *d = getenv("TMPDIR"); - if (d != NULL && !diraccess(d)) + register const char *d = getenv ("TMPDIR"); + if (d != NULL && !diraccess (d)) d = NULL; - if (d == NULL && dir != NULL && diraccess(dir)) + if (d == NULL && dir != NULL && diraccess (dir)) d = dir; - if (d == NULL && diraccess(tmpdir)) + if (d == NULL && diraccess (tmpdir)) d = tmpdir; - if (d == NULL && diraccess("/tmp")) + if (d == NULL && diraccess ("/tmp")) d = "/tmp"; if (d == NULL) { @@ -139,14 +139,14 @@ if (pfx != NULL && *pfx != '\0') { - plen = strlen(pfx); + plen = strlen (pfx); if (plen > 5) plen = 5; } else plen = 0; - if (dir != tmpdir && !strcmp(dir, tmpdir)) + if (dir != tmpdir && !strcmp (dir, tmpdir)) dir = tmpdir; idx = &indices[(plen == 0 && dir == tmpdir) ? 1 : 0];
--- a/m4/acinclude.m4 Sat Jul 28 15:17:57 2012 +0200 +++ b/m4/acinclude.m4 Sat Jul 28 12:06:34 2012 -0400 @@ -286,7 +286,7 @@ dnl dnl OCTAVE_CC_FLAG AC_DEFUN([OCTAVE_CC_FLAG], [ - ac_safe=`echo "$1" | sed 'y%./+-:=%__p___%'` + ac_safe=`echo "$1" | sed 'y% ./+-:=%___p___%'` AC_MSG_CHECKING([whether ${CC-cc} accepts $1]) AC_CACHE_VAL(octave_cv_cc_flag_$ac_safe, [ AC_LANG_PUSH(C) @@ -628,15 +628,12 @@ else AC_CHECK_PROGS(GNUPLOT, [$gp_names]) if test -z "$GNUPLOT"; then - warn_gnuplot=yes - GNUPLOT="$gp_default" - warn_gnuplot = " + warn_gnuplot=" gnuplot not found. It isn't necessary to have gnuplot installed, but without native graphics or gnuplot you won't be able to use any of Octave's plotting commands. - " OCTAVE_CONFIGURE_WARNING([warn_gnuplot]) fi
--- a/scripts/help/help.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/help/help.m Sat Jul 28 12:06:34 2012 -0400 @@ -19,6 +19,7 @@ ## -*- texinfo -*- ## @deftypefn {Command} {} help @var{name} ## @deftypefnx {Command} {} help @code{--list} +## @deftypefnx {Command} {} help @code{.} ## Display the help text for @var{name}. For example, the command ## @kbd{help help} prints a short message describing the @code{help} ## command. @@ -27,6 +28,9 @@ ## keywords, built-in functions, and loadable functions available ## in the current session of Octave. ## +## Given the single argument @code{.}, list all operators available +## in the current session of Octave. +## ## If invoked without any arguments, @code{help} display instructions ## on how to access help from the command line. ## @@ -68,6 +72,16 @@ return; endif + if (strcmp (name, ".")) + tmp = do_list_operators (); + if (nargout == 0) + printf ("%s", tmp); + else + retval = tmp; + endif + return; + endif + ## Get help text [text, format] = get_help_text (name); @@ -106,10 +120,15 @@ endfunction +function retval = do_list_operators () + + retval = sprintf ("*** operators:\n\n%s\n\n", + list_in_columns (__operators__ ())); +endfunction + function retval = do_list_functions () - operators = sprintf ("*** operators:\n\n%s\n\n", - list_in_columns (__operators__ ())); + operators = do_list_operators (); keywords = sprintf ("*** keywords:\n\n%s\n\n", list_in_columns (__keywords__ ()));
--- a/scripts/help/type.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/help/type.m Sat Jul 28 12:06:34 2012 -0400 @@ -118,7 +118,7 @@ %! typestr = typestr{1}(1:17); %! assert (typestr, "var is a variable"); -%!assert (type ("dot"){1}, "dot is a dynamically-linked function") +%!assert (type ("amd"){1}, "amd is a dynamically-linked function") %!assert (type ("cat"){1}, "cat is a built-in function") %!assert (type ("+"){1}, "+ is an operator") %!assert (type ("end"){1}, "end is a keyword")
--- a/scripts/help/unimplemented.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/help/unimplemented.m Sat Jul 28 12:06:34 2012 -0400 @@ -38,7 +38,7 @@ txt = ["quad2d is not implemented. Consider using dblquad."]; case "gsvd" - txt = ["gsvd is not currently part of core Octave. See the ", + txt = ["gsvd is not currently part of core Octave. See the ",... "linear-algebra package at @url{http://octave.sf.net/linear-algebra/}."]; case "linprog"
--- a/scripts/help/which.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/help/which.m Sat Jul 28 12:06:34 2012 -0400 @@ -59,8 +59,8 @@ %! str = which ("ls"); %! assert (str(end-17:end), strcat ("miscellaneous", filesep (), "ls.m")); %!test -%! str = which ("dot"); -%! assert (str(end-6:end), "dot.oct"); +%! str = which ("amd"); +%! assert (str(end-6:end), "amd.oct"); %!assert (which ("_NO_SUCH_NAME_"), "")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/scripts/image/cmpermute.m Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,144 @@ +## Copyright (C) 2004 Josep Mones i Teixidor +## Copyright (C) 2012 Rik Wehbring +## +## This file is part of Octave. +## +## Octave is free software; you can redistribute it and/or modify it +## under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 3 of the License, or (at +## your option) any later version. +## +## Octave is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +## General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with Octave; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} {[@var{Y}, @var{newmap}] =} cmpermute (@var{X}, @var{map}) +## @deftypefnx {Function File} {[@var{Y}, @var{newmap}] =} cmpermute (@var{X}, @var{map}, @var{index}) +## Reorder colors in a colormap. +## +## When called with only two arguments, @code{cmpermute} randomly rearranges +## the colormap @var{map} and returns a new colormap @var{newmap}. It also +## returns the indexed image @var{Y} which is the equivalent of the original +## input image @var{X} when displayed using @var{newmap}. The input image +## @var{X} must be an indexed image of class uint8 or double. +## +## When called with an optional third argument the order of colors in the +## new colormap is defined by @var{index}. +## +## @strong{Caution:} @code{index} should not have repeated elements or the +## function will fail. +## +## @end deftypefn + +## Author: Josep Mones i Teixidor <jmones@puntbarra.com> + +function [Y, newmap] = cmpermute (X, map, index) + + if (nargin < 2 || nargin > 3) + print_usage (); + endif + + ## FIXME: Matlab only accepts 2 types. Expand to uint16 & single?? + if (! (isa (X, "uint8") || isa (X, "double"))) + error ("cmpermute: X must be of class uint8 or double"); + endif + + if (! isreal (X) || issparse (X) + || (isfloat (X) && (any (X(:) < 1 || any (X(:) != fix (X(:))))))) + error ("cmpermute: X must be an indexed image"); + endif + + if (! isnumeric (map) || iscomplex (map) + || ndims (map) != 2 || columns (map) != 3 + || any (map(:) < 0) || any (map(:) > 1)) + error ("cmpermute: MAP must be a valid colormap"); + endif + + if (nargin < 3) + index = randperm (rows (map)); + elseif (! isvector (index) || length (index) != rows (map)) + error ("cmpermute: invalid parameter INDEX"); + endif + + ## new colormap + newmap = map(index,:); + + ## build reverse index + rindex = zeros (size (index)); + rindex(index) = 1:length (index); + + ## adapt indices + if (isa (X, "uint8")) + rindex = uint8 (rindex-1); + ## 0-based indices + Y = rindex(double (X) + 1); + else + Y = rindex(X); + endif + +endfunction + + +%!demo +%! [Y, newmap] = cmpermute ([1:4], hot (4), 4:-1:1) +%! ## colormap will be arranged in reverse order (so will image) + +%!shared X, map +%! X = uint8 (magic (16)); +%! [X, map] = cmunique (X); + +%!test # random permutation, 0-based index +%! [Y, newmap] = cmpermute (X, map); +%! ## test we didn't lose colors +%! assert (sort (map), sortrows (newmap)); +%! ## test if images are equal +%! assert (map(double (X)+1), newmap(double (Y)+1)); + +%!test # reverse map, 0-based index +%! [Y, newmap] = cmpermute (X, map, rows (map):-1:1); +%! ## we expect a reversed colormap +%! assert (flipud (newmap), map); +%! ## we expect reversed indices in image +%! assert (X, max (Y(:)) - Y); + +%!shared X,map +%! X = uint16 (magic (20)); +%! [X, map] = cmunique (X); + +%!test # random permutation, 1-based index +%! [Y, newmap] = cmpermute (X, map); +%! ## test we didn't lose colors +%! assert (sort (map), sortrows (newmap)); +%! ## test if images are equal +%! assert (map(X), newmap(Y)); + +%!test # reverse map, 1-based index +%! [Y, newmap] = cmpermute (X, map, rows (map):-1:1); +%! ## we expect a reversed colormap +%! assert (newmap (rows (newmap):-1:1,:), map); +%! ## we expect reversed indices in image +%! assert (X, max (Y(:)) + 1 - Y); + +## Test input validation +%!error cmpermute () +%!error cmpermute (1,2,3,4) +%!error <X must be of class uint8> cmpermute (uint16 (magic (16)), jet (256)) +%!error <X must be an indexed image> cmpermute (1+i, jet (256)) +%!error <X must be an indexed image> cmpermute (sparse (1), jet (256)) +%!error <X must be an indexed image> cmpermute (0, jet (256)) +%!error <X must be an indexed image> cmpermute (1.5, jet (256)) +%!error <MAP must be a valid colormap> cmpermute (1, "a") +%!error <MAP must be a valid colormap> cmpermute (1, i) +%!error <MAP must be a valid colormap> cmpermute (1, ones (3,3,3)) +%!error <MAP must be a valid colormap> cmpermute (1, ones (3,2)) +%!error <MAP must be a valid colormap> cmpermute (1, [-1 1 1]) +%!error <MAP must be a valid colormap> cmpermute (1, [2 1 1]) +%!error <invalid parameter INDEX> cmpermute (1, [0 1 0;1 0 1], ones (3)) +%!error <invalid parameter INDEX> cmpermute (1, [0 1 0;1 0 1], 1:3) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/scripts/image/cmunique.m Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,204 @@ +## Copyright (C) 2004 Josep Mones i Teixidor +## Copyright (C) 2012 Rik Wehbring +## +## This file is part of Octave. +## +## Octave is free software; you can redistribute it and/or modify it +## under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 3 of the License, or (at +## your option) any later version. +## +## Octave is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +## General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with Octave; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} {[@var{Y}, @var{newmap}] =} cmunique (@var{X}, @var{map}) +## @deftypefnx {Function File} {[@var{Y}, @var{newmap}] =} cmunique (@var{RGB}) +## @deftypefnx {Function File} {[@var{Y}, @var{newmap}] =} cmunique (@var{I}) +## Convert an input image @var{X} to an ouput indexed image @var{Y} which uses +## the smallest colormap possible @var{newmap}. +## +## When the input is an indexed image (@var{X} with colormap @var{map}) the +## output is a colormap @var{newmap} from which any repeated rows have been +## eliminated. The output image, @var{Y}, is the original input image with +## the indices adjusted to match the new, possibly smaller, colormap. +## +## When the input is an RGB image (an @nospell{MxNx3} array), the output +## colormap will contain one entry for every unique color in the original image. +## In the worst case the new map could have as many rows as the number of +## pixels in the original image. +## +## When the input is a grayscale image @var{I}, the output colormap will +## contain one entry for every unique intensity value in the original image. +## In the worst case the new map could have as many rows as the number of +## pixels in the original image. +## +## Implementation Details: +## +## @var{newmap} is always an Mx3 matrix, even if the input image is +## an intensity grayscale image @var{I} (all three RGB planes are +## assigned the same value). +## +## The output image is of class uint8 if the size of the new colormap is +## less than or equal to 256. Otherwise, the output image is of class double. +## +## @seealso{rgb2ind, gray2ind} +## @end deftypefn + + +## Author: Josep Mones i Teixidor <jmones@puntbarra.com> + +function [Y, newmap] = cmunique (X, map) + + if (nargin < 1 || nargin > 2) + print_usage (); + endif + + cls = class (X); + ## FIXME: Documentation accepts only 3 classes. Could easily add 'single'. + if (! any (isa (X, {"uint8", "uint16", "double"}))) + error ("cmunique: X is of invalid data type '%s'", cls); + endif + + if (nargin == 2) + ## (X, map) case + if (! isnumeric (map) || iscomplex (map) + || ndims (map) != 2 || columns (map) != 3 + || any (map(:) < 0) || any (map(:) > 1)) + error ("cmunique: MAP must be a valid colormap"); + endif + [newmap,i,j] = unique (map, "rows"); # calculate unique colormap + if (isa (X, "double")) + Y = j(X); # find new indices + else + Y = j(double (X) + 1); # find new indices + endif + else + switch (size (X,3)) + case (1) + ## I case + [newmap,i,j] = unique (X); # calculate unique colormap + newmap = repmat (newmap,1,3); # get a RGB colormap + Y = reshape (j, rows (X), columns (X)); # Y is j reshaped + case (3) + ## RGB case + ## build a map with all values + map = [X(:,:,1)(:), X(:,:,2)(:), X(:,:,3)(:)]; + [newmap,i,j] = unique (map, "rows"); # calculate unique colormap + Y = reshape (j, rows (X), columns (X)); # Y is j reshaped + otherwise + error ("cmunique: X is not a valid image"); + endswitch + + ## if image was uint8 or uint16 we have to convert newmap to [0,1] range + if (! isa (X, "double")) + newmap = double (newmap) / double (intmax (class (X))); + endif + endif + + if (rows (newmap) <= 256) + ## convert Y to uint8 (0-based indices then) + Y = uint8 (Y-1); + endif + +endfunction + + +%!demo +%! [Y, newmap] = cmunique ([1:4;5:8], [hot(4);hot(4)]) +%! ## Both rows are equal since map maps colors to the same value +%! ## cmunique will give the same indices to both + +## Check that output is uint8 in short colormaps +%!test +%! [Y, newmap] = cmunique ([1:4;5:8], [hot(4);hot(4)]); +%! assert (Y, uint8 ([0:3;0:3])); +%! assert (newmap, hot (4)); + +## Check that output is double in bigger +%!test +%! [Y, newmap] = cmunique ([1:300;301:600], [hot(300);hot(300)]); +%! assert (Y, [1:300;1:300]); +%! assert (newmap, hot (300)); + +## Check boundary case 256 +%!test +%! [Y, newmap] = cmunique ([1:256;257:512], [hot(256);hot(256)]); +%! assert (Y, uint8 ([0:255;0:255])); +%! assert (newmap, hot (256)); + +## Check boundary case 257 +%!test +%! [Y, newmap] = cmunique ([1:257;258:514], [hot(257);hot(257)]); +%! assert (Y, [1:257;1:257]); +%! assert (newmap, hot (257)); + +## Random RGB image +%!test +%! RGB = rand (10,10,3); +%! [Y, newmap] = cmunique (RGB); +%! assert (RGB(:,:,1), newmap(:,1)(Y+1)); +%! assert (RGB(:,:,2), newmap(:,2)(Y+1)); +%! assert (RGB(:,:,3), newmap(:,3)(Y+1)); + +## Random uint8 RGB image +%!test +%! RGB = uint8 (rand (10,10,3)*255); +%! RGBd = double (RGB) / 255; +%! [Y, newmap] = cmunique (RGB); +%! assert (RGBd(:,:,1), newmap(:,1)(Y+1)); +%! assert (RGBd(:,:,2), newmap(:,2)(Y+1)); +%! assert (RGBd(:,:,3), newmap(:,3)(Y+1)); + +## Random uint16 RGB image +%!test +%! RGB = uint16 (rand (10,10,3)*65535); +%! RGBd = double (RGB) / 65535; +%! [Y, newmap] = cmunique (RGB); +%! assert (RGBd(:,:,1), newmap(:,1)(Y+1)); +%! assert (RGBd(:,:,2), newmap(:,2)(Y+1)); +%! assert (RGBd(:,:,3), newmap(:,3)(Y+1)); + +## Random I image +%!test +%! I = rand (10,10); +%! [Y, newmap] = cmunique (I); +%! assert (I, newmap(:,1)(Y+1)); +%! assert (I, newmap(:,2)(Y+1)); +%! assert (I, newmap(:,3)(Y+1)); + +## Random uint8 I image +%!test +%! I = uint8 (rand (10,10)*256); +%! Id = double (I) / 255; +%! [Y, newmap] = cmunique (I); +%! assert (Id, newmap(:,1)(Y+1)); +%! assert (Id, newmap(:,2)(Y+1)); +%! assert (Id, newmap(:,3)(Y+1)); + +## Random uint16 I image +%!test +%! I = uint16 (rand (10,10)*65535); +%! Id = double (I) / 65535; +%! [Y,newmap] = cmunique (I); +%! assert (Id,newmap (:,1)(Y+1)); +%! assert (Id,newmap (:,2)(Y+1)); +%! assert (Id,newmap (:,3)(Y+1)); + +## Test input validation +%!error cmpermute () +%!error cmpermute (1,2,3) +%!error <X is of invalid data type> cmunique (single (magic (16))) +%!error <MAP must be a valid colormap> cmunique (1, "a") +%!error <MAP must be a valid colormap> cmunique (1, i) +%!error <MAP must be a valid colormap> cmunique (1, ones (3,3,3)) +%!error <MAP must be a valid colormap> cmunique (1, ones (3,2)) +%!error <MAP must be a valid colormap> cmunique (1, [-1 1 1]) +%!error <MAP must be a valid colormap> cmunique (1, [2 1 1]) +
--- a/scripts/image/imshow.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/image/imshow.m Sat Jul 28 12:06:34 2012 -0400 @@ -25,7 +25,7 @@ ## @deftypefnx {Function File} {} imshow (@dots{}, @var{string_param1}, @var{value1}, @dots{}) ## @deftypefnx {Function File} {@var{h} =} imshow (@dots{}) ## Display the image @var{im}, where @var{im} can be a 2-dimensional -## (gray-scale image) or a 3-dimensional (RGB image) matrix. +## (grayscale image) or a 3-dimensional (RGB image) matrix. ## ## If @var{limits} is a 2-element vector @code{[@var{low}, @var{high}]}, ## the image is shown using a display range between @var{low} and
--- a/scripts/image/module.mk Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/image/module.mk Sat Jul 28 12:06:34 2012 -0400 @@ -4,6 +4,8 @@ image/autumn.m \ image/bone.m \ image/brighten.m \ + image/cmpermute.m \ + image/cmunique.m \ image/colorcube.m \ image/colormap.m \ image/contrast.m \
--- a/scripts/miscellaneous/fileattrib.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/miscellaneous/fileattrib.m Sat Jul 28 12:06:34 2012 -0400 @@ -57,6 +57,7 @@ ## True if the user (group; other users) has execute permission for ## @var{file}. ## @end table +## ## If an attribute does not apply (i.e., archive on a Unix system) then ## the field is set to NaN. ##
--- a/scripts/miscellaneous/gzip.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/miscellaneous/gzip.m Sat Jul 28 12:06:34 2012 -0400 @@ -51,10 +51,10 @@ %! mkdir (dirname); %! entry = gzip (filename, dirname); %! [path, basename, extension] = fileparts (filename); -%! if ! strcmp (entry, [dirname, filesep, basename, extension, ".gz"]) +%! if (! strcmp (entry, [dirname, filesep, basename, extension, ".gz"])) %! error ("gzipped file does not match expected name!"); %! endif -%! if ! exist (entry, "file") +%! if (! exist (entry, "file")) %! error ("gzipped file cannot be found!"); %! endif %! gunzip (entry);
--- a/scripts/optimization/fminbnd.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/optimization/fminbnd.m Sat Jul 28 12:06:34 2012 -0400 @@ -20,14 +20,13 @@ ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{x}, @var{fval}, @var{info}, @var{output}] =} fminbnd (@var{fun}, @var{a}, @var{b}, @var{options}) -## Find a minimum point of a univariate function. @var{fun} should be a -## function -## handle or name. @var{a}, @var{b} specify a starting interval. @var{options} -## is a -## structure specifying additional options. Currently, @code{fminbnd} -## recognizes these options: @code{"FunValCheck"}, @code{"OutputFcn"}, -## @code{"TolX"}, @code{"MaxIter"}, @code{"MaxFunEvals"}. -## For description of these options, see @ref{doc-optimset,,optimset}. +## Find a minimum point of a univariate function. +## +## @var{fun} should be a function handle or name. @var{a}, @var{b} specify a +## starting interval. @var{options} is a structure specifying additional +## options. Currently, @code{fminbnd} recognizes these options: +## "FunValCheck", "OutputFcn", "TolX", "MaxIter", "MaxFunEvals". For a +## description of these options, see @ref{doc-optimset,,optimset}. ## ## On exit, the function returns @var{x}, the approximate minimum point ## and @var{fval}, the function value thereof. @@ -43,7 +42,13 @@ ## @item -1 ## The algorithm has been terminated from user output function. ## @end itemize -## @seealso{optimset, fzero, fminunc} +## +## Notes: The search for a minimum is restricted to be in the interval +## bound by @var{a} and @var{b}. If you only have an initial point +## to begin searching from you will need to use an unconstrained +## minimization algorithm such as @code{fminunc} or @code{fminsearch}. +## @code{fminbnd} internally uses a Golden Section search strategy. +## @seealso{fzero, fminunc, fminsearch, optimset} ## @end deftypefn ## This is patterned after opt/fmin.f from Netlib, which in turn is taken from
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/scripts/optimization/fminsearch.m Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,352 @@ +## Copyright (C) 2003,2012 Andy Adler +## Copyright (C) 2002 N.J.Higham +## +## This file is part of Octave. +## +## Octave is free software; you can redistribute it and/or modify it +## under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 3 of the License, or (at +## your option) any later version. +## +## Octave is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +## General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with Octave; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Function File} {@var{x} =} fminsearch (@var{fun}, @var{x0}) +## @deftypefnx {Function File} {@var{x} =} fminsearch (@var{fun}, @var{x0}, @var{options}) +## @deftypefnx {Function File} {[@var{x}, @var{fval}] =} fminsearch (@dots{}) +## +## Find a value of @var{x} which minimizes the function @var{fun}. +## The search begins at the point @var{x0} and iterates using the +## Nelder & Mead Simplex algorithm (a derivative-free method). This algorithm +## is better-suited to functions which have discontinuities or for which +## a gradient-based search such as @code{fminunc} fails. +## +## Options for the search are provided in the parameter @var{options} using +## the function @code{optimset}. Currently, @code{fminsearch} accepts the +## options: "TolX", "MaxFunEvals", "MaxIter", "Display". For a description of +## these options, see @code{optimset}. +## +## On exit, the function returns @var{x}, the minimum point, +## and @var{fval}, the function value thereof. +## +## Example usages: +## +## @example +## @group +## fminsearch (@@(x) (x(1)-5).^2+(x(2)-8).^4, [0;0]) +## +## fminsearch (inline ("(x(1)-5).^2+(x(2)-8).^4", "x"), [0;0]) +## @end group +## @end example +## @seealso{fminbnd, fminunc, optimset} +## @end deftypefn + +## PKG_ADD: ## Discard result to avoid polluting workspace with ans at startup. +## PKG_ADD: [~] = __all_opts__ ("fminsearch"); + +## FIXME: Add support for "exitflag" output variable +## FIXME: Add support for "output" output variable +## FIXME: For Display option, add 'final' and 'notify' options. Not too hard. +## FIXME: Add support for OutputFcn. See fminunc for a template +## FIXME: Add support for exiting based on TolFun. See fminunc for an idea. + +function [x, fval] = fminsearch (fun, x0, options = struct ()) + + ## Get default options if requested. + if (nargin == 1 && ischar (fun) && strcmp (fun, "defaults")) + x = optimset ("Display", "notify", "FunValCheck", "off", + "MaxFunEvals", 400, "MaxIter", 400, + "OutputFcn", [], + "TolFun", 1e-7, "TolX", 1e-4); + return; + endif + + if (nargin < 2 || nargin > 3) + print_usage (); + endif + + x = nmsmax (fun, x0, options); + + if (isargout (2)) + fval = feval (fun, x); + endif + +endfunction + +##NMSMAX Nelder-Mead simplex method for direct search optimization. +## [x, fmax, nf] = NMSMAX(FUN, x0, STOPIT, SAVIT) attempts to +## maximize the function FUN, using the starting vector x0. +## The Nelder-Mead direct search method is used. +## Output arguments: +## x = vector yielding largest function value found, +## fmax = function value at x, +## nf = number of function evaluations. +## The iteration is terminated when either +## - the relative size of the simplex is <= STOPIT(1) +## (default 1e-3), +## - STOPIT(2) function evaluations have been performed +## (default inf, i.e., no limit), or +## - a function value equals or exceeds STOPIT(3) +## (default inf, i.e., no test on function values). +## The form of the initial simplex is determined by STOPIT(4): +## STOPIT(4) = 0: regular simplex (sides of equal length, the default) +## STOPIT(4) = 1: right-angled simplex. +## Progress of the iteration is not shown if STOPIT(5) = 0 (default 1). +## STOPIT(6) indicates the direction (ie. minimization or +## maximization.) Default is 1, maximization. +## set STOPIT(6)=-1 for minimization +## If a non-empty fourth parameter string SAVIT is present, then +## `SAVE SAVIT x fmax nf' is executed after each inner iteration. +## NB: x0 can be a matrix. In the output argument, in SAVIT saves, +## and in function calls, x has the same shape as x0. +## NMSMAX(fun, x0, STOPIT, SAVIT, P1, P2,...) allows additional +## arguments to be passed to fun, via feval(fun,x,P1,P2,...). +## References: +## N. J. Higham, Optimization by direct search in matrix computations, +## SIAM J. Matrix Anal. Appl, 14(2): 317-333, 1993. +## C. T. Kelley, Iterative Methods for Optimization, Society for Industrial +## and Applied Mathematics, Philadelphia, PA, 1999. + +## From Matrix Toolbox +## Copyright (C) 2002 N.J.Higham +## www.maths.man.ac.uk/~higham/mctoolbox +## +## Modifications for Octave by A.Adler 2003 + +function [stopit, savit, dirn, trace, tol, maxiter] = parse_options (options, x ); + + ## Tolerance for cgce test based on relative size of simplex. + stopit(1) = tol = optimget (options, "TolX", 1e-4); + + ## Max no. of f-evaluations. + stopit(2) = optimget (options, "MaxFunEvals", length (x) * 200); + + ## Max no. of iterations + maxiter = optimget (options, "MaxIter", length (x) * 200); + + ## Default target for f-values. + stopit(3) = Inf; # FIXME: expose this parameter to the outside + + ## Default initial simplex. + stopit(4) = 0; # FIXME: expose this parameter to the outside + + ## Default: show progress. + display = optimget (options, "Display", "notify"); + if (strcmp (display, "iter")) + stopit(5) = 1; + else + stopit(5) = 0; + endif + trace = stopit(5); + + ## Use function to minimize, not maximize + stopit(6) = dirn = -1; + + ## File name for snapshots. + savit = []; # FIXME: expose this parameter to the outside + +endfunction + +function [x, fmax, nf] = nmsmax (fun, x, options, savit, varargin) + + [stopit, savit, dirn, trace, tol, maxiter] = parse_options (options, x); + + if (strcmpi (optimget (options, "FunValCheck", "off"), "on")) + ## Replace fcn with a guarded version. + fun = @(x) guarded_eval (fun, x); + endif + + x0 = x(:); # Work with column vector internally. + n = length (x0); + + V = [zeros(n,1) eye(n)]; + f = zeros (n+1,1); + V(:,1) = x0; + f(1) = dirn * feval (fun,x,varargin{:}); + fmax_old = f(1); + + if (trace) + fprintf ("f(x0) = %9.4e\n", f(1)); + endif + + k = 0; m = 0; + + ## Set up initial simplex. + scale = max (norm (x0,Inf), 1); + if (stopit(4) == 0) + ## Regular simplex - all edges have same length. + ## Generated from construction given in reference [18, pp. 80-81] of [1]. + alpha = scale / (n*sqrt (2)) * [sqrt(n+1)-1+n, sqrt(n+1)-1]; + V(:,2:n+1) = (x0 + alpha(2)*ones (n,1)) * ones (1,n); + for j = 2:n+1 + V(j-1,j) = x0(j-1) + alpha(1); + x(:) = V(:,j); + f(j) = dirn * feval (fun,x,varargin{:}); + endfor + else + ## Right-angled simplex based on co-ordinate axes. + alpha = scale * ones(n+1,1); + for j=2:n+1 + V(:,j) = x0 + alpha(j)*V(:,j); + x(:) = V(:,j); + f(j) = dirn * feval (fun,x,varargin{:}); + endfor + endif + nf = n+1; + how = "initial "; + + [~,j] = sort (f); + j = j(n+1:-1:1); + f = f(j); + V = V(:,j); + + alpha = 1; beta = 1/2; gamma = 2; + + while (1) # Outer (and only) loop. + k++; + + if (k > maxiter) + msg = "Exceeded maximum iterations...quitting\n"; + break; + endif + + fmax = f(1); + if (fmax > fmax_old) + if (! isempty (savit)) + x(:) = V(:,1); + eval (["save " savit " x fmax nf"]); + endif + endif + if (trace) + fprintf ("Iter. %2.0f,", k); + fprintf ([" how = " how " "]); + fprintf ("nf = %3.0f, f = %9.4e (%2.1f%%)\n", nf, fmax, ... + 100*(fmax-fmax_old)/(abs(fmax_old)+eps)); + endif + fmax_old = fmax; + + ## Three stopping tests from MDSMAX.M + + ## Stopping Test 1 - f reached target value? + if (fmax >= stopit(3)) + msg = "Exceeded target...quitting\n"; + break; + endif + + ## Stopping Test 2 - too many f-evals? + if (nf >= stopit(2)) + msg = "Max no. of function evaluations exceeded...quitting\n"; + break; + endif + + ## Stopping Test 3 - converged? This is test (4.3) in [1]. + v1 = V(:,1); + size_simplex = norm (V(:,2:n+1)-v1(:,ones (1,n)),1) / max (1, norm (v1,1)); + if (size_simplex <= tol) + msg = sprintf ("Simplex size %9.4e <= %9.4e...quitting\n", ... + size_simplex, tol); + break; + endif + + ## One step of the Nelder-Mead simplex algorithm + ## NJH: Altered function calls and changed CNT to NF. + ## Changed each `fr < f(1)' type test to `>' for maximization + ## and re-ordered function values after sort. + + vbar = (sum (V(:,1:n)')/n)'; # Mean value + vr = (1 + alpha)*vbar - alpha*V(:,n+1); + x(:) = vr; + fr = dirn * feval (fun,x,varargin{:}); + nf = nf + 1; + vk = vr; fk = fr; how = "reflect, "; + if (fr > f(n)) + if (fr > f(1)) + ve = gamma*vr + (1-gamma)*vbar; + x(:) = ve; + fe = dirn * feval (fun,x,varargin{:}); + nf = nf + 1; + if (fe > f(1)) + vk = ve; + fk = fe; + how = "expand, "; + endif + endif + else + vt = V(:,n+1); + ft = f(n+1); + if (fr > ft) + vt = vr; + ft = fr; + endif + vc = beta*vt + (1-beta)*vbar; + x(:) = vc; + fc = dirn * feval (fun,x,varargin{:}); + nf = nf + 1; + if (fc > f(n)) + vk = vc; fk = fc; + how = "contract,"; + else + for j = 2:n + V(:,j) = (V(:,1) + V(:,j))/2; + x(:) = V(:,j); + f(j) = dirn * feval (fun,x,varargin{:}); + endfor + nf = nf + n-1; + vk = (V(:,1) + V(:,n+1))/2; + x(:) = vk; + fk = dirn * feval (fun,x,varargin{:}); + nf = nf + 1; + how = "shrink, "; + endif + endif + V(:,n+1) = vk; + f(n+1) = fk; + [~,j] = sort(f); + j = j(n+1:-1:1); + f = f(j); + V = V(:,j); + + endwhile # End of outer (and only) loop. + + ## Finished. + if (trace) + fprintf (msg); + endif + x(:) = V(:,1); + +endfunction + +## A helper function that evaluates a function and checks for bad results. +function y = guarded_eval (fun, x) + + y = fun (x); + + if (! (isreal (f))) + error ("fminsearch:notreal", "fminsearch: non-real value encountered"); + elseif (any (isnan (f(:)))) + error ("fminsearch:isnan", "fminsearch: NaN value encountered"); + elseif (any (isinf (f(:)))) + error ("fminsearch:isinf", "fminsearch: Inf value encountered"); + endif + +endfunction + + +%!demo +%! fcn = @(x) (x(1)-5).^2 + (x(2)-8).^4 +%! x0 = [0;0]; +%! [xmin, fval] = fminsearch (fcn, x0) + +%!assert (fminsearch (@sin, 3, optimset ("MaxIter", 3)), 4.8750, 1e-4) +%!assert (fminsearch (@sin, 3, optimset ("MaxIter", 30)), 4.7124, 1e-4) +%!shared c +%! c = 1.5; +%!assert (fminsearch (@(x) x(1).^2+c*x(2).^2,[1;1]), [0;0], 1e-4) +
--- a/scripts/optimization/fminunc.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/optimization/fminunc.m Sat Jul 28 12:06:34 2012 -0400 @@ -24,6 +24,7 @@ ## @deftypefnx {Function File} {[@var{x}, @var{fvec}, @var{info}, @var{output}, @var{grad}, @var{hess}] =} fminunc (@var{fcn}, @dots{}) ## Solve an unconstrained optimization problem defined by the function ## @var{fcn}. +## ## @var{fcn} should accepts a vector (array) defining the unknown variables, ## and return the objective function value, optionally with gradient. ## In other words, this function attempts to determine a vector @var{x} such @@ -72,9 +73,12 @@ ## (@var{output}), the output gradient (@var{grad}) and approximate Hessian ## (@var{hess}). ## -## Note: If you only have a single nonlinear equation of one variable, using -## @code{fminbnd} is usually a much better idea. -## @seealso{fminbnd, optimset} +## Notes: If you only have a single nonlinear equation of one variable then +## using @code{fminbnd} is usually a much better idea. The algorithm used is a +## gradient search which depends on the objective function being differentiable. +## If the function has discontinuities it may be better to use a derivative-free +## algorithm such as @code{fminsearch}. +## @seealso{fminbnd, fminsearch, optimset} ## @end deftypefn ## PKG_ADD: ## Discard result to avoid polluting workspace with ans at startup.
--- a/scripts/optimization/glpk.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/optimization/glpk.m Sat Jul 28 12:06:34 2012 -0400 @@ -369,6 +369,7 @@ ## @item 185 (@w{@code{LPX_UNDEF}}) ## Solution status is undefined. ## @end table +## ## Interior Point Method: ## ## @table @asis @@ -378,6 +379,7 @@ ## @item 151 (@w{@code{LPX_T_OPT}}) ## The interior point method is optimal. ## @end table +## ## Mixed Integer Method: ## ## @table @asis @@ -393,6 +395,7 @@ ## @item 173 (@w{@code{LPX_I_NOFEAS}}) ## No integer feasible solution. ## @end table +## ## @noindent ## If an error occurs, @var{status} will contain one of the following ## codes:
--- a/scripts/optimization/module.mk Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/optimization/module.mk Sat Jul 28 12:06:34 2012 -0400 @@ -6,6 +6,7 @@ optimization_FCN_FILES = \ optimization/__all_opts__.m \ optimization/fminbnd.m \ + optimization/fminsearch.m \ optimization/fminunc.m \ optimization/fsolve.m \ optimization/fzero.m \
--- a/scripts/optimization/optimset.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/optimization/optimset.m Sat Jul 28 12:06:34 2012 -0400 @@ -26,16 +26,34 @@ ## ## Valid parameters are: ## -## @itemize @bullet +## @table @asis ## @item AutoScaling ## ## @item ComplexEqn ## +## @item Display +## Request verbose display of results from optimizations. Values are: +## +## @table @asis +## @item "off" [default] +## No display. +## +## @item "iter" +## Display intermediate results for every loop iteration. +## +## @item "final" +## Display the result of the final loop iteration. +## +## @item "notify" +## Display the result of the final loop iteration if the function has +## failed to converge. +## @end table +## ## @item FinDiffType ## ## @item FunValCheck ## When enabled, display an error if the objective function returns an invalid -## value (a complex value, NaN, or Inf). Must be set to "on" or "off" +## value (a complex number, NaN, or Inf). Must be set to "on" or "off" ## [default]. Note: the functions @code{fzero} and @code{fminbnd} correctly ## handle Inf values and only complex values or NaN will cause an error in this ## case. @@ -77,7 +95,7 @@ ## @item TypicalX ## ## @item Updating -## @end itemize +## @end table ## @end deftypefn function retval = optimset (varargin)
--- a/scripts/pkg/module.mk Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/pkg/module.mk Sat Jul 28 12:06:34 2012 -0400 @@ -1,7 +1,6 @@ FCN_FILE_DIRS += pkg pkg_PRIVATE_FCN_FILES = \ - pkg/private/absolute_pathname.m \ pkg/private/build.m \ pkg/private/configure_make.m \ pkg/private/copy_files.m \
--- a/scripts/pkg/pkg.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/pkg/pkg.m Sat Jul 28 12:06:34 2012 -0400 @@ -421,50 +421,46 @@ global_packages = archprefix; elseif (length (files) >= 1 && nargout <= 2 && ischar (files{1})) prefix = files{1}; - try - prefix = absolute_pathname (prefix); - catch + if (! exist (prefix, "dir")) [status, msg, msgid] = mkdir (prefix); if (status == 0) error("cannot create prefix %s: %s", prefix, msg); endif warning ("creating the directory %s\n", prefix); - prefix = absolute_pathname (prefix); - end_try_catch - prefix = absolute_pathname (prefix); - local_packages = prefix; + endif + local_packages = prefix = canonicalize_filename (prefix); user_prefix = true; if (length (files) >= 2 && ischar (files{2})) archprefix = files{2}; - try - archprefix = absolute_pathname (archprefix); - catch + if (! exist (archprefix, "dir")) [status, msg, msgid] = mkdir (archprefix); if (status == 0) error("cannot create archprefix %s: %s", archprefix, msg); endif warning ("creating the directory %s\n", archprefix); - archprefix = absolute_pathname (archprefix); - end_try_catch - global_packages = archprefix; + global_packages = archprefix = canonicalize_file_name (archprefix); + endif endif else error ("you must specify a prefix directory, or request an output argument"); endif - + case "local_list" if (length (files) == 0 && nargout == 0) disp (local_list); elseif (length (files) == 0 && nargout == 1) local_packages = local_list; elseif (length (files) == 1 && nargout == 0 && ischar (files{1})) - try - local_list = absolute_pathname (files{1}); - catch - ## Force file to be created - fclose (fopen (files{1}, "wt")); - local_list = absolute_pathname (files{1}); - end_try_catch + local_list = files{1}; + if (! exist (local_list, "file")) + try + ## Force file to be created + fclose (fopen (local_list, "wt")); + catch + error ("cannot create file %s", local_list); + end_try_catch + endif + local_list = canonicalize_file_name (local_list); else error ("you must specify a local_list file, or request an output argument"); endif @@ -475,13 +471,16 @@ elseif (length (files) == 0 && nargout == 1) local_packages = global_list; elseif (length (files) == 1 && nargout == 0 && ischar (files{1})) - try - global_list = absolute_pathname (files{1}); - catch - ## Force file to be created - fclose (fopen (files{1}, "wt")); - global_list = absolute_pathname (files{1}); - end_try_catch + global_list = files{1}; + if (! exist (global_list, "file")) + try + ## Force file to be created + fclose (fopen (files{1}, "wt")); + catch + error ("cannot create file %s", global_list); + end_try_catch + endif + global_list = canonicalize_file_name (global_list); else error ("you must specify a global_list file, or request an output argument"); endif
--- a/scripts/pkg/private/absolute_pathname.m Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -## Copyright (C) 2005-2012 Søren Hauberg -## Copyright (C) 2010 VZLU Prague, a.s. -## -## This file is part of Octave. -## -## Octave is free software; you can redistribute it and/or modify it -## under the terms of the GNU General Public License as published by -## the Free Software Foundation; either version 3 of the License, or (at -## your option) any later version. -## -## Octave is distributed in the hope that it will be useful, but -## WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -## General Public License for more details. -## -## You should have received a copy of the GNU General Public License -## along with Octave; see the file COPYING. If not, see -## <http://www.gnu.org/licenses/>. - -## -*- texinfo -*- -## @deftypefn {Function File} {@var{pth} =} absolute_pathname (@var{pth}) -## Undocumented internal function. -## @end deftypefn - -function pth = absolute_pathname (pth) - [status, msg, msgid] = fileattrib (pth); - if (status != 1) - error ("could not find the file or path %s", pth); - else - pth = msg.Name; - endif -endfunction -
--- a/scripts/pkg/private/build.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/pkg/private/build.m Sat Jul 28 12:06:34 2012 -0400 @@ -34,7 +34,10 @@ error ("could not create installation directory: %s", msg); endif endif - builddir = absolute_pathname (builddir); + [builddir, status] = canonicalize_file_name (builddir); + if (! status) + error ("cannot find directory %s", builddir); + endif installdir = fullfile (builddir, "install"); if (! exist (installdir, "dir")) [status, msg] = mkdir (installdir);
--- a/scripts/plot/axis.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/axis.m Sat Jul 28 12:06:34 2012 -0400 @@ -109,6 +109,7 @@ ## @item "nolabel" ## Turn tic labels off for all axes. ## @end table +## ## Note, if there are no tic marks for an axis, there can be no labels. ## ## @noindent
--- a/scripts/plot/copyobj.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/copyobj.m Sat Jul 28 12:06:34 2012 -0400 @@ -15,51 +15,89 @@ ## <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn {Function File} {@var{hnew} =} copyobj (@var{horig}) -## @deftypefnx {Function File} {@var{hnew} =} copyobj (@var{horig}, @var{hparent}) -## Constructs a copy of the object associated with handle @var{horig} -## and returns a handle, @var{hnew}, to the new object. -## If a parent handle @var{hparent} (root, figure, axes or hggroup) is specified, -## the copied object will be created as a child to @var{hparent}. +## @deftypefn {Function File} {@var{hnew} =} copyobj (@var{horig}) +## @deftypefnx {Function File} {@var{hnew} =} copyobj (@var{horig}, @var{hparent}) +## Construct a copy of the object associated with handle @var{horig} +## and return a handle @var{hnew} to the new object. +## If a parent handle @var{hparent} (root, figure, axes, or hggroup) is +## specified, the copied object will be created as a child to @var{hparent}. ## @seealso{findobj, get, set, struct2hdl, hdl2struct} ## @end deftypefn ## Author: pdiribarne <pdiribarne@new-host.home> ## Created: 2012-04-01 -function hout = copyobj (hin, hpar = 0) +function hnew = copyobj (horig, hparent = 0) partypes = {"root", "figure", "axes", "hggroup"}; othertypes = {"line", "patch", "surface", "image", "text"}; alltypes = [partypes othertypes]; - if (! ishandle (hin) || nargin > 2) + if (! ishandle (horig) || nargin > 2) print_usage (); - elseif (! ishandle (hpar)) - hpar = figure (floor (hpar)); - elseif (! any (strcmpi (get (hpar).type, partypes))) + elseif (! ishandle (hparent)) + hparent = figure (fix (hparent)); + elseif (! any (strcmpi (get (hparent).type, partypes))) print_usage (); endif ## compatibility of input handles - kididx = find (strcmp (alltypes, get (hin).type)); - paridx = find (strcmp (alltypes, get (hpar).type)); + kididx = find (strcmp (alltypes, get (horig).type)); + paridx = find (strcmp (alltypes, get (hparent).type)); if (kididx <= paridx) error ("copyobj: %s object can't be children to %s.", - alltypes{kididx}, alltypes{paridx}) - elseif nargin == 1 - str = hdl2struct (hin); - hout = struct2hdl (str); + alltypes{kididx}, alltypes{paridx}); + elseif (nargin == 1) + str = hdl2struct (horig); + hnew = struct2hdl (str); else - str = hdl2struct (hin); - hout = struct2hdl (str, hpar); + str = hdl2struct (horig); + hnew = struct2hdl (str, hparent); endif + endfunction + +%!demo +%! hdl = figure (1234); +%! clf; +%! hold on; +%! x = 1:10; +%! y = x.^2; +%! dy = 2 * (.2 * x); +%! y2 = (x - 3).^2; +%! hg = errorbar (x, y, dy,'#~'); +%! set (hg, 'marker', '^', 'markerfacecolor', rand (1,3)); +%! plot (x, y2, 'ok-'); +%! legend ('errorbar', 'line'); +%! hnew = copyobj (hdl); + +%!demo +%! ## FIXME: This demo fails occasionally for an obscure reason. +%! ## It appears that there is something wrong with Octave code for patches. +%! hdl = figure (1234); +%! clf; +%! subplot (2,2,1); +%! hold on; +%! contourf (rand (10, 10)); +%! colorbar; +%! subplot (2,2,2); +%! quiver (rand (10, 10), rand (10, 10)); +%! subplot (2,2,3); +%! colormap (jet (64)); +%! hold on; +%! sombrero; +%! colorbar ('peer', gca, 'NorthOutside'); +%! subplot (2,2,4); +%! imagesc (rand (30, 30)); +%! text (15, 15, 'Rotated text', ... +%! 'HorizontAlalignment', 'Center', 'Rotation', 30); +%! hnew = copyobj (hdl); + %!test %! h1 = figure (); -%! set (h1, "visible", "off") +%! set (h1, "visible", "off"); %! x = 0:0.1:2*pi; %! y1 = sin (x); %! y2 = exp (x - 1); @@ -79,49 +117,14 @@ %! png1 = strcat (tmpnam (), ".png"); %! png2 = strcat (tmpnam (), ".png"); %! unwind_protect -%! print (h1, png1) +%! print (h1, png1); %! [img1, map1, alpha1] = imread (png1); -%! print (h2, png2) +%! print (h2, png2); %! [img2, map2, alpha2] = imread (png2); %! unwind_protect_cleanup %! unlink (png1); %! unlink (png2); %! end_unwind_protect -%! assert (img1, img2) -%! assert (map1, map2) -%! assert (alpha1, alpha2) - -%!demo -%! hdl = figure (1234); -%! clf () -%! hold on -%! x = 1:10; -%! y = x.^2; -%! dy = 2 * (.2 * x); -%! y2 = (x - 3).^2; -%! hg = errorbar (x, y, dy,'#~'); -%! set (hg, 'marker', '^', 'markerfacecolor', rand(1,3)) -%! plot (x, y2, 'ok-') -%! legend ('errorbar', 'line') -%! hout = copyobj (1234); - -%!demo -%! hdl = figure (1234); -%! clf () -%! subplot (2, 2, 1); -%! hold on -%! [C, H] = contourf (rand(10, 10)); -%! colorbar -%! subplot (2, 2, 2); -%! hold on -%! quiver (rand(10, 10), rand(10, 10)) -%! subplot (2, 2, 3); -%! colormap (jet (64)) -%! sombrero; -%! colorbar('peer', gca, 'NorthOutside') -%! subplot (2, 2, 4); -%! imagesc (rand (30, 30)); -%! text (15, 15, 'Rotated text', ... -%! 'HorizontAlalignment', 'Center', 'Rotation', 30); -%! hout = copyobj (1234); - +%! assert (img1, img2); +%! assert (map1, map2); +%! assert (alpha1, alpha2);
--- a/scripts/plot/findfigs.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/findfigs.m Sat Jul 28 12:06:34 2012 -0400 @@ -47,7 +47,7 @@ screensize(3:4) -= margin; for i = 1:numel (figh) - if strcmp (get (figh(i), "visible"), "on") + if (strcmp (get (figh(i), "visible"), "on")) units = get (figh(i), "units"); unwind_protect
--- a/scripts/plot/gco.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/gco.m Sat Jul 28 12:06:34 2012 -0400 @@ -20,18 +20,18 @@ ## @deftypefn {Function File} {@var{h} =} gco () ## @deftypefnx {Function File} {@var{h} =} gco (@var{fig}) ## Return a handle to the current object of the current figure, or a handle -## to the current object of the figure with handle @var{fig}. The current -## object of a figure is the object that was last clicked on. It is stored +## to the current object of the figure with handle @var{fig}. The current +## object of a figure is the object that was last clicked on. It is stored ## in the CurrentObject property of the target figure. ## ## If the last mouse click didn't occur on any child object of the figure, ## the current object is the figure itself. ## -## If no mouse click occured in the target figure, this function returns and +## If no mouse click occured in the target figure, this function returns an ## empty matrix. ## ## Note that the value returned by this function is not necessarily the same -## as the one returned by gcbo during callback execution. An executing +## as the one returned by gcbo during callback execution. An executing ## callback can be interrupted by another callback and the current object ## can be modified. ##
--- a/scripts/plot/hdl2struct.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/hdl2struct.m Sat Jul 28 12:06:34 2012 -0400 @@ -15,8 +15,8 @@ ## <http://www.gnu.org/licenses/>. ## -*- texinfo -*- -## @deftypefn {Function File} {@var{s} =} hdl2struct (@var{h}) -## Returns a structure, @var{s}, whose fields describe the properties +## @deftypefn {Function File} {@var{s} =} hdl2struct (@var{h}) +## Return a structure, @var{s}, whose fields describe the properties ## of the object, and its children, associated with the handle, @var{h}. ## The fields of the structure, @var{s}, are "type", "handle", "properties", ## "children" and "special". @@ -26,23 +26,24 @@ ## Author: pdiribarne <pdiribarne@new-host.home> ## Created: 2012-03-04 -function hgS = hdl2struct (h) +function s = hdl2struct (h) + if (nargin != 1 || !ishandle (h)) print_usage (); endif hiddenh = get (0, "showhiddenhandles"); - if strcmp (hiddenh, "on") + if (strcmp (hiddenh, "on")) set (0, "showhiddenhandles", "off"); endif ## main object main = get (h); - hgS.handle = h; - hgS.type = main.type; - hgS.properties = getprops (h); - hgS.children = []; - hgS.special = []; + s.handle = h; + s.type = main.type; + s.properties = getprops (h); + s.children = []; + s.special = []; ## sweep all children but legends, colorbars, uimenu and hggroup children ## in reverse order @@ -52,11 +53,11 @@ ui = findobj (h, "-depth", 1, "type", "uimenu"); nkids = length (kids); ii = 0; - while nkids - if (! any (kids (nkids) == lg) && !any (kids (nkids) == cb) - && ! any (kids (nkids) == ui) && !strcmpi (main.type, "hggroup")) + while (nkids) + if (! any (kids (nkids) == lg) && ! any (kids (nkids) == cb) + && ! any (kids (nkids) == ui) && ! strcmp (main.type, "hggroup")) ii++; - hgS.children(ii) = hdl2struct(kids(nkids)); + s.children(ii) = hdl2struct (kids(nkids)); endif nkids--; endwhile @@ -64,31 +65,31 @@ ## add non "children" children objects (title, xlabel, ...) and ## hggroup children and tag theim in "special" special = []; - if (strcmpi (main.type, "hggroup")) + if (strcmp (main.type, "hggroup")) special = main.children; endif special = [special getspecial(h)]; nsp = length (special); - while nsp + while (nsp) ii++; - hgS.children(ii) = hdl2struct (special(nsp)); - hgS.special(nsp) = ii; + s.children(ii) = hdl2struct (special(nsp)); + s.special(nsp) = ii; nsp--; endwhile ## look for legends and colorbars among "main"'s brothers and add them ## to the children list - if (strcmpi (main.type, "axes")) + if (strcmp (main.type, "axes")) par = main.parent; lg = findobj (par, "-depth", 1, "tag", "legend"); - if !isempty (lg) + if (! isempty (lg)) idx = arrayfun (@(x) get(x).userdata.handle(end) == h, lg); - lg = lg(find(idx)); + lg = lg(find (idx)); endif nlg = length (lg); - if nlg == 1 + if (nlg == 1) ii++; - hgS.children(ii) = hdl2struct (lg); + s.children(ii) = hdl2struct (lg); elseif (nlg > 1) error ("hdl2struct: more than one legend found") endif @@ -96,13 +97,13 @@ cb = findobj (par, "-depth", 1, "tag", "colorbar"); if (! isempty (cb)) idx = arrayfun (@(x) get(x).axes == h, cb); - cb = cb(find(idx)); + cb = cb(find (idx)); endif ncb = length (cb); if (ncb == 1) ii++; - hgS.children(ii) = hdl2struct(cb); + s.children(ii) = hdl2struct (cb); elseif (nlg > 1) error ("hdl2struct: more than one colorbar found") endif @@ -149,7 +150,7 @@ prop = fields{nflds}; val = obj.(fields{nflds}); ii++; - if !any (strcmp (prop, forbid)) + if (! any (strcmp (prop, forbid))) prpstr.(prop) = val; endif nflds--; @@ -162,5 +163,8 @@ prpstr.(hidden{ii}) = get (h, hidden{ii}); endif endfor + endfunction + +## FIXME: need validation tests
--- a/scripts/plot/plot.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/plot.m Sat Jul 28 12:06:34 2012 -0400 @@ -205,5 +205,20 @@ endfunction -%% FIXME: Need demo or test for function +%!demo +%! x = 1:5; y = 1:5; +%! plot (x,y,'g'); +%! title ('plot of green line at 45 degrees'); +%!demo +%! x = 1:5; y = 1:5; +%! plot (x,y,'g*'); +%! title ('plot of green stars along a line at 45 degrees'); + +%!demo +%! x1 = 1:5; y1 = 1:5; +%! x2 = 5:9; y2 = 5:-1:1; +%! plot (x1,y1,'bo-', x2,y2,'rs-'); +%! axis ('tight'); +%! title ('plot of blue circles ascending and red squares descending with connecting lines drawn'); +
--- a/scripts/plot/slice.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/slice.m Sat Jul 28 12:06:34 2012 -0400 @@ -104,7 +104,7 @@ x = varargin{1}; y = varargin{2}; z = varargin{3}; - if (isvector (x) && isvector (y) && isvector (z)])) + if (isvector (x) && isvector (y) && isvector (z)) [x, y, z] = meshgrid (x, y, z); elseif (ndims (x) == 3 && size_equal (x, y, z)) ## Do nothing.
--- a/scripts/plot/struct2hdl.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/struct2hdl.m Sat Jul 28 12:06:34 2012 -0400 @@ -18,188 +18,187 @@ ## @deftypefn {Function File} {@var{h} =} struct2hdl (@var{s}) ## @deftypefnx {Function File} {@var{h} =} struct2hdl (@var{s}, @var{p}) ## @deftypefnx {Function File} {@var{h} =} struct2hdl (@var{s}, @var{p}, @var{hilev}) -## Constructs an object from the structure @var{s}. The structure must -## contain the fields "handle", "type", "children", "properties", and +## Construct a handle object @var{h} from the structure @var{s}. The structure +## must contain the fields "handle", "type", "children", "properties", and ## "special". If the handle of an existing figure or axes is specified, -## @var{p}, the new object will be created as a child to that object. -## If no object handle is provided, then a new figure and the necessary +## @var{p}, the new object will be created as a child of that object. +## If no object handle is provided then a new figure and the necessary ## children will be constructed using the default object values from ## the root figure. ## -## A third boolean argument @var{hilev} can be passed to specify wether -## the function should try to preserve listeners/calbacks e.g for -## legends or hggroups. Default is false. -## @seealso{findobj, get, hdl2struct, set} +## A third boolean argument @var{hilev} can be passed to specify whether +## the function should try to preserve listeners/callbacks, e.g., for +## legends or hggroups. The default is false. +## @seealso{hdl2struct, findobj, get, set} ## @end deftypefn ## Author: pdiribarne <pdiribarne@new-host.home> ## Created: 2012-03-04 -function [ h, matchout ] = struct2hdl (hgS, matchin=[], hilev = false) +function [h, pout] = struct2hdl (s, p=[], hilev = false) - fields = { "handle", "type", "children", "properties", "special"}; + fields = {"handle", "type", "children", "properties", "special"}; partypes = {"root", "figure", "axes", "hggroup"}; othertypes = {"line", "patch", "surface", "image", "text"}; alltypes = [partypes othertypes]; - if (nargin > 3 || ! isstruct (hgS)) + if (nargin > 3 || ! isstruct (s)) print_usage (); - elseif (! all (isfield (hgS, fields))) + elseif (! all (isfield (s, fields))) print_usage (); - elseif (isscalar (matchin)) - if (! ishandle (matchin)) - error ("struct2hdl: argument #2 is not a handle to graphic object") + elseif (isscalar (p)) + if (! ishandle (p)) + error ("struct2hdl: P is not a handle to a graphic object"); endif - if (any (strcmp (get (matchin).type, partypes))) - paridx = find (strcmp (get (matchin).type, alltypes)); - kididx = find (strcmp (hgS.type, alltypes)); + if (any (strcmp (get (p).type, partypes))) + paridx = find (strcmp (get (p).type, alltypes)); + kididx = find (strcmp (s.type, alltypes)); if (kididx <= paridx) - error ("struct2hdl: incompatible input handles") + error ("struct2hdl: incompatible input handles"); endif else - error ("struct2hdl: %s object can't be parent object", get (matchin).type) + error ("struct2hdl: %s object can't be parent object", get (p).type); endif - hpar = matchin; - matchin = [NaN; hpar]; + hpar = p; + p = [NaN; hpar]; ## create appropriate parent if needed - if (any (strcmp (hgS.type, othertypes))) + if (any (strcmp (s.type, othertypes))) for ii = (paridx+1) : (numel (partypes)-1) eval (["hpar = " partypes{ii} "(\"parent\", hpar);"]); - matchin = [matchin [NaN; hpar]]; + p = [p [NaN; hpar]]; endfor - elseif (any (strcmp (hgS.type, {"hggroup", "axes"}))) + elseif (any (strcmp (s.type, {"hggroup", "axes"}))) for ii = (paridx+1) : (kididx-1) eval (["hpar = " partypes{ii} "(\"parent\", hpar);"]); - matchin = [matchin [NaN; hpar]]; + p = [p [NaN; hpar]]; endfor else par = NaN; endif - elseif (isempty (matchin)) - if (any (strcmp (hgS.type, othertypes))) + elseif (isempty (p)) + if (any (strcmp (s.type, othertypes))) par = axes (); - elseif (any (strcmp (hgS.type, {"hggroup", "axes"}))) + elseif (any (strcmp (s.type, {"hggroup", "axes"}))) par = figure (); else par = NaN; endif - matchin = [NaN; par]; + p = [NaN; par]; endif - ## read parent (last column) in matchin and remove it if duplicate - par = matchin (2,end); - tst = find (matchin (2,:) == par); + ## read parent (last column) in p and remove it if duplicate + par = p(2,end); + tst = find (p(2,:) == par); if (numel (tst) > 1) - matchin = matchin (1:2, 1:(tst(end)-1)); + p = p(1:2, 1:(tst(end)-1)); endif ## create object - if (strcmpi (hgS.type, "root")) + if (strcmp (s.type, "root")) h = 0; - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"callbackobject", "commandwindowsize", ... "screendepth", "screenpixelsperinch", ... "screensize"}); - elseif (strcmpi (hgS.type, "figure")) + elseif (strcmp (s.type, "figure")) h = figure (); - elseif (strcmpi (hgS.type, "axes")) + elseif (strcmp (s.type, "axes")) ## legends and colorbars are "transformed" in normal axes ## if hilev is not requested if (! hilev) - if (strcmp (hgS.properties.tag, "legend")) - hgS.properties.tag = ""; - hgS.properties.userdata = []; + if (strcmp (s.properties.tag, "legend")) + s.properties.tag = ""; + s.properties.userdata = []; par = gcf; - elseif (strcmp (hgS.properties.tag, "colorbar")) - hgS.properties.tag = ""; - hgS.properties.userdata = []; + elseif (strcmp (s.properties.tag, "colorbar")) + s.properties.tag = ""; + s.properties.userdata = []; par = gcf; endif endif - [h, hgS] = createaxes (hgS, matchin, par); - elseif (strcmpi (hgS.type, "line")) - h = createline (hgS, par); - elseif (strcmpi (hgS.type, "patch")) - [h, hgS] = createpatch (hgS, par); - elseif (strcmpi (hgS.type, "text")) - h = createtext (hgS, par); - elseif (strcmpi (hgS.type, "image")) - h = createimage (hgS, par); - elseif (strcmpi (hgS.type, "surface")) - h = createsurface (hgS, par); - elseif (strcmpi (hgS.type, "hggroup")) - [h, hgS, matchin] = createhg (hgS, matchin, par, hilev); + [h, s] = createaxes (s, p, par); + elseif (strcmp (s.type, "line")) + h = createline (s, par); + elseif (strcmp (s.type, "patch")) + [h, s] = createpatch (s, par); + elseif (strcmp (s.type, "text")) + h = createtext (s, par); + elseif (strcmp (s.type, "image")) + h = createimage (s, par); + elseif (strcmp (s.type, "surface")) + h = createsurface (s, par); + elseif (strcmp (s.type, "hggroup")) + [h, s, p] = createhg (s, p, par, hilev); endif ## children - matchin = [matchin [hgS.handle; h]]; # [original; new] - kids = hgS.children; + p = [p [s.handle; h]]; # [original; new] + kids = s.children; nkids = length (kids); ii = 0; - while nkids + while (nkids) ii++; - if (! any (ii == hgS.special)) - [h2, matchin] = struct2hdl (hgS.children(ii), - [matchin [hgS.handle; h]], hilev); + if (! any (ii == s.special)) + [h2, p] = struct2hdl (s.children(ii), [p [s.handle; h]], hilev); endif nkids--; endwhile ## paste properties - setprops (hgS, h, matchin, hilev); + setprops (s, h, p, hilev); - matchout = matchin; + pout = p; endfunction -function [h, hgSout] = createaxes (hgS, matchin, par); +function [h, sout] = createaxes (s, p, par) ## regular axes - if (strcmpi (hgS.properties.tag, "")) - propval = {"position", hgS.properties.position}; + if (strcmp (s.properties.tag, "")) + propval = {"position", s.properties.position}; hid = {"autopos_tag", "looseinset"}; for ii = 1:numel (hid) prop = hid{ii}; - if (isfield (hgS.properties, prop)) - val = hgS.properties.(prop); + if (isfield (s.properties, prop)) + val = s.properties.(prop); propval = [propval, prop, val]; endif endfor h = axes (propval{:}, "parent", par); - if isfield (hgS.properties, "__plotyy_axes__") - plty = hgS.properties.__plotyy_axes__; - addproperty ("__plotyy_axes__", h, "any") - tmp = [matchin [hgS.handle; h]]; - tst = arrayfun (@(x) any (plty == x), tmp (1:2:end)); - if sum (tst) == numel (plty) + if (isfield (s.properties, "__plotyy_axes__")) + plty = s.properties.__plotyy_axes__; + addproperty ("__plotyy_axes__", h, "any"); + tmp = [p [s.handle; h]]; + tst = arrayfun (@(x) any (plty == x), tmp(1:2:end)); + if (sum (tst) == numel (plty)) for ii = 1:numel (plty) - plty(ii) = tmp (find (tmp == plty(ii)) + 1); + plty(ii) = tmp(find (tmp == plty(ii)) + 1); endfor for ii = 1:numel (plty) set (plty(ii), "__plotyy_axes__", plty); endfor endif - hgS.properties = rmfield (hgS.properties, "__plotyy_axes__"); + s.properties = rmfield (s.properties, "__plotyy_axes__"); endif ## delete non-default and already set properties - fields = fieldnames (hgS.properties); + fields = fieldnames (s.properties); tst = cellfun (@(x) isprop (h, x), fields); - hgS.properties = rmfield (hgS.properties, fields(find (tst == 0))); + s.properties = rmfield (s.properties, fields(find (tst == 0))); - elseif (strcmpi (hgS.properties.tag, "legend")) + elseif (strcmp (s.properties.tag, "legend")) ## legends - oldax = hgS.properties.userdata.handle; - idx = find (matchin == oldax); - newax = matchin(idx+1); + oldax = s.properties.userdata.handle; + idx = find (p == oldax); + newax = p(idx+1); strings = {}; - kids = hgS.children; - kids(hgS.special) = []; + kids = s.children; + kids(s.special) = []; oldh = unique (arrayfun (@(x) x.properties.userdata(end), kids)); for ii = 1:length (oldh) - idx = find (matchin(1:2:end) == oldh(ii)) * 2; + idx = find (p(1:2:end) == oldh(ii)) * 2; if (! isempty (idx)) - newh(ii) = matchin (idx); + newh(ii) = p(idx); if (! strcmp (get (newh(ii), "type"), "hggroup")) str = get (newh(ii), "displayname"); strings = [strings str]; @@ -208,93 +207,93 @@ strings = [strings str]; endif else - error ("struct2hdl: didn't find a legend item") + error ("struct2hdl: didn't find a legend item"); endif endfor - location = hgS.properties.location; - orientation = hgS.properties.orientation; - textpos = hgS.properties.textposition; - box = hgS.properties.box; + location = s.properties.location; + orientation = s.properties.orientation; + textpos = s.properties.textposition; + box = s.properties.box; h = legend (newax, newh, strings, "location", location, ... "orientation", orientation); set (h, "textposition", textpos); # bug makes "textposition" - # redefine the legend + # redefine the legend h = legend (newax, newh, strings, "location", location, ... "orientation", orientation); ## box if (strcmp (box, "on")) - legend boxon + legend ("boxon"); endif ## visibility tst = arrayfun (@(x) strcmp (x.properties.visible, "on"), kids); - if !any (tst) + if (! any (tst)) legend ("hide"); endif ## remove all properties such as "textposition" that redefines ## the entire legend. Also remove chidren - hgS.properties = rmfield (hgS.properties, ... - {"userdata", "xlabel",... - "ylabel", "zlabel", "location", ... - "title", "string","orientation", ... - "visible", "textposition"}); + s.properties = rmfield (s.properties, ... + {"userdata", "xlabel",... + "ylabel", "zlabel", "location", ... + "title", "string","orientation", ... + "visible", "textposition"}); - hgS.children = []; + s.children = []; - elseif (strcmpi (hgS.properties.tag, "colorbar")) + elseif (strcmp (s.properties.tag, "colorbar")) ## colorbar - oldax = hgS.properties.axes; - if (! isempty (idx = find (oldax == matchin))) - ax = matchin(idx+1); - location = hgS.properties.location; + oldax = s.properties.axes; + if (! isempty (idx = find (oldax == p))) + ax = p(idx+1); + location = s.properties.location; h = colorbar ("peer", ax, location); - hgS.properties = rmfield (hgS.properties, ... - {"userdata", "xlabel" ... - "ylabel", "zlabel", ... - "title", "axes"}); - hgS.children= []; + s.properties = rmfield (s.properties, ... + {"userdata", "xlabel" ... + "ylabel", "zlabel", ... + "title", "axes"}); + s.children= []; else - error ("hdl2struct: didn't find an object") + error ("hdl2struct: didn't find an object"); endif endif - hgSout = hgS; + sout = s; endfunction -function [h] = createline (hgS, par); +function h = createline (s, par) h = line ("parent", par); - addmissingprops (h, hgS.properties); + addmissingprops (h, s.properties); endfunction -function [h, hgSout] = createpatch (hgS, par); - prp.faces = hgS.properties.faces; - prp.vertices = hgS.properties.vertices; - prp.facevertexcdata = hgS.properties.facevertexcdata; +function [h, sout] = createpatch (s, par) + prp.faces = s.properties.faces; + prp.vertices = s.properties.vertices; + prp.facevertexcdata = s.properties.facevertexcdata; h = patch (prp); set (h, "parent", par); - hgS.properties = rmfield (hgS.properties, + s.properties = rmfield (s.properties, {"faces", "vertices", "facevertexcdata"}); - addmissingprops (h, hgS.properties); - hgSout = hgS; + addmissingprops (h, s.properties); + sout = s; endfunction -function [h] = createtext (hgS, par); +function h = createtext (s, par) h = text ("parent", par); - addmissingprops (h, hgS.properties) + addmissingprops (h, s.properties); endfunction -function [h] = createimage (hgS, par); +function h = createimage (s, par) h = image ("parent", par); - addmissingprops (h, hgS.properties) + addmissingprops (h, s.properties); endfunction -function [h] = createsurface (hgS, par); +function h = createsurface (s, par) h = surface ("parent", par); - addmissingprops (h, hgS.properties) + addmissingprops (h, s.properties); endfunction -function [h, hgSout, matchout] = createhg (hgS, matchin, par, hilev) +function [h, sout, pout] = createhg (s, p, par, hilev) ## Here we infer from properties the type of hggroup we should build ## an call corresponding high level functions ## We manually set "hold on" to avoid next hggroup be deleted @@ -302,57 +301,57 @@ hold on; if (hilev) - [h, hgS, matchin] = createhg_hilev (hgS, matchin, par); - if (numel (hgS.children) != numel (get (h).children)) - warning (["struct2hdl: couldn't infer the hggroup type. ", ... + [h, s, p] = createhg_hilev (s, p, par); + if (numel (s.children) != numel (get (h).children)) + warning (["struct2hdl: could not infer the hggroup type. ", ... "Will build objects but listener/callback functions ", ... "will be lost"]); - if isfield (h, "bargroup") + if (isfield (h, "bargroup")) delete (get (h).bargroup); else delete (h); endif h = hggroup ("parent", par); - addmissingprops (h, hgS.properties); - hgS.special = []; + addmissingprops (h, s.properties); + s.special = []; else - oldkids = hgS.children; + oldkids = s.children; newkids = get (h).children; nkids = numel (oldkids); ii = 1; - while nkids - matchin = [matchin [oldkids(ii++).handle; newkids(nkids--)]]; + while (nkids) + p = [p [oldkids(ii++).handle; newkids(nkids--)]]; endwhile endif else h = hggroup ("parent", par); - addmissingprops (h, hgS.properties); - hgS.special = []; + addmissingprops (h, s.properties); + s.special = []; endif - hgSout = hgS; - matchout = matchin; + sout = s; + pout = p; endfunction -function [h, hgSout, matchout] = createhg_hilev (hgS, matchin, par) - fields = hgS.properties; +function [h, sout, pout] = createhg_hilev (s, p, par) + fields = s.properties; if (isfield (fields, "contourmatrix")) ## contours - xdata = hgS.properties.xdata; - ydata = hgS.properties.ydata; - zdata = hgS.properties.zdata; - levellist = hgS.properties.levellist; - textlist = hgS.properties.textlist; + xdata = s.properties.xdata; + ydata = s.properties.ydata; + zdata = s.properties.zdata; + levellist = s.properties.levellist; + textlist = s.properties.textlist; ## contour creation - if (isempty (hgS.children(1).properties.zdata)) - if (strcmpi (hgS.properties.fill, "on")) + if (isempty (s.children(1).properties.zdata)) + if (strcmpi (s.properties.fill, "on")) [cm2, h] = contourf (xdata, ydata, zdata, levellist); else [cm2, h] = contour (xdata, ydata, zdata, levellist); endif ## labels - if (strcmpi (hgS.properties.showtext, "on")) + if (strcmpi (s.properties.showtext, "on")) clabel (cm2, h, textlist); endif else @@ -360,7 +359,7 @@ endif ## delete already set properties and children - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"xdata", "ydata", "zdata", ... "contourmatrix", "levellist", ... "fill", "labelspacing", ... @@ -372,16 +371,16 @@ elseif (isfield (fields, "udata") && isfield (fields, "vdata")) ## quiver - xdata = hgS.properties.xdata; - ydata = hgS.properties.ydata; + xdata = s.properties.xdata; + ydata = s.properties.ydata; - udata = hgS.properties.udata; - vdata = hgS.properties.vdata; + udata = s.properties.udata; + vdata = s.properties.vdata; h = quiver (xdata, ydata, udata, vdata); ## delete already set properties and children - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"xdata", "ydata", "zdata", ... "xdatasource", "ydatasource", "zdatasource", ... "udata", "vdata", "wdata", ... @@ -389,13 +388,13 @@ elseif (isfield (fields, "format")) ##errorbar - form = hgS.properties.format; - xdata = hgS.properties.xdata; - ydata = hgS.properties.ydata; - xldata = hgS.properties.xldata; - ldata = hgS.properties.ldata; - xudata = hgS.properties.xudata; - udata = hgS.properties.udata; + form = s.properties.format; + xdata = s.properties.xdata; + ydata = s.properties.ydata; + xldata = s.properties.xldata; + ldata = s.properties.ldata; + xudata = s.properties.xudata; + udata = s.properties.udata; switch form case "xerr" @@ -411,10 +410,10 @@ case "boxxy" h = errorbar (xdata, ydata, xldata, xudata, ldata, udata, "#~>"); otherwise - error ("struct2hdl: couldn't guess the errorbar format") + error ("struct2hdl: couldn't guess the errorbar format"); endswitch ## delete already set properties - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"xdata", "ydata", ... "xldata", "ldata", ... "xudata", "udata", ... @@ -429,20 +428,20 @@ ## and rebuild the whole bargroup. ## The duplicate are deleted after calling "setprops" - bargroup = hgS.properties.bargroup; - oldh = hgS.handle; + bargroup = s.properties.bargroup; + oldh = s.handle; - temp = arrayfun (@(x) any(x == bargroup), [matchin(1:2:end) oldh]); + temp = arrayfun (@(x) any(x == bargroup), [p(1:2:end) oldh]); tst = sum (temp) == length (bargroup); if (isscalar (bargroup) || !tst) - xdata = hgS.properties.xdata; - ydata = hgS.properties.ydata; + xdata = s.properties.xdata; + ydata = s.properties.ydata; h = bar (xdata, ydata); ## delete already set properties, - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"xdata", "ydata", ... "xdatasource", "ydatasource", ... "bargroup", ... @@ -453,18 +452,18 @@ ##build x/y matrix nbar = length (bargroup); - tmp = struct ("handle", NaN,"type", "", "children", [], "special", []); + tmp = struct ("handle", NaN, "type", "", "children", [], "special", []); for ii = 1:(nbar - 1) - idx = find (matchin(1:2:end) == bargroup(ii)) * 2; - hdl = matchin (idx); + idx = find (p(1:2:end) == bargroup(ii)) * 2; + hdl = p (idx); xdata = [xdata get(hdl).xdata]; ydata = [ydata get(hdl).ydata]; tmp.children(ii) = hdl2struct (hdl); endfor - xdata = [xdata hgS.properties.xdata]; - ydata = [ydata hgS.properties.ydata]; - width = hgS.properties.barwidth; + xdata = [xdata s.properties.xdata]; + ydata = [ydata s.properties.ydata]; + width = s.properties.barwidth; h = bar (ydata, width); ## replace previous handles in "match", copy props and delete redundant @@ -472,82 +471,82 @@ props = tmp.children(ii).properties; bl = props.baseline; tmp.children(ii).properties = rmfield (props, {"baseline", "bargroup"}); - setprops (tmp.children(ii), h(ii), matchin, 1); + setprops (tmp.children(ii), h(ii), p, 1); delete (tmp.children(ii).handle); delete (bl); - idxpar = find (matchin == tmp.children(ii).handle); - matchin (idxpar) = h(ii); + idxpar = find (p == tmp.children(ii).handle); + p(idxpar) = h(ii); idxkid = idxpar - 2; - matchin (idxkid) = get (h(ii), "children"); + p(idxkid) = get (h(ii), "children"); endfor - matchin (2,((end-nbar+2):end)) = h (1:(end-1)); - h = h (end); + p(2,((end-nbar+2):end)) = h(1:(end-1)); + h = h(end); ## delete already set properties , - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"xdata", "ydata", "bargroup"... "barwidth", "baseline"}); endif elseif (isfield (fields, "baseline")) ## stem plot - xdata = hgS.properties.xdata; - ydata = hgS.properties.ydata; + xdata = s.properties.xdata; + ydata = s.properties.ydata; h = stem (xdata, ydata); ## delete already set properties, - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"xdata", "ydata", ... "xdatasource", "ydatasource", ... "baseline"}); elseif (isfield (fields, "basevalue")) ## area plot - xdata = hgS.properties.xdata; - ydata = hgS.properties.ydata; - level = hgS.properties.basevalue; + xdata = s.properties.xdata; + ydata = s.properties.ydata; + level = s.properties.basevalue; h = area (xdata, ydata, level); ## delete already set properties, - hgS.properties = rmfield (hgS.properties, ... + s.properties = rmfield (s.properties, ... {"xdata", "ydata", ... "xdatasource", "ydatasource"}); else - warning ("struct2hdl: couldn't infer the hggroup type. Will build objects but listener/callback functions will be lost"); + warning ("struct2hdl: could not infer the hggroup type. Will build objects but listener/callback functions will be lost"); h = hggroup ("parent", par); - addmissingprops (h, hgS.properties); - hgS.special = []; # children will be treated as normal children + addmissingprops (h, s.properties); + s.special = []; # children will be treated as normal children endif - hgSout = hgS; - matchout = matchin; + sout = s; + pout = p; endfunction -function setprops (hgS, h, matchin, hilev) - more off - if (strcmpi (hgS.properties.tag, "")) - specs = hgS.children(hgS.special); +function setprops (s, h, p, hilev) + more off; + if (strcmpi (s.properties.tag, "")) + specs = s.children(s.special); hdls = arrayfun (@(x) x.handle, specs); - nh = length(hdls); + nh = length (hdls); msg = ""; if (! nh) - set (h, hgS.properties); + set (h, s.properties); else ## Specials are objects that where automatically constructed with ## current object. Among them are "x(yz)labels", "title", high ## level hggroup children - fields = fieldnames (hgS.properties); - vals = struct2cell (hgS.properties); + fields = fieldnames (s.properties); + vals = struct2cell (s.properties); idx = find (cellfun (@(x) valcomp(x, hdls) , vals)); - hgS.properties = rmfield (hgS.properties, fields(idx)); + s.properties = rmfield (s.properties, fields(idx)); ## set all properties but special handles - set (h, hgS.properties); + set (h, s.properties); ## find props with val == (one of special handles) nf = length (idx); fields = fields(idx); vals = vals(idx); - while nf + while (nf) field = fields{nf}; idx = find (hdls == vals{nf}); spec = specs(idx); @@ -561,39 +560,39 @@ ## If hggroup children were created by high level functions, ## copy only usefull properties. if (hilev) - if (strcmpi (hgS.type, "hggroup")) - nold = numel (hgS.children); - nnew = numel (get(h).children); + if (strcmp (s.type, "hggroup")) + nold = numel (s.children); + nnew = numel (get (h).children); if (nold == nnew) - hnew = get(h).children; + hnew = get (h).children; ii = 1; - while ii <= nnew + while (ii <= nnew) try set (hnew (ii), "displayname", ... - hgS.children(ii).properties.displayname); + s.children(ii).properties.displayname); catch - sprintf ("struct2hdl: couldn't set hggroup children #%d props.", ii) + sprintf ("struct2hdl: couldn't set hggroup children #%d props.", ii); end_try_catch ii ++; endwhile else - error ("struct2hdl: non-conformant number of children in hgggroup") + error ("struct2hdl: non-conformant number of children in hgggroup"); endif endif endif endif - elseif (strcmpi (hgS.properties.tag, "legend") - || strcmpi (hgS.properties.tag, "colorbar")) - set (h, hgS.properties); + elseif (strcmpi (s.properties.tag, "legend") + || strcmpi (s.properties.tag, "colorbar")) + set (h, s.properties); endif endfunction function out = valcomp (x, hdls) - if (isfloat(x) && isscalar(x)) + if (isfloat (x) && isscalar (x)) out = any (x == hdls); else out = 0; @@ -606,10 +605,13 @@ curfields = fieldnames (get (h)); missing = cellfun (@(x) !any (strcmp (x, curfields)), oldfields); idx = find (missing); - for ii = 1:length(idx) + for ii = 1:length (idx) prop = oldfields{idx(ii)}; if (! any (strcmp (prop, hid))) addproperty (prop, h, "any"); endif endfor endfunction + + +## FIXME: Need validation tests
--- a/scripts/plot/uigetfile.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/uigetfile.m Sat Jul 28 12:06:34 2012 -0400 @@ -81,7 +81,7 @@ error ("uigetfile: number of input arguments must be less than eight"); endif - defaultvals = {cell (0, 2), # File Filter + defaultvals = {cell(0, 2), # File Filter "Open File", # Dialog Title "", # Default file name [240, 120], # Dialog Position (pixel x/y)
--- a/scripts/plot/uiputfile.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/plot/uiputfile.m Sat Jul 28 12:06:34 2012 -0400 @@ -72,7 +72,7 @@ print_usage (); endif - defaultvals = {cell (0, 2), # File Filter + defaultvals = {cell(0, 2), # File Filter "Save File", # Dialog Title "", # Default file name [240, 120], # Dialog Position (pixel x/y)
--- a/scripts/testfun/test.m Sat Jul 28 15:17:57 2012 +0200 +++ b/scripts/testfun/test.m Sat Jul 28 12:06:34 2012 -0400 @@ -334,10 +334,6 @@ __signal_fail); end_try_catch - ## Clear shared function definitions. - eval (__clear, ""); - __clear = ""; - ## Initialization code will be evaluated below. ### FUNCTION @@ -555,6 +551,7 @@ __tests += __istest; __successes += __success * __istest; endfor + ## Clear any test functions created eval (__clear, ""); if (nargout == 0)
--- a/src/DLD-FUNCTIONS/__contourc__.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,340 +0,0 @@ -/* Contour lines for function evaluated on a grid. - -Copyright (C) 2007-2012 Kai Habel -Copyright (C) 2004, 2007 Shai Ayal - -Adapted to an oct file from the stand alone contourl by Victro Munoz -Copyright (C) 2004 Victor Munoz - -Based on contour plot routine (plcont.c) in PLPlot package -http://plplot.org/ - -Copyright (C) 1995, 2000, 2001 Maurice LeBrun -Copyright (C) 2000, 2002 Joao Cardoso -Copyright (C) 2000, 2001, 2002, 2004 Alan W. Irwin -Copyright (C) 2004 Andrew Ross - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <cfloat> - -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" - -static Matrix this_contour; -static Matrix contourc; -static int elem; - -// This is the quanta in which we increase this_contour. -#define CONTOUR_QUANT 50 - -// Add a coordinate point (x,y) to this_contour. - -static void -add_point (double x, double y) -{ - if (elem % CONTOUR_QUANT == 0) - this_contour = this_contour.append (Matrix (2, CONTOUR_QUANT, 0)); - - this_contour (0, elem) = x; - this_contour (1, elem) = y; - elem++; -} - -// Add contents of current contour to contourc. -// this_contour.cols () - 1; - -static void -end_contour (void) -{ - if (elem > 2) - { - this_contour (1, 0) = elem - 1; - contourc = contourc.append (this_contour.extract_n (0, 0, 2, elem)); - } - - this_contour = Matrix (); - elem = 0; -} - -// Start a new contour, and add contents of current one to contourc. - -static void -start_contour (double lvl, double x, double y) -{ - end_contour (); - this_contour.resize (2, 0); - add_point (lvl, 0); - add_point (x, y); -} - -static void -drawcn (const RowVector& X, const RowVector& Y, const Matrix& Z, - double lvl, int r, int c, double ct_x, double ct_y, - unsigned int start_edge, bool first, charMatrix& mark) -{ - double px[4], py[4], pz[4], tmp; - unsigned int stop_edge, next_edge, pt[2]; - int next_r, next_c; - - //get x, y, and z - lvl for current facet - px[0] = px[3] = X(c); - px[1] = px[2] = X(c+1); - - py[0] = py[1] = Y(r); - py[2] = py[3] = Y(r+1); - - pz[3] = Z(r+1, c) - lvl; - pz[2] = Z(r+1, c + 1) - lvl; - pz[1] = Z(r, c+1) - lvl; - pz[0] = Z(r, c) - lvl; - - // Facet edge and point naming assignment. - // - // 0-----1 .-0-. - // | | | | - // | | 3 1 - // | | | | - // 3-----2 .-2-. - - // Get mark value of current facet. - char id = static_cast<char> (mark(r, c)); - - // Check startedge s. - if (start_edge == 255) - { - // Find start edge. - for (unsigned int k = 0; k < 4; k++) - if (static_cast<char> (1 << k) & id) - start_edge = k; - } - - if (start_edge == 255) - return; - - // Decrease mark value of current facet for start edge. - mark(r, c) -= static_cast<char> (1 << start_edge); - - // Next point (clockwise). - pt[0] = start_edge; - pt[1] = (pt[0] + 1) % 4; - - // Calculate contour segment start if first of contour. - if (first) - { - tmp = fabs (pz[pt[1]]) / fabs (pz[pt[0]]); - - if (xisnan (tmp)) - ct_x = ct_y = 0.5; - else - { - ct_x = px[pt[0]] + (px[pt[1]] - px[pt[0]])/(1 + tmp); - ct_y = py[pt[0]] + (py[pt[1]] - py[pt[0]])/(1 + tmp); - } - - start_contour (lvl, ct_x, ct_y); - } - - // Find stop edge. - // FIXME -- perhaps this should use a while loop? - for (unsigned int k = 1; k <= 4; k++) - { - if (start_edge == 0 || start_edge == 2) - stop_edge = (start_edge + k) % 4; - else - stop_edge = (start_edge - k) % 4; - - if (static_cast<char> (1 << stop_edge) & id) - break; - } - - pt[0] = stop_edge; - pt[1] = (pt[0] + 1) % 4; - tmp = fabs (pz[pt[1]]) / fabs (pz[pt[0]]); - - if (xisnan (tmp)) - ct_x = ct_y = 0.5; - else - { - ct_x = px[pt[0]] + (px[pt[1]] - px[pt[0]])/(1 + tmp); - ct_y = py[pt[0]] + (py[pt[1]] - py[pt[0]])/(1 + tmp); - } - - // Add point to contour. - add_point (ct_x, ct_y); - - // Decrease id value of current facet for start edge. - mark(r, c) -= static_cast<char> (1 << stop_edge); - - // Find next facet. - next_c = c; - next_r = r; - - if (stop_edge == 0) - next_r--; - else if (stop_edge == 1) - next_c++; - else if (stop_edge == 2) - next_r++; - else if (stop_edge == 3) - next_c--; - - // Check if next facet is not done yet. - // Go to next facet. - if (next_r >= 0 && next_c >= 0 && next_r < mark.rows () - && next_c < mark.cols () && mark(next_r, next_c) > 0) - { - next_edge = (stop_edge + 2) % 4; - drawcn (X, Y, Z, lvl, next_r, next_c, ct_x, ct_y, next_edge, false, mark); - } -} - -static void -mark_facets (const Matrix& Z, charMatrix& mark, double lvl) -{ - unsigned int nr = mark.rows (); - unsigned int nc = mark.cols (); - - double f[4]; - - for (unsigned int c = 0; c < nc; c++) - for (unsigned int r = 0; r < nr; r++) - { - f[0] = Z(r, c) - lvl; - f[1] = Z(r, c+1) - lvl; - f[3] = Z(r+1, c) - lvl; - f[2] = Z(r+1, c+1) - lvl; - - for (unsigned int i = 0; i < 4; i++) - if (fabs(f[i]) < DBL_EPSILON) - f[i] = DBL_EPSILON; - - if (f[1] * f[2] < 0) - mark(r, c) += 2; - - if (f[0] * f[3] < 0) - mark(r, c) += 8; - } - - for (unsigned int r = 0; r < nr; r++) - for (unsigned int c = 0; c < nc; c++) - { - f[0] = Z(r, c) - lvl; - f[1] = Z(r, c+1) - lvl; - f[3] = Z(r+1, c) - lvl; - f[2] = Z(r+1, c+1) - lvl; - - for (unsigned int i = 0; i < 4; i++) - if (fabs(f[i]) < DBL_EPSILON) - f[i] = DBL_EPSILON; - - if (f[0] * f[1] < 0) - mark(r, c) += 1; - - if (f[2] * f[3] < 0) - mark(r, c) += 4; - } -} - -static void -cntr (const RowVector& X, const RowVector& Y, const Matrix& Z, double lvl) -{ - unsigned int nr = Z.rows (); - unsigned int nc = Z.cols (); - - charMatrix mark (nr - 1, nc - 1, 0); - - mark_facets (Z, mark, lvl); - - // Find contours that start at a domain edge. - - for (unsigned int c = 0; c < nc - 1; c++) - { - // Top. - if (mark(0, c) & 1) - drawcn (X, Y, Z, lvl, 0, c, 0.0, 0.0, 0, true, mark); - - // Bottom. - if (mark(nr - 2, c) & 4) - drawcn (X, Y, Z, lvl, nr - 2, c, 0.0, 0.0, 2, true, mark); - } - - for (unsigned int r = 0; r < nr - 1; r++) - { - // Left. - if (mark(r, 0) & 8) - drawcn (X, Y, Z, lvl, r, 0, 0.0, 0.0, 3, true, mark); - - // Right. - if (mark(r, nc - 2) & 2) - drawcn (X, Y, Z, lvl, r, nc - 2, 0.0, 0.0, 1, true, mark); - } - - for (unsigned int r = 0; r < nr - 1; r++) - for (unsigned int c = 0; c < nc - 1; c++) - if (mark (r, c) > 0) - drawcn (X, Y, Z, lvl, r, c, 0.0, 0.0, 255, true, mark); -} - -DEFUN_DLD (__contourc__, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} __contourc__ (@var{x}, @var{y}, @var{z}, @var{levels})\n\ -Undocumented internal function.\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 4) - { - RowVector X = args (0).row_vector_value (); - RowVector Y = args (1).row_vector_value (); - Matrix Z = args (2).matrix_value (); - RowVector L = args (3).row_vector_value (); - - if (! error_state) - { - contourc.resize (2, 0); - - for (int i = 0; i < L.length (); i++) - cntr (X, Y, Z, L (i)); - - end_contour (); - - retval = contourc; - } - else - error ("__contourc__: invalid argument values"); - } - else - print_usage (); - - return retval; -} - -/* -## No test needed for internal helper function. -%!assert (1) -*/
--- a/src/DLD-FUNCTIONS/__dispatch__.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,136 +0,0 @@ -/* - -Copyright (C) 2001-2012 John W. Eaton and Paul Kienzle - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <list> -#include <map> -#include <string> - -#include "Cell.h" -#include "oct-map.h" -#include "defun-dld.h" -#include "ov.h" -#include "ov-fcn.h" -#include "ov-typeinfo.h" -#include "pager.h" -#include "parse.h" -#include "symtab.h" -#include "variables.h" - -DEFUN_DLD (__dispatch__, args, nargout, - "Undocumented internal function") -{ - octave_value retval; - - int nargin = args.length (); - - std::string f, r, t; - - if (nargin > 0 && nargin < 4) - { - if (nargin > 0) - { - f = args(0).string_value (); - - if (error_state) - { - error ("__dispatch__: first argument must be a function name"); - return retval; - } - } - - if (nargin > 1) - { - r = args(1).string_value (); - - if (error_state) - { - error ("__dispatch__: second argument must be a function name"); - return retval; - } - } - - if (nargin > 2) - { - t = args(2).string_value (); - - if (error_state) - { - error ("__dispatch__: third argument must be a type name"); - return retval; - } - } - - if (nargin == 1) - { - if (nargout > 0) - { - symbol_table::fcn_info::dispatch_map_type dm - = symbol_table::get_dispatch (f); - - size_t len = dm.size (); - - Cell type_field (len, 1); - Cell name_field (len, 1); - - symbol_table::fcn_info::dispatch_map_type::const_iterator p - = dm.begin (); - - for (size_t i = 0; i < len; i++) - { - type_field(i) = p->first; - name_field(i) = p->second; - - p++; - } - - octave_scalar_map m; - - m.assign ("type", type_field); - m.assign ("name", name_field); - - retval = m; - } - else - symbol_table::print_dispatch (octave_stdout, f); - } - else if (nargin == 2) - { - t = r; - symbol_table::clear_dispatch (f, t); - } - else - symbol_table::add_dispatch (f, t, r); - } - else - print_usage (); - - return retval; -} - -/* -## No test needed for internal helper function. -%!assert (1) -*/
--- a/src/DLD-FUNCTIONS/__lin_interpn__.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,362 +0,0 @@ -/* - -Copyright (C) 2007-2012 Alexander Barth - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-ieee.h" -#include "dNDArray.h" -#include "oct-locbuf.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" - -// equivalent to isvector.m - -template <class T> -bool -isvector (const T& array) -{ - const dim_vector dv = array.dims (); - return dv.length () == 2 && (dv(0) == 1 || dv(1) == 1); -} - -// lookup a value in a sorted table (lookup.m) -template <class T> -octave_idx_type -lookup (const T *x, octave_idx_type n, T y) -{ - octave_idx_type j; - - if (x[0] < x[n-1]) - { - // increasing x - - if (y > x[n-1] || y < x[0]) - return -1; - -#ifdef EXHAUSTIF - for (j = 0; j < n - 1; j++) - { - if (x[j] <= y && y <= x[j+1]) - return j; - } -#else - octave_idx_type j0 = 0; - octave_idx_type j1 = n - 1; - - while (true) - { - j = (j0+j1)/2; - - if (y <= x[j+1]) - { - if (x[j] <= y) - return j; - - j1 = j; - } - - if (x[j] <= y) - j0 = j; - } -#endif - } - else - { - // decreasing x - // previous code with x -> -x and y -> -y - - if (y > x[0] || y < x[n-1]) - return -1; - -#ifdef EXHAUSTIF - for (j = 0; j < n - 1; j++) - { - if (x[j+1] <= y && y <= x[j]) - return j; - } -#else - octave_idx_type j0 = 0; - octave_idx_type j1 = n - 1; - - while (true) - { - j = (j0+j1)/2; - - if (y >= x[j+1]) - { - if (x[j] >= y) - return j; - - j1 = j; - } - - if (x[j] >= y) - j0 = j; - } -#endif - } -} - -// n-dimensional linear interpolation - -template <class T> -void -lin_interpn (int n, const octave_idx_type *size, const octave_idx_type *scale, - octave_idx_type Ni, T extrapval, const T **x, - const T *v, const T **y, T *vi) -{ - bool out = false; - int bit; - - OCTAVE_LOCAL_BUFFER (T, coef, 2*n); - OCTAVE_LOCAL_BUFFER (octave_idx_type, index, n); - - // loop over all points - for (octave_idx_type m = 0; m < Ni; m++) - { - // loop over all dimensions - for (int i = 0; i < n; i++) - { - index[i] = lookup (x[i], size[i], y[i][m]); - out = index[i] == -1; - - if (out) - break; - else - { - octave_idx_type j = index[i]; - coef[2*i+1] = (y[i][m] - x[i][j])/(x[i][j+1] - x[i][j]); - coef[2*i] = 1 - coef[2*i+1]; - } - } - - - if (out) - vi[m] = extrapval; - else - { - vi[m] = 0; - - // loop over all corners of hypercube (1<<n = 2^n) - for (int i = 0; i < (1 << n); i++) - { - T c = 1; - octave_idx_type l = 0; - - // loop over all dimensions - for (int j = 0; j < n; j++) - { - // test if the jth bit in i is set - bit = i >> j & 1; - l += scale[j] * (index[j] + bit); - c *= coef[2*j+bit]; - } - - vi[m] += c * v[l]; - } - } - } -} - -template <class T, class M> -octave_value -lin_interpn (int n, M *X, const M V, M *Y) -{ - octave_value retval; - - M Vi = M (Y[0].dims ()); - - OCTAVE_LOCAL_BUFFER (const T *, y, n); - OCTAVE_LOCAL_BUFFER (octave_idx_type, size, n); - - for (int i = 0; i < n; i++) - { - y[i] = Y[i].data (); - size[i] = V.dims ()(i); - } - - OCTAVE_LOCAL_BUFFER (const T *, x, n); - OCTAVE_LOCAL_BUFFER (octave_idx_type, scale, n); - - const T *v = V.data (); - T *vi = Vi.fortran_vec (); - octave_idx_type Ni = Vi.numel (); - - T extrapval = octave_NA; - - // offset in memory of each dimension - - scale[0] = 1; - - for (int i = 1; i < n; i++) - scale[i] = scale[i-1] * size[i-1]; - - // tests if X[0] is a vector, if yes, assume that all elements of X are - // in the ndgrid format. - - if (! isvector (X[0])) - { - for (int i = 0; i < n; i++) - { - if (X[i].dims () != V.dims ()) - { - error ("interpn: incompatible size of argument number %d", i+1); - return retval; - } - else - { - M tmp = M (dim_vector (size[i], 1)); - - for (octave_idx_type j = 0; j < size[i]; j++) - tmp(j) = X[i](scale[i]*j); - - X[i] = tmp; - } - } - } - - for (int i = 0; i < n; i++) - { - if (! isvector (X[i]) && X[i].numel () != size[i]) - { - error ("interpn: incompatible size of argument number %d", i+1); - return retval; - } - else - x[i] = X[i].data (); - } - - lin_interpn (n, size, scale, Ni, extrapval, x, v, y, vi); - - retval = Vi; - - return retval; -} - -// Perform @var{n}-dimensional interpolation. Each element of then -// @var{n}-dimensional array @var{v} represents a value at a location -// given by the parameters @var{x1}, @var{x2},...,@var{xn}. The parameters -// @var{x1}, @var{x2}, @dots{}, @var{xn} are either @var{n}-dimensional -// arrays of the same size as the array @var{v} in the \"ndgrid\" format -// or vectors. The parameters @var{y1}, @var{y2}, @dots{}, @var{yn} are -// all @var{n}-dimensional arrays of the same size and represent the -// points at which the array @var{vi} is interpolated. -// -//This function only performs linear interpolation. - -DEFUN_DLD (__lin_interpn__, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{vi} =} __lin_interpn__ (@var{x1}, @var{x2}, @dots{}, @var{xn}, @var{v}, @var{y1}, @var{y2}, @dots{}, @var{yn})\n\ -Undocumented internal function.\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 2 || nargin % 2 == 0) - { - print_usage (); - return retval; - } - - // dimension of the problem - int n = (nargin-1)/2; - - if (args(n).is_single_type ()) - { - OCTAVE_LOCAL_BUFFER (FloatNDArray, X, n); - OCTAVE_LOCAL_BUFFER (FloatNDArray, Y, n); - - const FloatNDArray V = args(n).float_array_value (); - - if (error_state) - { - print_usage (); - return retval; - } - - for (int i = 0; i < n; i++) - { - X[i] = args(i).float_array_value (); - Y[i] = args(n+i+1).float_array_value (); - - if (error_state) - { - print_usage (); - return retval; - } - - if (Y[0].dims () != Y[i].dims ()) - { - error ("interpn: incompatible size of argument number %d", n+i+2); - return retval; - } - } - - retval = lin_interpn<float, FloatNDArray> (n, X, V, Y); - } - else - { - OCTAVE_LOCAL_BUFFER (NDArray, X, n); - OCTAVE_LOCAL_BUFFER (NDArray, Y, n); - - const NDArray V = args(n).array_value (); - - if (error_state) - { - print_usage (); - return retval; - } - - for (int i = 0; i < n; i++) - { - X[i] = args(i).array_value (); - Y[i] = args(n+i+1).array_value (); - - if (error_state) - { - print_usage (); - return retval; - } - - if (Y[0].dims () != Y[i].dims ()) - { - error ("interpn: incompatible size of argument number %d", n+i+2); - return retval; - } - } - - retval = lin_interpn<double, NDArray> (n, X, V, Y); - } - - return retval; -} - -/* -## No test needed for internal helper function. -%!assert (1) -*/
--- a/src/DLD-FUNCTIONS/__pchip_deriv__.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,168 +0,0 @@ -/* - -Copyright (C) 2002-2012 Kai Habel -Copyright (C) 2008-2009 Jaroslav Hajek - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" -#include "f77-fcn.h" - -extern "C" -{ - F77_RET_T - F77_FUNC (dpchim, DPCHIM) (const octave_idx_type& n, const double *x, - const double *f, double *d, - const octave_idx_type &incfd, - octave_idx_type *ierr); - - F77_RET_T - F77_FUNC (pchim, PCHIM) (const octave_idx_type& n, const float *x, - const float *f, float *d, - const octave_idx_type& incfd, - octave_idx_type *ierr); -} - -// Wrapper for SLATEC/PCHIP function DPCHIM to calculate the derivates -// for piecewise polynomials. - -DEFUN_DLD (__pchip_deriv__, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} __pchip_deriv__ (@var{x}, @var{y}, @var{dim})\n\ -Undocumented internal function.\n\ -@end deftypefn") -{ - octave_value retval; - const int nargin = args.length (); - - bool rows = (nargin == 3 && args (2).uint_value () == 2); - - if (nargin >= 2) - { - if (args(0).is_single_type () || args(1).is_single_type ()) - { - FloatColumnVector xvec (args(0).float_vector_value ()); - FloatMatrix ymat (args(1).float_matrix_value ()); - - octave_idx_type nx = xvec.length (); - - if (nx < 2) - { - error ("__pchip_deriv__: X must be at least of length 2"); - return retval; - } - - octave_idx_type nyr = ymat.rows (); - octave_idx_type nyc = ymat.columns (); - - if (nx != (rows ? nyc : nyr)) - { - error ("__pchip_deriv__: X and Y dimension mismatch"); - return retval; - } - - const float *yvec = ymat.data (); - FloatMatrix dmat (nyr, nyc); - float *dvec = dmat.fortran_vec (); - - octave_idx_type ierr; - const octave_idx_type incfd = rows ? nyr : 1; - const octave_idx_type inc = rows ? 1 : nyr; - - for (octave_idx_type i = (rows ? nyr : nyc); i > 0; i--) - { - F77_FUNC (pchim, PCHIM) (nx, xvec.data (), - yvec, dvec, incfd, &ierr); - - yvec += inc; - dvec += inc; - - if (ierr < 0) - { - error ("PCHIM: error: %i\n", ierr); - return retval; - } - } - - retval = dmat; - } - else - { - ColumnVector xvec (args(0).vector_value ()); - Matrix ymat (args(1).matrix_value ()); - - octave_idx_type nx = xvec.length (); - - if (nx < 2) - { - error ("__pchip_deriv__: X must be at least of length 2"); - return retval; - } - - octave_idx_type nyr = ymat.rows (); - octave_idx_type nyc = ymat.columns (); - - if (nx != (rows ? nyc : nyr)) - { - error ("__pchip_deriv__: X and Y dimension mismatch"); - return retval; - } - - const double *yvec = ymat.data (); - Matrix dmat (nyr, nyc); - double *dvec = dmat.fortran_vec (); - - octave_idx_type ierr; - const octave_idx_type incfd = rows ? nyr : 1; - const octave_idx_type inc = rows ? 1 : nyr; - - for (octave_idx_type i = (rows ? nyr : nyc); i > 0; i--) - { - F77_FUNC (dpchim, DPCHIM) (nx, xvec.data (), - yvec, dvec, incfd, &ierr); - - yvec += inc; - dvec += inc; - - if (ierr < 0) - { - error ("DPCHIM: error: %i\n", ierr); - return retval; - } - } - - retval = dmat; - } - } - - return retval; -} - -/* -## No test needed for internal helper function. -%!assert (1) -*/
--- a/src/DLD-FUNCTIONS/__qp__.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,535 +0,0 @@ -/* - -Copyright (C) 2000-2012 Gabriele Pannocchia - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <cfloat> - -#include "dbleCHOL.h" -#include "dbleSVD.h" -#include "mx-m-dm.h" -#include "EIG.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "pr-output.h" -#include "utils.h" - -static Matrix -null (const Matrix& A, octave_idx_type& rank) -{ - Matrix retval; - - rank = 0; - - if (! A.is_empty ()) - { - SVD A_svd (A); - - DiagMatrix S = A_svd.singular_values (); - - ColumnVector s = S.diag (); - - Matrix V = A_svd.right_singular_matrix (); - - octave_idx_type A_nr = A.rows (); - octave_idx_type A_nc = A.cols (); - - octave_idx_type tmp = A_nr > A_nc ? A_nr : A_nc; - - double tol = tmp * s(0) * DBL_EPSILON; - - octave_idx_type n = s.length (); - - for (octave_idx_type i = 0; i < n; i++) - { - if (s(i) > tol) - rank++; - } - - if (rank < A_nc) - retval = V.extract (0, rank, A_nc-1, A_nc-1); - else - retval.resize (A_nc, 0); - - for (octave_idx_type i = 0; i < retval.numel (); i++) - if (std::abs (retval(i)) < DBL_EPSILON) - retval(i) = 0; - } - - return retval; -} - -static int -qp (const Matrix& H, const ColumnVector& q, - const Matrix& Aeq, const ColumnVector& beq, - const Matrix& Ain, const ColumnVector& bin, - int maxit, - ColumnVector& x, ColumnVector& lambda, int& iter) -{ - int info = 0; - - iter = 0; - - double rtol = sqrt (DBL_EPSILON); - - // Problem dimension. - octave_idx_type n = x.length (); - - // Dimension of constraints. - octave_idx_type n_eq = beq.length (); - octave_idx_type n_in = bin.length (); - - // Filling the current active set. - - octave_idx_type n_act = n_eq; - - octave_idx_type n_tot = n_eq + n_in; - - // Equality constraints come first. We won't check the sign of the - // Lagrange multiplier for those. - - Matrix Aact = Aeq; - ColumnVector bact = beq; - ColumnVector Wact; - - if (n_in > 0) - { - ColumnVector res = Ain*x - bin; - - for (octave_idx_type i = 0; i < n_in; i++) - { - res(i) /= (1.0 + std::abs (bin(i))); - - if (res(i) < rtol) - { - n_act++; - Aact = Aact.stack (Ain.row (i)); - bact.resize (n_act, bin(i)); - Wact.resize (n_act-n_eq, i); - } - } - } - - // Computing the ??? - - EIG eigH (H); - - if (error_state) - { - error ("qp: failed to compute eigenvalues of H"); - return -1; - } - - ColumnVector eigenvalH = real (eigH.eigenvalues ()); - Matrix eigenvecH = real (eigH.eigenvectors ()); - double minReal = eigenvalH.min (); - octave_idx_type indminR = 0; - for (octave_idx_type i = 0; i < n; i++) - { - if (minReal == eigenvalH(i)) - { - indminR = i; - break; - } - } - - bool done = false; - - double alpha = 0.0; - - Matrix R; - Matrix Y (n, 0, 0.0); - - ColumnVector g (n, 0.0); - ColumnVector p (n, 0.0); - - ColumnVector lambda_tmp (n_in, 0.0); - - while (! done) - { - iter++; - - // Current Gradient - // g = q + H * x; - - g = q + H * x; - - if (n_act == 0) - { - // There are no active constraints. - - if (minReal > 0.0) - { - // Inverting the Hessian. Using the Cholesky - // factorization since the Hessian is positive - // definite. - - CHOL cholH (H); - - R = cholH.chol_matrix (); - - Matrix Hinv = chol2inv (R); - - // Computing the unconstrained step. - // p = -Hinv * g; - - p = -Hinv * g; - - info = 0; - } - else - { - // Finding the negative curvature of H. - - p = eigenvecH.column (indminR); - - // Following the negative curvature of H. - - if (p.transpose () * g > DBL_EPSILON) - p = -p; - - info = 1; - } - - // Multipliers are zero. - lambda_tmp.fill (0.0); - } - else - { - // There are active constraints. - - // Computing the null space. - - octave_idx_type rank; - - Matrix Z = null (Aact, rank); - - octave_idx_type dimZ = n - rank; - - // FIXME -- still remain to handle the case of - // non-full rank active set matrix. - - // Computing the Y matrix (orthogonal to Z) - Y = Aact.pseudo_inverse (); - - // Reduced Hessian - Matrix Zt = Z.transpose (); - Matrix rH = Zt * H * Z; - - octave_idx_type pR = 0; - - if (dimZ > 0) - { - // Computing the Cholesky factorization (pR = 0 means - // that the reduced Hessian was positive definite). - - CHOL cholrH (rH, pR); - Matrix tR = cholrH.chol_matrix (); - if (pR == 0) - R = tR; - } - - if (pR == 0) - { - info = 0; - - // Computing the step pz. - if (dimZ > 0) - { - // Using the Cholesky factorization to invert rH - - Matrix rHinv = chol2inv (R); - - ColumnVector pz = -rHinv * Zt * g; - - // Global step. - p = Z * pz; - } - else - { - // Global step. - p.fill (0.0); - } - } - else - { - info = 1; - - // Searching for the most negative curvature. - - EIG eigrH (rH); - - if (error_state) - { - error ("qp: failed to compute eigenvalues of rH"); - return -1; - } - - ColumnVector eigenvalrH = real (eigrH.eigenvalues ()); - Matrix eigenvecrH = real (eigrH.eigenvectors ()); - double mRrH = eigenvalrH.min (); - indminR = 0; - for (octave_idx_type i = 0; i < n; i++) - { - if (mRrH == eigenvalH(i)) - { - indminR = i; - break; - } - } - - ColumnVector eVrH = eigenvecrH.column (indminR); - - // Computing the step pz. - p = Z * eVrH; - - if (p.transpose () * g > DBL_EPSILON) - p = -p; - } - } - - // Checking the step-size. - ColumnVector abs_p (n); - for (octave_idx_type i = 0; i < n; i++) - abs_p(i) = std::abs (p(i)); - double max_p = abs_p.max (); - - if (max_p < rtol) - { - // The step is null. Checking constraints. - if (n_act - n_eq == 0) - // Solution is found because no inequality - // constraints are active. - done = true; - else - { - // Computing the multipliers only for the inequality - // constraints that are active. We do NOT compute - // multipliers for the equality constraints. - Matrix Yt = Y.transpose (); - Yt = Yt.extract_n (n_eq, 0, n_act-n_eq, n); - lambda_tmp = Yt * (g + H * p); - - // Checking the multipliers. We remove the most - // negative from the set (if any). - double min_lambda = lambda_tmp.min (); - if (min_lambda >= 0) - { - // Solution is found. - done = true; - } - else - { - octave_idx_type which_eig = 0; - for (octave_idx_type i = 0; i < n_act; i++) - { - if (lambda_tmp(i) == min_lambda) - { - which_eig = i; - break; - } - } - - // At least one multiplier is negative, we - // remove it from the set. - - n_act--; - for (octave_idx_type i = which_eig; i < n_act - n_eq; i++) - { - Wact(i) = Wact(i+1); - for (octave_idx_type j = 0; j < n; j++) - Aact(n_eq+i,j) = Aact(n_eq+i+1,j); - bact(n_eq+i) = bact(n_eq+i+1); - } - - // Resizing the active set. - Wact.resize (n_act-n_eq); - bact.resize (n_act); - Aact.resize (n_act, n); - } - } - } - else - { - // The step is not null. - if (n_act - n_eq == n_in) - { - // All inequality constraints were active. We can - // add the whole step. - x += p; - } - else - { - // Some constraints were not active. Checking if - // there is a blocking constraint. - alpha = 1.0; - octave_idx_type is_block = -1; - - for (octave_idx_type i = 0; i < n_in; i++) - { - bool found = false; - - for (octave_idx_type j = 0; j < n_act-n_eq; j++) - { - if (Wact(j) == i) - { - found = true; - break; - } - } - - if (! found) - { - // The i-th constraint was not in the set. Is it a - // blocking constraint? - - RowVector tmp_row = Ain.row (i); - double tmp = tmp_row * p; - double res = tmp_row * x; - - if (tmp < 0.0) - { - double alpha_tmp = (bin(i) - res) / tmp; - - if (alpha_tmp < alpha) - { - alpha = alpha_tmp; - is_block = i; - } - } - } - } - - // In is_block there is the index of the blocking - // constraint (if any). - if (is_block >= 0) - { - // There is a blocking constraint (index in - // is_block) which is added to the active set. - n_act++; - Aact = Aact.stack (Ain.row (is_block)); - bact.resize (n_act, bin(is_block)); - Wact.resize (n_act-n_eq, is_block); - - // Adding the reduced step - x += alpha * p; - } - else - { - // There are no blocking constraints. Adding the - // whole step. - x += alpha * p; - } - } - } - - if (iter == maxit) - { - done = true; - // warning ("qp_main: maximum number of iteration reached"); - info = 3; - } - } - - lambda_tmp = Y.transpose () * (g + H * p); - - // Reordering the Lagrange multipliers. - - lambda.resize (n_tot); - lambda.fill (0.0); - for (octave_idx_type i = 0; i < n_eq; i++) - lambda(i) = lambda_tmp(i); - - for (octave_idx_type i = n_eq; i < n_tot; i++) - { - for (octave_idx_type j = 0; j < n_act-n_eq; j++) - { - if (Wact(j) == i - n_eq) - { - lambda(i) = lambda_tmp(n_eq+j); - break; - } - } - } - - return info; -} - -DEFUN_DLD (__qp__, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{x}, @var{lambda}, @var{info}, @var{iter}] =} __qp__ (@var{x0}, @var{H}, @var{q}, @var{Aeq}, @var{beq}, @var{Ain}, @var{bin}, @var{maxit})\n\ -Undocumented internal function.\n\ -@end deftypefn") -{ - octave_value_list retval; - - if (args.length () == 8) - { - const ColumnVector x0 (args(0) . vector_value ()); - const Matrix H (args(1) . matrix_value ()); - const ColumnVector q (args(2) . vector_value ()); - const Matrix Aeq (args(3) . matrix_value ()); - const ColumnVector beq (args(4) . vector_value ()); - const Matrix Ain (args(5) . matrix_value ()); - const ColumnVector bin (args(6) . vector_value ()); - const int maxit (args(7) . int_value ()); - - if (! error_state) - { - int iter = 0; - - // Copying the initial guess in the working variable - ColumnVector x = x0; - - // Reordering the Lagrange multipliers - ColumnVector lambda; - - int info = qp (H, q, Aeq, beq, Ain, bin, maxit, x, lambda, iter); - - if (! error_state) - { - retval(3) = iter; - retval(2) = info; - retval(1) = lambda; - retval(0) = x; - } - else - error ("qp: internal error"); - } - else - error ("__qp__: invalid arguments"); - } - else - print_usage (); - - return retval; -} - -/* -## No test needed for internal helper function. -%!assert (1) -*/
--- a/src/DLD-FUNCTIONS/balance.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,389 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton -Copyright (C) 2008-2009 Jaroslav Hajek - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Author: A. S. Hodel <scotte@eng.auburn.edu> - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include "CmplxAEPBAL.h" -#include "fCmplxAEPBAL.h" -#include "dbleAEPBAL.h" -#include "floatAEPBAL.h" -#include "CmplxGEPBAL.h" -#include "fCmplxGEPBAL.h" -#include "dbleGEPBAL.h" -#include "floatGEPBAL.h" -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "f77-fcn.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (balance, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{AA} =} balance (@var{A})\n\ -@deftypefnx {Loadable Function} {@var{AA} =} balance (@var{A}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{DD}, @var{AA}] =} balance (@var{A}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{D}, @var{P}, @var{AA}] =} balance (@var{A}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{CC}, @var{DD}, @var{AA}, @var{BB}] =} balance (@var{A}, @var{B}, @var{opt})\n\ -\n\ -Compute @code{@var{AA} = @var{DD} \\ @var{A} * @var{DD}} in which @var{AA}\n\ -is a matrix whose row and column norms are roughly equal in magnitude, and\n\ -@code{@var{DD} = @var{P} * @var{D}}, in which @var{P} is a permutation\n\ -matrix and @var{D} is a diagonal matrix of powers of two. This allows the\n\ -equilibration to be computed without round-off. Results of eigenvalue\n\ -calculation are typically improved by balancing first.\n\ -\n\ -If two output values are requested, @code{balance} returns\n\ -the diagonal @var{D} and the permutation @var{P} separately as vectors.\n\ -In this case, @code{@var{DD} = eye(n)(:,@var{P}) * diag (@var{D})}, where\n\ -@math{n} is the matrix size.\n\ -\n\ -If four output values are requested, compute @code{@var{AA} =\n\ -@var{CC}*@var{A}*@var{DD}} and @code{@var{BB} = @var{CC}*@var{B}*@var{DD}},\n\ -in which @var{AA} and @var{BB} have non-zero elements of approximately the\n\ -same magnitude and @var{CC} and @var{DD} are permuted diagonal matrices as\n\ -in @var{DD} for the algebraic eigenvalue problem.\n\ -\n\ -The eigenvalue balancing option @var{opt} may be one of:\n\ -\n\ -@table @asis\n\ -@item \"noperm\", \"S\"\n\ -Scale only; do not permute.\n\ -\n\ -@item \"noscal\", \"P\"\n\ -Permute only; do not scale.\n\ -@end table\n\ -\n\ -Algebraic eigenvalue balancing uses standard @sc{lapack} routines.\n\ -\n\ -Generalized eigenvalue problem balancing uses Ward's algorithm\n\ -(SIAM Journal on Scientific and Statistical Computing, 1981).\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 3 || nargout < 0 || nargout > 4) - { - print_usage (); - return retval; - } - - // determine if it's AEP or GEP - bool AEPcase = nargin == 1 || args(1).is_string (); - - // problem dimension - octave_idx_type nn = args(0).rows (); - - if (nn != args(0).columns ()) - { - gripe_square_matrix_required ("balance"); - return retval; - } - - bool isfloat = args(0).is_single_type () || - (! AEPcase && args(1).is_single_type ()); - - bool complex_case = (args(0).is_complex_type () || - (! AEPcase && args(1).is_complex_type ())); - - // Extract argument 1 parameter for both AEP and GEP. - Matrix aa; - ComplexMatrix caa; - FloatMatrix faa; - FloatComplexMatrix fcaa; - - if (isfloat) - { - if (complex_case) - fcaa = args(0).float_complex_matrix_value (); - else - faa = args(0).float_matrix_value (); - } - else - { - if (complex_case) - caa = args(0).complex_matrix_value (); - else - aa = args(0).matrix_value (); - } - - if (error_state) - return retval; - - // Treat AEP/GEP cases. - if (AEPcase) - { - // Algebraic eigenvalue problem. - bool noperm = false, noscal = false; - if (nargin > 1) - { - std::string a1s = args(1).string_value (); - noperm = a1s == "noperm" || a1s == "S"; - noscal = a1s == "noscal" || a1s == "P"; - } - - // balance the AEP - if (isfloat) - { - if (complex_case) - { - FloatComplexAEPBALANCE result (fcaa, noperm, noscal); - - if (nargout == 0 || nargout == 1) - retval(0) = result.balanced_matrix (); - else if (nargout == 2) - { - retval(1) = result.balanced_matrix (); - retval(0) = result.balancing_matrix (); - } - else - { - retval(2) = result.balanced_matrix (); - retval(1) = result.permuting_vector (); - retval(0) = result.scaling_vector (); - } - - } - else - { - FloatAEPBALANCE result (faa, noperm, noscal); - - if (nargout == 0 || nargout == 1) - retval(0) = result.balanced_matrix (); - else if (nargout == 2) - { - retval(1) = result.balanced_matrix (); - retval(0) = result.balancing_matrix (); - } - else - { - retval(2) = result.balanced_matrix (); - retval(1) = result.permuting_vector (); - retval(0) = result.scaling_vector (); - } - } - } - else - { - if (complex_case) - { - ComplexAEPBALANCE result (caa, noperm, noscal); - - if (nargout == 0 || nargout == 1) - retval(0) = result.balanced_matrix (); - else if (nargout == 2) - { - retval(1) = result.balanced_matrix (); - retval(0) = result.balancing_matrix (); - } - else - { - retval(2) = result.balanced_matrix (); - retval(1) = result.permuting_vector (); - retval(0) = result.scaling_vector (); - } - } - else - { - AEPBALANCE result (aa, noperm, noscal); - - if (nargout == 0 || nargout == 1) - retval(0) = result.balanced_matrix (); - else if (nargout == 2) - { - retval(1) = result.balanced_matrix (); - retval(0) = result.balancing_matrix (); - } - else - { - retval(2) = result.balanced_matrix (); - retval(1) = result.permuting_vector (); - retval(0) = result.scaling_vector (); - } - } - } - } - else - { - std::string bal_job; - if (nargout == 1) - warning ("balance: used GEP, should have two output arguments"); - - // Generalized eigenvalue problem. - if (nargin == 2) - bal_job = "B"; - else if (args(2).is_string ()) - bal_job = args(2).string_value (); - else - { - error ("balance: OPT argument must be a string"); - return retval; - } - - if ((nn != args(1).columns ()) || (nn != args(1).rows ())) - { - gripe_nonconformant (); - return retval; - } - - Matrix bb; - ComplexMatrix cbb; - FloatMatrix fbb; - FloatComplexMatrix fcbb; - - if (isfloat) - { - if (complex_case) - fcbb = args(1).float_complex_matrix_value (); - else - fbb = args(1).float_matrix_value (); - } - else - { - if (complex_case) - cbb = args(1).complex_matrix_value (); - else - bb = args(1).matrix_value (); - } - - // balance the GEP - if (isfloat) - { - if (complex_case) - { - FloatComplexGEPBALANCE result (fcaa, fcbb, bal_job); - - switch (nargout) - { - case 4: - retval(3) = result.balanced_matrix2 (); - // fall through - case 3: - retval(2) = result.balanced_matrix (); - retval(1) = result.balancing_matrix2 (); - retval(0) = result.balancing_matrix (); - break; - case 2: - retval(1) = result.balancing_matrix2 (); - // fall through - case 1: - retval(0) = result.balancing_matrix (); - break; - default: - error ("balance: invalid number of output arguments"); - break; - } - } - else - { - FloatGEPBALANCE result (faa, fbb, bal_job); - - switch (nargout) - { - case 4: - retval(3) = result.balanced_matrix2 (); - // fall through - case 3: - retval(2) = result.balanced_matrix (); - retval(1) = result.balancing_matrix2 (); - retval(0) = result.balancing_matrix (); - break; - case 2: - retval(1) = result.balancing_matrix2 (); - // fall through - case 1: - retval(0) = result.balancing_matrix (); - break; - default: - error ("balance: invalid number of output arguments"); - break; - } - } - } - else - { - if (complex_case) - { - ComplexGEPBALANCE result (caa, cbb, bal_job); - - switch (nargout) - { - case 4: - retval(3) = result.balanced_matrix2 (); - // fall through - case 3: - retval(2) = result.balanced_matrix (); - retval(1) = result.balancing_matrix2 (); - retval(0) = result.balancing_matrix (); - break; - case 2: - retval(1) = result.balancing_matrix2 (); - // fall through - case 1: - retval(0) = result.balancing_matrix (); - break; - default: - error ("balance: invalid number of output arguments"); - break; - } - } - else - { - GEPBALANCE result (aa, bb, bal_job); - - switch (nargout) - { - case 4: - retval(3) = result.balanced_matrix2 (); - // fall through - case 3: - retval(2) = result.balanced_matrix (); - retval(1) = result.balancing_matrix2 (); - retval(0) = result.balancing_matrix (); - break; - case 2: - retval(1) = result.balancing_matrix2 (); - // fall through - case 1: - retval(0) = result.balancing_matrix (); - break; - default: - error ("balance: invalid number of output arguments"); - break; - } - } - } - } - - return retval; -}
--- a/src/DLD-FUNCTIONS/besselj.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1246 +0,0 @@ -/* - -Copyright (C) 1997-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-specfun.h" -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -enum bessel_type -{ - BESSEL_J, - BESSEL_Y, - BESSEL_I, - BESSEL_K, - BESSEL_H1, - BESSEL_H2 -}; - -#define DO_BESSEL(type, alpha, x, scaled, ierr, result) \ - do \ - { \ - switch (type) \ - { \ - case BESSEL_J: \ - result = besselj (alpha, x, scaled, ierr); \ - break; \ - \ - case BESSEL_Y: \ - result = bessely (alpha, x, scaled, ierr); \ - break; \ - \ - case BESSEL_I: \ - result = besseli (alpha, x, scaled, ierr); \ - break; \ - \ - case BESSEL_K: \ - result = besselk (alpha, x, scaled, ierr); \ - break; \ - \ - case BESSEL_H1: \ - result = besselh1 (alpha, x, scaled, ierr); \ - break; \ - \ - case BESSEL_H2: \ - result = besselh2 (alpha, x, scaled, ierr); \ - break; \ - \ - default: \ - break; \ - } \ - } \ - while (0) - -static void -gripe_bessel_arg (const char *fn, const char *arg) -{ - error ("%s: expecting scalar or matrix as %s argument", fn, arg); -} - -octave_value_list -do_bessel (enum bessel_type type, const char *fn, - const octave_value_list& args, int nargout) -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin == 2 || nargin == 3) - { - bool scaled = (nargin == 3); - - octave_value alpha_arg = args(0); - octave_value x_arg = args(1); - - if (alpha_arg.is_single_type () || x_arg.is_single_type ()) - { - if (alpha_arg.is_scalar_type ()) - { - float alpha = args(0).float_value (); - - if (! error_state) - { - if (x_arg.is_scalar_type ()) - { - FloatComplex x = x_arg.float_complex_value (); - - if (! error_state) - { - octave_idx_type ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = static_cast<float> (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - else - { - FloatComplexNDArray x = x_arg.float_complex_array_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - } - else - gripe_bessel_arg (fn, "first"); - } - else - { - dim_vector dv0 = args(0).dims (); - dim_vector dv1 = args(1).dims (); - - bool args0_is_row_vector = (dv0 (1) == dv0.numel ()); - bool args1_is_col_vector = (dv1 (0) == dv1.numel ()); - - if (args0_is_row_vector && args1_is_col_vector) - { - FloatRowVector ralpha = args(0).float_row_vector_value (); - - if (! error_state) - { - FloatComplexColumnVector cx = - x_arg.float_complex_column_vector_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, ralpha, cx, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - else - gripe_bessel_arg (fn, "first"); - } - else - { - FloatNDArray alpha = args(0).float_array_value (); - - if (! error_state) - { - if (x_arg.is_scalar_type ()) - { - FloatComplex x = x_arg.float_complex_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - else - { - FloatComplexNDArray x = x_arg.float_complex_array_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - } - else - gripe_bessel_arg (fn, "first"); - } - } - } - else - { - if (alpha_arg.is_scalar_type ()) - { - double alpha = args(0).double_value (); - - if (! error_state) - { - if (x_arg.is_scalar_type ()) - { - Complex x = x_arg.complex_value (); - - if (! error_state) - { - octave_idx_type ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = static_cast<double> (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - else - { - ComplexNDArray x = x_arg.complex_array_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - } - else - gripe_bessel_arg (fn, "first"); - } - else - { - dim_vector dv0 = args(0).dims (); - dim_vector dv1 = args(1).dims (); - - bool args0_is_row_vector = (dv0 (1) == dv0.numel ()); - bool args1_is_col_vector = (dv1 (0) == dv1.numel ()); - - if (args0_is_row_vector && args1_is_col_vector) - { - RowVector ralpha = args(0).row_vector_value (); - - if (! error_state) - { - ComplexColumnVector cx = - x_arg.complex_column_vector_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, ralpha, cx, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - else - gripe_bessel_arg (fn, "first"); - } - else - { - NDArray alpha = args(0).array_value (); - - if (! error_state) - { - if (x_arg.is_scalar_type ()) - { - Complex x = x_arg.complex_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - else - { - ComplexNDArray x = x_arg.complex_array_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - DO_BESSEL (type, alpha, x, scaled, ierr, result); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - gripe_bessel_arg (fn, "second"); - } - } - else - gripe_bessel_arg (fn, "first"); - } - } - } - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (besselj, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{j}, @var{ierr}] =} besselj (@var{alpha}, @var{x}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{y}, @var{ierr}] =} bessely (@var{alpha}, @var{x}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{i}, @var{ierr}] =} besseli (@var{alpha}, @var{x}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{k}, @var{ierr}] =} besselk (@var{alpha}, @var{x}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{h}, @var{ierr}] =} besselh (@var{alpha}, @var{k}, @var{x}, @var{opt})\n\ -Compute Bessel or Hankel functions of various kinds:\n\ -\n\ -@table @code\n\ -@item besselj\n\ -Bessel functions of the first kind. If the argument @var{opt} is supplied,\n\ -the result is multiplied by @code{exp (-abs (imag (@var{x})))}.\n\ -\n\ -@item bessely\n\ -Bessel functions of the second kind. If the argument @var{opt} is supplied,\n\ -the result is multiplied by @code{exp (-abs (imag (@var{x})))}.\n\ -\n\ -@item besseli\n\ -\n\ -Modified Bessel functions of the first kind. If the argument @var{opt} is\n\ -supplied, the result is multiplied by @code{exp (-abs (real (@var{x})))}.\n\ -\n\ -@item besselk\n\ -\n\ -Modified Bessel functions of the second kind. If the argument @var{opt} is\n\ -supplied, the result is multiplied by @code{exp (@var{x})}.\n\ -\n\ -@item besselh\n\ -Compute Hankel functions of the first (@var{k} = 1) or second (@var{k}\n\ -= 2) kind. If the argument @var{opt} is supplied, the result is multiplied\n\ -by @code{exp (-I*@var{x})} for @var{k} = 1 or @code{exp (I*@var{x})} for\n\ -@var{k} = 2.\n\ -@end table\n\ -\n\ -If @var{alpha} is a scalar, the result is the same size as @var{x}.\n\ -If @var{x} is a scalar, the result is the same size as @var{alpha}.\n\ -If @var{alpha} is a row vector and @var{x} is a column vector, the\n\ -result is a matrix with @code{length (@var{x})} rows and\n\ -@code{length (@var{alpha})} columns. Otherwise, @var{alpha} and\n\ -@var{x} must conform and the result will be the same size.\n\ -\n\ -The value of @var{alpha} must be real. The value of @var{x} may be\n\ -complex.\n\ -\n\ -If requested, @var{ierr} contains the following status information\n\ -and is the same size as the result.\n\ -\n\ -@enumerate 0\n\ -@item\n\ -Normal return.\n\ -\n\ -@item\n\ -Input error, return @code{NaN}.\n\ -\n\ -@item\n\ -Overflow, return @code{Inf}.\n\ -\n\ -@item\n\ -Loss of significance by argument reduction results in less than\n\ -half of machine accuracy.\n\ -\n\ -@item\n\ -Complete loss of significance by argument reduction, return @code{NaN}.\n\ -\n\ -@item\n\ -Error---no computation, algorithm termination condition not met,\n\ -return @code{NaN}.\n\ -@end enumerate\n\ -@end deftypefn") -{ - return do_bessel (BESSEL_J, "besselj", args, nargout); -} - -DEFUN_DLD (bessely, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{y}, @var{ierr}] =} bessely (@var{alpha}, @var{x}, @var{opt})\n\ -See besselj.\n\ -@end deftypefn") -{ - return do_bessel (BESSEL_Y, "bessely", args, nargout); -} - -DEFUN_DLD (besseli, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{i}, @var{ierr}] =} besseli (@var{alpha}, @var{x}, @var{opt})\n\ -See besselj.\n\ -@end deftypefn") -{ - return do_bessel (BESSEL_I, "besseli", args, nargout); -} - -DEFUN_DLD (besselk, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{k}, @var{ierr}] =} besselk (@var{alpha}, @var{x}, @var{opt})\n\ -See besselj.\n\ -@end deftypefn") -{ - return do_bessel (BESSEL_K, "besselk", args, nargout); -} - -DEFUN_DLD (besselh, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{h}, @var{ierr}] =} besselh (@var{alpha}, @var{k}, @var{x}, @var{opt})\n\ -See besselj.\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin == 2) - { - retval = do_bessel (BESSEL_H1, "besselh", args, nargout); - } - else if (nargin == 3 || nargin == 4) - { - octave_idx_type kind = args(1).int_value (); - - if (! error_state) - { - octave_value_list tmp_args; - - if (nargin == 4) - tmp_args(2) = args(3); - - tmp_args(1) = args(2); - tmp_args(0) = args(0); - - if (kind == 1) - retval = do_bessel (BESSEL_H1, "besselh", tmp_args, nargout); - else if (kind == 2) - retval = do_bessel (BESSEL_H2, "besselh", tmp_args, nargout); - else - error ("besselh: expecting K = 1 or 2"); - } - else - error ("besselh: invalid value of K"); - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (airy, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{a}, @var{ierr}] =} airy (@var{k}, @var{z}, @var{opt})\n\ -Compute Airy functions of the first and second kind, and their\n\ -derivatives.\n\ -\n\ -@example\n\ -@group\n\ - K Function Scale factor (if 'opt' is supplied)\n\ ---- -------- ---------------------------------------\n\ - 0 Ai (Z) exp ((2/3) * Z * sqrt (Z))\n\ - 1 dAi(Z)/dZ exp ((2/3) * Z * sqrt (Z))\n\ - 2 Bi (Z) exp (-abs (real ((2/3) * Z * sqrt (Z))))\n\ - 3 dBi(Z)/dZ exp (-abs (real ((2/3) * Z * sqrt (Z))))\n\ -@end group\n\ -@end example\n\ -\n\ -The function call @code{airy (@var{z})} is equivalent to\n\ -@code{airy (0, @var{z})}.\n\ -\n\ -The result is the same size as @var{z}.\n\ -\n\ -If requested, @var{ierr} contains the following status information and\n\ -is the same size as the result.\n\ -\n\ -@enumerate 0\n\ -@item\n\ -Normal return.\n\ -\n\ -@item\n\ -Input error, return @code{NaN}.\n\ -\n\ -@item\n\ -Overflow, return @code{Inf}.\n\ -\n\ -@item\n\ -Loss of significance by argument reduction results in less than half\n\ - of machine accuracy.\n\ -\n\ -@item\n\ -Complete loss of significance by argument reduction, return @code{NaN}.\n\ -\n\ -@item\n\ -Error---no computation, algorithm termination condition not met,\n\ -return @code{NaN}.\n\ -@end enumerate\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin > 0 && nargin < 4) - { - bool scale = (nargin == 3); - - int kind = 0; - - if (nargin > 1) - { - kind = args(0).int_value (); - - if (! error_state) - { - if (kind < 0 || kind > 3) - error ("airy: expecting K = 0, 1, 2, or 3"); - } - else - error ("airy: K must be an integer value"); - } - - if (! error_state) - { - int idx = nargin == 1 ? 0 : 1; - - if (args (idx).is_single_type ()) - { - FloatComplexNDArray z = args(idx).float_complex_array_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - if (kind > 1) - result = biry (z, kind == 3, scale, ierr); - else - result = airy (z, kind == 1, scale, ierr); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - error ("airy: Z must be a complex matrix"); - } - else - { - ComplexNDArray z = args(idx).complex_array_value (); - - if (! error_state) - { - Array<octave_idx_type> ierr; - octave_value result; - - if (kind > 1) - result = biry (z, kind == 3, scale, ierr); - else - result = airy (z, kind == 1, scale, ierr); - - if (nargout > 1) - retval(1) = NDArray (ierr); - - retval(0) = result; - } - else - error ("airy: Z must be a complex matrix"); - } - } - } - else - print_usage (); - - return retval; -} - -/* -%! # Test values computed with GP/PARI version 2.3.3 -%! -%!shared alpha, x, jx, yx, ix, kx, nix -%! -%! # Bessel functions, even order, positive and negative x -%! alpha = 2; x = 1.25; -%! jx = 0.1710911312405234823613091417; -%! yx = -1.193199310178553861283790424; -%! ix = 0.2220184483766341752692212604; -%! kx = 0.9410016167388185767085460540; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%!assert (besselj (-alpha,x), jx, 100*eps) -%!assert (bessely (-alpha,x), yx, 100*eps) -%!assert (besseli (-alpha,x), ix, 100*eps) -%!assert (besselk (-alpha,x), kx, 100*eps) -%!assert (besselh (-alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (-alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (-alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (-alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (-alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%! x *= -1; -%! yx = -1.193199310178553861283790424 + 0.3421822624810469647226182835*I; -%! kx = 0.9410016167388185767085460540 - 0.6974915263814386815610060884*I; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%! # Bessel functions, odd order, positive and negative x -%! alpha = 3; x = 2.5; -%! jx = 0.2166003910391135247666890035; -%! yx = -0.7560554967536709968379029772; -%! ix = 0.4743704087780355895548240179; -%! kx = 0.2682271463934492027663765197; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%!assert (besselj (-alpha,x), -jx, 100*eps) -%!assert (bessely (-alpha,x), -yx, 100*eps) -%!assert (besseli (-alpha,x), ix, 100*eps) -%!assert (besselk (-alpha,x), kx, 100*eps) -%!assert (besselh (-alpha,1,x), -(jx + I*yx), 100*eps) -%!assert (besselh (-alpha,2,x), -(jx - I*yx), 100*eps) -%! -%!assert (besselj (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (-alpha,x,1), -yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (-alpha,1,x,1), -(jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (-alpha,2,x,1), -(jx - I*yx)*exp(I*x), 100*eps) -%! -%! x *= -1; -%! jx = -jx; -%! yx = 0.7560554967536709968379029772 - 0.4332007820782270495333780070*I; -%! ix = -ix; -%! kx = -0.2682271463934492027663765197 - 1.490278591297463775542004240*I; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%! # Bessel functions, fractional order, positive and negative x -%! -%! alpha = 3.5; x = 2.75; -%! jx = 0.1691636439842384154644784389; -%! yx = -0.8301381935499356070267953387; -%! ix = 0.3930540878794826310979363668; -%! kx = 0.2844099013460621170288192503; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%! nix = 0.2119931212254662995364461998; -%! -%!assert (besselj (-alpha,x), yx, 100*eps) -%!assert (bessely (-alpha,x), -jx, 100*eps) -%!assert (besseli (-alpha,x), nix, 100*eps) -%!assert (besselk (-alpha,x), kx, 100*eps) -%!assert (besselh (-alpha,1,x), -I*(jx + I*yx), 100*eps) -%!assert (besselh (-alpha,2,x), I*(jx - I*yx), 100*eps) -%! -%!assert (besselj (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (-alpha,x,1), nix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (-alpha,1,x,1), -I*(jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (-alpha,2,x,1), I*(jx - I*yx)*exp(I*x), 100*eps) -%! -%! x *= -1; -%! jx *= -I; -%! yx = -0.8301381935499356070267953387*I; -%! ix *= -I; -%! kx = -0.9504059335995575096509874508*I; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%! # Bessel functions, even order, complex x -%! -%! alpha = 2; x = 1.25 + 3.625 * I; -%! jx = -1.299533366810794494030065917 + 4.370833116012278943267479589*I; -%! yx = -4.370357232383223896393056727 - 1.283083391453582032688834041*I; -%! ix = -0.6717801680341515541002273932 - 0.2314623443930774099910228553*I; -%! kx = -0.01108009888623253515463783379 + 0.2245218229358191588208084197*I; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%!assert (besselj (-alpha,x), jx, 100*eps) -%!assert (bessely (-alpha,x), yx, 100*eps) -%!assert (besseli (-alpha,x), ix, 100*eps) -%!assert (besselk (-alpha,x), kx, 100*eps) -%!assert (besselh (-alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (-alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (-alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (-alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (-alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%! # Bessel functions, odd order, complex x -%! -%! alpha = 3; x = 2.5 + 1.875 * I; -%! jx = 0.1330721523048277493333458596 + 0.5386295217249660078754395597*I; -%! yx = -0.6485072392105829901122401551 + 0.2608129289785456797046996987*I; -%! ix = -0.6182064685486998097516365709 + 0.4677561094683470065767989920*I; -%! kx = -0.1568585587733540007867882337 - 0.05185853709490846050505141321*I; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%!assert (besselj (-alpha,x), -jx, 100*eps) -%!assert (bessely (-alpha,x), -yx, 100*eps) -%!assert (besseli (-alpha,x), ix, 100*eps) -%!assert (besselk (-alpha,x), kx, 100*eps) -%!assert (besselh (-alpha,1,x), -(jx + I*yx), 100*eps) -%!assert (besselh (-alpha,2,x), -(jx - I*yx), 100*eps) -%! -%!assert (besselj (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (-alpha,x,1), -yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (-alpha,1,x,1), -(jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (-alpha,2,x,1), -(jx - I*yx)*exp(I*x), 100*eps) -%! -%! # Bessel functions, fractional order, complex x -%! -%! alpha = 3.5; x = 1.75 + 4.125 * I; -%! jx = -3.018566131370455929707009100 - 0.7585648436793900607704057611*I; -%! yx = 0.7772278839106298215614791107 - 3.018518722313849782683792010*I; -%! ix = 0.2100873577220057189038160913 - 0.6551765604618246531254970926*I; -%! kx = 0.1757147290513239935341488069 + 0.08772348296883849205562558311*I; -%! -%!assert (besselj (alpha,x), jx, 100*eps) -%!assert (bessely (alpha,x), yx, 100*eps) -%!assert (besseli (alpha,x), ix, 100*eps) -%!assert (besselk (alpha,x), kx, 100*eps) -%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) -%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) -%! -%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) -%! -%! nix = 0.09822388691172060573913739253 - 0.7110230642207380127317227407*I; -%! -%!assert (besselj (-alpha,x), yx, 100*eps) -%!assert (bessely (-alpha,x), -jx, 100*eps) -%!assert (besseli (-alpha,x), nix, 100*eps) -%!assert (besselk (-alpha,x), kx, 100*eps) -%!assert (besselh (-alpha,1,x), -I*(jx + I*yx), 100*eps) -%!assert (besselh (-alpha,2,x), I*(jx - I*yx), 100*eps) -%! -%!assert (besselj (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) -%!assert (bessely (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) -%!assert (besseli (-alpha,x,1), nix*exp(-abs(real(x))), 100*eps) -%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) -%!assert (besselh (-alpha,1,x,1), -I*(jx + I*yx)*exp(-I*x), 100*eps) -%!assert (besselh (-alpha,2,x,1), I*(jx - I*yx)*exp(I*x), 100*eps) - - -Tests contributed by Robert T. Short. -Tests are based on the properties and tables in A&S: - Abramowitz and Stegun, "Handbook of Mathematical Functions", - 1972. - -For regular Bessel functions, there are 3 tests. These compare octave -results against Tables 9.1, 9.2, and 9.4 in A&S. Tables 9.1 and 9.2 -are good to only a few decimal places, so any failures should be -considered a broken implementation. Table 9.4 is an extended table -for larger orders and arguments. There are some differences between -Octave and Table 9.4, mostly in the last decimal place but in a very -few instances the errors are in the last two places. The comparison -tolerance has been changed to reflect this. - -Similarly for modifed Bessel functions, there are 3 tests. These -compare octave results against Tables 9.8, 9.9, and 9.11 in A&S. -Tables 9.8 and 9.9 are good to only a few decimal places, so any -failures should be considered a broken implementation. Table 9.11 is -an extended table for larger orders and arguments. There are some -differences between octave and Table 9.11, mostly in the last decimal -place but in a very few instances the errors are in the last two -places. The comparison tolerance has been changed to reflect this. - -For spherical Bessel functions, there are also three tests, comparing -octave results to Tables 10.1, 10.2, and 10.4 in A&S. Very similar -comments may be made here as in the previous lines. At this time, -modified spherical Bessel function tests are not included. - -% Table 9.1 - J and Y for integer orders 0, 1, 2. -% Compare against excerpts of Table 9.1, Abramowitz and Stegun. -%!test -%! n = 0:2; -%! z = (0:2.5:17.5)'; -%! -%! Jt = [[ 1.000000000000000, 0.0000000000, 0.0000000000]; -%! [-0.048383776468198, 0.4970941025, 0.4460590584]; -%! [-0.177596771314338, -0.3275791376, 0.0465651163]; -%! [ 0.266339657880378, 0.1352484276, -0.2302734105]; -%! [-0.245935764451348, 0.0434727462, 0.2546303137]; -%! [ 0.146884054700421, -0.1654838046, -0.1733614634]; -%! [-0.014224472826781, 0.2051040386, 0.0415716780]; -%! [-0.103110398228686, -0.1634199694, 0.0844338303]]; -%! -%! Yt = [[-Inf, -Inf, -Inf ]; -%! [ 0.4980703596, 0.1459181380, -0.38133585 ]; -%! [-0.3085176252, 0.1478631434, 0.36766288 ]; -%! [ 0.1173132861, -0.2591285105, -0.18641422 ]; -%! [ 0.0556711673, 0.2490154242, -0.00586808 ]; -%! [-0.1712143068, -0.1538382565, 0.14660019 ]; -%! [ 0.2054642960, 0.0210736280, -0.20265448 ]; -%! [-0.1604111925, 0.0985727987, 0.17167666 ]]; -%! -%! J = besselj (n,z); -%! Y = bessely (n,z); -%! assert (Jt(:,1), J(:,1), 0.5e-10); -%! assert (Yt(:,1), Y(:,1), 0.5e-10); -%! assert (Jt(:,2:3), J(:,2:3), 0.5e-10); - -Table 9.2 - J and Y for integer orders 3-9. - -%!test -%! n = (3:9); -%! z = (0:2:20).'; -%! -%! Jt = [[ 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00]; -%! [ 1.2894e-01, 3.3996e-02, 7.0396e-03, 1.2024e-03, 1.7494e-04, 2.2180e-05, 2.4923e-06]; -%! [ 4.3017e-01, 2.8113e-01, 1.3209e-01, 4.9088e-02, 1.5176e-02, 4.0287e-03, 9.3860e-04]; -%! [ 1.1477e-01, 3.5764e-01, 3.6209e-01, 2.4584e-01, 1.2959e-01, 5.6532e-02, 2.1165e-02]; -%! [-2.9113e-01,-1.0536e-01, 1.8577e-01, 3.3758e-01, 3.2059e-01, 2.2345e-01, 1.2632e-01]; -%! [ 5.8379e-02,-2.1960e-01,-2.3406e-01,-1.4459e-02, 2.1671e-01, 3.1785e-01, 2.9186e-01]; -%! [ 1.9514e-01, 1.8250e-01,-7.3471e-02,-2.4372e-01,-1.7025e-01, 4.5095e-02, 2.3038e-01]; -%! [-1.7681e-01, 7.6244e-02, 2.2038e-01, 8.1168e-02,-1.5080e-01,-2.3197e-01,-1.1431e-01]; -%! [-4.3847e-02,-2.0264e-01,-5.7473e-02, 1.6672e-01, 1.8251e-01,-7.0211e-03,-1.8953e-01]; -%! [ 1.8632e-01, 6.9640e-02,-1.5537e-01,-1.5596e-01, 5.1399e-02, 1.9593e-01, 1.2276e-01]; -%! [-9.8901e-02, 1.3067e-01, 1.5117e-01,-5.5086e-02,-1.8422e-01,-7.3869e-02, 1.2513e-01]]; -%! -%! Yt = [[ -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf]; -%! [-1.1278e+00,-2.7659e+00,-9.9360e+00,-4.6914e+01,-2.7155e+02,-1.8539e+03,-1.4560e+04]; -%! [-1.8202e-01,-4.8894e-01,-7.9585e-01,-1.5007e+00,-3.7062e+00,-1.1471e+01,-4.2178e+01]; -%! [ 3.2825e-01, 9.8391e-02,-1.9706e-01,-4.2683e-01,-6.5659e-01,-1.1052e+00,-2.2907e+00]; -%! [ 2.6542e-02, 2.8294e-01, 2.5640e-01, 3.7558e-02,-2.0006e-01,-3.8767e-01,-5.7528e-01]; -%! [-2.5136e-01,-1.4495e-01, 1.3540e-01, 2.8035e-01, 2.0102e-01, 1.0755e-03,-1.9930e-01]; -%! [ 1.2901e-01,-1.5122e-01,-2.2982e-01,-4.0297e-02, 1.8952e-01, 2.6140e-01, 1.5902e-01]; -%! [ 1.2350e-01, 2.0393e-01,-6.9717e-03,-2.0891e-01,-1.7209e-01, 3.6816e-02, 2.1417e-01]; -%! [-1.9637e-01,-7.3222e-05, 1.9633e-01, 1.2278e-01,-1.0425e-01,-2.1399e-01,-1.0975e-01]; -%! [ 3.3724e-02,-1.7722e-01,-1.1249e-01, 1.1472e-01, 1.8897e-01, 3.2253e-02,-1.6030e-01]; -%! [ 1.4967e-01, 1.2409e-01,-1.0004e-01,-1.7411e-01,-4.4312e-03, 1.7101e-01, 1.4124e-01]]; -%! -%! n = (3:9); -%! z = (0:2:20).'; -%! J = besselj (n,z); -%! Y = bessely (n,z); -%! -%! assert (J(1,:), zeros (1, columns (J))); -%! assert (J(2:end,:), Jt(2:end,:), -5e-5); -%! assert (Yt(1,:), Y(1,:)); -%! assert (Y(2:end,:), Yt(2:end,:), -5e-5); - -Table 9.4 - J and Y for various integer orders and arguments. - -%!test -%! Jt = [[ 7.651976866e-01, 2.238907791e-01, -1.775967713e-01, -2.459357645e-01, 5.581232767e-02, 1.998585030e-02]; -%! [ 2.497577302e-04, 7.039629756e-03, 2.611405461e-01, -2.340615282e-01, -8.140024770e-02, -7.419573696e-02]; -%! [ 2.630615124e-10, 2.515386283e-07, 1.467802647e-03, 2.074861066e-01, -1.138478491e-01, -5.473217694e-02]; -%! [ 2.297531532e-17, 7.183016356e-13, 4.796743278e-07, 4.507973144e-03, -1.082255990e-01, 1.519812122e-02]; -%! [ 3.873503009e-25, 3.918972805e-19, 2.770330052e-11, 1.151336925e-05, -1.167043528e-01, 6.221745850e-02]; -%! [ 3.482869794e-42, 3.650256266e-33, 2.671177278e-21, 1.551096078e-12, 4.843425725e-02, 8.146012958e-02]; -%! [ 1.107915851e-60, 1.196077458e-48, 8.702241617e-33, 6.030895312e-21, -1.381762812e-01, 7.270175482e-02]; -%! [ 2.906004948e-80, 3.224095839e-65, 2.294247616e-45, 1.784513608e-30, 1.214090219e-01, -3.869833973e-02]; -%! [ 8.431828790e-189, 1.060953112e-158, 6.267789396e-119, 6.597316064e-89, 1.115927368e-21, 9.636667330e-02]]; -%! -%! Yt = [[ 8.825696420e-02, 5.103756726e-01, -3.085176252e-01, 5.567116730e-02, -9.806499547e-02, -7.724431337e-02] -%! [-2.604058666e+02, -9.935989128e+00, -4.536948225e-01, 1.354030477e-01, -7.854841391e-02, -2.948019628e-02] -%! [-1.216180143e+08, -1.291845422e+05, -2.512911010e+01, -3.598141522e-01, 5.723897182e-03, 5.833157424e-02] -%! [-9.256973276e+14, -2.981023646e+10, -4.694049564e+04, -6.364745877e+00, 4.041280205e-02, 7.879068695e-02] -%! [-4.113970315e+22, -4.081651389e+16, -5.933965297e+08, -1.597483848e+03, 1.644263395e-02, 5.124797308e-02] -%! [-3.048128783e+39, -2.913223848e+30, -4.028568418e+18, -7.256142316e+09, -1.164572349e-01, 6.138839212e-03] -%! [-7.184874797e+57, -6.661541235e+45, -9.216816571e+29, -1.362803297e+18, -4.530801120e-02, 4.074685217e-02] -%! [-2.191142813e+77, -1.976150576e+62, -2.788837017e+42, -3.641066502e+27, -2.103165546e-01, 7.650526394e-02] -%! [-3.775287810e+185, -3.000826049e+155, -5.084863915e+115, -4.849148271e+85, -3.293800188e+18, -1.669214114e-01]]; -%! -%! n = [(0:5:20).';30;40;50;100]; -%! z = [1,2,5,10,50,100]; -%! J = besselj (n.', z.').'; -%! Y = bessely (n.', z.').'; -%! assert (J, Jt, -1e-9); -%! assert (Y, Yt, -1e-9); - -Table 9.8 - I and K for integer orders 0, 1, 2. - -%!test -%! n = 0:2; -%! z1 = [0.1;2.5;5.0]; -%! z2 = [7.5;10.0;15.0;20.0]; -%! rtbl = [[ 0.9071009258 0.0452984468 0.1251041992 2.6823261023 10.890182683 1.995039646 ]; -%! [ 0.2700464416 0.2065846495 0.2042345837 0.7595486903 0.9001744239 0.759126289 ]; -%! [ 0.1835408126 0.1639722669 0.7002245988 0.5478075643 0.6002738588 0.132723593 ]; -%! [ 0.1483158301 0.1380412115 0.111504840 0.4505236991 0.4796689336 0.57843541 ]; -%! [ 0.1278333372 0.1212626814 0.103580801 0.3916319344 0.4107665704 0.47378525 ]; -%! [ 0.1038995314 0.1003741751 0.090516308 0.3210023535 0.3315348950 0.36520701 ]; -%! [ 0.0897803119 0.0875062222 0.081029690 0.2785448768 0.2854254970 0.30708743 ]]; -%! -%! tbl = [besseli(n,z1,1), besselk(n,z1,1)]; -%! tbl(:,3) = tbl(:,3) .* (exp (z1) .* z1.^(-2)); -%! tbl(:,6) = tbl(:,6) .* (exp (-z1) .* z1.^(2)); -%! tbl = [tbl;[besseli(n,z2,1),besselk(n,z2,1)]]; -%! -%! assert (tbl, rtbl, -2e-8); - -Table 9.9 - I and K for orders 3-9. - -%!test -%! It = [[ 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00]; -%! [ 2.8791e-02 6.8654e-03 1.3298e-03 2.1656e-04 3.0402e-05 3.7487e-06 4.1199e-07]; -%! [ 6.1124e-02 2.5940e-02 9.2443e-03 2.8291e-03 7.5698e-04 1.7968e-04 3.8284e-05]; -%! [ 7.4736e-02 4.1238e-02 1.9752e-02 8.3181e-03 3.1156e-03 1.0484e-03 3.1978e-04]; -%! [ 7.9194e-02 5.0500e-02 2.8694e-02 1.4633e-02 6.7449e-03 2.8292e-03 1.0866e-03]; -%! [ 7.9830e-02 5.5683e-02 3.5284e-02 2.0398e-02 1.0806e-02 5.2694e-03 2.3753e-03]; -%! [ 7.8848e-02 5.8425e-02 3.9898e-02 2.5176e-02 1.4722e-02 8.0010e-03 4.0537e-03]; -%! [ 7.7183e-02 5.9723e-02 4.3056e-02 2.8969e-02 1.8225e-02 1.0744e-02 5.9469e-03]; -%! [ 7.5256e-02 6.0155e-02 4.5179e-02 3.1918e-02 2.1240e-02 1.3333e-02 7.9071e-03]; -%! [ 7.3263e-02 6.0059e-02 4.6571e-02 3.4186e-02 2.3780e-02 1.5691e-02 9.8324e-03]; -%! [ 7.1300e-02 5.9640e-02 4.7444e-02 3.5917e-02 2.5894e-02 1.7792e-02 1.1661e-02]]; -%! -%! Kt = [[ Inf Inf Inf Inf Inf Inf Inf]; -%! [ 4.7836e+00 1.6226e+01 6.9687e+01 3.6466e+02 2.2576e+03 1.6168e+04 1.3160e+05]; -%! [ 1.6317e+00 3.3976e+00 8.4268e+00 2.4465e+01 8.1821e+01 3.1084e+02 1.3252e+03]; -%! [ 9.9723e-01 1.6798e+00 3.2370e+00 7.0748e+00 1.7387e+01 4.7644e+01 1.4444e+02]; -%! [ 7.3935e-01 1.1069e+00 1.8463e+00 3.4148e+00 6.9684e+00 1.5610e+01 3.8188e+01]; -%! [ 6.0028e-01 8.3395e-01 1.2674e+00 2.1014e+00 3.7891e+00 7.4062e+00 1.5639e+01]; -%! [ 5.1294e-01 6.7680e-01 9.6415e-01 1.4803e+00 2.4444e+00 4.3321e+00 8.2205e+00]; -%! [ 4.5266e-01 5.7519e-01 7.8133e-01 1.1333e+00 1.7527e+00 2.8860e+00 5.0510e+00]; -%! [ 4.0829e-01 5.0414e-01 6.6036e-01 9.1686e-01 1.3480e+00 2.0964e+00 3.4444e+00]; -%! [ 3.7411e-01 4.5162e-01 5.7483e-01 7.7097e-01 1.0888e+00 1.6178e+00 2.5269e+00]; -%! [ 3.4684e-01 4.1114e-01 5.1130e-01 6.6679e-01 9.1137e-01 1.3048e+00 1.9552e+00]]; -%! -%! n = (3:9); -%! z = (0:2:20).'; -%! I = besseli (n,z,1); -%! K = besselk (n,z,1); -%! -%! assert (abs (I(1,:)), zeros (1, columns (I))); -%! assert (I(2:end,:), It(2:end,:), -5e-5); -%! assert (Kt(1,:), K(1,:)); -%! assert (K(2:end,:), Kt(2:end,:), -5e-5); - -Table 9.11 - I and K for various integer orders and arguments. - -%!test -%! It = [[ 1.266065878e+00 2.279585302e+00 2.723987182e+01 2.815716628e+03 2.93255378e+20 1.07375171e+42 ]; -%! [ 2.714631560e-04 9.825679323e-03 2.157974547e+00 7.771882864e+02 2.27854831e+20 9.47009387e+41 ]; -%! [ 2.752948040e-10 3.016963879e-07 4.580044419e-03 2.189170616e+01 1.07159716e+20 6.49897552e+41 ]; -%! [ 2.370463051e-17 8.139432531e-13 1.047977675e-06 1.043714907e-01 3.07376455e+19 3.47368638e+41 ]; -%! [ 3.966835986e-25 4.310560576e-19 5.024239358e-11 1.250799736e-04 5.44200840e+18 1.44834613e+41 ]; -%! [ 3.539500588e-42 3.893519664e-33 3.997844971e-21 7.787569783e-12 4.27499365e+16 1.20615487e+40 ]; -%! [ 1.121509741e-60 1.255869192e-48 1.180426980e-32 2.042123274e-20 6.00717897e+13 3.84170550e+38 ]; -%! [ 2.934635309e-80 3.353042830e-65 2.931469647e-45 4.756894561e-30 1.76508024e+10 4.82195809e+36 ]; -%! [ 8.473674008e-189 1.082171475e-158 7.093551489e-119 1.082344202e-88 2.72788795e-16 4.64153494e+21 ]]; -%! -%! Kt = [[ 4.210244382e-01 1.138938727e-01 3.691098334e-03 1.778006232e-05 3.41016774e-23 4.65662823e-45 ]; -%! [ 3.609605896e+02 9.431049101e+00 3.270627371e-02 5.754184999e-05 4.36718224e-23 5.27325611e-45 ]; -%! [ 1.807132899e+08 1.624824040e+05 9.758562829e+00 1.614255300e-03 9.15098819e-23 7.65542797e-45 ]; -%! [ 1.403066801e+15 4.059213332e+10 3.016976630e+04 2.656563849e-01 3.11621117e-22 1.42348325e-44 ]; -%! [ 6.294369360e+22 5.770856853e+16 4.827000521e+08 1.787442782e+02 1.70614838e-21 3.38520541e-44 ]; -%! [ 4.706145527e+39 4.271125755e+30 4.112132063e+18 2.030247813e+09 2.00581681e-19 3.97060205e-43 ]; -%! [ 1.114220651e+58 9.940839886e+45 1.050756722e+30 5.938224681e+17 1.29986971e-16 1.20842080e-41 ]; -%! [ 3.406896854e+77 2.979981740e+62 3.394322243e+42 2.061373775e+27 4.00601349e-13 9.27452265e-40 ]; -%! [ 5.900333184e+185 4.619415978e+155 7.039860193e+115 4.596674084e+85 1.63940352e+13 7.61712963e-25 ]]; -%! -%! n = [(0:5:20).';30;40;50;100]; -%! z = [1,2,5,10,50,100]; -%! I = besseli (n.', z.').'; -%! K = besselk (n.', z.').'; -%! assert (I, It, -5e-9); -%! assert (K, Kt, -5e-9); - -The next section checks that negative integer orders and positive -integer orders are appropriately related. - -%!test -%! n = (0:2:20); -%! assert (besselj (n,1), besselj (-n,1), 1e-8); -%! assert (-besselj (n+1,1), besselj (-n-1,1), 1e-8); - -besseli (n,z) = besseli (-n,z); - -%!test -%! n = (0:2:20); -%! assert (besseli (n,1), besseli (-n,1), 1e-8); - -Table 10.1 - j and y for integer orders 0, 1, 2. -Compare against excerpts of Table 10.1, Abramowitz and Stegun. - -%!test -%! n = (0:2); -%! z = [0.1;(2.5:2.5:10.0).']; -%! -%! jt = [[ 9.9833417e-01 3.33000119e-02 6.6619061e-04 ]; -%! [ 2.3938886e-01 4.16212989e-01 2.6006673e-01 ]; -%! [-1.9178485e-01 -9.50894081e-02 1.3473121e-01 ]; -%! [ 1.2507e-01 -2.9542e-02 -1.3688e-01 ]; -%! [ -5.4402e-02 7.8467e-02 7.7942e-02 ]]; -%! -%! yt = [[-9.9500417e+00 -1.0049875e+02 -3.0050125e+03 ]; -%! [ 3.2045745e-01 -1.1120588e-01 -4.5390450e-01 ]; -%! [-5.6732437e-02 1.8043837e-01 1.6499546e-01 ]; -%! [ -4.6218e-02 -1.3123e-01 -6.2736e-03 ]; -%! [ 8.3907e-02 6.2793e-02 -6.5069e-02 ]]; -%! -%! j = sqrt ((pi/2)./z) .* besselj (n+1/2,z); -%! y = sqrt ((pi/2)./z) .* bessely (n+1/2,z); -%! assert (jt, j, -5e-5); -%! assert (yt, y, -5e-5); - -Table 10.2 - j and y for orders 3-8. -Compare against excerpts of Table 10.2, Abramowitzh and Stegun. - - Important note: In A&S, y_4(0.1) = -1.0507e+7, but Octave returns - y_4(0.1) = -1.0508e+07 (-10507503.75). If I compute the same term using - a series, the difference is in the eighth significant digit so I left - the Octave results in place. - -%!test -%! n = (3:8); -%! z = (0:2.5:10).'; z(1) = 0.1; -%! -%! jt = [[ 9.5185e-06 1.0577e-07 9.6163e-10 7.3975e-12 4.9319e-14 2.9012e-16]; -%! [ 1.0392e-01 3.0911e-02 7.3576e-03 1.4630e-03 2.5009e-04 3.7516e-05]; -%! [ 2.2982e-01 1.8702e-01 1.0681e-01 4.7967e-02 1.7903e-02 5.7414e-03]; -%! [-6.1713e-02 7.9285e-02 1.5685e-01 1.5077e-01 1.0448e-01 5.8188e-02]; -%! [-3.9496e-02 -1.0559e-01 -5.5535e-02 4.4501e-02 1.1339e-01 1.2558e-01]]; -%! -%! yt = [[-1.5015e+05 -1.0508e+07 -9.4553e+08 -1.0400e+11 -1.3519e+13 -2.0277e+15]; -%! [-7.9660e-01 -1.7766e+00 -5.5991e+00 -2.2859e+01 -1.1327e+02 -6.5676e+02]; -%! [-1.5443e-02 -1.8662e-01 -3.2047e-01 -5.1841e-01 -1.0274e+00 -2.5638e+00]; -%! [ 1.2705e-01 1.2485e-01 2.2774e-02 -9.1449e-02 -1.8129e-01 -2.7112e-01]; -%! [-9.5327e-02 -1.6599e-03 9.3834e-02 1.0488e-01 4.2506e-02 -4.1117e-02]]; -%! -%! j = sqrt ((pi/2)./z) .* besselj (n+1/2,z); -%! y = sqrt ((pi/2)./z) .* bessely (n+1/2,z); -%! -%! assert (jt, j, -5e-5); -%! assert (yt, y, -5e-5); - -Table 10.4 - j and y for various integer orders and arguments. - -%!test -%! jt = [[ 8.414709848e-01 4.546487134e-01 -1.917848549e-01 -5.440211109e-02 -5.247497074e-03 -5.063656411e-03]; -%! [ 9.256115861e-05 2.635169770e-03 1.068111615e-01 -5.553451162e-02 -2.004830056e-02 -9.290148935e-03]; -%! [ 7.116552640e-11 6.825300865e-08 4.073442442e-04 6.460515449e-02 -1.503922146e-02 -1.956578597e-04]; -%! [ 5.132686115e-18 1.606982166e-13 1.084280182e-07 1.063542715e-03 -1.129084539e-02 7.877261748e-03]; -%! [ 7.537795722e-26 7.632641101e-20 5.427726761e-12 2.308371961e-06 -1.578502990e-02 1.010767128e-02]; -%! [ 5.566831267e-43 5.836617888e-34 4.282730217e-22 2.512057385e-13 -1.494673454e-03 8.700628514e-03]; -%! [ 1.538210374e-61 1.660978779e-49 1.210347583e-33 8.435671634e-22 -2.606336952e-02 1.043410851e-02]; -%! [ 3.615274717e-81 4.011575290e-66 2.857479350e-46 2.230696023e-31 1.882910737e-02 5.797140882e-04]; -%! [7.444727742e-190 9.367832591e-160 5.535650303e-120 5.832040182e-90 1.019012263e-22 1.088047701e-02]]; -%! -%! yt = [[ -5.403023059e-01 2.080734183e-01 -5.673243709e-02 8.390715291e-02 -1.929932057e-02 -8.623188723e-03] -%! [ -9.994403434e+02 -1.859144531e+01 -3.204650467e-01 9.383354168e-02 -6.971131965e-04 3.720678486e-03] -%! [ -6.722150083e+08 -3.554147201e+05 -2.665611441e+01 -1.724536721e-01 1.352468751e-02 1.002577737e-02] -%! [ -6.298007233e+15 -1.012182944e+11 -6.288146513e+04 -3.992071745e+00 1.712319725e-02 6.258641510e-03] -%! [ -3.239592219e+23 -1.605436493e+17 -9.267951403e+08 -1.211210605e+03 1.375953130e-02 5.631729379e-05] -%! [ -2.946428547e+40 -1.407393871e+31 -7.760717570e+18 -6.908318646e+09 -2.241226812e-02 -5.412929349e-03] -%! [ -8.028450851e+58 -3.720929322e+46 -2.055758716e+30 -1.510304919e+18 4.978797221e-05 -7.048420407e-04] -%! [ -2.739192285e+78 -1.235021944e+63 -6.964109188e+42 -4.528227272e+27 -4.190000150e-02 1.074782297e-02] -%! [-6.683079463e+186 -2.655955830e+156 -1.799713983e+116 -8.573226309e+85 -1.125692891e+18 -2.298385049e-02]]; -%! -%! n = [(0:5:20).';30;40;50;100]; -%! z = [1,2,5,10,50,100]; -%! j = sqrt ((pi/2)./z) .* besselj ((n+1/2).', z.').'; -%! y = sqrt ((pi/2)./z) .* bessely ((n+1/2).', z.').'; -%! assert (j, jt, -1e-9); -%! assert (y, yt, -1e-9); -*/
--- a/src/DLD-FUNCTIONS/betainc.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,491 +0,0 @@ -/* - -Copyright (C) 1997-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-specfun.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -// FIXME: These functions do not need to be dynamically loaded. They should -// be placed elsewhere in the Octave code hierarchy. - -DEFUN_DLD (betainc, args, , - "-*- texinfo -*-\n\ -@deftypefn {Mapping Function} {} betainc (@var{x}, @var{a}, @var{b})\n\ -Return the regularized incomplete Beta function,\n\ -@tex\n\ -$$\n\ - I (x, a, b) = {1 \\over {B (a, b)}} \\int_0^x t^{(a-z)} (1-t)^{(b-1)} dt.\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -@c Set example in small font to prevent overfull line\n\ -\n\ -@smallexample\n\ -@group\n\ - x\n\ - 1 /\n\ -betainc (x, a, b) = ----------- | t^(a-1) (1-t)^(b-1) dt.\n\ - beta (a, b) /\n\ - t=0\n\ -@end group\n\ -@end smallexample\n\ -\n\ -@end ifnottex\n\ -\n\ -If @var{x} has more than one component, both @var{a} and @var{b} must be\n\ -scalars. If @var{x} is a scalar, @var{a} and @var{b} must be of\n\ -compatible dimensions.\n\ -@seealso{betaincinv, beta, betaln}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin == 3) - { - octave_value x_arg = args(0); - octave_value a_arg = args(1); - octave_value b_arg = args(2); - - // FIXME Can we make a template version of the duplicated code below - if (x_arg.is_single_type () || a_arg.is_single_type () || - b_arg.is_single_type ()) - { - if (x_arg.is_scalar_type ()) - { - float x = x_arg.float_value (); - - if (a_arg.is_scalar_type ()) - { - float a = a_arg.float_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - float b = b_arg.float_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<float> b = b_arg.float_array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - else - { - Array<float> a = a_arg.float_array_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - float b = b_arg.float_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<float> b = b_arg.float_array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - } - else - { - Array<float> x = x_arg.float_array_value (); - - if (a_arg.is_scalar_type ()) - { - float a = a_arg.float_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - float b = b_arg.float_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<float> b = b_arg.float_array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - else - { - Array<float> a = a_arg.float_array_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - float b = b_arg.float_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<float> b = b_arg.float_array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - } - } - else - { - if (x_arg.is_scalar_type ()) - { - double x = x_arg.double_value (); - - if (a_arg.is_scalar_type ()) - { - double a = a_arg.double_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - else - { - Array<double> a = a_arg.array_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - } - else - { - Array<double> x = x_arg.array_value (); - - if (a_arg.is_scalar_type ()) - { - double a = a_arg.double_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - else - { - Array<double> a = a_arg.array_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betainc (x, a, b); - } - } - } - } - } - } - else - print_usage (); - - return retval; -} - -/* -## Double precision -%!test -%! a = [1, 1.5, 2, 3]; -%! b = [4, 3, 2, 1]; -%! v1 = betainc (1,a,b); -%! v2 = [1,1,1,1]; -%! x = [.2, .4, .6, .8]; -%! v3 = betainc (x, a, b); -%! v4 = 1 - betainc (1.-x, b, a); -%! assert (v1, v2, sqrt (eps)); -%! assert (v3, v4, sqrt (eps)); - -## Single precision -%!test -%! a = single ([1, 1.5, 2, 3]); -%! b = single ([4, 3, 2, 1]); -%! v1 = betainc (1,a,b); -%! v2 = single ([1,1,1,1]); -%! x = single ([.2, .4, .6, .8]); -%! v3 = betainc (x, a, b); -%! v4 = 1 - betainc (1.-x, b, a); -%! assert (v1, v2, sqrt (eps ("single"))); -%! assert (v3, v4, sqrt (eps ("single"))); - -## Mixed double/single precision -%!test -%! a = single ([1, 1.5, 2, 3]); -%! b = [4, 3, 2, 1]; -%! v1 = betainc (1,a,b); -%! v2 = single ([1,1,1,1]); -%! x = [.2, .4, .6, .8]; -%! v3 = betainc (x, a, b); -%! v4 = 1-betainc (1.-x, b, a); -%! assert (v1, v2, sqrt (eps ("single"))); -%! assert (v3, v4, sqrt (eps ("single"))); - -%!error betainc () -%!error betainc (1) -%!error betainc (1,2) -%!error betainc (1,2,3,4) -*/ - -DEFUN_DLD (betaincinv, args, , - "-*- texinfo -*-\n\ -@deftypefn {Mapping Function} {} betaincinv (@var{y}, @var{a}, @var{b})\n\ -Compute the inverse of the incomplete Beta function, i.e., @var{x} such that\n\ -\n\ -@example\n\ -@var{y} == betainc (@var{x}, @var{a}, @var{b}) \n\ -@end example\n\ -@seealso{betainc, beta, betaln}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin == 3) - { - octave_value x_arg = args(0); - octave_value a_arg = args(1); - octave_value b_arg = args(2); - - if (x_arg.is_scalar_type ()) - { - double x = x_arg.double_value (); - - if (a_arg.is_scalar_type ()) - { - double a = a_arg.double_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - } - } - else - { - Array<double> a = a_arg.array_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - } - } - } - else - { - Array<double> x = x_arg.array_value (); - - if (a_arg.is_scalar_type ()) - { - double a = a_arg.double_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - } - } - else - { - Array<double> a = a_arg.array_value (); - - if (! error_state) - { - if (b_arg.is_scalar_type ()) - { - double b = b_arg.double_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - else - { - Array<double> b = b_arg.array_value (); - - if (! error_state) - retval = betaincinv (x, a, b); - } - } - } - } - - // FIXME: It would be better to have an algorithm for betaincinv which - // accepted float inputs and returned float outputs. As it is, we do - // extra work to calculate betaincinv to double precision and then throw - // that precision away. - if (x_arg.is_single_type () || a_arg.is_single_type () || - b_arg.is_single_type ()) - { - retval = Array<float> (retval.array_value ()); - } - } - else - print_usage (); - - return retval; -} - -/* -%!assert (betaincinv ([0.875 0.6875], [1 2], 3), [0.5 0.5], sqrt (eps)) -%!assert (betaincinv (0.5, 3, 3), 0.5, sqrt (eps)) -%!assert (betaincinv (0.34375, 4, 3), 0.5, sqrt (eps)) -%!assert (betaincinv (0.2265625, 5, 3), 0.5, sqrt (eps)) -%!assert (betaincinv (0.14453125, 6, 3), 0.5, sqrt (eps)) -%!assert (betaincinv (0.08984375, 7, 3), 0.5, sqrt (eps)) -%!assert (betaincinv (0.0546875, 8, 3), 0.5, sqrt (eps)) -%!assert (betaincinv (0.03271484375, 9, 3), 0.5, sqrt (eps)) -%!assert (betaincinv (0.019287109375, 10, 3), 0.5, sqrt (eps)) - -## Test class single as well -%!assert (betaincinv ([0.875 0.6875], [1 2], single (3)), [0.5 0.5], sqrt (eps ("single"))) -%!assert (betaincinv (0.5, 3, single (3)), 0.5, sqrt (eps ("single"))) -%!assert (betaincinv (0.34375, 4, single (3)), 0.5, sqrt (eps ("single"))) - -## Extreme values -%!assert (betaincinv (0, 42, 42), 0, sqrt (eps)) -%!assert (betaincinv (1, 42, 42), 1, sqrt (eps)) - -%!error betaincinv () -%!error betaincinv (1, 2) -*/ -
--- a/src/DLD-FUNCTIONS/bsxfun.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,813 +0,0 @@ -/* - -Copyright (C) 2007-2012 David Bateman -Copyright (C) 2009 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> -#include <vector> -#include <list> - -#include "lo-mappers.h" - -#include "oct-map.h" -#include "defun-dld.h" -#include "parse.h" -#include "variables.h" -#include "ov-colon.h" -#include "unwind-prot.h" -#include "ov-fcn-handle.h" - -// Optimized bsxfun operations -enum bsxfun_builtin_op -{ - bsxfun_builtin_plus = 0, - bsxfun_builtin_minus, - bsxfun_builtin_times, - bsxfun_builtin_divide, - bsxfun_builtin_max, - bsxfun_builtin_min, - bsxfun_builtin_eq, - bsxfun_builtin_ne, - bsxfun_builtin_lt, - bsxfun_builtin_le, - bsxfun_builtin_gt, - bsxfun_builtin_ge, - bsxfun_builtin_and, - bsxfun_builtin_or, - bsxfun_builtin_power, - bsxfun_builtin_unknown, - bsxfun_num_builtin_ops = bsxfun_builtin_unknown -}; - -const char *bsxfun_builtin_names[] = -{ - "plus", - "minus", - "times", - "rdivide", - "max", - "min", - "eq", - "ne", - "lt", - "le", - "gt", - "ge", - "and", - "or", - "power" -}; - -static bsxfun_builtin_op -bsxfun_builtin_lookup (const std::string& name) -{ - for (int i = 0; i < bsxfun_num_builtin_ops; i++) - if (name == bsxfun_builtin_names[i]) - return static_cast<bsxfun_builtin_op> (i); - return bsxfun_builtin_unknown; -} - -typedef octave_value (*bsxfun_handler) (const octave_value&, const octave_value&); - -// Static table of handlers. -bsxfun_handler bsxfun_handler_table[bsxfun_num_builtin_ops][btyp_num_types]; - -template <class NDA, NDA (bsxfun_op) (const NDA&, const NDA&)> -static octave_value -bsxfun_forward_op (const octave_value& x, const octave_value& y) -{ - NDA xa = octave_value_extract<NDA> (x); - NDA ya = octave_value_extract<NDA> (y); - return octave_value (bsxfun_op (xa, ya)); -} - -template <class NDA, boolNDArray (bsxfun_rel) (const NDA&, const NDA&)> -static octave_value -bsxfun_forward_rel (const octave_value& x, const octave_value& y) -{ - NDA xa = octave_value_extract<NDA> (x); - NDA ya = octave_value_extract<NDA> (y); - return octave_value (bsxfun_rel (xa, ya)); -} - -// Pow needs a special handler for reals because of the potentially complex result. -template <class NDA, class CNDA> -static octave_value -do_bsxfun_real_pow (const octave_value& x, const octave_value& y) -{ - NDA xa = octave_value_extract<NDA> (x); - NDA ya = octave_value_extract<NDA> (y); - if (! ya.all_integers () && xa.any_element_is_negative ()) - return octave_value (bsxfun_pow (CNDA (xa), ya)); - else - return octave_value (bsxfun_pow (xa, ya)); -} - -static void maybe_fill_table (void) -{ - static bool filled = false; - if (filled) - return; - -#define REGISTER_OP_HANDLER(OP, BTYP, NDA, FUNOP) \ - bsxfun_handler_table[OP][BTYP] = bsxfun_forward_op<NDA, FUNOP> -#define REGISTER_REL_HANDLER(REL, BTYP, NDA, FUNREL) \ - bsxfun_handler_table[REL][BTYP] = bsxfun_forward_rel<NDA, FUNREL> -#define REGISTER_STD_HANDLERS(BTYP, NDA) \ - REGISTER_OP_HANDLER (bsxfun_builtin_plus, BTYP, NDA, bsxfun_add); \ - REGISTER_OP_HANDLER (bsxfun_builtin_minus, BTYP, NDA, bsxfun_sub); \ - REGISTER_OP_HANDLER (bsxfun_builtin_times, BTYP, NDA, bsxfun_mul); \ - REGISTER_OP_HANDLER (bsxfun_builtin_divide, BTYP, NDA, bsxfun_div); \ - REGISTER_OP_HANDLER (bsxfun_builtin_max, BTYP, NDA, bsxfun_max); \ - REGISTER_OP_HANDLER (bsxfun_builtin_min, BTYP, NDA, bsxfun_min); \ - REGISTER_REL_HANDLER (bsxfun_builtin_eq, BTYP, NDA, bsxfun_eq); \ - REGISTER_REL_HANDLER (bsxfun_builtin_ne, BTYP, NDA, bsxfun_ne); \ - REGISTER_REL_HANDLER (bsxfun_builtin_lt, BTYP, NDA, bsxfun_lt); \ - REGISTER_REL_HANDLER (bsxfun_builtin_le, BTYP, NDA, bsxfun_le); \ - REGISTER_REL_HANDLER (bsxfun_builtin_gt, BTYP, NDA, bsxfun_gt); \ - REGISTER_REL_HANDLER (bsxfun_builtin_ge, BTYP, NDA, bsxfun_ge) - - REGISTER_STD_HANDLERS (btyp_double, NDArray); - REGISTER_STD_HANDLERS (btyp_float, FloatNDArray); - REGISTER_STD_HANDLERS (btyp_complex, ComplexNDArray); - REGISTER_STD_HANDLERS (btyp_float_complex, FloatComplexNDArray); - REGISTER_STD_HANDLERS (btyp_int8, int8NDArray); - REGISTER_STD_HANDLERS (btyp_int16, int16NDArray); - REGISTER_STD_HANDLERS (btyp_int32, int32NDArray); - REGISTER_STD_HANDLERS (btyp_int64, int64NDArray); - REGISTER_STD_HANDLERS (btyp_uint8, uint8NDArray); - REGISTER_STD_HANDLERS (btyp_uint16, uint16NDArray); - REGISTER_STD_HANDLERS (btyp_uint32, uint32NDArray); - REGISTER_STD_HANDLERS (btyp_uint64, uint64NDArray); - - // For bools, we register and/or. - REGISTER_OP_HANDLER (bsxfun_builtin_and, btyp_bool, boolNDArray, bsxfun_and); - REGISTER_OP_HANDLER (bsxfun_builtin_or, btyp_bool, boolNDArray, bsxfun_or); - - // Register power handlers. - bsxfun_handler_table[bsxfun_builtin_power][btyp_double] = - do_bsxfun_real_pow<NDArray, ComplexNDArray>; - bsxfun_handler_table[bsxfun_builtin_power][btyp_float] = - do_bsxfun_real_pow<FloatNDArray, FloatComplexNDArray>; - - REGISTER_OP_HANDLER (bsxfun_builtin_power, btyp_complex, ComplexNDArray, bsxfun_pow); - REGISTER_OP_HANDLER (bsxfun_builtin_power, btyp_float_complex, FloatComplexNDArray, bsxfun_pow); - - // For chars, we want just relational handlers. - REGISTER_REL_HANDLER (bsxfun_builtin_eq, btyp_char, charNDArray, bsxfun_eq); - REGISTER_REL_HANDLER (bsxfun_builtin_ne, btyp_char, charNDArray, bsxfun_ne); - REGISTER_REL_HANDLER (bsxfun_builtin_lt, btyp_char, charNDArray, bsxfun_lt); - REGISTER_REL_HANDLER (bsxfun_builtin_le, btyp_char, charNDArray, bsxfun_le); - REGISTER_REL_HANDLER (bsxfun_builtin_gt, btyp_char, charNDArray, bsxfun_gt); - REGISTER_REL_HANDLER (bsxfun_builtin_ge, btyp_char, charNDArray, bsxfun_ge); - - filled = true; -} - -static octave_value -maybe_optimized_builtin (const std::string& name, - const octave_value& a, const octave_value& b) -{ - octave_value retval; - - maybe_fill_table (); - - bsxfun_builtin_op op = bsxfun_builtin_lookup (name); - if (op != bsxfun_builtin_unknown) - { - builtin_type_t btyp_a = a.builtin_type (), btyp_b = b.builtin_type (); - - // Simplify single/double combinations. - if (btyp_a == btyp_float && btyp_b == btyp_double) - btyp_b = btyp_float; - else if (btyp_a == btyp_double && btyp_b == btyp_float) - btyp_a = btyp_float; - else if (btyp_a == btyp_float_complex && btyp_b == btyp_complex) - btyp_b = btyp_float_complex; - else if (btyp_a == btyp_complex && btyp_b == btyp_float_complex) - btyp_a = btyp_float_complex; - - if (btyp_a == btyp_b && btyp_a != btyp_unknown) - { - bsxfun_handler handler = bsxfun_handler_table[op][btyp_a]; - if (handler) - retval = handler (a, b); - } - } - - return retval; -} - -static bool -maybe_update_column (octave_value& Ac, const octave_value& A, - const dim_vector& dva, const dim_vector& dvc, - octave_idx_type i, octave_value_list &idx) -{ - octave_idx_type nd = dva.length (); - - if (i == 0) - { - idx(0) = octave_value (':'); - for (octave_idx_type j = 1; j < nd; j++) - { - if (dva (j) == 1) - idx(j) = octave_value (1); - else - idx(j) = octave_value ((i % dvc(j)) + 1); - - i = i / dvc (j); - } - - Ac = A; - Ac = Ac.single_subsref ("(", idx); - return true; - } - else - { - bool is_changed = false; - octave_idx_type k = i; - octave_idx_type k1 = i - 1; - for (octave_idx_type j = 1; j < nd; j++) - { - if (dva(j) != 1 && k % dvc (j) != k1 % dvc (j)) - { - idx (j) = octave_value ((k % dvc(j)) + 1); - is_changed = true; - } - - k = k / dvc (j); - k1 = k1 / dvc (j); - } - - if (is_changed) - { - Ac = A; - Ac = Ac.single_subsref ("(", idx); - return true; - } - else - return false; - } -} - -#if 0 -// FIXME -- this function is not used; is it OK to delete it? -static void -update_index (octave_value_list& idx, const dim_vector& dv, octave_idx_type i) -{ - octave_idx_type nd = dv.length (); - - if (i == 0) - { - for (octave_idx_type j = nd - 1; j > 0; j--) - idx(j) = octave_value (static_cast<double>(1)); - idx(0) = octave_value (':'); - } - else - { - for (octave_idx_type j = 1; j < nd; j++) - { - idx (j) = octave_value (i % dv (j) + 1); - i = i / dv (j); - } - } -} -#endif - -static void -update_index (Array<int>& idx, const dim_vector& dv, octave_idx_type i) -{ - octave_idx_type nd = dv.length (); - - idx(0) = 0; - for (octave_idx_type j = 1; j < nd; j++) - { - idx (j) = i % dv (j); - i = i / dv (j); - } -} - -DEFUN_DLD (bsxfun, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} bsxfun (@var{f}, @var{A}, @var{B})\n\ -The binary singleton expansion function applier performs broadcasting,\n\ -that is, applies a binary function @var{f} element-by-element to two\n\ -array arguments @var{A} and @var{B}, and expands as necessary\n\ -singleton dimensions in either input argument. @var{f} is a function\n\ -handle, inline function, or string containing the name of the function\n\ -to evaluate. The function @var{f} must be capable of accepting two\n\ -column-vector arguments of equal length, or one column vector argument\n\ -and a scalar.\n\ -\n\ -The dimensions of @var{A} and @var{B} must be equal or singleton. The\n\ -singleton dimensions of the arrays will be expanded to the same\n\ -dimensionality as the other array.\n\ -@seealso{arrayfun, cellfun}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value_list retval; - - if (nargin != 3) - print_usage (); - else - { - octave_value func = args(0); - - if (func.is_string ()) - { - std::string name = func.string_value (); - func = symbol_table::find_function (name); - if (func.is_undefined ()) - error ("bsxfun: invalid function name: %s", name.c_str ()); - } - else if (! (args(0).is_function_handle () || args(0).is_inline_function ())) - error ("bsxfun: F must be a string or function handle"); - - const octave_value A = args (1); - const octave_value B = args (2); - - if (func.is_builtin_function () - || (func.is_function_handle () && ! A.is_object () && ! B.is_object ())) - { - // This may break if the default behavior is overriden. But if you override - // arithmetic operators for builtin classes, you should expect mayhem - // anyway (constant folding etc). Querying is_overloaded may not be - // exactly what we need here. - octave_function *fcn_val = func.function_value (); - if (fcn_val) - { - octave_value tmp = maybe_optimized_builtin (fcn_val->name (), A, B); - if (tmp.is_defined ()) - retval(0) = tmp; - } - } - - if (! error_state && retval.empty ()) - { - dim_vector dva = A.dims (); - octave_idx_type nda = dva.length (); - dim_vector dvb = B.dims (); - octave_idx_type ndb = dvb.length (); - octave_idx_type nd = nda; - - if (nda > ndb) - dvb.resize (nda, 1); - else if (nda < ndb) - { - dva.resize (ndb, 1); - nd = ndb; - } - - for (octave_idx_type i = 0; i < nd; i++) - if (dva (i) != dvb (i) && dva (i) != 1 && dvb (i) != 1) - { - error ("bsxfun: dimensions of A and B must match"); - break; - } - - if (!error_state) - { - // Find the size of the output - dim_vector dvc; - dvc.resize (nd); - - for (octave_idx_type i = 0; i < nd; i++) - dvc (i) = (dva (i) < 1 ? dva (i) : (dvb (i) < 1 ? dvb (i) : - (dva (i) > dvb (i) ? dva (i) : dvb (i)))); - - if (dva == dvb || dva.numel () == 1 || dvb.numel () == 1) - { - octave_value_list inputs; - inputs (0) = A; - inputs (1) = B; - retval = func.do_multi_index_op (1, inputs); - } - else if (dvc.numel () < 1) - { - octave_value_list inputs; - inputs (0) = A.resize (dvc); - inputs (1) = B.resize (dvc); - retval = func.do_multi_index_op (1, inputs); - } - else - { - octave_idx_type ncount = 1; - for (octave_idx_type i = 1; i < nd; i++) - ncount *= dvc (i); - -#define BSXDEF(T) \ - T result_ ## T; \ - bool have_ ## T = false; - - BSXDEF(NDArray); - BSXDEF(ComplexNDArray); - BSXDEF(FloatNDArray); - BSXDEF(FloatComplexNDArray); - BSXDEF(boolNDArray); - BSXDEF(int8NDArray); - BSXDEF(int16NDArray); - BSXDEF(int32NDArray); - BSXDEF(int64NDArray); - BSXDEF(uint8NDArray); - BSXDEF(uint16NDArray); - BSXDEF(uint32NDArray); - BSXDEF(uint64NDArray); - - octave_value Ac ; - octave_value_list idxA; - octave_value Bc; - octave_value_list idxB; - octave_value C; - octave_value_list inputs; - Array<int> ra_idx (dim_vector (dvc.length (), 1), 0); - - - for (octave_idx_type i = 0; i < ncount; i++) - { - if (maybe_update_column (Ac, A, dva, dvc, i, idxA)) - inputs (0) = Ac; - - if (maybe_update_column (Bc, B, dvb, dvc, i, idxB)) - inputs (1) = Bc; - - octave_value_list tmp = func.do_multi_index_op (1, inputs); - - if (error_state) - break; - -#define BSXINIT(T, CLS, EXTRACTOR) \ - (result_type == CLS) \ - { \ - have_ ## T = true; \ - result_ ## T = \ - tmp (0). EXTRACTOR ## _array_value (); \ - result_ ## T .resize (dvc); \ - } - - if (i == 0) - { - if (! tmp(0).is_sparse_type ()) - { - std::string result_type = tmp(0).class_name (); - if (result_type == "double") - { - if (tmp(0).is_real_type ()) - { - have_NDArray = true; - result_NDArray = tmp(0).array_value (); - result_NDArray.resize (dvc); - } - else - { - have_ComplexNDArray = true; - result_ComplexNDArray = - tmp(0).complex_array_value (); - result_ComplexNDArray.resize (dvc); - } - } - else if (result_type == "single") - { - if (tmp(0).is_real_type ()) - { - have_FloatNDArray = true; - result_FloatNDArray = tmp(0).float_array_value (); - result_FloatNDArray.resize (dvc); - } - else - { - have_ComplexNDArray = true; - result_ComplexNDArray = - tmp(0).complex_array_value (); - result_ComplexNDArray.resize (dvc); - } - } - else if BSXINIT(boolNDArray, "logical", bool) - else if BSXINIT(int8NDArray, "int8", int8) - else if BSXINIT(int16NDArray, "int16", int16) - else if BSXINIT(int32NDArray, "int32", int32) - else if BSXINIT(int64NDArray, "int64", int64) - else if BSXINIT(uint8NDArray, "uint8", uint8) - else if BSXINIT(uint16NDArray, "uint16", uint16) - else if BSXINIT(uint32NDArray, "uint32", uint32) - else if BSXINIT(uint64NDArray, "uint64", uint64) - else - { - C = tmp (0); - C = C.resize (dvc); - } - } - } - else - { - update_index (ra_idx, dvc, i); - - if (have_FloatNDArray || - have_FloatComplexNDArray) - { - if (! tmp(0).is_float_type ()) - { - if (have_FloatNDArray) - { - have_FloatNDArray = false; - C = result_FloatNDArray; - } - else - { - have_FloatComplexNDArray = false; - C = result_FloatComplexNDArray; - } - C = do_cat_op (C, tmp(0), ra_idx); - } - else if (tmp(0).is_double_type ()) - { - if (tmp(0).is_complex_type () && - have_FloatNDArray) - { - result_ComplexNDArray = - ComplexNDArray (result_FloatNDArray); - result_ComplexNDArray.insert - (tmp(0).complex_array_value (), ra_idx); - have_FloatComplexNDArray = false; - have_ComplexNDArray = true; - } - else - { - result_NDArray = - NDArray (result_FloatNDArray); - result_NDArray.insert - (tmp(0).array_value (), ra_idx); - have_FloatNDArray = false; - have_NDArray = true; - } - } - else if (tmp(0).is_real_type ()) - result_FloatNDArray.insert - (tmp(0).float_array_value (), ra_idx); - else - { - result_FloatComplexNDArray = - FloatComplexNDArray (result_FloatNDArray); - result_FloatComplexNDArray.insert - (tmp(0).float_complex_array_value (), ra_idx); - have_FloatNDArray = false; - have_FloatComplexNDArray = true; - } - } - else if (have_NDArray) - { - if (! tmp(0).is_float_type ()) - { - have_NDArray = false; - C = result_NDArray; - C = do_cat_op (C, tmp(0), ra_idx); - } - else if (tmp(0).is_real_type ()) - result_NDArray.insert (tmp(0).array_value (), - ra_idx); - else - { - result_ComplexNDArray = - ComplexNDArray (result_NDArray); - result_ComplexNDArray.insert - (tmp(0).complex_array_value (), ra_idx); - have_NDArray = false; - have_ComplexNDArray = true; - } - } - -#define BSXLOOP(T, CLS, EXTRACTOR) \ - (have_ ## T) \ - { \ - if (tmp (0).class_name () != CLS) \ - { \ - have_ ## T = false; \ - C = result_ ## T; \ - C = do_cat_op (C, tmp (0), ra_idx); \ - } \ - else \ - result_ ## T .insert \ - (tmp(0). EXTRACTOR ## _array_value (), \ - ra_idx); \ - } - - else if BSXLOOP(ComplexNDArray, "double", complex) - else if BSXLOOP(boolNDArray, "logical", bool) - else if BSXLOOP(int8NDArray, "int8", int8) - else if BSXLOOP(int16NDArray, "int16", int16) - else if BSXLOOP(int32NDArray, "int32", int32) - else if BSXLOOP(int64NDArray, "int64", int64) - else if BSXLOOP(uint8NDArray, "uint8", uint8) - else if BSXLOOP(uint16NDArray, "uint16", uint16) - else if BSXLOOP(uint32NDArray, "uint32", uint32) - else if BSXLOOP(uint64NDArray, "uint64", uint64) - else - C = do_cat_op (C, tmp(0), ra_idx); - } - } - -#define BSXEND(T) \ - (have_ ## T) \ - retval(0) = result_ ## T; - - if BSXEND(NDArray) - else if BSXEND(ComplexNDArray) - else if BSXEND(FloatNDArray) - else if BSXEND(FloatComplexNDArray) - else if BSXEND(boolNDArray) - else if BSXEND(int8NDArray) - else if BSXEND(int16NDArray) - else if BSXEND(int32NDArray) - else if BSXEND(int64NDArray) - else if BSXEND(uint8NDArray) - else if BSXEND(uint16NDArray) - else if BSXEND(uint32NDArray) - else if BSXEND(uint64NDArray) - else - retval(0) = C; - } - } - } - } - - return retval; -} - -/* - -%!shared a, b, c, f -%! a = randn (4, 4); -%! b = mean (a, 1); -%! c = mean (a, 2); -%! f = @minus; -%!error (bsxfun (f)) -%!error (bsxfun (f, a)) -%!error (bsxfun (a, b)) -%!error (bsxfun (a, b, c)) -%!error (bsxfun (f, a, b, c)) -%!error (bsxfun (f, ones (4, 0), ones (4, 4))) -%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0)) -%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), zeros (4, 4)) -%!assert (bsxfun (f, a, b), a - repmat (b, 4, 1)) -%!assert (bsxfun (f, a, c), a - repmat (c, 1, 4)) -%!assert (bsxfun ("minus", ones (1, 4), ones (4, 1)), zeros (4, 4)) - -%!shared a, b, c, f -%! a = randn (4, 4); -%! a(1) *= 1i; -%! b = mean (a, 1); -%! c = mean (a, 2); -%! f = @minus; -%!error (bsxfun (f)) -%!error (bsxfun (f, a)) -%!error (bsxfun (a, b)) -%!error (bsxfun (a, b, c)) -%!error (bsxfun (f, a, b, c)) -%!error (bsxfun (f, ones (4, 0), ones (4, 4))) -%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0)) -%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), zeros (4, 4)) -%!assert (bsxfun (f, a, b), a - repmat (b, 4, 1)) -%!assert (bsxfun (f, a, c), a - repmat (c, 1, 4)) -%!assert (bsxfun ("minus", ones (1, 4), ones (4, 1)), zeros (4, 4)) - -%!shared a, b, c, f -%! a = randn (4, 4); -%! a(end) *= 1i; -%! b = mean (a, 1); -%! c = mean (a, 2); -%! f = @minus; -%!error (bsxfun (f)) -%!error (bsxfun (f, a)) -%!error (bsxfun (a, b)) -%!error (bsxfun (a, b, c)) -%!error (bsxfun (f, a, b, c)) -%!error (bsxfun (f, ones (4, 0), ones (4, 4))) -%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0)) -%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), zeros (4, 4)) -%!assert (bsxfun (f, a, b), a - repmat (b, 4, 1)) -%!assert (bsxfun (f, a, c), a - repmat (c, 1, 4)) -%!assert (bsxfun ("minus", ones (1, 4), ones (4, 1)), zeros (4, 4)) - -%!shared a, b, c, f -%! a = randn (4, 4); -%! b = a (1, :); -%! c = a (:, 1); -%! f = @(x, y) x == y; -%!error (bsxfun (f)) -%!error (bsxfun (f, a)) -%!error (bsxfun (a, b)) -%!error (bsxfun (a, b, c)) -%!error (bsxfun (f, a, b, c)) -%!error (bsxfun (f, ones (4, 0), ones (4, 4))) -%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0, "logical")) -%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), ones (4, 4, "logical")) -%!assert (bsxfun (f, a, b), a == repmat (b, 4, 1)) -%!assert (bsxfun (f, a, c), a == repmat (c, 1, 4)) - -%!shared a, b, c, d, f -%! a = randn (4, 4, 4); -%! b = mean (a, 1); -%! c = mean (a, 2); -%! d = mean (a, 3); -%! f = @minus; -%!error (bsxfun (f, ones ([4, 0, 4]), ones ([4, 4, 4]))) -%!assert (bsxfun (f, ones ([4, 0, 4]), ones ([4, 1, 4])), zeros ([4, 0, 4])) -%!assert (bsxfun (f, ones ([4, 4, 0]), ones ([4, 1, 1])), zeros ([4, 4, 0])) -%!assert (bsxfun (f, ones ([1, 4, 4]), ones ([4, 1, 4])), zeros ([4, 4, 4])) -%!assert (bsxfun (f, ones ([4, 4, 1]), ones ([4, 1, 4])), zeros ([4, 4, 4])) -%!assert (bsxfun (f, ones ([4, 1, 4]), ones ([1, 4, 4])), zeros ([4, 4, 4])) -%!assert (bsxfun (f, ones ([4, 1, 4]), ones ([1, 4, 1])), zeros ([4, 4, 4])) -%!assert (bsxfun (f, a, b), a - repmat (b, [4, 1, 1])) -%!assert (bsxfun (f, a, c), a - repmat (c, [1, 4, 1])) -%!assert (bsxfun (f, a, d), a - repmat (d, [1, 1, 4])) -%!assert (bsxfun ("minus", ones ([4, 0, 4]), ones ([4, 1, 4])), zeros ([4, 0, 4])) - -%% The test below is a very hard case to treat -%!assert (bsxfun (f, ones ([4, 1, 4, 1]), ones ([1, 4, 1, 4])), zeros ([4, 4, 4, 4])); - -%!shared a, b, aa, bb -%! a = randn (3, 1, 3); -%! aa = a(:, ones (1, 3), :, ones (1, 3)); -%! b = randn (1, 3, 3, 3); -%! bb = b(ones (1, 3), :, :, :); -%!assert (bsxfun (@plus, a, b), aa + bb) -%!assert (bsxfun (@minus, a, b), aa - bb) -%!assert (bsxfun (@times, a, b), aa .* bb) -%!assert (bsxfun (@rdivide, a, b), aa ./ bb) -%!assert (bsxfun (@ldivide, a, b), aa .\ bb) -%!assert (bsxfun (@power, a, b), aa .^ bb) -%!assert (bsxfun (@power, abs (a), b), abs (aa) .^ bb) -%!assert (bsxfun (@eq, round (a), round (b)), round (aa) == round (bb)) -%!assert (bsxfun (@ne, round (a), round (b)), round (aa) != round (bb)) -%!assert (bsxfun (@lt, a, b), aa < bb) -%!assert (bsxfun (@le, a, b), aa <= bb) -%!assert (bsxfun (@gt, a, b), aa > bb) -%!assert (bsxfun (@ge, a, b), aa >= bb) -%!assert (bsxfun (@min, a, b), min (aa, bb)) -%!assert (bsxfun (@max, a, b), max (aa, bb)) -%!assert (bsxfun (@and, a > 0, b > 0), (aa > 0) & (bb > 0)) -%!assert (bsxfun (@or, a > 0, b > 0), (aa > 0) | (bb > 0)) - -%% Test automatic bsxfun -% -%!test -%! funs = {@plus, @minus, @times, @rdivide, @ldivide, @power, @max, @min, \ -%! @rem, @mod, @atan2, @hypot, @eq, @ne, @lt, @le, @gt, @ge, \ -%! @and, @or, @xor }; -%! -%! float_types = {@single, @double}; -%! int_types = {@int8, @int16, @int32, @int64, \ -%! @uint8, @uint16, @uint32, @uint64}; -%! -%! x = rand (3) * 10-5; -%! y = rand (3,1) * 10-5; -%! -%! for i=1:length (funs) -%! for j = 1:length (float_types) -%! for k = 1:length (int_types) -%! -%! fun = funs{i}; -%! f_type = float_types{j}; -%! i_type = int_types{k}; -%! -%! assert (bsxfun (fun, f_type (x), i_type (y)), \ -%! fun (f_type(x), i_type (y))); -%! assert (bsxfun (fun, f_type (y), i_type (x)), \ -%! fun (f_type(y), i_type (x))); -%! -%! assert (bsxfun (fun, i_type (x), i_type (y)), \ -%! fun (i_type (x), i_type (y))); -%! assert (bsxfun (fun, i_type (y), i_type (x)), \ -%! fun (i_type (y), i_type (x))); -%! -%! assert (bsxfun (fun, f_type (x), f_type (y)), \ -%! fun (f_type (x), f_type (y))); -%! assert (bsxfun (fun, f_type(y), f_type(x)), \ -%! fun (f_type (y), f_type (x))); -%! endfor -%! endfor -%! endfor -%! -*/
--- a/src/DLD-FUNCTIONS/ccolamd.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/DLD-FUNCTIONS/ccolamd.cc Sat Jul 28 12:06:34 2012 -0400 @@ -164,53 +164,53 @@ int nel_User_knobs = User_knobs.length (); if (nel_User_knobs > 0) - knobs [CCOLAMD_LU] = (User_knobs (0) != 0); + knobs[CCOLAMD_LU] = (User_knobs(0) != 0); if (nel_User_knobs > 1) - knobs [CCOLAMD_DENSE_ROW] = User_knobs (1); + knobs[CCOLAMD_DENSE_ROW] = User_knobs(1); if (nel_User_knobs > 2) - knobs [CCOLAMD_DENSE_COL] = User_knobs (2); + knobs[CCOLAMD_DENSE_COL] = User_knobs(2); if (nel_User_knobs > 3) - knobs [CCOLAMD_AGGRESSIVE] = (User_knobs (3) != 0); + knobs[CCOLAMD_AGGRESSIVE] = (User_knobs(3) != 0); if (nel_User_knobs > 4) - spumoni = (User_knobs (4) != 0); + spumoni = (User_knobs(4) != 0); // print knob settings if spumoni is set if (spumoni) { octave_stdout << "\nccolamd version " << CCOLAMD_MAIN_VERSION << "." << CCOLAMD_SUB_VERSION << ", " << CCOLAMD_DATE - << ":\nknobs(1): " << User_knobs (0) << ", order for "; - if ( knobs [CCOLAMD_LU] != 0) + << ":\nknobs(1): " << User_knobs(0) << ", order for "; + if (knobs[CCOLAMD_LU] != 0) octave_stdout << "lu (A)\n"; else octave_stdout << "chol (A'*A)\n"; - if (knobs [CCOLAMD_DENSE_ROW] >= 0) - octave_stdout << "knobs(2): " << User_knobs (1) + if (knobs[CCOLAMD_DENSE_ROW] >= 0) + octave_stdout << "knobs(2): " << User_knobs(1) << ", rows with > max (16," - << knobs [CCOLAMD_DENSE_ROW] << "*sqrt (size(A,2)))" + << knobs[CCOLAMD_DENSE_ROW] << "*sqrt (size(A,2)))" << " entries removed\n"; else - octave_stdout << "knobs(2): " << User_knobs (1) + octave_stdout << "knobs(2): " << User_knobs(1) << ", no dense rows removed\n"; - if (knobs [CCOLAMD_DENSE_COL] >= 0) - octave_stdout << "knobs(3): " << User_knobs (2) + if (knobs[CCOLAMD_DENSE_COL] >= 0) + octave_stdout << "knobs(3): " << User_knobs(2) << ", cols with > max (16," - << knobs [CCOLAMD_DENSE_COL] << "*sqrt (size(A)))" + << knobs[CCOLAMD_DENSE_COL] << "*sqrt (size(A)))" << " entries removed\n"; else - octave_stdout << "knobs(3): " << User_knobs (2) + octave_stdout << "knobs(3): " << User_knobs(2) << ", no dense columns removed\n"; - if (knobs [CCOLAMD_AGGRESSIVE] != 0) + if (knobs[CCOLAMD_AGGRESSIVE] != 0) octave_stdout << "knobs(4): " << User_knobs(3) << ", aggressive absorption: yes"; else octave_stdout << "knobs(4): " << User_knobs(3) << ", aggressive absorption: no"; - octave_stdout << "knobs(5): " << User_knobs (4) + octave_stdout << "knobs(5): " << User_knobs(4) << ", statistics and knobs printed\n"; } } @@ -259,12 +259,12 @@ // Allocate workspace for ccolamd OCTAVE_LOCAL_BUFFER (octave_idx_type, p, n_col+1); for (octave_idx_type i = 0; i < n_col+1; i++) - p[i] = cidx [i]; + p[i] = cidx[i]; octave_idx_type Alen = CCOLAMD_NAME (_recommended) (nnz, n_row, n_col); OCTAVE_LOCAL_BUFFER (octave_idx_type, A, Alen); for (octave_idx_type i = 0; i < nnz; i++) - A[i] = ridx [i]; + A[i] = ridx[i]; OCTAVE_LOCAL_BUFFER (octave_idx_type, stats, CCOLAMD_STATS); @@ -315,7 +315,7 @@ { NDArray out_stats (dim_vector (1, CCOLAMD_STATS)); for (octave_idx_type i = 0 ; i < CCOLAMD_STATS ; i++) - out_stats (i) = stats [i] ; + out_stats(i) = stats[i] ; retval(1) = out_stats; // fix stats (5) and (6), for 1-based information on @@ -419,11 +419,11 @@ int nel_User_knobs = User_knobs.length (); if (nel_User_knobs > 0) - knobs [CCOLAMD_DENSE_ROW] = User_knobs (0); + knobs[CCOLAMD_DENSE_ROW] = User_knobs(0); if (nel_User_knobs > 0) - knobs [CCOLAMD_AGGRESSIVE] = User_knobs (1); + knobs[CCOLAMD_AGGRESSIVE] = User_knobs(1); if (nel_User_knobs > 1) - spumoni = static_cast<int> (User_knobs (2)); + spumoni = static_cast<int> (User_knobs(2)); // print knob settings if spumoni is set if (spumoni) @@ -431,16 +431,16 @@ octave_stdout << "\ncsymamd version " << CCOLAMD_MAIN_VERSION << "." << CCOLAMD_SUB_VERSION << ", " << CCOLAMD_DATE << "\n"; - if (knobs [CCOLAMD_DENSE_ROW] >= 0) - octave_stdout << "knobs(1): " << User_knobs (0) + if (knobs[CCOLAMD_DENSE_ROW] >= 0) + octave_stdout << "knobs(1): " << User_knobs(0) << ", rows/cols with > max (16," - << knobs [CCOLAMD_DENSE_ROW] << "*sqrt (size(A,2)))" + << knobs[CCOLAMD_DENSE_ROW] << "*sqrt (size(A,2)))" << " entries removed\n"; else - octave_stdout << "knobs(1): " << User_knobs (0) + octave_stdout << "knobs(1): " << User_knobs(0) << ", no dense rows/cols removed\n"; - if (knobs [CCOLAMD_AGGRESSIVE] != 0) + if (knobs[CCOLAMD_AGGRESSIVE] != 0) octave_stdout << "knobs(2): " << User_knobs(1) << ", aggressive absorption: yes"; else @@ -448,7 +448,7 @@ << ", aggressive absorption: no"; - octave_stdout << "knobs(3): " << User_knobs (2) + octave_stdout << "knobs(3): " << User_knobs(2) << ", statistics and knobs printed\n"; } } @@ -543,7 +543,7 @@ { NDArray out_stats (dim_vector (1, CCOLAMD_STATS)); for (octave_idx_type i = 0 ; i < CCOLAMD_STATS ; i++) - out_stats (i) = stats [i] ; + out_stats(i) = stats[i] ; retval(1) = out_stats; // fix stats (5) and (6), for 1-based information on @@ -562,7 +562,7 @@ { NDArray out_stats (dim_vector (1, CCOLAMD_STATS)); for (octave_idx_type i = 0 ; i < CCOLAMD_STATS ; i++) - out_stats (i) = stats [i] ; + out_stats(i) = stats[i] ; retval(1) = out_stats; // fix stats (5) and (6), for 1-based information on
--- a/src/DLD-FUNCTIONS/cellfun.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2472 +0,0 @@ -/* - -Copyright (C) 2005-2012 Mohamed Kamoun -Copyright (C) 2006-2012 Bill Denney -Copyright (C) 2009 Jaroslav Hajek -Copyright (C) 2010 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> -#include <vector> -#include <list> -#include <memory> - -#include "caseless-str.h" -#include "lo-mappers.h" -#include "oct-locbuf.h" - -#include "Cell.h" -#include "oct-map.h" -#include "defun-dld.h" -#include "parse.h" -#include "variables.h" -#include "ov-colon.h" -#include "unwind-prot.h" -#include "gripes.h" -#include "utils.h" - -#include "ov-class.h" -#include "ov-scalar.h" -#include "ov-float.h" -#include "ov-complex.h" -#include "ov-flt-complex.h" -#include "ov-bool.h" -#include "ov-int8.h" -#include "ov-int16.h" -#include "ov-int32.h" -#include "ov-int64.h" -#include "ov-uint8.h" -#include "ov-uint16.h" -#include "ov-uint32.h" -#include "ov-uint64.h" - -#include "ov-fcn-handle.h" - -static octave_value_list -get_output_list (octave_idx_type count, octave_idx_type nargout, - const octave_value_list& inputlist, - octave_value& func, - octave_value& error_handler) -{ - octave_value_list tmp = func.do_multi_index_op (nargout, inputlist); - - if (error_state) - { - if (error_handler.is_defined ()) - { - octave_scalar_map msg; - msg.assign ("identifier", last_error_id ()); - msg.assign ("message", last_error_message ()); - msg.assign ("index", static_cast<double> (count + static_cast<octave_idx_type>(1))); - - octave_value_list errlist = inputlist; - errlist.prepend (msg); - - buffer_error_messages--; - - error_state = 0; - - tmp = error_handler.do_multi_index_op (nargout, errlist); - - buffer_error_messages++; - - if (error_state) - tmp.clear (); - } - else - tmp.clear (); - } - - return tmp; -} - -static octave_value_list -try_cellfun_internal_ops (const octave_value_list& args, int nargin) -{ - octave_value_list retval; - - std::string name = args(0).string_value (); - - const Cell f_args = args(1).cell_value (); - - octave_idx_type k = f_args.numel (); - - if (name == "isempty") - { - boolNDArray result (f_args.dims ()); - for (octave_idx_type count = 0; count < k; count++) - result(count) = f_args.elem (count).is_empty (); - retval(0) = result; - } - else if (name == "islogical") - { - boolNDArray result (f_args.dims ()); - for (octave_idx_type count= 0; count < k; count++) - result(count) = f_args.elem (count).is_bool_type (); - retval(0) = result; - } - else if (name == "isreal") - { - boolNDArray result (f_args.dims ()); - for (octave_idx_type count= 0; count < k; count++) - result(count) = f_args.elem (count).is_real_type (); - retval(0) = result; - } - else if (name == "length") - { - NDArray result (f_args.dims ()); - for (octave_idx_type count= 0; count < k; count++) - result(count) = static_cast<double> (f_args.elem (count).length ()); - retval(0) = result; - } - else if (name == "ndims") - { - NDArray result (f_args.dims ()); - for (octave_idx_type count = 0; count < k; count++) - result(count) = static_cast<double> (f_args.elem (count).ndims ()); - retval(0) = result; - } - else if (name == "prodofsize" || name == "numel") - { - NDArray result (f_args.dims ()); - for (octave_idx_type count = 0; count < k; count++) - result(count) = static_cast<double> (f_args.elem (count).numel ()); - retval(0) = result; - } - else if (name == "size") - { - if (nargin == 3) - { - int d = args(2).nint_value () - 1; - - if (d < 0) - error ("cellfun: K must be a positive integer"); - - if (! error_state) - { - NDArray result (f_args.dims ()); - for (octave_idx_type count = 0; count < k; count++) - { - dim_vector dv = f_args.elem (count).dims (); - if (d < dv.length ()) - result(count) = static_cast<double> (dv(d)); - else - result(count) = 1.0; - } - retval(0) = result; - } - } - else - error ("cellfun: not enough arguments for \"size\""); - } - else if (name == "isclass") - { - if (nargin == 3) - { - std::string class_name = args(2).string_value (); - boolNDArray result (f_args.dims ()); - for (octave_idx_type count = 0; count < k; count++) - result(count) = (f_args.elem (count).class_name () == class_name); - - retval(0) = result; - } - else - error ("cellfun: not enough arguments for \"isclass\""); - } - - return retval; -} - -static void -get_mapper_fun_options (const octave_value_list& args, int& nargin, - bool& uniform_output, octave_value& error_handler) -{ - while (nargin > 3 && args(nargin-2).is_string ()) - { - caseless_str arg = args(nargin-2).string_value (); - - size_t compare_len = std::max (arg.length (), static_cast<size_t> (2)); - - if (arg.compare ("uniformoutput", compare_len)) - uniform_output = args(nargin-1).bool_value (); - else if (arg.compare ("errorhandler", compare_len)) - { - if (args(nargin-1).is_function_handle () - || args(nargin-1).is_inline_function ()) - { - error_handler = args(nargin-1); - } - else if (args(nargin-1).is_string ()) - { - std::string err_name = args(nargin-1).string_value (); - - error_handler = symbol_table::find_function (err_name); - - if (error_handler.is_undefined ()) - { - error ("cellfun: invalid function NAME: %s", - err_name.c_str ()); - break; - } - } - else - { - error ("cellfun: invalid value for 'ErrorHandler' function"); - break; - } - } - else - { - error ("cellfun: unrecognized parameter %s", - arg.c_str ()); - break; - } - - nargin -= 2; - } - - nargin -= 1; -} - -DEFUN_DLD (cellfun, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} cellfun (@var{name}, @var{C})\n\ -@deftypefnx {Loadable Function} {} cellfun (\"size\", @var{C}, @var{k})\n\ -@deftypefnx {Loadable Function} {} cellfun (\"isclass\", @var{C}, @var{class})\n\ -@deftypefnx {Loadable Function} {} cellfun (@var{func}, @var{C})\n\ -@deftypefnx {Loadable Function} {} cellfun (@var{func}, @var{C}, @var{D})\n\ -@deftypefnx {Loadable Function} {[@var{a}, @dots{}] =} cellfun (@dots{})\n\ -@deftypefnx {Loadable Function} {} cellfun (@dots{}, \"ErrorHandler\", @var{errfunc})\n\ -@deftypefnx {Loadable Function} {} cellfun (@dots{}, \"UniformOutput\", @var{val})\n\ -\n\ -Evaluate the function named @var{name} on the elements of the cell array\n\ -@var{C}. Elements in @var{C} are passed on to the named function\n\ -individually. The function @var{name} can be one of the functions\n\ -\n\ -@table @code\n\ -@item isempty\n\ -Return 1 for empty elements.\n\ -\n\ -@item islogical\n\ -Return 1 for logical elements.\n\ -\n\ -@item isreal\n\ -Return 1 for real elements.\n\ -\n\ -@item length\n\ -Return a vector of the lengths of cell elements.\n\ -\n\ -@item ndims\n\ -Return the number of dimensions of each element.\n\ -\n\ -@item numel\n\ -@itemx prodofsize\n\ -Return the number of elements contained within each cell element. The\n\ -number is the product of the dimensions of the object at each cell element.\n\ -\n\ -@item size\n\ -Return the size along the @var{k}-th dimension.\n\ -\n\ -@item isclass\n\ -Return 1 for elements of @var{class}.\n\ -@end table\n\ -\n\ -Additionally, @code{cellfun} accepts an arbitrary function @var{func}\n\ -in the form of an inline function, function handle, or the name of a\n\ -function (in a character string). In the case of a character string\n\ -argument, the function must accept a single argument named @var{x}, and\n\ -it must return a string value. The function can take one or more arguments,\n\ -with the inputs arguments given by @var{C}, @var{D}, etc. Equally the\n\ -function can return one or more output arguments. For example:\n\ -\n\ -@example\n\ -@group\n\ -cellfun (\"atan2\", @{1, 0@}, @{0, 1@})\n\ - @result{} [ 1.57080 0.00000 ]\n\ -@end group\n\ -@end example\n\ -\n\ -The number of output arguments of @code{cellfun} matches the number of output\n\ -arguments of the function. The outputs of the function will be collected\n\ -into the output arguments of @code{cellfun} like this:\n\ -\n\ -@example\n\ -@group\n\ -function [a, b] = twoouts (x)\n\ - a = x;\n\ - b = x*x;\n\ -endfunction\n\ -[aa, bb] = cellfun (@@twoouts, @{1, 2, 3@})\n\ - @result{}\n\ - aa =\n\ - 1 2 3\n\ - bb =\n\ - 1 4 9\n\ -@end group\n\ -@end example\n\ -\n\ -Note that per default the output argument(s) are arrays of the same size as\n\ -the input arguments. Input arguments that are singleton (1x1) cells will be\n\ -automatically expanded to the size of the other arguments.\n\ -\n\ -If the parameter \"UniformOutput\" is set to true (the default), then the\n\ -function must return scalars which will be concatenated into the return\n\ -array(s). If \"UniformOutput\" is false, the outputs are concatenated into a\n\ -cell array (or cell arrays). For example:\n\ -\n\ -@example\n\ -@group\n\ -cellfun (\"tolower\", @{\"Foo\", \"Bar\", \"FooBar\"@},\n\ - \"UniformOutput\", false)\n\ -@result{} @{\"foo\", \"bar\", \"foobar\"@}\n\ -@end group\n\ -@end example\n\ -\n\ -Given the parameter \"ErrorHandler\", then @var{errfunc} defines a function\n\ -to call in case @var{func} generates an error. The form of the function is\n\ -\n\ -@example\n\ -function [@dots{}] = errfunc (@var{s}, @dots{})\n\ -@end example\n\ -\n\ -@noindent\n\ -where there is an additional input argument to @var{errfunc} relative to\n\ -@var{func}, given by @var{s}. This is a structure with the elements\n\ -'identifier', 'message' and 'index', giving respectively the error\n\ -identifier, the error message, and the index into the input arguments\n\ -of the element that caused the error. For example:\n\ -\n\ -@example\n\ -@group\n\ -function y = foo (s, x), y = NaN; endfunction\n\ -cellfun (\"factorial\", @{-1,2@}, \"ErrorHandler\", @@foo)\n\ -@result{} [NaN 2]\n\ -@end group\n\ -@end example\n\ -\n\ -Use @code{cellfun} intelligently. The @code{cellfun} function is a\n\ -useful tool for avoiding loops. It is often used with anonymous\n\ -function handles; however, calling an anonymous function involves an\n\ -overhead quite comparable to the overhead of an m-file function.\n\ -Passing a handle to a built-in function is faster, because the\n\ -interpreter is not involved in the internal loop. For example:\n\ -\n\ -@example\n\ -@group\n\ -a = @{@dots{}@}\n\ -v = cellfun (@@(x) det (x), a); # compute determinants\n\ -v = cellfun (@@det, a); # faster\n\ -@end group\n\ -@end example\n\ -\n\ -@seealso{arrayfun, structfun, spfun}\n\ -@end deftypefn") -{ - octave_value_list retval; - int nargin = args.length (); - int nargout1 = (nargout < 1 ? 1 : nargout); - - if (nargin < 2) - { - error ("cellfun: function requires at least 2 arguments"); - print_usage (); - return retval; - } - - octave_value func = args(0); - - if (! args(1).is_cell ()) - { - error ("cellfun: C must be a cell array"); - - return retval; - } - - if (func.is_string ()) - { - retval = try_cellfun_internal_ops (args, nargin); - - if (error_state || ! retval.empty ()) - return retval; - - // See if we can convert the string into a function. - - std::string name = args(0).string_value (); - - if (! valid_identifier (name)) - { - std::string fcn_name = unique_symbol_name ("__cellfun_fcn_"); - std::string fname = "function y = " + fcn_name + "(x) y = "; - - octave_function *ptr_func - = extract_function (args(0), "cellfun", fcn_name, - fname, "; endfunction"); - - if (ptr_func && ! error_state) - func = octave_value (ptr_func, true); - } - else - { - func = symbol_table::find_function (name); - - if (func.is_undefined ()) - error ("cellfun: invalid function NAME: %s", name.c_str ()); - } - - if (error_state || ! retval.empty ()) - return retval; - } - - if (func.is_function_handle () || func.is_inline_function () - || func.is_function ()) - { - - // The following is an optimisation because the symbol table can - // give a more specific function class, so this can result in - // fewer polymorphic function calls as the function gets called - // for each value of the array. - { - if (func.is_function_handle ()) - { - octave_fcn_handle* f = func.fcn_handle_value (); - - // Overloaded function handles need to check the type of the - // arguments for each element of the array, so they cannot - // be optimised this way. - if (f -> is_overloaded ()) - goto nevermind; - } - - std::string name = func.function_value () -> name (); - octave_value f = symbol_table::find_function (name); - - if (f.is_defined ()) - { - //Except for these two which are special cases... - if (name != "size" && name != "class") - { - //Try first the optimised code path for built-in functions - octave_value_list tmp_args = args; - tmp_args(0) = name; - retval = try_cellfun_internal_ops (tmp_args, nargin); - if (error_state || ! retval.empty ()) - return retval; - } - - //Okay, we tried, doesn't work, let's do the best we can - //instead and avoid polymorphic calls for each element of - //the array. - func = f; - } - } - nevermind: - - bool uniform_output = true; - octave_value error_handler; - - get_mapper_fun_options (args, nargin, uniform_output, error_handler); - - if (error_state) - return octave_value_list (); - - // Extract cell arguments. - - octave_value_list inputlist (nargin, octave_value ()); - - OCTAVE_LOCAL_BUFFER (Cell, inputs, nargin); - OCTAVE_LOCAL_BUFFER (bool, mask, nargin); - - // This is to prevent copy-on-write. - const Cell *cinputs = inputs; - - octave_idx_type k = 1; - - dim_vector fdims (1, 1); - - // Collect arguments. Pre-fill scalar elements of inputlist - // array. - - for (int j = 0; j < nargin; j++) - { - if (! args(j+1).is_cell ()) - { - error ("cellfun: arguments must be cells"); - return octave_value_list (); - } - - inputs[j] = args(j+1).cell_value (); - mask[j] = inputs[j].numel () != 1; - if (! mask[j]) - inputlist(j) = cinputs[j](0); - } - - for (int j = 0; j < nargin; j++) - { - if (mask[j]) - { - fdims = inputs[j].dims (); - k = inputs[j].numel (); - for (int i = j+1; i < nargin; i++) - { - if (mask[i] && inputs[i].dims () != fdims) - { - error ("cellfun: dimensions mismatch"); - return octave_value_list (); - } - } - break; - } - } - - unwind_protect frame; - frame.protect_var (buffer_error_messages); - - if (error_handler.is_defined ()) - buffer_error_messages++; - - // Apply functions. - - if (uniform_output) - { - std::list<octave_value_list> idx_list (1); - idx_list.front ().resize (1); - std::string idx_type = "("; - - OCTAVE_LOCAL_BUFFER (octave_value, retv, nargout1); - - for (octave_idx_type count = 0; count < k; count++) - { - for (int j = 0; j < nargin; j++) - { - if (mask[j]) - inputlist.xelem (j) = cinputs[j](count); - } - - const octave_value_list tmp - = get_output_list (count, nargout, inputlist, func, - error_handler); - - if (error_state) - return retval; - - if (nargout > 0 && tmp.length () < nargout) - { - error ("cellfun: function returned fewer than nargout values"); - return retval; - } - - if (nargout > 0 - || (nargout == 0 - && tmp.length () > 0 && tmp(0).is_defined ())) - { - int num_to_copy = tmp.length (); - - if (num_to_copy > nargout1) - num_to_copy = nargout1; - - if (count == 0) - { - for (int j = 0; j < num_to_copy; j++) - { - if (tmp(j).is_defined ()) - { - octave_value val = tmp(j); - - if (val.numel () == 1) - retv[j] = val.resize (fdims); - else - { - error ("cellfun: all values must be scalars when UniformOutput = true"); - break; - } - } - } - } - else - { - for (int j = 0; j < num_to_copy; j++) - { - if (tmp(j).is_defined ()) - { - octave_value val = tmp(j); - - if (! retv[j].fast_elem_insert (count, val)) - { - if (val.numel () == 1) - { - idx_list.front ()(0) = count + 1.0; - retv[j].assign (octave_value::op_asn_eq, - idx_type, idx_list, val); - - if (error_state) - break; - } - else - { - error ("cellfun: all values must be scalars when UniformOutput = true"); - break; - } - } - } - } - } - } - - if (error_state) - break; - } - - retval.resize (nargout1); - - for (int j = 0; j < nargout1; j++) - { - if (nargout > 0 && retv[j].is_undefined ()) - retval(j) = NDArray (fdims); - else - retval(j) = retv[j]; - } - } - else - { - OCTAVE_LOCAL_BUFFER (Cell, results, nargout1); - - for (int j = 0; j < nargout1; j++) - results[j].resize (fdims, Matrix ()); - - bool have_some_output = false; - - for (octave_idx_type count = 0; count < k; count++) - { - for (int j = 0; j < nargin; j++) - { - if (mask[j]) - inputlist.xelem (j) = cinputs[j](count); - } - - const octave_value_list tmp - = get_output_list (count, nargout, inputlist, func, - error_handler); - - if (error_state) - return retval; - - if (nargout > 0 && tmp.length () < nargout) - { - error ("cellfun: function returned fewer than nargout values"); - return retval; - } - - if (nargout > 0 - || (nargout == 0 - && tmp.length () > 0 && tmp(0).is_defined ())) - { - int num_to_copy = tmp.length (); - - if (num_to_copy > nargout1) - num_to_copy = nargout1; - - if (num_to_copy > 0) - have_some_output = true; - - for (int j = 0; j < num_to_copy; j++) - results[j](count) = tmp(j); - } - } - - if (have_some_output || fdims.any_zero ()) - { - retval.resize (nargout1); - - for (int j = 0; j < nargout1; j++) - retval(j) = results[j]; - } - } - } - else - error ("cellfun: argument NAME must be a string or function handle"); - - return retval; -} - -/* - -%!function r = __f11 (x) -%! global __cellfun_test_num_outputs__; -%! __cellfun_test_num_outputs__ = nargout; -%! r = x; -%!endfunction - -%!function __f01 (x) -%! global __cellfun_test_num_outputs__; -%! __cellfun_test_num_outputs__ = nargout; -%!endfunction - -%!test -%! global __cellfun_test_num_outputs__; -%! cellfun (@__f11, {1}); -%! assert (__cellfun_test_num_outputs__, 0); -%! x = cellfun (@__f11, {1}); -%! assert (__cellfun_test_num_outputs__, 1); - -%!test -%! global __cellfun_test_num_outputs__; -%! cellfun (@__f01, {1}); -%! assert (__cellfun_test_num_outputs__, 0); - -%!error x = cellfun (@__f01, {1, 2}); - -%!test -%! assert (cellfun (@__f11, {1, 2}), [1, 2]); -%! assert (cellfun (@__f11, {1, 2}, 'uniformoutput', false), {1, 2}); - -%!test -%! [a,b] = cellfun (@(x) x, cell (2, 0)); -%! assert (a, zeros (2, 0)); -%! assert (b, zeros (2, 0)); - -%!test -%! [a,b] = cellfun (@(x) x, cell (2, 0), "uniformoutput", false); -%! assert (a, cell (2, 0)); -%! assert (b, cell (2, 0)); - -%% Test function to check the "Errorhandler" option -%!function z = __cellfunerror (S, varargin) -%! z = S; -%!endfunction - -%% First input argument can be a string, an inline function, -%% a function_handle or an anonymous function -%!test -%! A = cellfun ("islogical", {true, 0.1, false, i*2}); -%! assert (A, [true, false, true, false]); -%!test -%! A = cellfun (inline ("islogical (x)", "x"), {true, 0.1, false, i*2}); -%! assert (A, [true, false, true, false]); -%!test -%! A = cellfun (@islogical, {true, 0.1, false, i*2}); -%! assert (A, [true, false, true, false]); -%!test -%! A = cellfun (@(x) islogical (x), {true, 0.1, false, i*2}); -%! assert (A, [true, false, true, false]); - -%% First input argument can be the special string "isreal", -%% "isempty", "islogical", "length", "ndims" or "prodofsize" -%!test -%! A = cellfun ("isreal", {true, 0.1, {}, i*2, [], "abc"}); -%! assert (A, [true, true, false, false, true, true]); -%!test -%! A = cellfun ("isempty", {true, 0.1, false, i*2, [], "abc"}); -%! assert (A, [false, false, false, false, true, false]); -%!test -%! A = cellfun ("islogical", {true, 0.1, false, i*2, [], "abc"}); -%! assert (A, [true, false, true, false, false, false]); -%!test -%! A = cellfun ("length", {true, 0.1, false, i*2, [], "abc"}); -%! assert (A, [1, 1, 1, 1, 0, 3]); -%!test -%! A = cellfun ("ndims", {[1, 2; 3, 4]; (cell (1,2,3,4))}); -%! assert (A, [2; 4]); -%!test -%! A = cellfun ("prodofsize", {[1, 2; 3, 4], (cell (1,2,3,4))}); -%! assert (A, [4, 24]); - -%% Number of input and output arguments may not be limited to one -%!test -%! A = cellfun (@(x,y,z) x + y + z, {1, 1, 1}, {2, 2, 2}, {3, 4, 5}); -%! assert (A, [6, 7, 8]); -%!test -%! A = cellfun (@(x,y,z) x + y + z, {1, 1, 1}, {2, 2, 2}, {3, 4, 5}, \ -%! "UniformOutput", false); -%! assert (A, {6, 7, 8}); -%!test %% Two input arguments of different types -%! A = cellfun (@(x,y) islogical (x) && ischar (y), {false, true}, {"a", 3}); -%! assert (A, [true, false]); -%!test %% Pass another variable to the anonymous function -%! y = true; -%! A = cellfun (@(x) islogical (x) && y, {false, 0.3}); -%! assert (A, [true, false]); -%!test %% Three ouptut arguments of different type -%! [A, B, C] = cellfun (@find, {10, 11; 0, 12}, "UniformOutput", false); -%! assert (isequal (A, {true, true; [], true})); -%! assert (isequal (B, {true, true; [], true})); -%! assert (isequal (C, {10, 11; [], 12})); - -%% Input arguments can be of type cell array of logical -%!test -%! A = cellfun (@(x,y) x == y, {false, true}, {true, true}); -%! assert (A, [false, true]); -%!test -%! A = cellfun (@(x,y) x == y, {false; true}, {true; true}, \ -%! "UniformOutput", true); -%! assert (A, [false; true]); -%!test -%! A = cellfun (@(x) x, {false, true; false, true}, "UniformOutput", false); -%! assert (A, {false, true; false, true}); -%!test %% Three ouptut arguments of same type -%! [A, B, C] = cellfun (@find, {true, false; false, true}, \ -%! "UniformOutput", false); -%! assert (isequal (A, {true, []; [], true})); -%! assert (isequal (B, {true, []; [], true})); -%! assert (isequal (C, {true, []; [], true})); -%!test -%! A = cellfun (@(x,y) cell2str (x,y), {true}, {true}, \ -%! "ErrorHandler", @__cellfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); -%!test %% Overwriting setting of "UniformOutput" true -%! A = cellfun (@(x,y) cell2str (x,y), {true}, {true}, \ -%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); - -%% Input arguments can be of type cell array of numeric -%!test -%! A = cellfun (@(x,y) x>y, {1.1, 4.2}, {3.1, 2+3*i}); -%! assert (A, [false, true]); -%!test -%! A = cellfun (@(x,y) x>y, {1.1, 4.2; 2, 4}, {3.1, 2; 2, 4+2*i}, \ -%! "UniformOutput", true); -%! assert (A, [false, true; false, false]); -%!test -%! A = cellfun (@(x,y) x:y, {1.1, 4}, {3.1, 6}, "UniformOutput", false); -%! assert (isequal (A{1}, [1.1, 2.1, 3.1])); -%! assert (isequal (A{2}, [4, 5, 6])); -%!test %% Three ouptut arguments of different type -%! [A, B, C] = cellfun (@find, {10, 11; 0, 12}, "UniformOutput", false); -%! assert (isequal (A, {true, true; [], true})); -%! assert (isequal (B, {true, true; [], true})); -%! assert (isequal (C, {10, 11; [], 12})); -%!test -%! A = cellfun (@(x,y) cell2str (x,y), {1.1, 4}, {3.1, 6}, \ -%! "ErrorHandler", @__cellfunerror); -%! B = isfield (A(1), "message") && isfield (A(1), "index"); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); -%!test %% Overwriting setting of "UniformOutput" true -%! A = cellfun (@(x,y) cell2str (x,y), {1.1, 4}, {3.1, 6}, \ -%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); -%! B = isfield (A(1), "message") && isfield (A(1), "index"); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); - -%% Input arguments can be of type cell arrays of character or strings -%!error %% "UniformOutput" false should be used -%! A = cellfun (@(x,y) x>y, {"ad", "c", "ghi"}, {"cc", "d", "fgh"}); -%!test -%! A = cellfun (@(x,y) x>y, {"a"; "f"}, {"c"; "d"}, "UniformOutput", true); -%! assert (A, [false; true]); -%!test -%! A = cellfun (@(x,y) x:y, {"a", "d"}, {"c", "f"}, "UniformOutput", false); -%! assert (A, {"abc", "def"}); -%!test -%! A = cellfun (@(x,y) cell2str (x,y), {"a", "d"}, {"c", "f"}, \ -%! "ErrorHandler", @__cellfunerror); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); -%!test %% Overwriting setting of "UniformOutput" true -%! A = cellfun (@(x,y) cell2str (x,y), {"a", "d"}, {"c", "f"}, \ -%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); - -%% Structures cannot be handled by cellfun -%!error -%! vst1.a = 1.1; vst1.b = 4.2; vst2.a = 3.1; vst2.b = 2; -%! A = cellfun (@(x,y) (x.a < y.a) && (x.b > y.b), vst1, vst2); - -%% Input arguments can be of type cell array of cell arrays -%!test -%! A = cellfun (@(x,y) x{1} < y{1}, {{1.1}, {4.2}}, {{3.1}, {2}}); -%! assert (A, [1, 0], 1e-16); -%!test -%! A = cellfun (@(x,y) x{1} < y{1}, {{1.1}; {4.2}}, {{3.1}; {2}}, \ -%! "UniformOutput", true); -%! assert (A, [1; 0], 1e-16); -%!test -%! A = cellfun (@(x,y) x{1} < y{1}, {{1.1}, {4.2}}, {{3.1}, {2}}, \ -%! "UniformOutput", false); -%! assert (A, {true, false}); -%!test -%! A = cellfun (@(x,y) mat2str (x,y), {{1.1}, {4.2}}, {{3.1}, {2}}, \ -%! "ErrorHandler", @__cellfunerror); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); -%!test %% Overwriting setting of "UniformOutput" true -%! A = cellfun (@(x,y) mat2str (x,y), {{1.1}, {4.2}}, {{3.1}, {2}}, \ -%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); - -%% Input arguments can be of type cell array of structure arrays -%!test -%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); -%! A = cellfun (@(x,y) (x.a == y.a) && (x.b < y.b), {a}, {b}); -%! assert (A, true); -%!test -%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); -%! A = cellfun (@(x,y) (x.a == y.a) && (x.b < y.b) , {a}, {b}, \ -%! "UniformOutput", true); -%! assert (A, true); -%!test -%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); -%! A = cellfun (@(x,y) (x.a == y.a) && (x.b < y.b) , {a}, {b}, \ -%! "UniformOutput", false); -%! assert (A, {true}); -%!test -%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); -%! A = cellfun (@(x,y) cell2str (x.a, y.a), {a}, {b}, \ -%! "ErrorHandler", @__cellfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); -%!test %% Overwriting setting of "UniformOutput" true -%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); -%! A = cellfun (@(x,y) cell2str (x.a, y.a), {a}, {b}, \ -%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); - -%% A lot of other tests -%!assert (cellfun (@sin, {0,1}), sin ([0,1])) -%!assert (cellfun (inline ("sin (x)"), {0,1}), sin ([0,1])) -%!assert (cellfun ("sin", {0,1}), sin ([0,1])) -%!assert (cellfun ("isempty", {1,[]}), [false,true]) -%!assert (cellfun ("islogical", {false,pi}), [true,false]) -%!assert (cellfun ("isreal", {1i,1}), [false,true]) -%!assert (cellfun ("length", {zeros(2,2),1}), [2,1]) -%!assert (cellfun ("prodofsize", {zeros(2,2),1}), [4,1]) -%!assert (cellfun ("ndims", {zeros([2,2,2]),1}), [3,2]) -%!assert (cellfun ("isclass", {zeros([2,2,2]),"test"}, "double"), [true,false]) -%!assert (cellfun ("size", {zeros([1,2,3]),1}, 1), [1,1]) -%!assert (cellfun ("size", {zeros([1,2,3]),1}, 2), [2,1]) -%!assert (cellfun ("size", {zeros([1,2,3]),1}, 3), [3,1]) -%!assert (cellfun (@atan2, {1,1}, {1,2}), [atan2(1,1), atan2(1,2)]) -%!assert (cellfun (@atan2, {1,1}, {1,2},"UniformOutput", false), {atan2(1,1), atan2(1,2)}) -%!assert (cellfun (@sin, {1,2;3,4}), sin ([1,2;3,4])) -%!assert (cellfun (@atan2, {1,1;1,1}, {1,2;1,2}), atan2 ([1,1;1,1],[1,2;1,2])) -%!error cellfun (@factorial, {-1,3}) -%!assert (cellfun (@factorial,{-1,3},"ErrorHandler",@(x,y) NaN), [NaN,6]) -%!test -%! [a,b,c] = cellfun (@fileparts, {fullfile("a","b","c.d"), fullfile("e","f","g.h")}, "UniformOutput", false); -%! assert (a, {fullfile("a","b"), fullfile("e","f")}); -%! assert (b, {"c", "g"}); -%! assert (c, {".d", ".h"}); - -%!error cellfun (1) -%!error cellfun ("isclass", 1) -%!error cellfun ("size", 1) -%!error cellfun (@sin, {[]}, "BadParam", false) -%!error cellfun (@sin, {[]}, "UniformOuput") -%!error cellfun (@sin, {[]}, "ErrorHandler") -*/ - -// Arrayfun was originally a .m file written by Bill Denney and Jaroslav -// Hajek. It was converted to C++ by jwe so that it could properly -// handle the nargout = 0 case. - -DEFUN_DLD (arrayfun, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Function File} {} arrayfun (@var{func}, @var{A})\n\ -@deftypefnx {Function File} {@var{x} =} arrayfun (@var{func}, @var{A})\n\ -@deftypefnx {Function File} {@var{x} =} arrayfun (@var{func}, @var{A}, @var{b}, @dots{})\n\ -@deftypefnx {Function File} {[@var{x}, @var{y}, @dots{}] =} arrayfun (@var{func}, @var{A}, @dots{})\n\ -@deftypefnx {Function File} {} arrayfun (@dots{}, \"UniformOutput\", @var{val})\n\ -@deftypefnx {Function File} {} arrayfun (@dots{}, \"ErrorHandler\", @var{errfunc})\n\ -\n\ -Execute a function on each element of an array. This is useful for\n\ -functions that do not accept array arguments. If the function does\n\ -accept array arguments it is better to call the function directly.\n\ -\n\ -The first input argument @var{func} can be a string, a function\n\ -handle, an inline function, or an anonymous function. The input\n\ -argument @var{A} can be a logic array, a numeric array, a string\n\ -array, a structure array, or a cell array. By a call of the function\n\ -@command{arrayfun} all elements of @var{A} are passed on to the named\n\ -function @var{func} individually.\n\ -\n\ -The named function can also take more than two input arguments, with\n\ -the input arguments given as third input argument @var{b}, fourth\n\ -input argument @var{c}, @dots{} If given more than one array input\n\ -argument then all input arguments must have the same sizes, for\n\ -example:\n\ -\n\ -@example\n\ -@group\n\ -arrayfun (@@atan2, [1, 0], [0, 1])\n\ - @result{} [ 1.5708 0.0000 ]\n\ -@end group\n\ -@end example\n\ -\n\ -If the parameter @var{val} after a further string input argument\n\ -\"UniformOutput\" is set @code{true} (the default), then the named\n\ -function @var{func} must return a single element which then will be\n\ -concatenated into the return value and is of type matrix. Otherwise,\n\ -if that parameter is set to @code{false}, then the outputs are\n\ -concatenated in a cell array. For example:\n\ -\n\ -@example\n\ -@group\n\ -arrayfun (@@(x,y) x:y, \"abc\", \"def\", \"UniformOutput\", false)\n\ -@result{}\n\ - @{\n\ - [1,1] = abcd\n\ - [1,2] = bcde\n\ - [1,3] = cdef\n\ - @}\n\ -@end group\n\ -@end example\n\ -\n\ -If more than one output arguments are given then the named function\n\ -must return the number of return values that also are expected, for\n\ -example:\n\ -\n\ -@example\n\ -@group\n\ -[A, B, C] = arrayfun (@@find, [10; 0], \"UniformOutput\", false)\n\ -@result{}\n\ -A =\n\ -@{\n\ - [1,1] = 1\n\ - [2,1] = [](0x0)\n\ -@}\n\ -B =\n\ -@{\n\ - [1,1] = 1\n\ - [2,1] = [](0x0)\n\ -@}\n\ -C =\n\ -@{\n\ - [1,1] = 10\n\ - [2,1] = [](0x0)\n\ -@}\n\ -@end group\n\ -@end example\n\ -\n\ -If the parameter @var{errfunc} after a further string input argument\n\ -\"ErrorHandler\" is another string, a function handle, an inline\n\ -function, or an anonymous function, then @var{errfunc} defines a\n\ -function to call in the case that @var{func} generates an error.\n\ -The definition of the function must be of the form\n\ -\n\ -@example\n\ -function [@dots{}] = errfunc (@var{s}, @dots{})\n\ -@end example\n\ -\n\ -@noindent\n\ -where there is an additional input argument to @var{errfunc}\n\ -relative to @var{func}, given by @var{s}. This is a structure with\n\ -the elements \"identifier\", \"message\", and \"index\" giving,\n\ -respectively, the error identifier, the error message, and the index of\n\ -the array elements that caused the error. The size of the output\n\ -argument of @var{errfunc} must have the same size as the output\n\ -argument of @var{func}, otherwise a real error is thrown. For\n\ -example:\n\ -\n\ -@example\n\ -@group\n\ -function y = ferr (s, x), y = \"MyString\"; endfunction\n\ -arrayfun (@@str2num, [1234],\n\ - \"UniformOutput\", false, \"ErrorHandler\", @@ferr)\n\ -@result{}\n\ - @{\n\ - [1,1] = MyString\n\ - @}\n\ -@end group\n\ -@end example\n\ -\n\ -@seealso{spfun, cellfun, structfun}\n\ -@end deftypefn") -{ - octave_value_list retval; - int nargin = args.length (); - int nargout1 = (nargout < 1 ? 1 : nargout); - - if (nargin < 2) - { - error ("arrayfun: function requires at least 2 arguments"); - print_usage (); - return retval; - } - - octave_value func = args(0); - bool symbol_table_lookup = false; - - if (func.is_string ()) - { - // See if we can convert the string into a function. - - std::string name = args(0).string_value (); - - if (! valid_identifier (name)) - { - std::string fcn_name = unique_symbol_name ("__arrayfun_fcn_"); - std::string fname = "function y = " + fcn_name + "(x) y = "; - - octave_function *ptr_func - = extract_function (args(0), "arrayfun", fcn_name, - fname, "; endfunction"); - - if (ptr_func && ! error_state) - func = octave_value (ptr_func, true); - } - else - { - func = symbol_table::find_function (name); - - if (func.is_undefined ()) - error ("arrayfun: invalid function NAME: %s", name.c_str ()); - - symbol_table_lookup = true; - } - - if (error_state) - return retval; - } - - if (func.is_function_handle () || func.is_inline_function () - || func.is_function ()) - { - // The following is an optimisation because the symbol table can - // give a more specific function class, so this can result in - // fewer polymorphic function calls as the function gets called - // for each value of the array. - - if (! symbol_table_lookup ) - { - if (func.is_function_handle ()) - { - octave_fcn_handle* f = func.fcn_handle_value (); - - // Overloaded function handles need to check the type of - // the arguments for each element of the array, so they - // cannot be optimised this way. - - if (f -> is_overloaded ()) - goto nevermind; - } - octave_value f = symbol_table::find_function (func.function_value () - -> name ()); - if (f.is_defined ()) - func = f; - } - - nevermind: - - bool uniform_output = true; - octave_value error_handler; - - get_mapper_fun_options (args, nargin, uniform_output, error_handler); - - if (error_state) - return octave_value_list (); - - octave_value_list inputlist (nargin, octave_value ()); - - OCTAVE_LOCAL_BUFFER (octave_value, inputs, nargin); - OCTAVE_LOCAL_BUFFER (bool, mask, nargin); - - octave_idx_type k = 1; - - dim_vector fdims (1, 1); - - // Collect arguments. Pre-fill scalar elements of inputlist - // array. - - for (int j = 0; j < nargin; j++) - { - inputs[j] = args(j+1); - mask[j] = inputs[j].numel () != 1; - - if (! mask[j]) - inputlist(j) = inputs[j]; - } - - for (int j = 0; j < nargin; j++) - { - if (mask[j]) - { - fdims = inputs[j].dims (); - k = inputs[j].numel (); - - for (int i = j+1; i < nargin; i++) - { - if (mask[i] && inputs[i].dims () != fdims) - { - error ("arrayfun: dimensions mismatch"); - return retval; - } - } - break; - } - } - - - unwind_protect frame; - frame.protect_var (buffer_error_messages); - - if (error_handler.is_defined ()) - buffer_error_messages++; - - // Apply functions. - - if (uniform_output) - { - std::list<octave_value_list> idx_list (1); - idx_list.front ().resize (1); - std::string idx_type = "("; - - OCTAVE_LOCAL_BUFFER (octave_value, retv, nargout1); - - for (octave_idx_type count = 0; count < k; count++) - { - idx_list.front ()(0) = count + 1.0; - - for (int j = 0; j < nargin; j++) - { - if (mask[j]) - inputlist.xelem (j) = inputs[j].do_index_op (idx_list); - - if (error_state) - return retval; - } - - const octave_value_list tmp - = get_output_list (count, nargout, inputlist, func, - error_handler); - - if (error_state) - return retval; - - if (nargout > 0 && tmp.length () < nargout) - { - error ("arrayfun: function returned fewer than nargout values"); - return retval; - } - - if (nargout > 0 - || (nargout == 0 - && tmp.length () > 0 && tmp(0).is_defined ())) - { - int num_to_copy = tmp.length (); - - if (num_to_copy > nargout1) - num_to_copy = nargout1; - - if (count == 0) - { - for (int j = 0; j < num_to_copy; j++) - { - if (tmp(j).is_defined ()) - { - octave_value val = tmp(j); - - if (val.numel () == 1) - retv[j] = val.resize (fdims); - else - { - error ("arrayfun: all values must be scalars when UniformOutput = true"); - break; - } - } - } - } - else - { - for (int j = 0; j < num_to_copy; j++) - { - if (tmp(j).is_defined ()) - { - octave_value val = tmp(j); - - if (! retv[j].fast_elem_insert (count, val)) - { - if (val.numel () == 1) - { - idx_list.front ()(0) = count + 1.0; - retv[j].assign (octave_value::op_asn_eq, - idx_type, idx_list, val); - - if (error_state) - break; - } - else - { - error ("arrayfun: all values must be scalars when UniformOutput = true"); - break; - } - } - } - } - } - } - - if (error_state) - break; - } - - retval.resize (nargout1); - - for (int j = 0; j < nargout1; j++) - { - if (nargout > 0 && retv[j].is_undefined ()) - retval(j) = NDArray (fdims); - else - retval(j) = retv[j]; - } - } - else - { - std::list<octave_value_list> idx_list (1); - idx_list.front ().resize (1); - std::string idx_type = "("; - - OCTAVE_LOCAL_BUFFER (Cell, results, nargout1); - - for (int j = 0; j < nargout1; j++) - results[j].resize (fdims, Matrix ()); - - bool have_some_output = false; - - for (octave_idx_type count = 0; count < k; count++) - { - idx_list.front ()(0) = count + 1.0; - - for (int j = 0; j < nargin; j++) - { - if (mask[j]) - inputlist.xelem (j) = inputs[j].do_index_op (idx_list); - - if (error_state) - return retval; - } - - const octave_value_list tmp - = get_output_list (count, nargout, inputlist, func, - error_handler); - - if (error_state) - return retval; - - if (nargout > 0 && tmp.length () < nargout) - { - error ("arrayfun: function returned fewer than nargout values"); - return retval; - } - - if (nargout > 0 - || (nargout == 0 - && tmp.length () > 0 && tmp(0).is_defined ())) - { - int num_to_copy = tmp.length (); - - if (num_to_copy > nargout1) - num_to_copy = nargout1; - - if (num_to_copy > 0) - have_some_output = true; - - for (int j = 0; j < num_to_copy; j++) - results[j](count) = tmp(j); - } - } - - if (have_some_output || fdims.any_zero ()) - { - retval.resize (nargout1); - - for (int j = 0; j < nargout1; j++) - retval(j) = results[j]; - } - } - } - else - error ("arrayfun: argument NAME must be a string or function handle"); - - return retval; -} - -/* -%!function r = __f11 (x) -%! global __arrayfun_test_num_outputs__; -%! __arrayfun_test_num_outputs__ = nargout; -%! r = x; -%!endfunction - -%!function __f01 (x) -%! global __arrayfun_test_num_outputs__; -%! __arrayfun_test_num_outputs__ = nargout; -%!endfunction - -%!test -%! global __arrayfun_test_num_outputs__; -%! arrayfun (@__f11, {1}); -%! assert (__arrayfun_test_num_outputs__, 0); -%! x = arrayfun (@__f11, {1}); -%! assert (__arrayfun_test_num_outputs__, 1); - -%!test -%! global __arrayfun_test_num_outputs__; -%! arrayfun (@__f01, {1}); -%! assert (__arrayfun_test_num_outputs__, 0); - -%!error x = arrayfun (@__f01, [1, 2]); - -%!test -%! assert (arrayfun (@__f11, [1, 2]), [1, 2]); -%! assert (arrayfun (@__f11, [1, 2], "uniformoutput", false), {1, 2}); -%! assert (arrayfun (@__f11, {1, 2}), {1, 2}); -%! assert (arrayfun (@__f11, {1, 2}, "uniformoutput", false), {{1}, {2}}); - -%!assert (arrayfun (@ones, 1, [2,3], "uniformoutput", false), {[1,1], [1,1,1]}) - -%% Test function to check the "Errorhandler" option -%!function z = __arrayfunerror (S, varargin) -%! z = S; -%!endfunction -%% First input argument can be a string, an inline function, a -%% function_handle or an anonymous function -%!test -%! arrayfun (@isequal, [false, true], [true, true]); %% No output argument -%!error -%! arrayfun (@isequal); %% One or less input arguments -%!test -%! A = arrayfun ("isequal", [false, true], [true, true]); -%! assert (A, [false, true]); -%!test -%! A = arrayfun (inline ("(x == y)", "x", "y"), [false, true], [true, true]); -%! assert (A, [false, true]); -%!test -%! A = arrayfun (@isequal, [false, true], [true, true]); -%! assert (A, [false, true]); -%!test -%! A = arrayfun (@(x,y) isequal (x,y), [false, true], [true, true]); -%! assert (A, [false, true]); - -%% Number of input and output arguments may be greater than one -%#!test -%! A = arrayfun (@(x) islogical (x), false); -%! assert (A, true); -%!test -%! A = arrayfun (@(x,y,z) x + y + z, [1, 1, 1], [2, 2, 2], [3, 4, 5]); -%! assert (A, [6, 7, 8], 1e-16); -%!test %% Two input arguments of different types -%! A = arrayfun (@(x,y) islogical (x) && ischar (y), false, "a"); -%! assert (A, true); -%!test %% Pass another variable to the anonymous function -%! y = true; -%! A = arrayfun (@(x) islogical (x && y), false); -%! assert (A, true); -%!test %% Three ouptut arguments of different type -%! [A, B, C] = arrayfun (@find, [10, 11; 0, 12], "UniformOutput", false); -%! assert (isequal (A, {true, true; [], true})); -%! assert (isequal (B, {true, true; [], true})); -%! assert (isequal (C, {10, 11; [], 12})); - -%% Input arguments can be of type logical -%!test -%! A = arrayfun (@(x,y) x == y, [false, true], [true, true]); -%! assert (A, [false, true]); -%!test -%! A = arrayfun (@(x,y) x == y, [false; true], [true; true], "UniformOutput", true); -%! assert (A, [false; true]); -%!test -%! A = arrayfun (@(x) x, [false, true, false, true], "UniformOutput", false); -%! assert (A, {false, true, false, true}); -%!test %% Three ouptut arguments of same type -%! [A, B, C] = arrayfun (@find, [true, false; false, true], "UniformOutput", false); -%! assert (isequal (A, {true, []; [], true})); -%! assert (isequal (B, {true, []; [], true})); -%! assert (isequal (C, {true, []; [], true})); -%!test -%! A = arrayfun (@(x,y) array2str (x,y), true, true, \ -%! "ErrorHandler", @__arrayfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); -%!test %% Overwriting setting of "UniformOutput" true -%! A = arrayfun (@(x,y) array2str (x,y), true, true, "UniformOutput", true, \ -%! "ErrorHandler", @__arrayfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); - -%% Input arguments can be of type numeric -%!test -%! A = arrayfun (@(x,y) x>y, [1.1, 4.2], [3.1, 2+3*i]); -%! assert (A, [false, true]); -%!test -%! A = arrayfun (@(x,y) x>y, [1.1, 4.2; 2, 4], [3.1, 2; 2, 4+2*i], "UniformOutput", true); -%! assert (A, [false, true; false, false]); -%!test -%! A = arrayfun (@(x,y) x:y, [1.1, 4], [3.1, 6], "UniformOutput", false); -%! assert (isequal (A{1}, [1.1, 2.1, 3.1])); -%! assert (isequal (A{2}, [4, 5, 6])); -%!test %% Three ouptut arguments of different type -%! [A, B, C] = arrayfun (@find, [10, 11; 0, 12], "UniformOutput", false); -%! assert (isequal (A, {true, true; [], true})); -%! assert (isequal (B, {true, true; [], true})); -%! assert (isequal (C, {10, 11; [], 12})); -%!test -%! A = arrayfun (@(x,y) array2str (x,y), {1.1, 4}, {3.1, 6}, \ -%! "ErrorHandler", @__arrayfunerror); -%! B = isfield (A(1), "message") && isfield (A(1), "index"); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); -%!test %% Overwriting setting of "UniformOutput" true -%! A = arrayfun (@(x,y) array2str (x,y), {1.1, 4}, {3.1, 6}, \ -%! "UniformOutput", true, "ErrorHandler", @__arrayfunerror); -%! B = isfield (A(1), "message") && isfield (A(1), "index"); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); - -%% Input arguments can be of type character or strings -%!test -%! A = arrayfun (@(x,y) x>y, ["ad", "c", "ghi"], ["cc", "d", "fgh"]); -%! assert (A, [false, true, false, true, true, true]); -%!test -%! A = arrayfun (@(x,y) x>y, ["a"; "f"], ["c"; "d"], "UniformOutput", true); -%! assert (A, [false; true]); -%!test -%! A = arrayfun (@(x,y) x:y, ["a", "d"], ["c", "f"], "UniformOutput", false); -%! assert (A, {"abc", "def"}); -%!test -%! A = arrayfun (@(x,y) cell2str (x,y), ["a", "d"], ["c", "f"], \ -%! "ErrorHandler", @__arrayfunerror); -%! B = isfield (A(1), "identifier") && isfield (A(1), "message") && isfield (A(1), "index"); -%! assert (B, true); - -%% Input arguments can be of type structure -%!test -%! a = struct ("a", 1.1, "b", 4.2); b = struct ("a", 3.1, "b", 2); -%! A = arrayfun (@(x,y) (x.a < y.a) && (x.b > y.b), a, b); -%! assert (A, true); -%!test -%! a = struct ("a", 1.1, "b", 4.2); b = struct ("a", 3.1, "b", 2); -%! A = arrayfun (@(x,y) (x.a < y.a) && (x.b > y.b), a, b, "UniformOutput", true); -%! assert (A, true); -%!test -%! a = struct ("a", 1.1, "b", 4.2); b = struct ("a", 3.1, "b", 2); -%! A = arrayfun (@(x,y) x.a:y.a, a, b, "UniformOutput", false); -%! assert (isequal (A, {[1.1, 2.1, 3.1]})); -%!test -%! A = arrayfun (@(x) mat2str(x), "a", "ErrorHandler", @__arrayfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); -%!test %% Overwriting setting of "UniformOutput" true -%! A = arrayfun (@(x) mat2str(x), "a", "UniformOutput", true, \ -%! "ErrorHandler", @__arrayfunerror); -%! assert (isfield (A, "identifier"), true); -%! assert (isfield (A, "message"), true); -%! assert (isfield (A, "index"), true); -%! assert (isempty (A.message), false); -%! assert (A.index, 1); - -%% Input arguments can be of type cell array -%!test -%! A = arrayfun (@(x,y) x{1} < y{1}, {1.1, 4.2}, {3.1, 2}); -%! assert (A, [true, false]); -%!test -%! A = arrayfun (@(x,y) x{1} < y{1}, {1.1; 4.2}, {3.1; 2}, "UniformOutput", true); -%! assert (A, [true; false]); -%!test -%! A = arrayfun (@(x,y) x{1} < y{1}, {1.1, 4.2}, {3.1, 2}, "UniformOutput", false); -%! assert (A, {true, false}); -%!test -%! A = arrayfun (@(x,y) num2str(x,y), {1.1, 4.2}, {3.1, 2}, "ErrorHandler", @__arrayfunerror); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); -%!test -%! A = arrayfun (@(x,y) num2str (x,y), {1.1, 4.2}, {3.1, 2}, \ -%! "UniformOutput", true, "ErrorHandler", @__arrayfunerror); -%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); -%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); -%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); -%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); -%! assert ([A(1).index, A(2).index], [1, 2]); -*/ - -static void -do_num2cell_helper (const dim_vector& dv, - const Array<int>& dimv, - dim_vector& celldv, dim_vector& arraydv, - Array<int>& perm) -{ - int dvl = dimv.length (); - int maxd = dv.length (); - celldv = dv; - for (int i = 0; i < dvl; i++) - maxd = std::max (maxd, dimv(i)); - if (maxd > dv.length ()) - celldv.resize (maxd, 1); - arraydv = celldv; - - OCTAVE_LOCAL_BUFFER_INIT (bool, sing, maxd, false); - - perm.clear (maxd, 1); - for (int i = 0; i < dvl; i++) - { - int k = dimv(i) - 1; - if (k < 0) - { - error ("num2cell: dimension indices must be positive"); - return; - } - else if (i > 0 && k < dimv(i-1) - 1) - { - error ("num2cell: dimension indices must be strictly increasing"); - return; - } - - sing[k] = true; - perm(i) = k; - } - - for (int k = 0, i = dvl; k < maxd; k++) - if (! sing[k]) - perm(i++) = k; - - for (int i = 0; i < maxd; i++) - if (sing[i]) - celldv(i) = 1; - else - arraydv(i) = 1; -} - -template<class NDA> -static inline typename NDA::element_type -do_num2cell_elem (const NDA& array, octave_idx_type i) -{ return array(i); } - -static inline Cell -do_num2cell_elem (const Cell& array, octave_idx_type i) -{ return Cell (array(i)); } - - -template<class NDA> -static Cell -do_num2cell (const NDA& array, const Array<int>& dimv) -{ - if (dimv.is_empty ()) - { - Cell retval (array.dims ()); - octave_idx_type nel = array.numel (); - for (octave_idx_type i = 0; i < nel; i++) - retval.xelem (i) = do_num2cell_elem (array, i); - - return retval; - } - else - { - dim_vector celldv, arraydv; - Array<int> perm; - do_num2cell_helper (array.dims (), dimv, celldv, arraydv, perm); - if (error_state) - return Cell (); - - NDA parray = array.permute (perm); - - octave_idx_type nela = arraydv.numel (), nelc = celldv.numel (); - parray = parray.reshape (dim_vector (nela, nelc)); - - Cell retval (celldv); - for (octave_idx_type i = 0; i < nelc; i++) - { - retval.xelem (i) = NDA (parray.column (i).reshape (arraydv)); - } - - return retval; - } -} - -// FIXME -- this is a mess, but if a size method for the object exists, -// we have to call it to get the size of the object instead of using the -// internal dims method. - -static dim_vector -get_object_dims (octave_value& obj) -{ - dim_vector retval; - - Matrix m = obj.size (); - - int n = m.numel (); - - retval.resize (n); - - for (int i = 0; i < n; i++) - retval(i) = m(i); - - return retval; -} - -static Cell -do_object2cell (const octave_value& obj, const Array<int>& dimv) -{ - Cell retval; - - // FIXME -- this copy is only needed because the octave_value::size - // method is not const. - octave_value array = obj; - - if (dimv.is_empty ()) - { - dim_vector dv = get_object_dims (array); - - if (! error_state) - { - retval.resize (dv); - - octave_value_list idx (1); - - for (octave_idx_type i = 0; i < dv.numel (); i++) - { - octave_quit (); - - idx(0) = double (i+1); - - retval.xelem (i) = array.single_subsref ("(", idx); - - if (error_state) - break; - } - } - } - else - { - error ("num2cell (A, dim) not implemented for class objects"); - } - - return retval; -} - -DEFUN_DLD (num2cell, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{C} =} num2cell (@var{A})\n\ -@deftypefnx {Loadable Function} {@var{C} =} num2cell (@var{A}, @var{dim})\n\ -Convert the numeric matrix @var{A} to a cell array. If @var{dim} is\n\ -defined, the value @var{C} is of dimension 1 in this dimension and the\n\ -elements of @var{A} are placed into @var{C} in slices. For example:\n\ -\n\ -@example\n\ -@group\n\ -num2cell ([1,2;3,4])\n\ - @result{}\n\ - @{\n\ - [1,1] = 1\n\ - [2,1] = 3\n\ - [1,2] = 2\n\ - [2,2] = 4\n\ - @}\n\ -num2cell ([1,2;3,4],1)\n\ - @result{}\n\ - @{\n\ - [1,1] =\n\ - 1\n\ - 3\n\ - [1,2] =\n\ - 2\n\ - 4\n\ - @}\n\ -@end group\n\ -@end example\n\ -\n\ -@seealso{mat2cell}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value retval; - - if (nargin < 1 || nargin > 2) - print_usage (); - else - { - octave_value array = args(0); - Array<int> dimv; - if (nargin > 1) - dimv = args (1).int_vector_value (true); - - if (error_state) - ; - else if (array.is_bool_type ()) - retval = do_num2cell (array.bool_array_value (), dimv); - else if (array.is_char_matrix ()) - retval = do_num2cell (array.char_array_value (), dimv); - else if (array.is_numeric_type ()) - { - if (array.is_integer_type ()) - { - if (array.is_int8_type ()) - retval = do_num2cell (array.int8_array_value (), dimv); - else if (array.is_int16_type ()) - retval = do_num2cell (array.int16_array_value (), dimv); - else if (array.is_int32_type ()) - retval = do_num2cell (array.int32_array_value (), dimv); - else if (array.is_int64_type ()) - retval = do_num2cell (array.int64_array_value (), dimv); - else if (array.is_uint8_type ()) - retval = do_num2cell (array.uint8_array_value (), dimv); - else if (array.is_uint16_type ()) - retval = do_num2cell (array.uint16_array_value (), dimv); - else if (array.is_uint32_type ()) - retval = do_num2cell (array.uint32_array_value (), dimv); - else if (array.is_uint64_type ()) - retval = do_num2cell (array.uint64_array_value (), dimv); - } - else if (array.is_complex_type ()) - { - if (array.is_single_type ()) - retval = do_num2cell (array.float_complex_array_value (), dimv); - else - retval = do_num2cell (array.complex_array_value (), dimv); - } - else - { - if (array.is_single_type ()) - retval = do_num2cell (array.float_array_value (), dimv); - else - retval = do_num2cell (array.array_value (), dimv); - } - } - else if (array.is_object ()) - retval = do_object2cell (array, dimv); - else if (array.is_map ()) - retval = do_num2cell (array.map_value (), dimv); - else if (array.is_cell ()) - retval = do_num2cell (array.cell_value (), dimv); - else if (array.is_object ()) - retval = do_num2cell (array.cell_value (), dimv); - else - gripe_wrong_type_arg ("num2cell", array); - } - - return retval; -} - -/* -%!assert (num2cell ([1,2;3,4]), {1,2;3,4}) -%!assert (num2cell ([1,2;3,4], 1), {[1;3],[2;4]}) -%!assert (num2cell ([1,2;3,4], 2), {[1,2];[3,4]}) -*/ - -static bool -mat2cell_mismatch (const dim_vector& dv, - const Array<octave_idx_type> *d, int nd) -{ - for (int i = 0; i < nd; i++) - { - octave_idx_type s = 0; - for (octave_idx_type j = 0; j < d[i].length (); j++) - s += d[i](j); - - octave_idx_type r = i < dv.length () ? dv(i) : 1; - - if (s != r) - { - error ("mat2cell: mismatch on %d-th dimension (%d != %d)", - i+1, r, s); - return true; - } - } - - return false; -} - -template<class container> -static void -prepare_idx (container *idx, int idim, int nd, - const Array<octave_idx_type>* d) -{ - octave_idx_type nidx = idim < nd ? d[idim].numel () : 1; - if (nidx == 1) - idx[0] = idx_vector::colon; - else - { - octave_idx_type l = 0; - for (octave_idx_type i = 0; i < nidx; i++) - { - octave_idx_type u = l + d[idim](i); - idx[i] = idx_vector (l, u); - l = u; - } - } -} - -// 2D specialization, works for Array, Sparse and octave_map. -// Uses 1D or 2D indexing. - -template <class Array2D> -static Cell -do_mat2cell_2d (const Array2D& a, const Array<octave_idx_type> *d, int nd) -{ - NoAlias<Cell> retval; - assert (nd == 1 || nd == 2); - assert (a.ndims () == 2); - - if (mat2cell_mismatch (a.dims (), d, nd)) - return retval; - - octave_idx_type nridx = d[0].length (); - octave_idx_type ncidx = nd == 1 ? 1 : d[1].length (); - retval.clear (nridx, ncidx); - - int ivec = -1; - if (a.rows () > 1 && a.cols () == 1 && ncidx == 1) - ivec = 0; - else if (a.rows () == 1 && nridx == 1 && nd == 2) - ivec = 1; - - if (ivec >= 0) - { - // Vector split. Use 1D indexing. - octave_idx_type l = 0, nidx = (ivec == 0 ? nridx : ncidx); - for (octave_idx_type i = 0; i < nidx; i++) - { - octave_idx_type u = l + d[ivec](i); - retval(i) = a.index (idx_vector (l, u)); - l = u; - } - } - else - { - // General 2D case. Use 2D indexing. - OCTAVE_LOCAL_BUFFER (idx_vector, ridx, nridx); - prepare_idx (ridx, 0, nd, d); - - OCTAVE_LOCAL_BUFFER (idx_vector, cidx, ncidx); - prepare_idx (cidx, 1, nd, d); - - for (octave_idx_type j = 0; j < ncidx; j++) - for (octave_idx_type i = 0; i < nridx; i++) - { - octave_quit (); - - retval(i,j) = a.index (ridx[i], cidx[j]); - } - } - - return retval; -} - -// Nd case. Works for Arrays and octave_map. -// Uses Nd indexing. - -template <class ArrayND> -Cell -do_mat2cell_nd (const ArrayND& a, const Array<octave_idx_type> *d, int nd) -{ - NoAlias<Cell> retval; - assert (nd >= 1); - - if (mat2cell_mismatch (a.dims (), d, nd)) - return retval; - - dim_vector rdv = dim_vector::alloc (nd); - OCTAVE_LOCAL_BUFFER (octave_idx_type, nidx, nd); - octave_idx_type idxtot = 0; - for (int i = 0; i < nd; i++) - { - rdv(i) = nidx[i] = d[i].length (); - idxtot += nidx[i]; - } - - retval.clear (rdv); - - OCTAVE_LOCAL_BUFFER (idx_vector, xidx, idxtot); - OCTAVE_LOCAL_BUFFER (idx_vector *, idx, nd); - - idxtot = 0; - for (int i = 0; i < nd; i++) - { - idx[i] = xidx + idxtot; - prepare_idx (idx[i], i, nd, d); - idxtot += nidx[i]; - } - - OCTAVE_LOCAL_BUFFER_INIT (octave_idx_type, ridx, nd, 0); - NoAlias< Array<idx_vector> > ra_idx - (dim_vector (1, std::max (nd, a.ndims ())), idx_vector::colon); - - for (octave_idx_type j = 0; j < retval.numel (); j++) - { - octave_quit (); - - for (int i = 0; i < nd; i++) - ra_idx(i) = idx[i][ridx[i]]; - - retval(j) = a.index (ra_idx); - - rdv.increment_index (ridx); - } - - return retval; -} - -// Dispatcher. -template <class ArrayND> -Cell -do_mat2cell (const ArrayND& a, const Array<octave_idx_type> *d, int nd) -{ - if (a.ndims () == 2 && nd <= 2) - return do_mat2cell_2d (a, d, nd); - else - return do_mat2cell_nd (a, d, nd); -} - -// General case. Works for any class supporting do_index_op. -// Uses Nd indexing. - -Cell -do_mat2cell (octave_value& a, const Array<octave_idx_type> *d, int nd) -{ - NoAlias<Cell> retval; - assert (nd >= 1); - - if (mat2cell_mismatch (a.dims (), d, nd)) - return retval; - - dim_vector rdv = dim_vector::alloc (nd); - OCTAVE_LOCAL_BUFFER (octave_idx_type, nidx, nd); - octave_idx_type idxtot = 0; - for (int i = 0; i < nd; i++) - { - rdv(i) = nidx[i] = d[i].length (); - idxtot += nidx[i]; - } - - retval.clear (rdv); - - OCTAVE_LOCAL_BUFFER (octave_value, xidx, idxtot); - OCTAVE_LOCAL_BUFFER (octave_value *, idx, nd); - - idxtot = 0; - for (int i = 0; i < nd; i++) - { - idx[i] = xidx + idxtot; - prepare_idx (idx[i], i, nd, d); - idxtot += nidx[i]; - } - - OCTAVE_LOCAL_BUFFER_INIT (octave_idx_type, ridx, nd, 0); - octave_value_list ra_idx (std::max (nd, a.ndims ()), - octave_value::magic_colon_t); - - for (octave_idx_type j = 0; j < retval.numel (); j++) - { - octave_quit (); - - for (int i = 0; i < nd; i++) - ra_idx(i) = idx[i][ridx[i]]; - - retval(j) = a.do_index_op (ra_idx); - - if (error_state) - break; - - rdv.increment_index (ridx); - } - - return retval; -} - -DEFUN_DLD (mat2cell, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{C} =} mat2cell (@var{A}, @var{m}, @var{n})\n\ -@deftypefnx {Loadable Function} {@var{C} =} mat2cell (@var{A}, @var{d1}, @var{d2}, @dots{})\n\ -@deftypefnx {Loadable Function} {@var{C} =} mat2cell (@var{A}, @var{r})\n\ -Convert the matrix @var{A} to a cell array. If @var{A} is 2-D, then\n\ -it is required that @code{sum (@var{m}) == size (@var{A}, 1)} and\n\ -@code{sum (@var{n}) == size (@var{A}, 2)}. Similarly, if @var{A} is\n\ -multi-dimensional and the number of dimensional arguments is equal\n\ -to the dimensions of @var{A}, then it is required that @code{sum (@var{di})\n\ -== size (@var{A}, i)}.\n\ -\n\ -Given a single dimensional argument @var{r}, the other dimensional\n\ -arguments are assumed to equal @code{size (@var{A},@var{i})}.\n\ -\n\ -An example of the use of mat2cell is\n\ -\n\ -@example\n\ -mat2cell (reshape (1:16,4,4), [3,1], [3,1])\n\ -@result{}\n\ -@{\n\ - [1,1] =\n\ -\n\ - 1 5 9\n\ - 2 6 10\n\ - 3 7 11\n\ -\n\ - [2,1] =\n\ -\n\ - 4 8 12\n\ -\n\ - [1,2] =\n\ -\n\ - 13\n\ - 14\n\ - 15\n\ -\n\ - [2,2] = 16\n\ -@}\n\ -@end example\n\ -@seealso{num2cell, cell2mat}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value retval; - - if (nargin < 2) - print_usage (); - else - { - // Prepare indices. - OCTAVE_LOCAL_BUFFER (Array<octave_idx_type>, d, nargin-1); - - for (int i = 1; i < nargin; i++) - { - d[i-1] = args(i).octave_idx_type_vector_value (true); - if (error_state) - return retval; - } - - octave_value a = args(0); - bool sparse = a.is_sparse_type (); - if (sparse && nargin > 3) - { - error ("mat2cell: sparse arguments only support 2D indexing"); - return retval; - } - - switch (a.builtin_type ()) - { - case btyp_double: - { - if (sparse) - retval = do_mat2cell_2d (a.sparse_matrix_value (), d, nargin-1); - else - retval = do_mat2cell (a.array_value (), d, nargin - 1); - break; - } - case btyp_complex: - { - if (sparse) - retval = do_mat2cell_2d (a.sparse_complex_matrix_value (), d, nargin-1); - else - retval = do_mat2cell (a.complex_array_value (), d, nargin - 1); - break; - } -#define BTYP_BRANCH(X,Y) \ - case btyp_ ## X: \ - retval = do_mat2cell (a.Y ## _value (), d, nargin - 1); \ - break - - BTYP_BRANCH (float, float_array); - BTYP_BRANCH (float_complex, float_complex_array); - BTYP_BRANCH (bool, bool_array); - BTYP_BRANCH (char, char_array); - - BTYP_BRANCH (int8, int8_array); - BTYP_BRANCH (int16, int16_array); - BTYP_BRANCH (int32, int32_array); - BTYP_BRANCH (int64, int64_array); - BTYP_BRANCH (uint8, uint8_array); - BTYP_BRANCH (uint16, uint16_array); - BTYP_BRANCH (uint32, uint32_array); - BTYP_BRANCH (uint64, uint64_array); - - BTYP_BRANCH (cell, cell); - BTYP_BRANCH (struct, map); -#undef BTYP_BRANCH - - case btyp_func_handle: - gripe_wrong_type_arg ("mat2cell", a); - break; - default: - retval = do_mat2cell (a, d, nargin-1); - } - } - - return retval; -} - -/* -%!test -%! x = reshape (1:20, 5, 4); -%! c = mat2cell (x, [3,2], [3,1]); -%! assert (c, {[1,6,11;2,7,12;3,8,13],[16;17;18];[4,9,14;5,10,15],[19;20]}); - -%!test -%! x = "abcdefghij"; -%! c = mat2cell (x, 1, [0,4,2,0,4,0]); -%! empty1by0str = resize ("", 1, 0); -%! assert (c, {empty1by0str,"abcd","ef",empty1by0str,"ghij",empty1by0str}); -*/ - -// FIXME: it would be nice to allow ranges being handled without a conversion. -template <class NDA> -static Cell -do_cellslices_nda (const NDA& array, - const Array<octave_idx_type>& lb, - const Array<octave_idx_type>& ub, - int dim = -1) -{ - octave_idx_type n = lb.length (); - Cell retval (1, n); - if (array.is_vector () && (dim == -1 - || (dim == 0 && array.columns () == 1) - || (dim == 1 && array.rows () == 1))) - { - for (octave_idx_type i = 0; i < n && ! error_state; i++) - retval(i) = array.index (idx_vector (lb(i) - 1, ub(i))); - } - else - { - const dim_vector dv = array.dims (); - int ndims = dv.length (); - if (dim < 0) - dim = dv.first_non_singleton (); - ndims = std::max (ndims, dim + 1); - - Array<idx_vector> idx (dim_vector (ndims, 1), idx_vector::colon); - - for (octave_idx_type i = 0; i < n && ! error_state; i++) - { - idx(dim) = idx_vector (lb(i) - 1, ub(i)); - retval(i) = array.index (idx); - } - } - - return retval; -} - -DEFUN_DLD (cellslices, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{sl} =} cellslices (@var{x}, @var{lb}, @var{ub}, @var{dim})\n\ -Given an array @var{x}, this function produces a cell array of slices from\n\ -the array determined by the index vectors @var{lb}, @var{ub}, for lower and\n\ -upper bounds, respectively. In other words, it is equivalent to the\n\ -following code:\n\ -\n\ -@example\n\ -@group\n\ -n = length (lb);\n\ -sl = cell (1, n);\n\ -for i = 1:length (lb)\n\ - sl@{i@} = x(:,@dots{},lb(i):ub(i),@dots{},:);\n\ -endfor\n\ -@end group\n\ -@end example\n\ -\n\ -The position of the index is determined by @var{dim}. If not specified,\n\ -slicing is done along the first non-singleton dimension.\n\ -@seealso{cell2mat, cellindexmat, cellfun}\n\ -@end deftypefn") -{ - octave_value retval; - int nargin = args.length (); - if (nargin == 3 || nargin == 4) - { - octave_value x = args(0); - Array<octave_idx_type> lb = args(1).octave_idx_type_vector_value (); - Array<octave_idx_type> ub = args(2).octave_idx_type_vector_value (); - int dim = -1; - if (nargin == 4) - { - dim = args(3).int_value () - 1; - if (dim < 0) - error ("cellslices: DIM must be a valid dimension"); - } - - if (! error_state) - { - if (lb.length () != ub.length ()) - error ("cellslices: the lengths of LB and UB must match"); - else - { - Cell retcell; - if (! x.is_sparse_type () && x.is_matrix_type ()) - { - // specialize for some dense arrays. - if (x.is_bool_type ()) - retcell = do_cellslices_nda (x.bool_array_value (), lb, ub, dim); - else if (x.is_char_matrix ()) - retcell = do_cellslices_nda (x.char_array_value (), lb, ub, dim); - else if (x.is_integer_type ()) - { - if (x.is_int8_type ()) - retcell = do_cellslices_nda (x.int8_array_value (), lb, ub, dim); - else if (x.is_int16_type ()) - retcell = do_cellslices_nda (x.int16_array_value (), lb, ub, dim); - else if (x.is_int32_type ()) - retcell = do_cellslices_nda (x.int32_array_value (), lb, ub, dim); - else if (x.is_int64_type ()) - retcell = do_cellslices_nda (x.int64_array_value (), lb, ub, dim); - else if (x.is_uint8_type ()) - retcell = do_cellslices_nda (x.uint8_array_value (), lb, ub, dim); - else if (x.is_uint16_type ()) - retcell = do_cellslices_nda (x.uint16_array_value (), lb, ub, dim); - else if (x.is_uint32_type ()) - retcell = do_cellslices_nda (x.uint32_array_value (), lb, ub, dim); - else if (x.is_uint64_type ()) - retcell = do_cellslices_nda (x.uint64_array_value (), lb, ub, dim); - } - else if (x.is_complex_type ()) - { - if (x.is_single_type ()) - retcell = do_cellslices_nda (x.float_complex_array_value (), lb, ub, dim); - else - retcell = do_cellslices_nda (x.complex_array_value (), lb, ub, dim); - } - else - { - if (x.is_single_type ()) - retcell = do_cellslices_nda (x.float_array_value (), lb, ub, dim); - else - retcell = do_cellslices_nda (x.array_value (), lb, ub, dim); - } - } - else - { - // generic code. - octave_idx_type n = lb.length (); - retcell = Cell (1, n); - const dim_vector dv = x.dims (); - int ndims = dv.length (); - if (dim < 0) - dim = dv.first_non_singleton (); - ndims = std::max (ndims, dim + 1); - octave_value_list idx (ndims, octave_value::magic_colon_t); - for (octave_idx_type i = 0; i < n && ! error_state; i++) - { - idx(dim) = Range (lb(i), ub(i)); - retcell(i) = x.do_index_op (idx); - } - } - if (! error_state) - retval = retcell; - } - } - } - else - print_usage (); - - return retval; -} - -/* -%!test -%! m = [1, 2, 3, 4; 5, 6, 7, 8; 9, 10, 11, 12]; -%! c = cellslices (m, [1, 2], [2, 3], 2); -%! assert (c, {[1, 2; 5, 6; 9, 10], [2, 3; 6, 7; 10, 11]}); -*/ - -DEFUN_DLD (cellindexmat, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{y} =} cellindexmat (@var{x}, @var{varargin})\n\ -Given a cell array of matrices @var{x}, this function computes\n\ -\n\ -@example\n\ -@group\n\ -Y = cell (size (X));\n\ -for i = 1:numel (X)\n\ - Y@{i@} = X@{i@}(varargin@{:@});\n\ -endfor\n\ -@end group\n\ -@end example\n\ -@seealso{cellslices, cellfun}\n\ -@end deftypefn") -{ - octave_value retval; - if (args.length () >= 1) - { - if (args(0).is_cell ()) - { - const Cell x = args(0).cell_value (); - NoAlias<Cell> y(x.dims ()); - octave_idx_type nel = x.numel (); - octave_value_list idx = args.slice (1, args.length () - 1); - - for (octave_idx_type i = 0; i < nel; i++) - { - octave_quit (); - octave_value tmp = x(i); - y(i) = tmp.do_index_op (idx); - if (error_state) - break; - } - - retval = y; - } - else - error ("cellindexmat: X must be a cell"); - } - else - print_usage (); - - return retval; -}
--- a/src/DLD-FUNCTIONS/colamd.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/DLD-FUNCTIONS/colamd.cc Sat Jul 28 12:06:34 2012 -0400 @@ -63,28 +63,28 @@ if (P) // If P is present then compute Pinv, the inverse of P for (octave_idx_type k = 0 ; k < n ; k++) - Pinv [P [k]] = k ; + Pinv[P[k]] = k ; for (octave_idx_type k = 0 ; k < n ; k++) { // L(k,:) pattern: all nodes reachable in etree from nz in A(0:k-1,k) - Parent [k] = n ; // parent of k is not yet known - Flag [k] = k ; // mark node k as visited - octave_idx_type kk = (P) ? (P [k]) : (k) ; // kth original, or permuted, column - octave_idx_type p2 = cidx [kk+1] ; - for (octave_idx_type p = cidx [kk] ; p < p2 ; p++) + Parent[k] = n ; // parent of k is not yet known + Flag[k] = k ; // mark node k as visited + octave_idx_type kk = (P) ? (P[k]) : (k) ; // kth original, or permuted, column + octave_idx_type p2 = cidx[kk+1] ; + for (octave_idx_type p = cidx[kk] ; p < p2 ; p++) { // A (i,k) is nonzero (original or permuted A) - octave_idx_type i = (Pinv) ? (Pinv [ridx [p]]) : (ridx [p]) ; + octave_idx_type i = (Pinv) ? (Pinv[ridx[p]]) : (ridx[p]) ; if (i < k) { // follow path from i to root of etree, stop at flagged node - for ( ; Flag [i] != k ; i = Parent [i]) + for ( ; Flag[i] != k ; i = Parent[i]) { // find parent of i if not yet determined - if (Parent [i] == n) - Parent [i] = k ; - Flag [i] = k ; // mark i as visited + if (Parent[i] == n) + Parent[i] = k ; + Flag[i] = k ; // mark i as visited } } } @@ -299,11 +299,11 @@ int nel_User_knobs = User_knobs.length (); if (nel_User_knobs > 0) - knobs [COLAMD_DENSE_ROW] = User_knobs (0); + knobs[COLAMD_DENSE_ROW] = User_knobs(0); if (nel_User_knobs > 1) - knobs [COLAMD_DENSE_COL] = User_knobs (1) ; + knobs[COLAMD_DENSE_COL] = User_knobs(1) ; if (nel_User_knobs > 2) - spumoni = static_cast<int> (User_knobs (2)); + spumoni = static_cast<int> (User_knobs(2)); // print knob settings if spumoni is set if (spumoni) @@ -312,19 +312,19 @@ octave_stdout << "\ncolamd version " << COLAMD_MAIN_VERSION << "." << COLAMD_SUB_VERSION << ", " << COLAMD_DATE << ":\n"; - if (knobs [COLAMD_DENSE_ROW] >= 0) + if (knobs[COLAMD_DENSE_ROW] >= 0) octave_stdout << "knobs(1): " << User_knobs (0) << ", rows with > max (16," - << knobs [COLAMD_DENSE_ROW] << "*sqrt (size(A,2)))" + << knobs[COLAMD_DENSE_ROW] << "*sqrt (size(A,2)))" << " entries removed\n"; else octave_stdout << "knobs(1): " << User_knobs (0) << ", only completely dense rows removed\n"; - if (knobs [COLAMD_DENSE_COL] >= 0) + if (knobs[COLAMD_DENSE_COL] >= 0) octave_stdout << "knobs(2): " << User_knobs (1) << ", cols with > max (16," - << knobs [COLAMD_DENSE_COL] << "*sqrt (size(A)))" + << knobs[COLAMD_DENSE_COL] << "*sqrt (size(A)))" << " entries removed\n"; else octave_stdout << "knobs(2): " << User_knobs (1) @@ -380,12 +380,12 @@ // Allocate workspace for colamd OCTAVE_LOCAL_BUFFER (octave_idx_type, p, n_col+1); for (octave_idx_type i = 0; i < n_col+1; i++) - p[i] = cidx [i]; + p[i] = cidx[i]; octave_idx_type Alen = COLAMD_NAME (_recommended) (nnz, n_row, n_col); OCTAVE_LOCAL_BUFFER (octave_idx_type, A, Alen); for (octave_idx_type i = 0; i < nnz; i++) - A[i] = ridx [i]; + A[i] = ridx[i]; // Order the columns (destroys A) OCTAVE_LOCAL_BUFFER (octave_idx_type, stats, COLAMD_STATS); @@ -415,7 +415,7 @@ // return the permutation vector NDArray out_perm (dim_vector (1, n_col)); for (octave_idx_type i = 0; i < n_col; i++) - out_perm(i) = p[colbeg [i]] + 1; + out_perm(i) = p[colbeg[i]] + 1; retval(0) = out_perm; @@ -428,7 +428,7 @@ { NDArray out_stats (dim_vector (1, COLAMD_STATS)); for (octave_idx_type i = 0 ; i < COLAMD_STATS ; i++) - out_stats (i) = stats [i] ; + out_stats(i) = stats[i] ; retval(1) = out_stats; // fix stats (5) and (6), for 1-based information on @@ -534,7 +534,7 @@ int nel_User_knobs = User_knobs.length (); if (nel_User_knobs > 0) - knobs [COLAMD_DENSE_ROW] = User_knobs (COLAMD_DENSE_ROW); + knobs[COLAMD_DENSE_ROW] = User_knobs(COLAMD_DENSE_ROW); if (nel_User_knobs > 1) spumoni = static_cast<int> (User_knobs (1)); } @@ -542,7 +542,7 @@ // print knob settings if spumoni is set if (spumoni > 0) octave_stdout << "symamd: dense row/col fraction: " - << knobs [COLAMD_DENSE_ROW] << std::endl; + << knobs[COLAMD_DENSE_ROW] << std::endl; octave_idx_type n_row, n_col; octave_idx_type *ridx, *cidx; @@ -608,7 +608,7 @@ // return the permutation vector NDArray out_perm (dim_vector (1, n_col)); for (octave_idx_type i = 0; i < n_col; i++) - out_perm(i) = perm[post [i]] + 1; + out_perm(i) = perm[post[i]] + 1; retval(0) = out_perm; @@ -621,7 +621,7 @@ { NDArray out_stats (dim_vector (1, COLAMD_STATS)); for (octave_idx_type i = 0 ; i < COLAMD_STATS ; i++) - out_stats (i) = stats [i] ; + out_stats(i) = stats[i] ; retval(1) = out_stats; // fix stats (5) and (6), for 1-based information on
--- a/src/DLD-FUNCTIONS/colloc.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,139 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include "CollocWt.h" -#include "lo-mappers.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (colloc, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{r}, @var{amat}, @var{bmat}, @var{q}] =} colloc (@var{n}, \"left\", \"right\")\n\ -Compute derivative and integral weight matrices for orthogonal\n\ -collocation using the subroutines given in J. Villadsen and\n\ -M. L. Michelsen, @cite{Solution of Differential Equation Models by\n\ -Polynomial Approximation}.\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 3) - { - print_usage (); - return retval; - } - - if (! args(0).is_scalar_type ()) - { - error ("colloc: N must be a scalar"); - return retval; - } - - double tmp = args(0).double_value (); - - if (error_state) - return retval; - - if (xisnan (tmp)) - { - error ("colloc: N cannot be NaN"); - return retval; - } - - octave_idx_type ncol = NINTbig (tmp); - if (ncol < 0) - { - error ("colloc: N must be positive"); - return retval; - } - - octave_idx_type ntot = ncol; - octave_idx_type left = 0; - octave_idx_type right = 0; - - for (int i = 1; i < nargin; i++) - { - if (args(i).is_defined ()) - { - if (! args(i).is_string ()) - { - error ("colloc: expecting string argument \"left\" or \"right\""); - return retval; - } - - std::string s = args(i).string_value (); - - if ((s.length () == 1 && (s[0] == 'R' || s[0] == 'r')) - || s == "right") - { - right = 1; - } - else if ((s.length () == 1 && (s[0] == 'L' || s[0] == 'l')) - || s == "left") - { - left = 1; - } - else - { - error ("colloc: unrecognized argument"); - return retval; - } - } - else - { - error ("colloc: unexpected empty argument"); - return retval; - } - } - - ntot += left + right; - if (ntot < 1) - { - error ("colloc: the total number of roots must be positive"); - return retval; - } - - CollocWt wts (ncol, left, right); - - ColumnVector r = wts.roots (); - Matrix A = wts.first (); - Matrix B = wts.second (); - ColumnVector q = wts.quad_weights (); - - retval(3) = q; - retval(2) = B; - retval(1) = A; - retval(0) = r; - - return retval; -}
--- a/src/DLD-FUNCTIONS/config-module.awk Sat Jul 28 15:17:57 2012 +0200 +++ b/src/DLD-FUNCTIONS/config-module.awk Sat Jul 28 12:06:34 2012 -0400 @@ -52,7 +52,7 @@ } print "else"; print ""; - print "noinst_LTLIBRARIES = $(DLD_FUNCTIONS_LIBS)"; + print "noinst_LTLIBRARIES += $(DLD_FUNCTIONS_LIBS)"; print ""; print "endif";
--- a/src/DLD-FUNCTIONS/conv2.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -/* - -Copyright (C) 1999-2012 Andy Adler -Copyright (C) 2010 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "oct-convn.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" -#include "utils.h" - -enum Shape { SHAPE_FULL, SHAPE_SAME, SHAPE_VALID }; - -DEFUN_DLD (conv2, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} conv2 (@var{A}, @var{B})\n\ -@deftypefnx {Loadable Function} {} conv2 (@var{v1}, @var{v2}, @var{m})\n\ -@deftypefnx {Loadable Function} {} conv2 (@dots{}, @var{shape})\n\ -Return the 2-D convolution of @var{A} and @var{B}. The size of the result\n\ -is determined by the optional @var{shape} argument which takes the following\n\ -values\n\ -\n\ -@table @asis\n\ -@item @var{shape} = \"full\"\n\ -Return the full convolution. (default)\n\ -\n\ -@item @var{shape} = \"same\"\n\ -Return the central part of the convolution with the same size as @var{A}.\n\ -The central part of the convolution begins at the indices\n\ -@code{floor ([size(@var{B})/2] + 1)}.\n\ -\n\ -@item @var{shape} = \"valid\"\n\ -Return only the parts which do not include zero-padded edges.\n\ -The size of the result is @code{max (size (A) - size (B) + 1, 0)}.\n\ -@end table\n\ -\n\ -When the third argument is a matrix, return the convolution of the matrix\n\ -@var{m} by the vector @var{v1} in the column direction and by the vector\n\ -@var{v2} in the row direction.\n\ -@seealso{conv, convn}\n\ -@end deftypefn") -{ - octave_value retval; - octave_value tmp; - int nargin = args.length (); - std::string shape = "full"; // default - bool separable = false; - convn_type ct; - - if (nargin < 2) - { - print_usage (); - return retval; - } - else if (nargin == 3) - { - if (args(2).is_string ()) - shape = args(2).string_value (); - else - separable = true; - } - else if (nargin >= 4) - { - separable = true; - shape = args(3).string_value (); - } - - if (shape == "full") - ct = convn_full; - else if (shape == "same") - ct = convn_same; - else if (shape == "valid") - ct = convn_valid; - else - { - error ("conv2: SHAPE type not valid"); - print_usage (); - return retval; - } - - if (separable) - { - // If user requests separable, check first two params are vectors - - if (! (1 == args(0).rows () || 1 == args(0).columns ()) - || ! (1 == args(1).rows () || 1 == args(1).columns ())) - { - print_usage (); - return retval; - } - - if (args(0).is_single_type () || args(1).is_single_type () - || args(2).is_single_type ()) - { - if (args(0).is_complex_type () || args(1).is_complex_type () - || args(2).is_complex_type ()) - { - FloatComplexMatrix a (args(2).float_complex_matrix_value ()); - if (args(1).is_real_type () && args(2).is_real_type ()) - { - FloatColumnVector v1 (args(0).float_vector_value ()); - FloatRowVector v2 (args(1).float_vector_value ()); - retval = convn (a, v1, v2, ct); - } - else - { - FloatComplexColumnVector v1 (args(0).float_complex_vector_value ()); - FloatComplexRowVector v2 (args(1).float_complex_vector_value ()); - retval = convn (a, v1, v2, ct); - } - } - else - { - FloatColumnVector v1 (args(0).float_vector_value ()); - FloatRowVector v2 (args(1).float_vector_value ()); - FloatMatrix a (args(2).float_matrix_value ()); - retval = convn (a, v1, v2, ct); - } - } - else - { - if (args(0).is_complex_type () || args(1).is_complex_type () - || args(2).is_complex_type ()) - { - ComplexMatrix a (args(2).complex_matrix_value ()); - if (args(1).is_real_type () && args(2).is_real_type ()) - { - ColumnVector v1 (args(0).vector_value ()); - RowVector v2 (args(1).vector_value ()); - retval = convn (a, v1, v2, ct); - } - else - { - ComplexColumnVector v1 (args(0).complex_vector_value ()); - ComplexRowVector v2 (args(1).complex_vector_value ()); - retval = convn (a, v1, v2, ct); - } - } - else - { - ColumnVector v1 (args(0).vector_value ()); - RowVector v2 (args(1).vector_value ()); - Matrix a (args(2).matrix_value ()); - retval = convn (a, v1, v2, ct); - } - } - } // if (separable) - else - { - if (args(0).is_single_type () || args(1).is_single_type ()) - { - if (args(0).is_complex_type () || args(1).is_complex_type ()) - { - FloatComplexMatrix a (args(0).float_complex_matrix_value ()); - if (args(1).is_real_type ()) - { - FloatMatrix b (args(1).float_matrix_value ()); - retval = convn (a, b, ct); - } - else - { - FloatComplexMatrix b (args(1).float_complex_matrix_value ()); - retval = convn (a, b, ct); - } - } - else - { - FloatMatrix a (args(0).float_matrix_value ()); - FloatMatrix b (args(1).float_matrix_value ()); - retval = convn (a, b, ct); - } - } - else - { - if (args(0).is_complex_type () || args(1).is_complex_type ()) - { - ComplexMatrix a (args(0).complex_matrix_value ()); - if (args(1).is_real_type ()) - { - Matrix b (args(1).matrix_value ()); - retval = convn (a, b, ct); - } - else - { - ComplexMatrix b (args(1).complex_matrix_value ()); - retval = convn (a, b, ct); - } - } - else - { - Matrix a (args(0).matrix_value ()); - Matrix b (args(1).matrix_value ()); - retval = convn (a, b, ct); - } - } - - } // if (separable) - - return retval; -} - -/* -%!test -%! c = [0,1,2,3;1,8,12,12;4,20,24,21;7,22,25,18]; -%! assert (conv2 ([0,1;1,2], [1,2,3;4,5,6;7,8,9]), c); - -%!test -%! c = single ([0,1,2,3;1,8,12,12;4,20,24,21;7,22,25,18]); -%! assert (conv2 (single ([0,1;1,2]), single ([1,2,3;4,5,6;7,8,9])), c); - -%!test -%! c = [1,4,4;5,18,16;14,48,40;19,62,48;15,48,36]; -%! assert (conv2 (1:3, 1:2, [1,2;3,4;5,6]), c); - -%!assert (conv2 (1:3, 1:2, [1,2;3,4;5,6], "full"), -%! conv2 (1:3, 1:2, [1,2;3,4;5,6])); - -%% Test shapes -%!shared A, B, C -%! A = rand (3, 4); -%! B = rand (4); -%! C = conv2 (A, B); -%!assert (conv2 (A,B, "full"), C) -%!assert (conv2 (A,B, "same"), C(3:5,3:6)) -%!assert (conv2 (A,B, "valid"), zeros (0, 1)) -%!assert (size (conv2 (B,A, "valid")), [2 1]) - -%!test -%! B = rand (5); -%! C = conv2 (A, B); -%!assert (conv2 (A,B, "full"), C) -%!assert (conv2 (A,B, "same"), C(3:5,3:6)) -%!assert (conv2 (A,B, "valid"), zeros (0, 0)) -%!assert (size (conv2 (B,A, "valid")), [3 2]) - -%% Clear shared variables so they are not reported for tests below -%!shared - -%% Test cases from Bug #34893 -%!assert (conv2 ([1:5;1:5], [1:2], "same"), [4 7 10 13 10; 4 7 10 13 10]) -%!assert (conv2 ([1:5;1:5]', [1:2]', "same"), [4 7 10 13 10; 4 7 10 13 10]') -%!assert (conv2 ([1:5;1:5], [1:2], "valid"), [4 7 10 13; 4 7 10 13]) -%!assert (conv2 ([1:5;1:5]', [1:2]', "valid"), [4 7 10 13; 4 7 10 13]') - -%!test -%! rand ("seed", 42); -%! x = rand (100); -%! y = ones (5); -%! A = conv2 (x, y)(5:end-4,5:end-4); -%! B = conv2 (x, y, "valid"); -%! assert (B, A); ## Yes, this test is for *exact* equivalence. - - -%% Test input validation -%!error conv2 () -%!error conv2 (1) -%!error <SHAPE type not valid> conv2 (1,2, "NOT_A_SHAPE") -%% Test alternate calling form which should be 2 vectors and a matrix -%!error conv2 (ones (2), 1, 1) -%!error conv2 (1, ones (2), 1) -*/ - -DEFUN_DLD (convn, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{C} =} convn (@var{A}, @var{B})\n\ -@deftypefnx {Loadable Function} {@var{C} =} convn (@var{A}, @var{B}, @var{shape})\n\ -Return the n-D convolution of @var{A} and @var{B}. The size of the result\n\ -is determined by the optional @var{shape} argument which takes the following\n\ -values\n\ -\n\ -@table @asis\n\ -@item @var{shape} = \"full\"\n\ -Return the full convolution. (default)\n\ -\n\ -@item @var{shape} = \"same\"\n\ -Return central part of the convolution with the same size as @var{A}.\n\ -The central part of the convolution begins at the indices\n\ -@code{floor ([size(@var{B})/2] + 1)}.\n\ -\n\ -@item @var{shape} = \"valid\"\n\ -Return only the parts which do not include zero-padded edges.\n\ -The size of the result is @code{max (size (A) - size (B) + 1, 0)}.\n\ -@end table\n\ -\n\ -@seealso{conv2, conv}\n\ -@end deftypefn") -{ - octave_value retval; - octave_value tmp; - int nargin = args.length (); - std::string shape = "full"; // default - convn_type ct; - - if (nargin < 2 || nargin > 3) - { - print_usage (); - return retval; - } - else if (nargin == 3) - { - if (args(2).is_string ()) - shape = args(2).string_value (); - } - - if (shape == "full") - ct = convn_full; - else if (shape == "same") - ct = convn_same; - else if (shape == "valid") - ct = convn_valid; - else - { - error ("convn: SHAPE type not valid"); - print_usage (); - return retval; - } - - if (args(0).is_single_type () || args(1).is_single_type ()) - { - if (args(0).is_complex_type () || args(1).is_complex_type ()) - { - FloatComplexNDArray a (args(0).float_complex_array_value ()); - if (args(1).is_real_type ()) - { - FloatNDArray b (args(1).float_array_value ()); - retval = convn (a, b, ct); - } - else - { - FloatComplexNDArray b (args(1).float_complex_array_value ()); - retval = convn (a, b, ct); - } - } - else - { - FloatNDArray a (args(0).float_array_value ()); - FloatNDArray b (args(1).float_array_value ()); - retval = convn (a, b, ct); - } - } - else - { - if (args(0).is_complex_type () || args(1).is_complex_type ()) - { - ComplexNDArray a (args(0).complex_array_value ()); - if (args(1).is_real_type ()) - { - NDArray b (args(1).array_value ()); - retval = convn (a, b, ct); - } - else - { - ComplexNDArray b (args(1).complex_array_value ()); - retval = convn (a, b, ct); - } - } - else - { - NDArray a (args(0).array_value ()); - NDArray b (args(1).array_value ()); - retval = convn (a, b, ct); - } - } - - return retval; -} - -/* - FIXME: Need tests for convn in addition to conv2. -*/
--- a/src/DLD-FUNCTIONS/daspk.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,480 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include <iomanip> -#include <iostream> - -#include "DASPK.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "ov-fcn.h" -#include "ov-cell.h" -#include "pager.h" -#include "unwind-prot.h" -#include "utils.h" -#include "variables.h" - -#include "DASPK-opts.cc" - -// Global pointer for user defined function required by daspk. -static octave_function *daspk_fcn; - -// Global pointer for optional user defined jacobian function. -static octave_function *daspk_jac; - -// Have we warned about imaginary values returned from user function? -static bool warned_fcn_imaginary = false; -static bool warned_jac_imaginary = false; - -// Is this a recursive call? -static int call_depth = 0; - -ColumnVector -daspk_user_function (const ColumnVector& x, const ColumnVector& xdot, - double t, octave_idx_type& ires) -{ - ColumnVector retval; - - assert (x.capacity () == xdot.capacity ()); - - octave_value_list args; - - args(2) = t; - args(1) = xdot; - args(0) = x; - - if (daspk_fcn) - { - octave_value_list tmp = daspk_fcn->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("daspk"); - return retval; - } - - int tlen = tmp.length (); - if (tlen > 0 && tmp(0).is_defined ()) - { - if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) - { - warning ("daspk: ignoring imaginary part returned from user-supplied function"); - warned_fcn_imaginary = true; - } - - retval = ColumnVector (tmp(0).vector_value ()); - - if (tlen > 1) - ires = tmp(1).int_value (); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("daspk"); - } - else - gripe_user_supplied_eval ("daspk"); - } - - return retval; -} - -Matrix -daspk_user_jacobian (const ColumnVector& x, const ColumnVector& xdot, - double t, double cj) -{ - Matrix retval; - - assert (x.capacity () == xdot.capacity ()); - - octave_value_list args; - - args(3) = cj; - args(2) = t; - args(1) = xdot; - args(0) = x; - - if (daspk_jac) - { - octave_value_list tmp = daspk_jac->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("daspk"); - return retval; - } - - int tlen = tmp.length (); - if (tlen > 0 && tmp(0).is_defined ()) - { - if (! warned_jac_imaginary && tmp(0).is_complex_type ()) - { - warning ("daspk: ignoring imaginary part returned from user-supplied jacobian function"); - warned_jac_imaginary = true; - } - - retval = tmp(0).matrix_value (); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("daspk"); - } - else - gripe_user_supplied_eval ("daspk"); - } - - return retval; -} - -#define DASPK_ABORT() \ - return retval - -#define DASPK_ABORT1(msg) \ - do \ - { \ - ::error ("daspk: " msg); \ - DASPK_ABORT (); \ - } \ - while (0) - -#define DASPK_ABORT2(fmt, arg) \ - do \ - { \ - ::error ("daspk: " fmt, arg); \ - DASPK_ABORT (); \ - } \ - while (0) - -DEFUN_DLD (daspk, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{x}, @var{xdot}, @var{istate}, @var{msg}] =} daspk (@var{fcn}, @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ -Solve the set of differential-algebraic equations\n\ -@tex\n\ -$$ 0 = f (x, \\dot{x}, t) $$\n\ -with\n\ -$$ x(t_0) = x_0, \\dot{x}(t_0) = \\dot{x}_0 $$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -0 = f (x, xdot, t)\n\ -@end example\n\ -\n\ -@noindent\n\ -with\n\ -\n\ -@example\n\ -x(t_0) = x_0, xdot(t_0) = xdot_0\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -The solution is returned in the matrices @var{x} and @var{xdot},\n\ -with each row in the result matrices corresponding to one of the\n\ -elements in the vector @var{t}. The first element of @var{t}\n\ -should be @math{t_0} and correspond to the initial state of the\n\ -system @var{x_0} and its derivative @var{xdot_0}, so that the first\n\ -row of the output @var{x} is @var{x_0} and the first row\n\ -of the output @var{xdot} is @var{xdot_0}.\n\ -\n\ -The first argument, @var{fcn}, is a string, inline, or function handle\n\ -that names the function @math{f} to call to compute the vector of\n\ -residuals for the set of equations. It must have the form\n\ -\n\ -@example\n\ -@var{res} = f (@var{x}, @var{xdot}, @var{t})\n\ -@end example\n\ -\n\ -@noindent\n\ -in which @var{x}, @var{xdot}, and @var{res} are vectors, and @var{t} is a\n\ -scalar.\n\ -\n\ -If @var{fcn} is a two-element string array or a two-element cell array\n\ -of strings, inline functions, or function handles, the first element names\n\ -the function @math{f} described above, and the second element names a\n\ -function to compute the modified Jacobian\n\ -@tex\n\ -$$\n\ -J = {\\partial f \\over \\partial x}\n\ - + c {\\partial f \\over \\partial \\dot{x}}\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ - df df\n\ -jac = -- + c ------\n\ - dx d xdot\n\ -@end group\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -\n\ -The modified Jacobian function must have the form\n\ -\n\ -@example\n\ -@group\n\ -\n\ -@var{jac} = j (@var{x}, @var{xdot}, @var{t}, @var{c})\n\ -\n\ -@end group\n\ -@end example\n\ -\n\ -The second and third arguments to @code{daspk} specify the initial\n\ -condition of the states and their derivatives, and the fourth argument\n\ -specifies a vector of output times at which the solution is desired,\n\ -including the time corresponding to the initial condition.\n\ -\n\ -The set of initial states and derivatives are not strictly required to\n\ -be consistent. If they are not consistent, you must use the\n\ -@code{daspk_options} function to provide additional information so\n\ -that @code{daspk} can compute a consistent starting point.\n\ -\n\ -The fifth argument is optional, and may be used to specify a set of\n\ -times that the DAE solver should not integrate past. It is useful for\n\ -avoiding difficulties with singularities and points where there is a\n\ -discontinuity in the derivative.\n\ -\n\ -After a successful computation, the value of @var{istate} will be\n\ -greater than zero (consistent with the Fortran version of @sc{daspk}).\n\ -\n\ -If the computation is not successful, the value of @var{istate} will be\n\ -less than zero and @var{msg} will contain additional information.\n\ -\n\ -You can use the function @code{daspk_options} to set optional\n\ -parameters for @code{daspk}.\n\ -@seealso{dassl}\n\ -@end deftypefn") -{ - octave_value_list retval; - - warned_fcn_imaginary = false; - warned_jac_imaginary = false; - - unwind_protect frame; - - frame.protect_var (call_depth); - call_depth++; - - if (call_depth > 1) - DASPK_ABORT1 ("invalid recursive call"); - - int nargin = args.length (); - - if (nargin > 3 && nargin < 6) - { - std::string fcn_name, fname, jac_name, jname; - daspk_fcn = 0; - daspk_jac = 0; - - octave_value f_arg = args(0); - - if (f_arg.is_cell ()) - { - Cell c = f_arg.cell_value (); - if (c.length () == 1) - f_arg = c(0); - else if (c.length () == 2) - { - if (c(0).is_function_handle () || c(0).is_inline_function ()) - daspk_fcn = c(0).function_value (); - else - { - fcn_name = unique_symbol_name ("__daspk_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - daspk_fcn = extract_function - (c(0), "daspk", fcn_name, fname, "; endfunction"); - } - - if (daspk_fcn) - { - if (c(1).is_function_handle () || c(1).is_inline_function ()) - daspk_jac = c(1).function_value (); - else - { - jac_name = unique_symbol_name ("__daspk_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, xdot, t, cj) jac = "); - daspk_jac = extract_function - (c(1), "daspk", jac_name, jname, "; endfunction"); - - if (!daspk_jac) - { - if (fcn_name.length ()) - clear_function (fcn_name); - daspk_fcn = 0; - } - } - } - } - else - DASPK_ABORT1 ("incorrect number of elements in cell array"); - } - - if (!daspk_fcn && ! f_arg.is_cell ()) - { - if (f_arg.is_function_handle () || f_arg.is_inline_function ()) - daspk_fcn = f_arg.function_value (); - else - { - switch (f_arg.rows ()) - { - case 1: - do - { - fcn_name = unique_symbol_name ("__daspk_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - daspk_fcn = extract_function - (f_arg, "daspk", fcn_name, fname, "; endfunction"); - } - while (0); - break; - - case 2: - { - string_vector tmp = f_arg.all_strings (); - - if (! error_state) - { - fcn_name = unique_symbol_name ("__daspk_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - daspk_fcn = extract_function - (tmp(0), "daspk", fcn_name, fname, "; endfunction"); - - if (daspk_fcn) - { - jac_name = unique_symbol_name ("__daspk_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, xdot, t, cj) jac = "); - daspk_jac = extract_function - (tmp(1), "daspk", jac_name, jname, - "; endfunction"); - - if (!daspk_jac) - { - if (fcn_name.length ()) - clear_function (fcn_name); - daspk_fcn = 0; - } - } - } - } - } - } - } - - if (error_state || ! daspk_fcn) - DASPK_ABORT (); - - ColumnVector state = ColumnVector (args(1).vector_value ()); - - if (error_state) - DASPK_ABORT1 ("expecting state vector as second argument"); - - ColumnVector deriv (args(2).vector_value ()); - - if (error_state) - DASPK_ABORT1 ("expecting derivative vector as third argument"); - - ColumnVector out_times (args(3).vector_value ()); - - if (error_state) - DASPK_ABORT1 ("expecting output time vector as fourth argument"); - - ColumnVector crit_times; - int crit_times_set = 0; - if (nargin > 4) - { - crit_times = ColumnVector (args(4).vector_value ()); - - if (error_state) - DASPK_ABORT1 ("expecting critical time vector as fifth argument"); - - crit_times_set = 1; - } - - if (state.capacity () != deriv.capacity ()) - DASPK_ABORT1 ("x and xdot must have the same size"); - - double tzero = out_times (0); - - DAEFunc func (daspk_user_function); - if (daspk_jac) - func.set_jacobian_function (daspk_user_jacobian); - - DASPK dae (state, deriv, tzero, func); - dae.set_options (daspk_opts); - - Matrix output; - Matrix deriv_output; - - if (crit_times_set) - output = dae.integrate (out_times, deriv_output, crit_times); - else - output = dae.integrate (out_times, deriv_output); - - if (fcn_name.length ()) - clear_function (fcn_name); - if (jac_name.length ()) - clear_function (jac_name); - - if (! error_state) - { - std::string msg = dae.error_message (); - - retval(3) = msg; - retval(2) = static_cast<double> (dae.integration_state ()); - - if (dae.integration_ok ()) - { - retval(1) = deriv_output; - retval(0) = output; - } - else - { - retval(1) = Matrix (); - retval(0) = Matrix (); - - if (nargout < 3) - error ("daspk: %s", msg.c_str ()); - } - } - } - else - print_usage (); - - return retval; -}
--- a/src/DLD-FUNCTIONS/dasrt.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,590 +0,0 @@ -/* - -Copyright (C) 2002-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <iostream> -#include <string> - -#include "DASRT.h" -#include "lo-mappers.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "ov-fcn.h" -#include "ov-cell.h" -#include "pager.h" -#include "parse.h" -#include "unwind-prot.h" -#include "utils.h" -#include "variables.h" - -#include "DASRT-opts.cc" - -// Global pointers for user defined function required by dasrt. -static octave_function *dasrt_f; -static octave_function *dasrt_j; -static octave_function *dasrt_cf; - -// Have we warned about imaginary values returned from user function? -static bool warned_fcn_imaginary = false; -static bool warned_jac_imaginary = false; -static bool warned_cf_imaginary = false; - -// Is this a recursive call? -static int call_depth = 0; - -static ColumnVector -dasrt_user_f (const ColumnVector& x, const ColumnVector& xdot, - double t, octave_idx_type&) -{ - ColumnVector retval; - - assert (x.capacity () == xdot.capacity ()); - - octave_value_list args; - - args(2) = t; - args(1) = xdot; - args(0) = x; - - if (dasrt_f) - { - octave_value_list tmp = dasrt_f->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("dasrt"); - return retval; - } - - if (tmp.length () > 0 && tmp(0).is_defined ()) - { - if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) - { - warning ("dasrt: ignoring imaginary part returned from user-supplied function"); - warned_fcn_imaginary = true; - } - - retval = ColumnVector (tmp(0).vector_value ()); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("dasrt"); - } - else - gripe_user_supplied_eval ("dasrt"); - } - - return retval; -} - -static ColumnVector -dasrt_user_cf (const ColumnVector& x, double t) -{ - ColumnVector retval; - - octave_value_list args; - - args(1) = t; - args(0) = x; - - if (dasrt_cf) - { - octave_value_list tmp = dasrt_cf->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("dasrt"); - return retval; - } - - if (tmp.length () > 0 && tmp(0).is_defined ()) - { - if (! warned_cf_imaginary && tmp(0).is_complex_type ()) - { - warning ("dasrt: ignoring imaginary part returned from user-supplied constraint function"); - warned_cf_imaginary = true; - } - - retval = ColumnVector (tmp(0).vector_value ()); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("dasrt"); - } - else - gripe_user_supplied_eval ("dasrt"); - } - - return retval; -} - -static Matrix -dasrt_user_j (const ColumnVector& x, const ColumnVector& xdot, - double t, double cj) -{ - Matrix retval; - - assert (x.capacity () == xdot.capacity ()); - - octave_value_list args; - - args(3) = cj; - args(2) = t; - args(1) = xdot; - args(0) = x; - - if (dasrt_j) - { - octave_value_list tmp = dasrt_j->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("dasrt"); - return retval; - } - - int tlen = tmp.length (); - if (tlen > 0 && tmp(0).is_defined ()) - { - if (! warned_jac_imaginary && tmp(0).is_complex_type ()) - { - warning ("dasrt: ignoring imaginary part returned from user-supplied jacobian function"); - warned_jac_imaginary = true; - } - - retval = tmp(0).matrix_value (); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("dasrt"); - } - else - gripe_user_supplied_eval ("dasrt"); - } - - return retval; -} - -#define DASRT_ABORT \ - return retval - -#define DASRT_ABORT1(msg) \ - do \ - { \ - ::error ("dasrt: " msg); \ - DASRT_ABORT; \ - } \ - while (0) - -#define DASRT_ABORT2(fmt, arg) \ - do \ - { \ - ::error ("dasrt: " fmt, arg); \ - DASRT_ABORT; \ - } \ - while (0) - -DEFUN_DLD (dasrt, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{x}, @var{xdot}, @var{t_out}, @var{istat}, @var{msg}] =} dasrt (@var{fcn}, [], @var{x_0}, @var{xdot_0}, @var{t})\n\ -@deftypefnx {Loadable Function} {@dots{} =} dasrt (@var{fcn}, @var{g}, @var{x_0}, @var{xdot_0}, @var{t})\n\ -@deftypefnx {Loadable Function} {@dots{} =} dasrt (@var{fcn}, [], @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ -@deftypefnx {Loadable Function} {@dots{} =} dasrt (@var{fcn}, @var{g}, @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ -Solve the set of differential-algebraic equations\n\ -@tex\n\ -$$ 0 = f (x, \\dot{x}, t) $$\n\ -with\n\ -$$ x(t_0) = x_0, \\dot{x}(t_0) = \\dot{x}_0 $$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -0 = f (x, xdot, t)\n\ -@end example\n\ -\n\ -@noindent\n\ -with\n\ -\n\ -@example\n\ -x(t_0) = x_0, xdot(t_0) = xdot_0\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -with functional stopping criteria (root solving).\n\ -\n\ -The solution is returned in the matrices @var{x} and @var{xdot},\n\ -with each row in the result matrices corresponding to one of the\n\ -elements in the vector @var{t_out}. The first element of @var{t}\n\ -should be @math{t_0} and correspond to the initial state of the\n\ -system @var{x_0} and its derivative @var{xdot_0}, so that the first\n\ -row of the output @var{x} is @var{x_0} and the first row\n\ -of the output @var{xdot} is @var{xdot_0}.\n\ -\n\ -The vector @var{t} provides an upper limit on the length of the\n\ -integration. If the stopping condition is met, the vector\n\ -@var{t_out} will be shorter than @var{t}, and the final element of\n\ -@var{t_out} will be the point at which the stopping condition was met,\n\ -and may not correspond to any element of the vector @var{t}.\n\ -\n\ -The first argument, @var{fcn}, is a string, inline, or function handle\n\ -that names the function @math{f} to call to compute the vector of\n\ -residuals for the set of equations. It must have the form\n\ -\n\ -@example\n\ -@var{res} = f (@var{x}, @var{xdot}, @var{t})\n\ -@end example\n\ -\n\ -@noindent\n\ -in which @var{x}, @var{xdot}, and @var{res} are vectors, and @var{t} is a\n\ -scalar.\n\ -\n\ -If @var{fcn} is a two-element string array or a two-element cell array\n\ -of strings, inline functions, or function handles, the first element names\n\ -the function @math{f} described above, and the second element names a\n\ -function to compute the modified Jacobian\n\ -\n\ -@tex\n\ -$$\n\ -J = {\\partial f \\over \\partial x}\n\ - + c {\\partial f \\over \\partial \\dot{x}}\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ - df df\n\ -jac = -- + c ------\n\ - dx d xdot\n\ -@end group\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -\n\ -The modified Jacobian function must have the form\n\ -\n\ -@example\n\ -@group\n\ -\n\ -@var{jac} = j (@var{x}, @var{xdot}, @var{t}, @var{c})\n\ -\n\ -@end group\n\ -@end example\n\ -\n\ -The optional second argument names a function that defines the\n\ -constraint functions whose roots are desired during the integration.\n\ -This function must have the form\n\ -\n\ -@example\n\ -@var{g_out} = g (@var{x}, @var{t})\n\ -@end example\n\ -\n\ -@noindent\n\ -and return a vector of the constraint function values.\n\ -If the value of any of the constraint functions changes sign, @sc{dasrt}\n\ -will attempt to stop the integration at the point of the sign change.\n\ -\n\ -If the name of the constraint function is omitted, @code{dasrt} solves\n\ -the same problem as @code{daspk} or @code{dassl}.\n\ -\n\ -Note that because of numerical errors in the constraint functions\n\ -due to round-off and integration error, @sc{dasrt} may return false\n\ -roots, or return the same root at two or more nearly equal values of\n\ -@var{T}. If such false roots are suspected, the user should consider\n\ -smaller error tolerances or higher precision in the evaluation of the\n\ -constraint functions.\n\ -\n\ -If a root of some constraint function defines the end of the problem,\n\ -the input to @sc{dasrt} should nevertheless allow integration to a\n\ -point slightly past that root, so that @sc{dasrt} can locate the root\n\ -by interpolation.\n\ -\n\ -The third and fourth arguments to @code{dasrt} specify the initial\n\ -condition of the states and their derivatives, and the fourth argument\n\ -specifies a vector of output times at which the solution is desired,\n\ -including the time corresponding to the initial condition.\n\ -\n\ -The set of initial states and derivatives are not strictly required to\n\ -be consistent. In practice, however, @sc{dassl} is not very good at\n\ -determining a consistent set for you, so it is best if you ensure that\n\ -the initial values result in the function evaluating to zero.\n\ -\n\ -The sixth argument is optional, and may be used to specify a set of\n\ -times that the DAE solver should not integrate past. It is useful for\n\ -avoiding difficulties with singularities and points where there is a\n\ -discontinuity in the derivative.\n\ -\n\ -After a successful computation, the value of @var{istate} will be\n\ -greater than zero (consistent with the Fortran version of @sc{dassl}).\n\ -\n\ -If the computation is not successful, the value of @var{istate} will be\n\ -less than zero and @var{msg} will contain additional information.\n\ -\n\ -You can use the function @code{dasrt_options} to set optional\n\ -parameters for @code{dasrt}.\n\ -@seealso{dasrt_options, daspk, dasrt, lsode}\n\ -@end deftypefn") -{ - octave_value_list retval; - - warned_fcn_imaginary = false; - warned_jac_imaginary = false; - warned_cf_imaginary = false; - - unwind_protect frame; - - frame.protect_var (call_depth); - call_depth++; - - if (call_depth > 1) - DASRT_ABORT1 ("invalid recursive call"); - - int argp = 0; - - int nargin = args.length (); - - if (nargin < 4 || nargin > 6) - { - print_usage (); - return retval; - } - - std::string fcn_name, fname, jac_name, jname; - dasrt_f = 0; - dasrt_j = 0; - dasrt_cf = 0; - - // Check all the arguments. Are they the right animals? - - // Here's where I take care of f and j in one shot: - - octave_value f_arg = args(0); - - if (f_arg.is_cell ()) - { - Cell c = f_arg.cell_value (); - if (c.length () == 1) - f_arg = c(0); - else if (c.length () == 2) - { - if (c(0).is_function_handle () || c(0).is_inline_function ()) - dasrt_f = c(0).function_value (); - else - { - fcn_name = unique_symbol_name ("__dasrt_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - dasrt_f = extract_function - (c(0), "dasrt", fcn_name, fname, "; endfunction"); - } - - if (dasrt_f) - { - if (c(1).is_function_handle () || c(1).is_inline_function ()) - dasrt_j = c(1).function_value (); - else - { - jac_name = unique_symbol_name ("__dasrt_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, xdot, t, cj) jac = "); - dasrt_j = extract_function - (c(1), "dasrt", jac_name, jname, "; endfunction"); - - if (!dasrt_j) - { - if (fcn_name.length ()) - clear_function (fcn_name); - dasrt_f = 0; - } - } - } - } - else - DASRT_ABORT1 ("incorrect number of elements in cell array"); - } - - if (!dasrt_f && ! f_arg.is_cell ()) - { - if (f_arg.is_function_handle () || f_arg.is_inline_function ()) - dasrt_f = f_arg.function_value (); - else - { - switch (f_arg.rows ()) - { - case 1: - fcn_name = unique_symbol_name ("__dasrt_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - dasrt_f = extract_function - (f_arg, "dasrt", fcn_name, fname, "; endfunction"); - break; - - case 2: - { - string_vector tmp = args(0).all_strings (); - - if (! error_state) - { - fcn_name = unique_symbol_name ("__dasrt_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - dasrt_f = extract_function - (tmp(0), "dasrt", fcn_name, fname, "; endfunction"); - - if (dasrt_f) - { - jac_name = unique_symbol_name ("__dasrt_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, xdot, t, cj) jac = "); - dasrt_j = extract_function - (tmp(1), "dasrt", jac_name, jname, "; endfunction"); - - if (! dasrt_j) - dasrt_f = 0; - } - } - } - break; - - default: - DASRT_ABORT1 - ("first arg should be a string or 2-element string array"); - } - } - } - - if (error_state || (! dasrt_f)) - DASRT_ABORT; - - DAERTFunc func (dasrt_user_f); - - argp++; - - if (args(1).is_function_handle () || args(1).is_inline_function ()) - { - dasrt_cf = args(1).function_value (); - - if (! dasrt_cf) - DASRT_ABORT1 ("expecting function name as argument 2"); - - argp++; - - func.set_constraint_function (dasrt_user_cf); - } - else if (args(1).is_string ()) - { - dasrt_cf = is_valid_function (args(1), "dasrt", true); - if (! dasrt_cf) - DASRT_ABORT1 ("expecting function name as argument 2"); - - argp++; - - func.set_constraint_function (dasrt_user_cf); - } - - ColumnVector state (args(argp++).vector_value ()); - - if (error_state) - DASRT_ABORT2 ("expecting state vector as argument %d", argp); - - ColumnVector stateprime (args(argp++).vector_value ()); - - if (error_state) - DASRT_ABORT2 - ("expecting time derivative of state vector as argument %d", argp); - - ColumnVector out_times (args(argp++).vector_value ()); - - if (error_state) - DASRT_ABORT2 - ("expecting output time vector as %s argument %d", argp); - - double tzero = out_times (0); - - ColumnVector crit_times; - - bool crit_times_set = false; - - if (argp < nargin) - { - crit_times = ColumnVector (args(argp++).vector_value ()); - - if (error_state) - DASRT_ABORT2 - ("expecting critical time vector as argument %d", argp); - - crit_times_set = true; - } - - if (dasrt_j) - func.set_jacobian_function (dasrt_user_j); - - DASRT_result output; - - DASRT dae = DASRT (state, stateprime, tzero, func); - - dae.set_options (dasrt_opts); - - if (crit_times_set) - output = dae.integrate (out_times, crit_times); - else - output = dae.integrate (out_times); - - if (fcn_name.length ()) - clear_function (fcn_name); - if (jac_name.length ()) - clear_function (jac_name); - - if (! error_state) - { - std::string msg = dae.error_message (); - - retval(4) = msg; - retval(3) = static_cast<double> (dae.integration_state ()); - - if (dae.integration_ok ()) - { - retval(2) = output.times (); - retval(1) = output.deriv (); - retval(0) = output.state (); - } - else - { - retval(2) = Matrix (); - retval(1) = Matrix (); - retval(0) = Matrix (); - - if (nargout < 4) - error ("dasrt: %s", msg.c_str ()); - } - } - - return retval; -}
--- a/src/DLD-FUNCTIONS/dassl.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,565 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include <iomanip> -#include <iostream> - -#include "DASSL.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "ov-fcn.h" -#include "ov-cell.h" -#include "pager.h" -#include "unwind-prot.h" -#include "utils.h" -#include "variables.h" - -#include "DASSL-opts.cc" - -// Global pointer for user defined function required by dassl. -static octave_function *dassl_fcn; - -// Global pointer for optional user defined jacobian function. -static octave_function *dassl_jac; - -// Have we warned about imaginary values returned from user function? -static bool warned_fcn_imaginary = false; -static bool warned_jac_imaginary = false; - -// Is this a recursive call? -static int call_depth = 0; - -ColumnVector -dassl_user_function (const ColumnVector& x, const ColumnVector& xdot, - double t, octave_idx_type& ires) -{ - ColumnVector retval; - - assert (x.capacity () == xdot.capacity ()); - - octave_value_list args; - - args(2) = t; - args(1) = xdot; - args(0) = x; - - if (dassl_fcn) - { - octave_value_list tmp = dassl_fcn->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("dassl"); - return retval; - } - - int tlen = tmp.length (); - if (tlen > 0 && tmp(0).is_defined ()) - { - if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) - { - warning ("dassl: ignoring imaginary part returned from user-supplied function"); - warned_fcn_imaginary = true; - } - - retval = ColumnVector (tmp(0).vector_value ()); - - if (tlen > 1) - ires = tmp(1).int_value (); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("dassl"); - } - else - gripe_user_supplied_eval ("dassl"); - } - - return retval; -} - -Matrix -dassl_user_jacobian (const ColumnVector& x, const ColumnVector& xdot, - double t, double cj) -{ - Matrix retval; - - assert (x.capacity () == xdot.capacity ()); - - octave_value_list args; - - args(3) = cj; - args(2) = t; - args(1) = xdot; - args(0) = x; - - if (dassl_jac) - { - octave_value_list tmp = dassl_jac->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("dassl"); - return retval; - } - - int tlen = tmp.length (); - if (tlen > 0 && tmp(0).is_defined ()) - { - if (! warned_jac_imaginary && tmp(0).is_complex_type ()) - { - warning ("dassl: ignoring imaginary part returned from user-supplied jacobian function"); - warned_jac_imaginary = true; - } - - retval = tmp(0).matrix_value (); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("dassl"); - } - else - gripe_user_supplied_eval ("dassl"); - } - - return retval; -} - -#define DASSL_ABORT() \ - return retval - -#define DASSL_ABORT1(msg) \ - do \ - { \ - ::error ("dassl: " msg); \ - DASSL_ABORT (); \ - } \ - while (0) - -#define DASSL_ABORT2(fmt, arg) \ - do \ - { \ - ::error ("dassl: " fmt, arg); \ - DASSL_ABORT (); \ - } \ - while (0) - -DEFUN_DLD (dassl, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{x}, @var{xdot}, @var{istate}, @var{msg}] =} dassl (@var{fcn}, @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ -Solve the set of differential-algebraic equations\n\ -@tex\n\ -$$ 0 = f (x, \\dot{x}, t) $$\n\ -with\n\ -$$ x(t_0) = x_0, \\dot{x}(t_0) = \\dot{x}_0 $$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -0 = f (x, xdot, t)\n\ -@end example\n\ -\n\ -@noindent\n\ -with\n\ -\n\ -@example\n\ -x(t_0) = x_0, xdot(t_0) = xdot_0\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -The solution is returned in the matrices @var{x} and @var{xdot},\n\ -with each row in the result matrices corresponding to one of the\n\ -elements in the vector @var{t}. The first element of @var{t}\n\ -should be @math{t_0} and correspond to the initial state of the\n\ -system @var{x_0} and its derivative @var{xdot_0}, so that the first\n\ -row of the output @var{x} is @var{x_0} and the first row\n\ -of the output @var{xdot} is @var{xdot_0}.\n\ -\n\ -The first argument, @var{fcn}, is a string, inline, or function handle\n\ -that names the function @math{f} to call to compute the vector of\n\ -residuals for the set of equations. It must have the form\n\ -\n\ -@example\n\ -@var{res} = f (@var{x}, @var{xdot}, @var{t})\n\ -@end example\n\ -\n\ -@noindent\n\ -in which @var{x}, @var{xdot}, and @var{res} are vectors, and @var{t} is a\n\ -scalar.\n\ -\n\ -If @var{fcn} is a two-element string array or a two-element cell array\n\ -of strings, inline functions, or function handles, the first element names\n\ -the function @math{f} described above, and the second element names a\n\ -function to compute the modified Jacobian\n\ -\n\ -@tex\n\ -$$\n\ -J = {\\partial f \\over \\partial x}\n\ - + c {\\partial f \\over \\partial \\dot{x}}\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ - df df\n\ -jac = -- + c ------\n\ - dx d xdot\n\ -@end group\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -\n\ -The modified Jacobian function must have the form\n\ -\n\ -@example\n\ -@group\n\ -\n\ -@var{jac} = j (@var{x}, @var{xdot}, @var{t}, @var{c})\n\ -\n\ -@end group\n\ -@end example\n\ -\n\ -The second and third arguments to @code{dassl} specify the initial\n\ -condition of the states and their derivatives, and the fourth argument\n\ -specifies a vector of output times at which the solution is desired,\n\ -including the time corresponding to the initial condition.\n\ -\n\ -The set of initial states and derivatives are not strictly required to\n\ -be consistent. In practice, however, @sc{dassl} is not very good at\n\ -determining a consistent set for you, so it is best if you ensure that\n\ -the initial values result in the function evaluating to zero.\n\ -\n\ -The fifth argument is optional, and may be used to specify a set of\n\ -times that the DAE solver should not integrate past. It is useful for\n\ -avoiding difficulties with singularities and points where there is a\n\ -discontinuity in the derivative.\n\ -\n\ -After a successful computation, the value of @var{istate} will be\n\ -greater than zero (consistent with the Fortran version of @sc{dassl}).\n\ -\n\ -If the computation is not successful, the value of @var{istate} will be\n\ -less than zero and @var{msg} will contain additional information.\n\ -\n\ -You can use the function @code{dassl_options} to set optional\n\ -parameters for @code{dassl}.\n\ -@seealso{daspk, dasrt, lsode}\n\ -@end deftypefn") -{ - octave_value_list retval; - - warned_fcn_imaginary = false; - warned_jac_imaginary = false; - - unwind_protect frame; - - frame.protect_var (call_depth); - call_depth++; - - if (call_depth > 1) - DASSL_ABORT1 ("invalid recursive call"); - - int nargin = args.length (); - - if (nargin > 3 && nargin < 6 && nargout < 5) - { - std::string fcn_name, fname, jac_name, jname; - dassl_fcn = 0; - dassl_jac = 0; - - octave_value f_arg = args(0); - - if (f_arg.is_cell ()) - { - Cell c = f_arg.cell_value (); - if (c.length () == 1) - f_arg = c(0); - else if (c.length () == 2) - { - if (c(0).is_function_handle () || c(0).is_inline_function ()) - dassl_fcn = c(0).function_value (); - else - { - fcn_name = unique_symbol_name ("__dassl_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - dassl_fcn = extract_function - (c(0), "dassl", fcn_name, fname, "; endfunction"); - } - - if (dassl_fcn) - { - if (c(1).is_function_handle () || c(1).is_inline_function ()) - dassl_jac = c(1).function_value (); - else - { - jac_name = unique_symbol_name ("__dassl_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, xdot, t, cj) jac = "); - dassl_jac = extract_function - (c(1), "dassl", jac_name, jname, "; endfunction"); - - if (!dassl_jac) - { - if (fcn_name.length ()) - clear_function (fcn_name); - dassl_fcn = 0; - } - } - } - } - else - DASSL_ABORT1 ("incorrect number of elements in cell array"); - } - - if (!dassl_fcn && ! f_arg.is_cell ()) - { - if (f_arg.is_function_handle () || f_arg.is_inline_function ()) - dassl_fcn = f_arg.function_value (); - else - { - switch (f_arg.rows ()) - { - case 1: - do - { - fcn_name = unique_symbol_name ("__dassl_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - dassl_fcn = extract_function - (f_arg, "dassl", fcn_name, fname, "; endfunction"); - } - while (0); - break; - - case 2: - { - string_vector tmp = f_arg.all_strings (); - - if (! error_state) - { - fcn_name = unique_symbol_name ("__dassl_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, xdot, t) y = "); - dassl_fcn = extract_function - (tmp(0), "dassl", fcn_name, fname, "; endfunction"); - - if (dassl_fcn) - { - jac_name = unique_symbol_name ("__dassl_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, xdot, t, cj) jac = "); - dassl_jac = extract_function - (tmp(1), "dassl", jac_name, jname, - "; endfunction"); - - if (!dassl_jac) - { - if (fcn_name.length ()) - clear_function (fcn_name); - dassl_fcn = 0; - } - } - } - } - } - } - } - - if (error_state || ! dassl_fcn) - DASSL_ABORT (); - - ColumnVector state = ColumnVector (args(1).vector_value ()); - - if (error_state) - DASSL_ABORT1 ("expecting state vector as second argument"); - - ColumnVector deriv (args(2).vector_value ()); - - if (error_state) - DASSL_ABORT1 ("expecting derivative vector as third argument"); - - ColumnVector out_times (args(3).vector_value ()); - - if (error_state) - DASSL_ABORT1 ("expecting output time vector as fourth argument"); - - ColumnVector crit_times; - int crit_times_set = 0; - if (nargin > 4) - { - crit_times = ColumnVector (args(4).vector_value ()); - - if (error_state) - DASSL_ABORT1 ("expecting critical time vector as fifth argument"); - - crit_times_set = 1; - } - - if (state.capacity () != deriv.capacity ()) - DASSL_ABORT1 ("x and xdot must have the same size"); - - double tzero = out_times (0); - - DAEFunc func (dassl_user_function); - if (dassl_jac) - func.set_jacobian_function (dassl_user_jacobian); - - DASSL dae (state, deriv, tzero, func); - - dae.set_options (dassl_opts); - - Matrix output; - Matrix deriv_output; - - if (crit_times_set) - output = dae.integrate (out_times, deriv_output, crit_times); - else - output = dae.integrate (out_times, deriv_output); - - if (fcn_name.length ()) - clear_function (fcn_name); - if (jac_name.length ()) - clear_function (jac_name); - - if (! error_state) - { - std::string msg = dae.error_message (); - - retval(3) = msg; - retval(2) = static_cast<double> (dae.integration_state ()); - - if (dae.integration_ok ()) - { - retval(1) = deriv_output; - retval(0) = output; - } - else - { - retval(1) = Matrix (); - retval(0) = Matrix (); - - if (nargout < 3) - error ("dassl: %s", msg.c_str ()); - } - } - } - else - print_usage (); - - return retval; -} - -/* -## dassl-1.m -## -## Test dassl() function -## -## Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -## Comalco Research and Technology -## 20 May 1998 -## -## Problem -## -## y1' = -y2, y1(0) = 1 -## y2' = y1, y2(0) = 0 -## -## Solution -## -## y1(t) = cos(t) -## y2(t) = sin(t) -## -%!function res = __f (x, xdot, t) -%! res = [xdot(1)+x(2); xdot(2)-x(1)]; -%!endfunction - -%!test -%! -%! x0 = [1; 0]; -%! xdot0 = [0; 1]; -%! t = (0:1:10)'; -%! -%! tol = 100 * dassl_options ("relative tolerance"); -%! -%! [x, xdot] = dassl ("__f", x0, xdot0, t); -%! -%! y = [cos(t), sin(t)]; -%! -%! assert (x, y, tol); - -## dassl-2.m -## -## Test dassl() function -## -## Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -## Comalco Research and Technology -## 20 May 1998 -## -## Based on SLATEC quick check for DASSL by Linda Petzold -## -## Problem -## -## x1' + 10*x1 = 0, x1(0) = 1 -## x1 + x2 = 1, x2(0) = 0 -## -## -## Solution -## -## x1(t) = exp(-10*t) -## x2(t) = 1 - x(1) -## -%!function res = __f (x, xdot, t) -%! res = [xdot(1)+10*x(1); x(1)+x(2)-1]; -%!endfunction - -%!test -%! -%! x0 = [1; 0]; -%! xdot0 = [-10; 10]; -%! t = (0:0.2:1)'; -%! -%! tol = 500 * dassl_options ("relative tolerance"); -%! -%! [x, xdot] = dassl ("__f", x0, xdot0, t); -%! -%! y = [exp(-10*t), 1-exp(-10*t)]; -%! -%! assert (x, y, tol); - -%!test -%! dassl_options ("absolute tolerance", eps); -%! assert (dassl_options ("absolute tolerance") == eps); - -%!error dassl_options ("foo", 1, 2) -*/
--- a/src/DLD-FUNCTIONS/det.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,253 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "DET.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" -#include "ops.h" - -#include "ov-re-mat.h" -#include "ov-cx-mat.h" -#include "ov-flt-re-mat.h" -#include "ov-flt-cx-mat.h" -#include "ov-re-diag.h" -#include "ov-cx-diag.h" -#include "ov-flt-re-diag.h" -#include "ov-flt-cx-diag.h" -#include "ov-perm.h" - -#define MAYBE_CAST(VAR, CLASS) \ - const CLASS *VAR = arg.type_id () == CLASS::static_type_id () ? \ - dynamic_cast<const CLASS *> (&arg.get_rep ()) : 0 - -DEFUN_DLD (det, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} det (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{d}, @var{rcond}] =} det (@var{A})\n\ -Compute the determinant of @var{A}.\n\ -\n\ -Return an estimate of the reciprocal condition number if requested.\n\ -\n\ -Routines from @sc{lapack} are used for full matrices and code from\n\ -@sc{umfpack} is used for sparse matrices.\n\ -\n\ -The determinant should not be used to check a matrix for singularity.\n\ -For that, use any of the condition number functions: @code{cond},\n\ -@code{condest}, @code{rcond}.\n\ -@seealso{cond, condest, rcond}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin != 1) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - - octave_idx_type nr = arg.rows (); - octave_idx_type nc = arg.columns (); - - if (nr == 0 && nc == 0) - { - retval(0) = 1.0; - return retval; - } - - int arg_is_empty = empty_arg ("det", nr, nc); - if (arg_is_empty < 0) - return retval; - if (arg_is_empty > 0) - return octave_value (Matrix (1, 1, 1.0)); - - - if (nr != nc) - { - gripe_square_matrix_required ("det"); - return retval; - } - - bool isfloat = arg.is_single_type (); - - if (arg.is_diag_matrix ()) - { - if (arg.is_complex_type ()) - { - if (isfloat) - { - retval(0) = arg.float_complex_diag_matrix_value ().determinant ().value (); - if (nargout > 1) - retval(1) = arg.float_complex_diag_matrix_value ().rcond (); - } - else - { - retval(0) = arg.complex_diag_matrix_value ().determinant ().value (); - if (nargout > 1) - retval(1) = arg.complex_diag_matrix_value ().rcond (); - } - } - else - { - if (isfloat) - { - retval(0) = arg.float_diag_matrix_value ().determinant ().value (); - if (nargout > 1) - retval(1) = arg.float_diag_matrix_value ().rcond (); - } - else - { - retval(0) = arg.diag_matrix_value ().determinant ().value (); - if (nargout > 1) - retval(1) = arg.diag_matrix_value ().rcond (); - } - } - } - else if (arg.is_perm_matrix ()) - { - retval(0) = static_cast<double> (arg.perm_matrix_value ().determinant ()); - if (nargout > 1) - retval(1) = 1.0; - } - else if (arg.is_single_type ()) - { - if (arg.is_real_type ()) - { - octave_idx_type info; - float rcond = 0.0; - // Always compute rcond, so we can detect numerically - // singular matrices. - FloatMatrix m = arg.float_matrix_value (); - if (! error_state) - { - MAYBE_CAST (rep, octave_float_matrix); - MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); - FloatDET det = m.determinant (mtype, info, rcond); - retval(1) = rcond; - retval(0) = info == -1 ? static_cast<float>(0.0) : det.value (); - if (rep) rep->matrix_type (mtype); - } - } - else if (arg.is_complex_type ()) - { - octave_idx_type info; - float rcond = 0.0; - // Always compute rcond, so we can detect numerically - // singular matrices. - FloatComplexMatrix m = arg.float_complex_matrix_value (); - if (! error_state) - { - MAYBE_CAST (rep, octave_float_complex_matrix); - MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); - FloatComplexDET det = m.determinant (mtype, info, rcond); - retval(1) = rcond; - retval(0) = info == -1 ? FloatComplex (0.0) : det.value (); - if (rep) rep->matrix_type (mtype); - } - } - } - else - { - if (arg.is_real_type ()) - { - octave_idx_type info; - double rcond = 0.0; - // Always compute rcond, so we can detect numerically - // singular matrices. - if (arg.is_sparse_type ()) - { - SparseMatrix m = arg.sparse_matrix_value (); - if (! error_state) - { - DET det = m.determinant (info, rcond); - retval(1) = rcond; - retval(0) = info == -1 ? 0.0 : det.value (); - } - } - else - { - Matrix m = arg.matrix_value (); - if (! error_state) - { - MAYBE_CAST (rep, octave_matrix); - MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); - DET det = m.determinant (mtype, info, rcond); - retval(1) = rcond; - retval(0) = info == -1 ? 0.0 : det.value (); - if (rep) rep->matrix_type (mtype); - } - } - } - else if (arg.is_complex_type ()) - { - octave_idx_type info; - double rcond = 0.0; - // Always compute rcond, so we can detect numerically - // singular matrices. - if (arg.is_sparse_type ()) - { - SparseComplexMatrix m = arg.sparse_complex_matrix_value (); - if (! error_state) - { - ComplexDET det = m.determinant (info, rcond); - retval(1) = rcond; - retval(0) = info == -1 ? Complex (0.0) : det.value (); - } - } - else - { - ComplexMatrix m = arg.complex_matrix_value (); - if (! error_state) - { - MAYBE_CAST (rep, octave_complex_matrix); - MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); - ComplexDET det = m.determinant (mtype, info, rcond); - retval(1) = rcond; - retval(0) = info == -1 ? Complex (0.0) : det.value (); - if (rep) rep->matrix_type (mtype); - } - } - } - else - gripe_wrong_type_arg ("det", arg); - } - return retval; -} - -/* -%!assert (det ([1, 2; 3, 4]), -2, 10*eps) -%!assert (det (single ([1, 2; 3, 4])), single (-2), 10*eps ("single")) -%!error det () -%!error det (1, 2) -%!error <argument must be a square matrix> det ([1, 2; 3, 4; 5, 6]) -*/
--- a/src/DLD-FUNCTIONS/dlmread.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,520 +0,0 @@ -/* - -Copyright (C) 2008-2012 Jonathan Stickel -Copyright (C) 2010 Jaroslav Hajek - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Adapted from previous version of dlmread.occ as authored by Kai -// Habel, but core code has been completely re-written. - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <cctype> -#include <fstream> -#include <limits> - -#include "file-ops.h" -#include "lo-ieee.h" - -#include "defun-dld.h" -#include "oct-stream.h" -#include "error.h" -#include "oct-obj.h" -#include "utils.h" - -static const octave_idx_type idx_max = std::numeric_limits<octave_idx_type>::max (); - -static bool -read_cell_spec (std::istream& is, octave_idx_type& row, octave_idx_type& col) -{ - bool stat = false; - - if (is.peek () == std::istream::traits_type::eof ()) - stat = true; - else - { - if (::isalpha (is.peek ())) - { - col = 0; - while (is && ::isalpha (is.peek ())) - { - char ch = is.get (); - col *= 26; - if (ch >= 'a') - col += ch - 'a' + 1; - else - col += ch - 'A' + 1; - } - col --; - - if (is) - { - is >> row; - row --; - if (is) - stat = true; - } - } - } - - return stat; -} - -static bool -parse_range_spec (const octave_value& range_spec, - octave_idx_type& rlo, octave_idx_type& clo, - octave_idx_type& rup, octave_idx_type& cup) -{ - bool stat = true; - - if (range_spec.is_string ()) - { - std::istringstream is (range_spec.string_value ()); - char ch = is.peek (); - - if (ch == '.' || ch == ':') - { - rlo = 0; - clo = 0; - ch = is.get (); - if (ch == '.') - { - ch = is.get (); - if (ch != '.') - stat = false; - } - } - else - { - stat = read_cell_spec (is, rlo, clo); - - if (stat) - { - ch = is.peek (); - - if (ch == '.' || ch == ':') - { - ch = is.get (); - if (ch == '.') - { - ch = is.get (); - if (!is || ch != '.') - stat = false; - } - - rup = idx_max - 1; - cup = idx_max - 1; - } - else - { - rup = rlo; - cup = clo; - if (!is || !is.eof ()) - stat = false; - } - } - } - - if (stat && is && !is.eof ()) - stat = read_cell_spec (is, rup, cup); - - if (!is || !is.eof ()) - stat = false; - } - else if (range_spec.is_real_matrix () && range_spec.numel () == 4) - { - ColumnVector range(range_spec.vector_value ()); - // double --> unsigned int - rlo = static_cast<octave_idx_type> (range(0)); - clo = static_cast<octave_idx_type> (range(1)); - rup = static_cast<octave_idx_type> (range(2)); - cup = static_cast<octave_idx_type> (range(3)); - } - else - stat = false; - - return stat; -} - -DEFUN_DLD (dlmread, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{data} =} dlmread (@var{file})\n\ -@deftypefnx {Loadable Function} {@var{data} =} dlmread (@var{file}, @var{sep})\n\ -@deftypefnx {Loadable Function} {@var{data} =} dlmread (@var{file}, @var{sep}, @var{r0}, @var{c0})\n\ -@deftypefnx {Loadable Function} {@var{data} =} dlmread (@var{file}, @var{sep}, @var{range})\n\ -@deftypefnx {Loadable Function} {@var{data} =} dlmread (@dots{}, \"emptyvalue\", @var{EMPTYVAL})\n\ -Read the matrix @var{data} from a text file. If not defined the separator\n\ -between fields is determined from the file itself. Otherwise the\n\ -separation character is defined by @var{sep}.\n\ -\n\ -Given two scalar arguments @var{r0} and @var{c0}, these define the starting\n\ -row and column of the data to be read. These values are indexed from zero,\n\ -such that the first row corresponds to an index of zero.\n\ -\n\ -The @var{range} parameter may be a 4-element vector containing the upper\n\ -left and lower right corner @code{[@var{R0},@var{C0},@var{R1},@var{C1}]}\n\ -where the lowest index value is zero. Alternatively, a spreadsheet style\n\ -range such as \"A2..Q15\" or \"T1:AA5\" can be used. The lowest alphabetical\n\ -index 'A' refers to the first column. The lowest row index is 1.\n\ -\n\ -@var{file} should be a file name or file id given by @code{fopen}. In the\n\ -latter case, the file is read until end of file is reached.\n\ -\n\ -The \"emptyvalue\" option may be used to specify the value used to fill empty\n\ -fields. The default is zero.\n\ -@seealso{csvread, textscan, textread, dlmwrite}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - double empty_value = 0.0; - - if (nargin > 2 && args(nargin-2).is_string () - && args(nargin-2).string_value () == "emptyvalue") - { - empty_value = args(nargin-1).double_value (); - if (error_state) - return retval; - nargin -= 2; - } - - if (nargin < 1 || nargin > 4) - { - print_usage (); - return retval; - } - - std::istream *input = 0; - std::ifstream input_file; - - if (args(0).is_string ()) - { - // File name. - std::string fname (args(0).string_value ()); - if (error_state) - return retval; - - std::string tname = file_ops::tilde_expand (fname); - - input_file.open (tname.c_str (), std::ios::in); - - if (! input_file) - { - error ("dlmread: unable to open file `%s'", fname.c_str ()); - return retval; - } - else - input = &input_file; - } - else if (args(0).is_scalar_type ()) - { - octave_stream is = octave_stream_list::lookup (args(0), "dlmread"); - - if (error_state) - return retval; - - input = is.input_stream (); - - if (! input) - { - error ("dlmread: stream FILE not open for input"); - return retval; - } - } - else - { - error ("dlmread: FILE argument must be a string or file id"); - return retval; - } - - // Set default separator. - std::string sep; - if (nargin > 1) - { - if (args(1).is_sq_string ()) - sep = do_string_escapes (args(1).string_value ()); - else - sep = args(1).string_value (); - - if (error_state) - return retval; - } - - // Take a subset if a range was given. - octave_idx_type r0 = 0, c0 = 0, r1 = idx_max-1, c1 = idx_max-1; - if (nargin > 2) - { - if (nargin == 3) - { - if (!parse_range_spec (args (2), r0, c0, r1, c1)) - error ("dlmread: error parsing RANGE"); - } - else if (nargin == 4) - { - r0 = args(2).idx_type_value (); - c0 = args(3).idx_type_value (); - - if (error_state) - return retval; - } - - if (r0 < 0 || c0 < 0) - error ("dlmread: left & top must be positive"); - } - - if (!error_state) - { - octave_idx_type i = 0, j = 0, r = 1, c = 1, rmax = 0, cmax = 0; - - Matrix rdata; - ComplexMatrix cdata; - - bool iscmplx = false; - bool sepflag = false; - - std::string line; - - // Skip the r0 leading lines as these might be a header. - for (octave_idx_type m = 0; m < r0; m++) - getline (*input, line); - r1 -= r0; - - std::istringstream tmp_stream; - - // Read in the data one field at a time, growing the data matrix - // as needed. - while (getline (*input, line)) - { - // Skip blank lines for compatibility. - if (line.find_first_not_of (" \t") == std::string::npos) - continue; - - // To be compatible with matlab, blank separator should - // correspond to whitespace as delimter. - if (!sep.length ()) - { - size_t n = line.find_first_of (",:; \t", - line.find_first_of ("0123456789")); - if (n == std::string::npos) - { - sep = " \t"; - sepflag = true; - } - else - { - char ch = line.at (n); - - switch (line.at (n)) - { - case ' ': - case '\t': - sepflag = true; - sep = " \t"; - break; - - default: - sep = ch; - break; - } - } - } - - if (cmax == 0) - { - // Try to estimate the number of columns. Skip leading - // whitespace. - size_t pos1 = line.find_first_not_of (" \t"); - do - { - size_t pos2 = line.find_first_of (sep, pos1); - - if (sepflag && pos2 != std::string::npos) - // Treat consecutive separators as one. - { - pos2 = line.find_first_not_of (sep, pos2); - if (pos2 != std::string::npos) - pos2 -= 1; - else - pos2 = line.length () - 1; - } - - cmax++; - - if (pos2 != std::string::npos) - pos1 = pos2 + 1; - else - pos1 = std::string::npos; - - } - while (pos1 != std::string::npos); - - if (iscmplx) - cdata.resize (rmax, cmax); - else - rdata.resize (rmax, cmax); - } - - r = (r > i + 1 ? r : i + 1); - j = 0; - // Skip leading whitespace. - size_t pos1 = line.find_first_not_of (" \t"); - do - { - octave_quit (); - - size_t pos2 = line.find_first_of (sep, pos1); - std::string str = line.substr (pos1, pos2 - pos1); - - if (sepflag && pos2 != std::string::npos) - // Treat consecutive separators as one. - pos2 = line.find_first_not_of (sep, pos2) - 1; - - c = (c > j + 1 ? c : j + 1); - if (r > rmax || c > cmax) - { - // Use resize_and_fill for the case of not-equal - // length rows. - rmax = 2*r; - cmax = c; - if (iscmplx) - cdata.resize (rmax, cmax); - else - rdata.resize (rmax, cmax); - } - - tmp_stream.str (str); - tmp_stream.clear (); - - double x = octave_read_double (tmp_stream); - if (tmp_stream) - { - if (tmp_stream.eof ()) - { - if (iscmplx) - cdata(i,j++) = x; - else - rdata(i,j++) = x; - } - else if (std::toupper (tmp_stream.peek ()) == 'I') - { - // This is to allow pure imaginary numbers. - if (iscmplx) - cdata(i,j++) = x; - else - rdata(i,j++) = x; - } - else - { - double y = octave_read_double (tmp_stream); - - if (!iscmplx && y != 0.) - { - iscmplx = true; - cdata = ComplexMatrix (rdata); - } - - if (iscmplx) - cdata(i,j++) = Complex (x, y); - else - rdata(i,j++) = x; - } - } - else if (iscmplx) - cdata(i,j++) = empty_value; - else - rdata(i,j++) = empty_value; - - if (pos2 != std::string::npos) - pos1 = pos2 + 1; - else - pos1 = std::string::npos; - - } - while (pos1 != std::string::npos); - - if (i == r1) - break; - - i++; - } - - if (r1 >= r) - r1 = r - 1; - if (c1 >= c) - c1 = c - 1; - - // Now take the subset of the matrix. - if (iscmplx) - cdata = cdata.extract (0, c0, r1, c1); - else - rdata = rdata.extract (0, c0, r1, c1); - - if (iscmplx) - retval(0) = cdata; - else - retval(0) = rdata; - } - - return retval; -} - -/* -%!shared file -%! file = tmpnam (); -%! fid = fopen (file, "wt"); -%! fwrite (fid, "1, 2, 3\n4, 5, 6\n7, 8, 9\n10, 11, 12"); -%! fclose (fid); - -%!assert (dlmread (file), [1, 2, 3; 4, 5, 6; 7, 8, 9;10, 11, 12]) -%!assert (dlmread (file, ","), [1, 2, 3; 4, 5, 6; 7, 8, 9; 10, 11, 12]) -%!assert (dlmread (file, ",", [1, 0, 2, 1]), [4, 5; 7, 8]) -%!assert (dlmread (file, ",", "B1..C2"), [2, 3; 5, 6]) -%!assert (dlmread (file, ",", "B1:C2"), [2, 3; 5, 6]) -%!assert (dlmread (file, ",", "..C2"), [1, 2, 3; 4, 5, 6]) -%!assert (dlmread (file, ",", 0, 1), [2, 3; 5, 6; 8, 9; 11, 12]) -%!assert (dlmread (file, ",", "B1.."), [2, 3; 5, 6; 8, 9; 11, 12]) -%!error (dlmread (file, ",", [0 1])) - -%!test -%! unlink (file); - -%!shared file -%! file = tmpnam (); -%! fid = fopen (file, "wt"); -%! fwrite (fid, "1, 2, 3\n4+4i, 5, 6\n7, 8, 9\n10, 11, 12"); -%! fclose (fid); - -%!assert (dlmread (file), [1, 2, 3; 4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) -%!assert (dlmread (file, ","), [1, 2, 3; 4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) -%!assert (dlmread (file, ",", [1, 0, 2, 1]), [4 + 4i, 5; 7, 8]) -%!assert (dlmread (file, ",", "A2..B3"), [4 + 4i, 5; 7, 8]) -%!assert (dlmread (file, ",", "A2:B3"), [4 + 4i, 5; 7, 8]) -%!assert (dlmread (file, ",", "..B3"), [1, 2; 4 + 4i, 5; 7, 8]) -%!assert (dlmread (file, ",", 1, 0), [4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) -%!assert (dlmread (file, ",", "A2.."), [4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) -%!error (dlmread (file, ",", [0 1])) - -%!test -%! unlink (file); -*/
--- a/src/DLD-FUNCTIONS/dot.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,364 +0,0 @@ -/* - -Copyright (C) 2009-2012 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "f77-fcn.h" -#include "mx-base.h" -#include "error.h" -#include "defun-dld.h" -#include "parse.h" - -extern "C" -{ - F77_RET_T - F77_FUNC (ddot3, DDOT3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const double*, - const double*, double*); - - F77_RET_T - F77_FUNC (sdot3, SDOT3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const float*, - const float*, float*); - - F77_RET_T - F77_FUNC (zdotc3, ZDOTC3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const Complex*, - const Complex*, Complex*); - - F77_RET_T - F77_FUNC (cdotc3, CDOTC3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const FloatComplex*, - const FloatComplex*, FloatComplex*); - - F77_RET_T - F77_FUNC (dmatm3, DMATM3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const octave_idx_type&, - const double*, const double*, double*); - - F77_RET_T - F77_FUNC (smatm3, SMATM3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const octave_idx_type&, - const float*, const float*, float*); - - F77_RET_T - F77_FUNC (zmatm3, ZMATM3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const octave_idx_type&, - const Complex*, const Complex*, Complex*); - - F77_RET_T - F77_FUNC (cmatm3, CMATM3) (const octave_idx_type&, const octave_idx_type&, - const octave_idx_type&, const octave_idx_type&, - const FloatComplex*, const FloatComplex*, - FloatComplex*); -} - -static void -get_red_dims (const dim_vector& x, const dim_vector& y, int dim, - dim_vector& z, octave_idx_type& m, octave_idx_type& n, - octave_idx_type& k) -{ - int nd = x.length (); - assert (nd == y.length ()); - z = dim_vector::alloc (nd); - m = 1, n = 1, k = 1; - for (int i = 0; i < nd; i++) - { - if (i < dim) - { - z(i) = x(i); - m *= x(i); - } - else if (i > dim) - { - z(i) = x(i); - n *= x(i); - } - else - { - k = x(i); - z(i) = 1; - } - } -} - -DEFUN_DLD (dot, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dot (@var{x}, @var{y}, @var{dim})\n\ -Compute the dot product of two vectors. If @var{x} and @var{y}\n\ -are matrices, calculate the dot products along the first\n\ -non-singleton dimension. If the optional argument @var{dim} is\n\ -given, calculate the dot products along this dimension.\n\ -\n\ -This is equivalent to\n\ -@code{sum (conj (@var{X}) .* @var{Y}, @var{dim})},\n\ -but avoids forming a temporary array and is faster. When @var{X} and\n\ -@var{Y} are column vectors, the result is equivalent to\n\ -@code{@var{X}' * @var{Y}}.\n\ -@seealso{cross, divergence}\n\ -@end deftypefn") -{ - octave_value retval; - int nargin = args.length (); - - if (nargin < 2 || nargin > 3) - { - print_usage (); - return retval; - } - - octave_value argx = args(0), argy = args(1); - - if (argx.is_numeric_type () && argy.is_numeric_type ()) - { - dim_vector dimx = argx.dims (), dimy = argy.dims (); - bool match = dimx == dimy; - if (! match && nargin == 2 - && dimx.is_vector () && dimy.is_vector ()) - { - // Change to column vectors. - dimx = dimx.redim (1); - argx = argx.reshape (dimx); - dimy = dimy.redim (1); - argy = argy.reshape (dimy); - match = ! error_state; - } - - if (match) - { - int dim; - if (nargin == 2) - dim = dimx.first_non_singleton (); - else - dim = args(2).int_value (true) - 1; - - if (error_state) - ; - else if (dim < 0) - error ("dot: DIM must be a valid dimension"); - else - { - octave_idx_type m, n, k; - dim_vector dimz; - if (argx.is_complex_type () || argy.is_complex_type ()) - { - if (argx.is_single_type () || argy.is_single_type ()) - { - FloatComplexNDArray x = argx.float_complex_array_value (); - FloatComplexNDArray y = argy.float_complex_array_value (); - get_red_dims (dimx, dimy, dim, dimz, m, n, k); - FloatComplexNDArray z(dimz); - if (! error_state) - F77_XFCN (cdotc3, CDOTC3, (m, n, k, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - else - { - ComplexNDArray x = argx.complex_array_value (); - ComplexNDArray y = argy.complex_array_value (); - get_red_dims (dimx, dimy, dim, dimz, m, n, k); - ComplexNDArray z(dimz); - if (! error_state) - F77_XFCN (zdotc3, ZDOTC3, (m, n, k, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - } - else if (argx.is_float_type () && argy.is_float_type ()) - { - if (argx.is_single_type () || argy.is_single_type ()) - { - FloatNDArray x = argx.float_array_value (); - FloatNDArray y = argy.float_array_value (); - get_red_dims (dimx, dimy, dim, dimz, m, n, k); - FloatNDArray z(dimz); - if (! error_state) - F77_XFCN (sdot3, SDOT3, (m, n, k, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - else - { - NDArray x = argx.array_value (); - NDArray y = argy.array_value (); - get_red_dims (dimx, dimy, dim, dimz, m, n, k); - NDArray z(dimz); - if (! error_state) - F77_XFCN (ddot3, DDOT3, (m, n, k, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - } - else - { - // Non-optimized evaluation. - octave_value_list tmp; - tmp(1) = args(2); - tmp(0) = do_binary_op (octave_value::op_el_mul, argx, argy); - if (! error_state) - { - tmp = feval ("sum", tmp, 1); - if (! tmp.empty ()) - retval = tmp(0); - } - } - } - } - else - error ("dot: sizes of X and Y must match"); - - } - else - error ("dot: X and Y must be numeric"); - - return retval; -} - -/* -%!assert (dot ([1, 2], [2, 3]), 8) - -%!test -%! x = [2, 1; 2, 1]; -%! y = [-0.5, 2; 0.5, -2]; -%! assert (dot (x, y), [0 0]); - -%!test -%! x = [1+i, 3-i; 1-i, 3-i]; -%! assert (dot (x, x), [4, 20]); -*/ - -DEFUN_DLD (blkmm, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} blkmm (@var{A}, @var{B})\n\ -Compute products of matrix blocks. The blocks are given as\n\ -2-dimensional subarrays of the arrays @var{A}, @var{B}.\n\ -The size of @var{A} must have the form @code{[m,k,@dots{}]} and\n\ -size of @var{B} must be @code{[k,n,@dots{}]}. The result is\n\ -then of size @code{[m,n,@dots{}]} and is computed as follows:\n\ -\n\ -@example\n\ -@group\n\ -for i = 1:prod (size (@var{A})(3:end))\n\ - @var{C}(:,:,i) = @var{A}(:,:,i) * @var{B}(:,:,i)\n\ -endfor\n\ -@end group\n\ -@end example\n\ -@end deftypefn") -{ - octave_value retval; - int nargin = args.length (); - - if (nargin != 2) - { - print_usage (); - return retval; - } - - octave_value argx = args(0), argy = args(1); - - if (argx.is_numeric_type () && argy.is_numeric_type ()) - { - const dim_vector dimx = argx.dims (), dimy = argy.dims (); - int nd = dimx.length (); - octave_idx_type m = dimx(0), k = dimx(1), n = dimy(1), np = 1; - bool match = dimy(0) == k && nd == dimy.length (); - dim_vector dimz = dim_vector::alloc (nd); - dimz(0) = m; - dimz(1) = n; - for (int i = 2; match && i < nd; i++) - { - match = match && dimx(i) == dimy(i); - dimz(i) = dimx(i); - np *= dimz(i); - } - - if (match) - { - if (argx.is_complex_type () || argy.is_complex_type ()) - { - if (argx.is_single_type () || argy.is_single_type ()) - { - FloatComplexNDArray x = argx.float_complex_array_value (); - FloatComplexNDArray y = argy.float_complex_array_value (); - FloatComplexNDArray z(dimz); - if (! error_state) - F77_XFCN (cmatm3, CMATM3, (m, n, k, np, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - else - { - ComplexNDArray x = argx.complex_array_value (); - ComplexNDArray y = argy.complex_array_value (); - ComplexNDArray z(dimz); - if (! error_state) - F77_XFCN (zmatm3, ZMATM3, (m, n, k, np, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - } - else - { - if (argx.is_single_type () || argy.is_single_type ()) - { - FloatNDArray x = argx.float_array_value (); - FloatNDArray y = argy.float_array_value (); - FloatNDArray z(dimz); - if (! error_state) - F77_XFCN (smatm3, SMATM3, (m, n, k, np, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - else - { - NDArray x = argx.array_value (); - NDArray y = argy.array_value (); - NDArray z(dimz); - if (! error_state) - F77_XFCN (dmatm3, DMATM3, (m, n, k, np, x.data (), y.data (), - z.fortran_vec ())); - retval = z; - } - } - } - else - error ("blkmm: A and B dimensions don't match: (%s) and (%s)", - dimx.str ().c_str (), dimy.str ().c_str ()); - - } - else - error ("blkmm: A and B must be numeric"); - - return retval; -} - -/* -%!test -%! x(:,:,1) = [1 2; 3 4]; -%! x(:,:,2) = [1 1; 1 1]; -%! z(:,:,1) = [7 10; 15 22]; -%! z(:,:,2) = [2 2; 2 2]; -%! assert (blkmm (x,x), z); -*/
--- a/src/DLD-FUNCTIONS/eig.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,334 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "EIG.h" -#include "fEIG.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (eig, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{lambda} =} eig (@var{A})\n\ -@deftypefnx {Loadable Function} {@var{lambda} =} eig (@var{A}, @var{B})\n\ -@deftypefnx {Loadable Function} {[@var{V}, @var{lambda}] =} eig (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{V}, @var{lambda}] =} eig (@var{A}, @var{B})\n\ -Compute the eigenvalues and eigenvectors of a matrix.\n\ -\n\ -Eigenvalues are computed in a several step process which begins with a\n\ -Hessenberg decomposition, followed by a Schur@tie{}decomposition, from which\n\ -the eigenvalues are apparent. The eigenvectors, when desired, are computed\n\ -by further manipulations of the Schur@tie{}decomposition.\n\ -\n\ -The eigenvalues returned by @code{eig} are not ordered.\n\ -@seealso{eigs, svd}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin > 2 || nargin == 0 || nargout > 2) - { - print_usage (); - return retval; - } - - octave_value arg_a, arg_b; - - octave_idx_type nr_a = 0, nr_b = 0; - octave_idx_type nc_a = 0, nc_b = 0; - - arg_a = args(0); - nr_a = arg_a.rows (); - nc_a = arg_a.columns (); - - int arg_is_empty = empty_arg ("eig", nr_a, nc_a); - if (arg_is_empty < 0) - return retval; - else if (arg_is_empty > 0) - return octave_value_list (2, Matrix ()); - - if (!(arg_a.is_single_type () || arg_a.is_double_type ())) - { - gripe_wrong_type_arg ("eig", arg_a); - return retval; - } - - if (nargin == 2) - { - arg_b = args(1); - nr_b = arg_b.rows (); - nc_b = arg_b.columns (); - - arg_is_empty = empty_arg ("eig", nr_b, nc_b); - if (arg_is_empty < 0) - return retval; - else if (arg_is_empty > 0) - return octave_value_list (2, Matrix ()); - - if (!(arg_b.is_single_type () || arg_b.is_double_type ())) - { - gripe_wrong_type_arg ("eig", arg_b); - return retval; - } - } - - if (nr_a != nc_a) - { - gripe_square_matrix_required ("eig"); - return retval; - } - - if (nargin == 2 && nr_b != nc_b) - { - gripe_square_matrix_required ("eig"); - return retval; - } - - Matrix tmp_a, tmp_b; - ComplexMatrix ctmp_a, ctmp_b; - FloatMatrix ftmp_a, ftmp_b; - FloatComplexMatrix fctmp_a, fctmp_b; - - if (arg_a.is_single_type ()) - { - FloatEIG result; - - if (nargin == 1) - { - if (arg_a.is_real_type ()) - { - ftmp_a = arg_a.float_matrix_value (); - - if (error_state) - return retval; - else - result = FloatEIG (ftmp_a, nargout > 1); - } - else - { - fctmp_a = arg_a.float_complex_matrix_value (); - - if (error_state) - return retval; - else - result = FloatEIG (fctmp_a, nargout > 1); - } - } - else if (nargin == 2) - { - if (arg_a.is_real_type () && arg_b.is_real_type ()) - { - ftmp_a = arg_a.float_matrix_value (); - ftmp_b = arg_b.float_matrix_value (); - - if (error_state) - return retval; - else - result = FloatEIG (ftmp_a, ftmp_b, nargout > 1); - } - else - { - fctmp_a = arg_a.float_complex_matrix_value (); - fctmp_b = arg_b.float_complex_matrix_value (); - - if (error_state) - return retval; - else - result = FloatEIG (fctmp_a, fctmp_b, nargout > 1); - } - } - - if (! error_state) - { - if (nargout == 0 || nargout == 1) - { - retval(0) = result.eigenvalues (); - } - else - { - // Blame it on Matlab. - - FloatComplexDiagMatrix d (result.eigenvalues ()); - - retval(1) = d; - retval(0) = result.eigenvectors (); - } - } - } - else - { - EIG result; - - if (nargin == 1) - { - if (arg_a.is_real_type ()) - { - tmp_a = arg_a.matrix_value (); - - if (error_state) - return retval; - else - result = EIG (tmp_a, nargout > 1); - } - else - { - ctmp_a = arg_a.complex_matrix_value (); - - if (error_state) - return retval; - else - result = EIG (ctmp_a, nargout > 1); - } - } - else if (nargin == 2) - { - if (arg_a.is_real_type () && arg_b.is_real_type ()) - { - tmp_a = arg_a.matrix_value (); - tmp_b = arg_b.matrix_value (); - - if (error_state) - return retval; - else - result = EIG (tmp_a, tmp_b, nargout > 1); - } - else - { - ctmp_a = arg_a.complex_matrix_value (); - ctmp_b = arg_b.complex_matrix_value (); - - if (error_state) - return retval; - else - result = EIG (ctmp_a, ctmp_b, nargout > 1); - } - } - - if (! error_state) - { - if (nargout == 0 || nargout == 1) - { - retval(0) = result.eigenvalues (); - } - else - { - // Blame it on Matlab. - - ComplexDiagMatrix d (result.eigenvalues ()); - - retval(1) = d; - retval(0) = result.eigenvectors (); - } - } - } - - return retval; -} - -/* -%!assert (eig ([1, 2; 2, 1]), [-1; 3], sqrt (eps)) - -%!test -%! [v, d] = eig ([1, 2; 2, 1]); -%! x = 1 / sqrt (2); -%! assert (d, [-1, 0; 0, 3], sqrt (eps)); -%! assert (v, [-x, x; x, x], sqrt (eps)); - -%!assert (eig (single ([1, 2; 2, 1])), single ([-1; 3]), sqrt (eps ("single"))) - -%!test -%! [v, d] = eig (single ([1, 2; 2, 1])); -%! x = single (1 / sqrt (2)); -%! assert (d, single ([-1, 0; 0, 3]), sqrt (eps ("single"))); -%! assert (v, [-x, x; x, x], sqrt (eps ("single"))); - -%!test -%! A = [1, 2; -1, 1]; B = [3, 3; 1, 2]; -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); - -%!test -%! A = single ([1, 2; -1, 1]); B = single ([3, 3; 1, 2]); -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); - -%!test -%! A = [1, 2; 2, 1]; B = [3, -2; -2, 3]; -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); - -%!test -%! A = single ([1, 2; 2, 1]); B = single ([3, -2; -2, 3]); -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); - -%!test -%! A = [1+3i, 2+i; 2-i, 1+3i]; B = [5+9i, 2+i; 2-i, 5+9i]; -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); - -%!test -%! A = single ([1+3i, 2+i; 2-i, 1+3i]); B = single ([5+9i, 2+i; 2-i, 5+9i]); -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); - -%!test -%! A = [1+3i, 2+3i; 3-8i, 8+3i]; B = [8+i, 3+i; 4-9i, 3+i]; -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); - -%!test -%! A = single ([1+3i, 2+3i; 3-8i, 8+3i]); B = single ([8+i, 3+i; 4-9i, 3+i]); -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); - -%!test -%! A = [1, 2; 3, 8]; B = [8, 3; 4, 3]; -%! [v, d] = eig (A, B); -%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); -%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); - -%!error eig () -%!error eig ([1, 2; 3, 4], [4, 3; 2, 1], 1) -%!error <EIG requires same size matrices> eig ([1, 2; 3, 4], 2) -%!error <argument must be a square matrix> eig ([1, 2; 3, 4; 5, 6]) -%!error <wrong type argument> eig ("abcd") -%!error <wrong type argument> eig ([1 2 ; 2 3], "abcd") -%!error <wrong type argument> eig (false, [1 2 ; 2 3]) -*/
--- a/src/DLD-FUNCTIONS/eigs.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/DLD-FUNCTIONS/eigs.cc Sat Jul 28 12:06:34 2012 -0400 @@ -258,6 +258,7 @@ default is @code{1:@var{n}}.\n\ \n\ @end table\n\ +\n\ It is also possible to represent @var{A} by a function denoted @var{af}.\n\ @var{af} must be followed by a scalar argument @var{n} defining the length\n\ of the vector argument accepted by @var{af}. @var{af} can be\n\
--- a/src/DLD-FUNCTIONS/fft.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,319 +0,0 @@ -/* - -Copyright (C) 1997-2012 David Bateman -Copyright (C) 1996-1997 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-mappers.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -#if defined (HAVE_FFTW) -#define FFTSRC "@sc{fftw}" -#else -#define FFTSRC "@sc{fftpack}" -#endif - -static octave_value -do_fft (const octave_value_list &args, const char *fcn, int type) -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 3) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - dim_vector dims = arg.dims (); - octave_idx_type n_points = -1; - int dim = -1; - - if (nargin > 1) - { - if (! args(1).is_empty ()) - { - double dval = args(1).double_value (); - if (xisnan (dval)) - error ("%s: number of points (N) cannot be NaN", fcn); - else - { - n_points = NINTbig (dval); - if (n_points < 0) - error ("%s: number of points (N) must be greater than zero", fcn); - } - } - } - - if (error_state) - return retval; - - if (nargin > 2) - { - double dval = args(2).double_value (); - if (xisnan (dval)) - error ("%s: DIM cannot be NaN", fcn); - else if (dval < 1 || dval > dims.length ()) - error ("%s: DIM must be a valid dimension along which to perform FFT", fcn); - else - // to be safe, cast it back to int since dim is an int - dim = NINT (dval) - 1; - } - - if (error_state) - return retval; - - for (octave_idx_type i = 0; i < dims.length (); i++) - if (dims(i) < 0) - return retval; - - if (dim < 0) - { - for (octave_idx_type i = 0; i < dims.length (); i++) - if (dims(i) > 1) - { - dim = i; - break; - } - - // And if the first argument is scalar? - if (dim < 0) - dim = 1; - } - - if (n_points < 0) - n_points = dims (dim); - else - dims (dim) = n_points; - - if (dims.any_zero () || n_points == 0) - { - if (arg.is_single_type ()) - return octave_value (FloatNDArray (dims)); - else - return octave_value (NDArray (dims)); - } - - if (arg.is_single_type ()) - { - if (arg.is_real_type ()) - { - FloatNDArray nda = arg.float_array_value (); - - if (! error_state) - { - nda.resize (dims, 0.0); - retval = (type != 0 ? nda.ifourier (dim) : nda.fourier (dim)); - } - } - else - { - FloatComplexNDArray cnda = arg.float_complex_array_value (); - - if (! error_state) - { - cnda.resize (dims, 0.0); - retval = (type != 0 ? cnda.ifourier (dim) : cnda.fourier (dim)); - } - } - } - else - { - if (arg.is_real_type ()) - { - NDArray nda = arg.array_value (); - - if (! error_state) - { - nda.resize (dims, 0.0); - retval = (type != 0 ? nda.ifourier (dim) : nda.fourier (dim)); - } - } - else if (arg.is_complex_type ()) - { - ComplexNDArray cnda = arg.complex_array_value (); - - if (! error_state) - { - cnda.resize (dims, 0.0); - retval = (type != 0 ? cnda.ifourier (dim) : cnda.fourier (dim)); - } - } - else - { - gripe_wrong_type_arg (fcn, arg); - } - } - - return retval; -} - -/* -%!assert (fft ([]), []) -%!assert (fft (zeros (10,0)), zeros (10,0)) -%!assert (fft (zeros (0,10)), zeros (0,10)) -%!assert (fft (0), 0) -%!assert (fft (1), 1) -%!assert (fft (ones (2,2)), [2,2; 0,0]) -%!assert (fft (eye (2,2)), [1,1; 1,-1]) - -%!assert (fft (single ([])), single ([])) -%!assert (fft (zeros (10,0,"single")), zeros (10,0,"single")) -%!assert (fft (zeros (0,10,"single")), zeros (0,10,"single")) -%!assert (fft (single (0)), single (0)) -%!assert (fft (single (1)), single (1)) -%!assert (fft (ones (2,2,"single")), single ([2,2; 0,0])) -%!assert (fft (eye (2,2,"single")), single ([1,1; 1,-1])) - -%!error (fft ()) -*/ - - -DEFUN_DLD (fft, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} fft (@var{x})\n\ -@deftypefnx {Loadable Function} {} fft (@var{x}, @var{n})\n\ -@deftypefnx {Loadable Function} {} fft (@var{x}, @var{n}, @var{dim})\n\ -Compute the discrete Fourier transform of @var{A} using\n\ -a Fast Fourier Transform (FFT) algorithm.\n\ -\n\ -The FFT is calculated along the first non-singleton dimension of the\n\ -array. Thus if @var{x} is a matrix, @code{fft (@var{x})} computes the\n\ -FFT for each column of @var{x}.\n\ -\n\ -If called with two arguments, @var{n} is expected to be an integer\n\ -specifying the number of elements of @var{x} to use, or an empty\n\ -matrix to specify that its value should be ignored. If @var{n} is\n\ -larger than the dimension along which the FFT is calculated, then\n\ -@var{x} is resized and padded with zeros. Otherwise, if @var{n} is\n\ -smaller than the dimension along which the FFT is calculated, then\n\ -@var{x} is truncated.\n\ -\n\ -If called with three arguments, @var{dim} is an integer specifying the\n\ -dimension of the matrix along which the FFT is performed\n\ -@seealso{ifft, fft2, fftn, fftw}\n\ -@end deftypefn") -{ - return do_fft (args, "fft", 0); -} - - -DEFUN_DLD (ifft, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} ifft (@var{x})\n\ -@deftypefnx {Loadable Function} {} ifft (@var{x}, @var{n})\n\ -@deftypefnx {Loadable Function} {} ifft (@var{x}, @var{n}, @var{dim})\n\ -Compute the inverse discrete Fourier transform of @var{A}\n\ -using a Fast Fourier Transform (FFT) algorithm.\n\ -\n\ -The inverse FFT is calculated along the first non-singleton dimension\n\ -of the array. Thus if @var{x} is a matrix, @code{fft (@var{x})} computes\n\ -the inverse FFT for each column of @var{x}.\n\ -\n\ -If called with two arguments, @var{n} is expected to be an integer\n\ -specifying the number of elements of @var{x} to use, or an empty\n\ -matrix to specify that its value should be ignored. If @var{n} is\n\ -larger than the dimension along which the inverse FFT is calculated, then\n\ -@var{x} is resized and padded with zeros. Otherwise, if @var{n} is\n\ -smaller than the dimension along which the inverse FFT is calculated,\n\ -then @var{x} is truncated.\n\ -\n\ -If called with three arguments, @var{dim} is an integer specifying the\n\ -dimension of the matrix along which the inverse FFT is performed\n\ -@seealso{fft, ifft2, ifftn, fftw}\n\ -@end deftypefn") -{ - return do_fft (args, "ifft", 1); -} - -/* -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! N = 64; -%! n = 4; -%! t = 2*pi*(0:1:N-1)/N; -%! s = cos (n*t); -%! S = fft (s); -%! -%! answer = zeros (size (t)); -%! answer(n+1) = N/2; -%! answer(N-n+1) = N/2; -%! -%! assert (S, answer, 4*N*eps); - -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! N = 64; -%! n = 7; -%! t = 2*pi*(0:1:N-1)/N; -%! s = cos (n*t); -%! -%! S = zeros (size (t)); -%! S(n+1) = N/2; -%! S(N-n+1) = N/2; -%! -%! assert (ifft (S), s, 4*N*eps); - -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! N = 64; -%! n = 4; -%! t = single (2*pi*(0:1:N-1)/N); -%! s = cos (n*t); -%! S = fft (s); -%! -%! answer = zeros (size (t), "single"); -%! answer(n+1) = N/2; -%! answer(N-n+1) = N/2; -%! -%! assert (S, answer, 4*N*eps ("single")); - -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! N = 64; -%! n = 7; -%! t = 2*pi*(0:1:N-1)/N; -%! s = cos (n*t); -%! -%! S = zeros (size (t), "single"); -%! S(n+1) = N/2; -%! S(N-n+1) = N/2; -%! -%! assert (ifft (S), s, 4*N*eps ("single")); -*/
--- a/src/DLD-FUNCTIONS/fft2.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,294 +0,0 @@ -/* - -Copyright (C) 1997-2012 David Bateman -Copyright (C) 1996-1997 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-mappers.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -// This function should be merged with Fifft. - -#if defined (HAVE_FFTW) -#define FFTSRC "@sc{fftw}" -#else -#define FFTSRC "@sc{fftpack}" -#endif - -static octave_value -do_fft2 (const octave_value_list &args, const char *fcn, int type) -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 3) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - dim_vector dims = arg.dims (); - octave_idx_type n_rows = -1; - - if (nargin > 1) - { - double dval = args(1).double_value (); - if (xisnan (dval)) - error ("%s: number of rows (N) cannot be NaN", fcn); - else - { - n_rows = NINTbig (dval); - if (n_rows < 0) - error ("%s: number of rows (N) must be greater than zero", fcn); - } - } - - if (error_state) - return retval; - - octave_idx_type n_cols = -1; - if (nargin > 2) - { - double dval = args(2).double_value (); - if (xisnan (dval)) - error ("%s: number of columns (M) cannot be NaN", fcn); - else - { - n_cols = NINTbig (dval); - if (n_cols < 0) - error ("%s: number of columns (M) must be greater than zero", fcn); - } - } - - if (error_state) - return retval; - - for (int i = 0; i < dims.length (); i++) - if (dims(i) < 0) - return retval; - - if (n_rows < 0) - n_rows = dims (0); - else - dims (0) = n_rows; - - if (n_cols < 0) - n_cols = dims (1); - else - dims (1) = n_cols; - - if (dims.all_zero () || n_rows == 0 || n_cols == 0) - { - if (arg.is_single_type ()) - return octave_value (FloatMatrix ()); - else - return octave_value (Matrix ()); - } - - if (arg.is_single_type ()) - { - if (arg.is_real_type ()) - { - FloatNDArray nda = arg.float_array_value (); - - if (! error_state) - { - nda.resize (dims, 0.0); - retval = (type != 0 ? nda.ifourier2d () : nda.fourier2d ()); - } - } - else - { - FloatComplexNDArray cnda = arg.float_complex_array_value (); - - if (! error_state) - { - cnda.resize (dims, 0.0); - retval = (type != 0 ? cnda.ifourier2d () : cnda.fourier2d ()); - } - } - } - else - { - if (arg.is_real_type ()) - { - NDArray nda = arg.array_value (); - - if (! error_state) - { - nda.resize (dims, 0.0); - retval = (type != 0 ? nda.ifourier2d () : nda.fourier2d ()); - } - } - else if (arg.is_complex_type ()) - { - ComplexNDArray cnda = arg.complex_array_value (); - - if (! error_state) - { - cnda.resize (dims, 0.0); - retval = (type != 0 ? cnda.ifourier2d () : cnda.fourier2d ()); - } - } - else - { - gripe_wrong_type_arg (fcn, arg); - } - } - - return retval; -} - -DEFUN_DLD (fft2, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} fft2 (@var{A})\n\ -@deftypefnx {Loadable Function} {} fft2 (@var{A}, @var{m}, @var{n})\n\ -Compute the two-dimensional discrete Fourier transform of @var{A} using\n\ -a Fast Fourier Transform (FFT) algorithm.\n\ -\n\ -The optional arguments @var{m} and @var{n} may be used specify the\n\ -number of rows and columns of @var{A} to use. If either of these is\n\ -larger than the size of @var{A}, @var{A} is resized and padded with\n\ -zeros.\n\ -\n\ -If @var{A} is a multi-dimensional matrix, each two-dimensional sub-matrix\n\ -of @var{A} is treated separately.\n\ -@seealso {ifft2, fft, fftn, fftw}\n\ -@end deftypefn") -{ - return do_fft2 (args, "fft2", 0); -} - - -DEFUN_DLD (ifft2, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} ifft2 (@var{A})\n\ -@deftypefnx {Loadable Function} {} ifft2 (@var{A}, @var{m}, @var{n})\n\ -Compute the inverse two-dimensional discrete Fourier transform of @var{A}\n\ -using a Fast Fourier Transform (FFT) algorithm.\n\ -\n\ -The optional arguments @var{m} and @var{n} may be used specify the\n\ -number of rows and columns of @var{A} to use. If either of these is\n\ -larger than the size of @var{A}, @var{A} is resized and padded with\n\ -zeros.\n\ -\n\ -If @var{A} is a multi-dimensional matrix, each two-dimensional sub-matrix\n\ -of @var{A} is treated separately\n\ -@seealso {fft2, ifft, ifftn, fftw}\n\ -@end deftypefn") -{ - return do_fft2 (args, "ifft2", 1); -} - -/* -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! M = 16; -%! N = 8; -%! -%! m = 5; -%! n = 3; -%! -%! x = 2*pi*(0:1:M-1)/M; -%! y = 2*pi*(0:1:N-1)/N; -%! sx = cos (m*x); -%! sy = sin (n*y); -%! s = kron (sx',sy); -%! S = fft2 (s); -%! answer = kron (fft (sx)', fft (sy)); -%! assert (S, answer, 4*M*N*eps); - -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! M = 12; -%! N = 7; -%! -%! m = 3; -%! n = 2; -%! -%! x = 2*pi*(0:1:M-1)/M; -%! y = 2*pi*(0:1:N-1)/N; -%! -%! sx = cos (m*x); -%! sy = cos (n*y); -%! -%! S = kron (fft (sx)', fft (sy)); -%! answer = kron (sx', sy); -%! s = ifft2 (S); -%! -%! assert (s, answer, 30*eps); - - -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! M = 16; -%! N = 8; -%! -%! m = 5; -%! n = 3; -%! -%! x = 2*pi*(0:1:M-1)/M; -%! y = 2*pi*(0:1:N-1)/N; -%! sx = single (cos (m*x)); -%! sy = single (sin (n*y)); -%! s = kron (sx', sy); -%! S = fft2 (s); -%! answer = kron (fft (sx)', fft (sy)); -%! assert (S, answer, 4*M*N*eps ("single")); - -%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -%% Comalco Research and Technology -%% 02 May 2000 -%!test -%! M = 12; -%! N = 7; -%! -%! m = 3; -%! n = 2; -%! -%! x = single (2*pi*(0:1:M-1)/M); -%! y = single (2*pi*(0:1:N-1)/N); -%! -%! sx = cos (m*x); -%! sy = cos (n*y); -%! -%! S = kron (fft (sx)', fft (sy)); -%! answer = kron (sx', sy); -%! s = ifft2 (S); -%! -%! assert (s, answer, 30*eps ("single")); -*/
--- a/src/DLD-FUNCTIONS/fftn.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,188 +0,0 @@ -/* - -Copyright (C) 2004-2012 David Bateman - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-mappers.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -// This function should be merged with Fifft. - -#if defined (HAVE_FFTW) -#define FFTSRC "@sc{fftw}" -#else -#define FFTSRC "@sc{fftpack}" -#endif - -static octave_value -do_fftn (const octave_value_list &args, const char *fcn, int type) -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 2) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - dim_vector dims = arg.dims (); - - for (int i = 0; i < dims.length (); i++) - if (dims(i) < 0) - return retval; - - if (nargin > 1) - { - Matrix val = args(1).matrix_value (); - if (val.rows () > val.columns ()) - val = val.transpose (); - - if (error_state || val.columns () != dims.length () || val.rows () != 1) - error ("%s: SIZE must be a vector of length dim", fcn); - else - { - for (int i = 0; i < dims.length (); i++) - { - if (xisnan (val(i,0))) - error ("%s: SIZE has invalid NaN entries", fcn); - else if (NINTbig (val(i,0)) < 0) - error ("%s: all dimensions in SIZE must be greater than zero", fcn); - else - { - dims(i) = NINTbig(val(i,0)); - } - } - } - } - - if (error_state) - return retval; - - if (dims.all_zero ()) - { - if (arg.is_single_type ()) - return octave_value (FloatMatrix ()); - else - return octave_value (Matrix ()); - } - - if (arg.is_single_type ()) - { - if (arg.is_real_type ()) - { - FloatNDArray nda = arg.float_array_value (); - - if (! error_state) - { - nda.resize (dims, 0.0); - retval = (type != 0 ? nda.ifourierNd () : nda.fourierNd ()); - } - } - else - { - FloatComplexNDArray cnda = arg.float_complex_array_value (); - - if (! error_state) - { - cnda.resize (dims, 0.0); - retval = (type != 0 ? cnda.ifourierNd () : cnda.fourierNd ()); - } - } - } - else - { - if (arg.is_real_type ()) - { - NDArray nda = arg.array_value (); - - if (! error_state) - { - nda.resize (dims, 0.0); - retval = (type != 0 ? nda.ifourierNd () : nda.fourierNd ()); - } - } - else if (arg.is_complex_type ()) - { - ComplexNDArray cnda = arg.complex_array_value (); - - if (! error_state) - { - cnda.resize (dims, 0.0); - retval = (type != 0 ? cnda.ifourierNd () : cnda.fourierNd ()); - } - } - else - { - gripe_wrong_type_arg (fcn, arg); - } - } - - return retval; -} - -DEFUN_DLD (fftn, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} fftn (@var{A})\n\ -@deftypefnx {Loadable Function} {} fftn (@var{A}, @var{size})\n\ -Compute the N-dimensional discrete Fourier transform of @var{A} using\n\ -a Fast Fourier Transform (FFT) algorithm.\n\ -\n\ -The optional vector argument @var{size} may be used specify the\n\ -dimensions of the array to be used. If an element of @var{size} is\n\ -smaller than the corresponding dimension of @var{A}, then the dimension of\n\ -@var{A} is truncated prior to performing the FFT@. Otherwise, if an element\n\ -of @var{size} is larger than the corresponding dimension then @var{A}\n\ -is resized and padded with zeros.\n\ -@seealso{ifftn, fft, fft2, fftw}\n\ -@end deftypefn") -{ - return do_fftn (args, "fftn", 0); -} - -DEFUN_DLD (ifftn, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} ifftn (@var{A})\n\ -@deftypefnx {Loadable Function} {} ifftn (@var{A}, @var{size})\n\ -Compute the inverse N-dimensional discrete Fourier transform of @var{A}\n\ -using a Fast Fourier Transform (FFT) algorithm.\n\ -\n\ -The optional vector argument @var{size} may be used specify the\n\ -dimensions of the array to be used. If an element of @var{size} is\n\ -smaller than the corresponding dimension of @var{A}, then the dimension of\n\ -@var{A} is truncated prior to performing the inverse FFT@. Otherwise, if an\n\ -element of @var{size} is larger than the corresponding dimension then @var{A}\n\ -is resized and padded with zeros.\n\ -@seealso{fftn, ifft, ifft2, fftw}\n\ -@end deftypefn") -{ - return do_fftn (args, "ifftn", 1); -}
--- a/src/DLD-FUNCTIONS/filter.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,738 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Based on Tony Richardson's filter.m. -// -// Originally translated to C++ by KH (Kurt.Hornik@wu-wien.ac.at) -// with help from Fritz Leisch and Andreas Weingessel on Oct 20, 1994. -// -// Rewritten to use templates to handle both real and complex cases by -// jwe, Wed Nov 1 19:15:29 1995. - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" - -#if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) -extern MArray<double> -filter (MArray<double>&, MArray<double>&, MArray<double>&, int dim); - -extern MArray<Complex> -filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, int dim); - -extern MArray<float> -filter (MArray<float>&, MArray<float>&, MArray<float>&, int dim); - -extern MArray<FloatComplex> -filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, int dim); -#endif - -template <class T> -MArray<T> -filter (MArray<T>& b, MArray<T>& a, MArray<T>& x, MArray<T>& si, - int dim = 0) -{ - MArray<T> y; - - octave_idx_type a_len = a.length (); - octave_idx_type b_len = b.length (); - - octave_idx_type ab_len = a_len > b_len ? a_len : b_len; - - // FIXME: The two lines below should be unecessary because - // this template is called with a and b as column vectors - // already. However the a.resize line is currently (2011/04/26) - // necessary to stop bug #33164. - b.resize (dim_vector (ab_len, 1), 0.0); - if (a_len > 1) - a.resize (dim_vector (ab_len, 1), 0.0); - - T norm = a (0); - - if (norm == static_cast<T>(0.0)) - { - error ("filter: the first element of A must be non-zero"); - return y; - } - - dim_vector x_dims = x.dims (); - if (dim < 0 || dim > x_dims.length ()) - { - error ("filter: DIM must be a valid dimension"); - return y; - } - - octave_idx_type x_len = x_dims(dim); - - dim_vector si_dims = si.dims (); - octave_idx_type si_len = si_dims(0); - - if (si_len != ab_len - 1) - { - error ("filter: first dimension of SI must be of length max (length (a), length (b)) - 1"); - return y; - } - - if (si_dims.length () != x_dims.length ()) - { - error ("filter: dimensionality of SI and X must agree"); - return y; - } - - for (octave_idx_type i = 1; i < dim; i++) - { - if (si_dims(i) != x_dims(i-1)) - { - error ("filter: dimensionality of SI and X must agree"); - return y; - } - } - for (octave_idx_type i = dim+1; i < x_dims.length (); i++) - { - if (si_dims(i) != x_dims(i)) - { - error ("filter: dimensionality of SI and X must agree"); - return y; - } - } - - if (x_len == 0) - return x; - - if (norm != static_cast<T>(1.0)) - { - a = a / norm; - b = b / norm; - } - - if (a_len <= 1 && si_len <= 0) - return b(0) * x; - - y.resize (x_dims, 0.0); - - int x_stride = 1; - for (int i = 0; i < dim; i++) - x_stride *= x_dims(i); - - octave_idx_type x_num = x_dims.numel () / x_len; - for (octave_idx_type num = 0; num < x_num; num++) - { - octave_idx_type x_offset; - if (x_stride == 1) - x_offset = num * x_len; - else - { - octave_idx_type x_offset2 = 0; - x_offset = num; - while (x_offset >= x_stride) - { - x_offset -= x_stride; - x_offset2++; - } - x_offset += x_offset2 * x_stride * x_len; - } - octave_idx_type si_offset = num * si_len; - - if (a_len > 1) - { - T *py = y.fortran_vec (); - T *psi = si.fortran_vec (); - - const T *pa = a.data (); - const T *pb = b.data (); - const T *px = x.data (); - - psi += si_offset; - - for (octave_idx_type i = 0, idx = x_offset; i < x_len; i++, idx += x_stride) - { - py[idx] = psi[0] + pb[0] * px[idx]; - - if (si_len > 0) - { - for (octave_idx_type j = 0; j < si_len - 1; j++) - { - OCTAVE_QUIT; - - psi[j] = psi[j+1] - pa[j+1] * py[idx] + pb[j+1] * px[idx]; - } - - psi[si_len-1] = pb[si_len] * px[idx] - pa[si_len] * py[idx]; - } - else - { - OCTAVE_QUIT; - - psi[0] = pb[si_len] * px[idx] - pa[si_len] * py[idx]; - } - } - } - else if (si_len > 0) - { - T *py = y.fortran_vec (); - T *psi = si.fortran_vec (); - - const T *pb = b.data (); - const T *px = x.data (); - - psi += si_offset; - - for (octave_idx_type i = 0, idx = x_offset; i < x_len; i++, idx += x_stride) - { - py[idx] = psi[0] + pb[0] * px[idx]; - - if (si_len > 1) - { - for (octave_idx_type j = 0; j < si_len - 1; j++) - { - OCTAVE_QUIT; - - psi[j] = psi[j+1] + pb[j+1] * px[idx]; - } - - psi[si_len-1] = pb[si_len] * px[idx]; - } - else - { - OCTAVE_QUIT; - - psi[0] = pb[1] * px[idx]; - } - } - } - } - - return y; -} - -#if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) -extern MArray<double> -filter (MArray<double>&, MArray<double>&, MArray<double>&, - MArray<double>&, int dim); - -extern MArray<Complex> -filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, - MArray<Complex>&, int dim); - -extern MArray<float> -filter (MArray<float>&, MArray<float>&, MArray<float>&, - MArray<float>&, int dim); - -extern MArray<FloatComplex> -filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, - MArray<FloatComplex>&, int dim); -#endif - -template <class T> -MArray<T> -filter (MArray<T>& b, MArray<T>& a, MArray<T>& x, int dim = -1) -{ - dim_vector x_dims = x.dims (); - - if (dim < 0) - { - // Find first non-singleton dimension - while (dim < x_dims.length () && x_dims(dim) <= 1) - dim++; - - // All dimensions singleton, pick first dimension - if (dim == x_dims.length ()) - dim = 0; - } - else - if (dim < 0 || dim > x_dims.length ()) - { - error ("filter: DIM must be a valid dimension"); - return MArray<T> (); - } - - octave_idx_type a_len = a.length (); - octave_idx_type b_len = b.length (); - - octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; - dim_vector si_dims = x.dims (); - for (int i = dim; i > 0; i--) - si_dims(i) = si_dims(i-1); - si_dims(0) = si_len; - - MArray<T> si (si_dims, T (0.0)); - - return filter (b, a, x, si, dim); -} - -DEFUN_DLD (filter, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {y =} filter (@var{b}, @var{a}, @var{x})\n\ -@deftypefnx {Loadable Function} {[@var{y}, @var{sf}] =} filter (@var{b}, @var{a}, @var{x}, @var{si})\n\ -@deftypefnx {Loadable Function} {[@var{y}, @var{sf}] =} filter (@var{b}, @var{a}, @var{x}, [], @var{dim})\n\ -@deftypefnx {Loadable Function} {[@var{y}, @var{sf}] =} filter (@var{b}, @var{a}, @var{x}, @var{si}, @var{dim})\n\ -Return the solution to the following linear, time-invariant difference\n\ -equation:\n\ -@tex\n\ -$$\n\ -\\sum_{k=0}^N a_{k+1} y_{n-k} = \\sum_{k=0}^M b_{k+1} x_{n-k}, \\qquad\n\ - 1 \\le n \\le P\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -@c Set example in small font to prevent overfull line\n\ -\n\ -@smallexample\n\ -@group\n\ - N M\n\ -SUM a(k+1) y(n-k) = SUM b(k+1) x(n-k) for 1<=n<=length(x)\n\ -k=0 k=0\n\ -@end group\n\ -@end smallexample\n\ -\n\ -@end ifnottex\n\ -\n\ -@noindent\n\ -where\n\ -@ifnottex\n\ -N=length(a)-1 and M=length(b)-1.\n\ -@end ifnottex\n\ -@tex\n\ -$a \\in \\Re^{N-1}$, $b \\in \\Re^{M-1}$, and $x \\in \\Re^P$.\n\ -@end tex\n\ -The result is calculated over the first non-singleton dimension of @var{x}\n\ -or over @var{dim} if supplied.\n\ -\n\ -An equivalent form of the equation is:\n\ -@tex\n\ -$$\n\ -y_n = -\\sum_{k=1}^N c_{k+1} y_{n-k} + \\sum_{k=0}^M d_{k+1} x_{n-k}, \\qquad\n\ - 1 \\le n \\le P\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -@c Set example in small font to prevent overfull line\n\ -\n\ -@smallexample\n\ -@group\n\ - N M\n\ -y(n) = - SUM c(k+1) y(n-k) + SUM d(k+1) x(n-k) for 1<=n<=length(x)\n\ - k=1 k=0\n\ -@end group\n\ -@end smallexample\n\ -\n\ -@end ifnottex\n\ -\n\ -@noindent\n\ -where\n\ -@ifnottex\n\ - c = a/a(1) and d = b/a(1).\n\ -@end ifnottex\n\ -@tex\n\ -$c = a/a_1$ and $d = b/a_1$.\n\ -@end tex\n\ -\n\ -If the fourth argument @var{si} is provided, it is taken as the\n\ -initial state of the system and the final state is returned as\n\ -@var{sf}. The state vector is a column vector whose length is\n\ -equal to the length of the longest coefficient vector minus one.\n\ -If @var{si} is not supplied, the initial state vector is set to all\n\ -zeros.\n\ -\n\ -In terms of the Z Transform, y is the result of passing the discrete-\n\ -time signal x through a system characterized by the following rational\n\ -system function:\n\ -@tex\n\ -$$\n\ -H(z) = {\\displaystyle\\sum_{k=0}^M d_{k+1} z^{-k}\n\ - \\over 1 + \\displaystyle\\sum_{k+1}^N c_{k+1} z^{-k}}\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ - M\n\ - SUM d(k+1) z^(-k)\n\ - k=0\n\ -H(z) = ---------------------\n\ - N\n\ - 1 + SUM c(k+1) z^(-k)\n\ - k=1\n\ -@end group\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -@seealso{filter2, fftfilt, freqz}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin < 3 || nargin > 5) - { - print_usage (); - return retval; - } - - const char *errmsg = "filter: arguments a and b must be vectors"; - - int dim; - dim_vector x_dims = args(2).dims (); - - if (nargin == 5) - { - dim = args(4).nint_value () - 1; - if (dim < 0 || dim >= x_dims.length ()) - { - error ("filter: DIM must be a valid dimension"); - return retval; - } - } - else - { - // Find first non-singleton dimension - dim = 0; - while (dim < x_dims.length () && x_dims(dim) <= 1) - dim++; - - // All dimensions singleton, pick first dimension - if (dim == x_dims.length ()) - dim = 0; - } - - bool isfloat = (args(0).is_single_type () - || args(1).is_single_type () - || args(2).is_single_type () - || (nargin >= 4 && args(3).is_single_type ())); - - if (args(0).is_complex_type () - || args(1).is_complex_type () - || args(2).is_complex_type () - || (nargin >= 4 && args(3).is_complex_type ())) - { - if (isfloat) - { - FloatComplexColumnVector b (args(0).float_complex_vector_value ()); - FloatComplexColumnVector a (args(1).float_complex_vector_value ()); - - FloatComplexNDArray x (args(2).float_complex_array_value ()); - - if (! error_state) - { - FloatComplexNDArray si; - - if (nargin == 3 || args(3).is_empty ()) - { - octave_idx_type a_len = a.length (); - octave_idx_type b_len = b.length (); - - octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; - - dim_vector si_dims = x.dims (); - for (int i = dim; i > 0; i--) - si_dims(i) = si_dims(i-1); - si_dims(0) = si_len; - - si.resize (si_dims, 0.0); - } - else - { - si = args(3).float_complex_array_value (); - - if (si.is_vector () && x.is_vector ()) - si = si.reshape (dim_vector (si.numel (), 1)); - } - - if (! error_state) - { - FloatComplexNDArray y (filter (b, a, x, si, dim)); - - if (nargout == 2) - retval(1) = si; - - retval(0) = y; - } - else - error (errmsg); - } - else - error (errmsg); - } - else - { - ComplexColumnVector b (args(0).complex_vector_value ()); - ComplexColumnVector a (args(1).complex_vector_value ()); - - ComplexNDArray x (args(2).complex_array_value ()); - - if (! error_state) - { - ComplexNDArray si; - - if (nargin == 3 || args(3).is_empty ()) - { - octave_idx_type a_len = a.length (); - octave_idx_type b_len = b.length (); - - octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; - - dim_vector si_dims = x.dims (); - for (int i = dim; i > 0; i--) - si_dims(i) = si_dims(i-1); - si_dims(0) = si_len; - - si.resize (si_dims, 0.0); - } - else - { - si = args(3).complex_array_value (); - - if (si.is_vector () && x.is_vector ()) - si = si.reshape (dim_vector (si.numel (), 1)); - } - - if (! error_state) - { - ComplexNDArray y (filter (b, a, x, si, dim)); - - if (nargout == 2) - retval(1) = si; - - retval(0) = y; - } - else - error (errmsg); - } - else - error (errmsg); - } - } - else - { - if (isfloat) - { - FloatColumnVector b (args(0).float_vector_value ()); - FloatColumnVector a (args(1).float_vector_value ()); - - FloatNDArray x (args(2).float_array_value ()); - - if (! error_state) - { - FloatNDArray si; - - if (nargin == 3 || args(3).is_empty ()) - { - octave_idx_type a_len = a.length (); - octave_idx_type b_len = b.length (); - - octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; - - dim_vector si_dims = x.dims (); - for (int i = dim; i > 0; i--) - si_dims(i) = si_dims(i-1); - si_dims(0) = si_len; - - si.resize (si_dims, 0.0); - } - else - { - si = args(3).float_array_value (); - - if (si.is_vector () && x.is_vector ()) - si = si.reshape (dim_vector (si.numel (), 1)); - } - - if (! error_state) - { - FloatNDArray y (filter (b, a, x, si, dim)); - - if (nargout == 2) - retval(1) = si; - - retval(0) = y; - } - else - error (errmsg); - } - else - error (errmsg); - } - else - { - ColumnVector b (args(0).vector_value ()); - ColumnVector a (args(1).vector_value ()); - - NDArray x (args(2).array_value ()); - - if (! error_state) - { - NDArray si; - - if (nargin == 3 || args(3).is_empty ()) - { - octave_idx_type a_len = a.length (); - octave_idx_type b_len = b.length (); - - octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; - - dim_vector si_dims = x.dims (); - for (int i = dim; i > 0; i--) - si_dims(i) = si_dims(i-1); - si_dims(0) = si_len; - - si.resize (si_dims, 0.0); - } - else - { - si = args(3).array_value (); - - if (si.is_vector () && x.is_vector ()) - si = si.reshape (dim_vector (si.numel (), 1)); - } - - if (! error_state) - { - NDArray y (filter (b, a, x, si, dim)); - - if (nargout == 2) - retval(1) = si; - - retval(0) = y; - } - else - error (errmsg); - } - else - error (errmsg); - } - } - - return retval; -} - -template MArray<double> -filter (MArray<double>&, MArray<double>&, MArray<double>&, - MArray<double>&, int dim); - -template MArray<double> -filter (MArray<double>&, MArray<double>&, MArray<double>&, int dim); - -template MArray<Complex> -filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, - MArray<Complex>&, int dim); - -template MArray<Complex> -filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, int dim); - -template MArray<float> -filter (MArray<float>&, MArray<float>&, MArray<float>&, - MArray<float>&, int dim); - -template MArray<float> -filter (MArray<float>&, MArray<float>&, MArray<float>&, int dim); - -template MArray<FloatComplex> -filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, - MArray<FloatComplex>&, int dim); - -template MArray<FloatComplex> -filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, int dim); - -/* -%!shared a, b, x, r -%!test -%! a = [1 1]; -%! b = [1 1]; -%! x = zeros (1,10); x(1) = 1; -%! assert (filter (b, [1], x ), [1 1 0 0 0 0 0 0 0 0]); -%! assert (filter (b, [1], x.'), [1 1 0 0 0 0 0 0 0 0].'); -%! assert (filter (b.', [1], x ), [1 1 0 0 0 0 0 0 0 0] ); -%! assert (filter (b.', [1], x.'), [1 1 0 0 0 0 0 0 0 0].'); -%! assert (filter ([1], a, x ), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1] ); -%! assert (filter ([1], a, x.'), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1].'); -%! assert (filter ([1], a.', x ), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1] ); -%! assert (filter ([1], a.', x.'), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1].'); -%! assert (filter (b, a, x ), [1 0 0 0 0 0 0 0 0 0] ); -%! assert (filter (b.', a, x ), [1 0 0 0 0 0 0 0 0 0] ); -%! assert (filter (b, a.', x ), [1 0 0 0 0 0 0 0 0 0] ); -%! assert (filter (b.', a, x ), [1 0 0 0 0 0 0 0 0 0] ); -%! assert (filter (b, a, x.'), [1 0 0 0 0 0 0 0 0 0].'); -%! assert (filter (b.', a, x.'), [1 0 0 0 0 0 0 0 0 0].'); -%! assert (filter (b, a.', x.'), [1 0 0 0 0 0 0 0 0 0].'); -%! assert (filter (b.', a, x.'), [1 0 0 0 0 0 0 0 0 0].'); - -%!test -%! r = sqrt (1/2) * (1+i); -%! a = a*r; -%! b = b*r; -%! assert (filter (b, [1], x ), r*[1 1 0 0 0 0 0 0 0 0] ); -%! assert (filter (b, [1], r*x ), r*r*[1 1 0 0 0 0 0 0 0 0] ); -%! assert (filter (b, [1], x.' ), r*[1 1 0 0 0 0 0 0 0 0].' ); -%! assert (filter (b, a, x ), [1 0 0 0 0 0 0 0 0 0] ); -%! assert (filter (b, a, r*x ), r*[1 0 0 0 0 0 0 0 0 0] ); - -%!shared a, b, x, y, so -%!test -%! a = [1,1]; -%! b = [1,1]; -%! x = zeros (1,10); x(1) = 1; -%! [y, so] = filter (b, [1], x, [-1]); -%! assert (y, [0 1 0 0 0 0 0 0 0 0]); -%! assert (so, 0); - -%!test -%! x = zeros (10,3); x(1,1) = -1; x(1,2) = 1; -%! y0 = zeros (10,3); y0(1:2,1) = -1; y0(1:2,2) = 1; -%! y = filter (b, [1], x); -%! assert (y, y0); - -%!test -%! a = [1,1]; -%! b=[1,1]; -%! x = zeros (4,4,2); x(1,1:4,1) = +1; x(1,1:4,2) = -1; -%! y0 = zeros (4,4,2); y0(1:2,1:4,1) = +1; y0(1:2,1:4,2) = -1; -%! y = filter (b, [1], x); -%! assert (y, y0); - -%!assert (filter (1, ones (10,1) / 10, []), []) -%!assert (filter (1, ones (10,1) / 10, zeros (0,10)), zeros (0,10)) -%!assert (filter (1, ones (10,1) / 10, single (1:5)), repmat (single (10), 1, 5)) - -%% Test using initial conditions -%!assert (filter ([1, 1, 1], [1, 1], [1 2], [1, 1]), [2 2]) -%!assert (filter ([1, 1, 1], [1, 1], [1 2], [1, 1]'), [2 2]) -%!assert (filter ([1, 3], [1], [1 2; 3 4; 5 6], [4, 5]), [5 7; 6 10; 14 18]) -%!error (filter ([1, 3], [1], [1 2; 3 4; 5 6], [4, 5]')) -%!assert (filter ([1, 3, 2], [1], [1 2; 3 4; 5 6], [1 0 0; 1 0 0], 2), [2 6; 3 13; 5 21]) - -## Test of DIM parameter -%!test -%! x = ones (2, 1, 3, 4); -%! x(1,1,:,:) = [1 2 3 4; 5 6 7 8; 9 10 11 12]; -%! y0 = [1 1 6 2 15 3 2 1 8 2 18 3 3 1 10 2 21 3 4 1 12 2 24 3]; -%! y0 = reshape (y0, size (x)); -%! y = filter ([1 1 1], 1, x, [], 3); -%! assert (y, y0); -*/
--- a/src/DLD-FUNCTIONS/find.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,621 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" - -// Find at most N_TO_FIND nonzero elements in NDA. Search forward if -// DIRECTION is 1, backward if it is -1. NARGOUT is the number of -// output arguments. If N_TO_FIND is -1, find all nonzero elements. - -template <typename T> -octave_value_list -find_nonzero_elem_idx (const Array<T>& nda, int nargout, - octave_idx_type n_to_find, int direction) -{ - octave_value_list retval ((nargout == 0 ? 1 : nargout), Matrix ()); - - Array<octave_idx_type> idx; - if (n_to_find >= 0) - idx = nda.find (n_to_find, direction == -1); - else - idx = nda.find (); - - // The maximum element is always at the end. - octave_idx_type iext = idx.is_empty () ? 0 : idx.xelem (idx.numel () - 1) + 1; - - switch (nargout) - { - default: - case 3: - retval(2) = Array<T> (nda.index (idx_vector (idx))); - // Fall through! - - case 2: - { - Array<octave_idx_type> jdx (idx.dims ()); - octave_idx_type n = idx.length (), nr = nda.rows (); - for (octave_idx_type i = 0; i < n; i++) - { - jdx.xelem (i) = idx.xelem (i) / nr; - idx.xelem (i) %= nr; - } - iext = -1; - retval(1) = idx_vector (jdx, -1); - } - // Fall through! - - case 1: - case 0: - retval(0) = idx_vector (idx, iext); - break; - } - - return retval; -} - -template <typename T> -octave_value_list -find_nonzero_elem_idx (const Sparse<T>& v, int nargout, - octave_idx_type n_to_find, int direction) -{ - octave_value_list retval ((nargout == 0 ? 1 : nargout), Matrix ()); - - - octave_idx_type nc = v.cols (); - octave_idx_type nr = v.rows (); - octave_idx_type nz = v.nnz (); - - // Search in the default range. - octave_idx_type start_nc = -1; - octave_idx_type end_nc = -1; - octave_idx_type count; - - // Search for the range to search - if (n_to_find < 0) - { - start_nc = 0; - end_nc = nc; - n_to_find = nz; - count = nz; - } - else if (direction > 0) - { - for (octave_idx_type j = 0; j < nc; j++) - { - OCTAVE_QUIT; - if (v.cidx (j) == 0 && v.cidx (j+1) != 0) - start_nc = j; - if (v.cidx (j+1) >= n_to_find) - { - end_nc = j + 1; - break; - } - } - } - else - { - for (octave_idx_type j = nc; j > 0; j--) - { - OCTAVE_QUIT; - if (v.cidx (j) == nz && v.cidx (j-1) != nz) - end_nc = j; - if (nz - v.cidx (j-1) >= n_to_find) - { - start_nc = j - 1; - break; - } - } - } - - count = (n_to_find > v.cidx (end_nc) - v.cidx (start_nc) ? - v.cidx (end_nc) - v.cidx (start_nc) : n_to_find); - - // If the original argument was a row vector, force a row vector of - // the overall indices to be returned. But see below for scalar - // case... - - octave_idx_type result_nr = count; - octave_idx_type result_nc = 1; - - bool scalar_arg = false; - - if (v.rows () == 1) - { - result_nr = 1; - result_nc = count; - - scalar_arg = (v.columns () == 1); - } - - Matrix idx (result_nr, result_nc); - - Matrix i_idx (result_nr, result_nc); - Matrix j_idx (result_nr, result_nc); - - Array<T> val (dim_vector (result_nr, result_nc)); - - if (count > 0) - { - // Search for elements to return. Only search the region where - // there are elements to be found using the count that we want - // to find. - for (octave_idx_type j = start_nc, cx = 0; j < end_nc; j++) - for (octave_idx_type i = v.cidx (j); i < v.cidx (j+1); i++ ) - { - OCTAVE_QUIT; - if (direction < 0 && i < nz - count) - continue; - i_idx(cx) = static_cast<double> (v.ridx (i) + 1); - j_idx(cx) = static_cast<double> (j + 1); - idx(cx) = j * nr + v.ridx (i) + 1; - val(cx) = v.data(i); - cx++; - if (cx == count) - break; - } - } - else if (scalar_arg) - { - idx.resize (0, 0); - - i_idx.resize (0, 0); - j_idx.resize (0, 0); - - val.resize (dim_vector (0, 0)); - } - - switch (nargout) - { - case 0: - case 1: - retval(0) = idx; - break; - - case 5: - retval(4) = nc; - // Fall through - - case 4: - retval(3) = nr; - // Fall through - - case 3: - retval(2) = val; - // Fall through! - - case 2: - retval(1) = j_idx; - retval(0) = i_idx; - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -octave_value_list -find_nonzero_elem_idx (const PermMatrix& v, int nargout, - octave_idx_type n_to_find, int direction) -{ - // There are far fewer special cases to handle for a PermMatrix. - octave_value_list retval ((nargout == 0 ? 1 : nargout), Matrix ()); - - octave_idx_type nc = v.cols (); - octave_idx_type start_nc, count; - - // Determine the range to search. - if (n_to_find < 0 || n_to_find >= nc) - { - start_nc = 0; - n_to_find = nc; - count = nc; - } - else if (direction > 0) - { - start_nc = 0; - count = n_to_find; - } - else - { - start_nc = nc - n_to_find; - count = n_to_find; - } - - bool scalar_arg = (v.rows () == 1 && v.cols () == 1); - - Matrix idx (count, 1); - Matrix i_idx (count, 1); - Matrix j_idx (count, 1); - // Every value is 1. - Array<double> val (dim_vector (count, 1), 1.0); - - if (count > 0) - { - const octave_idx_type* p = v.data (); - if (v.is_col_perm ()) - { - for (octave_idx_type k = 0; k < count; k++) - { - OCTAVE_QUIT; - const octave_idx_type j = start_nc + k; - const octave_idx_type i = p[j]; - i_idx(k) = static_cast<double> (1+i); - j_idx(k) = static_cast<double> (1+j); - idx(k) = j * nc + i + 1; - } - } - else - { - for (octave_idx_type k = 0; k < count; k++) - { - OCTAVE_QUIT; - const octave_idx_type i = start_nc + k; - const octave_idx_type j = p[i]; - // Scatter into the index arrays according to - // j adjusted by the start point. - const octave_idx_type koff = j - start_nc; - i_idx(koff) = static_cast<double> (1+i); - j_idx(koff) = static_cast<double> (1+j); - idx(koff) = j * nc + i + 1; - } - } - } - else if (scalar_arg) - { - // Same odd compatibility case as the other overrides. - idx.resize (0, 0); - i_idx.resize (0, 0); - j_idx.resize (0, 0); - val.resize (dim_vector (0, 0)); - } - - switch (nargout) - { - case 0: - case 1: - retval(0) = idx; - break; - - case 5: - retval(4) = nc; - // Fall through - - case 4: - retval(3) = nc; - // Fall through - - case 3: - retval(2) = val; - // Fall through! - - case 2: - retval(1) = j_idx; - retval(0) = i_idx; - break; - - default: - panic_impossible (); - break; - } - - return retval; -} - -DEFUN_DLD (find, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{idx} =} find (@var{x})\n\ -@deftypefnx {Loadable Function} {@var{idx} =} find (@var{x}, @var{n})\n\ -@deftypefnx {Loadable Function} {@var{idx} =} find (@var{x}, @var{n}, @var{direction})\n\ -@deftypefnx {Loadable Function} {[i, j] =} find (@dots{})\n\ -@deftypefnx {Loadable Function} {[i, j, v] =} find (@dots{})\n\ -Return a vector of indices of nonzero elements of a matrix, as a row if\n\ -@var{x} is a row vector or as a column otherwise. To obtain a single index\n\ -for each matrix element, Octave pretends that the columns of a matrix form\n\ -one long vector (like Fortran arrays are stored). For example:\n\ -\n\ -@example\n\ -@group\n\ -find (eye (2))\n\ - @result{} [ 1; 4 ]\n\ -@end group\n\ -@end example\n\ -\n\ -If two outputs are requested, @code{find} returns the row and column\n\ -indices of nonzero elements of a matrix. For example:\n\ -\n\ -@example\n\ -@group\n\ -[i, j] = find (2 * eye (2))\n\ - @result{} i = [ 1; 2 ]\n\ - @result{} j = [ 1; 2 ]\n\ -@end group\n\ -@end example\n\ -\n\ -If three outputs are requested, @code{find} also returns a vector\n\ -containing the nonzero values. For example:\n\ -\n\ -@example\n\ -@group\n\ -[i, j, v] = find (3 * eye (2))\n\ - @result{} i = [ 1; 2 ]\n\ - @result{} j = [ 1; 2 ]\n\ - @result{} v = [ 3; 3 ]\n\ -@end group\n\ -@end example\n\ -\n\ -If two inputs are given, @var{n} indicates the maximum number of\n\ -elements to find from the beginning of the matrix or vector.\n\ -\n\ -If three inputs are given, @var{direction} should be one of \"first\" or\n\ -\"last\", requesting only the first or last @var{n} indices, respectively.\n\ -However, the indices are always returned in ascending order.\n\ -\n\ -Note that this function is particularly useful for sparse matrices, as\n\ -it extracts the non-zero elements as vectors, which can then be used to\n\ -create the original matrix. For example:\n\ -\n\ -@example\n\ -@group\n\ -sz = size (a);\n\ -[i, j, v] = find (a);\n\ -b = sparse (i, j, v, sz(1), sz(2));\n\ -@end group\n\ -@end example\n\ -@seealso{nonzeros}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin > 3 || nargin < 1) - { - print_usage (); - return retval; - } - - // Setup the default options. - octave_idx_type n_to_find = -1; - if (nargin > 1) - { - double val = args(1).scalar_value (); - - if (error_state || (val < 0 || (! xisinf (val) && val != xround (val)))) - { - error ("find: N must be a non-negative integer"); - return retval; - } - else if (! xisinf (val)) - n_to_find = val; - } - - // Direction to do the searching (1 == forward, -1 == reverse). - int direction = 1; - if (nargin > 2) - { - direction = 0; - - std::string s_arg = args(2).string_value (); - - if (! error_state) - { - if (s_arg == "first") - direction = 1; - else if (s_arg == "last") - direction = -1; - } - - if (direction == 0) - { - error ("find: DIRECTION must be \"first\" or \"last\""); - return retval; - } - } - - octave_value arg = args(0); - - if (arg.is_bool_type ()) - { - if (arg.is_sparse_type ()) - { - SparseBoolMatrix v = arg.sparse_bool_matrix_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (v, nargout, - n_to_find, direction); - } - else if (nargout <= 1 && n_to_find == -1 && direction == 1) - { - // This case is equivalent to extracting indices from a logical - // matrix. Try to reuse the possibly cached index vector. - retval(0) = arg.index_vector ().unmask (); - } - else - { - boolNDArray v = arg.bool_array_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (v, nargout, - n_to_find, direction); - } - } - else if (arg.is_integer_type ()) - { -#define DO_INT_BRANCH(INTT) \ - else if (arg.is_ ## INTT ## _type ()) \ - { \ - INTT ## NDArray v = arg.INTT ## _array_value (); \ - \ - if (! error_state) \ - retval = find_nonzero_elem_idx (v, nargout, \ - n_to_find, direction);\ - } - - if (false) - ; - DO_INT_BRANCH (int8) - DO_INT_BRANCH (int16) - DO_INT_BRANCH (int32) - DO_INT_BRANCH (int64) - DO_INT_BRANCH (uint8) - DO_INT_BRANCH (uint16) - DO_INT_BRANCH (uint32) - DO_INT_BRANCH (uint64) - else - panic_impossible (); - } - else if (arg.is_sparse_type ()) - { - if (arg.is_real_type ()) - { - SparseMatrix v = arg.sparse_matrix_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (v, nargout, - n_to_find, direction); - } - else if (arg.is_complex_type ()) - { - SparseComplexMatrix v = arg.sparse_complex_matrix_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (v, nargout, - n_to_find, direction); - } - else - gripe_wrong_type_arg ("find", arg); - } - else if (arg.is_perm_matrix ()) - { - PermMatrix P = arg.perm_matrix_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (P, nargout, n_to_find, direction); - } - else if (arg.is_string ()) - { - charNDArray chnda = arg.char_array_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (chnda, nargout, n_to_find, direction); - } - else if (arg.is_single_type ()) - { - if (arg.is_real_type ()) - { - FloatNDArray nda = arg.float_array_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (nda, nargout, n_to_find, - direction); - } - else if (arg.is_complex_type ()) - { - FloatComplexNDArray cnda = arg.float_complex_array_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (cnda, nargout, n_to_find, - direction); - } - } - else if (arg.is_real_type ()) - { - NDArray nda = arg.array_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (nda, nargout, n_to_find, direction); - } - else if (arg.is_complex_type ()) - { - ComplexNDArray cnda = arg.complex_array_value (); - - if (! error_state) - retval = find_nonzero_elem_idx (cnda, nargout, n_to_find, direction); - } - else - gripe_wrong_type_arg ("find", arg); - - return retval; -} - -/* -%!assert (find (char ([0, 97])), 2) -%!assert (find ([1, 0, 1, 0, 1]), [1, 3, 5]) -%!assert (find ([1; 0; 3; 0; 1]), [1; 3; 5]) -%!assert (find ([0, 0, 2; 0, 3, 0; -1, 0, 0]), [3; 5; 7]) - -%!test -%! [i, j, v] = find ([0, 0, 2; 0, 3, 0; -1, 0, 0]); -%! -%! assert (i, [3; 2; 1]); -%! assert (j, [1; 2; 3]); -%! assert (v, [-1; 3; 2]); - -%!assert (find (single ([1, 0, 1, 0, 1])), [1, 3, 5]) -%!assert (find (single ([1; 0; 3; 0; 1])), [1; 3; 5]) -%!assert (find (single ([0, 0, 2; 0, 3, 0; -1, 0, 0])), [3; 5; 7]) - -%!test -%! [i, j, v] = find (single ([0, 0, 2; 0, 3, 0; -1, 0, 0])); -%! -%! assert (i, [3; 2; 1]); -%! assert (j, [1; 2; 3]); -%! assert (v, single ([-1; 3; 2])); - -%!test -%! pcol = [5 1 4 3 2]; -%! P = eye (5) (:, pcol); -%! [i, j, v] = find (P); -%! [ifull, jfull, vfull] = find (full (P)); -%! assert (i, ifull); -%! assert (j, jfull); -%! assert (all (v == 1)); - -%!test -%! prow = [5 1 4 3 2]; -%! P = eye (5) (prow, :); -%! [i, j, v] = find (P); -%! [ifull, jfull, vfull] = find (full (P)); -%! assert (i, ifull); -%! assert (j, jfull); -%! assert (all (v == 1)); - -%!assert (find ([2 0 1 0 5 0], 1), 1) -%!assert (find ([2 0 1 0 5 0], 2, "last"), [3, 5]) - -%!assert (find ([2 0 1 0 5 0], Inf), [1, 3, 5]) -%!assert (find ([2 0 1 0 5 0], Inf, "last"), [1, 3, 5]) - -%!error find () -*/
--- a/src/DLD-FUNCTIONS/gammainc.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,230 +0,0 @@ -/* - -Copyright (C) 1997-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-specfun.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (gammainc, args, , - "-*- texinfo -*-\n\ -@deftypefn {Mapping Function} {} gammainc (@var{x}, @var{a})\n\ -@deftypefnx {Mapping Function} {} gammainc (@var{x}, @var{a}, \"lower\")\n\ -@deftypefnx {Mapping Function} {} gammainc (@var{x}, @var{a}, \"upper\")\n\ -Compute the normalized incomplete gamma function,\n\ -@tex\n\ -$$\n\ - \\gamma (x, a) = {1 \\over {\\Gamma (a)}}\\displaystyle{\\int_0^x t^{a-1} e^{-t} dt}\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ - x\n\ - 1 /\n\ -gammainc (x, a) = --------- | exp (-t) t^(a-1) dt\n\ - gamma (a) /\n\ - t=0\n\ -@end group\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -with the limiting value of 1 as @var{x} approaches infinity.\n\ -The standard notation is @math{P(a,x)}, e.g., Abramowitz and Stegun (6.5.1).\n\ -\n\ -If @var{a} is scalar, then @code{gammainc (@var{x}, @var{a})} is returned\n\ -for each element of @var{x} and vice versa.\n\ -\n\ -If neither @var{x} nor @var{a} is scalar, the sizes of @var{x} and\n\ -@var{a} must agree, and @code{gammainc} is applied element-by-element.\n\ -\n\ -By default the incomplete gamma function integrated from 0 to @var{x} is\n\ -computed. If \"upper\" is given then the complementary function integrated\n\ -from @var{x} to infinity is calculated. It should be noted that\n\ -\n\ -@example\n\ -gammainc (@var{x}, @var{a}) @equiv{} 1 - gammainc (@var{x}, @var{a}, \"upper\")\n\ -@end example\n\ -@seealso{gamma, lgamma}\n\ -@end deftypefn") -{ - octave_value retval; - bool lower = true; - - int nargin = args.length (); - - if (nargin == 3) - { - if (args(2).is_string ()) - { - std::string s = args(2).string_value (); - std::transform (s.begin (), s.end (), s.begin (), tolower); - if (s == "upper") - lower = false; - else if (s != "lower") - error ("gammainc: third argument must be \"lower\" or \"upper\""); - } - else - error ("gammainc: third argument must be \"lower\" or \"upper\""); - - } - - if (!error_state && nargin >= 2 && nargin <= 3) - { - octave_value x_arg = args(0); - octave_value a_arg = args(1); - - // FIXME Can we make a template version of the duplicated code below - if (x_arg.is_single_type () || a_arg.is_single_type ()) - { - if (x_arg.is_scalar_type ()) - { - float x = x_arg.float_value (); - - if (! error_state) - { - if (a_arg.is_scalar_type ()) - { - float a = a_arg.float_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) - : static_cast<float>(1) - gammainc (x, a); - } - else - { - FloatNDArray a = a_arg.float_array_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) - : static_cast<float>(1) - gammainc (x, a); - } - } - } - else - { - FloatNDArray x = x_arg.float_array_value (); - - if (! error_state) - { - if (a_arg.is_scalar_type ()) - { - float a = a_arg.float_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) - : static_cast<float>(1) - gammainc (x, a); - } - else - { - FloatNDArray a = a_arg.float_array_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) - : static_cast<float>(1) - gammainc (x, a); - } - } - } - } - else - { - if (x_arg.is_scalar_type ()) - { - double x = x_arg.double_value (); - - if (! error_state) - { - if (a_arg.is_scalar_type ()) - { - double a = a_arg.double_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); - } - else - { - NDArray a = a_arg.array_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); - } - } - } - else - { - NDArray x = x_arg.array_value (); - - if (! error_state) - { - if (a_arg.is_scalar_type ()) - { - double a = a_arg.double_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); - } - else - { - NDArray a = a_arg.array_value (); - - if (! error_state) - retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); - } - } - } - } - } - else - print_usage (); - - return retval; -} - -/* -%!test -%! a = [.5 .5 .5 .5 .5]; -%! x = [0 1 2 3 4]; -%! v1 = sqrt (pi)*erf (x)./gamma (a); -%! v3 = gammainc (x.*x, a); -%! assert (v1, v3, sqrt (eps)); - -%!assert (gammainc (0:4,0.5, "upper"), 1-gammainc (0:4,0.5), 1e-10) - -%!test -%! a = single ([.5 .5 .5 .5 .5]); -%! x = single ([0 1 2 3 4]); -%! v1 = sqrt (pi ("single"))*erf (x)./gamma (a); -%! v3 = gammainc (x.*x, a); -%! assert (v1, v3, sqrt (eps ("single"))); - -%!assert (gammainc (single (0:4), single (0.5), "upper"), -%! single (1)-gammainc (single (0:4), single (0.5)), -%! single (1e-7)) -*/
--- a/src/DLD-FUNCTIONS/gcd.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,528 +0,0 @@ -/* - -Copyright (C) 2004-2012 David Bateman -Copyright (C) 2010 Jaroslav Hajek, Jordi Gutiérrez Hermoso - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "dNDArray.h" -#include "CNDArray.h" -#include "fNDArray.h" -#include "fCNDArray.h" -#include "lo-mappers.h" -#include "oct-binmap.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" - -static double -simple_gcd (double a, double b) -{ - if (! xisinteger (a) || ! xisinteger (b)) - (*current_liboctave_error_handler) - ("gcd: all values must be integers"); - - double aa = fabs (a); - double bb = fabs (b); - - while (bb != 0) - { - double tt = fmod (aa, bb); - aa = bb; - bb = tt; - } - - return aa; -} - -// Don't use the Complex and FloatComplex typedefs because we need to -// refer to the actual float precision FP in the body (and when gcc -// implements template aliases from C++0x, can do a small fix here). -template <typename FP> -static void -divide (const std::complex<FP>& a, const std::complex<FP>& b, - std::complex<FP>& q, std::complex<FP>& r) -{ - FP qr = gnulib::floor ((a/b).real () + 0.5); - FP qi = gnulib::floor ((a/b).imag () + 0.5); - - q = std::complex<FP> (qr, qi); - - r = a - q*b; -} - -template <typename FP> -static std::complex<FP> -simple_gcd (const std::complex<FP>& a, const std::complex<FP>& b) -{ - if (! xisinteger (a.real ()) || ! xisinteger (a.imag ()) - || ! xisinteger (b.real ()) || ! xisinteger (b.imag ())) - (*current_liboctave_error_handler) - ("gcd: all complex parts must be integers"); - - std::complex<FP> aa = a; - std::complex<FP> bb = b; - - if (abs (aa) < abs (bb)) - std::swap (aa, bb); - - while (abs (bb) != 0) - { - std::complex<FP> qq, rr; - divide (aa, bb, qq, rr); - aa = bb; - bb = rr; - } - - return aa; -} - -template <class T> -static octave_int<T> -simple_gcd (const octave_int<T>& a, const octave_int<T>& b) -{ - T aa = a.abs ().value (); - T bb = b.abs ().value (); - - while (bb != 0) - { - T tt = aa % bb; - aa = bb; - bb = tt; - } - - return aa; -} - -static double -extended_gcd (double a, double b, double& x, double& y) -{ - if (! xisinteger (a) || ! xisinteger (b)) - (*current_liboctave_error_handler) - ("gcd: all values must be integers"); - - double aa = fabs (a); - double bb = fabs (b); - - double xx = 0, yy = 1; - double lx = 1, ly = 0; - - while (bb != 0) - { - double qq = gnulib::floor (aa / bb); - double tt = fmod (aa, bb); - - aa = bb; - bb = tt; - - double tx = lx - qq*xx; - lx = xx; - xx = tx; - - double ty = ly - qq*yy; - ly = yy; - yy = ty; - } - - x = a >= 0 ? lx : -lx; - y = b >= 0 ? ly : -ly; - - return aa; -} - -template <typename FP> -static std::complex<FP> -extended_gcd (const std::complex<FP>& a, const std::complex<FP>& b, - std::complex<FP>& x, std::complex<FP>& y) -{ - if (! xisinteger (a.real ()) || ! xisinteger (a.imag ()) - || ! xisinteger (b.real ()) || ! xisinteger (b.imag ())) - (*current_liboctave_error_handler) - ("gcd: all complex parts must be integers"); - - std::complex<FP> aa = a, bb = b; - bool swapped = false; - if (abs (aa) < abs (bb)) - { - std::swap (aa, bb); - swapped = true; - } - - std::complex<FP> xx = 0, lx = 1; - std::complex<FP> yy = 1, ly = 0; - - while (abs(bb) != 0) - { - std::complex<FP> qq, rr; - divide (aa, bb, qq, rr); - aa = bb; - bb = rr; - - std::complex<FP> tx = lx - qq*xx; - lx = xx; - xx = tx; - - std::complex<FP> ty = ly - qq*yy; - ly = yy; - yy = ty; - } - - x = lx; - y = ly; - - if (swapped) - std::swap (x, y); - - return aa; -} - -template <class T> -static octave_int<T> -extended_gcd (const octave_int<T>& a, const octave_int<T>& b, - octave_int<T>& x, octave_int<T>& y) -{ - T aa = a.abs ().value (); - T bb = b.abs ().value (); - T xx = 0, lx = 1; - T yy = 1, ly = 0; - - while (bb != 0) - { - T qq = aa / bb; - T tt = aa % bb; - aa = bb; - bb = tt; - - T tx = lx - qq*xx; - lx = xx; - xx = tx; - - T ty = ly - qq*yy; - ly = yy; - yy = ty; - } - - x = octave_int<T> (lx) * a.signum (); - y = octave_int<T> (ly) * b.signum (); - - return aa; -} - -template<class NDA> -static octave_value -do_simple_gcd (const octave_value& a, const octave_value& b) -{ - typedef typename NDA::element_type T; - octave_value retval; - - if (a.is_scalar_type () && b.is_scalar_type ()) - { - // Optimize scalar case. - T aa = octave_value_extract<T> (a); - T bb = octave_value_extract<T> (b); - retval = simple_gcd (aa, bb); - } - else - { - NDA aa = octave_value_extract<NDA> (a); - NDA bb = octave_value_extract<NDA> (b); - retval = binmap<T> (aa, bb, simple_gcd, "gcd"); - } - - return retval; -} - -// Dispatcher -static octave_value -do_simple_gcd (const octave_value& a, const octave_value& b) -{ - octave_value retval; - builtin_type_t btyp = btyp_mixed_numeric (a.builtin_type (), - b.builtin_type ()); - switch (btyp) - { - case btyp_double: - if (a.is_sparse_type () && b.is_sparse_type ()) - { - retval = do_simple_gcd<SparseMatrix> (a, b); - break; - } - // fall through! - - case btyp_float: - retval = do_simple_gcd<NDArray> (a, b); - break; - -#define MAKE_INT_BRANCH(X) \ - case btyp_ ## X: \ - retval = do_simple_gcd<X ## NDArray> (a, b); \ - break - - MAKE_INT_BRANCH (int8); - MAKE_INT_BRANCH (int16); - MAKE_INT_BRANCH (int32); - MAKE_INT_BRANCH (int64); - MAKE_INT_BRANCH (uint8); - MAKE_INT_BRANCH (uint16); - MAKE_INT_BRANCH (uint32); - MAKE_INT_BRANCH (uint64); - -#undef MAKE_INT_BRANCH - - case btyp_complex: - retval = do_simple_gcd<ComplexNDArray> (a, b); - break; - - case btyp_float_complex: - retval = do_simple_gcd<FloatComplexNDArray> (a, b); - break; - - default: - error ("gcd: invalid class combination for gcd: %s and %s\n", - a.class_name ().c_str (), b.class_name ().c_str ()); - } - - if (btyp == btyp_float) - retval = retval.float_array_value (); - - return retval; -} - -template<class NDA> -static octave_value -do_extended_gcd (const octave_value& a, const octave_value& b, - octave_value& x, octave_value& y) -{ - typedef typename NDA::element_type T; - octave_value retval; - - if (a.is_scalar_type () && b.is_scalar_type ()) - { - // Optimize scalar case. - T aa = octave_value_extract<T> (a); - T bb = octave_value_extract<T> (b); - T xx, yy; - retval = extended_gcd (aa, bb, xx, yy); - x = xx; - y = yy; - } - else - { - NDA aa = octave_value_extract<NDA> (a); - NDA bb = octave_value_extract<NDA> (b); - - dim_vector dv = aa.dims (); - if (aa.numel () == 1) - dv = bb.dims (); - else if (bb.numel () != 1 && bb.dims () != dv) - gripe_nonconformant ("gcd", a.dims (), b.dims ()); - - NDA gg (dv), xx (dv), yy (dv); - - const T *aptr = aa.fortran_vec (); - const T *bptr = bb.fortran_vec (); - - bool inca = aa.numel () != 1; - bool incb = bb.numel () != 1; - - T *gptr = gg.fortran_vec (); - T *xptr = xx.fortran_vec (), *yptr = yy.fortran_vec (); - - octave_idx_type n = gg.numel (); - for (octave_idx_type i = 0; i < n; i++) - { - octave_quit (); - - *gptr++ = extended_gcd (*aptr, *bptr, *xptr++, *yptr++); - - aptr += inca; - bptr += incb; - } - - x = xx; - y = yy; - - retval = gg; - } - - return retval; -} - -// Dispatcher -static octave_value -do_extended_gcd (const octave_value& a, const octave_value& b, - octave_value& x, octave_value& y) -{ - octave_value retval; - - builtin_type_t btyp = btyp_mixed_numeric (a.builtin_type (), - b.builtin_type ()); - switch (btyp) - { - case btyp_double: - case btyp_float: - retval = do_extended_gcd<NDArray> (a, b, x, y); - break; - -#define MAKE_INT_BRANCH(X) \ - case btyp_ ## X: \ - retval = do_extended_gcd<X ## NDArray> (a, b, x, y); \ - break - - MAKE_INT_BRANCH (int8); - MAKE_INT_BRANCH (int16); - MAKE_INT_BRANCH (int32); - MAKE_INT_BRANCH (int64); - MAKE_INT_BRANCH (uint8); - MAKE_INT_BRANCH (uint16); - MAKE_INT_BRANCH (uint32); - MAKE_INT_BRANCH (uint64); - -#undef MAKE_INT_BRANCH - - case btyp_complex: - retval = do_extended_gcd<ComplexNDArray> (a, b, x, y); - break; - - case btyp_float_complex: - retval = do_extended_gcd<FloatComplexNDArray> (a, b, x, y); - break; - - default: - error ("gcd: invalid class combination for gcd: %s and %s\n", - a.class_name ().c_str (), b.class_name ().c_str ()); - } - - // For consistency. - if (! error_state && a.is_sparse_type () && b.is_sparse_type ()) - { - retval = retval.sparse_matrix_value (); - x = x.sparse_matrix_value (); - y = y.sparse_matrix_value (); - } - - if (btyp == btyp_float) - { - retval = retval.float_array_value (); - x = x.float_array_value (); - y = y.float_array_value (); - } - - return retval; -} - -DEFUN_DLD (gcd, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{g} =} gcd (@var{a1}, @var{a2}, @dots{})\n\ -@deftypefnx {Loadable Function} {[@var{g}, @var{v1}, @dots{}] =} gcd (@var{a1}, @var{a2}, @dots{})\n\ -\n\ -Compute the greatest common divisor of @var{a1}, @var{a2}, @dots{}. If more\n\ -than one argument is given all arguments must be the same size or scalar.\n\ -In this case the greatest common divisor is calculated for each element\n\ -individually. All elements must be ordinary or Gaussian (complex)\n\ -integers. Note that for Gaussian integers, the gcd is not unique up to\n\ -units (multiplication by 1, -1, @var{i} or -@var{i}), so an arbitrary\n\ -greatest common divisor amongst four possible is returned.\n\ -\n\ -Example code:\n\ -\n\ -@example\n\ -@group\n\ -gcd ([15, 9], [20, 18])\n\ - @result{} 5 9\n\ -@end group\n\ -@end example\n\ -\n\ -Optional return arguments @var{v1}, etc., contain integer vectors such\n\ -that,\n\ -\n\ -@tex\n\ -$g = v_1 a_1 + v_2 a_2 + \\cdots$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@var{g} = @var{v1} .* @var{a1} + @var{v2} .* @var{a2} + @dots{}\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -\n\ -@seealso{lcm, factor}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin > 1) - { - if (nargout > 1) - { - retval.resize (nargin + 1); - - retval(0) = do_extended_gcd (args(0), args(1), retval(1), retval(2)); - - for (int j = 2; j < nargin; j++) - { - octave_value x; - retval(0) = do_extended_gcd (retval(0), args(j), - x, retval(j+1)); - for (int i = 0; i < j; i++) - retval(i+1).assign (octave_value::op_el_mul_eq, x); - - if (error_state) - break; - } - } - else - { - retval(0) = do_simple_gcd (args(0), args(1)); - - for (int j = 2; j < nargin; j++) - { - retval(0) = do_simple_gcd (retval(0), args(j)); - - if (error_state) - break; - } - } - } - else - print_usage (); - - return retval; -} - -/* -%!assert (gcd (200, 300, 50, 35), 5) -%!assert (gcd (int16 (200), int16 (300), int16 (50), int16 (35)), int16 (5)) -%!assert (gcd (uint64 (200), uint64 (300), uint64 (50), uint64 (35)), uint64 (5)) -%!assert (gcd (18-i, -29+3i), -3-4i) - -%!error gcd () - -%!test -%! s.a = 1; -%! fail ("gcd (s)"); -*/
--- a/src/DLD-FUNCTIONS/getgrent.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,215 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include <sys/types.h> - -#include "oct-group.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-map.h" -#include "ov.h" -#include "oct-obj.h" -#include "utils.h" - -// Group file functions. (Why not?) - -static octave_value -mk_gr_map (const octave_group& gr) -{ - octave_value retval; - - if (gr) - { - octave_scalar_map m; - - m.assign ("name", gr.name ()); - m.assign ("passwd", gr.passwd ()); - m.assign ("gid", static_cast<double> (gr.gid ())); - m.assign ("mem", octave_value (gr.mem ())); - - retval = m; - } - else - retval = 0; - - return retval; -} - -DEFUN_DLD (getgrent, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{grp_struct} =} getgrent ()\n\ -Return an entry from the group database, opening it if necessary.\n\ -Once the end of data has been reached, @code{getgrent} returns 0.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = 0; - - int nargin = args.length (); - - if (nargin == 0) - { - std::string msg; - - retval(1) = msg; - retval(0) = mk_gr_map (octave_group::getgrent (msg)); - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (getgrgid, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{grp_struct} =} getgrgid (@var{gid}).\n\ -Return the first entry from the group database with the group ID\n\ -@var{gid}. If the group ID does not exist in the database,\n\ -@code{getgrgid} returns 0.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = 0; - - int nargin = args.length (); - - if (nargin == 1) - { - double dval = args(0).double_value (); - - if (! error_state) - { - if (D_NINT (dval) == dval) - { - gid_t gid = static_cast<gid_t> (dval); - - std::string msg; - - retval(1) = msg; - retval(0) = mk_gr_map (octave_group::getgrgid (gid, msg)); - } - else - error ("getgrgid: GID must be an integer"); - } - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (getgrnam, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{grp_struct} =} getgrnam (@var{name})\n\ -Return the first entry from the group database with the group name\n\ -@var{name}. If the group name does not exist in the database,\n\ -@code{getgrnam} returns 0.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = 0; - - int nargin = args.length (); - - if (nargin == 1) - { - std::string s = args(0).string_value (); - - if (! error_state) - { - std::string msg; - - retval(1) = msg; - retval(0) = mk_gr_map (octave_group::getgrnam (s.c_str (), msg)); - } - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (setgrent, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} setgrent ()\n\ -Return the internal pointer to the beginning of the group database.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = -1.0; - - int nargin = args.length (); - - if (nargin == 0) - { - std::string msg; - - retval(1) = msg; - retval(0) = static_cast<double> (octave_group::setgrent (msg)); - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (endgrent, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} endgrent ()\n\ -Close the group database.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = -1.0; - - int nargin = args.length (); - - if (nargin == 0) - { - std::string msg; - - retval(1) = msg; - retval(0) = static_cast<double> (octave_group::endgrent (msg)); - } - else - print_usage (); - - return retval; -}
--- a/src/DLD-FUNCTIONS/getpwent.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include <sys/types.h> - -#include "oct-passwd.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-map.h" -#include "ov.h" -#include "oct-obj.h" -#include "utils.h" - -// Password file functions. (Why not?) - -static octave_value -mk_pw_map (const octave_passwd& pw) -{ - octave_value retval; - - if (pw) - { - octave_scalar_map m; - - m.assign ("name", pw.name ()); - m.assign ("passwd", pw.passwd ()); - m.assign ("uid", static_cast<double> (pw.uid ())); - m.assign ("gid", static_cast<double> (pw.gid ())); - m.assign ("gecos", pw.gecos ()); - m.assign ("dir", pw.dir ()); - m.assign ("shell", pw.shell ()); - - retval = m; - } - else - retval = 0; - - return retval; -} - -DEFUN_DLD (getpwent, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{pw_struct} =} getpwent ()\n\ -Return a structure containing an entry from the password database,\n\ -opening it if necessary. Once the end of the data has been reached,\n\ -@code{getpwent} returns 0.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = 0; - - int nargin = args.length (); - - if (nargin == 0) - { - std::string msg; - - retval(1) = msg; - retval(0) = mk_pw_map (octave_passwd::getpwent (msg)); - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (getpwuid, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{pw_struct} =} getpwuid (@var{uid}).\n\ -Return a structure containing the first entry from the password database\n\ -with the user ID @var{uid}. If the user ID does not exist in the\n\ -database, @code{getpwuid} returns 0.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = 0; - - int nargin = args.length (); - - if (nargin == 1) - { - double dval = args(0).double_value (); - - if (! error_state) - { - if (D_NINT (dval) == dval) - { - uid_t uid = static_cast<uid_t> (dval); - - std::string msg; - - retval(1) = msg; - retval(0) = mk_pw_map (octave_passwd::getpwuid (uid, msg)); - } - else - error ("getpwuid: UID must be an integer"); - } - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (getpwnam, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{pw_struct} =} getpwnam (@var{name})\n\ -Return a structure containing the first entry from the password database\n\ -with the user name @var{name}. If the user name does not exist in the\n\ -database, @code{getpwname} returns 0.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = 0.0; - - int nargin = args.length (); - - if (nargin == 1) - { - std::string s = args(0).string_value (); - - if (! error_state) - { - std::string msg; - - retval(1) = msg; - retval(0) = mk_pw_map (octave_passwd::getpwnam (s, msg)); - } - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (setpwent, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} setpwent ()\n\ -Return the internal pointer to the beginning of the password database.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = -1.0; - - int nargin = args.length (); - - if (nargin == 0) - { - std::string msg; - - retval(1) = msg; - retval(0) = static_cast<double> (octave_passwd::setpwent (msg)); - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (endpwent, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} endpwent ()\n\ -Close the password database.\n\ -@end deftypefn") -{ - octave_value_list retval; - - retval(1) = std::string (); - retval(0) = -1.0; - - int nargin = args.length (); - - if (nargin == 0) - { - std::string msg; - - retval(1) = msg; - retval(0) = static_cast<double> (octave_passwd::endpwent (msg)); - } - else - print_usage (); - - return retval; -}
--- a/src/DLD-FUNCTIONS/getrusage.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,205 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <sys/time.h> -#include <sys/times.h> -#include <sys/types.h> - -#ifdef HAVE_SYS_RESOURCE_H -#include <sys/resource.h> -#endif - -#if defined (HAVE_SYS_PARAM_H) -#include <sys/param.h> -#endif - -#include "defun-dld.h" -#include "oct-map.h" -#include "sysdep.h" -#include "ov.h" -#include "oct-obj.h" -#include "utils.h" - -#if !defined (HZ) -#if defined (CLK_TCK) -#define HZ CLK_TCK -#elif defined (USG) -#define HZ 100 -#else -#define HZ 60 -#endif -#endif - -#ifndef RUSAGE_SELF -#define RUSAGE_SELF 0 -#endif - -// System resource functions. - -DEFUN_DLD (getrusage, , , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} getrusage ()\n\ -Return a structure containing a number of statistics about the current\n\ -Octave process. Not all fields are available on all systems. If it is\n\ -not possible to get CPU time statistics, the CPU time slots are set to\n\ -zero. Other missing data are replaced by NaN@. The list of possible\n\ -fields is:\n\ -\n\ -@table @code\n\ -@item idrss\n\ -Unshared data size.\n\ -\n\ -@item inblock\n\ -Number of block input operations.\n\ -\n\ -@item isrss\n\ -Unshared stack size.\n\ -\n\ -@item ixrss\n\ -Shared memory size.\n\ -\n\ -@item majflt\n\ -Number of major page faults.\n\ -\n\ -@item maxrss\n\ -Maximum data size.\n\ -\n\ -@item minflt\n\ -Number of minor page faults.\n\ -\n\ -@item msgrcv\n\ -Number of messages received.\n\ -\n\ -@item msgsnd\n\ -Number of messages sent.\n\ -\n\ -@item nivcsw\n\ -Number of involuntary context switches.\n\ -\n\ -@item nsignals\n\ -Number of signals received.\n\ -\n\ -@item nswap\n\ -Number of swaps.\n\ -\n\ -@item nvcsw\n\ -Number of voluntary context switches.\n\ -\n\ -@item oublock\n\ -Number of block output operations.\n\ -\n\ -@item stime\n\ -A structure containing the system CPU time used. The structure has the\n\ -elements @code{sec} (seconds) @code{usec} (microseconds).\n\ -\n\ -@item utime\n\ -A structure containing the user CPU time used. The structure has the\n\ -elements @code{sec} (seconds) @code{usec} (microseconds).\n\ -@end table\n\ -@end deftypefn") -{ - octave_scalar_map m; - octave_scalar_map tv_tmp; - - // FIXME -- maybe encapsulate all of this in a liboctave class -#if defined (HAVE_GETRUSAGE) - - struct rusage ru; - - getrusage (RUSAGE_SELF, &ru); - - tv_tmp.assign ("sec", static_cast<double> (ru.ru_utime.tv_sec)); - tv_tmp.assign ("usec", static_cast<double> (ru.ru_utime.tv_usec)); - m.assign ("utime", octave_value (tv_tmp)); - - tv_tmp.assign ("sec", static_cast<double> (ru.ru_stime.tv_sec)); - tv_tmp.assign ("usec", static_cast<double> (ru.ru_stime.tv_usec)); - m.assign ("stime", octave_value (tv_tmp)); - -#if ! defined (RUSAGE_TIMES_ONLY) - m.assign ("maxrss", static_cast<double> (ru.ru_maxrss)); - m.assign ("ixrss", static_cast<double> (ru.ru_ixrss)); - m.assign ("idrss", static_cast<double> (ru.ru_idrss)); - m.assign ("isrss", static_cast<double> (ru.ru_isrss)); - m.assign ("minflt", static_cast<double> (ru.ru_minflt)); - m.assign ("majflt", static_cast<double> (ru.ru_majflt)); - m.assign ("nswap", static_cast<double> (ru.ru_nswap)); - m.assign ("inblock", static_cast<double> (ru.ru_inblock)); - m.assign ("oublock", static_cast<double> (ru.ru_oublock)); - m.assign ("msgsnd", static_cast<double> (ru.ru_msgsnd)); - m.assign ("msgrcv", static_cast<double> (ru.ru_msgrcv)); - m.assign ("nsignals", static_cast<double> (ru.ru_nsignals)); - m.assign ("nvcsw", static_cast<double> (ru.ru_nvcsw)); - m.assign ("nivcsw", static_cast<double> (ru.ru_nivcsw)); -#endif - -#else - - struct tms t; - - times (&t); - - unsigned long ticks; - unsigned long seconds; - unsigned long fraction; - - ticks = t.tms_utime + t.tms_cutime; - fraction = ticks % HZ; - seconds = ticks / HZ; - - tv_tmp.assign ("sec", static_cast<double> (seconds)); - tv_tmp.assign ("usec", static_cast<double> (fraction * 1e6 / HZ)); - m.assign ("utime", octave_value (tv_tmp)); - - ticks = t.tms_stime + t.tms_cstime; - fraction = ticks % HZ; - seconds = ticks / HZ; - - tv_tmp.assign ("sec", static_cast<double> (seconds)); - tv_tmp.assign ("usec", static_cast<double> (fraction * 1e6 / HZ)); - m.assign ("stime", octave_value (tv_tmp)); - - double tmp = lo_ieee_nan_value (); - - m.assign ("maxrss", tmp); - m.assign ("ixrss", tmp); - m.assign ("idrss", tmp); - m.assign ("isrss", tmp); - m.assign ("minflt", tmp); - m.assign ("majflt", tmp); - m.assign ("nswap", tmp); - m.assign ("inblock", tmp); - m.assign ("oublock", tmp); - m.assign ("msgsnd", tmp); - m.assign ("msgrcv", tmp); - m.assign ("nsignals", tmp); - m.assign ("nvcsw", tmp); - m.assign ("nivcsw", tmp); - -#endif - - return octave_value (m); -}
--- a/src/DLD-FUNCTIONS/givens.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,214 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Originally written by A. S. Hodel <scotte@eng.auburn.edu> - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" - -DEFUN_DLD (givens, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{g} =} givens (@var{x}, @var{y})\n\ -@deftypefnx {Loadable Function} {[@var{c}, @var{s}] =} givens (@var{x}, @var{y})\n\ -@tex\n\ -Return a $2\\times 2$ orthogonal matrix\n\ -$$\n\ - G = \\left[\\matrix{c & s\\cr -s'& c\\cr}\\right]\n\ -$$\n\ -such that\n\ -$$\n\ - G \\left[\\matrix{x\\cr y}\\right] = \\left[\\matrix{\\ast\\cr 0}\\right]\n\ -$$\n\ -with $x$ and $y$ scalars.\n\ -@end tex\n\ -@ifnottex\n\ -Return a 2 by 2 orthogonal matrix\n\ -@code{@var{g} = [@var{c} @var{s}; -@var{s}' @var{c}]} such that\n\ -@code{@var{g} [@var{x}; @var{y}] = [*; 0]} with @var{x} and @var{y} scalars.\n\ -@end ifnottex\n\ -\n\ -For example:\n\ -\n\ -@example\n\ -@group\n\ -givens (1, 1)\n\ - @result{} 0.70711 0.70711\n\ - -0.70711 0.70711\n\ -@end group\n\ -@end example\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin != 2 || nargout > 2) - { - print_usage (); - return retval; - } - else - { - if (args(0).is_single_type () || args(1).is_single_type ()) - { - if (args(0).is_complex_type () || args(1).is_complex_type ()) - { - FloatComplex cx = args(0).float_complex_value (); - FloatComplex cy = args(1).float_complex_value (); - - if (! error_state) - { - FloatComplexMatrix result = Givens (cx, cy); - - if (! error_state) - { - switch (nargout) - { - case 0: - case 1: - retval(0) = result; - break; - - case 2: - retval(1) = result (0, 1); - retval(0) = result (0, 0); - break; - - default: - error ("givens: invalid number of output arguments"); - break; - } - } - } - } - else - { - float x = args(0).float_value (); - float y = args(1).float_value (); - - if (! error_state) - { - FloatMatrix result = Givens (x, y); - - if (! error_state) - { - switch (nargout) - { - case 0: - case 1: - retval(0) = result; - break; - - case 2: - retval(1) = result (0, 1); - retval(0) = result (0, 0); - break; - - default: - error ("givens: invalid number of output arguments"); - break; - } - } - } - } - } - else - { - if (args(0).is_complex_type () || args(1).is_complex_type ()) - { - Complex cx = args(0).complex_value (); - Complex cy = args(1).complex_value (); - - if (! error_state) - { - ComplexMatrix result = Givens (cx, cy); - - if (! error_state) - { - switch (nargout) - { - case 0: - case 1: - retval(0) = result; - break; - - case 2: - retval(1) = result (0, 1); - retval(0) = result (0, 0); - break; - - default: - error ("givens: invalid number of output arguments"); - break; - } - } - } - } - else - { - double x = args(0).double_value (); - double y = args(1).double_value (); - - if (! error_state) - { - Matrix result = Givens (x, y); - - if (! error_state) - { - switch (nargout) - { - case 0: - case 1: - retval(0) = result; - break; - - case 2: - retval(1) = result (0, 1); - retval(0) = result (0, 0); - break; - - default: - error ("givens: invalid number of output arguments"); - break; - } - } - } - } - } - } - - return retval; -} - -/* -%!assert (givens (1,1), [1, 1; -1, 1] / sqrt (2), 2*eps) -%!assert (givens (1,0), eye (2)) -%!assert (givens (0,1), [0, 1; -1 0]) - -%!error givens () -%!error givens (1) -*/
--- a/src/DLD-FUNCTIONS/hess.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "CmplxHESS.h" -#include "dbleHESS.h" -#include "fCmplxHESS.h" -#include "floatHESS.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (hess, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{H} =} hess (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{P}, @var{H}] =} hess (@var{A})\n\ -@cindex Hessenberg decomposition\n\ -Compute the Hessenberg decomposition of the matrix @var{A}.\n\ -\n\ -The Hessenberg decomposition is\n\ -@tex\n\ -$$\n\ -A = PHP^T\n\ -$$\n\ -where $P$ is a square unitary matrix ($P^TP = I$), and $H$\n\ -is upper Hessenberg ($H_{i,j} = 0, \\forall i \\ge j+1$).\n\ -@end tex\n\ -@ifnottex\n\ -@code{@var{P} * @var{H} * @var{P}' = @var{A}} where @var{P} is a square\n\ -unitary matrix (@code{@var{P}' * @var{P} = I}, using complex-conjugate\n\ -transposition) and @var{H} is upper Hessenberg\n\ -(@code{@var{H}(i, j) = 0 forall i >= j+1)}.\n\ -@end ifnottex\n\ -\n\ -The Hessenberg decomposition is usually used as the first step in an\n\ -eigenvalue computation, but has other applications as well (see Golub,\n\ -Nash, and Van Loan, IEEE Transactions on Automatic Control, 1979).\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin != 1 || nargout > 2) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - - octave_idx_type nr = arg.rows (); - octave_idx_type nc = arg.columns (); - - int arg_is_empty = empty_arg ("hess", nr, nc); - - if (arg_is_empty < 0) - return retval; - else if (arg_is_empty > 0) - return octave_value_list (2, Matrix ()); - - if (nr != nc) - { - gripe_square_matrix_required ("hess"); - return retval; - } - - if (arg.is_single_type ()) - { - if (arg.is_real_type ()) - { - FloatMatrix tmp = arg.float_matrix_value (); - - if (! error_state) - { - FloatHESS result (tmp); - - if (nargout <= 1) - retval(0) = result.hess_matrix (); - else - { - retval(1) = result.hess_matrix (); - retval(0) = result.unitary_hess_matrix (); - } - } - } - else if (arg.is_complex_type ()) - { - FloatComplexMatrix ctmp = arg.float_complex_matrix_value (); - - if (! error_state) - { - FloatComplexHESS result (ctmp); - - if (nargout <= 1) - retval(0) = result.hess_matrix (); - else - { - retval(1) = result.hess_matrix (); - retval(0) = result.unitary_hess_matrix (); - } - } - } - } - else - { - if (arg.is_real_type ()) - { - Matrix tmp = arg.matrix_value (); - - if (! error_state) - { - HESS result (tmp); - - if (nargout <= 1) - retval(0) = result.hess_matrix (); - else - { - retval(1) = result.hess_matrix (); - retval(0) = result.unitary_hess_matrix (); - } - } - } - else if (arg.is_complex_type ()) - { - ComplexMatrix ctmp = arg.complex_matrix_value (); - - if (! error_state) - { - ComplexHESS result (ctmp); - - if (nargout <= 1) - retval(0) = result.hess_matrix (); - else - { - retval(1) = result.hess_matrix (); - retval(0) = result.unitary_hess_matrix (); - } - } - } - else - { - gripe_wrong_type_arg ("hess", arg); - } - } - - return retval; -} - -/* -%!test -%! a = [1, 2, 3; 5, 4, 6; 8, 7, 9]; -%! [p, h] = hess (a); -%! assert (p * h * p', a, sqrt (eps)); - -%!test -%! a = single ([1, 2, 3; 5, 4, 6; 8, 7, 9]); -%! [p, h] = hess (a); -%! assert (p * h * p', a, sqrt (eps ("single"))); - -%!error hess () -%!error hess ([1, 2; 3, 4], 2) -%!error <argument must be a square matrix> hess ([1, 2; 3, 4; 5, 6]) -*/
--- a/src/DLD-FUNCTIONS/hex2num.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -/* - -Copyright (C) 2008-2012 David Bateman - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <algorithm> - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (hex2num, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{n} =} hex2num (@var{s})\n\ -Typecast the 16 character hexadecimal character string to an IEEE 754\n\ -double precision number. If fewer than 16 characters are given the\n\ -strings are right padded with '0' characters.\n\ -\n\ -Given a string matrix, @code{hex2num} treats each row as a separate\n\ -number.\n\ -\n\ -@example\n\ -@group\n\ -hex2num ([\"4005bf0a8b145769\"; \"4024000000000000\"])\n\ - @result{} [2.7183; 10.000]\n\ -@end group\n\ -@end example\n\ -@seealso{num2hex, hex2dec, dec2hex}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value retval; - - if (nargin != 1) - print_usage (); - else - { - const charMatrix cmat = args(0).char_matrix_value (); - - if (cmat.columns () > 16) - error ("hex2num: S must be no more than 16 characters"); - else if (! error_state) - { - octave_idx_type nr = cmat.rows (); - octave_idx_type nc = cmat.columns (); - ColumnVector m (nr); - - for (octave_idx_type i = 0; i < nr; i++) - { - union - { - uint64_t ival; - double dval; - } num; - - num.ival = 0; - - for (octave_idx_type j = 0; j < nc; j++) - { - unsigned char ch = cmat.elem (i, j); - - if (isxdigit (ch)) - { - num.ival <<= 4; - if (ch >= 'a') - num.ival += static_cast<uint64_t> (ch - 'a' + 10); - else if (ch >= 'A') - num.ival += static_cast<uint64_t> (ch - 'A' + 10); - else - num.ival += static_cast<uint64_t> (ch - '0'); - } - else - { - error ("hex2num: illegal character found in string S"); - break; - } - } - - if (error_state) - break; - else - { - if (nc < 16) - num.ival <<= (16 - nc) * 4; - - m(i) = num.dval; - } - } - - if (! error_state) - retval = m; - } - } - - return retval; -} - -/* -%!assert (hex2num (["c00";"bff";"000";"3ff";"400"]), [-2:2]') -*/ - -DEFUN_DLD (num2hex, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{s} =} num2hex (@var{n})\n\ -Typecast a double precision number or vector to a 16 character hexadecimal\n\ -string of the IEEE 754 representation of the number. For example:\n\ -\n\ -@example\n\ -@group\n\ -num2hex ([-1, 1, e, Inf, NaN, NA])\n\ -@result{} \"bff0000000000000\n\ - 3ff0000000000000\n\ - 4005bf0a8b145769\n\ - 7ff0000000000000\n\ - fff8000000000000\n\ - 7ff00000000007a2\"\n\ -@end group\n\ -@end example\n\ -@seealso{hex2num, hex2dec, dec2hex}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value retval; - - if (nargin != 1) - print_usage (); - else - { - const ColumnVector v (args(0).vector_value ()); - - if (! error_state) - { - octave_idx_type nr = v.length (); - charMatrix m (nr, 16); - const double *pv = v.fortran_vec (); - - for (octave_idx_type i = 0; i < nr; i++) - { - union - { - uint64_t ival; - double dval; - } num; - - num.dval = *pv++; - - for (octave_idx_type j = 0; j < 16; j++) - { - unsigned char ch = - static_cast<char> (num.ival >> ((15 - j) * 4) & 0xF); - if (ch >= 10) - ch += 'a' - 10; - else - ch += '0'; - - m.elem (i, j) = ch; - } - } - - retval = m; - } - } - - return retval; -} - -/* -%!assert (num2hex (-2:2), ["c000000000000000";"bff0000000000000";"0000000000000000";"3ff0000000000000";"4000000000000000"]) -*/
--- a/src/DLD-FUNCTIONS/inv.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,250 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "ops.h" -#include "ov-re-diag.h" -#include "ov-cx-diag.h" -#include "ov-flt-re-diag.h" -#include "ov-flt-cx-diag.h" -#include "ov-perm.h" -#include "utils.h" - -DEFUN_DLD (inv, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{x} =} inv (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{x}, @var{rcond}] =} inv (@var{A})\n\ -Compute the inverse of the square matrix @var{A}. Return an estimate\n\ -of the reciprocal condition number if requested, otherwise warn of an\n\ -ill-conditioned matrix if the reciprocal condition number is small.\n\ -\n\ -In general it is best to avoid calculating the inverse of a matrix\n\ -directly. For example, it is both faster and more accurate to solve\n\ -systems of equations (@var{A}*@math{x} = @math{b}) with\n\ -@code{@var{y} = @var{A} \\ @math{b}}, rather than\n\ -@code{@var{y} = inv (@var{A}) * @math{b}}.\n\ -\n\ -If called with a sparse matrix, then in general @var{x} will be a full\n\ -matrix requiring significantly more storage. Avoid forming the inverse\n\ -of a sparse matrix if possible.\n\ -@seealso{ldivide, rdivide}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin != 1) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - - octave_idx_type nr = arg.rows (); - octave_idx_type nc = arg.columns (); - - int arg_is_empty = empty_arg ("inverse", nr, nc); - - if (arg_is_empty < 0) - return retval; - else if (arg_is_empty > 0) - return octave_value (Matrix ()); - - if (nr != nc) - { - gripe_square_matrix_required ("inverse"); - return retval; - } - - octave_value result; - octave_idx_type info; - double rcond = 0.0; - float frcond = 0.0; - bool isfloat = arg.is_single_type (); - - if (arg.is_diag_matrix ()) - { - rcond = 1.0; - frcond = 1.0f; - if (arg.is_complex_type ()) - { - if (isfloat) - { - result = arg.float_complex_diag_matrix_value ().inverse (info); - if (nargout > 1) - frcond = arg.float_complex_diag_matrix_value ().rcond (); - } - else - { - result = arg.complex_diag_matrix_value ().inverse (info); - if (nargout > 1) - rcond = arg.complex_diag_matrix_value ().rcond (); - } - } - else - { - if (isfloat) - { - result = arg.float_diag_matrix_value ().inverse (info); - if (nargout > 1) - frcond = arg.float_diag_matrix_value ().rcond (); - } - else - { - result = arg.diag_matrix_value ().inverse (info); - if (nargout > 1) - rcond = arg.diag_matrix_value ().rcond (); - } - } - } - else if (arg.is_perm_matrix ()) - { - rcond = 1.0; - info = 0; - result = arg.perm_matrix_value ().inverse (); - } - else if (isfloat) - { - if (arg.is_real_type ()) - { - FloatMatrix m = arg.float_matrix_value (); - if (! error_state) - { - MatrixType mattyp = args(0).matrix_type (); - result = m.inverse (mattyp, info, frcond, 1); - args(0).matrix_type (mattyp); - } - } - else if (arg.is_complex_type ()) - { - FloatComplexMatrix m = arg.float_complex_matrix_value (); - if (! error_state) - { - MatrixType mattyp = args(0).matrix_type (); - result = m.inverse (mattyp, info, frcond, 1); - args(0).matrix_type (mattyp); - } - } - } - else - { - if (arg.is_real_type ()) - { - if (arg.is_sparse_type ()) - { - SparseMatrix m = arg.sparse_matrix_value (); - if (! error_state) - { - MatrixType mattyp = args(0).matrix_type (); - result = m.inverse (mattyp, info, rcond, 1); - args(0).matrix_type (mattyp); - } - } - else - { - Matrix m = arg.matrix_value (); - if (! error_state) - { - MatrixType mattyp = args(0).matrix_type (); - result = m.inverse (mattyp, info, rcond, 1); - args(0).matrix_type (mattyp); - } - } - } - else if (arg.is_complex_type ()) - { - if (arg.is_sparse_type ()) - { - SparseComplexMatrix m = arg.sparse_complex_matrix_value (); - if (! error_state) - { - MatrixType mattyp = args(0).matrix_type (); - result = m.inverse (mattyp, info, rcond, 1); - args(0).matrix_type (mattyp); - } - } - else - { - ComplexMatrix m = arg.complex_matrix_value (); - if (! error_state) - { - MatrixType mattyp = args(0).matrix_type (); - result = m.inverse (mattyp, info, rcond, 1); - args(0).matrix_type (mattyp); - } - } - } - else - gripe_wrong_type_arg ("inv", arg); - } - - if (! error_state) - { - if (nargout > 1) - retval(1) = isfloat ? octave_value (frcond) : octave_value (rcond); - - retval(0) = result; - - volatile double xrcond = rcond; - xrcond += 1.0; - if (nargout < 2 && (info == -1 || xrcond == 1.0)) - warning ("inverse: matrix singular to machine precision, rcond = %g", - rcond); - } - - return retval; -} - -/* -%!assert (inv ([1, 2; 3, 4]), [-2, 1; 1.5, -0.5], sqrt (eps)) -%!assert (inv (single ([1, 2; 3, 4])), single ([-2, 1; 1.5, -0.5]), sqrt (eps ("single"))) - -%!error inv () -%!error inv ([1, 2; 3, 4], 2) -%!error <argument must be a square matrix> inv ([1, 2; 3, 4; 5, 6]) -*/ - -// FIXME -- this should really be done with an alias, but -// alias_builtin() won't do the right thing if we are actually using -// dynamic linking. - -DEFUN_DLD (inverse, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{x} =} inverse (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{x}, @var{rcond}] =} inverse (@var{A})\n\ -Compute the inverse of the square matrix @var{A}.\n\ -\n\ -This is an alias for @code{inv}.\n\ -@seealso{inv}\n\ -@end deftypefn") -{ - return Finv (args, nargout); -}
--- a/src/DLD-FUNCTIONS/kron.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,321 +0,0 @@ -/* - -Copyright (C) 2002-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Author: Paul Kienzle <pkienzle@users.sf.net> - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "dMatrix.h" -#include "fMatrix.h" -#include "CMatrix.h" -#include "fCMatrix.h" - -#include "dSparse.h" -#include "CSparse.h" - -#include "dDiagMatrix.h" -#include "fDiagMatrix.h" -#include "CDiagMatrix.h" -#include "fCDiagMatrix.h" - -#include "PermMatrix.h" - -#include "mx-inlines.cc" -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" - -template <class R, class T> -static MArray<T> -kron (const MArray<R>& a, const MArray<T>& b) -{ - assert (a.ndims () == 2); - assert (b.ndims () == 2); - - octave_idx_type nra = a.rows (), nrb = b.rows (); - octave_idx_type nca = a.cols (), ncb = b.cols (); - - MArray<T> c (dim_vector (nra*nrb, nca*ncb)); - T *cv = c.fortran_vec (); - - for (octave_idx_type ja = 0; ja < nca; ja++) - for (octave_idx_type jb = 0; jb < ncb; jb++) - for (octave_idx_type ia = 0; ia < nra; ia++) - { - octave_quit (); - mx_inline_mul (nrb, cv, a(ia, ja), b.data () + nrb*jb); - cv += nrb; - } - - return c; -} - -template <class R, class T> -static MArray<T> -kron (const MDiagArray2<R>& a, const MArray<T>& b) -{ - assert (b.ndims () == 2); - - octave_idx_type nra = a.rows (), nrb = b.rows (), dla = a.diag_length (); - octave_idx_type nca = a.cols (), ncb = b.cols (); - - MArray<T> c (dim_vector (nra*nrb, nca*ncb), T ()); - - for (octave_idx_type ja = 0; ja < dla; ja++) - for (octave_idx_type jb = 0; jb < ncb; jb++) - { - octave_quit (); - mx_inline_mul (nrb, &c.xelem (ja*nrb, ja*ncb + jb), a.dgelem (ja), b.data () + nrb*jb); - } - - return c; -} - -template <class T> -static MSparse<T> -kron (const MSparse<T>& A, const MSparse<T>& B) -{ - octave_idx_type idx = 0; - MSparse<T> C (A.rows () * B.rows (), A.columns () * B.columns (), - A.nnz () * B.nnz ()); - - C.cidx (0) = 0; - - for (octave_idx_type Aj = 0; Aj < A.columns (); Aj++) - for (octave_idx_type Bj = 0; Bj < B.columns (); Bj++) - { - octave_quit (); - for (octave_idx_type Ai = A.cidx (Aj); Ai < A.cidx (Aj+1); Ai++) - { - octave_idx_type Ci = A.ridx (Ai) * B.rows (); - const T v = A.data (Ai); - - for (octave_idx_type Bi = B.cidx (Bj); Bi < B.cidx (Bj+1); Bi++) - { - C.data (idx) = v * B.data (Bi); - C.ridx (idx++) = Ci + B.ridx (Bi); - } - } - C.cidx (Aj * B.columns () + Bj + 1) = idx; - } - - return C; -} - -static PermMatrix -kron (const PermMatrix& a, const PermMatrix& b) -{ - octave_idx_type na = a.rows (), nb = b.rows (); - const octave_idx_type *pa = a.data (), *pb = b.data (); - PermMatrix c(na*nb); // Row permutation. - octave_idx_type *pc = c.fortran_vec (); - - bool cola = a.is_col_perm (), colb = b.is_col_perm (); - if (cola && colb) - { - for (octave_idx_type i = 0; i < na; i++) - for (octave_idx_type j = 0; j < nb; j++) - pc[pa[i]*nb+pb[j]] = i*nb+j; - } - else if (cola) - { - for (octave_idx_type i = 0; i < na; i++) - for (octave_idx_type j = 0; j < nb; j++) - pc[pa[i]*nb+j] = i*nb+pb[j]; - } - else if (colb) - { - for (octave_idx_type i = 0; i < na; i++) - for (octave_idx_type j = 0; j < nb; j++) - pc[i*nb+pb[j]] = pa[i]*nb+j; - } - else - { - for (octave_idx_type i = 0; i < na; i++) - for (octave_idx_type j = 0; j < nb; j++) - pc[i*nb+j] = pa[i]*nb+pb[j]; - } - - return c; -} - -template <class MTA, class MTB> -octave_value -do_kron (const octave_value& a, const octave_value& b) -{ - MTA am = octave_value_extract<MTA> (a); - MTB bm = octave_value_extract<MTB> (b); - return octave_value (kron (am, bm)); -} - -octave_value -dispatch_kron (const octave_value& a, const octave_value& b) -{ - octave_value retval; - if (a.is_perm_matrix () && b.is_perm_matrix ()) - retval = do_kron<PermMatrix, PermMatrix> (a, b); - else if (a.is_diag_matrix ()) - { - if (b.is_diag_matrix () && a.rows () == a.columns () - && b.rows () == b.columns ()) - { - // We have two diagonal matrices, the product of those will be - // another diagonal matrix. To do that efficiently, extract - // the diagonals as vectors and compute the product. That - // will be another vector, which we then use to construct a - // diagonal matrix object. Note that this will fail if our - // digaonal matrix object is modified to allow the non-zero - // values to be stored off of the principal diagonal (i.e., if - // diag ([1,2], 3) is modified to return a diagonal matrix - // object instead of a full matrix object). - - octave_value tmp = dispatch_kron (a.diag (), b.diag ()); - retval = tmp.diag (); - } - else if (a.is_single_type () || b.is_single_type ()) - { - if (a.is_complex_type ()) - retval = do_kron<FloatComplexDiagMatrix, FloatComplexMatrix> (a, b); - else if (b.is_complex_type ()) - retval = do_kron<FloatDiagMatrix, FloatComplexMatrix> (a, b); - else - retval = do_kron<FloatDiagMatrix, FloatMatrix> (a, b); - } - else - { - if (a.is_complex_type ()) - retval = do_kron<ComplexDiagMatrix, ComplexMatrix> (a, b); - else if (b.is_complex_type ()) - retval = do_kron<DiagMatrix, ComplexMatrix> (a, b); - else - retval = do_kron<DiagMatrix, Matrix> (a, b); - } - } - else if (a.is_sparse_type () || b.is_sparse_type ()) - { - if (a.is_complex_type () || b.is_complex_type ()) - retval = do_kron<SparseComplexMatrix, SparseComplexMatrix> (a, b); - else - retval = do_kron<SparseMatrix, SparseMatrix> (a, b); - } - else if (a.is_single_type () || b.is_single_type ()) - { - if (a.is_complex_type ()) - retval = do_kron<FloatComplexMatrix, FloatComplexMatrix> (a, b); - else if (b.is_complex_type ()) - retval = do_kron<FloatMatrix, FloatComplexMatrix> (a, b); - else - retval = do_kron<FloatMatrix, FloatMatrix> (a, b); - } - else - { - if (a.is_complex_type ()) - retval = do_kron<ComplexMatrix, ComplexMatrix> (a, b); - else if (b.is_complex_type ()) - retval = do_kron<Matrix, ComplexMatrix> (a, b); - else - retval = do_kron<Matrix, Matrix> (a, b); - } - return retval; -} - - -DEFUN_DLD (kron, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} kron (@var{A}, @var{B})\n\ -@deftypefnx {Loadable Function} {} kron (@var{A1}, @var{A2}, @dots{})\n\ -Form the Kronecker product of two or more matrices, defined block by \n\ -block as\n\ -\n\ -@example\n\ -x = [ a(i,j)*b ]\n\ -@end example\n\ -\n\ -For example:\n\ -\n\ -@example\n\ -@group\n\ -kron (1:4, ones (3, 1))\n\ - @result{} 1 2 3 4\n\ - 1 2 3 4\n\ - 1 2 3 4\n\ -@end group\n\ -@end example\n\ -\n\ -If there are more than two input arguments @var{A1}, @var{A2}, @dots{}, \n\ -@var{An} the Kronecker product is computed as\n\ -\n\ -@example\n\ -kron (kron (@var{A1}, @var{A2}), @dots{}, @var{An})\n\ -@end example\n\ -\n\ -@noindent\n\ -Since the Kronecker product is associative, this is well-defined.\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin >= 2) - { - octave_value a = args(0), b = args(1); - retval = dispatch_kron (a, b); - for (octave_idx_type i = 2; i < nargin; i++) - retval = dispatch_kron (retval, args(i)); - } - else - print_usage (); - - return retval; -} - - -/* -%!test -%! x = ones (2); -%! assert (kron (x, x), ones (4)); - -%!shared x, y, z -%! x = [1, 2]; -%! y = [-1, -2]; -%! z = [1, 2, 3, 4; 1, 2, 3, 4; 1, 2, 3, 4]; -%!assert (kron (1:4, ones (3, 1)), z) -%!assert (kron (x, y, z), kron (kron (x, y), z)) -%!assert (kron (x, y, z), kron (x, kron (y, z))) - -%!assert (kron (diag ([1, 2]), diag ([3, 4])), diag ([3, 4, 6, 8])) - -%% Test for two diag matrices. See the comments above in -%% dispatch_kron for this case. -%% -%!test -%! expected = zeros (16, 16); -%! expected (1, 11) = 3; -%! expected (2, 12) = 4; -%! expected (5, 15) = 6; -%! expected (6, 16) = 8; -%! assert (kron (diag ([1, 2], 2), diag ([3, 4], 2)), expected) -*/
--- a/src/DLD-FUNCTIONS/lookup.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,397 +0,0 @@ -/* - -Copyright (C) 2008-2012 VZLU Prague a.s., Czech Republic - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 3 of the License, or (at -your option) any later version. - -Octave is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Author: Jaroslav Hajek <highegg@gmail.com> - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <cctype> -#include <functional> -#include <algorithm> - -#include "dNDArray.h" -#include "CNDArray.h" - -#include "Cell.h" -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "ov.h" - -static -bool -contains_char (const std::string& str, char c) -{ - return (str.find (c) != std::string::npos - || str.find (std::toupper (c)) != std::string::npos); -} - -// case-insensitive character comparison functors -struct icmp_char_lt : public std::binary_function<char, char, bool> -{ - bool operator () (char x, char y) const - { return std::toupper (x) < std::toupper (y); } -}; - -struct icmp_char_gt : public std::binary_function<char, char, bool> -{ - bool operator () (char x, char y) const - { return std::toupper (x) > std::toupper (y); } -}; - -// FIXME -- maybe these should go elsewhere? -// FIXME -- are they even needed now? -// case-insensitive ascending comparator -#if 0 -static bool -stri_comp_lt (const std::string& a, const std::string& b) -{ - return std::lexicographical_compare (a.begin (), a.end (), - b.begin (), b.end (), - icmp_char_lt ()); -} - -// case-insensitive descending comparator -static bool -stri_comp_gt (const std::string& a, const std::string& b) -{ - return std::lexicographical_compare (a.begin (), a.end (), - b.begin (), b.end (), - icmp_char_gt ()); -} -#endif - -template <class T> -inline sortmode -get_sort_mode (const Array<T>& array, - typename octave_sort<T>::compare_fcn_type desc_comp - = octave_sort<T>::descending_compare) -{ - octave_idx_type n = array.numel (); - if (n > 1 && desc_comp (array (0), array (n-1))) - return DESCENDING; - else - return ASCENDING; -} - -// FIXME: perhaps there should be octave_value::lookup? -// The question is, how should it behave w.r.t. the second argument's type. -// We'd need a dispatch on two arguments. Hmmm... - -#define INT_ARRAY_LOOKUP(TYPE) \ - (table.is_ ## TYPE ## _type () && y.is_ ## TYPE ## _type ()) \ - retval = do_numeric_lookup (table.TYPE ## _array_value (), \ - y.TYPE ## _array_value (), \ - left_inf, right_inf, \ - match_idx, match_bool); -template <class ArrayT> -static octave_value -do_numeric_lookup (const ArrayT& array, const ArrayT& values, - bool left_inf, bool right_inf, - bool match_idx, bool match_bool) -{ - octave_value retval; - - Array<octave_idx_type> idx = array.lookup (values); - octave_idx_type n = array.numel (), nval = values.numel (); - - // Post-process. - if (match_bool) - { - boolNDArray match (idx.dims ()); - for (octave_idx_type i = 0; i < nval; i++) - { - octave_idx_type j = idx.xelem (i); - match.xelem (i) = j != 0 && values(i) == array(j-1); - } - - retval = match; - } - else if (match_idx || left_inf || right_inf) - { - if (match_idx) - { - NDArray ridx (idx.dims ()); - - for (octave_idx_type i = 0; i < nval; i++) - { - octave_idx_type j = idx.xelem (i); - ridx.xelem (i) = (j != 0 && values(i) == array(j-1)) ? j : 0; - } - - retval = ridx; - } - else if (left_inf && right_inf) - { - // Results in valid indices. Optimize using lazy index. - octave_idx_type zero = 0; - for (octave_idx_type i = 0; i < nval; i++) - { - octave_idx_type j = idx.xelem (i) - 1; - idx.xelem (i) = std::max (zero, std::min (j, n-2)); - } - - retval = idx_vector (idx); - } - else if (left_inf) - { - // Results in valid indices. Optimize using lazy index. - octave_idx_type zero = 0; - for (octave_idx_type i = 0; i < nval; i++) - { - octave_idx_type j = idx.xelem (i) - 1; - idx.xelem (i) = std::max (zero, j); - } - - retval = idx_vector (idx); - } - else if (right_inf) - { - NDArray ridx (idx.dims ()); - - for (octave_idx_type i = 0; i < nval; i++) - { - octave_idx_type j = idx.xelem (i); - ridx.xelem (i) = std::min (j, n-1); - } - - retval = ridx; - } - } - else - retval = idx; - - return retval; -} - -DEFUN_DLD (lookup, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{idx} =} lookup (@var{table}, @var{y})\n\ -@deftypefnx {Loadable Function} {@var{idx} =} lookup (@var{table}, @var{y}, @var{opt})\n\ -Lookup values in a sorted table. Usually used as a prelude to\n\ -interpolation.\n\ -\n\ -If table is increasing and @code{idx = lookup (table, y)}, then\n\ -@code{table(idx(i)) <= y(i) < table(idx(i+1))} for all @code{y(i)}\n\ -within the table. If @code{y(i) < table(1)} then\n\ -@code{idx(i)} is 0. If @code{y(i) >= table(end)} or @code{isnan (y(i))} then\n\ -@code{idx(i)} is @code{n}.\n\ -\n\ -If the table is decreasing, then the tests are reversed.\n\ -For non-strictly monotonic tables, empty intervals are always skipped.\n\ -The result is undefined if @var{table} is not monotonic, or if\n\ -@var{table} contains a NaN.\n\ -\n\ -The complexity of the lookup is O(M*log(N)) where N is the size of\n\ -@var{table} and M is the size of @var{y}. In the special case when @var{y}\n\ -is also sorted, the complexity is O(min(M*log(N),M+N)).\n\ -\n\ -@var{table} and @var{y} can also be cell arrays of strings\n\ -(or @var{y} can be a single string). In this case, string lookup\n\ -is performed using lexicographical comparison.\n\ -\n\ -If @var{opts} is specified, it must be a string with letters indicating\n\ -additional options.\n\ -\n\ -@table @code\n\ -@item m\n\ -@code{table(idx(i)) == val(i)} if @code{val(i)}\n\ -occurs in table; otherwise, @code{idx(i)} is zero.\n\ -\n\ -@item b\n\ -@code{idx(i)} is a logical 1 or 0, indicating whether\n\ -@code{val(i)} is contained in table or not.\n\ -\n\ -@item l\n\ -For numeric lookups\n\ -the leftmost subinterval shall be extended to infinity (i.e., all indices\n\ -at least 1)\n\ -\n\ -@item r\n\ -For numeric lookups\n\ -the rightmost subinterval shall be extended to infinity (i.e., all indices\n\ -at most n-1).\n\ -@end table\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 2 || nargin > 3 || (nargin == 3 && ! args(2).is_string ())) - { - print_usage (); - return retval; - } - - octave_value table = args(0), y = args(1); - if (table.ndims () > 2 || (table.columns () > 1 && table.rows () > 1)) - warning ("lookup: table is not a vector"); - - bool num_case = ((table.is_numeric_type () && y.is_numeric_type ()) - || (table.is_char_matrix () && y.is_char_matrix ())); - bool str_case = table.is_cellstr () && (y.is_string () || y.is_cellstr ()); - bool left_inf = false; - bool right_inf = false; - bool match_idx = false; - bool match_bool = false; - - if (nargin == 3) - { - std::string opt = args(2).string_value (); - left_inf = contains_char (opt, 'l'); - right_inf = contains_char (opt, 'r'); - match_idx = contains_char (opt, 'm'); - match_bool = contains_char (opt, 'b'); - if (opt.find_first_not_of ("lrmb") != std::string::npos) - { - error ("lookup: unrecognized option: %c", - opt[opt.find_first_not_of ("lrmb")]); - return retval; - } - } - - if ((match_idx || match_bool) && (left_inf || right_inf)) - error ("lookup: m, b cannot be specified with l or r"); - else if (match_idx && match_bool) - error ("lookup: only one of m or b can be specified"); - else if (str_case && (left_inf || right_inf)) - error ("lookup: l, r are not recognized for string lookups"); - - if (error_state) - return retval; - - if (num_case) - { - - // In the case of a complex array, absolute values will be used for compatibility - // (though it's not too meaningful). - - if (table.is_complex_type ()) - table = table.abs (); - - if (y.is_complex_type ()) - y = y.abs (); - - Array<octave_idx_type> idx; - - // PS: I learned this from data.cc - if INT_ARRAY_LOOKUP (int8) - else if INT_ARRAY_LOOKUP (int16) - else if INT_ARRAY_LOOKUP (int32) - else if INT_ARRAY_LOOKUP (int64) - else if INT_ARRAY_LOOKUP (uint8) - else if INT_ARRAY_LOOKUP (uint16) - else if INT_ARRAY_LOOKUP (uint32) - else if INT_ARRAY_LOOKUP (uint64) - else if (table.is_char_matrix () && y.is_char_matrix ()) - retval = do_numeric_lookup (table.char_array_value (), - y.char_array_value (), - left_inf, right_inf, - match_idx, match_bool); - else if (table.is_single_type () || y.is_single_type ()) - retval = do_numeric_lookup (table.float_array_value (), - y.float_array_value (), - left_inf, right_inf, - match_idx, match_bool); - else - retval = do_numeric_lookup (table.array_value (), - y.array_value (), - left_inf, right_inf, - match_idx, match_bool); - - } - else if (str_case) - { - Array<std::string> str_table = table.cellstr_value (); - Array<std::string> str_y (dim_vector (1, 1)); - - if (y.is_cellstr ()) - str_y = y.cellstr_value (); - else - str_y(0) = y.string_value (); - - Array<octave_idx_type> idx = str_table.lookup (str_y); - octave_idx_type nval = str_y.numel (); - - // Post-process. - if (match_bool) - { - boolNDArray match (idx.dims ()); - for (octave_idx_type i = 0; i < nval; i++) - { - octave_idx_type j = idx.xelem (i); - match.xelem (i) = j != 0 && str_y(i) == str_table(j-1); - } - - retval = match; - } - else if (match_idx) - { - NDArray ridx (idx.dims ()); - if (match_idx) - { - for (octave_idx_type i = 0; i < nval; i++) - { - octave_idx_type j = idx.xelem (i); - ridx.xelem (i) = (j != 0 && str_y(i) == str_table(j-1)) ? j : 0; - } - } - - retval = ridx; - } - else - retval = idx; - } - else - print_usage (); - - return retval; - -} - -/* -%!assert (lookup (1:3, 0.5), 0) # value before table -%!assert (lookup (1:3, 3.5), 3) # value after table error -%!assert (lookup (1:3, 1.5), 1) # value within table error -%!assert (lookup (1:3, [3,2,1]), [3,2,1]) -%!assert (lookup ([1:4]', [1.2, 3.5]'), [1, 3]') -%!assert (lookup ([1:4], [1.2, 3.5]'), [1, 3]') -%!assert (lookup ([1:4]', [1.2, 3.5]), [1, 3]) -%!assert (lookup ([1:4], [1.2, 3.5]), [1, 3]) -%!assert (lookup (1:3, [3, 2, 1]), [3, 2, 1]) -%!assert (lookup ([3:-1:1], [3.5, 3, 1.2, 2.5, 2.5]), [0, 1, 2, 1, 1]) -%!assert (isempty (lookup ([1:3], []))) -%!assert (isempty (lookup ([1:3]', []))) -%!assert (lookup (1:3, [1, 2; 3, 0.5]), [1, 2; 3, 0]) -%!assert (lookup (1:4, [1, 1.2; 3, 2.5], "m"), [1, 0; 3, 0]) -%!assert (lookup (4:-1:1, [1, 1.2; 3, 2.5], "m"), [4, 0; 2, 0]) -%!assert (lookup (1:4, [1, 1.2; 3, 2.5], "b"), logical ([1, 0; 3, 0])) -%!assert (lookup (4:-1:1, [1, 1.2; 3, 2.5], "b"), logical ([4, 0; 2, 0])) -%! -%!assert (lookup ({"apple","lemon","orange"}, {"banana","kiwi"; "ananas","mango"}), [1,1;0,2]) -%!assert (lookup ({"apple","lemon","orange"}, "potato"), 3) -%!assert (lookup ({"orange","lemon","apple"}, "potato"), 0) -*/
--- a/src/DLD-FUNCTIONS/lsode.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,548 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include <iomanip> -#include <iostream> - -#include "LSODE.h" -#include "lo-mappers.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "ov-fcn.h" -#include "ov-cell.h" -#include "pager.h" -#include "pr-output.h" -#include "unwind-prot.h" -#include "utils.h" -#include "variables.h" - -#include "LSODE-opts.cc" - -// Global pointer for user defined function required by lsode. -static octave_function *lsode_fcn; - -// Global pointer for optional user defined jacobian function used by lsode. -static octave_function *lsode_jac; - -// Have we warned about imaginary values returned from user function? -static bool warned_fcn_imaginary = false; -static bool warned_jac_imaginary = false; - -// Is this a recursive call? -static int call_depth = 0; - -ColumnVector -lsode_user_function (const ColumnVector& x, double t) -{ - ColumnVector retval; - - octave_value_list args; - args(1) = t; - args(0) = x; - - if (lsode_fcn) - { - octave_value_list tmp = lsode_fcn->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("lsode"); - return retval; - } - - if (tmp.length () > 0 && tmp(0).is_defined ()) - { - if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) - { - warning ("lsode: ignoring imaginary part returned from user-supplied function"); - warned_fcn_imaginary = true; - } - - retval = ColumnVector (tmp(0).vector_value ()); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("lsode"); - } - else - gripe_user_supplied_eval ("lsode"); - } - - return retval; -} - -Matrix -lsode_user_jacobian (const ColumnVector& x, double t) -{ - Matrix retval; - - octave_value_list args; - args(1) = t; - args(0) = x; - - if (lsode_jac) - { - octave_value_list tmp = lsode_jac->do_multi_index_op (1, args); - - if (error_state) - { - gripe_user_supplied_eval ("lsode"); - return retval; - } - - if (tmp.length () > 0 && tmp(0).is_defined ()) - { - if (! warned_jac_imaginary && tmp(0).is_complex_type ()) - { - warning ("lsode: ignoring imaginary part returned from user-supplied jacobian function"); - warned_jac_imaginary = true; - } - - retval = tmp(0).matrix_value (); - - if (error_state || retval.length () == 0) - gripe_user_supplied_eval ("lsode"); - } - else - gripe_user_supplied_eval ("lsode"); - } - - return retval; -} - -#define LSODE_ABORT() \ - return retval - -#define LSODE_ABORT1(msg) \ - do \ - { \ - ::error ("lsode: " msg); \ - LSODE_ABORT (); \ - } \ - while (0) - -#define LSODE_ABORT2(fmt, arg) \ - do \ - { \ - ::error ("lsode: " fmt, arg); \ - LSODE_ABORT (); \ - } \ - while (0) - -DEFUN_DLD (lsode, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{x}, @var{istate}, @var{msg}] =} lsode (@var{fcn}, @var{x_0}, @var{t})\n\ -@deftypefnx {Loadable Function} {[@var{x}, @var{istate}, @var{msg}] =} lsode (@var{fcn}, @var{x_0}, @var{t}, @var{t_crit})\n\ -Solve the set of differential equations\n\ -@tex\n\ -$$ {dx \\over dt} = f (x, t) $$\n\ -with\n\ -$$ x(t_0) = x_0 $$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ -dx\n\ --- = f (x, t)\n\ -dt\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -with\n\ -\n\ -@example\n\ -x(t_0) = x_0\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -The solution is returned in the matrix @var{x}, with each row\n\ -corresponding to an element of the vector @var{t}. The first element\n\ -of @var{t} should be @math{t_0} and should correspond to the initial\n\ -state of the system @var{x_0}, so that the first row of the output\n\ -is @var{x_0}.\n\ -\n\ -The first argument, @var{fcn}, is a string, inline, or function handle\n\ -that names the function @math{f} to call to compute the vector of right\n\ -hand sides for the set of equations. The function must have the form\n\ -\n\ -@example\n\ -@var{xdot} = f (@var{x}, @var{t})\n\ -@end example\n\ -\n\ -@noindent\n\ -in which @var{xdot} and @var{x} are vectors and @var{t} is a scalar.\n\ -\n\ -If @var{fcn} is a two-element string array or a two-element cell array\n\ -of strings, inline functions, or function handles, the first element names\n\ -the function @math{f} described above, and the second element names a\n\ -function to compute the Jacobian of @math{f}. The Jacobian function\n\ -must have the form\n\ -\n\ -@example\n\ -@var{jac} = j (@var{x}, @var{t})\n\ -@end example\n\ -\n\ -@noindent\n\ -in which @var{jac} is the matrix of partial derivatives\n\ -@tex\n\ -$$ J = {\\partial f_i \\over \\partial x_j} = \\left[\\matrix{\n\ -{\\partial f_1 \\over \\partial x_1}\n\ - & {\\partial f_1 \\over \\partial x_2}\n\ - & \\cdots\n\ - & {\\partial f_1 \\over \\partial x_N} \\cr\n\ -{\\partial f_2 \\over \\partial x_1}\n\ - & {\\partial f_2 \\over \\partial x_2}\n\ - & \\cdots\n\ - & {\\partial f_2 \\over \\partial x_N} \\cr\n\ - \\vdots & \\vdots & \\ddots & \\vdots \\cr\n\ -{\\partial f_3 \\over \\partial x_1}\n\ - & {\\partial f_3 \\over \\partial x_2}\n\ - & \\cdots\n\ - & {\\partial f_3 \\over \\partial x_N} \\cr}\\right]$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ - | df_1 df_1 df_1 |\n\ - | ---- ---- ... ---- |\n\ - | dx_1 dx_2 dx_N |\n\ - | |\n\ - | df_2 df_2 df_2 |\n\ - | ---- ---- ... ---- |\n\ - df_i | dx_1 dx_2 dx_N |\n\ -jac = ---- = | |\n\ - dx_j | . . . . |\n\ - | . . . . |\n\ - | . . . . |\n\ - | |\n\ - | df_N df_N df_N |\n\ - | ---- ---- ... ---- |\n\ - | dx_1 dx_2 dx_N |\n\ -@end group\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -\n\ -The second and third arguments specify the initial state of the system,\n\ -@math{x_0}, and the initial value of the independent variable @math{t_0}.\n\ -\n\ -The fourth argument is optional, and may be used to specify a set of\n\ -times that the ODE solver should not integrate past. It is useful for\n\ -avoiding difficulties with singularities and points where there is a\n\ -discontinuity in the derivative.\n\ -\n\ -After a successful computation, the value of @var{istate} will be 2\n\ -(consistent with the Fortran version of @sc{lsode}).\n\ -\n\ -If the computation is not successful, @var{istate} will be something\n\ -other than 2 and @var{msg} will contain additional information.\n\ -\n\ -You can use the function @code{lsode_options} to set optional\n\ -parameters for @code{lsode}.\n\ -@seealso{daspk, dassl, dasrt}\n\ -@end deftypefn") -{ - octave_value_list retval; - - warned_fcn_imaginary = false; - warned_jac_imaginary = false; - - unwind_protect frame; - - frame.protect_var (call_depth); - call_depth++; - - if (call_depth > 1) - LSODE_ABORT1 ("invalid recursive call"); - - int nargin = args.length (); - - if (nargin > 2 && nargin < 5 && nargout < 4) - { - std::string fcn_name, fname, jac_name, jname; - lsode_fcn = 0; - lsode_jac = 0; - - octave_value f_arg = args(0); - - if (f_arg.is_cell ()) - { - Cell c = f_arg.cell_value (); - if (c.length () == 1) - f_arg = c(0); - else if (c.length () == 2) - { - if (c(0).is_function_handle () || c(0).is_inline_function ()) - lsode_fcn = c(0).function_value (); - else - { - fcn_name = unique_symbol_name ("__lsode_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, t) y = "); - lsode_fcn = extract_function - (c(0), "lsode", fcn_name, fname, "; endfunction"); - } - - if (lsode_fcn) - { - if (c(1).is_function_handle () || c(1).is_inline_function ()) - lsode_jac = c(1).function_value (); - else - { - jac_name = unique_symbol_name ("__lsode_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, t) jac = "); - lsode_jac = extract_function - (c(1), "lsode", jac_name, jname, "; endfunction"); - - if (!lsode_jac) - { - if (fcn_name.length ()) - clear_function (fcn_name); - lsode_fcn = 0; - } - } - } - } - else - LSODE_ABORT1 ("incorrect number of elements in cell array"); - } - - if (!lsode_fcn && ! f_arg.is_cell ()) - { - if (f_arg.is_function_handle () || f_arg.is_inline_function ()) - lsode_fcn = f_arg.function_value (); - else - { - switch (f_arg.rows ()) - { - case 1: - do - { - fcn_name = unique_symbol_name ("__lsode_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, t) y = "); - lsode_fcn = extract_function - (f_arg, "lsode", fcn_name, fname, "; endfunction"); - } - while (0); - break; - - case 2: - { - string_vector tmp = f_arg.all_strings (); - - if (! error_state) - { - fcn_name = unique_symbol_name ("__lsode_fcn__"); - fname = "function y = "; - fname.append (fcn_name); - fname.append (" (x, t) y = "); - lsode_fcn = extract_function - (tmp(0), "lsode", fcn_name, fname, "; endfunction"); - - if (lsode_fcn) - { - jac_name = unique_symbol_name ("__lsode_jac__"); - jname = "function jac = "; - jname.append (jac_name); - jname.append (" (x, t) jac = "); - lsode_jac = extract_function - (tmp(1), "lsode", jac_name, jname, - "; endfunction"); - - if (!lsode_jac) - { - if (fcn_name.length ()) - clear_function (fcn_name); - lsode_fcn = 0; - } - } - } - } - break; - - default: - LSODE_ABORT1 - ("first arg should be a string or 2-element string array"); - } - } - } - - if (error_state || ! lsode_fcn) - LSODE_ABORT (); - - ColumnVector state (args(1).vector_value ()); - - if (error_state) - LSODE_ABORT1 ("expecting state vector as second argument"); - - ColumnVector out_times (args(2).vector_value ()); - - if (error_state) - LSODE_ABORT1 ("expecting output time vector as third argument"); - - ColumnVector crit_times; - - int crit_times_set = 0; - if (nargin > 3) - { - crit_times = ColumnVector (args(3).vector_value ()); - - if (error_state) - LSODE_ABORT1 ("expecting critical time vector as fourth argument"); - - crit_times_set = 1; - } - - double tzero = out_times (0); - - ODEFunc func (lsode_user_function); - if (lsode_jac) - func.set_jacobian_function (lsode_user_jacobian); - - LSODE ode (state, tzero, func); - - ode.set_options (lsode_opts); - - Matrix output; - if (crit_times_set) - output = ode.integrate (out_times, crit_times); - else - output = ode.integrate (out_times); - - if (fcn_name.length ()) - clear_function (fcn_name); - if (jac_name.length ()) - clear_function (jac_name); - - if (! error_state) - { - std::string msg = ode.error_message (); - - retval(2) = msg; - retval(1) = static_cast<double> (ode.integration_state ()); - - if (ode.integration_ok ()) - retval(0) = output; - else - { - retval(0) = Matrix (); - - if (nargout < 2) - error ("lsode: %s", msg.c_str ()); - } - } - } - else - print_usage (); - - return retval; -} - -/* - -## dassl-1.m -## -## Test lsode() function -## -## Author: David Billinghurst (David.Billinghurst@riotinto.com.au) -## Comalco Research and Technology -## 20 May 1998 -## -## Problem -## -## y1' = -y2, y1(0) = 1 -## y2' = y1, y2(0) = 0 -## -## Solution -## -## y1(t) = cos(t) -## y2(t) = sin(t) -## -%!function xdot = __f (x, t) -%! xdot = [-x(2); x(1)]; -%!endfunction -%!test -%! -%! x0 = [1; 0]; -%! xdot0 = [0; 1]; -%! t = (0:1:10)'; -%! -%! tol = 500 * lsode_options ("relative tolerance"); -%! -%! x = lsode ("__f", x0, t); -%! -%! y = [cos(t), sin(t)]; -%! -%! assert (x, y, tol); - -%!function xdotdot = __f (x, t) -%! xdotdot = [x(2); -x(1)]; -%!endfunction -%!test -%! -%! x0 = [1; 0]; -%! t = [0; 2*pi]; -%! tol = 100 * dassl_options ("relative tolerance"); -%! -%! x = lsode ("__f", x0, t); -%! -%! y = [1, 0; 1, 0]; -%! -%! assert (x, y, tol); - -%!function xdot = __f (x, t) -%! xdot = x; -%!endfunction -%!test -%! -%! x0 = 1; -%! t = [0; 1]; -%! tol = 100 * dassl_options ("relative tolerance"); -%! -%! x = lsode ("__f", x0, t); -%! -%! y = [1; e]; -%! -%! assert (x, y, tol); - -%!test -%! lsode_options ("absolute tolerance", eps); -%! assert (lsode_options ("absolute tolerance") == eps); - -%!error lsode_options ("foo", 1, 2) -*/
--- a/src/DLD-FUNCTIONS/lu.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,857 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "CmplxLU.h" -#include "dbleLU.h" -#include "fCmplxLU.h" -#include "floatLU.h" -#include "SparseCmplxLU.h" -#include "SparsedbleLU.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" -#include "ov-re-sparse.h" -#include "ov-cx-sparse.h" - -template <class MT> -static octave_value -get_lu_l (const base_lu<MT>& fact) -{ - MT L = fact.L (); - if (L.is_square ()) - return octave_value (L, MatrixType (MatrixType::Lower)); - else - return L; -} - -template <class MT> -static octave_value -get_lu_u (const base_lu<MT>& fact) -{ - MT U = fact.U (); - if (U.is_square () && fact.regular ()) - return octave_value (U, MatrixType (MatrixType::Upper)); - else - return U; -} - -DEFUN_DLD (lu, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{L}, @var{U}] =} lu (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{L}, @var{U}, @var{P}] =} lu (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} lu (@var{S})\n\ -@deftypefnx {Loadable Function} {[@var{L}, @var{U}, @var{P}, @var{Q}, @var{R}] =} lu (@var{S})\n\ -@deftypefnx {Loadable Function} {[@dots{}] =} lu (@var{S}, @var{thres})\n\ -@deftypefnx {Loadable Function} {@var{y} =} lu (@dots{})\n\ -@deftypefnx {Loadable Function} {[@dots{}] =} lu (@dots{}, \"vector\")\n\ -@cindex LU decomposition\n\ -Compute the LU@tie{}decomposition of @var{A}. If @var{A} is full\n\ -subroutines from\n\ -@sc{lapack} are used and if @var{A} is sparse then @sc{umfpack} is used. The\n\ -result is returned in a permuted form, according to the optional return\n\ -value @var{P}. For example, given the matrix @code{a = [1, 2; 3, 4]},\n\ -\n\ -@example\n\ -[l, u, p] = lu (@var{a})\n\ -@end example\n\ -\n\ -@noindent\n\ -returns\n\ -\n\ -@example\n\ -@group\n\ -l =\n\ -\n\ - 1.00000 0.00000\n\ - 0.33333 1.00000\n\ -\n\ -u =\n\ -\n\ - 3.00000 4.00000\n\ - 0.00000 0.66667\n\ -\n\ -p =\n\ -\n\ - 0 1\n\ - 1 0\n\ -@end group\n\ -@end example\n\ -\n\ -The matrix is not required to be square.\n\ -\n\ -When called with two or three output arguments and a spare input matrix,\n\ -@code{lu} does not attempt to perform sparsity preserving column\n\ -permutations. Called with a fourth output argument, the sparsity\n\ -preserving column transformation @var{Q} is returned, such that\n\ -@code{@var{P} * @var{A} * @var{Q} = @var{L} * @var{U}}.\n\ -\n\ -Called with a fifth output argument and a sparse input matrix,\n\ -@code{lu} attempts to use a scaling factor @var{R} on the input matrix\n\ -such that\n\ -@code{@var{P} * (@var{R} \\ @var{A}) * @var{Q} = @var{L} * @var{U}}.\n\ -This typically leads to a sparser and more stable factorization.\n\ -\n\ -An additional input argument @var{thres}, that defines the pivoting\n\ -threshold can be given. @var{thres} can be a scalar, in which case\n\ -it defines the @sc{umfpack} pivoting tolerance for both symmetric and\n\ -unsymmetric cases. If @var{thres} is a 2-element vector, then the first\n\ -element defines the pivoting tolerance for the unsymmetric @sc{umfpack}\n\ -pivoting strategy and the second for the symmetric strategy. By default,\n\ -the values defined by @code{spparms} are used ([0.1, 0.001]).\n\ -\n\ -Given the string argument \"vector\", @code{lu} returns the values of @var{P}\n\ -and @var{Q} as vector values, such that for full matrix, @code{@var{A}\n\ -(@var{P},:) = @var{L} * @var{U}}, and @code{@var{R}(@var{P},:) * @var{A}\n\ -(:, @var{Q}) = @var{L} * @var{U}}.\n\ -\n\ -With two output arguments, returns the permuted forms of the upper and\n\ -lower triangular matrices, such that @code{@var{A} = @var{L} * @var{U}}.\n\ -With one output argument @var{y}, then the matrix returned by the @sc{lapack}\n\ -routines is returned. If the input matrix is sparse then the matrix @var{L}\n\ -is embedded into @var{U} to give a return value similar to the full case.\n\ -For both full and sparse matrices, @code{lu} loses the permutation\n\ -information.\n\ -@end deftypefn") -{ - octave_value_list retval; - int nargin = args.length (); - bool issparse = (nargin > 0 && args(0).is_sparse_type ()); - bool scale = (nargout == 5); - - if (nargin < 1 || (issparse && (nargin > 3 || nargout > 5)) - || (!issparse && (nargin > 2 || nargout > 3))) - { - print_usage (); - return retval; - } - - bool vecout = false; - Matrix thres; - - int n = 1; - while (n < nargin && ! error_state) - { - if (args (n).is_string ()) - { - std::string tmp = args(n++).string_value (); - - if (! error_state ) - { - if (tmp.compare ("vector") == 0) - vecout = true; - else - error ("lu: unrecognized string argument"); - } - } - else - { - Matrix tmp = args(n++).matrix_value (); - - if (! error_state ) - { - if (!issparse) - error ("lu: can not define pivoting threshold THRES for full matrices"); - else if (tmp.nelem () == 1) - { - thres.resize (1,2); - thres(0) = tmp(0); - thres(1) = tmp(0); - } - else if (tmp.nelem () == 2) - thres = tmp; - else - error ("lu: expecting 2-element vector for THRES"); - } - } - } - - octave_value arg = args(0); - - octave_idx_type nr = arg.rows (); - octave_idx_type nc = arg.columns (); - - int arg_is_empty = empty_arg ("lu", nr, nc); - - if (issparse) - { - if (arg_is_empty < 0) - return retval; - else if (arg_is_empty > 0) - return octave_value_list (5, SparseMatrix ()); - - ColumnVector Qinit; - if (nargout < 4) - { - Qinit.resize (nc); - for (octave_idx_type i = 0; i < nc; i++) - Qinit (i) = i; - } - - if (arg.is_real_type ()) - { - SparseMatrix m = arg.sparse_matrix_value (); - - switch (nargout) - { - case 0: - case 1: - case 2: - { - SparseLU fact (m, Qinit, thres, false, true); - - if (nargout < 2) - retval(0) = fact.Y (); - else - { - PermMatrix P = fact.Pr_mat (); - SparseMatrix L = P.transpose () * fact.L (); - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - - retval(0) = octave_value (L, - MatrixType (MatrixType::Permuted_Lower, - nr, fact.row_perm ())); - } - } - break; - - case 3: - { - SparseLU fact (m, Qinit, thres, false, true); - - if (vecout) - retval(2) = fact.Pr_vec (); - else - retval(2) = fact.Pr_mat (); - - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - break; - - case 4: - default: - { - SparseLU fact (m, thres, scale); - - if (scale) - retval(4) = fact.R (); - - if (vecout) - { - retval(3) = fact.Pc_vec (); - retval(2) = fact.Pr_vec (); - } - else - { - retval(3) = fact.Pc_mat (); - retval(2) = fact.Pr_mat (); - } - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - break; - } - } - else if (arg.is_complex_type ()) - { - SparseComplexMatrix m = arg.sparse_complex_matrix_value (); - - switch (nargout) - { - case 0: - case 1: - case 2: - { - SparseComplexLU fact (m, Qinit, thres, false, true); - - if (nargout < 2) - retval(0) = fact.Y (); - else - { - PermMatrix P = fact.Pr_mat (); - SparseComplexMatrix L = P.transpose () * fact.L (); - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - - retval(0) = octave_value (L, - MatrixType (MatrixType::Permuted_Lower, - nr, fact.row_perm ())); - } - } - break; - - case 3: - { - SparseComplexLU fact (m, Qinit, thres, false, true); - - if (vecout) - retval(2) = fact.Pr_vec (); - else - retval(2) = fact.Pr_mat (); - - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - break; - - case 4: - default: - { - SparseComplexLU fact (m, thres, scale); - - if (scale) - retval(4) = fact.R (); - - if (vecout) - { - retval(3) = fact.Pc_vec (); - retval(2) = fact.Pr_vec (); - } - else - { - retval(3) = fact.Pc_mat (); - retval(2) = fact.Pr_mat (); - } - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - break; - } - } - else - gripe_wrong_type_arg ("lu", arg); - } - else - { - if (arg_is_empty < 0) - return retval; - else if (arg_is_empty > 0) - return octave_value_list (3, Matrix ()); - - if (arg.is_real_type ()) - { - if (arg.is_single_type ()) - { - FloatMatrix m = arg.float_matrix_value (); - - if (! error_state) - { - FloatLU fact (m); - - switch (nargout) - { - case 0: - case 1: - retval(0) = fact.Y (); - break; - - case 2: - { - PermMatrix P = fact.P (); - FloatMatrix L = P.transpose () * fact.L (); - retval(1) = get_lu_u (fact); - retval(0) = L; - } - break; - - case 3: - default: - { - if (vecout) - retval(2) = fact.P_vec (); - else - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - break; - } - } - } - else - { - Matrix m = arg.matrix_value (); - - if (! error_state) - { - LU fact (m); - - switch (nargout) - { - case 0: - case 1: - retval(0) = fact.Y (); - break; - - case 2: - { - PermMatrix P = fact.P (); - Matrix L = P.transpose () * fact.L (); - retval(1) = get_lu_u (fact); - retval(0) = L; - } - break; - - case 3: - default: - { - if (vecout) - retval(2) = fact.P_vec (); - else - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - break; - } - } - } - } - else if (arg.is_complex_type ()) - { - if (arg.is_single_type ()) - { - FloatComplexMatrix m = arg.float_complex_matrix_value (); - - if (! error_state) - { - FloatComplexLU fact (m); - - switch (nargout) - { - case 0: - case 1: - retval(0) = fact.Y (); - break; - - case 2: - { - PermMatrix P = fact.P (); - FloatComplexMatrix L = P.transpose () * fact.L (); - retval(1) = get_lu_u (fact); - retval(0) = L; - } - break; - - case 3: - default: - { - if (vecout) - retval(2) = fact.P_vec (); - else - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - break; - } - } - } - else - { - ComplexMatrix m = arg.complex_matrix_value (); - - if (! error_state) - { - ComplexLU fact (m); - - switch (nargout) - { - case 0: - case 1: - retval(0) = fact.Y (); - break; - - case 2: - { - PermMatrix P = fact.P (); - ComplexMatrix L = P.transpose () * fact.L (); - retval(1) = get_lu_u (fact); - retval(0) = L; - } - break; - - case 3: - default: - { - if (vecout) - retval(2) = fact.P_vec (); - else - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - break; - } - } - } - } - else - gripe_wrong_type_arg ("lu", arg); - } - - return retval; -} - -/* -%!assert(lu ([1, 2; 3, 4]), [3, 4; 1/3, 2/3], eps); - -%!test -%! [l, u] = lu ([1, 2; 3, 4]); -%! assert (l, [1/3, 1; 1, 0], sqrt (eps)); -%! assert (u, [3, 4; 0, 2/3], sqrt (eps)); - -%!test -%! [l, u, p] = lu ([1, 2; 3, 4]); -%! assert (l, [1, 0; 1/3, 1], sqrt (eps)); -%! assert (u, [3, 4; 0, 2/3], sqrt (eps)); -%! assert (p(:,:), [0, 1; 1, 0], sqrt (eps)); - -%!test -%! [l, u, p] = lu ([1, 2; 3, 4], "vector"); -%! assert (l, [1, 0; 1/3, 1], sqrt (eps)); -%! assert (u, [3, 4; 0, 2/3], sqrt (eps)); -%! assert (p, [2;1], sqrt (eps)); - -%!test -%! [l, u, p] = lu ([1, 2; 3, 4; 5, 6]); -%! assert (l, [1, 0; 1/5, 1; 3/5, 1/2], sqrt (eps)); -%! assert (u, [5, 6; 0, 4/5], sqrt (eps)); -%! assert (p(:,:), [0, 0, 1; 1, 0, 0; 0 1 0], sqrt (eps)); - -%!assert (lu (single ([1, 2; 3, 4])), single ([3, 4; 1/3, 2/3]), eps ("single")) - -%!test -%! [l, u] = lu (single ([1, 2; 3, 4])); -%! assert (l, single ([1/3, 1; 1, 0]), sqrt (eps ("single"))); -%! assert (u, single ([3, 4; 0, 2/3]), sqrt (eps ("single"))); - -%!test -%! [l, u, p] = lu (single ([1, 2; 3, 4])); -%! assert (l, single ([1, 0; 1/3, 1]), sqrt (eps ("single"))); -%! assert (u, single ([3, 4; 0, 2/3]), sqrt (eps ("single"))); -%! assert (p(:,:), single ([0, 1; 1, 0]), sqrt (eps ("single"))); - -%!test -%! [l, u, p] = lu (single ([1, 2; 3, 4]), "vector"); -%! assert (l, single ([1, 0; 1/3, 1]), sqrt (eps ("single"))); -%! assert (u, single ([3, 4; 0, 2/3]), sqrt (eps ("single"))); -%! assert (p, single ([2;1]), sqrt (eps ("single"))); - -%!test -%! [l u p] = lu (single ([1, 2; 3, 4; 5, 6])); -%! assert (l, single ([1, 0; 1/5, 1; 3/5, 1/2]), sqrt (eps ("single"))); -%! assert (u, single ([5, 6; 0, 4/5]), sqrt (eps ("single"))); -%! assert (p(:,:), single ([0, 0, 1; 1, 0, 0; 0 1 0]), sqrt (eps ("single"))); - -%!error lu () -%!error <can not define pivoting threshold> lu ([1, 2; 3, 4], 2) -*/ - -static -bool check_lu_dims (const octave_value& l, const octave_value& u, - const octave_value& p) -{ - octave_idx_type m = l.rows (), k = u.rows (), n = u.columns (); - return ((l.ndims () == 2 && u.ndims () == 2 && k == l.columns ()) - && k == std::min (m, n) && - (p.is_undefined () || p.rows () == m)); -} - -DEFUN_DLD (luupdate, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{L}, @var{U}] =} luupdate (@var{L}, @var{U}, @var{x}, @var{y})\n\ -@deftypefnx {Loadable Function} {[@var{L}, @var{U}, @var{P}] =} luupdate (@var{L}, @var{U}, @var{P}, @var{x}, @var{y})\n\ -Given an LU@tie{}factorization of a real or complex matrix\n\ -@w{@var{A} = @var{L}*@var{U}}, @var{L}@tie{}lower unit trapezoidal and\n\ -@var{U}@tie{}upper trapezoidal, return the LU@tie{}factorization\n\ -of @w{@var{A} + @var{x}*@var{y}.'}, where @var{x} and @var{y} are\n\ -column vectors (rank-1 update) or matrices with equal number of columns\n\ -(rank-k update).\n\ -Optionally, row-pivoted updating can be used by supplying\n\ -a row permutation (pivoting) matrix @var{P};\n\ -in that case, an updated permutation matrix is returned.\n\ -Note that if @var{L}, @var{U}, @var{P} is a pivoted LU@tie{}factorization\n\ -as obtained by @code{lu}:\n\ -\n\ -@example\n\ -[@var{L}, @var{U}, @var{P}] = lu (@var{A});\n\ -@end example\n\ -\n\ -@noindent\n\ -then a factorization of @xcode{@var{A}+@var{x}*@var{y}.'} can be obtained\n\ -either as\n\ -\n\ -@example\n\ -[@var{L1}, @var{U1}] = lu (@var{L}, @var{U}, @var{P}*@var{x}, @var{y})\n\ -@end example\n\ -\n\ -@noindent\n\ -or\n\ -\n\ -@example\n\ -[@var{L1}, @var{U1}, @var{P1}] = lu (@var{L}, @var{U}, @var{P}, @var{x}, @var{y})\n\ -@end example\n\ -\n\ -The first form uses the unpivoted algorithm, which is faster, but less\n\ -stable. The second form uses a slower pivoted algorithm, which is more\n\ -stable.\n\ -\n\ -The matrix case is done as a sequence of rank-1 updates;\n\ -thus, for large enough k, it will be both faster and more accurate to\n\ -recompute the factorization from scratch.\n\ -@seealso{lu, qrupdate, cholupdate}\n\ -@end deftypefn") -{ - octave_idx_type nargin = args.length (); - octave_value_list retval; - - bool pivoted = nargin == 5; - - if (nargin != 4 && nargin != 5) - { - print_usage (); - return retval; - } - - octave_value argl = args(0); - octave_value argu = args(1); - octave_value argp = pivoted ? args(2) : octave_value (); - octave_value argx = args(2 + pivoted); - octave_value argy = args(3 + pivoted); - - if (argl.is_numeric_type () && argu.is_numeric_type () - && argx.is_numeric_type () && argy.is_numeric_type () - && (! pivoted || argp.is_perm_matrix ())) - { - if (check_lu_dims (argl, argu, argp)) - { - PermMatrix P = (pivoted - ? argp.perm_matrix_value () - : PermMatrix::eye (argl.rows ())); - - if (argl.is_real_type () - && argu.is_real_type () - && argx.is_real_type () - && argy.is_real_type ()) - { - // all real case - if (argl.is_single_type () - || argu.is_single_type () - || argx.is_single_type () - || argy.is_single_type ()) - { - FloatMatrix L = argl.float_matrix_value (); - FloatMatrix U = argu.float_matrix_value (); - FloatMatrix x = argx.float_matrix_value (); - FloatMatrix y = argy.float_matrix_value (); - - FloatLU fact (L, U, P); - if (pivoted) - fact.update_piv (x, y); - else - fact.update (x, y); - - if (pivoted) - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - else - { - Matrix L = argl.matrix_value (); - Matrix U = argu.matrix_value (); - Matrix x = argx.matrix_value (); - Matrix y = argy.matrix_value (); - - LU fact (L, U, P); - if (pivoted) - fact.update_piv (x, y); - else - fact.update (x, y); - - if (pivoted) - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - } - else - { - // complex case - if (argl.is_single_type () - || argu.is_single_type () - || argx.is_single_type () - || argy.is_single_type ()) - { - FloatComplexMatrix L = argl.float_complex_matrix_value (); - FloatComplexMatrix U = argu.float_complex_matrix_value (); - FloatComplexMatrix x = argx.float_complex_matrix_value (); - FloatComplexMatrix y = argy.float_complex_matrix_value (); - - FloatComplexLU fact (L, U, P); - if (pivoted) - fact.update_piv (x, y); - else - fact.update (x, y); - - if (pivoted) - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - else - { - ComplexMatrix L = argl.complex_matrix_value (); - ComplexMatrix U = argu.complex_matrix_value (); - ComplexMatrix x = argx.complex_matrix_value (); - ComplexMatrix y = argy.complex_matrix_value (); - - ComplexLU fact (L, U, P); - if (pivoted) - fact.update_piv (x, y); - else - fact.update (x, y); - - if (pivoted) - retval(2) = fact.P (); - retval(1) = get_lu_u (fact); - retval(0) = get_lu_l (fact); - } - } - } - else - error ("luupdate: dimension mismatch"); - } - else - error ("luupdate: L, U, X, and Y must be numeric"); - - return retval; -} - -/* -%!shared A, u, v, Ac, uc, vc -%! A = [0.091364 0.613038 0.999083; -%! 0.594638 0.425302 0.603537; -%! 0.383594 0.291238 0.085574; -%! 0.265712 0.268003 0.238409; -%! 0.669966 0.743851 0.445057 ]; -%! -%! u = [0.85082; -%! 0.76426; -%! 0.42883; -%! 0.53010; -%! 0.80683 ]; -%! -%! v = [0.98810; -%! 0.24295; -%! 0.43167 ]; -%! -%! Ac = [0.620405 + 0.956953i 0.480013 + 0.048806i 0.402627 + 0.338171i; -%! 0.589077 + 0.658457i 0.013205 + 0.279323i 0.229284 + 0.721929i; -%! 0.092758 + 0.345687i 0.928679 + 0.241052i 0.764536 + 0.832406i; -%! 0.912098 + 0.721024i 0.049018 + 0.269452i 0.730029 + 0.796517i; -%! 0.112849 + 0.603871i 0.486352 + 0.142337i 0.355646 + 0.151496i ]; -%! -%! uc = [0.20351 + 0.05401i; -%! 0.13141 + 0.43708i; -%! 0.29808 + 0.08789i; -%! 0.69821 + 0.38844i; -%! 0.74871 + 0.25821i ]; -%! -%! vc = [0.85839 + 0.29468i; -%! 0.20820 + 0.93090i; -%! 0.86184 + 0.34689i ]; -%! - -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (A); -%! [L,U] = luupdate (L,U,P*u,v); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - A - u*v.'), Inf) < norm (A)*1e1*eps); -%! -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (Ac); -%! [L,U] = luupdate (L,U,P*uc,vc); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - Ac - uc*vc.'), Inf) < norm (Ac)*1e1*eps); - -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (single (A)); -%! [L,U] = luupdate (L,U,P*single (u), single (v)); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - single (A) - single (u)*single (v).'), Inf) < norm (single (A))*1e1*eps ("single")); -%! -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (single (Ac)); -%! [L,U] = luupdate (L,U,P*single (uc),single (vc)); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - single (Ac) - single (uc)*single (vc).'), Inf) < norm (single (Ac))*1e1*eps ("single")); - -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (A); -%! [L,U,P] = luupdate (L,U,P,u,v); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - A - u*v.'), Inf) < norm (A)*1e1*eps); -%! -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (Ac); -%! [L,U,P] = luupdate (L,U,P,uc,vc); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - Ac - uc*vc.'), Inf) < norm (Ac)*1e1*eps); - -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (single (A)); -%! [L,U,P] = luupdate (L,U,P,single (u),single (v)); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - single (A) - single (u)*single (v).'), Inf) < norm (single (A))*1e1*eps ("single")); -%! -%!testif HAVE_QRUPDATE_LUU -%! [L,U,P] = lu (single (Ac)); -%! [L,U,P] = luupdate (L,U,P,single (uc),single (vc)); -%! assert (norm (vec (tril (L)-L), Inf) == 0); -%! assert (norm (vec (triu (U)-U), Inf) == 0); -%! assert (norm (vec (P'*L*U - single (Ac) - single (uc)*single (vc).'), Inf) < norm (single (Ac))*1e1*eps ("single")); -*/
--- a/src/DLD-FUNCTIONS/luinc.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,383 +0,0 @@ -/* - -Copyright (C) 2005-2012 David Bateman - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" -#include "oct-map.h" - -#include "MatrixType.h" -#include "SparseCmplxLU.h" -#include "SparsedbleLU.h" -#include "ov-re-sparse.h" -#include "ov-cx-sparse.h" - -DEFUN_DLD (luinc, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} luinc (@var{A}, '0')\n\ -@deftypefnx {Loadable Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} luinc (@var{A}, @var{droptol})\n\ -@deftypefnx {Loadable Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} luinc (@var{A}, @var{opts})\n\ -@cindex LU decomposition\n\ -Produce the incomplete LU@tie{}factorization of the sparse matrix @var{A}.\n\ -Two types of incomplete factorization are possible, and the type\n\ -is determined by the second argument to @code{luinc}.\n\ -\n\ -Called with a second argument of '0', the zero-level incomplete\n\ -LU@tie{}factorization is produced. This creates a factorization of @var{A}\n\ -where the position of the non-zero arguments correspond to the same\n\ -positions as in the matrix @var{A}.\n\ -\n\ -Alternatively, the fill-in of the incomplete LU@tie{}factorization can\n\ -be controlled through the variable @var{droptol} or the structure\n\ -@var{opts}. The @sc{umfpack} multifrontal factorization code by Tim A.\n\ -Davis is used for the incomplete LU@tie{}factorization, (availability\n\ -@url{http://www.cise.ufl.edu/research/sparse/umfpack/})\n\ -\n\ -@var{droptol} determines the values below which the values in the\n\ -LU@tie{} factorization are dropped and replaced by zero. It must be a\n\ -positive scalar, and any values in the factorization whose absolute value\n\ -are less than this value are dropped, expect if leaving them increase the\n\ -sparsity of the matrix. Setting @var{droptol} to zero results in a complete\n\ -LU@tie{}factorization which is the default.\n\ -\n\ -@var{opts} is a structure containing one or more of the fields\n\ -\n\ -@table @code\n\ -@item droptol\n\ -The drop tolerance as above. If @var{opts} only contains @code{droptol}\n\ -then this is equivalent to using the variable @var{droptol}.\n\ -\n\ -@item milu\n\ -A logical variable flagging whether to use the modified incomplete\n\ -LU@tie{} factorization. In the case that @code{milu} is true, the dropped\n\ -values are subtracted from the diagonal of the matrix @var{U} of the\n\ -factorization. The default is @code{false}.\n\ -\n\ -@item udiag\n\ -A logical variable that flags whether zero elements on the diagonal of\n\ -@var{U} should be replaced with @var{droptol} to attempt to avoid singular\n\ -factors. The default is @code{false}.\n\ -\n\ -@item thresh\n\ -Defines the pivot threshold in the interval [0,1]. Values outside that\n\ -range are ignored.\n\ -@end table\n\ -\n\ -All other fields in @var{opts} are ignored. The outputs from @code{luinc}\n\ -are the same as for @code{lu}.\n\ -\n\ -Given the string argument \"vector\", @code{luinc} returns the values of\n\ -@var{p} @var{q} as vector values.\n\ -@seealso{sparse, lu}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value_list retval; - - if (nargin == 0) - print_usage (); - else if (nargin < 2 || nargin > 3) - error ("luinc: incorrect number of arguments"); - else - { - bool zero_level = false; - bool milu = false; - bool udiag = false; - Matrix thresh; - double droptol = -1.; - bool vecout = false; - - if (args(1).is_string ()) - { - if (args(1).string_value () == "0") - zero_level = true; - else - error ("luinc: unrecognized string argument"); - } - else if (args(1).is_map ()) - { - octave_scalar_map map = args(1).scalar_map_value (); - - if (! error_state) - { - octave_value tmp; - - tmp = map.getfield ("droptol"); - if (tmp.is_defined ()) - droptol = tmp.double_value (); - - tmp = map.getfield ("milu"); - if (tmp.is_defined ()) - { - double val = tmp.double_value (); - - milu = (val == 0. ? false : true); - } - - tmp = map.getfield ("udiag"); - if (tmp.is_defined ()) - { - double val = tmp.double_value (); - - udiag = (val == 0. ? false : true); - } - - tmp = map.getfield ("thresh"); - if (tmp.is_defined ()) - { - thresh = tmp.matrix_value (); - - if (thresh.nelem () == 1) - { - thresh.resize (1,2); - thresh(1) = thresh(0); - } - else if (thresh.nelem () != 2) - { - error ("luinc: expecting 2-element vector for thresh"); - return retval; - } - } - } - else - { - error ("luinc: OPTS must be a scalar structure"); - return retval; - } - } - else - droptol = args(1).double_value (); - - if (nargin == 3) - { - std::string tmp = args(2).string_value (); - - if (! error_state ) - { - if (tmp.compare ("vector") == 0) - vecout = true; - else - error ("luinc: unrecognized string argument"); - } - } - - // FIXME Add code for zero-level factorization - if (zero_level) - error ("luinc: zero-level factorization not implemented"); - - if (!error_state) - { - if (args(0).type_name () == "sparse matrix") - { - SparseMatrix sm = args(0).sparse_matrix_value (); - octave_idx_type sm_nr = sm.rows (); - octave_idx_type sm_nc = sm.cols (); - ColumnVector Qinit (sm_nc); - - for (octave_idx_type i = 0; i < sm_nc; i++) - Qinit (i) = i; - - if (! error_state) - { - switch (nargout) - { - case 0: - case 1: - case 2: - { - SparseLU fact (sm, Qinit, thresh, false, true, droptol, - milu, udiag); - - if (! error_state) - { - SparseMatrix P = fact.Pr (); - SparseMatrix L = P.transpose () * fact.L (); - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (L, MatrixType - (MatrixType::Permuted_Lower, - sm_nr, fact.row_perm ())); - } - } - break; - - case 3: - { - SparseLU fact (sm, Qinit, thresh, false, true, droptol, - milu, udiag); - - if (! error_state) - { - if (vecout) - retval(2) = fact.Pr_vec (); - else - retval(2) = fact.Pr_mat (); - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - } - break; - - case 4: - default: - { - SparseLU fact (sm, Qinit, thresh, false, false, droptol, - milu, udiag); - - if (! error_state) - { - if (vecout) - { - retval(3) = fact.Pc_vec (); - retval(2) = fact.Pr_vec (); - } - else - { - retval(3) = fact.Pc_mat (); - retval(2) = fact.Pr_mat (); - } - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - } - break; - } - } - } - else if (args(0).type_name () == "sparse complex matrix") - { - SparseComplexMatrix sm = - args(0).sparse_complex_matrix_value (); - octave_idx_type sm_nr = sm.rows (); - octave_idx_type sm_nc = sm.cols (); - ColumnVector Qinit (sm_nc); - - for (octave_idx_type i = 0; i < sm_nc; i++) - Qinit (i) = i; - - if (! error_state) - { - switch (nargout) - { - case 0: - case 1: - case 2: - { - SparseComplexLU fact (sm, Qinit, thresh, false, true, - droptol, milu, udiag); - - - if (! error_state) - { - SparseMatrix P = fact.Pr (); - SparseComplexMatrix L = P.transpose () * fact.L (); - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (L, MatrixType - (MatrixType::Permuted_Lower, - sm_nr, fact.row_perm ())); - } - } - break; - - case 3: - { - SparseComplexLU fact (sm, Qinit, thresh, false, true, - droptol, milu, udiag); - - if (! error_state) - { - if (vecout) - retval(2) = fact.Pr_vec (); - else - retval(2) = fact.Pr_mat (); - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - } - break; - - case 4: - default: - { - SparseComplexLU fact (sm, Qinit, thresh, false, false, - droptol, milu, udiag); - - if (! error_state) - { - if (vecout) - { - retval(3) = fact.Pc_vec (); - retval(2) = fact.Pr_vec (); - } - else - { - retval(3) = fact.Pc_mat (); - retval(2) = fact.Pr_mat (); - } - retval(1) = octave_value (fact.U (), - MatrixType (MatrixType::Upper)); - retval(0) = octave_value (fact.L (), - MatrixType (MatrixType::Lower)); - } - } - break; - } - } - } - else - error ("luinc: matrix A must be sparse"); - } - } - - return retval; -} - -/* -%!testif HAVE_UMFPACK -%! a = sparse ([1,2,0,0;0,1,2,0;1e-14,0,3,0;0,0,0,1]); -%! [l,u] = luinc (a, 1e-10); -%! assert (l*u, sparse ([1,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); -%! opts.droptol = 1e-10; -%! [l,u] = luinc (a, opts); -%! assert (l*u, sparse ([1,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); - -%!testif HAVE_UMFPACK -%! a = sparse ([1i,2,0,0;0,1,2,0;1e-14,0,3,0;0,0,0,1]); -%! [l,u] = luinc (a, 1e-10); -%! assert (l*u, sparse ([1i,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); -%! opts.droptol = 1e-10; -%! [l,u] = luinc (a, opts); -%! assert (l*u, sparse ([1i,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); -*/
--- a/src/DLD-FUNCTIONS/matrix_type.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,621 +0,0 @@ -/* - -Copyright (C) 2005-2012 David Bateman - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <algorithm> - -#include "ov.h" -#include "defun-dld.h" -#include "error.h" -#include "ov-re-mat.h" -#include "ov-cx-mat.h" -#include "ov-re-sparse.h" -#include "ov-cx-sparse.h" -#include "MatrixType.h" -#include "oct-locbuf.h" - -DEFUN_DLD (matrix_type, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{type} =} matrix_type (@var{A})\n\ -@deftypefnx {Loadable Function} {@var{type} =} matrix_type (@var{A}, \"nocompute\")\n\ -@deftypefnx {Loadable Function} {@var{A} =} matrix_type (@var{A}, @var{type})\n\ -@deftypefnx {Loadable Function} {@var{A} =} matrix_type (@var{A}, \"upper\", @var{perm})\n\ -@deftypefnx {Loadable Function} {@var{A} =} matrix_type (@var{A}, \"lower\", @var{perm})\n\ -@deftypefnx {Loadable Function} {@var{A} =} matrix_type (@var{A}, \"banded\", @var{nl}, @var{nu})\n\ -Identify the matrix type or mark a matrix as a particular type. This allows\n\ -more rapid solutions of linear equations involving @var{A} to be performed.\n\ -Called with a single argument, @code{matrix_type} returns the type of the\n\ -matrix and caches it for future use. Called with more than one argument,\n\ -@code{matrix_type} allows the type of the matrix to be defined.\n\ -\n\ -If the option \"nocompute\" is given, the function will not attempt to guess\n\ -the type if it is still unknown. This is useful for debugging purposes.\n\ -\n\ -The possible matrix types depend on whether the matrix is full or sparse, and\n\ -can be one of the following\n\ -\n\ -@table @asis\n\ -@item \"unknown\"\n\ -Remove any previously cached matrix type, and mark type as unknown.\n\ -\n\ -@item \"full\"\n\ -Mark the matrix as full.\n\ -\n\ -@item \"positive definite\"\n\ -Probable full positive definite matrix.\n\ -\n\ -@item \"diagonal\"\n\ -Diagonal matrix. (Sparse matrices only)\n\ -\n\ -@item \"permuted diagonal\"\n\ -Permuted Diagonal matrix. The permutation does not need to be specifically\n\ -indicated, as the structure of the matrix explicitly gives this. (Sparse\n\ -matrices only)\n\ -\n\ -@item \"upper\"\n\ -Upper triangular. If the optional third argument @var{perm} is given, the\n\ -matrix is assumed to be a permuted upper triangular with the permutations\n\ -defined by the vector @var{perm}.\n\ -\n\ -@item \"lower\"\n\ -Lower triangular. If the optional third argument @var{perm} is given, the\n\ -matrix is assumed to be a permuted lower triangular with the permutations\n\ -defined by the vector @var{perm}.\n\ -\n\ -@item \"banded\"\n\ -@itemx \"banded positive definite\"\n\ -Banded matrix with the band size of @var{nl} below the diagonal and @var{nu}\n\ -above it. If @var{nl} and @var{nu} are 1, then the matrix is tridiagonal and\n\ -treated with specialized code. In addition the matrix can be marked as\n\ -probably a positive definite. (Sparse matrices only)\n\ -\n\ -@item \"singular\"\n\ -The matrix is assumed to be singular and will be treated with a minimum norm\n\ -solution.\n\ -\n\ -@end table\n\ -\n\ -Note that the matrix type will be discovered automatically on the first\n\ -attempt to solve a linear equation involving @var{A}. Therefore\n\ -@code{matrix_type} is only useful to give Octave hints of the matrix type.\n\ -Incorrectly defining the matrix type will result in incorrect results from\n\ -solutions of linear equations; it is entirely @strong{the responsibility of\n\ -the user} to correctly identify the matrix type.\n\ -\n\ -Also, the test for positive definiteness is a low-cost test for a Hermitian\n\ -matrix with a real positive diagonal. This does not guarantee that the\n\ -matrix is positive definite, but only that it is a probable candidate. When\n\ -such a matrix is factorized, a Cholesky@tie{}factorization is first\n\ -attempted, and if that fails the matrix is then treated with an\n\ -LU@tie{}factorization. Once the matrix has been factorized,\n\ -@code{matrix_type} will return the correct classification of the matrix.\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value retval; - - if (nargin == 0) - print_usage (); - else if (nargin > 4) - error ("matrix_type: incorrect number of arguments"); - else - { - bool autocomp = true; - if (nargin == 2 && args(1).is_string () && args(1).string_value () == "nocompute") - { - nargin = 1; - autocomp = false; - } - - if (args(0).is_scalar_type ()) - { - if (nargin == 1) - retval = octave_value ("Diagonal"); - else - retval = args(0); - } - else if (args(0).is_sparse_type ()) - { - if (nargin == 1) - { - MatrixType mattyp; - - if (args(0).is_complex_type ()) - { - mattyp = args(0).matrix_type (); - - if (mattyp.is_unknown () && autocomp ) - { - SparseComplexMatrix m = - args(0).sparse_complex_matrix_value (); - if (!error_state) - { - mattyp = MatrixType (m); - args(0).matrix_type (mattyp); - } - } - } - else - { - mattyp = args(0).matrix_type (); - - if (mattyp.is_unknown () && autocomp) - { - SparseMatrix m = args(0).sparse_matrix_value (); - if (!error_state) - { - mattyp = MatrixType (m); - args(0).matrix_type (mattyp); - } - } - } - - int typ = mattyp.type (); - - if (typ == MatrixType::Diagonal) - retval = octave_value ("Diagonal"); - else if (typ == MatrixType::Permuted_Diagonal) - retval = octave_value ("Permuted Diagonal"); - else if (typ == MatrixType::Upper) - retval = octave_value ("Upper"); - else if (typ == MatrixType::Permuted_Upper) - retval = octave_value ("Permuted Upper"); - else if (typ == MatrixType::Lower) - retval = octave_value ("Lower"); - else if (typ == MatrixType::Permuted_Lower) - retval = octave_value ("Permuted Lower"); - else if (typ == MatrixType::Banded) - retval = octave_value ("Banded"); - else if (typ == MatrixType::Banded_Hermitian) - retval = octave_value ("Banded Positive Definite"); - else if (typ == MatrixType::Tridiagonal) - retval = octave_value ("Tridiagonal"); - else if (typ == MatrixType::Tridiagonal_Hermitian) - retval = octave_value ("Tridiagonal Positive Definite"); - else if (typ == MatrixType::Hermitian) - retval = octave_value ("Positive Definite"); - else if (typ == MatrixType::Rectangular) - { - if (args(0).rows () == args(0).columns ()) - retval = octave_value ("Singular"); - else - retval = octave_value ("Rectangular"); - } - else if (typ == MatrixType::Full) - retval = octave_value ("Full"); - else - retval = octave_value ("Unknown"); - } - else - { - // Ok, we're changing the matrix type - std::string str_typ = args(1).string_value (); - - // FIXME -- why do I have to explicitly call the constructor? - MatrixType mattyp = MatrixType (); - - octave_idx_type nl = 0; - octave_idx_type nu = 0; - - if (error_state) - error ("matrix_type: TYPE must be a string"); - else - { - // Use STL function to convert to lower case - std::transform (str_typ.begin (), str_typ.end (), - str_typ.begin (), tolower); - - if (str_typ == "diagonal") - mattyp.mark_as_diagonal (); - if (str_typ == "permuted diagonal") - mattyp.mark_as_permuted_diagonal (); - else if (str_typ == "upper") - mattyp.mark_as_upper_triangular (); - else if (str_typ == "lower") - mattyp.mark_as_lower_triangular (); - else if (str_typ == "banded" || str_typ == "banded positive definite") - { - if (nargin != 4) - error ("matrix_type: banded matrix type requires 4 arguments"); - else - { - nl = args(2).nint_value (); - nu = args(3).nint_value (); - - if (error_state) - error ("matrix_type: band size NL, NU must be integers"); - else - { - if (nl == 1 && nu == 1) - mattyp.mark_as_tridiagonal (); - else - mattyp.mark_as_banded (nu, nl); - - if (str_typ == "banded positive definite") - mattyp.mark_as_symmetric (); - } - } - } - else if (str_typ == "positive definite") - { - mattyp.mark_as_full (); - mattyp.mark_as_symmetric (); - } - else if (str_typ == "singular") - mattyp.mark_as_rectangular (); - else if (str_typ == "full") - mattyp.mark_as_full (); - else if (str_typ == "unknown") - mattyp.invalidate_type (); - else - error ("matrix_type: Unknown matrix type %s", str_typ.c_str ()); - - if (! error_state) - { - if (nargin == 3 && (str_typ == "upper" || str_typ == "lower")) - { - const ColumnVector perm = - ColumnVector (args (2).vector_value ()); - - if (error_state) - error ("matrix_type: Invalid permutation vector PERM"); - else - { - octave_idx_type len = perm.length (); - dim_vector dv = args(0).dims (); - - if (len != dv(0)) - error ("matrix_type: Invalid permutation vector PERM"); - else - { - OCTAVE_LOCAL_BUFFER (octave_idx_type, p, len); - - for (octave_idx_type i = 0; i < len; i++) - p[i] = static_cast<octave_idx_type> (perm (i)) - 1; - - if (str_typ == "upper") - mattyp.mark_as_permuted (len, p); - else - mattyp.mark_as_permuted (len, p); - } - } - } - else if (nargin != 2 && str_typ != "banded positive definite" && - str_typ != "banded") - error ("matrix_type: Invalid number of arguments"); - - if (! error_state) - { - // Set the matrix type - if (args(0).is_complex_type ()) - retval = - octave_value (args(0).sparse_complex_matrix_value (), - mattyp); - else - retval = octave_value (args(0).sparse_matrix_value (), - mattyp); - } - } - } - } - } - else - { - if (nargin == 1) - { - MatrixType mattyp; - - if (args(0).is_complex_type ()) - { - mattyp = args(0).matrix_type (); - - if (mattyp.is_unknown () && autocomp) - { - if (args(0).is_single_type ()) - { - FloatComplexMatrix m = args(0).float_complex_matrix_value (); - if (!error_state) - { - mattyp = MatrixType (m); - args(0).matrix_type (mattyp); - } - } - else - { - ComplexMatrix m = args(0).complex_matrix_value (); - if (!error_state) - { - mattyp = MatrixType (m); - args(0).matrix_type (mattyp); - } - } - } - } - else - { - mattyp = args(0).matrix_type (); - - if (mattyp.is_unknown () && autocomp) - { - if (args(0).is_single_type ()) - { - FloatMatrix m = args(0).float_matrix_value (); - if (!error_state) - { - mattyp = MatrixType (m); - args(0).matrix_type (mattyp); - } - } - else - { - Matrix m = args(0).matrix_value (); - if (!error_state) - { - mattyp = MatrixType (m); - args(0).matrix_type (mattyp); - } - } - } - } - - int typ = mattyp.type (); - - if (typ == MatrixType::Upper) - retval = octave_value ("Upper"); - else if (typ == MatrixType::Permuted_Upper) - retval = octave_value ("Permuted Upper"); - else if (typ == MatrixType::Lower) - retval = octave_value ("Lower"); - else if (typ == MatrixType::Permuted_Lower) - retval = octave_value ("Permuted Lower"); - else if (typ == MatrixType::Hermitian) - retval = octave_value ("Positive Definite"); - else if (typ == MatrixType::Rectangular) - { - if (args(0).rows () == args(0).columns ()) - retval = octave_value ("Singular"); - else - retval = octave_value ("Rectangular"); - } - else if (typ == MatrixType::Full) - retval = octave_value ("Full"); - else - retval = octave_value ("Unknown"); - } - else - { - // Ok, we're changing the matrix type - std::string str_typ = args(1).string_value (); - - // FIXME -- why do I have to explicitly call the constructor? - MatrixType mattyp = MatrixType (MatrixType::Unknown, true); - - if (error_state) - error ("matrix_type: TYPE must be a string"); - else - { - // Use STL function to convert to lower case - std::transform (str_typ.begin (), str_typ.end (), - str_typ.begin (), tolower); - - if (str_typ == "upper") - mattyp.mark_as_upper_triangular (); - else if (str_typ == "lower") - mattyp.mark_as_lower_triangular (); - else if (str_typ == "positive definite") - { - mattyp.mark_as_full (); - mattyp.mark_as_symmetric (); - } - else if (str_typ == "singular") - mattyp.mark_as_rectangular (); - else if (str_typ == "full") - mattyp.mark_as_full (); - else if (str_typ == "unknown") - mattyp.invalidate_type (); - else - error ("matrix_type: Unknown matrix type %s", str_typ.c_str ()); - - if (! error_state) - { - if (nargin == 3 && (str_typ == "upper" - || str_typ == "lower")) - { - const ColumnVector perm = - ColumnVector (args (2).vector_value ()); - - if (error_state) - error ("matrix_type: Invalid permutation vector PERM"); - else - { - octave_idx_type len = perm.length (); - dim_vector dv = args(0).dims (); - - if (len != dv(0)) - error ("matrix_type: Invalid permutation vector PERM"); - else - { - OCTAVE_LOCAL_BUFFER (octave_idx_type, p, len); - - for (octave_idx_type i = 0; i < len; i++) - p[i] = static_cast<octave_idx_type> (perm (i)) - 1; - - if (str_typ == "upper") - mattyp.mark_as_permuted (len, p); - else - mattyp.mark_as_permuted (len, p); - } - } - } - else if (nargin != 2) - error ("matrix_type: Invalid number of arguments"); - - if (! error_state) - { - // Set the matrix type - if (args(0).is_single_type ()) - { - if (args(0).is_complex_type ()) - retval = octave_value - (args(0).float_complex_matrix_value (), - mattyp); - else - retval = octave_value - (args(0).float_matrix_value (), - mattyp); - } - else - { - if (args(0).is_complex_type ()) - retval = octave_value - (args(0).complex_matrix_value (), - mattyp); - else - retval = octave_value - (args(0).matrix_value (), - mattyp); - } - } - } - } - } - } - } - - return retval; -} - -/* -## FIXME: -## Disable tests for lower under-determined and upper over-determined -## matrices as this detection is disabled in MatrixType due to issues -## of non minimum norm solution being found. - -%!assert (matrix_type (speye (10,10)), "Diagonal") -%!assert (matrix_type (speye (10,10)([2:10,1],:)), "Permuted Diagonal") -%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1;sparse(9,1);1]]), "Upper") -%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1;sparse(9,1);1]](:,[2,1,3:11])), "Permuted Upper") -%!assert (matrix_type ([speye(10,10),sparse(10,1);1,sparse(1,9),1]), "Lower") -%!assert (matrix_type ([speye(10,10),sparse(10,1);1,sparse(1,9),1]([2,1,3:11],:)), "Permuted Lower") - -%!test -%! bnd = spparms ("bandden"); -%! spparms ("bandden", 0.5); -%! a = spdiags (rand (10,3)-0.5,[-1,0,1],10,10); -%! assert (matrix_type (a), "Tridiagonal"); -%! assert (matrix_type (a'+a+2*speye (10)), "Tridiagonal Positive Definite"); -%! spparms ("bandden", bnd); -%!test -%! bnd=spparms ("bandden"); -%! spparms ("bandden", 0.5); -%! a = spdiags (randn (10,4),[-2:1],10,10); -%! assert (matrix_type (a), "Banded"); -%! assert (matrix_type (a'*a), "Banded Positive Definite"); -%! spparms ("bandden", bnd); -%!test -%! a = [speye(10,10),[sparse(9,1);1];-1,sparse(1,9),1]; -%! assert (matrix_type (a), "Full"); -%! assert (matrix_type (a'*a), "Positive Definite"); - -%!assert (matrix_type (speye (10,11)), "Diagonal") -%!assert (matrix_type (speye (10,11)([2:10,1],:)), "Permuted Diagonal") -%!assert (matrix_type (speye (11,10)), "Diagonal") -%!assert (matrix_type (speye (11,10)([2:11,1],:)), "Permuted Diagonal") -%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1,1];sparse(9,2);[1,1]]]), "Upper") -%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1,1];sparse(9,2);[1,1]]](:,[2,1,3:12])), "Permuted Upper") -%!assert (matrix_type ([speye(11,9),[1;sparse(8,1);1;0]]), "Upper") -%!assert (matrix_type ([speye(11,9),[1;sparse(8,1);1;0]](:,[2,1,3:10])), "Permuted Upper") -%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1;1],sparse(2,9),[1;1]]), "Lower") -%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1;1],sparse(2,9),[1;1]]([2,1,3:12],:)), "Permuted Lower") -%!assert (matrix_type ([speye(9,11);[1,sparse(1,8),1,0]]), "Lower") -%!assert (matrix_type ([speye(9,11);[1,sparse(1,8),1,0]]([2,1,3:10],:)), "Permuted Lower") -%!assert (matrix_type (spdiags (randn (10,4),[-2:1],10,9)), "Rectangular") - -%!assert (matrix_type (1i*speye (10,10)), "Diagonal") -%!assert (matrix_type (1i*speye (10,10)([2:10,1],:)), "Permuted Diagonal") -%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1i;sparse(9,1);1]]), "Upper") -%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1i;sparse(9,1);1]](:,[2,1,3:11])), "Permuted Upper") -%!assert (matrix_type ([speye(10,10),sparse(10,1);1i,sparse(1,9),1]), "Lower") -%!assert (matrix_type ([speye(10,10),sparse(10,1);1i,sparse(1,9),1]([2,1,3:11],:)), "Permuted Lower") - -%!test -%! bnd = spparms ("bandden"); -%! spparms ("bandden", 0.5); -%! assert (matrix_type (spdiags (1i*randn (10,3),[-1,0,1],10,10)), "Tridiagonal"); -%! a = 1i*(rand (9,1)-0.5); -%! a = [[a;0],ones(10,1),[0;-a]]; -%! assert (matrix_type (spdiags (a,[-1,0,1],10,10)), "Tridiagonal Positive Definite"); -%! spparms ("bandden", bnd); -%!test -%! bnd = spparms ("bandden"); -%! spparms ("bandden", 0.5); -%! assert (matrix_type (spdiags (1i*randn (10,4),[-2:1],10,10)), "Banded"); -%! a = 1i*(rand (9,2)-0.5); -%! a = [[a;[0,0]],ones(10,1),[[0;-a(:,2)],[0;0;-a(1:8,1)]]]; -%! assert (matrix_type (spdiags (a,[-2:2],10,10)), "Banded Positive Definite"); -%! spparms ("bandden", bnd); -%!test -%! a = [speye(10,10),[sparse(9,1);1i];-1,sparse(1,9),1]; -%! assert (matrix_type (a), "Full"); -%! assert (matrix_type (a'*a), "Positive Definite"); - -%!assert (matrix_type (1i*speye (10,11)), "Diagonal") -%!assert (matrix_type (1i*speye (10,11)([2:10,1],:)), "Permuted Diagonal") -%!assert (matrix_type (1i*speye (11,10)), "Diagonal") -%!assert (matrix_type (1i*speye (11,10)([2:11,1],:)), "Permuted Diagonal") -%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1i,1i];sparse(9,2);[1i,1i]]]), "Upper") -%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1i,1i];sparse(9,2);[1i,1i]]](:,[2,1,3:12])), "Permuted Upper") -%!assert (matrix_type ([speye(11,9),[1i;sparse(8,1);1i;0]]), "Upper") -%!assert (matrix_type ([speye(11,9),[1i;sparse(8,1);1i;0]](:,[2,1,3:10])), "Permuted Upper") -%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1i;1i],sparse(2,9),[1i;1i]]), "Lower") -%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1i;1i],sparse(2,9),[1i;1i]]([2,1,3:12],:)), "Permuted Lower") -%!assert (matrix_type ([speye(9,11);[1i,sparse(1,8),1i,0]]), "Lower") -%!assert (matrix_type ([speye(9,11);[1i,sparse(1,8),1i,0]]([2,1,3:10],:)), "Permuted Lower") -%!assert (matrix_type (1i*spdiags(randn(10,4),[-2:1],10,9)), "Rectangular") - -%!test -%! a = matrix_type (spdiags (randn (10,3),[-1,0,1],10,10), "Singular"); -%! assert (matrix_type (a), "Singular"); - -%!assert (matrix_type (triu (ones(10,10))), "Upper") -%!assert (matrix_type (triu (ones(10,10),-1)), "Full") -%!assert (matrix_type (tril (ones(10,10))), "Lower") -%!assert (matrix_type (tril (ones(10,10),1)), "Full") -%!assert (matrix_type (10*eye (10,10) + ones (10,10)), "Positive Definite") -%!assert (matrix_type (ones (11,10)), "Rectangular") -%!test -%! a = matrix_type (ones (10,10), "Singular"); -%! assert (matrix_type (a), "Singular"); - -%!assert (matrix_type (triu (1i*ones (10,10))), "Upper") -%!assert (matrix_type (triu (1i*ones (10,10),-1)), "Full") -%!assert (matrix_type (tril (1i*ones (10,10))), "Lower") -%!assert (matrix_type (tril (1i*ones (10,10),1)), "Full") -%!assert (matrix_type (10*eye (10,10) + 1i*triu (ones (10,10),1) -1i*tril (ones (10,10),-1)), "Positive Definite") -%!assert (matrix_type (ones (11,10)), "Rectangular") -%!test -%! a = matrix_type (ones (10,10), "Singular"); -%! assert (matrix_type (a), "Singular"); -*/
--- a/src/DLD-FUNCTIONS/max.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,632 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton -Copyright (C) 2009 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "lo-ieee.h" -#include "lo-mappers.h" -#include "lo-math.h" -#include "dNDArray.h" -#include "CNDArray.h" -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" - -#include "ov-cx-mat.h" -#include "ov-re-sparse.h" -#include "ov-cx-sparse.h" - -template <class ArrayType> -static octave_value_list -do_minmax_red_op (const octave_value& arg, - int nargout, int dim, bool ismin) -{ - octave_value_list retval; - ArrayType array = octave_value_extract<ArrayType> (arg); - - if (error_state) - return retval; - - if (nargout == 2) - { - retval.resize (2); - Array<octave_idx_type> idx; - if (ismin) - retval(0) = array.min (idx, dim); - else - retval(0) = array.max (idx, dim); - - retval(1) = octave_value (idx, true, true); - } - else - { - if (ismin) - retval(0) = array.min (dim); - else - retval(0) = array.max (dim); - } - - return retval; -} - -// Specialization for bool arrays. -template <> -octave_value_list -do_minmax_red_op<boolNDArray> (const octave_value& arg, - int nargout, int dim, bool ismin) -{ - octave_value_list retval; - - if (nargout <= 1) - { - // This case can be handled using any/all. - boolNDArray array = arg.bool_array_value (); - - if (array.is_empty ()) - retval(0) = array; - else if (ismin) - retval(0) = array.all (dim); - else - retval(0) = array.any (dim); - } - else - { - // any/all don't have indexed versions, so do it via a conversion. - retval = do_minmax_red_op<int8NDArray> (arg, nargout, dim, ismin); - if (! error_state) - retval(0) = retval(0).bool_array_value (); - } - - return retval; -} - -template <class ArrayType> -static octave_value -do_minmax_bin_op (const octave_value& argx, const octave_value& argy, - bool ismin) -{ - typedef typename ArrayType::element_type ScalarType; - - octave_value retval; - - if (argx.is_scalar_type () == 1) - { - ScalarType x = octave_value_extract<ScalarType> (argx); - ArrayType y = octave_value_extract<ArrayType> (argy); - - if (error_state) - ; - else if (ismin) - retval = min (x, y); - else - retval = max (x, y); - } - else if (argy.is_scalar_type () == 1) - { - ArrayType x = octave_value_extract<ArrayType> (argx); - ScalarType y = octave_value_extract<ScalarType> (argy); - - if (error_state) - ; - else if (ismin) - retval = min (x, y); - else - retval = max (x, y); - } - else - { - ArrayType x = octave_value_extract<ArrayType> (argx); - ArrayType y = octave_value_extract<ArrayType> (argy); - - if (error_state) - ; - else if (ismin) - retval = min (x, y); - else - retval = max (x, y); - } - - return retval; -} - -static octave_value_list -do_minmax_body (const octave_value_list& args, - int nargout, bool ismin) -{ - octave_value_list retval; - - const char *func = ismin ? "min" : "max"; - - int nargin = args.length (); - - if (nargin == 3 || nargin == 1) - { - octave_value arg = args(0); - int dim = -1; - if (nargin == 3) - { - dim = args(2).int_value (true) - 1; - if (error_state || dim < 0) - { - error ("%s: DIM must be a valid dimension", func); - return retval; - } - - if (! args(1).is_empty ()) - warning ("%s: second argument is ignored", func); - } - - switch (arg.builtin_type ()) - { - case btyp_double: - { - if (arg.is_range () && (dim == -1 || dim == 1)) - { - Range range = arg.range_value (); - if (range.nelem () == 0) - { - retval(0) = arg; - if (nargout > 1) - retval(1) = arg; - } - else if (ismin) - { - retval(0) = range.min (); - if (nargout > 1) - retval(1) = static_cast<double> (range.inc () < 0 ? range.nelem () : 1); - } - else - { - retval(0) = range.max (); - if (nargout > 1) - retval(1) = static_cast<double> (range.inc () >= 0 ? range.nelem () : 1); - } - } - else if (arg.is_sparse_type ()) - retval = do_minmax_red_op<SparseMatrix> (arg, nargout, dim, ismin); - else - retval = do_minmax_red_op<NDArray> (arg, nargout, dim, ismin); - break; - } - case btyp_complex: - { - if (arg.is_sparse_type ()) - retval = do_minmax_red_op<SparseComplexMatrix> (arg, nargout, dim, ismin); - else - retval = do_minmax_red_op<ComplexNDArray> (arg, nargout, dim, ismin); - break; - } - case btyp_float: - retval = do_minmax_red_op<FloatNDArray> (arg, nargout, dim, ismin); - break; - case btyp_float_complex: - retval = do_minmax_red_op<FloatComplexNDArray> (arg, nargout, dim, ismin); - break; -#define MAKE_INT_BRANCH(X) \ - case btyp_ ## X: \ - retval = do_minmax_red_op<X ## NDArray> (arg, nargout, dim, ismin); \ - break; - MAKE_INT_BRANCH (int8); - MAKE_INT_BRANCH (int16); - MAKE_INT_BRANCH (int32); - MAKE_INT_BRANCH (int64); - MAKE_INT_BRANCH (uint8); - MAKE_INT_BRANCH (uint16); - MAKE_INT_BRANCH (uint32); - MAKE_INT_BRANCH (uint64); -#undef MAKE_INT_BRANCH - case btyp_bool: - retval = do_minmax_red_op<boolNDArray> (arg, nargout, dim, ismin); - break; - default: - gripe_wrong_type_arg (func, arg); - } - } - else if (nargin == 2) - { - octave_value argx = args(0), argy = args(1); - builtin_type_t xtyp = argx.builtin_type (), ytyp = argy.builtin_type (); - builtin_type_t rtyp = btyp_mixed_numeric (xtyp, ytyp); - - switch (rtyp) - { - case btyp_double: - { - if ((argx.is_sparse_type () - && (argy.is_sparse_type () || argy.is_scalar_type ())) - || (argy.is_sparse_type () && argx.is_scalar_type ())) - retval = do_minmax_bin_op<SparseMatrix> (argx, argy, ismin); - else - retval = do_minmax_bin_op<NDArray> (argx, argy, ismin); - break; - } - case btyp_complex: - { - if ((argx.is_sparse_type () - && (argy.is_sparse_type () || argy.is_scalar_type ())) - || (argy.is_sparse_type () && argx.is_scalar_type ())) - retval = do_minmax_bin_op<SparseComplexMatrix> (argx, argy, ismin); - else - retval = do_minmax_bin_op<ComplexNDArray> (argx, argy, ismin); - break; - } - case btyp_float: - retval = do_minmax_bin_op<FloatNDArray> (argx, argy, ismin); - break; - case btyp_float_complex: - retval = do_minmax_bin_op<FloatComplexNDArray> (argx, argy, ismin); - break; -#define MAKE_INT_BRANCH(X) \ - case btyp_ ## X: \ - retval = do_minmax_bin_op<X ## NDArray> (argx, argy, ismin); \ - break; - MAKE_INT_BRANCH (int8); - MAKE_INT_BRANCH (int16); - MAKE_INT_BRANCH (int32); - MAKE_INT_BRANCH (int64); - MAKE_INT_BRANCH (uint8); - MAKE_INT_BRANCH (uint16); - MAKE_INT_BRANCH (uint32); - MAKE_INT_BRANCH (uint64); -#undef MAKE_INT_BRANCH - default: - error ("%s: cannot compute %s (%s, %s)", func, func, - argx.type_name ().c_str (), argy.type_name ().c_str ()); - } - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (min, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} min (@var{x})\n\ -@deftypefnx {Loadable Function} {} min (@var{x}, @var{y})\n\ -@deftypefnx {Loadable Function} {} min (@var{x}, [], @var{dim})\n\ -@deftypefnx {Loadable Function} {} min (@var{x}, @var{y}, @var{dim})\n\ -@deftypefnx {Loadable Function} {[@var{w}, @var{iw}] =} min (@var{x})\n\ -For a vector argument, return the minimum value. For a matrix\n\ -argument, return the minimum value from each column, as a row\n\ -vector, or over the dimension @var{dim} if defined, in which case @var{y} \n\ -should be set to the empty matrix (it's ignored otherwise). For two matrices\n\ -(or a matrix and scalar), return the pair-wise minimum.\n\ -Thus,\n\ -\n\ -@example\n\ -min (min (@var{x}))\n\ -@end example\n\ -\n\ -@noindent\n\ -returns the smallest element of @var{x}, and\n\ -\n\ -@example\n\ -@group\n\ -min (2:5, pi)\n\ - @result{} 2.0000 3.0000 3.1416 3.1416\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -compares each element of the range @code{2:5} with @code{pi}, and\n\ -returns a row vector of the minimum values.\n\ -\n\ -For complex arguments, the magnitude of the elements are used for\n\ -comparison.\n\ -\n\ -If called with one input and two output arguments,\n\ -@code{min} also returns the first index of the\n\ -minimum value(s). Thus,\n\ -\n\ -@example\n\ -@group\n\ -[x, ix] = min ([1, 3, 0, 2, 0])\n\ - @result{} x = 0\n\ - ix = 3\n\ -@end group\n\ -@end example\n\ -@seealso{max, cummin, cummax}\n\ -@end deftypefn") -{ - return do_minmax_body (args, nargout, true); -} - -/* -%!assert (min ([1, 4, 2, 3]), 1) -%!assert (min ([1; -10; 5; -2]), -10) -%!assert (min ([4, i; -2, 2]), [-2, i]) - -%!test -%! x = reshape (1:8, [2,2,2]); -%! assert (max (x, [], 1), reshape ([2, 4, 6, 8], [1,2,2])); -%! assert (max (x, [], 2), reshape ([3, 4, 7, 8], [2,1,2])); -%! [y, i] = max (x, [], 3); -%! assert (ndims (y), 2); -%! assert (y, [5, 7; 6, 8]); -%! assert (ndims (i), 2); -%! assert (i, [2, 2; 2, 2]); - -%!error min () -%!error min (1, 2, 3, 4) -*/ - -DEFUN_DLD (max, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} max (@var{x})\n\ -@deftypefnx {Loadable Function} {} max (@var{x}, @var{y})\n\ -@deftypefnx {Loadable Function} {} max (@var{x}, [], @var{dim})\n\ -@deftypefnx {Loadable Function} {} max (@var{x}, @var{y}, @var{dim})\n\ -@deftypefnx {Loadable Function} {[@var{w}, @var{iw}] =} max (@var{x})\n\ -For a vector argument, return the maximum value. For a matrix\n\ -argument, return the maximum value from each column, as a row\n\ -vector, or over the dimension @var{dim} if defined, in which case @var{y} \n\ -should be set to the empty matrix (it's ignored otherwise). For two matrices\n\ -(or a matrix and scalar), return the pair-wise maximum.\n\ -Thus,\n\ -\n\ -@example\n\ -max (max (@var{x}))\n\ -@end example\n\ -\n\ -@noindent\n\ -returns the largest element of the matrix @var{x}, and\n\ -\n\ -@example\n\ -@group\n\ -max (2:5, pi)\n\ - @result{} 3.1416 3.1416 4.0000 5.0000\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -compares each element of the range @code{2:5} with @code{pi}, and\n\ -returns a row vector of the maximum values.\n\ -\n\ -For complex arguments, the magnitude of the elements are used for\n\ -comparison.\n\ -\n\ -If called with one input and two output arguments,\n\ -@code{max} also returns the first index of the\n\ -maximum value(s). Thus,\n\ -\n\ -@example\n\ -@group\n\ -[x, ix] = max ([1, 3, 5, 2, 5])\n\ - @result{} x = 5\n\ - ix = 3\n\ -@end group\n\ -@end example\n\ -@seealso{min, cummax, cummin}\n\ -@end deftypefn") -{ - return do_minmax_body (args, nargout, false); -} - -/* -%!assert (max ([1, 4, 2, 3]), 4) -%!assert (max ([1; -10; 5; -2]), 5) -%!assert (max ([4, i 4.999; -2, 2, 3+4i]), [4, 2, 3+4i]) - -%!test -%! x = reshape (1:8, [2,2,2]); -%! assert (min (x, [], 1), reshape ([1, 3, 5, 7], [1,2,2])); -%! assert (min (x, [], 2), reshape ([1, 2, 5, 6], [2,1,2])); -%! [y, i] = min (x, [], 3); -%! assert (ndims(y), 2); -%! assert (y, [1, 3; 2, 4]); -%! assert (ndims(i), 2); -%! assert (i, [1, 1; 1, 1]); - -%!error max () -%!error max (1, 2, 3, 4) -*/ - -template <class ArrayType> -static octave_value_list -do_cumminmax_red_op (const octave_value& arg, - int nargout, int dim, bool ismin) -{ - octave_value_list retval; - ArrayType array = octave_value_extract<ArrayType> (arg); - - if (error_state) - return retval; - - if (nargout == 2) - { - retval.resize (2); - Array<octave_idx_type> idx; - if (ismin) - retval(0) = array.cummin (idx, dim); - else - retval(0) = array.cummax (idx, dim); - - retval(1) = octave_value (idx, true, true); - } - else - { - if (ismin) - retval(0) = array.cummin (dim); - else - retval(0) = array.cummax (dim); - } - - return retval; -} - -static octave_value_list -do_cumminmax_body (const octave_value_list& args, - int nargout, bool ismin) -{ - octave_value_list retval; - - const char *func = ismin ? "cummin" : "cummax"; - - int nargin = args.length (); - - if (nargin == 1 || nargin == 2) - { - octave_value arg = args(0); - int dim = -1; - if (nargin == 2) - { - dim = args(1).int_value (true) - 1; - if (error_state || dim < 0) - { - error ("%s: DIM must be a valid dimension", func); - return retval; - } - } - - switch (arg.builtin_type ()) - { - case btyp_double: - retval = do_cumminmax_red_op<NDArray> (arg, nargout, dim, ismin); - break; - case btyp_complex: - retval = do_cumminmax_red_op<ComplexNDArray> (arg, nargout, dim, ismin); - break; - case btyp_float: - retval = do_cumminmax_red_op<FloatNDArray> (arg, nargout, dim, ismin); - break; - case btyp_float_complex: - retval = do_cumminmax_red_op<FloatComplexNDArray> (arg, nargout, dim, ismin); - break; -#define MAKE_INT_BRANCH(X) \ - case btyp_ ## X: \ - retval = do_cumminmax_red_op<X ## NDArray> (arg, nargout, dim, ismin); \ - break; - MAKE_INT_BRANCH (int8); - MAKE_INT_BRANCH (int16); - MAKE_INT_BRANCH (int32); - MAKE_INT_BRANCH (int64); - MAKE_INT_BRANCH (uint8); - MAKE_INT_BRANCH (uint16); - MAKE_INT_BRANCH (uint32); - MAKE_INT_BRANCH (uint64); -#undef MAKE_INT_BRANCH - case btyp_bool: - { - retval = do_cumminmax_red_op<int8NDArray> (arg, nargout, dim, ismin); - if (retval.length () > 0) - retval(0) = retval(0).bool_array_value (); - break; - } - default: - gripe_wrong_type_arg (func, arg); - } - } - else - print_usage (); - - return retval; -} - -DEFUN_DLD (cummin, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} cummin (@var{x})\n\ -@deftypefnx {Loadable Function} {} cummin (@var{x}, @var{dim})\n\ -@deftypefnx {Loadable Function} {[@var{w}, @var{iw}] =} cummin (@var{x})\n\ -Return the cumulative minimum values along dimension @var{dim}. If @var{dim}\n\ -is unspecified it defaults to column-wise operation. For example:\n\ -\n\ -@example\n\ -@group\n\ -cummin ([5 4 6 2 3 1])\n\ - @result{} 5 4 4 2 2 1\n\ -@end group\n\ -@end example\n\ -\n\ -\n\ -The call\n\ -\n\ -@example\n\ - [w, iw] = cummin (x)\n\ -@end example\n\ -\n\ -@noindent\n\ -with @code{x} a vector, is equivalent to the following code:\n\ -\n\ -@example\n\ -@group\n\ -w = iw = zeros (size (x));\n\ -for i = 1:length (x)\n\ - [w(i), iw(i)] = max (x(1:i));\n\ -endfor\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -but computed in a much faster manner.\n\ -@seealso{cummax, min, max}\n\ -@end deftypefn") -{ - return do_cumminmax_body (args, nargout, true); -} - -DEFUN_DLD (cummax, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} cummax (@var{x})\n\ -@deftypefnx {Loadable Function} {} cummax (@var{x}, @var{dim})\n\ -@deftypefnx {Loadable Function} {[@var{w}, @var{iw}] =} cummax (@var{x})\n\ -Return the cumulative maximum values along dimension @var{dim}. If @var{dim}\n\ -is unspecified it defaults to column-wise operation. For example:\n\ -\n\ -@example\n\ -@group\n\ -cummax ([1 3 2 6 4 5])\n\ - @result{} 1 3 3 6 6 6\n\ -@end group\n\ -@end example\n\ -\n\ -The call\n\ -\n\ -@example\n\ -[w, iw] = cummax (x, dim)\n\ -@end example\n\ -\n\ -@noindent\n\ -with @code{x} a vector, is equivalent to the following code:\n\ -\n\ -@example\n\ -@group\n\ -w = iw = zeros (size (x));\n\ -for i = 1:length (x)\n\ - [w(i), iw(i)] = max (x(1:i));\n\ -endfor\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -but computed in a much faster manner.\n\ -@seealso{cummin, max, min}\n\ -@end deftypefn") -{ - return do_cumminmax_body (args, nargout, false); -}
--- a/src/DLD-FUNCTIONS/md5sum.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,101 +0,0 @@ -/* - -Copyright (C) 2007-2012 David Bateman - - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> -#include <vector> - -#include "defun-dld.h" -#include "file-stat.h" -#include "file-ops.h" -#include "gripes.h" -#include "load-path.h" -#include "oct-env.h" -#include "oct-md5.h" - -DEFUN_DLD (md5sum, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} md5sum (@var{file})\n\ -@deftypefnx {Loadable Function} {} md5sum (@var{str}, @var{opt})\n\ -Calculate the MD5 sum of the file @var{file}. If the second parameter\n\ -@var{opt} exists and is true, then calculate the MD5 sum of the\n\ -string @var{str}.\n\ -@end deftypefn") -{ - octave_value retval; - int nargin = args.length (); - - if (nargin != 1 && nargin != 2) - print_usage (); - else - { - bool have_str = false; - std::string str = args(0).string_value (); - - if (nargin == 2) - have_str = args(1).bool_value (); - - if (!error_state) - { - if (have_str) - retval = oct_md5 (str); - else - { - file_stat fs (str); - - if (! fs.exists ()) - { - std::string tmp - = octave_env::make_absolute (load_path::find_file (str)); - - if (! tmp.empty ()) - { - warning_with_id ("Octave:md5sum-file-in-path", - "md5sum: file found in load path"); - str = tmp; - } - } - - retval = oct_md5_file (str); - } - } - } - - return retval; -} - -/* -%!assert (md5sum ("abc\0", true), "147a664a2ca9410911e61986d3f0d52a"); - -%!test -%! tfile = tmpnam (); -%! fid = fopen (tfile, "wb"); -%! fwrite (fid, "abc\0"); -%! fclose (fid); -%! assert (md5sum (tfile), "147a664a2ca9410911e61986d3f0d52a"); -%! unlink (tfile); -*/ -
--- a/src/DLD-FUNCTIONS/mgorth.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,154 +0,0 @@ -/* - -Copyright (C) 2009-2012 Carlo de Falco -Copyright (C) 2010 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "oct-norm.h" -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" - -template <class ColumnVector, class Matrix, class RowVector> -static void -do_mgorth (ColumnVector& x, const Matrix& V, RowVector& h) -{ - octave_idx_type Vc = V.columns (); - h = RowVector (Vc + 1); - for (octave_idx_type j = 0; j < Vc; j++) - { - ColumnVector Vcj = V.column (j); - h(j) = RowVector (Vcj.hermitian ()) * x; - x -= h(j) * Vcj; - } - - h(Vc) = xnorm (x); - if (real (h(Vc)) > 0) - x = x / h(Vc); -} - -DEFUN_DLD (mgorth, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{y}, @var{h}] =} mgorth (@var{x}, @var{v})\n\ -Orthogonalize a given column vector @var{x} with respect to a given\n\ -orthonormal basis @var{v} using a modified Gram-Schmidt orthogonalization. \n\ -On exit, @var{y} is a unit vector such that:\n\ -\n\ -@example\n\ -@group\n\ - norm (@var{y}) = 1\n\ - @var{v}' * @var{y} = 0\n\ - @var{x} = @var{h}*[@var{v}, @var{y}]\n\ -@end group\n\ -@end example\n\ -\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin != 2 || nargout > 2) - { - print_usage (); - return retval; - } - - octave_value arg_x = args(0); - octave_value arg_v = args(1); - - if (arg_v.ndims () != 2 || arg_x.ndims () != 2 || arg_x.columns () != 1 - || arg_v.rows () != arg_x.rows ()) - { - error ("mgorth: V should me a matrix, and X a column vector with" - " the same number of rows as V."); - return retval; - } - - if (! arg_x.is_numeric_type () && ! arg_v.is_numeric_type ()) - { - error ("mgorth: X and V must be numeric"); - } - - bool iscomplex = (arg_x.is_complex_type () || arg_v.is_complex_type ()); - if (arg_x.is_single_type () || arg_v.is_single_type ()) - { - if (iscomplex) - { - FloatComplexColumnVector x = arg_x.float_complex_column_vector_value (); - FloatComplexMatrix V = arg_v.float_complex_matrix_value (); - FloatComplexRowVector h; - do_mgorth (x, V, h); - retval(1) = h; - retval(0) = x; - } - else - { - FloatColumnVector x = arg_x.float_column_vector_value (); - FloatMatrix V = arg_v.float_matrix_value (); - FloatRowVector h; - do_mgorth (x, V, h); - retval(1) = h; - retval(0) = x; - } - } - else - { - if (iscomplex) - { - ComplexColumnVector x = arg_x.complex_column_vector_value (); - ComplexMatrix V = arg_v.complex_matrix_value (); - ComplexRowVector h; - do_mgorth (x, V, h); - retval(1) = h; - retval(0) = x; - } - else - { - ColumnVector x = arg_x.column_vector_value (); - Matrix V = arg_v.matrix_value (); - RowVector h; - do_mgorth (x, V, h); - retval(1) = h; - retval(0) = x; - } - } - - return retval; -} - -/* -%!test -%! for ii=1:100 -%! assert (abs (mgorth (randn (5, 1), eye (5, 4))), [0 0 0 0 1]', eps); -%! endfor - -%!test -%! a = hilb (5); -%! a(:, 1) /= norm (a(:, 1)); -%! for ii = 1:5 -%! a(:, ii) = mgorth (a(:, ii), a(:, 1:ii-1)); -%! endfor -%! assert (a' * a, eye (5), 1e10); -*/
--- a/src/DLD-FUNCTIONS/module-files Sat Jul 28 15:17:57 2012 +0200 +++ b/src/DLD-FUNCTIONS/module-files Sat Jul 28 12:06:34 2012 -0400 @@ -1,83 +1,22 @@ # FILE|CPPFLAGS|LDFLAGS|LIBRARIES -__contourc__.cc +chol.cc __delaunayn__.cc|$(QHULL_CPPFLAGS)|$(QHULL_LDFLAGS)|$(QHULL_LIBS) -__dispatch__.cc __dsearchn__.cc __fltk_uigetfile__.cc|$(GRAPHICS_CFLAGS) $(FT2_CPPFLAGS)|$(GRAPHICS_LDFLAGS) $(FT2_LDFLAGS)|$(GRAPHICS_LIBS) $(FT2_LIBS) __glpk__.cc|$(GLPK_CPPFLAGS)|$(GLPK_LDFLAGS)|$(GLPK_LIBS) __init_fltk__.cc|$(GRAPHICS_CFLAGS) $(FT2_CPPFLAGS)|$(GRAPHICS_LDFLAGS) $(FT2_LDFLAGS)|$(GRAPHICS_LIBS) $(FT2_LIBS) __init_gnuplot__.cc -__lin_interpn__.cc __magick_read__.cc|$(MAGICK_CPPFLAGS)|$(MAGICK_LDFLAGS)|$(MAGICK_LIBS) -__pchip_deriv__.cc -__qp__.cc __voronoi__.cc|$(QHULL_CPPFLAGS)|$(QHULL_LDFLAGS)|$(QHULL_LIBS) amd.cc|$(SPARSE_XCPPFLAGS)|$(SPARSE_XLDFLAGS)|$(SPARSE_XLIBS) -balance.cc -besselj.cc -betainc.cc -bsxfun.cc ccolamd.cc|$(SPARSE_XCPPFLAGS)|$(SPARSE_XLDFLAGS)|$(SPARSE_XLIBS) -cellfun.cc -chol.cc|$(QRUPDATE_CPPFLAGS) $(SPARSE_XCPPFLAGS)|$(QRUPDATE_LDFLAGS) $(SPARSE_XLDFLAGS)|$(QRUPDATE_LIBS) $(SPARSE_XLIBS) colamd.cc|$(SPARSE_XCPPFLAGS)|$(SPARSE_XLDFLAGS)|$(SPARSE_XLIBS) -colloc.cc -conv2.cc convhulln.cc|$(QHULL_CPPFLAGS)|$(QHULL_LDFLAGS)|$(QHULL_LIBS) -daspk.cc -dasrt.cc -dassl.cc -det.cc -dlmread.cc dmperm.cc|$(SPARSE_XCPPFLAGS)|$(SPARSE_XLDFLAGS)|$(SPARSE_XLIBS) -dot.cc -eig.cc eigs.cc|$(ARPACK_CPPFLAGS) $(SPARSE_XCPPFLAGS)|$(ARPACK_LDFLAGS) $(SPARSE_XLDFLAGS)|$(ARPACK_LIBS) $(SPARSE_XLIBS) $(LAPACK_LIBS) $(BLAS_LIBS) -fft.cc|$(FFTW_XCPPFLAGS)|$(FFTW_XLDFLAGS)|$(FFTW_XLIBS) -fft2.cc|$(FFTW_XCPPFLAGS)|$(FFTW_XLDFLAGS)|$(FFTW_XLIBS) -fftn.cc|$(FFTW_XCPPFLAGS)|$(FFTW_XLDFLAGS)|$(FFTW_XLIBS) fftw.cc|$(FFTW_XCPPFLAGS)|$(FFTW_XLDFLAGS)|$(FFTW_XLIBS) -filter.cc -find.cc -gammainc.cc -gcd.cc -getgrent.cc -getpwent.cc -getrusage.cc -givens.cc -hess.cc -hex2num.cc -inv.cc -kron.cc -lookup.cc -lsode.cc -lu.cc -luinc.cc -matrix_type.cc -max.cc -md5sum.cc -mgorth.cc -nproc.cc -pinv.cc qr.cc|$(QRUPDATE_CPPFLAGS) $(SPARSE_XCPPFLAGS)|$(QRUPDATE_LDFLAGS) $(SPARSE_XLDFLAGS)|$(QRUPDATE_LIBS) $(SPARSE_XLIBS) -quad.cc -quadcc.cc -qz.cc|||$(LAPACK_LIBS) $(BLAS_LIBS) -rand.cc -rcond.cc -regexp.cc|$(REGEX_CPPFLAGS)|$(REGEX_LDFLAGS)|$(REGEX_LIBS) -schur.cc -spparms.cc -sqrtm.cc -strfind.cc -str2double.cc -sub2ind.cc -svd.cc -syl.cc symbfact.cc|$(SPARSE_XCPPFLAGS)|$(SPARSE_XLDFLAGS)|$(SPARSE_XLIBS) symrcm.cc|$(SPARSE_XCPPFLAGS)|$(SPARSE_XLDFLAGS)|$(SPARSE_XLIBS) -time.cc -tril.cc tsearch.cc -typecast.cc urlwrite.cc|$(CURL_CPPFLAGS)|$(CURL_LDFLAGS)|$(CURL_LIBS)
--- a/src/DLD-FUNCTIONS/nproc.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,90 +0,0 @@ -/* - -Copyright (C) 2012 Iain Murray - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "nproc.h" - -DEFUN_DLD (nproc, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} nproc ()\n\ -@deftypefnx {Loadable Function} {} nproc (@var{query})\n\ -Return the current number of available processors.\n\ -\n\ -If called with the optional argument @var{query}, modify how processors\n\ -are counted as follows:\n\ -\n\ -@table @code\n\ -@item all\n\ -total number of processors.\n\ -\n\ -@item current\n\ -processors available to the current process.\n\ -\n\ -@item overridable\n\ -likewise, but overridable through the @w{@env{OMP_NUM_THREADS}} environment\n\ -variable.\n\ -@end table\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if ((nargin != 0 && nargin != 1) || (nargout != 0 && nargout != 1)) - { - print_usage (); - return retval; - } - - nproc_query query = NPROC_CURRENT; - if (nargin == 1) - { - std::string arg = args(0).string_value (); - - std::transform (arg.begin (), arg.end (), arg.begin (), tolower); - - if (arg == "all") - query = NPROC_ALL; - else if (arg == "current") - query = NPROC_CURRENT; - else if (arg == "overridable") - query = NPROC_CURRENT_OVERRIDABLE; - else - { - error ("nproc: invalid value for QUERY"); - return retval; - } - } - - retval = num_processors (query); - - return retval; -} - -/* -## Must always report at least 1 cpu available -%!assert (nproc () >= 1); -*/
--- a/src/DLD-FUNCTIONS/pinv.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" -#include "ops.h" -#include "ov-re-diag.h" -#include "ov-cx-diag.h" -#include "ov-flt-re-diag.h" -#include "ov-flt-cx-diag.h" -#include "ov-perm.h" - -DEFUN_DLD (pinv, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} pinv (@var{x})\n\ -@deftypefnx {Loadable Function} {} pinv (@var{x}, @var{tol})\n\ -Return the pseudoinverse of @var{x}. Singular values less than\n\ -@var{tol} are ignored.\n\ -\n\ -If the second argument is omitted, it is taken to be\n\ -\n\ -@example\n\ -tol = max (size (@var{x})) * sigma_max (@var{x}) * eps,\n\ -@end example\n\ -\n\ -@noindent\n\ -where @code{sigma_max (@var{x})} is the maximal singular value of @var{x}.\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 2) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - - int arg_is_empty = empty_arg ("pinv", arg.rows (), arg.columns ()); - - if (arg_is_empty < 0) - return retval; - else if (arg_is_empty > 0) - return octave_value (Matrix ()); - - bool isfloat = arg.is_single_type (); - - if (arg.is_diag_matrix ()) - { - if (nargin == 2) - warning ("pinv: tol is ignored for diagonal matrices"); - - if (arg.is_complex_type ()) - { - if (isfloat) - retval = arg.float_complex_diag_matrix_value ().pseudo_inverse (); - else - retval = arg.complex_diag_matrix_value ().pseudo_inverse (); - } - else - { - if (isfloat) - retval = arg.float_diag_matrix_value ().pseudo_inverse (); - else - retval = arg.diag_matrix_value ().pseudo_inverse (); - } - } - else if (arg.is_perm_matrix ()) - { - retval = arg.perm_matrix_value ().inverse (); - } - else if (isfloat) - { - float tol = 0.0; - if (nargin == 2) - tol = args(1).float_value (); - - if (error_state) - return retval; - - if (tol < 0.0) - { - error ("pinv: TOL must be greater than zero"); - return retval; - } - - if (arg.is_real_type ()) - { - FloatMatrix m = arg.float_matrix_value (); - - if (! error_state) - retval = m.pseudo_inverse (tol); - } - else if (arg.is_complex_type ()) - { - FloatComplexMatrix m = arg.float_complex_matrix_value (); - - if (! error_state) - retval = m.pseudo_inverse (tol); - } - else - { - gripe_wrong_type_arg ("pinv", arg); - } - } - else - { - double tol = 0.0; - if (nargin == 2) - tol = args(1).double_value (); - - if (error_state) - return retval; - - if (tol < 0.0) - { - error ("pinv: TOL must be greater than zero"); - return retval; - } - - if (arg.is_real_type ()) - { - Matrix m = arg.matrix_value (); - - if (! error_state) - retval = m.pseudo_inverse (tol); - } - else if (arg.is_complex_type ()) - { - ComplexMatrix m = arg.complex_matrix_value (); - - if (! error_state) - retval = m.pseudo_inverse (tol); - } - else - { - gripe_wrong_type_arg ("pinv", arg); - } - } - - return retval; -} - -/* -%!shared a, b, tol, hitol, d, u, x, y -%! a = reshape (rand*[1:16], 4, 4); ## Rank 2 matrix -%! b = pinv (a); -%! tol = 4e-14; -%! hitol = 40*sqrt (eps); -%! d = diag ([rand, rand, hitol, hitol]); -%! u = rand (4); ## Could be singular by freak accident -%! x = inv (u)*d*u; -%! y = pinv (x, sqrt (eps)); -%! -%!assert (a*b*a, a, tol) -%!assert (b*a*b, b, tol) -%!assert ((b*a)', b*a, tol) -%!assert ((a*b)', a*b, tol) -%!assert (x*y*x, x, -hitol) -%!assert (y*x*y, y, -hitol) -%!assert ((x*y)', x*y, hitol) -%!assert ((y*x)', y*x, hitol) -*/
--- a/src/DLD-FUNCTIONS/quad.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,518 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include <iomanip> -#include <iostream> - -#include "Quad.h" -#include "lo-mappers.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "pager.h" -#include "oct-obj.h" -#include "ov-fcn.h" -#include "unwind-prot.h" -#include "utils.h" -#include "variables.h" - -#include "Quad-opts.cc" - -#if defined (quad) -#undef quad -#endif - -// Global pointer for user defined function required by quadrature functions. -static octave_function *quad_fcn; - -// Have we warned about imaginary values returned from user function? -static bool warned_imaginary = false; - -// Is this a recursive call? -static int call_depth = 0; - -double -quad_user_function (double x) -{ - double retval = 0.0; - - octave_value_list args; - args(0) = x; - - if (quad_fcn) - { - octave_value_list tmp = quad_fcn->do_multi_index_op (1, args); - - if (error_state) - { - quad_integration_error = 1; // FIXME - gripe_user_supplied_eval ("quad"); - return retval; - } - - if (tmp.length () && tmp(0).is_defined ()) - { - if (! warned_imaginary && tmp(0).is_complex_type ()) - { - warning ("quad: ignoring imaginary part returned from user-supplied function"); - warned_imaginary = true; - } - - retval = tmp(0).double_value (); - - if (error_state) - { - quad_integration_error = 1; // FIXME - gripe_user_supplied_eval ("quad"); - } - } - else - { - quad_integration_error = 1; // FIXME - gripe_user_supplied_eval ("quad"); - } - } - - return retval; -} - -float -quad_float_user_function (float x) -{ - float retval = 0.0; - - octave_value_list args; - args(0) = x; - - if (quad_fcn) - { - octave_value_list tmp = quad_fcn->do_multi_index_op (1, args); - - if (error_state) - { - quad_integration_error = 1; // FIXME - gripe_user_supplied_eval ("quad"); - return retval; - } - - if (tmp.length () && tmp(0).is_defined ()) - { - if (! warned_imaginary && tmp(0).is_complex_type ()) - { - warning ("quad: ignoring imaginary part returned from user-supplied function"); - warned_imaginary = true; - } - - retval = tmp(0).float_value (); - - if (error_state) - { - quad_integration_error = 1; // FIXME - gripe_user_supplied_eval ("quad"); - } - } - else - { - quad_integration_error = 1; // FIXME - gripe_user_supplied_eval ("quad"); - } - } - - return retval; -} - -#define QUAD_ABORT() \ - do \ - { \ - if (fcn_name.length ()) \ - clear_function (fcn_name); \ - return retval; \ - } \ - while (0) - -#define QUAD_ABORT1(msg) \ - do \ - { \ - ::error ("quad: " msg); \ - QUAD_ABORT (); \ - } \ - while (0) - -#define QUAD_ABORT2(fmt, arg) \ - do \ - { \ - ::error ("quad: " fmt, arg); \ - QUAD_ABORT (); \ - } \ - while (0) - -DEFUN_DLD (quad, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{q} =} quad (@var{f}, @var{a}, @var{b})\n\ -@deftypefnx {Loadable Function} {@var{q} =} quad (@var{f}, @var{a}, @var{b}, @var{tol})\n\ -@deftypefnx {Loadable Function} {@var{q} =} quad (@var{f}, @var{a}, @var{b}, @var{tol}, @var{sing})\n\ -@deftypefnx {Loadable Function} {[@var{q}, @var{ier}, @var{nfun}, @var{err}] =} quad (@dots{})\n\ -Numerically evaluate the integral of @var{f} from @var{a} to @var{b} using\n\ -Fortran routines from @w{@sc{quadpack}}. @var{f} is a function handle,\n\ -inline function, or a string containing the name of the function to\n\ -evaluate. The function must have the form @code{y = f (x)} where @var{y} and\n\ -@var{x} are scalars.\n\ -\n\ -@var{a} and @var{b} are the lower and upper limits of integration. Either\n\ -or both may be infinite.\n\ -\n\ -The optional argument @var{tol} is a vector that specifies the desired\n\ -accuracy of the result. The first element of the vector is the desired\n\ -absolute tolerance, and the second element is the desired relative\n\ -tolerance. To choose a relative test only, set the absolute\n\ -tolerance to zero. To choose an absolute test only, set the relative\n\ -tolerance to zero. Both tolerances default to @code{sqrt (eps)} or\n\ -approximately @math{1.5e^{-8}}.\n\ -\n\ -The optional argument @var{sing} is a vector of values at which the\n\ -integrand is known to be singular.\n\ -\n\ -The result of the integration is returned in @var{q}. @var{ier}\n\ -contains an integer error code (0 indicates a successful integration).\n\ -@var{nfun} indicates the number of function evaluations that were\n\ -made, and @var{err} contains an estimate of the error in the\n\ -solution.\n\ -\n\ -The function @code{quad_options} can set other optional\n\ -parameters for @code{quad}.\n\ -\n\ -Note: because @code{quad} is written in Fortran it cannot be called\n\ -recursively. This prevents its use in integrating over more than one\n\ -variable by routines @code{dblquad} and @code{triplequad}.\n\ -@seealso{quad_options, quadv, quadl, quadgk, quadcc, trapz, dblquad, triplequad}\n\ -@end deftypefn") -{ - octave_value_list retval; - - std::string fcn_name; - - warned_imaginary = false; - - unwind_protect frame; - - frame.protect_var (call_depth); - call_depth++; - - if (call_depth > 1) - QUAD_ABORT1 ("invalid recursive call"); - - int nargin = args.length (); - - if (nargin > 2 && nargin < 6 && nargout < 5) - { - if (args(0).is_function_handle () || args(0).is_inline_function ()) - quad_fcn = args(0).function_value (); - else - { - fcn_name = unique_symbol_name ("__quad_fcn_"); - std::string fname = "function y = "; - fname.append (fcn_name); - fname.append ("(x) y = "); - quad_fcn = extract_function (args(0), "quad", fcn_name, fname, - "; endfunction"); - } - - if (! quad_fcn) - QUAD_ABORT (); - - if (args(1).is_single_type () || args(2).is_single_type ()) - { - float a = args(1).float_value (); - - if (error_state) - QUAD_ABORT1 ("expecting second argument to be a scalar"); - - float b = args(2).float_value (); - - if (error_state) - QUAD_ABORT1 ("expecting third argument to be a scalar"); - - int indefinite = 0; - FloatIndefQuad::IntegralType indef_type = FloatIndefQuad::doubly_infinite; - float bound = 0.0; - if (xisinf (a) && xisinf (b)) - { - indefinite = 1; - indef_type = FloatIndefQuad::doubly_infinite; - } - else if (xisinf (a)) - { - indefinite = 1; - bound = b; - indef_type = FloatIndefQuad::neg_inf_to_bound; - } - else if (xisinf (b)) - { - indefinite = 1; - bound = a; - indef_type = FloatIndefQuad::bound_to_inf; - } - - octave_idx_type ier = 0; - octave_idx_type nfun = 0; - float abserr = 0.0; - float val = 0.0; - bool have_sing = false; - FloatColumnVector sing; - FloatColumnVector tol; - - switch (nargin) - { - case 5: - if (indefinite) - QUAD_ABORT1 ("singularities not allowed on infinite intervals"); - - have_sing = true; - - sing = FloatColumnVector (args(4).float_vector_value ()); - - if (error_state) - QUAD_ABORT1 ("expecting vector of singularities as fourth argument"); - - case 4: - tol = FloatColumnVector (args(3).float_vector_value ()); - - if (error_state) - QUAD_ABORT1 ("expecting vector of tolerances as fifth argument"); - - switch (tol.capacity ()) - { - case 2: - quad_opts.set_single_precision_relative_tolerance (tol (1)); - - case 1: - quad_opts.set_single_precision_absolute_tolerance (tol (0)); - break; - - default: - QUAD_ABORT1 ("expecting tol to contain no more than two values"); - } - - case 3: - if (indefinite) - { - FloatIndefQuad iq (quad_float_user_function, bound, - indef_type); - iq.set_options (quad_opts); - val = iq.float_integrate (ier, nfun, abserr); - } - else - { - if (have_sing) - { - FloatDefQuad dq (quad_float_user_function, a, b, sing); - dq.set_options (quad_opts); - val = dq.float_integrate (ier, nfun, abserr); - } - else - { - FloatDefQuad dq (quad_float_user_function, a, b); - dq.set_options (quad_opts); - val = dq.float_integrate (ier, nfun, abserr); - } - } - break; - - default: - panic_impossible (); - break; - } - - retval(3) = abserr; - retval(2) = nfun; - retval(1) = ier; - retval(0) = val; - - } - else - { - double a = args(1).double_value (); - - if (error_state) - QUAD_ABORT1 ("expecting second argument to be a scalar"); - - double b = args(2).double_value (); - - if (error_state) - QUAD_ABORT1 ("expecting third argument to be a scalar"); - - int indefinite = 0; - IndefQuad::IntegralType indef_type = IndefQuad::doubly_infinite; - double bound = 0.0; - if (xisinf (a) && xisinf (b)) - { - indefinite = 1; - indef_type = IndefQuad::doubly_infinite; - } - else if (xisinf (a)) - { - indefinite = 1; - bound = b; - indef_type = IndefQuad::neg_inf_to_bound; - } - else if (xisinf (b)) - { - indefinite = 1; - bound = a; - indef_type = IndefQuad::bound_to_inf; - } - - octave_idx_type ier = 0; - octave_idx_type nfun = 0; - double abserr = 0.0; - double val = 0.0; - bool have_sing = false; - ColumnVector sing; - ColumnVector tol; - - switch (nargin) - { - case 5: - if (indefinite) - QUAD_ABORT1 ("singularities not allowed on infinite intervals"); - - have_sing = true; - - sing = ColumnVector (args(4).vector_value ()); - - if (error_state) - QUAD_ABORT1 ("expecting vector of singularities as fourth argument"); - - case 4: - tol = ColumnVector (args(3).vector_value ()); - - if (error_state) - QUAD_ABORT1 ("expecting vector of tolerances as fifth argument"); - - switch (tol.capacity ()) - { - case 2: - quad_opts.set_relative_tolerance (tol (1)); - - case 1: - quad_opts.set_absolute_tolerance (tol (0)); - break; - - default: - QUAD_ABORT1 ("expecting tol to contain no more than two values"); - } - - case 3: - if (indefinite) - { - IndefQuad iq (quad_user_function, bound, indef_type); - iq.set_options (quad_opts); - val = iq.integrate (ier, nfun, abserr); - } - else - { - if (have_sing) - { - DefQuad dq (quad_user_function, a, b, sing); - dq.set_options (quad_opts); - val = dq.integrate (ier, nfun, abserr); - } - else - { - DefQuad dq (quad_user_function, a, b); - dq.set_options (quad_opts); - val = dq.integrate (ier, nfun, abserr); - } - } - break; - - default: - panic_impossible (); - break; - } - - retval(3) = abserr; - retval(2) = nfun; - retval(1) = ier; - retval(0) = val; - } - - if (fcn_name.length ()) - clear_function (fcn_name); - } - else - print_usage (); - - return retval; -} - -/* -%!function y = __f (x) -%! y = x + 1; -%!endfunction - -%!test -%! [v, ier, nfun, err] = quad ("__f", 0, 5); -%! assert (ier, 0); -%! assert (v, 17.5, sqrt (eps)); -%! assert (nfun > 0); -%! assert (err < sqrt (eps)); - -%!test -%! [v, ier, nfun, err] = quad ("__f", single (0), single (5)); -%! assert (ier, 0); -%! assert (v, 17.5, sqrt (eps ("single"))); -%! assert (nfun > 0); -%! assert (err < sqrt (eps ("single"))); - -%!function y = __f (x) -%! y = x .* sin (1 ./ x) .* sqrt (abs (1 - x)); -%!endfunction - -%!test -%! [v, ier, nfun, err] = quad ("__f", 0.001, 3); -%! assert (ier == 0 || ier == 1); -%! assert (v, 1.98194120273598, sqrt (eps)); -%! assert (nfun > 0); - -%!test -%! [v, ier, nfun, err] = quad ("__f", single (0.001), single (3)); -%! assert (ier == 0 || ier == 1); -%! assert (v, 1.98194120273598, sqrt (eps ("single"))); -%! assert (nfun > 0); - -%!error quad () -%!error quad ("__f", 1, 2, 3, 4, 5) - -%!test -%! quad_options ("absolute tolerance", eps); -%! assert (quad_options ("absolute tolerance") == eps); - -%!error quad_options (1, 2, 3) -*/
--- a/src/DLD-FUNCTIONS/quadcc.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2263 +0,0 @@ -/* - -Copyright (C) 2010-2012 Pedro Gonnet - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <stdlib.h> -#include "lo-math.h" -#include "lo-ieee.h" -#include "oct.h" -#include "parse.h" -#include "ov-fcn-handle.h" - -/* Define the size of the interval heap. */ -#define cquad_heapsize 200 - - -/* Data of a single interval */ -typedef struct -{ - double a, b; - double c[64]; - double fx[33]; - double igral, err; - int depth, rdepth, ndiv; -} cquad_ival; - -/* Some constants and matrices that we'll need. */ - -static const double xi[33] = { - -1., -0.99518472667219688624, -0.98078528040323044912, - -0.95694033573220886493, -0.92387953251128675612, - -0.88192126434835502970, -0.83146961230254523708, - -0.77301045336273696082, -0.70710678118654752440, - -0.63439328416364549822, -0.55557023301960222475, - -0.47139673682599764857, -0.38268343236508977173, - -0.29028467725446236764, -0.19509032201612826785, - -0.098017140329560601995, 0., 0.098017140329560601995, - 0.19509032201612826785, 0.29028467725446236764, 0.38268343236508977173, - 0.47139673682599764857, 0.55557023301960222475, 0.63439328416364549822, - 0.70710678118654752440, 0.77301045336273696082, 0.83146961230254523708, - 0.88192126434835502970, 0.92387953251128675612, 0.95694033573220886493, - 0.98078528040323044912, 0.99518472667219688624, 1. -}; - -static const double bee[68] = { - 0.00000000000000e+00, 2.28868854108532e-01, 0.00000000000000e+00, - -8.15740215243451e-01, 0.00000000000000e+00, 5.31212715259731e-01, - 0.00000000000000e+00, 1.38538036812454e-02, 0.00000000000000e+00, - 3.74405228908818e-02, 0.00000000000000e+00, 2.12224115039342e-01, - 0.00000000000000e+00, -8.16362644507898e-01, 0.00000000000000e+00, - 5.35648426691481e-01, 0.00000000000000e+00, 1.52417902753662e-03, - 0.00000000000000e+00, 2.63058840550873e-03, 0.00000000000000e+00, - 4.15292106318904e-03, 0.00000000000000e+00, 6.97106011119775e-03, - 0.00000000000000e+00, 1.35535708431058e-02, 0.00000000000000e+00, - 3.52132898424856e-02, 0.00000000000000e+00, 2.06946714741884e-01, - 0.00000000000000e+00, -8.15674251283876e-01, 0.00000000000000e+00, - 5.38841175520580e-01, 0.00000000000000e+00, 1.84909689577590e-04, - 0.00000000000000e+00, 2.90936325007499e-04, 0.00000000000000e+00, - 3.84877750950089e-04, 0.00000000000000e+00, 4.86436656735046e-04, - 0.00000000000000e+00, 6.08688640346879e-04, 0.00000000000000e+00, - 7.66732830740331e-04, 0.00000000000000e+00, 9.82753336104205e-04, - 0.00000000000000e+00, 1.29359957505615e-03, 0.00000000000000e+00, - 1.76616363801885e-03, 0.00000000000000e+00, 2.53323433039089e-03, - 0.00000000000000e+00, 3.88872172121956e-03, 0.00000000000000e+00, - 6.58635106468291e-03, 0.00000000000000e+00, 1.30326736343254e-02, - 0.00000000000000e+00, 3.44353850696714e-02, 0.00000000000000e+00, - 2.05025409531915e-01, 0.00000000000000e+00, -8.14985893995401e-01, - 0.00000000000000e+00, 5.40679930965238e-01 -}; - -static const double Lalpha[33] = { - 5.77350269189626e-01, 5.16397779494322e-01, 5.07092552837110e-01, - 5.03952630678970e-01, 5.02518907629606e-01, 5.01745206004255e-01, - 5.01280411827603e-01, 5.00979432868120e-01, 5.00773395667191e-01, - 5.00626174321759e-01, 5.00517330712619e-01, 5.00434593736979e-01, - 5.00370233297676e-01, 5.00319182924304e-01, 5.00278009473803e-01, - 5.00244319584578e-01, 5.00216403386025e-01, 5.00193012939056e-01, - 5.00173220168024e-01, 5.00156323280355e-01, 5.00141783641018e-01, - 5.00129182278347e-01, 5.00118189340972e-01, 5.00108542278496e-01, - 5.00100030010004e-01, 5.00092481273333e-01, 5.00085755939229e-01, - 5.00079738458365e-01, 5.00074332862969e-01, 5.00069458915387e-01, - 5.00065049112355e-01, 5.00061046334395e-01, 5.00057401986298e-01 -}; - -static const double Lgamma[33] = { - 0.0, 0.0, 5.16397779494322e-01, 5.07092552837110e-01, 5.03952630678970e-01, - 5.02518907629606e-01, 5.01745206004255e-01, 5.01280411827603e-01, - 5.00979432868120e-01, 5.00773395667191e-01, 5.00626174321759e-01, - 5.00517330712619e-01, 5.00434593736979e-01, 5.00370233297676e-01, - 5.00319182924304e-01, 5.00278009473803e-01, 5.00244319584578e-01, - 5.00216403386025e-01, 5.00193012939056e-01, 5.00173220168024e-01, - 5.00156323280355e-01, 5.00141783641018e-01, 5.00129182278347e-01, - 5.00118189340972e-01, 5.00108542278496e-01, 5.00100030010003e-01, - 5.00092481273333e-01, 5.00085755939229e-01, 5.00079738458365e-01, - 5.00074332862969e-01, 5.00069458915387e-01, 5.00065049112355e-01, - 5.00061046334395e-01 -}; - -static const double V1inv[5 * 5] = { - .47140452079103168293e-1, .37712361663282534635, .56568542494923801952, - .37712361663282534635, .47140452079103168293e-1, - -.81649658092772603273e-1, -.46188021535170061160, 0, - .46188021535170061160, .81649658092772603273e-1, .15058465048420853962, - .12046772038736683169, -.54210474174315074262, .12046772038736683169, - .15058465048420853962, -.21380899352993950775, .30237157840738178177, -0., - -.30237157840738178177, .21380899352993950775, .10774960475223581324, - -.21549920950447162648, .21549920950447162648, -.21549920950447162648, - .10774960475223581324 -}; - -static const double V2inv[9 * 9] = { - .11223917161691230546e-1, .10339219839658349826, .19754094204576565761, - .25577315077753587922, .27835314560994251755, .25577315077753587922, - .19754094204576565761, .10339219839658349826, .11223917161691230546e-1, - -.19440394783993476970e-1, -.16544884625069155470, -.24193725566041460608, - -.16953338808305493604, 0.0, .16953338808305493604, .24193725566041460608, - .16544884625069155470, .19440394783993476970e-1, .26466393115406349388e-1, - .17766815796285469394, .11316664642449611462, -.16306601003711325980, - -.30847037493128779631, -.16306601003711325980, .11316664642449611462, - .17766815796285469394, .26466393115406349388e-1, - -.32395302049990834508e-1, -.15521142532414866547, - .88573492664788602740e-1, .29570405784974857322, 0.0, - -.29570405784974857322, -.88573492664788602740e-1, .15521142532414866547, - .32395302049990834508e-1, .41442155673936851246e-1, - .98186757907405608245e-1, -.23056908429499411784, - -.68047008326360625520e-1, .31797435808002456774, - -.68047008326360625520e-1, -.23056908429499411784, - .98186757907405608245e-1, .41442155673936851246e-1, - -.49981120317798783134e-1, -.24861810572835756217e-1, - .23561326072010832539, -.24472785656448415351, 0.0, .24472785656448415351, - -.23561326072010832539, .24861810572835756217e-1, - .49981120317798783134e-1, .79691635865674781228e-1, - -.95725617891693941833e-1, -.57957553356854386344e-1, - .21164072460540271452, -.27529837844505833514, .21164072460540271452, - -.57957553356854386344e-1, -.95725617891693941833e-1, - .79691635865674781228e-1, - -.10894869830716590913, .20131094491947531782, -.15407672674888869038, - .83385723639789791384e-1, 0.0, -.83385723639789791384e-1, - .15407672674888869038, -.20131094491947531782, .10894869830716590913, - .54581057089643838221e-1, -.10916211417928767644, .10916211417928767644, - -.10916211417928767644, .10916211417928767644, -.10916211417928767644, - .10916211417928767644, -.10916211417928767644, .54581057089643838221e-1 -}; - -static const double V3inv[17 * 17] = { - .27729677693590098996e-2, .26423663180333065153e-1, - .53374068493933898312e-1, .77007854739523195947e-1, - .98257061072911596869e-1, .11538049741786835604, .12832134344120884559, - .13612785914022865001, .13888293186236181317, .13612785914022865001, - .12832134344120884559, .11538049741786835604, .98257061072911596869e-1, - .77007854739523195947e-1, .53374068493933898312e-1, - .26423663180333065153e-1, .27729677693590098996e-2, - -.48029210642807413690e-2, -.44887724635478800254e-1, - -.85409520147301089416e-1, -.11090267822061423050, -.12033983162705862441, - -.11102786862182788886, -.85054870109799336515e-1, - -.45998467987742225160e-1, 0.0, .45998467987742225160e-1, - .85054870109799336515e-1, .11102786862182788886, .12033983162705862441, - .11090267822061423050, .85409520147301089416e-1, .44887724635478800254e-1, - .48029210642807413690e-2, .62758546879582030087e-2, - .55561297093529155869e-1, - .93281491021051539742e-1, .92320151237493695139e-1, - .55077987469605684531e-1, - -.96998141716497488255e-2, -.80285961895427405567e-1, - -.13496839655913850224, - -.15512521776684524331, -.13496839655913850224, -.80285961895427405567e-1, - -.96998141716497488255e-2, .55077987469605684531e-1, - .92320151237493695139e-1, .93281491021051539742e-1, - .55561297093529155869e-1, .62758546879582030087e-2, - -.74850969394858555939e-2, -.61751608943839234096e-1, - -.82974150437304275958e-1, -.38437763431942633378e-1, - .45745502025779701366e-1, .12369235652734542162, .14720439712852868239, - .98768034347019704401e-1, 0.0, - -.98768034347019704401e-1, -.14720439712852868239, -.12369235652734542162, - -.45745502025779701366e-1, .38437763431942633378e-1, - .82974150437304275958e-1, .61751608943839234096e-1, - .74850969394858555939e-2, .86710099994384056338e-2, - .64006230103659573344e-1, .58517426396091675690e-1, - -.29743410528985802680e-1, - -.11934127779157114754, -.12686773515361299409, -.30729137153877447035e-1, - .97307836256600731568e-1, .15635811574451401023, .97307836256600731568e-1, - -.30729137153877447035e-1, -.12686773515361299409, -.11934127779157114754, - -.29743410528985802680e-1, .58517426396091675690e-1, - .64006230103659573344e-1, .86710099994384056338e-2, - -.97486395666294840165e-2, -.62995604908060224672e-1, - -.24373234450275529219e-1, .87760984413626872730e-1, - .12205204576993351394, - .16216004196864002088e-1, -.12422320942156845775, -.13682714580929614678, - 0.0, .13682714580929614678, .12422320942156845775, - -.16216004196864002088e-1, -.12205204576993351394, - -.87760984413626872730e-1, .24373234450275529219e-1, - .62995604908060224672e-1, .97486395666294840165e-2, - .10956271233750488468e-1, .58613204255294358939e-1, - -.13306063940736618859e-1, -.11606666444978454399, - -.52059598001115805639e-1, .10868540217796151849, .12594452879014618005, - -.44678658254872910434e-1, -.15617684362128533405, - -.44678658254872910434e-1, .12594452879014618005, .10868540217796151849, - -.52059598001115805639e-1, -.11606666444978454399, - -.13306063940736618859e-1, .58613204255294358939e-1, - .10956271233750488468e-1, -.12098893000863087230e-1, - -.51626244709126208453e-1, .48919433304746979330e-1, - .10467644465949427090, - -.48729879523084673782e-1, -.13668732103524749234, .28190838706814496438e-1, - .15434223333238741600, 0.0, -.15434223333238741600, - -.28190838706814496438e-1, .13668732103524749234, - .48729879523084673782e-1, -.10467644465949427090, - -.48919433304746979330e-1, .51626244709126208453e-1, - .12098893000863087230e-1, .13542668300437944822e-1, - .41712033418258689308e-1, - -.76190463272803434388e-1, -.58303943170068132010e-1, .12158068748245606853, - .42121099930651007882e-1, -.14684425840766337756, - -.16108203535058647043e-1, .15698075850757976092, - -.16108203535058647043e-1, -.14684425840766337756, - .42121099930651007882e-1, .12158068748245606853, - -.58303943170068132010e-1, -.76190463272803434388e-1, - .41712033418258689308e-1, .13542668300437944822e-1, - -.14939634995117694417e-1, -.30047246373341564039e-1, - .91624635082546425678e-1, -.79133374319110026377e-2, - -.12292558212072233355, .90013382617762643524e-1, - .84013717196539593395e-1, -.14813033309980695856, 0.0, - .14813033309980695856, -.84013717196539593395e-1, - -.90013382617762643524e-1, - .12292558212072233355, .79133374319110026377e-2, -.91624635082546425678e-1, - .30047246373341564039e-1, .14939634995117694417e-1, - .16986031342807474208e-1, - .15760203882617033601e-1, -.91494054040950941996e-1, - .70082459207876130806e-1, - .53390713710144539104e-1, -.14340746778352039430, .84048122493418898508e-1, - .72456667788091316868e-1, -.15564535320096811360, - .72456667788091316868e-1, .84048122493418898508e-1, - -.14340746778352039430, .53390713710144539104e-1, - .70082459207876130806e-1, -.91494054040950941996e-1, - .15760203882617033601e-1, - .16986031342807474208e-1, -.18994065631858742028e-1, - -.82901821370405592927e-3, .77239669773015192888e-1, - -.10850735431039424680, .47524484622086496464e-1, - .69148184871588737021e-1, -.14829314646228194928, .11992057742398672066, - 0.0, -.11992057742398672066, .14829314646228194928, - -.69148184871588737021e-1, -.47524484622086496464e-1, - .10850735431039424680, -.77239669773015192888e-1, - .82901821370405592927e-3, .18994065631858742028e-1, - .22761703826371535132e-1, -.17728848711449643358e-1, - -.47496371572480503788e-1, .10659958402328690063, -.11696013966166296514, - .63073750910894244526e-1, .32928881123602721303e-1, - -.12280950532497593683, .15926189077282729505, -.12280950532497593683, - .32928881123602721303e-1, .63073750910894244526e-1, - -.11696013966166296514, .10659958402328690063, -.47496371572480503788e-1, - -.17728848711449643358e-1, .22761703826371535132e-1, - -.26493215276042203434e-1, .35579780856128386192e-1, - .10447309718398935122e-1, -.68616154085314996709e-1, - .11775363082763954214, -.13918901977011837274, .12312819418827395690, - -.72053565748259077905e-1, 0.0, .72053565748259077905e-1, - -.12312819418827395690, .13918901977011837274, -.11775363082763954214, - .68616154085314996709e-1, -.10447309718398935122e-1, - -.35579780856128386192e-1, - .26493215276042203434e-1, .40742523354399706918e-1, - -.73124912999529117195e-1, .49317266444153837821e-1, - -.13686605413876015320e-1, -.28342624942191100464e-1, - .70371855298258216249e-1, -.10600251632853603875, .12981016288391131812, - -.13817029659318161476, .12981016288391131812, -.10600251632853603875, - .70371855298258216249e-1, -.28342624942191100464e-1, - -.13686605413876015320e-1, - .49317266444153837821e-1, -.73124912999529117195e-1, - .40742523354399706918e-1, -.54944368958699908688e-1, - .10777725663147408190, -.10152395581538265428, .91369146312596428468e-1, - -.77703071757424700773e-1, .61050911730999815031e-1, - -.42052599404498348871e-1, .21438229266251454773e-1, 0.0, - -.21438229266251454773e-1, .42052599404498348871e-1, - -.61050911730999815031e-1, .77703071757424700773e-1, - -.91369146312596428468e-1, - .10152395581538265428, -.10777725663147408190, .54944368958699908688e-1, - .27485608464748840573e-1, -.54971216929497681146e-1, - .54971216929497681146e-1, - -.54971216929497681146e-1, .54971216929497681146e-1, - -.54971216929497681146e-1, .54971216929497681146e-1, - -.54971216929497681146e-1, .54971216929497681146e-1, - -.54971216929497681146e-1, .54971216929497681146e-1, - -.54971216929497681146e-1, .54971216929497681146e-1, - -.54971216929497681146e-1, .54971216929497681146e-1, - -.54971216929497681146e-1, .27485608464748840573e-1 -}; - -static const double V4inv[33 * 33] = { - .69120897476690862600e-3, .66419939766331555194e-2, - .13600665164323186111e-1, .20122785860913684493e-1, - .26583214101668429944e-1, .32712713318999268739e-1, - .38576221976287138036e-1, .44033030938268925133e-1, - .49092709529622799673e-1, .53657949874312515646e-1, - .57724533144734311859e-1, .61219564530655179096e-1, - .64138907503837875026e-1, .66427905189318792009e-1, - .68088956652280022887e-1, .69083051391555695878e-1, - .69422738116739271449e-1, .69083051391555695878e-1, - .68088956652280022887e-1, .66427905189318792009e-1, - .64138907503837875026e-1, .61219564530655179096e-1, - .57724533144734311859e-1, .53657949874312515646e-1, - .49092709529622799673e-1, .44033030938268925133e-1, - .38576221976287138036e-1, .32712713318999268739e-1, - .26583214101668429944e-1, .20122785860913684493e-1, - .13600665164323186111e-1, .66419939766331555194e-2, - .69120897476690862600e-3, -.11972090629438798134e-2, - -.11448874821643225573e-1, -.23104401104002905904e-1, - -.33352899418646530133e-1, -.42538626424075425908e-1, - -.49969730733911825941e-1, -.55555454015360728353e-1, - -.58955533624852604918e-1, -.60126044219122513907e-1, - -.58959430451175833624e-1, -.55546925396227130606e-1, - -.49984739749347973762e-1, -.42513009141170294365e-1, - -.33399140950669746346e-1, -.23007690803851790829e-1, - -.11728275717520066169e-1, 0.0, .11728275717520066169e-1, - .23007690803851790829e-1, .33399140950669746346e-1, - .42513009141170294365e-1, .49984739749347973762e-1, - .55546925396227130606e-1, .58959430451175833624e-1, - .60126044219122513907e-1, .58955533624852604918e-1, - .55555454015360728353e-1, .49969730733911825941e-1, - .42538626424075425908e-1, .33352899418646530133e-1, - .23104401104002905904e-1, .11448874821643225573e-1, - .11972090629438798134e-2, .15501585012936019146e-2, - .14628781502199620482e-1, .28684915921474815271e-1, - .39299396074628048026e-1, .46393418975496284204e-1, - .48756902531094699526e-1, .46331333488337494692e-1, - .39012645376980228775e-1, .27452795421085791153e-1, - .12430953621169863781e-1, -.47682978056024928800e-2, - -.22825828045428973853e-1, - -.40195512090720278312e-1, -.55503004262826221955e-1, - -.67424537752827046308e-1, -.75020199300113606452e-1, - -.77607844312483656131e-1, -.75020199300113606452e-1, - -.67424537752827046308e-1, -.55503004262826221955e-1, - -.40195512090720278312e-1, -.22825828045428973853e-1, - -.47682978056024928800e-2, .12430953621169863781e-1, - .27452795421085791153e-1, .39012645376980228775e-1, - .46331333488337494692e-1, .48756902531094699526e-1, - .46393418975496284204e-1, .39299396074628048026e-1, - .28684915921474815271e-1, .14628781502199620482e-1, - .15501585012936019146e-2, -.18377757558949194214e-2, - -.17050470050949761565e-1, -.31952119564923250836e-1, - -.40197423449026348155e-1, - -.41205649520281371624e-1, -.33909965817492272248e-1, - -.19393664422115332144e-1, .56661049630886784692e-3, - .22948272173686561721e-1, .44489719570904738207e-1, - .61790363672287920596e-1, .72121014727028013894e-1, - .73627151185287858579e-1, .65784665375961398923e-1, - .49369676372333667559e-1, .26444326317059715065e-1, 0.0, - -.26444326317059715065e-1, -.49369676372333667559e-1, - -.65784665375961398923e-1, -.73627151185287858579e-1, - -.72121014727028013894e-1, -.61790363672287920596e-1, - -.44489719570904738207e-1, -.22948272173686561721e-1, - -.56661049630886784692e-3, .19393664422115332144e-1, - .33909965817492272248e-1, .41205649520281371624e-1, - .40197423449026348155e-1, .31952119564923250836e-1, - .17050470050949761565e-1, .18377757558949194214e-2, - .20942714740729767769e-2, .18935902405146518232e-1, - .33335840852491735126e-1, .36770680999102286065e-1, - .28873194534132768509e-1, .10267303017729535513e-1, - -.14607738306201572890e-1, -.40139568545572305818e-1, - -.59808326733858291561e-1, -.68528358823372627506e-1, - -.63306535387619244879e-1, -.44508601817574921056e-1, - -.15449116105605395357e-1, .17941083795006546367e-1, - .48747356011657242123e-1, .70329553984201665523e-1, - .78106117292526169663e-1, .70329553984201665523e-1, - .48747356011657242123e-1, .17941083795006546367e-1, - -.15449116105605395357e-1, -.44508601817574921056e-1, - -.63306535387619244879e-1, -.68528358823372627506e-1, - -.59808326733858291561e-1, - -.40139568545572305818e-1, -.14607738306201572890e-1, - .10267303017729535513e-1, .28873194534132768509e-1, - .36770680999102286065e-1, .33335840852491735126e-1, - .18935902405146518232e-1, .20942714740729767769e-2, - -.23245285491878278419e-2, -.20401404737639389919e-1, - -.33019548231022514097e-1, -.29709828426463720091e-1, - -.11760070922697422156e-1, .15987584743850393793e-1, - .43619012891472813485e-1, .61177322409671487721e-1, - .61144030218486655594e-1, - .41895377620089086167e-1, .80232011820644308033e-2, - -.30574701186675900915e-1, - -.62072243008844865848e-1, -.76336186183574765586e-1, - -.68435466095345537115e-1, -.40237669208466966207e-1, 0.0, - .40237669208466966207e-1, .68435466095345537115e-1, - .76336186183574765586e-1, .62072243008844865848e-1, - .30574701186675900915e-1, -.80232011820644308033e-2, - -.41895377620089086167e-1, -.61144030218486655594e-1, - -.61177322409671487721e-1, -.43619012891472813485e-1, - -.15987584743850393793e-1, .11760070922697422156e-1, - .29709828426463720091e-1, .33019548231022514097e-1, - .20401404737639389919e-1, .23245285491878278419e-2, - .25451717261579269307e-2, .21480418595666878775e-1, - .31177212469293007998e-1, .19816333607013379373e-1, - -.72439496274458793681e-2, -.38404203906598342397e-1, - -.57633632255322221046e-1, -.54070547403585392952e-1, - -.26249823354368866005e-1, .15643058212336881516e-1, - .54539832735118677194e-1, .73283028002473989724e-1, - .62835303524135936213e-1, .26175977027801048141e-1, - -.22193636309998606610e-1, -.62597049956093311234e-1, - -.78206986173170212505e-1, -.62597049956093311234e-1, - -.22193636309998606610e-1, .26175977027801048141e-1, - .62835303524135936213e-1, - .73283028002473989724e-1, .54539832735118677194e-1, - .15643058212336881516e-1, - -.26249823354368866005e-1, -.54070547403585392952e-1, - -.57633632255322221046e-1, -.38404203906598342397e-1, - -.72439496274458793681e-2, .19816333607013379373e-1, - .31177212469293007998e-1, .21480418595666878775e-1, - .25451717261579269307e-2, -.27506573922483820005e-2, - -.22224442095099251870e-1, -.27949927254215773020e-1, - -.80918481053370034987e-2, .25121859354449306916e-1, - .51563535009373061074e-1, .51936965107145960512e-1, - .22146626648171527753e-1, - -.24172689882103382748e-1, -.61731229104853568296e-1, - -.68477262429344201201e-1, -.38311232728303704742e-1, - .14160578713659552679e-1, .61248813427564184033e-1, - .77136328841293031805e-1, .52514801765183697988e-1, 0.0, - -.52514801765183697988e-1, -.77136328841293031805e-1, - -.61248813427564184033e-1, -.14160578713659552679e-1, - .38311232728303704742e-1, - .68477262429344201201e-1, .61731229104853568296e-1, - .24172689882103382748e-1, - -.22146626648171527753e-1, -.51936965107145960512e-1, - -.51563535009373061074e-1, -.25121859354449306916e-1, - .80918481053370034987e-2, .27949927254215773020e-1, - .22224442095099251870e-1, .27506573922483820005e-2, - .29562461131654311467e-2, .22630271480554450613e-1, - .23547399831373800971e-1, -.43964593440902476642e-2, - -.39055315767504970597e-1, -.52369643937940066804e-1, - -.28506131614971613422e-1, .19906048093338832322e-1, - .60408880866392420279e-1, .62493397473656883090e-1, - .21391278377641297859e-1, -.37302864786623254746e-1, - -.73665127933539496872e-1, -.61706142476854010202e-1, - -.78065168882546327888e-2, .52335307373945544428e-1, - .78278746279419264777e-1, .52335307373945544428e-1, - -.78065168882546327888e-2, -.61706142476854010202e-1, - -.73665127933539496872e-1, -.37302864786623254746e-1, - .21391278377641297859e-1, .62493397473656883090e-1, - .60408880866392420279e-1, .19906048093338832322e-1, - -.28506131614971613422e-1, -.52369643937940066804e-1, - -.39055315767504970597e-1, -.43964593440902476642e-2, - .23547399831373800971e-1, .22630271480554450613e-1, - .29562461131654311467e-2, -.31515718415504761303e-2, - -.22739451096655080673e-1, -.18157123602272119779e-1, - .16496480897167303621e-1, .46921166788569301124e-1, - .40644395739978416354e-1, -.46275803430732216900e-2, - -.52883375891308909486e-1, -.61116483226324111734e-1, - -.17411698764545629853e-1, .44773430013166822765e-1, - .73441577962383869198e-1, .42127368371995472815e-1, - -.25504645957196772465e-1, -.74126818045972742488e-1, - -.62780077864719287317e-1, 0.0, .62780077864719287317e-1, - .74126818045972742488e-1, .25504645957196772465e-1, - -.42127368371995472815e-1, -.73441577962383869198e-1, - -.44773430013166822765e-1, .17411698764545629853e-1, - .61116483226324111734e-1, .52883375891308909486e-1, - .46275803430732216900e-2, -.40644395739978416354e-1, - -.46921166788569301124e-1, -.16496480897167303621e-1, - .18157123602272119779e-1, .22739451096655080673e-1, - .31515718415504761303e-2, .33536559294882188208e-2, - .22535348942792006185e-1, - .12048629300953560767e-1, -.27166076791299493403e-1, - -.47492745604230978367e-1, -.19246623430993153174e-1, - .36231297307556299322e-1, .61713617181636122004e-1, - .25928029734266134490e-1, -.40478700752883602818e-1, - -.71053889866326412049e-1, -.31870824482961751482e-1, - .41515251100219081281e-1, .76481960760098381651e-1, - .36726509155999912440e-1, -.40090067032627055969e-1, - -.78270742903374539397e-1, -.40090067032627055969e-1, - .36726509155999912440e-1, .76481960760098381651e-1, - .41515251100219081281e-1, -.31870824482961751482e-1, - -.71053889866326412049e-1, -.40478700752883602818e-1, - .25928029734266134490e-1, .61713617181636122004e-1, - .36231297307556299322e-1, -.19246623430993153174e-1, - -.47492745604230978367e-1, -.27166076791299493403e-1, - .12048629300953560767e-1, .22535348942792006185e-1, - .33536559294882188208e-2, - -.35481220456925318865e-2, -.22062913693073191150e-1, - -.54487362861834144999e-2, .35438821865804087489e-1, - .40733077820527411302e-1, -.67403098138950720914e-2, - -.55559584405239171054e-1, -.42417050790865158745e-1, - .24499901971884704925e-1, .68721232891705409302e-1, - .34086082787461126592e-1, -.43441000373118474002e-1, - -.73878085292669148950e-1, -.18846995664706657127e-1, - .59827776178286834498e-1, .70644634584085901794e-1, 0.0, - -.70644634584085901794e-1, -.59827776178286834498e-1, - .18846995664706657127e-1, .73878085292669148950e-1, - .43441000373118474002e-1, -.34086082787461126592e-1, - -.68721232891705409302e-1, -.24499901971884704925e-1, - .42417050790865158745e-1, .55559584405239171054e-1, - .67403098138950720914e-2, -.40733077820527411302e-1, - -.35438821865804087489e-1, .54487362861834144999e-2, - .22062913693073191150e-1, .35481220456925318865e-2, - .37554176816665075631e-2, .21297045781589919482e-1, - -.13327293083183431816e-2, - -.40635299172764596484e-1, -.27659860508374175359e-1, - .31089232744083445986e-1, .56113781541334176109e-1, - .37577840643257763400e-2, -.60511227350664590865e-1, - -.46670556446129053853e-1, .33263195878575888247e-1, - .72757324720645228775e-1, .15011712351692283635e-1, - -.65601212994924119078e-1, -.60016855838843789772e-1, - .26220858553188665966e-1, .78322776605833552980e-1, - .26220858553188665966e-1, -.60016855838843789772e-1, - -.65601212994924119078e-1, - .15011712351692283635e-1, .72757324720645228775e-1, - .33263195878575888247e-1, - -.46670556446129053853e-1, -.60511227350664590865e-1, - .37577840643257763400e-2, .56113781541334176109e-1, - .31089232744083445986e-1, -.27659860508374175359e-1, - -.40635299172764596484e-1, -.13327293083183431816e-2, - .21297045781589919482e-1, .37554176816665075631e-2, - -.39566995305720591229e-2, -.20291873414438919995e-1, - .80617453830770930551e-2, .42270189157016547906e-1, - .10332624526759093004e-1, -.48054759547616142024e-1, - -.37678032941171643972e-1, - .36617192625732482394e-1, .61009425973424865714e-1, - -.95589113168026591466e-2, - -.71023202645076922361e-1, -.25097788086808784456e-1, - .62406621963267050244e-1, .56907293171100693511e-1, - -.36435383083882206257e-1, -.75790105119208756348e-1, 0.0, - .75790105119208756348e-1, .36435383083882206257e-1, - -.56907293171100693511e-1, -.62406621963267050244e-1, - .25097788086808784456e-1, .71023202645076922361e-1, - .95589113168026591466e-2, - -.61009425973424865714e-1, -.36617192625732482394e-1, - .37678032941171643972e-1, .48054759547616142024e-1, - -.10332624526759093004e-1, -.42270189157016547906e-1, - -.80617453830770930551e-2, .20291873414438919995e-1, - .39566995305720591229e-2, .41776092289182138591e-2, - .19013221163904414395e-1, -.14420609729849899876e-1, - -.40259160586844441220e-1, .86327811113710831649e-2, - .53564430703021034399e-1, .65469185402150431933e-2, - -.60383116311280629856e-1, - -.25657793784058876939e-1, .58745680576829226900e-1, - .45649937869034420296e-1, - -.49167932056844167772e-1, -.62696614328552187977e-1, - .32540234556426699997e-1, .74280410383464269758e-1, - -.11425672633410999870e-1, -.78280649404686404903e-1, - -.11425672633410999870e-1, .74280410383464269758e-1, - .32540234556426699997e-1, -.62696614328552187977e-1, - -.49167932056844167772e-1, .45649937869034420296e-1, - .58745680576829226900e-1, -.25657793784058876939e-1, - -.60383116311280629856e-1, .65469185402150431933e-2, - .53564430703021034399e-1, - .86327811113710831649e-2, -.40259160586844441220e-1, - -.14420609729849899876e-1, .19013221163904414395e-1, - .41776092289182138591e-2, -.43935502082478059199e-2, - -.17528761237509401631e-1, .20208915249153872535e-1, - .34734743119040669109e-1, -.26275910172353637955e-1, - -.46368003346018878786e-1, - .26800056330709381025e-1, .56681476464606609921e-1, - -.24749011438127255898e-1, - -.64934612189056658992e-1, .20333742247679279535e-1, - .71429299070059318651e-1, - -.14452513210428671266e-1, -.75793341281736586582e-1, - .74717094137184935270e-2, .78034921554757317374e-1, 0.0, - -.78034921554757317374e-1, -.74717094137184935270e-2, - .75793341281736586582e-1, .14452513210428671266e-1, - -.71429299070059318651e-1, -.20333742247679279535e-1, - .64934612189056658992e-1, .24749011438127255898e-1, - -.56681476464606609921e-1, - -.26800056330709381025e-1, .46368003346018878786e-1, - .26275910172353637955e-1, - -.34734743119040669109e-1, -.20208915249153872535e-1, - .17528761237509401631e-1, .43935502082478059199e-2, - .46379089482818671473e-2, .15791188144791287229e-1, - -.25134290048737455284e-1, -.26249795071946841205e-1, - .39960457575789924651e-1, .28111892450146525404e-1, - -.51026476400767918226e-1, - -.27266747278681831364e-1, .60708796647861610865e-1, - .23532306960642115854e-1, - -.68169639871532441111e-1, -.18204924701958312032e-1, - .73822890510656128485e-1, .11373392486424717019e-1, - -.77133324017644609416e-1, -.39295877480342619961e-2, - .78351902829418987960e-1, -.39295877480342619961e-2, - -.77133324017644609416e-1, .11373392486424717019e-1, - .73822890510656128485e-1, -.18204924701958312032e-1, - -.68169639871532441111e-1, .23532306960642115854e-1, - .60708796647861610865e-1, -.27266747278681831364e-1, - -.51026476400767918226e-1, .28111892450146525404e-1, - .39960457575789924651e-1, -.26249795071946841205e-1, - -.25134290048737455284e-1, .15791188144791287229e-1, - .46379089482818671473e-2, -.48780095920069827068e-2, - -.13886961667516983541e-1, .29071311049368895844e-1, - .15480559452075811600e-1, -.47527977686242313065e-1, - -.31929089844361042178e-2, .58015667638415922967e-1, - -.14547915466597622925e-1, -.61067668299848923244e-1, - .35093678009090186851e-1, .55378399159800654657e-1, - -.54277226474891610385e-1, -.42023830782434076509e-1, - .69197384645944912066e-1, .22610783557709586445e-1, - -.77269275900637030185e-1, 0.0, .77269275900637030185e-1, - -.22610783557709586445e-1, - -.69197384645944912066e-1, .42023830782434076509e-1, - .54277226474891610385e-1, - -.55378399159800654657e-1, -.35093678009090186851e-1, - .61067668299848923244e-1, .14547915466597622925e-1, - -.58015667638415922967e-1, .31929089844361042178e-2, - .47527977686242313065e-1, -.15480559452075811600e-1, - -.29071311049368895844e-1, .13886961667516983541e-1, - .48780095920069827068e-2, .51591759101720291381e-2, - .11747497650231330965e-1, -.31777863364694653331e-1, - -.34555825499804605557e-2, .47914131921157015198e-1, - -.22573685920142225247e-1, -.45320344390022666738e-1, - .49660630547172186418e-1, .25707858143963615736e-1, - -.68132707341917233933e-1, .67534860185243140399e-2, - .69268150370037450063e-1, -.41585011920451477177e-1, - -.51622397460510041271e-1, .68408139576363036148e-1, - .18981259024768933323e-1, -.78265472429342305554e-1, - .18981259024768933323e-1, .68408139576363036148e-1, - -.51622397460510041271e-1, - -.41585011920451477177e-1, .69268150370037450063e-1, - .67534860185243140399e-2, - -.68132707341917233933e-1, .25707858143963615736e-1, - .49660630547172186418e-1, - -.45320344390022666738e-1, -.22573685920142225247e-1, - .47914131921157015198e-1, -.34555825499804605557e-2, - -.31777863364694653331e-1, .11747497650231330965e-1, - .51591759101720291381e-2, -.54365757412741340377e-2, - -.94862516619529080191e-2, .33240472093448190877e-1, - -.88698898099681552229e-2, - -.40973252097216337576e-1, .42995673349795657065e-1, - .17320914507876958783e-1, - -.62201292691914856803e-1, .24726274174637346693e-1, - .51320859246515407288e-1, - -.62882063373810501763e-1, -.11003569131725622672e-1, - .73842261324108943465e-1, -.39240120294802923208e-1, - -.49293966443941122807e-1, .73552644778818223475e-1, 0.0, - -.73552644778818223475e-1, .49293966443941122807e-1, - .39240120294802923208e-1, -.73842261324108943465e-1, - .11003569131725622672e-1, .62882063373810501763e-1, - -.51320859246515407288e-1, - -.24726274174637346693e-1, .62201292691914856803e-1, - -.17320914507876958783e-1, -.42995673349795657065e-1, - .40973252097216337576e-1, .88698898099681552229e-2, - -.33240472093448190877e-1, .94862516619529080191e-2, - .54365757412741340377e-2, .57750194549356126240e-2, - .69981166020044116791e-2, -.33274982140403110792e-1, - .20297071020698356116e-1, .27898517839646066582e-1, - -.53368678853282030262e-1, .16656482990394548343e-1, - .46342901447260614255e-1, - -.60536796508149003365e-1, .29109107483842596340e-2, - .63224486124385124504e-1, - -.59028872851312033411e-1, -.14783105962696191734e-1, - .74269399241069253865e-1, -.49053677339382384625e-1, - -.33525466624811186739e-1, .78397349622515386647e-1, - -.33525466624811186739e-1, -.49053677339382384625e-1, - .74269399241069253865e-1, -.14783105962696191734e-1, - -.59028872851312033411e-1, - .63224486124385124504e-1, .29109107483842596340e-2, - -.60536796508149003365e-1, - .46342901447260614255e-1, .16656482990394548343e-1, - -.53368678853282030262e-1, - .27898517839646066582e-1, .20297071020698356116e-1, - -.33274982140403110792e-1, - .69981166020044116791e-2, .57750194549356126240e-2, - -.61100308370519200637e-2, -.44383614355738148616e-2, - .32011283412619094811e-1, -.29965011866372897633e-1, - -.10560682331349193348e-1, .51110336443392506342e-1, - -.45012284729681775492e-1, -.94236825555873320102e-2, - .60860695783141264746e-1, - -.55014628647083368926e-1, -.73474782382499482121e-2, - .66640148475243034781e-1, -.62533116045749887988e-1, - -.38650525912400102585e-2, .68429769005837003777e-1, - -.66984505412544901945e-1, 0.0, .66984505412544901945e-1, - -.68429769005837003777e-1, .38650525912400102585e-2, - .62533116045749887988e-1, -.66640148475243034781e-1, - .73474782382499482121e-2, - .55014628647083368926e-1, -.60860695783141264746e-1, - .94236825555873320102e-2, - .45012284729681775492e-1, -.51110336443392506342e-1, - .10560682331349193348e-1, - .29965011866372897633e-1, -.32011283412619094811e-1, - .44383614355738148616e-2, - .61100308370519200637e-2, .65409373892036191538e-2, - .16350101107071157065e-2, -.29301957285983144319e-1, - .36838667173388832579e-1, -.81922703976491586393e-2, - -.36955670021050133434e-1, .58374851095540469865e-1, - -.31977016246946181856e-1, -.25311073698658094646e-1, - .66674413950106952577e-1, - -.54865713324521039571e-1, -.39797027891537985440e-2, - .62830285264808449064e-1, -.72226313251296100676e-1, - .22560232697133353980e-1, .46455784709904033738e-1, - -.78200930751070349956e-1, .46455784709904033738e-1, - .22560232697133353980e-1, -.72226313251296100676e-1, - .62830285264808449064e-1, -.39797027891537985440e-2, - -.54865713324521039571e-1, .66674413950106952577e-1, - -.25311073698658094646e-1, -.31977016246946181856e-1, - .58374851095540469865e-1, -.36955670021050133434e-1, - -.81922703976491586393e-2, .36838667173388832579e-1, - -.29301957285983144319e-1, .16350101107071157065e-2, - .65409373892036191538e-2, -.69686180931868703196e-2, - .11849538727632789870e-2, .25452286414610537766e-1, - -.40522480651713943230e-1, .25694679053362813183e-1, - .14057118113748390637e-1, -.52037614725803488893e-1, - .58849342223684035589e-1, - -.25075229077361409271e-1, -.29559771094034181083e-1, - .68296746944165720199e-1, -.62890462146423984955e-1, - .14457636466274596445e-1, .45787612031322361496e-1, - -.77231759014655809742e-1, .57881203613910543657e-1, 0.0, - -.57881203613910543657e-1, .77231759014655809742e-1, - -.45787612031322361496e-1, -.14457636466274596445e-1, - .62890462146423984955e-1, - -.68296746944165720199e-1, .29559771094034181083e-1, - .25075229077361409271e-1, - -.58849342223684035589e-1, .52037614725803488893e-1, - -.14057118113748390637e-1, -.25694679053362813183e-1, - .40522480651713943230e-1, -.25452286414610537766e-1, - -.11849538727632789870e-2, .69686180931868703196e-2, - .75611653617520254845e-2, -.43290610418608409141e-2, - -.20277062025115566914e-1, - .40362947027704828926e-1, -.38938808024132120254e-1, - .11831186195916702262e-1, - .28476667401744525357e-1, -.59320969056617684621e-1, - .61101629747436200186e-1, - -.29514834848355389223e-1, -.20668001885001084821e-1, - .62923592802445122793e-1, -.73558456263588833115e-1, - .45314556330160999776e-1, .79031645918426015574e-2, - -.58136953576334689357e-1, .78538474524006405758e-1, - -.58136953576334689357e-1, .79031645918426015574e-2, - .45314556330160999776e-1, -.73558456263588833115e-1, - .62923592802445122793e-1, -.20668001885001084821e-1, - -.29514834848355389223e-1, .61101629747436200186e-1, - -.59320969056617684621e-1, .28476667401744525357e-1, - .11831186195916702262e-1, -.38938808024132120254e-1, - .40362947027704828926e-1, -.20277062025115566914e-1, - -.43290610418608409141e-2, .75611653617520254845e-2, - -.81505692478987769484e-2, .74297333588288568430e-2, - .14314212513540223314e-1, -.36711242251332751607e-1, - .46240027755503814626e-1, -.34921532671769023773e-1, - .46930051972353714773e-2, - .32842770336385381562e-1, -.61317813706529588466e-1, - .67000809902468893103e-1, - -.45337449655535622885e-1, .35794459576271920867e-2, - .41830061526027213385e-1, - -.72091371931944711708e-1, .74150028530317793195e-1, - -.46487632538609942002e-1, 0.0, .46487632538609942002e-1, - -.74150028530317793195e-1, .72091371931944711708e-1, - -.41830061526027213385e-1, -.35794459576271920867e-2, - .45337449655535622885e-1, -.67000809902468893103e-1, - .61317813706529588466e-1, -.32842770336385381562e-1, - -.46930051972353714773e-2, .34921532671769023773e-1, - -.46240027755503814626e-1, .36711242251332751607e-1, - -.14314212513540223314e-1, -.74297333588288568430e-2, - .81505692478987769484e-2, .90693182942442189743e-2, - -.11121000903959576737e-1, -.71308296141317458546e-2, - .29219439765986671645e-1, -.45820286629778129593e-1, - .49088381175879124421e-1, -.35614888785023038938e-1, - .78906970900092777895e-2, - .26262843038404929480e-1, -.56143674270125757857e-1, - .71700220472378350694e-1, - -.66963544500697307945e-1, .42215091779892228883e-1, - -.41338867413966866997e-2, -.36164891772995367321e-1, - .66584367783847858225e-1, -.77874712365070098328e-1, - .66584367783847858225e-1, -.36164891772995367321e-1, - -.41338867413966866997e-2, .42215091779892228883e-1, - -.66963544500697307945e-1, - .71700220472378350694e-1, -.56143674270125757857e-1, - .26262843038404929480e-1, - .78906970900092777895e-2, -.35614888785023038938e-1, - .49088381175879124421e-1, - -.45820286629778129593e-1, .29219439765986671645e-1, - -.71308296141317458546e-2, -.11121000903959576737e-1, - .90693182942442189743e-2, -.99848472706332791043e-2, - .14701271465939718856e-1, -.32917820356048383366e-3, - -.19201195309873585230e-1, .38409681836626963278e-1, - -.51647324405878909521e-1, .54522171113149311354e-1, - -.45040302741689006270e-1, .24183738595685990149e-1, - .42204134165479735097e-2, -.34317295181348742251e-1, - .59542472465494579941e-1, -.74135115907618101263e-1, - .74491937840566532596e-1, -.60042604725161994304e-1, - .33437677409000083169e-1, 0.0, - -.33437677409000083169e-1, .60042604725161994304e-1, - -.74491937840566532596e-1, .74135115907618101263e-1, - -.59542472465494579941e-1, .34317295181348742251e-1, - -.42204134165479735097e-2, -.24183738595685990149e-1, - .45040302741689006270e-1, -.54522171113149311354e-1, - .51647324405878909521e-1, -.38409681836626963278e-1, - .19201195309873585230e-1, .32917820356048383366e-3, - -.14701271465939718856e-1, .99848472706332791043e-2, - .11775579274769383373e-1, -.19892153937316935880e-1, - .95335114477449041055e-2, .57661528440359081617e-2, - -.23382690532380910781e-1, .40237257037170725321e-1, - -.53280289903551636474e-1, .59974361806023689068e-1, - -.58701684061992853224e-1, .49033407111597129616e-1, - -.31818835267847249219e-1, .90800541261162098886e-2, - .16272906819312603838e-1, -.40863896581186229487e-1, - .61346046297517367703e-1, - -.74896047554167268919e-1, .79632642148310325817e-1, - -.74896047554167268919e-1, .61346046297517367703e-1, - -.40863896581186229487e-1, .16272906819312603838e-1, - .90800541261162098886e-2, -.31818835267847249219e-1, - .49033407111597129616e-1, -.58701684061992853224e-1, - .59974361806023689068e-1, -.53280289903551636474e-1, - .40237257037170725321e-1, -.23382690532380910781e-1, - .57661528440359081617e-2, .95335114477449041055e-2, - -.19892153937316935880e-1, - .11775579274769383373e-1, -.13562702617218467450e-1, - .24885419969649845849e-1, -.18368693901908875583e-1, - .81673147806084084638e-2, .47890591326129587131e-2, - -.19313752945227974024e-1, .34065953398362954708e-1, - -.47667045133463415672e-1, .58820377816690514309e-1, - -.66424139824618415970e-1, - .69667606260856092515e-1, -.68102459384364543253e-1, - .61683024923302547971e-1, - -.50771943476441639136e-1, .36110771847327189215e-1, - -.18758028464284563358e-1, 0.0, .18758028464284563358e-1, - -.36110771847327189215e-1, .50771943476441639136e-1, - -.61683024923302547971e-1, .68102459384364543253e-1, - -.69667606260856092515e-1, .66424139824618415970e-1, - -.58820377816690514309e-1, .47667045133463415672e-1, - -.34065953398362954708e-1, .19313752945227974024e-1, - -.47890591326129587131e-2, -.81673147806084084638e-2, - .18368693901908875583e-1, -.24885419969649845849e-1, - .13562702617218467450e-1, .20576545037980523979e-1, - -.40093155172981004337e-1, .36954083167944054826e-1, - -.31856506837591907746e-1, .24996323181546255126e-1, - -.16637165210473614136e-1, .71002706773325085237e-2, - .32478629093205201133e-2, - -.14009562579050569518e-1, .24771262248780618922e-1, - -.35119395835433647559e-1, .44656290368574753171e-1, - -.53015448339647394161e-1, .59875631995693046782e-1, - -.64973208326045193862e-1, .68112280331082143373e-1, - -.69172215234062186994e-1, .68112280331082143373e-1, - -.64973208326045193862e-1, .59875631995693046782e-1, - -.53015448339647394161e-1, .44656290368574753171e-1, - -.35119395835433647559e-1, .24771262248780618922e-1, - -.14009562579050569518e-1, .32478629093205201133e-2, - .71002706773325085237e-2, -.16637165210473614136e-1, - .24996323181546255126e-1, -.31856506837591907746e-1, - .36954083167944054826e-1, -.40093155172981004337e-1, - .20576545037980523979e-1, -.27584914609096156163e-1, - .54904171411058497973e-1, -.54109756419563083153e-1, - .52794234894345577483e-1, -.50970276026831042415e-1, - .48655445537990983379e-1, - -.45872036510847994332e-1, .42646854695899611372e-1, - -.39010960357087507670e-1, .34999369144476467749e-1, - -.30650714874402762189e-1, .26006877464703437057e-1, - -.21112579608213651273e-1, .16014956068786763273e-1, - -.10763099747751940252e-1, .54075888924374485533e-2, 0.0, - -.54075888924374485533e-2, .10763099747751940252e-1, - -.16014956068786763273e-1, - .21112579608213651273e-1, -.26006877464703437057e-1, - .30650714874402762189e-1, - -.34999369144476467749e-1, .39010960357087507670e-1, - -.42646854695899611372e-1, .45872036510847994332e-1, - -.48655445537990983379e-1, .50970276026831042415e-1, - -.52794234894345577483e-1, .54109756419563083153e-1, - -.54904171411058497973e-1, .27584914609096156163e-1, - .13794141262469565740e-1, -.27588282524939131481e-1, - .27588282524939131481e-1, -.27588282524939131481e-1, - .27588282524939131481e-1, -.27588282524939131481e-1, - .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .27588282524939131481e-1, - -.27588282524939131481e-1, .13794141262469565740e-1 -}; - -static const double Tleft[33 * 33] = { - 1., -.86602540378443864678, 0., .33071891388307382381, 0., - -.20728904939721249057, 0., .15128841196122722208, 0., - -.11918864298744029244, 0., .98352013661686631224e-1, 0., - -.83727065404940845733e-1, 0., .72893399403505841203e-1, 0., - -.64544632643375022436e-1, 0., .57913170372415565639e-1, 0., - -.52518242575729562263e-1, 0., .48043311993977520457e-1, 0., - -.44271433659733990243e-1, 0., .41048928022856771981e-1, 0., - -.38263878662008271459e-1, 0., .35832844026365304501e-1, 0., 0., - .50000000000000000000, -.96824583655185422130, .57282196186948000082, - .21650635094610966169, -.35903516540862679125, -.97578093724974971969e-1, - .26203921611325660506, .55792409597991015609e-1, -.20644078533943456204, - -.36172381205961199479e-1, .17035068468874958194, - .25371838001497225980e-1, -.14501953125000000000, - -.18786835250972344757e-1, .12625507130328301066, - .14473795929590520582e-1, -.11179458309419422675, - -.11494434254897626155e-1, .10030855351241635862, - .93498556820544479096e-2, -.90964264465390582629e-1, - -.77546391824364392762e-2, .83213457337452292745e-1, - .65358085945588638605e-2, -.76680372422574234569e-1, - -.55835321940047427169e-2, .71098828931825789428e-1, - .48253327982967591019e-2, -.66274981937248958553e-1, - -.42118078245337801387e-2, .62064306433355646267e-1, - .37083386598903548973e-2, 0., 0., .25000000000000000000, - -.73950997288745200531, .83852549156242113615, -.23175620272173946716, - -.37791833195149451496, .25710129174850522325, .21608307321780204633, - -.22844049245646009157, -.14009503000335388415, .19897685605518413847, - .98264706042471226893e-1, -.17445445004279014046, - -.72761100054958328401e-1, .15463589893742108388, - .56056770591708784481e-1, -.13855313872640495158, - -.44517752443294564781e-1, .12534277657695128850, - .36211835346039665762e-1, -.11434398255136139683, - -.30033588409423828125e-1, .10506705408753910481, - .25313077840725783008e-1, -.97149327637744872155e-1, - -.21624927200393328444e-1, .90319582367202122625e-1, - .18688433567711780666e-1, -.84372291635345108584e-1, - -.16312261561845420752e-1, .79149526894804751586e-1, - .14362333871852474757e-1, 0., 0., 0., .12500000000000000000, - -.49607837082461073572, .82265291131801144317, -.59621200088559103072, - -.80054302859059362371e-1, .42612156697795759420, - -.90098145270865592887e-1, -.29769623255090078484, .13630307904779758221, - .21638835185708931831, -.14600247270306082052, -.16348801804014290453, - .14340708728599057249, .12755243353979286190, -.13661523715071346961, - -.10215585947881057394, .12864248070157166547, .83592528025348693602e-1, - -.12066728689302565222, -.69633728678718053052e-1, .11314245177331919532, - .58882939251410088028e-1, -.10621835858758221487, - -.50432266865187597572e-1, .99916834723527771581e-1, - .43672094283057258509e-1, -.94206380251950852413e-1, - -.38181356812697746418e-1, .89035739656537771225e-1, - .33661934598216332678e-1, 0., 0., 0., 0., .62500000000000000000e-1, - -.31093357409581873586, .67604086414949799246, -.75644205980613611039, - .28990586430124175741, .30648508196770360914, -.35801372616842500052, - -.91326869828709014708e-1, .31127929687500000000, - -.90915752838698393094e-2, -.25637381283965534330, - .57601077850322797594e-1, .21019685709225757945, - -.81244992138514014256e-1, -.17375078516720988858, - .92289437277967051125e-1, .14527351914265391374, - -.96675340792832019889e-1, -.12289485697108543415, - .97448175340011084006e-1, .10511755943298339844, - -.96242247086378239657e-1, -.90822942272780513537e-1, - .93966350452322132384e-1, .79189411876493712558e-1, - -.91139307067989309325e-1, -.69613039934383197265e-1, - .88062491671135767870e-1, .61646331729340817494e-1, 0., 0., 0., 0., 0., - .31250000000000000000e-1, -.18684782411095934408, .50176689760410660236, - -.74784031498626095398, .56472001151566251186, .14842464993721351203e-1, - -.41162920273003120936, .20243071230196532282, .23772054897172750436, - -.24963810923972235950, -.12116179938394678936, .24330535483519110663, - .47903849781124471359e-1, -.22133299683101224293, - -.20542915138527200983e-2, .19653465717678146728, - -.26818172626509178444e-1, -.17319122357631210944, - .45065391411065545445e-1, .15253391395444065941, - -.56543897711725408302e-1, -.13469154928743585367, - .63632471400208840155e-1, .11941684923913523817, - -.67828850207933293098e-1, -.10636309084510652670, - .70095786922999181504e-1, .95187373095150709082e-1, 0., 0., 0., 0., 0., - 0., .15625000000000000000e-1, -.10909562534194485289, - .34842348626527747318, -.64461114561628111443, .69382480527334683659, - -.29551102358528827763, -.25527584713978439819, .38878771718544715394, - -.82956185835347407489e-2, -.31183177761966943912, .12831420840372374767, - .22067618205599434368, -.17569196937129496961, -.14598057000132284135, - .18864406621763419484, .89921002550386645767e-1, -.18571835020187122114, - -.48967672227195481777e-1, .17584685670380332798, - .19267984545067426324e-1, -.16335437520503462738, - .22598055455032407594e-2, .15032800884170631129, - -.17883358353754640871e-1, -.13774837869432209951, - .29227555960587143675e-1, .12604194747513151053, 0., 0., 0., 0., 0., 0., - 0., .78125000000000000000e-2, -.62377810244809812496e-1, - .23080781467370883845, -.50841310636012325368, .69834547012574056043, - -.52572723156526459672, .11464215704954976471e-1, .38698869011491210342, - -.26125646622255207507, -.16951698812361607510, .29773875898928782269, - .20130501202570367491e-1, -.26332493149159310198, - .67734613690401207009e-1, .21207315477103762715, -.11541543390889415193, - -.16249634759782417533, .13885887405041735068, .11996491328010275427, - -.14810432001630926895, -.85177658352556243411e-1, .14918860659904380587, - .57317789510444151564e-1, -.14569827645586660151, - -.35213090145965327390e-1, .13975998126844578198, 0., 0., 0., 0., 0., 0., - 0., 0., .39062500000000000000e-2, -.35101954600803571207e-1, - .14761284084133737720, -.37655033076080192966, .62410290231517322776, - -.64335622317683389875, .28188168266139524244, .22488495672137010675, - -.39393811089283576186, .75184777995770096714e-1, .28472023119398293003, - -.20410910833705899572, -.15590046962908511750, .23814567544617953125, - .54442805556829031204e-1, -.22855930338589720954, - .16303223615756629897e-1, .20172722433875559213, - -.62723406421217419404e-1, -.17012230831020922010, - .91754642766136561612e-1, .13927644821381121197, -.10886600968068418181, - -.11139075654373395292, .11797455976331702879, 0., 0., 0., 0., 0., 0., 0., - 0., 0., .19531250000000000000e-2, -.19506820659607596598e-1, - .91865676095362231937e-1, -.26604607809696493849, .51425874205091288223, - -.66047561132505329292, .48660109511591303851, -.17575661168678285615e-1, - -.36594333408055703366, .29088854695378694533, .11318677346656537927, - -.31110645235730182168, .60733219161008787341e-1, .24333848233620420826, - -.15254312332655419708, -.15995968483455388613, .19010344455215289289, - .86040636766440260000e-1, -.19652589954665259945, - -.27633388517205837713e-1, .18660848552712880387, - -.15942583868416775867e-1, -.16902042462382064786, - .47278526495327740646e-1, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .97656250000000000000e-3, -.10731084460857378207e-1, - .55939644713816406331e-1, -.18118487371914493668, .39914857299829864263, - -.60812322949933902435, .60011887183061967583, -.26002695805835928795, - -.20883922404786010096, .38988130966114638081, -.11797833550782589082, - -.25231824756239520077, .24817859972953934712, .90516417677868996417e-1, - -.26079073291293066798, .30259468817169480161e-1, .22178195264114178432, - -.10569877864302048175, -.16679648389266977455, .14637718550245050850, - .11219272032739559870, -.16359363640525750353, -.64358194509092101393e-1, - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .48828125000000000000e-3, - -.58542865274813470967e-2, .33461741635290096452e-1, - -.11979993155896201271, .29580223766987206958, -.51874761979436016742, - .62861483498014306968, -.44868895761051453296, .12567502628371529386e-1, - .35040366183235474275, -.30466868455569500886, -.70903913601490112666e-1, - .30822791893032512740, -.11969443264190207736, -.20764760317621313946, - .20629838355452128532, .95269702915334718507e-1, -.22432624768705133300, - -.33103381593477797101e-2, .20570036048155716333, - -.62208282720094518964e-1, -.17095309330441436348, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., .24414062500000000000e-3, - -.31714797501871532475e-2, .19721062526127334100e-1, - -.77311181185536498246e-1, .21124871792841566575, -.41777980401893650886, - .59401977834943551650, -.56132417807488349048, .23433675061367565951, - .20222775295220942126, -.38280372496506190127, .14443804214023095767, - .22268950939178466797, -.27211314150777981984, -.34184876506180717313e-1, - .26006498895669734842, -.97650425186005090107e-1, -.19024527660129101293, - .16789164198044635671, .10875811641651905252, -.19276785058805921298, 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .12207031250000000000e-3, - -.17078941137247586143e-2, .11477733754843910060e-1, - -.48887017020924625462e-1, .14634927241421789683, -.32156282683019547854, - .52165811920227223937, -.60001958466396926460, .41208501541480733755, - -.11366945503190350975e-2, -.33968093962672089159, .30955190935923386766, - .40657421856578262210e-1, -.29873400409871531764, .16094481791768257440, - .16876122436206497694, -.23650217045022161255, -.33070260090574765012e-1, - .22985258456375907796, -.68645651043827097771e-1, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., .61035156250000000000e-4, - -.91501857608428649078e-3, .66085179496951987952e-2, - -.30383171695850355404e-1, .98840838845366876117e-1, - -.23855447246420318989, .43322017468145613917, -.58049033744876107191, - .52533893203742699346, -.20681056202371946180, -.20180000924562504384, - .37503922291962681797, -.15988102869837429062, -.19823558102762374094, - .28393023878803799622, -.11188133439357510403e-1, -.24730368377168229255, - .14731529061377942839, .14878558042884266021, 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., .30517578125000000000e-4, - -.48804277318479845551e-3, .37696080990601968396e-2, - -.18603912108994738255e-1, .65325006755649582964e-1, - -.17162960707938819795, .34411527956476971322, -.52289350347082497959, - .57319653625674910592, -.37662253421045430413, -.14099055105384663902e-1, - .33265570610216904208, -.30921265572647566661, -.19911390594166455281e-1, - .28738590811031797718, -.18912130469738472647, -.13235936203215819193, - .25076406142356675279, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., .15258789062500000000e-4, -.25928719280954633249e-3, - .21327398937568540428e-2, -.11244626133630732010e-1, - .42375605740664331966e-1, -.12031130345907846211, .26352562258934426830, - -.44590628258512682078, .56682835613700749379, -.49116715128261660395, - .17845943097110339078, .20541650677432497477, -.36739803642257458221, - .16776034069210108273, .17920950989905112908, -.28867732805385066532, - .46473465543376206337e-1, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., .76293945312500000000e-5, -.13727610943181290891e-3, - .11979683091449349286e-2, -.67195313034570709806e-2, - .27044920779931968175e-1, -.82472196498517457862e-1, - .19570475044896150093, -.36391620788543817693, .52241392782736588032, - -.54727504974907879912, .34211551468813581183, .31580472732719957762e-1, - -.32830006549176759667, .30563797665254420769, .64905014620683140120e-2, - -.27642986248995073032, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., .38146972656250000000e-5, - -.72454147007837596854e-4, .66859847582761390285e-3, - -.39751311980366118437e-2, .17015198650201528366e-1, - -.55443621868993855715e-1, .14157060481641692131, -.28641242619559616836, - .45610665490966615415, -.55262786406029265394, .45818352706035500108, - -.14984403004611673047, -.21163807462970713245, .36007252928843413718, - -.17030961385712954159, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., .19073486328125000000e-5, - -.38135049864067468562e-4, .37101393638555730015e-3, - -.23305339886279723213e-2, .10569913448297127219e-1, - -.36640175162216897547e-1, .10010476414320235508, -.21860074212675559892, - .38124757096345313719, -.52020999209879669177, .52172632730659212045, - -.30841620620308814614, -.50322546186721500184e-1, .32577618885114899053, - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., .95367431640625000000e-6, -.20021483206955925244e-4, - .20481807322420625431e-3, -.13553476938058909882e-2, - .64919676350791905019e-2, -.23848725425069251903e-1, - .69384632678886421292e-1, -.16249711393618776934, .30736618106830314788, - -.46399909601971539157, .53765031034002467225, -.42598991476520183929, - .12130445348350215652, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., .47683715820312500000e-6, - -.10487707828484902486e-4, .11254146162337528943e-3, - -.78248929534271987118e-3, .39468337145306794566e-2, - -.15313546659475671763e-1, .47249070825218564146e-1, - -.11804374107101480543, .24031796927792491122, -.39629215049166341285, - .51629108968402548545, -.49622372075429782915, 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .23841857910156250000e-6, -.54823314130625337326e-5, - .61575377321535518154e-4, -.44877834366497538134e-3, - .23774612048621955857e-2, -.97136347645161687796e-2, - .31671599547606636717e-1, -.84028665767000747480e-1, - .18298487576742964949, -.32647878537696945218, .46970971486488895077, 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., .11920928955078125000e-6, -.28604020001177375838e-5, - .33559227978295551013e-4, -.25583821662860610560e-3, - .14201552747787302339e-2, -.60938046986874414969e-2, - .20930869247951926793e-1, -.58745021125678072911e-1, - .13613725780285953720, -.26083988356030237586, 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .59604644775390625000e-7, -.14898180663526043291e-5, - .18224991282807693921e-4, -.14504433444608833821e-3, - .84184722720281809548e-3, -.37846965430000478789e-2, - .13656355548211376864e-1, -.40409541997718853934e-1, - .99226988101858325902e-1, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .29802322387695312500e-7, -.77471708843445529468e-6, - .98649879372606876995e-5, -.81814934772838523887e-4, - .49554483992403011328e-3, -.23290922072351413938e-2, - .88068134250844034186e-2, -.27393666952485719070e-1, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., .14901161193847656250e-7, -.40226235946098233685e-6, - .53236418690561306700e-5, -.45933829691164002269e-4, - .28982005232838857913e-3, -.14212974043211018374e-2, - .56192363087488842264e-2, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .74505805969238281250e-8, -.20858299254133430408e-6, - .28648457300134381744e-5, -.25677535898258910850e-4, - .16849420429491355445e-3, -.86062824010315834002e-3, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., .37252902984619140625e-8, -.10801736017613096861e-6, - .15376606719887104015e-5, -.14296523739727437959e-4, - .97419023656050887203e-4, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .18626451492309570312e-8, -.55871592916438890146e-7, - .82331193828137454068e-6, -.79302250528382787666e-5, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., .93132257461547851562e-9, - -.28867244235852488244e-7, .43982811713864556957e-6, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., .46566128730773925781e-9, - -.14899342093408253335e-7, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., .23283064365386962891e-9 -}; - -static const double Tright[33 * 33] = { - 1., .86602540378443864678, 0., -.33071891388307382381, 0., - .20728904939721249057, 0., -.15128841196122722208, 0., - .11918864298744029244, 0., -.98352013661686631224e-1, 0., - .83727065404940845733e-1, 0., -.72893399403505841203e-1, 0., - .64544632643375022436e-1, 0., -.57913170372415565639e-1, 0., - .52518242575729562263e-1, 0., -.48043311993977520457e-1, 0., - .44271433659733990243e-1, 0., -.41048928022856771981e-1, 0., - .38263878662008271459e-1, 0., -.35832844026365304501e-1, 0., 0., - .50000000000000000000, .96824583655185422130, .57282196186948000082, - -.21650635094610966169, -.35903516540862679125, .97578093724974971969e-1, - .26203921611325660506, -.55792409597991015609e-1, -.20644078533943456204, - .36172381205961199479e-1, .17035068468874958194, - -.25371838001497225980e-1, -.14501953125000000000, - .18786835250972344757e-1, .12625507130328301066, - -.14473795929590520582e-1, -.11179458309419422675, - .11494434254897626155e-1, .10030855351241635862, - -.93498556820544479096e-2, -.90964264465390582629e-1, - .77546391824364392762e-2, .83213457337452292745e-1, - -.65358085945588638605e-2, -.76680372422574234569e-1, - .55835321940047427169e-2, .71098828931825789428e-1, - -.48253327982967591019e-2, -.66274981937248958553e-1, - .42118078245337801387e-2, .62064306433355646267e-1, - -.37083386598903548973e-2, 0., 0., .25000000000000000000, - .73950997288745200531, .83852549156242113615, .23175620272173946716, - -.37791833195149451496, -.25710129174850522325, .21608307321780204633, - .22844049245646009157, -.14009503000335388415, -.19897685605518413847, - .98264706042471226893e-1, .17445445004279014046, - -.72761100054958328401e-1, -.15463589893742108388, - .56056770591708784481e-1, .13855313872640495158, - -.44517752443294564781e-1, -.12534277657695128850, - .36211835346039665762e-1, .11434398255136139683, - -.30033588409423828125e-1, -.10506705408753910481, - .25313077840725783008e-1, .97149327637744872155e-1, - -.21624927200393328444e-1, -.90319582367202122625e-1, - .18688433567711780666e-1, .84372291635345108584e-1, - -.16312261561845420752e-1, -.79149526894804751586e-1, - .14362333871852474757e-1, 0., 0., 0., .12500000000000000000, - .49607837082461073572, .82265291131801144317, .59621200088559103072, - -.80054302859059362371e-1, -.42612156697795759420, - -.90098145270865592887e-1, .29769623255090078484, .13630307904779758221, - -.21638835185708931831, -.14600247270306082052, .16348801804014290453, - .14340708728599057249, -.12755243353979286190, -.13661523715071346961, - .10215585947881057394, .12864248070157166547, -.83592528025348693602e-1, - -.12066728689302565222, .69633728678718053052e-1, .11314245177331919532, - -.58882939251410088028e-1, -.10621835858758221487, - .50432266865187597572e-1, .99916834723527771581e-1, - -.43672094283057258509e-1, -.94206380251950852413e-1, - .38181356812697746418e-1, .89035739656537771225e-1, - -.33661934598216332678e-1, 0., 0., 0., 0., .62500000000000000000e-1, - .31093357409581873586, .67604086414949799246, .75644205980613611039, - .28990586430124175741, -.30648508196770360914, -.35801372616842500052, - .91326869828709014708e-1, .31127929687500000000, .90915752838698393094e-2, - -.25637381283965534330, -.57601077850322797594e-1, .21019685709225757945, - .81244992138514014256e-1, -.17375078516720988858, - -.92289437277967051125e-1, .14527351914265391374, - .96675340792832019889e-1, -.12289485697108543415, - -.97448175340011084006e-1, .10511755943298339844, - .96242247086378239657e-1, -.90822942272780513537e-1, - -.93966350452322132384e-1, .79189411876493712558e-1, - .91139307067989309325e-1, -.69613039934383197265e-1, - -.88062491671135767870e-1, .61646331729340817494e-1, 0., 0., 0., 0., 0., - .31250000000000000000e-1, .18684782411095934408, .50176689760410660236, - .74784031498626095398, .56472001151566251186, -.14842464993721351203e-1, - -.41162920273003120936, -.20243071230196532282, .23772054897172750436, - .24963810923972235950, -.12116179938394678936, -.24330535483519110663, - .47903849781124471359e-1, .22133299683101224293, - -.20542915138527200983e-2, -.19653465717678146728, - -.26818172626509178444e-1, .17319122357631210944, - .45065391411065545445e-1, -.15253391395444065941, - -.56543897711725408302e-1, .13469154928743585367, - .63632471400208840155e-1, -.11941684923913523817, - -.67828850207933293098e-1, .10636309084510652670, - .70095786922999181504e-1, -.95187373095150709082e-1, 0., 0., 0., 0., 0., - 0., .15625000000000000000e-1, .10909562534194485289, - .34842348626527747318, .64461114561628111443, .69382480527334683659, - .29551102358528827763, -.25527584713978439819, -.38878771718544715394, - -.82956185835347407489e-2, .31183177761966943912, .12831420840372374767, - -.22067618205599434368, -.17569196937129496961, .14598057000132284135, - .18864406621763419484, -.89921002550386645767e-1, -.18571835020187122114, - .48967672227195481777e-1, .17584685670380332798, - -.19267984545067426324e-1, -.16335437520503462738, - -.22598055455032407594e-2, .15032800884170631129, - .17883358353754640871e-1, -.13774837869432209951, - -.29227555960587143675e-1, .12604194747513151053, 0., 0., 0., 0., 0., 0., - 0., .78125000000000000000e-2, .62377810244809812496e-1, - .23080781467370883845, .50841310636012325368, .69834547012574056043, - .52572723156526459672, .11464215704954976471e-1, -.38698869011491210342, - -.26125646622255207507, .16951698812361607510, .29773875898928782269, - -.20130501202570367491e-1, -.26332493149159310198, - -.67734613690401207009e-1, .21207315477103762715, .11541543390889415193, - -.16249634759782417533, -.13885887405041735068, .11996491328010275427, - .14810432001630926895, -.85177658352556243411e-1, -.14918860659904380587, - .57317789510444151564e-1, .14569827645586660151, - -.35213090145965327390e-1, -.13975998126844578198, 0., 0., 0., 0., 0., 0., - 0., 0., .39062500000000000000e-2, .35101954600803571207e-1, - .14761284084133737720, .37655033076080192966, .62410290231517322776, - .64335622317683389875, .28188168266139524244, -.22488495672137010675, - -.39393811089283576186, -.75184777995770096714e-1, .28472023119398293003, - .20410910833705899572, -.15590046962908511750, -.23814567544617953125, - .54442805556829031204e-1, .22855930338589720954, .16303223615756629897e-1, - -.20172722433875559213, -.62723406421217419404e-1, .17012230831020922010, - .91754642766136561612e-1, -.13927644821381121197, -.10886600968068418181, - .11139075654373395292, .11797455976331702879, 0., 0., 0., 0., 0., 0., 0., - 0., 0., .19531250000000000000e-2, .19506820659607596598e-1, - .91865676095362231937e-1, .26604607809696493849, .51425874205091288223, - .66047561132505329292, .48660109511591303851, .17575661168678285615e-1, - -.36594333408055703366, -.29088854695378694533, .11318677346656537927, - .31110645235730182168, .60733219161008787341e-1, -.24333848233620420826, - -.15254312332655419708, .15995968483455388613, .19010344455215289289, - -.86040636766440260000e-1, -.19652589954665259945, - .27633388517205837713e-1, .18660848552712880387, .15942583868416775867e-1, - -.16902042462382064786, -.47278526495327740646e-1, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., .97656250000000000000e-3, .10731084460857378207e-1, - .55939644713816406331e-1, .18118487371914493668, .39914857299829864263, - .60812322949933902435, .60011887183061967583, .26002695805835928795, - -.20883922404786010096, -.38988130966114638081, -.11797833550782589082, - .25231824756239520077, .24817859972953934712, -.90516417677868996417e-1, - -.26079073291293066798, -.30259468817169480161e-1, .22178195264114178432, - .10569877864302048175, -.16679648389266977455, -.14637718550245050850, - .11219272032739559870, .16359363640525750353, -.64358194509092101393e-1, - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .48828125000000000000e-3, - .58542865274813470967e-2, .33461741635290096452e-1, .11979993155896201271, - .29580223766987206958, .51874761979436016742, .62861483498014306968, - .44868895761051453296, .12567502628371529386e-1, -.35040366183235474275, - -.30466868455569500886, .70903913601490112666e-1, .30822791893032512740, - .11969443264190207736, -.20764760317621313946, -.20629838355452128532, - .95269702915334718507e-1, .22432624768705133300, - -.33103381593477797101e-2, -.20570036048155716333, - -.62208282720094518964e-1, .17095309330441436348, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., .24414062500000000000e-3, - .31714797501871532475e-2, .19721062526127334100e-1, - .77311181185536498246e-1, .21124871792841566575, .41777980401893650886, - .59401977834943551650, .56132417807488349048, .23433675061367565951, - -.20222775295220942126, -.38280372496506190127, -.14443804214023095767, - .22268950939178466797, .27211314150777981984, -.34184876506180717313e-1, - -.26006498895669734842, -.97650425186005090107e-1, .19024527660129101293, - .16789164198044635671, -.10875811641651905252, -.19276785058805921298, 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .12207031250000000000e-3, - .17078941137247586143e-2, .11477733754843910060e-1, - .48887017020924625462e-1, .14634927241421789683, .32156282683019547854, - .52165811920227223937, .60001958466396926460, .41208501541480733755, - .11366945503190350975e-2, -.33968093962672089159, -.30955190935923386766, - .40657421856578262210e-1, .29873400409871531764, .16094481791768257440, - -.16876122436206497694, -.23650217045022161255, .33070260090574765012e-1, - .22985258456375907796, .68645651043827097771e-1, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., .61035156250000000000e-4, - .91501857608428649078e-3, .66085179496951987952e-2, - .30383171695850355404e-1, .98840838845366876117e-1, .23855447246420318989, - .43322017468145613917, .58049033744876107191, .52533893203742699346, - .20681056202371946180, -.20180000924562504384, -.37503922291962681797, - -.15988102869837429062, .19823558102762374094, .28393023878803799622, - .11188133439357510403e-1, -.24730368377168229255, -.14731529061377942839, - .14878558042884266021, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., .30517578125000000000e-4, .48804277318479845551e-3, - .37696080990601968396e-2, .18603912108994738255e-1, - .65325006755649582964e-1, .17162960707938819795, .34411527956476971322, - .52289350347082497959, .57319653625674910592, .37662253421045430413, - -.14099055105384663902e-1, -.33265570610216904208, -.30921265572647566661, - .19911390594166455281e-1, .28738590811031797718, .18912130469738472647, - -.13235936203215819193, -.25076406142356675279, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .15258789062500000000e-4, - .25928719280954633249e-3, .21327398937568540428e-2, - .11244626133630732010e-1, .42375605740664331966e-1, .12031130345907846211, - .26352562258934426830, .44590628258512682078, .56682835613700749379, - .49116715128261660395, .17845943097110339078, -.20541650677432497477, - -.36739803642257458221, -.16776034069210108273, .17920950989905112908, - .28867732805385066532, .46473465543376206337e-1, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .76293945312500000000e-5, - .13727610943181290891e-3, .11979683091449349286e-2, - .67195313034570709806e-2, .27044920779931968175e-1, - .82472196498517457862e-1, .19570475044896150093, .36391620788543817693, - .52241392782736588032, .54727504974907879912, .34211551468813581183, - -.31580472732719957762e-1, -.32830006549176759667, -.30563797665254420769, - .64905014620683140120e-2, .27642986248995073032, 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .38146972656250000000e-5, - .72454147007837596854e-4, .66859847582761390285e-3, - .39751311980366118437e-2, .17015198650201528366e-1, - .55443621868993855715e-1, .14157060481641692131, .28641242619559616836, - .45610665490966615415, .55262786406029265394, .45818352706035500108, - .14984403004611673047, -.21163807462970713245, -.36007252928843413718, - -.17030961385712954159, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., .19073486328125000000e-5, - .38135049864067468562e-4, .37101393638555730015e-3, - .23305339886279723213e-2, .10569913448297127219e-1, - .36640175162216897547e-1, .10010476414320235508, .21860074212675559892, - .38124757096345313719, .52020999209879669177, .52172632730659212045, - .30841620620308814614, -.50322546186721500184e-1, -.32577618885114899053, - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., .95367431640625000000e-6, .20021483206955925244e-4, - .20481807322420625431e-3, .13553476938058909882e-2, - .64919676350791905019e-2, .23848725425069251903e-1, - .69384632678886421292e-1, .16249711393618776934, .30736618106830314788, - .46399909601971539157, .53765031034002467225, .42598991476520183929, - .12130445348350215652, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., .47683715820312500000e-6, - .10487707828484902486e-4, .11254146162337528943e-3, - .78248929534271987118e-3, .39468337145306794566e-2, - .15313546659475671763e-1, .47249070825218564146e-1, .11804374107101480543, - .24031796927792491122, .39629215049166341285, .51629108968402548545, - .49622372075429782915, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., .23841857910156250000e-6, - .54823314130625337326e-5, .61575377321535518154e-4, - .44877834366497538134e-3, .23774612048621955857e-2, - .97136347645161687796e-2, .31671599547606636717e-1, - .84028665767000747480e-1, .18298487576742964949, .32647878537696945218, - .46970971486488895077, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .11920928955078125000e-6, - .28604020001177375838e-5, .33559227978295551013e-4, - .25583821662860610560e-3, .14201552747787302339e-2, - .60938046986874414969e-2, .20930869247951926793e-1, - .58745021125678072911e-1, .13613725780285953720, .26083988356030237586, - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., .59604644775390625000e-7, - .14898180663526043291e-5, .18224991282807693921e-4, - .14504433444608833821e-3, .84184722720281809548e-3, - .37846965430000478789e-2, .13656355548211376864e-1, - .40409541997718853934e-1, .99226988101858325902e-1, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., .29802322387695312500e-7, .77471708843445529468e-6, - .98649879372606876995e-5, .81814934772838523887e-4, - .49554483992403011328e-3, .23290922072351413938e-2, - .88068134250844034186e-2, .27393666952485719070e-1, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., .14901161193847656250e-7, .40226235946098233685e-6, - .53236418690561306700e-5, .45933829691164002269e-4, - .28982005232838857913e-3, .14212974043211018374e-2, - .56192363087488842264e-2, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .74505805969238281250e-8, .20858299254133430408e-6, - .28648457300134381744e-5, .25677535898258910850e-4, - .16849420429491355445e-3, .86062824010315834002e-3, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., .37252902984619140625e-8, .10801736017613096861e-6, - .15376606719887104015e-5, .14296523739727437959e-4, - .97419023656050887203e-4, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - .18626451492309570312e-8, .55871592916438890146e-7, - .82331193828137454068e-6, .79302250528382787666e-5, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., .93132257461547851562e-9, - .28867244235852488244e-7, .43982811713864556957e-6, 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., .46566128730773925781e-9, - .14899342093408253335e-7, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., - 0., 0., .23283064365386962891e-9 -}; - -/* Allocates a workspace for the given maximum number of intervals. - Note that if the workspace gets filled, the intervals with the - lowest error estimates are dropped. The maximum number of - intervals is therefore not the maximum number of intervals - that will be computed, but merely the size of the buffer. - */ - -/* Compute the product of the fx with one of the inverse - Vandermonde-like matrices. */ - -void -Vinvfx (const double *fx, double *c, const int d) -{ - - int i, j; - - switch (d) - { - case 0: - for (i = 0; i <= 4; i++) - { - c[i] = 0.0; - for (j = 0; j <= 4; j++) - c[i] += V1inv[i * 5 + j] * fx[j * 8]; - } - break; - case 1: - for (i = 0; i <= 8; i++) - { - c[i] = 0.0; - for (j = 0; j <= 8; j++) - c[i] += V2inv[i * 9 + j] * fx[j * 4]; - } - break; - case 2: - for (i = 0; i <= 16; i++) - { - c[i] = 0.0; - for (j = 0; j <= 16; j++) - c[i] += V3inv[i * 17 + j] * fx[j * 2]; - } - break; - case 3: - for (i = 0; i <= 32; i++) - { - c[i] = 0.0; - for (j = 0; j <= 32; j++) - c[i] += V4inv[i * 33 + j] * fx[j]; - } - break; - } - -} - - -/* Downdate the interpolation given by the n coefficients c - by removing the nodes with indices in nans. */ - -void -downdate (double *c, int n, int d, int *nans, int nnans) -{ - - static const int bidx[4] = { 0, 6, 16, 34 }; - double b_new[34], alpha; - int i, j; - - for (i = 0; i <= n + 1; i++) - b_new[i] = bee[bidx[d] + i]; - for (i = 0; i < nnans; i++) - { - b_new[n + 1] = b_new[n + 1] / Lalpha[n]; - b_new[n] = (b_new[n] + xi[nans[i]] * b_new[n + 1]) / Lalpha[n - 1]; - for (j = n - 1; j > 0; j--) - b_new[j] = - (b_new[j] + xi[nans[i]] * b_new[j + 1] - - Lgamma[j + 1] * b_new[j + 2]) / Lalpha[j - 1]; - for (j = 0; j <= n; j++) - b_new[j] = b_new[j + 1]; - alpha = c[n] / b_new[n]; - for (j = 0; j < n; j++) - c[j] -= alpha * b_new[j]; - c[n] = 0; - n--; - } - -} - - -/* The actual integration routine. */ - -DEFUN_DLD (quadcc, args, nargout, -"-*- texinfo -*-\n\ -@deftypefn {Function File} {@var{q} =} quadcc (@var{f}, @var{a}, @var{b})\n\ -@deftypefnx {Function File} {@var{q} =} quadcc (@var{f}, @var{a}, @var{b}, @var{tol})\n\ -@deftypefnx {Function File} {@var{q} =} quadcc (@var{f}, @var{a}, @var{b}, @var{tol}, @var{sing})\n\ -@deftypefnx {Function File} {[@var{q}, @var{err}, @var{nr_points}] =} quadcc (@dots{})\n\ -Numerically evaluate the integral of @var{f} from @var{a} to @var{b}\n\ -using the doubly-adaptive Clenshaw-Curtis quadrature described by P. Gonnet\n\ -in @cite{Increasing the Reliability of Adaptive Quadrature Using Explicit\n\ -Interpolants}.\n\ -@var{f} is a function handle, inline function, or string\n\ -containing the name of the function to evaluate.\n\ -The function @var{f} must be vectorized and must return a vector of output\n\ -values if given a vector of input values. For example,\n\ -\n\ -@example\n\ -f = @@(x) x .* sin (1./x) .* sqrt (abs (1 - x));\n\ -@end example\n\ -\n\ -@noindent\n\ -which uses the element-by-element `dot' form for all operators.\n\ -\n\ -@var{a} and @var{b} are the lower and upper limits of integration. Either\n\ -or both limits may be infinite. @code{quadcc} handles an inifinite limit\n\ -by substituting the variable of integration with @code{x = tan (pi/2*u)}.\n\ -\n\ -The optional argument @var{tol} defines the relative tolerance used to stop\n\ -the integration procedure. The default value is @math{1e^{-6}}.\n\ -\n\ -The optional argument @var{sing} contains a list of points where the\n\ -integrand has known singularities, or discontinuities\n\ -in any of its derivatives, inside the integration interval.\n\ -For the example above, which has a discontinuity at x=1, the call to\n\ -@code{quadcc} would be as follows\n\ -\n\ -@example\n\ -int = quadcc (f, a, b, 1.0e-6, [ 1 ]);\n\ -@end example\n\ -\n\ -The result of the integration is returned in @var{q}.\n\ -@var{err} is an estimate of the absolute integration error and\n\ -@var{nr_points} is the number of points at which the integrand was evaluated.\n\ -If the adaptive integration did not converge, the value of\n\ -@var{err} will be larger than the requested tolerance. Therefore, it is\n\ -recommended to verify this value for difficult integrands.\n\ -\n\ -@code{quadcc} is capable of dealing with non-numeric\n\ -values of the integrand such as @code{NaN} or @code{Inf}.\n\ -If the integral diverges, and @code{quadcc} detects this,\n\ -then a warning is issued and @code{Inf} or @code{-Inf} is returned.\n\ -\n\ -Note: @code{quadcc} is a general purpose quadrature algorithm\n\ -and, as such, may be less efficient for a smooth or otherwise\n\ -well-behaved integrand than other methods such as @code{quadgk}.\n\ -\n\ -The algorithm uses Clenshaw-Curtis quadrature rules of increasing\n\ -degree in each interval and bisects the interval if either the\n\ -function does not appear to be smooth or a rule of maximum\n\ -degree has been reached. The error estimate is computed from the\n\ -L2-norm of the difference between two successive interpolations\n\ -of the integrand over the nodes of the respective quadrature rules.\n\ -\n\ -Reference: P. Gonnet, @cite{Increasing the Reliability of Adaptive\n\ -Quadrature Using Explicit Interpolants}, ACM Transactions on\n\ -Mathematical Software, Vol. 37, Issue 3, Article No. 3, 2010.\n\ -@seealso{quad, quadv, quadl, quadgk, trapz, dblquad, triplequad}\n\ -@end deftypefn") -{ - octave_value_list retval; - - /* Some constants that we will need. */ - static const int n[4] = { 4, 8, 16, 32 }; - static const int skip[4] = { 8, 4, 2, 1 }; - static const int idx[4] = { 0, 5, 14, 31 }; - static const double w = M_SQRT2 / 2; - static const int ndiv_max = 20; - - /* The interval heap. */ - cquad_ival ivals[cquad_heapsize]; - int heap[cquad_heapsize]; - - /* Arguments left and right */ - int nargin = args.length (); - octave_function *fcn; - double a, b, tol, iivals[cquad_heapsize], *sing; - - /* Variables needed for transforming the integrand. */ - bool wrap = false; - double xw; - - /* Stuff we will need to call the integrand. */ - octave_value_list fargs, fvals; - - /* Actual variables (as opposed to constants above). */ - double m, h, ml, hl, mr, hr, temp; - double igral, err, igral_final, err_final; - int nivals, neval = 0; - int i, j, d, split, t; - int nnans, nans[33]; - cquad_ival *iv, *ivl, *ivr; - double nc, ncdiff; - - - /* Parse the input arguments. */ - if (nargin < 3) - { - print_usage (); - return retval; - } - - if (args(0).is_function_handle () || args(0).is_inline_function ()) - fcn = args(0).function_value (); - else - { - std::string fcn_name = unique_symbol_name ("__quadcc_fcn_"); - std::string fname = "function y = "; - fname.append (fcn_name); - fname.append ("(x) y = "); - fcn = extract_function (args(0), "quadcc", fcn_name, fname, - "; endfunction"); - } - - if (!args(1).is_real_scalar ()) - { - error ("quadcc: lower limit of integration (A) must be a single real scalar"); - return retval; - } - else - a = args(1).double_value (); - - if (!args(2).is_real_scalar ()) - { - error ("quadcc: upper limit of integration (B) must be a single real scalar"); - return retval; - } - else - b = args(2).double_value (); - - if (nargin < 4 || args(3).is_empty ()) - tol = 1.0e-6; - else if (!args(3).is_real_scalar () || args(3).double_value () <= 0) - { - error ("quadcc: tolerance (TOL) must be a single real scalar > 0"); - return retval; - } - else - tol = args(3).double_value (); - - if (nargin < 5) - { - nivals = 1; - iivals[0] = a; - iivals[1] = b; - } - else if (!(args(4).is_real_scalar () || args(4).is_real_matrix ())) - { - error ("quadcc: list of singularities (SING) must be a vector of real values"); - return retval; - } - else - { - nivals = 1 + args(4).length (); - if (nivals > cquad_heapsize) - { - error ("quadcc: maximum number of singular points is limited to %i", - cquad_heapsize-1); - return retval; - } - sing = args(4).array_value ().fortran_vec (); - iivals[0] = a; - for (i = 0; i < nivals - 2; i++) - iivals[i + 1] = sing[i]; - iivals[nivals] = b; - } - - /* If a or b are +/-Inf, transform the integral. */ - if (xisinf (a) || xisinf (b)) - { - wrap = true; - for (i = 0; i <= nivals; i++) - if (xisinf (iivals[i])) - iivals[i] = gnulib::copysign (1.0, iivals[i]); - else - iivals[i] = 2.0 * atan (iivals[i]) / M_PI; - } - - - /* Initialize the heaps. */ - for (i = 0; i < cquad_heapsize; i++) - heap[i] = i; - - - /* Create the first interval(s). */ - igral = 0.0; - err = 0.0; - for (j = 0; j < nivals; j++) - { - - /* Initialize the interval. */ - iv = &(ivals[heap[j]]); - m = (iivals[j] + iivals[j + 1]) / 2; - h = (iivals[j + 1] - iivals[j]) / 2; - nnans = 0; - ColumnVector ex (33); - if (wrap) - { - for (i = 0; i <= n[3]; i++) - ex (i) = tan (M_PI / 2 * (m + xi[i] * h)); - } - else - { - for (i = 0; i <= n[3]; i++) - ex (i) = m + xi[i] * h; - } - fargs(0) = ex; - fvals = feval (fcn, fargs, 1); - if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) - { - error ("quadcc: integrand F must return a single, real-valued vector"); - return retval; - } - Matrix effex = fvals(0).matrix_value (); - if (effex.length () != ex.length ()) - { - error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); - return retval; - } - for (i = 0; i <= n[3]; i++) - { - iv->fx[i] = effex (i); - if (wrap) - { - xw = ex(i); - iv->fx[i] *= (1.0 + xw * xw) * M_PI / 2; - } - neval++; - if (!xfinite (iv->fx[i])) - { - nans[nnans++] = i; - iv->fx[i] = 0.0; - } - } - Vinvfx (iv->fx, &(iv->c[idx[3]]), 3); - Vinvfx (iv->fx, &(iv->c[idx[2]]), 2); - Vinvfx (iv->fx, &(iv->c[0]), 0); - for (i = 0; i < nnans; i++) - iv->fx[i] = octave_NaN; - iv->a = iivals[j]; - iv->b = iivals[j + 1]; - iv->depth = 3; - iv->rdepth = 1; - iv->ndiv = 0; - iv->igral = 2 * h * iv->c[idx[3]] * w; - nc = 0.0; - for (i = n[2] + 1; i <= n[3]; i++) - { - temp = iv->c[idx[3] + i]; - nc += temp * temp; - } - ncdiff = nc; - for (i = 0; i <= n[2]; i++) - { - temp = iv->c[idx[2] + i] - iv->c[idx[3] + i]; - ncdiff += temp * temp; - nc += iv->c[idx[3] + i] * iv->c[idx[3] + i]; - } - ncdiff = sqrt (ncdiff); - nc = sqrt (nc); - iv->err = ncdiff * 2 * h; - if (ncdiff / nc > 0.1 && iv->err < 2 * h * nc) - iv->err = 2 * h * nc; - - /* Tabulate this interval's data. */ - igral += iv->igral; - err += iv->err; - - /* Sift it up the heap. */ - i = j; - while (i > 0 && ivals[heap[i / 2]].err < ivals[heap[i]].err) - { - temp = heap[i]; - heap[i] = heap[i / 2]; - heap[i / 2] = temp; - i /= 2; - } - - } - - - /* Initialize some global values. */ - igral_final = 0.0; - err_final = 0.0; - - - /* Main loop. */ - while (nivals > 0 && err > 0.0 && err > fabs (igral) * tol - && !(err_final > fabs (igral) * tol - && err - err_final < fabs (igral) * tol)) - { - - /* Allow the user to interrupt. */ - OCTAVE_QUIT; - - /* Put our finger on the interval with the largest error. */ - iv = &(ivals[heap[0]]); - m = (iv->a + iv->b) / 2; - h = (iv->b - iv->a) / 2; - -/* printf - ("quadcc: processing ival %i (of %i) with [%e,%e] int=%e, err=%e, depth=%i\n", - heap[0], nivals, iv->a, iv->b, iv->igral, iv->err, iv->depth); -*/ - /* Should we try to increase the degree? */ - if (iv->depth < 3) - { - - /* Keep tabs on some variables. */ - d = ++iv->depth; - - /* Get the new (missing) function values */ - { - ColumnVector ex (n[d] / 2); - if (wrap) - { - for (i = 0; i < n[d] / 2; i++) - ex (i) = - tan (M_PI / 2 * (m + xi[(2 * i + 1) * skip[d]] * h)); - } - else - { - for (i = 0; i < n[d] / 2; i++) - ex (i) = m + xi[(2 * i + 1) * skip[d]] * h; - } - fargs(0) = ex; - fvals = feval (fcn, fargs, 1); - if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) - { - error ("quadcc: integrand F must return a single, real-valued vector"); - return retval; - } - Matrix effex = fvals(0).matrix_value (); - if (effex.length () != ex.length ()) - { - error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); - return retval; - } - neval += effex.length (); - for (i = 0; i < n[d] / 2; i++) - { - j = (2 * i + 1) * skip[d]; - iv->fx[j] = effex (i); - if (wrap) - { - xw = ex(i); - iv->fx[j] *= (1.0 + xw * xw) * M_PI / 2; - } - } - } - nnans = 0; - for (i = 0; i <= 32; i += skip[d]) - { - if (!xfinite (iv->fx[i])) - { - nans[nnans++] = i; - iv->fx[i] = 0.0; - } - } - - /* Compute the new coefficients. */ - Vinvfx (iv->fx, &(iv->c[idx[d]]), d); - /* Downdate any NaNs. */ - if (nnans > 0) - { - downdate (&(iv->c[idx[d]]), n[d], d, nans, nnans); - for (i = 0; i < nnans; i++) - iv->fx[i] = octave_NaN; - } - - /* Compute the error estimate. */ - nc = 0.0; - for (i = n[d - 1] + 1; i <= n[d]; i++) - { - temp = iv->c[idx[d] + i]; - nc += temp * temp; - } - ncdiff = nc; - for (i = 0; i <= n[d - 1]; i++) - { - temp = iv->c[idx[d - 1] + i] - iv->c[idx[d] + i]; - ncdiff += temp * temp; - nc += iv->c[idx[d] + i] * iv->c[idx[d] + i]; - } - ncdiff = sqrt (ncdiff); - nc = sqrt (nc); - iv->err = ncdiff * 2 * h; - /* Compute the local integral. */ - iv->igral = 2 * h * w * iv->c[idx[d]]; - /* Split the interval prematurely? */ - split = (nc > 0 && ncdiff / nc > 0.1); - } - - /* Maximum degree reached, just split. */ - else - { - split = 1; - } - - - /* Should we drop this interval? */ - if ((m + h * xi[0]) >= (m + h * xi[1]) - || (m + h * xi[31]) >= (m + h * xi[32]) - || iv->err < fabs (iv->igral) * DBL_EPSILON * 10) - { - -/* printf - ("quadcc: dropping ival %i (of %i) with [%e,%e] int=%e, err=%e, depth=%i\n", - heap[0], nivals, iv->a, iv->b, iv->igral, iv->err, - iv->depth); -*/ - /* Keep this interval's contribution */ - err_final += iv->err; - igral_final += iv->igral; - /* Swap with the last element on the heap */ - t = heap[nivals - 1]; - heap[nivals - 1] = heap[0]; - heap[0] = t; - nivals--; - /* Fix up the heap */ - i = 0; - while (2 * i + 1 < nivals) - { - - /* Get the kids */ - j = 2 * i + 1; - /* If the j+1st entry exists and is larger than the jth, - use it instead. */ - if (j + 1 < nivals - && ivals[heap[j + 1]].err >= ivals[heap[j]].err) - j++; - /* Do we need to move the ith entry up? */ - if (ivals[heap[j]].err <= ivals[heap[i]].err) - break; - else - { - t = heap[j]; - heap[j] = heap[i]; - heap[i] = t; - i = j; - } - } - - } - - /* Do we need to split this interval? */ - else if (split) - { - - /* Some values we will need often... */ - d = iv->depth; - /* Generate the interval on the left */ - ivl = &(ivals[heap[nivals++]]); - ivl->a = iv->a; - ivl->b = m; - ml = (ivl->a + ivl->b) / 2; - hl = h / 2; - ivl->depth = 0; - ivl->rdepth = iv->rdepth + 1; - ivl->fx[0] = iv->fx[0]; - ivl->fx[32] = iv->fx[16]; - { - ColumnVector ex (n[0] - 1); - if (wrap) - { - for (i = 0; i < n[0] - 1; i++) - ex (i) = tan (M_PI / 2 * (ml + xi[(i + 1) * skip[0]] * hl)); - } - else - { - for (i = 0; i < n[0] - 1; i++) - ex (i) = ml + xi[(i + 1) * skip[0]] * hl; - } - fargs(0) = ex; - fvals = feval (fcn, fargs, 1); - if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) - { - error ("quadcc: integrand F must return a single, real-valued vector"); - return retval; - } - Matrix effex = fvals(0).matrix_value (); - if (effex.length () != ex.length ()) - { - error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); - return retval; - } - neval += effex.length (); - for (i = 0; i < n[0] - 1; i++) - { - j = (i + 1) * skip[0]; - ivl->fx[j] = effex (i); - if (wrap) - { - xw = ex(i); - ivl->fx[j] *= (1.0 + xw * xw) * M_PI / 2; - } - } - } - nnans = 0; - for (i = 0; i <= 32; i += skip[0]) - { - if (!xfinite (ivl->fx[i])) - { - nans[nnans++] = i; - ivl->fx[i] = 0.0; - } - } - Vinvfx (ivl->fx, ivl->c, 0); - if (nnans > 0) - { - downdate (ivl->c, n[0], 0, nans, nnans); - for (i = 0; i < nnans; i++) - ivl->fx[i] = octave_NaN; - } - for (i = 0; i <= n[d]; i++) - { - ivl->c[idx[d] + i] = 0.0; - for (j = i; j <= n[d]; j++) - ivl->c[idx[d] + i] += Tleft[i * 33 + j] * iv->c[idx[d] + j]; - } - ncdiff = 0.0; - for (i = 0; i <= n[0]; i++) - { - temp = ivl->c[i] - ivl->c[idx[d] + i]; - ncdiff += temp * temp; - } - for (i = n[0] + 1; i <= n[d]; i++) - { - temp = ivl->c[idx[d] + i]; - ncdiff += temp * temp; - } - ncdiff = sqrt (ncdiff); - ivl->err = ncdiff * h; - /* Check for divergence. */ - ivl->ndiv = iv->ndiv + (fabs (iv->c[0]) > 0 - && ivl->c[0] / iv->c[0] > 2); - if (ivl->ndiv > ndiv_max && 2 * ivl->ndiv > ivl->rdepth) - { - igral = gnulib::copysign (octave_Inf, igral); - warning ("quadcc: divergent integral detected"); - break; - } - - /* Compute the local integral. */ - ivl->igral = h * w * ivl->c[0]; - - - /* Generate the interval on the right */ - ivr = &(ivals[heap[nivals++]]); - ivr->a = m; - ivr->b = iv->b; - mr = (ivr->a + ivr->b) / 2; - hr = h / 2; - ivr->depth = 0; - ivr->rdepth = iv->rdepth + 1; - ivr->fx[0] = iv->fx[16]; - ivr->fx[32] = iv->fx[32]; - { - ColumnVector ex (n[0] - 1); - if (wrap) - { - for (i = 0; i < n[0] - 1; i++) - ex (i) = tan (M_PI / 2 * (mr + xi[(i + 1) * skip[0]] * hr)); - } - else - { - for (i = 0; i < n[0] - 1; i++) - ex (i) = mr + xi[(i + 1) * skip[0]] * hr; - } - fargs(0) = ex; - fvals = feval (fcn, fargs, 1); - if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) - { - error ("quadcc: integrand F must return a single, real-valued vector"); - return retval; - } - Matrix effex = fvals(0).matrix_value (); - if (effex.length () != ex.length ()) - { - error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); - return retval; - } - neval += effex.length (); - for (i = 0; i < n[0] - 1; i++) - { - j = (i + 1) * skip[0]; - ivr->fx[j] = effex (i); - if (wrap) - { - xw = ex(i); - ivr->fx[j] *= (1.0 + xw * xw) * M_PI / 2; - } - } - } - nnans = 0; - for (i = 0; i <= 32; i += skip[0]) - { - if (!xfinite (ivr->fx[i])) - { - nans[nnans++] = i; - ivr->fx[i] = 0.0; - } - } - Vinvfx (ivr->fx, ivr->c, 0); - if (nnans > 0) - { - downdate (ivr->c, n[0], 0, nans, nnans); - for (i = 0; i < nnans; i++) - ivr->fx[i] = octave_NaN; - } - for (i = 0; i <= n[d]; i++) - { - ivr->c[idx[d] + i] = 0.0; - for (j = i; j <= n[d]; j++) - ivr->c[idx[d] + i] += Tright[i * 33 + j] * iv->c[idx[d] + j]; - } - ncdiff = 0.0; - for (i = 0; i <= n[0]; i++) - { - temp = ivr->c[i] - ivr->c[idx[d] + i]; - ncdiff += temp * temp; - } - for (i = n[0] + 1; i <= n[d]; i++) - { - temp = ivr->c[idx[d] + i]; - ncdiff += temp * temp; - } - ncdiff = sqrt (ncdiff); - ivr->err = ncdiff * h; - /* Check for divergence. */ - ivr->ndiv = iv->ndiv + (fabs (iv->c[0]) > 0 - && ivr->c[0] / iv->c[0] > 2); - if (ivr->ndiv > ndiv_max && 2 * ivr->ndiv > ivr->rdepth) - { - igral = gnulib::copysign (octave_Inf, igral); - warning ("quadcc: divergent integral detected"); - break; - } - - /* Compute the local integral. */ - ivr->igral = h * w * ivr->c[0]; - - - /* Fix-up the heap: we now have one interval on top - that we don't need any more and two new, unsorted - ones at the bottom. */ - /* Flip the last interval to the top of the heap and - sift down. */ - t = heap[nivals - 1]; - heap[nivals - 1] = heap[0]; - heap[0] = t; - nivals--; - /* Sift this interval back down the heap. */ - i = 0; - while (2 * i + 1 < nivals - 1) - { - j = 2 * i + 1; - if (j + 1 < nivals - 1 - && ivals[heap[j + 1]].err >= ivals[heap[j]].err) - j++; - if (ivals[heap[j]].err <= ivals[heap[i]].err) - break; - else - { - t = heap[j]; - heap[j] = heap[i]; - heap[i] = t; - i = j; - } - } - - /* Now grab the last interval and sift it up the heap. */ - i = nivals - 1; - while (i > 0) - { - j = (i - 1) / 2; - if (ivals[heap[j]].err < ivals[heap[i]].err) - { - t = heap[j]; - heap[j] = heap[i]; - heap[i] = t; - i = j; - } - else - break; - } - - - } - - /* Otherwise, just fix-up the heap. */ - else - { - i = 0; - while (2 * i + 1 < nivals) - { - j = 2 * i + 1; - if (j + 1 < nivals - && ivals[heap[j + 1]].err >= ivals[heap[j]].err) - j++; - if (ivals[heap[j]].err <= ivals[heap[i]].err) - break; - else - { - t = heap[j]; - heap[j] = heap[i]; - heap[i] = t; - i = j; - } - } - - } - - /* If the heap is about to overflow, remove the last two - intervals. */ - while (nivals > cquad_heapsize - 2) - { - iv = &(ivals[heap[nivals - 1]]); -/* printf - ("quadcc: dropping ival %i (of %i) with [%e,%e] int=%e, err=%e, depth=%i\n", - heap[0], nivals, iv->a, iv->b, iv->igral, iv->err, - iv->depth); -*/ - err_final += iv->err; - igral_final += iv->igral; - nivals--; - } - - /* Collect the value of the integral and error. */ - igral = igral_final; - err = err_final; - for (i = 0; i < nivals; i++) - { - igral += ivals[heap[i]].igral; - err += ivals[heap[i]].err; - } - - } - - /* Dump the contents of the heap. */ -/* for (i = 0; i < nivals; i++) - { - iv = &(ivals[heap[i]]); - printf - ("quadcc: ival %i (%i) with [%e,%e], int=%e, err=%e, depth=%i, rdepth=%i, ndiv=%i\n", - i, heap[i], iv->a, iv->b, iv->igral, iv->err, iv->depth, - iv->rdepth, iv->ndiv); - } -*/ - /* Clean up and present the results. */ - if (nargout > 2) - retval(2) = neval; - if (nargout > 1) - retval(1) = err; - retval(0) = igral; - /* All is well that ends well. */ - return retval; -} - - -/* -%!assert (quadcc (@sin, -pi, pi), 0, 1e-6) -%!assert (quadcc (inline ("sin"),- pi, pi), 0, 1e-6) -%!assert (quadcc ("sin", -pi, pi), 0, 1e-6) - -%!assert (quadcc (@sin, -pi, 0), -2, 1e-6) -%!assert (quadcc (@sin, 0, pi), 2, 1e-6) -%!assert (quadcc (@(x) 1./sqrt (x), 0, 1), 2, 1e-6) -%!assert (quadcc (@(x) 1./(sqrt (x).*(x+1)), 0, Inf), pi, 1e-6) - -%!assert (quadcc (@(x) exp (-x .^ 2), -Inf, Inf), sqrt (pi), 1e-6) -%!assert (quadcc (@(x) exp (-x .^ 2), -Inf, 0), sqrt (pi)/2, 1e-6) - -%% Test input validation -%!error (quadcc ()) -%!error (quadcc (@sin)) -%!error (quadcc (@sin, 0)) -%!error (quadcc (@sin, ones (2), pi)) -%!error (quadcc (@sin, -i, pi)) -%!error (quadcc (@sin, 0, ones (2))) -%!error (quadcc (@sin, 0, i)) -%!error (quadcc (@sin, 0, pi, 0)) -%!error (quadcc (@sin, 0, pi, 1e-6, [ i ])) -*/
--- a/src/DLD-FUNCTIONS/qz.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1278 +0,0 @@ -/* - -Copyright (C) 1998-2012 A. S. Hodel - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Generalized eigenvalue balancing via LAPACK - -// Author: A. S. Hodel <scotte@eng.auburn.edu> - -#undef DEBUG -#undef DEBUG_SORT -#undef DEBUG_EIG - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <cfloat> - -#include <iostream> -#include <iomanip> - -#include "CmplxQRP.h" -#include "CmplxQR.h" -#include "dbleQR.h" -#include "f77-fcn.h" -#include "lo-math.h" -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "oct-map.h" -#include "ov.h" -#include "pager.h" -#if defined (DEBUG) || defined (DEBUG_SORT) -#include "pr-output.h" -#endif -#include "symtab.h" -#include "utils.h" -#include "variables.h" - -typedef octave_idx_type (*sort_function) (const octave_idx_type& LSIZE, const double& ALPHA, - const double& BETA, const double& S, - const double& P); - -extern "C" -{ - F77_RET_T - F77_FUNC (dggbal, DGGBAL) (F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, double* A, - const octave_idx_type& LDA, double* B, - const octave_idx_type& LDB, octave_idx_type& ILO, - octave_idx_type& IHI, double* LSCALE, - double* RSCALE, double* WORK, - octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL); - -F77_RET_T - F77_FUNC (zggbal, ZGGBAL) (F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, Complex* A, - const octave_idx_type& LDA, Complex* B, - const octave_idx_type& LDB, octave_idx_type& ILO, - octave_idx_type& IHI, double* LSCALE, - double* RSCALE, double* WORK, - octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL); - - F77_RET_T - F77_FUNC (dggbak, DGGBAK) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, - const octave_idx_type& ILO, - const octave_idx_type& IHI, - const double* LSCALE, const double* RSCALE, - octave_idx_type& M, double* V, - const octave_idx_type& LDV, octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - -F77_RET_T - F77_FUNC (zggbak, ZGGBAK) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, - const octave_idx_type& ILO, - const octave_idx_type& IHI, - const double* LSCALE, const double* RSCALE, - octave_idx_type& M, Complex* V, - const octave_idx_type& LDV, octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - - F77_RET_T - F77_FUNC (dgghrd, DGGHRD) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, - const octave_idx_type& ILO, - const octave_idx_type& IHI, double* A, - const octave_idx_type& LDA, double* B, - const octave_idx_type& LDB, double* Q, - const octave_idx_type& LDQ, double* Z, - const octave_idx_type& LDZ, octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - - F77_RET_T - F77_FUNC (zgghrd, ZGGHRD) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, - const octave_idx_type& ILO, - const octave_idx_type& IHI, Complex* A, - const octave_idx_type& LDA, Complex* B, - const octave_idx_type& LDB, Complex* Q, - const octave_idx_type& LDQ, Complex* Z, - const octave_idx_type& LDZ, octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - - F77_RET_T - F77_FUNC (dhgeqz, DHGEQZ) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, - const octave_idx_type& ILO, - const octave_idx_type& IHI, - double* A, const octave_idx_type& LDA, double* B, - const octave_idx_type& LDB, double* ALPHAR, - double* ALPHAI, double* BETA, double* Q, - const octave_idx_type& LDQ, double* Z, - const octave_idx_type& LDZ, double* WORK, - const octave_idx_type& LWORK, - octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - -F77_RET_T - F77_FUNC (zhgeqz, ZHGEQZ) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - const octave_idx_type& N, - const octave_idx_type& ILO, - const octave_idx_type& IHI, - Complex* A, const octave_idx_type& LDA, - Complex* B, const octave_idx_type& LDB, - Complex* ALPHA, Complex* BETA, Complex* CQ, - const octave_idx_type& LDQ, - Complex* CZ, const octave_idx_type& LDZ, - Complex* WORK, const octave_idx_type& LWORK, - double* RWORK, octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - - F77_RET_T - F77_FUNC (dlag2, DLAG2) (const double* A, const octave_idx_type& LDA, - const double* B, const octave_idx_type& LDB, - const double& SAFMIN, double& SCALE1, - double& SCALE2, double& WR1, double& WR2, - double& WI); - - // Van Dooren's code (netlib.org: toms/590) for reordering - // GEP. Only processes Z, not Q. - F77_RET_T - F77_FUNC (dsubsp, DSUBSP) (const octave_idx_type& NMAX, - const octave_idx_type& N, double* A, - double* B, double* Z, sort_function, - const double& EPS, octave_idx_type& NDIM, - octave_idx_type& FAIL, octave_idx_type* IND); - - // Documentation for DTGEVC incorrectly states that VR, VL are - // complex*16; they are declared in DTGEVC as double precision - // (probably a cut and paste problem fro ZTGEVC). - F77_RET_T - F77_FUNC (dtgevc, DTGEVC) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - octave_idx_type* SELECT, - const octave_idx_type& N, double* A, - const octave_idx_type& LDA, double* B, - const octave_idx_type& LDB, double* VL, - const octave_idx_type& LDVL, double* VR, - const octave_idx_type& LDVR, - const octave_idx_type& MM, octave_idx_type& M, - double* WORK, octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - -F77_RET_T - F77_FUNC (ztgevc, ZTGEVC) (F77_CONST_CHAR_ARG_DECL, - F77_CONST_CHAR_ARG_DECL, - octave_idx_type* SELECT, - const octave_idx_type& N, const Complex* A, - const octave_idx_type& LDA,const Complex* B, - const octave_idx_type& LDB, Complex* xVL, - const octave_idx_type& LDVL, Complex* xVR, - const octave_idx_type& LDVR, - const octave_idx_type& MM, octave_idx_type& M, - Complex* CWORK, double* RWORK, - octave_idx_type& INFO - F77_CHAR_ARG_LEN_DECL - F77_CHAR_ARG_LEN_DECL); - - F77_RET_T - F77_FUNC (xdlamch, XDLAMCH) (F77_CONST_CHAR_ARG_DECL, - double& retval - F77_CHAR_ARG_LEN_DECL); - - F77_RET_T - F77_FUNC (xdlange, XDLANGE) (F77_CONST_CHAR_ARG_DECL, - const octave_idx_type&, - const octave_idx_type&, const double*, - const octave_idx_type&, double*, double& - F77_CHAR_ARG_LEN_DECL); -} - -// fcrhp, fin, fout, folhp: -// routines for ordering of generalized eigenvalues -// return 1 if test is passed, 0 otherwise -// fin: |lambda| < 1 -// fout: |lambda| >= 1 -// fcrhp: real(lambda) >= 0 -// folhp: real(lambda) < 0 - -static octave_idx_type -fcrhp (const octave_idx_type& lsize, const double& alpha, - const double& beta, const double& s, const double&) -{ - if (lsize == 1) - return (alpha * beta >= 0 ? 1 : -1); - else - return (s >= 0 ? 1 : -1); -} - -static octave_idx_type -fin (const octave_idx_type& lsize, const double& alpha, - const double& beta, const double&, const double& p) -{ - octave_idx_type retval; - - if (lsize == 1) - retval = (fabs (alpha) < fabs (beta) ? 1 : -1); - else - retval = (fabs (p) < 1 ? 1 : -1); - -#ifdef DEBUG - std::cout << "qz: fin: retval=" << retval << std::endl; -#endif - - return retval; -} - -static octave_idx_type -folhp (const octave_idx_type& lsize, const double& alpha, - const double& beta, const double& s, const double&) -{ - if (lsize == 1) - return (alpha * beta < 0 ? 1 : -1); - else - return (s < 0 ? 1 : -1); -} - -static octave_idx_type -fout (const octave_idx_type& lsize, const double& alpha, - const double& beta, const double&, const double& p) -{ - if (lsize == 1) - return (fabs (alpha) >= fabs (beta) ? 1 : -1); - else - return (fabs (p) >= 1 ? 1 : -1); -} - - -//FIXME: Matlab does not produce lambda as the first output argument. -// Compatibility problem? -DEFUN_DLD (qz, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{lambda} =} qz (@var{A}, @var{B})\n\ -@deftypefnx {Loadable Function} {@var{lambda} =} qz (@var{A}, @var{B}, @var{opt})\n\ -QZ@tie{}decomposition of the generalized eigenvalue problem\n\ -(@math{A x = s B x}). There are three ways to call this function:\n\ -@enumerate\n\ -@item @code{@var{lambda} = qz (@var{A}, @var{B})}\n\ -\n\ -Computes the generalized eigenvalues\n\ -@tex\n\ -$\\lambda$\n\ -@end tex\n\ -@ifnottex\n\ -@var{lambda}\n\ -@end ifnottex\n\ -of @math{(A - s B)}.\n\ -\n\ -@item @code{[AA, BB, Q, Z, V, W, @var{lambda}] = qz (@var{A}, @var{B})}\n\ -\n\ -Computes QZ@tie{}decomposition, generalized eigenvectors, and\n\ -generalized eigenvalues of @math{(A - s B)}\n\ -@tex\n\ -$$ AV = BV{ \\rm diag }(\\lambda) $$\n\ -$$ W^T A = { \\rm diag }(\\lambda)W^T B $$\n\ -$$ AA = Q^T AZ, BB = Q^T BZ $$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@group\n\ -\n\ -A * V = B * V * diag (@var{lambda})\n\ -W' * A = diag (@var{lambda}) * W' * B\n\ -AA = Q * A * Z, BB = Q * B * Z\n\ -\n\ -@end group\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -with @var{Q} and @var{Z} orthogonal (unitary)= @var{I}\n\ -\n\ -@item @code{[AA,BB,Z@{, @var{lambda}@}] = qz (@var{A}, @var{B}, @var{opt})}\n\ -\n\ -As in form [2], but allows ordering of generalized eigenpairs\n\ -for (e.g.) solution of discrete time algebraic Riccati equations.\n\ -Form 3 is not available for complex matrices, and does not compute\n\ -the generalized eigenvectors @var{V}, @var{W}, nor the orthogonal matrix\n\ -@var{Q}.\n\ -\n\ -@table @var\n\ -@item opt\n\ -for ordering eigenvalues of the GEP pencil. The leading block\n\ -of the revised pencil contains all eigenvalues that satisfy:\n\ -\n\ -@table @asis\n\ -@item \"N\"\n\ -= unordered (default)\n\ -\n\ -@item \"S\"\n\ -= small: leading block has all |lambda| @leq{} 1\n\ -\n\ -@item \"B\"\n\ -= big: leading block has all |lambda| @geq{} 1\n\ -\n\ -@item \"-\"\n\ -= negative real part: leading block has all eigenvalues\n\ -in the open left half-plane\n\ -\n\ -@item \"+\"\n\ -= non-negative real part: leading block has all eigenvalues\n\ -in the closed right half-plane\n\ -@end table\n\ -@end table\n\ -@end enumerate\n\ -\n\ -Note: @code{qz} performs permutation balancing, but not scaling\n\ -(@pxref{doc-balance}). The order of output arguments was selected for\n\ -compatibility with @sc{matlab}.\n\ -@seealso{balance, eig, schur}\n\ -@end deftypefn") -{ - octave_value_list retval; - int nargin = args.length (); - -#ifdef DEBUG - std::cout << "qz: nargin = " << nargin << ", nargout = " << nargout << std::endl; -#endif - - if (nargin < 2 || nargin > 3 || nargout > 7) - { - print_usage (); - return retval; - } - else if (nargin == 3 && (nargout < 3 || nargout > 4)) - { - error ("qz: invalid number of output arguments for form [3] call"); - return retval; - } - -#ifdef DEBUG - std::cout << "qz: determine ordering option" << std::endl; -#endif - - // Determine ordering option. - volatile char ord_job = 0; - static double safmin; - - if (nargin == 2) - ord_job = 'N'; - else if (!args(2).is_string ()) - { - error ("qz: OPT must be a string"); - return retval; - } - else - { - std::string tmp = args(2).string_value (); - - if (! tmp.empty ()) - ord_job = tmp[0]; - - if (! (ord_job == 'N' || ord_job == 'n' - || ord_job == 'S' || ord_job == 's' - || ord_job == 'B' || ord_job == 'b' - || ord_job == '+' || ord_job == '-')) - { - error ("qz: invalid order option"); - return retval; - } - - // overflow constant required by dlag2 - F77_FUNC (xdlamch, XDLAMCH) (F77_CONST_CHAR_ARG2 ("S", 1), - safmin - F77_CHAR_ARG_LEN (1)); - -#ifdef DEBUG_EIG - std::cout << "qz: initial value of safmin=" << setiosflags (std::ios::scientific) - << safmin << std::endl; -#endif - - // Some machines (e.g., DEC alpha) get safmin = 0; - // for these, use eps instead to avoid problems in dlag2. - if (safmin == 0) - { -#ifdef DEBUG_EIG - std::cout << "qz: DANGER WILL ROBINSON: safmin is 0!" << std::endl; -#endif - - F77_FUNC (xdlamch, XDLAMCH) (F77_CONST_CHAR_ARG2 ("E", 1), - safmin - F77_CHAR_ARG_LEN (1)); - -#ifdef DEBUG_EIG - std::cout << "qz: safmin set to " << setiosflags (std::ios::scientific) - << safmin << std::endl; -#endif - } - } - -#ifdef DEBUG - std::cout << "qz: check argument 1" << std::endl; -#endif - - // Argument 1: check if it's o.k. dimensioned. - octave_idx_type nn = args(0).rows (); - -#ifdef DEBUG - std::cout << "argument 1 dimensions: (" << nn << "," << args(0).columns () << ")" - << std::endl; -#endif - - int arg_is_empty = empty_arg ("qz", nn, args(0).columns ()); - - if (arg_is_empty < 0) - { - gripe_empty_arg ("qz: parameter 1", 0); - return retval; - } - else if (arg_is_empty > 0) - { - gripe_empty_arg ("qz: parameter 1; continuing", 0); - return octave_value_list (2, Matrix ()); - } - else if (args(0).columns () != nn) - { - gripe_square_matrix_required ("qz"); - return retval; - } - - // Argument 1: dimensions look good; get the value. - Matrix aa; - ComplexMatrix caa; - - if (args(0).is_complex_type ()) - caa = args(0).complex_matrix_value (); - else - aa = args(0).matrix_value (); - - if (error_state) - return retval; - -#ifdef DEBUG - std::cout << "qz: check argument 2" << std::endl; -#endif - - // Extract argument 2 (bb, or cbb if complex). - if ((nn != args(1).columns ()) || (nn != args(1).rows ())) - { - gripe_nonconformant (); - return retval; - } - - Matrix bb; - ComplexMatrix cbb; - - if (args(1).is_complex_type ()) - cbb = args(1).complex_matrix_value (); - else - bb = args(1).matrix_value (); - - if (error_state) - return retval; - - // Both matrices loaded, now let's check what kind of arithmetic: - // declared volatile to avoid compiler warnings about long jumps, - // vforks. - - volatile int complex_case - = (args(0).is_complex_type () || args(1).is_complex_type ()); - - if (nargin == 3 && complex_case) - { - error ("qz: cannot re-order complex qz decomposition"); - return retval; - } - - // First, declare variables used in both the real and complex case. - Matrix QQ(nn,nn), ZZ(nn,nn), VR(nn,nn), VL(nn,nn); - RowVector alphar(nn), alphai(nn), betar(nn); - ComplexRowVector xalpha(nn), xbeta(nn); - ComplexMatrix CQ(nn,nn), CZ(nn,nn), CVR(nn,nn), CVL(nn,nn); - octave_idx_type ilo, ihi, info; - char compq = (nargout >= 3 ? 'V' : 'N'); - char compz = ((nargout >= 4 || nargin == 3)? 'V' : 'N'); - - // Initialize Q, Z to identity if we need either of them. - if (compq == 'V' || compz == 'V') - for (octave_idx_type ii = 0; ii < nn; ii++) - for (octave_idx_type jj = 0; jj < nn; jj++) - { - OCTAVE_QUIT; - QQ(ii,jj) = ZZ(ii,jj) = (ii == jj ? 1.0 : 0.0); - } - - // Always perform permutation balancing. - const char bal_job = 'P'; - RowVector lscale (nn), rscale (nn), work (6 * nn), rwork (nn); - - if (complex_case) - { -#ifdef DEBUG - if (compq == 'V') - std::cout << "qz: performing balancing; CQ=" << std::endl << CQ << std::endl; -#endif - if (args(0).is_real_type ()) - caa = ComplexMatrix (aa); - - if (args(1).is_real_type ()) - cbb = ComplexMatrix (bb); - - if (compq == 'V') - CQ = ComplexMatrix (QQ); - - if (compz == 'V') - CZ = ComplexMatrix (ZZ); - - F77_XFCN (zggbal, ZGGBAL, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - nn, caa.fortran_vec (), nn, cbb.fortran_vec (), - nn, ilo, ihi, lscale.fortran_vec (), - rscale.fortran_vec (), work.fortran_vec (), info - F77_CHAR_ARG_LEN (1))); - } - else - { -#ifdef DEBUG - if (compq == 'V') - std::cout << "qz: performing balancing; QQ=" << std::endl << QQ << std::endl; -#endif - - F77_XFCN (dggbal, DGGBAL, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - nn, aa.fortran_vec (), nn, bb.fortran_vec (), - nn, ilo, ihi, lscale.fortran_vec (), - rscale.fortran_vec (), work.fortran_vec (), info - F77_CHAR_ARG_LEN (1))); - } - - // Since we just want the balancing matrices, we can use dggbal - // for both the real and complex cases; left first - -#if 0 - if (compq == 'V') - { - F77_XFCN (dggbak, DGGBAK, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - F77_CONST_CHAR_ARG2 ("L", 1), - nn, ilo, ihi, lscale.data (), rscale.data (), - nn, QQ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - -#ifdef DEBUG - if (compq == 'V') - std::cout << "qz: balancing done; QQ=" << std::endl << QQ << std::endl; -#endif - } - - // then right - if (compz == 'V') - { - F77_XFCN (dggbak, DGGBAK, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - F77_CONST_CHAR_ARG2 ("R", 1), - nn, ilo, ihi, lscale.data (), rscale.data (), - nn, ZZ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - -#ifdef DEBUG - if (compz == 'V') - std::cout << "qz: balancing done; ZZ=" << std::endl << ZZ << std::endl; -#endif - } -#endif - - static char qz_job; - qz_job = (nargout < 2 ? 'E' : 'S'); - - if (complex_case) - { - // Complex case. - - // The QR decomposition of cbb. - ComplexQR cbqr (cbb); - // The R matrix of QR decomposition for cbb. - cbb = cbqr.R (); - // (Q*)caa for following work. - caa = (cbqr.Q ().hermitian ()) * caa; - CQ = CQ * cbqr.Q (); - - F77_XFCN (zgghrd, ZGGHRD, - (F77_CONST_CHAR_ARG2 (&compq, 1), - F77_CONST_CHAR_ARG2 (&compz, 1), - nn, ilo, ihi, caa.fortran_vec (), - nn, cbb.fortran_vec (), nn, CQ.fortran_vec (), nn, - CZ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - - ComplexRowVector cwork (1 * nn); - - F77_XFCN (zhgeqz, ZHGEQZ, - (F77_CONST_CHAR_ARG2 (&qz_job, 1), - F77_CONST_CHAR_ARG2 (&compq, 1), - F77_CONST_CHAR_ARG2 (&compz, 1), - nn, ilo, ihi, - caa.fortran_vec (), nn, - cbb.fortran_vec (),nn, - xalpha.fortran_vec (), xbeta.fortran_vec (), - CQ.fortran_vec (), nn, - CZ.fortran_vec (), nn, - cwork.fortran_vec (), nn, rwork.fortran_vec (), info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - - if (compq == 'V') - { - // Left eigenvector. - F77_XFCN (zggbak, ZGGBAK, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - F77_CONST_CHAR_ARG2 ("L", 1), - nn, ilo, ihi, lscale.data (), rscale.data (), - nn, CQ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - } - - // Right eigenvector. - if (compz == 'V') - { - F77_XFCN (zggbak, ZGGBAK, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - F77_CONST_CHAR_ARG2 ("R", 1), - nn, ilo, ihi, lscale.data (), rscale.data (), - nn, CZ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - } - - } - else - { -#ifdef DEBUG - std::cout << "qz: peforming qr decomposition of bb" << std::endl; -#endif - - // Compute the QR factorization of bb. - QR bqr (bb); - -#ifdef DEBUG - std::cout << "qz: qr (bb) done; now peforming qz decomposition" << std::endl; -#endif - - bb = bqr.R (); - -#ifdef DEBUG - std::cout << "qz: extracted bb" << std::endl; -#endif - - aa = (bqr.Q ()).transpose () * aa; - -#ifdef DEBUG - std::cout << "qz: updated aa " << std::endl; - std::cout << "bqr.Q () = " << std::endl << bqr.Q () << std::endl; - - if (compq == 'V') - std::cout << "QQ =" << QQ << std::endl; -#endif - - if (compq == 'V') - QQ = QQ * bqr.Q (); - -#ifdef DEBUG - std::cout << "qz: precursors done..." << std::endl; -#endif - -#ifdef DEBUG - std::cout << "qz: compq = " << compq << ", compz = " << compz << std::endl; -#endif - - // Reduce to generalized hessenberg form. - F77_XFCN (dgghrd, DGGHRD, - (F77_CONST_CHAR_ARG2 (&compq, 1), - F77_CONST_CHAR_ARG2 (&compz, 1), - nn, ilo, ihi, aa.fortran_vec (), - nn, bb.fortran_vec (), nn, QQ.fortran_vec (), nn, - ZZ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - - // Check if just computing generalized eigenvalues or if we're - // actually computing the decomposition. - - // Reduce to generalized Schur form. - F77_XFCN (dhgeqz, DHGEQZ, - (F77_CONST_CHAR_ARG2 (&qz_job, 1), - F77_CONST_CHAR_ARG2 (&compq, 1), - F77_CONST_CHAR_ARG2 (&compz, 1), - nn, ilo, ihi, aa.fortran_vec (), nn, bb.fortran_vec (), - nn, alphar.fortran_vec (), alphai.fortran_vec (), - betar.fortran_vec (), QQ.fortran_vec (), nn, - ZZ.fortran_vec (), nn, work.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - - if (compq == 'V') - { - F77_XFCN (dggbak, DGGBAK, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - F77_CONST_CHAR_ARG2 ("L", 1), - nn, ilo, ihi, lscale.data (), rscale.data (), - nn, QQ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - -#ifdef DEBUG - if (compq == 'V') - std::cout << "qz: balancing done; QQ=" << std::endl << QQ << std::endl; -#endif - } - - // then right - if (compz == 'V') - { - F77_XFCN (dggbak, DGGBAK, - (F77_CONST_CHAR_ARG2 (&bal_job, 1), - F77_CONST_CHAR_ARG2 ("R", 1), - nn, ilo, ihi, lscale.data (), rscale.data (), - nn, ZZ.fortran_vec (), nn, info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - -#ifdef DEBUG - if (compz == 'V') - std::cout << "qz: balancing done; ZZ=" << std::endl << ZZ << std::endl; -#endif - } - - } - - // Order the QZ decomposition? - if (! (ord_job == 'N' || ord_job == 'n')) - { - if (complex_case) - { - // Probably not needed, but better be safe. - error ("qz: cannot re-order complex qz decomposition"); - return retval; - } - else - { -#ifdef DEBUG_SORT - std::cout << "qz: ordering eigenvalues: ord_job = " - << ord_job << std::endl; -#endif - - // Declared static to avoid vfork/long jump compiler complaints. - static sort_function sort_test; - sort_test = 0; - - switch (ord_job) - { - case 'S': - case 's': - sort_test = &fin; - break; - - case 'B': - case 'b': - sort_test = &fout; - break; - - case '+': - sort_test = &fcrhp; - break; - - case '-': - sort_test = &folhp; - break; - - default: - // Invalid order option (should never happen, since we - // checked the options at the top). - panic_impossible (); - break; - } - - octave_idx_type ndim, fail; - double inf_norm; - - F77_XFCN (xdlange, XDLANGE, - (F77_CONST_CHAR_ARG2 ("I", 1), - nn, nn, aa.data (), nn, work.fortran_vec (), inf_norm - F77_CHAR_ARG_LEN (1))); - - double eps = DBL_EPSILON * inf_norm * nn; - -#ifdef DEBUG_SORT - std::cout << "qz: calling dsubsp: aa=" << std::endl; - octave_print_internal (std::cout, aa, 0); - std::cout << std::endl << "bb=" << std::endl; - octave_print_internal (std::cout, bb, 0); - if (compz == 'V') - { - std::cout << std::endl << "ZZ=" << std::endl; - octave_print_internal (std::cout, ZZ, 0); - } - std::cout << std::endl; - std::cout << "alphar = " << std::endl; - octave_print_internal (std::cout, (Matrix) alphar, 0); - std::cout << std::endl << "alphai = " << std::endl; - octave_print_internal (std::cout, (Matrix) alphai, 0); - std::cout << std::endl << "beta = " << std::endl; - octave_print_internal (std::cout, (Matrix) betar, 0); - std::cout << std::endl; -#endif - - Array<octave_idx_type> ind (dim_vector (nn, 1)); - - F77_XFCN (dsubsp, DSUBSP, - (nn, nn, aa.fortran_vec (), bb.fortran_vec (), - ZZ.fortran_vec (), sort_test, eps, ndim, fail, - ind.fortran_vec ())); - -#ifdef DEBUG - std::cout << "qz: back from dsubsp: aa=" << std::endl; - octave_print_internal (std::cout, aa, 0); - std::cout << std::endl << "bb=" << std::endl; - octave_print_internal (std::cout, bb, 0); - if (compz == 'V') - { - std::cout << std::endl << "ZZ=" << std::endl; - octave_print_internal (std::cout, ZZ, 0); - } - std::cout << std::endl; -#endif - - // Manually update alphar, alphai, betar. - static int jj; - - jj = 0; - while (jj < nn) - { -#ifdef DEBUG_EIG - std::cout << "computing gen eig #" << jj << std::endl; -#endif - - // Number of zeros in this block. - static int zcnt; - - if (jj == (nn-1)) - zcnt = 1; - else if (aa(jj+1,jj) == 0) - zcnt = 1; - else zcnt = 2; - - if (zcnt == 1) - { - // Real zero. -#ifdef DEBUG_EIG - std::cout << " single gen eig:" << std::endl; - std::cout << " alphar(" << jj << ") = " << aa(jj,jj) << std::endl; - std::cout << " betar( " << jj << ") = " << bb(jj,jj) << std::endl; - std::cout << " alphai(" << jj << ") = 0" << std::endl; -#endif - - alphar(jj) = aa(jj,jj); - alphai(jj) = 0; - betar(jj) = bb(jj,jj); - } - else - { - // Complex conjugate pair. -#ifdef DEBUG_EIG - std::cout << "qz: calling dlag2:" << std::endl; - std::cout << "safmin=" - << setiosflags (std::ios::scientific) << safmin << std::endl; - - for (int idr = jj; idr <= jj+1; idr++) - { - for (int idc = jj; idc <= jj+1; idc++) - { - std::cout << "aa(" << idr << "," << idc << ")=" - << aa(idr,idc) << std::endl; - std::cout << "bb(" << idr << "," << idc << ")=" - << bb(idr,idc) << std::endl; - } - } -#endif - - // FIXME -- probably should be using - // fortran_vec instead of &aa(jj,jj) here. - - double scale1, scale2, wr1, wr2, wi; - const double *aa_ptr = aa.data () + jj * nn + jj; - const double *bb_ptr = bb.data () + jj * nn + jj; - F77_XFCN (dlag2, DLAG2, - (aa_ptr, nn, bb_ptr, nn, safmin, - scale1, scale2, wr1, wr2, wi)); - -#ifdef DEBUG_EIG - std::cout << "dlag2 returns: scale1=" << scale1 - << "\tscale2=" << scale2 << std::endl - << "\twr1=" << wr1 << "\twr2=" << wr2 - << "\twi=" << wi << std::endl; -#endif - - // Just to be safe, check if it's a real pair. - if (wi == 0) - { - alphar(jj) = wr1; - alphai(jj) = 0; - betar(jj) = scale1; - alphar(jj+1) = wr2; - alphai(jj+1) = 0; - betar(jj+1) = scale2; - } - else - { - alphar(jj) = alphar(jj+1) = wr1; - alphai(jj) = -(alphai(jj+1) = wi); - betar(jj) = betar(jj+1) = scale1; - } - } - - // Advance past this block. - jj += zcnt; - } - -#ifdef DEBUG_SORT - std::cout << "qz: back from dsubsp: aa=" << std::endl; - octave_print_internal (std::cout, aa, 0); - std::cout << std::endl << "bb=" << std::endl; - octave_print_internal (std::cout, bb, 0); - - if (compz == 'V') - { - std::cout << std::endl << "ZZ=" << std::endl; - octave_print_internal (std::cout, ZZ, 0); - } - std::cout << std::endl << "qz: ndim=" << ndim << std::endl - << "fail=" << fail << std::endl; - std::cout << "alphar = " << std::endl; - octave_print_internal (std::cout, (Matrix) alphar, 0); - std::cout << std::endl << "alphai = " << std::endl; - octave_print_internal (std::cout, (Matrix) alphai, 0); - std::cout << std::endl << "beta = " << std::endl; - octave_print_internal (std::cout, (Matrix) betar, 0); - std::cout << std::endl; -#endif - } - } - - // Compute generalized eigenvalues? - ComplexColumnVector gev; - - if (nargout < 2 || nargout == 7 || (nargin == 3 && nargout == 4)) - { - if (complex_case) - { - int cnt = 0; - - for (int ii = 0; ii < nn; ii++) - cnt++; - - ComplexColumnVector tmp (cnt); - - cnt = 0; - for (int ii = 0; ii < nn; ii++) - tmp(cnt++) = xalpha(ii) / xbeta(ii); - - gev = tmp; - } - else - { -#ifdef DEBUG - std::cout << "qz: computing generalized eigenvalues" << std::endl; -#endif - - // Return finite generalized eigenvalues. - int cnt = 0; - - for (int ii = 0; ii < nn; ii++) - if (betar(ii) != 0) - cnt++; - - ComplexColumnVector tmp (cnt); - - cnt = 0; - for (int ii = 0; ii < nn; ii++) - if (betar(ii) != 0) - tmp(cnt++) = Complex(alphar(ii), alphai(ii))/betar(ii); - - gev = tmp; - } - } - - // Right, left eigenvector matrices. - if (nargout >= 5) - { - // Which side to compute? - char side = (nargout == 5 ? 'R' : 'B'); - // Compute all of them and backtransform - char howmny = 'B'; - // Dummy pointer; select is not used. - octave_idx_type *select = 0; - - if (complex_case) - { - CVL = CQ; - CVR = CZ; - ComplexRowVector cwork2 (2 * nn); - RowVector rwork2 (8 * nn); - octave_idx_type m; - - F77_XFCN (ztgevc, ZTGEVC, - (F77_CONST_CHAR_ARG2 (&side, 1), - F77_CONST_CHAR_ARG2 (&howmny, 1), - select, nn, caa.fortran_vec (), nn, cbb.fortran_vec (), - nn, CVL.fortran_vec (), nn, CVR.fortran_vec (), nn, nn, - m, cwork2.fortran_vec (), rwork2.fortran_vec (), info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - } - else - { -#ifdef DEBUG - std::cout << "qz: computing generalized eigenvectors" << std::endl; -#endif - - VL = QQ; - VR = ZZ; - octave_idx_type m; - - F77_XFCN (dtgevc, DTGEVC, - (F77_CONST_CHAR_ARG2 (&side, 1), - F77_CONST_CHAR_ARG2 (&howmny, 1), - select, nn, aa.fortran_vec (), nn, bb.fortran_vec (), - nn, VL.fortran_vec (), nn, VR.fortran_vec (), nn, nn, - m, work.fortran_vec (), info - F77_CHAR_ARG_LEN (1) - F77_CHAR_ARG_LEN (1))); - - // Now construct the complex form of VV, WW. - int jj = 0; - - while (jj < nn) - { - OCTAVE_QUIT; - - // See if real or complex eigenvalue. - - // Column increment; assume complex eigenvalue. - int cinc = 2; - - if (jj == (nn-1)) - // Single column. - cinc = 1; - else if (aa(jj+1,jj) == 0) - cinc = 1; - - // Now copy the eigenvector (s) to CVR, CVL. - if (cinc == 1) - { - for (int ii = 0; ii < nn; ii++) - CVR(ii,jj) = VR(ii,jj); - - if (side == 'B') - for (int ii = 0; ii < nn; ii++) - CVL(ii,jj) = VL(ii,jj); - } - else - { - // Double column; complex vector. - - for (int ii = 0; ii < nn; ii++) - { - CVR(ii,jj) = Complex (VR(ii,jj), VR(ii,jj+1)); - CVR(ii,jj+1) = Complex (VR(ii,jj), -VR(ii,jj+1)); - } - - if (side == 'B') - for (int ii = 0; ii < nn; ii++) - { - CVL(ii,jj) = Complex (VL(ii,jj), VL(ii,jj+1)); - CVL(ii,jj+1) = Complex (VL(ii,jj), -VL(ii,jj+1)); - } - } - - // Advance to next eigenvectors (if any). - jj += cinc; - } - } - } - - switch (nargout) - { - case 7: - retval(6) = gev; - - case 6: - // Return eigenvectors. - retval(5) = CVL; - - case 5: - // Return eigenvectors. - retval(4) = CVR; - - case 4: - if (nargin == 3) - { -#ifdef DEBUG - std::cout << "qz: sort: retval(3) = gev = " << std::endl; - octave_print_internal (std::cout, gev); - std::cout << std::endl; -#endif - retval(3) = gev; - } - else - { - if (complex_case) - retval(3) = CZ; - else - retval(3) = ZZ; - } - - case 3: - if (nargin == 3) - { - if (complex_case) - retval(2) = CZ; - else - retval(2) = ZZ; - } - else - { - if (complex_case) - retval(2) = CQ.hermitian (); - else - retval(2) = QQ.transpose (); - } - - case 2: - { - if (complex_case) - { -#ifdef DEBUG - std::cout << "qz: retval(1) = cbb = " << std::endl; - octave_print_internal (std::cout, cbb, 0); - std::cout << std::endl << "qz: retval(0) = caa = " <<std::endl; - octave_print_internal (std::cout, caa, 0); - std::cout << std::endl; -#endif - retval(1) = cbb; - retval(0) = caa; - } - else - { -#ifdef DEBUG - std::cout << "qz: retval(1) = bb = " << std::endl; - octave_print_internal (std::cout, bb, 0); - std::cout << std::endl << "qz: retval(0) = aa = " <<std::endl; - octave_print_internal (std::cout, aa, 0); - std::cout << std::endl; -#endif - retval(1) = bb; - retval(0) = aa; - } - } - break; - - - case 1: - case 0: -#ifdef DEBUG - std::cout << "qz: retval(0) = gev = " << gev << std::endl; -#endif - retval(0) = gev; - break; - - default: - error ("qz: too many return arguments"); - break; - } - -#ifdef DEBUG - std::cout << "qz: exiting (at long last)" << std::endl; -#endif - - return retval; -} - -/* -%!shared a, b, c -%! a = [1 2; 0 3]; -%! b = [1 0; 0 0]; -%! c = [0 1; 0 0]; -%!assert (qz (a,b), 1) -%!assert (isempty (qz (a,c))) - -## Exaple 7.7.3 in Golub & Van Loan -%!test -%! a = [ 10 1 2; -%! 1 2 -1; -%! 1 1 2]; -%! b = reshape (1:9,3,3); -%! [aa, bb, q, z, v, w, lambda] = qz (a, b); -%! sz = length (lambda); -%! observed = (b * v * diag ([lambda;0])) (:, 1:sz); -%! assert ( (a*v) (:, 1:sz), observed, norm (observed) * 1e-14); -%! observed = (diag ([lambda;0]) * w' * b) (1:sz, :); -%! assert ( (w'*a) (1:sz, :) , observed, norm (observed) * 1e-13); -%! assert (q * a * z, aa, norm (aa) * 1e-14); -%! assert (q * b * z, bb, norm (bb) * 1e-14); - -%!test -%! A = [0, 0, -1, 0; 1, 0, 0, 0; -1, 0, -2, -1; 0, -1, 1, 0]; -%! B = [0, 0, 0, 0; 0, 1, 0, 0; 0, 0, 1, 0; 0, 0, 0, 1]; -%! [AA, BB, Q, Z1] = qz (A, B); -%! [AA, BB, Z2] = qz (A, B, '-'); -%! assert (Z1, Z2); -*/
--- a/src/DLD-FUNCTIONS/rand.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1221 +0,0 @@ - -/* - -Copyright (C) 1996-2012 John W. Eaton -Copyright (C) 2009 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <ctime> -#if defined (HAVE_UNORDERED_MAP) -#include <unordered_map> -#elif defined (HAVE_TR1_UNORDERED_MAP) -#include <tr1/unordered_map> -#endif -#include <string> - -#include "f77-fcn.h" -#include "lo-mappers.h" -#include "oct-rand.h" -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "unwind-prot.h" -#include "utils.h" -#include "ov-re-mat.h" - -/* -%!shared __random_statistical_tests__ -%! # Flag whether the statistical tests should be run in "make check" or not -%! __random_statistical_tests__ = 0; -*/ - -static octave_value -do_rand (const octave_value_list& args, int nargin, const char *fcn, - const std::string& distribution, bool additional_arg = false) -{ - octave_value retval; - NDArray a; - int idx = 0; - dim_vector dims; - bool is_single = false; - - unwind_protect frame; - // Restore current distribution on any exit. - frame.add_fcn (octave_rand::distribution, - octave_rand::distribution ()); - - octave_rand::distribution (distribution); - - if (nargin > 0 && args(nargin-1).is_string ()) - { - std::string s_arg = args(nargin-1).string_value (); - - if (s_arg == "single") - { - is_single = true; - nargin--; - } - else if (s_arg == "double") - nargin--; - } - - if (additional_arg) - { - if (nargin == 0) - { - error ("%s: expecting at least one argument", fcn); - goto done; - } - else if (args(0).is_string ()) - additional_arg = false; - else - { - a = args(0).array_value (); - if (error_state) - { - error ("%s: expecting scalar or matrix arguments", fcn); - goto done; - } - idx++; - nargin--; - } - } - - switch (nargin) - { - case 0: - { - if (additional_arg) - dims = a.dims (); - else - { - dims.resize (2); - - dims(0) = 1; - dims(1) = 1; - } - goto gen_matrix; - } - break; - - case 1: - { - octave_value tmp = args(idx); - - if (tmp.is_string ()) - { - std::string s_arg = tmp.string_value (); - - if (s_arg == "dist") - { - retval = octave_rand::distribution (); - } - else if (s_arg == "seed") - { - retval = octave_rand::seed (); - } - else if (s_arg == "state" || s_arg == "twister") - { - retval = octave_rand::state (fcn); - } - else if (s_arg == "uniform") - { - octave_rand::uniform_distribution (); - } - else if (s_arg == "normal") - { - octave_rand::normal_distribution (); - } - else if (s_arg == "exponential") - { - octave_rand::exponential_distribution (); - } - else if (s_arg == "poisson") - { - octave_rand::poisson_distribution (); - } - else if (s_arg == "gamma") - { - octave_rand::gamma_distribution (); - } - else - error ("%s: unrecognized string argument", fcn); - } - else if (tmp.is_scalar_type ()) - { - double dval = tmp.double_value (); - - if (xisnan (dval)) - { - error ("%s: NaN is invalid matrix dimension", fcn); - } - else - { - dims.resize (2); - - dims(0) = NINTbig (tmp.double_value ()); - dims(1) = NINTbig (tmp.double_value ()); - - if (! error_state) - goto gen_matrix; - } - } - else if (tmp.is_range ()) - { - Range r = tmp.range_value (); - - if (r.all_elements_are_ints ()) - { - octave_idx_type n = r.nelem (); - - dims.resize (n); - - octave_idx_type base = NINTbig (r.base ()); - octave_idx_type incr = NINTbig (r.inc ()); - - for (octave_idx_type i = 0; i < n; i++) - { - //Negative dimensions are treated as zero for Matlab - //compatibility - dims(i) = base >= 0 ? base : 0; - base += incr; - } - - goto gen_matrix; - - } - else - error ("%s: all elements of range must be integers", - fcn); - } - else if (tmp.is_matrix_type ()) - { - Array<int> iv = tmp.int_vector_value (true); - - if (! error_state) - { - octave_idx_type len = iv.length (); - - dims.resize (len); - - for (octave_idx_type i = 0; i < len; i++) - { - //Negative dimensions are treated as zero for Matlab - //compatibility - octave_idx_type elt = iv(i); - dims(i) = elt >=0 ? elt : 0; - } - - goto gen_matrix; - } - else - error ("%s: expecting integer vector", fcn); - } - else - { - gripe_wrong_type_arg ("rand", tmp); - return retval; - } - } - break; - - default: - { - octave_value tmp = args(idx); - - if (nargin == 2 && tmp.is_string ()) - { - std::string ts = tmp.string_value (); - - if (ts == "seed") - { - if (args(idx+1).is_real_scalar ()) - { - double d = args(idx+1).double_value (); - - if (! error_state) - octave_rand::seed (d); - } - else if (args(idx+1).is_string () - && args(idx+1).string_value () == "reset") - octave_rand::reset (); - else - error ("%s: seed must be a real scalar", fcn); - } - else if (ts == "state" || ts == "twister") - { - if (args(idx+1).is_string () - && args(idx+1).string_value () == "reset") - octave_rand::reset (fcn); - else - { - ColumnVector s = - ColumnVector (args(idx+1).vector_value(false, true)); - - if (! error_state) - octave_rand::state (s, fcn); - } - } - else - error ("%s: unrecognized string argument", fcn); - } - else - { - dims.resize (nargin); - - for (int i = 0; i < nargin; i++) - { - octave_idx_type elt = args(idx+i).int_value (); - if (error_state) - { - error ("%s: expecting integer arguments", fcn); - goto done; - } - //Negative is zero for Matlab compatibility - dims(i) = elt >= 0 ? elt : 0; - } - - goto gen_matrix; - } - } - break; - } - - done: - - return retval; - - gen_matrix: - - dims.chop_trailing_singletons (); - - if (is_single) - { - if (additional_arg) - { - if (a.length () == 1) - return octave_rand::float_nd_array (dims, a(0)); - else - { - if (a.dims () != dims) - { - error ("%s: mismatch in argument size", fcn); - return retval; - } - octave_idx_type len = a.length (); - FloatNDArray m (dims); - float *v = m.fortran_vec (); - for (octave_idx_type i = 0; i < len; i++) - v[i] = octave_rand::float_scalar (a(i)); - return m; - } - } - else - return octave_rand::float_nd_array (dims); - } - else - { - if (additional_arg) - { - if (a.length () == 1) - return octave_rand::nd_array (dims, a(0)); - else - { - if (a.dims () != dims) - { - error ("%s: mismatch in argument size", fcn); - return retval; - } - octave_idx_type len = a.length (); - NDArray m (dims); - double *v = m.fortran_vec (); - for (octave_idx_type i = 0; i < len; i++) - v[i] = octave_rand::scalar (a(i)); - return m; - } - } - else - return octave_rand::nd_array (dims); - } -} - -DEFUN_DLD (rand, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} rand (@var{n})\n\ -@deftypefnx {Loadable Function} {} rand (@var{n}, @var{m}, @dots{})\n\ -@deftypefnx {Loadable Function} {} rand ([@var{n} @var{m} @dots{}])\n\ -@deftypefnx {Loadable Function} {@var{v} =} rand (\"state\")\n\ -@deftypefnx {Loadable Function} {} rand (\"state\", @var{v})\n\ -@deftypefnx {Loadable Function} {} rand (\"state\", \"reset\")\n\ -@deftypefnx {Loadable Function} {@var{v} =} rand (\"seed\")\n\ -@deftypefnx {Loadable Function} {} rand (\"seed\", @var{v})\n\ -@deftypefnx {Loadable Function} {} rand (\"seed\", \"reset\")\n\ -@deftypefnx {Loadable Function} {} rand (@dots{}, \"single\")\n\ -@deftypefnx {Loadable Function} {} rand (@dots{}, \"double\")\n\ -Return a matrix with random elements uniformly distributed on the\n\ -interval (0, 1). The arguments are handled the same as the arguments\n\ -for @code{eye}.\n\ -\n\ -You can query the state of the random number generator using the\n\ -form\n\ -\n\ -@example\n\ -v = rand (\"state\")\n\ -@end example\n\ -\n\ -This returns a column vector @var{v} of length 625. Later, you can\n\ -restore the random number generator to the state @var{v}\n\ -using the form\n\ -\n\ -@example\n\ -rand (\"state\", v)\n\ -@end example\n\ -\n\ -@noindent\n\ -You may also initialize the state vector from an arbitrary vector of\n\ -length @leq{} 625 for @var{v}. This new state will be a hash based on the\n\ -value of @var{v}, not @var{v} itself.\n\ -\n\ -By default, the generator is initialized from @code{/dev/urandom} if it is\n\ -available, otherwise from CPU time, wall clock time, and the current\n\ -fraction of a second. Note that this differs from @sc{matlab}, which\n\ -always initializes the state to the same state at startup. To obtain\n\ -behavior comparable to @sc{matlab}, initialize with a deterministic state\n\ -vector in Octave's startup files (@pxref{Startup Files}).\n\ -\n\ -To compute the pseudo-random sequence, @code{rand} uses the Mersenne\n\ -Twister with a period of @math{2^{19937}-1} (See M. Matsumoto and\n\ -T. Nishimura,\n\ -@cite{Mersenne Twister: A 623-dimensionally equidistributed uniform\n\ -pseudorandom number generator}, ACM Trans. on\n\ -Modeling and Computer Simulation Vol. 8, No. 1, pp. 3-30, January 1998,\n\ -@url{http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html}).\n\ -Do @strong{not} use for cryptography without securely hashing\n\ -several returned values together, otherwise the generator state\n\ -can be learned after reading 624 consecutive values.\n\ -\n\ -Older versions of Octave used a different random number generator.\n\ -The new generator is used by default\n\ -as it is significantly faster than the old generator, and produces\n\ -random numbers with a significantly longer cycle time. However, in\n\ -some circumstances it might be desirable to obtain the same random\n\ -sequences as used by the old generators. To do this the keyword\n\ -\"seed\" is used to specify that the old generators should be use,\n\ -as in\n\ -\n\ -@example\n\ -rand (\"seed\", val)\n\ -@end example\n\ -\n\ -@noindent\n\ -which sets the seed of the generator to @var{val}. The seed of the\n\ -generator can be queried with\n\ -\n\ -@example\n\ -s = rand (\"seed\")\n\ -@end example\n\ -\n\ -However, it should be noted that querying the seed will not cause\n\ -@code{rand} to use the old generators, only setting the seed will.\n\ -To cause @code{rand} to once again use the new generators, the\n\ -keyword \"state\" should be used to reset the state of the @code{rand}.\n\ -\n\ -The state or seed of the generator can be reset to a new random value\n\ -using the \"reset\" keyword.\n\ -\n\ -The class of the value returned can be controlled by a trailing \"double\"\n\ -or \"single\" argument. These are the only valid classes.\n\ -@seealso{randn, rande, randg, randp}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - retval = do_rand (args, nargin, "rand", "uniform"); - - return retval; -} - -// FIXME -- The old generator (selected when "seed" is set) will not -// work properly if compiled to use 64-bit integers. - -/* -%!test # "state" can be a scalar -%! rand ("state", 12); x = rand (1,4); -%! rand ("state", 12); y = rand (1,4); -%! assert (x, y); -%!test # "state" can be a vector -%! rand ("state", [12,13]); x = rand (1,4); -%! rand ("state", [12;13]); y = rand (1,4); -%! assert (x, y); -%!test # querying "state" doesn't disturb sequence -%! rand ("state", 12); rand (1,2); x = rand (1,2); -%! rand ("state", 12); rand (1,2); -%! s = rand ("state"); y = rand (1,2); -%! assert (x, y); -%! rand ("state", s); z = rand (1,2); -%! assert (x, z); -%!test # "seed" must be a scalar -%! rand ("seed", 12); x = rand (1,4); -%! rand ("seed", 12); y = rand (1,4); -%! assert (x, y); -%!error <seed must be a real scalar> rand ("seed", [12,13]) -%!test # querying "seed" returns a value which can be used later -%! s = rand ("seed"); x = rand (1,2); -%! rand ("seed", s); y = rand (1,2); -%! assert (x, y); -%!test # querying "seed" doesn't disturb sequence -%! rand ("seed", 12); rand (1,2); x = rand (1,2); -%! rand ("seed", 12); rand (1,2); -%! s = rand ("seed"); y = rand (1,2); -%! assert (x, y); -%! rand ("seed", s); z = rand (1,2); -%! assert (x, z); -*/ - -/* -%!test -%! # Test fixed state -%! rand ("state", 1); -%! assert (rand (1,6), [0.1343642441124013 0.8474337369372327 0.763774618976614 0.2550690257394218 0.495435087091941 0.4494910647887382], 1e-6); -%!test -%! # Test fixed seed -%! rand ("seed", 1); -%! assert (rand (1,6), [0.8668024251237512 0.9126510815694928 0.09366085007786751 0.1664607301354408 0.7408077004365623 0.7615650338120759], 1e-6); -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! rand ("state", 12); -%! x = rand (100000, 1); -%! assert (max (x) < 1); #*** Please report this!!! *** -%! assert (min (x) > 0); #*** Please report this!!! *** -%! assert (mean (x), 0.5, 0.0024); -%! assert (var (x), 1/48, 0.0632); -%! assert (skewness (x), 0, 0.012); -%! assert (kurtosis (x), -6/5, 0.0094); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! rand ("seed", 12); -%! x = rand (100000, 1); -%! assert (max (x) < 1); #*** Please report this!!! *** -%! assert (min (x) > 0); #*** Please report this!!! *** -%! assert (mean (x), 0.5, 0.0024); -%! assert (var (x), 1/48, 0.0632); -%! assert (skewness (x), 0, 0.012); -%! assert (kurtosis (x), -6/5, 0.0094); -%! endif -*/ - -static std::string current_distribution = octave_rand::distribution (); - -DEFUN_DLD (randn, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} randn (@var{n})\n\ -@deftypefnx {Loadable Function} {} randn (@var{n}, @var{m}, @dots{})\n\ -@deftypefnx {Loadable Function} {} randn ([@var{n} @var{m} @dots{}])\n\ -@deftypefnx {Loadable Function} {@var{v} =} randn (\"state\")\n\ -@deftypefnx {Loadable Function} {} randn (\"state\", @var{v})\n\ -@deftypefnx {Loadable Function} {} randn (\"state\", \"reset\")\n\ -@deftypefnx {Loadable Function} {@var{v} =} randn (\"seed\")\n\ -@deftypefnx {Loadable Function} {} randn (\"seed\", @var{v})\n\ -@deftypefnx {Loadable Function} {} randn (\"seed\", \"reset\")\n\ -@deftypefnx {Loadable Function} {} randn (@dots{}, \"single\")\n\ -@deftypefnx {Loadable Function} {} randn (@dots{}, \"double\")\n\ -Return a matrix with normally distributed random\n\ -elements having zero mean and variance one. The arguments are\n\ -handled the same as the arguments for @code{rand}.\n\ -\n\ -By default, @code{randn} uses the Marsaglia and Tsang ``Ziggurat technique''\n\ -to transform from a uniform to a normal distribution.\n\ -\n\ -The class of the value returned can be controlled by a trailing \"double\"\n\ -or \"single\" argument. These are the only valid classes.\n\ -\n\ -Reference: G. Marsaglia and W.W. Tsang,\n\ -@cite{Ziggurat Method for Generating Random Variables},\n\ -J. Statistical Software, vol 5, 2000,\n\ -@url{http://www.jstatsoft.org/v05/i08/})\n\ -\n\ -@seealso{rand, rande, randg, randp}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - retval = do_rand (args, nargin, "randn", "normal"); - - return retval; -} - -/* -%!test -%! # Test fixed state -%! randn ("state", 1); -%! assert (randn (1, 6), [-2.666521678978671 -0.7381719971724564 1.507903992673601 0.6019427189162239 -0.450661261143348 -0.7054431351574116], 1e-6); -%!test -%! # Test fixed seed -%! randn ("seed", 1); -%! assert (randn (1, 6), [-1.039402365684509 -1.25938892364502 0.1968704611063004 0.3874166905879974 -0.5976632833480835 -0.6615074276924133], 1e-6); -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randn ("state", 12); -%! x = randn (100000, 1); -%! assert (mean (x), 0, 0.01); -%! assert (var (x), 1, 0.02); -%! assert (skewness (x), 0, 0.02); -%! assert (kurtosis (x), 0, 0.04); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randn ("seed", 12); -%! x = randn (100000, 1); -%! assert (mean (x), 0, 0.01); -%! assert (var (x), 1, 0.02); -%! assert (skewness (x), 0, 0.02); -%! assert (kurtosis (x), 0, 0.04); -%! endif -*/ - -DEFUN_DLD (rande, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} rande (@var{n})\n\ -@deftypefnx {Loadable Function} {} rande (@var{n}, @var{m}, @dots{})\n\ -@deftypefnx {Loadable Function} {} rande ([@var{n} @var{m} @dots{}])\n\ -@deftypefnx {Loadable Function} {@var{v} =} rande (\"state\")\n\ -@deftypefnx {Loadable Function} {} rande (\"state\", @var{v})\n\ -@deftypefnx {Loadable Function} {} rande (\"state\", \"reset\")\n\ -@deftypefnx {Loadable Function} {@var{v} =} rande (\"seed\")\n\ -@deftypefnx {Loadable Function} {} rande (\"seed\", @var{v})\n\ -@deftypefnx {Loadable Function} {} rande (\"seed\", \"reset\")\n\ -@deftypefnx {Loadable Function} {} rande (@dots{}, \"single\")\n\ -@deftypefnx {Loadable Function} {} rande (@dots{}, \"double\")\n\ -Return a matrix with exponentially distributed random elements. The\n\ -arguments are handled the same as the arguments for @code{rand}.\n\ -\n\ -By default, @code{randn} uses the Marsaglia and Tsang ``Ziggurat technique''\n\ -to transform from a uniform to an exponential distribution.\n\ -\n\ -The class of the value returned can be controlled by a trailing \"double\"\n\ -or \"single\" argument. These are the only valid classes.\n\ -\n\ -Reference: G. Marsaglia and W.W. Tsang,\n\ -@cite{Ziggurat Method for Generating Random Variables},\n\ -J. Statistical Software, vol 5, 2000,\n\ -@url{http://www.jstatsoft.org/v05/i08/})\n\ -\n\ -@seealso{rand, randn, randg, randp}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - retval = do_rand (args, nargin, "rande", "exponential"); - - return retval; -} - -/* -%!test -%! # Test fixed state -%! rande ("state", 1); -%! assert (rande (1, 6), [3.602973885835625 0.1386190677555021 0.6743112889616958 0.4512830847258422 0.7255744741233175 0.3415969205292291], 1e-6); -%!test -%! # Test fixed seed -%! rande ("seed", 1); -%! assert (rande (1, 6), [0.06492075175653866 1.717980206012726 0.4816154008731246 0.5231300676241517 0.103910739364359 1.668931916356087], 1e-6); -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally -%! rande ("state", 1); -%! x = rande (100000, 1); -%! assert (min (x) > 0); # *** Please report this!!! *** -%! assert (mean (x), 1, 0.01); -%! assert (var (x), 1, 0.03); -%! assert (skewness (x), 2, 0.06); -%! assert (kurtosis (x), 6, 0.7); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally -%! rande ("seed", 1); -%! x = rande (100000, 1); -%! assert (min (x)>0); # *** Please report this!!! *** -%! assert (mean (x), 1, 0.01); -%! assert (var (x), 1, 0.03); -%! assert (skewness (x), 2, 0.06); -%! assert (kurtosis (x), 6, 0.7); -%! endif -*/ - -DEFUN_DLD (randg, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} randg (@var{n})\n\ -@deftypefnx {Loadable Function} {} randg (@var{n}, @var{m}, @dots{})\n\ -@deftypefnx {Loadable Function} {} randg ([@var{n} @var{m} @dots{}])\n\ -@deftypefnx {Loadable Function} {@var{v} =} randg (\"state\")\n\ -@deftypefnx {Loadable Function} {} randg (\"state\", @var{v})\n\ -@deftypefnx {Loadable Function} {} randg (\"state\", \"reset\")\n\ -@deftypefnx {Loadable Function} {@var{v} =} randg (\"seed\")\n\ -@deftypefnx {Loadable Function} {} randg (\"seed\", @var{v})\n\ -@deftypefnx {Loadable Function} {} randg (\"seed\", \"reset\")\n\ -@deftypefnx {Loadable Function} {} randg (@dots{}, \"single\")\n\ -@deftypefnx {Loadable Function} {} randg (@dots{}, \"double\")\n\ -Return a matrix with @code{gamma (@var{a},1)} distributed random elements.\n\ -The arguments are handled the same as the arguments for @code{rand},\n\ -except for the argument @var{a}.\n\ -\n\ -This can be used to generate many distributions:\n\ -\n\ -@table @asis\n\ -@item @code{gamma (a, b)} for @code{a > -1}, @code{b > 0}\n\ -\n\ -@example\n\ -r = b * randg (a)\n\ -@end example\n\ -\n\ -@item @code{beta (a, b)} for @code{a > -1}, @code{b > -1}\n\ -\n\ -@example\n\ -@group\n\ -r1 = randg (a, 1)\n\ -r = r1 / (r1 + randg (b, 1))\n\ -@end group\n\ -@end example\n\ -\n\ -@item @code{Erlang (a, n)}\n\ -\n\ -@example\n\ -r = a * randg (n)\n\ -@end example\n\ -\n\ -@item @code{chisq (df)} for @code{df > 0}\n\ -\n\ -@example\n\ -r = 2 * randg (df / 2)\n\ -@end example\n\ -\n\ -@item @code{t (df)} for @code{0 < df < inf} (use randn if df is infinite)\n\ -\n\ -@example\n\ -r = randn () / sqrt (2 * randg (df / 2) / df)\n\ -@end example\n\ -\n\ -@item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2}\n\ -\n\ -@example\n\ -@group\n\ -## r1 equals 1 if n1 is infinite\n\ -r1 = 2 * randg (n1 / 2) / n1\n\ -## r2 equals 1 if n2 is infinite\n\ -r2 = 2 * randg (n2 / 2) / n2\n\ -r = r1 / r2\n\n\ -@end group\n\ -@end example\n\ -\n\ -@item negative @code{binomial (n, p)} for @code{n > 0}, @code{0 < p <= 1}\n\ -\n\ -@example\n\ -r = randp ((1 - p) / p * randg (n))\n\ -@end example\n\ -\n\ -@item non-central @code{chisq (df, L)}, for @code{df >= 0} and @code{L > 0}\n\ -(use chisq if @code{L = 0})\n\ -\n\ -@example\n\ -@group\n\ -r = randp (L / 2)\n\ -r(r > 0) = 2 * randg (r(r > 0))\n\ -r(df > 0) += 2 * randg (df(df > 0)/2)\n\ -@end group\n\ -@end example\n\ -\n\ -@item @code{Dirichlet (a1, @dots{} ak)}\n\ -\n\ -@example\n\ -@group\n\ -r = (randg (a1), @dots{}, randg (ak))\n\ -r = r / sum (r)\n\ -@end group\n\ -@end example\n\ -\n\ -@end table\n\ -\n\ -The class of the value returned can be controlled by a trailing \"double\"\n\ -or \"single\" argument. These are the only valid classes.\n\ -@seealso{rand, randn, rande, randp}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 1) - error ("randg: insufficient arguments"); - else - retval = do_rand (args, nargin, "randg", "gamma", true); - - return retval; -} - -/* -%!test -%! randg ("state", 12) -%! assert (randg ([-inf, -1, 0, inf, nan]), [nan, nan, nan, nan, nan]); # *** Please report - -%!test -%! # Test fixed state -%! randg ("state", 1); -%! assert (randg (0.1, 1, 6), [0.0103951513331241 8.335671459898252e-05 0.00138691397249762 0.000587308416993855 0.495590518784736 2.3921917414795e-12], 1e-6); -%!test -%! # Test fixed state -%! randg ("state", 1); -%! assert (randg (0.95, 1, 6), [3.099382433255327 0.3974529788871218 0.644367450750855 1.143261091802246 1.964111762696822 0.04011915547957939], 1e-6); -%!test -%! # Test fixed state -%! randg ("state", 1); -%! assert (randg (1, 1, 6), [0.2273389379645993 1.288822625058359 0.2406335209340746 1.218869553370733 1.024649860162554 0.09631230343599533], 1e-6); -%!test -%! # Test fixed state -%! randg ("state", 1); -%! assert (randg (10, 1, 6), [3.520369644331133 15.15369864472106 8.332112081991205 8.406211067432674 11.81193475187611 10.88792728177059], 1e-5); -%!test -%! # Test fixed state -%! randg ("state", 1); -%! assert (randg (100, 1, 6), [75.34570255262264 115.4911985594699 95.23493031356388 95.48926019250911 106.2397448229803 103.4813150404118], 1e-4); -%!test -%! # Test fixed seed -%! randg ("seed", 1); -%! assert (randg (0.1, 1, 6), [0.07144210487604141 0.460641473531723 0.4749028384685516 0.06823389977216721 0.000293838675133884 1.802567535340305e-12], 1e-6); -%!test -%! # Test fixed seed -%! randg ("seed", 1); -%! assert (randg (0.95, 1, 6), [1.664905071258545 1.879976987838745 1.905677795410156 0.9948706030845642 0.5606933236122131 0.0766092911362648], 1e-6); -%!test -%! # Test fixed seed -%! randg ("seed", 1); -%! assert (randg (1, 1, 6), [0.03512085229158401 0.6488978862762451 0.8114678859710693 0.1666885763406754 1.60791552066803 1.90356981754303], 1e-6); -%!test -%! # Test fixed seed -%! randg ("seed", 1); -%! assert (randg (10, 1, 6), [6.566435813903809 10.11648464202881 10.73162078857422 7.747178077697754 6.278522491455078 6.240195751190186], 1e-5); -%!test -%! # Test fixed seed -%! randg ("seed", 1); -%! assert (randg (100, 1, 6), [89.40208435058594 101.4734725952148 103.4020004272461 93.62763214111328 88.33104705810547 88.1871337890625], 1e-4); - -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("state", 12); -%! a = 0.1; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.01); -%! assert (var (x), a, 0.01); -%! assert (skewness (x), 2/sqrt (a), 1); -%! assert (kurtosis (x), 6/a, 50); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("state", 12); -%! a = 0.95; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.01); -%! assert (var (x), a, 0.04); -%! assert (skewness (x), 2/sqrt (a), 0.2); -%! assert (kurtosis (x), 6/a, 2); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("state", 12); -%! a = 1; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.01); -%! assert (var (x), a, 0.04); -%! assert (skewness (x), 2/sqrt (a), 0.2); -%! assert (kurtosis (x), 6/a, 2); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("state", 12); -%! a = 10; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.1); -%! assert (var (x), a, 0.5); -%! assert (skewness (x), 2/sqrt (a), 0.1); -%! assert (kurtosis (x), 6/a, 0.5); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("state", 12); -%! a = 100; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.2); -%! assert (var (x), a, 2); -%! assert (skewness (x), 2/sqrt (a), 0.05); -%! assert (kurtosis (x), 6/a, 0.2); -%! endif -%!test -%! randg ("seed", 12); -%!assert (randg ([-inf, -1, 0, inf, nan]), [nan, nan, nan, nan, nan]) # *** Please report -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("seed", 12); -%! a = 0.1; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.01); -%! assert (var (x), a, 0.01); -%! assert (skewness (x), 2/sqrt (a), 1); -%! assert (kurtosis (x), 6/a, 50); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("seed", 12); -%! a = 0.95; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.01); -%! assert (var (x), a, 0.04); -%! assert (skewness (x), 2/sqrt (a), 0.2); -%! assert (kurtosis (x), 6/a, 2); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("seed", 12); -%! a = 1; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.01); -%! assert (var (x), a, 0.04); -%! assert (skewness (x), 2/sqrt (a), 0.2); -%! assert (kurtosis (x), 6/a, 2); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("seed", 12); -%! a = 10; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.1); -%! assert (var (x), a, 0.5); -%! assert (skewness (x), 2/sqrt (a), 0.1); -%! assert (kurtosis (x), 6/a, 0.5); -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randg ("seed", 12); -%! a = 100; -%! x = randg (a, 100000, 1); -%! assert (mean (x), a, 0.2); -%! assert (var (x), a, 2); -%! assert (skewness (x), 2/sqrt (a), 0.05); -%! assert (kurtosis (x), 6/a, 0.2); -%! endif -*/ - -DEFUN_DLD (randp, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} randp (@var{l}, @var{n})\n\ -@deftypefnx {Loadable Function} {} randp (@var{l}, @var{n}, @var{m}, @dots{})\n\ -@deftypefnx {Loadable Function} {} randp (@var{l}, [@var{n} @var{m} @dots{}])\n\ -@deftypefnx {Loadable Function} {@var{v} =} randp (\"state\")\n\ -@deftypefnx {Loadable Function} {} randp (\"state\", @var{v})\n\ -@deftypefnx {Loadable Function} {} randp (\"state\", \"reset\")\n\ -@deftypefnx {Loadable Function} {@var{v} =} randp (\"seed\")\n\ -@deftypefnx {Loadable Function} {} randp (\"seed\", @var{v})\n\ -@deftypefnx {Loadable Function} {} randp (\"seed\", \"reset\")\n\ -@deftypefnx {Loadable Function} {} randp (@dots{}, \"single\")\n\ -@deftypefnx {Loadable Function} {} randp (@dots{}, \"double\")\n\ -Return a matrix with Poisson distributed random elements with mean value\n\ -parameter given by the first argument, @var{l}. The arguments\n\ -are handled the same as the arguments for @code{rand}, except for the\n\ -argument @var{l}.\n\ -\n\ -Five different algorithms are used depending on the range of @var{l}\n\ -and whether or not @var{l} is a scalar or a matrix.\n\ -\n\ -@table @asis\n\ -@item For scalar @var{l} @leq{} 12, use direct method.\n\ -W.H. Press, et al., @cite{Numerical Recipes in C},\n\ -Cambridge University Press, 1992.\n\ -\n\ -@item For scalar @var{l} > 12, use rejection method.[1]\n\ -W.H. Press, et al., @cite{Numerical Recipes in C},\n\ -Cambridge University Press, 1992.\n\ -\n\ -@item For matrix @var{l} @leq{} 10, use inversion method.[2]\n\ -E. Stadlober, et al., WinRand source code, available via FTP.\n\ -\n\ -@item For matrix @var{l} > 10, use patchwork rejection method.\n\ -E. Stadlober, et al., WinRand source code, available via FTP, or\n\ -H. Zechner, @cite{Efficient sampling from continuous and discrete\n\ -unimodal distributions}, Doctoral Dissertation, 156pp., Technical\n\ -University Graz, Austria, 1994.\n\ -\n\ -@item For @var{l} > 1e8, use normal approximation.\n\ -L. Montanet, et al., @cite{Review of Particle Properties}, Physical Review\n\ -D 50 p1284, 1994.\n\ -@end table\n\ -\n\ -The class of the value returned can be controlled by a trailing \"double\"\n\ -or \"single\" argument. These are the only valid classes.\n\ -@seealso{rand, randn, rande, randg}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin < 1) - error ("randp: insufficient arguments"); - else - retval = do_rand (args, nargin, "randp", "poisson", true); - - return retval; -} - -/* -%!test -%! randp ("state", 12); -%! assert (randp ([-inf, -1, 0, inf, nan]), [nan, nan, 0, nan, nan]); # *** Please report -%!test -%! # Test fixed state -%! randp ("state", 1); -%! assert (randp (5, 1, 6), [5 5 3 7 7 3]) -%!test -%! # Test fixed state -%! randp ("state", 1); -%! assert (randp (15, 1, 6), [13 15 8 18 18 15]) -%!test -%! # Test fixed state -%! randp ("state", 1); -%! assert (randp (1e9, 1, 6), [999915677 999976657 1000047684 1000019035 999985749 999977692], -1e-6) -%!test -%! # Test fixed state -%! randp ("seed", 1); -%! %%assert (randp (5, 1, 6), [8 2 3 6 6 8]) -%! assert (randp (5, 1, 5), [8 2 3 6 6]) -%!test -%! # Test fixed state -%! randp ("seed", 1); -%! assert (randp (15, 1, 6), [15 16 12 10 10 12]) -%!test -%! # Test fixed state -%! randp ("seed", 1); -%! assert (randp (1e9, 1, 6), [1000006208 1000012224 999981120 999963520 999963072 999981440], -1e-6) -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randp ("state", 12); -%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] -%! x = randp (a (1), 100000, 1); -%! assert (min (x) >= 0); # *** Please report this!!! *** -%! assert (mean (x), a(1), a(2)); -%! assert (var (x), a(1), 0.02*a(1)); -%! assert (skewness (x), 1/sqrt (a(1)), a(3)); -%! assert (kurtosis (x), 1/a(1), 3*a(3)); -%! endfor -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randp ("state", 12); -%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] -%! x = randp (a(1)*ones (100000, 1), 100000, 1); -%! assert (min (x) >= 0); # *** Please report this!!! *** -%! assert (mean (x), a(1), a(2)); -%! assert (var (x), a(1), 0.02*a(1)); -%! assert (skewness (x), 1/sqrt (a(1)), a(3)); -%! assert (kurtosis (x), 1/a(1), 3*a(3)); -%! endfor -%! endif -%!test -%! randp ("seed", 12); -%! assert (randp ([-inf, -1, 0, inf, nan]), [nan, nan, 0, nan, nan]); # *** Please report -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randp ("seed", 12); -%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] -%! x = randp (a(1), 100000, 1); -%! assert (min (x) >= 0); # *** Please report this!!! *** -%! assert (mean (x), a(1), a(2)); -%! assert (var (x), a(1), 0.02*a(1)); -%! assert (skewness (x), 1/sqrt (a(1)), a(3)); -%! assert (kurtosis (x), 1/a(1), 3*a(3)); -%! endfor -%! endif -%!test -%! if (__random_statistical_tests__) -%! # statistical tests may fail occasionally. -%! randp ("seed", 12); -%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] -%! x = randp (a(1)*ones (100000, 1), 100000, 1); -%! assert (min (x) >= 0); # *** Please report this!!! *** -%! assert (mean (x), a(1), a(2)); -%! assert (var (x), a(1), 0.02*a(1)); -%! assert (skewness (x), 1/sqrt (a(1)), a(3)); -%! assert (kurtosis (x), 1/a(1), 3*a(3)); -%! endfor -%! endif -*/ - -DEFUN_DLD (randperm, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} randperm (@var{n})\n\ -@deftypefnx {Loadable Function} {} randperm (@var{n}, @var{m})\n\ -Return a row vector containing a random permutation of @code{1:@var{n}}.\n\ -If @var{m} is supplied, return @var{m} unique entries, sampled without\n\ -replacement from @code{1:@var{n}}. The complexity is O(@var{n}) in\n\ -memory and O(@var{m}) in time, unless @var{m} < @var{n}/5, in which case\n\ -O(@var{m}) memory is used as well. The randomization is performed using\n\ -rand(). All permutations are equally likely.\n\ -@seealso{perms}\n\ -@end deftypefn") -{ - -#ifdef USE_UNORDERED_MAP_WITH_TR1 -using std::tr1::unordered_map; -#else -using std::unordered_map; -#endif - - int nargin = args.length (); - octave_value retval; - - if (nargin == 1 || nargin == 2) - { - octave_idx_type n, m; - - n = args(0).idx_type_value (true); - - if (nargin == 2) - m = args(1).idx_type_value (true); - else - m = n; - - if (m < 0 || n < 0) - error ("randperm: M and N must be non-negative"); - - if (m > n) - error ("randperm: M must be less than or equal to N"); - - // Quick and dirty heuristic to decide if we allocate or not the - // whole vector for tracking the truncated shuffle. - bool short_shuffle = m < n/5 && m < 1e5; - - if (! error_state) - { - // Generate random numbers. - NDArray r = octave_rand::nd_array (dim_vector (1, m)); - double *rvec = r.fortran_vec (); - - octave_idx_type idx_len = short_shuffle ? m : n; - Array<octave_idx_type> idx (dim_vector (1, idx_len)); - octave_idx_type *ivec = idx.fortran_vec (); - - for (octave_idx_type i = 0; i < idx_len; i++) - ivec[i] = i; - - if (short_shuffle) - { - unordered_map<octave_idx_type, octave_idx_type> map (m); - - // Perform the Knuth shuffle only keeping track of moved - // entries in the map - for (octave_idx_type i = 0; i < m; i++) - { - octave_idx_type k = i + - gnulib::floor (rvec[i] * (n - i)); - - //For shuffling first m entries, no need to use extra - //storage - if (k < m) - { - std::swap (ivec[i], ivec[k]); - } - else - { - if (map.find (k) == map.end ()) - map[k] = k; - - std::swap (ivec[i], map[k]); - } - } - } - else - { - - // Perform the Knuth shuffle of the first m entries - for (octave_idx_type i = 0; i < m; i++) - { - octave_idx_type k = i + - gnulib::floor (rvec[i] * (n - i)); - std::swap (ivec[i], ivec[k]); - } - } - - // Convert to doubles, reusing r. - for (octave_idx_type i = 0; i < m; i++) - rvec[i] = ivec[i] + 1; - - if (m < n) - idx.resize (dim_vector (1, m)); - - // Now create an array object with a cached idx_vector. - retval = new octave_matrix (r, idx_vector (idx)); - } - } - else - print_usage (); - - return retval; -} - -/* -%!assert (sort (randperm (20)), 1:20) -%!assert (length (randperm (20,10)), 10) - -%!test -%! rand ("seed", 0); -%! for i = 1:100 -%! p = randperm (305, 30); -%! assert (length (unique (p)), 30); -%! endfor -*/
--- a/src/DLD-FUNCTIONS/rcond.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -/* - -Copyright (C) 2008-2012 David Bateman - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (rcond, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{c} =} rcond (@var{A})\n\ -Compute the 1-norm estimate of the reciprocal condition number as returned\n\ -by @sc{lapack}. If the matrix is well-conditioned then @var{c} will be near\n\ -1 and if the matrix is poorly conditioned it will be close to zero.\n\ -\n\ -The matrix @var{A} must not be sparse. If the matrix is sparse then\n\ -@code{condest (@var{A})} or @code{rcond (full (@var{A}))} should be used\n\ -instead.\n\ -@seealso{cond, condest}\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin != 1) - print_usage (); - else if (args(0).is_sparse_type ()) - error ("rcond: for sparse matrices use 'rcond (full (a))' or 'condest (a)' instead"); - else if (args(0).is_single_type ()) - { - if (args(0).is_complex_type ()) - { - FloatComplexMatrix m = args(0).float_complex_matrix_value (); - MatrixType mattyp; - retval = m.rcond (mattyp); - args(0).matrix_type (mattyp); - } - else - { - FloatMatrix m = args(0).float_matrix_value (); - MatrixType mattyp; - retval = m.rcond (mattyp); - args(0).matrix_type (mattyp); - } - } - else if (args(0).is_complex_type ()) - { - ComplexMatrix m = args(0).complex_matrix_value (); - MatrixType mattyp; - retval = m.rcond (mattyp); - args(0).matrix_type (mattyp); - } - else - { - Matrix m = args(0).matrix_value (); - MatrixType mattyp; - retval = m.rcond (mattyp); - args(0).matrix_type (mattyp); - } - - return retval; -} - -/* -%!assert (rcond (eye (2)), 1) -%!assert (rcond (ones (2)), 0) -%!assert (rcond ([1 1; 2 1]), 1/9) -%!assert (rcond (magic (4)), 0, eps) -*/
--- a/src/DLD-FUNCTIONS/regexp.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1408 +0,0 @@ -/* - -Copyright (C) 2005-2012 David Bateman -Copyright (C) 2002-2005 Paul Kienzle - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <list> -#include <sstream> - -#include <pcre.h> - -#include "base-list.h" -#include "oct-locbuf.h" -#include "quit.h" -#include "regexp.h" -#include "str-vec.h" - -#include "defun-dld.h" -#include "Cell.h" -#include "error.h" -#include "gripes.h" -#include "oct-map.h" -#include "oct-obj.h" -#include "utils.h" - -// Replace backslash escapes in a string with the real values. We need -// this special function instead of the one in utils.cc because the set -// of escape sequences used in regexps is different from those used in -// the *printf functions. - -static std::string -do_regexp_string_escapes (const std::string& s) -{ - std::string retval; - - size_t i = 0; - size_t j = 0; - size_t len = s.length (); - - retval.resize (len); - - while (j < len) - { - if (s[j] == '\\' && j+1 < len) - { - switch (s[++j]) - { - case '$': - retval[i] = '$'; - break; - - case 'a': - retval[i] = '\a'; - break; - - case 'b': // backspace - retval[i] = '\b'; - break; - - case 'f': // formfeed - retval[i] = '\f'; - break; - - case 'n': // newline - retval[i] = '\n'; - break; - - case 'r': // carriage return - retval[i] = '\r'; - break; - - case 't': // horizontal tab - retval[i] = '\t'; - break; - - case 'v': // vertical tab - retval[i] = '\v'; - break; - - case '\\': // backslash - retval[i] = '\\'; - break; - -#if 0 -// FIXME -- to be complete, we need to handle \oN, \o{N}, \xN, and -// \x{N}. Hex digits may be upper or lower case. Brackets are -// optional, so \x5Bz is the same as \x{5B}z. - - case 'o': // octal number - case 'x': // hex number -#endif - - default: - retval[i] = '\\'; - retval[++i] = s[j]; - break; - } - } - else - { - retval[i] = s[j]; - } - - i++; - j++; - } - - retval.resize (i); - - return retval; -} - -static void -parse_options (regexp::opts& options, const octave_value_list& args, - const std::string& who, int skip, bool& extra_args) -{ - int nargin = args.length (); - - extra_args = false; - - for (int i = skip; i < nargin; i++) - { - std::string str = args(i).string_value (); - - if (error_state) - { - error ("%s: optional arguments must be character strings", - who.c_str ()); - break; - } - - std::transform (str.begin (), str.end (), str.begin (), tolower); - - if (str.find ("once", 0) == 0) - options.once (true); - else if (str.find ("matchcase", 0) == 0) - options.case_insensitive (false); - else if (str.find ("ignorecase", 0) == 0) - options.case_insensitive (true); - else if (str.find ("dotall", 0) == 0) - options.dotexceptnewline (false); - else if (str.find ("stringanchors", 0) == 0) - options.lineanchors (false); - else if (str.find ("literalspacing", 0) == 0) - options.freespacing (false); - else if (str.find ("noemptymatch", 0) == 0) - options.emptymatch (false); - else if (str.find ("dotexceptnewline", 0) == 0) - options.dotexceptnewline (true); - else if (str.find ("lineanchors", 0) == 0) - options.lineanchors (true); - else if (str.find ("freespacing", 0) == 0) - options.freespacing (true); - else if (str.find ("emptymatch", 0) == 0) - options.emptymatch (true); - else if (str.find ("start", 0) == 0 - || str.find ("end", 0) == 0 - || str.find ("tokenextents", 0) == 0 - || str.find ("match", 0) == 0 - || str.find ("tokens", 0) == 0 - || str.find ("names", 0) == 0 - || str.find ("split", 0) == 0) - extra_args = true; - else - error ("%s: unrecognized option", who.c_str ()); - } -} - -static octave_value_list -octregexp (const octave_value_list &args, int nargout, - const std::string &who, bool case_insensitive = false) -{ - octave_value_list retval; - - int nargin = args.length (); - - // Make sure we have string, pattern - const std::string buffer = args(0).string_value (); - if (error_state) - return retval; - - std::string pattern = args(1).string_value (); - if (error_state) - return retval; - // Matlab compatibility. - if (args(1).is_sq_string ()) - pattern = do_regexp_string_escapes (pattern); - - regexp::opts options; - options.case_insensitive (case_insensitive); - bool extra_options = false; - parse_options (options, args, who, 2, extra_options); - if (error_state) - return retval; - - regexp::match_data rx_lst = regexp_match (pattern, buffer, options, who); - - string_vector named_pats = rx_lst.named_patterns (); - - size_t sz = rx_lst.size (); - - if (! error_state) - { - // Converted the linked list in the correct form for the return values - - octave_idx_type i = 0; - octave_scalar_map nmap; - - retval.resize (7); - - if (sz == 1) - { - string_vector named_tokens = rx_lst.begin ()->named_tokens (); - - for (int j = 0; j < named_pats.length (); j++) - nmap.assign (named_pats(j), named_tokens(j)); - - retval(5) = nmap; - } - else - { - for (int j = 0; j < named_pats.length (); j++) - { - Cell tmp (dim_vector (1, sz)); - - i = 0; - for (regexp::match_data::const_iterator p = rx_lst.begin (); - p != rx_lst.end (); p++) - { - string_vector named_tokens = p->named_tokens (); - - tmp(i++) = named_tokens(j); - } - - nmap.assign (named_pats(j), octave_value (tmp)); - } - - retval(5) = nmap; - } - - if (options.once ()) - { - regexp::match_data::const_iterator p = rx_lst.begin (); - - retval(4) = sz ? p->tokens () : Cell (); - retval(3) = sz ? p->match_string () : std::string (); - retval(2) = sz ? p->token_extents () : Matrix (); - - if (sz) - { - double start = p->start (); - double end = p->end (); - - Cell split (dim_vector (1, 2)); - split(0) = buffer.substr (0, start-1); - split(1) = buffer.substr (end); - - retval(6) = split; - retval(1) = end; - retval(0) = start; - } - else - { - retval(6) = buffer; - retval(1) = Matrix (); - retval(0) = Matrix (); - } - } - else - { - Cell tokens (dim_vector (1, sz)); - Cell match_string (dim_vector (1, sz)); - Cell token_extents (dim_vector (1, sz)); - NDArray end (dim_vector (1, sz)); - NDArray start (dim_vector (1, sz)); - Cell split (dim_vector (1, sz+1)); - size_t sp_start = 0; - - i = 0; - for (regexp::match_data::const_iterator p = rx_lst.begin (); - p != rx_lst.end (); p++) - { - double s = p->start (); - double e = p->end (); - - string_vector tmp = p->tokens (); - tokens(i) = Cell (dim_vector (1, tmp.length ()), tmp); - match_string(i) = p->match_string (); - token_extents(i) = p->token_extents (); - end(i) = e; - start(i) = s; - split(i) = buffer.substr (sp_start, s-sp_start-1); - sp_start = e; - i++; - } - - split(i) = buffer.substr (sp_start); - - retval(6) = split; - retval(4) = tokens; - retval(3) = match_string; - retval(2) = token_extents; - retval(1) = end; - retval(0) = start; - } - - // Alter the order of the output arguments - - if (extra_options) - { - int n = 0; - octave_value_list new_retval; - new_retval.resize (nargout); - - OCTAVE_LOCAL_BUFFER (int, arg_used, 6); - for (int j = 0; j < 6; j++) - arg_used[j] = false; - - for (int j = 2; j < nargin; j++) - { - int k = 0; - std::string str = args(j).string_value (); - std::transform (str.begin (), str.end (), str.begin (), tolower); - - if (str.find ("once", 0) == 0 - || str.find ("stringanchors", 0) == 0 - || str.find ("lineanchors", 0) == 0 - || str.find ("matchcase", 0) == 0 - || str.find ("ignorecase", 0) == 0 - || str.find ("dotall", 0) == 0 - || str.find ("dotexceptnewline", 0) == 0 - || str.find ("literalspacing", 0) == 0 - || str.find ("freespacing", 0) == 0 - || str.find ("noemptymatch", 0) == 0 - || str.find ("emptymatch", 0) == 0) - continue; - else if (str.find ("start", 0) == 0) - k = 0; - else if (str.find ("end", 0) == 0) - k = 1; - else if (str.find ("tokenextents", 0) == 0) - k = 2; - else if (str.find ("match", 0) == 0) - k = 3; - else if (str.find ("tokens", 0) == 0) - k = 4; - else if (str.find ("names", 0) == 0) - k = 5; - else if (str.find ("split", 0) == 0) - k = 6; - - new_retval(n++) = retval(k); - arg_used[k] = true; - - if (n == nargout) - break; - } - - // Fill in the rest of the arguments - if (n < nargout) - { - for (int j = 0; j < 6; j++) - { - if (! arg_used[j]) - new_retval(n++) = retval(j); - } - } - - retval = new_retval; - } - } - - return retval; -} - -static octave_value_list -octcellregexp (const octave_value_list &args, int nargout, - const std::string &who, bool case_insensitive = false) -{ - octave_value_list retval; - - if (args(0).is_cell ()) - { - OCTAVE_LOCAL_BUFFER (Cell, newretval, nargout); - octave_value_list new_args = args; - Cell cellstr = args(0).cell_value (); - if (args(1).is_cell ()) - { - Cell cellpat = args(1).cell_value (); - - if (cellpat.numel () == 1) - { - for (int j = 0; j < nargout; j++) - newretval[j].resize (cellstr.dims ()); - - new_args(1) = cellpat(0); - - for (octave_idx_type i = 0; i < cellstr.numel (); i++) - { - new_args(0) = cellstr(i); - octave_value_list tmp = octregexp (new_args, nargout, who, - case_insensitive); - - if (error_state) - break; - - for (int j = 0; j < nargout; j++) - newretval[j](i) = tmp(j); - } - } - else if (cellstr.numel () == 1) - { - for (int j = 0; j < nargout; j++) - newretval[j].resize (cellpat.dims ()); - - new_args(0) = cellstr(0); - - for (octave_idx_type i = 0; i < cellpat.numel (); i++) - { - new_args(1) = cellpat(i); - octave_value_list tmp = octregexp (new_args, nargout, who, - case_insensitive); - - if (error_state) - break; - - for (int j = 0; j < nargout; j++) - newretval[j](i) = tmp(j); - } - } - else if (cellstr.numel () == cellpat.numel ()) - { - - if (cellstr.dims () != cellpat.dims ()) - error ("%s: inconsistent cell array dimensions", who.c_str ()); - else - { - for (int j = 0; j < nargout; j++) - newretval[j].resize (cellstr.dims ()); - - for (octave_idx_type i = 0; i < cellstr.numel (); i++) - { - new_args(0) = cellstr(i); - new_args(1) = cellpat(i); - - octave_value_list tmp = octregexp (new_args, nargout, who, - case_insensitive); - - if (error_state) - break; - - for (int j = 0; j < nargout; j++) - newretval[j](i) = tmp(j); - } - } - } - else - error ("regexp: cell array arguments must be scalar or equal size"); - } - else - { - for (int j = 0; j < nargout; j++) - newretval[j].resize (cellstr.dims ()); - - for (octave_idx_type i = 0; i < cellstr.numel (); i++) - { - new_args(0) = cellstr(i); - octave_value_list tmp = octregexp (new_args, nargout, who, - case_insensitive); - - if (error_state) - break; - - for (int j = 0; j < nargout; j++) - newretval[j](i) = tmp(j); - } - } - - if (!error_state) - for (int j = 0; j < nargout; j++) - retval(j) = octave_value (newretval[j]); - } - else if (args(1).is_cell ()) - { - OCTAVE_LOCAL_BUFFER (Cell, newretval, nargout); - octave_value_list new_args = args; - Cell cellpat = args(1).cell_value (); - - for (int j = 0; j < nargout; j++) - newretval[j].resize (cellpat.dims ()); - - for (octave_idx_type i = 0; i < cellpat.numel (); i++) - { - new_args(1) = cellpat(i); - octave_value_list tmp = octregexp (new_args, nargout, who, - case_insensitive); - - if (error_state) - break; - - for (int j = 0; j < nargout; j++) - newretval[j](i) = tmp(j); - } - - if (!error_state) - { - for (int j = 0; j < nargout; j++) - retval(j) = octave_value (newretval[j]); - } - } - else - retval = octregexp (args, nargout, who, case_insensitive); - - return retval; - -} - -DEFUN_DLD (regexp, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{s}, @var{e}, @var{te}, @var{m}, @var{t}, @var{nm}, @var{sp}] =} regexp (@var{str}, @var{pat})\n\ -@deftypefnx {Loadable Function} {[@dots{}] =} regexp (@var{str}, @var{pat}, \"@var{opt1}\", @dots{})\n\ -Regular expression string matching. Search for @var{pat} in @var{str} and\n\ -return the positions and substrings of any matches, or empty values if there\n\ -are none.\n\ -\n\ -The matched pattern @var{pat} can include any of the standard regex\n\ -operators, including:\n\ -\n\ -@table @code\n\ -@item .\n\ -Match any character\n\ -\n\ -@item * + ? @{@}\n\ -Repetition operators, representing\n\ -\n\ -@table @code\n\ -@item *\n\ -Match zero or more times\n\ -\n\ -@item +\n\ -Match one or more times\n\ -\n\ -@item ?\n\ -Match zero or one times\n\ -\n\ -@item @{@var{n}@}\n\ -Match exactly @var{n} times\n\ -\n\ -@item @{@var{n},@}\n\ -Match @var{n} or more times\n\ -\n\ -@item @{@var{m},@var{n}@}\n\ -Match between @var{m} and @var{n} times\n\ -@end table\n\ -\n\ -@item [@dots{}] [^@dots{}]\n\ -\n\ -List operators. The pattern will match any character listed between \"[\"\n\ -and \"]\". If the first character is \"^\" then the pattern is inverted and\n\ -any character except those listed between brackets will match.\n\ -\n\ -Escape sequences defined below can also be used inside list\n\ -operators. For example, a template for a floating point number might be\n\ -@code{[-+.\\d]+}.\n\ -\n\ -@item () (?:)\n\ -Grouping operator. The first form, parentheses only, also creates a token.\n\ -\n\ -@item |\n\ -Alternation operator. Match one of a choice of regular expressions. The\n\ -alternatives must be delimited by the grouping operator @code{()} above.\n\ -\n\ -@item ^ $\n\ -Anchoring operators. Requires pattern to occur at the start (@code{^}) or\n\ -end (@code{$}) of the string.\n\ -@end table\n\ -\n\ -In addition, the following escaped characters have special meaning. Note,\n\ -it is recommended to quote @var{pat} in single quotes, rather than double\n\ -quotes, to avoid the escape sequences being interpreted by Octave before\n\ -being passed to @code{regexp}.\n\ -\n\ -@table @code\n\ -@item \\b\n\ -Match a word boundary\n\ -\n\ -@item \\B\n\ -Match within a word\n\ -\n\ -@item \\w\n\ -Match any word character\n\ -\n\ -@item \\W\n\ -Match any non-word character\n\ -\n\ -@item \\<\n\ -Match the beginning of a word\n\ -\n\ -@item \\>\n\ -Match the end of a word\n\ -\n\ -@item \\s\n\ -Match any whitespace character\n\ -\n\ -@item \\S\n\ -Match any non-whitespace character\n\ -\n\ -@item \\d\n\ -Match any digit\n\ -\n\ -@item \\D\n\ -Match any non-digit\n\ -@end table\n\ -\n\ -The outputs of @code{regexp} default to the order given below\n\ -\n\ -@table @var\n\ -@item s\n\ -The start indices of each matching substring\n\ -\n\ -@item e\n\ -The end indices of each matching substring\n\ -\n\ -@item te\n\ -The extents of each matched token surrounded by @code{(@dots{})} in\n\ -@var{pat}\n\ -\n\ -@item m\n\ -A cell array of the text of each match\n\ -\n\ -@item t\n\ -A cell array of the text of each token matched\n\ -\n\ -@item nm\n\ -A structure containing the text of each matched named token, with the name\n\ -being used as the fieldname. A named token is denoted by\n\ -@code{(?<name>@dots{})}.\n\ -\n\ -@item sp\n\ -A cell array of the text not returned by match, i.e., what remains if you\n\ -split the string based on @var{pat}.\n\ -@end table\n\ -\n\ -Particular output arguments, or the order of the output arguments, can be\n\ -selected by additional @var{opt} arguments. These are strings and the\n\ -correspondence between the output arguments and the optional argument\n\ -are\n\ -\n\ -@multitable @columnfractions 0.2 0.3 0.3 0.2\n\ -@item @tab 'start' @tab @var{s} @tab\n\ -@item @tab 'end' @tab @var{e} @tab\n\ -@item @tab 'tokenExtents' @tab @var{te} @tab\n\ -@item @tab 'match' @tab @var{m} @tab\n\ -@item @tab 'tokens' @tab @var{t} @tab\n\ -@item @tab 'names' @tab @var{nm} @tab\n\ -@item @tab 'split' @tab @var{sp} @tab\n\ -@end multitable\n\ -\n\ -Additional arguments are summarized below.\n\ -\n\ -@table @samp\n\ -@item once\n\ -Return only the first occurrence of the pattern.\n\ -\n\ -@item matchcase\n\ -Make the matching case sensitive. (default)\n\ -\n\ -Alternatively, use (?-i) in the pattern.\n\ -\n\ -@item ignorecase\n\ -Ignore case when matching the pattern to the string.\n\ -\n\ -Alternatively, use (?i) in the pattern.\n\ -\n\ -@item stringanchors\n\ -Match the anchor characters at the beginning and end of the string.\n\ -(default)\n\ -\n\ -Alternatively, use (?-m) in the pattern.\n\ -\n\ -@item lineanchors\n\ -Match the anchor characters at the beginning and end of the line.\n\ -\n\ -Alternatively, use (?m) in the pattern.\n\ -\n\ -@item dotall\n\ -The pattern @code{.} matches all characters including the newline character.\n\ - (default)\n\ -\n\ -Alternatively, use (?s) in the pattern.\n\ -\n\ -@item dotexceptnewline\n\ -The pattern @code{.} matches all characters except the newline character.\n\ -\n\ -Alternatively, use (?-s) in the pattern.\n\ -\n\ -@item literalspacing\n\ -All characters in the pattern, including whitespace, are significant and are\n\ -used in pattern matching. (default)\n\ -\n\ -Alternatively, use (?-x) in the pattern.\n\ -\n\ -@item freespacing\n\ -The pattern may include arbitrary whitespace and also comments beginning with\n\ -the character @samp{#}.\n\ -\n\ -Alternatively, use (?x) in the pattern.\n\ -\n\ -@item noemptymatch\n\ -Zero-length matches are not returned. (default)\n\ -\n\ -@item emptymatch\n\ -Return zero-length matches.\n\ -\n\ -@code{regexp ('a', 'b*', 'emptymatch'} returns @code{[1 2]} because there are\n\ -zero or more 'b' characters at positions 1 and end-of-string.\n\ -\n\ -@end table\n\ -@seealso{regexpi, strfind, regexprep}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin < 2) - print_usage (); - else if (args(0).is_cell () || args(1).is_cell ()) - retval = octcellregexp (args, (nargout > 0 ? nargout : 1), "regexp"); - else - retval = octregexp (args, nargout, "regexp"); - - return retval; -} - -/* -## PCRE_ERROR_MATCHLIMIT test -%!test -%! s = sprintf ('\t4\n0000\t-0.00\t-0.0000\t4\t-0.00\t-0.0000\t4\n0000\t-0.00\t-0.0000\t0\t-0.00\t-'); -%! ws = warning ("query"); -%! unwind_protect -%! warning ("off"); -%! regexp (s, '(\s*-*\d+[.]*\d*\s*)+\n'); -%! unwind_protect_cleanup -%! warning (ws); -%! end_unwind_protect - -## segfault test -%!assert (regexp ("abcde", "."), [1,2,3,4,5]) -## Infinite loop test -%!assert (isempty (regexp ("abcde", ""))) - -## Check that anchoring of pattern works correctly -%!assert (regexp ('abcabc', '^abc'), 1) -%!assert (regexp ('abcabc', 'abc$'), 4) -%!assert (regexp ('abcabc', '^abc$'), zeros (1,0)) - -%!test -%! [s, e, te, m, t] = regexp (' No Match ', 'f(.*)uck'); -%! assert (s, zeros (1,0)); -%! assert (e, zeros (1,0)); -%! assert (te, cell (1,0)); -%! assert (m, cell (1,0)); -%! assert (t, cell (1,0)); - -%!test -%! [s, e, te, m, t] = regexp (' FiRetrUck ', 'f(.*)uck'); -%! assert (s, zeros (1,0)); -%! assert (e, zeros (1,0)); -%! assert (te, cell (1,0)); -%! assert (m, cell (1,0)); -%! assert (t, cell (1,0)); - -%!test -%! [s, e, te, m, t] = regexp (' firetruck ', 'f(.*)uck'); -%! assert (s, 2); -%! assert (e, 10); -%! assert (te{1}, [3, 7]); -%! assert (m{1}, 'firetruck'); -%! assert (t{1}{1}, 'iretr'); - -%!test -%! [s, e, te, m, t] = regexp ('short test string', '\w*r\w*'); -%! assert (s, [1, 12]); -%! assert (e, [5, 17]); -%! assert (size (te), [1, 2]); -%! assert (isempty (te{1})); -%! assert (isempty (te{2})); -%! assert (m{1}, 'short'); -%! assert (m{2}, 'string'); -%! assert (size (t), [1, 2]); -%! assert (isempty (t{1})); -%! assert (isempty (t{2})); - -%!test -%! [s, e, te, m, t] = regexp ('short test string', '\w*r\w*', 'once'); -%! assert (s, 1); -%! assert (e, 5); -%! assert (isempty (te)); -%! assert (m, 'short'); -%! assert (isempty (t)); - -%!test -%! [m, te, e, s, t] = regexp ('short test string', '\w*r\w*', 'once', 'match', 'tokenExtents', 'end', 'start', 'tokens'); -%! assert (s, 1); -%! assert (e, 5); -%! assert (isempty (te)); -%! assert (m, 'short'); -%! assert (isempty (t)); - -%!test -%! [s, e, te, m, t, nm] = regexp ('short test string', '(?<word1>\w*t)\s*(?<word2>\w*t)'); -%! assert (s, 1); -%! assert (e, 10); -%! assert (size (te), [1, 1]); -%! assert (te{1}, [1,5; 7,10]); -%! assert (m{1}, 'short test'); -%! assert (size (t), [1, 1]); -%! assert (t{1}{1}, 'short'); -%! assert (t{1}{2}, 'test'); -%! assert (size (nm), [1, 1]); -%! assert (! isempty (fieldnames (nm))); -%! assert (sort (fieldnames (nm)), {'word1';'word2'}); -%! assert (nm.word1, 'short'); -%! assert (nm.word2, 'test'); - -%!test -%! [nm, m, te, e, s, t] = regexp ('short test string', '(?<word1>\w*t)\s*(?<word2>\w*t)', 'names', 'match', 'tokenExtents', 'end', 'start', 'tokens'); -%! assert (s, 1); -%! assert (e, 10); -%! assert (size (te), [1, 1]); -%! assert (te{1}, [1,5; 7,10]); -%! assert (m{1}, 'short test'); -%! assert (size (t), [1, 1]); -%! assert (t{1}{1}, 'short'); -%! assert (t{1}{2}, 'test'); -%! assert (size (nm), [1, 1]); -%! assert (!isempty (fieldnames (nm))); -%! assert (sort (fieldnames (nm)), {'word1';'word2'}); -%! assert (nm.word1, 'short'); -%! assert (nm.word2, 'test'); - -%!test -%! [t, nm] = regexp ("John Davis\nRogers, James", '(?<first>\w+)\s+(?<last>\w+)|(?<last>\w+),\s+(?<first>\w+)', 'tokens', 'names'); -%! assert (size (t), [1, 2]); -%! assert (t{1}{1}, 'John'); -%! assert (t{1}{2}, 'Davis'); -%! assert (t{2}{1}, 'Rogers'); -%! assert (t{2}{2}, 'James'); -%! assert (size (nm), [1, 1]); -%! assert (nm.first{1}, 'John'); -%! assert (nm.first{2}, 'James'); -%! assert (nm.last{1}, 'Davis'); -%! assert (nm.last{2}, 'Rogers'); - -## Tests for named tokens -%!test -%! # Parenthesis in named token (ie (int)) causes a problem -%! assert (regexp ('qwe int asd', ['(?<typestr>(int))'], 'names'), struct ('typestr', 'int')); - -%!test -%! ## Mix of named and unnamed tokens can cause segfault (bug #35683) -%! str = "abcde"; -%! ptn = '(?<T1>a)(\w+)(?<T2>d\w+)'; -%! tokens = regexp (str, ptn, "names"); -%! assert (isstruct (tokens) && numel (tokens) == 1); -%! assert (tokens.T1, "a"); -%! assert (tokens.T2, "de"); - -%!assert (regexp ("abc\nabc", '.'), [1:7]) -%!assert (regexp ("abc\nabc", '.', 'dotall'), [1:7]) -%!test -%! assert (regexp ("abc\nabc", '(?s).'), [1:7]); -%! assert (regexp ("abc\nabc", '.', 'dotexceptnewline'), [1,2,3,5,6,7]); -%! assert (regexp ("abc\nabc", '(?-s).'), [1,2,3,5,6,7]); - -%!assert (regexp ("caseCaSe", 'case'), 1) -%!assert (regexp ("caseCaSe", 'case', "matchcase"), 1) -%!assert (regexp ("caseCaSe", 'case', "ignorecase"), [1,5]) -%!test -%! assert (regexp ("caseCaSe", '(?-i)case'), 1); -%! assert (regexp ("caseCaSe", '(?i)case'), [1, 5]); - -%!assert (regexp ("abc\nabc", 'c$'), 7) -%!assert (regexp ("abc\nabc", 'c$', "stringanchors"), 7) -%!test -%! assert (regexp ("abc\nabc", '(?-m)c$'), 7); -%! assert (regexp ("abc\nabc", 'c$',"lineanchors"), [3, 7]); -%! assert (regexp ("abc\nabc", '(?m)c$'), [3,7]); - -%!assert (regexp ("this word", 's w'), 4) -%!assert (regexp ("this word", 's w', 'literalspacing'), 4) -%!test -%! assert (regexp ("this word", '(?-x)s w', 'literalspacing'), 4); -%! assert (regexp ("this word", 's w', 'freespacing'), zeros (1,0)); -%! assert (regexp ("this word", '(?x)s w'), zeros (1,0)); - -%!test -%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '[VOCT]*', 'noemptymatch'); -%! assert (s, [1 5]); -%! assert (e, [3 5]); -%! assert (te, { zeros(0,2), zeros(0,2) }); -%! assert (m, { "OCT", "V" }); -%! assert (t, { cell(1,0), cell(1,0) }); -%! assert (isempty (fieldnames (nm))); -%! assert (sp, { "", "A", "E" }); - -%!test -%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '([VOCT]*)', 'noemptymatch'); -%! assert (s, [1 5]); -%! assert (e, [3 5]); -%! assert (te, { [1 3], [5 5] }); -%! assert (m, { "OCT", "V" }); -%! assert (t, { {"OCT"}, {"V"} }); -%! assert (isempty (fieldnames (nm))); -%! assert (sp, { "", "A", "E" }); - -%!test -%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '[VOCT]*', 'emptymatch'); -%! assert (s, [1 4 5 6 7]); -%! assert (e, [3 3 5 5 6]); -%! assert (te, repmat ({zeros(0,2)}, [1, 5])); -%! assert (m, { "OCT", "", "V", "", "" }); -%! assert (t, repmat({cell(1,0)}, [1, 5])); -%! assert (isempty (fieldnames (nm))); -%! assert (sp, { "", "", "A", "", "E", "" }); - -%!test -%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '([VOCT]*)', 'emptymatch'); -%! assert (s, [1 4 5 6 7]); -%! assert (e, [3 3 5 5 6]); -%! assert (te, { [1 3], [4 3], [5 5], [6 5], [7 6] }); -%! assert (m, { "OCT", "", "V", "", "" }); -%! assert (t, { {"OCT"}, {""}, {"V"}, {""}, {""} }); -%! assert (isempty (fieldnames (nm))); -%! assert (sp, { "", "", "A", "", "E", "" }); - -%!error regexp ('string', 'tri', 'BadArg') -%!error regexp ('string') - -%!assert (regexp ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, '-'), {6;[1,5,9];zeros(1,0)}) -%!assert (regexp ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, {'-';'f';'q'}), {6;[3,7];[1,9]}) -%!assert (regexp ('Strings', {'t','s'}), {2, 7}) - -## Test case for lookaround operators -%!test -%! assert (regexp ('Iraq', 'q(?!u)'), 4); -%! assert (regexp ('quit', 'q(?!u)'), zeros (1, 0)); -%! assert (regexp ('quit', 'q(?=u)' , 'match'), {'q'}); -%! assert (regexp ("quit", 'q(?=u+)', 'match'), {'q'}); -%! assert (regexp ("qit", 'q(?=u+)', 'match'), cell (1, 0)); -%! assert (regexp ("qit", 'q(?=u*)', 'match'), {'q'}); -%! assert (regexp ('thingamabob', '(?<=a)b'), 9); - -## Tests for split option. -%!shared str -%! str = "foo bar foo"; -%!test -%! [a, b] = regexp (str, "f..", "match", "split"); -%! assert (a, {"foo", "foo"}); -%! assert (b, {"", " bar ", ""}); -%!test -%! [a, b] = regexp (str, "f..", "match", "split", "once"); -%! assert (a, "foo"); -%! assert (b, {"", " bar foo"}); -%!test -%! [a, b] = regexp (str, "fx.", "match", "split"); -%! assert (a, cell (1, 0)); -%! assert (b, {"foo bar foo"}); -%!test -%! [a, b] = regexp (str, "fx.", "match", "split", "once"); -%! assert (a, "");; -%! assert (b, "foo bar foo"); - -%!shared str -%! str = "foo bar"; -%!test -%! [a, b] = regexp (str, "f..", "match", "split"); -%! assert (a, {"foo"}); -%! assert (b, {"", " bar"}); -%!test -%! [a, b] = regexp (str, "b..", "match", "split"); -%! assert (a, {"bar"}); -%! assert (b, {"foo ", ""}); -%!test -%! [a, b] = regexp (str, "x", "match", "split"); -%! assert (a, cell (1, 0)); -%! assert (b, {"foo bar"}); -%!test -%! [a, b] = regexp (str, "[o]+", "match", "split"); -%! assert (a, {"oo"}); -%! assert (b, {"f", " bar"}); - -%!assert (regexp ("\n", '\n'), 1); -%!assert (regexp ("\n", "\n"), 1); -*/ - -DEFUN_DLD (regexpi, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{s}, @var{e}, @var{te}, @var{m}, @var{t}, @var{nm}, @var{sp}] =} regexpi (@var{str}, @var{pat})\n\ -@deftypefnx {Loadable Function} {[@dots{}] =} regexpi (@var{str}, @var{pat}, \"@var{opt1}\", @dots{})\n\ -\n\ -Case insensitive regular expression string matching. Search for @var{pat} in\n\ -@var{str} and return the positions and substrings of any matches, or empty\n\ -values if there are none. @xref{doc-regexp,,regexp}, for details on the\n\ -syntax of the search pattern.\n\ -@seealso{regexp}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin < 2) - print_usage (); - else if (args(0).is_cell () || args(1).is_cell ()) - retval = octcellregexp (args, (nargout > 0 ? nargout : 1), "regexpi", true); - else - retval = octregexp (args, nargout, "regexpi", true); - - return retval; -} - -/* -## segfault test -%!assert (regexpi ("abcde", "."), [1,2,3,4,5]) - -## Check that anchoring of pattern works correctly -%!assert (regexpi ('abcabc', '^ABC'), 1) -%!assert (regexpi ('abcabc', 'ABC$'), 4) -%!assert (regexpi ('abcabc', '^ABC$'), zeros (1,0)) - -%!test -%! [s, e, te, m, t] = regexpi (' No Match ', 'f(.*)uck'); -%! assert (s, zeros (1,0)); -%! assert (e, zeros (1,0)); -%! assert (te, cell (1,0)); -%! assert (m, cell (1,0)); -%! assert (t, cell (1,0)); - -%!test -%! [s, e, te, m, t] = regexpi (' FiRetrUck ', 'f(.*)uck'); -%! assert (s, 2); -%! assert (e, 10); -%! assert (te{1}, [3, 7]); -%! assert (m{1}, 'FiRetrUck'); -%! assert (t{1}{1}, 'iRetr'); - -%!test -%! [s, e, te, m, t] = regexpi (' firetruck ', 'f(.*)uck'); -%! assert (s, 2); -%! assert (e, 10); -%! assert (te{1}, [3, 7]); -%! assert (m{1}, 'firetruck'); -%! assert (t{1}{1}, 'iretr'); - -%!test -%! [s, e, te, m, t] = regexpi ('ShoRt Test String', '\w*r\w*'); -%! assert (s, [1, 12]); -%! assert (e, [5, 17]); -%! assert (size (te), [1, 2]); -%! assert (isempty (te{1})); -%! assert (isempty (te{2})); -%! assert (m{1}, 'ShoRt'); -%! assert (m{2}, 'String'); -%! assert (size (t), [1, 2]); -%! assert (isempty (t{1})); -%! assert (isempty (t{2})); - -%!test -%! [s, e, te, m, t] = regexpi ('ShoRt Test String', '\w*r\w*', 'once'); -%! assert (s, 1); -%! assert (e, 5); -%! assert (isempty (te)); -%! assert (m, 'ShoRt'); -%! assert (isempty (t)); - -%!test -%! [m, te, e, s, t] = regexpi ('ShoRt Test String', '\w*r\w*', 'once', 'match', 'tokenExtents', 'end', 'start', 'tokens'); -%! assert (s, 1); -%! assert (e, 5); -%! assert (isempty (te)); -%! assert (m, 'ShoRt'); -%! assert (isempty (t)); - -%!test -%! [s, e, te, m, t, nm] = regexpi ('ShoRt Test String', '(?<word1>\w*t)\s*(?<word2>\w*t)'); -%! assert (s, 1); -%! assert (e, 10); -%! assert (size (te), [1, 1]); -%! assert (te{1}, [1,5; 7,10]); -%! assert (m{1}, 'ShoRt Test'); -%! assert (size (t), [1, 1]); -%! assert (t{1}{1}, 'ShoRt'); -%! assert (t{1}{2}, 'Test'); -%! assert (size (nm), [1, 1]); -%! assert (! isempty (fieldnames (nm))); -%! assert (sort (fieldnames (nm)), {'word1';'word2'}); -%! assert (nm.word1, 'ShoRt'); -%! assert (nm.word2, 'Test'); - -%!test -%! [nm, m, te, e, s, t] = regexpi ('ShoRt Test String', '(?<word1>\w*t)\s*(?<word2>\w*t)', 'names', 'match', 'tokenExtents', 'end', 'start', 'tokens'); -%! assert (s, 1); -%! assert (e, 10); -%! assert (size (te), [1, 1]); -%! assert (te{1}, [1,5; 7,10]); -%! assert (m{1}, 'ShoRt Test'); -%! assert (size (t), [1, 1]); -%! assert (t{1}{1}, 'ShoRt'); -%! assert (t{1}{2}, 'Test'); -%! assert (size (nm), [1, 1]); -%! assert (!isempty (fieldnames (nm))); -%! assert (sort (fieldnames (nm)), {'word1';'word2'}); -%! assert (nm.word1, 'ShoRt'); -%! assert (nm.word2, 'Test'); - -%!assert (regexpi ("abc\nabc", '.'), [1:7]) -%!assert (regexpi ("abc\nabc", '.', 'dotall'), [1:7]) -%!test -%! assert (regexpi ("abc\nabc", '(?s).'), [1:7]); -%! assert (regexpi ("abc\nabc", '.', 'dotexceptnewline'), [1,2,3,5,6,7]); -%! assert (regexpi ("abc\nabc", '(?-s).'), [1,2,3,5,6,7]); - -%!assert (regexpi ("caseCaSe", 'case'), [1, 5]) -%!assert (regexpi ("caseCaSe", 'case', "matchcase"), 1) -%!assert (regexpi ("caseCaSe", 'case', "ignorecase"), [1, 5]) -%!test -%! assert (regexpi ("caseCaSe", '(?-i)case'), 1); -%! assert (regexpi ("caseCaSe", '(?i)case'), [1, 5]); - -%!assert (regexpi ("abc\nabc", 'C$'), 7) -%!assert (regexpi ("abc\nabc", 'C$', "stringanchors"), 7) -%!test -%! assert (regexpi ("abc\nabc", '(?-m)C$'), 7); -%! assert (regexpi ("abc\nabc", 'C$', "lineanchors"), [3, 7]); -%! assert (regexpi ("abc\nabc", '(?m)C$'), [3, 7]); - -%!assert (regexpi ("this word", 'S w'), 4) -%!assert (regexpi ("this word", 'S w', 'literalspacing'), 4) -%!test -%! assert (regexpi ("this word", '(?-x)S w', 'literalspacing'), 4); -%! assert (regexpi ("this word", 'S w', 'freespacing'), zeros (1,0)); -%! assert (regexpi ("this word", '(?x)S w'), zeros (1,0)); - -%!error regexpi ('string', 'tri', 'BadArg') -%!error regexpi ('string') - -%!assert (regexpi ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, '-'), {6;[1,5,9];zeros(1, 0)}) -%!assert (regexpi ({'asdfg-dfd', '-dfd-dfd-', 'qasfdfdaq'}, '-'), {6, [1,5,9], zeros(1,0)}) -%!assert (regexpi ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, {'-';'f';'q'}), {6;[3,7];[1,9]}) -%!assert (regexpi ('Strings', {'t', 's'}), {2, [1, 7]}) - -%!assert (regexpi ("\n", '\n'), 1); -%!assert (regexpi ("\n", "\n"), 1); -*/ - -static octave_value -octregexprep (const octave_value_list &args, const std::string &who) -{ - octave_value retval; - - int nargin = args.length (); - - // Make sure we have string, pattern, replacement - const std::string buffer = args(0).string_value (); - if (error_state) - return retval; - - std::string pattern = args(1).string_value (); - if (error_state) - return retval; - // Matlab compatibility. - if (args(1).is_sq_string ()) - pattern = do_regexp_string_escapes (pattern); - - std::string replacement = args(2).string_value (); - if (error_state) - return retval; - // Matlab compatibility. - if (args(2).is_sq_string ()) - replacement = do_regexp_string_escapes (replacement); - - // Pack options excluding 'tokenize' and various output - // reordering strings into regexp arg list - octave_value_list regexpargs (nargin-3, octave_value ()); - - int len = 0; - for (int i = 3; i < nargin; i++) - { - const std::string opt = args(i).string_value (); - if (opt != "tokenize" && opt != "start" && opt != "end" - && opt != "tokenextents" && opt != "match" && opt != "tokens" - && opt != "names" && opt != "split" && opt != "warnings") - { - regexpargs(len++) = args(i); - } - } - regexpargs.resize (len); - - regexp::opts options; - bool extra_args = false; - parse_options (options, regexpargs, who, 0, extra_args); - if (error_state) - return retval; - - return regexp_replace (pattern, buffer, replacement, options, who); -} - -DEFUN_DLD (regexprep, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{outstr} =} regexprep (@var{string}, @var{pat}, @var{repstr})\n\ -@deftypefnx {Loadable Function} {@var{outstr} =} regexprep (@var{string}, @var{pat}, @var{repstr}, \"@var{opt1}\", @dots{})\n\ -Replace occurrences of pattern @var{pat} in @var{string} with @var{repstr}.\n\ -\n\ -The pattern is a regular expression as documented for @code{regexp}.\n\ -@xref{doc-regexp,,regexp}.\n\ -\n\ -The replacement string may contain @code{$i}, which substitutes\n\ -for the ith set of parentheses in the match string. For example,\n\ -\n\ -@example\n\ -regexprep (\"Bill Dunn\", '(\\w+) (\\w+)', '$2, $1')\n\ -@end example\n\ -\n\ -@noindent\n\ -returns \"Dunn, Bill\"\n\ -\n\ -Options in addition to those of @code{regexp} are\n\ -\n\ -@table @samp\n\ -\n\ -@item once\n\ -Replace only the first occurrence of @var{pat} in the result.\n\ -\n\ -@item warnings\n\ -This option is present for compatibility but is ignored.\n\ -\n\ -@end table\n\ -@seealso{regexp, regexpi, strrep}\n\ -@end deftypefn") -{ - octave_value_list retval; - int nargin = args.length (); - - if (nargin < 3) - { - print_usage (); - return retval; - } - - if (args(0).is_cell () || args(1).is_cell () || args(2).is_cell ()) - { - Cell str; - Cell pat; - Cell rep; - dim_vector dv0; - dim_vector dv1 (1, 1); - - if (args(0).is_cell ()) - str = args(0).cell_value (); - else - str = Cell (args(0)); - - if (args(1).is_cell ()) - pat = args(1).cell_value (); - else - pat = Cell (args(1)); - - if (args(2).is_cell ()) - rep = args(2).cell_value (); - else - rep = Cell (args(2)); - - dv0 = str.dims (); - if (pat.numel () != 1) - { - dv1 = pat.dims (); - if (rep.numel () != 1 && dv1 != rep.dims ()) - error ("regexprep: inconsistent cell array dimensions"); - } - else if (rep.numel () != 1) - dv1 = rep.dims (); - - if (!error_state) - { - Cell ret (dv0); - octave_value_list new_args = args; - - for (octave_idx_type i = 0; i < dv0.numel (); i++) - { - new_args(0) = str(i); - if (pat.numel () == 1) - new_args(1) = pat(0); - if (rep.numel () == 1) - new_args(2) = rep(0); - - for (octave_idx_type j = 0; j < dv1.numel (); j++) - { - if (pat.numel () != 1) - new_args(1) = pat(j); - if (rep.numel () != 1) - new_args(2) = rep(j); - new_args(0) = octregexprep (new_args, "regexprep"); - - if (error_state) - break; - } - - if (error_state) - break; - - ret(i) = new_args(0); - } - - if (!error_state) - retval = args(0).is_cell () - ? octave_value (ret) : octave_value (ret(0)); - } - } - else - retval = octregexprep (args, "regexprep"); - - return retval; -} - -/* -%!test # Replace with empty -%! xml = '<!-- This is some XML --> <tag v="hello">some stuff<!-- sample tag--></tag>'; -%! t = regexprep (xml, '<[!?][^>]*>', ''); -%! assert (t, ' <tag v="hello">some stuff</tag>'); - -%!test # Replace with non-empty -%! xml = '<!-- This is some XML --> <tag v="hello">some stuff<!-- sample tag--></tag>'; -%! t = regexprep (xml, '<[!?][^>]*>', '?'); -%! assert (t, '? <tag v="hello">some stuff?</tag>'); - -%!test # Check that 'tokenize' is ignored -%! xml = '<!-- This is some XML --> <tag v="hello">some stuff<!-- sample tag--></tag>'; -%! t = regexprep (xml, '<[!?][^>]*>', '', 'tokenize'); -%! assert (t, ' <tag v="hello">some stuff</tag>'); - -## Test capture replacement -%!test -%! data = "Bob Smith\nDavid Hollerith\nSam Jenkins"; -%! result = "Smith, Bob\nHollerith, David\nJenkins, Sam"; -%! t = regexprep (data, '(?m)^(\w+)\s+(\w+)$', '$2, $1'); -%! assert (t, result); - -## Return the original if no match -%!assert (regexprep ('hello', 'world', 'earth'), 'hello') - -## Test emptymatch -%!assert (regexprep ('World', '^', 'Hello '), 'World') -%!assert (regexprep ('World', '^', 'Hello ', 'emptymatch'), 'Hello World') - -## Test a general replacement -%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Za-z0-9_]", "_"), "a_b_c_d_e_f_g") - -## Make sure it works at the beginning and end -%!assert (regexprep ("a[b]c{d}e-f=g", "a", "_"), "_[b]c{d}e-f=g") -%!assert (regexprep ("a[b]c{d}e-f=g", "g", "_"), "a[b]c{d}e-f=_") - -## Options -%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Za-z0-9_]", "_", "once"), "a_b]c{d}e-f=g") -%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Z0-9_]", "_", "ignorecase"), "a_b_c_d_e_f_g") - -## Option combinations -%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Z0-9_]", "_", "once", "ignorecase"), "a_b]c{d}e-f=g") - -## End conditions on replacement -%!assert (regexprep ("abc", "(b)", ".$1"), "a.bc"); -%!assert (regexprep ("abc", "(b)", "$1"), "abc"); -%!assert (regexprep ("abc", "(b)", "$1."), "ab.c"); -%!assert (regexprep ("abc", "(b)", "$1.."), "ab..c"); - -## Test cell array arguments -%!assert (regexprep ("abc", {"b","a"}, "?"), "??c") -%!assert (regexprep ({"abc","cba"}, "b", "?"), {"a?c","c?a"}) -%!assert (regexprep ({"abc","cba"}, {"b","a"}, {"?","!"}), {"!?c","c?!"}) - -# Nasty lookbehind expression -%!assert (regexprep ('x^(-1)+y(-1)+z(-1)=0', '(?<=[a-z]+)\(\-[1-9]*\)', '_minus1'),'x^(-1)+y_minus1+z_minus1=0') - -%!assert (regexprep ("\n", '\n', "X"), "X"); -%!assert (regexprep ("\n", "\n", "X"), "X"); -*/
--- a/src/DLD-FUNCTIONS/schur.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,381 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include "CmplxSCHUR.h" -#include "dbleSCHUR.h" -#include "fCmplxSCHUR.h" -#include "floatSCHUR.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -template <class Matrix> -static octave_value -mark_upper_triangular (const Matrix& a) -{ - octave_value retval = a; - - octave_idx_type n = a.rows (); - assert (a.columns () == n); - - const typename Matrix::element_type zero = typename Matrix::element_type (); - - for (octave_idx_type i = 0; i < n; i++) - if (a(i,i) == zero) - return retval; - - retval.matrix_type (MatrixType::Upper); - - return retval; -} - -DEFUN_DLD (schur, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{S} =} schur (@var{A})\n\ -@deftypefnx {Loadable Function} {@var{S} =} schur (@var{A}, \"real\")\n\ -@deftypefnx {Loadable Function} {@var{S} =} schur (@var{A}, \"complex\")\n\ -@deftypefnx {Loadable Function} {@var{S} =} schur (@var{A}, @var{opt})\n\ -@deftypefnx {Loadable Function} {[@var{U}, @var{S}] =} schur (@var{A}, @dots{})\n\ -@cindex Schur decomposition\n\ -Compute the Schur@tie{}decomposition of @var{A}\n\ -@tex\n\ -$$\n\ - S = U^T A U\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -@code{@var{S} = @var{U}' * @var{A} * @var{U}}\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -where @var{U} is a unitary matrix\n\ -@tex\n\ -($U^T U$ is identity)\n\ -@end tex\n\ -@ifnottex\n\ -(@code{@var{U}'* @var{U}} is identity)\n\ -@end ifnottex\n\ -and @var{S} is upper triangular. The eigenvalues of @var{A} (and @var{S})\n\ -are the diagonal elements of @var{S}. If the matrix @var{A}\n\ -is real, then the real Schur@tie{}decomposition is computed, in which the\n\ -matrix @var{U} is orthogonal and @var{S} is block upper triangular\n\ -with blocks of size at most\n\ -@tex\n\ -$2 \\times 2$\n\ -@end tex\n\ -@ifnottex\n\ -@code{2 x 2}\n\ -@end ifnottex\n\ -along the diagonal. The diagonal elements of @var{S}\n\ -(or the eigenvalues of the\n\ -@tex\n\ -$2 \\times 2$\n\ -@end tex\n\ -@ifnottex\n\ -@code{2 x 2}\n\ -@end ifnottex\n\ -blocks, when appropriate) are the eigenvalues of @var{A} and @var{S}.\n\ -\n\ -The default for real matrices is a real Schur@tie{}decomposition.\n\ -A complex decomposition may be forced by passing the flag \"complex\".\n\ -\n\ -The eigenvalues are optionally ordered along the diagonal according to\n\ -the value of @var{opt}. @code{@var{opt} = \"a\"} indicates that all\n\ -eigenvalues with negative real parts should be moved to the leading\n\ -block of @var{S}\n\ -(used in @code{are}), @code{@var{opt} = \"d\"} indicates that all eigenvalues\n\ -with magnitude less than one should be moved to the leading block of @var{S}\n\ -(used in @code{dare}), and @code{@var{opt} = \"u\"}, the default, indicates\n\ -that no ordering of eigenvalues should occur. The leading @var{k}\n\ -columns of @var{U} always span the @var{A}-invariant\n\ -subspace corresponding to the @var{k} leading eigenvalues of @var{S}.\n\ -\n\ -The Schur@tie{}decomposition is used to compute eigenvalues of a\n\ -square matrix, and has applications in the solution of algebraic\n\ -Riccati equations in control (see @code{are} and @code{dare}).\n\ -@seealso{rsf2csf}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 2 || nargout > 2) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - - std::string ord; - - if (nargin == 2) - { - ord = args(1).string_value (); - - if (error_state) - { - error ("schur: second argument must be a string"); - return retval; - } - } - - bool force_complex = false; - - if (ord == "real") - { - ord = std::string (); - } - else if (ord == "complex") - { - force_complex = true; - ord = std::string (); - } - else - { - char ord_char = ord.empty () ? 'U' : ord[0]; - - if (ord_char != 'U' && ord_char != 'A' && ord_char != 'D' - && ord_char != 'u' && ord_char != 'a' && ord_char != 'd') - { - warning ("schur: incorrect ordered schur argument `%c'", - ord.c_str ()); - return retval; - } - } - - octave_idx_type nr = arg.rows (); - octave_idx_type nc = arg.columns (); - - if (nr != nc) - { - gripe_square_matrix_required ("schur"); - return retval; - } - - if (! arg.is_numeric_type ()) - gripe_wrong_type_arg ("schur", arg); - else if (arg.is_single_type ()) - { - if (! force_complex && arg.is_real_type ()) - { - FloatMatrix tmp = arg.float_matrix_value (); - - if (! error_state) - { - if (nargout == 0 || nargout == 1) - { - FloatSCHUR result (tmp, ord, false); - retval(0) = result.schur_matrix (); - } - else - { - FloatSCHUR result (tmp, ord, true); - retval(1) = result.schur_matrix (); - retval(0) = result.unitary_matrix (); - } - } - } - else - { - FloatComplexMatrix ctmp = arg.float_complex_matrix_value (); - - if (! error_state) - { - - if (nargout == 0 || nargout == 1) - { - FloatComplexSCHUR result (ctmp, ord, false); - retval(0) = mark_upper_triangular (result.schur_matrix ()); - } - else - { - FloatComplexSCHUR result (ctmp, ord, true); - retval(1) = mark_upper_triangular (result.schur_matrix ()); - retval(0) = result.unitary_matrix (); - } - } - } - } - else - { - if (! force_complex && arg.is_real_type ()) - { - Matrix tmp = arg.matrix_value (); - - if (! error_state) - { - if (nargout == 0 || nargout == 1) - { - SCHUR result (tmp, ord, false); - retval(0) = result.schur_matrix (); - } - else - { - SCHUR result (tmp, ord, true); - retval(1) = result.schur_matrix (); - retval(0) = result.unitary_matrix (); - } - } - } - else - { - ComplexMatrix ctmp = arg.complex_matrix_value (); - - if (! error_state) - { - - if (nargout == 0 || nargout == 1) - { - ComplexSCHUR result (ctmp, ord, false); - retval(0) = mark_upper_triangular (result.schur_matrix ()); - } - else - { - ComplexSCHUR result (ctmp, ord, true); - retval(1) = mark_upper_triangular (result.schur_matrix ()); - retval(0) = result.unitary_matrix (); - } - } - } - } - - return retval; -} - -/* -%!test -%! a = [1, 2, 3; 4, 5, 9; 7, 8, 6]; -%! [u, s] = schur (a); -%! assert (u' * a * u, s, sqrt (eps)); - -%!test -%! a = single ([1, 2, 3; 4, 5, 9; 7, 8, 6]); -%! [u, s] = schur (a); -%! assert (u' * a * u, s, sqrt (eps ("single"))); - -%!test -%! fail ("schur ([1, 2; 3, 4], 2)", "warning"); - -%!error schur () -%!error <argument must be a square matrix> schur ([1, 2, 3; 4, 5, 6]) -*/ - -DEFUN_DLD (rsf2csf, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Function File} {[@var{U}, @var{T}] =} rsf2csf (@var{UR}, @var{TR})\n\ -Convert a real, upper quasi-triangular Schur@tie{}form @var{TR} to a complex,\n\ -upper triangular Schur@tie{}form @var{T}.\n\ -\n\ -Note that the following relations hold:\n\ -\n\ -@tex\n\ -$UR \\cdot TR \\cdot {UR}^T = U T U^{\\dagger}$ and\n\ -$U^{\\dagger} U$ is the identity matrix I.\n\ -@end tex\n\ -@ifnottex\n\ -@xcode{@var{UR} * @var{TR} * @var{UR}' = @var{U} * @var{T} * @var{U}'} and\n\ -@code{@var{U}' * @var{U}} is the identity matrix I.\n\ -@end ifnottex\n\ -\n\ -Note also that @var{U} and @var{T} are not unique.\n\ -@seealso{schur}\n\ -@end deftypefn") -{ - octave_value_list retval; - - if (args.length () == 2 && nargout <= 2) - { - if (! args(0).is_numeric_type ()) - gripe_wrong_type_arg ("rsf2csf", args(0)); - else if (! args(1).is_numeric_type ()) - gripe_wrong_type_arg ("rsf2csf", args(1)); - else if (args(0).is_complex_type () || args(1).is_complex_type ()) - error ("rsf2csf: UR and TR must be real matrices"); - else - { - - if (args(0).is_single_type () || args(1).is_single_type ()) - { - FloatMatrix u = args(0).float_matrix_value (); - FloatMatrix t = args(1).float_matrix_value (); - if (! error_state) - { - FloatComplexSCHUR cs (FloatSCHUR (t, u)); - - retval(1) = cs.schur_matrix (); - retval(0) = cs.unitary_matrix (); - } - } - else - { - Matrix u = args(0).matrix_value (); - Matrix t = args(1).matrix_value (); - if (! error_state) - { - ComplexSCHUR cs (SCHUR (t, u)); - - retval(1) = cs.schur_matrix (); - retval(0) = cs.unitary_matrix (); - } - } - } - } - else - print_usage (); - - return retval; -} - -/* -%!test -%! A = [1, 1, 1, 2; 1, 2, 1, 1; 1, 1, 3, 1; -2, 1, 1, 1]; -%! [u, t] = schur (A); -%! [U, T] = rsf2csf (u, t); -%! assert (norm (u * t * u' - U * T * U'), 0, 1e-12); -%! assert (norm (A - U * T * U'), 0, 1e-12); - -%!test -%! A = rand (10); -%! [u, t] = schur (A); -%! [U, T] = rsf2csf (u, t); -%! assert (norm (tril (T, -1)), 0); -%! assert (norm (U * U'), 1, 1e-14); - -%!test -%! A = [0, 1;-1, 0]; -%! [u, t] = schur (A); -%! [U, T] = rsf2csf (u,t); -%! assert (U * T * U', A, 1e-14); -*/
--- a/src/DLD-FUNCTIONS/spparms.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,208 +0,0 @@ -/* - -Copyright (C) 2004-2012 David Bateman -Copyright (C) 1998-2004 Andy Adler - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "ov.h" -#include "pager.h" -#include "error.h" -#include "gripes.h" - -#include "oct-spparms.h" - -DEFUN_DLD (spparms, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} { } spparms ()\n\ -@deftypefnx {Loadable Function} {@var{vals} =} spparms ()\n\ -@deftypefnx {Loadable Function} {[@var{keys}, @var{vals}] =} spparms ()\n\ -@deftypefnx {Loadable Function} {@var{val} =} spparms (@var{key})\n\ -@deftypefnx {Loadable Function} { } spparms (@var{vals})\n\ -@deftypefnx {Loadable Function} { } spparms (\"defaults\")\n\ -@deftypefnx {Loadable Function} { } spparms (\"tight\")\n\ -@deftypefnx {Loadable Function} { } spparms (@var{key}, @var{val})\n\ -Query or set the parameters used by the sparse solvers and factorization\n\ -functions. The first four calls above get information about the current\n\ -settings, while the others change the current settings. The parameters are\n\ -stored as pairs of keys and values, where the values are all floats and the\n\ -keys are one of the following strings:\n\ -\n\ -@table @samp\n\ -@item spumoni\n\ -Printing level of debugging information of the solvers (default 0)\n\ -\n\ -@item ths_rel\n\ -Included for compatibility. Not used. (default 1)\n\ -\n\ -@item ths_abs\n\ -Included for compatibility. Not used. (default 1)\n\ -\n\ -@item exact_d\n\ -Included for compatibility. Not used. (default 0)\n\ -\n\ -@item supernd\n\ -Included for compatibility. Not used. (default 3)\n\ -\n\ -@item rreduce\n\ -Included for compatibility. Not used. (default 3)\n\ -\n\ -@item wh_frac\n\ -Included for compatibility. Not used. (default 0.5)\n\ -\n\ -@item autommd\n\ -Flag whether the LU/QR and the '\\' and '/' operators will automatically\n\ -use the sparsity preserving mmd functions (default 1)\n\ -\n\ -@item autoamd\n\ -Flag whether the LU and the '\\' and '/' operators will automatically\n\ -use the sparsity preserving amd functions (default 1)\n\ -\n\ -@item piv_tol\n\ -The pivot tolerance of the @sc{umfpack} solvers (default 0.1)\n\ -\n\ -@item sym_tol\n\ -The pivot tolerance of the @sc{umfpack} symmetric solvers (default 0.001)\n\ -\n\ -@item bandden\n\ -The density of non-zero elements in a banded matrix before it is treated\n\ -by the @sc{lapack} banded solvers (default 0.5)\n\ -\n\ -@item umfpack\n\ -Flag whether the @sc{umfpack} or mmd solvers are used for the LU, '\\' and\n\ -'/' operations (default 1)\n\ -@end table\n\ -\n\ -The value of individual keys can be set with\n\ -@code{spparms (@var{key}, @var{val})}.\n\ -The default values can be restored with the special keyword\n\ -\"defaults\". The special keyword \"tight\" can be used to set the mmd\n\ -solvers to attempt a sparser solution at the potential cost of longer\n\ -running time.\n\ -@end deftypefn") -{ - octave_value_list retval; - int nargin = args.length (); - - if (nargin == 0) - { - if (nargout == 0) - octave_sparse_params::print_info (octave_stdout, ""); - else if (nargout == 1) - retval(0) = octave_sparse_params::get_vals (); - else if (nargout == 2) - { - retval(1) = octave_sparse_params::get_vals (); - retval(0) = octave_sparse_params::get_keys (); - } - else - error ("spparms: too many output arguments"); - } - else if (nargin == 1) - { - if (args(0).is_string ()) - { - std::string str = args(0).string_value (); - int len = str.length (); - for (int i = 0; i < len; i++) - str [i] = tolower (str [i]); - - if (str == "defaults") - octave_sparse_params::defaults (); - else if (str == "tight") - octave_sparse_params::tight (); - else - { - double val = octave_sparse_params::get_key (str); - if (xisnan (val)) - error ("spparms: KEY not recognized"); - else - retval(0) = val; - } - } - else - { - NDArray vals = args(0).array_value (); - - if (error_state) - error ("spparms: input must be a string or a vector"); - else if (vals.numel () > OCTAVE_SPARSE_CONTROLS_SIZE) - error ("spparms: too many elements in vector VALS"); - else - octave_sparse_params::set_vals (vals); - } - } - else if (nargin == 2) - { - if (args(0).is_string ()) - { - std::string str = args(0).string_value (); - - double val = args(1).double_value (); - - if (error_state) - error ("spparms: second argument must be a real scalar"); - else if (str == "umfpack") - warning ("spparms: request to disable umfpack solvers ignored"); - else if (!octave_sparse_params::set_key (str, val)) - error ("spparms: KEY not found"); - } - else - error ("spparms: first argument must be a string"); - } - else - error ("spparms: too many input arguments"); - - return retval; -} - -/* -%!test -%! old_vals = spparms (); # save state -%! spparms ("defaults"); -%! vals = spparms (); -%! assert (vals, [0 1 1 0 3 3 0.5 1.0 1.0 0.1 0.5 1.0 0.001]'); -%! [keys, vals] = spparms (); -%! assert (rows (keys), 13); -%! assert (keys(2,:), "ths_rel"); -%! assert (vals, [0 1 1 0 3 3 0.5 1.0 1.0 0.1 0.5 1.0 0.001]'); -%! spparms ([3 2 1]); -%! assert (spparms ()(1:3), [3, 2, 1]'); -%! assert (spparms ("ths_rel"), 2); -%! spparms ("exact_d", 5); -%! assert (spparms ("exact_d"), 5); -%! spparms (old_vals); # restore state - -%% Test input validation -%!error <too many input arguments> spparms (1, 2, 3) -%!error <too many output arguments> [x, y, z] = spparms () -%!error <KEY not recognized> spparms ("UNKNOWN_KEY") -%!#error <input must be a string> spparms ({1, 2, 3}) -%!error spparms ({1, 2, 3}) -%!error <too many elements in vector VALS> spparms (ones (14, 1)) -%!error <first argument must be a string> spparms (1, 1) -%!#error <second argument must be a real scalar> spparms ("ths_rel", "hello") -%!error spparms ("ths_rel", "hello") -%!error <KEY not found> spparms ("UNKNOWN_KEY", 1) -*/
--- a/src/DLD-FUNCTIONS/sqrtm.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,276 +0,0 @@ -/* - -Copyright (C) 2001-2012 Ross Lippert and Paul Kienzle -Copyright (C) 2010 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <float.h> - -#include "CmplxSCHUR.h" -#include "fCmplxSCHUR.h" -#include "lo-ieee.h" -#include "lo-mappers.h" -#include "oct-norm.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "utils.h" -#include "xnorm.h" - -template <class Matrix> -static void -sqrtm_utri_inplace (Matrix& T) -{ - typedef typename Matrix::element_type element_type; - - const element_type zero = element_type (); - - bool singular = false; - - // The following code is equivalent to this triple loop: - // - // n = rows (T); - // for j = 1:n - // T(j,j) = sqrt (T(j,j)); - // for i = j-1:-1:1 - // T(i,j) /= (T(i,i) + T(j,j)); - // k = 1:i-1; - // T(k,j) -= T(k,i) * T(i,j); - // endfor - // endfor - // - // this is an in-place, cache-aligned variant of the code - // given in Higham's paper. - - const octave_idx_type n = T.rows (); - element_type *Tp = T.fortran_vec (); - for (octave_idx_type j = 0; j < n; j++) - { - element_type *colj = Tp + n*j; - if (colj[j] != zero) - colj[j] = sqrt (colj[j]); - else - singular = true; - - for (octave_idx_type i = j-1; i >= 0; i--) - { - const element_type *coli = Tp + n*i; - const element_type colji = colj[i] /= (coli[i] + colj[j]); - for (octave_idx_type k = 0; k < i; k++) - colj[k] -= coli[k] * colji; - } - } - - if (singular) - warning_with_id ("Octave:sqrtm:SingularMatrix", - "sqrtm: matrix is singular, may not have a square root"); -} - -template <class Matrix, class ComplexMatrix, class ComplexSCHUR> -static octave_value -do_sqrtm (const octave_value& arg) -{ - - octave_value retval; - - MatrixType mt = arg.matrix_type (); - - bool iscomplex = arg.is_complex_type (); - - typedef typename Matrix::element_type real_type; - - real_type cutoff = 0, one = 1; - real_type eps = std::numeric_limits<real_type>::epsilon (); - - if (! iscomplex) - { - Matrix x = octave_value_extract<Matrix> (arg); - - if (mt.is_unknown ()) // if type is not known, compute it now. - arg.matrix_type (mt = MatrixType (x)); - - switch (mt.type ()) - { - case MatrixType::Upper: - case MatrixType::Diagonal: - if (! x.diag ().any_element_is_negative ()) - { - // Do it in real arithmetic. - sqrtm_utri_inplace (x); - retval = x; - retval.matrix_type (mt); - } - else - iscomplex = true; - break; - - case MatrixType::Lower: - if (! x.diag ().any_element_is_negative ()) - { - x = x.transpose (); - sqrtm_utri_inplace (x); - retval = x.transpose (); - retval.matrix_type (mt); - } - else - iscomplex = true; - break; - - default: - iscomplex = true; - break; - } - - if (iscomplex) - cutoff = 10 * x.rows () * eps * xnorm (x, one); - } - - if (iscomplex) - { - ComplexMatrix x = octave_value_extract<ComplexMatrix> (arg); - - if (mt.is_unknown ()) // if type is not known, compute it now. - arg.matrix_type (mt = MatrixType (x)); - - switch (mt.type ()) - { - case MatrixType::Upper: - case MatrixType::Diagonal: - sqrtm_utri_inplace (x); - retval = x; - retval.matrix_type (mt); - break; - - case MatrixType::Lower: - x = x.transpose (); - sqrtm_utri_inplace (x); - retval = x.transpose (); - retval.matrix_type (mt); - break; - - default: - { - ComplexMatrix u; - - do - { - ComplexSCHUR schur (x, std::string (), true); - x = schur.schur_matrix (); - u = schur.unitary_matrix (); - } - while (0); // schur no longer needed. - - sqrtm_utri_inplace (x); - - x = u * x; // original x no longer needed. - ComplexMatrix res = xgemm (x, u, blas_no_trans, blas_conj_trans); - - if (cutoff > 0 && xnorm (imag (res), one) <= cutoff) - retval = real (res); - else - retval = res; - } - break; - } - } - - return retval; -} - -DEFUN_DLD (sqrtm, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{s} =} sqrtm (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{s}, @var{error_estimate}] =} sqrtm (@var{A})\n\ -Compute the matrix square root of the square matrix @var{A}.\n\ -\n\ -Ref: N.J. Higham. @cite{A New sqrtm for @sc{matlab}}. Numerical\n\ -Analysis Report No. 336, Manchester @nospell{Centre} for Computational\n\ -Mathematics, Manchester, England, January 1999.\n\ -@seealso{expm, logm}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin != 1) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - - octave_idx_type n = arg.rows (); - octave_idx_type nc = arg.columns (); - - if (n != nc || arg.ndims () > 2) - { - gripe_square_matrix_required ("sqrtm"); - return retval; - } - - if (nargout > 1) - { - retval.resize (1, 2); - retval(2) = -1.0; - } - - if (arg.is_diag_matrix ()) - // sqrtm of a diagonal matrix is just sqrt. - retval(0) = arg.sqrt (); - else if (arg.is_single_type ()) - retval(0) = do_sqrtm<FloatMatrix, FloatComplexMatrix, FloatComplexSCHUR> (arg); - else if (arg.is_numeric_type ()) - retval(0) = do_sqrtm<Matrix, ComplexMatrix, ComplexSCHUR> (arg); - - if (nargout > 1 && ! error_state) - { - // This corresponds to generic code - // - // norm (s*s - x, "fro") / norm (x, "fro"); - - octave_value s = retval(0); - retval(1) = xfrobnorm (s*s - arg) / xfrobnorm (arg); - } - - return retval; -} - -/* -%!assert (sqrtm (2*ones (2)), ones (2), 3*eps) - -## The following two tests are from the reference in the docstring above. -%!test -%! x = [0 1; 0 0]; -%! assert (any (isnan (sqrtm (x))(:))); - -%!test -%! x = eye (4); x(2,2) = x(3,3) = 2^-26; x(1,4) = 1; -%! z = eye (4); z(2,2) = z(3,3) = 2^-13; z(1,4) = 0.5; -%! [y, err] = sqrtm (x); -%! assert (y, z); -%! assert (err, 0); ## Yes, this one has to hold exactly -*/
--- a/src/DLD-FUNCTIONS/str2double.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,406 +0,0 @@ -/* - -Copyright (C) 2010-2012 Jaroslav Hajek -Copyright (C) 2010 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> -#include <cctype> -#include <sstream> -#include <algorithm> - -#include "lo-ieee.h" - -#include "Cell.h" -#include "ov.h" -#include "defun-dld.h" -#include "gripes.h" -#include "utils.h" - -static inline bool -is_imag_unit (int c) -{ return c == 'i' || c == 'j'; } - -static std::istringstream& -single_num (std::istringstream& is, double& num) -{ - char c = is.peek (); - - // Skip spaces. - while (isspace (c)) - { - is.get (); - c = is.peek (); - } - - if (std::toupper (c) == 'I') - { - // It's infinity. - is.get (); - char c1 = is.get (), c2 = is.get (); - if (std::tolower (c1) == 'n' && std::tolower (c2) == 'f') - { - num = octave_Inf; - is.peek (); // May set EOF bit. - } - else - is.setstate (std::ios::failbit); // indicate that read has failed. - } - else if (c == 'N') - { - // It's NA or NaN - is.get (); - char c1 = is.get (); - if (c1 == 'A') - { - num = octave_NA; - is.peek (); // May set EOF bit. - } - else - { - char c2 = is.get (); - if (c1 == 'a' && c2 == 'N') - { - num = octave_NaN; - is.peek (); // May set EOF bit. - } - else - is.setstate (std::ios::failbit); // indicate that read has failed. - } - } - else - is >> num; - - return is; -} - -static std::istringstream& -extract_num (std::istringstream& is, double& num, bool& imag, bool& have_sign) -{ - have_sign = imag = false; - - char c = is.peek (); - - // Skip leading spaces. - while (isspace (c)) - { - is.get (); - c = is.peek (); - } - - bool negative = false; - - // Accept leading sign. - if (c == '+' || c == '-') - { - negative = c == '-'; - is.get (); - c = is.peek (); - have_sign = true; - } - - // Skip spaces after sign. - while (isspace (c)) - { - is.get (); - c = is.peek (); - } - - // Imaginary number (i*num or just i), or maybe 'inf'. - if (c == 'i') - { - // possible infinity. - is.get (); - c = is.peek (); - - if (is.eof ()) - { - // just 'i' and string is finished. Return immediately. - imag = true; - num = 1.0; - if (negative) - num = -num; - return is; - } - else - { - if (std::tolower (c) != 'n') - imag = true; - is.unget (); - } - } - else if (c == 'j') - imag = true; - - // It's i*num or just i - if (imag) - { - is.get (); - c = is.peek (); - // Skip spaces after imaginary unit. - while (isspace (c)) - { - is.get (); - c = is.peek (); - } - - if (c == '*') - { - // Multiplier follows, we extract it as a number. - is.get (); - single_num (is, num); - if (is.good ()) - c = is.peek (); - } - else - num = 1.0; - } - else - { - // It's num, num*i, or numi. - single_num (is, num); - if (is.good ()) - { - c = is.peek (); - - // Skip spaces after number. - while (isspace (c)) - { - is.get (); - c = is.peek (); - } - - if (c == '*') - { - is.get (); - c = is.peek (); - - // Skip spaces after operator. - while (isspace (c)) - { - is.get (); - c = is.peek (); - } - - if (is_imag_unit (c)) - { - imag = true; - is.get (); - c = is.peek (); - } - else - is.setstate (std::ios::failbit); // indicate that read has failed. - } - else if (is_imag_unit (c)) - { - imag = true; - is.get (); - c = is.peek (); - } - } - } - - if (is.good ()) - { - // Skip trailing spaces. - while (isspace (c)) - { - is.get (); - c = is.peek (); - } - } - - if (negative) - num = -num; - - return is; -} - -static inline void -set_component (Complex& c, double num, bool imag) -{ -#if defined (HAVE_CXX_COMPLEX_SETTERS) - if (imag) - c.imag (num); - else - c.real (num); -#elif defined (HAVE_CXX_COMPLEX_REFERENCE_ACCESSORS) - if (imag) - c.imag () = num; - else - c.real () = num; -#else - if (imag) - c = Complex (c.real (), num); - else - c = Complex (num, c.imag ()); -#endif -} - -static Complex -str2double1 (const std::string& str_arg) -{ - Complex val (0.0, 0.0); - - std::string str = str_arg; - - // FIXME -- removing all commas does too much... - std::string::iterator se = str.end (); - se = std::remove (str.begin (), se, ','); - str.erase (se, str.end ()); - std::istringstream is (str); - - double num; - bool i1, i2, s1, s2; - - if (is.eof ()) - val = octave_NaN; - else if (! extract_num (is, num, i1, s1)) - val = octave_NaN; - else - { - set_component (val, num, i1); - - if (! is.eof ()) - { - if (! extract_num (is, num, i2, s2) || i1 == i2 || ! s2) - val = octave_NaN; - else - set_component (val, num, i2); - } - } - - return val; -} - -DEFUN_DLD (str2double, args, , - "-*- texinfo -*-\n\ -@deftypefn {Built-in Function} {} str2double (@var{s})\n\ -Convert a string to a real or complex number.\n\ -\n\ -The string must be in one of the following formats where\n\ -a and b are real numbers and the complex unit is 'i' or 'j':\n\ -\n\ -@itemize\n\ -@item a + bi\n\ -\n\ -@item a + b*i\n\ -\n\ -@item a + i*b\n\ -\n\ -@item bi + a\n\ -\n\ -@item b*i + a\n\ -\n\ -@item i*b + a\n\ -@end itemize\n\ -\n\ -If present, a and/or b are of the form @nospell{[+-]d[,.]d[[eE][+-]d]} where\n\ -the brackets indicate optional arguments and 'd' indicates zero or more\n\ -digits. The special input values @code{Inf}, @code{NaN}, and @code{NA} are\n\ -also accepted.\n\ -\n\ -@var{s} may also be a character matrix, in which case the conversion is\n\ -repeated for each row. Or @var{s} may be a cell array of strings, in which\n\ -case each element is converted and an array of the same dimensions is\n\ -returned.\n\ -\n\ -@code{str2double} returns NaN for elements of @var{s} which cannot be\n\ -converted.\n\ -\n\ -@code{str2double} can replace @code{str2num}, and it avoids the security\n\ -risk of using @code{eval} on unknown data.\n\ -@seealso{str2num}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () != 1) - print_usage (); - else if (args(0).is_string ()) - { - if (args(0).rows () == 1 && args(0).ndims () == 2) - { - retval = str2double1 (args(0).string_value ()); - } - else - { - const string_vector sv = args(0).all_strings (); - if (! error_state) - retval = sv.map<Complex> (str2double1); - } - } - else if (args(0).is_cell ()) - { - const Cell cell = args(0).cell_value (); - - if (! error_state) - { - ComplexNDArray output (cell.dims (), octave_NaN); - for (octave_idx_type i = 0; i < cell.numel (); i++) - { - if (cell(i).is_string ()) - output(i) = str2double1 (cell(i).string_value ()); - } - retval = output; - } - } - else - retval = NDArray (args(0).dims (), octave_NaN); - - - return retval; -} - -/* -%!assert (str2double ("1"), 1) -%!assert (str2double ("-.1e-5"), -1e-6) -%!assert (str2double (char ("1", "2 3", "4i")), [1; NaN; 4i]) -%!assert (str2double ("-.1e-5"), -1e-6) -%!assert (str2double ("1,222.5"), 1222.5) -%!assert (str2double ("i"), i) -%!assert (str2double ("2j"), 2i) -%!assert (str2double ("2 + j"), 2+j) -%!assert (str2double ("i*2 + 3"), 3+2i) -%!assert (str2double (".5*i + 3.5"), 3.5+0.5i) -%!assert (str2double ("1e-3 + i*.25"), 1e-3 + 0.25i) -%!assert (str2double (["2 + j";"1.25e-3";"-05"]), [2+i; 1.25e-3; -5]) -%!assert (str2double ({"2 + j","1.25e-3","-05"}), [2+i, 1.25e-3, -5]) -%!assert (str2double (1), NaN) -%!assert (str2double ("1 2 3 4"), NaN) -%!assert (str2double ("Hello World"), NaN) -%!assert (str2double ("NaN"), NaN) -%!assert (str2double ("NA"), NA) -%!assert (str2double ("Inf"), Inf) -%!assert (str2double ("iNF"), Inf) -%!assert (str2double ("-Inf"), -Inf) -%!assert (str2double ("Inf*i"), complex (0, Inf)) -%!assert (str2double ("iNF*i"), complex (0, Inf)) -%!assert (str2double ("NaN + Inf*i"), complex (NaN, Inf)) -%!assert (str2double ("Inf - Inf*i"), complex (Inf, -Inf)) -%!assert (str2double ("-i*NaN - Inf"), complex (-Inf, -NaN)) -%!assert (str2double ({"abc", "4i"}), [NaN + 0i, 4i]) -%!assert (str2double ({2, "4i"}), [NaN + 0i, 4i]) -%!assert (str2double (zeros (3,1,2)), NaN (3,1,2)) -*/
--- a/src/DLD-FUNCTIONS/strfind.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,415 +0,0 @@ -/* - -Copyright (C) 2009-2012 Jaroslav Hajek -Copyright (C) 2009-2010 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> -#include <climits> -#include <algorithm> -#include <deque> - -#include "Cell.h" -#include "ov.h" -#include "defun-dld.h" -#include "unwind-prot.h" -#include "gripes.h" -#include "utils.h" - -// This allows safe indexing with char. In C++, char may be (and often is) signed! -#define ORD(ch) static_cast<unsigned char>(ch) -#define TABSIZE (UCHAR_MAX + 1) - -// This is the quick search algorithm, as described at -// http://www-igm.univ-mlv.fr/~lecroq/string/node19.html -static void -qs_preprocess (const Array<char>& needle, - octave_idx_type table[TABSIZE]) -{ - const char *x = needle.data (); - octave_idx_type m = needle.numel (); - - for (octave_idx_type i = 0; i < TABSIZE; i++) - table[i] = m + 1; - for (octave_idx_type i = 0; i < m; i++) - table[ORD(x[i])] = m - i; -} - - -static Array<octave_idx_type> -qs_search (const Array<char>& needle, - const Array<char>& haystack, - const octave_idx_type table[TABSIZE], - bool overlaps = true) -{ - const char *x = needle.data (); - octave_idx_type m = needle.numel (); - const char *y = haystack.data (); - octave_idx_type n = haystack.numel (); - - // We'll use deque because it typically has the most favorable properties for - // the operation we need. - std::deque<octave_idx_type> accum; - if (m == 1) - { - // Looking for a single character. - for (octave_idx_type i = 0; i < n; i++) - { - if (y[i] == x[0]) - accum.push_back (i); - } - } - else if (m == 2) - { - // Two characters. - if (overlaps) - { - for (octave_idx_type i = 0; i < n-1; i++) - { - if (y[i] == x[0] && y[i+1] == x[1]) - accum.push_back (i); - } - } - else - { - for (octave_idx_type i = 0; i < n-1; i++) - { - if (y[i] == x[0] && y[i+1] == x[1]) - accum.push_back (i++); - } - } - } - else if (n >= m) - { - // General case. - octave_idx_type j = 0; - - if (overlaps) - { - while (j < n - m) - { - if (std::equal (x, x + m, y + j)) - accum.push_back (j); - j += table[ORD(y[j + m])]; - } - } - else - { - while (j < n - m) - { - if (std::equal (x, x + m, y + j)) - { - accum.push_back (j); - j += m; - } - else - j += table[ORD(y[j + m])]; - } - } - - if (j == n - m && std::equal (x, x + m, y + j)) - accum.push_back (j); - } - - octave_idx_type nmatch = accum.size (); - octave_idx_type one = 1; - Array<octave_idx_type> result (dim_vector (std::min (one, nmatch), nmatch)); - octave_idx_type k = 0; - for (std::deque<octave_idx_type>::const_iterator iter = accum.begin (); - iter != accum.end (); iter++) - { - result.xelem (k++) = *iter; - } - - return result; -} - -DEFUN_DLD (strfind, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{idx} =} strfind (@var{str}, @var{pattern})\n\ -@deftypefnx {Loadable Function} {@var{idx} =} strfind (@var{cellstr}, @var{pattern})\n\ -Search for @var{pattern} in the string @var{str} and return the\n\ -starting index of every such occurrence in the vector @var{idx}.\n\ -If there is no such occurrence, or if @var{pattern} is longer\n\ -than @var{str}, then @var{idx} is the empty array @code{[]}.\n\ -\n\ -If a cell array of strings @var{cellstr} is specified\n\ -then @var{idx} is a cell array of vectors, as specified\n\ -above. Examples:\n\ -\n\ -@example\n\ -@group\n\ -strfind (\"abababa\", \"aba\")\n\ - @result{} [1, 3, 5]\n\ -\n\ -strfind (@{\"abababa\", \"bebebe\", \"ab\"@}, \"aba\")\n\ - @result{}\n\ - @{\n\ - [1,1] =\n\ -\n\ - 1 3 5\n\ -\n\ - [1,2] = [](1x0)\n\ - [1,3] = [](1x0)\n\ - @}\n\ -@end group\n\ -@end example\n\ -@seealso{findstr, strmatch, regexp, regexpi, find}\n\ -@end deftypefn") -{ - octave_value retval; - int nargin = args.length (); - bool overlaps = true; - - if (nargin == 4 && args(2).is_string () && args(3).is_scalar_type ()) - { - std::string opt = args(2).string_value (); - if (opt == "overlaps") - { - overlaps = args(3).bool_value (); - nargin = 2; - } - else - { - error ("strfind: unknown option: %s", opt.c_str ()); - return retval; - } - } - - if (nargin == 2) - { - octave_value argstr = args(0), argpat = args(1); - if (argpat.is_string ()) - { - Array<char> needle = argpat.char_array_value (); - OCTAVE_LOCAL_BUFFER (octave_idx_type, table, TABSIZE); - qs_preprocess (needle, table); - - if (argstr.is_string ()) - retval = octave_value (qs_search (needle, argstr.char_array_value (), - table, overlaps), - true, true); - else if (argstr.is_cell ()) - { - const Cell argsc = argstr.cell_value (); - Cell retc (argsc.dims ()); - octave_idx_type ns = argsc.numel (); - - for (octave_idx_type i = 0; i < ns; i++) - { - octave_value argse = argsc(i); - if (argse.is_string ()) - retc(i) = octave_value (qs_search (needle, argse.char_array_value (), - table, overlaps), - true, true); - else - { - error ("strfind: each element of CELLSTR must be a string"); - break; - } - } - - retval = retc; - } - else - error ("strfind: first argument must be a string or cell array of strings"); - } - else if (argpat.is_cell ()) - retval = do_simple_cellfun (Fstrfind, "strfind", args); - else - error ("strfind: PATTERN must be a string or cell array of strings"); - } - else - print_usage (); - - return retval; -} - -/* -%!assert (strfind ("abababa", "aba"), [1, 3, 5]) -%!assert (strfind ("abababa", "aba", "overlaps", false), [1, 5]) -%!assert (strfind ({"abababa", "bla", "bla"}, "a"), {[1, 3, 5, 7], 3, 3}) -%!assert (strfind ("Linux _is_ user-friendly. It just isn't ignorant-friendly or idiot-friendly.", "friendly"), [17, 50, 68]) - -%!error strfind () -%!error strfind ("foo", "bar", 1) -%!error <PATTERN must be a string> strfind ("foo", 100) -%!error <first argument must be a string> strfind (100, "foo") -*/ - -static Array<char> -qs_replace (const Array<char>& str, const Array<char>& pat, - const Array<char>& rep, - const octave_idx_type table[TABSIZE], - bool overlaps = true) -{ - Array<char> ret = str; - - octave_idx_type siz = str.numel (), psiz = pat.numel (), rsiz = rep.numel (); - - if (psiz != 0) - { - // Look up matches, without overlaps. - const Array<octave_idx_type> idx = qs_search (pat, str, table, overlaps); - octave_idx_type nidx = idx.numel (); - - if (nidx) - { - // Compute result size. - octave_idx_type retsiz; - if (overlaps) - { - retsiz = 0; - // OMG. Is this the "right answer" MW always looks for, or - // someone was just lazy? - octave_idx_type k = 0; - for (octave_idx_type i = 0; i < nidx; i++) - { - octave_idx_type j = idx(i); - if (j >= k) - retsiz += j - k; - retsiz += rsiz; - k = j + psiz; - } - - retsiz += siz - k; - } - else - retsiz = siz + nidx * (rsiz - psiz); - - ret.clear (dim_vector (1, retsiz)); - const char *src = str.data (), *reps = rep.data (); - char *dest = ret.fortran_vec (); - - octave_idx_type k = 0; - for (octave_idx_type i = 0; i < nidx; i++) - { - octave_idx_type j = idx(i); - if (j >= k) - dest = std::copy (src + k, src + j, dest); - dest = std::copy (reps, reps + rsiz, dest); - k = j + psiz; - } - - std::copy (src + k, src + siz, dest); - } - } - - return ret; -} - -DEFUN_DLD (strrep, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} strrep (@var{s}, @var{ptn}, @var{rep})\n\ -@deftypefnx {Loadable Function} {} strrep (@var{s}, @var{ptn}, @var{rep}, \"overlaps\", @var{o})\n\ -Replace all occurrences of the substring @var{ptn} in the string @var{s}\n\ -with the string @var{rep} and return the result. For example:\n\ -\n\ -@example\n\ -@group\n\ -strrep (\"This is a test string\", \"is\", \"&%$\")\n\ - @result{} \"Th&%$ &%$ a test string\"\n\ -@end group\n\ -@end example\n\ -\n\ -@var{s} may also be a cell array of strings, in which case the replacement is\n\ -done for each element and a cell array is returned.\n\ -@seealso{regexprep, strfind, findstr}\n\ -@end deftypefn") -{ - octave_value retval; - int nargin = args.length (); - bool overlaps = true; - - if (nargin == 5 && args(3).is_string () && args(4).is_scalar_type ()) - { - std::string opt = args(3).string_value (); - if (opt == "overlaps") - { - overlaps = args(4).bool_value (); - nargin = 3; - } - else - { - error ("strrep: unknown option: %s", opt.c_str ()); - return retval; - } - } - - if (nargin == 3) - { - octave_value argstr = args(0), argpat = args(1), argrep = args(2); - if (argpat.is_string () && argrep.is_string ()) - { - const Array<char> pat = argpat.char_array_value (); - const Array<char> rep = argrep.char_array_value (); - - OCTAVE_LOCAL_BUFFER (octave_idx_type, table, TABSIZE); - qs_preprocess (pat, table); - - if (argstr.is_string ()) - retval = qs_replace (argstr.char_array_value (), pat, rep, table, overlaps); - else if (argstr.is_cell ()) - { - const Cell argsc = argstr.cell_value (); - Cell retc (argsc.dims ()); - octave_idx_type ns = argsc.numel (); - - for (octave_idx_type i = 0; i < ns; i++) - { - octave_value argse = argsc(i); - if (argse.is_string ()) - retc(i) = qs_replace (argse.char_array_value (), pat, rep, table, overlaps); - else - { - error ("strrep: each element of S must be a string"); - break; - } - } - - retval = retc; - } - else - error ("strrep: S must be a string or cell array of strings"); - } - else if (argpat.is_cell () || argrep.is_cell ()) - retval = do_simple_cellfun (Fstrrep, "strrep", args); - else - error ("strrep: PTN and REP arguments must be strings or cell arrays of strings"); - } - else - print_usage (); - - return retval; -} - -/* -%!assert (strrep ("This is a test string", "is", "&%$"), -%! "Th&%$ &%$ a test string") -%!assert (strrep ("abababc", "abab", "xyz"), "xyzxyzc") -%!assert (strrep ("abababc", "abab", "xyz", "overlaps", false), "xyzabc") - -%!error strrep () -%!error strrep ("foo", "bar", 3, 4) -*/
--- a/src/DLD-FUNCTIONS/sub2ind.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,209 +0,0 @@ -/* - -Copyright (C) 2009-2012 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "quit.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" - - -static dim_vector -get_dim_vector (const octave_value& val, const char *name) -{ - RowVector dimsv = val.row_vector_value (false, true); - dim_vector dv; - octave_idx_type n = dimsv.length (); - - if (n < 1) - error ("%s: dimension vector DIMS must not be empty", name); - else - { - dv.resize (std::max (n, static_cast<octave_idx_type> (2))); - dv(1) = 1; - for (octave_idx_type i = 0; i < n; i++) - { - octave_idx_type ii = dimsv(i); - if (ii == dimsv(i) && ii >= 0) - dv(i) = ii; - else - { - error ("%s: dimension vector DIMS must contain integers", name); - break; - } - } - } - - return dv; -} - -DEFUN_DLD (sub2ind, args, , - "-*- texinfo -*-\n\ -@deftypefn {Function File} {@var{ind} =} sub2ind (@var{dims}, @var{i}, @var{j})\n\ -@deftypefnx {Function File} {@var{ind} =} sub2ind (@var{dims}, @var{s1}, @var{s2}, @dots{}, @var{sN})\n\ -Convert subscripts to a linear index.\n\ -\n\ -The following example shows how to convert the two-dimensional\n\ -index @code{(2,3)} of a 3-by-3 matrix to a linear index. The matrix\n\ -is linearly indexed moving from one column to next, filling up\n\ -all rows in each column.\n\ -\n\ -@example\n\ -@group\n\ -linear_index = sub2ind ([3, 3], 2, 3)\n\ -@result{} 8\n\ -@end group\n\ -@end example\n\ -@seealso{ind2sub}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value retval; - - if (nargin < 2) - print_usage (); - else - { - dim_vector dv = get_dim_vector (args(0), "sub2ind"); - Array<idx_vector> idxa (dim_vector (nargin-1, 1)); - - if (! error_state) - { - dv = dv.redim (nargin - 1); - for (int j = 0; j < nargin - 1; j++) - { - if (args(j+1).is_numeric_type ()) - { - idxa(j) = args(j+1).index_vector (); - if (error_state) - break; - else if (j > 0 && args(j+1).dims () != args(1).dims ()) - error ("sub2ind: all subscripts must be of the same size"); - } - else - error ("sub2ind: subscripts must be numeric"); - - if (error_state) - break; - } - } - - if (! error_state) - { - idx_vector idx = sub2ind (dv, idxa); - retval = idx; - } - } - - return retval; -} - -/* -## Test evaluation -%!test -%! s1 = [ 1 1 1 1 ; 2 2 2 2 ]; -%! s2 = [ 1 1 2 2 ; 1 1 2 2 ]; -%! s3 = [ 1 2 1 2 ; 1 2 1 2 ]; -%! in = [ 1 101 11 111 ; 2 102 12 112 ]; -%! assert (sub2ind ([10 10 10], s1, s2, s3), in); - -# Test low index -%!assert (sub2ind ([10 10 10], 1, 1, 1), 1) -%!error <subscript indices> sub2ind ([10 10 10], 0, 1, 1) -%!error <subscript indices> sub2ind ([10 10 10], 1, 0, 1) -%!error <subscript indices> sub2ind ([10 10 10], 1, 1, 0) - -# Test high index -%!assert (sub2ind ([10 10 10], 10, 10, 10), 1000) -%!error <index out of range> sub2ind ([10 10 10], 11, 10, 10) -%!error <index out of range> sub2ind ([10 10 10], 10, 11, 10) -%!error <index out of range> sub2ind ([10 10 10], 10, 10, 11) - -# Test high index in the trailing dimensions -%!assert (sub2ind ([10, 1], 2, 1, 1), 2) -%!error <index out of range> sub2ind ([10, 1], 1, 2, 1) -%!error <index out of range> sub2ind ([10, 1], 1, 1, 2) -%!assert (sub2ind ([10 10], 2, 2, 1), 12) -%!error <index out of range> sub2ind ([10 10], 2, 1, 2) -%!error <index out of range> sub2ind ([10 10], 1, 2, 2) - -# Test handling of empty arguments -%!assert (sub2ind ([10 10], zeros (0,0), zeros (0,0)), zeros (0,0)) -%!assert (sub2ind ([10 10], zeros (2,0), zeros (2,0)), zeros (2,0)) -%!assert (sub2ind ([10 10], zeros (0,2), zeros (0,2)), zeros (0,2)) -%!error <all subscripts .* same size> sub2ind ([10 10 10], zeros (0,2), zeros (2,0)) - -# Test handling of arguments of different size -%!error <all subscripts .* same size> sub2ind ([10 10], ones (1,2), ones (1,3)) -%!error <all subscripts .* same size> sub2ind ([10 10], ones (1,2), ones (2,1)) - -## Test input validation -%!error <dimension vector> sub2ind ([10 10.5], 1, 1) -%!error <subscript indices> sub2ind ([10 10], 1.5, 1) -%!error <subscript indices> sub2ind ([10 10], 1, 1.5) -*/ - -DEFUN_DLD (ind2sub, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Function File} {[@var{s1}, @var{s2}, @dots{}, @var{sN}] =} ind2sub (@var{dims}, @var{ind})\n\ -Convert a linear index to subscripts.\n\ -\n\ -The following example shows how to convert the linear index @code{8}\n\ -in a 3-by-3 matrix into a subscript. The matrix is linearly indexed\n\ -moving from one column to next, filling up all rows in each column.\n\ -\n\ -@example\n\ -@group\n\ -[r, c] = ind2sub ([3, 3], 8)\n\ - @result{} r = 2\n\ - @result{} c = 3\n\ -@end group\n\ -@end example\n\ -@seealso{sub2ind}\n\ -@end deftypefn") -{ - int nargin = args.length (); - octave_value_list retval; - - if (nargin != 2) - print_usage (); - else - { - dim_vector dv = get_dim_vector (args(0), "ind2sub"); - idx_vector idx = args(1).index_vector (); - if (! error_state) - { - if (nargout > dv.length ()) - dv = dv.redim (nargout); - - Array<idx_vector> idxa = ind2sub (dv, idx); - retval = Array<octave_value> (idxa); - } - } - - return retval; -}
--- a/src/DLD-FUNCTIONS/svd.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,423 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "CmplxSVD.h" -#include "dbleSVD.h" -#include "fCmplxSVD.h" -#include "floatSVD.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "pr-output.h" -#include "utils.h" -#include "variables.h" - -static int Vsvd_driver = SVD::GESVD; - -DEFUN_DLD (svd, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{s} =} svd (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{U}, @var{S}, @var{V}] =} svd (@var{A})\n\ -@deftypefnx {Loadable Function} {[@var{U}, @var{S}, @var{V}] =} svd (@var{A}, @var{econ})\n\ -@cindex singular value decomposition\n\ -Compute the singular value decomposition of @var{A}\n\ -@tex\n\ -$$\n\ - A = U S V^{\\dagger}\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -A = U*S*V'\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -\n\ -The function @code{svd} normally returns only the vector of singular values.\n\ -When called with three return values, it computes\n\ -@tex\n\ -$U$, $S$, and $V$.\n\ -@end tex\n\ -@ifnottex\n\ -@var{U}, @var{S}, and @var{V}.\n\ -@end ifnottex\n\ -For example,\n\ -\n\ -@example\n\ -svd (hilb (3))\n\ -@end example\n\ -\n\ -@noindent\n\ -returns\n\ -\n\ -@example\n\ -@group\n\ -ans =\n\ -\n\ - 1.4083189\n\ - 0.1223271\n\ - 0.0026873\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -and\n\ -\n\ -@example\n\ -[u, s, v] = svd (hilb (3))\n\ -@end example\n\ -\n\ -@noindent\n\ -returns\n\ -\n\ -@example\n\ -@group\n\ -u =\n\ -\n\ - -0.82704 0.54745 0.12766\n\ - -0.45986 -0.52829 -0.71375\n\ - -0.32330 -0.64901 0.68867\n\ -\n\ -s =\n\ -\n\ - 1.40832 0.00000 0.00000\n\ - 0.00000 0.12233 0.00000\n\ - 0.00000 0.00000 0.00269\n\ -\n\ -v =\n\ -\n\ - -0.82704 0.54745 0.12766\n\ - -0.45986 -0.52829 -0.71375\n\ - -0.32330 -0.64901 0.68867\n\ -@end group\n\ -@end example\n\ -\n\ -If given a second argument, @code{svd} returns an economy-sized\n\ -decomposition, eliminating the unnecessary rows or columns of @var{U} or\n\ -@var{V}.\n\ -@seealso{svd_driver, svds, eig}\n\ -@end deftypefn") -{ - octave_value_list retval; - - int nargin = args.length (); - - if (nargin < 1 || nargin > 2 || nargout == 2 || nargout > 3) - { - print_usage (); - return retval; - } - - octave_value arg = args(0); - - octave_idx_type nr = arg.rows (); - octave_idx_type nc = arg.columns (); - - if (arg.ndims () != 2) - { - error ("svd: A must be a 2-D matrix"); - return retval; - } - - bool isfloat = arg.is_single_type (); - - SVD::type type = ((nargout == 0 || nargout == 1) - ? SVD::sigma_only - : (nargin == 2) ? SVD::economy : SVD::std); - - SVD::driver driver = static_cast<SVD::driver> (Vsvd_driver); - - if (nr == 0 || nc == 0) - { - if (isfloat) - { - switch (type) - { - case SVD::std: - retval(2) = FloatDiagMatrix (nc, nc, 1.0f); - retval(1) = FloatMatrix (nr, nc); - retval(0) = FloatDiagMatrix (nr, nr, 1.0f); - break; - case SVD::economy: - retval(2) = FloatDiagMatrix (0, nc, 1.0f); - retval(1) = FloatMatrix (0, 0); - retval(0) = FloatDiagMatrix (nr, 0, 1.0f); - break; - case SVD::sigma_only: default: - retval(0) = FloatMatrix (0, 1); - break; - } - } - else - { - switch (type) - { - case SVD::std: - retval(2) = DiagMatrix (nc, nc, 1.0); - retval(1) = Matrix (nr, nc); - retval(0) = DiagMatrix (nr, nr, 1.0); - break; - case SVD::economy: - retval(2) = DiagMatrix (0, nc, 1.0); - retval(1) = Matrix (0, 0); - retval(0) = DiagMatrix (nr, 0, 1.0); - break; - case SVD::sigma_only: default: - retval(0) = Matrix (0, 1); - break; - } - } - } - else - { - if (isfloat) - { - if (arg.is_real_type ()) - { - FloatMatrix tmp = arg.float_matrix_value (); - - if (! error_state) - { - if (tmp.any_element_is_inf_or_nan ()) - { - error ("svd: cannot take SVD of matrix containing Inf or NaN values"); - return retval; - } - - FloatSVD result (tmp, type, driver); - - FloatDiagMatrix sigma = result.singular_values (); - - if (nargout == 0 || nargout == 1) - { - retval(0) = sigma.diag (); - } - else - { - retval(2) = result.right_singular_matrix (); - retval(1) = sigma; - retval(0) = result.left_singular_matrix (); - } - } - } - else if (arg.is_complex_type ()) - { - FloatComplexMatrix ctmp = arg.float_complex_matrix_value (); - - if (! error_state) - { - if (ctmp.any_element_is_inf_or_nan ()) - { - error ("svd: cannot take SVD of matrix containing Inf or NaN values"); - return retval; - } - - FloatComplexSVD result (ctmp, type, driver); - - FloatDiagMatrix sigma = result.singular_values (); - - if (nargout == 0 || nargout == 1) - { - retval(0) = sigma.diag (); - } - else - { - retval(2) = result.right_singular_matrix (); - retval(1) = sigma; - retval(0) = result.left_singular_matrix (); - } - } - } - } - else - { - if (arg.is_real_type ()) - { - Matrix tmp = arg.matrix_value (); - - if (! error_state) - { - if (tmp.any_element_is_inf_or_nan ()) - { - error ("svd: cannot take SVD of matrix containing Inf or NaN values"); - return retval; - } - - SVD result (tmp, type, driver); - - DiagMatrix sigma = result.singular_values (); - - if (nargout == 0 || nargout == 1) - { - retval(0) = sigma.diag (); - } - else - { - retval(2) = result.right_singular_matrix (); - retval(1) = sigma; - retval(0) = result.left_singular_matrix (); - } - } - } - else if (arg.is_complex_type ()) - { - ComplexMatrix ctmp = arg.complex_matrix_value (); - - if (! error_state) - { - if (ctmp.any_element_is_inf_or_nan ()) - { - error ("svd: cannot take SVD of matrix containing Inf or NaN values"); - return retval; - } - - ComplexSVD result (ctmp, type, driver); - - DiagMatrix sigma = result.singular_values (); - - if (nargout == 0 || nargout == 1) - { - retval(0) = sigma.diag (); - } - else - { - retval(2) = result.right_singular_matrix (); - retval(1) = sigma; - retval(0) = result.left_singular_matrix (); - } - } - } - else - { - gripe_wrong_type_arg ("svd", arg); - return retval; - } - } - } - - return retval; -} - -/* -%!assert (svd ([1, 2; 2, 1]), [3; 1], sqrt (eps)) - -%!test -%! [u, s, v] = svd ([1, 2; 2, 1]); -%! x = 1 / sqrt (2); -%! assert (u, [-x, -x; -x, x], sqrt (eps)); -%! assert (s, [3, 0; 0, 1], sqrt (eps)); -%! assert (v, [-x, x; -x, -x], sqrt (eps)); - -%!test -%! a = [1, 2, 3; 4, 5, 6]; -%! [u, s, v] = svd (a); -%! assert (u * s * v', a, sqrt (eps)); - -%!test -%! a = [1, 2; 3, 4; 5, 6]; -%! [u, s, v] = svd (a); -%! assert (u * s * v', a, sqrt (eps)); - -%!test -%! a = [1, 2, 3; 4, 5, 6]; -%! [u, s, v] = svd (a, 1); -%! assert (u * s * v', a, sqrt (eps)); - -%!test -%! a = [1, 2; 3, 4; 5, 6]; -%! [u, s, v] = svd (a, 1); -%! assert (u * s * v', a, sqrt (eps)); - -%!assert (svd (single ([1, 2; 2, 1])), single ([3; 1]), sqrt (eps ("single"))) - -%!test -%! [u, s, v] = svd (single ([1, 2; 2, 1])); -%! x = single (1 / sqrt (2)); -%! assert (u, [-x, -x; -x, x], sqrt (eps ("single"))); -%! assert (s, single ([3, 0; 0, 1]), sqrt (eps ("single"))); -%! assert (v, [-x, x; -x, -x], sqrt (eps ("single"))); - -%!test -%! a = single ([1, 2, 3; 4, 5, 6]); -%! [u, s, v] = svd (a); -%! assert (u * s * v', a, sqrt (eps ("single"))); - -%!test -%! a = single ([1, 2; 3, 4; 5, 6]); -%! [u, s, v] = svd (a); -%! assert (u * s * v', a, sqrt (eps ("single"))); - -%!test -%! a = single ([1, 2, 3; 4, 5, 6]); -%! [u, s, v] = svd (a, 1); -%! assert (u * s * v', a, sqrt (eps ("single"))); - -%!test -%! a = single ([1, 2; 3, 4; 5, 6]); -%! [u, s, v] = svd (a, 1); -%! assert (u * s * v', a, sqrt (eps ("single"))); - -%!test -%! a = zeros (0, 5); -%! [u, s, v] = svd (a); -%! assert (size (u), [0, 0]); -%! assert (size (s), [0, 5]); -%! assert (size (v), [5, 5]); - -%!test -%! a = zeros (5, 0); -%! [u, s, v] = svd (a, 1); -%! assert (size (u), [5, 0]); -%! assert (size (s), [0, 0]); -%! assert (size (v), [0, 0]); - -%!error svd () -%!error svd ([1, 2; 4, 5], 2, 3) -%!error [u, v] = svd ([1, 2; 3, 4]) -*/ - -DEFUN_DLD (svd_driver, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{val} =} svd_driver ()\n\ -@deftypefnx {Loadable Function} {@var{old_val} =} svd_driver (@var{new_val})\n\ -@deftypefnx {Loadable Function} {} svd_driver (@var{new_val}, \"local\")\n\ -Query or set the underlying @sc{lapack} driver used by @code{svd}.\n\ -Currently recognized values are \"gesvd\" and \"gesdd\". The default\n\ -is \"gesvd\".\n\ -\n\ -When called from inside a function with the \"local\" option, the variable is\n\ -changed locally for the function and any subroutines it calls. The original\n\ -variable value is restored when exiting the function.\n\ -@seealso{svd}\n\ -@end deftypefn") -{ - static const char *driver_names[] = { "gesvd", "gesdd", 0 }; - - return SET_INTERNAL_VARIABLE_CHOICES (svd_driver, driver_names); -}
--- a/src/DLD-FUNCTIONS/syl.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,218 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -// Author: A. S. Hodel <scotte@eng.auburn.edu> - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "utils.h" - -DEFUN_DLD (syl, args, nargout, - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{x} =} syl (@var{A}, @var{B}, @var{C})\n\ -Solve the Sylvester equation\n\ -@tex\n\ -$$\n\ - A X + X B + C = 0\n\ -$$\n\ -@end tex\n\ -@ifnottex\n\ -\n\ -@example\n\ -A X + X B + C = 0\n\ -@end example\n\ -\n\ -@end ifnottex\n\ -using standard @sc{lapack} subroutines. For example:\n\ -\n\ -@example\n\ -@group\n\ -syl ([1, 2; 3, 4], [5, 6; 7, 8], [9, 10; 11, 12])\n\ - @result{} [ -0.50000, -0.66667; -0.66667, -0.50000 ]\n\ -@end group\n\ -@end example\n\ -@end deftypefn") -{ - octave_value retval; - - int nargin = args.length (); - - if (nargin != 3 || nargout > 1) - { - print_usage (); - return retval; - } - - octave_value arg_a = args(0); - octave_value arg_b = args(1); - octave_value arg_c = args(2); - - octave_idx_type a_nr = arg_a.rows (); - octave_idx_type a_nc = arg_a.columns (); - - octave_idx_type b_nr = arg_b.rows (); - octave_idx_type b_nc = arg_b.columns (); - - octave_idx_type c_nr = arg_c.rows (); - octave_idx_type c_nc = arg_c.columns (); - - int arg_a_is_empty = empty_arg ("syl", a_nr, a_nc); - int arg_b_is_empty = empty_arg ("syl", b_nr, b_nc); - int arg_c_is_empty = empty_arg ("syl", c_nr, c_nc); - - bool isfloat = arg_a.is_single_type () || arg_b.is_single_type () || - arg_c.is_single_type (); - - if (arg_a_is_empty > 0 && arg_b_is_empty > 0 && arg_c_is_empty > 0) - if (isfloat) - return octave_value (FloatMatrix ()); - else - return octave_value (Matrix ()); - else if (arg_a_is_empty || arg_b_is_empty || arg_c_is_empty) - return retval; - - // Arguments are not empty, so check for correct dimensions. - - if (a_nr != a_nc || b_nr != b_nc) - { - gripe_square_matrix_required ("syl: first two parameters:"); - return retval; - } - else if (a_nr != c_nr || b_nr != c_nc) - { - gripe_nonconformant (); - return retval; - } - - // Dimensions look o.k., let's solve the problem. - if (isfloat) - { - if (arg_a.is_complex_type () - || arg_b.is_complex_type () - || arg_c.is_complex_type ()) - { - // Do everything in complex arithmetic; - - FloatComplexMatrix ca = arg_a.float_complex_matrix_value (); - - if (error_state) - return retval; - - FloatComplexMatrix cb = arg_b.float_complex_matrix_value (); - - if (error_state) - return retval; - - FloatComplexMatrix cc = arg_c.float_complex_matrix_value (); - - if (error_state) - return retval; - - retval = Sylvester (ca, cb, cc); - } - else - { - // Do everything in real arithmetic. - - FloatMatrix ca = arg_a.float_matrix_value (); - - if (error_state) - return retval; - - FloatMatrix cb = arg_b.float_matrix_value (); - - if (error_state) - return retval; - - FloatMatrix cc = arg_c.float_matrix_value (); - - if (error_state) - return retval; - - retval = Sylvester (ca, cb, cc); - } - } - else - { - if (arg_a.is_complex_type () - || arg_b.is_complex_type () - || arg_c.is_complex_type ()) - { - // Do everything in complex arithmetic; - - ComplexMatrix ca = arg_a.complex_matrix_value (); - - if (error_state) - return retval; - - ComplexMatrix cb = arg_b.complex_matrix_value (); - - if (error_state) - return retval; - - ComplexMatrix cc = arg_c.complex_matrix_value (); - - if (error_state) - return retval; - - retval = Sylvester (ca, cb, cc); - } - else - { - // Do everything in real arithmetic. - - Matrix ca = arg_a.matrix_value (); - - if (error_state) - return retval; - - Matrix cb = arg_b.matrix_value (); - - if (error_state) - return retval; - - Matrix cc = arg_c.matrix_value (); - - if (error_state) - return retval; - - retval = Sylvester (ca, cb, cc); - } - } - - return retval; -} - -/* -%!assert (syl ([1, 2; 3, 4], [5, 6; 7, 8], [9, 10; 11, 12]), [-1/2, -2/3; -2/3, -1/2], sqrt (eps)) -%!assert (syl (single ([1, 2; 3, 4]), single ([5, 6; 7, 8]), single ([9, 10; 11, 12])), single ([-1/2, -2/3; -2/3, -1/2]), sqrt (eps ("single"))) - -%!error syl () -%!error syl (1, 2, 3, 4) -%!error <must be a square matrix> syl ([1, 2; 3, 4], [1, 2, 3; 4, 5, 6], [4, 3]) -*/
--- a/src/DLD-FUNCTIONS/symbfact.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/DLD-FUNCTIONS/symbfact.cc Sat Jul 28 12:06:34 2012 -0400 @@ -270,7 +270,7 @@ // count the total number of entries in L octave_idx_type lnz = 0 ; for (octave_idx_type j = 0 ; j < n ; j++) - lnz += ColCount [j] ; + lnz += ColCount[j]; // allocate the output matrix L (pattern-only) @@ -281,7 +281,7 @@ for (octave_idx_type j = 0 ; j < n ; j++) { L.xcidx(j) = lnz; - lnz += ColCount [j]; + lnz += ColCount[j]; } L.xcidx(n) = lnz; @@ -302,11 +302,11 @@ { // get the kth row of L and store in the columns of L CHOLMOD_NAME (row_subtree) (A1, A2, k, Parent, R, cm) ; - for (octave_idx_type p = 0 ; p < Rp [1] ; p++) - L.xridx (W [Ri [p]]++) = k ; + for (octave_idx_type p = 0 ; p < Rp[1] ; p++) + L.xridx (W[Ri[p]]++) = k ; // add the diagonal entry - L.xridx (W [k]++) = k ; + L.xridx (W[k]++) = k ; } // free workspace
--- a/src/DLD-FUNCTIONS/symrcm.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/DLD-FUNCTIONS/symrcm.cc Sat Jul 28 12:06:34 2012 -0400 @@ -405,7 +405,7 @@ for (octave_idx_type k = cidx[j]; k < cidx[j + 1]; k++) { OCTAVE_QUIT; - octave_idx_type q = w [ridx[k]]++; + octave_idx_type q = w[ridx[k]]++; ridx2[q] = j; } }
--- a/src/DLD-FUNCTIONS/time.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,539 +0,0 @@ -/* - -Copyright (C) 1996-2012 John W. Eaton - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <string> - -#include "defun-dld.h" -#include "error.h" -#include "oct-map.h" -#include "oct-time.h" -#include "ov.h" -#include "oct-obj.h" - -// Date and time functions. - -static octave_scalar_map -mk_tm_map (const octave_base_tm& t) -{ - octave_scalar_map m; - - m.assign ("usec", static_cast<double> (t.usec ())); - m.assign ("sec", static_cast<double> (t.sec ())); - m.assign ("min", static_cast<double> (t.min ())); - m.assign ("hour", static_cast<double> (t.hour ())); - m.assign ("mday", static_cast<double> (t.mday ())); - m.assign ("mon", static_cast<double> (t.mon ())); - m.assign ("year", static_cast<double> (t.year ())); - m.assign ("wday", static_cast<double> (t.wday ())); - m.assign ("yday", static_cast<double> (t.yday ())); - m.assign ("isdst", static_cast<double> (t.isdst ())); - m.assign ("zone", t.zone ()); - - return m; -} - -static inline int -intfield (const octave_scalar_map& m, const std::string& k) -{ - int retval = 0; - - octave_value v = m.getfield (k); - - if (! v.is_empty ()) - retval = v.int_value (); - - return retval; -} - -static inline std::string -stringfield (const octave_scalar_map& m, const std::string& k) -{ - std::string retval; - - octave_value v = m.getfield (k); - - if (! v.is_empty ()) - retval = v.string_value (); - - return retval; -} - -static octave_base_tm -extract_tm (const octave_scalar_map& m) -{ - octave_base_tm tm; - - tm.usec (intfield (m, "usec")); - tm.sec (intfield (m, "sec")); - tm.min (intfield (m, "min")); - tm.hour (intfield (m, "hour")); - tm.mday (intfield (m, "mday")); - tm.mon (intfield (m, "mon")); - tm.year (intfield (m, "year")); - tm.wday (intfield (m, "wday")); - tm.yday (intfield (m, "yday")); - tm.isdst (intfield (m, "isdst")); - tm.zone (stringfield (m, "zone")); - - return tm; -} - -DEFUN_DLD (time, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{seconds} =} time ()\n\ -Return the current time as the number of seconds since the epoch. The\n\ -epoch is referenced to 00:00:00 CUT (Coordinated Universal Time) 1 Jan\n\ -1970. For example, on Monday February 17, 1997 at 07:15:06 CUT, the\n\ -value returned by @code{time} was 856163706.\n\ -@seealso{strftime, strptime, localtime, gmtime, mktime, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 0) - retval = octave_time (); - else - print_usage (); - - return retval; -} - -/* -%!assert (time () > 0) -*/ - -DEFUN_DLD (gmtime, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{tm_struct} =} gmtime (@var{t})\n\ -Given a value returned from @code{time}, or any non-negative integer,\n\ -return a time structure corresponding to CUT (Coordinated Universal Time).\n\ -For example:\n\ -\n\ -@example\n\ -@group\n\ -gmtime (time ())\n\ - @result{} @{\n\ - usec = 0\n\ - sec = 6\n\ - min = 15\n\ - hour = 7\n\ - mday = 17\n\ - mon = 1\n\ - year = 97\n\ - wday = 1\n\ - yday = 47\n\ - isdst = 0\n\ - zone = CST\n\ - @}\n\ -@end group\n\ -@end example\n\ -@seealso{strftime, strptime, localtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 1) - { - double tmp = args(0).double_value (); - - if (! error_state) - retval = octave_value (mk_tm_map (octave_gmtime (tmp))); - } - else - print_usage (); - - return retval; -} - -/* -%!test -%! ts = gmtime (time ()); -%! assert (isstruct (ts)); -%! assert (isfield (ts, "usec")); -%! assert (isfield (ts, "year")); -%! assert (isfield (ts, "mon")); -%! assert (isfield (ts, "mday")); -%! assert (isfield (ts, "sec")); -%! assert (isfield (ts, "min")); -%! assert (isfield (ts, "wday")); -%! assert (isfield (ts, "hour")); -%! assert (isfield (ts, "isdst")); -%! assert (isfield (ts, "yday")); - -%!error gmtime () -%!error gmtime (1, 2) -*/ - -DEFUN_DLD (localtime, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{tm_struct} =} localtime (@var{t})\n\ -Given a value returned from @code{time}, or any non-negative integer,\n\ -return a time structure corresponding to the local time zone.\n\ -\n\ -@example\n\ -@group\n\ -localtime (time ())\n\ - @result{} @{\n\ - usec = 0\n\ - sec = 6\n\ - min = 15\n\ - hour = 1\n\ - mday = 17\n\ - mon = 1\n\ - year = 97\n\ - wday = 1\n\ - yday = 47\n\ - isdst = 0\n\ - zone = CST\n\ - @}\n\ -@end group\n\ -@end example\n\ -@seealso{strftime, strptime, gmtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 1) - { - double tmp = args(0).double_value (); - - if (! error_state) - retval = octave_value (mk_tm_map (octave_localtime (tmp))); - } - else - print_usage (); - - return retval; -} - -/* -%!test -%! ts = localtime (time ()); -%! assert (isstruct (ts)); -%! assert (isfield (ts, "usec")); -%! assert (isfield (ts, "year")); -%! assert (isfield (ts, "mon")); -%! assert (isfield (ts, "mday")); -%! assert (isfield (ts, "sec")); -%! assert (isfield (ts, "min")); -%! assert (isfield (ts, "wday")); -%! assert (isfield (ts, "hour")); -%! assert (isfield (ts, "isdst")); -%! assert (isfield (ts, "yday")); - -%!error localtime () -%!error localtime (1, 2) -*/ - -DEFUN_DLD (mktime, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{seconds} =} mktime (@var{tm_struct})\n\ -Convert a time structure corresponding to the local time to the number\n\ -of seconds since the epoch. For example:\n\ -\n\ -@example\n\ -@group\n\ -mktime (localtime (time ()))\n\ - @result{} 856163706\n\ -@end group\n\ -@end example\n\ -@seealso{strftime, strptime, localtime, gmtime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 1) - { - octave_scalar_map map = args(0).scalar_map_value (); - - if (! error_state) - { - octave_base_tm tm = extract_tm (map); - - if (! error_state) - retval = octave_time (tm); - else - error ("mktime: invalid TM_STRUCT argument"); - } - else - error ("mktime: TM_STRUCT argument must be a structure"); - } - else - print_usage (); - - return retval; -} - -/* -%!test -%! t = time (); -%! assert (fix (mktime (localtime (t))) == fix (t)); - -## These tests fail on systems with mktime functions of limited -## intelligence: -%!assert (datestr (datenum (1969, 1, 1), 0), "01-Jan-1969 00:00:00") -%!assert (datestr (datenum (1901, 1, 1), 0), "01-Jan-1901 00:00:00") -%!assert (datestr (datenum (1795, 1, 1), 0), "01-Jan-1795 00:00:00") - -%!error mktime () -%!error mktime (1, 2, 3) -*/ - -DEFUN_DLD (strftime, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} strftime (@var{fmt}, @var{tm_struct})\n\ -Format the time structure @var{tm_struct} in a flexible way using the\n\ -format string @var{fmt} that contains @samp{%} substitutions\n\ -similar to those in @code{printf}. Except where noted, substituted\n\ -fields have a fixed size; numeric fields are padded if necessary.\n\ -Padding is with zeros by default; for fields that display a single\n\ -number, padding can be changed or inhibited by following the @samp{%}\n\ -with one of the modifiers described below. Unknown field specifiers are\n\ -copied as normal characters. All other characters are copied to the\n\ -output without change. For example:\n\ -\n\ -@example\n\ -@group\n\ -strftime (\"%r (%Z) %A %e %B %Y\", localtime (time ()))\n\ - @result{} \"01:15:06 AM (CST) Monday 17 February 1997\"\n\ -@end group\n\ -@end example\n\ -\n\ -Octave's @code{strftime} function supports a superset of the ANSI C\n\ -field specifiers.\n\ -\n\ -@noindent\n\ -Literal character fields:\n\ -\n\ -@table @code\n\ -@item %%\n\ -% character.\n\ -\n\ -@item %n\n\ -Newline character.\n\ -\n\ -@item %t\n\ -Tab character.\n\ -@end table\n\ -\n\ -@noindent\n\ -Numeric modifiers (a nonstandard extension):\n\ -\n\ -@table @code\n\ -@item - (dash)\n\ -Do not pad the field.\n\ -\n\ -@item _ (underscore)\n\ -Pad the field with spaces.\n\ -@end table\n\ -\n\ -@noindent\n\ -Time fields:\n\ -\n\ -@table @code\n\ -@item %H\n\ -Hour (00-23).\n\ -\n\ -@item %I\n\ -Hour (01-12).\n\ -\n\ -@item %k\n\ -Hour (0-23).\n\ -\n\ -@item %l\n\ -Hour (1-12).\n\ -\n\ -@item %M\n\ -Minute (00-59).\n\ -\n\ -@item %p\n\ -Locale's AM or PM.\n\ -\n\ -@item %r\n\ -Time, 12-hour (hh:mm:ss [AP]M).\n\ -\n\ -@item %R\n\ -Time, 24-hour (hh:mm).\n\ -\n\ -@item %s\n\ -Time in seconds since 00:00:00, Jan 1, 1970 (a nonstandard extension).\n\ -\n\ -@item %S\n\ -Second (00-61).\n\ -\n\ -@item %T\n\ -Time, 24-hour (hh:mm:ss).\n\ -\n\ -@item %X\n\ -Locale's time representation (%H:%M:%S).\n\ -\n\ -@item %Z\n\ -Time zone (EDT), or nothing if no time zone is determinable.\n\ -@end table\n\ -\n\ -@noindent\n\ -Date fields:\n\ -\n\ -@table @code\n\ -@item %a\n\ -Locale's abbreviated weekday name (Sun-Sat).\n\ -\n\ -@item %A\n\ -Locale's full weekday name, variable length (Sunday-Saturday).\n\ -\n\ -@item %b\n\ -Locale's abbreviated month name (Jan-Dec).\n\ -\n\ -@item %B\n\ -Locale's full month name, variable length (January-December).\n\ -\n\ -@item %c\n\ -Locale's date and time (Sat Nov 04 12:02:33 EST 1989).\n\ -\n\ -@item %C\n\ -Century (00-99).\n\ -\n\ -@item %d\n\ -Day of month (01-31).\n\ -\n\ -@item %e\n\ -Day of month ( 1-31).\n\ -\n\ -@item %D\n\ -Date (mm/dd/yy).\n\ -\n\ -@item %h\n\ -Same as %b.\n\ -\n\ -@item %j\n\ -Day of year (001-366).\n\ -\n\ -@item %m\n\ -Month (01-12).\n\ -\n\ -@item %U\n\ -Week number of year with Sunday as first day of week (00-53).\n\ -\n\ -@item %w\n\ -Day of week (0-6).\n\ -\n\ -@item %W\n\ -Week number of year with Monday as first day of week (00-53).\n\ -\n\ -@item %x\n\ -Locale's date representation (mm/dd/yy).\n\ -\n\ -@item %y\n\ -Last two digits of year (00-99).\n\ -\n\ -@item %Y\n\ -Year (1970-).\n\ -@end table\n\ -@seealso{strptime, localtime, gmtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 2) - { - std::string fmt = args(0).string_value (); - - if (! error_state) - { - octave_scalar_map map = args(1).scalar_map_value (); - - if (! error_state) - { - octave_base_tm tm = extract_tm (map); - - if (! error_state) - retval = tm.strftime (fmt); - else - error ("strftime: invalid TM_STRUCT argument"); - } - else - error ("strftime: TM_STRUCT must be a structure"); - } - else - error ("strftime: FMT must be a string"); - } - else - print_usage (); - - return retval; -} - -/* -%!assert (ischar (strftime ("%%%n%t%H%I%k%l", localtime (time ())))); -%!assert (ischar (strftime ("%M%p%r%R%s%S%T", localtime (time ())))); -%!assert (ischar (strftime ("%X%Z%z%a%A%b%B", localtime (time ())))); -%!assert (ischar (strftime ("%c%C%d%e%D%h%j", localtime (time ())))); -%!assert (ischar (strftime ("%m%U%w%W%x%y%Y", localtime (time ())))); - -%!error strftime () -%!error strftime ("foo", localtime (time ()), 1) -*/ - -DEFUN_DLD (strptime, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{tm_struct}, @var{nchars}] =} strptime (@var{str}, @var{fmt})\n\ -Convert the string @var{str} to the time structure @var{tm_struct} under\n\ -the control of the format string @var{fmt}.\n\ -\n\ -If @var{fmt} fails to match, @var{nchars} is 0; otherwise, it is set to the\n\ -position of last matched character plus 1. Always check for this unless\n\ -you're absolutely sure the date string will be parsed correctly.\n\ -@seealso{strftime, localtime, gmtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ -@end deftypefn") -{ - octave_value_list retval; - - if (args.length () == 2) - { - std::string str = args(0).string_value (); - - if (! error_state) - { - std::string fmt = args(1).string_value (); - - if (! error_state) - { - octave_strptime t (str, fmt); - - retval(1) = t.characters_converted (); - retval(0) = octave_value (mk_tm_map (t)); - } - else - error ("strptime: FMT must be a string"); - } - else - error ("strptime: argument STR must be a string"); - } - else - print_usage (); - - return retval; -}
--- a/src/DLD-FUNCTIONS/tril.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,430 +0,0 @@ -/* - -Copyright (C) 2004-2012 David Bateman -Copyright (C) 2009 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <algorithm> -#include "Array.h" -#include "Sparse.h" -#include "mx-base.h" - -#include "ov.h" -#include "Cell.h" - -#include "defun-dld.h" -#include "error.h" -#include "oct-obj.h" - -// The bulk of the work. -template <class T> -static Array<T> -do_tril (const Array<T>& a, octave_idx_type k, bool pack) -{ - octave_idx_type nr = a.rows (), nc = a.columns (); - const T *avec = a.fortran_vec (); - octave_idx_type zero = 0; - - if (pack) - { - octave_idx_type j1 = std::min (std::max (zero, k), nc); - octave_idx_type j2 = std::min (std::max (zero, nr + k), nc); - octave_idx_type n = j1 * nr + ((j2 - j1) * (nr-(j1-k) + nr-(j2-1-k))) / 2; - Array<T> r (dim_vector (n, 1)); - T *rvec = r.fortran_vec (); - for (octave_idx_type j = 0; j < nc; j++) - { - octave_idx_type ii = std::min (std::max (zero, j - k), nr); - rvec = std::copy (avec + ii, avec + nr, rvec); - avec += nr; - } - - return r; - } - else - { - Array<T> r (a.dims ()); - T *rvec = r.fortran_vec (); - for (octave_idx_type j = 0; j < nc; j++) - { - octave_idx_type ii = std::min (std::max (zero, j - k), nr); - std::fill (rvec, rvec + ii, T ()); - std::copy (avec + ii, avec + nr, rvec + ii); - avec += nr; - rvec += nr; - } - - return r; - } -} - -template <class T> -static Array<T> -do_triu (const Array<T>& a, octave_idx_type k, bool pack) -{ - octave_idx_type nr = a.rows (), nc = a.columns (); - const T *avec = a.fortran_vec (); - octave_idx_type zero = 0; - - if (pack) - { - octave_idx_type j1 = std::min (std::max (zero, k), nc); - octave_idx_type j2 = std::min (std::max (zero, nr + k), nc); - octave_idx_type n = ((j2 - j1) * ((j1+1-k) + (j2-k))) / 2 + (nc - j2) * nr; - Array<T> r (dim_vector (n, 1)); - T *rvec = r.fortran_vec (); - for (octave_idx_type j = 0; j < nc; j++) - { - octave_idx_type ii = std::min (std::max (zero, j + 1 - k), nr); - rvec = std::copy (avec, avec + ii, rvec); - avec += nr; - } - - return r; - } - else - { - NoAlias<Array<T> > r (a.dims ()); - T *rvec = r.fortran_vec (); - for (octave_idx_type j = 0; j < nc; j++) - { - octave_idx_type ii = std::min (std::max (zero, j + 1 - k), nr); - std::copy (avec, avec + ii, rvec); - std::fill (rvec + ii, rvec + nr, T ()); - avec += nr; - rvec += nr; - } - - return r; - } -} - -// These two are by David Bateman. -// FIXME: optimizations possible. "pack" support missing. - -template <class T> -static Sparse<T> -do_tril (const Sparse<T>& a, octave_idx_type k, bool pack) -{ - if (pack) // FIXME - { - error ("tril: \"pack\" not implemented for sparse matrices"); - return Sparse<T> (); - } - - Sparse<T> m = a; - octave_idx_type nc = m.cols (); - - for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) - if (m.ridx (i) < j-k) - m.data(i) = 0.; - - m.maybe_compress (true); - return m; -} - -template <class T> -static Sparse<T> -do_triu (const Sparse<T>& a, octave_idx_type k, bool pack) -{ - if (pack) // FIXME - { - error ("triu: \"pack\" not implemented for sparse matrices"); - return Sparse<T> (); - } - - Sparse<T> m = a; - octave_idx_type nc = m.cols (); - - for (octave_idx_type j = 0; j < nc; j++) - for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) - if (m.ridx (i) > j-k) - m.data(i) = 0.; - - m.maybe_compress (true); - return m; -} - -// Convenience dispatchers. -template <class T> -static Array<T> -do_trilu (const Array<T>& a, octave_idx_type k, bool lower, bool pack) -{ - return lower ? do_tril (a, k, pack) : do_triu (a, k, pack); -} - -template <class T> -static Sparse<T> -do_trilu (const Sparse<T>& a, octave_idx_type k, bool lower, bool pack) -{ - return lower ? do_tril (a, k, pack) : do_triu (a, k, pack); -} - -static octave_value -do_trilu (const std::string& name, - const octave_value_list& args) -{ - bool lower = name == "tril"; - - octave_value retval; - int nargin = args.length (); - octave_idx_type k = 0; - bool pack = false; - if (nargin >= 2 && args(nargin-1).is_string ()) - { - pack = args(nargin-1).string_value () == "pack"; - nargin--; - } - - if (nargin == 2) - { - k = args(1).int_value (true); - - if (error_state) - return retval; - } - - if (nargin < 1 || nargin > 2) - print_usage (); - else - { - octave_value arg = args (0); - - dim_vector dims = arg.dims (); - if (dims.length () != 2) - error ("%s: need a 2-D matrix", name.c_str ()); - else if (k < -dims (0) || k > dims(1)) - error ("%s: requested diagonal out of range", name.c_str ()); - else - { - switch (arg.builtin_type ()) - { - case btyp_double: - if (arg.is_sparse_type ()) - retval = do_trilu (arg.sparse_matrix_value (), k, lower, pack); - else - retval = do_trilu (arg.array_value (), k, lower, pack); - break; - case btyp_complex: - if (arg.is_sparse_type ()) - retval = do_trilu (arg.sparse_complex_matrix_value (), k, lower, pack); - else - retval = do_trilu (arg.complex_array_value (), k, lower, pack); - break; - case btyp_bool: - if (arg.is_sparse_type ()) - retval = do_trilu (arg.sparse_bool_matrix_value (), k, lower, pack); - else - retval = do_trilu (arg.bool_array_value (), k, lower, pack); - break; -#define ARRAYCASE(TYP) \ - case btyp_ ## TYP: \ - retval = do_trilu (arg.TYP ## _array_value (), k, lower, pack); \ - break - ARRAYCASE (float); - ARRAYCASE (float_complex); - ARRAYCASE (int8); - ARRAYCASE (int16); - ARRAYCASE (int32); - ARRAYCASE (int64); - ARRAYCASE (uint8); - ARRAYCASE (uint16); - ARRAYCASE (uint32); - ARRAYCASE (uint64); - ARRAYCASE (char); -#undef ARRAYCASE - default: - { - // Generic code that works on octave-values, that is slow - // but will also work on arbitrary user types - - if (pack) // FIXME - { - error ("%s: \"pack\" not implemented for class %s", - name.c_str (), arg.class_name ().c_str ()); - return octave_value (); - } - - octave_value tmp = arg; - if (arg.numel () == 0) - return arg; - - octave_idx_type nr = dims(0), nc = dims (1); - - // The sole purpose of the below is to force the correct - // matrix size. This would not be necessary if the - // octave_value resize function allowed a fill_value. - // It also allows odd attributes in some user types - // to be handled. With a fill_value ot should be replaced - // with - // - // octave_value_list ov_idx; - // tmp = tmp.resize(dim_vector (0,0)).resize (dims, fill_value); - - octave_value_list ov_idx; - std::list<octave_value_list> idx_tmp; - ov_idx(1) = static_cast<double> (nc+1); - ov_idx(0) = Range (1, nr); - idx_tmp.push_back (ov_idx); - ov_idx(1) = static_cast<double> (nc); - tmp = tmp.resize (dim_vector (0,0)); - tmp = tmp.subsasgn ("(",idx_tmp, arg.do_index_op (ov_idx)); - tmp = tmp.resize (dims); - - if (lower) - { - octave_idx_type st = nc < nr + k ? nc : nr + k; - - for (octave_idx_type j = 1; j <= st; j++) - { - octave_idx_type nr_limit = 1 > j - k ? 1 : j - k; - ov_idx(1) = static_cast<double> (j); - ov_idx(0) = Range (nr_limit, nr); - std::list<octave_value_list> idx; - idx.push_back (ov_idx); - - tmp = tmp.subsasgn ("(", idx, arg.do_index_op (ov_idx)); - - if (error_state) - return retval; - } - } - else - { - octave_idx_type st = k + 1 > 1 ? k + 1 : 1; - - for (octave_idx_type j = st; j <= nc; j++) - { - octave_idx_type nr_limit = nr < j - k ? nr : j - k; - ov_idx(1) = static_cast<double> (j); - ov_idx(0) = Range (1, nr_limit); - std::list<octave_value_list> idx; - idx.push_back (ov_idx); - - tmp = tmp.subsasgn ("(", idx, arg.do_index_op (ov_idx)); - - if (error_state) - return retval; - } - } - - retval = tmp; - } - } - } - } - - return retval; -} - -DEFUN_DLD (tril, args, , - "-*- texinfo -*-\n\ -@deftypefn {Function File} {} tril (@var{A})\n\ -@deftypefnx {Function File} {} tril (@var{A}, @var{k})\n\ -@deftypefnx {Function File} {} tril (@var{A}, @var{k}, @var{pack})\n\ -@deftypefnx {Function File} {} triu (@var{A})\n\ -@deftypefnx {Function File} {} triu (@var{A}, @var{k})\n\ -@deftypefnx {Function File} {} triu (@var{A}, @var{k}, @var{pack})\n\ -Return a new matrix formed by extracting the lower (@code{tril})\n\ -or upper (@code{triu}) triangular part of the matrix @var{A}, and\n\ -setting all other elements to zero. The second argument is optional,\n\ -and specifies how many diagonals above or below the main diagonal should\n\ -also be set to zero.\n\ -\n\ -The default value of @var{k} is zero, so that @code{triu} and\n\ -@code{tril} normally include the main diagonal as part of the result.\n\ -\n\ -If the value of @var{k} is negative, additional elements above (for\n\ -@code{tril}) or below (for @code{triu}) the main diagonal are also\n\ -selected.\n\ -\n\ -The absolute value of @var{k} must not be greater than the number of\n\ -sub-diagonals or super-diagonals.\n\ -\n\ -For example:\n\ -\n\ -@example\n\ -@group\n\ -tril (ones (3), -1)\n\ - @result{} 0 0 0\n\ - 1 0 0\n\ - 1 1 0\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -and\n\ -\n\ -@example\n\ -@group\n\ -tril (ones (3), 1)\n\ - @result{} 1 1 0\n\ - 1 1 1\n\ - 1 1 1\n\ -@end group\n\ -@end example\n\ -\n\ -If the option \"pack\" is given as third argument, the extracted elements\n\ -are not inserted into a matrix, but rather stacked column-wise one above\n\ -other.\n\ -@seealso{diag}\n\ -@end deftypefn") -{ - return do_trilu ("tril", args); -} - -DEFUN_DLD (triu, args, , - "-*- texinfo -*-\n\ -@deftypefn {Function File} {} triu (@var{A})\n\ -@deftypefnx {Function File} {} triu (@var{A}, @var{k})\n\ -@deftypefnx {Function File} {} triu (@var{A}, @var{k}, @var{pack})\n\ -See the documentation for the @code{tril} function (@pxref{tril}).\n\ -@end deftypefn") -{ - return do_trilu ("triu", args); -} - -/* -%!test -%! a = [1, 2, 3; 4, 5, 6; 7, 8, 9; 10, 11, 12]; -%! -%! l0 = [1, 0, 0; 4, 5, 0; 7, 8, 9; 10, 11, 12]; -%! l1 = [1, 2, 0; 4, 5, 6; 7, 8, 9; 10, 11, 12]; -%! l2 = [1, 2, 3; 4, 5, 6; 7, 8, 9; 10, 11, 12]; -%! lm1 = [0, 0, 0; 4, 0, 0; 7, 8, 0; 10, 11, 12]; -%! lm2 = [0, 0, 0; 0, 0, 0; 7, 0, 0; 10, 11, 0]; -%! lm3 = [0, 0, 0; 0, 0, 0; 0, 0, 0; 10, 0, 0]; -%! lm4 = [0, 0, 0; 0, 0, 0; 0, 0, 0; 0, 0, 0]; -%! -%! assert (tril (a, -4), lm4); -%! assert (tril (a, -3), lm3); -%! assert (tril (a, -2), lm2); -%! assert (tril (a, -1), lm1); -%! assert (tril (a), l0); -%! assert (tril (a, 1), l1); -%! assert (tril (a, 2), l2); - -%!error tril () -*/
--- a/src/DLD-FUNCTIONS/typecast.cc Sat Jul 28 15:17:57 2012 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,460 +0,0 @@ -/* - -Copyright (C) 2007-2012 David Bateman -Copyright (C) 2009 VZLU Prague - -This file is part of Octave. - -Octave is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 3 of the License, or (at your -option) any later version. - -Octave is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Octave; see the file COPYING. If not, see -<http://www.gnu.org/licenses/>. - -*/ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include "mx-base.h" - -#include "defun-dld.h" -#include "error.h" -#include "gripes.h" -#include "oct-obj.h" -#include "unwind-prot.h" - -static dim_vector -get_vec_dims (const dim_vector& old_dims, octave_idx_type n) -{ - if (old_dims.length () == 2 && old_dims(0) == 1) - return dim_vector (1, n); - else if (old_dims.length () == 2 && old_dims (0) == 0 && old_dims (1) == 0) - return dim_vector (); - else - return dim_vector (n, 1); -} - -template <class ArrayType> -static void -get_data_and_bytesize (const ArrayType& array, - const void *& data, - octave_idx_type& byte_size, - dim_vector& old_dims, - unwind_protect& frame) -{ - // The array given may be a temporary, constructed from a scalar or sparse - // array. This will ensure the data will be deallocated after we exit. - frame.add_delete (new ArrayType (array)); - - data = reinterpret_cast<const void *> (array.data ()); - byte_size = array.byte_size (); - - old_dims = array.dims (); -} - -template <class ArrayType> -static ArrayType -reinterpret_copy (const void *data, octave_idx_type byte_size, - const dim_vector& old_dims) -{ - typedef typename ArrayType::element_type T; - octave_idx_type n = byte_size / sizeof (T); - - if (n * static_cast<int> (sizeof (T)) == byte_size) - { - ArrayType retval (get_vec_dims (old_dims, n)); - T *dest = retval.fortran_vec (); - std::memcpy (dest, data, n * sizeof (T)); - - return retval; - } - else - { - error ("typecast: incorrect number of input values to make output value"); - return ArrayType (); - } -} - - -DEFUN_DLD (typecast, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} typecast (@var{x}, @var{class})\n\ -Return a new array @var{y} resulting from interpreting the data of\n\ -@var{x} in memory as data of the numeric class @var{class}. Both the class\n\ -of @var{x} and @var{class} must be one of the built-in numeric classes:\n\ -\n\ -@example\n\ -@group\n\ -\"logical\"\n\ -\"char\"\n\ -\"int8\"\n\ -\"int16\"\n\ -\"int32\"\n\ -\"int64\"\n\ -\"uint8\"\n\ -\"uint16\"\n\ -\"uint32\"\n\ -\"uint64\"\n\ -\"double\"\n\ -\"single\"\n\ -\"double complex\"\n\ -\"single complex\"\n\ -@end group\n\ -@end example\n\ -\n\ -@noindent\n\ -the last two are reserved for @var{class}; they indicate that a\n\ -complex-valued result is requested. Complex arrays are stored in memory as\n\ -consecutive pairs of real numbers. The sizes of integer types are given by\n\ -their bit counts. Both logical and char are typically one byte wide;\n\ -however, this is not guaranteed by C++. If your system is IEEE conformant,\n\ -single and double should be 4 bytes and 8 bytes wide, respectively.\n\ -\"logical\" is not allowed for @var{class}. If the input is a row vector,\n\ -the return value is a row vector, otherwise it is a column vector. If the\n\ -bit length of @var{x} is not divisible by that of @var{class}, an error\n\ -occurs.\n\ -\n\ -An example of the use of typecast on a little-endian machine is\n\ -\n\ -@example\n\ -@group\n\ -@var{x} = uint16 ([1, 65535]);\n\ -typecast (@var{x}, \"uint8\")\n\ - @result{} [ 0, 1, 255, 255]\n\ -@end group\n\ -@end example\n\ -@seealso{cast, bitunpack, bitpack, swapbytes}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 2) - { - unwind_protect frame; - const void *data = 0; - octave_idx_type byte_size = 0; - dim_vector old_dims; - - octave_value array = args(0); - - if (array.is_bool_type ()) - get_data_and_bytesize (array.bool_array_value (), data, byte_size, old_dims, frame); - else if (array.is_string ()) - get_data_and_bytesize (array.char_array_value (), data, byte_size, old_dims, frame); - else if (array.is_integer_type ()) - { - if (array.is_int8_type ()) - get_data_and_bytesize (array.int8_array_value (), data, byte_size, old_dims, frame); - else if (array.is_int16_type ()) - get_data_and_bytesize (array.int16_array_value (), data, byte_size, old_dims, frame); - else if (array.is_int32_type ()) - get_data_and_bytesize (array.int32_array_value (), data, byte_size, old_dims, frame); - else if (array.is_int64_type ()) - get_data_and_bytesize (array.int64_array_value (), data, byte_size, old_dims, frame); - else if (array.is_uint8_type ()) - get_data_and_bytesize (array.uint8_array_value (), data, byte_size, old_dims, frame); - else if (array.is_uint16_type ()) - get_data_and_bytesize (array.uint16_array_value (), data, byte_size, old_dims, frame); - else if (array.is_uint32_type ()) - get_data_and_bytesize (array.uint32_array_value (), data, byte_size, old_dims, frame); - else if (array.is_uint64_type ()) - get_data_and_bytesize (array.uint64_array_value (), data, byte_size, old_dims, frame); - else - assert (0); - } - else if (array.is_complex_type ()) - { - if (array.is_single_type ()) - get_data_and_bytesize (array.float_complex_array_value (), data, byte_size, old_dims, frame); - else - get_data_and_bytesize (array.complex_array_value (), data, byte_size, old_dims, frame); - } - else if (array.is_real_type ()) - { - if (array.is_single_type ()) - get_data_and_bytesize (array.float_array_value (), data, byte_size, old_dims, frame); - else - get_data_and_bytesize (array.array_value (), data, byte_size, old_dims, frame); - } - else - error ("typecast: invalid input class: %s", array.class_name ().c_str ()); - - std::string numclass = args(1).string_value (); - - if (error_state || numclass.size () == 0) - ; - else if (numclass == "char") - retval = octave_value (reinterpret_copy<charNDArray> (data, byte_size, old_dims), array.is_dq_string () ? '"' : '\''); - else if (numclass[0] == 'i') - { - if (numclass == "int8") - retval = reinterpret_copy<int8NDArray> (data, byte_size, old_dims); - else if (numclass == "int16") - retval = reinterpret_copy<int16NDArray> (data, byte_size, old_dims); - else if (numclass == "int32") - retval = reinterpret_copy<int32NDArray> (data, byte_size, old_dims); - else if (numclass == "int64") - retval = reinterpret_copy<int64NDArray> (data, byte_size, old_dims); - } - else if (numclass[0] == 'u') - { - if (numclass == "uint8") - retval = reinterpret_copy<uint8NDArray> (data, byte_size, old_dims); - else if (numclass == "uint16") - retval = reinterpret_copy<uint16NDArray> (data, byte_size, old_dims); - else if (numclass == "uint32") - retval = reinterpret_copy<uint32NDArray> (data, byte_size, old_dims); - else if (numclass == "uint64") - retval = reinterpret_copy<uint64NDArray> (data, byte_size, old_dims); - } - else if (numclass == "single") - retval = reinterpret_copy<FloatNDArray> (data, byte_size, old_dims); - else if (numclass == "double") - retval = reinterpret_copy<NDArray> (data, byte_size, old_dims); - else if (numclass == "single complex") - retval = reinterpret_copy<FloatComplexNDArray> (data, byte_size, old_dims); - else if (numclass == "double complex") - retval = reinterpret_copy<ComplexNDArray> (data, byte_size, old_dims); - - if (! error_state && retval.is_undefined ()) - error ("typecast: cannot convert to %s class", numclass.c_str ()); - } - else - print_usage (); - - return retval; -} - -template <class ArrayType> -ArrayType -do_bitpack (const boolNDArray& bitp) -{ - typedef typename ArrayType::element_type T; - octave_idx_type n = bitp.numel () / (sizeof (T) * CHAR_BIT); - - if (n * static_cast<int> (sizeof (T)) * CHAR_BIT == bitp.numel ()) - { - - ArrayType retval (get_vec_dims (bitp.dims (), n)); - - const bool *bits = bitp.fortran_vec (); - char *packed = reinterpret_cast<char *> (retval.fortran_vec ()); - - octave_idx_type m = n * sizeof (T); - - for (octave_idx_type i = 0; i < m; i++) - { - char c = bits[0]; - for (int j = 1; j < CHAR_BIT; j++) - c |= bits[j] << j; - - packed[i] = c; - bits += CHAR_BIT; - } - - return retval; - } - else - { - error ("bitpack: incorrect number of bits to make up output value"); - return ArrayType (); - } -} - -DEFUN_DLD (bitpack, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{y} =} bitpack (@var{x}, @var{class})\n\ -Return a new array @var{y} resulting from interpreting an array\n\ -@var{x} as raw bit patterns for data of the numeric class @var{class}.\n\ -@var{class} must be one of the built-in numeric classes:\n\ -\n\ -@example\n\ -@group\n\ -\"char\"\n\ -\"int8\"\n\ -\"int16\"\n\ -\"int32\"\n\ -\"int64\"\n\ -\"uint8\"\n\ -\"uint16\"\n\ -\"uint32\"\n\ -\"uint64\"\n\ -\"double\"\n\ -\"single\"\n\ -@end group\n\ -@end example\n\ -\n\ -The number of elements of @var{x} should be divisible by the bit length of\n\ -@var{class}. If it is not, excess bits are discarded. Bits come in\n\ -increasing order of significance, i.e., @code{x(1)} is bit 0, @code{x(2)} is\n\ -bit 1, etc. The result is a row vector if @var{x} is a row vector, otherwise\n\ -it is a column vector.\n\ -@seealso{bitunpack, typecast}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 2 && args(0).is_bool_type ()) - { - boolNDArray bitp = args(0).bool_array_value (); - - std::string numclass = args(1).string_value (); - - if (error_state || numclass.size () == 0) - ; - else if (numclass == "char") - retval = octave_value (do_bitpack<charNDArray> (bitp), '\''); - else if (numclass[0] == 'i') - { - if (numclass == "int8") - retval = do_bitpack<int8NDArray> (bitp); - else if (numclass == "int16") - retval = do_bitpack<int16NDArray> (bitp); - else if (numclass == "int32") - retval = do_bitpack<int32NDArray> (bitp); - else if (numclass == "int64") - retval = do_bitpack<int64NDArray> (bitp); - } - else if (numclass[0] == 'u') - { - if (numclass == "uint8") - retval = do_bitpack<uint8NDArray> (bitp); - else if (numclass == "uint16") - retval = do_bitpack<uint16NDArray> (bitp); - else if (numclass == "uint32") - retval = do_bitpack<uint32NDArray> (bitp); - else if (numclass == "uint64") - retval = do_bitpack<uint64NDArray> (bitp); - } - else if (numclass == "single") - retval = do_bitpack<FloatNDArray> (bitp); - else if (numclass == "double") - retval = do_bitpack<NDArray> (bitp); - else if (numclass == "single complex") - retval = do_bitpack<FloatComplexNDArray> (bitp); - else if (numclass == "double complex") - retval = do_bitpack<ComplexNDArray> (bitp); - - if (! error_state && retval.is_undefined ()) - error ("bitpack: cannot pack to %s class", numclass.c_str ()); - } - else - print_usage (); - - return retval; -} - -template <class ArrayType> -boolNDArray -do_bitunpack (const ArrayType& array) -{ - typedef typename ArrayType::element_type T; - octave_idx_type n = array.numel () * sizeof (T) * CHAR_BIT; - - boolNDArray retval (get_vec_dims (array.dims (), n)); - - const char *packed = reinterpret_cast<const char *> (array.fortran_vec ()); - bool *bits = retval.fortran_vec (); - - octave_idx_type m = n / CHAR_BIT; - - for (octave_idx_type i = 0; i < m; i++) - { - char c = packed[i]; - bits[0] = c & 1; - for (int j = 1; j < CHAR_BIT; j++) - bits[j] = (c >>= 1) & 1; - bits += CHAR_BIT; - } - - return retval; -} - -DEFUN_DLD (bitunpack, args, , - "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{y} =} bitunpack (@var{x})\n\ -Return an array @var{y} corresponding to the raw bit patterns of\n\ -@var{x}. @var{x} must belong to one of the built-in numeric classes:\n\ -\n\ -@example\n\ -@group\n\ -\"char\"\n\ -\"int8\"\n\ -\"int16\"\n\ -\"int32\"\n\ -\"int64\"\n\ -\"uint8\"\n\ -\"uint16\"\n\ -\"uint32\"\n\ -\"uint64\"\n\ -\"double\"\n\ -\"single\"\n\ -@end group\n\ -@end example\n\ -\n\ -The result is a row vector if @var{x} is a row vector; otherwise, it is a\n\ -column vector.\n\ -@seealso{bitpack, typecast}\n\ -@end deftypefn") -{ - octave_value retval; - - if (args.length () == 1 && (args(0).is_numeric_type () || args(0).is_string ())) - { - octave_value array = args(0); - - if (array.is_string ()) - retval = do_bitunpack (array.char_array_value ()); - else if (array.is_integer_type ()) - { - if (array.is_int8_type ()) - retval = do_bitunpack (array.int8_array_value ()); - else if (array.is_int16_type ()) - retval = do_bitunpack (array.int16_array_value ()); - else if (array.is_int32_type ()) - retval = do_bitunpack (array.int32_array_value ()); - else if (array.is_int64_type ()) - retval = do_bitunpack (array.int64_array_value ()); - else if (array.is_uint8_type ()) - retval = do_bitunpack (array.uint8_array_value ()); - else if (array.is_uint16_type ()) - retval = do_bitunpack (array.uint16_array_value ()); - else if (array.is_uint32_type ()) - retval = do_bitunpack (array.uint32_array_value ()); - else if (array.is_uint64_type ()) - retval = do_bitunpack (array.uint64_array_value ()); - else - assert (0); - } - else if (array.is_complex_type ()) - { - if (array.is_single_type ()) - retval = do_bitunpack (array.float_complex_array_value ()); - else - retval = do_bitunpack (array.complex_array_value ()); - } - else if (array.is_real_type ()) - { - if (array.is_single_type ()) - retval = do_bitunpack (array.float_array_value ()); - else - retval = do_bitunpack (array.array_value ()); - } - else - error ("bitunpack: invalid input class: %s", array.class_name ().c_str ()); - } - else - print_usage (); - - return retval; -}
--- a/src/Makefile.am Sat Jul 28 15:17:57 2012 +0200 +++ b/src/Makefile.am Sat Jul 28 12:06:34 2012 -0400 @@ -25,6 +25,7 @@ -I../libgnu -I$(top_srcdir)/libgnu \ -I$(top_srcdir)/libcruft/misc \ -I../liboctave -I$(top_srcdir)/liboctave \ + -Icorefcn -I$(srcdir)/corefcn \ -I. -I$(srcdir) \ @CPPFLAGS@ @@ -44,7 +45,7 @@ octave_config_SOURCES = nodist_octave_config_SOURCES = octave-config.cc -octave_config_LDADD = ../libgnu/libgnu.la $(LIBS) +octave_config_LDADD = corefcn/libcorefcn.la ../libgnu/libgnu.la $(LIBS) BUILT_SOURCES_EXTRA = \ mkoctfile.cc \ @@ -231,6 +232,12 @@ pt-walk.h \ pt.h +JIT_INCLUDES = \ + jit-util.h \ + jit-typeinfo.h \ + jit-ir.h \ + pt-jit.h + octinclude_HEADERS = \ Cell.h \ builtins.h \ @@ -309,7 +316,8 @@ zfstream.h \ $(OV_INCLUDES) \ $(OV_SPARSE_INCLUDES) \ - $(PT_INCLUDES) + $(PT_INCLUDES) \ + $(JIT_INCLUDES) nodist_octinclude_HEADERS = \ defaults.h \ @@ -402,6 +410,16 @@ pt-unop.cc \ pt.cc +JIT_SRC = \ + jit-util.cc \ + jit-typeinfo.cc \ + jit-ir.cc \ + pt-jit.cc + +#noinst_LTLIBRARIES = +# +#include corefcn/module.mk +# DIST_SRC = \ Cell.cc \ bitfcns.cc \ @@ -473,9 +491,14 @@ xnorm.cc \ xpow.cc \ zfstream.cc \ + $(corefcn_SRC) \ $(OV_SRC) \ - $(PT_SRC) + $(PT_SRC) \ + $(JIT_SRC) +noinst_LTLIBRARIES = + +include corefcn/module.mk include DLD-FUNCTIONS/module.mk $(srcdir)/DLD-FUNCTIONS/module.mk: $(srcdir)/DLD-FUNCTIONS/config-module.sh $(srcdir)/DLD-FUNCTIONS/config-module.awk $(srcdir)/DLD-FUNCTIONS/module-files @@ -534,6 +557,9 @@ display.df display.lo: CPPFLAGS += $(X11_FLAGS) +## FIXME: Does this rule need to be uncommented? +#fft.df fft.lo fft2.df fft2.lo fftn.df fftn.lo: CPPFLAGS += $(FFTW_XCPPFLAGS) + octave_SOURCES = main.c octave_LDADD = \
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/TEMPLATE-INST/Array-jit.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,40 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#ifdef HAVE_LLVM + +#include "Array.h" +#include "Array.cc" + +extern template class OCTAVE_API Array<octave_idx_type>; + +#include "pt-jit.h" + +NO_INSTANTIATE_ARRAY_SORT (jit_function); + +INSTANTIATE_ARRAY (jit_function, OCTINTERP_API); + +#endif
--- a/src/TEMPLATE-INST/module.mk Sat Jul 28 15:17:57 2012 +0200 +++ b/src/TEMPLATE-INST/module.mk Sat Jul 28 12:06:34 2012 -0400 @@ -2,4 +2,5 @@ TEMPLATE_INST_SRC = \ TEMPLATE-INST/Array-os.cc \ - TEMPLATE-INST/Array-tc.cc + TEMPLATE-INST/Array-tc.cc \ + TEMPLATE-INST/Array-jit.cc
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/__contourc__.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,340 @@ +/* Contour lines for function evaluated on a grid. + +Copyright (C) 2007-2012 Kai Habel +Copyright (C) 2004, 2007 Shai Ayal + +Adapted to an oct file from the stand alone contourl by Victro Munoz +Copyright (C) 2004 Victor Munoz + +Based on contour plot routine (plcont.c) in PLPlot package +http://plplot.org/ + +Copyright (C) 1995, 2000, 2001 Maurice LeBrun +Copyright (C) 2000, 2002 Joao Cardoso +Copyright (C) 2000, 2001, 2002, 2004 Alan W. Irwin +Copyright (C) 2004 Andrew Ross + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <cfloat> + +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" + +static Matrix this_contour; +static Matrix contourc; +static int elem; + +// This is the quanta in which we increase this_contour. +#define CONTOUR_QUANT 50 + +// Add a coordinate point (x,y) to this_contour. + +static void +add_point (double x, double y) +{ + if (elem % CONTOUR_QUANT == 0) + this_contour = this_contour.append (Matrix (2, CONTOUR_QUANT, 0)); + + this_contour (0, elem) = x; + this_contour (1, elem) = y; + elem++; +} + +// Add contents of current contour to contourc. +// this_contour.cols () - 1; + +static void +end_contour (void) +{ + if (elem > 2) + { + this_contour (1, 0) = elem - 1; + contourc = contourc.append (this_contour.extract_n (0, 0, 2, elem)); + } + + this_contour = Matrix (); + elem = 0; +} + +// Start a new contour, and add contents of current one to contourc. + +static void +start_contour (double lvl, double x, double y) +{ + end_contour (); + this_contour.resize (2, 0); + add_point (lvl, 0); + add_point (x, y); +} + +static void +drawcn (const RowVector& X, const RowVector& Y, const Matrix& Z, + double lvl, int r, int c, double ct_x, double ct_y, + unsigned int start_edge, bool first, charMatrix& mark) +{ + double px[4], py[4], pz[4], tmp; + unsigned int stop_edge, next_edge, pt[2]; + int next_r, next_c; + + //get x, y, and z - lvl for current facet + px[0] = px[3] = X(c); + px[1] = px[2] = X(c+1); + + py[0] = py[1] = Y(r); + py[2] = py[3] = Y(r+1); + + pz[3] = Z(r+1, c) - lvl; + pz[2] = Z(r+1, c + 1) - lvl; + pz[1] = Z(r, c+1) - lvl; + pz[0] = Z(r, c) - lvl; + + // Facet edge and point naming assignment. + // + // 0-----1 .-0-. + // | | | | + // | | 3 1 + // | | | | + // 3-----2 .-2-. + + // Get mark value of current facet. + char id = static_cast<char> (mark(r, c)); + + // Check startedge s. + if (start_edge == 255) + { + // Find start edge. + for (unsigned int k = 0; k < 4; k++) + if (static_cast<char> (1 << k) & id) + start_edge = k; + } + + if (start_edge == 255) + return; + + // Decrease mark value of current facet for start edge. + mark(r, c) -= static_cast<char> (1 << start_edge); + + // Next point (clockwise). + pt[0] = start_edge; + pt[1] = (pt[0] + 1) % 4; + + // Calculate contour segment start if first of contour. + if (first) + { + tmp = fabs (pz[pt[1]]) / fabs (pz[pt[0]]); + + if (xisnan (tmp)) + ct_x = ct_y = 0.5; + else + { + ct_x = px[pt[0]] + (px[pt[1]] - px[pt[0]])/(1 + tmp); + ct_y = py[pt[0]] + (py[pt[1]] - py[pt[0]])/(1 + tmp); + } + + start_contour (lvl, ct_x, ct_y); + } + + // Find stop edge. + // FIXME -- perhaps this should use a while loop? + for (unsigned int k = 1; k <= 4; k++) + { + if (start_edge == 0 || start_edge == 2) + stop_edge = (start_edge + k) % 4; + else + stop_edge = (start_edge - k) % 4; + + if (static_cast<char> (1 << stop_edge) & id) + break; + } + + pt[0] = stop_edge; + pt[1] = (pt[0] + 1) % 4; + tmp = fabs (pz[pt[1]]) / fabs (pz[pt[0]]); + + if (xisnan (tmp)) + ct_x = ct_y = 0.5; + else + { + ct_x = px[pt[0]] + (px[pt[1]] - px[pt[0]])/(1 + tmp); + ct_y = py[pt[0]] + (py[pt[1]] - py[pt[0]])/(1 + tmp); + } + + // Add point to contour. + add_point (ct_x, ct_y); + + // Decrease id value of current facet for start edge. + mark(r, c) -= static_cast<char> (1 << stop_edge); + + // Find next facet. + next_c = c; + next_r = r; + + if (stop_edge == 0) + next_r--; + else if (stop_edge == 1) + next_c++; + else if (stop_edge == 2) + next_r++; + else if (stop_edge == 3) + next_c--; + + // Check if next facet is not done yet. + // Go to next facet. + if (next_r >= 0 && next_c >= 0 && next_r < mark.rows () + && next_c < mark.cols () && mark(next_r, next_c) > 0) + { + next_edge = (stop_edge + 2) % 4; + drawcn (X, Y, Z, lvl, next_r, next_c, ct_x, ct_y, next_edge, false, mark); + } +} + +static void +mark_facets (const Matrix& Z, charMatrix& mark, double lvl) +{ + unsigned int nr = mark.rows (); + unsigned int nc = mark.cols (); + + double f[4]; + + for (unsigned int c = 0; c < nc; c++) + for (unsigned int r = 0; r < nr; r++) + { + f[0] = Z(r, c) - lvl; + f[1] = Z(r, c+1) - lvl; + f[3] = Z(r+1, c) - lvl; + f[2] = Z(r+1, c+1) - lvl; + + for (unsigned int i = 0; i < 4; i++) + if (fabs(f[i]) < DBL_EPSILON) + f[i] = DBL_EPSILON; + + if (f[1] * f[2] < 0) + mark(r, c) += 2; + + if (f[0] * f[3] < 0) + mark(r, c) += 8; + } + + for (unsigned int r = 0; r < nr; r++) + for (unsigned int c = 0; c < nc; c++) + { + f[0] = Z(r, c) - lvl; + f[1] = Z(r, c+1) - lvl; + f[3] = Z(r+1, c) - lvl; + f[2] = Z(r+1, c+1) - lvl; + + for (unsigned int i = 0; i < 4; i++) + if (fabs(f[i]) < DBL_EPSILON) + f[i] = DBL_EPSILON; + + if (f[0] * f[1] < 0) + mark(r, c) += 1; + + if (f[2] * f[3] < 0) + mark(r, c) += 4; + } +} + +static void +cntr (const RowVector& X, const RowVector& Y, const Matrix& Z, double lvl) +{ + unsigned int nr = Z.rows (); + unsigned int nc = Z.cols (); + + charMatrix mark (nr - 1, nc - 1, 0); + + mark_facets (Z, mark, lvl); + + // Find contours that start at a domain edge. + + for (unsigned int c = 0; c < nc - 1; c++) + { + // Top. + if (mark(0, c) & 1) + drawcn (X, Y, Z, lvl, 0, c, 0.0, 0.0, 0, true, mark); + + // Bottom. + if (mark(nr - 2, c) & 4) + drawcn (X, Y, Z, lvl, nr - 2, c, 0.0, 0.0, 2, true, mark); + } + + for (unsigned int r = 0; r < nr - 1; r++) + { + // Left. + if (mark(r, 0) & 8) + drawcn (X, Y, Z, lvl, r, 0, 0.0, 0.0, 3, true, mark); + + // Right. + if (mark(r, nc - 2) & 2) + drawcn (X, Y, Z, lvl, r, nc - 2, 0.0, 0.0, 1, true, mark); + } + + for (unsigned int r = 0; r < nr - 1; r++) + for (unsigned int c = 0; c < nc - 1; c++) + if (mark (r, c) > 0) + drawcn (X, Y, Z, lvl, r, c, 0.0, 0.0, 255, true, mark); +} + +DEFUN (__contourc__, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} __contourc__ (@var{x}, @var{y}, @var{z}, @var{levels})\n\ +Undocumented internal function.\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 4) + { + RowVector X = args (0).row_vector_value (); + RowVector Y = args (1).row_vector_value (); + Matrix Z = args (2).matrix_value (); + RowVector L = args (3).row_vector_value (); + + if (! error_state) + { + contourc.resize (2, 0); + + for (int i = 0; i < L.length (); i++) + cntr (X, Y, Z, L (i)); + + end_contour (); + + retval = contourc; + } + else + error ("__contourc__: invalid argument values"); + } + else + print_usage (); + + return retval; +} + +/* +## No test needed for internal helper function. +%!assert (1) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/__dispatch__.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,136 @@ +/* + +Copyright (C) 2001-2012 John W. Eaton and Paul Kienzle + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <list> +#include <map> +#include <string> + +#include "Cell.h" +#include "oct-map.h" +#include "defun.h" +#include "ov.h" +#include "ov-fcn.h" +#include "ov-typeinfo.h" +#include "pager.h" +#include "parse.h" +#include "symtab.h" +#include "variables.h" + +DEFUN (__dispatch__, args, nargout, + "Undocumented internal function") +{ + octave_value retval; + + int nargin = args.length (); + + std::string f, r, t; + + if (nargin > 0 && nargin < 4) + { + if (nargin > 0) + { + f = args(0).string_value (); + + if (error_state) + { + error ("__dispatch__: first argument must be a function name"); + return retval; + } + } + + if (nargin > 1) + { + r = args(1).string_value (); + + if (error_state) + { + error ("__dispatch__: second argument must be a function name"); + return retval; + } + } + + if (nargin > 2) + { + t = args(2).string_value (); + + if (error_state) + { + error ("__dispatch__: third argument must be a type name"); + return retval; + } + } + + if (nargin == 1) + { + if (nargout > 0) + { + symbol_table::fcn_info::dispatch_map_type dm + = symbol_table::get_dispatch (f); + + size_t len = dm.size (); + + Cell type_field (len, 1); + Cell name_field (len, 1); + + symbol_table::fcn_info::dispatch_map_type::const_iterator p + = dm.begin (); + + for (size_t i = 0; i < len; i++) + { + type_field(i) = p->first; + name_field(i) = p->second; + + p++; + } + + octave_scalar_map m; + + m.assign ("type", type_field); + m.assign ("name", name_field); + + retval = m; + } + else + symbol_table::print_dispatch (octave_stdout, f); + } + else if (nargin == 2) + { + t = r; + symbol_table::clear_dispatch (f, t); + } + else + symbol_table::add_dispatch (f, t, r); + } + else + print_usage (); + + return retval; +} + +/* +## No test needed for internal helper function. +%!assert (1) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/__lin_interpn__.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,362 @@ +/* + +Copyright (C) 2007-2012 Alexander Barth + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-ieee.h" +#include "dNDArray.h" +#include "oct-locbuf.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" + +// equivalent to isvector.m + +template <class T> +bool +isvector (const T& array) +{ + const dim_vector dv = array.dims (); + return dv.length () == 2 && (dv(0) == 1 || dv(1) == 1); +} + +// lookup a value in a sorted table (lookup.m) +template <class T> +octave_idx_type +lookup (const T *x, octave_idx_type n, T y) +{ + octave_idx_type j; + + if (x[0] < x[n-1]) + { + // increasing x + + if (y > x[n-1] || y < x[0]) + return -1; + +#ifdef EXHAUSTIF + for (j = 0; j < n - 1; j++) + { + if (x[j] <= y && y <= x[j+1]) + return j; + } +#else + octave_idx_type j0 = 0; + octave_idx_type j1 = n - 1; + + while (true) + { + j = (j0+j1)/2; + + if (y <= x[j+1]) + { + if (x[j] <= y) + return j; + + j1 = j; + } + + if (x[j] <= y) + j0 = j; + } +#endif + } + else + { + // decreasing x + // previous code with x -> -x and y -> -y + + if (y > x[0] || y < x[n-1]) + return -1; + +#ifdef EXHAUSTIF + for (j = 0; j < n - 1; j++) + { + if (x[j+1] <= y && y <= x[j]) + return j; + } +#else + octave_idx_type j0 = 0; + octave_idx_type j1 = n - 1; + + while (true) + { + j = (j0+j1)/2; + + if (y >= x[j+1]) + { + if (x[j] >= y) + return j; + + j1 = j; + } + + if (x[j] >= y) + j0 = j; + } +#endif + } +} + +// n-dimensional linear interpolation + +template <class T> +void +lin_interpn (int n, const octave_idx_type *size, const octave_idx_type *scale, + octave_idx_type Ni, T extrapval, const T **x, + const T *v, const T **y, T *vi) +{ + bool out = false; + int bit; + + OCTAVE_LOCAL_BUFFER (T, coef, 2*n); + OCTAVE_LOCAL_BUFFER (octave_idx_type, index, n); + + // loop over all points + for (octave_idx_type m = 0; m < Ni; m++) + { + // loop over all dimensions + for (int i = 0; i < n; i++) + { + index[i] = lookup (x[i], size[i], y[i][m]); + out = index[i] == -1; + + if (out) + break; + else + { + octave_idx_type j = index[i]; + coef[2*i+1] = (y[i][m] - x[i][j])/(x[i][j+1] - x[i][j]); + coef[2*i] = 1 - coef[2*i+1]; + } + } + + + if (out) + vi[m] = extrapval; + else + { + vi[m] = 0; + + // loop over all corners of hypercube (1<<n = 2^n) + for (int i = 0; i < (1 << n); i++) + { + T c = 1; + octave_idx_type l = 0; + + // loop over all dimensions + for (int j = 0; j < n; j++) + { + // test if the jth bit in i is set + bit = i >> j & 1; + l += scale[j] * (index[j] + bit); + c *= coef[2*j+bit]; + } + + vi[m] += c * v[l]; + } + } + } +} + +template <class T, class M> +octave_value +lin_interpn (int n, M *X, const M V, M *Y) +{ + octave_value retval; + + M Vi = M (Y[0].dims ()); + + OCTAVE_LOCAL_BUFFER (const T *, y, n); + OCTAVE_LOCAL_BUFFER (octave_idx_type, size, n); + + for (int i = 0; i < n; i++) + { + y[i] = Y[i].data (); + size[i] = V.dims ()(i); + } + + OCTAVE_LOCAL_BUFFER (const T *, x, n); + OCTAVE_LOCAL_BUFFER (octave_idx_type, scale, n); + + const T *v = V.data (); + T *vi = Vi.fortran_vec (); + octave_idx_type Ni = Vi.numel (); + + T extrapval = octave_NA; + + // offset in memory of each dimension + + scale[0] = 1; + + for (int i = 1; i < n; i++) + scale[i] = scale[i-1] * size[i-1]; + + // tests if X[0] is a vector, if yes, assume that all elements of X are + // in the ndgrid format. + + if (! isvector (X[0])) + { + for (int i = 0; i < n; i++) + { + if (X[i].dims () != V.dims ()) + { + error ("interpn: incompatible size of argument number %d", i+1); + return retval; + } + else + { + M tmp = M (dim_vector (size[i], 1)); + + for (octave_idx_type j = 0; j < size[i]; j++) + tmp(j) = X[i](scale[i]*j); + + X[i] = tmp; + } + } + } + + for (int i = 0; i < n; i++) + { + if (! isvector (X[i]) && X[i].numel () != size[i]) + { + error ("interpn: incompatible size of argument number %d", i+1); + return retval; + } + else + x[i] = X[i].data (); + } + + lin_interpn (n, size, scale, Ni, extrapval, x, v, y, vi); + + retval = Vi; + + return retval; +} + +// Perform @var{n}-dimensional interpolation. Each element of then +// @var{n}-dimensional array @var{v} represents a value at a location +// given by the parameters @var{x1}, @var{x2},...,@var{xn}. The parameters +// @var{x1}, @var{x2}, @dots{}, @var{xn} are either @var{n}-dimensional +// arrays of the same size as the array @var{v} in the \"ndgrid\" format +// or vectors. The parameters @var{y1}, @var{y2}, @dots{}, @var{yn} are +// all @var{n}-dimensional arrays of the same size and represent the +// points at which the array @var{vi} is interpolated. +// +//This function only performs linear interpolation. + +DEFUN (__lin_interpn__, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{vi} =} __lin_interpn__ (@var{x1}, @var{x2}, @dots{}, @var{xn}, @var{v}, @var{y1}, @var{y2}, @dots{}, @var{yn})\n\ +Undocumented internal function.\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 2 || nargin % 2 == 0) + { + print_usage (); + return retval; + } + + // dimension of the problem + int n = (nargin-1)/2; + + if (args(n).is_single_type ()) + { + OCTAVE_LOCAL_BUFFER (FloatNDArray, X, n); + OCTAVE_LOCAL_BUFFER (FloatNDArray, Y, n); + + const FloatNDArray V = args(n).float_array_value (); + + if (error_state) + { + print_usage (); + return retval; + } + + for (int i = 0; i < n; i++) + { + X[i] = args(i).float_array_value (); + Y[i] = args(n+i+1).float_array_value (); + + if (error_state) + { + print_usage (); + return retval; + } + + if (Y[0].dims () != Y[i].dims ()) + { + error ("interpn: incompatible size of argument number %d", n+i+2); + return retval; + } + } + + retval = lin_interpn<float, FloatNDArray> (n, X, V, Y); + } + else + { + OCTAVE_LOCAL_BUFFER (NDArray, X, n); + OCTAVE_LOCAL_BUFFER (NDArray, Y, n); + + const NDArray V = args(n).array_value (); + + if (error_state) + { + print_usage (); + return retval; + } + + for (int i = 0; i < n; i++) + { + X[i] = args(i).array_value (); + Y[i] = args(n+i+1).array_value (); + + if (error_state) + { + print_usage (); + return retval; + } + + if (Y[0].dims () != Y[i].dims ()) + { + error ("interpn: incompatible size of argument number %d", n+i+2); + return retval; + } + } + + retval = lin_interpn<double, NDArray> (n, X, V, Y); + } + + return retval; +} + +/* +## No test needed for internal helper function. +%!assert (1) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/__pchip_deriv__.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,168 @@ +/* + +Copyright (C) 2002-2012 Kai Habel +Copyright (C) 2008-2009 Jaroslav Hajek + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" +#include "f77-fcn.h" + +extern "C" +{ + F77_RET_T + F77_FUNC (dpchim, DPCHIM) (const octave_idx_type& n, const double *x, + const double *f, double *d, + const octave_idx_type &incfd, + octave_idx_type *ierr); + + F77_RET_T + F77_FUNC (pchim, PCHIM) (const octave_idx_type& n, const float *x, + const float *f, float *d, + const octave_idx_type& incfd, + octave_idx_type *ierr); +} + +// Wrapper for SLATEC/PCHIP function DPCHIM to calculate the derivates +// for piecewise polynomials. + +DEFUN (__pchip_deriv__, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} __pchip_deriv__ (@var{x}, @var{y}, @var{dim})\n\ +Undocumented internal function.\n\ +@end deftypefn") +{ + octave_value retval; + const int nargin = args.length (); + + bool rows = (nargin == 3 && args (2).uint_value () == 2); + + if (nargin >= 2) + { + if (args(0).is_single_type () || args(1).is_single_type ()) + { + FloatColumnVector xvec (args(0).float_vector_value ()); + FloatMatrix ymat (args(1).float_matrix_value ()); + + octave_idx_type nx = xvec.length (); + + if (nx < 2) + { + error ("__pchip_deriv__: X must be at least of length 2"); + return retval; + } + + octave_idx_type nyr = ymat.rows (); + octave_idx_type nyc = ymat.columns (); + + if (nx != (rows ? nyc : nyr)) + { + error ("__pchip_deriv__: X and Y dimension mismatch"); + return retval; + } + + const float *yvec = ymat.data (); + FloatMatrix dmat (nyr, nyc); + float *dvec = dmat.fortran_vec (); + + octave_idx_type ierr; + const octave_idx_type incfd = rows ? nyr : 1; + const octave_idx_type inc = rows ? 1 : nyr; + + for (octave_idx_type i = (rows ? nyr : nyc); i > 0; i--) + { + F77_FUNC (pchim, PCHIM) (nx, xvec.data (), + yvec, dvec, incfd, &ierr); + + yvec += inc; + dvec += inc; + + if (ierr < 0) + { + error ("PCHIM: error: %i\n", ierr); + return retval; + } + } + + retval = dmat; + } + else + { + ColumnVector xvec (args(0).vector_value ()); + Matrix ymat (args(1).matrix_value ()); + + octave_idx_type nx = xvec.length (); + + if (nx < 2) + { + error ("__pchip_deriv__: X must be at least of length 2"); + return retval; + } + + octave_idx_type nyr = ymat.rows (); + octave_idx_type nyc = ymat.columns (); + + if (nx != (rows ? nyc : nyr)) + { + error ("__pchip_deriv__: X and Y dimension mismatch"); + return retval; + } + + const double *yvec = ymat.data (); + Matrix dmat (nyr, nyc); + double *dvec = dmat.fortran_vec (); + + octave_idx_type ierr; + const octave_idx_type incfd = rows ? nyr : 1; + const octave_idx_type inc = rows ? 1 : nyr; + + for (octave_idx_type i = (rows ? nyr : nyc); i > 0; i--) + { + F77_FUNC (dpchim, DPCHIM) (nx, xvec.data (), + yvec, dvec, incfd, &ierr); + + yvec += inc; + dvec += inc; + + if (ierr < 0) + { + error ("DPCHIM: error: %i\n", ierr); + return retval; + } + } + + retval = dmat; + } + } + + return retval; +} + +/* +## No test needed for internal helper function. +%!assert (1) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/__qp__.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,535 @@ +/* + +Copyright (C) 2000-2012 Gabriele Pannocchia + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <cfloat> + +#include "dbleCHOL.h" +#include "dbleSVD.h" +#include "mx-m-dm.h" +#include "EIG.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "pr-output.h" +#include "utils.h" + +static Matrix +null (const Matrix& A, octave_idx_type& rank) +{ + Matrix retval; + + rank = 0; + + if (! A.is_empty ()) + { + SVD A_svd (A); + + DiagMatrix S = A_svd.singular_values (); + + ColumnVector s = S.diag (); + + Matrix V = A_svd.right_singular_matrix (); + + octave_idx_type A_nr = A.rows (); + octave_idx_type A_nc = A.cols (); + + octave_idx_type tmp = A_nr > A_nc ? A_nr : A_nc; + + double tol = tmp * s(0) * DBL_EPSILON; + + octave_idx_type n = s.length (); + + for (octave_idx_type i = 0; i < n; i++) + { + if (s(i) > tol) + rank++; + } + + if (rank < A_nc) + retval = V.extract (0, rank, A_nc-1, A_nc-1); + else + retval.resize (A_nc, 0); + + for (octave_idx_type i = 0; i < retval.numel (); i++) + if (std::abs (retval(i)) < DBL_EPSILON) + retval(i) = 0; + } + + return retval; +} + +static int +qp (const Matrix& H, const ColumnVector& q, + const Matrix& Aeq, const ColumnVector& beq, + const Matrix& Ain, const ColumnVector& bin, + int maxit, + ColumnVector& x, ColumnVector& lambda, int& iter) +{ + int info = 0; + + iter = 0; + + double rtol = sqrt (DBL_EPSILON); + + // Problem dimension. + octave_idx_type n = x.length (); + + // Dimension of constraints. + octave_idx_type n_eq = beq.length (); + octave_idx_type n_in = bin.length (); + + // Filling the current active set. + + octave_idx_type n_act = n_eq; + + octave_idx_type n_tot = n_eq + n_in; + + // Equality constraints come first. We won't check the sign of the + // Lagrange multiplier for those. + + Matrix Aact = Aeq; + ColumnVector bact = beq; + ColumnVector Wact; + + if (n_in > 0) + { + ColumnVector res = Ain*x - bin; + + for (octave_idx_type i = 0; i < n_in; i++) + { + res(i) /= (1.0 + std::abs (bin(i))); + + if (res(i) < rtol) + { + n_act++; + Aact = Aact.stack (Ain.row (i)); + bact.resize (n_act, bin(i)); + Wact.resize (n_act-n_eq, i); + } + } + } + + // Computing the ??? + + EIG eigH (H); + + if (error_state) + { + error ("qp: failed to compute eigenvalues of H"); + return -1; + } + + ColumnVector eigenvalH = real (eigH.eigenvalues ()); + Matrix eigenvecH = real (eigH.eigenvectors ()); + double minReal = eigenvalH.min (); + octave_idx_type indminR = 0; + for (octave_idx_type i = 0; i < n; i++) + { + if (minReal == eigenvalH(i)) + { + indminR = i; + break; + } + } + + bool done = false; + + double alpha = 0.0; + + Matrix R; + Matrix Y (n, 0, 0.0); + + ColumnVector g (n, 0.0); + ColumnVector p (n, 0.0); + + ColumnVector lambda_tmp (n_in, 0.0); + + while (! done) + { + iter++; + + // Current Gradient + // g = q + H * x; + + g = q + H * x; + + if (n_act == 0) + { + // There are no active constraints. + + if (minReal > 0.0) + { + // Inverting the Hessian. Using the Cholesky + // factorization since the Hessian is positive + // definite. + + CHOL cholH (H); + + R = cholH.chol_matrix (); + + Matrix Hinv = chol2inv (R); + + // Computing the unconstrained step. + // p = -Hinv * g; + + p = -Hinv * g; + + info = 0; + } + else + { + // Finding the negative curvature of H. + + p = eigenvecH.column (indminR); + + // Following the negative curvature of H. + + if (p.transpose () * g > DBL_EPSILON) + p = -p; + + info = 1; + } + + // Multipliers are zero. + lambda_tmp.fill (0.0); + } + else + { + // There are active constraints. + + // Computing the null space. + + octave_idx_type rank; + + Matrix Z = null (Aact, rank); + + octave_idx_type dimZ = n - rank; + + // FIXME -- still remain to handle the case of + // non-full rank active set matrix. + + // Computing the Y matrix (orthogonal to Z) + Y = Aact.pseudo_inverse (); + + // Reduced Hessian + Matrix Zt = Z.transpose (); + Matrix rH = Zt * H * Z; + + octave_idx_type pR = 0; + + if (dimZ > 0) + { + // Computing the Cholesky factorization (pR = 0 means + // that the reduced Hessian was positive definite). + + CHOL cholrH (rH, pR); + Matrix tR = cholrH.chol_matrix (); + if (pR == 0) + R = tR; + } + + if (pR == 0) + { + info = 0; + + // Computing the step pz. + if (dimZ > 0) + { + // Using the Cholesky factorization to invert rH + + Matrix rHinv = chol2inv (R); + + ColumnVector pz = -rHinv * Zt * g; + + // Global step. + p = Z * pz; + } + else + { + // Global step. + p.fill (0.0); + } + } + else + { + info = 1; + + // Searching for the most negative curvature. + + EIG eigrH (rH); + + if (error_state) + { + error ("qp: failed to compute eigenvalues of rH"); + return -1; + } + + ColumnVector eigenvalrH = real (eigrH.eigenvalues ()); + Matrix eigenvecrH = real (eigrH.eigenvectors ()); + double mRrH = eigenvalrH.min (); + indminR = 0; + for (octave_idx_type i = 0; i < n; i++) + { + if (mRrH == eigenvalH(i)) + { + indminR = i; + break; + } + } + + ColumnVector eVrH = eigenvecrH.column (indminR); + + // Computing the step pz. + p = Z * eVrH; + + if (p.transpose () * g > DBL_EPSILON) + p = -p; + } + } + + // Checking the step-size. + ColumnVector abs_p (n); + for (octave_idx_type i = 0; i < n; i++) + abs_p(i) = std::abs (p(i)); + double max_p = abs_p.max (); + + if (max_p < rtol) + { + // The step is null. Checking constraints. + if (n_act - n_eq == 0) + // Solution is found because no inequality + // constraints are active. + done = true; + else + { + // Computing the multipliers only for the inequality + // constraints that are active. We do NOT compute + // multipliers for the equality constraints. + Matrix Yt = Y.transpose (); + Yt = Yt.extract_n (n_eq, 0, n_act-n_eq, n); + lambda_tmp = Yt * (g + H * p); + + // Checking the multipliers. We remove the most + // negative from the set (if any). + double min_lambda = lambda_tmp.min (); + if (min_lambda >= 0) + { + // Solution is found. + done = true; + } + else + { + octave_idx_type which_eig = 0; + for (octave_idx_type i = 0; i < n_act; i++) + { + if (lambda_tmp(i) == min_lambda) + { + which_eig = i; + break; + } + } + + // At least one multiplier is negative, we + // remove it from the set. + + n_act--; + for (octave_idx_type i = which_eig; i < n_act - n_eq; i++) + { + Wact(i) = Wact(i+1); + for (octave_idx_type j = 0; j < n; j++) + Aact(n_eq+i,j) = Aact(n_eq+i+1,j); + bact(n_eq+i) = bact(n_eq+i+1); + } + + // Resizing the active set. + Wact.resize (n_act-n_eq); + bact.resize (n_act); + Aact.resize (n_act, n); + } + } + } + else + { + // The step is not null. + if (n_act - n_eq == n_in) + { + // All inequality constraints were active. We can + // add the whole step. + x += p; + } + else + { + // Some constraints were not active. Checking if + // there is a blocking constraint. + alpha = 1.0; + octave_idx_type is_block = -1; + + for (octave_idx_type i = 0; i < n_in; i++) + { + bool found = false; + + for (octave_idx_type j = 0; j < n_act-n_eq; j++) + { + if (Wact(j) == i) + { + found = true; + break; + } + } + + if (! found) + { + // The i-th constraint was not in the set. Is it a + // blocking constraint? + + RowVector tmp_row = Ain.row (i); + double tmp = tmp_row * p; + double res = tmp_row * x; + + if (tmp < 0.0) + { + double alpha_tmp = (bin(i) - res) / tmp; + + if (alpha_tmp < alpha) + { + alpha = alpha_tmp; + is_block = i; + } + } + } + } + + // In is_block there is the index of the blocking + // constraint (if any). + if (is_block >= 0) + { + // There is a blocking constraint (index in + // is_block) which is added to the active set. + n_act++; + Aact = Aact.stack (Ain.row (is_block)); + bact.resize (n_act, bin(is_block)); + Wact.resize (n_act-n_eq, is_block); + + // Adding the reduced step + x += alpha * p; + } + else + { + // There are no blocking constraints. Adding the + // whole step. + x += alpha * p; + } + } + } + + if (iter == maxit) + { + done = true; + // warning ("qp_main: maximum number of iteration reached"); + info = 3; + } + } + + lambda_tmp = Y.transpose () * (g + H * p); + + // Reordering the Lagrange multipliers. + + lambda.resize (n_tot); + lambda.fill (0.0); + for (octave_idx_type i = 0; i < n_eq; i++) + lambda(i) = lambda_tmp(i); + + for (octave_idx_type i = n_eq; i < n_tot; i++) + { + for (octave_idx_type j = 0; j < n_act-n_eq; j++) + { + if (Wact(j) == i - n_eq) + { + lambda(i) = lambda_tmp(n_eq+j); + break; + } + } + } + + return info; +} + +DEFUN (__qp__, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{x}, @var{lambda}, @var{info}, @var{iter}] =} __qp__ (@var{x0}, @var{H}, @var{q}, @var{Aeq}, @var{beq}, @var{Ain}, @var{bin}, @var{maxit})\n\ +Undocumented internal function.\n\ +@end deftypefn") +{ + octave_value_list retval; + + if (args.length () == 8) + { + const ColumnVector x0 (args(0) . vector_value ()); + const Matrix H (args(1) . matrix_value ()); + const ColumnVector q (args(2) . vector_value ()); + const Matrix Aeq (args(3) . matrix_value ()); + const ColumnVector beq (args(4) . vector_value ()); + const Matrix Ain (args(5) . matrix_value ()); + const ColumnVector bin (args(6) . vector_value ()); + const int maxit (args(7) . int_value ()); + + if (! error_state) + { + int iter = 0; + + // Copying the initial guess in the working variable + ColumnVector x = x0; + + // Reordering the Lagrange multipliers + ColumnVector lambda; + + int info = qp (H, q, Aeq, beq, Ain, bin, maxit, x, lambda, iter); + + if (! error_state) + { + retval(3) = iter; + retval(2) = info; + retval(1) = lambda; + retval(0) = x; + } + else + error ("qp: internal error"); + } + else + error ("__qp__: invalid arguments"); + } + else + print_usage (); + + return retval; +} + +/* +## No test needed for internal helper function. +%!assert (1) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/balance.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,389 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton +Copyright (C) 2008-2009 Jaroslav Hajek + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Author: A. S. Hodel <scotte@eng.auburn.edu> + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include "CmplxAEPBAL.h" +#include "fCmplxAEPBAL.h" +#include "dbleAEPBAL.h" +#include "floatAEPBAL.h" +#include "CmplxGEPBAL.h" +#include "fCmplxGEPBAL.h" +#include "dbleGEPBAL.h" +#include "floatGEPBAL.h" +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "f77-fcn.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (balance, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{AA} =} balance (@var{A})\n\ +@deftypefnx {Built-in Function} {@var{AA} =} balance (@var{A}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{DD}, @var{AA}] =} balance (@var{A}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{D}, @var{P}, @var{AA}] =} balance (@var{A}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{CC}, @var{DD}, @var{AA}, @var{BB}] =} balance (@var{A}, @var{B}, @var{opt})\n\ +\n\ +Compute @code{@var{AA} = @var{DD} \\ @var{A} * @var{DD}} in which @var{AA}\n\ +is a matrix whose row and column norms are roughly equal in magnitude, and\n\ +@code{@var{DD} = @var{P} * @var{D}}, in which @var{P} is a permutation\n\ +matrix and @var{D} is a diagonal matrix of powers of two. This allows the\n\ +equilibration to be computed without round-off. Results of eigenvalue\n\ +calculation are typically improved by balancing first.\n\ +\n\ +If two output values are requested, @code{balance} returns\n\ +the diagonal @var{D} and the permutation @var{P} separately as vectors.\n\ +In this case, @code{@var{DD} = eye(n)(:,@var{P}) * diag (@var{D})}, where\n\ +@math{n} is the matrix size.\n\ +\n\ +If four output values are requested, compute @code{@var{AA} =\n\ +@var{CC}*@var{A}*@var{DD}} and @code{@var{BB} = @var{CC}*@var{B}*@var{DD}},\n\ +in which @var{AA} and @var{BB} have non-zero elements of approximately the\n\ +same magnitude and @var{CC} and @var{DD} are permuted diagonal matrices as\n\ +in @var{DD} for the algebraic eigenvalue problem.\n\ +\n\ +The eigenvalue balancing option @var{opt} may be one of:\n\ +\n\ +@table @asis\n\ +@item \"noperm\", \"S\"\n\ +Scale only; do not permute.\n\ +\n\ +@item \"noscal\", \"P\"\n\ +Permute only; do not scale.\n\ +@end table\n\ +\n\ +Algebraic eigenvalue balancing uses standard @sc{lapack} routines.\n\ +\n\ +Generalized eigenvalue problem balancing uses Ward's algorithm\n\ +(SIAM Journal on Scientific and Statistical Computing, 1981).\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 3 || nargout < 0 || nargout > 4) + { + print_usage (); + return retval; + } + + // determine if it's AEP or GEP + bool AEPcase = nargin == 1 || args(1).is_string (); + + // problem dimension + octave_idx_type nn = args(0).rows (); + + if (nn != args(0).columns ()) + { + gripe_square_matrix_required ("balance"); + return retval; + } + + bool isfloat = args(0).is_single_type () || + (! AEPcase && args(1).is_single_type ()); + + bool complex_case = (args(0).is_complex_type () || + (! AEPcase && args(1).is_complex_type ())); + + // Extract argument 1 parameter for both AEP and GEP. + Matrix aa; + ComplexMatrix caa; + FloatMatrix faa; + FloatComplexMatrix fcaa; + + if (isfloat) + { + if (complex_case) + fcaa = args(0).float_complex_matrix_value (); + else + faa = args(0).float_matrix_value (); + } + else + { + if (complex_case) + caa = args(0).complex_matrix_value (); + else + aa = args(0).matrix_value (); + } + + if (error_state) + return retval; + + // Treat AEP/GEP cases. + if (AEPcase) + { + // Algebraic eigenvalue problem. + bool noperm = false, noscal = false; + if (nargin > 1) + { + std::string a1s = args(1).string_value (); + noperm = a1s == "noperm" || a1s == "S"; + noscal = a1s == "noscal" || a1s == "P"; + } + + // balance the AEP + if (isfloat) + { + if (complex_case) + { + FloatComplexAEPBALANCE result (fcaa, noperm, noscal); + + if (nargout == 0 || nargout == 1) + retval(0) = result.balanced_matrix (); + else if (nargout == 2) + { + retval(1) = result.balanced_matrix (); + retval(0) = result.balancing_matrix (); + } + else + { + retval(2) = result.balanced_matrix (); + retval(1) = result.permuting_vector (); + retval(0) = result.scaling_vector (); + } + + } + else + { + FloatAEPBALANCE result (faa, noperm, noscal); + + if (nargout == 0 || nargout == 1) + retval(0) = result.balanced_matrix (); + else if (nargout == 2) + { + retval(1) = result.balanced_matrix (); + retval(0) = result.balancing_matrix (); + } + else + { + retval(2) = result.balanced_matrix (); + retval(1) = result.permuting_vector (); + retval(0) = result.scaling_vector (); + } + } + } + else + { + if (complex_case) + { + ComplexAEPBALANCE result (caa, noperm, noscal); + + if (nargout == 0 || nargout == 1) + retval(0) = result.balanced_matrix (); + else if (nargout == 2) + { + retval(1) = result.balanced_matrix (); + retval(0) = result.balancing_matrix (); + } + else + { + retval(2) = result.balanced_matrix (); + retval(1) = result.permuting_vector (); + retval(0) = result.scaling_vector (); + } + } + else + { + AEPBALANCE result (aa, noperm, noscal); + + if (nargout == 0 || nargout == 1) + retval(0) = result.balanced_matrix (); + else if (nargout == 2) + { + retval(1) = result.balanced_matrix (); + retval(0) = result.balancing_matrix (); + } + else + { + retval(2) = result.balanced_matrix (); + retval(1) = result.permuting_vector (); + retval(0) = result.scaling_vector (); + } + } + } + } + else + { + std::string bal_job; + if (nargout == 1) + warning ("balance: used GEP, should have two output arguments"); + + // Generalized eigenvalue problem. + if (nargin == 2) + bal_job = "B"; + else if (args(2).is_string ()) + bal_job = args(2).string_value (); + else + { + error ("balance: OPT argument must be a string"); + return retval; + } + + if ((nn != args(1).columns ()) || (nn != args(1).rows ())) + { + gripe_nonconformant (); + return retval; + } + + Matrix bb; + ComplexMatrix cbb; + FloatMatrix fbb; + FloatComplexMatrix fcbb; + + if (isfloat) + { + if (complex_case) + fcbb = args(1).float_complex_matrix_value (); + else + fbb = args(1).float_matrix_value (); + } + else + { + if (complex_case) + cbb = args(1).complex_matrix_value (); + else + bb = args(1).matrix_value (); + } + + // balance the GEP + if (isfloat) + { + if (complex_case) + { + FloatComplexGEPBALANCE result (fcaa, fcbb, bal_job); + + switch (nargout) + { + case 4: + retval(3) = result.balanced_matrix2 (); + // fall through + case 3: + retval(2) = result.balanced_matrix (); + retval(1) = result.balancing_matrix2 (); + retval(0) = result.balancing_matrix (); + break; + case 2: + retval(1) = result.balancing_matrix2 (); + // fall through + case 1: + retval(0) = result.balancing_matrix (); + break; + default: + error ("balance: invalid number of output arguments"); + break; + } + } + else + { + FloatGEPBALANCE result (faa, fbb, bal_job); + + switch (nargout) + { + case 4: + retval(3) = result.balanced_matrix2 (); + // fall through + case 3: + retval(2) = result.balanced_matrix (); + retval(1) = result.balancing_matrix2 (); + retval(0) = result.balancing_matrix (); + break; + case 2: + retval(1) = result.balancing_matrix2 (); + // fall through + case 1: + retval(0) = result.balancing_matrix (); + break; + default: + error ("balance: invalid number of output arguments"); + break; + } + } + } + else + { + if (complex_case) + { + ComplexGEPBALANCE result (caa, cbb, bal_job); + + switch (nargout) + { + case 4: + retval(3) = result.balanced_matrix2 (); + // fall through + case 3: + retval(2) = result.balanced_matrix (); + retval(1) = result.balancing_matrix2 (); + retval(0) = result.balancing_matrix (); + break; + case 2: + retval(1) = result.balancing_matrix2 (); + // fall through + case 1: + retval(0) = result.balancing_matrix (); + break; + default: + error ("balance: invalid number of output arguments"); + break; + } + } + else + { + GEPBALANCE result (aa, bb, bal_job); + + switch (nargout) + { + case 4: + retval(3) = result.balanced_matrix2 (); + // fall through + case 3: + retval(2) = result.balanced_matrix (); + retval(1) = result.balancing_matrix2 (); + retval(0) = result.balancing_matrix (); + break; + case 2: + retval(1) = result.balancing_matrix2 (); + // fall through + case 1: + retval(0) = result.balancing_matrix (); + break; + default: + error ("balance: invalid number of output arguments"); + break; + } + } + } + } + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/besselj.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,1246 @@ +/* + +Copyright (C) 1997-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-specfun.h" +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +enum bessel_type +{ + BESSEL_J, + BESSEL_Y, + BESSEL_I, + BESSEL_K, + BESSEL_H1, + BESSEL_H2 +}; + +#define DO_BESSEL(type, alpha, x, scaled, ierr, result) \ + do \ + { \ + switch (type) \ + { \ + case BESSEL_J: \ + result = besselj (alpha, x, scaled, ierr); \ + break; \ + \ + case BESSEL_Y: \ + result = bessely (alpha, x, scaled, ierr); \ + break; \ + \ + case BESSEL_I: \ + result = besseli (alpha, x, scaled, ierr); \ + break; \ + \ + case BESSEL_K: \ + result = besselk (alpha, x, scaled, ierr); \ + break; \ + \ + case BESSEL_H1: \ + result = besselh1 (alpha, x, scaled, ierr); \ + break; \ + \ + case BESSEL_H2: \ + result = besselh2 (alpha, x, scaled, ierr); \ + break; \ + \ + default: \ + break; \ + } \ + } \ + while (0) + +static void +gripe_bessel_arg (const char *fn, const char *arg) +{ + error ("%s: expecting scalar or matrix as %s argument", fn, arg); +} + +octave_value_list +do_bessel (enum bessel_type type, const char *fn, + const octave_value_list& args, int nargout) +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin == 2 || nargin == 3) + { + bool scaled = (nargin == 3); + + octave_value alpha_arg = args(0); + octave_value x_arg = args(1); + + if (alpha_arg.is_single_type () || x_arg.is_single_type ()) + { + if (alpha_arg.is_scalar_type ()) + { + float alpha = args(0).float_value (); + + if (! error_state) + { + if (x_arg.is_scalar_type ()) + { + FloatComplex x = x_arg.float_complex_value (); + + if (! error_state) + { + octave_idx_type ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = static_cast<float> (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + else + { + FloatComplexNDArray x = x_arg.float_complex_array_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + } + else + gripe_bessel_arg (fn, "first"); + } + else + { + dim_vector dv0 = args(0).dims (); + dim_vector dv1 = args(1).dims (); + + bool args0_is_row_vector = (dv0 (1) == dv0.numel ()); + bool args1_is_col_vector = (dv1 (0) == dv1.numel ()); + + if (args0_is_row_vector && args1_is_col_vector) + { + FloatRowVector ralpha = args(0).float_row_vector_value (); + + if (! error_state) + { + FloatComplexColumnVector cx = + x_arg.float_complex_column_vector_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, ralpha, cx, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + else + gripe_bessel_arg (fn, "first"); + } + else + { + FloatNDArray alpha = args(0).float_array_value (); + + if (! error_state) + { + if (x_arg.is_scalar_type ()) + { + FloatComplex x = x_arg.float_complex_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + else + { + FloatComplexNDArray x = x_arg.float_complex_array_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + } + else + gripe_bessel_arg (fn, "first"); + } + } + } + else + { + if (alpha_arg.is_scalar_type ()) + { + double alpha = args(0).double_value (); + + if (! error_state) + { + if (x_arg.is_scalar_type ()) + { + Complex x = x_arg.complex_value (); + + if (! error_state) + { + octave_idx_type ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = static_cast<double> (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + else + { + ComplexNDArray x = x_arg.complex_array_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + } + else + gripe_bessel_arg (fn, "first"); + } + else + { + dim_vector dv0 = args(0).dims (); + dim_vector dv1 = args(1).dims (); + + bool args0_is_row_vector = (dv0 (1) == dv0.numel ()); + bool args1_is_col_vector = (dv1 (0) == dv1.numel ()); + + if (args0_is_row_vector && args1_is_col_vector) + { + RowVector ralpha = args(0).row_vector_value (); + + if (! error_state) + { + ComplexColumnVector cx = + x_arg.complex_column_vector_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, ralpha, cx, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + else + gripe_bessel_arg (fn, "first"); + } + else + { + NDArray alpha = args(0).array_value (); + + if (! error_state) + { + if (x_arg.is_scalar_type ()) + { + Complex x = x_arg.complex_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + else + { + ComplexNDArray x = x_arg.complex_array_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + DO_BESSEL (type, alpha, x, scaled, ierr, result); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + gripe_bessel_arg (fn, "second"); + } + } + else + gripe_bessel_arg (fn, "first"); + } + } + } + } + else + print_usage (); + + return retval; +} + +DEFUN (besselj, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{j}, @var{ierr}] =} besselj (@var{alpha}, @var{x}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{y}, @var{ierr}] =} bessely (@var{alpha}, @var{x}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{i}, @var{ierr}] =} besseli (@var{alpha}, @var{x}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{k}, @var{ierr}] =} besselk (@var{alpha}, @var{x}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{h}, @var{ierr}] =} besselh (@var{alpha}, @var{k}, @var{x}, @var{opt})\n\ +Compute Bessel or Hankel functions of various kinds:\n\ +\n\ +@table @code\n\ +@item besselj\n\ +Bessel functions of the first kind. If the argument @var{opt} is supplied,\n\ +the result is multiplied by @code{exp (-abs (imag (@var{x})))}.\n\ +\n\ +@item bessely\n\ +Bessel functions of the second kind. If the argument @var{opt} is supplied,\n\ +the result is multiplied by @code{exp (-abs (imag (@var{x})))}.\n\ +\n\ +@item besseli\n\ +\n\ +Modified Bessel functions of the first kind. If the argument @var{opt} is\n\ +supplied, the result is multiplied by @code{exp (-abs (real (@var{x})))}.\n\ +\n\ +@item besselk\n\ +\n\ +Modified Bessel functions of the second kind. If the argument @var{opt} is\n\ +supplied, the result is multiplied by @code{exp (@var{x})}.\n\ +\n\ +@item besselh\n\ +Compute Hankel functions of the first (@var{k} = 1) or second (@var{k}\n\ += 2) kind. If the argument @var{opt} is supplied, the result is multiplied\n\ +by @code{exp (-I*@var{x})} for @var{k} = 1 or @code{exp (I*@var{x})} for\n\ +@var{k} = 2.\n\ +@end table\n\ +\n\ +If @var{alpha} is a scalar, the result is the same size as @var{x}.\n\ +If @var{x} is a scalar, the result is the same size as @var{alpha}.\n\ +If @var{alpha} is a row vector and @var{x} is a column vector, the\n\ +result is a matrix with @code{length (@var{x})} rows and\n\ +@code{length (@var{alpha})} columns. Otherwise, @var{alpha} and\n\ +@var{x} must conform and the result will be the same size.\n\ +\n\ +The value of @var{alpha} must be real. The value of @var{x} may be\n\ +complex.\n\ +\n\ +If requested, @var{ierr} contains the following status information\n\ +and is the same size as the result.\n\ +\n\ +@enumerate 0\n\ +@item\n\ +Normal return.\n\ +\n\ +@item\n\ +Input error, return @code{NaN}.\n\ +\n\ +@item\n\ +Overflow, return @code{Inf}.\n\ +\n\ +@item\n\ +Loss of significance by argument reduction results in less than\n\ +half of machine accuracy.\n\ +\n\ +@item\n\ +Complete loss of significance by argument reduction, return @code{NaN}.\n\ +\n\ +@item\n\ +Error---no computation, algorithm termination condition not met,\n\ +return @code{NaN}.\n\ +@end enumerate\n\ +@end deftypefn") +{ + return do_bessel (BESSEL_J, "besselj", args, nargout); +} + +DEFUN (bessely, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{y}, @var{ierr}] =} bessely (@var{alpha}, @var{x}, @var{opt})\n\ +See besselj.\n\ +@end deftypefn") +{ + return do_bessel (BESSEL_Y, "bessely", args, nargout); +} + +DEFUN (besseli, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{i}, @var{ierr}] =} besseli (@var{alpha}, @var{x}, @var{opt})\n\ +See besselj.\n\ +@end deftypefn") +{ + return do_bessel (BESSEL_I, "besseli", args, nargout); +} + +DEFUN (besselk, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{k}, @var{ierr}] =} besselk (@var{alpha}, @var{x}, @var{opt})\n\ +See besselj.\n\ +@end deftypefn") +{ + return do_bessel (BESSEL_K, "besselk", args, nargout); +} + +DEFUN (besselh, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{h}, @var{ierr}] =} besselh (@var{alpha}, @var{k}, @var{x}, @var{opt})\n\ +See besselj.\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin == 2) + { + retval = do_bessel (BESSEL_H1, "besselh", args, nargout); + } + else if (nargin == 3 || nargin == 4) + { + octave_idx_type kind = args(1).int_value (); + + if (! error_state) + { + octave_value_list tmp_args; + + if (nargin == 4) + tmp_args(2) = args(3); + + tmp_args(1) = args(2); + tmp_args(0) = args(0); + + if (kind == 1) + retval = do_bessel (BESSEL_H1, "besselh", tmp_args, nargout); + else if (kind == 2) + retval = do_bessel (BESSEL_H2, "besselh", tmp_args, nargout); + else + error ("besselh: expecting K = 1 or 2"); + } + else + error ("besselh: invalid value of K"); + } + else + print_usage (); + + return retval; +} + +DEFUN (airy, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{a}, @var{ierr}] =} airy (@var{k}, @var{z}, @var{opt})\n\ +Compute Airy functions of the first and second kind, and their\n\ +derivatives.\n\ +\n\ +@example\n\ +@group\n\ + K Function Scale factor (if 'opt' is supplied)\n\ +--- -------- ---------------------------------------\n\ + 0 Ai (Z) exp ((2/3) * Z * sqrt (Z))\n\ + 1 dAi(Z)/dZ exp ((2/3) * Z * sqrt (Z))\n\ + 2 Bi (Z) exp (-abs (real ((2/3) * Z * sqrt (Z))))\n\ + 3 dBi(Z)/dZ exp (-abs (real ((2/3) * Z * sqrt (Z))))\n\ +@end group\n\ +@end example\n\ +\n\ +The function call @code{airy (@var{z})} is equivalent to\n\ +@code{airy (0, @var{z})}.\n\ +\n\ +The result is the same size as @var{z}.\n\ +\n\ +If requested, @var{ierr} contains the following status information and\n\ +is the same size as the result.\n\ +\n\ +@enumerate 0\n\ +@item\n\ +Normal return.\n\ +\n\ +@item\n\ +Input error, return @code{NaN}.\n\ +\n\ +@item\n\ +Overflow, return @code{Inf}.\n\ +\n\ +@item\n\ +Loss of significance by argument reduction results in less than half\n\ + of machine accuracy.\n\ +\n\ +@item\n\ +Complete loss of significance by argument reduction, return @code{NaN}.\n\ +\n\ +@item\n\ +Error---no computation, algorithm termination condition not met,\n\ +return @code{NaN}.\n\ +@end enumerate\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin > 0 && nargin < 4) + { + bool scale = (nargin == 3); + + int kind = 0; + + if (nargin > 1) + { + kind = args(0).int_value (); + + if (! error_state) + { + if (kind < 0 || kind > 3) + error ("airy: expecting K = 0, 1, 2, or 3"); + } + else + error ("airy: K must be an integer value"); + } + + if (! error_state) + { + int idx = nargin == 1 ? 0 : 1; + + if (args (idx).is_single_type ()) + { + FloatComplexNDArray z = args(idx).float_complex_array_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + if (kind > 1) + result = biry (z, kind == 3, scale, ierr); + else + result = airy (z, kind == 1, scale, ierr); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + error ("airy: Z must be a complex matrix"); + } + else + { + ComplexNDArray z = args(idx).complex_array_value (); + + if (! error_state) + { + Array<octave_idx_type> ierr; + octave_value result; + + if (kind > 1) + result = biry (z, kind == 3, scale, ierr); + else + result = airy (z, kind == 1, scale, ierr); + + if (nargout > 1) + retval(1) = NDArray (ierr); + + retval(0) = result; + } + else + error ("airy: Z must be a complex matrix"); + } + } + } + else + print_usage (); + + return retval; +} + +/* +%! # Test values computed with GP/PARI version 2.3.3 +%! +%!shared alpha, x, jx, yx, ix, kx, nix +%! +%! # Bessel functions, even order, positive and negative x +%! alpha = 2; x = 1.25; +%! jx = 0.1710911312405234823613091417; +%! yx = -1.193199310178553861283790424; +%! ix = 0.2220184483766341752692212604; +%! kx = 0.9410016167388185767085460540; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%!assert (besselj (-alpha,x), jx, 100*eps) +%!assert (bessely (-alpha,x), yx, 100*eps) +%!assert (besseli (-alpha,x), ix, 100*eps) +%!assert (besselk (-alpha,x), kx, 100*eps) +%!assert (besselh (-alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (-alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (-alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (-alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (-alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%! x *= -1; +%! yx = -1.193199310178553861283790424 + 0.3421822624810469647226182835*I; +%! kx = 0.9410016167388185767085460540 - 0.6974915263814386815610060884*I; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%! # Bessel functions, odd order, positive and negative x +%! alpha = 3; x = 2.5; +%! jx = 0.2166003910391135247666890035; +%! yx = -0.7560554967536709968379029772; +%! ix = 0.4743704087780355895548240179; +%! kx = 0.2682271463934492027663765197; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%!assert (besselj (-alpha,x), -jx, 100*eps) +%!assert (bessely (-alpha,x), -yx, 100*eps) +%!assert (besseli (-alpha,x), ix, 100*eps) +%!assert (besselk (-alpha,x), kx, 100*eps) +%!assert (besselh (-alpha,1,x), -(jx + I*yx), 100*eps) +%!assert (besselh (-alpha,2,x), -(jx - I*yx), 100*eps) +%! +%!assert (besselj (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (-alpha,x,1), -yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (-alpha,1,x,1), -(jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (-alpha,2,x,1), -(jx - I*yx)*exp(I*x), 100*eps) +%! +%! x *= -1; +%! jx = -jx; +%! yx = 0.7560554967536709968379029772 - 0.4332007820782270495333780070*I; +%! ix = -ix; +%! kx = -0.2682271463934492027663765197 - 1.490278591297463775542004240*I; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%! # Bessel functions, fractional order, positive and negative x +%! +%! alpha = 3.5; x = 2.75; +%! jx = 0.1691636439842384154644784389; +%! yx = -0.8301381935499356070267953387; +%! ix = 0.3930540878794826310979363668; +%! kx = 0.2844099013460621170288192503; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%! nix = 0.2119931212254662995364461998; +%! +%!assert (besselj (-alpha,x), yx, 100*eps) +%!assert (bessely (-alpha,x), -jx, 100*eps) +%!assert (besseli (-alpha,x), nix, 100*eps) +%!assert (besselk (-alpha,x), kx, 100*eps) +%!assert (besselh (-alpha,1,x), -I*(jx + I*yx), 100*eps) +%!assert (besselh (-alpha,2,x), I*(jx - I*yx), 100*eps) +%! +%!assert (besselj (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (-alpha,x,1), nix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (-alpha,1,x,1), -I*(jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (-alpha,2,x,1), I*(jx - I*yx)*exp(I*x), 100*eps) +%! +%! x *= -1; +%! jx *= -I; +%! yx = -0.8301381935499356070267953387*I; +%! ix *= -I; +%! kx = -0.9504059335995575096509874508*I; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%! # Bessel functions, even order, complex x +%! +%! alpha = 2; x = 1.25 + 3.625 * I; +%! jx = -1.299533366810794494030065917 + 4.370833116012278943267479589*I; +%! yx = -4.370357232383223896393056727 - 1.283083391453582032688834041*I; +%! ix = -0.6717801680341515541002273932 - 0.2314623443930774099910228553*I; +%! kx = -0.01108009888623253515463783379 + 0.2245218229358191588208084197*I; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%!assert (besselj (-alpha,x), jx, 100*eps) +%!assert (bessely (-alpha,x), yx, 100*eps) +%!assert (besseli (-alpha,x), ix, 100*eps) +%!assert (besselk (-alpha,x), kx, 100*eps) +%!assert (besselh (-alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (-alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (-alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (-alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (-alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%! # Bessel functions, odd order, complex x +%! +%! alpha = 3; x = 2.5 + 1.875 * I; +%! jx = 0.1330721523048277493333458596 + 0.5386295217249660078754395597*I; +%! yx = -0.6485072392105829901122401551 + 0.2608129289785456797046996987*I; +%! ix = -0.6182064685486998097516365709 + 0.4677561094683470065767989920*I; +%! kx = -0.1568585587733540007867882337 - 0.05185853709490846050505141321*I; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%!assert (besselj (-alpha,x), -jx, 100*eps) +%!assert (bessely (-alpha,x), -yx, 100*eps) +%!assert (besseli (-alpha,x), ix, 100*eps) +%!assert (besselk (-alpha,x), kx, 100*eps) +%!assert (besselh (-alpha,1,x), -(jx + I*yx), 100*eps) +%!assert (besselh (-alpha,2,x), -(jx - I*yx), 100*eps) +%! +%!assert (besselj (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (-alpha,x,1), -yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (-alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (-alpha,1,x,1), -(jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (-alpha,2,x,1), -(jx - I*yx)*exp(I*x), 100*eps) +%! +%! # Bessel functions, fractional order, complex x +%! +%! alpha = 3.5; x = 1.75 + 4.125 * I; +%! jx = -3.018566131370455929707009100 - 0.7585648436793900607704057611*I; +%! yx = 0.7772278839106298215614791107 - 3.018518722313849782683792010*I; +%! ix = 0.2100873577220057189038160913 - 0.6551765604618246531254970926*I; +%! kx = 0.1757147290513239935341488069 + 0.08772348296883849205562558311*I; +%! +%!assert (besselj (alpha,x), jx, 100*eps) +%!assert (bessely (alpha,x), yx, 100*eps) +%!assert (besseli (alpha,x), ix, 100*eps) +%!assert (besselk (alpha,x), kx, 100*eps) +%!assert (besselh (alpha,1,x), jx + I*yx, 100*eps) +%!assert (besselh (alpha,2,x), jx - I*yx, 100*eps) +%! +%!assert (besselj (alpha,x,1), jx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (alpha,x,1), ix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (alpha,1,x,1), (jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (alpha,2,x,1), (jx - I*yx)*exp(I*x), 100*eps) +%! +%! nix = 0.09822388691172060573913739253 - 0.7110230642207380127317227407*I; +%! +%!assert (besselj (-alpha,x), yx, 100*eps) +%!assert (bessely (-alpha,x), -jx, 100*eps) +%!assert (besseli (-alpha,x), nix, 100*eps) +%!assert (besselk (-alpha,x), kx, 100*eps) +%!assert (besselh (-alpha,1,x), -I*(jx + I*yx), 100*eps) +%!assert (besselh (-alpha,2,x), I*(jx - I*yx), 100*eps) +%! +%!assert (besselj (-alpha,x,1), yx*exp(-abs(imag(x))), 100*eps) +%!assert (bessely (-alpha,x,1), -jx*exp(-abs(imag(x))), 100*eps) +%!assert (besseli (-alpha,x,1), nix*exp(-abs(real(x))), 100*eps) +%!assert (besselk (-alpha,x,1), kx*exp(x), 100*eps) +%!assert (besselh (-alpha,1,x,1), -I*(jx + I*yx)*exp(-I*x), 100*eps) +%!assert (besselh (-alpha,2,x,1), I*(jx - I*yx)*exp(I*x), 100*eps) + + +Tests contributed by Robert T. Short. +Tests are based on the properties and tables in A&S: + Abramowitz and Stegun, "Handbook of Mathematical Functions", + 1972. + +For regular Bessel functions, there are 3 tests. These compare octave +results against Tables 9.1, 9.2, and 9.4 in A&S. Tables 9.1 and 9.2 +are good to only a few decimal places, so any failures should be +considered a broken implementation. Table 9.4 is an extended table +for larger orders and arguments. There are some differences between +Octave and Table 9.4, mostly in the last decimal place but in a very +few instances the errors are in the last two places. The comparison +tolerance has been changed to reflect this. + +Similarly for modifed Bessel functions, there are 3 tests. These +compare octave results against Tables 9.8, 9.9, and 9.11 in A&S. +Tables 9.8 and 9.9 are good to only a few decimal places, so any +failures should be considered a broken implementation. Table 9.11 is +an extended table for larger orders and arguments. There are some +differences between octave and Table 9.11, mostly in the last decimal +place but in a very few instances the errors are in the last two +places. The comparison tolerance has been changed to reflect this. + +For spherical Bessel functions, there are also three tests, comparing +octave results to Tables 10.1, 10.2, and 10.4 in A&S. Very similar +comments may be made here as in the previous lines. At this time, +modified spherical Bessel function tests are not included. + +% Table 9.1 - J and Y for integer orders 0, 1, 2. +% Compare against excerpts of Table 9.1, Abramowitz and Stegun. +%!test +%! n = 0:2; +%! z = (0:2.5:17.5)'; +%! +%! Jt = [[ 1.000000000000000, 0.0000000000, 0.0000000000]; +%! [-0.048383776468198, 0.4970941025, 0.4460590584]; +%! [-0.177596771314338, -0.3275791376, 0.0465651163]; +%! [ 0.266339657880378, 0.1352484276, -0.2302734105]; +%! [-0.245935764451348, 0.0434727462, 0.2546303137]; +%! [ 0.146884054700421, -0.1654838046, -0.1733614634]; +%! [-0.014224472826781, 0.2051040386, 0.0415716780]; +%! [-0.103110398228686, -0.1634199694, 0.0844338303]]; +%! +%! Yt = [[-Inf, -Inf, -Inf ]; +%! [ 0.4980703596, 0.1459181380, -0.38133585 ]; +%! [-0.3085176252, 0.1478631434, 0.36766288 ]; +%! [ 0.1173132861, -0.2591285105, -0.18641422 ]; +%! [ 0.0556711673, 0.2490154242, -0.00586808 ]; +%! [-0.1712143068, -0.1538382565, 0.14660019 ]; +%! [ 0.2054642960, 0.0210736280, -0.20265448 ]; +%! [-0.1604111925, 0.0985727987, 0.17167666 ]]; +%! +%! J = besselj (n,z); +%! Y = bessely (n,z); +%! assert (Jt(:,1), J(:,1), 0.5e-10); +%! assert (Yt(:,1), Y(:,1), 0.5e-10); +%! assert (Jt(:,2:3), J(:,2:3), 0.5e-10); + +Table 9.2 - J and Y for integer orders 3-9. + +%!test +%! n = (3:9); +%! z = (0:2:20).'; +%! +%! Jt = [[ 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00, 0.0000e+00]; +%! [ 1.2894e-01, 3.3996e-02, 7.0396e-03, 1.2024e-03, 1.7494e-04, 2.2180e-05, 2.4923e-06]; +%! [ 4.3017e-01, 2.8113e-01, 1.3209e-01, 4.9088e-02, 1.5176e-02, 4.0287e-03, 9.3860e-04]; +%! [ 1.1477e-01, 3.5764e-01, 3.6209e-01, 2.4584e-01, 1.2959e-01, 5.6532e-02, 2.1165e-02]; +%! [-2.9113e-01,-1.0536e-01, 1.8577e-01, 3.3758e-01, 3.2059e-01, 2.2345e-01, 1.2632e-01]; +%! [ 5.8379e-02,-2.1960e-01,-2.3406e-01,-1.4459e-02, 2.1671e-01, 3.1785e-01, 2.9186e-01]; +%! [ 1.9514e-01, 1.8250e-01,-7.3471e-02,-2.4372e-01,-1.7025e-01, 4.5095e-02, 2.3038e-01]; +%! [-1.7681e-01, 7.6244e-02, 2.2038e-01, 8.1168e-02,-1.5080e-01,-2.3197e-01,-1.1431e-01]; +%! [-4.3847e-02,-2.0264e-01,-5.7473e-02, 1.6672e-01, 1.8251e-01,-7.0211e-03,-1.8953e-01]; +%! [ 1.8632e-01, 6.9640e-02,-1.5537e-01,-1.5596e-01, 5.1399e-02, 1.9593e-01, 1.2276e-01]; +%! [-9.8901e-02, 1.3067e-01, 1.5117e-01,-5.5086e-02,-1.8422e-01,-7.3869e-02, 1.2513e-01]]; +%! +%! Yt = [[ -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf]; +%! [-1.1278e+00,-2.7659e+00,-9.9360e+00,-4.6914e+01,-2.7155e+02,-1.8539e+03,-1.4560e+04]; +%! [-1.8202e-01,-4.8894e-01,-7.9585e-01,-1.5007e+00,-3.7062e+00,-1.1471e+01,-4.2178e+01]; +%! [ 3.2825e-01, 9.8391e-02,-1.9706e-01,-4.2683e-01,-6.5659e-01,-1.1052e+00,-2.2907e+00]; +%! [ 2.6542e-02, 2.8294e-01, 2.5640e-01, 3.7558e-02,-2.0006e-01,-3.8767e-01,-5.7528e-01]; +%! [-2.5136e-01,-1.4495e-01, 1.3540e-01, 2.8035e-01, 2.0102e-01, 1.0755e-03,-1.9930e-01]; +%! [ 1.2901e-01,-1.5122e-01,-2.2982e-01,-4.0297e-02, 1.8952e-01, 2.6140e-01, 1.5902e-01]; +%! [ 1.2350e-01, 2.0393e-01,-6.9717e-03,-2.0891e-01,-1.7209e-01, 3.6816e-02, 2.1417e-01]; +%! [-1.9637e-01,-7.3222e-05, 1.9633e-01, 1.2278e-01,-1.0425e-01,-2.1399e-01,-1.0975e-01]; +%! [ 3.3724e-02,-1.7722e-01,-1.1249e-01, 1.1472e-01, 1.8897e-01, 3.2253e-02,-1.6030e-01]; +%! [ 1.4967e-01, 1.2409e-01,-1.0004e-01,-1.7411e-01,-4.4312e-03, 1.7101e-01, 1.4124e-01]]; +%! +%! n = (3:9); +%! z = (0:2:20).'; +%! J = besselj (n,z); +%! Y = bessely (n,z); +%! +%! assert (J(1,:), zeros (1, columns (J))); +%! assert (J(2:end,:), Jt(2:end,:), -5e-5); +%! assert (Yt(1,:), Y(1,:)); +%! assert (Y(2:end,:), Yt(2:end,:), -5e-5); + +Table 9.4 - J and Y for various integer orders and arguments. + +%!test +%! Jt = [[ 7.651976866e-01, 2.238907791e-01, -1.775967713e-01, -2.459357645e-01, 5.581232767e-02, 1.998585030e-02]; +%! [ 2.497577302e-04, 7.039629756e-03, 2.611405461e-01, -2.340615282e-01, -8.140024770e-02, -7.419573696e-02]; +%! [ 2.630615124e-10, 2.515386283e-07, 1.467802647e-03, 2.074861066e-01, -1.138478491e-01, -5.473217694e-02]; +%! [ 2.297531532e-17, 7.183016356e-13, 4.796743278e-07, 4.507973144e-03, -1.082255990e-01, 1.519812122e-02]; +%! [ 3.873503009e-25, 3.918972805e-19, 2.770330052e-11, 1.151336925e-05, -1.167043528e-01, 6.221745850e-02]; +%! [ 3.482869794e-42, 3.650256266e-33, 2.671177278e-21, 1.551096078e-12, 4.843425725e-02, 8.146012958e-02]; +%! [ 1.107915851e-60, 1.196077458e-48, 8.702241617e-33, 6.030895312e-21, -1.381762812e-01, 7.270175482e-02]; +%! [ 2.906004948e-80, 3.224095839e-65, 2.294247616e-45, 1.784513608e-30, 1.214090219e-01, -3.869833973e-02]; +%! [ 8.431828790e-189, 1.060953112e-158, 6.267789396e-119, 6.597316064e-89, 1.115927368e-21, 9.636667330e-02]]; +%! +%! Yt = [[ 8.825696420e-02, 5.103756726e-01, -3.085176252e-01, 5.567116730e-02, -9.806499547e-02, -7.724431337e-02] +%! [-2.604058666e+02, -9.935989128e+00, -4.536948225e-01, 1.354030477e-01, -7.854841391e-02, -2.948019628e-02] +%! [-1.216180143e+08, -1.291845422e+05, -2.512911010e+01, -3.598141522e-01, 5.723897182e-03, 5.833157424e-02] +%! [-9.256973276e+14, -2.981023646e+10, -4.694049564e+04, -6.364745877e+00, 4.041280205e-02, 7.879068695e-02] +%! [-4.113970315e+22, -4.081651389e+16, -5.933965297e+08, -1.597483848e+03, 1.644263395e-02, 5.124797308e-02] +%! [-3.048128783e+39, -2.913223848e+30, -4.028568418e+18, -7.256142316e+09, -1.164572349e-01, 6.138839212e-03] +%! [-7.184874797e+57, -6.661541235e+45, -9.216816571e+29, -1.362803297e+18, -4.530801120e-02, 4.074685217e-02] +%! [-2.191142813e+77, -1.976150576e+62, -2.788837017e+42, -3.641066502e+27, -2.103165546e-01, 7.650526394e-02] +%! [-3.775287810e+185, -3.000826049e+155, -5.084863915e+115, -4.849148271e+85, -3.293800188e+18, -1.669214114e-01]]; +%! +%! n = [(0:5:20).';30;40;50;100]; +%! z = [1,2,5,10,50,100]; +%! J = besselj (n.', z.').'; +%! Y = bessely (n.', z.').'; +%! assert (J, Jt, -1e-9); +%! assert (Y, Yt, -1e-9); + +Table 9.8 - I and K for integer orders 0, 1, 2. + +%!test +%! n = 0:2; +%! z1 = [0.1;2.5;5.0]; +%! z2 = [7.5;10.0;15.0;20.0]; +%! rtbl = [[ 0.9071009258 0.0452984468 0.1251041992 2.6823261023 10.890182683 1.995039646 ]; +%! [ 0.2700464416 0.2065846495 0.2042345837 0.7595486903 0.9001744239 0.759126289 ]; +%! [ 0.1835408126 0.1639722669 0.7002245988 0.5478075643 0.6002738588 0.132723593 ]; +%! [ 0.1483158301 0.1380412115 0.111504840 0.4505236991 0.4796689336 0.57843541 ]; +%! [ 0.1278333372 0.1212626814 0.103580801 0.3916319344 0.4107665704 0.47378525 ]; +%! [ 0.1038995314 0.1003741751 0.090516308 0.3210023535 0.3315348950 0.36520701 ]; +%! [ 0.0897803119 0.0875062222 0.081029690 0.2785448768 0.2854254970 0.30708743 ]]; +%! +%! tbl = [besseli(n,z1,1), besselk(n,z1,1)]; +%! tbl(:,3) = tbl(:,3) .* (exp (z1) .* z1.^(-2)); +%! tbl(:,6) = tbl(:,6) .* (exp (-z1) .* z1.^(2)); +%! tbl = [tbl;[besseli(n,z2,1),besselk(n,z2,1)]]; +%! +%! assert (tbl, rtbl, -2e-8); + +Table 9.9 - I and K for orders 3-9. + +%!test +%! It = [[ 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00]; +%! [ 2.8791e-02 6.8654e-03 1.3298e-03 2.1656e-04 3.0402e-05 3.7487e-06 4.1199e-07]; +%! [ 6.1124e-02 2.5940e-02 9.2443e-03 2.8291e-03 7.5698e-04 1.7968e-04 3.8284e-05]; +%! [ 7.4736e-02 4.1238e-02 1.9752e-02 8.3181e-03 3.1156e-03 1.0484e-03 3.1978e-04]; +%! [ 7.9194e-02 5.0500e-02 2.8694e-02 1.4633e-02 6.7449e-03 2.8292e-03 1.0866e-03]; +%! [ 7.9830e-02 5.5683e-02 3.5284e-02 2.0398e-02 1.0806e-02 5.2694e-03 2.3753e-03]; +%! [ 7.8848e-02 5.8425e-02 3.9898e-02 2.5176e-02 1.4722e-02 8.0010e-03 4.0537e-03]; +%! [ 7.7183e-02 5.9723e-02 4.3056e-02 2.8969e-02 1.8225e-02 1.0744e-02 5.9469e-03]; +%! [ 7.5256e-02 6.0155e-02 4.5179e-02 3.1918e-02 2.1240e-02 1.3333e-02 7.9071e-03]; +%! [ 7.3263e-02 6.0059e-02 4.6571e-02 3.4186e-02 2.3780e-02 1.5691e-02 9.8324e-03]; +%! [ 7.1300e-02 5.9640e-02 4.7444e-02 3.5917e-02 2.5894e-02 1.7792e-02 1.1661e-02]]; +%! +%! Kt = [[ Inf Inf Inf Inf Inf Inf Inf]; +%! [ 4.7836e+00 1.6226e+01 6.9687e+01 3.6466e+02 2.2576e+03 1.6168e+04 1.3160e+05]; +%! [ 1.6317e+00 3.3976e+00 8.4268e+00 2.4465e+01 8.1821e+01 3.1084e+02 1.3252e+03]; +%! [ 9.9723e-01 1.6798e+00 3.2370e+00 7.0748e+00 1.7387e+01 4.7644e+01 1.4444e+02]; +%! [ 7.3935e-01 1.1069e+00 1.8463e+00 3.4148e+00 6.9684e+00 1.5610e+01 3.8188e+01]; +%! [ 6.0028e-01 8.3395e-01 1.2674e+00 2.1014e+00 3.7891e+00 7.4062e+00 1.5639e+01]; +%! [ 5.1294e-01 6.7680e-01 9.6415e-01 1.4803e+00 2.4444e+00 4.3321e+00 8.2205e+00]; +%! [ 4.5266e-01 5.7519e-01 7.8133e-01 1.1333e+00 1.7527e+00 2.8860e+00 5.0510e+00]; +%! [ 4.0829e-01 5.0414e-01 6.6036e-01 9.1686e-01 1.3480e+00 2.0964e+00 3.4444e+00]; +%! [ 3.7411e-01 4.5162e-01 5.7483e-01 7.7097e-01 1.0888e+00 1.6178e+00 2.5269e+00]; +%! [ 3.4684e-01 4.1114e-01 5.1130e-01 6.6679e-01 9.1137e-01 1.3048e+00 1.9552e+00]]; +%! +%! n = (3:9); +%! z = (0:2:20).'; +%! I = besseli (n,z,1); +%! K = besselk (n,z,1); +%! +%! assert (abs (I(1,:)), zeros (1, columns (I))); +%! assert (I(2:end,:), It(2:end,:), -5e-5); +%! assert (Kt(1,:), K(1,:)); +%! assert (K(2:end,:), Kt(2:end,:), -5e-5); + +Table 9.11 - I and K for various integer orders and arguments. + +%!test +%! It = [[ 1.266065878e+00 2.279585302e+00 2.723987182e+01 2.815716628e+03 2.93255378e+20 1.07375171e+42 ]; +%! [ 2.714631560e-04 9.825679323e-03 2.157974547e+00 7.771882864e+02 2.27854831e+20 9.47009387e+41 ]; +%! [ 2.752948040e-10 3.016963879e-07 4.580044419e-03 2.189170616e+01 1.07159716e+20 6.49897552e+41 ]; +%! [ 2.370463051e-17 8.139432531e-13 1.047977675e-06 1.043714907e-01 3.07376455e+19 3.47368638e+41 ]; +%! [ 3.966835986e-25 4.310560576e-19 5.024239358e-11 1.250799736e-04 5.44200840e+18 1.44834613e+41 ]; +%! [ 3.539500588e-42 3.893519664e-33 3.997844971e-21 7.787569783e-12 4.27499365e+16 1.20615487e+40 ]; +%! [ 1.121509741e-60 1.255869192e-48 1.180426980e-32 2.042123274e-20 6.00717897e+13 3.84170550e+38 ]; +%! [ 2.934635309e-80 3.353042830e-65 2.931469647e-45 4.756894561e-30 1.76508024e+10 4.82195809e+36 ]; +%! [ 8.473674008e-189 1.082171475e-158 7.093551489e-119 1.082344202e-88 2.72788795e-16 4.64153494e+21 ]]; +%! +%! Kt = [[ 4.210244382e-01 1.138938727e-01 3.691098334e-03 1.778006232e-05 3.41016774e-23 4.65662823e-45 ]; +%! [ 3.609605896e+02 9.431049101e+00 3.270627371e-02 5.754184999e-05 4.36718224e-23 5.27325611e-45 ]; +%! [ 1.807132899e+08 1.624824040e+05 9.758562829e+00 1.614255300e-03 9.15098819e-23 7.65542797e-45 ]; +%! [ 1.403066801e+15 4.059213332e+10 3.016976630e+04 2.656563849e-01 3.11621117e-22 1.42348325e-44 ]; +%! [ 6.294369360e+22 5.770856853e+16 4.827000521e+08 1.787442782e+02 1.70614838e-21 3.38520541e-44 ]; +%! [ 4.706145527e+39 4.271125755e+30 4.112132063e+18 2.030247813e+09 2.00581681e-19 3.97060205e-43 ]; +%! [ 1.114220651e+58 9.940839886e+45 1.050756722e+30 5.938224681e+17 1.29986971e-16 1.20842080e-41 ]; +%! [ 3.406896854e+77 2.979981740e+62 3.394322243e+42 2.061373775e+27 4.00601349e-13 9.27452265e-40 ]; +%! [ 5.900333184e+185 4.619415978e+155 7.039860193e+115 4.596674084e+85 1.63940352e+13 7.61712963e-25 ]]; +%! +%! n = [(0:5:20).';30;40;50;100]; +%! z = [1,2,5,10,50,100]; +%! I = besseli (n.', z.').'; +%! K = besselk (n.', z.').'; +%! assert (I, It, -5e-9); +%! assert (K, Kt, -5e-9); + +The next section checks that negative integer orders and positive +integer orders are appropriately related. + +%!test +%! n = (0:2:20); +%! assert (besselj (n,1), besselj (-n,1), 1e-8); +%! assert (-besselj (n+1,1), besselj (-n-1,1), 1e-8); + +besseli (n,z) = besseli (-n,z); + +%!test +%! n = (0:2:20); +%! assert (besseli (n,1), besseli (-n,1), 1e-8); + +Table 10.1 - j and y for integer orders 0, 1, 2. +Compare against excerpts of Table 10.1, Abramowitz and Stegun. + +%!test +%! n = (0:2); +%! z = [0.1;(2.5:2.5:10.0).']; +%! +%! jt = [[ 9.9833417e-01 3.33000119e-02 6.6619061e-04 ]; +%! [ 2.3938886e-01 4.16212989e-01 2.6006673e-01 ]; +%! [-1.9178485e-01 -9.50894081e-02 1.3473121e-01 ]; +%! [ 1.2507e-01 -2.9542e-02 -1.3688e-01 ]; +%! [ -5.4402e-02 7.8467e-02 7.7942e-02 ]]; +%! +%! yt = [[-9.9500417e+00 -1.0049875e+02 -3.0050125e+03 ]; +%! [ 3.2045745e-01 -1.1120588e-01 -4.5390450e-01 ]; +%! [-5.6732437e-02 1.8043837e-01 1.6499546e-01 ]; +%! [ -4.6218e-02 -1.3123e-01 -6.2736e-03 ]; +%! [ 8.3907e-02 6.2793e-02 -6.5069e-02 ]]; +%! +%! j = sqrt ((pi/2)./z) .* besselj (n+1/2,z); +%! y = sqrt ((pi/2)./z) .* bessely (n+1/2,z); +%! assert (jt, j, -5e-5); +%! assert (yt, y, -5e-5); + +Table 10.2 - j and y for orders 3-8. +Compare against excerpts of Table 10.2, Abramowitzh and Stegun. + + Important note: In A&S, y_4(0.1) = -1.0507e+7, but Octave returns + y_4(0.1) = -1.0508e+07 (-10507503.75). If I compute the same term using + a series, the difference is in the eighth significant digit so I left + the Octave results in place. + +%!test +%! n = (3:8); +%! z = (0:2.5:10).'; z(1) = 0.1; +%! +%! jt = [[ 9.5185e-06 1.0577e-07 9.6163e-10 7.3975e-12 4.9319e-14 2.9012e-16]; +%! [ 1.0392e-01 3.0911e-02 7.3576e-03 1.4630e-03 2.5009e-04 3.7516e-05]; +%! [ 2.2982e-01 1.8702e-01 1.0681e-01 4.7967e-02 1.7903e-02 5.7414e-03]; +%! [-6.1713e-02 7.9285e-02 1.5685e-01 1.5077e-01 1.0448e-01 5.8188e-02]; +%! [-3.9496e-02 -1.0559e-01 -5.5535e-02 4.4501e-02 1.1339e-01 1.2558e-01]]; +%! +%! yt = [[-1.5015e+05 -1.0508e+07 -9.4553e+08 -1.0400e+11 -1.3519e+13 -2.0277e+15]; +%! [-7.9660e-01 -1.7766e+00 -5.5991e+00 -2.2859e+01 -1.1327e+02 -6.5676e+02]; +%! [-1.5443e-02 -1.8662e-01 -3.2047e-01 -5.1841e-01 -1.0274e+00 -2.5638e+00]; +%! [ 1.2705e-01 1.2485e-01 2.2774e-02 -9.1449e-02 -1.8129e-01 -2.7112e-01]; +%! [-9.5327e-02 -1.6599e-03 9.3834e-02 1.0488e-01 4.2506e-02 -4.1117e-02]]; +%! +%! j = sqrt ((pi/2)./z) .* besselj (n+1/2,z); +%! y = sqrt ((pi/2)./z) .* bessely (n+1/2,z); +%! +%! assert (jt, j, -5e-5); +%! assert (yt, y, -5e-5); + +Table 10.4 - j and y for various integer orders and arguments. + +%!test +%! jt = [[ 8.414709848e-01 4.546487134e-01 -1.917848549e-01 -5.440211109e-02 -5.247497074e-03 -5.063656411e-03]; +%! [ 9.256115861e-05 2.635169770e-03 1.068111615e-01 -5.553451162e-02 -2.004830056e-02 -9.290148935e-03]; +%! [ 7.116552640e-11 6.825300865e-08 4.073442442e-04 6.460515449e-02 -1.503922146e-02 -1.956578597e-04]; +%! [ 5.132686115e-18 1.606982166e-13 1.084280182e-07 1.063542715e-03 -1.129084539e-02 7.877261748e-03]; +%! [ 7.537795722e-26 7.632641101e-20 5.427726761e-12 2.308371961e-06 -1.578502990e-02 1.010767128e-02]; +%! [ 5.566831267e-43 5.836617888e-34 4.282730217e-22 2.512057385e-13 -1.494673454e-03 8.700628514e-03]; +%! [ 1.538210374e-61 1.660978779e-49 1.210347583e-33 8.435671634e-22 -2.606336952e-02 1.043410851e-02]; +%! [ 3.615274717e-81 4.011575290e-66 2.857479350e-46 2.230696023e-31 1.882910737e-02 5.797140882e-04]; +%! [7.444727742e-190 9.367832591e-160 5.535650303e-120 5.832040182e-90 1.019012263e-22 1.088047701e-02]]; +%! +%! yt = [[ -5.403023059e-01 2.080734183e-01 -5.673243709e-02 8.390715291e-02 -1.929932057e-02 -8.623188723e-03] +%! [ -9.994403434e+02 -1.859144531e+01 -3.204650467e-01 9.383354168e-02 -6.971131965e-04 3.720678486e-03] +%! [ -6.722150083e+08 -3.554147201e+05 -2.665611441e+01 -1.724536721e-01 1.352468751e-02 1.002577737e-02] +%! [ -6.298007233e+15 -1.012182944e+11 -6.288146513e+04 -3.992071745e+00 1.712319725e-02 6.258641510e-03] +%! [ -3.239592219e+23 -1.605436493e+17 -9.267951403e+08 -1.211210605e+03 1.375953130e-02 5.631729379e-05] +%! [ -2.946428547e+40 -1.407393871e+31 -7.760717570e+18 -6.908318646e+09 -2.241226812e-02 -5.412929349e-03] +%! [ -8.028450851e+58 -3.720929322e+46 -2.055758716e+30 -1.510304919e+18 4.978797221e-05 -7.048420407e-04] +%! [ -2.739192285e+78 -1.235021944e+63 -6.964109188e+42 -4.528227272e+27 -4.190000150e-02 1.074782297e-02] +%! [-6.683079463e+186 -2.655955830e+156 -1.799713983e+116 -8.573226309e+85 -1.125692891e+18 -2.298385049e-02]]; +%! +%! n = [(0:5:20).';30;40;50;100]; +%! z = [1,2,5,10,50,100]; +%! j = sqrt ((pi/2)./z) .* besselj ((n+1/2).', z.').'; +%! y = sqrt ((pi/2)./z) .* bessely ((n+1/2).', z.').'; +%! assert (j, jt, -1e-9); +%! assert (y, yt, -1e-9); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/betainc.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,491 @@ +/* + +Copyright (C) 1997-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-specfun.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +// FIXME: These functions do not need to be dynamically loaded. They should +// be placed elsewhere in the Octave code hierarchy. + +DEFUN (betainc, args, , + "-*- texinfo -*-\n\ +@deftypefn {Mapping Function} {} betainc (@var{x}, @var{a}, @var{b})\n\ +Return the regularized incomplete Beta function,\n\ +@tex\n\ +$$\n\ + I (x, a, b) = {1 \\over {B (a, b)}} \\int_0^x t^{(a-z)} (1-t)^{(b-1)} dt.\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +@c Set example in small font to prevent overfull line\n\ +\n\ +@smallexample\n\ +@group\n\ + x\n\ + 1 /\n\ +betainc (x, a, b) = ----------- | t^(a-1) (1-t)^(b-1) dt.\n\ + beta (a, b) /\n\ + t=0\n\ +@end group\n\ +@end smallexample\n\ +\n\ +@end ifnottex\n\ +\n\ +If @var{x} has more than one component, both @var{a} and @var{b} must be\n\ +scalars. If @var{x} is a scalar, @var{a} and @var{b} must be of\n\ +compatible dimensions.\n\ +@seealso{betaincinv, beta, betaln}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin == 3) + { + octave_value x_arg = args(0); + octave_value a_arg = args(1); + octave_value b_arg = args(2); + + // FIXME Can we make a template version of the duplicated code below + if (x_arg.is_single_type () || a_arg.is_single_type () || + b_arg.is_single_type ()) + { + if (x_arg.is_scalar_type ()) + { + float x = x_arg.float_value (); + + if (a_arg.is_scalar_type ()) + { + float a = a_arg.float_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + float b = b_arg.float_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<float> b = b_arg.float_array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + else + { + Array<float> a = a_arg.float_array_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + float b = b_arg.float_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<float> b = b_arg.float_array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + } + else + { + Array<float> x = x_arg.float_array_value (); + + if (a_arg.is_scalar_type ()) + { + float a = a_arg.float_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + float b = b_arg.float_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<float> b = b_arg.float_array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + else + { + Array<float> a = a_arg.float_array_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + float b = b_arg.float_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<float> b = b_arg.float_array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + } + } + else + { + if (x_arg.is_scalar_type ()) + { + double x = x_arg.double_value (); + + if (a_arg.is_scalar_type ()) + { + double a = a_arg.double_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + else + { + Array<double> a = a_arg.array_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + } + else + { + Array<double> x = x_arg.array_value (); + + if (a_arg.is_scalar_type ()) + { + double a = a_arg.double_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + else + { + Array<double> a = a_arg.array_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betainc (x, a, b); + } + } + } + } + } + } + else + print_usage (); + + return retval; +} + +/* +## Double precision +%!test +%! a = [1, 1.5, 2, 3]; +%! b = [4, 3, 2, 1]; +%! v1 = betainc (1,a,b); +%! v2 = [1,1,1,1]; +%! x = [.2, .4, .6, .8]; +%! v3 = betainc (x, a, b); +%! v4 = 1 - betainc (1.-x, b, a); +%! assert (v1, v2, sqrt (eps)); +%! assert (v3, v4, sqrt (eps)); + +## Single precision +%!test +%! a = single ([1, 1.5, 2, 3]); +%! b = single ([4, 3, 2, 1]); +%! v1 = betainc (1,a,b); +%! v2 = single ([1,1,1,1]); +%! x = single ([.2, .4, .6, .8]); +%! v3 = betainc (x, a, b); +%! v4 = 1 - betainc (1.-x, b, a); +%! assert (v1, v2, sqrt (eps ("single"))); +%! assert (v3, v4, sqrt (eps ("single"))); + +## Mixed double/single precision +%!test +%! a = single ([1, 1.5, 2, 3]); +%! b = [4, 3, 2, 1]; +%! v1 = betainc (1,a,b); +%! v2 = single ([1,1,1,1]); +%! x = [.2, .4, .6, .8]; +%! v3 = betainc (x, a, b); +%! v4 = 1-betainc (1.-x, b, a); +%! assert (v1, v2, sqrt (eps ("single"))); +%! assert (v3, v4, sqrt (eps ("single"))); + +%!error betainc () +%!error betainc (1) +%!error betainc (1,2) +%!error betainc (1,2,3,4) +*/ + +DEFUN (betaincinv, args, , + "-*- texinfo -*-\n\ +@deftypefn {Mapping Function} {} betaincinv (@var{y}, @var{a}, @var{b})\n\ +Compute the inverse of the incomplete Beta function, i.e., @var{x} such that\n\ +\n\ +@example\n\ +@var{y} == betainc (@var{x}, @var{a}, @var{b}) \n\ +@end example\n\ +@seealso{betainc, beta, betaln}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin == 3) + { + octave_value x_arg = args(0); + octave_value a_arg = args(1); + octave_value b_arg = args(2); + + if (x_arg.is_scalar_type ()) + { + double x = x_arg.double_value (); + + if (a_arg.is_scalar_type ()) + { + double a = a_arg.double_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + } + } + else + { + Array<double> a = a_arg.array_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + } + } + } + else + { + Array<double> x = x_arg.array_value (); + + if (a_arg.is_scalar_type ()) + { + double a = a_arg.double_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + } + } + else + { + Array<double> a = a_arg.array_value (); + + if (! error_state) + { + if (b_arg.is_scalar_type ()) + { + double b = b_arg.double_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + else + { + Array<double> b = b_arg.array_value (); + + if (! error_state) + retval = betaincinv (x, a, b); + } + } + } + } + + // FIXME: It would be better to have an algorithm for betaincinv which + // accepted float inputs and returned float outputs. As it is, we do + // extra work to calculate betaincinv to double precision and then throw + // that precision away. + if (x_arg.is_single_type () || a_arg.is_single_type () || + b_arg.is_single_type ()) + { + retval = Array<float> (retval.array_value ()); + } + } + else + print_usage (); + + return retval; +} + +/* +%!assert (betaincinv ([0.875 0.6875], [1 2], 3), [0.5 0.5], sqrt (eps)) +%!assert (betaincinv (0.5, 3, 3), 0.5, sqrt (eps)) +%!assert (betaincinv (0.34375, 4, 3), 0.5, sqrt (eps)) +%!assert (betaincinv (0.2265625, 5, 3), 0.5, sqrt (eps)) +%!assert (betaincinv (0.14453125, 6, 3), 0.5, sqrt (eps)) +%!assert (betaincinv (0.08984375, 7, 3), 0.5, sqrt (eps)) +%!assert (betaincinv (0.0546875, 8, 3), 0.5, sqrt (eps)) +%!assert (betaincinv (0.03271484375, 9, 3), 0.5, sqrt (eps)) +%!assert (betaincinv (0.019287109375, 10, 3), 0.5, sqrt (eps)) + +## Test class single as well +%!assert (betaincinv ([0.875 0.6875], [1 2], single (3)), [0.5 0.5], sqrt (eps ("single"))) +%!assert (betaincinv (0.5, 3, single (3)), 0.5, sqrt (eps ("single"))) +%!assert (betaincinv (0.34375, 4, single (3)), 0.5, sqrt (eps ("single"))) + +## Extreme values +%!assert (betaincinv (0, 42, 42), 0, sqrt (eps)) +%!assert (betaincinv (1, 42, 42), 1, sqrt (eps)) + +%!error betaincinv () +%!error betaincinv (1, 2) +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/bsxfun.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,813 @@ +/* + +Copyright (C) 2007-2012 David Bateman +Copyright (C) 2009 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> +#include <vector> +#include <list> + +#include "lo-mappers.h" + +#include "oct-map.h" +#include "defun.h" +#include "parse.h" +#include "variables.h" +#include "ov-colon.h" +#include "unwind-prot.h" +#include "ov-fcn-handle.h" + +// Optimized bsxfun operations +enum bsxfun_builtin_op +{ + bsxfun_builtin_plus = 0, + bsxfun_builtin_minus, + bsxfun_builtin_times, + bsxfun_builtin_divide, + bsxfun_builtin_max, + bsxfun_builtin_min, + bsxfun_builtin_eq, + bsxfun_builtin_ne, + bsxfun_builtin_lt, + bsxfun_builtin_le, + bsxfun_builtin_gt, + bsxfun_builtin_ge, + bsxfun_builtin_and, + bsxfun_builtin_or, + bsxfun_builtin_power, + bsxfun_builtin_unknown, + bsxfun_num_builtin_ops = bsxfun_builtin_unknown +}; + +const char *bsxfun_builtin_names[] = +{ + "plus", + "minus", + "times", + "rdivide", + "max", + "min", + "eq", + "ne", + "lt", + "le", + "gt", + "ge", + "and", + "or", + "power" +}; + +static bsxfun_builtin_op +bsxfun_builtin_lookup (const std::string& name) +{ + for (int i = 0; i < bsxfun_num_builtin_ops; i++) + if (name == bsxfun_builtin_names[i]) + return static_cast<bsxfun_builtin_op> (i); + return bsxfun_builtin_unknown; +} + +typedef octave_value (*bsxfun_handler) (const octave_value&, const octave_value&); + +// Static table of handlers. +bsxfun_handler bsxfun_handler_table[bsxfun_num_builtin_ops][btyp_num_types]; + +template <class NDA, NDA (bsxfun_op) (const NDA&, const NDA&)> +static octave_value +bsxfun_forward_op (const octave_value& x, const octave_value& y) +{ + NDA xa = octave_value_extract<NDA> (x); + NDA ya = octave_value_extract<NDA> (y); + return octave_value (bsxfun_op (xa, ya)); +} + +template <class NDA, boolNDArray (bsxfun_rel) (const NDA&, const NDA&)> +static octave_value +bsxfun_forward_rel (const octave_value& x, const octave_value& y) +{ + NDA xa = octave_value_extract<NDA> (x); + NDA ya = octave_value_extract<NDA> (y); + return octave_value (bsxfun_rel (xa, ya)); +} + +// Pow needs a special handler for reals because of the potentially complex result. +template <class NDA, class CNDA> +static octave_value +do_bsxfun_real_pow (const octave_value& x, const octave_value& y) +{ + NDA xa = octave_value_extract<NDA> (x); + NDA ya = octave_value_extract<NDA> (y); + if (! ya.all_integers () && xa.any_element_is_negative ()) + return octave_value (bsxfun_pow (CNDA (xa), ya)); + else + return octave_value (bsxfun_pow (xa, ya)); +} + +static void maybe_fill_table (void) +{ + static bool filled = false; + if (filled) + return; + +#define REGISTER_OP_HANDLER(OP, BTYP, NDA, FUNOP) \ + bsxfun_handler_table[OP][BTYP] = bsxfun_forward_op<NDA, FUNOP> +#define REGISTER_REL_HANDLER(REL, BTYP, NDA, FUNREL) \ + bsxfun_handler_table[REL][BTYP] = bsxfun_forward_rel<NDA, FUNREL> +#define REGISTER_STD_HANDLERS(BTYP, NDA) \ + REGISTER_OP_HANDLER (bsxfun_builtin_plus, BTYP, NDA, bsxfun_add); \ + REGISTER_OP_HANDLER (bsxfun_builtin_minus, BTYP, NDA, bsxfun_sub); \ + REGISTER_OP_HANDLER (bsxfun_builtin_times, BTYP, NDA, bsxfun_mul); \ + REGISTER_OP_HANDLER (bsxfun_builtin_divide, BTYP, NDA, bsxfun_div); \ + REGISTER_OP_HANDLER (bsxfun_builtin_max, BTYP, NDA, bsxfun_max); \ + REGISTER_OP_HANDLER (bsxfun_builtin_min, BTYP, NDA, bsxfun_min); \ + REGISTER_REL_HANDLER (bsxfun_builtin_eq, BTYP, NDA, bsxfun_eq); \ + REGISTER_REL_HANDLER (bsxfun_builtin_ne, BTYP, NDA, bsxfun_ne); \ + REGISTER_REL_HANDLER (bsxfun_builtin_lt, BTYP, NDA, bsxfun_lt); \ + REGISTER_REL_HANDLER (bsxfun_builtin_le, BTYP, NDA, bsxfun_le); \ + REGISTER_REL_HANDLER (bsxfun_builtin_gt, BTYP, NDA, bsxfun_gt); \ + REGISTER_REL_HANDLER (bsxfun_builtin_ge, BTYP, NDA, bsxfun_ge) + + REGISTER_STD_HANDLERS (btyp_double, NDArray); + REGISTER_STD_HANDLERS (btyp_float, FloatNDArray); + REGISTER_STD_HANDLERS (btyp_complex, ComplexNDArray); + REGISTER_STD_HANDLERS (btyp_float_complex, FloatComplexNDArray); + REGISTER_STD_HANDLERS (btyp_int8, int8NDArray); + REGISTER_STD_HANDLERS (btyp_int16, int16NDArray); + REGISTER_STD_HANDLERS (btyp_int32, int32NDArray); + REGISTER_STD_HANDLERS (btyp_int64, int64NDArray); + REGISTER_STD_HANDLERS (btyp_uint8, uint8NDArray); + REGISTER_STD_HANDLERS (btyp_uint16, uint16NDArray); + REGISTER_STD_HANDLERS (btyp_uint32, uint32NDArray); + REGISTER_STD_HANDLERS (btyp_uint64, uint64NDArray); + + // For bools, we register and/or. + REGISTER_OP_HANDLER (bsxfun_builtin_and, btyp_bool, boolNDArray, bsxfun_and); + REGISTER_OP_HANDLER (bsxfun_builtin_or, btyp_bool, boolNDArray, bsxfun_or); + + // Register power handlers. + bsxfun_handler_table[bsxfun_builtin_power][btyp_double] = + do_bsxfun_real_pow<NDArray, ComplexNDArray>; + bsxfun_handler_table[bsxfun_builtin_power][btyp_float] = + do_bsxfun_real_pow<FloatNDArray, FloatComplexNDArray>; + + REGISTER_OP_HANDLER (bsxfun_builtin_power, btyp_complex, ComplexNDArray, bsxfun_pow); + REGISTER_OP_HANDLER (bsxfun_builtin_power, btyp_float_complex, FloatComplexNDArray, bsxfun_pow); + + // For chars, we want just relational handlers. + REGISTER_REL_HANDLER (bsxfun_builtin_eq, btyp_char, charNDArray, bsxfun_eq); + REGISTER_REL_HANDLER (bsxfun_builtin_ne, btyp_char, charNDArray, bsxfun_ne); + REGISTER_REL_HANDLER (bsxfun_builtin_lt, btyp_char, charNDArray, bsxfun_lt); + REGISTER_REL_HANDLER (bsxfun_builtin_le, btyp_char, charNDArray, bsxfun_le); + REGISTER_REL_HANDLER (bsxfun_builtin_gt, btyp_char, charNDArray, bsxfun_gt); + REGISTER_REL_HANDLER (bsxfun_builtin_ge, btyp_char, charNDArray, bsxfun_ge); + + filled = true; +} + +static octave_value +maybe_optimized_builtin (const std::string& name, + const octave_value& a, const octave_value& b) +{ + octave_value retval; + + maybe_fill_table (); + + bsxfun_builtin_op op = bsxfun_builtin_lookup (name); + if (op != bsxfun_builtin_unknown) + { + builtin_type_t btyp_a = a.builtin_type (), btyp_b = b.builtin_type (); + + // Simplify single/double combinations. + if (btyp_a == btyp_float && btyp_b == btyp_double) + btyp_b = btyp_float; + else if (btyp_a == btyp_double && btyp_b == btyp_float) + btyp_a = btyp_float; + else if (btyp_a == btyp_float_complex && btyp_b == btyp_complex) + btyp_b = btyp_float_complex; + else if (btyp_a == btyp_complex && btyp_b == btyp_float_complex) + btyp_a = btyp_float_complex; + + if (btyp_a == btyp_b && btyp_a != btyp_unknown) + { + bsxfun_handler handler = bsxfun_handler_table[op][btyp_a]; + if (handler) + retval = handler (a, b); + } + } + + return retval; +} + +static bool +maybe_update_column (octave_value& Ac, const octave_value& A, + const dim_vector& dva, const dim_vector& dvc, + octave_idx_type i, octave_value_list &idx) +{ + octave_idx_type nd = dva.length (); + + if (i == 0) + { + idx(0) = octave_value (':'); + for (octave_idx_type j = 1; j < nd; j++) + { + if (dva (j) == 1) + idx(j) = octave_value (1); + else + idx(j) = octave_value ((i % dvc(j)) + 1); + + i = i / dvc (j); + } + + Ac = A; + Ac = Ac.single_subsref ("(", idx); + return true; + } + else + { + bool is_changed = false; + octave_idx_type k = i; + octave_idx_type k1 = i - 1; + for (octave_idx_type j = 1; j < nd; j++) + { + if (dva(j) != 1 && k % dvc (j) != k1 % dvc (j)) + { + idx (j) = octave_value ((k % dvc(j)) + 1); + is_changed = true; + } + + k = k / dvc (j); + k1 = k1 / dvc (j); + } + + if (is_changed) + { + Ac = A; + Ac = Ac.single_subsref ("(", idx); + return true; + } + else + return false; + } +} + +#if 0 +// FIXME -- this function is not used; is it OK to delete it? +static void +update_index (octave_value_list& idx, const dim_vector& dv, octave_idx_type i) +{ + octave_idx_type nd = dv.length (); + + if (i == 0) + { + for (octave_idx_type j = nd - 1; j > 0; j--) + idx(j) = octave_value (static_cast<double>(1)); + idx(0) = octave_value (':'); + } + else + { + for (octave_idx_type j = 1; j < nd; j++) + { + idx (j) = octave_value (i % dv (j) + 1); + i = i / dv (j); + } + } +} +#endif + +static void +update_index (Array<int>& idx, const dim_vector& dv, octave_idx_type i) +{ + octave_idx_type nd = dv.length (); + + idx(0) = 0; + for (octave_idx_type j = 1; j < nd; j++) + { + idx (j) = i % dv (j); + i = i / dv (j); + } +} + +DEFUN (bsxfun, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} bsxfun (@var{f}, @var{A}, @var{B})\n\ +The binary singleton expansion function applier performs broadcasting,\n\ +that is, applies a binary function @var{f} element-by-element to two\n\ +array arguments @var{A} and @var{B}, and expands as necessary\n\ +singleton dimensions in either input argument. @var{f} is a function\n\ +handle, inline function, or string containing the name of the function\n\ +to evaluate. The function @var{f} must be capable of accepting two\n\ +column-vector arguments of equal length, or one column vector argument\n\ +and a scalar.\n\ +\n\ +The dimensions of @var{A} and @var{B} must be equal or singleton. The\n\ +singleton dimensions of the arrays will be expanded to the same\n\ +dimensionality as the other array.\n\ +@seealso{arrayfun, cellfun}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value_list retval; + + if (nargin != 3) + print_usage (); + else + { + octave_value func = args(0); + + if (func.is_string ()) + { + std::string name = func.string_value (); + func = symbol_table::find_function (name); + if (func.is_undefined ()) + error ("bsxfun: invalid function name: %s", name.c_str ()); + } + else if (! (args(0).is_function_handle () || args(0).is_inline_function ())) + error ("bsxfun: F must be a string or function handle"); + + const octave_value A = args (1); + const octave_value B = args (2); + + if (func.is_builtin_function () + || (func.is_function_handle () && ! A.is_object () && ! B.is_object ())) + { + // This may break if the default behavior is overriden. But if you override + // arithmetic operators for builtin classes, you should expect mayhem + // anyway (constant folding etc). Querying is_overloaded may not be + // exactly what we need here. + octave_function *fcn_val = func.function_value (); + if (fcn_val) + { + octave_value tmp = maybe_optimized_builtin (fcn_val->name (), A, B); + if (tmp.is_defined ()) + retval(0) = tmp; + } + } + + if (! error_state && retval.empty ()) + { + dim_vector dva = A.dims (); + octave_idx_type nda = dva.length (); + dim_vector dvb = B.dims (); + octave_idx_type ndb = dvb.length (); + octave_idx_type nd = nda; + + if (nda > ndb) + dvb.resize (nda, 1); + else if (nda < ndb) + { + dva.resize (ndb, 1); + nd = ndb; + } + + for (octave_idx_type i = 0; i < nd; i++) + if (dva (i) != dvb (i) && dva (i) != 1 && dvb (i) != 1) + { + error ("bsxfun: dimensions of A and B must match"); + break; + } + + if (!error_state) + { + // Find the size of the output + dim_vector dvc; + dvc.resize (nd); + + for (octave_idx_type i = 0; i < nd; i++) + dvc (i) = (dva (i) < 1 ? dva (i) : (dvb (i) < 1 ? dvb (i) : + (dva (i) > dvb (i) ? dva (i) : dvb (i)))); + + if (dva == dvb || dva.numel () == 1 || dvb.numel () == 1) + { + octave_value_list inputs; + inputs (0) = A; + inputs (1) = B; + retval = func.do_multi_index_op (1, inputs); + } + else if (dvc.numel () < 1) + { + octave_value_list inputs; + inputs (0) = A.resize (dvc); + inputs (1) = B.resize (dvc); + retval = func.do_multi_index_op (1, inputs); + } + else + { + octave_idx_type ncount = 1; + for (octave_idx_type i = 1; i < nd; i++) + ncount *= dvc (i); + +#define BSXDEF(T) \ + T result_ ## T; \ + bool have_ ## T = false; + + BSXDEF(NDArray); + BSXDEF(ComplexNDArray); + BSXDEF(FloatNDArray); + BSXDEF(FloatComplexNDArray); + BSXDEF(boolNDArray); + BSXDEF(int8NDArray); + BSXDEF(int16NDArray); + BSXDEF(int32NDArray); + BSXDEF(int64NDArray); + BSXDEF(uint8NDArray); + BSXDEF(uint16NDArray); + BSXDEF(uint32NDArray); + BSXDEF(uint64NDArray); + + octave_value Ac ; + octave_value_list idxA; + octave_value Bc; + octave_value_list idxB; + octave_value C; + octave_value_list inputs; + Array<int> ra_idx (dim_vector (dvc.length (), 1), 0); + + + for (octave_idx_type i = 0; i < ncount; i++) + { + if (maybe_update_column (Ac, A, dva, dvc, i, idxA)) + inputs (0) = Ac; + + if (maybe_update_column (Bc, B, dvb, dvc, i, idxB)) + inputs (1) = Bc; + + octave_value_list tmp = func.do_multi_index_op (1, inputs); + + if (error_state) + break; + +#define BSXINIT(T, CLS, EXTRACTOR) \ + (result_type == CLS) \ + { \ + have_ ## T = true; \ + result_ ## T = \ + tmp (0). EXTRACTOR ## _array_value (); \ + result_ ## T .resize (dvc); \ + } + + if (i == 0) + { + if (! tmp(0).is_sparse_type ()) + { + std::string result_type = tmp(0).class_name (); + if (result_type == "double") + { + if (tmp(0).is_real_type ()) + { + have_NDArray = true; + result_NDArray = tmp(0).array_value (); + result_NDArray.resize (dvc); + } + else + { + have_ComplexNDArray = true; + result_ComplexNDArray = + tmp(0).complex_array_value (); + result_ComplexNDArray.resize (dvc); + } + } + else if (result_type == "single") + { + if (tmp(0).is_real_type ()) + { + have_FloatNDArray = true; + result_FloatNDArray = tmp(0).float_array_value (); + result_FloatNDArray.resize (dvc); + } + else + { + have_ComplexNDArray = true; + result_ComplexNDArray = + tmp(0).complex_array_value (); + result_ComplexNDArray.resize (dvc); + } + } + else if BSXINIT(boolNDArray, "logical", bool) + else if BSXINIT(int8NDArray, "int8", int8) + else if BSXINIT(int16NDArray, "int16", int16) + else if BSXINIT(int32NDArray, "int32", int32) + else if BSXINIT(int64NDArray, "int64", int64) + else if BSXINIT(uint8NDArray, "uint8", uint8) + else if BSXINIT(uint16NDArray, "uint16", uint16) + else if BSXINIT(uint32NDArray, "uint32", uint32) + else if BSXINIT(uint64NDArray, "uint64", uint64) + else + { + C = tmp (0); + C = C.resize (dvc); + } + } + } + else + { + update_index (ra_idx, dvc, i); + + if (have_FloatNDArray || + have_FloatComplexNDArray) + { + if (! tmp(0).is_float_type ()) + { + if (have_FloatNDArray) + { + have_FloatNDArray = false; + C = result_FloatNDArray; + } + else + { + have_FloatComplexNDArray = false; + C = result_FloatComplexNDArray; + } + C = do_cat_op (C, tmp(0), ra_idx); + } + else if (tmp(0).is_double_type ()) + { + if (tmp(0).is_complex_type () && + have_FloatNDArray) + { + result_ComplexNDArray = + ComplexNDArray (result_FloatNDArray); + result_ComplexNDArray.insert + (tmp(0).complex_array_value (), ra_idx); + have_FloatComplexNDArray = false; + have_ComplexNDArray = true; + } + else + { + result_NDArray = + NDArray (result_FloatNDArray); + result_NDArray.insert + (tmp(0).array_value (), ra_idx); + have_FloatNDArray = false; + have_NDArray = true; + } + } + else if (tmp(0).is_real_type ()) + result_FloatNDArray.insert + (tmp(0).float_array_value (), ra_idx); + else + { + result_FloatComplexNDArray = + FloatComplexNDArray (result_FloatNDArray); + result_FloatComplexNDArray.insert + (tmp(0).float_complex_array_value (), ra_idx); + have_FloatNDArray = false; + have_FloatComplexNDArray = true; + } + } + else if (have_NDArray) + { + if (! tmp(0).is_float_type ()) + { + have_NDArray = false; + C = result_NDArray; + C = do_cat_op (C, tmp(0), ra_idx); + } + else if (tmp(0).is_real_type ()) + result_NDArray.insert (tmp(0).array_value (), + ra_idx); + else + { + result_ComplexNDArray = + ComplexNDArray (result_NDArray); + result_ComplexNDArray.insert + (tmp(0).complex_array_value (), ra_idx); + have_NDArray = false; + have_ComplexNDArray = true; + } + } + +#define BSXLOOP(T, CLS, EXTRACTOR) \ + (have_ ## T) \ + { \ + if (tmp (0).class_name () != CLS) \ + { \ + have_ ## T = false; \ + C = result_ ## T; \ + C = do_cat_op (C, tmp (0), ra_idx); \ + } \ + else \ + result_ ## T .insert \ + (tmp(0). EXTRACTOR ## _array_value (), \ + ra_idx); \ + } + + else if BSXLOOP(ComplexNDArray, "double", complex) + else if BSXLOOP(boolNDArray, "logical", bool) + else if BSXLOOP(int8NDArray, "int8", int8) + else if BSXLOOP(int16NDArray, "int16", int16) + else if BSXLOOP(int32NDArray, "int32", int32) + else if BSXLOOP(int64NDArray, "int64", int64) + else if BSXLOOP(uint8NDArray, "uint8", uint8) + else if BSXLOOP(uint16NDArray, "uint16", uint16) + else if BSXLOOP(uint32NDArray, "uint32", uint32) + else if BSXLOOP(uint64NDArray, "uint64", uint64) + else + C = do_cat_op (C, tmp(0), ra_idx); + } + } + +#define BSXEND(T) \ + (have_ ## T) \ + retval(0) = result_ ## T; + + if BSXEND(NDArray) + else if BSXEND(ComplexNDArray) + else if BSXEND(FloatNDArray) + else if BSXEND(FloatComplexNDArray) + else if BSXEND(boolNDArray) + else if BSXEND(int8NDArray) + else if BSXEND(int16NDArray) + else if BSXEND(int32NDArray) + else if BSXEND(int64NDArray) + else if BSXEND(uint8NDArray) + else if BSXEND(uint16NDArray) + else if BSXEND(uint32NDArray) + else if BSXEND(uint64NDArray) + else + retval(0) = C; + } + } + } + } + + return retval; +} + +/* + +%!shared a, b, c, f +%! a = randn (4, 4); +%! b = mean (a, 1); +%! c = mean (a, 2); +%! f = @minus; +%!error (bsxfun (f)) +%!error (bsxfun (f, a)) +%!error (bsxfun (a, b)) +%!error (bsxfun (a, b, c)) +%!error (bsxfun (f, a, b, c)) +%!error (bsxfun (f, ones (4, 0), ones (4, 4))) +%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0)) +%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), zeros (4, 4)) +%!assert (bsxfun (f, a, b), a - repmat (b, 4, 1)) +%!assert (bsxfun (f, a, c), a - repmat (c, 1, 4)) +%!assert (bsxfun ("minus", ones (1, 4), ones (4, 1)), zeros (4, 4)) + +%!shared a, b, c, f +%! a = randn (4, 4); +%! a(1) *= 1i; +%! b = mean (a, 1); +%! c = mean (a, 2); +%! f = @minus; +%!error (bsxfun (f)) +%!error (bsxfun (f, a)) +%!error (bsxfun (a, b)) +%!error (bsxfun (a, b, c)) +%!error (bsxfun (f, a, b, c)) +%!error (bsxfun (f, ones (4, 0), ones (4, 4))) +%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0)) +%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), zeros (4, 4)) +%!assert (bsxfun (f, a, b), a - repmat (b, 4, 1)) +%!assert (bsxfun (f, a, c), a - repmat (c, 1, 4)) +%!assert (bsxfun ("minus", ones (1, 4), ones (4, 1)), zeros (4, 4)) + +%!shared a, b, c, f +%! a = randn (4, 4); +%! a(end) *= 1i; +%! b = mean (a, 1); +%! c = mean (a, 2); +%! f = @minus; +%!error (bsxfun (f)) +%!error (bsxfun (f, a)) +%!error (bsxfun (a, b)) +%!error (bsxfun (a, b, c)) +%!error (bsxfun (f, a, b, c)) +%!error (bsxfun (f, ones (4, 0), ones (4, 4))) +%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0)) +%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), zeros (4, 4)) +%!assert (bsxfun (f, a, b), a - repmat (b, 4, 1)) +%!assert (bsxfun (f, a, c), a - repmat (c, 1, 4)) +%!assert (bsxfun ("minus", ones (1, 4), ones (4, 1)), zeros (4, 4)) + +%!shared a, b, c, f +%! a = randn (4, 4); +%! b = a (1, :); +%! c = a (:, 1); +%! f = @(x, y) x == y; +%!error (bsxfun (f)) +%!error (bsxfun (f, a)) +%!error (bsxfun (a, b)) +%!error (bsxfun (a, b, c)) +%!error (bsxfun (f, a, b, c)) +%!error (bsxfun (f, ones (4, 0), ones (4, 4))) +%!assert (bsxfun (f, ones (4, 0), ones (4, 1)), zeros (4, 0, "logical")) +%!assert (bsxfun (f, ones (1, 4), ones (4, 1)), ones (4, 4, "logical")) +%!assert (bsxfun (f, a, b), a == repmat (b, 4, 1)) +%!assert (bsxfun (f, a, c), a == repmat (c, 1, 4)) + +%!shared a, b, c, d, f +%! a = randn (4, 4, 4); +%! b = mean (a, 1); +%! c = mean (a, 2); +%! d = mean (a, 3); +%! f = @minus; +%!error (bsxfun (f, ones ([4, 0, 4]), ones ([4, 4, 4]))) +%!assert (bsxfun (f, ones ([4, 0, 4]), ones ([4, 1, 4])), zeros ([4, 0, 4])) +%!assert (bsxfun (f, ones ([4, 4, 0]), ones ([4, 1, 1])), zeros ([4, 4, 0])) +%!assert (bsxfun (f, ones ([1, 4, 4]), ones ([4, 1, 4])), zeros ([4, 4, 4])) +%!assert (bsxfun (f, ones ([4, 4, 1]), ones ([4, 1, 4])), zeros ([4, 4, 4])) +%!assert (bsxfun (f, ones ([4, 1, 4]), ones ([1, 4, 4])), zeros ([4, 4, 4])) +%!assert (bsxfun (f, ones ([4, 1, 4]), ones ([1, 4, 1])), zeros ([4, 4, 4])) +%!assert (bsxfun (f, a, b), a - repmat (b, [4, 1, 1])) +%!assert (bsxfun (f, a, c), a - repmat (c, [1, 4, 1])) +%!assert (bsxfun (f, a, d), a - repmat (d, [1, 1, 4])) +%!assert (bsxfun ("minus", ones ([4, 0, 4]), ones ([4, 1, 4])), zeros ([4, 0, 4])) + +%% The test below is a very hard case to treat +%!assert (bsxfun (f, ones ([4, 1, 4, 1]), ones ([1, 4, 1, 4])), zeros ([4, 4, 4, 4])); + +%!shared a, b, aa, bb +%! a = randn (3, 1, 3); +%! aa = a(:, ones (1, 3), :, ones (1, 3)); +%! b = randn (1, 3, 3, 3); +%! bb = b(ones (1, 3), :, :, :); +%!assert (bsxfun (@plus, a, b), aa + bb) +%!assert (bsxfun (@minus, a, b), aa - bb) +%!assert (bsxfun (@times, a, b), aa .* bb) +%!assert (bsxfun (@rdivide, a, b), aa ./ bb) +%!assert (bsxfun (@ldivide, a, b), aa .\ bb) +%!assert (bsxfun (@power, a, b), aa .^ bb) +%!assert (bsxfun (@power, abs (a), b), abs (aa) .^ bb) +%!assert (bsxfun (@eq, round (a), round (b)), round (aa) == round (bb)) +%!assert (bsxfun (@ne, round (a), round (b)), round (aa) != round (bb)) +%!assert (bsxfun (@lt, a, b), aa < bb) +%!assert (bsxfun (@le, a, b), aa <= bb) +%!assert (bsxfun (@gt, a, b), aa > bb) +%!assert (bsxfun (@ge, a, b), aa >= bb) +%!assert (bsxfun (@min, a, b), min (aa, bb)) +%!assert (bsxfun (@max, a, b), max (aa, bb)) +%!assert (bsxfun (@and, a > 0, b > 0), (aa > 0) & (bb > 0)) +%!assert (bsxfun (@or, a > 0, b > 0), (aa > 0) | (bb > 0)) + +%% Test automatic bsxfun +% +%!test +%! funs = {@plus, @minus, @times, @rdivide, @ldivide, @power, @max, @min, \ +%! @rem, @mod, @atan2, @hypot, @eq, @ne, @lt, @le, @gt, @ge, \ +%! @and, @or, @xor }; +%! +%! float_types = {@single, @double}; +%! int_types = {@int8, @int16, @int32, @int64, \ +%! @uint8, @uint16, @uint32, @uint64}; +%! +%! x = rand (3) * 10-5; +%! y = rand (3,1) * 10-5; +%! +%! for i=1:length (funs) +%! for j = 1:length (float_types) +%! for k = 1:length (int_types) +%! +%! fun = funs{i}; +%! f_type = float_types{j}; +%! i_type = int_types{k}; +%! +%! assert (bsxfun (fun, f_type (x), i_type (y)), \ +%! fun (f_type(x), i_type (y))); +%! assert (bsxfun (fun, f_type (y), i_type (x)), \ +%! fun (f_type(y), i_type (x))); +%! +%! assert (bsxfun (fun, i_type (x), i_type (y)), \ +%! fun (i_type (x), i_type (y))); +%! assert (bsxfun (fun, i_type (y), i_type (x)), \ +%! fun (i_type (y), i_type (x))); +%! +%! assert (bsxfun (fun, f_type (x), f_type (y)), \ +%! fun (f_type (x), f_type (y))); +%! assert (bsxfun (fun, f_type(y), f_type(x)), \ +%! fun (f_type (y), f_type (x))); +%! endfor +%! endfor +%! endfor +%! +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/cellfun.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,2472 @@ +/* + +Copyright (C) 2005-2012 Mohamed Kamoun +Copyright (C) 2006-2012 Bill Denney +Copyright (C) 2009 Jaroslav Hajek +Copyright (C) 2010 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> +#include <vector> +#include <list> +#include <memory> + +#include "caseless-str.h" +#include "lo-mappers.h" +#include "oct-locbuf.h" + +#include "Cell.h" +#include "oct-map.h" +#include "defun.h" +#include "parse.h" +#include "variables.h" +#include "ov-colon.h" +#include "unwind-prot.h" +#include "gripes.h" +#include "utils.h" + +#include "ov-class.h" +#include "ov-scalar.h" +#include "ov-float.h" +#include "ov-complex.h" +#include "ov-flt-complex.h" +#include "ov-bool.h" +#include "ov-int8.h" +#include "ov-int16.h" +#include "ov-int32.h" +#include "ov-int64.h" +#include "ov-uint8.h" +#include "ov-uint16.h" +#include "ov-uint32.h" +#include "ov-uint64.h" + +#include "ov-fcn-handle.h" + +static octave_value_list +get_output_list (octave_idx_type count, octave_idx_type nargout, + const octave_value_list& inputlist, + octave_value& func, + octave_value& error_handler) +{ + octave_value_list tmp = func.do_multi_index_op (nargout, inputlist); + + if (error_state) + { + if (error_handler.is_defined ()) + { + octave_scalar_map msg; + msg.assign ("identifier", last_error_id ()); + msg.assign ("message", last_error_message ()); + msg.assign ("index", static_cast<double> (count + static_cast<octave_idx_type>(1))); + + octave_value_list errlist = inputlist; + errlist.prepend (msg); + + buffer_error_messages--; + + error_state = 0; + + tmp = error_handler.do_multi_index_op (nargout, errlist); + + buffer_error_messages++; + + if (error_state) + tmp.clear (); + } + else + tmp.clear (); + } + + return tmp; +} + +static octave_value_list +try_cellfun_internal_ops (const octave_value_list& args, int nargin) +{ + octave_value_list retval; + + std::string name = args(0).string_value (); + + const Cell f_args = args(1).cell_value (); + + octave_idx_type k = f_args.numel (); + + if (name == "isempty") + { + boolNDArray result (f_args.dims ()); + for (octave_idx_type count = 0; count < k; count++) + result(count) = f_args.elem (count).is_empty (); + retval(0) = result; + } + else if (name == "islogical") + { + boolNDArray result (f_args.dims ()); + for (octave_idx_type count= 0; count < k; count++) + result(count) = f_args.elem (count).is_bool_type (); + retval(0) = result; + } + else if (name == "isreal") + { + boolNDArray result (f_args.dims ()); + for (octave_idx_type count= 0; count < k; count++) + result(count) = f_args.elem (count).is_real_type (); + retval(0) = result; + } + else if (name == "length") + { + NDArray result (f_args.dims ()); + for (octave_idx_type count= 0; count < k; count++) + result(count) = static_cast<double> (f_args.elem (count).length ()); + retval(0) = result; + } + else if (name == "ndims") + { + NDArray result (f_args.dims ()); + for (octave_idx_type count = 0; count < k; count++) + result(count) = static_cast<double> (f_args.elem (count).ndims ()); + retval(0) = result; + } + else if (name == "prodofsize" || name == "numel") + { + NDArray result (f_args.dims ()); + for (octave_idx_type count = 0; count < k; count++) + result(count) = static_cast<double> (f_args.elem (count).numel ()); + retval(0) = result; + } + else if (name == "size") + { + if (nargin == 3) + { + int d = args(2).nint_value () - 1; + + if (d < 0) + error ("cellfun: K must be a positive integer"); + + if (! error_state) + { + NDArray result (f_args.dims ()); + for (octave_idx_type count = 0; count < k; count++) + { + dim_vector dv = f_args.elem (count).dims (); + if (d < dv.length ()) + result(count) = static_cast<double> (dv(d)); + else + result(count) = 1.0; + } + retval(0) = result; + } + } + else + error ("cellfun: not enough arguments for \"size\""); + } + else if (name == "isclass") + { + if (nargin == 3) + { + std::string class_name = args(2).string_value (); + boolNDArray result (f_args.dims ()); + for (octave_idx_type count = 0; count < k; count++) + result(count) = (f_args.elem (count).class_name () == class_name); + + retval(0) = result; + } + else + error ("cellfun: not enough arguments for \"isclass\""); + } + + return retval; +} + +static void +get_mapper_fun_options (const octave_value_list& args, int& nargin, + bool& uniform_output, octave_value& error_handler) +{ + while (nargin > 3 && args(nargin-2).is_string ()) + { + caseless_str arg = args(nargin-2).string_value (); + + size_t compare_len = std::max (arg.length (), static_cast<size_t> (2)); + + if (arg.compare ("uniformoutput", compare_len)) + uniform_output = args(nargin-1).bool_value (); + else if (arg.compare ("errorhandler", compare_len)) + { + if (args(nargin-1).is_function_handle () + || args(nargin-1).is_inline_function ()) + { + error_handler = args(nargin-1); + } + else if (args(nargin-1).is_string ()) + { + std::string err_name = args(nargin-1).string_value (); + + error_handler = symbol_table::find_function (err_name); + + if (error_handler.is_undefined ()) + { + error ("cellfun: invalid function NAME: %s", + err_name.c_str ()); + break; + } + } + else + { + error ("cellfun: invalid value for 'ErrorHandler' function"); + break; + } + } + else + { + error ("cellfun: unrecognized parameter %s", + arg.c_str ()); + break; + } + + nargin -= 2; + } + + nargin -= 1; +} + +DEFUN (cellfun, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} cellfun (@var{name}, @var{C})\n\ +@deftypefnx {Built-in Function} {} cellfun (\"size\", @var{C}, @var{k})\n\ +@deftypefnx {Built-in Function} {} cellfun (\"isclass\", @var{C}, @var{class})\n\ +@deftypefnx {Built-in Function} {} cellfun (@var{func}, @var{C})\n\ +@deftypefnx {Built-in Function} {} cellfun (@var{func}, @var{C}, @var{D})\n\ +@deftypefnx {Built-in Function} {[@var{a}, @dots{}] =} cellfun (@dots{})\n\ +@deftypefnx {Built-in Function} {} cellfun (@dots{}, \"ErrorHandler\", @var{errfunc})\n\ +@deftypefnx {Built-in Function} {} cellfun (@dots{}, \"UniformOutput\", @var{val})\n\ +\n\ +Evaluate the function named @var{name} on the elements of the cell array\n\ +@var{C}. Elements in @var{C} are passed on to the named function\n\ +individually. The function @var{name} can be one of the functions\n\ +\n\ +@table @code\n\ +@item isempty\n\ +Return 1 for empty elements.\n\ +\n\ +@item islogical\n\ +Return 1 for logical elements.\n\ +\n\ +@item isreal\n\ +Return 1 for real elements.\n\ +\n\ +@item length\n\ +Return a vector of the lengths of cell elements.\n\ +\n\ +@item ndims\n\ +Return the number of dimensions of each element.\n\ +\n\ +@item numel\n\ +@itemx prodofsize\n\ +Return the number of elements contained within each cell element. The\n\ +number is the product of the dimensions of the object at each cell element.\n\ +\n\ +@item size\n\ +Return the size along the @var{k}-th dimension.\n\ +\n\ +@item isclass\n\ +Return 1 for elements of @var{class}.\n\ +@end table\n\ +\n\ +Additionally, @code{cellfun} accepts an arbitrary function @var{func}\n\ +in the form of an inline function, function handle, or the name of a\n\ +function (in a character string). In the case of a character string\n\ +argument, the function must accept a single argument named @var{x}, and\n\ +it must return a string value. The function can take one or more arguments,\n\ +with the inputs arguments given by @var{C}, @var{D}, etc. Equally the\n\ +function can return one or more output arguments. For example:\n\ +\n\ +@example\n\ +@group\n\ +cellfun (\"atan2\", @{1, 0@}, @{0, 1@})\n\ + @result{} [ 1.57080 0.00000 ]\n\ +@end group\n\ +@end example\n\ +\n\ +The number of output arguments of @code{cellfun} matches the number of output\n\ +arguments of the function. The outputs of the function will be collected\n\ +into the output arguments of @code{cellfun} like this:\n\ +\n\ +@example\n\ +@group\n\ +function [a, b] = twoouts (x)\n\ + a = x;\n\ + b = x*x;\n\ +endfunction\n\ +[aa, bb] = cellfun (@@twoouts, @{1, 2, 3@})\n\ + @result{}\n\ + aa =\n\ + 1 2 3\n\ + bb =\n\ + 1 4 9\n\ +@end group\n\ +@end example\n\ +\n\ +Note that per default the output argument(s) are arrays of the same size as\n\ +the input arguments. Input arguments that are singleton (1x1) cells will be\n\ +automatically expanded to the size of the other arguments.\n\ +\n\ +If the parameter \"UniformOutput\" is set to true (the default), then the\n\ +function must return scalars which will be concatenated into the return\n\ +array(s). If \"UniformOutput\" is false, the outputs are concatenated into a\n\ +cell array (or cell arrays). For example:\n\ +\n\ +@example\n\ +@group\n\ +cellfun (\"tolower\", @{\"Foo\", \"Bar\", \"FooBar\"@},\n\ + \"UniformOutput\", false)\n\ +@result{} @{\"foo\", \"bar\", \"foobar\"@}\n\ +@end group\n\ +@end example\n\ +\n\ +Given the parameter \"ErrorHandler\", then @var{errfunc} defines a function\n\ +to call in case @var{func} generates an error. The form of the function is\n\ +\n\ +@example\n\ +function [@dots{}] = errfunc (@var{s}, @dots{})\n\ +@end example\n\ +\n\ +@noindent\n\ +where there is an additional input argument to @var{errfunc} relative to\n\ +@var{func}, given by @var{s}. This is a structure with the elements\n\ +'identifier', 'message' and 'index', giving respectively the error\n\ +identifier, the error message, and the index into the input arguments\n\ +of the element that caused the error. For example:\n\ +\n\ +@example\n\ +@group\n\ +function y = foo (s, x), y = NaN; endfunction\n\ +cellfun (\"factorial\", @{-1,2@}, \"ErrorHandler\", @@foo)\n\ +@result{} [NaN 2]\n\ +@end group\n\ +@end example\n\ +\n\ +Use @code{cellfun} intelligently. The @code{cellfun} function is a\n\ +useful tool for avoiding loops. It is often used with anonymous\n\ +function handles; however, calling an anonymous function involves an\n\ +overhead quite comparable to the overhead of an m-file function.\n\ +Passing a handle to a built-in function is faster, because the\n\ +interpreter is not involved in the internal loop. For example:\n\ +\n\ +@example\n\ +@group\n\ +a = @{@dots{}@}\n\ +v = cellfun (@@(x) det (x), a); # compute determinants\n\ +v = cellfun (@@det, a); # faster\n\ +@end group\n\ +@end example\n\ +\n\ +@seealso{arrayfun, structfun, spfun}\n\ +@end deftypefn") +{ + octave_value_list retval; + int nargin = args.length (); + int nargout1 = (nargout < 1 ? 1 : nargout); + + if (nargin < 2) + { + error ("cellfun: function requires at least 2 arguments"); + print_usage (); + return retval; + } + + octave_value func = args(0); + + if (! args(1).is_cell ()) + { + error ("cellfun: C must be a cell array"); + + return retval; + } + + if (func.is_string ()) + { + retval = try_cellfun_internal_ops (args, nargin); + + if (error_state || ! retval.empty ()) + return retval; + + // See if we can convert the string into a function. + + std::string name = args(0).string_value (); + + if (! valid_identifier (name)) + { + std::string fcn_name = unique_symbol_name ("__cellfun_fcn_"); + std::string fname = "function y = " + fcn_name + "(x) y = "; + + octave_function *ptr_func + = extract_function (args(0), "cellfun", fcn_name, + fname, "; endfunction"); + + if (ptr_func && ! error_state) + func = octave_value (ptr_func, true); + } + else + { + func = symbol_table::find_function (name); + + if (func.is_undefined ()) + error ("cellfun: invalid function NAME: %s", name.c_str ()); + } + + if (error_state || ! retval.empty ()) + return retval; + } + + if (func.is_function_handle () || func.is_inline_function () + || func.is_function ()) + { + + // The following is an optimisation because the symbol table can + // give a more specific function class, so this can result in + // fewer polymorphic function calls as the function gets called + // for each value of the array. + { + if (func.is_function_handle ()) + { + octave_fcn_handle* f = func.fcn_handle_value (); + + // Overloaded function handles need to check the type of the + // arguments for each element of the array, so they cannot + // be optimised this way. + if (f -> is_overloaded ()) + goto nevermind; + } + + std::string name = func.function_value () -> name (); + octave_value f = symbol_table::find_function (name); + + if (f.is_defined ()) + { + //Except for these two which are special cases... + if (name != "size" && name != "class") + { + //Try first the optimised code path for built-in functions + octave_value_list tmp_args = args; + tmp_args(0) = name; + retval = try_cellfun_internal_ops (tmp_args, nargin); + if (error_state || ! retval.empty ()) + return retval; + } + + //Okay, we tried, doesn't work, let's do the best we can + //instead and avoid polymorphic calls for each element of + //the array. + func = f; + } + } + nevermind: + + bool uniform_output = true; + octave_value error_handler; + + get_mapper_fun_options (args, nargin, uniform_output, error_handler); + + if (error_state) + return octave_value_list (); + + // Extract cell arguments. + + octave_value_list inputlist (nargin, octave_value ()); + + OCTAVE_LOCAL_BUFFER (Cell, inputs, nargin); + OCTAVE_LOCAL_BUFFER (bool, mask, nargin); + + // This is to prevent copy-on-write. + const Cell *cinputs = inputs; + + octave_idx_type k = 1; + + dim_vector fdims (1, 1); + + // Collect arguments. Pre-fill scalar elements of inputlist + // array. + + for (int j = 0; j < nargin; j++) + { + if (! args(j+1).is_cell ()) + { + error ("cellfun: arguments must be cells"); + return octave_value_list (); + } + + inputs[j] = args(j+1).cell_value (); + mask[j] = inputs[j].numel () != 1; + if (! mask[j]) + inputlist(j) = cinputs[j](0); + } + + for (int j = 0; j < nargin; j++) + { + if (mask[j]) + { + fdims = inputs[j].dims (); + k = inputs[j].numel (); + for (int i = j+1; i < nargin; i++) + { + if (mask[i] && inputs[i].dims () != fdims) + { + error ("cellfun: dimensions mismatch"); + return octave_value_list (); + } + } + break; + } + } + + unwind_protect frame; + frame.protect_var (buffer_error_messages); + + if (error_handler.is_defined ()) + buffer_error_messages++; + + // Apply functions. + + if (uniform_output) + { + std::list<octave_value_list> idx_list (1); + idx_list.front ().resize (1); + std::string idx_type = "("; + + OCTAVE_LOCAL_BUFFER (octave_value, retv, nargout1); + + for (octave_idx_type count = 0; count < k; count++) + { + for (int j = 0; j < nargin; j++) + { + if (mask[j]) + inputlist.xelem (j) = cinputs[j](count); + } + + const octave_value_list tmp + = get_output_list (count, nargout, inputlist, func, + error_handler); + + if (error_state) + return retval; + + if (nargout > 0 && tmp.length () < nargout) + { + error ("cellfun: function returned fewer than nargout values"); + return retval; + } + + if (nargout > 0 + || (nargout == 0 + && tmp.length () > 0 && tmp(0).is_defined ())) + { + int num_to_copy = tmp.length (); + + if (num_to_copy > nargout1) + num_to_copy = nargout1; + + if (count == 0) + { + for (int j = 0; j < num_to_copy; j++) + { + if (tmp(j).is_defined ()) + { + octave_value val = tmp(j); + + if (val.numel () == 1) + retv[j] = val.resize (fdims); + else + { + error ("cellfun: all values must be scalars when UniformOutput = true"); + break; + } + } + } + } + else + { + for (int j = 0; j < num_to_copy; j++) + { + if (tmp(j).is_defined ()) + { + octave_value val = tmp(j); + + if (! retv[j].fast_elem_insert (count, val)) + { + if (val.numel () == 1) + { + idx_list.front ()(0) = count + 1.0; + retv[j].assign (octave_value::op_asn_eq, + idx_type, idx_list, val); + + if (error_state) + break; + } + else + { + error ("cellfun: all values must be scalars when UniformOutput = true"); + break; + } + } + } + } + } + } + + if (error_state) + break; + } + + retval.resize (nargout1); + + for (int j = 0; j < nargout1; j++) + { + if (nargout > 0 && retv[j].is_undefined ()) + retval(j) = NDArray (fdims); + else + retval(j) = retv[j]; + } + } + else + { + OCTAVE_LOCAL_BUFFER (Cell, results, nargout1); + + for (int j = 0; j < nargout1; j++) + results[j].resize (fdims, Matrix ()); + + bool have_some_output = false; + + for (octave_idx_type count = 0; count < k; count++) + { + for (int j = 0; j < nargin; j++) + { + if (mask[j]) + inputlist.xelem (j) = cinputs[j](count); + } + + const octave_value_list tmp + = get_output_list (count, nargout, inputlist, func, + error_handler); + + if (error_state) + return retval; + + if (nargout > 0 && tmp.length () < nargout) + { + error ("cellfun: function returned fewer than nargout values"); + return retval; + } + + if (nargout > 0 + || (nargout == 0 + && tmp.length () > 0 && tmp(0).is_defined ())) + { + int num_to_copy = tmp.length (); + + if (num_to_copy > nargout1) + num_to_copy = nargout1; + + if (num_to_copy > 0) + have_some_output = true; + + for (int j = 0; j < num_to_copy; j++) + results[j](count) = tmp(j); + } + } + + if (have_some_output || fdims.any_zero ()) + { + retval.resize (nargout1); + + for (int j = 0; j < nargout1; j++) + retval(j) = results[j]; + } + } + } + else + error ("cellfun: argument NAME must be a string or function handle"); + + return retval; +} + +/* + +%!function r = __f11 (x) +%! global __cellfun_test_num_outputs__; +%! __cellfun_test_num_outputs__ = nargout; +%! r = x; +%!endfunction + +%!function __f01 (x) +%! global __cellfun_test_num_outputs__; +%! __cellfun_test_num_outputs__ = nargout; +%!endfunction + +%!test +%! global __cellfun_test_num_outputs__; +%! cellfun (@__f11, {1}); +%! assert (__cellfun_test_num_outputs__, 0); +%! x = cellfun (@__f11, {1}); +%! assert (__cellfun_test_num_outputs__, 1); + +%!test +%! global __cellfun_test_num_outputs__; +%! cellfun (@__f01, {1}); +%! assert (__cellfun_test_num_outputs__, 0); + +%!error x = cellfun (@__f01, {1, 2}); + +%!test +%! assert (cellfun (@__f11, {1, 2}), [1, 2]); +%! assert (cellfun (@__f11, {1, 2}, 'uniformoutput', false), {1, 2}); + +%!test +%! [a,b] = cellfun (@(x) x, cell (2, 0)); +%! assert (a, zeros (2, 0)); +%! assert (b, zeros (2, 0)); + +%!test +%! [a,b] = cellfun (@(x) x, cell (2, 0), "uniformoutput", false); +%! assert (a, cell (2, 0)); +%! assert (b, cell (2, 0)); + +%% Test function to check the "Errorhandler" option +%!function z = __cellfunerror (S, varargin) +%! z = S; +%!endfunction + +%% First input argument can be a string, an inline function, +%% a function_handle or an anonymous function +%!test +%! A = cellfun ("islogical", {true, 0.1, false, i*2}); +%! assert (A, [true, false, true, false]); +%!test +%! A = cellfun (inline ("islogical (x)", "x"), {true, 0.1, false, i*2}); +%! assert (A, [true, false, true, false]); +%!test +%! A = cellfun (@islogical, {true, 0.1, false, i*2}); +%! assert (A, [true, false, true, false]); +%!test +%! A = cellfun (@(x) islogical (x), {true, 0.1, false, i*2}); +%! assert (A, [true, false, true, false]); + +%% First input argument can be the special string "isreal", +%% "isempty", "islogical", "length", "ndims" or "prodofsize" +%!test +%! A = cellfun ("isreal", {true, 0.1, {}, i*2, [], "abc"}); +%! assert (A, [true, true, false, false, true, true]); +%!test +%! A = cellfun ("isempty", {true, 0.1, false, i*2, [], "abc"}); +%! assert (A, [false, false, false, false, true, false]); +%!test +%! A = cellfun ("islogical", {true, 0.1, false, i*2, [], "abc"}); +%! assert (A, [true, false, true, false, false, false]); +%!test +%! A = cellfun ("length", {true, 0.1, false, i*2, [], "abc"}); +%! assert (A, [1, 1, 1, 1, 0, 3]); +%!test +%! A = cellfun ("ndims", {[1, 2; 3, 4]; (cell (1,2,3,4))}); +%! assert (A, [2; 4]); +%!test +%! A = cellfun ("prodofsize", {[1, 2; 3, 4], (cell (1,2,3,4))}); +%! assert (A, [4, 24]); + +%% Number of input and output arguments may not be limited to one +%!test +%! A = cellfun (@(x,y,z) x + y + z, {1, 1, 1}, {2, 2, 2}, {3, 4, 5}); +%! assert (A, [6, 7, 8]); +%!test +%! A = cellfun (@(x,y,z) x + y + z, {1, 1, 1}, {2, 2, 2}, {3, 4, 5}, \ +%! "UniformOutput", false); +%! assert (A, {6, 7, 8}); +%!test %% Two input arguments of different types +%! A = cellfun (@(x,y) islogical (x) && ischar (y), {false, true}, {"a", 3}); +%! assert (A, [true, false]); +%!test %% Pass another variable to the anonymous function +%! y = true; +%! A = cellfun (@(x) islogical (x) && y, {false, 0.3}); +%! assert (A, [true, false]); +%!test %% Three ouptut arguments of different type +%! [A, B, C] = cellfun (@find, {10, 11; 0, 12}, "UniformOutput", false); +%! assert (isequal (A, {true, true; [], true})); +%! assert (isequal (B, {true, true; [], true})); +%! assert (isequal (C, {10, 11; [], 12})); + +%% Input arguments can be of type cell array of logical +%!test +%! A = cellfun (@(x,y) x == y, {false, true}, {true, true}); +%! assert (A, [false, true]); +%!test +%! A = cellfun (@(x,y) x == y, {false; true}, {true; true}, \ +%! "UniformOutput", true); +%! assert (A, [false; true]); +%!test +%! A = cellfun (@(x) x, {false, true; false, true}, "UniformOutput", false); +%! assert (A, {false, true; false, true}); +%!test %% Three ouptut arguments of same type +%! [A, B, C] = cellfun (@find, {true, false; false, true}, \ +%! "UniformOutput", false); +%! assert (isequal (A, {true, []; [], true})); +%! assert (isequal (B, {true, []; [], true})); +%! assert (isequal (C, {true, []; [], true})); +%!test +%! A = cellfun (@(x,y) cell2str (x,y), {true}, {true}, \ +%! "ErrorHandler", @__cellfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); +%!test %% Overwriting setting of "UniformOutput" true +%! A = cellfun (@(x,y) cell2str (x,y), {true}, {true}, \ +%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); + +%% Input arguments can be of type cell array of numeric +%!test +%! A = cellfun (@(x,y) x>y, {1.1, 4.2}, {3.1, 2+3*i}); +%! assert (A, [false, true]); +%!test +%! A = cellfun (@(x,y) x>y, {1.1, 4.2; 2, 4}, {3.1, 2; 2, 4+2*i}, \ +%! "UniformOutput", true); +%! assert (A, [false, true; false, false]); +%!test +%! A = cellfun (@(x,y) x:y, {1.1, 4}, {3.1, 6}, "UniformOutput", false); +%! assert (isequal (A{1}, [1.1, 2.1, 3.1])); +%! assert (isequal (A{2}, [4, 5, 6])); +%!test %% Three ouptut arguments of different type +%! [A, B, C] = cellfun (@find, {10, 11; 0, 12}, "UniformOutput", false); +%! assert (isequal (A, {true, true; [], true})); +%! assert (isequal (B, {true, true; [], true})); +%! assert (isequal (C, {10, 11; [], 12})); +%!test +%! A = cellfun (@(x,y) cell2str (x,y), {1.1, 4}, {3.1, 6}, \ +%! "ErrorHandler", @__cellfunerror); +%! B = isfield (A(1), "message") && isfield (A(1), "index"); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); +%!test %% Overwriting setting of "UniformOutput" true +%! A = cellfun (@(x,y) cell2str (x,y), {1.1, 4}, {3.1, 6}, \ +%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); +%! B = isfield (A(1), "message") && isfield (A(1), "index"); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); + +%% Input arguments can be of type cell arrays of character or strings +%!error %% "UniformOutput" false should be used +%! A = cellfun (@(x,y) x>y, {"ad", "c", "ghi"}, {"cc", "d", "fgh"}); +%!test +%! A = cellfun (@(x,y) x>y, {"a"; "f"}, {"c"; "d"}, "UniformOutput", true); +%! assert (A, [false; true]); +%!test +%! A = cellfun (@(x,y) x:y, {"a", "d"}, {"c", "f"}, "UniformOutput", false); +%! assert (A, {"abc", "def"}); +%!test +%! A = cellfun (@(x,y) cell2str (x,y), {"a", "d"}, {"c", "f"}, \ +%! "ErrorHandler", @__cellfunerror); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); +%!test %% Overwriting setting of "UniformOutput" true +%! A = cellfun (@(x,y) cell2str (x,y), {"a", "d"}, {"c", "f"}, \ +%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); + +%% Structures cannot be handled by cellfun +%!error +%! vst1.a = 1.1; vst1.b = 4.2; vst2.a = 3.1; vst2.b = 2; +%! A = cellfun (@(x,y) (x.a < y.a) && (x.b > y.b), vst1, vst2); + +%% Input arguments can be of type cell array of cell arrays +%!test +%! A = cellfun (@(x,y) x{1} < y{1}, {{1.1}, {4.2}}, {{3.1}, {2}}); +%! assert (A, [1, 0], 1e-16); +%!test +%! A = cellfun (@(x,y) x{1} < y{1}, {{1.1}; {4.2}}, {{3.1}; {2}}, \ +%! "UniformOutput", true); +%! assert (A, [1; 0], 1e-16); +%!test +%! A = cellfun (@(x,y) x{1} < y{1}, {{1.1}, {4.2}}, {{3.1}, {2}}, \ +%! "UniformOutput", false); +%! assert (A, {true, false}); +%!test +%! A = cellfun (@(x,y) mat2str (x,y), {{1.1}, {4.2}}, {{3.1}, {2}}, \ +%! "ErrorHandler", @__cellfunerror); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); +%!test %% Overwriting setting of "UniformOutput" true +%! A = cellfun (@(x,y) mat2str (x,y), {{1.1}, {4.2}}, {{3.1}, {2}}, \ +%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); + +%% Input arguments can be of type cell array of structure arrays +%!test +%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); +%! A = cellfun (@(x,y) (x.a == y.a) && (x.b < y.b), {a}, {b}); +%! assert (A, true); +%!test +%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); +%! A = cellfun (@(x,y) (x.a == y.a) && (x.b < y.b) , {a}, {b}, \ +%! "UniformOutput", true); +%! assert (A, true); +%!test +%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); +%! A = cellfun (@(x,y) (x.a == y.a) && (x.b < y.b) , {a}, {b}, \ +%! "UniformOutput", false); +%! assert (A, {true}); +%!test +%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); +%! A = cellfun (@(x,y) cell2str (x.a, y.a), {a}, {b}, \ +%! "ErrorHandler", @__cellfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); +%!test %% Overwriting setting of "UniformOutput" true +%! a = struct ("a", 1, "b", 2); b = struct ("a", 1, "b", 3); +%! A = cellfun (@(x,y) cell2str (x.a, y.a), {a}, {b}, \ +%! "UniformOutput", true, "ErrorHandler", @__cellfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); + +%% A lot of other tests +%!assert (cellfun (@sin, {0,1}), sin ([0,1])) +%!assert (cellfun (inline ("sin (x)"), {0,1}), sin ([0,1])) +%!assert (cellfun ("sin", {0,1}), sin ([0,1])) +%!assert (cellfun ("isempty", {1,[]}), [false,true]) +%!assert (cellfun ("islogical", {false,pi}), [true,false]) +%!assert (cellfun ("isreal", {1i,1}), [false,true]) +%!assert (cellfun ("length", {zeros(2,2),1}), [2,1]) +%!assert (cellfun ("prodofsize", {zeros(2,2),1}), [4,1]) +%!assert (cellfun ("ndims", {zeros([2,2,2]),1}), [3,2]) +%!assert (cellfun ("isclass", {zeros([2,2,2]),"test"}, "double"), [true,false]) +%!assert (cellfun ("size", {zeros([1,2,3]),1}, 1), [1,1]) +%!assert (cellfun ("size", {zeros([1,2,3]),1}, 2), [2,1]) +%!assert (cellfun ("size", {zeros([1,2,3]),1}, 3), [3,1]) +%!assert (cellfun (@atan2, {1,1}, {1,2}), [atan2(1,1), atan2(1,2)]) +%!assert (cellfun (@atan2, {1,1}, {1,2},"UniformOutput", false), {atan2(1,1), atan2(1,2)}) +%!assert (cellfun (@sin, {1,2;3,4}), sin ([1,2;3,4])) +%!assert (cellfun (@atan2, {1,1;1,1}, {1,2;1,2}), atan2 ([1,1;1,1],[1,2;1,2])) +%!error cellfun (@factorial, {-1,3}) +%!assert (cellfun (@factorial,{-1,3},"ErrorHandler",@(x,y) NaN), [NaN,6]) +%!test +%! [a,b,c] = cellfun (@fileparts, {fullfile("a","b","c.d"), fullfile("e","f","g.h")}, "UniformOutput", false); +%! assert (a, {fullfile("a","b"), fullfile("e","f")}); +%! assert (b, {"c", "g"}); +%! assert (c, {".d", ".h"}); + +%!error cellfun (1) +%!error cellfun ("isclass", 1) +%!error cellfun ("size", 1) +%!error cellfun (@sin, {[]}, "BadParam", false) +%!error cellfun (@sin, {[]}, "UniformOuput") +%!error cellfun (@sin, {[]}, "ErrorHandler") +*/ + +// Arrayfun was originally a .m file written by Bill Denney and Jaroslav +// Hajek. It was converted to C++ by jwe so that it could properly +// handle the nargout = 0 case. + +DEFUN (arrayfun, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Function File} {} arrayfun (@var{func}, @var{A})\n\ +@deftypefnx {Function File} {@var{x} =} arrayfun (@var{func}, @var{A})\n\ +@deftypefnx {Function File} {@var{x} =} arrayfun (@var{func}, @var{A}, @var{b}, @dots{})\n\ +@deftypefnx {Function File} {[@var{x}, @var{y}, @dots{}] =} arrayfun (@var{func}, @var{A}, @dots{})\n\ +@deftypefnx {Function File} {} arrayfun (@dots{}, \"UniformOutput\", @var{val})\n\ +@deftypefnx {Function File} {} arrayfun (@dots{}, \"ErrorHandler\", @var{errfunc})\n\ +\n\ +Execute a function on each element of an array. This is useful for\n\ +functions that do not accept array arguments. If the function does\n\ +accept array arguments it is better to call the function directly.\n\ +\n\ +The first input argument @var{func} can be a string, a function\n\ +handle, an inline function, or an anonymous function. The input\n\ +argument @var{A} can be a logic array, a numeric array, a string\n\ +array, a structure array, or a cell array. By a call of the function\n\ +@command{arrayfun} all elements of @var{A} are passed on to the named\n\ +function @var{func} individually.\n\ +\n\ +The named function can also take more than two input arguments, with\n\ +the input arguments given as third input argument @var{b}, fourth\n\ +input argument @var{c}, @dots{} If given more than one array input\n\ +argument then all input arguments must have the same sizes, for\n\ +example:\n\ +\n\ +@example\n\ +@group\n\ +arrayfun (@@atan2, [1, 0], [0, 1])\n\ + @result{} [ 1.5708 0.0000 ]\n\ +@end group\n\ +@end example\n\ +\n\ +If the parameter @var{val} after a further string input argument\n\ +\"UniformOutput\" is set @code{true} (the default), then the named\n\ +function @var{func} must return a single element which then will be\n\ +concatenated into the return value and is of type matrix. Otherwise,\n\ +if that parameter is set to @code{false}, then the outputs are\n\ +concatenated in a cell array. For example:\n\ +\n\ +@example\n\ +@group\n\ +arrayfun (@@(x,y) x:y, \"abc\", \"def\", \"UniformOutput\", false)\n\ +@result{}\n\ + @{\n\ + [1,1] = abcd\n\ + [1,2] = bcde\n\ + [1,3] = cdef\n\ + @}\n\ +@end group\n\ +@end example\n\ +\n\ +If more than one output arguments are given then the named function\n\ +must return the number of return values that also are expected, for\n\ +example:\n\ +\n\ +@example\n\ +@group\n\ +[A, B, C] = arrayfun (@@find, [10; 0], \"UniformOutput\", false)\n\ +@result{}\n\ +A =\n\ +@{\n\ + [1,1] = 1\n\ + [2,1] = [](0x0)\n\ +@}\n\ +B =\n\ +@{\n\ + [1,1] = 1\n\ + [2,1] = [](0x0)\n\ +@}\n\ +C =\n\ +@{\n\ + [1,1] = 10\n\ + [2,1] = [](0x0)\n\ +@}\n\ +@end group\n\ +@end example\n\ +\n\ +If the parameter @var{errfunc} after a further string input argument\n\ +\"ErrorHandler\" is another string, a function handle, an inline\n\ +function, or an anonymous function, then @var{errfunc} defines a\n\ +function to call in the case that @var{func} generates an error.\n\ +The definition of the function must be of the form\n\ +\n\ +@example\n\ +function [@dots{}] = errfunc (@var{s}, @dots{})\n\ +@end example\n\ +\n\ +@noindent\n\ +where there is an additional input argument to @var{errfunc}\n\ +relative to @var{func}, given by @var{s}. This is a structure with\n\ +the elements \"identifier\", \"message\", and \"index\" giving,\n\ +respectively, the error identifier, the error message, and the index of\n\ +the array elements that caused the error. The size of the output\n\ +argument of @var{errfunc} must have the same size as the output\n\ +argument of @var{func}, otherwise a real error is thrown. For\n\ +example:\n\ +\n\ +@example\n\ +@group\n\ +function y = ferr (s, x), y = \"MyString\"; endfunction\n\ +arrayfun (@@str2num, [1234],\n\ + \"UniformOutput\", false, \"ErrorHandler\", @@ferr)\n\ +@result{}\n\ + @{\n\ + [1,1] = MyString\n\ + @}\n\ +@end group\n\ +@end example\n\ +\n\ +@seealso{spfun, cellfun, structfun}\n\ +@end deftypefn") +{ + octave_value_list retval; + int nargin = args.length (); + int nargout1 = (nargout < 1 ? 1 : nargout); + + if (nargin < 2) + { + error ("arrayfun: function requires at least 2 arguments"); + print_usage (); + return retval; + } + + octave_value func = args(0); + bool symbol_table_lookup = false; + + if (func.is_string ()) + { + // See if we can convert the string into a function. + + std::string name = args(0).string_value (); + + if (! valid_identifier (name)) + { + std::string fcn_name = unique_symbol_name ("__arrayfun_fcn_"); + std::string fname = "function y = " + fcn_name + "(x) y = "; + + octave_function *ptr_func + = extract_function (args(0), "arrayfun", fcn_name, + fname, "; endfunction"); + + if (ptr_func && ! error_state) + func = octave_value (ptr_func, true); + } + else + { + func = symbol_table::find_function (name); + + if (func.is_undefined ()) + error ("arrayfun: invalid function NAME: %s", name.c_str ()); + + symbol_table_lookup = true; + } + + if (error_state) + return retval; + } + + if (func.is_function_handle () || func.is_inline_function () + || func.is_function ()) + { + // The following is an optimisation because the symbol table can + // give a more specific function class, so this can result in + // fewer polymorphic function calls as the function gets called + // for each value of the array. + + if (! symbol_table_lookup ) + { + if (func.is_function_handle ()) + { + octave_fcn_handle* f = func.fcn_handle_value (); + + // Overloaded function handles need to check the type of + // the arguments for each element of the array, so they + // cannot be optimised this way. + + if (f -> is_overloaded ()) + goto nevermind; + } + octave_value f = symbol_table::find_function (func.function_value () + -> name ()); + if (f.is_defined ()) + func = f; + } + + nevermind: + + bool uniform_output = true; + octave_value error_handler; + + get_mapper_fun_options (args, nargin, uniform_output, error_handler); + + if (error_state) + return octave_value_list (); + + octave_value_list inputlist (nargin, octave_value ()); + + OCTAVE_LOCAL_BUFFER (octave_value, inputs, nargin); + OCTAVE_LOCAL_BUFFER (bool, mask, nargin); + + octave_idx_type k = 1; + + dim_vector fdims (1, 1); + + // Collect arguments. Pre-fill scalar elements of inputlist + // array. + + for (int j = 0; j < nargin; j++) + { + inputs[j] = args(j+1); + mask[j] = inputs[j].numel () != 1; + + if (! mask[j]) + inputlist(j) = inputs[j]; + } + + for (int j = 0; j < nargin; j++) + { + if (mask[j]) + { + fdims = inputs[j].dims (); + k = inputs[j].numel (); + + for (int i = j+1; i < nargin; i++) + { + if (mask[i] && inputs[i].dims () != fdims) + { + error ("arrayfun: dimensions mismatch"); + return retval; + } + } + break; + } + } + + + unwind_protect frame; + frame.protect_var (buffer_error_messages); + + if (error_handler.is_defined ()) + buffer_error_messages++; + + // Apply functions. + + if (uniform_output) + { + std::list<octave_value_list> idx_list (1); + idx_list.front ().resize (1); + std::string idx_type = "("; + + OCTAVE_LOCAL_BUFFER (octave_value, retv, nargout1); + + for (octave_idx_type count = 0; count < k; count++) + { + idx_list.front ()(0) = count + 1.0; + + for (int j = 0; j < nargin; j++) + { + if (mask[j]) + inputlist.xelem (j) = inputs[j].do_index_op (idx_list); + + if (error_state) + return retval; + } + + const octave_value_list tmp + = get_output_list (count, nargout, inputlist, func, + error_handler); + + if (error_state) + return retval; + + if (nargout > 0 && tmp.length () < nargout) + { + error ("arrayfun: function returned fewer than nargout values"); + return retval; + } + + if (nargout > 0 + || (nargout == 0 + && tmp.length () > 0 && tmp(0).is_defined ())) + { + int num_to_copy = tmp.length (); + + if (num_to_copy > nargout1) + num_to_copy = nargout1; + + if (count == 0) + { + for (int j = 0; j < num_to_copy; j++) + { + if (tmp(j).is_defined ()) + { + octave_value val = tmp(j); + + if (val.numel () == 1) + retv[j] = val.resize (fdims); + else + { + error ("arrayfun: all values must be scalars when UniformOutput = true"); + break; + } + } + } + } + else + { + for (int j = 0; j < num_to_copy; j++) + { + if (tmp(j).is_defined ()) + { + octave_value val = tmp(j); + + if (! retv[j].fast_elem_insert (count, val)) + { + if (val.numel () == 1) + { + idx_list.front ()(0) = count + 1.0; + retv[j].assign (octave_value::op_asn_eq, + idx_type, idx_list, val); + + if (error_state) + break; + } + else + { + error ("arrayfun: all values must be scalars when UniformOutput = true"); + break; + } + } + } + } + } + } + + if (error_state) + break; + } + + retval.resize (nargout1); + + for (int j = 0; j < nargout1; j++) + { + if (nargout > 0 && retv[j].is_undefined ()) + retval(j) = NDArray (fdims); + else + retval(j) = retv[j]; + } + } + else + { + std::list<octave_value_list> idx_list (1); + idx_list.front ().resize (1); + std::string idx_type = "("; + + OCTAVE_LOCAL_BUFFER (Cell, results, nargout1); + + for (int j = 0; j < nargout1; j++) + results[j].resize (fdims, Matrix ()); + + bool have_some_output = false; + + for (octave_idx_type count = 0; count < k; count++) + { + idx_list.front ()(0) = count + 1.0; + + for (int j = 0; j < nargin; j++) + { + if (mask[j]) + inputlist.xelem (j) = inputs[j].do_index_op (idx_list); + + if (error_state) + return retval; + } + + const octave_value_list tmp + = get_output_list (count, nargout, inputlist, func, + error_handler); + + if (error_state) + return retval; + + if (nargout > 0 && tmp.length () < nargout) + { + error ("arrayfun: function returned fewer than nargout values"); + return retval; + } + + if (nargout > 0 + || (nargout == 0 + && tmp.length () > 0 && tmp(0).is_defined ())) + { + int num_to_copy = tmp.length (); + + if (num_to_copy > nargout1) + num_to_copy = nargout1; + + if (num_to_copy > 0) + have_some_output = true; + + for (int j = 0; j < num_to_copy; j++) + results[j](count) = tmp(j); + } + } + + if (have_some_output || fdims.any_zero ()) + { + retval.resize (nargout1); + + for (int j = 0; j < nargout1; j++) + retval(j) = results[j]; + } + } + } + else + error ("arrayfun: argument NAME must be a string or function handle"); + + return retval; +} + +/* +%!function r = __f11 (x) +%! global __arrayfun_test_num_outputs__; +%! __arrayfun_test_num_outputs__ = nargout; +%! r = x; +%!endfunction + +%!function __f01 (x) +%! global __arrayfun_test_num_outputs__; +%! __arrayfun_test_num_outputs__ = nargout; +%!endfunction + +%!test +%! global __arrayfun_test_num_outputs__; +%! arrayfun (@__f11, {1}); +%! assert (__arrayfun_test_num_outputs__, 0); +%! x = arrayfun (@__f11, {1}); +%! assert (__arrayfun_test_num_outputs__, 1); + +%!test +%! global __arrayfun_test_num_outputs__; +%! arrayfun (@__f01, {1}); +%! assert (__arrayfun_test_num_outputs__, 0); + +%!error x = arrayfun (@__f01, [1, 2]); + +%!test +%! assert (arrayfun (@__f11, [1, 2]), [1, 2]); +%! assert (arrayfun (@__f11, [1, 2], "uniformoutput", false), {1, 2}); +%! assert (arrayfun (@__f11, {1, 2}), {1, 2}); +%! assert (arrayfun (@__f11, {1, 2}, "uniformoutput", false), {{1}, {2}}); + +%!assert (arrayfun (@ones, 1, [2,3], "uniformoutput", false), {[1,1], [1,1,1]}) + +%% Test function to check the "Errorhandler" option +%!function z = __arrayfunerror (S, varargin) +%! z = S; +%!endfunction +%% First input argument can be a string, an inline function, a +%% function_handle or an anonymous function +%!test +%! arrayfun (@isequal, [false, true], [true, true]); %% No output argument +%!error +%! arrayfun (@isequal); %% One or less input arguments +%!test +%! A = arrayfun ("isequal", [false, true], [true, true]); +%! assert (A, [false, true]); +%!test +%! A = arrayfun (inline ("(x == y)", "x", "y"), [false, true], [true, true]); +%! assert (A, [false, true]); +%!test +%! A = arrayfun (@isequal, [false, true], [true, true]); +%! assert (A, [false, true]); +%!test +%! A = arrayfun (@(x,y) isequal (x,y), [false, true], [true, true]); +%! assert (A, [false, true]); + +%% Number of input and output arguments may be greater than one +%#!test +%! A = arrayfun (@(x) islogical (x), false); +%! assert (A, true); +%!test +%! A = arrayfun (@(x,y,z) x + y + z, [1, 1, 1], [2, 2, 2], [3, 4, 5]); +%! assert (A, [6, 7, 8], 1e-16); +%!test %% Two input arguments of different types +%! A = arrayfun (@(x,y) islogical (x) && ischar (y), false, "a"); +%! assert (A, true); +%!test %% Pass another variable to the anonymous function +%! y = true; +%! A = arrayfun (@(x) islogical (x && y), false); +%! assert (A, true); +%!test %% Three ouptut arguments of different type +%! [A, B, C] = arrayfun (@find, [10, 11; 0, 12], "UniformOutput", false); +%! assert (isequal (A, {true, true; [], true})); +%! assert (isequal (B, {true, true; [], true})); +%! assert (isequal (C, {10, 11; [], 12})); + +%% Input arguments can be of type logical +%!test +%! A = arrayfun (@(x,y) x == y, [false, true], [true, true]); +%! assert (A, [false, true]); +%!test +%! A = arrayfun (@(x,y) x == y, [false; true], [true; true], "UniformOutput", true); +%! assert (A, [false; true]); +%!test +%! A = arrayfun (@(x) x, [false, true, false, true], "UniformOutput", false); +%! assert (A, {false, true, false, true}); +%!test %% Three ouptut arguments of same type +%! [A, B, C] = arrayfun (@find, [true, false; false, true], "UniformOutput", false); +%! assert (isequal (A, {true, []; [], true})); +%! assert (isequal (B, {true, []; [], true})); +%! assert (isequal (C, {true, []; [], true})); +%!test +%! A = arrayfun (@(x,y) array2str (x,y), true, true, \ +%! "ErrorHandler", @__arrayfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); +%!test %% Overwriting setting of "UniformOutput" true +%! A = arrayfun (@(x,y) array2str (x,y), true, true, "UniformOutput", true, \ +%! "ErrorHandler", @__arrayfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); + +%% Input arguments can be of type numeric +%!test +%! A = arrayfun (@(x,y) x>y, [1.1, 4.2], [3.1, 2+3*i]); +%! assert (A, [false, true]); +%!test +%! A = arrayfun (@(x,y) x>y, [1.1, 4.2; 2, 4], [3.1, 2; 2, 4+2*i], "UniformOutput", true); +%! assert (A, [false, true; false, false]); +%!test +%! A = arrayfun (@(x,y) x:y, [1.1, 4], [3.1, 6], "UniformOutput", false); +%! assert (isequal (A{1}, [1.1, 2.1, 3.1])); +%! assert (isequal (A{2}, [4, 5, 6])); +%!test %% Three ouptut arguments of different type +%! [A, B, C] = arrayfun (@find, [10, 11; 0, 12], "UniformOutput", false); +%! assert (isequal (A, {true, true; [], true})); +%! assert (isequal (B, {true, true; [], true})); +%! assert (isequal (C, {10, 11; [], 12})); +%!test +%! A = arrayfun (@(x,y) array2str (x,y), {1.1, 4}, {3.1, 6}, \ +%! "ErrorHandler", @__arrayfunerror); +%! B = isfield (A(1), "message") && isfield (A(1), "index"); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); +%!test %% Overwriting setting of "UniformOutput" true +%! A = arrayfun (@(x,y) array2str (x,y), {1.1, 4}, {3.1, 6}, \ +%! "UniformOutput", true, "ErrorHandler", @__arrayfunerror); +%! B = isfield (A(1), "message") && isfield (A(1), "index"); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); + +%% Input arguments can be of type character or strings +%!test +%! A = arrayfun (@(x,y) x>y, ["ad", "c", "ghi"], ["cc", "d", "fgh"]); +%! assert (A, [false, true, false, true, true, true]); +%!test +%! A = arrayfun (@(x,y) x>y, ["a"; "f"], ["c"; "d"], "UniformOutput", true); +%! assert (A, [false; true]); +%!test +%! A = arrayfun (@(x,y) x:y, ["a", "d"], ["c", "f"], "UniformOutput", false); +%! assert (A, {"abc", "def"}); +%!test +%! A = arrayfun (@(x,y) cell2str (x,y), ["a", "d"], ["c", "f"], \ +%! "ErrorHandler", @__arrayfunerror); +%! B = isfield (A(1), "identifier") && isfield (A(1), "message") && isfield (A(1), "index"); +%! assert (B, true); + +%% Input arguments can be of type structure +%!test +%! a = struct ("a", 1.1, "b", 4.2); b = struct ("a", 3.1, "b", 2); +%! A = arrayfun (@(x,y) (x.a < y.a) && (x.b > y.b), a, b); +%! assert (A, true); +%!test +%! a = struct ("a", 1.1, "b", 4.2); b = struct ("a", 3.1, "b", 2); +%! A = arrayfun (@(x,y) (x.a < y.a) && (x.b > y.b), a, b, "UniformOutput", true); +%! assert (A, true); +%!test +%! a = struct ("a", 1.1, "b", 4.2); b = struct ("a", 3.1, "b", 2); +%! A = arrayfun (@(x,y) x.a:y.a, a, b, "UniformOutput", false); +%! assert (isequal (A, {[1.1, 2.1, 3.1]})); +%!test +%! A = arrayfun (@(x) mat2str(x), "a", "ErrorHandler", @__arrayfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); +%!test %% Overwriting setting of "UniformOutput" true +%! A = arrayfun (@(x) mat2str(x), "a", "UniformOutput", true, \ +%! "ErrorHandler", @__arrayfunerror); +%! assert (isfield (A, "identifier"), true); +%! assert (isfield (A, "message"), true); +%! assert (isfield (A, "index"), true); +%! assert (isempty (A.message), false); +%! assert (A.index, 1); + +%% Input arguments can be of type cell array +%!test +%! A = arrayfun (@(x,y) x{1} < y{1}, {1.1, 4.2}, {3.1, 2}); +%! assert (A, [true, false]); +%!test +%! A = arrayfun (@(x,y) x{1} < y{1}, {1.1; 4.2}, {3.1; 2}, "UniformOutput", true); +%! assert (A, [true; false]); +%!test +%! A = arrayfun (@(x,y) x{1} < y{1}, {1.1, 4.2}, {3.1, 2}, "UniformOutput", false); +%! assert (A, {true, false}); +%!test +%! A = arrayfun (@(x,y) num2str(x,y), {1.1, 4.2}, {3.1, 2}, "ErrorHandler", @__arrayfunerror); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); +%!test +%! A = arrayfun (@(x,y) num2str (x,y), {1.1, 4.2}, {3.1, 2}, \ +%! "UniformOutput", true, "ErrorHandler", @__arrayfunerror); +%! assert ([(isfield (A(1), "identifier")), (isfield (A(2), "identifier"))], [true, true]); +%! assert ([(isfield (A(1), "message")), (isfield (A(2), "message"))], [true, true]); +%! assert ([(isfield (A(1), "index")), (isfield (A(2), "index"))], [true, true]); +%! assert ([(isempty (A(1).message)), (isempty (A(2).message))], [false, false]); +%! assert ([A(1).index, A(2).index], [1, 2]); +*/ + +static void +do_num2cell_helper (const dim_vector& dv, + const Array<int>& dimv, + dim_vector& celldv, dim_vector& arraydv, + Array<int>& perm) +{ + int dvl = dimv.length (); + int maxd = dv.length (); + celldv = dv; + for (int i = 0; i < dvl; i++) + maxd = std::max (maxd, dimv(i)); + if (maxd > dv.length ()) + celldv.resize (maxd, 1); + arraydv = celldv; + + OCTAVE_LOCAL_BUFFER_INIT (bool, sing, maxd, false); + + perm.clear (maxd, 1); + for (int i = 0; i < dvl; i++) + { + int k = dimv(i) - 1; + if (k < 0) + { + error ("num2cell: dimension indices must be positive"); + return; + } + else if (i > 0 && k < dimv(i-1) - 1) + { + error ("num2cell: dimension indices must be strictly increasing"); + return; + } + + sing[k] = true; + perm(i) = k; + } + + for (int k = 0, i = dvl; k < maxd; k++) + if (! sing[k]) + perm(i++) = k; + + for (int i = 0; i < maxd; i++) + if (sing[i]) + celldv(i) = 1; + else + arraydv(i) = 1; +} + +template<class NDA> +static inline typename NDA::element_type +do_num2cell_elem (const NDA& array, octave_idx_type i) +{ return array(i); } + +static inline Cell +do_num2cell_elem (const Cell& array, octave_idx_type i) +{ return Cell (array(i)); } + + +template<class NDA> +static Cell +do_num2cell (const NDA& array, const Array<int>& dimv) +{ + if (dimv.is_empty ()) + { + Cell retval (array.dims ()); + octave_idx_type nel = array.numel (); + for (octave_idx_type i = 0; i < nel; i++) + retval.xelem (i) = do_num2cell_elem (array, i); + + return retval; + } + else + { + dim_vector celldv, arraydv; + Array<int> perm; + do_num2cell_helper (array.dims (), dimv, celldv, arraydv, perm); + if (error_state) + return Cell (); + + NDA parray = array.permute (perm); + + octave_idx_type nela = arraydv.numel (), nelc = celldv.numel (); + parray = parray.reshape (dim_vector (nela, nelc)); + + Cell retval (celldv); + for (octave_idx_type i = 0; i < nelc; i++) + { + retval.xelem (i) = NDA (parray.column (i).reshape (arraydv)); + } + + return retval; + } +} + +// FIXME -- this is a mess, but if a size method for the object exists, +// we have to call it to get the size of the object instead of using the +// internal dims method. + +static dim_vector +get_object_dims (octave_value& obj) +{ + dim_vector retval; + + Matrix m = obj.size (); + + int n = m.numel (); + + retval.resize (n); + + for (int i = 0; i < n; i++) + retval(i) = m(i); + + return retval; +} + +static Cell +do_object2cell (const octave_value& obj, const Array<int>& dimv) +{ + Cell retval; + + // FIXME -- this copy is only needed because the octave_value::size + // method is not const. + octave_value array = obj; + + if (dimv.is_empty ()) + { + dim_vector dv = get_object_dims (array); + + if (! error_state) + { + retval.resize (dv); + + octave_value_list idx (1); + + for (octave_idx_type i = 0; i < dv.numel (); i++) + { + octave_quit (); + + idx(0) = double (i+1); + + retval.xelem (i) = array.single_subsref ("(", idx); + + if (error_state) + break; + } + } + } + else + { + error ("num2cell (A, dim) not implemented for class objects"); + } + + return retval; +} + +DEFUN (num2cell, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{C} =} num2cell (@var{A})\n\ +@deftypefnx {Built-in Function} {@var{C} =} num2cell (@var{A}, @var{dim})\n\ +Convert the numeric matrix @var{A} to a cell array. If @var{dim} is\n\ +defined, the value @var{C} is of dimension 1 in this dimension and the\n\ +elements of @var{A} are placed into @var{C} in slices. For example:\n\ +\n\ +@example\n\ +@group\n\ +num2cell ([1,2;3,4])\n\ + @result{}\n\ + @{\n\ + [1,1] = 1\n\ + [2,1] = 3\n\ + [1,2] = 2\n\ + [2,2] = 4\n\ + @}\n\ +num2cell ([1,2;3,4],1)\n\ + @result{}\n\ + @{\n\ + [1,1] =\n\ + 1\n\ + 3\n\ + [1,2] =\n\ + 2\n\ + 4\n\ + @}\n\ +@end group\n\ +@end example\n\ +\n\ +@seealso{mat2cell}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value retval; + + if (nargin < 1 || nargin > 2) + print_usage (); + else + { + octave_value array = args(0); + Array<int> dimv; + if (nargin > 1) + dimv = args (1).int_vector_value (true); + + if (error_state) + ; + else if (array.is_bool_type ()) + retval = do_num2cell (array.bool_array_value (), dimv); + else if (array.is_char_matrix ()) + retval = do_num2cell (array.char_array_value (), dimv); + else if (array.is_numeric_type ()) + { + if (array.is_integer_type ()) + { + if (array.is_int8_type ()) + retval = do_num2cell (array.int8_array_value (), dimv); + else if (array.is_int16_type ()) + retval = do_num2cell (array.int16_array_value (), dimv); + else if (array.is_int32_type ()) + retval = do_num2cell (array.int32_array_value (), dimv); + else if (array.is_int64_type ()) + retval = do_num2cell (array.int64_array_value (), dimv); + else if (array.is_uint8_type ()) + retval = do_num2cell (array.uint8_array_value (), dimv); + else if (array.is_uint16_type ()) + retval = do_num2cell (array.uint16_array_value (), dimv); + else if (array.is_uint32_type ()) + retval = do_num2cell (array.uint32_array_value (), dimv); + else if (array.is_uint64_type ()) + retval = do_num2cell (array.uint64_array_value (), dimv); + } + else if (array.is_complex_type ()) + { + if (array.is_single_type ()) + retval = do_num2cell (array.float_complex_array_value (), dimv); + else + retval = do_num2cell (array.complex_array_value (), dimv); + } + else + { + if (array.is_single_type ()) + retval = do_num2cell (array.float_array_value (), dimv); + else + retval = do_num2cell (array.array_value (), dimv); + } + } + else if (array.is_object ()) + retval = do_object2cell (array, dimv); + else if (array.is_map ()) + retval = do_num2cell (array.map_value (), dimv); + else if (array.is_cell ()) + retval = do_num2cell (array.cell_value (), dimv); + else if (array.is_object ()) + retval = do_num2cell (array.cell_value (), dimv); + else + gripe_wrong_type_arg ("num2cell", array); + } + + return retval; +} + +/* +%!assert (num2cell ([1,2;3,4]), {1,2;3,4}) +%!assert (num2cell ([1,2;3,4], 1), {[1;3],[2;4]}) +%!assert (num2cell ([1,2;3,4], 2), {[1,2];[3,4]}) +*/ + +static bool +mat2cell_mismatch (const dim_vector& dv, + const Array<octave_idx_type> *d, int nd) +{ + for (int i = 0; i < nd; i++) + { + octave_idx_type s = 0; + for (octave_idx_type j = 0; j < d[i].length (); j++) + s += d[i](j); + + octave_idx_type r = i < dv.length () ? dv(i) : 1; + + if (s != r) + { + error ("mat2cell: mismatch on %d-th dimension (%d != %d)", + i+1, r, s); + return true; + } + } + + return false; +} + +template<class container> +static void +prepare_idx (container *idx, int idim, int nd, + const Array<octave_idx_type>* d) +{ + octave_idx_type nidx = idim < nd ? d[idim].numel () : 1; + if (nidx == 1) + idx[0] = idx_vector::colon; + else + { + octave_idx_type l = 0; + for (octave_idx_type i = 0; i < nidx; i++) + { + octave_idx_type u = l + d[idim](i); + idx[i] = idx_vector (l, u); + l = u; + } + } +} + +// 2D specialization, works for Array, Sparse and octave_map. +// Uses 1D or 2D indexing. + +template <class Array2D> +static Cell +do_mat2cell_2d (const Array2D& a, const Array<octave_idx_type> *d, int nd) +{ + NoAlias<Cell> retval; + assert (nd == 1 || nd == 2); + assert (a.ndims () == 2); + + if (mat2cell_mismatch (a.dims (), d, nd)) + return retval; + + octave_idx_type nridx = d[0].length (); + octave_idx_type ncidx = nd == 1 ? 1 : d[1].length (); + retval.clear (nridx, ncidx); + + int ivec = -1; + if (a.rows () > 1 && a.cols () == 1 && ncidx == 1) + ivec = 0; + else if (a.rows () == 1 && nridx == 1 && nd == 2) + ivec = 1; + + if (ivec >= 0) + { + // Vector split. Use 1D indexing. + octave_idx_type l = 0, nidx = (ivec == 0 ? nridx : ncidx); + for (octave_idx_type i = 0; i < nidx; i++) + { + octave_idx_type u = l + d[ivec](i); + retval(i) = a.index (idx_vector (l, u)); + l = u; + } + } + else + { + // General 2D case. Use 2D indexing. + OCTAVE_LOCAL_BUFFER (idx_vector, ridx, nridx); + prepare_idx (ridx, 0, nd, d); + + OCTAVE_LOCAL_BUFFER (idx_vector, cidx, ncidx); + prepare_idx (cidx, 1, nd, d); + + for (octave_idx_type j = 0; j < ncidx; j++) + for (octave_idx_type i = 0; i < nridx; i++) + { + octave_quit (); + + retval(i,j) = a.index (ridx[i], cidx[j]); + } + } + + return retval; +} + +// Nd case. Works for Arrays and octave_map. +// Uses Nd indexing. + +template <class ArrayND> +Cell +do_mat2cell_nd (const ArrayND& a, const Array<octave_idx_type> *d, int nd) +{ + NoAlias<Cell> retval; + assert (nd >= 1); + + if (mat2cell_mismatch (a.dims (), d, nd)) + return retval; + + dim_vector rdv = dim_vector::alloc (nd); + OCTAVE_LOCAL_BUFFER (octave_idx_type, nidx, nd); + octave_idx_type idxtot = 0; + for (int i = 0; i < nd; i++) + { + rdv(i) = nidx[i] = d[i].length (); + idxtot += nidx[i]; + } + + retval.clear (rdv); + + OCTAVE_LOCAL_BUFFER (idx_vector, xidx, idxtot); + OCTAVE_LOCAL_BUFFER (idx_vector *, idx, nd); + + idxtot = 0; + for (int i = 0; i < nd; i++) + { + idx[i] = xidx + idxtot; + prepare_idx (idx[i], i, nd, d); + idxtot += nidx[i]; + } + + OCTAVE_LOCAL_BUFFER_INIT (octave_idx_type, ridx, nd, 0); + NoAlias< Array<idx_vector> > ra_idx + (dim_vector (1, std::max (nd, a.ndims ())), idx_vector::colon); + + for (octave_idx_type j = 0; j < retval.numel (); j++) + { + octave_quit (); + + for (int i = 0; i < nd; i++) + ra_idx(i) = idx[i][ridx[i]]; + + retval(j) = a.index (ra_idx); + + rdv.increment_index (ridx); + } + + return retval; +} + +// Dispatcher. +template <class ArrayND> +Cell +do_mat2cell (const ArrayND& a, const Array<octave_idx_type> *d, int nd) +{ + if (a.ndims () == 2 && nd <= 2) + return do_mat2cell_2d (a, d, nd); + else + return do_mat2cell_nd (a, d, nd); +} + +// General case. Works for any class supporting do_index_op. +// Uses Nd indexing. + +Cell +do_mat2cell (octave_value& a, const Array<octave_idx_type> *d, int nd) +{ + NoAlias<Cell> retval; + assert (nd >= 1); + + if (mat2cell_mismatch (a.dims (), d, nd)) + return retval; + + dim_vector rdv = dim_vector::alloc (nd); + OCTAVE_LOCAL_BUFFER (octave_idx_type, nidx, nd); + octave_idx_type idxtot = 0; + for (int i = 0; i < nd; i++) + { + rdv(i) = nidx[i] = d[i].length (); + idxtot += nidx[i]; + } + + retval.clear (rdv); + + OCTAVE_LOCAL_BUFFER (octave_value, xidx, idxtot); + OCTAVE_LOCAL_BUFFER (octave_value *, idx, nd); + + idxtot = 0; + for (int i = 0; i < nd; i++) + { + idx[i] = xidx + idxtot; + prepare_idx (idx[i], i, nd, d); + idxtot += nidx[i]; + } + + OCTAVE_LOCAL_BUFFER_INIT (octave_idx_type, ridx, nd, 0); + octave_value_list ra_idx (std::max (nd, a.ndims ()), + octave_value::magic_colon_t); + + for (octave_idx_type j = 0; j < retval.numel (); j++) + { + octave_quit (); + + for (int i = 0; i < nd; i++) + ra_idx(i) = idx[i][ridx[i]]; + + retval(j) = a.do_index_op (ra_idx); + + if (error_state) + break; + + rdv.increment_index (ridx); + } + + return retval; +} + +DEFUN (mat2cell, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{C} =} mat2cell (@var{A}, @var{m}, @var{n})\n\ +@deftypefnx {Built-in Function} {@var{C} =} mat2cell (@var{A}, @var{d1}, @var{d2}, @dots{})\n\ +@deftypefnx {Built-in Function} {@var{C} =} mat2cell (@var{A}, @var{r})\n\ +Convert the matrix @var{A} to a cell array. If @var{A} is 2-D, then\n\ +it is required that @code{sum (@var{m}) == size (@var{A}, 1)} and\n\ +@code{sum (@var{n}) == size (@var{A}, 2)}. Similarly, if @var{A} is\n\ +multi-dimensional and the number of dimensional arguments is equal\n\ +to the dimensions of @var{A}, then it is required that @code{sum (@var{di})\n\ +== size (@var{A}, i)}.\n\ +\n\ +Given a single dimensional argument @var{r}, the other dimensional\n\ +arguments are assumed to equal @code{size (@var{A},@var{i})}.\n\ +\n\ +An example of the use of mat2cell is\n\ +\n\ +@example\n\ +mat2cell (reshape (1:16,4,4), [3,1], [3,1])\n\ +@result{}\n\ +@{\n\ + [1,1] =\n\ +\n\ + 1 5 9\n\ + 2 6 10\n\ + 3 7 11\n\ +\n\ + [2,1] =\n\ +\n\ + 4 8 12\n\ +\n\ + [1,2] =\n\ +\n\ + 13\n\ + 14\n\ + 15\n\ +\n\ + [2,2] = 16\n\ +@}\n\ +@end example\n\ +@seealso{num2cell, cell2mat}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value retval; + + if (nargin < 2) + print_usage (); + else + { + // Prepare indices. + OCTAVE_LOCAL_BUFFER (Array<octave_idx_type>, d, nargin-1); + + for (int i = 1; i < nargin; i++) + { + d[i-1] = args(i).octave_idx_type_vector_value (true); + if (error_state) + return retval; + } + + octave_value a = args(0); + bool sparse = a.is_sparse_type (); + if (sparse && nargin > 3) + { + error ("mat2cell: sparse arguments only support 2D indexing"); + return retval; + } + + switch (a.builtin_type ()) + { + case btyp_double: + { + if (sparse) + retval = do_mat2cell_2d (a.sparse_matrix_value (), d, nargin-1); + else + retval = do_mat2cell (a.array_value (), d, nargin - 1); + break; + } + case btyp_complex: + { + if (sparse) + retval = do_mat2cell_2d (a.sparse_complex_matrix_value (), d, nargin-1); + else + retval = do_mat2cell (a.complex_array_value (), d, nargin - 1); + break; + } +#define BTYP_BRANCH(X,Y) \ + case btyp_ ## X: \ + retval = do_mat2cell (a.Y ## _value (), d, nargin - 1); \ + break + + BTYP_BRANCH (float, float_array); + BTYP_BRANCH (float_complex, float_complex_array); + BTYP_BRANCH (bool, bool_array); + BTYP_BRANCH (char, char_array); + + BTYP_BRANCH (int8, int8_array); + BTYP_BRANCH (int16, int16_array); + BTYP_BRANCH (int32, int32_array); + BTYP_BRANCH (int64, int64_array); + BTYP_BRANCH (uint8, uint8_array); + BTYP_BRANCH (uint16, uint16_array); + BTYP_BRANCH (uint32, uint32_array); + BTYP_BRANCH (uint64, uint64_array); + + BTYP_BRANCH (cell, cell); + BTYP_BRANCH (struct, map); +#undef BTYP_BRANCH + + case btyp_func_handle: + gripe_wrong_type_arg ("mat2cell", a); + break; + default: + retval = do_mat2cell (a, d, nargin-1); + } + } + + return retval; +} + +/* +%!test +%! x = reshape (1:20, 5, 4); +%! c = mat2cell (x, [3,2], [3,1]); +%! assert (c, {[1,6,11;2,7,12;3,8,13],[16;17;18];[4,9,14;5,10,15],[19;20]}); + +%!test +%! x = "abcdefghij"; +%! c = mat2cell (x, 1, [0,4,2,0,4,0]); +%! empty1by0str = resize ("", 1, 0); +%! assert (c, {empty1by0str,"abcd","ef",empty1by0str,"ghij",empty1by0str}); +*/ + +// FIXME: it would be nice to allow ranges being handled without a conversion. +template <class NDA> +static Cell +do_cellslices_nda (const NDA& array, + const Array<octave_idx_type>& lb, + const Array<octave_idx_type>& ub, + int dim = -1) +{ + octave_idx_type n = lb.length (); + Cell retval (1, n); + if (array.is_vector () && (dim == -1 + || (dim == 0 && array.columns () == 1) + || (dim == 1 && array.rows () == 1))) + { + for (octave_idx_type i = 0; i < n && ! error_state; i++) + retval(i) = array.index (idx_vector (lb(i) - 1, ub(i))); + } + else + { + const dim_vector dv = array.dims (); + int ndims = dv.length (); + if (dim < 0) + dim = dv.first_non_singleton (); + ndims = std::max (ndims, dim + 1); + + Array<idx_vector> idx (dim_vector (ndims, 1), idx_vector::colon); + + for (octave_idx_type i = 0; i < n && ! error_state; i++) + { + idx(dim) = idx_vector (lb(i) - 1, ub(i)); + retval(i) = array.index (idx); + } + } + + return retval; +} + +DEFUN (cellslices, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{sl} =} cellslices (@var{x}, @var{lb}, @var{ub}, @var{dim})\n\ +Given an array @var{x}, this function produces a cell array of slices from\n\ +the array determined by the index vectors @var{lb}, @var{ub}, for lower and\n\ +upper bounds, respectively. In other words, it is equivalent to the\n\ +following code:\n\ +\n\ +@example\n\ +@group\n\ +n = length (lb);\n\ +sl = cell (1, n);\n\ +for i = 1:length (lb)\n\ + sl@{i@} = x(:,@dots{},lb(i):ub(i),@dots{},:);\n\ +endfor\n\ +@end group\n\ +@end example\n\ +\n\ +The position of the index is determined by @var{dim}. If not specified,\n\ +slicing is done along the first non-singleton dimension.\n\ +@seealso{cell2mat, cellindexmat, cellfun}\n\ +@end deftypefn") +{ + octave_value retval; + int nargin = args.length (); + if (nargin == 3 || nargin == 4) + { + octave_value x = args(0); + Array<octave_idx_type> lb = args(1).octave_idx_type_vector_value (); + Array<octave_idx_type> ub = args(2).octave_idx_type_vector_value (); + int dim = -1; + if (nargin == 4) + { + dim = args(3).int_value () - 1; + if (dim < 0) + error ("cellslices: DIM must be a valid dimension"); + } + + if (! error_state) + { + if (lb.length () != ub.length ()) + error ("cellslices: the lengths of LB and UB must match"); + else + { + Cell retcell; + if (! x.is_sparse_type () && x.is_matrix_type ()) + { + // specialize for some dense arrays. + if (x.is_bool_type ()) + retcell = do_cellslices_nda (x.bool_array_value (), lb, ub, dim); + else if (x.is_char_matrix ()) + retcell = do_cellslices_nda (x.char_array_value (), lb, ub, dim); + else if (x.is_integer_type ()) + { + if (x.is_int8_type ()) + retcell = do_cellslices_nda (x.int8_array_value (), lb, ub, dim); + else if (x.is_int16_type ()) + retcell = do_cellslices_nda (x.int16_array_value (), lb, ub, dim); + else if (x.is_int32_type ()) + retcell = do_cellslices_nda (x.int32_array_value (), lb, ub, dim); + else if (x.is_int64_type ()) + retcell = do_cellslices_nda (x.int64_array_value (), lb, ub, dim); + else if (x.is_uint8_type ()) + retcell = do_cellslices_nda (x.uint8_array_value (), lb, ub, dim); + else if (x.is_uint16_type ()) + retcell = do_cellslices_nda (x.uint16_array_value (), lb, ub, dim); + else if (x.is_uint32_type ()) + retcell = do_cellslices_nda (x.uint32_array_value (), lb, ub, dim); + else if (x.is_uint64_type ()) + retcell = do_cellslices_nda (x.uint64_array_value (), lb, ub, dim); + } + else if (x.is_complex_type ()) + { + if (x.is_single_type ()) + retcell = do_cellslices_nda (x.float_complex_array_value (), lb, ub, dim); + else + retcell = do_cellslices_nda (x.complex_array_value (), lb, ub, dim); + } + else + { + if (x.is_single_type ()) + retcell = do_cellslices_nda (x.float_array_value (), lb, ub, dim); + else + retcell = do_cellslices_nda (x.array_value (), lb, ub, dim); + } + } + else + { + // generic code. + octave_idx_type n = lb.length (); + retcell = Cell (1, n); + const dim_vector dv = x.dims (); + int ndims = dv.length (); + if (dim < 0) + dim = dv.first_non_singleton (); + ndims = std::max (ndims, dim + 1); + octave_value_list idx (ndims, octave_value::magic_colon_t); + for (octave_idx_type i = 0; i < n && ! error_state; i++) + { + idx(dim) = Range (lb(i), ub(i)); + retcell(i) = x.do_index_op (idx); + } + } + if (! error_state) + retval = retcell; + } + } + } + else + print_usage (); + + return retval; +} + +/* +%!test +%! m = [1, 2, 3, 4; 5, 6, 7, 8; 9, 10, 11, 12]; +%! c = cellslices (m, [1, 2], [2, 3], 2); +%! assert (c, {[1, 2; 5, 6; 9, 10], [2, 3; 6, 7; 10, 11]}); +*/ + +DEFUN (cellindexmat, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{y} =} cellindexmat (@var{x}, @var{varargin})\n\ +Given a cell array of matrices @var{x}, this function computes\n\ +\n\ +@example\n\ +@group\n\ +Y = cell (size (X));\n\ +for i = 1:numel (X)\n\ + Y@{i@} = X@{i@}(varargin@{:@});\n\ +endfor\n\ +@end group\n\ +@end example\n\ +@seealso{cellslices, cellfun}\n\ +@end deftypefn") +{ + octave_value retval; + if (args.length () >= 1) + { + if (args(0).is_cell ()) + { + const Cell x = args(0).cell_value (); + NoAlias<Cell> y(x.dims ()); + octave_idx_type nel = x.numel (); + octave_value_list idx = args.slice (1, args.length () - 1); + + for (octave_idx_type i = 0; i < nel; i++) + { + octave_quit (); + octave_value tmp = x(i); + y(i) = tmp.do_index_op (idx); + if (error_state) + break; + } + + retval = y; + } + else + error ("cellindexmat: X must be a cell"); + } + else + print_usage (); + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/colloc.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,139 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include "CollocWt.h" +#include "lo-mappers.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (colloc, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{r}, @var{amat}, @var{bmat}, @var{q}] =} colloc (@var{n}, \"left\", \"right\")\n\ +Compute derivative and integral weight matrices for orthogonal\n\ +collocation using the subroutines given in J. Villadsen and\n\ +M. L. Michelsen, @cite{Solution of Differential Equation Models by\n\ +Polynomial Approximation}.\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 3) + { + print_usage (); + return retval; + } + + if (! args(0).is_scalar_type ()) + { + error ("colloc: N must be a scalar"); + return retval; + } + + double tmp = args(0).double_value (); + + if (error_state) + return retval; + + if (xisnan (tmp)) + { + error ("colloc: N cannot be NaN"); + return retval; + } + + octave_idx_type ncol = NINTbig (tmp); + if (ncol < 0) + { + error ("colloc: N must be positive"); + return retval; + } + + octave_idx_type ntot = ncol; + octave_idx_type left = 0; + octave_idx_type right = 0; + + for (int i = 1; i < nargin; i++) + { + if (args(i).is_defined ()) + { + if (! args(i).is_string ()) + { + error ("colloc: expecting string argument \"left\" or \"right\""); + return retval; + } + + std::string s = args(i).string_value (); + + if ((s.length () == 1 && (s[0] == 'R' || s[0] == 'r')) + || s == "right") + { + right = 1; + } + else if ((s.length () == 1 && (s[0] == 'L' || s[0] == 'l')) + || s == "left") + { + left = 1; + } + else + { + error ("colloc: unrecognized argument"); + return retval; + } + } + else + { + error ("colloc: unexpected empty argument"); + return retval; + } + } + + ntot += left + right; + if (ntot < 1) + { + error ("colloc: the total number of roots must be positive"); + return retval; + } + + CollocWt wts (ncol, left, right); + + ColumnVector r = wts.roots (); + Matrix A = wts.first (); + Matrix B = wts.second (); + ColumnVector q = wts.quad_weights (); + + retval(3) = q; + retval(2) = B; + retval(1) = A; + retval(0) = r; + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/conv2.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,393 @@ +/* + +Copyright (C) 1999-2012 Andy Adler +Copyright (C) 2010 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "oct-convn.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" +#include "utils.h" + +enum Shape { SHAPE_FULL, SHAPE_SAME, SHAPE_VALID }; + +DEFUN (conv2, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} conv2 (@var{A}, @var{B})\n\ +@deftypefnx {Built-in Function} {} conv2 (@var{v1}, @var{v2}, @var{m})\n\ +@deftypefnx {Built-in Function} {} conv2 (@dots{}, @var{shape})\n\ +Return the 2-D convolution of @var{A} and @var{B}. The size of the result\n\ +is determined by the optional @var{shape} argument which takes the following\n\ +values\n\ +\n\ +@table @asis\n\ +@item @var{shape} = \"full\"\n\ +Return the full convolution. (default)\n\ +\n\ +@item @var{shape} = \"same\"\n\ +Return the central part of the convolution with the same size as @var{A}.\n\ +The central part of the convolution begins at the indices\n\ +@code{floor ([size(@var{B})/2] + 1)}.\n\ +\n\ +@item @var{shape} = \"valid\"\n\ +Return only the parts which do not include zero-padded edges.\n\ +The size of the result is @code{max (size (A) - size (B) + 1, 0)}.\n\ +@end table\n\ +\n\ +When the third argument is a matrix, return the convolution of the matrix\n\ +@var{m} by the vector @var{v1} in the column direction and by the vector\n\ +@var{v2} in the row direction.\n\ +@seealso{conv, convn}\n\ +@end deftypefn") +{ + octave_value retval; + octave_value tmp; + int nargin = args.length (); + std::string shape = "full"; // default + bool separable = false; + convn_type ct; + + if (nargin < 2) + { + print_usage (); + return retval; + } + else if (nargin == 3) + { + if (args(2).is_string ()) + shape = args(2).string_value (); + else + separable = true; + } + else if (nargin >= 4) + { + separable = true; + shape = args(3).string_value (); + } + + if (shape == "full") + ct = convn_full; + else if (shape == "same") + ct = convn_same; + else if (shape == "valid") + ct = convn_valid; + else + { + error ("conv2: SHAPE type not valid"); + print_usage (); + return retval; + } + + if (separable) + { + // If user requests separable, check first two params are vectors + + if (! (1 == args(0).rows () || 1 == args(0).columns ()) + || ! (1 == args(1).rows () || 1 == args(1).columns ())) + { + print_usage (); + return retval; + } + + if (args(0).is_single_type () || args(1).is_single_type () + || args(2).is_single_type ()) + { + if (args(0).is_complex_type () || args(1).is_complex_type () + || args(2).is_complex_type ()) + { + FloatComplexMatrix a (args(2).float_complex_matrix_value ()); + if (args(1).is_real_type () && args(2).is_real_type ()) + { + FloatColumnVector v1 (args(0).float_vector_value ()); + FloatRowVector v2 (args(1).float_vector_value ()); + retval = convn (a, v1, v2, ct); + } + else + { + FloatComplexColumnVector v1 (args(0).float_complex_vector_value ()); + FloatComplexRowVector v2 (args(1).float_complex_vector_value ()); + retval = convn (a, v1, v2, ct); + } + } + else + { + FloatColumnVector v1 (args(0).float_vector_value ()); + FloatRowVector v2 (args(1).float_vector_value ()); + FloatMatrix a (args(2).float_matrix_value ()); + retval = convn (a, v1, v2, ct); + } + } + else + { + if (args(0).is_complex_type () || args(1).is_complex_type () + || args(2).is_complex_type ()) + { + ComplexMatrix a (args(2).complex_matrix_value ()); + if (args(1).is_real_type () && args(2).is_real_type ()) + { + ColumnVector v1 (args(0).vector_value ()); + RowVector v2 (args(1).vector_value ()); + retval = convn (a, v1, v2, ct); + } + else + { + ComplexColumnVector v1 (args(0).complex_vector_value ()); + ComplexRowVector v2 (args(1).complex_vector_value ()); + retval = convn (a, v1, v2, ct); + } + } + else + { + ColumnVector v1 (args(0).vector_value ()); + RowVector v2 (args(1).vector_value ()); + Matrix a (args(2).matrix_value ()); + retval = convn (a, v1, v2, ct); + } + } + } // if (separable) + else + { + if (args(0).is_single_type () || args(1).is_single_type ()) + { + if (args(0).is_complex_type () || args(1).is_complex_type ()) + { + FloatComplexMatrix a (args(0).float_complex_matrix_value ()); + if (args(1).is_real_type ()) + { + FloatMatrix b (args(1).float_matrix_value ()); + retval = convn (a, b, ct); + } + else + { + FloatComplexMatrix b (args(1).float_complex_matrix_value ()); + retval = convn (a, b, ct); + } + } + else + { + FloatMatrix a (args(0).float_matrix_value ()); + FloatMatrix b (args(1).float_matrix_value ()); + retval = convn (a, b, ct); + } + } + else + { + if (args(0).is_complex_type () || args(1).is_complex_type ()) + { + ComplexMatrix a (args(0).complex_matrix_value ()); + if (args(1).is_real_type ()) + { + Matrix b (args(1).matrix_value ()); + retval = convn (a, b, ct); + } + else + { + ComplexMatrix b (args(1).complex_matrix_value ()); + retval = convn (a, b, ct); + } + } + else + { + Matrix a (args(0).matrix_value ()); + Matrix b (args(1).matrix_value ()); + retval = convn (a, b, ct); + } + } + + } // if (separable) + + return retval; +} + +/* +%!test +%! c = [0,1,2,3;1,8,12,12;4,20,24,21;7,22,25,18]; +%! assert (conv2 ([0,1;1,2], [1,2,3;4,5,6;7,8,9]), c); + +%!test +%! c = single ([0,1,2,3;1,8,12,12;4,20,24,21;7,22,25,18]); +%! assert (conv2 (single ([0,1;1,2]), single ([1,2,3;4,5,6;7,8,9])), c); + +%!test +%! c = [1,4,4;5,18,16;14,48,40;19,62,48;15,48,36]; +%! assert (conv2 (1:3, 1:2, [1,2;3,4;5,6]), c); + +%!assert (conv2 (1:3, 1:2, [1,2;3,4;5,6], "full"), +%! conv2 (1:3, 1:2, [1,2;3,4;5,6])); + +%% Test shapes +%!shared A, B, C +%! A = rand (3, 4); +%! B = rand (4); +%! C = conv2 (A, B); +%!assert (conv2 (A,B, "full"), C) +%!assert (conv2 (A,B, "same"), C(3:5,3:6)) +%!assert (conv2 (A,B, "valid"), zeros (0, 1)) +%!assert (size (conv2 (B,A, "valid")), [2 1]) + +%!test +%! B = rand (5); +%! C = conv2 (A, B); +%!assert (conv2 (A,B, "full"), C) +%!assert (conv2 (A,B, "same"), C(3:5,3:6)) +%!assert (conv2 (A,B, "valid"), zeros (0, 0)) +%!assert (size (conv2 (B,A, "valid")), [3 2]) + +%% Clear shared variables so they are not reported for tests below +%!shared + +%% Test cases from Bug #34893 +%!assert (conv2 ([1:5;1:5], [1:2], "same"), [4 7 10 13 10; 4 7 10 13 10]) +%!assert (conv2 ([1:5;1:5]', [1:2]', "same"), [4 7 10 13 10; 4 7 10 13 10]') +%!assert (conv2 ([1:5;1:5], [1:2], "valid"), [4 7 10 13; 4 7 10 13]) +%!assert (conv2 ([1:5;1:5]', [1:2]', "valid"), [4 7 10 13; 4 7 10 13]') + +%!test +%! rand ("seed", 42); +%! x = rand (100); +%! y = ones (5); +%! A = conv2 (x, y)(5:end-4,5:end-4); +%! B = conv2 (x, y, "valid"); +%! assert (B, A); ## Yes, this test is for *exact* equivalence. + + +%% Test input validation +%!error conv2 () +%!error conv2 (1) +%!error <SHAPE type not valid> conv2 (1,2, "NOT_A_SHAPE") +%% Test alternate calling form which should be 2 vectors and a matrix +%!error conv2 (ones (2), 1, 1) +%!error conv2 (1, ones (2), 1) +*/ + +DEFUN (convn, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{C} =} convn (@var{A}, @var{B})\n\ +@deftypefnx {Built-in Function} {@var{C} =} convn (@var{A}, @var{B}, @var{shape})\n\ +Return the n-D convolution of @var{A} and @var{B}. The size of the result\n\ +is determined by the optional @var{shape} argument which takes the following\n\ +values\n\ +\n\ +@table @asis\n\ +@item @var{shape} = \"full\"\n\ +Return the full convolution. (default)\n\ +\n\ +@item @var{shape} = \"same\"\n\ +Return central part of the convolution with the same size as @var{A}.\n\ +The central part of the convolution begins at the indices\n\ +@code{floor ([size(@var{B})/2] + 1)}.\n\ +\n\ +@item @var{shape} = \"valid\"\n\ +Return only the parts which do not include zero-padded edges.\n\ +The size of the result is @code{max (size (A) - size (B) + 1, 0)}.\n\ +@end table\n\ +\n\ +@seealso{conv2, conv}\n\ +@end deftypefn") +{ + octave_value retval; + octave_value tmp; + int nargin = args.length (); + std::string shape = "full"; // default + convn_type ct; + + if (nargin < 2 || nargin > 3) + { + print_usage (); + return retval; + } + else if (nargin == 3) + { + if (args(2).is_string ()) + shape = args(2).string_value (); + } + + if (shape == "full") + ct = convn_full; + else if (shape == "same") + ct = convn_same; + else if (shape == "valid") + ct = convn_valid; + else + { + error ("convn: SHAPE type not valid"); + print_usage (); + return retval; + } + + if (args(0).is_single_type () || args(1).is_single_type ()) + { + if (args(0).is_complex_type () || args(1).is_complex_type ()) + { + FloatComplexNDArray a (args(0).float_complex_array_value ()); + if (args(1).is_real_type ()) + { + FloatNDArray b (args(1).float_array_value ()); + retval = convn (a, b, ct); + } + else + { + FloatComplexNDArray b (args(1).float_complex_array_value ()); + retval = convn (a, b, ct); + } + } + else + { + FloatNDArray a (args(0).float_array_value ()); + FloatNDArray b (args(1).float_array_value ()); + retval = convn (a, b, ct); + } + } + else + { + if (args(0).is_complex_type () || args(1).is_complex_type ()) + { + ComplexNDArray a (args(0).complex_array_value ()); + if (args(1).is_real_type ()) + { + NDArray b (args(1).array_value ()); + retval = convn (a, b, ct); + } + else + { + ComplexNDArray b (args(1).complex_array_value ()); + retval = convn (a, b, ct); + } + } + else + { + NDArray a (args(0).array_value ()); + NDArray b (args(1).array_value ()); + retval = convn (a, b, ct); + } + } + + return retval; +} + +/* + FIXME: Need tests for convn in addition to conv2. +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/daspk.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,480 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include <iomanip> +#include <iostream> + +#include "DASPK.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ov-fcn.h" +#include "ov-cell.h" +#include "pager.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" + +#include "DASPK-opts.cc" + +// Global pointer for user defined function required by daspk. +static octave_function *daspk_fcn; + +// Global pointer for optional user defined jacobian function. +static octave_function *daspk_jac; + +// Have we warned about imaginary values returned from user function? +static bool warned_fcn_imaginary = false; +static bool warned_jac_imaginary = false; + +// Is this a recursive call? +static int call_depth = 0; + +ColumnVector +daspk_user_function (const ColumnVector& x, const ColumnVector& xdot, + double t, octave_idx_type& ires) +{ + ColumnVector retval; + + assert (x.capacity () == xdot.capacity ()); + + octave_value_list args; + + args(2) = t; + args(1) = xdot; + args(0) = x; + + if (daspk_fcn) + { + octave_value_list tmp = daspk_fcn->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("daspk"); + return retval; + } + + int tlen = tmp.length (); + if (tlen > 0 && tmp(0).is_defined ()) + { + if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) + { + warning ("daspk: ignoring imaginary part returned from user-supplied function"); + warned_fcn_imaginary = true; + } + + retval = ColumnVector (tmp(0).vector_value ()); + + if (tlen > 1) + ires = tmp(1).int_value (); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("daspk"); + } + else + gripe_user_supplied_eval ("daspk"); + } + + return retval; +} + +Matrix +daspk_user_jacobian (const ColumnVector& x, const ColumnVector& xdot, + double t, double cj) +{ + Matrix retval; + + assert (x.capacity () == xdot.capacity ()); + + octave_value_list args; + + args(3) = cj; + args(2) = t; + args(1) = xdot; + args(0) = x; + + if (daspk_jac) + { + octave_value_list tmp = daspk_jac->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("daspk"); + return retval; + } + + int tlen = tmp.length (); + if (tlen > 0 && tmp(0).is_defined ()) + { + if (! warned_jac_imaginary && tmp(0).is_complex_type ()) + { + warning ("daspk: ignoring imaginary part returned from user-supplied jacobian function"); + warned_jac_imaginary = true; + } + + retval = tmp(0).matrix_value (); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("daspk"); + } + else + gripe_user_supplied_eval ("daspk"); + } + + return retval; +} + +#define DASPK_ABORT() \ + return retval + +#define DASPK_ABORT1(msg) \ + do \ + { \ + ::error ("daspk: " msg); \ + DASPK_ABORT (); \ + } \ + while (0) + +#define DASPK_ABORT2(fmt, arg) \ + do \ + { \ + ::error ("daspk: " fmt, arg); \ + DASPK_ABORT (); \ + } \ + while (0) + +DEFUN (daspk, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{x}, @var{xdot}, @var{istate}, @var{msg}] =} daspk (@var{fcn}, @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ +Solve the set of differential-algebraic equations\n\ +@tex\n\ +$$ 0 = f (x, \\dot{x}, t) $$\n\ +with\n\ +$$ x(t_0) = x_0, \\dot{x}(t_0) = \\dot{x}_0 $$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +0 = f (x, xdot, t)\n\ +@end example\n\ +\n\ +@noindent\n\ +with\n\ +\n\ +@example\n\ +x(t_0) = x_0, xdot(t_0) = xdot_0\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +The solution is returned in the matrices @var{x} and @var{xdot},\n\ +with each row in the result matrices corresponding to one of the\n\ +elements in the vector @var{t}. The first element of @var{t}\n\ +should be @math{t_0} and correspond to the initial state of the\n\ +system @var{x_0} and its derivative @var{xdot_0}, so that the first\n\ +row of the output @var{x} is @var{x_0} and the first row\n\ +of the output @var{xdot} is @var{xdot_0}.\n\ +\n\ +The first argument, @var{fcn}, is a string, inline, or function handle\n\ +that names the function @math{f} to call to compute the vector of\n\ +residuals for the set of equations. It must have the form\n\ +\n\ +@example\n\ +@var{res} = f (@var{x}, @var{xdot}, @var{t})\n\ +@end example\n\ +\n\ +@noindent\n\ +in which @var{x}, @var{xdot}, and @var{res} are vectors, and @var{t} is a\n\ +scalar.\n\ +\n\ +If @var{fcn} is a two-element string array or a two-element cell array\n\ +of strings, inline functions, or function handles, the first element names\n\ +the function @math{f} described above, and the second element names a\n\ +function to compute the modified Jacobian\n\ +@tex\n\ +$$\n\ +J = {\\partial f \\over \\partial x}\n\ + + c {\\partial f \\over \\partial \\dot{x}}\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ + df df\n\ +jac = -- + c ------\n\ + dx d xdot\n\ +@end group\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +\n\ +The modified Jacobian function must have the form\n\ +\n\ +@example\n\ +@group\n\ +\n\ +@var{jac} = j (@var{x}, @var{xdot}, @var{t}, @var{c})\n\ +\n\ +@end group\n\ +@end example\n\ +\n\ +The second and third arguments to @code{daspk} specify the initial\n\ +condition of the states and their derivatives, and the fourth argument\n\ +specifies a vector of output times at which the solution is desired,\n\ +including the time corresponding to the initial condition.\n\ +\n\ +The set of initial states and derivatives are not strictly required to\n\ +be consistent. If they are not consistent, you must use the\n\ +@code{daspk_options} function to provide additional information so\n\ +that @code{daspk} can compute a consistent starting point.\n\ +\n\ +The fifth argument is optional, and may be used to specify a set of\n\ +times that the DAE solver should not integrate past. It is useful for\n\ +avoiding difficulties with singularities and points where there is a\n\ +discontinuity in the derivative.\n\ +\n\ +After a successful computation, the value of @var{istate} will be\n\ +greater than zero (consistent with the Fortran version of @sc{daspk}).\n\ +\n\ +If the computation is not successful, the value of @var{istate} will be\n\ +less than zero and @var{msg} will contain additional information.\n\ +\n\ +You can use the function @code{daspk_options} to set optional\n\ +parameters for @code{daspk}.\n\ +@seealso{dassl}\n\ +@end deftypefn") +{ + octave_value_list retval; + + warned_fcn_imaginary = false; + warned_jac_imaginary = false; + + unwind_protect frame; + + frame.protect_var (call_depth); + call_depth++; + + if (call_depth > 1) + DASPK_ABORT1 ("invalid recursive call"); + + int nargin = args.length (); + + if (nargin > 3 && nargin < 6) + { + std::string fcn_name, fname, jac_name, jname; + daspk_fcn = 0; + daspk_jac = 0; + + octave_value f_arg = args(0); + + if (f_arg.is_cell ()) + { + Cell c = f_arg.cell_value (); + if (c.length () == 1) + f_arg = c(0); + else if (c.length () == 2) + { + if (c(0).is_function_handle () || c(0).is_inline_function ()) + daspk_fcn = c(0).function_value (); + else + { + fcn_name = unique_symbol_name ("__daspk_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + daspk_fcn = extract_function + (c(0), "daspk", fcn_name, fname, "; endfunction"); + } + + if (daspk_fcn) + { + if (c(1).is_function_handle () || c(1).is_inline_function ()) + daspk_jac = c(1).function_value (); + else + { + jac_name = unique_symbol_name ("__daspk_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, xdot, t, cj) jac = "); + daspk_jac = extract_function + (c(1), "daspk", jac_name, jname, "; endfunction"); + + if (!daspk_jac) + { + if (fcn_name.length ()) + clear_function (fcn_name); + daspk_fcn = 0; + } + } + } + } + else + DASPK_ABORT1 ("incorrect number of elements in cell array"); + } + + if (!daspk_fcn && ! f_arg.is_cell ()) + { + if (f_arg.is_function_handle () || f_arg.is_inline_function ()) + daspk_fcn = f_arg.function_value (); + else + { + switch (f_arg.rows ()) + { + case 1: + do + { + fcn_name = unique_symbol_name ("__daspk_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + daspk_fcn = extract_function + (f_arg, "daspk", fcn_name, fname, "; endfunction"); + } + while (0); + break; + + case 2: + { + string_vector tmp = f_arg.all_strings (); + + if (! error_state) + { + fcn_name = unique_symbol_name ("__daspk_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + daspk_fcn = extract_function + (tmp(0), "daspk", fcn_name, fname, "; endfunction"); + + if (daspk_fcn) + { + jac_name = unique_symbol_name ("__daspk_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, xdot, t, cj) jac = "); + daspk_jac = extract_function + (tmp(1), "daspk", jac_name, jname, + "; endfunction"); + + if (!daspk_jac) + { + if (fcn_name.length ()) + clear_function (fcn_name); + daspk_fcn = 0; + } + } + } + } + } + } + } + + if (error_state || ! daspk_fcn) + DASPK_ABORT (); + + ColumnVector state = ColumnVector (args(1).vector_value ()); + + if (error_state) + DASPK_ABORT1 ("expecting state vector as second argument"); + + ColumnVector deriv (args(2).vector_value ()); + + if (error_state) + DASPK_ABORT1 ("expecting derivative vector as third argument"); + + ColumnVector out_times (args(3).vector_value ()); + + if (error_state) + DASPK_ABORT1 ("expecting output time vector as fourth argument"); + + ColumnVector crit_times; + int crit_times_set = 0; + if (nargin > 4) + { + crit_times = ColumnVector (args(4).vector_value ()); + + if (error_state) + DASPK_ABORT1 ("expecting critical time vector as fifth argument"); + + crit_times_set = 1; + } + + if (state.capacity () != deriv.capacity ()) + DASPK_ABORT1 ("x and xdot must have the same size"); + + double tzero = out_times (0); + + DAEFunc func (daspk_user_function); + if (daspk_jac) + func.set_jacobian_function (daspk_user_jacobian); + + DASPK dae (state, deriv, tzero, func); + dae.set_options (daspk_opts); + + Matrix output; + Matrix deriv_output; + + if (crit_times_set) + output = dae.integrate (out_times, deriv_output, crit_times); + else + output = dae.integrate (out_times, deriv_output); + + if (fcn_name.length ()) + clear_function (fcn_name); + if (jac_name.length ()) + clear_function (jac_name); + + if (! error_state) + { + std::string msg = dae.error_message (); + + retval(3) = msg; + retval(2) = static_cast<double> (dae.integration_state ()); + + if (dae.integration_ok ()) + { + retval(1) = deriv_output; + retval(0) = output; + } + else + { + retval(1) = Matrix (); + retval(0) = Matrix (); + + if (nargout < 3) + error ("daspk: %s", msg.c_str ()); + } + } + } + else + print_usage (); + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/dasrt.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,590 @@ +/* + +Copyright (C) 2002-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <iostream> +#include <string> + +#include "DASRT.h" +#include "lo-mappers.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ov-fcn.h" +#include "ov-cell.h" +#include "pager.h" +#include "parse.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" + +#include "DASRT-opts.cc" + +// Global pointers for user defined function required by dasrt. +static octave_function *dasrt_f; +static octave_function *dasrt_j; +static octave_function *dasrt_cf; + +// Have we warned about imaginary values returned from user function? +static bool warned_fcn_imaginary = false; +static bool warned_jac_imaginary = false; +static bool warned_cf_imaginary = false; + +// Is this a recursive call? +static int call_depth = 0; + +static ColumnVector +dasrt_user_f (const ColumnVector& x, const ColumnVector& xdot, + double t, octave_idx_type&) +{ + ColumnVector retval; + + assert (x.capacity () == xdot.capacity ()); + + octave_value_list args; + + args(2) = t; + args(1) = xdot; + args(0) = x; + + if (dasrt_f) + { + octave_value_list tmp = dasrt_f->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("dasrt"); + return retval; + } + + if (tmp.length () > 0 && tmp(0).is_defined ()) + { + if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) + { + warning ("dasrt: ignoring imaginary part returned from user-supplied function"); + warned_fcn_imaginary = true; + } + + retval = ColumnVector (tmp(0).vector_value ()); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("dasrt"); + } + else + gripe_user_supplied_eval ("dasrt"); + } + + return retval; +} + +static ColumnVector +dasrt_user_cf (const ColumnVector& x, double t) +{ + ColumnVector retval; + + octave_value_list args; + + args(1) = t; + args(0) = x; + + if (dasrt_cf) + { + octave_value_list tmp = dasrt_cf->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("dasrt"); + return retval; + } + + if (tmp.length () > 0 && tmp(0).is_defined ()) + { + if (! warned_cf_imaginary && tmp(0).is_complex_type ()) + { + warning ("dasrt: ignoring imaginary part returned from user-supplied constraint function"); + warned_cf_imaginary = true; + } + + retval = ColumnVector (tmp(0).vector_value ()); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("dasrt"); + } + else + gripe_user_supplied_eval ("dasrt"); + } + + return retval; +} + +static Matrix +dasrt_user_j (const ColumnVector& x, const ColumnVector& xdot, + double t, double cj) +{ + Matrix retval; + + assert (x.capacity () == xdot.capacity ()); + + octave_value_list args; + + args(3) = cj; + args(2) = t; + args(1) = xdot; + args(0) = x; + + if (dasrt_j) + { + octave_value_list tmp = dasrt_j->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("dasrt"); + return retval; + } + + int tlen = tmp.length (); + if (tlen > 0 && tmp(0).is_defined ()) + { + if (! warned_jac_imaginary && tmp(0).is_complex_type ()) + { + warning ("dasrt: ignoring imaginary part returned from user-supplied jacobian function"); + warned_jac_imaginary = true; + } + + retval = tmp(0).matrix_value (); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("dasrt"); + } + else + gripe_user_supplied_eval ("dasrt"); + } + + return retval; +} + +#define DASRT_ABORT \ + return retval + +#define DASRT_ABORT1(msg) \ + do \ + { \ + ::error ("dasrt: " msg); \ + DASRT_ABORT; \ + } \ + while (0) + +#define DASRT_ABORT2(fmt, arg) \ + do \ + { \ + ::error ("dasrt: " fmt, arg); \ + DASRT_ABORT; \ + } \ + while (0) + +DEFUN (dasrt, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{x}, @var{xdot}, @var{t_out}, @var{istat}, @var{msg}] =} dasrt (@var{fcn}, [], @var{x_0}, @var{xdot_0}, @var{t})\n\ +@deftypefnx {Built-in Function} {@dots{} =} dasrt (@var{fcn}, @var{g}, @var{x_0}, @var{xdot_0}, @var{t})\n\ +@deftypefnx {Built-in Function} {@dots{} =} dasrt (@var{fcn}, [], @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ +@deftypefnx {Built-in Function} {@dots{} =} dasrt (@var{fcn}, @var{g}, @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ +Solve the set of differential-algebraic equations\n\ +@tex\n\ +$$ 0 = f (x, \\dot{x}, t) $$\n\ +with\n\ +$$ x(t_0) = x_0, \\dot{x}(t_0) = \\dot{x}_0 $$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +0 = f (x, xdot, t)\n\ +@end example\n\ +\n\ +@noindent\n\ +with\n\ +\n\ +@example\n\ +x(t_0) = x_0, xdot(t_0) = xdot_0\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +with functional stopping criteria (root solving).\n\ +\n\ +The solution is returned in the matrices @var{x} and @var{xdot},\n\ +with each row in the result matrices corresponding to one of the\n\ +elements in the vector @var{t_out}. The first element of @var{t}\n\ +should be @math{t_0} and correspond to the initial state of the\n\ +system @var{x_0} and its derivative @var{xdot_0}, so that the first\n\ +row of the output @var{x} is @var{x_0} and the first row\n\ +of the output @var{xdot} is @var{xdot_0}.\n\ +\n\ +The vector @var{t} provides an upper limit on the length of the\n\ +integration. If the stopping condition is met, the vector\n\ +@var{t_out} will be shorter than @var{t}, and the final element of\n\ +@var{t_out} will be the point at which the stopping condition was met,\n\ +and may not correspond to any element of the vector @var{t}.\n\ +\n\ +The first argument, @var{fcn}, is a string, inline, or function handle\n\ +that names the function @math{f} to call to compute the vector of\n\ +residuals for the set of equations. It must have the form\n\ +\n\ +@example\n\ +@var{res} = f (@var{x}, @var{xdot}, @var{t})\n\ +@end example\n\ +\n\ +@noindent\n\ +in which @var{x}, @var{xdot}, and @var{res} are vectors, and @var{t} is a\n\ +scalar.\n\ +\n\ +If @var{fcn} is a two-element string array or a two-element cell array\n\ +of strings, inline functions, or function handles, the first element names\n\ +the function @math{f} described above, and the second element names a\n\ +function to compute the modified Jacobian\n\ +\n\ +@tex\n\ +$$\n\ +J = {\\partial f \\over \\partial x}\n\ + + c {\\partial f \\over \\partial \\dot{x}}\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ + df df\n\ +jac = -- + c ------\n\ + dx d xdot\n\ +@end group\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +\n\ +The modified Jacobian function must have the form\n\ +\n\ +@example\n\ +@group\n\ +\n\ +@var{jac} = j (@var{x}, @var{xdot}, @var{t}, @var{c})\n\ +\n\ +@end group\n\ +@end example\n\ +\n\ +The optional second argument names a function that defines the\n\ +constraint functions whose roots are desired during the integration.\n\ +This function must have the form\n\ +\n\ +@example\n\ +@var{g_out} = g (@var{x}, @var{t})\n\ +@end example\n\ +\n\ +@noindent\n\ +and return a vector of the constraint function values.\n\ +If the value of any of the constraint functions changes sign, @sc{dasrt}\n\ +will attempt to stop the integration at the point of the sign change.\n\ +\n\ +If the name of the constraint function is omitted, @code{dasrt} solves\n\ +the same problem as @code{daspk} or @code{dassl}.\n\ +\n\ +Note that because of numerical errors in the constraint functions\n\ +due to round-off and integration error, @sc{dasrt} may return false\n\ +roots, or return the same root at two or more nearly equal values of\n\ +@var{T}. If such false roots are suspected, the user should consider\n\ +smaller error tolerances or higher precision in the evaluation of the\n\ +constraint functions.\n\ +\n\ +If a root of some constraint function defines the end of the problem,\n\ +the input to @sc{dasrt} should nevertheless allow integration to a\n\ +point slightly past that root, so that @sc{dasrt} can locate the root\n\ +by interpolation.\n\ +\n\ +The third and fourth arguments to @code{dasrt} specify the initial\n\ +condition of the states and their derivatives, and the fourth argument\n\ +specifies a vector of output times at which the solution is desired,\n\ +including the time corresponding to the initial condition.\n\ +\n\ +The set of initial states and derivatives are not strictly required to\n\ +be consistent. In practice, however, @sc{dassl} is not very good at\n\ +determining a consistent set for you, so it is best if you ensure that\n\ +the initial values result in the function evaluating to zero.\n\ +\n\ +The sixth argument is optional, and may be used to specify a set of\n\ +times that the DAE solver should not integrate past. It is useful for\n\ +avoiding difficulties with singularities and points where there is a\n\ +discontinuity in the derivative.\n\ +\n\ +After a successful computation, the value of @var{istate} will be\n\ +greater than zero (consistent with the Fortran version of @sc{dassl}).\n\ +\n\ +If the computation is not successful, the value of @var{istate} will be\n\ +less than zero and @var{msg} will contain additional information.\n\ +\n\ +You can use the function @code{dasrt_options} to set optional\n\ +parameters for @code{dasrt}.\n\ +@seealso{dasrt_options, daspk, dasrt, lsode}\n\ +@end deftypefn") +{ + octave_value_list retval; + + warned_fcn_imaginary = false; + warned_jac_imaginary = false; + warned_cf_imaginary = false; + + unwind_protect frame; + + frame.protect_var (call_depth); + call_depth++; + + if (call_depth > 1) + DASRT_ABORT1 ("invalid recursive call"); + + int argp = 0; + + int nargin = args.length (); + + if (nargin < 4 || nargin > 6) + { + print_usage (); + return retval; + } + + std::string fcn_name, fname, jac_name, jname; + dasrt_f = 0; + dasrt_j = 0; + dasrt_cf = 0; + + // Check all the arguments. Are they the right animals? + + // Here's where I take care of f and j in one shot: + + octave_value f_arg = args(0); + + if (f_arg.is_cell ()) + { + Cell c = f_arg.cell_value (); + if (c.length () == 1) + f_arg = c(0); + else if (c.length () == 2) + { + if (c(0).is_function_handle () || c(0).is_inline_function ()) + dasrt_f = c(0).function_value (); + else + { + fcn_name = unique_symbol_name ("__dasrt_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + dasrt_f = extract_function + (c(0), "dasrt", fcn_name, fname, "; endfunction"); + } + + if (dasrt_f) + { + if (c(1).is_function_handle () || c(1).is_inline_function ()) + dasrt_j = c(1).function_value (); + else + { + jac_name = unique_symbol_name ("__dasrt_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, xdot, t, cj) jac = "); + dasrt_j = extract_function + (c(1), "dasrt", jac_name, jname, "; endfunction"); + + if (!dasrt_j) + { + if (fcn_name.length ()) + clear_function (fcn_name); + dasrt_f = 0; + } + } + } + } + else + DASRT_ABORT1 ("incorrect number of elements in cell array"); + } + + if (!dasrt_f && ! f_arg.is_cell ()) + { + if (f_arg.is_function_handle () || f_arg.is_inline_function ()) + dasrt_f = f_arg.function_value (); + else + { + switch (f_arg.rows ()) + { + case 1: + fcn_name = unique_symbol_name ("__dasrt_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + dasrt_f = extract_function + (f_arg, "dasrt", fcn_name, fname, "; endfunction"); + break; + + case 2: + { + string_vector tmp = args(0).all_strings (); + + if (! error_state) + { + fcn_name = unique_symbol_name ("__dasrt_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + dasrt_f = extract_function + (tmp(0), "dasrt", fcn_name, fname, "; endfunction"); + + if (dasrt_f) + { + jac_name = unique_symbol_name ("__dasrt_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, xdot, t, cj) jac = "); + dasrt_j = extract_function + (tmp(1), "dasrt", jac_name, jname, "; endfunction"); + + if (! dasrt_j) + dasrt_f = 0; + } + } + } + break; + + default: + DASRT_ABORT1 + ("first arg should be a string or 2-element string array"); + } + } + } + + if (error_state || (! dasrt_f)) + DASRT_ABORT; + + DAERTFunc func (dasrt_user_f); + + argp++; + + if (args(1).is_function_handle () || args(1).is_inline_function ()) + { + dasrt_cf = args(1).function_value (); + + if (! dasrt_cf) + DASRT_ABORT1 ("expecting function name as argument 2"); + + argp++; + + func.set_constraint_function (dasrt_user_cf); + } + else if (args(1).is_string ()) + { + dasrt_cf = is_valid_function (args(1), "dasrt", true); + if (! dasrt_cf) + DASRT_ABORT1 ("expecting function name as argument 2"); + + argp++; + + func.set_constraint_function (dasrt_user_cf); + } + + ColumnVector state (args(argp++).vector_value ()); + + if (error_state) + DASRT_ABORT2 ("expecting state vector as argument %d", argp); + + ColumnVector stateprime (args(argp++).vector_value ()); + + if (error_state) + DASRT_ABORT2 + ("expecting time derivative of state vector as argument %d", argp); + + ColumnVector out_times (args(argp++).vector_value ()); + + if (error_state) + DASRT_ABORT2 + ("expecting output time vector as %s argument %d", argp); + + double tzero = out_times (0); + + ColumnVector crit_times; + + bool crit_times_set = false; + + if (argp < nargin) + { + crit_times = ColumnVector (args(argp++).vector_value ()); + + if (error_state) + DASRT_ABORT2 + ("expecting critical time vector as argument %d", argp); + + crit_times_set = true; + } + + if (dasrt_j) + func.set_jacobian_function (dasrt_user_j); + + DASRT_result output; + + DASRT dae = DASRT (state, stateprime, tzero, func); + + dae.set_options (dasrt_opts); + + if (crit_times_set) + output = dae.integrate (out_times, crit_times); + else + output = dae.integrate (out_times); + + if (fcn_name.length ()) + clear_function (fcn_name); + if (jac_name.length ()) + clear_function (jac_name); + + if (! error_state) + { + std::string msg = dae.error_message (); + + retval(4) = msg; + retval(3) = static_cast<double> (dae.integration_state ()); + + if (dae.integration_ok ()) + { + retval(2) = output.times (); + retval(1) = output.deriv (); + retval(0) = output.state (); + } + else + { + retval(2) = Matrix (); + retval(1) = Matrix (); + retval(0) = Matrix (); + + if (nargout < 4) + error ("dasrt: %s", msg.c_str ()); + } + } + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/dassl.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,565 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include <iomanip> +#include <iostream> + +#include "DASSL.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ov-fcn.h" +#include "ov-cell.h" +#include "pager.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" + +#include "DASSL-opts.cc" + +// Global pointer for user defined function required by dassl. +static octave_function *dassl_fcn; + +// Global pointer for optional user defined jacobian function. +static octave_function *dassl_jac; + +// Have we warned about imaginary values returned from user function? +static bool warned_fcn_imaginary = false; +static bool warned_jac_imaginary = false; + +// Is this a recursive call? +static int call_depth = 0; + +ColumnVector +dassl_user_function (const ColumnVector& x, const ColumnVector& xdot, + double t, octave_idx_type& ires) +{ + ColumnVector retval; + + assert (x.capacity () == xdot.capacity ()); + + octave_value_list args; + + args(2) = t; + args(1) = xdot; + args(0) = x; + + if (dassl_fcn) + { + octave_value_list tmp = dassl_fcn->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("dassl"); + return retval; + } + + int tlen = tmp.length (); + if (tlen > 0 && tmp(0).is_defined ()) + { + if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) + { + warning ("dassl: ignoring imaginary part returned from user-supplied function"); + warned_fcn_imaginary = true; + } + + retval = ColumnVector (tmp(0).vector_value ()); + + if (tlen > 1) + ires = tmp(1).int_value (); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("dassl"); + } + else + gripe_user_supplied_eval ("dassl"); + } + + return retval; +} + +Matrix +dassl_user_jacobian (const ColumnVector& x, const ColumnVector& xdot, + double t, double cj) +{ + Matrix retval; + + assert (x.capacity () == xdot.capacity ()); + + octave_value_list args; + + args(3) = cj; + args(2) = t; + args(1) = xdot; + args(0) = x; + + if (dassl_jac) + { + octave_value_list tmp = dassl_jac->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("dassl"); + return retval; + } + + int tlen = tmp.length (); + if (tlen > 0 && tmp(0).is_defined ()) + { + if (! warned_jac_imaginary && tmp(0).is_complex_type ()) + { + warning ("dassl: ignoring imaginary part returned from user-supplied jacobian function"); + warned_jac_imaginary = true; + } + + retval = tmp(0).matrix_value (); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("dassl"); + } + else + gripe_user_supplied_eval ("dassl"); + } + + return retval; +} + +#define DASSL_ABORT() \ + return retval + +#define DASSL_ABORT1(msg) \ + do \ + { \ + ::error ("dassl: " msg); \ + DASSL_ABORT (); \ + } \ + while (0) + +#define DASSL_ABORT2(fmt, arg) \ + do \ + { \ + ::error ("dassl: " fmt, arg); \ + DASSL_ABORT (); \ + } \ + while (0) + +DEFUN (dassl, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{x}, @var{xdot}, @var{istate}, @var{msg}] =} dassl (@var{fcn}, @var{x_0}, @var{xdot_0}, @var{t}, @var{t_crit})\n\ +Solve the set of differential-algebraic equations\n\ +@tex\n\ +$$ 0 = f (x, \\dot{x}, t) $$\n\ +with\n\ +$$ x(t_0) = x_0, \\dot{x}(t_0) = \\dot{x}_0 $$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +0 = f (x, xdot, t)\n\ +@end example\n\ +\n\ +@noindent\n\ +with\n\ +\n\ +@example\n\ +x(t_0) = x_0, xdot(t_0) = xdot_0\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +The solution is returned in the matrices @var{x} and @var{xdot},\n\ +with each row in the result matrices corresponding to one of the\n\ +elements in the vector @var{t}. The first element of @var{t}\n\ +should be @math{t_0} and correspond to the initial state of the\n\ +system @var{x_0} and its derivative @var{xdot_0}, so that the first\n\ +row of the output @var{x} is @var{x_0} and the first row\n\ +of the output @var{xdot} is @var{xdot_0}.\n\ +\n\ +The first argument, @var{fcn}, is a string, inline, or function handle\n\ +that names the function @math{f} to call to compute the vector of\n\ +residuals for the set of equations. It must have the form\n\ +\n\ +@example\n\ +@var{res} = f (@var{x}, @var{xdot}, @var{t})\n\ +@end example\n\ +\n\ +@noindent\n\ +in which @var{x}, @var{xdot}, and @var{res} are vectors, and @var{t} is a\n\ +scalar.\n\ +\n\ +If @var{fcn} is a two-element string array or a two-element cell array\n\ +of strings, inline functions, or function handles, the first element names\n\ +the function @math{f} described above, and the second element names a\n\ +function to compute the modified Jacobian\n\ +\n\ +@tex\n\ +$$\n\ +J = {\\partial f \\over \\partial x}\n\ + + c {\\partial f \\over \\partial \\dot{x}}\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ + df df\n\ +jac = -- + c ------\n\ + dx d xdot\n\ +@end group\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +\n\ +The modified Jacobian function must have the form\n\ +\n\ +@example\n\ +@group\n\ +\n\ +@var{jac} = j (@var{x}, @var{xdot}, @var{t}, @var{c})\n\ +\n\ +@end group\n\ +@end example\n\ +\n\ +The second and third arguments to @code{dassl} specify the initial\n\ +condition of the states and their derivatives, and the fourth argument\n\ +specifies a vector of output times at which the solution is desired,\n\ +including the time corresponding to the initial condition.\n\ +\n\ +The set of initial states and derivatives are not strictly required to\n\ +be consistent. In practice, however, @sc{dassl} is not very good at\n\ +determining a consistent set for you, so it is best if you ensure that\n\ +the initial values result in the function evaluating to zero.\n\ +\n\ +The fifth argument is optional, and may be used to specify a set of\n\ +times that the DAE solver should not integrate past. It is useful for\n\ +avoiding difficulties with singularities and points where there is a\n\ +discontinuity in the derivative.\n\ +\n\ +After a successful computation, the value of @var{istate} will be\n\ +greater than zero (consistent with the Fortran version of @sc{dassl}).\n\ +\n\ +If the computation is not successful, the value of @var{istate} will be\n\ +less than zero and @var{msg} will contain additional information.\n\ +\n\ +You can use the function @code{dassl_options} to set optional\n\ +parameters for @code{dassl}.\n\ +@seealso{daspk, dasrt, lsode}\n\ +@end deftypefn") +{ + octave_value_list retval; + + warned_fcn_imaginary = false; + warned_jac_imaginary = false; + + unwind_protect frame; + + frame.protect_var (call_depth); + call_depth++; + + if (call_depth > 1) + DASSL_ABORT1 ("invalid recursive call"); + + int nargin = args.length (); + + if (nargin > 3 && nargin < 6 && nargout < 5) + { + std::string fcn_name, fname, jac_name, jname; + dassl_fcn = 0; + dassl_jac = 0; + + octave_value f_arg = args(0); + + if (f_arg.is_cell ()) + { + Cell c = f_arg.cell_value (); + if (c.length () == 1) + f_arg = c(0); + else if (c.length () == 2) + { + if (c(0).is_function_handle () || c(0).is_inline_function ()) + dassl_fcn = c(0).function_value (); + else + { + fcn_name = unique_symbol_name ("__dassl_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + dassl_fcn = extract_function + (c(0), "dassl", fcn_name, fname, "; endfunction"); + } + + if (dassl_fcn) + { + if (c(1).is_function_handle () || c(1).is_inline_function ()) + dassl_jac = c(1).function_value (); + else + { + jac_name = unique_symbol_name ("__dassl_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, xdot, t, cj) jac = "); + dassl_jac = extract_function + (c(1), "dassl", jac_name, jname, "; endfunction"); + + if (!dassl_jac) + { + if (fcn_name.length ()) + clear_function (fcn_name); + dassl_fcn = 0; + } + } + } + } + else + DASSL_ABORT1 ("incorrect number of elements in cell array"); + } + + if (!dassl_fcn && ! f_arg.is_cell ()) + { + if (f_arg.is_function_handle () || f_arg.is_inline_function ()) + dassl_fcn = f_arg.function_value (); + else + { + switch (f_arg.rows ()) + { + case 1: + do + { + fcn_name = unique_symbol_name ("__dassl_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + dassl_fcn = extract_function + (f_arg, "dassl", fcn_name, fname, "; endfunction"); + } + while (0); + break; + + case 2: + { + string_vector tmp = f_arg.all_strings (); + + if (! error_state) + { + fcn_name = unique_symbol_name ("__dassl_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, xdot, t) y = "); + dassl_fcn = extract_function + (tmp(0), "dassl", fcn_name, fname, "; endfunction"); + + if (dassl_fcn) + { + jac_name = unique_symbol_name ("__dassl_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, xdot, t, cj) jac = "); + dassl_jac = extract_function + (tmp(1), "dassl", jac_name, jname, + "; endfunction"); + + if (!dassl_jac) + { + if (fcn_name.length ()) + clear_function (fcn_name); + dassl_fcn = 0; + } + } + } + } + } + } + } + + if (error_state || ! dassl_fcn) + DASSL_ABORT (); + + ColumnVector state = ColumnVector (args(1).vector_value ()); + + if (error_state) + DASSL_ABORT1 ("expecting state vector as second argument"); + + ColumnVector deriv (args(2).vector_value ()); + + if (error_state) + DASSL_ABORT1 ("expecting derivative vector as third argument"); + + ColumnVector out_times (args(3).vector_value ()); + + if (error_state) + DASSL_ABORT1 ("expecting output time vector as fourth argument"); + + ColumnVector crit_times; + int crit_times_set = 0; + if (nargin > 4) + { + crit_times = ColumnVector (args(4).vector_value ()); + + if (error_state) + DASSL_ABORT1 ("expecting critical time vector as fifth argument"); + + crit_times_set = 1; + } + + if (state.capacity () != deriv.capacity ()) + DASSL_ABORT1 ("x and xdot must have the same size"); + + double tzero = out_times (0); + + DAEFunc func (dassl_user_function); + if (dassl_jac) + func.set_jacobian_function (dassl_user_jacobian); + + DASSL dae (state, deriv, tzero, func); + + dae.set_options (dassl_opts); + + Matrix output; + Matrix deriv_output; + + if (crit_times_set) + output = dae.integrate (out_times, deriv_output, crit_times); + else + output = dae.integrate (out_times, deriv_output); + + if (fcn_name.length ()) + clear_function (fcn_name); + if (jac_name.length ()) + clear_function (jac_name); + + if (! error_state) + { + std::string msg = dae.error_message (); + + retval(3) = msg; + retval(2) = static_cast<double> (dae.integration_state ()); + + if (dae.integration_ok ()) + { + retval(1) = deriv_output; + retval(0) = output; + } + else + { + retval(1) = Matrix (); + retval(0) = Matrix (); + + if (nargout < 3) + error ("dassl: %s", msg.c_str ()); + } + } + } + else + print_usage (); + + return retval; +} + +/* +## dassl-1.m +## +## Test dassl() function +## +## Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +## Comalco Research and Technology +## 20 May 1998 +## +## Problem +## +## y1' = -y2, y1(0) = 1 +## y2' = y1, y2(0) = 0 +## +## Solution +## +## y1(t) = cos(t) +## y2(t) = sin(t) +## +%!function res = __f (x, xdot, t) +%! res = [xdot(1)+x(2); xdot(2)-x(1)]; +%!endfunction + +%!test +%! +%! x0 = [1; 0]; +%! xdot0 = [0; 1]; +%! t = (0:1:10)'; +%! +%! tol = 100 * dassl_options ("relative tolerance"); +%! +%! [x, xdot] = dassl ("__f", x0, xdot0, t); +%! +%! y = [cos(t), sin(t)]; +%! +%! assert (x, y, tol); + +## dassl-2.m +## +## Test dassl() function +## +## Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +## Comalco Research and Technology +## 20 May 1998 +## +## Based on SLATEC quick check for DASSL by Linda Petzold +## +## Problem +## +## x1' + 10*x1 = 0, x1(0) = 1 +## x1 + x2 = 1, x2(0) = 0 +## +## +## Solution +## +## x1(t) = exp(-10*t) +## x2(t) = 1 - x(1) +## +%!function res = __f (x, xdot, t) +%! res = [xdot(1)+10*x(1); x(1)+x(2)-1]; +%!endfunction + +%!test +%! +%! x0 = [1; 0]; +%! xdot0 = [-10; 10]; +%! t = (0:0.2:1)'; +%! +%! tol = 500 * dassl_options ("relative tolerance"); +%! +%! [x, xdot] = dassl ("__f", x0, xdot0, t); +%! +%! y = [exp(-10*t), 1-exp(-10*t)]; +%! +%! assert (x, y, tol); + +%!test +%! dassl_options ("absolute tolerance", eps); +%! assert (dassl_options ("absolute tolerance") == eps); + +%!error dassl_options ("foo", 1, 2) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/det.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,253 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "DET.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" +#include "ops.h" + +#include "ov-re-mat.h" +#include "ov-cx-mat.h" +#include "ov-flt-re-mat.h" +#include "ov-flt-cx-mat.h" +#include "ov-re-diag.h" +#include "ov-cx-diag.h" +#include "ov-flt-re-diag.h" +#include "ov-flt-cx-diag.h" +#include "ov-perm.h" + +#define MAYBE_CAST(VAR, CLASS) \ + const CLASS *VAR = arg.type_id () == CLASS::static_type_id () ? \ + dynamic_cast<const CLASS *> (&arg.get_rep ()) : 0 + +DEFUN (det, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} det (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{d}, @var{rcond}] =} det (@var{A})\n\ +Compute the determinant of @var{A}.\n\ +\n\ +Return an estimate of the reciprocal condition number if requested.\n\ +\n\ +Routines from @sc{lapack} are used for full matrices and code from\n\ +@sc{umfpack} is used for sparse matrices.\n\ +\n\ +The determinant should not be used to check a matrix for singularity.\n\ +For that, use any of the condition number functions: @code{cond},\n\ +@code{condest}, @code{rcond}.\n\ +@seealso{cond, condest, rcond}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin != 1) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + + octave_idx_type nr = arg.rows (); + octave_idx_type nc = arg.columns (); + + if (nr == 0 && nc == 0) + { + retval(0) = 1.0; + return retval; + } + + int arg_is_empty = empty_arg ("det", nr, nc); + if (arg_is_empty < 0) + return retval; + if (arg_is_empty > 0) + return octave_value (Matrix (1, 1, 1.0)); + + + if (nr != nc) + { + gripe_square_matrix_required ("det"); + return retval; + } + + bool isfloat = arg.is_single_type (); + + if (arg.is_diag_matrix ()) + { + if (arg.is_complex_type ()) + { + if (isfloat) + { + retval(0) = arg.float_complex_diag_matrix_value ().determinant ().value (); + if (nargout > 1) + retval(1) = arg.float_complex_diag_matrix_value ().rcond (); + } + else + { + retval(0) = arg.complex_diag_matrix_value ().determinant ().value (); + if (nargout > 1) + retval(1) = arg.complex_diag_matrix_value ().rcond (); + } + } + else + { + if (isfloat) + { + retval(0) = arg.float_diag_matrix_value ().determinant ().value (); + if (nargout > 1) + retval(1) = arg.float_diag_matrix_value ().rcond (); + } + else + { + retval(0) = arg.diag_matrix_value ().determinant ().value (); + if (nargout > 1) + retval(1) = arg.diag_matrix_value ().rcond (); + } + } + } + else if (arg.is_perm_matrix ()) + { + retval(0) = static_cast<double> (arg.perm_matrix_value ().determinant ()); + if (nargout > 1) + retval(1) = 1.0; + } + else if (arg.is_single_type ()) + { + if (arg.is_real_type ()) + { + octave_idx_type info; + float rcond = 0.0; + // Always compute rcond, so we can detect numerically + // singular matrices. + FloatMatrix m = arg.float_matrix_value (); + if (! error_state) + { + MAYBE_CAST (rep, octave_float_matrix); + MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); + FloatDET det = m.determinant (mtype, info, rcond); + retval(1) = rcond; + retval(0) = info == -1 ? static_cast<float>(0.0) : det.value (); + if (rep) rep->matrix_type (mtype); + } + } + else if (arg.is_complex_type ()) + { + octave_idx_type info; + float rcond = 0.0; + // Always compute rcond, so we can detect numerically + // singular matrices. + FloatComplexMatrix m = arg.float_complex_matrix_value (); + if (! error_state) + { + MAYBE_CAST (rep, octave_float_complex_matrix); + MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); + FloatComplexDET det = m.determinant (mtype, info, rcond); + retval(1) = rcond; + retval(0) = info == -1 ? FloatComplex (0.0) : det.value (); + if (rep) rep->matrix_type (mtype); + } + } + } + else + { + if (arg.is_real_type ()) + { + octave_idx_type info; + double rcond = 0.0; + // Always compute rcond, so we can detect numerically + // singular matrices. + if (arg.is_sparse_type ()) + { + SparseMatrix m = arg.sparse_matrix_value (); + if (! error_state) + { + DET det = m.determinant (info, rcond); + retval(1) = rcond; + retval(0) = info == -1 ? 0.0 : det.value (); + } + } + else + { + Matrix m = arg.matrix_value (); + if (! error_state) + { + MAYBE_CAST (rep, octave_matrix); + MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); + DET det = m.determinant (mtype, info, rcond); + retval(1) = rcond; + retval(0) = info == -1 ? 0.0 : det.value (); + if (rep) rep->matrix_type (mtype); + } + } + } + else if (arg.is_complex_type ()) + { + octave_idx_type info; + double rcond = 0.0; + // Always compute rcond, so we can detect numerically + // singular matrices. + if (arg.is_sparse_type ()) + { + SparseComplexMatrix m = arg.sparse_complex_matrix_value (); + if (! error_state) + { + ComplexDET det = m.determinant (info, rcond); + retval(1) = rcond; + retval(0) = info == -1 ? Complex (0.0) : det.value (); + } + } + else + { + ComplexMatrix m = arg.complex_matrix_value (); + if (! error_state) + { + MAYBE_CAST (rep, octave_complex_matrix); + MatrixType mtype = rep ? rep -> matrix_type () : MatrixType (); + ComplexDET det = m.determinant (mtype, info, rcond); + retval(1) = rcond; + retval(0) = info == -1 ? Complex (0.0) : det.value (); + if (rep) rep->matrix_type (mtype); + } + } + } + else + gripe_wrong_type_arg ("det", arg); + } + return retval; +} + +/* +%!assert (det ([1, 2; 3, 4]), -2, 10*eps) +%!assert (det (single ([1, 2; 3, 4])), single (-2), 10*eps ("single")) +%!error det () +%!error det (1, 2) +%!error <argument must be a square matrix> det ([1, 2; 3, 4; 5, 6]) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/dlmread.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,520 @@ +/* + +Copyright (C) 2008-2012 Jonathan Stickel +Copyright (C) 2010 Jaroslav Hajek + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Adapted from previous version of dlmread.occ as authored by Kai +// Habel, but core code has been completely re-written. + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <cctype> +#include <fstream> +#include <limits> + +#include "file-ops.h" +#include "lo-ieee.h" + +#include "defun.h" +#include "oct-stream.h" +#include "error.h" +#include "oct-obj.h" +#include "utils.h" + +static const octave_idx_type idx_max = std::numeric_limits<octave_idx_type>::max (); + +static bool +read_cell_spec (std::istream& is, octave_idx_type& row, octave_idx_type& col) +{ + bool stat = false; + + if (is.peek () == std::istream::traits_type::eof ()) + stat = true; + else + { + if (::isalpha (is.peek ())) + { + col = 0; + while (is && ::isalpha (is.peek ())) + { + char ch = is.get (); + col *= 26; + if (ch >= 'a') + col += ch - 'a' + 1; + else + col += ch - 'A' + 1; + } + col --; + + if (is) + { + is >> row; + row --; + if (is) + stat = true; + } + } + } + + return stat; +} + +static bool +parse_range_spec (const octave_value& range_spec, + octave_idx_type& rlo, octave_idx_type& clo, + octave_idx_type& rup, octave_idx_type& cup) +{ + bool stat = true; + + if (range_spec.is_string ()) + { + std::istringstream is (range_spec.string_value ()); + char ch = is.peek (); + + if (ch == '.' || ch == ':') + { + rlo = 0; + clo = 0; + ch = is.get (); + if (ch == '.') + { + ch = is.get (); + if (ch != '.') + stat = false; + } + } + else + { + stat = read_cell_spec (is, rlo, clo); + + if (stat) + { + ch = is.peek (); + + if (ch == '.' || ch == ':') + { + ch = is.get (); + if (ch == '.') + { + ch = is.get (); + if (!is || ch != '.') + stat = false; + } + + rup = idx_max - 1; + cup = idx_max - 1; + } + else + { + rup = rlo; + cup = clo; + if (!is || !is.eof ()) + stat = false; + } + } + } + + if (stat && is && !is.eof ()) + stat = read_cell_spec (is, rup, cup); + + if (!is || !is.eof ()) + stat = false; + } + else if (range_spec.is_real_matrix () && range_spec.numel () == 4) + { + ColumnVector range(range_spec.vector_value ()); + // double --> unsigned int + rlo = static_cast<octave_idx_type> (range(0)); + clo = static_cast<octave_idx_type> (range(1)); + rup = static_cast<octave_idx_type> (range(2)); + cup = static_cast<octave_idx_type> (range(3)); + } + else + stat = false; + + return stat; +} + +DEFUN (dlmread, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{data} =} dlmread (@var{file})\n\ +@deftypefnx {Built-in Function} {@var{data} =} dlmread (@var{file}, @var{sep})\n\ +@deftypefnx {Built-in Function} {@var{data} =} dlmread (@var{file}, @var{sep}, @var{r0}, @var{c0})\n\ +@deftypefnx {Built-in Function} {@var{data} =} dlmread (@var{file}, @var{sep}, @var{range})\n\ +@deftypefnx {Built-in Function} {@var{data} =} dlmread (@dots{}, \"emptyvalue\", @var{EMPTYVAL})\n\ +Read the matrix @var{data} from a text file. If not defined the separator\n\ +between fields is determined from the file itself. Otherwise the\n\ +separation character is defined by @var{sep}.\n\ +\n\ +Given two scalar arguments @var{r0} and @var{c0}, these define the starting\n\ +row and column of the data to be read. These values are indexed from zero,\n\ +such that the first row corresponds to an index of zero.\n\ +\n\ +The @var{range} parameter may be a 4-element vector containing the upper\n\ +left and lower right corner @code{[@var{R0},@var{C0},@var{R1},@var{C1}]}\n\ +where the lowest index value is zero. Alternatively, a spreadsheet style\n\ +range such as \"A2..Q15\" or \"T1:AA5\" can be used. The lowest alphabetical\n\ +index 'A' refers to the first column. The lowest row index is 1.\n\ +\n\ +@var{file} should be a file name or file id given by @code{fopen}. In the\n\ +latter case, the file is read until end of file is reached.\n\ +\n\ +The \"emptyvalue\" option may be used to specify the value used to fill empty\n\ +fields. The default is zero.\n\ +@seealso{csvread, textscan, textread, dlmwrite}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + double empty_value = 0.0; + + if (nargin > 2 && args(nargin-2).is_string () + && args(nargin-2).string_value () == "emptyvalue") + { + empty_value = args(nargin-1).double_value (); + if (error_state) + return retval; + nargin -= 2; + } + + if (nargin < 1 || nargin > 4) + { + print_usage (); + return retval; + } + + std::istream *input = 0; + std::ifstream input_file; + + if (args(0).is_string ()) + { + // File name. + std::string fname (args(0).string_value ()); + if (error_state) + return retval; + + std::string tname = file_ops::tilde_expand (fname); + + input_file.open (tname.c_str (), std::ios::in); + + if (! input_file) + { + error ("dlmread: unable to open file `%s'", fname.c_str ()); + return retval; + } + else + input = &input_file; + } + else if (args(0).is_scalar_type ()) + { + octave_stream is = octave_stream_list::lookup (args(0), "dlmread"); + + if (error_state) + return retval; + + input = is.input_stream (); + + if (! input) + { + error ("dlmread: stream FILE not open for input"); + return retval; + } + } + else + { + error ("dlmread: FILE argument must be a string or file id"); + return retval; + } + + // Set default separator. + std::string sep; + if (nargin > 1) + { + if (args(1).is_sq_string ()) + sep = do_string_escapes (args(1).string_value ()); + else + sep = args(1).string_value (); + + if (error_state) + return retval; + } + + // Take a subset if a range was given. + octave_idx_type r0 = 0, c0 = 0, r1 = idx_max-1, c1 = idx_max-1; + if (nargin > 2) + { + if (nargin == 3) + { + if (!parse_range_spec (args (2), r0, c0, r1, c1)) + error ("dlmread: error parsing RANGE"); + } + else if (nargin == 4) + { + r0 = args(2).idx_type_value (); + c0 = args(3).idx_type_value (); + + if (error_state) + return retval; + } + + if (r0 < 0 || c0 < 0) + error ("dlmread: left & top must be positive"); + } + + if (!error_state) + { + octave_idx_type i = 0, j = 0, r = 1, c = 1, rmax = 0, cmax = 0; + + Matrix rdata; + ComplexMatrix cdata; + + bool iscmplx = false; + bool sepflag = false; + + std::string line; + + // Skip the r0 leading lines as these might be a header. + for (octave_idx_type m = 0; m < r0; m++) + getline (*input, line); + r1 -= r0; + + std::istringstream tmp_stream; + + // Read in the data one field at a time, growing the data matrix + // as needed. + while (getline (*input, line)) + { + // Skip blank lines for compatibility. + if (line.find_first_not_of (" \t") == std::string::npos) + continue; + + // To be compatible with matlab, blank separator should + // correspond to whitespace as delimter. + if (!sep.length ()) + { + size_t n = line.find_first_of (",:; \t", + line.find_first_of ("0123456789")); + if (n == std::string::npos) + { + sep = " \t"; + sepflag = true; + } + else + { + char ch = line.at (n); + + switch (line.at (n)) + { + case ' ': + case '\t': + sepflag = true; + sep = " \t"; + break; + + default: + sep = ch; + break; + } + } + } + + if (cmax == 0) + { + // Try to estimate the number of columns. Skip leading + // whitespace. + size_t pos1 = line.find_first_not_of (" \t"); + do + { + size_t pos2 = line.find_first_of (sep, pos1); + + if (sepflag && pos2 != std::string::npos) + // Treat consecutive separators as one. + { + pos2 = line.find_first_not_of (sep, pos2); + if (pos2 != std::string::npos) + pos2 -= 1; + else + pos2 = line.length () - 1; + } + + cmax++; + + if (pos2 != std::string::npos) + pos1 = pos2 + 1; + else + pos1 = std::string::npos; + + } + while (pos1 != std::string::npos); + + if (iscmplx) + cdata.resize (rmax, cmax); + else + rdata.resize (rmax, cmax); + } + + r = (r > i + 1 ? r : i + 1); + j = 0; + // Skip leading whitespace. + size_t pos1 = line.find_first_not_of (" \t"); + do + { + octave_quit (); + + size_t pos2 = line.find_first_of (sep, pos1); + std::string str = line.substr (pos1, pos2 - pos1); + + if (sepflag && pos2 != std::string::npos) + // Treat consecutive separators as one. + pos2 = line.find_first_not_of (sep, pos2) - 1; + + c = (c > j + 1 ? c : j + 1); + if (r > rmax || c > cmax) + { + // Use resize_and_fill for the case of not-equal + // length rows. + rmax = 2*r; + cmax = c; + if (iscmplx) + cdata.resize (rmax, cmax); + else + rdata.resize (rmax, cmax); + } + + tmp_stream.str (str); + tmp_stream.clear (); + + double x = octave_read_double (tmp_stream); + if (tmp_stream) + { + if (tmp_stream.eof ()) + { + if (iscmplx) + cdata(i,j++) = x; + else + rdata(i,j++) = x; + } + else if (std::toupper (tmp_stream.peek ()) == 'I') + { + // This is to allow pure imaginary numbers. + if (iscmplx) + cdata(i,j++) = x; + else + rdata(i,j++) = x; + } + else + { + double y = octave_read_double (tmp_stream); + + if (!iscmplx && y != 0.) + { + iscmplx = true; + cdata = ComplexMatrix (rdata); + } + + if (iscmplx) + cdata(i,j++) = Complex (x, y); + else + rdata(i,j++) = x; + } + } + else if (iscmplx) + cdata(i,j++) = empty_value; + else + rdata(i,j++) = empty_value; + + if (pos2 != std::string::npos) + pos1 = pos2 + 1; + else + pos1 = std::string::npos; + + } + while (pos1 != std::string::npos); + + if (i == r1) + break; + + i++; + } + + if (r1 >= r) + r1 = r - 1; + if (c1 >= c) + c1 = c - 1; + + // Now take the subset of the matrix. + if (iscmplx) + cdata = cdata.extract (0, c0, r1, c1); + else + rdata = rdata.extract (0, c0, r1, c1); + + if (iscmplx) + retval(0) = cdata; + else + retval(0) = rdata; + } + + return retval; +} + +/* +%!shared file +%! file = tmpnam (); +%! fid = fopen (file, "wt"); +%! fwrite (fid, "1, 2, 3\n4, 5, 6\n7, 8, 9\n10, 11, 12"); +%! fclose (fid); + +%!assert (dlmread (file), [1, 2, 3; 4, 5, 6; 7, 8, 9;10, 11, 12]) +%!assert (dlmread (file, ","), [1, 2, 3; 4, 5, 6; 7, 8, 9; 10, 11, 12]) +%!assert (dlmread (file, ",", [1, 0, 2, 1]), [4, 5; 7, 8]) +%!assert (dlmread (file, ",", "B1..C2"), [2, 3; 5, 6]) +%!assert (dlmread (file, ",", "B1:C2"), [2, 3; 5, 6]) +%!assert (dlmread (file, ",", "..C2"), [1, 2, 3; 4, 5, 6]) +%!assert (dlmread (file, ",", 0, 1), [2, 3; 5, 6; 8, 9; 11, 12]) +%!assert (dlmread (file, ",", "B1.."), [2, 3; 5, 6; 8, 9; 11, 12]) +%!error (dlmread (file, ",", [0 1])) + +%!test +%! unlink (file); + +%!shared file +%! file = tmpnam (); +%! fid = fopen (file, "wt"); +%! fwrite (fid, "1, 2, 3\n4+4i, 5, 6\n7, 8, 9\n10, 11, 12"); +%! fclose (fid); + +%!assert (dlmread (file), [1, 2, 3; 4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) +%!assert (dlmread (file, ","), [1, 2, 3; 4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) +%!assert (dlmread (file, ",", [1, 0, 2, 1]), [4 + 4i, 5; 7, 8]) +%!assert (dlmread (file, ",", "A2..B3"), [4 + 4i, 5; 7, 8]) +%!assert (dlmread (file, ",", "A2:B3"), [4 + 4i, 5; 7, 8]) +%!assert (dlmread (file, ",", "..B3"), [1, 2; 4 + 4i, 5; 7, 8]) +%!assert (dlmread (file, ",", 1, 0), [4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) +%!assert (dlmread (file, ",", "A2.."), [4 + 4i, 5, 6; 7, 8, 9; 10, 11, 12]) +%!error (dlmread (file, ",", [0 1])) + +%!test +%! unlink (file); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/dot.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,364 @@ +/* + +Copyright (C) 2009-2012 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "f77-fcn.h" +#include "mx-base.h" +#include "error.h" +#include "defun.h" +#include "parse.h" + +extern "C" +{ + F77_RET_T + F77_FUNC (ddot3, DDOT3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const double*, + const double*, double*); + + F77_RET_T + F77_FUNC (sdot3, SDOT3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const float*, + const float*, float*); + + F77_RET_T + F77_FUNC (zdotc3, ZDOTC3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const Complex*, + const Complex*, Complex*); + + F77_RET_T + F77_FUNC (cdotc3, CDOTC3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const FloatComplex*, + const FloatComplex*, FloatComplex*); + + F77_RET_T + F77_FUNC (dmatm3, DMATM3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const octave_idx_type&, + const double*, const double*, double*); + + F77_RET_T + F77_FUNC (smatm3, SMATM3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const octave_idx_type&, + const float*, const float*, float*); + + F77_RET_T + F77_FUNC (zmatm3, ZMATM3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const octave_idx_type&, + const Complex*, const Complex*, Complex*); + + F77_RET_T + F77_FUNC (cmatm3, CMATM3) (const octave_idx_type&, const octave_idx_type&, + const octave_idx_type&, const octave_idx_type&, + const FloatComplex*, const FloatComplex*, + FloatComplex*); +} + +static void +get_red_dims (const dim_vector& x, const dim_vector& y, int dim, + dim_vector& z, octave_idx_type& m, octave_idx_type& n, + octave_idx_type& k) +{ + int nd = x.length (); + assert (nd == y.length ()); + z = dim_vector::alloc (nd); + m = 1, n = 1, k = 1; + for (int i = 0; i < nd; i++) + { + if (i < dim) + { + z(i) = x(i); + m *= x(i); + } + else if (i > dim) + { + z(i) = x(i); + n *= x(i); + } + else + { + k = x(i); + z(i) = 1; + } + } +} + +DEFUN (dot, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} dot (@var{x}, @var{y}, @var{dim})\n\ +Compute the dot product of two vectors. If @var{x} and @var{y}\n\ +are matrices, calculate the dot products along the first\n\ +non-singleton dimension. If the optional argument @var{dim} is\n\ +given, calculate the dot products along this dimension.\n\ +\n\ +This is equivalent to\n\ +@code{sum (conj (@var{X}) .* @var{Y}, @var{dim})},\n\ +but avoids forming a temporary array and is faster. When @var{X} and\n\ +@var{Y} are column vectors, the result is equivalent to\n\ +@code{@var{X}' * @var{Y}}.\n\ +@seealso{cross, divergence}\n\ +@end deftypefn") +{ + octave_value retval; + int nargin = args.length (); + + if (nargin < 2 || nargin > 3) + { + print_usage (); + return retval; + } + + octave_value argx = args(0), argy = args(1); + + if (argx.is_numeric_type () && argy.is_numeric_type ()) + { + dim_vector dimx = argx.dims (), dimy = argy.dims (); + bool match = dimx == dimy; + if (! match && nargin == 2 + && dimx.is_vector () && dimy.is_vector ()) + { + // Change to column vectors. + dimx = dimx.redim (1); + argx = argx.reshape (dimx); + dimy = dimy.redim (1); + argy = argy.reshape (dimy); + match = ! error_state; + } + + if (match) + { + int dim; + if (nargin == 2) + dim = dimx.first_non_singleton (); + else + dim = args(2).int_value (true) - 1; + + if (error_state) + ; + else if (dim < 0) + error ("dot: DIM must be a valid dimension"); + else + { + octave_idx_type m, n, k; + dim_vector dimz; + if (argx.is_complex_type () || argy.is_complex_type ()) + { + if (argx.is_single_type () || argy.is_single_type ()) + { + FloatComplexNDArray x = argx.float_complex_array_value (); + FloatComplexNDArray y = argy.float_complex_array_value (); + get_red_dims (dimx, dimy, dim, dimz, m, n, k); + FloatComplexNDArray z(dimz); + if (! error_state) + F77_XFCN (cdotc3, CDOTC3, (m, n, k, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + else + { + ComplexNDArray x = argx.complex_array_value (); + ComplexNDArray y = argy.complex_array_value (); + get_red_dims (dimx, dimy, dim, dimz, m, n, k); + ComplexNDArray z(dimz); + if (! error_state) + F77_XFCN (zdotc3, ZDOTC3, (m, n, k, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + } + else if (argx.is_float_type () && argy.is_float_type ()) + { + if (argx.is_single_type () || argy.is_single_type ()) + { + FloatNDArray x = argx.float_array_value (); + FloatNDArray y = argy.float_array_value (); + get_red_dims (dimx, dimy, dim, dimz, m, n, k); + FloatNDArray z(dimz); + if (! error_state) + F77_XFCN (sdot3, SDOT3, (m, n, k, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + else + { + NDArray x = argx.array_value (); + NDArray y = argy.array_value (); + get_red_dims (dimx, dimy, dim, dimz, m, n, k); + NDArray z(dimz); + if (! error_state) + F77_XFCN (ddot3, DDOT3, (m, n, k, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + } + else + { + // Non-optimized evaluation. + octave_value_list tmp; + tmp(1) = args(2); + tmp(0) = do_binary_op (octave_value::op_el_mul, argx, argy); + if (! error_state) + { + tmp = feval ("sum", tmp, 1); + if (! tmp.empty ()) + retval = tmp(0); + } + } + } + } + else + error ("dot: sizes of X and Y must match"); + + } + else + error ("dot: X and Y must be numeric"); + + return retval; +} + +/* +%!assert (dot ([1, 2], [2, 3]), 8) + +%!test +%! x = [2, 1; 2, 1]; +%! y = [-0.5, 2; 0.5, -2]; +%! assert (dot (x, y), [0 0]); + +%!test +%! x = [1+i, 3-i; 1-i, 3-i]; +%! assert (dot (x, x), [4, 20]); +*/ + +DEFUN (blkmm, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} blkmm (@var{A}, @var{B})\n\ +Compute products of matrix blocks. The blocks are given as\n\ +2-dimensional subarrays of the arrays @var{A}, @var{B}.\n\ +The size of @var{A} must have the form @code{[m,k,@dots{}]} and\n\ +size of @var{B} must be @code{[k,n,@dots{}]}. The result is\n\ +then of size @code{[m,n,@dots{}]} and is computed as follows:\n\ +\n\ +@example\n\ +@group\n\ +for i = 1:prod (size (@var{A})(3:end))\n\ + @var{C}(:,:,i) = @var{A}(:,:,i) * @var{B}(:,:,i)\n\ +endfor\n\ +@end group\n\ +@end example\n\ +@end deftypefn") +{ + octave_value retval; + int nargin = args.length (); + + if (nargin != 2) + { + print_usage (); + return retval; + } + + octave_value argx = args(0), argy = args(1); + + if (argx.is_numeric_type () && argy.is_numeric_type ()) + { + const dim_vector dimx = argx.dims (), dimy = argy.dims (); + int nd = dimx.length (); + octave_idx_type m = dimx(0), k = dimx(1), n = dimy(1), np = 1; + bool match = dimy(0) == k && nd == dimy.length (); + dim_vector dimz = dim_vector::alloc (nd); + dimz(0) = m; + dimz(1) = n; + for (int i = 2; match && i < nd; i++) + { + match = match && dimx(i) == dimy(i); + dimz(i) = dimx(i); + np *= dimz(i); + } + + if (match) + { + if (argx.is_complex_type () || argy.is_complex_type ()) + { + if (argx.is_single_type () || argy.is_single_type ()) + { + FloatComplexNDArray x = argx.float_complex_array_value (); + FloatComplexNDArray y = argy.float_complex_array_value (); + FloatComplexNDArray z(dimz); + if (! error_state) + F77_XFCN (cmatm3, CMATM3, (m, n, k, np, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + else + { + ComplexNDArray x = argx.complex_array_value (); + ComplexNDArray y = argy.complex_array_value (); + ComplexNDArray z(dimz); + if (! error_state) + F77_XFCN (zmatm3, ZMATM3, (m, n, k, np, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + } + else + { + if (argx.is_single_type () || argy.is_single_type ()) + { + FloatNDArray x = argx.float_array_value (); + FloatNDArray y = argy.float_array_value (); + FloatNDArray z(dimz); + if (! error_state) + F77_XFCN (smatm3, SMATM3, (m, n, k, np, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + else + { + NDArray x = argx.array_value (); + NDArray y = argy.array_value (); + NDArray z(dimz); + if (! error_state) + F77_XFCN (dmatm3, DMATM3, (m, n, k, np, x.data (), y.data (), + z.fortran_vec ())); + retval = z; + } + } + } + else + error ("blkmm: A and B dimensions don't match: (%s) and (%s)", + dimx.str ().c_str (), dimy.str ().c_str ()); + + } + else + error ("blkmm: A and B must be numeric"); + + return retval; +} + +/* +%!test +%! x(:,:,1) = [1 2; 3 4]; +%! x(:,:,2) = [1 1; 1 1]; +%! z(:,:,1) = [7 10; 15 22]; +%! z(:,:,2) = [2 2; 2 2]; +%! assert (blkmm (x,x), z); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/eig.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,334 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "EIG.h" +#include "fEIG.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (eig, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{lambda} =} eig (@var{A})\n\ +@deftypefnx {Built-in Function} {@var{lambda} =} eig (@var{A}, @var{B})\n\ +@deftypefnx {Built-in Function} {[@var{V}, @var{lambda}] =} eig (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{V}, @var{lambda}] =} eig (@var{A}, @var{B})\n\ +Compute the eigenvalues (and optionally the eigenvectors) of a matrix\n\ +or a pair of matrices\n\ +\n\ +The algorithm used depends on whether there are one or two input\n\ +matrices, if they are real or complex and if they are symmetric\n\ +(Hermitian if complex) or non-symmetric.\n\ +\n\ +The eigenvalues returned by @code{eig} are not ordered.\n\ +@seealso{eigs, svd}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin > 2 || nargin == 0 || nargout > 2) + { + print_usage (); + return retval; + } + + octave_value arg_a, arg_b; + + octave_idx_type nr_a = 0, nr_b = 0; + octave_idx_type nc_a = 0, nc_b = 0; + + arg_a = args(0); + nr_a = arg_a.rows (); + nc_a = arg_a.columns (); + + int arg_is_empty = empty_arg ("eig", nr_a, nc_a); + if (arg_is_empty < 0) + return retval; + else if (arg_is_empty > 0) + return octave_value_list (2, Matrix ()); + + if (!(arg_a.is_single_type () || arg_a.is_double_type ())) + { + gripe_wrong_type_arg ("eig", arg_a); + return retval; + } + + if (nargin == 2) + { + arg_b = args(1); + nr_b = arg_b.rows (); + nc_b = arg_b.columns (); + + arg_is_empty = empty_arg ("eig", nr_b, nc_b); + if (arg_is_empty < 0) + return retval; + else if (arg_is_empty > 0) + return octave_value_list (2, Matrix ()); + + if (!(arg_b.is_single_type () || arg_b.is_double_type ())) + { + gripe_wrong_type_arg ("eig", arg_b); + return retval; + } + } + + if (nr_a != nc_a) + { + gripe_square_matrix_required ("eig"); + return retval; + } + + if (nargin == 2 && nr_b != nc_b) + { + gripe_square_matrix_required ("eig"); + return retval; + } + + Matrix tmp_a, tmp_b; + ComplexMatrix ctmp_a, ctmp_b; + FloatMatrix ftmp_a, ftmp_b; + FloatComplexMatrix fctmp_a, fctmp_b; + + if (arg_a.is_single_type ()) + { + FloatEIG result; + + if (nargin == 1) + { + if (arg_a.is_real_type ()) + { + ftmp_a = arg_a.float_matrix_value (); + + if (error_state) + return retval; + else + result = FloatEIG (ftmp_a, nargout > 1); + } + else + { + fctmp_a = arg_a.float_complex_matrix_value (); + + if (error_state) + return retval; + else + result = FloatEIG (fctmp_a, nargout > 1); + } + } + else if (nargin == 2) + { + if (arg_a.is_real_type () && arg_b.is_real_type ()) + { + ftmp_a = arg_a.float_matrix_value (); + ftmp_b = arg_b.float_matrix_value (); + + if (error_state) + return retval; + else + result = FloatEIG (ftmp_a, ftmp_b, nargout > 1); + } + else + { + fctmp_a = arg_a.float_complex_matrix_value (); + fctmp_b = arg_b.float_complex_matrix_value (); + + if (error_state) + return retval; + else + result = FloatEIG (fctmp_a, fctmp_b, nargout > 1); + } + } + + if (! error_state) + { + if (nargout == 0 || nargout == 1) + { + retval(0) = result.eigenvalues (); + } + else + { + // Blame it on Matlab. + + FloatComplexDiagMatrix d (result.eigenvalues ()); + + retval(1) = d; + retval(0) = result.eigenvectors (); + } + } + } + else + { + EIG result; + + if (nargin == 1) + { + if (arg_a.is_real_type ()) + { + tmp_a = arg_a.matrix_value (); + + if (error_state) + return retval; + else + result = EIG (tmp_a, nargout > 1); + } + else + { + ctmp_a = arg_a.complex_matrix_value (); + + if (error_state) + return retval; + else + result = EIG (ctmp_a, nargout > 1); + } + } + else if (nargin == 2) + { + if (arg_a.is_real_type () && arg_b.is_real_type ()) + { + tmp_a = arg_a.matrix_value (); + tmp_b = arg_b.matrix_value (); + + if (error_state) + return retval; + else + result = EIG (tmp_a, tmp_b, nargout > 1); + } + else + { + ctmp_a = arg_a.complex_matrix_value (); + ctmp_b = arg_b.complex_matrix_value (); + + if (error_state) + return retval; + else + result = EIG (ctmp_a, ctmp_b, nargout > 1); + } + } + + if (! error_state) + { + if (nargout == 0 || nargout == 1) + { + retval(0) = result.eigenvalues (); + } + else + { + // Blame it on Matlab. + + ComplexDiagMatrix d (result.eigenvalues ()); + + retval(1) = d; + retval(0) = result.eigenvectors (); + } + } + } + + return retval; +} + +/* +%!assert (eig ([1, 2; 2, 1]), [-1; 3], sqrt (eps)) + +%!test +%! [v, d] = eig ([1, 2; 2, 1]); +%! x = 1 / sqrt (2); +%! assert (d, [-1, 0; 0, 3], sqrt (eps)); +%! assert (v, [-x, x; x, x], sqrt (eps)); + +%!assert (eig (single ([1, 2; 2, 1])), single ([-1; 3]), sqrt (eps ("single"))) + +%!test +%! [v, d] = eig (single ([1, 2; 2, 1])); +%! x = single (1 / sqrt (2)); +%! assert (d, single ([-1, 0; 0, 3]), sqrt (eps ("single"))); +%! assert (v, [-x, x; x, x], sqrt (eps ("single"))); + +%!test +%! A = [1, 2; -1, 1]; B = [3, 3; 1, 2]; +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); + +%!test +%! A = single ([1, 2; -1, 1]); B = single ([3, 3; 1, 2]); +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); + +%!test +%! A = [1, 2; 2, 1]; B = [3, -2; -2, 3]; +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); + +%!test +%! A = single ([1, 2; 2, 1]); B = single ([3, -2; -2, 3]); +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); + +%!test +%! A = [1+3i, 2+i; 2-i, 1+3i]; B = [5+9i, 2+i; 2-i, 5+9i]; +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); + +%!test +%! A = single ([1+3i, 2+i; 2-i, 1+3i]); B = single ([5+9i, 2+i; 2-i, 5+9i]); +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); + +%!test +%! A = [1+3i, 2+3i; 3-8i, 8+3i]; B = [8+i, 3+i; 4-9i, 3+i]; +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); + +%!test +%! A = single ([1+3i, 2+3i; 3-8i, 8+3i]); B = single ([8+i, 3+i; 4-9i, 3+i]); +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps ("single"))); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps ("single"))); + +%!test +%! A = [1, 2; 3, 8]; B = [8, 3; 4, 3]; +%! [v, d] = eig (A, B); +%! assert (A * v(:, 1), d(1, 1) * B * v(:, 1), sqrt (eps)); +%! assert (A * v(:, 2), d(2, 2) * B * v(:, 2), sqrt (eps)); + +%!error eig () +%!error eig ([1, 2; 3, 4], [4, 3; 2, 1], 1) +%!error <EIG requires same size matrices> eig ([1, 2; 3, 4], 2) +%!error <argument must be a square matrix> eig ([1, 2; 3, 4; 5, 6]) +%!error <wrong type argument> eig ("abcd") +%!error <wrong type argument> eig ([1 2 ; 2 3], "abcd") +%!error <wrong type argument> eig (false, [1 2 ; 2 3]) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/fft.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,319 @@ +/* + +Copyright (C) 1997-2012 David Bateman +Copyright (C) 1996-1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-mappers.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +#if defined (HAVE_FFTW) +#define FFTSRC "@sc{fftw}" +#else +#define FFTSRC "@sc{fftpack}" +#endif + +static octave_value +do_fft (const octave_value_list &args, const char *fcn, int type) +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 3) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + dim_vector dims = arg.dims (); + octave_idx_type n_points = -1; + int dim = -1; + + if (nargin > 1) + { + if (! args(1).is_empty ()) + { + double dval = args(1).double_value (); + if (xisnan (dval)) + error ("%s: number of points (N) cannot be NaN", fcn); + else + { + n_points = NINTbig (dval); + if (n_points < 0) + error ("%s: number of points (N) must be greater than zero", fcn); + } + } + } + + if (error_state) + return retval; + + if (nargin > 2) + { + double dval = args(2).double_value (); + if (xisnan (dval)) + error ("%s: DIM cannot be NaN", fcn); + else if (dval < 1 || dval > dims.length ()) + error ("%s: DIM must be a valid dimension along which to perform FFT", fcn); + else + // to be safe, cast it back to int since dim is an int + dim = NINT (dval) - 1; + } + + if (error_state) + return retval; + + for (octave_idx_type i = 0; i < dims.length (); i++) + if (dims(i) < 0) + return retval; + + if (dim < 0) + { + for (octave_idx_type i = 0; i < dims.length (); i++) + if (dims(i) > 1) + { + dim = i; + break; + } + + // And if the first argument is scalar? + if (dim < 0) + dim = 1; + } + + if (n_points < 0) + n_points = dims (dim); + else + dims (dim) = n_points; + + if (dims.any_zero () || n_points == 0) + { + if (arg.is_single_type ()) + return octave_value (FloatNDArray (dims)); + else + return octave_value (NDArray (dims)); + } + + if (arg.is_single_type ()) + { + if (arg.is_real_type ()) + { + FloatNDArray nda = arg.float_array_value (); + + if (! error_state) + { + nda.resize (dims, 0.0); + retval = (type != 0 ? nda.ifourier (dim) : nda.fourier (dim)); + } + } + else + { + FloatComplexNDArray cnda = arg.float_complex_array_value (); + + if (! error_state) + { + cnda.resize (dims, 0.0); + retval = (type != 0 ? cnda.ifourier (dim) : cnda.fourier (dim)); + } + } + } + else + { + if (arg.is_real_type ()) + { + NDArray nda = arg.array_value (); + + if (! error_state) + { + nda.resize (dims, 0.0); + retval = (type != 0 ? nda.ifourier (dim) : nda.fourier (dim)); + } + } + else if (arg.is_complex_type ()) + { + ComplexNDArray cnda = arg.complex_array_value (); + + if (! error_state) + { + cnda.resize (dims, 0.0); + retval = (type != 0 ? cnda.ifourier (dim) : cnda.fourier (dim)); + } + } + else + { + gripe_wrong_type_arg (fcn, arg); + } + } + + return retval; +} + +/* +%!assert (fft ([]), []) +%!assert (fft (zeros (10,0)), zeros (10,0)) +%!assert (fft (zeros (0,10)), zeros (0,10)) +%!assert (fft (0), 0) +%!assert (fft (1), 1) +%!assert (fft (ones (2,2)), [2,2; 0,0]) +%!assert (fft (eye (2,2)), [1,1; 1,-1]) + +%!assert (fft (single ([])), single ([])) +%!assert (fft (zeros (10,0,"single")), zeros (10,0,"single")) +%!assert (fft (zeros (0,10,"single")), zeros (0,10,"single")) +%!assert (fft (single (0)), single (0)) +%!assert (fft (single (1)), single (1)) +%!assert (fft (ones (2,2,"single")), single ([2,2; 0,0])) +%!assert (fft (eye (2,2,"single")), single ([1,1; 1,-1])) + +%!error (fft ()) +*/ + + +DEFUN (fft, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} fft (@var{x})\n\ +@deftypefnx {Built-in Function} {} fft (@var{x}, @var{n})\n\ +@deftypefnx {Built-in Function} {} fft (@var{x}, @var{n}, @var{dim})\n\ +Compute the discrete Fourier transform of @var{A} using\n\ +a Fast Fourier Transform (FFT) algorithm.\n\ +\n\ +The FFT is calculated along the first non-singleton dimension of the\n\ +array. Thus if @var{x} is a matrix, @code{fft (@var{x})} computes the\n\ +FFT for each column of @var{x}.\n\ +\n\ +If called with two arguments, @var{n} is expected to be an integer\n\ +specifying the number of elements of @var{x} to use, or an empty\n\ +matrix to specify that its value should be ignored. If @var{n} is\n\ +larger than the dimension along which the FFT is calculated, then\n\ +@var{x} is resized and padded with zeros. Otherwise, if @var{n} is\n\ +smaller than the dimension along which the FFT is calculated, then\n\ +@var{x} is truncated.\n\ +\n\ +If called with three arguments, @var{dim} is an integer specifying the\n\ +dimension of the matrix along which the FFT is performed\n\ +@seealso{ifft, fft2, fftn, fftw}\n\ +@end deftypefn") +{ + return do_fft (args, "fft", 0); +} + + +DEFUN (ifft, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} ifft (@var{x})\n\ +@deftypefnx {Built-in Function} {} ifft (@var{x}, @var{n})\n\ +@deftypefnx {Built-in Function} {} ifft (@var{x}, @var{n}, @var{dim})\n\ +Compute the inverse discrete Fourier transform of @var{A}\n\ +using a Fast Fourier Transform (FFT) algorithm.\n\ +\n\ +The inverse FFT is calculated along the first non-singleton dimension\n\ +of the array. Thus if @var{x} is a matrix, @code{fft (@var{x})} computes\n\ +the inverse FFT for each column of @var{x}.\n\ +\n\ +If called with two arguments, @var{n} is expected to be an integer\n\ +specifying the number of elements of @var{x} to use, or an empty\n\ +matrix to specify that its value should be ignored. If @var{n} is\n\ +larger than the dimension along which the inverse FFT is calculated, then\n\ +@var{x} is resized and padded with zeros. Otherwise, if @var{n} is\n\ +smaller than the dimension along which the inverse FFT is calculated,\n\ +then @var{x} is truncated.\n\ +\n\ +If called with three arguments, @var{dim} is an integer specifying the\n\ +dimension of the matrix along which the inverse FFT is performed\n\ +@seealso{fft, ifft2, ifftn, fftw}\n\ +@end deftypefn") +{ + return do_fft (args, "ifft", 1); +} + +/* +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! N = 64; +%! n = 4; +%! t = 2*pi*(0:1:N-1)/N; +%! s = cos (n*t); +%! S = fft (s); +%! +%! answer = zeros (size (t)); +%! answer(n+1) = N/2; +%! answer(N-n+1) = N/2; +%! +%! assert (S, answer, 4*N*eps); + +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! N = 64; +%! n = 7; +%! t = 2*pi*(0:1:N-1)/N; +%! s = cos (n*t); +%! +%! S = zeros (size (t)); +%! S(n+1) = N/2; +%! S(N-n+1) = N/2; +%! +%! assert (ifft (S), s, 4*N*eps); + +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! N = 64; +%! n = 4; +%! t = single (2*pi*(0:1:N-1)/N); +%! s = cos (n*t); +%! S = fft (s); +%! +%! answer = zeros (size (t), "single"); +%! answer(n+1) = N/2; +%! answer(N-n+1) = N/2; +%! +%! assert (S, answer, 4*N*eps ("single")); + +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! N = 64; +%! n = 7; +%! t = 2*pi*(0:1:N-1)/N; +%! s = cos (n*t); +%! +%! S = zeros (size (t), "single"); +%! S(n+1) = N/2; +%! S(N-n+1) = N/2; +%! +%! assert (ifft (S), s, 4*N*eps ("single")); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/fft2.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,294 @@ +/* + +Copyright (C) 1997-2012 David Bateman +Copyright (C) 1996-1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-mappers.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +// This function should be merged with Fifft. + +#if defined (HAVE_FFTW) +#define FFTSRC "@sc{fftw}" +#else +#define FFTSRC "@sc{fftpack}" +#endif + +static octave_value +do_fft2 (const octave_value_list &args, const char *fcn, int type) +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 3) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + dim_vector dims = arg.dims (); + octave_idx_type n_rows = -1; + + if (nargin > 1) + { + double dval = args(1).double_value (); + if (xisnan (dval)) + error ("%s: number of rows (N) cannot be NaN", fcn); + else + { + n_rows = NINTbig (dval); + if (n_rows < 0) + error ("%s: number of rows (N) must be greater than zero", fcn); + } + } + + if (error_state) + return retval; + + octave_idx_type n_cols = -1; + if (nargin > 2) + { + double dval = args(2).double_value (); + if (xisnan (dval)) + error ("%s: number of columns (M) cannot be NaN", fcn); + else + { + n_cols = NINTbig (dval); + if (n_cols < 0) + error ("%s: number of columns (M) must be greater than zero", fcn); + } + } + + if (error_state) + return retval; + + for (int i = 0; i < dims.length (); i++) + if (dims(i) < 0) + return retval; + + if (n_rows < 0) + n_rows = dims (0); + else + dims (0) = n_rows; + + if (n_cols < 0) + n_cols = dims (1); + else + dims (1) = n_cols; + + if (dims.all_zero () || n_rows == 0 || n_cols == 0) + { + if (arg.is_single_type ()) + return octave_value (FloatMatrix ()); + else + return octave_value (Matrix ()); + } + + if (arg.is_single_type ()) + { + if (arg.is_real_type ()) + { + FloatNDArray nda = arg.float_array_value (); + + if (! error_state) + { + nda.resize (dims, 0.0); + retval = (type != 0 ? nda.ifourier2d () : nda.fourier2d ()); + } + } + else + { + FloatComplexNDArray cnda = arg.float_complex_array_value (); + + if (! error_state) + { + cnda.resize (dims, 0.0); + retval = (type != 0 ? cnda.ifourier2d () : cnda.fourier2d ()); + } + } + } + else + { + if (arg.is_real_type ()) + { + NDArray nda = arg.array_value (); + + if (! error_state) + { + nda.resize (dims, 0.0); + retval = (type != 0 ? nda.ifourier2d () : nda.fourier2d ()); + } + } + else if (arg.is_complex_type ()) + { + ComplexNDArray cnda = arg.complex_array_value (); + + if (! error_state) + { + cnda.resize (dims, 0.0); + retval = (type != 0 ? cnda.ifourier2d () : cnda.fourier2d ()); + } + } + else + { + gripe_wrong_type_arg (fcn, arg); + } + } + + return retval; +} + +DEFUN (fft2, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} fft2 (@var{A})\n\ +@deftypefnx {Built-in Function} {} fft2 (@var{A}, @var{m}, @var{n})\n\ +Compute the two-dimensional discrete Fourier transform of @var{A} using\n\ +a Fast Fourier Transform (FFT) algorithm.\n\ +\n\ +The optional arguments @var{m} and @var{n} may be used specify the\n\ +number of rows and columns of @var{A} to use. If either of these is\n\ +larger than the size of @var{A}, @var{A} is resized and padded with\n\ +zeros.\n\ +\n\ +If @var{A} is a multi-dimensional matrix, each two-dimensional sub-matrix\n\ +of @var{A} is treated separately.\n\ +@seealso {ifft2, fft, fftn, fftw}\n\ +@end deftypefn") +{ + return do_fft2 (args, "fft2", 0); +} + + +DEFUN (ifft2, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} ifft2 (@var{A})\n\ +@deftypefnx {Built-in Function} {} ifft2 (@var{A}, @var{m}, @var{n})\n\ +Compute the inverse two-dimensional discrete Fourier transform of @var{A}\n\ +using a Fast Fourier Transform (FFT) algorithm.\n\ +\n\ +The optional arguments @var{m} and @var{n} may be used specify the\n\ +number of rows and columns of @var{A} to use. If either of these is\n\ +larger than the size of @var{A}, @var{A} is resized and padded with\n\ +zeros.\n\ +\n\ +If @var{A} is a multi-dimensional matrix, each two-dimensional sub-matrix\n\ +of @var{A} is treated separately\n\ +@seealso {fft2, ifft, ifftn, fftw}\n\ +@end deftypefn") +{ + return do_fft2 (args, "ifft2", 1); +} + +/* +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! M = 16; +%! N = 8; +%! +%! m = 5; +%! n = 3; +%! +%! x = 2*pi*(0:1:M-1)/M; +%! y = 2*pi*(0:1:N-1)/N; +%! sx = cos (m*x); +%! sy = sin (n*y); +%! s = kron (sx',sy); +%! S = fft2 (s); +%! answer = kron (fft (sx)', fft (sy)); +%! assert (S, answer, 4*M*N*eps); + +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! M = 12; +%! N = 7; +%! +%! m = 3; +%! n = 2; +%! +%! x = 2*pi*(0:1:M-1)/M; +%! y = 2*pi*(0:1:N-1)/N; +%! +%! sx = cos (m*x); +%! sy = cos (n*y); +%! +%! S = kron (fft (sx)', fft (sy)); +%! answer = kron (sx', sy); +%! s = ifft2 (S); +%! +%! assert (s, answer, 30*eps); + + +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! M = 16; +%! N = 8; +%! +%! m = 5; +%! n = 3; +%! +%! x = 2*pi*(0:1:M-1)/M; +%! y = 2*pi*(0:1:N-1)/N; +%! sx = single (cos (m*x)); +%! sy = single (sin (n*y)); +%! s = kron (sx', sy); +%! S = fft2 (s); +%! answer = kron (fft (sx)', fft (sy)); +%! assert (S, answer, 4*M*N*eps ("single")); + +%% Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +%% Comalco Research and Technology +%% 02 May 2000 +%!test +%! M = 12; +%! N = 7; +%! +%! m = 3; +%! n = 2; +%! +%! x = single (2*pi*(0:1:M-1)/M); +%! y = single (2*pi*(0:1:N-1)/N); +%! +%! sx = cos (m*x); +%! sy = cos (n*y); +%! +%! S = kron (fft (sx)', fft (sy)); +%! answer = kron (sx', sy); +%! s = ifft2 (S); +%! +%! assert (s, answer, 30*eps ("single")); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/fftn.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,188 @@ +/* + +Copyright (C) 2004-2012 David Bateman + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-mappers.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +// This function should be merged with Fifft. + +#if defined (HAVE_FFTW) +#define FFTSRC "@sc{fftw}" +#else +#define FFTSRC "@sc{fftpack}" +#endif + +static octave_value +do_fftn (const octave_value_list &args, const char *fcn, int type) +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 2) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + dim_vector dims = arg.dims (); + + for (int i = 0; i < dims.length (); i++) + if (dims(i) < 0) + return retval; + + if (nargin > 1) + { + Matrix val = args(1).matrix_value (); + if (val.rows () > val.columns ()) + val = val.transpose (); + + if (error_state || val.columns () != dims.length () || val.rows () != 1) + error ("%s: SIZE must be a vector of length dim", fcn); + else + { + for (int i = 0; i < dims.length (); i++) + { + if (xisnan (val(i,0))) + error ("%s: SIZE has invalid NaN entries", fcn); + else if (NINTbig (val(i,0)) < 0) + error ("%s: all dimensions in SIZE must be greater than zero", fcn); + else + { + dims(i) = NINTbig(val(i,0)); + } + } + } + } + + if (error_state) + return retval; + + if (dims.all_zero ()) + { + if (arg.is_single_type ()) + return octave_value (FloatMatrix ()); + else + return octave_value (Matrix ()); + } + + if (arg.is_single_type ()) + { + if (arg.is_real_type ()) + { + FloatNDArray nda = arg.float_array_value (); + + if (! error_state) + { + nda.resize (dims, 0.0); + retval = (type != 0 ? nda.ifourierNd () : nda.fourierNd ()); + } + } + else + { + FloatComplexNDArray cnda = arg.float_complex_array_value (); + + if (! error_state) + { + cnda.resize (dims, 0.0); + retval = (type != 0 ? cnda.ifourierNd () : cnda.fourierNd ()); + } + } + } + else + { + if (arg.is_real_type ()) + { + NDArray nda = arg.array_value (); + + if (! error_state) + { + nda.resize (dims, 0.0); + retval = (type != 0 ? nda.ifourierNd () : nda.fourierNd ()); + } + } + else if (arg.is_complex_type ()) + { + ComplexNDArray cnda = arg.complex_array_value (); + + if (! error_state) + { + cnda.resize (dims, 0.0); + retval = (type != 0 ? cnda.ifourierNd () : cnda.fourierNd ()); + } + } + else + { + gripe_wrong_type_arg (fcn, arg); + } + } + + return retval; +} + +DEFUN (fftn, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} fftn (@var{A})\n\ +@deftypefnx {Built-in Function} {} fftn (@var{A}, @var{size})\n\ +Compute the N-dimensional discrete Fourier transform of @var{A} using\n\ +a Fast Fourier Transform (FFT) algorithm.\n\ +\n\ +The optional vector argument @var{size} may be used specify the\n\ +dimensions of the array to be used. If an element of @var{size} is\n\ +smaller than the corresponding dimension of @var{A}, then the dimension of\n\ +@var{A} is truncated prior to performing the FFT@. Otherwise, if an element\n\ +of @var{size} is larger than the corresponding dimension then @var{A}\n\ +is resized and padded with zeros.\n\ +@seealso{ifftn, fft, fft2, fftw}\n\ +@end deftypefn") +{ + return do_fftn (args, "fftn", 0); +} + +DEFUN (ifftn, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} ifftn (@var{A})\n\ +@deftypefnx {Built-in Function} {} ifftn (@var{A}, @var{size})\n\ +Compute the inverse N-dimensional discrete Fourier transform of @var{A}\n\ +using a Fast Fourier Transform (FFT) algorithm.\n\ +\n\ +The optional vector argument @var{size} may be used specify the\n\ +dimensions of the array to be used. If an element of @var{size} is\n\ +smaller than the corresponding dimension of @var{A}, then the dimension of\n\ +@var{A} is truncated prior to performing the inverse FFT@. Otherwise, if an\n\ +element of @var{size} is larger than the corresponding dimension then @var{A}\n\ +is resized and padded with zeros.\n\ +@seealso{fftn, ifft, ifft2, fftw}\n\ +@end deftypefn") +{ + return do_fftn (args, "ifftn", 1); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/filter.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,738 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Based on Tony Richardson's filter.m. +// +// Originally translated to C++ by KH (Kurt.Hornik@wu-wien.ac.at) +// with help from Fritz Leisch and Andreas Weingessel on Oct 20, 1994. +// +// Rewritten to use templates to handle both real and complex cases by +// jwe, Wed Nov 1 19:15:29 1995. + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" + +#if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) +extern MArray<double> +filter (MArray<double>&, MArray<double>&, MArray<double>&, int dim); + +extern MArray<Complex> +filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, int dim); + +extern MArray<float> +filter (MArray<float>&, MArray<float>&, MArray<float>&, int dim); + +extern MArray<FloatComplex> +filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, int dim); +#endif + +template <class T> +MArray<T> +filter (MArray<T>& b, MArray<T>& a, MArray<T>& x, MArray<T>& si, + int dim = 0) +{ + MArray<T> y; + + octave_idx_type a_len = a.length (); + octave_idx_type b_len = b.length (); + + octave_idx_type ab_len = a_len > b_len ? a_len : b_len; + + // FIXME: The two lines below should be unecessary because + // this template is called with a and b as column vectors + // already. However the a.resize line is currently (2011/04/26) + // necessary to stop bug #33164. + b.resize (dim_vector (ab_len, 1), 0.0); + if (a_len > 1) + a.resize (dim_vector (ab_len, 1), 0.0); + + T norm = a (0); + + if (norm == static_cast<T>(0.0)) + { + error ("filter: the first element of A must be non-zero"); + return y; + } + + dim_vector x_dims = x.dims (); + if (dim < 0 || dim > x_dims.length ()) + { + error ("filter: DIM must be a valid dimension"); + return y; + } + + octave_idx_type x_len = x_dims(dim); + + dim_vector si_dims = si.dims (); + octave_idx_type si_len = si_dims(0); + + if (si_len != ab_len - 1) + { + error ("filter: first dimension of SI must be of length max (length (a), length (b)) - 1"); + return y; + } + + if (si_dims.length () != x_dims.length ()) + { + error ("filter: dimensionality of SI and X must agree"); + return y; + } + + for (octave_idx_type i = 1; i < dim; i++) + { + if (si_dims(i) != x_dims(i-1)) + { + error ("filter: dimensionality of SI and X must agree"); + return y; + } + } + for (octave_idx_type i = dim+1; i < x_dims.length (); i++) + { + if (si_dims(i) != x_dims(i)) + { + error ("filter: dimensionality of SI and X must agree"); + return y; + } + } + + if (x_len == 0) + return x; + + if (norm != static_cast<T>(1.0)) + { + a = a / norm; + b = b / norm; + } + + if (a_len <= 1 && si_len <= 0) + return b(0) * x; + + y.resize (x_dims, 0.0); + + int x_stride = 1; + for (int i = 0; i < dim; i++) + x_stride *= x_dims(i); + + octave_idx_type x_num = x_dims.numel () / x_len; + for (octave_idx_type num = 0; num < x_num; num++) + { + octave_idx_type x_offset; + if (x_stride == 1) + x_offset = num * x_len; + else + { + octave_idx_type x_offset2 = 0; + x_offset = num; + while (x_offset >= x_stride) + { + x_offset -= x_stride; + x_offset2++; + } + x_offset += x_offset2 * x_stride * x_len; + } + octave_idx_type si_offset = num * si_len; + + if (a_len > 1) + { + T *py = y.fortran_vec (); + T *psi = si.fortran_vec (); + + const T *pa = a.data (); + const T *pb = b.data (); + const T *px = x.data (); + + psi += si_offset; + + for (octave_idx_type i = 0, idx = x_offset; i < x_len; i++, idx += x_stride) + { + py[idx] = psi[0] + pb[0] * px[idx]; + + if (si_len > 0) + { + for (octave_idx_type j = 0; j < si_len - 1; j++) + { + OCTAVE_QUIT; + + psi[j] = psi[j+1] - pa[j+1] * py[idx] + pb[j+1] * px[idx]; + } + + psi[si_len-1] = pb[si_len] * px[idx] - pa[si_len] * py[idx]; + } + else + { + OCTAVE_QUIT; + + psi[0] = pb[si_len] * px[idx] - pa[si_len] * py[idx]; + } + } + } + else if (si_len > 0) + { + T *py = y.fortran_vec (); + T *psi = si.fortran_vec (); + + const T *pb = b.data (); + const T *px = x.data (); + + psi += si_offset; + + for (octave_idx_type i = 0, idx = x_offset; i < x_len; i++, idx += x_stride) + { + py[idx] = psi[0] + pb[0] * px[idx]; + + if (si_len > 1) + { + for (octave_idx_type j = 0; j < si_len - 1; j++) + { + OCTAVE_QUIT; + + psi[j] = psi[j+1] + pb[j+1] * px[idx]; + } + + psi[si_len-1] = pb[si_len] * px[idx]; + } + else + { + OCTAVE_QUIT; + + psi[0] = pb[1] * px[idx]; + } + } + } + } + + return y; +} + +#if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) +extern MArray<double> +filter (MArray<double>&, MArray<double>&, MArray<double>&, + MArray<double>&, int dim); + +extern MArray<Complex> +filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, + MArray<Complex>&, int dim); + +extern MArray<float> +filter (MArray<float>&, MArray<float>&, MArray<float>&, + MArray<float>&, int dim); + +extern MArray<FloatComplex> +filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, + MArray<FloatComplex>&, int dim); +#endif + +template <class T> +MArray<T> +filter (MArray<T>& b, MArray<T>& a, MArray<T>& x, int dim = -1) +{ + dim_vector x_dims = x.dims (); + + if (dim < 0) + { + // Find first non-singleton dimension + while (dim < x_dims.length () && x_dims(dim) <= 1) + dim++; + + // All dimensions singleton, pick first dimension + if (dim == x_dims.length ()) + dim = 0; + } + else + if (dim < 0 || dim > x_dims.length ()) + { + error ("filter: DIM must be a valid dimension"); + return MArray<T> (); + } + + octave_idx_type a_len = a.length (); + octave_idx_type b_len = b.length (); + + octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; + dim_vector si_dims = x.dims (); + for (int i = dim; i > 0; i--) + si_dims(i) = si_dims(i-1); + si_dims(0) = si_len; + + MArray<T> si (si_dims, T (0.0)); + + return filter (b, a, x, si, dim); +} + +DEFUN (filter, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {y =} filter (@var{b}, @var{a}, @var{x})\n\ +@deftypefnx {Built-in Function} {[@var{y}, @var{sf}] =} filter (@var{b}, @var{a}, @var{x}, @var{si})\n\ +@deftypefnx {Built-in Function} {[@var{y}, @var{sf}] =} filter (@var{b}, @var{a}, @var{x}, [], @var{dim})\n\ +@deftypefnx {Built-in Function} {[@var{y}, @var{sf}] =} filter (@var{b}, @var{a}, @var{x}, @var{si}, @var{dim})\n\ +Return the solution to the following linear, time-invariant difference\n\ +equation:\n\ +@tex\n\ +$$\n\ +\\sum_{k=0}^N a_{k+1} y_{n-k} = \\sum_{k=0}^M b_{k+1} x_{n-k}, \\qquad\n\ + 1 \\le n \\le P\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +@c Set example in small font to prevent overfull line\n\ +\n\ +@smallexample\n\ +@group\n\ + N M\n\ +SUM a(k+1) y(n-k) = SUM b(k+1) x(n-k) for 1<=n<=length(x)\n\ +k=0 k=0\n\ +@end group\n\ +@end smallexample\n\ +\n\ +@end ifnottex\n\ +\n\ +@noindent\n\ +where\n\ +@ifnottex\n\ +N=length(a)-1 and M=length(b)-1.\n\ +@end ifnottex\n\ +@tex\n\ +$a \\in \\Re^{N-1}$, $b \\in \\Re^{M-1}$, and $x \\in \\Re^P$.\n\ +@end tex\n\ +The result is calculated over the first non-singleton dimension of @var{x}\n\ +or over @var{dim} if supplied.\n\ +\n\ +An equivalent form of the equation is:\n\ +@tex\n\ +$$\n\ +y_n = -\\sum_{k=1}^N c_{k+1} y_{n-k} + \\sum_{k=0}^M d_{k+1} x_{n-k}, \\qquad\n\ + 1 \\le n \\le P\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +@c Set example in small font to prevent overfull line\n\ +\n\ +@smallexample\n\ +@group\n\ + N M\n\ +y(n) = - SUM c(k+1) y(n-k) + SUM d(k+1) x(n-k) for 1<=n<=length(x)\n\ + k=1 k=0\n\ +@end group\n\ +@end smallexample\n\ +\n\ +@end ifnottex\n\ +\n\ +@noindent\n\ +where\n\ +@ifnottex\n\ + c = a/a(1) and d = b/a(1).\n\ +@end ifnottex\n\ +@tex\n\ +$c = a/a_1$ and $d = b/a_1$.\n\ +@end tex\n\ +\n\ +If the fourth argument @var{si} is provided, it is taken as the\n\ +initial state of the system and the final state is returned as\n\ +@var{sf}. The state vector is a column vector whose length is\n\ +equal to the length of the longest coefficient vector minus one.\n\ +If @var{si} is not supplied, the initial state vector is set to all\n\ +zeros.\n\ +\n\ +In terms of the Z Transform, y is the result of passing the discrete-\n\ +time signal x through a system characterized by the following rational\n\ +system function:\n\ +@tex\n\ +$$\n\ +H(z) = {\\displaystyle\\sum_{k=0}^M d_{k+1} z^{-k}\n\ + \\over 1 + \\displaystyle\\sum_{k+1}^N c_{k+1} z^{-k}}\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ + M\n\ + SUM d(k+1) z^(-k)\n\ + k=0\n\ +H(z) = ---------------------\n\ + N\n\ + 1 + SUM c(k+1) z^(-k)\n\ + k=1\n\ +@end group\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +@seealso{filter2, fftfilt, freqz}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin < 3 || nargin > 5) + { + print_usage (); + return retval; + } + + const char *errmsg = "filter: arguments a and b must be vectors"; + + int dim; + dim_vector x_dims = args(2).dims (); + + if (nargin == 5) + { + dim = args(4).nint_value () - 1; + if (dim < 0 || dim >= x_dims.length ()) + { + error ("filter: DIM must be a valid dimension"); + return retval; + } + } + else + { + // Find first non-singleton dimension + dim = 0; + while (dim < x_dims.length () && x_dims(dim) <= 1) + dim++; + + // All dimensions singleton, pick first dimension + if (dim == x_dims.length ()) + dim = 0; + } + + bool isfloat = (args(0).is_single_type () + || args(1).is_single_type () + || args(2).is_single_type () + || (nargin >= 4 && args(3).is_single_type ())); + + if (args(0).is_complex_type () + || args(1).is_complex_type () + || args(2).is_complex_type () + || (nargin >= 4 && args(3).is_complex_type ())) + { + if (isfloat) + { + FloatComplexColumnVector b (args(0).float_complex_vector_value ()); + FloatComplexColumnVector a (args(1).float_complex_vector_value ()); + + FloatComplexNDArray x (args(2).float_complex_array_value ()); + + if (! error_state) + { + FloatComplexNDArray si; + + if (nargin == 3 || args(3).is_empty ()) + { + octave_idx_type a_len = a.length (); + octave_idx_type b_len = b.length (); + + octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; + + dim_vector si_dims = x.dims (); + for (int i = dim; i > 0; i--) + si_dims(i) = si_dims(i-1); + si_dims(0) = si_len; + + si.resize (si_dims, 0.0); + } + else + { + si = args(3).float_complex_array_value (); + + if (si.is_vector () && x.is_vector ()) + si = si.reshape (dim_vector (si.numel (), 1)); + } + + if (! error_state) + { + FloatComplexNDArray y (filter (b, a, x, si, dim)); + + if (nargout == 2) + retval(1) = si; + + retval(0) = y; + } + else + error (errmsg); + } + else + error (errmsg); + } + else + { + ComplexColumnVector b (args(0).complex_vector_value ()); + ComplexColumnVector a (args(1).complex_vector_value ()); + + ComplexNDArray x (args(2).complex_array_value ()); + + if (! error_state) + { + ComplexNDArray si; + + if (nargin == 3 || args(3).is_empty ()) + { + octave_idx_type a_len = a.length (); + octave_idx_type b_len = b.length (); + + octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; + + dim_vector si_dims = x.dims (); + for (int i = dim; i > 0; i--) + si_dims(i) = si_dims(i-1); + si_dims(0) = si_len; + + si.resize (si_dims, 0.0); + } + else + { + si = args(3).complex_array_value (); + + if (si.is_vector () && x.is_vector ()) + si = si.reshape (dim_vector (si.numel (), 1)); + } + + if (! error_state) + { + ComplexNDArray y (filter (b, a, x, si, dim)); + + if (nargout == 2) + retval(1) = si; + + retval(0) = y; + } + else + error (errmsg); + } + else + error (errmsg); + } + } + else + { + if (isfloat) + { + FloatColumnVector b (args(0).float_vector_value ()); + FloatColumnVector a (args(1).float_vector_value ()); + + FloatNDArray x (args(2).float_array_value ()); + + if (! error_state) + { + FloatNDArray si; + + if (nargin == 3 || args(3).is_empty ()) + { + octave_idx_type a_len = a.length (); + octave_idx_type b_len = b.length (); + + octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; + + dim_vector si_dims = x.dims (); + for (int i = dim; i > 0; i--) + si_dims(i) = si_dims(i-1); + si_dims(0) = si_len; + + si.resize (si_dims, 0.0); + } + else + { + si = args(3).float_array_value (); + + if (si.is_vector () && x.is_vector ()) + si = si.reshape (dim_vector (si.numel (), 1)); + } + + if (! error_state) + { + FloatNDArray y (filter (b, a, x, si, dim)); + + if (nargout == 2) + retval(1) = si; + + retval(0) = y; + } + else + error (errmsg); + } + else + error (errmsg); + } + else + { + ColumnVector b (args(0).vector_value ()); + ColumnVector a (args(1).vector_value ()); + + NDArray x (args(2).array_value ()); + + if (! error_state) + { + NDArray si; + + if (nargin == 3 || args(3).is_empty ()) + { + octave_idx_type a_len = a.length (); + octave_idx_type b_len = b.length (); + + octave_idx_type si_len = (a_len > b_len ? a_len : b_len) - 1; + + dim_vector si_dims = x.dims (); + for (int i = dim; i > 0; i--) + si_dims(i) = si_dims(i-1); + si_dims(0) = si_len; + + si.resize (si_dims, 0.0); + } + else + { + si = args(3).array_value (); + + if (si.is_vector () && x.is_vector ()) + si = si.reshape (dim_vector (si.numel (), 1)); + } + + if (! error_state) + { + NDArray y (filter (b, a, x, si, dim)); + + if (nargout == 2) + retval(1) = si; + + retval(0) = y; + } + else + error (errmsg); + } + else + error (errmsg); + } + } + + return retval; +} + +template MArray<double> +filter (MArray<double>&, MArray<double>&, MArray<double>&, + MArray<double>&, int dim); + +template MArray<double> +filter (MArray<double>&, MArray<double>&, MArray<double>&, int dim); + +template MArray<Complex> +filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, + MArray<Complex>&, int dim); + +template MArray<Complex> +filter (MArray<Complex>&, MArray<Complex>&, MArray<Complex>&, int dim); + +template MArray<float> +filter (MArray<float>&, MArray<float>&, MArray<float>&, + MArray<float>&, int dim); + +template MArray<float> +filter (MArray<float>&, MArray<float>&, MArray<float>&, int dim); + +template MArray<FloatComplex> +filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, + MArray<FloatComplex>&, int dim); + +template MArray<FloatComplex> +filter (MArray<FloatComplex>&, MArray<FloatComplex>&, MArray<FloatComplex>&, int dim); + +/* +%!shared a, b, x, r +%!test +%! a = [1 1]; +%! b = [1 1]; +%! x = zeros (1,10); x(1) = 1; +%! assert (filter (b, [1], x ), [1 1 0 0 0 0 0 0 0 0]); +%! assert (filter (b, [1], x.'), [1 1 0 0 0 0 0 0 0 0].'); +%! assert (filter (b.', [1], x ), [1 1 0 0 0 0 0 0 0 0] ); +%! assert (filter (b.', [1], x.'), [1 1 0 0 0 0 0 0 0 0].'); +%! assert (filter ([1], a, x ), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1] ); +%! assert (filter ([1], a, x.'), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1].'); +%! assert (filter ([1], a.', x ), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1] ); +%! assert (filter ([1], a.', x.'), [+1 -1 +1 -1 +1 -1 +1 -1 +1 -1].'); +%! assert (filter (b, a, x ), [1 0 0 0 0 0 0 0 0 0] ); +%! assert (filter (b.', a, x ), [1 0 0 0 0 0 0 0 0 0] ); +%! assert (filter (b, a.', x ), [1 0 0 0 0 0 0 0 0 0] ); +%! assert (filter (b.', a, x ), [1 0 0 0 0 0 0 0 0 0] ); +%! assert (filter (b, a, x.'), [1 0 0 0 0 0 0 0 0 0].'); +%! assert (filter (b.', a, x.'), [1 0 0 0 0 0 0 0 0 0].'); +%! assert (filter (b, a.', x.'), [1 0 0 0 0 0 0 0 0 0].'); +%! assert (filter (b.', a, x.'), [1 0 0 0 0 0 0 0 0 0].'); + +%!test +%! r = sqrt (1/2) * (1+i); +%! a = a*r; +%! b = b*r; +%! assert (filter (b, [1], x ), r*[1 1 0 0 0 0 0 0 0 0] ); +%! assert (filter (b, [1], r*x ), r*r*[1 1 0 0 0 0 0 0 0 0] ); +%! assert (filter (b, [1], x.' ), r*[1 1 0 0 0 0 0 0 0 0].' ); +%! assert (filter (b, a, x ), [1 0 0 0 0 0 0 0 0 0] ); +%! assert (filter (b, a, r*x ), r*[1 0 0 0 0 0 0 0 0 0] ); + +%!shared a, b, x, y, so +%!test +%! a = [1,1]; +%! b = [1,1]; +%! x = zeros (1,10); x(1) = 1; +%! [y, so] = filter (b, [1], x, [-1]); +%! assert (y, [0 1 0 0 0 0 0 0 0 0]); +%! assert (so, 0); + +%!test +%! x = zeros (10,3); x(1,1) = -1; x(1,2) = 1; +%! y0 = zeros (10,3); y0(1:2,1) = -1; y0(1:2,2) = 1; +%! y = filter (b, [1], x); +%! assert (y, y0); + +%!test +%! a = [1,1]; +%! b=[1,1]; +%! x = zeros (4,4,2); x(1,1:4,1) = +1; x(1,1:4,2) = -1; +%! y0 = zeros (4,4,2); y0(1:2,1:4,1) = +1; y0(1:2,1:4,2) = -1; +%! y = filter (b, [1], x); +%! assert (y, y0); + +%!assert (filter (1, ones (10,1) / 10, []), []) +%!assert (filter (1, ones (10,1) / 10, zeros (0,10)), zeros (0,10)) +%!assert (filter (1, ones (10,1) / 10, single (1:5)), repmat (single (10), 1, 5)) + +%% Test using initial conditions +%!assert (filter ([1, 1, 1], [1, 1], [1 2], [1, 1]), [2 2]) +%!assert (filter ([1, 1, 1], [1, 1], [1 2], [1, 1]'), [2 2]) +%!assert (filter ([1, 3], [1], [1 2; 3 4; 5 6], [4, 5]), [5 7; 6 10; 14 18]) +%!error (filter ([1, 3], [1], [1 2; 3 4; 5 6], [4, 5]')) +%!assert (filter ([1, 3, 2], [1], [1 2; 3 4; 5 6], [1 0 0; 1 0 0], 2), [2 6; 3 13; 5 21]) + +## Test of DIM parameter +%!test +%! x = ones (2, 1, 3, 4); +%! x(1,1,:,:) = [1 2 3 4; 5 6 7 8; 9 10 11 12]; +%! y0 = [1 1 6 2 15 3 2 1 8 2 18 3 3 1 10 2 21 3 4 1 12 2 24 3]; +%! y0 = reshape (y0, size (x)); +%! y = filter ([1 1 1], 1, x, [], 3); +%! assert (y, y0); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/find.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,621 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" + +// Find at most N_TO_FIND nonzero elements in NDA. Search forward if +// DIRECTION is 1, backward if it is -1. NARGOUT is the number of +// output arguments. If N_TO_FIND is -1, find all nonzero elements. + +template <typename T> +octave_value_list +find_nonzero_elem_idx (const Array<T>& nda, int nargout, + octave_idx_type n_to_find, int direction) +{ + octave_value_list retval ((nargout == 0 ? 1 : nargout), Matrix ()); + + Array<octave_idx_type> idx; + if (n_to_find >= 0) + idx = nda.find (n_to_find, direction == -1); + else + idx = nda.find (); + + // The maximum element is always at the end. + octave_idx_type iext = idx.is_empty () ? 0 : idx.xelem (idx.numel () - 1) + 1; + + switch (nargout) + { + default: + case 3: + retval(2) = Array<T> (nda.index (idx_vector (idx))); + // Fall through! + + case 2: + { + Array<octave_idx_type> jdx (idx.dims ()); + octave_idx_type n = idx.length (), nr = nda.rows (); + for (octave_idx_type i = 0; i < n; i++) + { + jdx.xelem (i) = idx.xelem (i) / nr; + idx.xelem (i) %= nr; + } + iext = -1; + retval(1) = idx_vector (jdx, -1); + } + // Fall through! + + case 1: + case 0: + retval(0) = idx_vector (idx, iext); + break; + } + + return retval; +} + +template <typename T> +octave_value_list +find_nonzero_elem_idx (const Sparse<T>& v, int nargout, + octave_idx_type n_to_find, int direction) +{ + octave_value_list retval ((nargout == 0 ? 1 : nargout), Matrix ()); + + + octave_idx_type nc = v.cols (); + octave_idx_type nr = v.rows (); + octave_idx_type nz = v.nnz (); + + // Search in the default range. + octave_idx_type start_nc = -1; + octave_idx_type end_nc = -1; + octave_idx_type count; + + // Search for the range to search + if (n_to_find < 0) + { + start_nc = 0; + end_nc = nc; + n_to_find = nz; + count = nz; + } + else if (direction > 0) + { + for (octave_idx_type j = 0; j < nc; j++) + { + OCTAVE_QUIT; + if (v.cidx (j) == 0 && v.cidx (j+1) != 0) + start_nc = j; + if (v.cidx (j+1) >= n_to_find) + { + end_nc = j + 1; + break; + } + } + } + else + { + for (octave_idx_type j = nc; j > 0; j--) + { + OCTAVE_QUIT; + if (v.cidx (j) == nz && v.cidx (j-1) != nz) + end_nc = j; + if (nz - v.cidx (j-1) >= n_to_find) + { + start_nc = j - 1; + break; + } + } + } + + count = (n_to_find > v.cidx (end_nc) - v.cidx (start_nc) ? + v.cidx (end_nc) - v.cidx (start_nc) : n_to_find); + + // If the original argument was a row vector, force a row vector of + // the overall indices to be returned. But see below for scalar + // case... + + octave_idx_type result_nr = count; + octave_idx_type result_nc = 1; + + bool scalar_arg = false; + + if (v.rows () == 1) + { + result_nr = 1; + result_nc = count; + + scalar_arg = (v.columns () == 1); + } + + Matrix idx (result_nr, result_nc); + + Matrix i_idx (result_nr, result_nc); + Matrix j_idx (result_nr, result_nc); + + Array<T> val (dim_vector (result_nr, result_nc)); + + if (count > 0) + { + // Search for elements to return. Only search the region where + // there are elements to be found using the count that we want + // to find. + for (octave_idx_type j = start_nc, cx = 0; j < end_nc; j++) + for (octave_idx_type i = v.cidx (j); i < v.cidx (j+1); i++ ) + { + OCTAVE_QUIT; + if (direction < 0 && i < nz - count) + continue; + i_idx(cx) = static_cast<double> (v.ridx (i) + 1); + j_idx(cx) = static_cast<double> (j + 1); + idx(cx) = j * nr + v.ridx (i) + 1; + val(cx) = v.data(i); + cx++; + if (cx == count) + break; + } + } + else if (scalar_arg) + { + idx.resize (0, 0); + + i_idx.resize (0, 0); + j_idx.resize (0, 0); + + val.resize (dim_vector (0, 0)); + } + + switch (nargout) + { + case 0: + case 1: + retval(0) = idx; + break; + + case 5: + retval(4) = nc; + // Fall through + + case 4: + retval(3) = nr; + // Fall through + + case 3: + retval(2) = val; + // Fall through! + + case 2: + retval(1) = j_idx; + retval(0) = i_idx; + break; + + default: + panic_impossible (); + break; + } + + return retval; +} + +octave_value_list +find_nonzero_elem_idx (const PermMatrix& v, int nargout, + octave_idx_type n_to_find, int direction) +{ + // There are far fewer special cases to handle for a PermMatrix. + octave_value_list retval ((nargout == 0 ? 1 : nargout), Matrix ()); + + octave_idx_type nc = v.cols (); + octave_idx_type start_nc, count; + + // Determine the range to search. + if (n_to_find < 0 || n_to_find >= nc) + { + start_nc = 0; + n_to_find = nc; + count = nc; + } + else if (direction > 0) + { + start_nc = 0; + count = n_to_find; + } + else + { + start_nc = nc - n_to_find; + count = n_to_find; + } + + bool scalar_arg = (v.rows () == 1 && v.cols () == 1); + + Matrix idx (count, 1); + Matrix i_idx (count, 1); + Matrix j_idx (count, 1); + // Every value is 1. + Array<double> val (dim_vector (count, 1), 1.0); + + if (count > 0) + { + const octave_idx_type* p = v.data (); + if (v.is_col_perm ()) + { + for (octave_idx_type k = 0; k < count; k++) + { + OCTAVE_QUIT; + const octave_idx_type j = start_nc + k; + const octave_idx_type i = p[j]; + i_idx(k) = static_cast<double> (1+i); + j_idx(k) = static_cast<double> (1+j); + idx(k) = j * nc + i + 1; + } + } + else + { + for (octave_idx_type k = 0; k < count; k++) + { + OCTAVE_QUIT; + const octave_idx_type i = start_nc + k; + const octave_idx_type j = p[i]; + // Scatter into the index arrays according to + // j adjusted by the start point. + const octave_idx_type koff = j - start_nc; + i_idx(koff) = static_cast<double> (1+i); + j_idx(koff) = static_cast<double> (1+j); + idx(koff) = j * nc + i + 1; + } + } + } + else if (scalar_arg) + { + // Same odd compatibility case as the other overrides. + idx.resize (0, 0); + i_idx.resize (0, 0); + j_idx.resize (0, 0); + val.resize (dim_vector (0, 0)); + } + + switch (nargout) + { + case 0: + case 1: + retval(0) = idx; + break; + + case 5: + retval(4) = nc; + // Fall through + + case 4: + retval(3) = nc; + // Fall through + + case 3: + retval(2) = val; + // Fall through! + + case 2: + retval(1) = j_idx; + retval(0) = i_idx; + break; + + default: + panic_impossible (); + break; + } + + return retval; +} + +DEFUN (find, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{idx} =} find (@var{x})\n\ +@deftypefnx {Built-in Function} {@var{idx} =} find (@var{x}, @var{n})\n\ +@deftypefnx {Built-in Function} {@var{idx} =} find (@var{x}, @var{n}, @var{direction})\n\ +@deftypefnx {Built-in Function} {[i, j] =} find (@dots{})\n\ +@deftypefnx {Built-in Function} {[i, j, v] =} find (@dots{})\n\ +Return a vector of indices of nonzero elements of a matrix, as a row if\n\ +@var{x} is a row vector or as a column otherwise. To obtain a single index\n\ +for each matrix element, Octave pretends that the columns of a matrix form\n\ +one long vector (like Fortran arrays are stored). For example:\n\ +\n\ +@example\n\ +@group\n\ +find (eye (2))\n\ + @result{} [ 1; 4 ]\n\ +@end group\n\ +@end example\n\ +\n\ +If two outputs are requested, @code{find} returns the row and column\n\ +indices of nonzero elements of a matrix. For example:\n\ +\n\ +@example\n\ +@group\n\ +[i, j] = find (2 * eye (2))\n\ + @result{} i = [ 1; 2 ]\n\ + @result{} j = [ 1; 2 ]\n\ +@end group\n\ +@end example\n\ +\n\ +If three outputs are requested, @code{find} also returns a vector\n\ +containing the nonzero values. For example:\n\ +\n\ +@example\n\ +@group\n\ +[i, j, v] = find (3 * eye (2))\n\ + @result{} i = [ 1; 2 ]\n\ + @result{} j = [ 1; 2 ]\n\ + @result{} v = [ 3; 3 ]\n\ +@end group\n\ +@end example\n\ +\n\ +If two inputs are given, @var{n} indicates the maximum number of\n\ +elements to find from the beginning of the matrix or vector.\n\ +\n\ +If three inputs are given, @var{direction} should be one of \"first\" or\n\ +\"last\", requesting only the first or last @var{n} indices, respectively.\n\ +However, the indices are always returned in ascending order.\n\ +\n\ +Note that this function is particularly useful for sparse matrices, as\n\ +it extracts the non-zero elements as vectors, which can then be used to\n\ +create the original matrix. For example:\n\ +\n\ +@example\n\ +@group\n\ +sz = size (a);\n\ +[i, j, v] = find (a);\n\ +b = sparse (i, j, v, sz(1), sz(2));\n\ +@end group\n\ +@end example\n\ +@seealso{nonzeros}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin > 3 || nargin < 1) + { + print_usage (); + return retval; + } + + // Setup the default options. + octave_idx_type n_to_find = -1; + if (nargin > 1) + { + double val = args(1).scalar_value (); + + if (error_state || (val < 0 || (! xisinf (val) && val != xround (val)))) + { + error ("find: N must be a non-negative integer"); + return retval; + } + else if (! xisinf (val)) + n_to_find = val; + } + + // Direction to do the searching (1 == forward, -1 == reverse). + int direction = 1; + if (nargin > 2) + { + direction = 0; + + std::string s_arg = args(2).string_value (); + + if (! error_state) + { + if (s_arg == "first") + direction = 1; + else if (s_arg == "last") + direction = -1; + } + + if (direction == 0) + { + error ("find: DIRECTION must be \"first\" or \"last\""); + return retval; + } + } + + octave_value arg = args(0); + + if (arg.is_bool_type ()) + { + if (arg.is_sparse_type ()) + { + SparseBoolMatrix v = arg.sparse_bool_matrix_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (v, nargout, + n_to_find, direction); + } + else if (nargout <= 1 && n_to_find == -1 && direction == 1) + { + // This case is equivalent to extracting indices from a logical + // matrix. Try to reuse the possibly cached index vector. + retval(0) = arg.index_vector ().unmask (); + } + else + { + boolNDArray v = arg.bool_array_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (v, nargout, + n_to_find, direction); + } + } + else if (arg.is_integer_type ()) + { +#define DO_INT_BRANCH(INTT) \ + else if (arg.is_ ## INTT ## _type ()) \ + { \ + INTT ## NDArray v = arg.INTT ## _array_value (); \ + \ + if (! error_state) \ + retval = find_nonzero_elem_idx (v, nargout, \ + n_to_find, direction);\ + } + + if (false) + ; + DO_INT_BRANCH (int8) + DO_INT_BRANCH (int16) + DO_INT_BRANCH (int32) + DO_INT_BRANCH (int64) + DO_INT_BRANCH (uint8) + DO_INT_BRANCH (uint16) + DO_INT_BRANCH (uint32) + DO_INT_BRANCH (uint64) + else + panic_impossible (); + } + else if (arg.is_sparse_type ()) + { + if (arg.is_real_type ()) + { + SparseMatrix v = arg.sparse_matrix_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (v, nargout, + n_to_find, direction); + } + else if (arg.is_complex_type ()) + { + SparseComplexMatrix v = arg.sparse_complex_matrix_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (v, nargout, + n_to_find, direction); + } + else + gripe_wrong_type_arg ("find", arg); + } + else if (arg.is_perm_matrix ()) + { + PermMatrix P = arg.perm_matrix_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (P, nargout, n_to_find, direction); + } + else if (arg.is_string ()) + { + charNDArray chnda = arg.char_array_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (chnda, nargout, n_to_find, direction); + } + else if (arg.is_single_type ()) + { + if (arg.is_real_type ()) + { + FloatNDArray nda = arg.float_array_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (nda, nargout, n_to_find, + direction); + } + else if (arg.is_complex_type ()) + { + FloatComplexNDArray cnda = arg.float_complex_array_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (cnda, nargout, n_to_find, + direction); + } + } + else if (arg.is_real_type ()) + { + NDArray nda = arg.array_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (nda, nargout, n_to_find, direction); + } + else if (arg.is_complex_type ()) + { + ComplexNDArray cnda = arg.complex_array_value (); + + if (! error_state) + retval = find_nonzero_elem_idx (cnda, nargout, n_to_find, direction); + } + else + gripe_wrong_type_arg ("find", arg); + + return retval; +} + +/* +%!assert (find (char ([0, 97])), 2) +%!assert (find ([1, 0, 1, 0, 1]), [1, 3, 5]) +%!assert (find ([1; 0; 3; 0; 1]), [1; 3; 5]) +%!assert (find ([0, 0, 2; 0, 3, 0; -1, 0, 0]), [3; 5; 7]) + +%!test +%! [i, j, v] = find ([0, 0, 2; 0, 3, 0; -1, 0, 0]); +%! +%! assert (i, [3; 2; 1]); +%! assert (j, [1; 2; 3]); +%! assert (v, [-1; 3; 2]); + +%!assert (find (single ([1, 0, 1, 0, 1])), [1, 3, 5]) +%!assert (find (single ([1; 0; 3; 0; 1])), [1; 3; 5]) +%!assert (find (single ([0, 0, 2; 0, 3, 0; -1, 0, 0])), [3; 5; 7]) + +%!test +%! [i, j, v] = find (single ([0, 0, 2; 0, 3, 0; -1, 0, 0])); +%! +%! assert (i, [3; 2; 1]); +%! assert (j, [1; 2; 3]); +%! assert (v, single ([-1; 3; 2])); + +%!test +%! pcol = [5 1 4 3 2]; +%! P = eye (5) (:, pcol); +%! [i, j, v] = find (P); +%! [ifull, jfull, vfull] = find (full (P)); +%! assert (i, ifull); +%! assert (j, jfull); +%! assert (all (v == 1)); + +%!test +%! prow = [5 1 4 3 2]; +%! P = eye (5) (prow, :); +%! [i, j, v] = find (P); +%! [ifull, jfull, vfull] = find (full (P)); +%! assert (i, ifull); +%! assert (j, jfull); +%! assert (all (v == 1)); + +%!assert (find ([2 0 1 0 5 0], 1), 1) +%!assert (find ([2 0 1 0 5 0], 2, "last"), [3, 5]) + +%!assert (find ([2 0 1 0 5 0], Inf), [1, 3, 5]) +%!assert (find ([2 0 1 0 5 0], Inf, "last"), [1, 3, 5]) + +%!error find () +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/gammainc.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,230 @@ +/* + +Copyright (C) 1997-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-specfun.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (gammainc, args, , + "-*- texinfo -*-\n\ +@deftypefn {Mapping Function} {} gammainc (@var{x}, @var{a})\n\ +@deftypefnx {Mapping Function} {} gammainc (@var{x}, @var{a}, \"lower\")\n\ +@deftypefnx {Mapping Function} {} gammainc (@var{x}, @var{a}, \"upper\")\n\ +Compute the normalized incomplete gamma function,\n\ +@tex\n\ +$$\n\ + \\gamma (x, a) = {1 \\over {\\Gamma (a)}}\\displaystyle{\\int_0^x t^{a-1} e^{-t} dt}\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ + x\n\ + 1 /\n\ +gammainc (x, a) = --------- | exp (-t) t^(a-1) dt\n\ + gamma (a) /\n\ + t=0\n\ +@end group\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +with the limiting value of 1 as @var{x} approaches infinity.\n\ +The standard notation is @math{P(a,x)}, e.g., Abramowitz and Stegun (6.5.1).\n\ +\n\ +If @var{a} is scalar, then @code{gammainc (@var{x}, @var{a})} is returned\n\ +for each element of @var{x} and vice versa.\n\ +\n\ +If neither @var{x} nor @var{a} is scalar, the sizes of @var{x} and\n\ +@var{a} must agree, and @code{gammainc} is applied element-by-element.\n\ +\n\ +By default the incomplete gamma function integrated from 0 to @var{x} is\n\ +computed. If \"upper\" is given then the complementary function integrated\n\ +from @var{x} to infinity is calculated. It should be noted that\n\ +\n\ +@example\n\ +gammainc (@var{x}, @var{a}) @equiv{} 1 - gammainc (@var{x}, @var{a}, \"upper\")\n\ +@end example\n\ +@seealso{gamma, lgamma}\n\ +@end deftypefn") +{ + octave_value retval; + bool lower = true; + + int nargin = args.length (); + + if (nargin == 3) + { + if (args(2).is_string ()) + { + std::string s = args(2).string_value (); + std::transform (s.begin (), s.end (), s.begin (), tolower); + if (s == "upper") + lower = false; + else if (s != "lower") + error ("gammainc: third argument must be \"lower\" or \"upper\""); + } + else + error ("gammainc: third argument must be \"lower\" or \"upper\""); + + } + + if (!error_state && nargin >= 2 && nargin <= 3) + { + octave_value x_arg = args(0); + octave_value a_arg = args(1); + + // FIXME Can we make a template version of the duplicated code below + if (x_arg.is_single_type () || a_arg.is_single_type ()) + { + if (x_arg.is_scalar_type ()) + { + float x = x_arg.float_value (); + + if (! error_state) + { + if (a_arg.is_scalar_type ()) + { + float a = a_arg.float_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) + : static_cast<float>(1) - gammainc (x, a); + } + else + { + FloatNDArray a = a_arg.float_array_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) + : static_cast<float>(1) - gammainc (x, a); + } + } + } + else + { + FloatNDArray x = x_arg.float_array_value (); + + if (! error_state) + { + if (a_arg.is_scalar_type ()) + { + float a = a_arg.float_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) + : static_cast<float>(1) - gammainc (x, a); + } + else + { + FloatNDArray a = a_arg.float_array_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) + : static_cast<float>(1) - gammainc (x, a); + } + } + } + } + else + { + if (x_arg.is_scalar_type ()) + { + double x = x_arg.double_value (); + + if (! error_state) + { + if (a_arg.is_scalar_type ()) + { + double a = a_arg.double_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); + } + else + { + NDArray a = a_arg.array_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); + } + } + } + else + { + NDArray x = x_arg.array_value (); + + if (! error_state) + { + if (a_arg.is_scalar_type ()) + { + double a = a_arg.double_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); + } + else + { + NDArray a = a_arg.array_value (); + + if (! error_state) + retval = lower ? gammainc (x, a) : 1. - gammainc (x, a); + } + } + } + } + } + else + print_usage (); + + return retval; +} + +/* +%!test +%! a = [.5 .5 .5 .5 .5]; +%! x = [0 1 2 3 4]; +%! v1 = sqrt (pi)*erf (x)./gamma (a); +%! v3 = gammainc (x.*x, a); +%! assert (v1, v3, sqrt (eps)); + +%!assert (gammainc (0:4,0.5, "upper"), 1-gammainc (0:4,0.5), 1e-10) + +%!test +%! a = single ([.5 .5 .5 .5 .5]); +%! x = single ([0 1 2 3 4]); +%! v1 = sqrt (pi ("single"))*erf (x)./gamma (a); +%! v3 = gammainc (x.*x, a); +%! assert (v1, v3, sqrt (eps ("single"))); + +%!assert (gammainc (single (0:4), single (0.5), "upper"), +%! single (1)-gammainc (single (0:4), single (0.5)), +%! single (1e-7)) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/gcd.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,528 @@ +/* + +Copyright (C) 2004-2012 David Bateman +Copyright (C) 2010 Jaroslav Hajek, Jordi Gutiérrez Hermoso + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "dNDArray.h" +#include "CNDArray.h" +#include "fNDArray.h" +#include "fCNDArray.h" +#include "lo-mappers.h" +#include "oct-binmap.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" + +static double +simple_gcd (double a, double b) +{ + if (! xisinteger (a) || ! xisinteger (b)) + (*current_liboctave_error_handler) + ("gcd: all values must be integers"); + + double aa = fabs (a); + double bb = fabs (b); + + while (bb != 0) + { + double tt = fmod (aa, bb); + aa = bb; + bb = tt; + } + + return aa; +} + +// Don't use the Complex and FloatComplex typedefs because we need to +// refer to the actual float precision FP in the body (and when gcc +// implements template aliases from C++0x, can do a small fix here). +template <typename FP> +static void +divide (const std::complex<FP>& a, const std::complex<FP>& b, + std::complex<FP>& q, std::complex<FP>& r) +{ + FP qr = gnulib::floor ((a/b).real () + 0.5); + FP qi = gnulib::floor ((a/b).imag () + 0.5); + + q = std::complex<FP> (qr, qi); + + r = a - q*b; +} + +template <typename FP> +static std::complex<FP> +simple_gcd (const std::complex<FP>& a, const std::complex<FP>& b) +{ + if (! xisinteger (a.real ()) || ! xisinteger (a.imag ()) + || ! xisinteger (b.real ()) || ! xisinteger (b.imag ())) + (*current_liboctave_error_handler) + ("gcd: all complex parts must be integers"); + + std::complex<FP> aa = a; + std::complex<FP> bb = b; + + if (abs (aa) < abs (bb)) + std::swap (aa, bb); + + while (abs (bb) != 0) + { + std::complex<FP> qq, rr; + divide (aa, bb, qq, rr); + aa = bb; + bb = rr; + } + + return aa; +} + +template <class T> +static octave_int<T> +simple_gcd (const octave_int<T>& a, const octave_int<T>& b) +{ + T aa = a.abs ().value (); + T bb = b.abs ().value (); + + while (bb != 0) + { + T tt = aa % bb; + aa = bb; + bb = tt; + } + + return aa; +} + +static double +extended_gcd (double a, double b, double& x, double& y) +{ + if (! xisinteger (a) || ! xisinteger (b)) + (*current_liboctave_error_handler) + ("gcd: all values must be integers"); + + double aa = fabs (a); + double bb = fabs (b); + + double xx = 0, yy = 1; + double lx = 1, ly = 0; + + while (bb != 0) + { + double qq = gnulib::floor (aa / bb); + double tt = fmod (aa, bb); + + aa = bb; + bb = tt; + + double tx = lx - qq*xx; + lx = xx; + xx = tx; + + double ty = ly - qq*yy; + ly = yy; + yy = ty; + } + + x = a >= 0 ? lx : -lx; + y = b >= 0 ? ly : -ly; + + return aa; +} + +template <typename FP> +static std::complex<FP> +extended_gcd (const std::complex<FP>& a, const std::complex<FP>& b, + std::complex<FP>& x, std::complex<FP>& y) +{ + if (! xisinteger (a.real ()) || ! xisinteger (a.imag ()) + || ! xisinteger (b.real ()) || ! xisinteger (b.imag ())) + (*current_liboctave_error_handler) + ("gcd: all complex parts must be integers"); + + std::complex<FP> aa = a, bb = b; + bool swapped = false; + if (abs (aa) < abs (bb)) + { + std::swap (aa, bb); + swapped = true; + } + + std::complex<FP> xx = 0, lx = 1; + std::complex<FP> yy = 1, ly = 0; + + while (abs(bb) != 0) + { + std::complex<FP> qq, rr; + divide (aa, bb, qq, rr); + aa = bb; + bb = rr; + + std::complex<FP> tx = lx - qq*xx; + lx = xx; + xx = tx; + + std::complex<FP> ty = ly - qq*yy; + ly = yy; + yy = ty; + } + + x = lx; + y = ly; + + if (swapped) + std::swap (x, y); + + return aa; +} + +template <class T> +static octave_int<T> +extended_gcd (const octave_int<T>& a, const octave_int<T>& b, + octave_int<T>& x, octave_int<T>& y) +{ + T aa = a.abs ().value (); + T bb = b.abs ().value (); + T xx = 0, lx = 1; + T yy = 1, ly = 0; + + while (bb != 0) + { + T qq = aa / bb; + T tt = aa % bb; + aa = bb; + bb = tt; + + T tx = lx - qq*xx; + lx = xx; + xx = tx; + + T ty = ly - qq*yy; + ly = yy; + yy = ty; + } + + x = octave_int<T> (lx) * a.signum (); + y = octave_int<T> (ly) * b.signum (); + + return aa; +} + +template<class NDA> +static octave_value +do_simple_gcd (const octave_value& a, const octave_value& b) +{ + typedef typename NDA::element_type T; + octave_value retval; + + if (a.is_scalar_type () && b.is_scalar_type ()) + { + // Optimize scalar case. + T aa = octave_value_extract<T> (a); + T bb = octave_value_extract<T> (b); + retval = simple_gcd (aa, bb); + } + else + { + NDA aa = octave_value_extract<NDA> (a); + NDA bb = octave_value_extract<NDA> (b); + retval = binmap<T> (aa, bb, simple_gcd, "gcd"); + } + + return retval; +} + +// Dispatcher +static octave_value +do_simple_gcd (const octave_value& a, const octave_value& b) +{ + octave_value retval; + builtin_type_t btyp = btyp_mixed_numeric (a.builtin_type (), + b.builtin_type ()); + switch (btyp) + { + case btyp_double: + if (a.is_sparse_type () && b.is_sparse_type ()) + { + retval = do_simple_gcd<SparseMatrix> (a, b); + break; + } + // fall through! + + case btyp_float: + retval = do_simple_gcd<NDArray> (a, b); + break; + +#define MAKE_INT_BRANCH(X) \ + case btyp_ ## X: \ + retval = do_simple_gcd<X ## NDArray> (a, b); \ + break + + MAKE_INT_BRANCH (int8); + MAKE_INT_BRANCH (int16); + MAKE_INT_BRANCH (int32); + MAKE_INT_BRANCH (int64); + MAKE_INT_BRANCH (uint8); + MAKE_INT_BRANCH (uint16); + MAKE_INT_BRANCH (uint32); + MAKE_INT_BRANCH (uint64); + +#undef MAKE_INT_BRANCH + + case btyp_complex: + retval = do_simple_gcd<ComplexNDArray> (a, b); + break; + + case btyp_float_complex: + retval = do_simple_gcd<FloatComplexNDArray> (a, b); + break; + + default: + error ("gcd: invalid class combination for gcd: %s and %s\n", + a.class_name ().c_str (), b.class_name ().c_str ()); + } + + if (btyp == btyp_float) + retval = retval.float_array_value (); + + return retval; +} + +template<class NDA> +static octave_value +do_extended_gcd (const octave_value& a, const octave_value& b, + octave_value& x, octave_value& y) +{ + typedef typename NDA::element_type T; + octave_value retval; + + if (a.is_scalar_type () && b.is_scalar_type ()) + { + // Optimize scalar case. + T aa = octave_value_extract<T> (a); + T bb = octave_value_extract<T> (b); + T xx, yy; + retval = extended_gcd (aa, bb, xx, yy); + x = xx; + y = yy; + } + else + { + NDA aa = octave_value_extract<NDA> (a); + NDA bb = octave_value_extract<NDA> (b); + + dim_vector dv = aa.dims (); + if (aa.numel () == 1) + dv = bb.dims (); + else if (bb.numel () != 1 && bb.dims () != dv) + gripe_nonconformant ("gcd", a.dims (), b.dims ()); + + NDA gg (dv), xx (dv), yy (dv); + + const T *aptr = aa.fortran_vec (); + const T *bptr = bb.fortran_vec (); + + bool inca = aa.numel () != 1; + bool incb = bb.numel () != 1; + + T *gptr = gg.fortran_vec (); + T *xptr = xx.fortran_vec (), *yptr = yy.fortran_vec (); + + octave_idx_type n = gg.numel (); + for (octave_idx_type i = 0; i < n; i++) + { + octave_quit (); + + *gptr++ = extended_gcd (*aptr, *bptr, *xptr++, *yptr++); + + aptr += inca; + bptr += incb; + } + + x = xx; + y = yy; + + retval = gg; + } + + return retval; +} + +// Dispatcher +static octave_value +do_extended_gcd (const octave_value& a, const octave_value& b, + octave_value& x, octave_value& y) +{ + octave_value retval; + + builtin_type_t btyp = btyp_mixed_numeric (a.builtin_type (), + b.builtin_type ()); + switch (btyp) + { + case btyp_double: + case btyp_float: + retval = do_extended_gcd<NDArray> (a, b, x, y); + break; + +#define MAKE_INT_BRANCH(X) \ + case btyp_ ## X: \ + retval = do_extended_gcd<X ## NDArray> (a, b, x, y); \ + break + + MAKE_INT_BRANCH (int8); + MAKE_INT_BRANCH (int16); + MAKE_INT_BRANCH (int32); + MAKE_INT_BRANCH (int64); + MAKE_INT_BRANCH (uint8); + MAKE_INT_BRANCH (uint16); + MAKE_INT_BRANCH (uint32); + MAKE_INT_BRANCH (uint64); + +#undef MAKE_INT_BRANCH + + case btyp_complex: + retval = do_extended_gcd<ComplexNDArray> (a, b, x, y); + break; + + case btyp_float_complex: + retval = do_extended_gcd<FloatComplexNDArray> (a, b, x, y); + break; + + default: + error ("gcd: invalid class combination for gcd: %s and %s\n", + a.class_name ().c_str (), b.class_name ().c_str ()); + } + + // For consistency. + if (! error_state && a.is_sparse_type () && b.is_sparse_type ()) + { + retval = retval.sparse_matrix_value (); + x = x.sparse_matrix_value (); + y = y.sparse_matrix_value (); + } + + if (btyp == btyp_float) + { + retval = retval.float_array_value (); + x = x.float_array_value (); + y = y.float_array_value (); + } + + return retval; +} + +DEFUN (gcd, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{g} =} gcd (@var{a1}, @var{a2}, @dots{})\n\ +@deftypefnx {Built-in Function} {[@var{g}, @var{v1}, @dots{}] =} gcd (@var{a1}, @var{a2}, @dots{})\n\ +\n\ +Compute the greatest common divisor of @var{a1}, @var{a2}, @dots{}. If more\n\ +than one argument is given all arguments must be the same size or scalar.\n\ +In this case the greatest common divisor is calculated for each element\n\ +individually. All elements must be ordinary or Gaussian (complex)\n\ +integers. Note that for Gaussian integers, the gcd is not unique up to\n\ +units (multiplication by 1, -1, @var{i} or -@var{i}), so an arbitrary\n\ +greatest common divisor amongst four possible is returned.\n\ +\n\ +Example code:\n\ +\n\ +@example\n\ +@group\n\ +gcd ([15, 9], [20, 18])\n\ + @result{} 5 9\n\ +@end group\n\ +@end example\n\ +\n\ +Optional return arguments @var{v1}, etc., contain integer vectors such\n\ +that,\n\ +\n\ +@tex\n\ +$g = v_1 a_1 + v_2 a_2 + \\cdots$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@var{g} = @var{v1} .* @var{a1} + @var{v2} .* @var{a2} + @dots{}\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +\n\ +@seealso{lcm, factor}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin > 1) + { + if (nargout > 1) + { + retval.resize (nargin + 1); + + retval(0) = do_extended_gcd (args(0), args(1), retval(1), retval(2)); + + for (int j = 2; j < nargin; j++) + { + octave_value x; + retval(0) = do_extended_gcd (retval(0), args(j), + x, retval(j+1)); + for (int i = 0; i < j; i++) + retval(i+1).assign (octave_value::op_el_mul_eq, x); + + if (error_state) + break; + } + } + else + { + retval(0) = do_simple_gcd (args(0), args(1)); + + for (int j = 2; j < nargin; j++) + { + retval(0) = do_simple_gcd (retval(0), args(j)); + + if (error_state) + break; + } + } + } + else + print_usage (); + + return retval; +} + +/* +%!assert (gcd (200, 300, 50, 35), 5) +%!assert (gcd (int16 (200), int16 (300), int16 (50), int16 (35)), int16 (5)) +%!assert (gcd (uint64 (200), uint64 (300), uint64 (50), uint64 (35)), uint64 (5)) +%!assert (gcd (18-i, -29+3i), -3-4i) + +%!error gcd () + +%!test +%! s.a = 1; +%! fail ("gcd (s)"); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/getgrent.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,215 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include <sys/types.h> + +#include "oct-group.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-map.h" +#include "ov.h" +#include "oct-obj.h" +#include "utils.h" + +// Group file functions. (Why not?) + +static octave_value +mk_gr_map (const octave_group& gr) +{ + octave_value retval; + + if (gr) + { + octave_scalar_map m; + + m.assign ("name", gr.name ()); + m.assign ("passwd", gr.passwd ()); + m.assign ("gid", static_cast<double> (gr.gid ())); + m.assign ("mem", octave_value (gr.mem ())); + + retval = m; + } + else + retval = 0; + + return retval; +} + +DEFUN (getgrent, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{grp_struct} =} getgrent ()\n\ +Return an entry from the group database, opening it if necessary.\n\ +Once the end of data has been reached, @code{getgrent} returns 0.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = 0; + + int nargin = args.length (); + + if (nargin == 0) + { + std::string msg; + + retval(1) = msg; + retval(0) = mk_gr_map (octave_group::getgrent (msg)); + } + else + print_usage (); + + return retval; +} + +DEFUN (getgrgid, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{grp_struct} =} getgrgid (@var{gid}).\n\ +Return the first entry from the group database with the group ID\n\ +@var{gid}. If the group ID does not exist in the database,\n\ +@code{getgrgid} returns 0.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = 0; + + int nargin = args.length (); + + if (nargin == 1) + { + double dval = args(0).double_value (); + + if (! error_state) + { + if (D_NINT (dval) == dval) + { + gid_t gid = static_cast<gid_t> (dval); + + std::string msg; + + retval(1) = msg; + retval(0) = mk_gr_map (octave_group::getgrgid (gid, msg)); + } + else + error ("getgrgid: GID must be an integer"); + } + } + else + print_usage (); + + return retval; +} + +DEFUN (getgrnam, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{grp_struct} =} getgrnam (@var{name})\n\ +Return the first entry from the group database with the group name\n\ +@var{name}. If the group name does not exist in the database,\n\ +@code{getgrnam} returns 0.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = 0; + + int nargin = args.length (); + + if (nargin == 1) + { + std::string s = args(0).string_value (); + + if (! error_state) + { + std::string msg; + + retval(1) = msg; + retval(0) = mk_gr_map (octave_group::getgrnam (s.c_str (), msg)); + } + } + else + print_usage (); + + return retval; +} + +DEFUN (setgrent, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} setgrent ()\n\ +Return the internal pointer to the beginning of the group database.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = -1.0; + + int nargin = args.length (); + + if (nargin == 0) + { + std::string msg; + + retval(1) = msg; + retval(0) = static_cast<double> (octave_group::setgrent (msg)); + } + else + print_usage (); + + return retval; +} + +DEFUN (endgrent, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} endgrent ()\n\ +Close the group database.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = -1.0; + + int nargin = args.length (); + + if (nargin == 0) + { + std::string msg; + + retval(1) = msg; + retval(0) = static_cast<double> (octave_group::endgrent (msg)); + } + else + print_usage (); + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/getpwent.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,219 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include <sys/types.h> + +#include "oct-passwd.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-map.h" +#include "ov.h" +#include "oct-obj.h" +#include "utils.h" + +// Password file functions. (Why not?) + +static octave_value +mk_pw_map (const octave_passwd& pw) +{ + octave_value retval; + + if (pw) + { + octave_scalar_map m; + + m.assign ("name", pw.name ()); + m.assign ("passwd", pw.passwd ()); + m.assign ("uid", static_cast<double> (pw.uid ())); + m.assign ("gid", static_cast<double> (pw.gid ())); + m.assign ("gecos", pw.gecos ()); + m.assign ("dir", pw.dir ()); + m.assign ("shell", pw.shell ()); + + retval = m; + } + else + retval = 0; + + return retval; +} + +DEFUN (getpwent, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{pw_struct} =} getpwent ()\n\ +Return a structure containing an entry from the password database,\n\ +opening it if necessary. Once the end of the data has been reached,\n\ +@code{getpwent} returns 0.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = 0; + + int nargin = args.length (); + + if (nargin == 0) + { + std::string msg; + + retval(1) = msg; + retval(0) = mk_pw_map (octave_passwd::getpwent (msg)); + } + else + print_usage (); + + return retval; +} + +DEFUN (getpwuid, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{pw_struct} =} getpwuid (@var{uid}).\n\ +Return a structure containing the first entry from the password database\n\ +with the user ID @var{uid}. If the user ID does not exist in the\n\ +database, @code{getpwuid} returns 0.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = 0; + + int nargin = args.length (); + + if (nargin == 1) + { + double dval = args(0).double_value (); + + if (! error_state) + { + if (D_NINT (dval) == dval) + { + uid_t uid = static_cast<uid_t> (dval); + + std::string msg; + + retval(1) = msg; + retval(0) = mk_pw_map (octave_passwd::getpwuid (uid, msg)); + } + else + error ("getpwuid: UID must be an integer"); + } + } + else + print_usage (); + + return retval; +} + +DEFUN (getpwnam, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{pw_struct} =} getpwnam (@var{name})\n\ +Return a structure containing the first entry from the password database\n\ +with the user name @var{name}. If the user name does not exist in the\n\ +database, @code{getpwname} returns 0.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = 0.0; + + int nargin = args.length (); + + if (nargin == 1) + { + std::string s = args(0).string_value (); + + if (! error_state) + { + std::string msg; + + retval(1) = msg; + retval(0) = mk_pw_map (octave_passwd::getpwnam (s, msg)); + } + } + else + print_usage (); + + return retval; +} + +DEFUN (setpwent, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} setpwent ()\n\ +Return the internal pointer to the beginning of the password database.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = -1.0; + + int nargin = args.length (); + + if (nargin == 0) + { + std::string msg; + + retval(1) = msg; + retval(0) = static_cast<double> (octave_passwd::setpwent (msg)); + } + else + print_usage (); + + return retval; +} + +DEFUN (endpwent, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} endpwent ()\n\ +Close the password database.\n\ +@end deftypefn") +{ + octave_value_list retval; + + retval(1) = std::string (); + retval(0) = -1.0; + + int nargin = args.length (); + + if (nargin == 0) + { + std::string msg; + + retval(1) = msg; + retval(0) = static_cast<double> (octave_passwd::endpwent (msg)); + } + else + print_usage (); + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/getrusage.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,205 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <sys/time.h> +#include <sys/times.h> +#include <sys/types.h> + +#ifdef HAVE_SYS_RESOURCE_H +#include <sys/resource.h> +#endif + +#if defined (HAVE_SYS_PARAM_H) +#include <sys/param.h> +#endif + +#include "defun.h" +#include "oct-map.h" +#include "sysdep.h" +#include "ov.h" +#include "oct-obj.h" +#include "utils.h" + +#if !defined (HZ) +#if defined (CLK_TCK) +#define HZ CLK_TCK +#elif defined (USG) +#define HZ 100 +#else +#define HZ 60 +#endif +#endif + +#ifndef RUSAGE_SELF +#define RUSAGE_SELF 0 +#endif + +// System resource functions. + +DEFUN (getrusage, , , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} getrusage ()\n\ +Return a structure containing a number of statistics about the current\n\ +Octave process. Not all fields are available on all systems. If it is\n\ +not possible to get CPU time statistics, the CPU time slots are set to\n\ +zero. Other missing data are replaced by NaN@. The list of possible\n\ +fields is:\n\ +\n\ +@table @code\n\ +@item idrss\n\ +Unshared data size.\n\ +\n\ +@item inblock\n\ +Number of block input operations.\n\ +\n\ +@item isrss\n\ +Unshared stack size.\n\ +\n\ +@item ixrss\n\ +Shared memory size.\n\ +\n\ +@item majflt\n\ +Number of major page faults.\n\ +\n\ +@item maxrss\n\ +Maximum data size.\n\ +\n\ +@item minflt\n\ +Number of minor page faults.\n\ +\n\ +@item msgrcv\n\ +Number of messages received.\n\ +\n\ +@item msgsnd\n\ +Number of messages sent.\n\ +\n\ +@item nivcsw\n\ +Number of involuntary context switches.\n\ +\n\ +@item nsignals\n\ +Number of signals received.\n\ +\n\ +@item nswap\n\ +Number of swaps.\n\ +\n\ +@item nvcsw\n\ +Number of voluntary context switches.\n\ +\n\ +@item oublock\n\ +Number of block output operations.\n\ +\n\ +@item stime\n\ +A structure containing the system CPU time used. The structure has the\n\ +elements @code{sec} (seconds) @code{usec} (microseconds).\n\ +\n\ +@item utime\n\ +A structure containing the user CPU time used. The structure has the\n\ +elements @code{sec} (seconds) @code{usec} (microseconds).\n\ +@end table\n\ +@end deftypefn") +{ + octave_scalar_map m; + octave_scalar_map tv_tmp; + + // FIXME -- maybe encapsulate all of this in a liboctave class +#if defined (HAVE_GETRUSAGE) + + struct rusage ru; + + getrusage (RUSAGE_SELF, &ru); + + tv_tmp.assign ("sec", static_cast<double> (ru.ru_utime.tv_sec)); + tv_tmp.assign ("usec", static_cast<double> (ru.ru_utime.tv_usec)); + m.assign ("utime", octave_value (tv_tmp)); + + tv_tmp.assign ("sec", static_cast<double> (ru.ru_stime.tv_sec)); + tv_tmp.assign ("usec", static_cast<double> (ru.ru_stime.tv_usec)); + m.assign ("stime", octave_value (tv_tmp)); + +#if ! defined (RUSAGE_TIMES_ONLY) + m.assign ("maxrss", static_cast<double> (ru.ru_maxrss)); + m.assign ("ixrss", static_cast<double> (ru.ru_ixrss)); + m.assign ("idrss", static_cast<double> (ru.ru_idrss)); + m.assign ("isrss", static_cast<double> (ru.ru_isrss)); + m.assign ("minflt", static_cast<double> (ru.ru_minflt)); + m.assign ("majflt", static_cast<double> (ru.ru_majflt)); + m.assign ("nswap", static_cast<double> (ru.ru_nswap)); + m.assign ("inblock", static_cast<double> (ru.ru_inblock)); + m.assign ("oublock", static_cast<double> (ru.ru_oublock)); + m.assign ("msgsnd", static_cast<double> (ru.ru_msgsnd)); + m.assign ("msgrcv", static_cast<double> (ru.ru_msgrcv)); + m.assign ("nsignals", static_cast<double> (ru.ru_nsignals)); + m.assign ("nvcsw", static_cast<double> (ru.ru_nvcsw)); + m.assign ("nivcsw", static_cast<double> (ru.ru_nivcsw)); +#endif + +#else + + struct tms t; + + times (&t); + + unsigned long ticks; + unsigned long seconds; + unsigned long fraction; + + ticks = t.tms_utime + t.tms_cutime; + fraction = ticks % HZ; + seconds = ticks / HZ; + + tv_tmp.assign ("sec", static_cast<double> (seconds)); + tv_tmp.assign ("usec", static_cast<double> (fraction * 1e6 / HZ)); + m.assign ("utime", octave_value (tv_tmp)); + + ticks = t.tms_stime + t.tms_cstime; + fraction = ticks % HZ; + seconds = ticks / HZ; + + tv_tmp.assign ("sec", static_cast<double> (seconds)); + tv_tmp.assign ("usec", static_cast<double> (fraction * 1e6 / HZ)); + m.assign ("stime", octave_value (tv_tmp)); + + double tmp = lo_ieee_nan_value (); + + m.assign ("maxrss", tmp); + m.assign ("ixrss", tmp); + m.assign ("idrss", tmp); + m.assign ("isrss", tmp); + m.assign ("minflt", tmp); + m.assign ("majflt", tmp); + m.assign ("nswap", tmp); + m.assign ("inblock", tmp); + m.assign ("oublock", tmp); + m.assign ("msgsnd", tmp); + m.assign ("msgrcv", tmp); + m.assign ("nsignals", tmp); + m.assign ("nvcsw", tmp); + m.assign ("nivcsw", tmp); + +#endif + + return octave_value (m); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/givens.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,214 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Originally written by A. S. Hodel <scotte@eng.auburn.edu> + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" + +DEFUN (givens, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{g} =} givens (@var{x}, @var{y})\n\ +@deftypefnx {Built-in Function} {[@var{c}, @var{s}] =} givens (@var{x}, @var{y})\n\ +@tex\n\ +Return a $2\\times 2$ orthogonal matrix\n\ +$$\n\ + G = \\left[\\matrix{c & s\\cr -s'& c\\cr}\\right]\n\ +$$\n\ +such that\n\ +$$\n\ + G \\left[\\matrix{x\\cr y}\\right] = \\left[\\matrix{\\ast\\cr 0}\\right]\n\ +$$\n\ +with $x$ and $y$ scalars.\n\ +@end tex\n\ +@ifnottex\n\ +Return a 2 by 2 orthogonal matrix\n\ +@code{@var{g} = [@var{c} @var{s}; -@var{s}' @var{c}]} such that\n\ +@code{@var{g} [@var{x}; @var{y}] = [*; 0]} with @var{x} and @var{y} scalars.\n\ +@end ifnottex\n\ +\n\ +For example:\n\ +\n\ +@example\n\ +@group\n\ +givens (1, 1)\n\ + @result{} 0.70711 0.70711\n\ + -0.70711 0.70711\n\ +@end group\n\ +@end example\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin != 2 || nargout > 2) + { + print_usage (); + return retval; + } + else + { + if (args(0).is_single_type () || args(1).is_single_type ()) + { + if (args(0).is_complex_type () || args(1).is_complex_type ()) + { + FloatComplex cx = args(0).float_complex_value (); + FloatComplex cy = args(1).float_complex_value (); + + if (! error_state) + { + FloatComplexMatrix result = Givens (cx, cy); + + if (! error_state) + { + switch (nargout) + { + case 0: + case 1: + retval(0) = result; + break; + + case 2: + retval(1) = result (0, 1); + retval(0) = result (0, 0); + break; + + default: + error ("givens: invalid number of output arguments"); + break; + } + } + } + } + else + { + float x = args(0).float_value (); + float y = args(1).float_value (); + + if (! error_state) + { + FloatMatrix result = Givens (x, y); + + if (! error_state) + { + switch (nargout) + { + case 0: + case 1: + retval(0) = result; + break; + + case 2: + retval(1) = result (0, 1); + retval(0) = result (0, 0); + break; + + default: + error ("givens: invalid number of output arguments"); + break; + } + } + } + } + } + else + { + if (args(0).is_complex_type () || args(1).is_complex_type ()) + { + Complex cx = args(0).complex_value (); + Complex cy = args(1).complex_value (); + + if (! error_state) + { + ComplexMatrix result = Givens (cx, cy); + + if (! error_state) + { + switch (nargout) + { + case 0: + case 1: + retval(0) = result; + break; + + case 2: + retval(1) = result (0, 1); + retval(0) = result (0, 0); + break; + + default: + error ("givens: invalid number of output arguments"); + break; + } + } + } + } + else + { + double x = args(0).double_value (); + double y = args(1).double_value (); + + if (! error_state) + { + Matrix result = Givens (x, y); + + if (! error_state) + { + switch (nargout) + { + case 0: + case 1: + retval(0) = result; + break; + + case 2: + retval(1) = result (0, 1); + retval(0) = result (0, 0); + break; + + default: + error ("givens: invalid number of output arguments"); + break; + } + } + } + } + } + } + + return retval; +} + +/* +%!assert (givens (1,1), [1, 1; -1, 1] / sqrt (2), 2*eps) +%!assert (givens (1,0), eye (2)) +%!assert (givens (0,1), [0, 1; -1 0]) + +%!error givens () +%!error givens (1) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/hess.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,189 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "CmplxHESS.h" +#include "dbleHESS.h" +#include "fCmplxHESS.h" +#include "floatHESS.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (hess, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{H} =} hess (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{P}, @var{H}] =} hess (@var{A})\n\ +@cindex Hessenberg decomposition\n\ +Compute the Hessenberg decomposition of the matrix @var{A}.\n\ +\n\ +The Hessenberg decomposition is\n\ +@tex\n\ +$$\n\ +A = PHP^T\n\ +$$\n\ +where $P$ is a square unitary matrix ($P^TP = I$), and $H$\n\ +is upper Hessenberg ($H_{i,j} = 0, \\forall i \\ge j+1$).\n\ +@end tex\n\ +@ifnottex\n\ +@code{@var{P} * @var{H} * @var{P}' = @var{A}} where @var{P} is a square\n\ +unitary matrix (@code{@var{P}' * @var{P} = I}, using complex-conjugate\n\ +transposition) and @var{H} is upper Hessenberg\n\ +(@code{@var{H}(i, j) = 0 forall i >= j+1)}.\n\ +@end ifnottex\n\ +\n\ +The Hessenberg decomposition is usually used as the first step in an\n\ +eigenvalue computation, but has other applications as well (see Golub,\n\ +Nash, and Van Loan, IEEE Transactions on Automatic Control, 1979).\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin != 1 || nargout > 2) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + + octave_idx_type nr = arg.rows (); + octave_idx_type nc = arg.columns (); + + int arg_is_empty = empty_arg ("hess", nr, nc); + + if (arg_is_empty < 0) + return retval; + else if (arg_is_empty > 0) + return octave_value_list (2, Matrix ()); + + if (nr != nc) + { + gripe_square_matrix_required ("hess"); + return retval; + } + + if (arg.is_single_type ()) + { + if (arg.is_real_type ()) + { + FloatMatrix tmp = arg.float_matrix_value (); + + if (! error_state) + { + FloatHESS result (tmp); + + if (nargout <= 1) + retval(0) = result.hess_matrix (); + else + { + retval(1) = result.hess_matrix (); + retval(0) = result.unitary_hess_matrix (); + } + } + } + else if (arg.is_complex_type ()) + { + FloatComplexMatrix ctmp = arg.float_complex_matrix_value (); + + if (! error_state) + { + FloatComplexHESS result (ctmp); + + if (nargout <= 1) + retval(0) = result.hess_matrix (); + else + { + retval(1) = result.hess_matrix (); + retval(0) = result.unitary_hess_matrix (); + } + } + } + } + else + { + if (arg.is_real_type ()) + { + Matrix tmp = arg.matrix_value (); + + if (! error_state) + { + HESS result (tmp); + + if (nargout <= 1) + retval(0) = result.hess_matrix (); + else + { + retval(1) = result.hess_matrix (); + retval(0) = result.unitary_hess_matrix (); + } + } + } + else if (arg.is_complex_type ()) + { + ComplexMatrix ctmp = arg.complex_matrix_value (); + + if (! error_state) + { + ComplexHESS result (ctmp); + + if (nargout <= 1) + retval(0) = result.hess_matrix (); + else + { + retval(1) = result.hess_matrix (); + retval(0) = result.unitary_hess_matrix (); + } + } + } + else + { + gripe_wrong_type_arg ("hess", arg); + } + } + + return retval; +} + +/* +%!test +%! a = [1, 2, 3; 5, 4, 6; 8, 7, 9]; +%! [p, h] = hess (a); +%! assert (p * h * p', a, sqrt (eps)); + +%!test +%! a = single ([1, 2, 3; 5, 4, 6; 8, 7, 9]); +%! [p, h] = hess (a); +%! assert (p * h * p', a, sqrt (eps ("single"))); + +%!error hess () +%!error hess ([1, 2; 3, 4], 2) +%!error <argument must be a square matrix> hess ([1, 2; 3, 4; 5, 6]) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/hex2num.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,192 @@ +/* + +Copyright (C) 2008-2012 David Bateman + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <algorithm> + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (hex2num, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{n} =} hex2num (@var{s})\n\ +Typecast the 16 character hexadecimal character string to an IEEE 754\n\ +double precision number. If fewer than 16 characters are given the\n\ +strings are right padded with '0' characters.\n\ +\n\ +Given a string matrix, @code{hex2num} treats each row as a separate\n\ +number.\n\ +\n\ +@example\n\ +@group\n\ +hex2num ([\"4005bf0a8b145769\"; \"4024000000000000\"])\n\ + @result{} [2.7183; 10.000]\n\ +@end group\n\ +@end example\n\ +@seealso{num2hex, hex2dec, dec2hex}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value retval; + + if (nargin != 1) + print_usage (); + else + { + const charMatrix cmat = args(0).char_matrix_value (); + + if (cmat.columns () > 16) + error ("hex2num: S must be no more than 16 characters"); + else if (! error_state) + { + octave_idx_type nr = cmat.rows (); + octave_idx_type nc = cmat.columns (); + ColumnVector m (nr); + + for (octave_idx_type i = 0; i < nr; i++) + { + union + { + uint64_t ival; + double dval; + } num; + + num.ival = 0; + + for (octave_idx_type j = 0; j < nc; j++) + { + unsigned char ch = cmat.elem (i, j); + + if (isxdigit (ch)) + { + num.ival <<= 4; + if (ch >= 'a') + num.ival += static_cast<uint64_t> (ch - 'a' + 10); + else if (ch >= 'A') + num.ival += static_cast<uint64_t> (ch - 'A' + 10); + else + num.ival += static_cast<uint64_t> (ch - '0'); + } + else + { + error ("hex2num: illegal character found in string S"); + break; + } + } + + if (error_state) + break; + else + { + if (nc < 16) + num.ival <<= (16 - nc) * 4; + + m(i) = num.dval; + } + } + + if (! error_state) + retval = m; + } + } + + return retval; +} + +/* +%!assert (hex2num (["c00";"bff";"000";"3ff";"400"]), [-2:2]') +*/ + +DEFUN (num2hex, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{s} =} num2hex (@var{n})\n\ +Typecast a double precision number or vector to a 16 character hexadecimal\n\ +string of the IEEE 754 representation of the number. For example:\n\ +\n\ +@example\n\ +@group\n\ +num2hex ([-1, 1, e, Inf, NaN, NA])\n\ +@result{} \"bff0000000000000\n\ + 3ff0000000000000\n\ + 4005bf0a8b145769\n\ + 7ff0000000000000\n\ + fff8000000000000\n\ + 7ff00000000007a2\"\n\ +@end group\n\ +@end example\n\ +@seealso{hex2num, hex2dec, dec2hex}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value retval; + + if (nargin != 1) + print_usage (); + else + { + const ColumnVector v (args(0).vector_value ()); + + if (! error_state) + { + octave_idx_type nr = v.length (); + charMatrix m (nr, 16); + const double *pv = v.fortran_vec (); + + for (octave_idx_type i = 0; i < nr; i++) + { + union + { + uint64_t ival; + double dval; + } num; + + num.dval = *pv++; + + for (octave_idx_type j = 0; j < 16; j++) + { + unsigned char ch = + static_cast<char> (num.ival >> ((15 - j) * 4) & 0xF); + if (ch >= 10) + ch += 'a' - 10; + else + ch += '0'; + + m.elem (i, j) = ch; + } + } + + retval = m; + } + } + + return retval; +} + +/* +%!assert (num2hex (-2:2), ["c000000000000000";"bff0000000000000";"0000000000000000";"3ff0000000000000";"4000000000000000"]) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/inv.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,250 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ops.h" +#include "ov-re-diag.h" +#include "ov-cx-diag.h" +#include "ov-flt-re-diag.h" +#include "ov-flt-cx-diag.h" +#include "ov-perm.h" +#include "utils.h" + +DEFUN (inv, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{x} =} inv (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{x}, @var{rcond}] =} inv (@var{A})\n\ +Compute the inverse of the square matrix @var{A}. Return an estimate\n\ +of the reciprocal condition number if requested, otherwise warn of an\n\ +ill-conditioned matrix if the reciprocal condition number is small.\n\ +\n\ +In general it is best to avoid calculating the inverse of a matrix\n\ +directly. For example, it is both faster and more accurate to solve\n\ +systems of equations (@var{A}*@math{x} = @math{b}) with\n\ +@code{@var{y} = @var{A} \\ @math{b}}, rather than\n\ +@code{@var{y} = inv (@var{A}) * @math{b}}.\n\ +\n\ +If called with a sparse matrix, then in general @var{x} will be a full\n\ +matrix requiring significantly more storage. Avoid forming the inverse\n\ +of a sparse matrix if possible.\n\ +@seealso{ldivide, rdivide}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin != 1) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + + octave_idx_type nr = arg.rows (); + octave_idx_type nc = arg.columns (); + + int arg_is_empty = empty_arg ("inverse", nr, nc); + + if (arg_is_empty < 0) + return retval; + else if (arg_is_empty > 0) + return octave_value (Matrix ()); + + if (nr != nc) + { + gripe_square_matrix_required ("inverse"); + return retval; + } + + octave_value result; + octave_idx_type info; + double rcond = 0.0; + float frcond = 0.0; + bool isfloat = arg.is_single_type (); + + if (arg.is_diag_matrix ()) + { + rcond = 1.0; + frcond = 1.0f; + if (arg.is_complex_type ()) + { + if (isfloat) + { + result = arg.float_complex_diag_matrix_value ().inverse (info); + if (nargout > 1) + frcond = arg.float_complex_diag_matrix_value ().rcond (); + } + else + { + result = arg.complex_diag_matrix_value ().inverse (info); + if (nargout > 1) + rcond = arg.complex_diag_matrix_value ().rcond (); + } + } + else + { + if (isfloat) + { + result = arg.float_diag_matrix_value ().inverse (info); + if (nargout > 1) + frcond = arg.float_diag_matrix_value ().rcond (); + } + else + { + result = arg.diag_matrix_value ().inverse (info); + if (nargout > 1) + rcond = arg.diag_matrix_value ().rcond (); + } + } + } + else if (arg.is_perm_matrix ()) + { + rcond = 1.0; + info = 0; + result = arg.perm_matrix_value ().inverse (); + } + else if (isfloat) + { + if (arg.is_real_type ()) + { + FloatMatrix m = arg.float_matrix_value (); + if (! error_state) + { + MatrixType mattyp = args(0).matrix_type (); + result = m.inverse (mattyp, info, frcond, 1); + args(0).matrix_type (mattyp); + } + } + else if (arg.is_complex_type ()) + { + FloatComplexMatrix m = arg.float_complex_matrix_value (); + if (! error_state) + { + MatrixType mattyp = args(0).matrix_type (); + result = m.inverse (mattyp, info, frcond, 1); + args(0).matrix_type (mattyp); + } + } + } + else + { + if (arg.is_real_type ()) + { + if (arg.is_sparse_type ()) + { + SparseMatrix m = arg.sparse_matrix_value (); + if (! error_state) + { + MatrixType mattyp = args(0).matrix_type (); + result = m.inverse (mattyp, info, rcond, 1); + args(0).matrix_type (mattyp); + } + } + else + { + Matrix m = arg.matrix_value (); + if (! error_state) + { + MatrixType mattyp = args(0).matrix_type (); + result = m.inverse (mattyp, info, rcond, 1); + args(0).matrix_type (mattyp); + } + } + } + else if (arg.is_complex_type ()) + { + if (arg.is_sparse_type ()) + { + SparseComplexMatrix m = arg.sparse_complex_matrix_value (); + if (! error_state) + { + MatrixType mattyp = args(0).matrix_type (); + result = m.inverse (mattyp, info, rcond, 1); + args(0).matrix_type (mattyp); + } + } + else + { + ComplexMatrix m = arg.complex_matrix_value (); + if (! error_state) + { + MatrixType mattyp = args(0).matrix_type (); + result = m.inverse (mattyp, info, rcond, 1); + args(0).matrix_type (mattyp); + } + } + } + else + gripe_wrong_type_arg ("inv", arg); + } + + if (! error_state) + { + if (nargout > 1) + retval(1) = isfloat ? octave_value (frcond) : octave_value (rcond); + + retval(0) = result; + + volatile double xrcond = rcond; + xrcond += 1.0; + if (nargout < 2 && (info == -1 || xrcond == 1.0)) + warning ("inverse: matrix singular to machine precision, rcond = %g", + rcond); + } + + return retval; +} + +/* +%!assert (inv ([1, 2; 3, 4]), [-2, 1; 1.5, -0.5], sqrt (eps)) +%!assert (inv (single ([1, 2; 3, 4])), single ([-2, 1; 1.5, -0.5]), sqrt (eps ("single"))) + +%!error inv () +%!error inv ([1, 2; 3, 4], 2) +%!error <argument must be a square matrix> inv ([1, 2; 3, 4; 5, 6]) +*/ + +// FIXME -- this should really be done with an alias, but +// alias_builtin() won't do the right thing if we are actually using +// dynamic linking. + +DEFUN (inverse, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{x} =} inverse (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{x}, @var{rcond}] =} inverse (@var{A})\n\ +Compute the inverse of the square matrix @var{A}.\n\ +\n\ +This is an alias for @code{inv}.\n\ +@seealso{inv}\n\ +@end deftypefn") +{ + return Finv (args, nargout); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/kron.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,321 @@ +/* + +Copyright (C) 2002-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Author: Paul Kienzle <pkienzle@users.sf.net> + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "dMatrix.h" +#include "fMatrix.h" +#include "CMatrix.h" +#include "fCMatrix.h" + +#include "dSparse.h" +#include "CSparse.h" + +#include "dDiagMatrix.h" +#include "fDiagMatrix.h" +#include "CDiagMatrix.h" +#include "fCDiagMatrix.h" + +#include "PermMatrix.h" + +#include "mx-inlines.cc" +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" + +template <class R, class T> +static MArray<T> +kron (const MArray<R>& a, const MArray<T>& b) +{ + assert (a.ndims () == 2); + assert (b.ndims () == 2); + + octave_idx_type nra = a.rows (), nrb = b.rows (); + octave_idx_type nca = a.cols (), ncb = b.cols (); + + MArray<T> c (dim_vector (nra*nrb, nca*ncb)); + T *cv = c.fortran_vec (); + + for (octave_idx_type ja = 0; ja < nca; ja++) + for (octave_idx_type jb = 0; jb < ncb; jb++) + for (octave_idx_type ia = 0; ia < nra; ia++) + { + octave_quit (); + mx_inline_mul (nrb, cv, a(ia, ja), b.data () + nrb*jb); + cv += nrb; + } + + return c; +} + +template <class R, class T> +static MArray<T> +kron (const MDiagArray2<R>& a, const MArray<T>& b) +{ + assert (b.ndims () == 2); + + octave_idx_type nra = a.rows (), nrb = b.rows (), dla = a.diag_length (); + octave_idx_type nca = a.cols (), ncb = b.cols (); + + MArray<T> c (dim_vector (nra*nrb, nca*ncb), T ()); + + for (octave_idx_type ja = 0; ja < dla; ja++) + for (octave_idx_type jb = 0; jb < ncb; jb++) + { + octave_quit (); + mx_inline_mul (nrb, &c.xelem (ja*nrb, ja*ncb + jb), a.dgelem (ja), b.data () + nrb*jb); + } + + return c; +} + +template <class T> +static MSparse<T> +kron (const MSparse<T>& A, const MSparse<T>& B) +{ + octave_idx_type idx = 0; + MSparse<T> C (A.rows () * B.rows (), A.columns () * B.columns (), + A.nnz () * B.nnz ()); + + C.cidx (0) = 0; + + for (octave_idx_type Aj = 0; Aj < A.columns (); Aj++) + for (octave_idx_type Bj = 0; Bj < B.columns (); Bj++) + { + octave_quit (); + for (octave_idx_type Ai = A.cidx (Aj); Ai < A.cidx (Aj+1); Ai++) + { + octave_idx_type Ci = A.ridx (Ai) * B.rows (); + const T v = A.data (Ai); + + for (octave_idx_type Bi = B.cidx (Bj); Bi < B.cidx (Bj+1); Bi++) + { + C.data (idx) = v * B.data (Bi); + C.ridx (idx++) = Ci + B.ridx (Bi); + } + } + C.cidx (Aj * B.columns () + Bj + 1) = idx; + } + + return C; +} + +static PermMatrix +kron (const PermMatrix& a, const PermMatrix& b) +{ + octave_idx_type na = a.rows (), nb = b.rows (); + const octave_idx_type *pa = a.data (), *pb = b.data (); + PermMatrix c(na*nb); // Row permutation. + octave_idx_type *pc = c.fortran_vec (); + + bool cola = a.is_col_perm (), colb = b.is_col_perm (); + if (cola && colb) + { + for (octave_idx_type i = 0; i < na; i++) + for (octave_idx_type j = 0; j < nb; j++) + pc[pa[i]*nb+pb[j]] = i*nb+j; + } + else if (cola) + { + for (octave_idx_type i = 0; i < na; i++) + for (octave_idx_type j = 0; j < nb; j++) + pc[pa[i]*nb+j] = i*nb+pb[j]; + } + else if (colb) + { + for (octave_idx_type i = 0; i < na; i++) + for (octave_idx_type j = 0; j < nb; j++) + pc[i*nb+pb[j]] = pa[i]*nb+j; + } + else + { + for (octave_idx_type i = 0; i < na; i++) + for (octave_idx_type j = 0; j < nb; j++) + pc[i*nb+j] = pa[i]*nb+pb[j]; + } + + return c; +} + +template <class MTA, class MTB> +octave_value +do_kron (const octave_value& a, const octave_value& b) +{ + MTA am = octave_value_extract<MTA> (a); + MTB bm = octave_value_extract<MTB> (b); + return octave_value (kron (am, bm)); +} + +octave_value +dispatch_kron (const octave_value& a, const octave_value& b) +{ + octave_value retval; + if (a.is_perm_matrix () && b.is_perm_matrix ()) + retval = do_kron<PermMatrix, PermMatrix> (a, b); + else if (a.is_diag_matrix ()) + { + if (b.is_diag_matrix () && a.rows () == a.columns () + && b.rows () == b.columns ()) + { + // We have two diagonal matrices, the product of those will be + // another diagonal matrix. To do that efficiently, extract + // the diagonals as vectors and compute the product. That + // will be another vector, which we then use to construct a + // diagonal matrix object. Note that this will fail if our + // digaonal matrix object is modified to allow the non-zero + // values to be stored off of the principal diagonal (i.e., if + // diag ([1,2], 3) is modified to return a diagonal matrix + // object instead of a full matrix object). + + octave_value tmp = dispatch_kron (a.diag (), b.diag ()); + retval = tmp.diag (); + } + else if (a.is_single_type () || b.is_single_type ()) + { + if (a.is_complex_type ()) + retval = do_kron<FloatComplexDiagMatrix, FloatComplexMatrix> (a, b); + else if (b.is_complex_type ()) + retval = do_kron<FloatDiagMatrix, FloatComplexMatrix> (a, b); + else + retval = do_kron<FloatDiagMatrix, FloatMatrix> (a, b); + } + else + { + if (a.is_complex_type ()) + retval = do_kron<ComplexDiagMatrix, ComplexMatrix> (a, b); + else if (b.is_complex_type ()) + retval = do_kron<DiagMatrix, ComplexMatrix> (a, b); + else + retval = do_kron<DiagMatrix, Matrix> (a, b); + } + } + else if (a.is_sparse_type () || b.is_sparse_type ()) + { + if (a.is_complex_type () || b.is_complex_type ()) + retval = do_kron<SparseComplexMatrix, SparseComplexMatrix> (a, b); + else + retval = do_kron<SparseMatrix, SparseMatrix> (a, b); + } + else if (a.is_single_type () || b.is_single_type ()) + { + if (a.is_complex_type ()) + retval = do_kron<FloatComplexMatrix, FloatComplexMatrix> (a, b); + else if (b.is_complex_type ()) + retval = do_kron<FloatMatrix, FloatComplexMatrix> (a, b); + else + retval = do_kron<FloatMatrix, FloatMatrix> (a, b); + } + else + { + if (a.is_complex_type ()) + retval = do_kron<ComplexMatrix, ComplexMatrix> (a, b); + else if (b.is_complex_type ()) + retval = do_kron<Matrix, ComplexMatrix> (a, b); + else + retval = do_kron<Matrix, Matrix> (a, b); + } + return retval; +} + + +DEFUN (kron, args, , "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} kron (@var{A}, @var{B})\n\ +@deftypefnx {Built-in Function} {} kron (@var{A1}, @var{A2}, @dots{})\n\ +Form the Kronecker product of two or more matrices, defined block by \n\ +block as\n\ +\n\ +@example\n\ +x = [ a(i,j)*b ]\n\ +@end example\n\ +\n\ +For example:\n\ +\n\ +@example\n\ +@group\n\ +kron (1:4, ones (3, 1))\n\ + @result{} 1 2 3 4\n\ + 1 2 3 4\n\ + 1 2 3 4\n\ +@end group\n\ +@end example\n\ +\n\ +If there are more than two input arguments @var{A1}, @var{A2}, @dots{}, \n\ +@var{An} the Kronecker product is computed as\n\ +\n\ +@example\n\ +kron (kron (@var{A1}, @var{A2}), @dots{}, @var{An})\n\ +@end example\n\ +\n\ +@noindent\n\ +Since the Kronecker product is associative, this is well-defined.\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin >= 2) + { + octave_value a = args(0), b = args(1); + retval = dispatch_kron (a, b); + for (octave_idx_type i = 2; i < nargin; i++) + retval = dispatch_kron (retval, args(i)); + } + else + print_usage (); + + return retval; +} + + +/* +%!test +%! x = ones (2); +%! assert (kron (x, x), ones (4)); + +%!shared x, y, z +%! x = [1, 2]; +%! y = [-1, -2]; +%! z = [1, 2, 3, 4; 1, 2, 3, 4; 1, 2, 3, 4]; +%!assert (kron (1:4, ones (3, 1)), z) +%!assert (kron (x, y, z), kron (kron (x, y), z)) +%!assert (kron (x, y, z), kron (x, kron (y, z))) + +%!assert (kron (diag ([1, 2]), diag ([3, 4])), diag ([3, 4, 6, 8])) + +%% Test for two diag matrices. See the comments above in +%% dispatch_kron for this case. +%% +%!test +%! expected = zeros (16, 16); +%! expected (1, 11) = 3; +%! expected (2, 12) = 4; +%! expected (5, 15) = 6; +%! expected (6, 16) = 8; +%! assert (kron (diag ([1, 2], 2), diag ([3, 4], 2)), expected) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/lookup.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,397 @@ +/* + +Copyright (C) 2008-2012 VZLU Prague a.s., Czech Republic + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3 of the License, or (at +your option) any later version. + +Octave is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Author: Jaroslav Hajek <highegg@gmail.com> + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <cctype> +#include <functional> +#include <algorithm> + +#include "dNDArray.h" +#include "CNDArray.h" + +#include "Cell.h" +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ov.h" + +static +bool +contains_char (const std::string& str, char c) +{ + return (str.find (c) != std::string::npos + || str.find (std::toupper (c)) != std::string::npos); +} + +// case-insensitive character comparison functors +struct icmp_char_lt : public std::binary_function<char, char, bool> +{ + bool operator () (char x, char y) const + { return std::toupper (x) < std::toupper (y); } +}; + +struct icmp_char_gt : public std::binary_function<char, char, bool> +{ + bool operator () (char x, char y) const + { return std::toupper (x) > std::toupper (y); } +}; + +// FIXME -- maybe these should go elsewhere? +// FIXME -- are they even needed now? +// case-insensitive ascending comparator +#if 0 +static bool +stri_comp_lt (const std::string& a, const std::string& b) +{ + return std::lexicographical_compare (a.begin (), a.end (), + b.begin (), b.end (), + icmp_char_lt ()); +} + +// case-insensitive descending comparator +static bool +stri_comp_gt (const std::string& a, const std::string& b) +{ + return std::lexicographical_compare (a.begin (), a.end (), + b.begin (), b.end (), + icmp_char_gt ()); +} +#endif + +template <class T> +inline sortmode +get_sort_mode (const Array<T>& array, + typename octave_sort<T>::compare_fcn_type desc_comp + = octave_sort<T>::descending_compare) +{ + octave_idx_type n = array.numel (); + if (n > 1 && desc_comp (array (0), array (n-1))) + return DESCENDING; + else + return ASCENDING; +} + +// FIXME: perhaps there should be octave_value::lookup? +// The question is, how should it behave w.r.t. the second argument's type. +// We'd need a dispatch on two arguments. Hmmm... + +#define INT_ARRAY_LOOKUP(TYPE) \ + (table.is_ ## TYPE ## _type () && y.is_ ## TYPE ## _type ()) \ + retval = do_numeric_lookup (table.TYPE ## _array_value (), \ + y.TYPE ## _array_value (), \ + left_inf, right_inf, \ + match_idx, match_bool); +template <class ArrayT> +static octave_value +do_numeric_lookup (const ArrayT& array, const ArrayT& values, + bool left_inf, bool right_inf, + bool match_idx, bool match_bool) +{ + octave_value retval; + + Array<octave_idx_type> idx = array.lookup (values); + octave_idx_type n = array.numel (), nval = values.numel (); + + // Post-process. + if (match_bool) + { + boolNDArray match (idx.dims ()); + for (octave_idx_type i = 0; i < nval; i++) + { + octave_idx_type j = idx.xelem (i); + match.xelem (i) = j != 0 && values(i) == array(j-1); + } + + retval = match; + } + else if (match_idx || left_inf || right_inf) + { + if (match_idx) + { + NDArray ridx (idx.dims ()); + + for (octave_idx_type i = 0; i < nval; i++) + { + octave_idx_type j = idx.xelem (i); + ridx.xelem (i) = (j != 0 && values(i) == array(j-1)) ? j : 0; + } + + retval = ridx; + } + else if (left_inf && right_inf) + { + // Results in valid indices. Optimize using lazy index. + octave_idx_type zero = 0; + for (octave_idx_type i = 0; i < nval; i++) + { + octave_idx_type j = idx.xelem (i) - 1; + idx.xelem (i) = std::max (zero, std::min (j, n-2)); + } + + retval = idx_vector (idx); + } + else if (left_inf) + { + // Results in valid indices. Optimize using lazy index. + octave_idx_type zero = 0; + for (octave_idx_type i = 0; i < nval; i++) + { + octave_idx_type j = idx.xelem (i) - 1; + idx.xelem (i) = std::max (zero, j); + } + + retval = idx_vector (idx); + } + else if (right_inf) + { + NDArray ridx (idx.dims ()); + + for (octave_idx_type i = 0; i < nval; i++) + { + octave_idx_type j = idx.xelem (i); + ridx.xelem (i) = std::min (j, n-1); + } + + retval = ridx; + } + } + else + retval = idx; + + return retval; +} + +DEFUN (lookup, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{idx} =} lookup (@var{table}, @var{y})\n\ +@deftypefnx {Built-in Function} {@var{idx} =} lookup (@var{table}, @var{y}, @var{opt})\n\ +Lookup values in a sorted table. Usually used as a prelude to\n\ +interpolation.\n\ +\n\ +If table is increasing and @code{idx = lookup (table, y)}, then\n\ +@code{table(idx(i)) <= y(i) < table(idx(i+1))} for all @code{y(i)}\n\ +within the table. If @code{y(i) < table(1)} then\n\ +@code{idx(i)} is 0. If @code{y(i) >= table(end)} or @code{isnan (y(i))} then\n\ +@code{idx(i)} is @code{n}.\n\ +\n\ +If the table is decreasing, then the tests are reversed.\n\ +For non-strictly monotonic tables, empty intervals are always skipped.\n\ +The result is undefined if @var{table} is not monotonic, or if\n\ +@var{table} contains a NaN.\n\ +\n\ +The complexity of the lookup is O(M*log(N)) where N is the size of\n\ +@var{table} and M is the size of @var{y}. In the special case when @var{y}\n\ +is also sorted, the complexity is O(min(M*log(N),M+N)).\n\ +\n\ +@var{table} and @var{y} can also be cell arrays of strings\n\ +(or @var{y} can be a single string). In this case, string lookup\n\ +is performed using lexicographical comparison.\n\ +\n\ +If @var{opts} is specified, it must be a string with letters indicating\n\ +additional options.\n\ +\n\ +@table @code\n\ +@item m\n\ +@code{table(idx(i)) == val(i)} if @code{val(i)}\n\ +occurs in table; otherwise, @code{idx(i)} is zero.\n\ +\n\ +@item b\n\ +@code{idx(i)} is a logical 1 or 0, indicating whether\n\ +@code{val(i)} is contained in table or not.\n\ +\n\ +@item l\n\ +For numeric lookups\n\ +the leftmost subinterval shall be extended to infinity (i.e., all indices\n\ +at least 1)\n\ +\n\ +@item r\n\ +For numeric lookups\n\ +the rightmost subinterval shall be extended to infinity (i.e., all indices\n\ +at most n-1).\n\ +@end table\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 2 || nargin > 3 || (nargin == 3 && ! args(2).is_string ())) + { + print_usage (); + return retval; + } + + octave_value table = args(0), y = args(1); + if (table.ndims () > 2 || (table.columns () > 1 && table.rows () > 1)) + warning ("lookup: table is not a vector"); + + bool num_case = ((table.is_numeric_type () && y.is_numeric_type ()) + || (table.is_char_matrix () && y.is_char_matrix ())); + bool str_case = table.is_cellstr () && (y.is_string () || y.is_cellstr ()); + bool left_inf = false; + bool right_inf = false; + bool match_idx = false; + bool match_bool = false; + + if (nargin == 3) + { + std::string opt = args(2).string_value (); + left_inf = contains_char (opt, 'l'); + right_inf = contains_char (opt, 'r'); + match_idx = contains_char (opt, 'm'); + match_bool = contains_char (opt, 'b'); + if (opt.find_first_not_of ("lrmb") != std::string::npos) + { + error ("lookup: unrecognized option: %c", + opt[opt.find_first_not_of ("lrmb")]); + return retval; + } + } + + if ((match_idx || match_bool) && (left_inf || right_inf)) + error ("lookup: m, b cannot be specified with l or r"); + else if (match_idx && match_bool) + error ("lookup: only one of m or b can be specified"); + else if (str_case && (left_inf || right_inf)) + error ("lookup: l, r are not recognized for string lookups"); + + if (error_state) + return retval; + + if (num_case) + { + + // In the case of a complex array, absolute values will be used for compatibility + // (though it's not too meaningful). + + if (table.is_complex_type ()) + table = table.abs (); + + if (y.is_complex_type ()) + y = y.abs (); + + Array<octave_idx_type> idx; + + // PS: I learned this from data.cc + if INT_ARRAY_LOOKUP (int8) + else if INT_ARRAY_LOOKUP (int16) + else if INT_ARRAY_LOOKUP (int32) + else if INT_ARRAY_LOOKUP (int64) + else if INT_ARRAY_LOOKUP (uint8) + else if INT_ARRAY_LOOKUP (uint16) + else if INT_ARRAY_LOOKUP (uint32) + else if INT_ARRAY_LOOKUP (uint64) + else if (table.is_char_matrix () && y.is_char_matrix ()) + retval = do_numeric_lookup (table.char_array_value (), + y.char_array_value (), + left_inf, right_inf, + match_idx, match_bool); + else if (table.is_single_type () || y.is_single_type ()) + retval = do_numeric_lookup (table.float_array_value (), + y.float_array_value (), + left_inf, right_inf, + match_idx, match_bool); + else + retval = do_numeric_lookup (table.array_value (), + y.array_value (), + left_inf, right_inf, + match_idx, match_bool); + + } + else if (str_case) + { + Array<std::string> str_table = table.cellstr_value (); + Array<std::string> str_y (dim_vector (1, 1)); + + if (y.is_cellstr ()) + str_y = y.cellstr_value (); + else + str_y(0) = y.string_value (); + + Array<octave_idx_type> idx = str_table.lookup (str_y); + octave_idx_type nval = str_y.numel (); + + // Post-process. + if (match_bool) + { + boolNDArray match (idx.dims ()); + for (octave_idx_type i = 0; i < nval; i++) + { + octave_idx_type j = idx.xelem (i); + match.xelem (i) = j != 0 && str_y(i) == str_table(j-1); + } + + retval = match; + } + else if (match_idx) + { + NDArray ridx (idx.dims ()); + if (match_idx) + { + for (octave_idx_type i = 0; i < nval; i++) + { + octave_idx_type j = idx.xelem (i); + ridx.xelem (i) = (j != 0 && str_y(i) == str_table(j-1)) ? j : 0; + } + } + + retval = ridx; + } + else + retval = idx; + } + else + print_usage (); + + return retval; + +} + +/* +%!assert (lookup (1:3, 0.5), 0) # value before table +%!assert (lookup (1:3, 3.5), 3) # value after table error +%!assert (lookup (1:3, 1.5), 1) # value within table error +%!assert (lookup (1:3, [3,2,1]), [3,2,1]) +%!assert (lookup ([1:4]', [1.2, 3.5]'), [1, 3]') +%!assert (lookup ([1:4], [1.2, 3.5]'), [1, 3]') +%!assert (lookup ([1:4]', [1.2, 3.5]), [1, 3]) +%!assert (lookup ([1:4], [1.2, 3.5]), [1, 3]) +%!assert (lookup (1:3, [3, 2, 1]), [3, 2, 1]) +%!assert (lookup ([3:-1:1], [3.5, 3, 1.2, 2.5, 2.5]), [0, 1, 2, 1, 1]) +%!assert (isempty (lookup ([1:3], []))) +%!assert (isempty (lookup ([1:3]', []))) +%!assert (lookup (1:3, [1, 2; 3, 0.5]), [1, 2; 3, 0]) +%!assert (lookup (1:4, [1, 1.2; 3, 2.5], "m"), [1, 0; 3, 0]) +%!assert (lookup (4:-1:1, [1, 1.2; 3, 2.5], "m"), [4, 0; 2, 0]) +%!assert (lookup (1:4, [1, 1.2; 3, 2.5], "b"), logical ([1, 0; 3, 0])) +%!assert (lookup (4:-1:1, [1, 1.2; 3, 2.5], "b"), logical ([4, 0; 2, 0])) +%! +%!assert (lookup ({"apple","lemon","orange"}, {"banana","kiwi"; "ananas","mango"}), [1,1;0,2]) +%!assert (lookup ({"apple","lemon","orange"}, "potato"), 3) +%!assert (lookup ({"orange","lemon","apple"}, "potato"), 0) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/lsode.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,548 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include <iomanip> +#include <iostream> + +#include "LSODE.h" +#include "lo-mappers.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "ov-fcn.h" +#include "ov-cell.h" +#include "pager.h" +#include "pr-output.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" + +#include "LSODE-opts.cc" + +// Global pointer for user defined function required by lsode. +static octave_function *lsode_fcn; + +// Global pointer for optional user defined jacobian function used by lsode. +static octave_function *lsode_jac; + +// Have we warned about imaginary values returned from user function? +static bool warned_fcn_imaginary = false; +static bool warned_jac_imaginary = false; + +// Is this a recursive call? +static int call_depth = 0; + +ColumnVector +lsode_user_function (const ColumnVector& x, double t) +{ + ColumnVector retval; + + octave_value_list args; + args(1) = t; + args(0) = x; + + if (lsode_fcn) + { + octave_value_list tmp = lsode_fcn->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("lsode"); + return retval; + } + + if (tmp.length () > 0 && tmp(0).is_defined ()) + { + if (! warned_fcn_imaginary && tmp(0).is_complex_type ()) + { + warning ("lsode: ignoring imaginary part returned from user-supplied function"); + warned_fcn_imaginary = true; + } + + retval = ColumnVector (tmp(0).vector_value ()); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("lsode"); + } + else + gripe_user_supplied_eval ("lsode"); + } + + return retval; +} + +Matrix +lsode_user_jacobian (const ColumnVector& x, double t) +{ + Matrix retval; + + octave_value_list args; + args(1) = t; + args(0) = x; + + if (lsode_jac) + { + octave_value_list tmp = lsode_jac->do_multi_index_op (1, args); + + if (error_state) + { + gripe_user_supplied_eval ("lsode"); + return retval; + } + + if (tmp.length () > 0 && tmp(0).is_defined ()) + { + if (! warned_jac_imaginary && tmp(0).is_complex_type ()) + { + warning ("lsode: ignoring imaginary part returned from user-supplied jacobian function"); + warned_jac_imaginary = true; + } + + retval = tmp(0).matrix_value (); + + if (error_state || retval.length () == 0) + gripe_user_supplied_eval ("lsode"); + } + else + gripe_user_supplied_eval ("lsode"); + } + + return retval; +} + +#define LSODE_ABORT() \ + return retval + +#define LSODE_ABORT1(msg) \ + do \ + { \ + ::error ("lsode: " msg); \ + LSODE_ABORT (); \ + } \ + while (0) + +#define LSODE_ABORT2(fmt, arg) \ + do \ + { \ + ::error ("lsode: " fmt, arg); \ + LSODE_ABORT (); \ + } \ + while (0) + +DEFUN (lsode, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{x}, @var{istate}, @var{msg}] =} lsode (@var{fcn}, @var{x_0}, @var{t})\n\ +@deftypefnx {Built-in Function} {[@var{x}, @var{istate}, @var{msg}] =} lsode (@var{fcn}, @var{x_0}, @var{t}, @var{t_crit})\n\ +Solve the set of differential equations\n\ +@tex\n\ +$$ {dx \\over dt} = f (x, t) $$\n\ +with\n\ +$$ x(t_0) = x_0 $$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ +dx\n\ +-- = f (x, t)\n\ +dt\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +with\n\ +\n\ +@example\n\ +x(t_0) = x_0\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +The solution is returned in the matrix @var{x}, with each row\n\ +corresponding to an element of the vector @var{t}. The first element\n\ +of @var{t} should be @math{t_0} and should correspond to the initial\n\ +state of the system @var{x_0}, so that the first row of the output\n\ +is @var{x_0}.\n\ +\n\ +The first argument, @var{fcn}, is a string, inline, or function handle\n\ +that names the function @math{f} to call to compute the vector of right\n\ +hand sides for the set of equations. The function must have the form\n\ +\n\ +@example\n\ +@var{xdot} = f (@var{x}, @var{t})\n\ +@end example\n\ +\n\ +@noindent\n\ +in which @var{xdot} and @var{x} are vectors and @var{t} is a scalar.\n\ +\n\ +If @var{fcn} is a two-element string array or a two-element cell array\n\ +of strings, inline functions, or function handles, the first element names\n\ +the function @math{f} described above, and the second element names a\n\ +function to compute the Jacobian of @math{f}. The Jacobian function\n\ +must have the form\n\ +\n\ +@example\n\ +@var{jac} = j (@var{x}, @var{t})\n\ +@end example\n\ +\n\ +@noindent\n\ +in which @var{jac} is the matrix of partial derivatives\n\ +@tex\n\ +$$ J = {\\partial f_i \\over \\partial x_j} = \\left[\\matrix{\n\ +{\\partial f_1 \\over \\partial x_1}\n\ + & {\\partial f_1 \\over \\partial x_2}\n\ + & \\cdots\n\ + & {\\partial f_1 \\over \\partial x_N} \\cr\n\ +{\\partial f_2 \\over \\partial x_1}\n\ + & {\\partial f_2 \\over \\partial x_2}\n\ + & \\cdots\n\ + & {\\partial f_2 \\over \\partial x_N} \\cr\n\ + \\vdots & \\vdots & \\ddots & \\vdots \\cr\n\ +{\\partial f_3 \\over \\partial x_1}\n\ + & {\\partial f_3 \\over \\partial x_2}\n\ + & \\cdots\n\ + & {\\partial f_3 \\over \\partial x_N} \\cr}\\right]$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ + | df_1 df_1 df_1 |\n\ + | ---- ---- ... ---- |\n\ + | dx_1 dx_2 dx_N |\n\ + | |\n\ + | df_2 df_2 df_2 |\n\ + | ---- ---- ... ---- |\n\ + df_i | dx_1 dx_2 dx_N |\n\ +jac = ---- = | |\n\ + dx_j | . . . . |\n\ + | . . . . |\n\ + | . . . . |\n\ + | |\n\ + | df_N df_N df_N |\n\ + | ---- ---- ... ---- |\n\ + | dx_1 dx_2 dx_N |\n\ +@end group\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +\n\ +The second and third arguments specify the initial state of the system,\n\ +@math{x_0}, and the initial value of the independent variable @math{t_0}.\n\ +\n\ +The fourth argument is optional, and may be used to specify a set of\n\ +times that the ODE solver should not integrate past. It is useful for\n\ +avoiding difficulties with singularities and points where there is a\n\ +discontinuity in the derivative.\n\ +\n\ +After a successful computation, the value of @var{istate} will be 2\n\ +(consistent with the Fortran version of @sc{lsode}).\n\ +\n\ +If the computation is not successful, @var{istate} will be something\n\ +other than 2 and @var{msg} will contain additional information.\n\ +\n\ +You can use the function @code{lsode_options} to set optional\n\ +parameters for @code{lsode}.\n\ +@seealso{daspk, dassl, dasrt}\n\ +@end deftypefn") +{ + octave_value_list retval; + + warned_fcn_imaginary = false; + warned_jac_imaginary = false; + + unwind_protect frame; + + frame.protect_var (call_depth); + call_depth++; + + if (call_depth > 1) + LSODE_ABORT1 ("invalid recursive call"); + + int nargin = args.length (); + + if (nargin > 2 && nargin < 5 && nargout < 4) + { + std::string fcn_name, fname, jac_name, jname; + lsode_fcn = 0; + lsode_jac = 0; + + octave_value f_arg = args(0); + + if (f_arg.is_cell ()) + { + Cell c = f_arg.cell_value (); + if (c.length () == 1) + f_arg = c(0); + else if (c.length () == 2) + { + if (c(0).is_function_handle () || c(0).is_inline_function ()) + lsode_fcn = c(0).function_value (); + else + { + fcn_name = unique_symbol_name ("__lsode_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, t) y = "); + lsode_fcn = extract_function + (c(0), "lsode", fcn_name, fname, "; endfunction"); + } + + if (lsode_fcn) + { + if (c(1).is_function_handle () || c(1).is_inline_function ()) + lsode_jac = c(1).function_value (); + else + { + jac_name = unique_symbol_name ("__lsode_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, t) jac = "); + lsode_jac = extract_function + (c(1), "lsode", jac_name, jname, "; endfunction"); + + if (!lsode_jac) + { + if (fcn_name.length ()) + clear_function (fcn_name); + lsode_fcn = 0; + } + } + } + } + else + LSODE_ABORT1 ("incorrect number of elements in cell array"); + } + + if (!lsode_fcn && ! f_arg.is_cell ()) + { + if (f_arg.is_function_handle () || f_arg.is_inline_function ()) + lsode_fcn = f_arg.function_value (); + else + { + switch (f_arg.rows ()) + { + case 1: + do + { + fcn_name = unique_symbol_name ("__lsode_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, t) y = "); + lsode_fcn = extract_function + (f_arg, "lsode", fcn_name, fname, "; endfunction"); + } + while (0); + break; + + case 2: + { + string_vector tmp = f_arg.all_strings (); + + if (! error_state) + { + fcn_name = unique_symbol_name ("__lsode_fcn__"); + fname = "function y = "; + fname.append (fcn_name); + fname.append (" (x, t) y = "); + lsode_fcn = extract_function + (tmp(0), "lsode", fcn_name, fname, "; endfunction"); + + if (lsode_fcn) + { + jac_name = unique_symbol_name ("__lsode_jac__"); + jname = "function jac = "; + jname.append (jac_name); + jname.append (" (x, t) jac = "); + lsode_jac = extract_function + (tmp(1), "lsode", jac_name, jname, + "; endfunction"); + + if (!lsode_jac) + { + if (fcn_name.length ()) + clear_function (fcn_name); + lsode_fcn = 0; + } + } + } + } + break; + + default: + LSODE_ABORT1 + ("first arg should be a string or 2-element string array"); + } + } + } + + if (error_state || ! lsode_fcn) + LSODE_ABORT (); + + ColumnVector state (args(1).vector_value ()); + + if (error_state) + LSODE_ABORT1 ("expecting state vector as second argument"); + + ColumnVector out_times (args(2).vector_value ()); + + if (error_state) + LSODE_ABORT1 ("expecting output time vector as third argument"); + + ColumnVector crit_times; + + int crit_times_set = 0; + if (nargin > 3) + { + crit_times = ColumnVector (args(3).vector_value ()); + + if (error_state) + LSODE_ABORT1 ("expecting critical time vector as fourth argument"); + + crit_times_set = 1; + } + + double tzero = out_times (0); + + ODEFunc func (lsode_user_function); + if (lsode_jac) + func.set_jacobian_function (lsode_user_jacobian); + + LSODE ode (state, tzero, func); + + ode.set_options (lsode_opts); + + Matrix output; + if (crit_times_set) + output = ode.integrate (out_times, crit_times); + else + output = ode.integrate (out_times); + + if (fcn_name.length ()) + clear_function (fcn_name); + if (jac_name.length ()) + clear_function (jac_name); + + if (! error_state) + { + std::string msg = ode.error_message (); + + retval(2) = msg; + retval(1) = static_cast<double> (ode.integration_state ()); + + if (ode.integration_ok ()) + retval(0) = output; + else + { + retval(0) = Matrix (); + + if (nargout < 2) + error ("lsode: %s", msg.c_str ()); + } + } + } + else + print_usage (); + + return retval; +} + +/* + +## dassl-1.m +## +## Test lsode() function +## +## Author: David Billinghurst (David.Billinghurst@riotinto.com.au) +## Comalco Research and Technology +## 20 May 1998 +## +## Problem +## +## y1' = -y2, y1(0) = 1 +## y2' = y1, y2(0) = 0 +## +## Solution +## +## y1(t) = cos(t) +## y2(t) = sin(t) +## +%!function xdot = __f (x, t) +%! xdot = [-x(2); x(1)]; +%!endfunction +%!test +%! +%! x0 = [1; 0]; +%! xdot0 = [0; 1]; +%! t = (0:1:10)'; +%! +%! tol = 500 * lsode_options ("relative tolerance"); +%! +%! x = lsode ("__f", x0, t); +%! +%! y = [cos(t), sin(t)]; +%! +%! assert (x, y, tol); + +%!function xdotdot = __f (x, t) +%! xdotdot = [x(2); -x(1)]; +%!endfunction +%!test +%! +%! x0 = [1; 0]; +%! t = [0; 2*pi]; +%! tol = 100 * dassl_options ("relative tolerance"); +%! +%! x = lsode ("__f", x0, t); +%! +%! y = [1, 0; 1, 0]; +%! +%! assert (x, y, tol); + +%!function xdot = __f (x, t) +%! xdot = x; +%!endfunction +%!test +%! +%! x0 = 1; +%! t = [0; 1]; +%! tol = 100 * dassl_options ("relative tolerance"); +%! +%! x = lsode ("__f", x0, t); +%! +%! y = [1; e]; +%! +%! assert (x, y, tol); + +%!test +%! lsode_options ("absolute tolerance", eps); +%! assert (lsode_options ("absolute tolerance") == eps); + +%!error lsode_options ("foo", 1, 2) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/lu.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,857 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "CmplxLU.h" +#include "dbleLU.h" +#include "fCmplxLU.h" +#include "floatLU.h" +#include "SparseCmplxLU.h" +#include "SparsedbleLU.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" +#include "ov-re-sparse.h" +#include "ov-cx-sparse.h" + +template <class MT> +static octave_value +get_lu_l (const base_lu<MT>& fact) +{ + MT L = fact.L (); + if (L.is_square ()) + return octave_value (L, MatrixType (MatrixType::Lower)); + else + return L; +} + +template <class MT> +static octave_value +get_lu_u (const base_lu<MT>& fact) +{ + MT U = fact.U (); + if (U.is_square () && fact.regular ()) + return octave_value (U, MatrixType (MatrixType::Upper)); + else + return U; +} + +DEFUN (lu, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{L}, @var{U}] =} lu (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{L}, @var{U}, @var{P}] =} lu (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} lu (@var{S})\n\ +@deftypefnx {Built-in Function} {[@var{L}, @var{U}, @var{P}, @var{Q}, @var{R}] =} lu (@var{S})\n\ +@deftypefnx {Built-in Function} {[@dots{}] =} lu (@var{S}, @var{thres})\n\ +@deftypefnx {Built-in Function} {@var{y} =} lu (@dots{})\n\ +@deftypefnx {Built-in Function} {[@dots{}] =} lu (@dots{}, \"vector\")\n\ +@cindex LU decomposition\n\ +Compute the LU@tie{}decomposition of @var{A}. If @var{A} is full\n\ +subroutines from\n\ +@sc{lapack} are used and if @var{A} is sparse then @sc{umfpack} is used. The\n\ +result is returned in a permuted form, according to the optional return\n\ +value @var{P}. For example, given the matrix @code{a = [1, 2; 3, 4]},\n\ +\n\ +@example\n\ +[l, u, p] = lu (@var{a})\n\ +@end example\n\ +\n\ +@noindent\n\ +returns\n\ +\n\ +@example\n\ +@group\n\ +l =\n\ +\n\ + 1.00000 0.00000\n\ + 0.33333 1.00000\n\ +\n\ +u =\n\ +\n\ + 3.00000 4.00000\n\ + 0.00000 0.66667\n\ +\n\ +p =\n\ +\n\ + 0 1\n\ + 1 0\n\ +@end group\n\ +@end example\n\ +\n\ +The matrix is not required to be square.\n\ +\n\ +When called with two or three output arguments and a spare input matrix,\n\ +@code{lu} does not attempt to perform sparsity preserving column\n\ +permutations. Called with a fourth output argument, the sparsity\n\ +preserving column transformation @var{Q} is returned, such that\n\ +@code{@var{P} * @var{A} * @var{Q} = @var{L} * @var{U}}.\n\ +\n\ +Called with a fifth output argument and a sparse input matrix,\n\ +@code{lu} attempts to use a scaling factor @var{R} on the input matrix\n\ +such that\n\ +@code{@var{P} * (@var{R} \\ @var{A}) * @var{Q} = @var{L} * @var{U}}.\n\ +This typically leads to a sparser and more stable factorization.\n\ +\n\ +An additional input argument @var{thres}, that defines the pivoting\n\ +threshold can be given. @var{thres} can be a scalar, in which case\n\ +it defines the @sc{umfpack} pivoting tolerance for both symmetric and\n\ +unsymmetric cases. If @var{thres} is a 2-element vector, then the first\n\ +element defines the pivoting tolerance for the unsymmetric @sc{umfpack}\n\ +pivoting strategy and the second for the symmetric strategy. By default,\n\ +the values defined by @code{spparms} are used ([0.1, 0.001]).\n\ +\n\ +Given the string argument \"vector\", @code{lu} returns the values of @var{P}\n\ +and @var{Q} as vector values, such that for full matrix, @code{@var{A}\n\ +(@var{P},:) = @var{L} * @var{U}}, and @code{@var{R}(@var{P},:) * @var{A}\n\ +(:, @var{Q}) = @var{L} * @var{U}}.\n\ +\n\ +With two output arguments, returns the permuted forms of the upper and\n\ +lower triangular matrices, such that @code{@var{A} = @var{L} * @var{U}}.\n\ +With one output argument @var{y}, then the matrix returned by the @sc{lapack}\n\ +routines is returned. If the input matrix is sparse then the matrix @var{L}\n\ +is embedded into @var{U} to give a return value similar to the full case.\n\ +For both full and sparse matrices, @code{lu} loses the permutation\n\ +information.\n\ +@end deftypefn") +{ + octave_value_list retval; + int nargin = args.length (); + bool issparse = (nargin > 0 && args(0).is_sparse_type ()); + bool scale = (nargout == 5); + + if (nargin < 1 || (issparse && (nargin > 3 || nargout > 5)) + || (!issparse && (nargin > 2 || nargout > 3))) + { + print_usage (); + return retval; + } + + bool vecout = false; + Matrix thres; + + int n = 1; + while (n < nargin && ! error_state) + { + if (args (n).is_string ()) + { + std::string tmp = args(n++).string_value (); + + if (! error_state ) + { + if (tmp.compare ("vector") == 0) + vecout = true; + else + error ("lu: unrecognized string argument"); + } + } + else + { + Matrix tmp = args(n++).matrix_value (); + + if (! error_state ) + { + if (!issparse) + error ("lu: can not define pivoting threshold THRES for full matrices"); + else if (tmp.nelem () == 1) + { + thres.resize (1,2); + thres(0) = tmp(0); + thres(1) = tmp(0); + } + else if (tmp.nelem () == 2) + thres = tmp; + else + error ("lu: expecting 2-element vector for THRES"); + } + } + } + + octave_value arg = args(0); + + octave_idx_type nr = arg.rows (); + octave_idx_type nc = arg.columns (); + + int arg_is_empty = empty_arg ("lu", nr, nc); + + if (issparse) + { + if (arg_is_empty < 0) + return retval; + else if (arg_is_empty > 0) + return octave_value_list (5, SparseMatrix ()); + + ColumnVector Qinit; + if (nargout < 4) + { + Qinit.resize (nc); + for (octave_idx_type i = 0; i < nc; i++) + Qinit (i) = i; + } + + if (arg.is_real_type ()) + { + SparseMatrix m = arg.sparse_matrix_value (); + + switch (nargout) + { + case 0: + case 1: + case 2: + { + SparseLU fact (m, Qinit, thres, false, true); + + if (nargout < 2) + retval(0) = fact.Y (); + else + { + PermMatrix P = fact.Pr_mat (); + SparseMatrix L = P.transpose () * fact.L (); + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + + retval(0) = octave_value (L, + MatrixType (MatrixType::Permuted_Lower, + nr, fact.row_perm ())); + } + } + break; + + case 3: + { + SparseLU fact (m, Qinit, thres, false, true); + + if (vecout) + retval(2) = fact.Pr_vec (); + else + retval(2) = fact.Pr_mat (); + + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + break; + + case 4: + default: + { + SparseLU fact (m, thres, scale); + + if (scale) + retval(4) = fact.R (); + + if (vecout) + { + retval(3) = fact.Pc_vec (); + retval(2) = fact.Pr_vec (); + } + else + { + retval(3) = fact.Pc_mat (); + retval(2) = fact.Pr_mat (); + } + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + break; + } + } + else if (arg.is_complex_type ()) + { + SparseComplexMatrix m = arg.sparse_complex_matrix_value (); + + switch (nargout) + { + case 0: + case 1: + case 2: + { + SparseComplexLU fact (m, Qinit, thres, false, true); + + if (nargout < 2) + retval(0) = fact.Y (); + else + { + PermMatrix P = fact.Pr_mat (); + SparseComplexMatrix L = P.transpose () * fact.L (); + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + + retval(0) = octave_value (L, + MatrixType (MatrixType::Permuted_Lower, + nr, fact.row_perm ())); + } + } + break; + + case 3: + { + SparseComplexLU fact (m, Qinit, thres, false, true); + + if (vecout) + retval(2) = fact.Pr_vec (); + else + retval(2) = fact.Pr_mat (); + + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + break; + + case 4: + default: + { + SparseComplexLU fact (m, thres, scale); + + if (scale) + retval(4) = fact.R (); + + if (vecout) + { + retval(3) = fact.Pc_vec (); + retval(2) = fact.Pr_vec (); + } + else + { + retval(3) = fact.Pc_mat (); + retval(2) = fact.Pr_mat (); + } + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + break; + } + } + else + gripe_wrong_type_arg ("lu", arg); + } + else + { + if (arg_is_empty < 0) + return retval; + else if (arg_is_empty > 0) + return octave_value_list (3, Matrix ()); + + if (arg.is_real_type ()) + { + if (arg.is_single_type ()) + { + FloatMatrix m = arg.float_matrix_value (); + + if (! error_state) + { + FloatLU fact (m); + + switch (nargout) + { + case 0: + case 1: + retval(0) = fact.Y (); + break; + + case 2: + { + PermMatrix P = fact.P (); + FloatMatrix L = P.transpose () * fact.L (); + retval(1) = get_lu_u (fact); + retval(0) = L; + } + break; + + case 3: + default: + { + if (vecout) + retval(2) = fact.P_vec (); + else + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + break; + } + } + } + else + { + Matrix m = arg.matrix_value (); + + if (! error_state) + { + LU fact (m); + + switch (nargout) + { + case 0: + case 1: + retval(0) = fact.Y (); + break; + + case 2: + { + PermMatrix P = fact.P (); + Matrix L = P.transpose () * fact.L (); + retval(1) = get_lu_u (fact); + retval(0) = L; + } + break; + + case 3: + default: + { + if (vecout) + retval(2) = fact.P_vec (); + else + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + break; + } + } + } + } + else if (arg.is_complex_type ()) + { + if (arg.is_single_type ()) + { + FloatComplexMatrix m = arg.float_complex_matrix_value (); + + if (! error_state) + { + FloatComplexLU fact (m); + + switch (nargout) + { + case 0: + case 1: + retval(0) = fact.Y (); + break; + + case 2: + { + PermMatrix P = fact.P (); + FloatComplexMatrix L = P.transpose () * fact.L (); + retval(1) = get_lu_u (fact); + retval(0) = L; + } + break; + + case 3: + default: + { + if (vecout) + retval(2) = fact.P_vec (); + else + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + break; + } + } + } + else + { + ComplexMatrix m = arg.complex_matrix_value (); + + if (! error_state) + { + ComplexLU fact (m); + + switch (nargout) + { + case 0: + case 1: + retval(0) = fact.Y (); + break; + + case 2: + { + PermMatrix P = fact.P (); + ComplexMatrix L = P.transpose () * fact.L (); + retval(1) = get_lu_u (fact); + retval(0) = L; + } + break; + + case 3: + default: + { + if (vecout) + retval(2) = fact.P_vec (); + else + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + break; + } + } + } + } + else + gripe_wrong_type_arg ("lu", arg); + } + + return retval; +} + +/* +%!assert(lu ([1, 2; 3, 4]), [3, 4; 1/3, 2/3], eps); + +%!test +%! [l, u] = lu ([1, 2; 3, 4]); +%! assert (l, [1/3, 1; 1, 0], sqrt (eps)); +%! assert (u, [3, 4; 0, 2/3], sqrt (eps)); + +%!test +%! [l, u, p] = lu ([1, 2; 3, 4]); +%! assert (l, [1, 0; 1/3, 1], sqrt (eps)); +%! assert (u, [3, 4; 0, 2/3], sqrt (eps)); +%! assert (p(:,:), [0, 1; 1, 0], sqrt (eps)); + +%!test +%! [l, u, p] = lu ([1, 2; 3, 4], "vector"); +%! assert (l, [1, 0; 1/3, 1], sqrt (eps)); +%! assert (u, [3, 4; 0, 2/3], sqrt (eps)); +%! assert (p, [2;1], sqrt (eps)); + +%!test +%! [l, u, p] = lu ([1, 2; 3, 4; 5, 6]); +%! assert (l, [1, 0; 1/5, 1; 3/5, 1/2], sqrt (eps)); +%! assert (u, [5, 6; 0, 4/5], sqrt (eps)); +%! assert (p(:,:), [0, 0, 1; 1, 0, 0; 0 1 0], sqrt (eps)); + +%!assert (lu (single ([1, 2; 3, 4])), single ([3, 4; 1/3, 2/3]), eps ("single")) + +%!test +%! [l, u] = lu (single ([1, 2; 3, 4])); +%! assert (l, single ([1/3, 1; 1, 0]), sqrt (eps ("single"))); +%! assert (u, single ([3, 4; 0, 2/3]), sqrt (eps ("single"))); + +%!test +%! [l, u, p] = lu (single ([1, 2; 3, 4])); +%! assert (l, single ([1, 0; 1/3, 1]), sqrt (eps ("single"))); +%! assert (u, single ([3, 4; 0, 2/3]), sqrt (eps ("single"))); +%! assert (p(:,:), single ([0, 1; 1, 0]), sqrt (eps ("single"))); + +%!test +%! [l, u, p] = lu (single ([1, 2; 3, 4]), "vector"); +%! assert (l, single ([1, 0; 1/3, 1]), sqrt (eps ("single"))); +%! assert (u, single ([3, 4; 0, 2/3]), sqrt (eps ("single"))); +%! assert (p, single ([2;1]), sqrt (eps ("single"))); + +%!test +%! [l u p] = lu (single ([1, 2; 3, 4; 5, 6])); +%! assert (l, single ([1, 0; 1/5, 1; 3/5, 1/2]), sqrt (eps ("single"))); +%! assert (u, single ([5, 6; 0, 4/5]), sqrt (eps ("single"))); +%! assert (p(:,:), single ([0, 0, 1; 1, 0, 0; 0 1 0]), sqrt (eps ("single"))); + +%!error lu () +%!error <can not define pivoting threshold> lu ([1, 2; 3, 4], 2) +*/ + +static +bool check_lu_dims (const octave_value& l, const octave_value& u, + const octave_value& p) +{ + octave_idx_type m = l.rows (), k = u.rows (), n = u.columns (); + return ((l.ndims () == 2 && u.ndims () == 2 && k == l.columns ()) + && k == std::min (m, n) && + (p.is_undefined () || p.rows () == m)); +} + +DEFUN (luupdate, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{L}, @var{U}] =} luupdate (@var{L}, @var{U}, @var{x}, @var{y})\n\ +@deftypefnx {Built-in Function} {[@var{L}, @var{U}, @var{P}] =} luupdate (@var{L}, @var{U}, @var{P}, @var{x}, @var{y})\n\ +Given an LU@tie{}factorization of a real or complex matrix\n\ +@w{@var{A} = @var{L}*@var{U}}, @var{L}@tie{}lower unit trapezoidal and\n\ +@var{U}@tie{}upper trapezoidal, return the LU@tie{}factorization\n\ +of @w{@var{A} + @var{x}*@var{y}.'}, where @var{x} and @var{y} are\n\ +column vectors (rank-1 update) or matrices with equal number of columns\n\ +(rank-k update).\n\ +Optionally, row-pivoted updating can be used by supplying\n\ +a row permutation (pivoting) matrix @var{P};\n\ +in that case, an updated permutation matrix is returned.\n\ +Note that if @var{L}, @var{U}, @var{P} is a pivoted LU@tie{}factorization\n\ +as obtained by @code{lu}:\n\ +\n\ +@example\n\ +[@var{L}, @var{U}, @var{P}] = lu (@var{A});\n\ +@end example\n\ +\n\ +@noindent\n\ +then a factorization of @xcode{@var{A}+@var{x}*@var{y}.'} can be obtained\n\ +either as\n\ +\n\ +@example\n\ +[@var{L1}, @var{U1}] = lu (@var{L}, @var{U}, @var{P}*@var{x}, @var{y})\n\ +@end example\n\ +\n\ +@noindent\n\ +or\n\ +\n\ +@example\n\ +[@var{L1}, @var{U1}, @var{P1}] = lu (@var{L}, @var{U}, @var{P}, @var{x}, @var{y})\n\ +@end example\n\ +\n\ +The first form uses the unpivoted algorithm, which is faster, but less\n\ +stable. The second form uses a slower pivoted algorithm, which is more\n\ +stable.\n\ +\n\ +The matrix case is done as a sequence of rank-1 updates;\n\ +thus, for large enough k, it will be both faster and more accurate to\n\ +recompute the factorization from scratch.\n\ +@seealso{lu, qrupdate, cholupdate}\n\ +@end deftypefn") +{ + octave_idx_type nargin = args.length (); + octave_value_list retval; + + bool pivoted = nargin == 5; + + if (nargin != 4 && nargin != 5) + { + print_usage (); + return retval; + } + + octave_value argl = args(0); + octave_value argu = args(1); + octave_value argp = pivoted ? args(2) : octave_value (); + octave_value argx = args(2 + pivoted); + octave_value argy = args(3 + pivoted); + + if (argl.is_numeric_type () && argu.is_numeric_type () + && argx.is_numeric_type () && argy.is_numeric_type () + && (! pivoted || argp.is_perm_matrix ())) + { + if (check_lu_dims (argl, argu, argp)) + { + PermMatrix P = (pivoted + ? argp.perm_matrix_value () + : PermMatrix::eye (argl.rows ())); + + if (argl.is_real_type () + && argu.is_real_type () + && argx.is_real_type () + && argy.is_real_type ()) + { + // all real case + if (argl.is_single_type () + || argu.is_single_type () + || argx.is_single_type () + || argy.is_single_type ()) + { + FloatMatrix L = argl.float_matrix_value (); + FloatMatrix U = argu.float_matrix_value (); + FloatMatrix x = argx.float_matrix_value (); + FloatMatrix y = argy.float_matrix_value (); + + FloatLU fact (L, U, P); + if (pivoted) + fact.update_piv (x, y); + else + fact.update (x, y); + + if (pivoted) + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + else + { + Matrix L = argl.matrix_value (); + Matrix U = argu.matrix_value (); + Matrix x = argx.matrix_value (); + Matrix y = argy.matrix_value (); + + LU fact (L, U, P); + if (pivoted) + fact.update_piv (x, y); + else + fact.update (x, y); + + if (pivoted) + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + } + else + { + // complex case + if (argl.is_single_type () + || argu.is_single_type () + || argx.is_single_type () + || argy.is_single_type ()) + { + FloatComplexMatrix L = argl.float_complex_matrix_value (); + FloatComplexMatrix U = argu.float_complex_matrix_value (); + FloatComplexMatrix x = argx.float_complex_matrix_value (); + FloatComplexMatrix y = argy.float_complex_matrix_value (); + + FloatComplexLU fact (L, U, P); + if (pivoted) + fact.update_piv (x, y); + else + fact.update (x, y); + + if (pivoted) + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + else + { + ComplexMatrix L = argl.complex_matrix_value (); + ComplexMatrix U = argu.complex_matrix_value (); + ComplexMatrix x = argx.complex_matrix_value (); + ComplexMatrix y = argy.complex_matrix_value (); + + ComplexLU fact (L, U, P); + if (pivoted) + fact.update_piv (x, y); + else + fact.update (x, y); + + if (pivoted) + retval(2) = fact.P (); + retval(1) = get_lu_u (fact); + retval(0) = get_lu_l (fact); + } + } + } + else + error ("luupdate: dimension mismatch"); + } + else + error ("luupdate: L, U, X, and Y must be numeric"); + + return retval; +} + +/* +%!shared A, u, v, Ac, uc, vc +%! A = [0.091364 0.613038 0.999083; +%! 0.594638 0.425302 0.603537; +%! 0.383594 0.291238 0.085574; +%! 0.265712 0.268003 0.238409; +%! 0.669966 0.743851 0.445057 ]; +%! +%! u = [0.85082; +%! 0.76426; +%! 0.42883; +%! 0.53010; +%! 0.80683 ]; +%! +%! v = [0.98810; +%! 0.24295; +%! 0.43167 ]; +%! +%! Ac = [0.620405 + 0.956953i 0.480013 + 0.048806i 0.402627 + 0.338171i; +%! 0.589077 + 0.658457i 0.013205 + 0.279323i 0.229284 + 0.721929i; +%! 0.092758 + 0.345687i 0.928679 + 0.241052i 0.764536 + 0.832406i; +%! 0.912098 + 0.721024i 0.049018 + 0.269452i 0.730029 + 0.796517i; +%! 0.112849 + 0.603871i 0.486352 + 0.142337i 0.355646 + 0.151496i ]; +%! +%! uc = [0.20351 + 0.05401i; +%! 0.13141 + 0.43708i; +%! 0.29808 + 0.08789i; +%! 0.69821 + 0.38844i; +%! 0.74871 + 0.25821i ]; +%! +%! vc = [0.85839 + 0.29468i; +%! 0.20820 + 0.93090i; +%! 0.86184 + 0.34689i ]; +%! + +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (A); +%! [L,U] = luupdate (L,U,P*u,v); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - A - u*v.'), Inf) < norm (A)*1e1*eps); +%! +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (Ac); +%! [L,U] = luupdate (L,U,P*uc,vc); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - Ac - uc*vc.'), Inf) < norm (Ac)*1e1*eps); + +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (single (A)); +%! [L,U] = luupdate (L,U,P*single (u), single (v)); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - single (A) - single (u)*single (v).'), Inf) < norm (single (A))*1e1*eps ("single")); +%! +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (single (Ac)); +%! [L,U] = luupdate (L,U,P*single (uc),single (vc)); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - single (Ac) - single (uc)*single (vc).'), Inf) < norm (single (Ac))*1e1*eps ("single")); + +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (A); +%! [L,U,P] = luupdate (L,U,P,u,v); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - A - u*v.'), Inf) < norm (A)*1e1*eps); +%! +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (Ac); +%! [L,U,P] = luupdate (L,U,P,uc,vc); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - Ac - uc*vc.'), Inf) < norm (Ac)*1e1*eps); + +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (single (A)); +%! [L,U,P] = luupdate (L,U,P,single (u),single (v)); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - single (A) - single (u)*single (v).'), Inf) < norm (single (A))*1e1*eps ("single")); +%! +%!testif HAVE_QRUPDATE_LUU +%! [L,U,P] = lu (single (Ac)); +%! [L,U,P] = luupdate (L,U,P,single (uc),single (vc)); +%! assert (norm (vec (tril (L)-L), Inf) == 0); +%! assert (norm (vec (triu (U)-U), Inf) == 0); +%! assert (norm (vec (P'*L*U - single (Ac) - single (uc)*single (vc).'), Inf) < norm (single (Ac))*1e1*eps ("single")); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/luinc.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,383 @@ +/* + +Copyright (C) 2005-2012 David Bateman + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" +#include "oct-map.h" + +#include "MatrixType.h" +#include "SparseCmplxLU.h" +#include "SparsedbleLU.h" +#include "ov-re-sparse.h" +#include "ov-cx-sparse.h" + +DEFUN (luinc, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} luinc (@var{A}, '0')\n\ +@deftypefnx {Built-in Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} luinc (@var{A}, @var{droptol})\n\ +@deftypefnx {Built-in Function} {[@var{L}, @var{U}, @var{P}, @var{Q}] =} luinc (@var{A}, @var{opts})\n\ +@cindex LU decomposition\n\ +Produce the incomplete LU@tie{}factorization of the sparse matrix @var{A}.\n\ +Two types of incomplete factorization are possible, and the type\n\ +is determined by the second argument to @code{luinc}.\n\ +\n\ +Called with a second argument of '0', the zero-level incomplete\n\ +LU@tie{}factorization is produced. This creates a factorization of @var{A}\n\ +where the position of the non-zero arguments correspond to the same\n\ +positions as in the matrix @var{A}.\n\ +\n\ +Alternatively, the fill-in of the incomplete LU@tie{}factorization can\n\ +be controlled through the variable @var{droptol} or the structure\n\ +@var{opts}. The @sc{umfpack} multifrontal factorization code by Tim A.\n\ +Davis is used for the incomplete LU@tie{}factorization, (availability\n\ +@url{http://www.cise.ufl.edu/research/sparse/umfpack/})\n\ +\n\ +@var{droptol} determines the values below which the values in the\n\ +LU@tie{} factorization are dropped and replaced by zero. It must be a\n\ +positive scalar, and any values in the factorization whose absolute value\n\ +are less than this value are dropped, expect if leaving them increase the\n\ +sparsity of the matrix. Setting @var{droptol} to zero results in a complete\n\ +LU@tie{}factorization which is the default.\n\ +\n\ +@var{opts} is a structure containing one or more of the fields\n\ +\n\ +@table @code\n\ +@item droptol\n\ +The drop tolerance as above. If @var{opts} only contains @code{droptol}\n\ +then this is equivalent to using the variable @var{droptol}.\n\ +\n\ +@item milu\n\ +A logical variable flagging whether to use the modified incomplete\n\ +LU@tie{} factorization. In the case that @code{milu} is true, the dropped\n\ +values are subtracted from the diagonal of the matrix @var{U} of the\n\ +factorization. The default is @code{false}.\n\ +\n\ +@item udiag\n\ +A logical variable that flags whether zero elements on the diagonal of\n\ +@var{U} should be replaced with @var{droptol} to attempt to avoid singular\n\ +factors. The default is @code{false}.\n\ +\n\ +@item thresh\n\ +Defines the pivot threshold in the interval [0,1]. Values outside that\n\ +range are ignored.\n\ +@end table\n\ +\n\ +All other fields in @var{opts} are ignored. The outputs from @code{luinc}\n\ +are the same as for @code{lu}.\n\ +\n\ +Given the string argument \"vector\", @code{luinc} returns the values of\n\ +@var{p} @var{q} as vector values.\n\ +@seealso{sparse, lu}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value_list retval; + + if (nargin == 0) + print_usage (); + else if (nargin < 2 || nargin > 3) + error ("luinc: incorrect number of arguments"); + else + { + bool zero_level = false; + bool milu = false; + bool udiag = false; + Matrix thresh; + double droptol = -1.; + bool vecout = false; + + if (args(1).is_string ()) + { + if (args(1).string_value () == "0") + zero_level = true; + else + error ("luinc: unrecognized string argument"); + } + else if (args(1).is_map ()) + { + octave_scalar_map map = args(1).scalar_map_value (); + + if (! error_state) + { + octave_value tmp; + + tmp = map.getfield ("droptol"); + if (tmp.is_defined ()) + droptol = tmp.double_value (); + + tmp = map.getfield ("milu"); + if (tmp.is_defined ()) + { + double val = tmp.double_value (); + + milu = (val == 0. ? false : true); + } + + tmp = map.getfield ("udiag"); + if (tmp.is_defined ()) + { + double val = tmp.double_value (); + + udiag = (val == 0. ? false : true); + } + + tmp = map.getfield ("thresh"); + if (tmp.is_defined ()) + { + thresh = tmp.matrix_value (); + + if (thresh.nelem () == 1) + { + thresh.resize (1,2); + thresh(1) = thresh(0); + } + else if (thresh.nelem () != 2) + { + error ("luinc: expecting 2-element vector for thresh"); + return retval; + } + } + } + else + { + error ("luinc: OPTS must be a scalar structure"); + return retval; + } + } + else + droptol = args(1).double_value (); + + if (nargin == 3) + { + std::string tmp = args(2).string_value (); + + if (! error_state ) + { + if (tmp.compare ("vector") == 0) + vecout = true; + else + error ("luinc: unrecognized string argument"); + } + } + + // FIXME Add code for zero-level factorization + if (zero_level) + error ("luinc: zero-level factorization not implemented"); + + if (!error_state) + { + if (args(0).type_name () == "sparse matrix") + { + SparseMatrix sm = args(0).sparse_matrix_value (); + octave_idx_type sm_nr = sm.rows (); + octave_idx_type sm_nc = sm.cols (); + ColumnVector Qinit (sm_nc); + + for (octave_idx_type i = 0; i < sm_nc; i++) + Qinit (i) = i; + + if (! error_state) + { + switch (nargout) + { + case 0: + case 1: + case 2: + { + SparseLU fact (sm, Qinit, thresh, false, true, droptol, + milu, udiag); + + if (! error_state) + { + SparseMatrix P = fact.Pr (); + SparseMatrix L = P.transpose () * fact.L (); + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (L, MatrixType + (MatrixType::Permuted_Lower, + sm_nr, fact.row_perm ())); + } + } + break; + + case 3: + { + SparseLU fact (sm, Qinit, thresh, false, true, droptol, + milu, udiag); + + if (! error_state) + { + if (vecout) + retval(2) = fact.Pr_vec (); + else + retval(2) = fact.Pr_mat (); + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + } + break; + + case 4: + default: + { + SparseLU fact (sm, Qinit, thresh, false, false, droptol, + milu, udiag); + + if (! error_state) + { + if (vecout) + { + retval(3) = fact.Pc_vec (); + retval(2) = fact.Pr_vec (); + } + else + { + retval(3) = fact.Pc_mat (); + retval(2) = fact.Pr_mat (); + } + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + } + break; + } + } + } + else if (args(0).type_name () == "sparse complex matrix") + { + SparseComplexMatrix sm = + args(0).sparse_complex_matrix_value (); + octave_idx_type sm_nr = sm.rows (); + octave_idx_type sm_nc = sm.cols (); + ColumnVector Qinit (sm_nc); + + for (octave_idx_type i = 0; i < sm_nc; i++) + Qinit (i) = i; + + if (! error_state) + { + switch (nargout) + { + case 0: + case 1: + case 2: + { + SparseComplexLU fact (sm, Qinit, thresh, false, true, + droptol, milu, udiag); + + + if (! error_state) + { + SparseMatrix P = fact.Pr (); + SparseComplexMatrix L = P.transpose () * fact.L (); + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (L, MatrixType + (MatrixType::Permuted_Lower, + sm_nr, fact.row_perm ())); + } + } + break; + + case 3: + { + SparseComplexLU fact (sm, Qinit, thresh, false, true, + droptol, milu, udiag); + + if (! error_state) + { + if (vecout) + retval(2) = fact.Pr_vec (); + else + retval(2) = fact.Pr_mat (); + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + } + break; + + case 4: + default: + { + SparseComplexLU fact (sm, Qinit, thresh, false, false, + droptol, milu, udiag); + + if (! error_state) + { + if (vecout) + { + retval(3) = fact.Pc_vec (); + retval(2) = fact.Pr_vec (); + } + else + { + retval(3) = fact.Pc_mat (); + retval(2) = fact.Pr_mat (); + } + retval(1) = octave_value (fact.U (), + MatrixType (MatrixType::Upper)); + retval(0) = octave_value (fact.L (), + MatrixType (MatrixType::Lower)); + } + } + break; + } + } + } + else + error ("luinc: matrix A must be sparse"); + } + } + + return retval; +} + +/* +%!testif HAVE_UMFPACK +%! a = sparse ([1,2,0,0;0,1,2,0;1e-14,0,3,0;0,0,0,1]); +%! [l,u] = luinc (a, 1e-10); +%! assert (l*u, sparse ([1,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); +%! opts.droptol = 1e-10; +%! [l,u] = luinc (a, opts); +%! assert (l*u, sparse ([1,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); + +%!testif HAVE_UMFPACK +%! a = sparse ([1i,2,0,0;0,1,2,0;1e-14,0,3,0;0,0,0,1]); +%! [l,u] = luinc (a, 1e-10); +%! assert (l*u, sparse ([1i,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); +%! opts.droptol = 1e-10; +%! [l,u] = luinc (a, opts); +%! assert (l*u, sparse ([1i,2,0,0;0,1,2,0;0,0,3,0;0,0,0,1]), 1e-10); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/matrix_type.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,621 @@ +/* + +Copyright (C) 2005-2012 David Bateman + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <algorithm> + +#include "ov.h" +#include "defun.h" +#include "error.h" +#include "ov-re-mat.h" +#include "ov-cx-mat.h" +#include "ov-re-sparse.h" +#include "ov-cx-sparse.h" +#include "MatrixType.h" +#include "oct-locbuf.h" + +DEFUN (matrix_type, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{type} =} matrix_type (@var{A})\n\ +@deftypefnx {Built-in Function} {@var{type} =} matrix_type (@var{A}, \"nocompute\")\n\ +@deftypefnx {Built-in Function} {@var{A} =} matrix_type (@var{A}, @var{type})\n\ +@deftypefnx {Built-in Function} {@var{A} =} matrix_type (@var{A}, \"upper\", @var{perm})\n\ +@deftypefnx {Built-in Function} {@var{A} =} matrix_type (@var{A}, \"lower\", @var{perm})\n\ +@deftypefnx {Built-in Function} {@var{A} =} matrix_type (@var{A}, \"banded\", @var{nl}, @var{nu})\n\ +Identify the matrix type or mark a matrix as a particular type. This allows\n\ +more rapid solutions of linear equations involving @var{A} to be performed.\n\ +Called with a single argument, @code{matrix_type} returns the type of the\n\ +matrix and caches it for future use. Called with more than one argument,\n\ +@code{matrix_type} allows the type of the matrix to be defined.\n\ +\n\ +If the option \"nocompute\" is given, the function will not attempt to guess\n\ +the type if it is still unknown. This is useful for debugging purposes.\n\ +\n\ +The possible matrix types depend on whether the matrix is full or sparse, and\n\ +can be one of the following\n\ +\n\ +@table @asis\n\ +@item \"unknown\"\n\ +Remove any previously cached matrix type, and mark type as unknown.\n\ +\n\ +@item \"full\"\n\ +Mark the matrix as full.\n\ +\n\ +@item \"positive definite\"\n\ +Probable full positive definite matrix.\n\ +\n\ +@item \"diagonal\"\n\ +Diagonal matrix. (Sparse matrices only)\n\ +\n\ +@item \"permuted diagonal\"\n\ +Permuted Diagonal matrix. The permutation does not need to be specifically\n\ +indicated, as the structure of the matrix explicitly gives this. (Sparse\n\ +matrices only)\n\ +\n\ +@item \"upper\"\n\ +Upper triangular. If the optional third argument @var{perm} is given, the\n\ +matrix is assumed to be a permuted upper triangular with the permutations\n\ +defined by the vector @var{perm}.\n\ +\n\ +@item \"lower\"\n\ +Lower triangular. If the optional third argument @var{perm} is given, the\n\ +matrix is assumed to be a permuted lower triangular with the permutations\n\ +defined by the vector @var{perm}.\n\ +\n\ +@item \"banded\"\n\ +@itemx \"banded positive definite\"\n\ +Banded matrix with the band size of @var{nl} below the diagonal and @var{nu}\n\ +above it. If @var{nl} and @var{nu} are 1, then the matrix is tridiagonal and\n\ +treated with specialized code. In addition the matrix can be marked as\n\ +probably a positive definite. (Sparse matrices only)\n\ +\n\ +@item \"singular\"\n\ +The matrix is assumed to be singular and will be treated with a minimum norm\n\ +solution.\n\ +\n\ +@end table\n\ +\n\ +Note that the matrix type will be discovered automatically on the first\n\ +attempt to solve a linear equation involving @var{A}. Therefore\n\ +@code{matrix_type} is only useful to give Octave hints of the matrix type.\n\ +Incorrectly defining the matrix type will result in incorrect results from\n\ +solutions of linear equations; it is entirely @strong{the responsibility of\n\ +the user} to correctly identify the matrix type.\n\ +\n\ +Also, the test for positive definiteness is a low-cost test for a Hermitian\n\ +matrix with a real positive diagonal. This does not guarantee that the\n\ +matrix is positive definite, but only that it is a probable candidate. When\n\ +such a matrix is factorized, a Cholesky@tie{}factorization is first\n\ +attempted, and if that fails the matrix is then treated with an\n\ +LU@tie{}factorization. Once the matrix has been factorized,\n\ +@code{matrix_type} will return the correct classification of the matrix.\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value retval; + + if (nargin == 0) + print_usage (); + else if (nargin > 4) + error ("matrix_type: incorrect number of arguments"); + else + { + bool autocomp = true; + if (nargin == 2 && args(1).is_string () && args(1).string_value () == "nocompute") + { + nargin = 1; + autocomp = false; + } + + if (args(0).is_scalar_type ()) + { + if (nargin == 1) + retval = octave_value ("Diagonal"); + else + retval = args(0); + } + else if (args(0).is_sparse_type ()) + { + if (nargin == 1) + { + MatrixType mattyp; + + if (args(0).is_complex_type ()) + { + mattyp = args(0).matrix_type (); + + if (mattyp.is_unknown () && autocomp ) + { + SparseComplexMatrix m = + args(0).sparse_complex_matrix_value (); + if (!error_state) + { + mattyp = MatrixType (m); + args(0).matrix_type (mattyp); + } + } + } + else + { + mattyp = args(0).matrix_type (); + + if (mattyp.is_unknown () && autocomp) + { + SparseMatrix m = args(0).sparse_matrix_value (); + if (!error_state) + { + mattyp = MatrixType (m); + args(0).matrix_type (mattyp); + } + } + } + + int typ = mattyp.type (); + + if (typ == MatrixType::Diagonal) + retval = octave_value ("Diagonal"); + else if (typ == MatrixType::Permuted_Diagonal) + retval = octave_value ("Permuted Diagonal"); + else if (typ == MatrixType::Upper) + retval = octave_value ("Upper"); + else if (typ == MatrixType::Permuted_Upper) + retval = octave_value ("Permuted Upper"); + else if (typ == MatrixType::Lower) + retval = octave_value ("Lower"); + else if (typ == MatrixType::Permuted_Lower) + retval = octave_value ("Permuted Lower"); + else if (typ == MatrixType::Banded) + retval = octave_value ("Banded"); + else if (typ == MatrixType::Banded_Hermitian) + retval = octave_value ("Banded Positive Definite"); + else if (typ == MatrixType::Tridiagonal) + retval = octave_value ("Tridiagonal"); + else if (typ == MatrixType::Tridiagonal_Hermitian) + retval = octave_value ("Tridiagonal Positive Definite"); + else if (typ == MatrixType::Hermitian) + retval = octave_value ("Positive Definite"); + else if (typ == MatrixType::Rectangular) + { + if (args(0).rows () == args(0).columns ()) + retval = octave_value ("Singular"); + else + retval = octave_value ("Rectangular"); + } + else if (typ == MatrixType::Full) + retval = octave_value ("Full"); + else + retval = octave_value ("Unknown"); + } + else + { + // Ok, we're changing the matrix type + std::string str_typ = args(1).string_value (); + + // FIXME -- why do I have to explicitly call the constructor? + MatrixType mattyp = MatrixType (); + + octave_idx_type nl = 0; + octave_idx_type nu = 0; + + if (error_state) + error ("matrix_type: TYPE must be a string"); + else + { + // Use STL function to convert to lower case + std::transform (str_typ.begin (), str_typ.end (), + str_typ.begin (), tolower); + + if (str_typ == "diagonal") + mattyp.mark_as_diagonal (); + if (str_typ == "permuted diagonal") + mattyp.mark_as_permuted_diagonal (); + else if (str_typ == "upper") + mattyp.mark_as_upper_triangular (); + else if (str_typ == "lower") + mattyp.mark_as_lower_triangular (); + else if (str_typ == "banded" || str_typ == "banded positive definite") + { + if (nargin != 4) + error ("matrix_type: banded matrix type requires 4 arguments"); + else + { + nl = args(2).nint_value (); + nu = args(3).nint_value (); + + if (error_state) + error ("matrix_type: band size NL, NU must be integers"); + else + { + if (nl == 1 && nu == 1) + mattyp.mark_as_tridiagonal (); + else + mattyp.mark_as_banded (nu, nl); + + if (str_typ == "banded positive definite") + mattyp.mark_as_symmetric (); + } + } + } + else if (str_typ == "positive definite") + { + mattyp.mark_as_full (); + mattyp.mark_as_symmetric (); + } + else if (str_typ == "singular") + mattyp.mark_as_rectangular (); + else if (str_typ == "full") + mattyp.mark_as_full (); + else if (str_typ == "unknown") + mattyp.invalidate_type (); + else + error ("matrix_type: Unknown matrix type %s", str_typ.c_str ()); + + if (! error_state) + { + if (nargin == 3 && (str_typ == "upper" || str_typ == "lower")) + { + const ColumnVector perm = + ColumnVector (args (2).vector_value ()); + + if (error_state) + error ("matrix_type: Invalid permutation vector PERM"); + else + { + octave_idx_type len = perm.length (); + dim_vector dv = args(0).dims (); + + if (len != dv(0)) + error ("matrix_type: Invalid permutation vector PERM"); + else + { + OCTAVE_LOCAL_BUFFER (octave_idx_type, p, len); + + for (octave_idx_type i = 0; i < len; i++) + p[i] = static_cast<octave_idx_type> (perm (i)) - 1; + + if (str_typ == "upper") + mattyp.mark_as_permuted (len, p); + else + mattyp.mark_as_permuted (len, p); + } + } + } + else if (nargin != 2 && str_typ != "banded positive definite" && + str_typ != "banded") + error ("matrix_type: Invalid number of arguments"); + + if (! error_state) + { + // Set the matrix type + if (args(0).is_complex_type ()) + retval = + octave_value (args(0).sparse_complex_matrix_value (), + mattyp); + else + retval = octave_value (args(0).sparse_matrix_value (), + mattyp); + } + } + } + } + } + else + { + if (nargin == 1) + { + MatrixType mattyp; + + if (args(0).is_complex_type ()) + { + mattyp = args(0).matrix_type (); + + if (mattyp.is_unknown () && autocomp) + { + if (args(0).is_single_type ()) + { + FloatComplexMatrix m = args(0).float_complex_matrix_value (); + if (!error_state) + { + mattyp = MatrixType (m); + args(0).matrix_type (mattyp); + } + } + else + { + ComplexMatrix m = args(0).complex_matrix_value (); + if (!error_state) + { + mattyp = MatrixType (m); + args(0).matrix_type (mattyp); + } + } + } + } + else + { + mattyp = args(0).matrix_type (); + + if (mattyp.is_unknown () && autocomp) + { + if (args(0).is_single_type ()) + { + FloatMatrix m = args(0).float_matrix_value (); + if (!error_state) + { + mattyp = MatrixType (m); + args(0).matrix_type (mattyp); + } + } + else + { + Matrix m = args(0).matrix_value (); + if (!error_state) + { + mattyp = MatrixType (m); + args(0).matrix_type (mattyp); + } + } + } + } + + int typ = mattyp.type (); + + if (typ == MatrixType::Upper) + retval = octave_value ("Upper"); + else if (typ == MatrixType::Permuted_Upper) + retval = octave_value ("Permuted Upper"); + else if (typ == MatrixType::Lower) + retval = octave_value ("Lower"); + else if (typ == MatrixType::Permuted_Lower) + retval = octave_value ("Permuted Lower"); + else if (typ == MatrixType::Hermitian) + retval = octave_value ("Positive Definite"); + else if (typ == MatrixType::Rectangular) + { + if (args(0).rows () == args(0).columns ()) + retval = octave_value ("Singular"); + else + retval = octave_value ("Rectangular"); + } + else if (typ == MatrixType::Full) + retval = octave_value ("Full"); + else + retval = octave_value ("Unknown"); + } + else + { + // Ok, we're changing the matrix type + std::string str_typ = args(1).string_value (); + + // FIXME -- why do I have to explicitly call the constructor? + MatrixType mattyp = MatrixType (MatrixType::Unknown, true); + + if (error_state) + error ("matrix_type: TYPE must be a string"); + else + { + // Use STL function to convert to lower case + std::transform (str_typ.begin (), str_typ.end (), + str_typ.begin (), tolower); + + if (str_typ == "upper") + mattyp.mark_as_upper_triangular (); + else if (str_typ == "lower") + mattyp.mark_as_lower_triangular (); + else if (str_typ == "positive definite") + { + mattyp.mark_as_full (); + mattyp.mark_as_symmetric (); + } + else if (str_typ == "singular") + mattyp.mark_as_rectangular (); + else if (str_typ == "full") + mattyp.mark_as_full (); + else if (str_typ == "unknown") + mattyp.invalidate_type (); + else + error ("matrix_type: Unknown matrix type %s", str_typ.c_str ()); + + if (! error_state) + { + if (nargin == 3 && (str_typ == "upper" + || str_typ == "lower")) + { + const ColumnVector perm = + ColumnVector (args (2).vector_value ()); + + if (error_state) + error ("matrix_type: Invalid permutation vector PERM"); + else + { + octave_idx_type len = perm.length (); + dim_vector dv = args(0).dims (); + + if (len != dv(0)) + error ("matrix_type: Invalid permutation vector PERM"); + else + { + OCTAVE_LOCAL_BUFFER (octave_idx_type, p, len); + + for (octave_idx_type i = 0; i < len; i++) + p[i] = static_cast<octave_idx_type> (perm (i)) - 1; + + if (str_typ == "upper") + mattyp.mark_as_permuted (len, p); + else + mattyp.mark_as_permuted (len, p); + } + } + } + else if (nargin != 2) + error ("matrix_type: Invalid number of arguments"); + + if (! error_state) + { + // Set the matrix type + if (args(0).is_single_type ()) + { + if (args(0).is_complex_type ()) + retval = octave_value + (args(0).float_complex_matrix_value (), + mattyp); + else + retval = octave_value + (args(0).float_matrix_value (), + mattyp); + } + else + { + if (args(0).is_complex_type ()) + retval = octave_value + (args(0).complex_matrix_value (), + mattyp); + else + retval = octave_value + (args(0).matrix_value (), + mattyp); + } + } + } + } + } + } + } + + return retval; +} + +/* +## FIXME: +## Disable tests for lower under-determined and upper over-determined +## matrices as this detection is disabled in MatrixType due to issues +## of non minimum norm solution being found. + +%!assert (matrix_type (speye (10,10)), "Diagonal") +%!assert (matrix_type (speye (10,10)([2:10,1],:)), "Permuted Diagonal") +%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1;sparse(9,1);1]]), "Upper") +%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1;sparse(9,1);1]](:,[2,1,3:11])), "Permuted Upper") +%!assert (matrix_type ([speye(10,10),sparse(10,1);1,sparse(1,9),1]), "Lower") +%!assert (matrix_type ([speye(10,10),sparse(10,1);1,sparse(1,9),1]([2,1,3:11],:)), "Permuted Lower") + +%!test +%! bnd = spparms ("bandden"); +%! spparms ("bandden", 0.5); +%! a = spdiags (rand (10,3)-0.5,[-1,0,1],10,10); +%! assert (matrix_type (a), "Tridiagonal"); +%! assert (matrix_type (a'+a+2*speye (10)), "Tridiagonal Positive Definite"); +%! spparms ("bandden", bnd); +%!test +%! bnd=spparms ("bandden"); +%! spparms ("bandden", 0.5); +%! a = spdiags (randn (10,4),[-2:1],10,10); +%! assert (matrix_type (a), "Banded"); +%! assert (matrix_type (a'*a), "Banded Positive Definite"); +%! spparms ("bandden", bnd); +%!test +%! a = [speye(10,10),[sparse(9,1);1];-1,sparse(1,9),1]; +%! assert (matrix_type (a), "Full"); +%! assert (matrix_type (a'*a), "Positive Definite"); + +%!assert (matrix_type (speye (10,11)), "Diagonal") +%!assert (matrix_type (speye (10,11)([2:10,1],:)), "Permuted Diagonal") +%!assert (matrix_type (speye (11,10)), "Diagonal") +%!assert (matrix_type (speye (11,10)([2:11,1],:)), "Permuted Diagonal") +%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1,1];sparse(9,2);[1,1]]]), "Upper") +%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1,1];sparse(9,2);[1,1]]](:,[2,1,3:12])), "Permuted Upper") +%!assert (matrix_type ([speye(11,9),[1;sparse(8,1);1;0]]), "Upper") +%!assert (matrix_type ([speye(11,9),[1;sparse(8,1);1;0]](:,[2,1,3:10])), "Permuted Upper") +%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1;1],sparse(2,9),[1;1]]), "Lower") +%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1;1],sparse(2,9),[1;1]]([2,1,3:12],:)), "Permuted Lower") +%!assert (matrix_type ([speye(9,11);[1,sparse(1,8),1,0]]), "Lower") +%!assert (matrix_type ([speye(9,11);[1,sparse(1,8),1,0]]([2,1,3:10],:)), "Permuted Lower") +%!assert (matrix_type (spdiags (randn (10,4),[-2:1],10,9)), "Rectangular") + +%!assert (matrix_type (1i*speye (10,10)), "Diagonal") +%!assert (matrix_type (1i*speye (10,10)([2:10,1],:)), "Permuted Diagonal") +%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1i;sparse(9,1);1]]), "Upper") +%!assert (matrix_type ([[speye(10,10);sparse(1,10)],[1i;sparse(9,1);1]](:,[2,1,3:11])), "Permuted Upper") +%!assert (matrix_type ([speye(10,10),sparse(10,1);1i,sparse(1,9),1]), "Lower") +%!assert (matrix_type ([speye(10,10),sparse(10,1);1i,sparse(1,9),1]([2,1,3:11],:)), "Permuted Lower") + +%!test +%! bnd = spparms ("bandden"); +%! spparms ("bandden", 0.5); +%! assert (matrix_type (spdiags (1i*randn (10,3),[-1,0,1],10,10)), "Tridiagonal"); +%! a = 1i*(rand (9,1)-0.5); +%! a = [[a;0],ones(10,1),[0;-a]]; +%! assert (matrix_type (spdiags (a,[-1,0,1],10,10)), "Tridiagonal Positive Definite"); +%! spparms ("bandden", bnd); +%!test +%! bnd = spparms ("bandden"); +%! spparms ("bandden", 0.5); +%! assert (matrix_type (spdiags (1i*randn (10,4),[-2:1],10,10)), "Banded"); +%! a = 1i*(rand (9,2)-0.5); +%! a = [[a;[0,0]],ones(10,1),[[0;-a(:,2)],[0;0;-a(1:8,1)]]]; +%! assert (matrix_type (spdiags (a,[-2:2],10,10)), "Banded Positive Definite"); +%! spparms ("bandden", bnd); +%!test +%! a = [speye(10,10),[sparse(9,1);1i];-1,sparse(1,9),1]; +%! assert (matrix_type (a), "Full"); +%! assert (matrix_type (a'*a), "Positive Definite"); + +%!assert (matrix_type (1i*speye (10,11)), "Diagonal") +%!assert (matrix_type (1i*speye (10,11)([2:10,1],:)), "Permuted Diagonal") +%!assert (matrix_type (1i*speye (11,10)), "Diagonal") +%!assert (matrix_type (1i*speye (11,10)([2:11,1],:)), "Permuted Diagonal") +%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1i,1i];sparse(9,2);[1i,1i]]]), "Upper") +%#!assert (matrix_type ([[speye(10,10);sparse(1,10)],[[1i,1i];sparse(9,2);[1i,1i]]](:,[2,1,3:12])), "Permuted Upper") +%!assert (matrix_type ([speye(11,9),[1i;sparse(8,1);1i;0]]), "Upper") +%!assert (matrix_type ([speye(11,9),[1i;sparse(8,1);1i;0]](:,[2,1,3:10])), "Permuted Upper") +%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1i;1i],sparse(2,9),[1i;1i]]), "Lower") +%#!assert (matrix_type ([speye(10,10),sparse(10,1);[1i;1i],sparse(2,9),[1i;1i]]([2,1,3:12],:)), "Permuted Lower") +%!assert (matrix_type ([speye(9,11);[1i,sparse(1,8),1i,0]]), "Lower") +%!assert (matrix_type ([speye(9,11);[1i,sparse(1,8),1i,0]]([2,1,3:10],:)), "Permuted Lower") +%!assert (matrix_type (1i*spdiags(randn(10,4),[-2:1],10,9)), "Rectangular") + +%!test +%! a = matrix_type (spdiags (randn (10,3),[-1,0,1],10,10), "Singular"); +%! assert (matrix_type (a), "Singular"); + +%!assert (matrix_type (triu (ones(10,10))), "Upper") +%!assert (matrix_type (triu (ones(10,10),-1)), "Full") +%!assert (matrix_type (tril (ones(10,10))), "Lower") +%!assert (matrix_type (tril (ones(10,10),1)), "Full") +%!assert (matrix_type (10*eye (10,10) + ones (10,10)), "Positive Definite") +%!assert (matrix_type (ones (11,10)), "Rectangular") +%!test +%! a = matrix_type (ones (10,10), "Singular"); +%! assert (matrix_type (a), "Singular"); + +%!assert (matrix_type (triu (1i*ones (10,10))), "Upper") +%!assert (matrix_type (triu (1i*ones (10,10),-1)), "Full") +%!assert (matrix_type (tril (1i*ones (10,10))), "Lower") +%!assert (matrix_type (tril (1i*ones (10,10),1)), "Full") +%!assert (matrix_type (10*eye (10,10) + 1i*triu (ones (10,10),1) -1i*tril (ones (10,10),-1)), "Positive Definite") +%!assert (matrix_type (ones (11,10)), "Rectangular") +%!test +%! a = matrix_type (ones (10,10), "Singular"); +%! assert (matrix_type (a), "Singular"); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/max.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,632 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton +Copyright (C) 2009 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-ieee.h" +#include "lo-mappers.h" +#include "lo-math.h" +#include "dNDArray.h" +#include "CNDArray.h" +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" + +#include "ov-cx-mat.h" +#include "ov-re-sparse.h" +#include "ov-cx-sparse.h" + +template <class ArrayType> +static octave_value_list +do_minmax_red_op (const octave_value& arg, + int nargout, int dim, bool ismin) +{ + octave_value_list retval; + ArrayType array = octave_value_extract<ArrayType> (arg); + + if (error_state) + return retval; + + if (nargout == 2) + { + retval.resize (2); + Array<octave_idx_type> idx; + if (ismin) + retval(0) = array.min (idx, dim); + else + retval(0) = array.max (idx, dim); + + retval(1) = octave_value (idx, true, true); + } + else + { + if (ismin) + retval(0) = array.min (dim); + else + retval(0) = array.max (dim); + } + + return retval; +} + +// Specialization for bool arrays. +template <> +octave_value_list +do_minmax_red_op<boolNDArray> (const octave_value& arg, + int nargout, int dim, bool ismin) +{ + octave_value_list retval; + + if (nargout <= 1) + { + // This case can be handled using any/all. + boolNDArray array = arg.bool_array_value (); + + if (array.is_empty ()) + retval(0) = array; + else if (ismin) + retval(0) = array.all (dim); + else + retval(0) = array.any (dim); + } + else + { + // any/all don't have indexed versions, so do it via a conversion. + retval = do_minmax_red_op<int8NDArray> (arg, nargout, dim, ismin); + if (! error_state) + retval(0) = retval(0).bool_array_value (); + } + + return retval; +} + +template <class ArrayType> +static octave_value +do_minmax_bin_op (const octave_value& argx, const octave_value& argy, + bool ismin) +{ + typedef typename ArrayType::element_type ScalarType; + + octave_value retval; + + if (argx.is_scalar_type () == 1) + { + ScalarType x = octave_value_extract<ScalarType> (argx); + ArrayType y = octave_value_extract<ArrayType> (argy); + + if (error_state) + ; + else if (ismin) + retval = min (x, y); + else + retval = max (x, y); + } + else if (argy.is_scalar_type () == 1) + { + ArrayType x = octave_value_extract<ArrayType> (argx); + ScalarType y = octave_value_extract<ScalarType> (argy); + + if (error_state) + ; + else if (ismin) + retval = min (x, y); + else + retval = max (x, y); + } + else + { + ArrayType x = octave_value_extract<ArrayType> (argx); + ArrayType y = octave_value_extract<ArrayType> (argy); + + if (error_state) + ; + else if (ismin) + retval = min (x, y); + else + retval = max (x, y); + } + + return retval; +} + +static octave_value_list +do_minmax_body (const octave_value_list& args, + int nargout, bool ismin) +{ + octave_value_list retval; + + const char *func = ismin ? "min" : "max"; + + int nargin = args.length (); + + if (nargin == 3 || nargin == 1) + { + octave_value arg = args(0); + int dim = -1; + if (nargin == 3) + { + dim = args(2).int_value (true) - 1; + if (error_state || dim < 0) + { + error ("%s: DIM must be a valid dimension", func); + return retval; + } + + if (! args(1).is_empty ()) + warning ("%s: second argument is ignored", func); + } + + switch (arg.builtin_type ()) + { + case btyp_double: + { + if (arg.is_range () && (dim == -1 || dim == 1)) + { + Range range = arg.range_value (); + if (range.nelem () == 0) + { + retval(0) = arg; + if (nargout > 1) + retval(1) = arg; + } + else if (ismin) + { + retval(0) = range.min (); + if (nargout > 1) + retval(1) = static_cast<double> (range.inc () < 0 ? range.nelem () : 1); + } + else + { + retval(0) = range.max (); + if (nargout > 1) + retval(1) = static_cast<double> (range.inc () >= 0 ? range.nelem () : 1); + } + } + else if (arg.is_sparse_type ()) + retval = do_minmax_red_op<SparseMatrix> (arg, nargout, dim, ismin); + else + retval = do_minmax_red_op<NDArray> (arg, nargout, dim, ismin); + break; + } + case btyp_complex: + { + if (arg.is_sparse_type ()) + retval = do_minmax_red_op<SparseComplexMatrix> (arg, nargout, dim, ismin); + else + retval = do_minmax_red_op<ComplexNDArray> (arg, nargout, dim, ismin); + break; + } + case btyp_float: + retval = do_minmax_red_op<FloatNDArray> (arg, nargout, dim, ismin); + break; + case btyp_float_complex: + retval = do_minmax_red_op<FloatComplexNDArray> (arg, nargout, dim, ismin); + break; +#define MAKE_INT_BRANCH(X) \ + case btyp_ ## X: \ + retval = do_minmax_red_op<X ## NDArray> (arg, nargout, dim, ismin); \ + break; + MAKE_INT_BRANCH (int8); + MAKE_INT_BRANCH (int16); + MAKE_INT_BRANCH (int32); + MAKE_INT_BRANCH (int64); + MAKE_INT_BRANCH (uint8); + MAKE_INT_BRANCH (uint16); + MAKE_INT_BRANCH (uint32); + MAKE_INT_BRANCH (uint64); +#undef MAKE_INT_BRANCH + case btyp_bool: + retval = do_minmax_red_op<boolNDArray> (arg, nargout, dim, ismin); + break; + default: + gripe_wrong_type_arg (func, arg); + } + } + else if (nargin == 2) + { + octave_value argx = args(0), argy = args(1); + builtin_type_t xtyp = argx.builtin_type (), ytyp = argy.builtin_type (); + builtin_type_t rtyp = btyp_mixed_numeric (xtyp, ytyp); + + switch (rtyp) + { + case btyp_double: + { + if ((argx.is_sparse_type () + && (argy.is_sparse_type () || argy.is_scalar_type ())) + || (argy.is_sparse_type () && argx.is_scalar_type ())) + retval = do_minmax_bin_op<SparseMatrix> (argx, argy, ismin); + else + retval = do_minmax_bin_op<NDArray> (argx, argy, ismin); + break; + } + case btyp_complex: + { + if ((argx.is_sparse_type () + && (argy.is_sparse_type () || argy.is_scalar_type ())) + || (argy.is_sparse_type () && argx.is_scalar_type ())) + retval = do_minmax_bin_op<SparseComplexMatrix> (argx, argy, ismin); + else + retval = do_minmax_bin_op<ComplexNDArray> (argx, argy, ismin); + break; + } + case btyp_float: + retval = do_minmax_bin_op<FloatNDArray> (argx, argy, ismin); + break; + case btyp_float_complex: + retval = do_minmax_bin_op<FloatComplexNDArray> (argx, argy, ismin); + break; +#define MAKE_INT_BRANCH(X) \ + case btyp_ ## X: \ + retval = do_minmax_bin_op<X ## NDArray> (argx, argy, ismin); \ + break; + MAKE_INT_BRANCH (int8); + MAKE_INT_BRANCH (int16); + MAKE_INT_BRANCH (int32); + MAKE_INT_BRANCH (int64); + MAKE_INT_BRANCH (uint8); + MAKE_INT_BRANCH (uint16); + MAKE_INT_BRANCH (uint32); + MAKE_INT_BRANCH (uint64); +#undef MAKE_INT_BRANCH + default: + error ("%s: cannot compute %s (%s, %s)", func, func, + argx.type_name ().c_str (), argy.type_name ().c_str ()); + } + } + else + print_usage (); + + return retval; +} + +DEFUN (min, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} min (@var{x})\n\ +@deftypefnx {Built-in Function} {} min (@var{x}, @var{y})\n\ +@deftypefnx {Built-in Function} {} min (@var{x}, [], @var{dim})\n\ +@deftypefnx {Built-in Function} {} min (@var{x}, @var{y}, @var{dim})\n\ +@deftypefnx {Built-in Function} {[@var{w}, @var{iw}] =} min (@var{x})\n\ +For a vector argument, return the minimum value. For a matrix\n\ +argument, return the minimum value from each column, as a row\n\ +vector, or over the dimension @var{dim} if defined, in which case @var{y} \n\ +should be set to the empty matrix (it's ignored otherwise). For two matrices\n\ +(or a matrix and scalar), return the pair-wise minimum.\n\ +Thus,\n\ +\n\ +@example\n\ +min (min (@var{x}))\n\ +@end example\n\ +\n\ +@noindent\n\ +returns the smallest element of @var{x}, and\n\ +\n\ +@example\n\ +@group\n\ +min (2:5, pi)\n\ + @result{} 2.0000 3.0000 3.1416 3.1416\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +compares each element of the range @code{2:5} with @code{pi}, and\n\ +returns a row vector of the minimum values.\n\ +\n\ +For complex arguments, the magnitude of the elements are used for\n\ +comparison.\n\ +\n\ +If called with one input and two output arguments,\n\ +@code{min} also returns the first index of the\n\ +minimum value(s). Thus,\n\ +\n\ +@example\n\ +@group\n\ +[x, ix] = min ([1, 3, 0, 2, 0])\n\ + @result{} x = 0\n\ + ix = 3\n\ +@end group\n\ +@end example\n\ +@seealso{max, cummin, cummax}\n\ +@end deftypefn") +{ + return do_minmax_body (args, nargout, true); +} + +/* +%!assert (min ([1, 4, 2, 3]), 1) +%!assert (min ([1; -10; 5; -2]), -10) +%!assert (min ([4, i; -2, 2]), [-2, i]) + +%!test +%! x = reshape (1:8, [2,2,2]); +%! assert (max (x, [], 1), reshape ([2, 4, 6, 8], [1,2,2])); +%! assert (max (x, [], 2), reshape ([3, 4, 7, 8], [2,1,2])); +%! [y, i] = max (x, [], 3); +%! assert (ndims (y), 2); +%! assert (y, [5, 7; 6, 8]); +%! assert (ndims (i), 2); +%! assert (i, [2, 2; 2, 2]); + +%!error min () +%!error min (1, 2, 3, 4) +*/ + +DEFUN (max, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} max (@var{x})\n\ +@deftypefnx {Built-in Function} {} max (@var{x}, @var{y})\n\ +@deftypefnx {Built-in Function} {} max (@var{x}, [], @var{dim})\n\ +@deftypefnx {Built-in Function} {} max (@var{x}, @var{y}, @var{dim})\n\ +@deftypefnx {Built-in Function} {[@var{w}, @var{iw}] =} max (@var{x})\n\ +For a vector argument, return the maximum value. For a matrix\n\ +argument, return the maximum value from each column, as a row\n\ +vector, or over the dimension @var{dim} if defined, in which case @var{y} \n\ +should be set to the empty matrix (it's ignored otherwise). For two matrices\n\ +(or a matrix and scalar), return the pair-wise maximum.\n\ +Thus,\n\ +\n\ +@example\n\ +max (max (@var{x}))\n\ +@end example\n\ +\n\ +@noindent\n\ +returns the largest element of the matrix @var{x}, and\n\ +\n\ +@example\n\ +@group\n\ +max (2:5, pi)\n\ + @result{} 3.1416 3.1416 4.0000 5.0000\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +compares each element of the range @code{2:5} with @code{pi}, and\n\ +returns a row vector of the maximum values.\n\ +\n\ +For complex arguments, the magnitude of the elements are used for\n\ +comparison.\n\ +\n\ +If called with one input and two output arguments,\n\ +@code{max} also returns the first index of the\n\ +maximum value(s). Thus,\n\ +\n\ +@example\n\ +@group\n\ +[x, ix] = max ([1, 3, 5, 2, 5])\n\ + @result{} x = 5\n\ + ix = 3\n\ +@end group\n\ +@end example\n\ +@seealso{min, cummax, cummin}\n\ +@end deftypefn") +{ + return do_minmax_body (args, nargout, false); +} + +/* +%!assert (max ([1, 4, 2, 3]), 4) +%!assert (max ([1; -10; 5; -2]), 5) +%!assert (max ([4, i 4.999; -2, 2, 3+4i]), [4, 2, 3+4i]) + +%!test +%! x = reshape (1:8, [2,2,2]); +%! assert (min (x, [], 1), reshape ([1, 3, 5, 7], [1,2,2])); +%! assert (min (x, [], 2), reshape ([1, 2, 5, 6], [2,1,2])); +%! [y, i] = min (x, [], 3); +%! assert (ndims(y), 2); +%! assert (y, [1, 3; 2, 4]); +%! assert (ndims(i), 2); +%! assert (i, [1, 1; 1, 1]); + +%!error max () +%!error max (1, 2, 3, 4) +*/ + +template <class ArrayType> +static octave_value_list +do_cumminmax_red_op (const octave_value& arg, + int nargout, int dim, bool ismin) +{ + octave_value_list retval; + ArrayType array = octave_value_extract<ArrayType> (arg); + + if (error_state) + return retval; + + if (nargout == 2) + { + retval.resize (2); + Array<octave_idx_type> idx; + if (ismin) + retval(0) = array.cummin (idx, dim); + else + retval(0) = array.cummax (idx, dim); + + retval(1) = octave_value (idx, true, true); + } + else + { + if (ismin) + retval(0) = array.cummin (dim); + else + retval(0) = array.cummax (dim); + } + + return retval; +} + +static octave_value_list +do_cumminmax_body (const octave_value_list& args, + int nargout, bool ismin) +{ + octave_value_list retval; + + const char *func = ismin ? "cummin" : "cummax"; + + int nargin = args.length (); + + if (nargin == 1 || nargin == 2) + { + octave_value arg = args(0); + int dim = -1; + if (nargin == 2) + { + dim = args(1).int_value (true) - 1; + if (error_state || dim < 0) + { + error ("%s: DIM must be a valid dimension", func); + return retval; + } + } + + switch (arg.builtin_type ()) + { + case btyp_double: + retval = do_cumminmax_red_op<NDArray> (arg, nargout, dim, ismin); + break; + case btyp_complex: + retval = do_cumminmax_red_op<ComplexNDArray> (arg, nargout, dim, ismin); + break; + case btyp_float: + retval = do_cumminmax_red_op<FloatNDArray> (arg, nargout, dim, ismin); + break; + case btyp_float_complex: + retval = do_cumminmax_red_op<FloatComplexNDArray> (arg, nargout, dim, ismin); + break; +#define MAKE_INT_BRANCH(X) \ + case btyp_ ## X: \ + retval = do_cumminmax_red_op<X ## NDArray> (arg, nargout, dim, ismin); \ + break; + MAKE_INT_BRANCH (int8); + MAKE_INT_BRANCH (int16); + MAKE_INT_BRANCH (int32); + MAKE_INT_BRANCH (int64); + MAKE_INT_BRANCH (uint8); + MAKE_INT_BRANCH (uint16); + MAKE_INT_BRANCH (uint32); + MAKE_INT_BRANCH (uint64); +#undef MAKE_INT_BRANCH + case btyp_bool: + { + retval = do_cumminmax_red_op<int8NDArray> (arg, nargout, dim, ismin); + if (retval.length () > 0) + retval(0) = retval(0).bool_array_value (); + break; + } + default: + gripe_wrong_type_arg (func, arg); + } + } + else + print_usage (); + + return retval; +} + +DEFUN (cummin, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} cummin (@var{x})\n\ +@deftypefnx {Built-in Function} {} cummin (@var{x}, @var{dim})\n\ +@deftypefnx {Built-in Function} {[@var{w}, @var{iw}] =} cummin (@var{x})\n\ +Return the cumulative minimum values along dimension @var{dim}. If @var{dim}\n\ +is unspecified it defaults to column-wise operation. For example:\n\ +\n\ +@example\n\ +@group\n\ +cummin ([5 4 6 2 3 1])\n\ + @result{} 5 4 4 2 2 1\n\ +@end group\n\ +@end example\n\ +\n\ +\n\ +The call\n\ +\n\ +@example\n\ + [w, iw] = cummin (x)\n\ +@end example\n\ +\n\ +@noindent\n\ +with @code{x} a vector, is equivalent to the following code:\n\ +\n\ +@example\n\ +@group\n\ +w = iw = zeros (size (x));\n\ +for i = 1:length (x)\n\ + [w(i), iw(i)] = max (x(1:i));\n\ +endfor\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +but computed in a much faster manner.\n\ +@seealso{cummax, min, max}\n\ +@end deftypefn") +{ + return do_cumminmax_body (args, nargout, true); +} + +DEFUN (cummax, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} cummax (@var{x})\n\ +@deftypefnx {Built-in Function} {} cummax (@var{x}, @var{dim})\n\ +@deftypefnx {Built-in Function} {[@var{w}, @var{iw}] =} cummax (@var{x})\n\ +Return the cumulative maximum values along dimension @var{dim}. If @var{dim}\n\ +is unspecified it defaults to column-wise operation. For example:\n\ +\n\ +@example\n\ +@group\n\ +cummax ([1 3 2 6 4 5])\n\ + @result{} 1 3 3 6 6 6\n\ +@end group\n\ +@end example\n\ +\n\ +The call\n\ +\n\ +@example\n\ +[w, iw] = cummax (x, dim)\n\ +@end example\n\ +\n\ +@noindent\n\ +with @code{x} a vector, is equivalent to the following code:\n\ +\n\ +@example\n\ +@group\n\ +w = iw = zeros (size (x));\n\ +for i = 1:length (x)\n\ + [w(i), iw(i)] = max (x(1:i));\n\ +endfor\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +but computed in a much faster manner.\n\ +@seealso{cummin, max, min}\n\ +@end deftypefn") +{ + return do_cumminmax_body (args, nargout, false); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/md5sum.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,101 @@ +/* + +Copyright (C) 2007-2012 David Bateman + + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> +#include <vector> + +#include "defun.h" +#include "file-stat.h" +#include "file-ops.h" +#include "gripes.h" +#include "load-path.h" +#include "oct-env.h" +#include "oct-md5.h" + +DEFUN (md5sum, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} md5sum (@var{file})\n\ +@deftypefnx {Built-in Function} {} md5sum (@var{str}, @var{opt})\n\ +Calculate the MD5 sum of the file @var{file}. If the second parameter\n\ +@var{opt} exists and is true, then calculate the MD5 sum of the\n\ +string @var{str}.\n\ +@end deftypefn") +{ + octave_value retval; + int nargin = args.length (); + + if (nargin != 1 && nargin != 2) + print_usage (); + else + { + bool have_str = false; + std::string str = args(0).string_value (); + + if (nargin == 2) + have_str = args(1).bool_value (); + + if (!error_state) + { + if (have_str) + retval = oct_md5 (str); + else + { + file_stat fs (str); + + if (! fs.exists ()) + { + std::string tmp + = octave_env::make_absolute (load_path::find_file (str)); + + if (! tmp.empty ()) + { + warning_with_id ("Octave:md5sum-file-in-path", + "md5sum: file found in load path"); + str = tmp; + } + } + + retval = oct_md5_file (str); + } + } + } + + return retval; +} + +/* +%!assert (md5sum ("abc\0", true), "147a664a2ca9410911e61986d3f0d52a"); + +%!test +%! tfile = tmpnam (); +%! fid = fopen (tfile, "wb"); +%! fwrite (fid, "abc\0"); +%! fclose (fid); +%! assert (md5sum (tfile), "147a664a2ca9410911e61986d3f0d52a"); +%! unlink (tfile); +*/ +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/mgorth.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,154 @@ +/* + +Copyright (C) 2009-2012 Carlo de Falco +Copyright (C) 2010 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "oct-norm.h" +#include "defun.h" +#include "error.h" +#include "gripes.h" + +template <class ColumnVector, class Matrix, class RowVector> +static void +do_mgorth (ColumnVector& x, const Matrix& V, RowVector& h) +{ + octave_idx_type Vc = V.columns (); + h = RowVector (Vc + 1); + for (octave_idx_type j = 0; j < Vc; j++) + { + ColumnVector Vcj = V.column (j); + h(j) = RowVector (Vcj.hermitian ()) * x; + x -= h(j) * Vcj; + } + + h(Vc) = xnorm (x); + if (real (h(Vc)) > 0) + x = x / h(Vc); +} + +DEFUN (mgorth, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{y}, @var{h}] =} mgorth (@var{x}, @var{v})\n\ +Orthogonalize a given column vector @var{x} with respect to a given\n\ +orthonormal basis @var{v} using a modified Gram-Schmidt orthogonalization. \n\ +On exit, @var{y} is a unit vector such that:\n\ +\n\ +@example\n\ +@group\n\ + norm (@var{y}) = 1\n\ + @var{v}' * @var{y} = 0\n\ + @var{x} = @var{h}*[@var{v}, @var{y}]\n\ +@end group\n\ +@end example\n\ +\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin != 2 || nargout > 2) + { + print_usage (); + return retval; + } + + octave_value arg_x = args(0); + octave_value arg_v = args(1); + + if (arg_v.ndims () != 2 || arg_x.ndims () != 2 || arg_x.columns () != 1 + || arg_v.rows () != arg_x.rows ()) + { + error ("mgorth: V should me a matrix, and X a column vector with" + " the same number of rows as V."); + return retval; + } + + if (! arg_x.is_numeric_type () && ! arg_v.is_numeric_type ()) + { + error ("mgorth: X and V must be numeric"); + } + + bool iscomplex = (arg_x.is_complex_type () || arg_v.is_complex_type ()); + if (arg_x.is_single_type () || arg_v.is_single_type ()) + { + if (iscomplex) + { + FloatComplexColumnVector x = arg_x.float_complex_column_vector_value (); + FloatComplexMatrix V = arg_v.float_complex_matrix_value (); + FloatComplexRowVector h; + do_mgorth (x, V, h); + retval(1) = h; + retval(0) = x; + } + else + { + FloatColumnVector x = arg_x.float_column_vector_value (); + FloatMatrix V = arg_v.float_matrix_value (); + FloatRowVector h; + do_mgorth (x, V, h); + retval(1) = h; + retval(0) = x; + } + } + else + { + if (iscomplex) + { + ComplexColumnVector x = arg_x.complex_column_vector_value (); + ComplexMatrix V = arg_v.complex_matrix_value (); + ComplexRowVector h; + do_mgorth (x, V, h); + retval(1) = h; + retval(0) = x; + } + else + { + ColumnVector x = arg_x.column_vector_value (); + Matrix V = arg_v.matrix_value (); + RowVector h; + do_mgorth (x, V, h); + retval(1) = h; + retval(0) = x; + } + } + + return retval; +} + +/* +%!test +%! for ii=1:100 +%! assert (abs (mgorth (randn (5, 1), eye (5, 4))), [0 0 0 0 1]', eps); +%! endfor + +%!test +%! a = hilb (5); +%! a(:, 1) /= norm (a(:, 1)); +%! for ii = 1:5 +%! a(:, ii) = mgorth (a(:, ii), a(:, 1:ii-1)); +%! endfor +%! assert (a' * a, eye (5), 1e10); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/module.mk Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,70 @@ +EXTRA_DIST += \ + corefcn/module.mk + +corefcn_SRC = \ + corefcn/__contourc__.cc \ + corefcn/__dispatch__.cc \ + corefcn/__lin_interpn__.cc \ + corefcn/__pchip_deriv__.cc \ + corefcn/__qp__.cc \ + corefcn/balance.cc \ + corefcn/besselj.cc \ + corefcn/betainc.cc \ + corefcn/bsxfun.cc \ + corefcn/cellfun.cc \ + corefcn/colloc.cc \ + corefcn/conv2.cc \ + corefcn/daspk.cc \ + corefcn/dasrt.cc \ + corefcn/dassl.cc \ + corefcn/det.cc \ + corefcn/dlmread.cc \ + corefcn/dot.cc \ + corefcn/eig.cc \ + corefcn/fft.cc \ + corefcn/fft2.cc \ + corefcn/fftn.cc \ + corefcn/filter.cc \ + corefcn/find.cc \ + corefcn/gammainc.cc \ + corefcn/gcd.cc \ + corefcn/getgrent.cc \ + corefcn/getpwent.cc \ + corefcn/getrusage.cc \ + corefcn/givens.cc \ + corefcn/hess.cc \ + corefcn/hex2num.cc \ + corefcn/inv.cc \ + corefcn/kron.cc \ + corefcn/lookup.cc \ + corefcn/lsode.cc \ + corefcn/lu.cc \ + corefcn/luinc.cc \ + corefcn/matrix_type.cc \ + corefcn/max.cc \ + corefcn/md5sum.cc \ + corefcn/mgorth.cc \ + corefcn/nproc.cc \ + corefcn/pinv.cc \ + corefcn/quad.cc \ + corefcn/quadcc.cc \ + corefcn/qz.cc \ + corefcn/rand.cc \ + corefcn/rcond.cc \ + corefcn/regexp.cc \ + corefcn/schur.cc \ + corefcn/spparms.cc \ + corefcn/sqrtm.cc \ + corefcn/str2double.cc \ + corefcn/strfind.cc \ + corefcn/sub2ind.cc \ + corefcn/svd.cc \ + corefcn/syl.cc \ + corefcn/time.cc \ + corefcn/tril.cc \ + corefcn/typecast.cc + +noinst_LTLIBRARIES += corefcn/libcorefcn.la + +corefcn_libcorefcn_la_SOURCES = $(corefcn_SRC) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/nproc.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,90 @@ +/* + +Copyright (C) 2012 Iain Murray + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "nproc.h" + +DEFUN (nproc, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} nproc ()\n\ +@deftypefnx {Built-in Function} {} nproc (@var{query})\n\ +Return the current number of available processors.\n\ +\n\ +If called with the optional argument @var{query}, modify how processors\n\ +are counted as follows:\n\ +\n\ +@table @code\n\ +@item all\n\ +total number of processors.\n\ +\n\ +@item current\n\ +processors available to the current process.\n\ +\n\ +@item overridable\n\ +likewise, but overridable through the @w{@env{OMP_NUM_THREADS}} environment\n\ +variable.\n\ +@end table\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if ((nargin != 0 && nargin != 1) || (nargout != 0 && nargout != 1)) + { + print_usage (); + return retval; + } + + nproc_query query = NPROC_CURRENT; + if (nargin == 1) + { + std::string arg = args(0).string_value (); + + std::transform (arg.begin (), arg.end (), arg.begin (), tolower); + + if (arg == "all") + query = NPROC_ALL; + else if (arg == "current") + query = NPROC_CURRENT; + else if (arg == "overridable") + query = NPROC_CURRENT_OVERRIDABLE; + else + { + error ("nproc: invalid value for QUERY"); + return retval; + } + } + + retval = num_processors (query); + + return retval; +} + +/* +## Must always report at least 1 cpu available +%!assert (nproc () >= 1); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/pinv.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,192 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" +#include "ops.h" +#include "ov-re-diag.h" +#include "ov-cx-diag.h" +#include "ov-flt-re-diag.h" +#include "ov-flt-cx-diag.h" +#include "ov-perm.h" + +DEFUN (pinv, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} pinv (@var{x})\n\ +@deftypefnx {Built-in Function} {} pinv (@var{x}, @var{tol})\n\ +Return the pseudoinverse of @var{x}. Singular values less than\n\ +@var{tol} are ignored.\n\ +\n\ +If the second argument is omitted, it is taken to be\n\ +\n\ +@example\n\ +tol = max (size (@var{x})) * sigma_max (@var{x}) * eps,\n\ +@end example\n\ +\n\ +@noindent\n\ +where @code{sigma_max (@var{x})} is the maximal singular value of @var{x}.\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 2) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + + int arg_is_empty = empty_arg ("pinv", arg.rows (), arg.columns ()); + + if (arg_is_empty < 0) + return retval; + else if (arg_is_empty > 0) + return octave_value (Matrix ()); + + bool isfloat = arg.is_single_type (); + + if (arg.is_diag_matrix ()) + { + if (nargin == 2) + warning ("pinv: tol is ignored for diagonal matrices"); + + if (arg.is_complex_type ()) + { + if (isfloat) + retval = arg.float_complex_diag_matrix_value ().pseudo_inverse (); + else + retval = arg.complex_diag_matrix_value ().pseudo_inverse (); + } + else + { + if (isfloat) + retval = arg.float_diag_matrix_value ().pseudo_inverse (); + else + retval = arg.diag_matrix_value ().pseudo_inverse (); + } + } + else if (arg.is_perm_matrix ()) + { + retval = arg.perm_matrix_value ().inverse (); + } + else if (isfloat) + { + float tol = 0.0; + if (nargin == 2) + tol = args(1).float_value (); + + if (error_state) + return retval; + + if (tol < 0.0) + { + error ("pinv: TOL must be greater than zero"); + return retval; + } + + if (arg.is_real_type ()) + { + FloatMatrix m = arg.float_matrix_value (); + + if (! error_state) + retval = m.pseudo_inverse (tol); + } + else if (arg.is_complex_type ()) + { + FloatComplexMatrix m = arg.float_complex_matrix_value (); + + if (! error_state) + retval = m.pseudo_inverse (tol); + } + else + { + gripe_wrong_type_arg ("pinv", arg); + } + } + else + { + double tol = 0.0; + if (nargin == 2) + tol = args(1).double_value (); + + if (error_state) + return retval; + + if (tol < 0.0) + { + error ("pinv: TOL must be greater than zero"); + return retval; + } + + if (arg.is_real_type ()) + { + Matrix m = arg.matrix_value (); + + if (! error_state) + retval = m.pseudo_inverse (tol); + } + else if (arg.is_complex_type ()) + { + ComplexMatrix m = arg.complex_matrix_value (); + + if (! error_state) + retval = m.pseudo_inverse (tol); + } + else + { + gripe_wrong_type_arg ("pinv", arg); + } + } + + return retval; +} + +/* +%!shared a, b, tol, hitol, d, u, x, y +%! a = reshape (rand*[1:16], 4, 4); ## Rank 2 matrix +%! b = pinv (a); +%! tol = 4e-14; +%! hitol = 40*sqrt (eps); +%! d = diag ([rand, rand, hitol, hitol]); +%! u = rand (4); ## Could be singular by freak accident +%! x = inv (u)*d*u; +%! y = pinv (x, sqrt (eps)); +%! +%!assert (a*b*a, a, tol) +%!assert (b*a*b, b, tol) +%!assert ((b*a)', b*a, tol) +%!assert ((a*b)', a*b, tol) +%!assert (x*y*x, x, -hitol) +%!assert (y*x*y, y, -hitol) +%!assert ((x*y)', x*y, hitol) +%!assert ((y*x)', y*x, hitol) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/quad.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,518 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include <iomanip> +#include <iostream> + +#include "Quad.h" +#include "lo-mappers.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "pager.h" +#include "oct-obj.h" +#include "ov-fcn.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" + +#include "Quad-opts.cc" + +#if defined (quad) +#undef quad +#endif + +// Global pointer for user defined function required by quadrature functions. +static octave_function *quad_fcn; + +// Have we warned about imaginary values returned from user function? +static bool warned_imaginary = false; + +// Is this a recursive call? +static int call_depth = 0; + +double +quad_user_function (double x) +{ + double retval = 0.0; + + octave_value_list args; + args(0) = x; + + if (quad_fcn) + { + octave_value_list tmp = quad_fcn->do_multi_index_op (1, args); + + if (error_state) + { + quad_integration_error = 1; // FIXME + gripe_user_supplied_eval ("quad"); + return retval; + } + + if (tmp.length () && tmp(0).is_defined ()) + { + if (! warned_imaginary && tmp(0).is_complex_type ()) + { + warning ("quad: ignoring imaginary part returned from user-supplied function"); + warned_imaginary = true; + } + + retval = tmp(0).double_value (); + + if (error_state) + { + quad_integration_error = 1; // FIXME + gripe_user_supplied_eval ("quad"); + } + } + else + { + quad_integration_error = 1; // FIXME + gripe_user_supplied_eval ("quad"); + } + } + + return retval; +} + +float +quad_float_user_function (float x) +{ + float retval = 0.0; + + octave_value_list args; + args(0) = x; + + if (quad_fcn) + { + octave_value_list tmp = quad_fcn->do_multi_index_op (1, args); + + if (error_state) + { + quad_integration_error = 1; // FIXME + gripe_user_supplied_eval ("quad"); + return retval; + } + + if (tmp.length () && tmp(0).is_defined ()) + { + if (! warned_imaginary && tmp(0).is_complex_type ()) + { + warning ("quad: ignoring imaginary part returned from user-supplied function"); + warned_imaginary = true; + } + + retval = tmp(0).float_value (); + + if (error_state) + { + quad_integration_error = 1; // FIXME + gripe_user_supplied_eval ("quad"); + } + } + else + { + quad_integration_error = 1; // FIXME + gripe_user_supplied_eval ("quad"); + } + } + + return retval; +} + +#define QUAD_ABORT() \ + do \ + { \ + if (fcn_name.length ()) \ + clear_function (fcn_name); \ + return retval; \ + } \ + while (0) + +#define QUAD_ABORT1(msg) \ + do \ + { \ + ::error ("quad: " msg); \ + QUAD_ABORT (); \ + } \ + while (0) + +#define QUAD_ABORT2(fmt, arg) \ + do \ + { \ + ::error ("quad: " fmt, arg); \ + QUAD_ABORT (); \ + } \ + while (0) + +DEFUN (quad, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{q} =} quad (@var{f}, @var{a}, @var{b})\n\ +@deftypefnx {Built-in Function} {@var{q} =} quad (@var{f}, @var{a}, @var{b}, @var{tol})\n\ +@deftypefnx {Built-in Function} {@var{q} =} quad (@var{f}, @var{a}, @var{b}, @var{tol}, @var{sing})\n\ +@deftypefnx {Built-in Function} {[@var{q}, @var{ier}, @var{nfun}, @var{err}] =} quad (@dots{})\n\ +Numerically evaluate the integral of @var{f} from @var{a} to @var{b} using\n\ +Fortran routines from @w{@sc{quadpack}}. @var{f} is a function handle,\n\ +inline function, or a string containing the name of the function to\n\ +evaluate. The function must have the form @code{y = f (x)} where @var{y} and\n\ +@var{x} are scalars.\n\ +\n\ +@var{a} and @var{b} are the lower and upper limits of integration. Either\n\ +or both may be infinite.\n\ +\n\ +The optional argument @var{tol} is a vector that specifies the desired\n\ +accuracy of the result. The first element of the vector is the desired\n\ +absolute tolerance, and the second element is the desired relative\n\ +tolerance. To choose a relative test only, set the absolute\n\ +tolerance to zero. To choose an absolute test only, set the relative\n\ +tolerance to zero. Both tolerances default to @code{sqrt (eps)} or\n\ +approximately @math{1.5e^{-8}}.\n\ +\n\ +The optional argument @var{sing} is a vector of values at which the\n\ +integrand is known to be singular.\n\ +\n\ +The result of the integration is returned in @var{q}. @var{ier}\n\ +contains an integer error code (0 indicates a successful integration).\n\ +@var{nfun} indicates the number of function evaluations that were\n\ +made, and @var{err} contains an estimate of the error in the\n\ +solution.\n\ +\n\ +The function @code{quad_options} can set other optional\n\ +parameters for @code{quad}.\n\ +\n\ +Note: because @code{quad} is written in Fortran it cannot be called\n\ +recursively. This prevents its use in integrating over more than one\n\ +variable by routines @code{dblquad} and @code{triplequad}.\n\ +@seealso{quad_options, quadv, quadl, quadgk, quadcc, trapz, dblquad, triplequad}\n\ +@end deftypefn") +{ + octave_value_list retval; + + std::string fcn_name; + + warned_imaginary = false; + + unwind_protect frame; + + frame.protect_var (call_depth); + call_depth++; + + if (call_depth > 1) + QUAD_ABORT1 ("invalid recursive call"); + + int nargin = args.length (); + + if (nargin > 2 && nargin < 6 && nargout < 5) + { + if (args(0).is_function_handle () || args(0).is_inline_function ()) + quad_fcn = args(0).function_value (); + else + { + fcn_name = unique_symbol_name ("__quad_fcn_"); + std::string fname = "function y = "; + fname.append (fcn_name); + fname.append ("(x) y = "); + quad_fcn = extract_function (args(0), "quad", fcn_name, fname, + "; endfunction"); + } + + if (! quad_fcn) + QUAD_ABORT (); + + if (args(1).is_single_type () || args(2).is_single_type ()) + { + float a = args(1).float_value (); + + if (error_state) + QUAD_ABORT1 ("expecting second argument to be a scalar"); + + float b = args(2).float_value (); + + if (error_state) + QUAD_ABORT1 ("expecting third argument to be a scalar"); + + int indefinite = 0; + FloatIndefQuad::IntegralType indef_type = FloatIndefQuad::doubly_infinite; + float bound = 0.0; + if (xisinf (a) && xisinf (b)) + { + indefinite = 1; + indef_type = FloatIndefQuad::doubly_infinite; + } + else if (xisinf (a)) + { + indefinite = 1; + bound = b; + indef_type = FloatIndefQuad::neg_inf_to_bound; + } + else if (xisinf (b)) + { + indefinite = 1; + bound = a; + indef_type = FloatIndefQuad::bound_to_inf; + } + + octave_idx_type ier = 0; + octave_idx_type nfun = 0; + float abserr = 0.0; + float val = 0.0; + bool have_sing = false; + FloatColumnVector sing; + FloatColumnVector tol; + + switch (nargin) + { + case 5: + if (indefinite) + QUAD_ABORT1 ("singularities not allowed on infinite intervals"); + + have_sing = true; + + sing = FloatColumnVector (args(4).float_vector_value ()); + + if (error_state) + QUAD_ABORT1 ("expecting vector of singularities as fourth argument"); + + case 4: + tol = FloatColumnVector (args(3).float_vector_value ()); + + if (error_state) + QUAD_ABORT1 ("expecting vector of tolerances as fifth argument"); + + switch (tol.capacity ()) + { + case 2: + quad_opts.set_single_precision_relative_tolerance (tol (1)); + + case 1: + quad_opts.set_single_precision_absolute_tolerance (tol (0)); + break; + + default: + QUAD_ABORT1 ("expecting tol to contain no more than two values"); + } + + case 3: + if (indefinite) + { + FloatIndefQuad iq (quad_float_user_function, bound, + indef_type); + iq.set_options (quad_opts); + val = iq.float_integrate (ier, nfun, abserr); + } + else + { + if (have_sing) + { + FloatDefQuad dq (quad_float_user_function, a, b, sing); + dq.set_options (quad_opts); + val = dq.float_integrate (ier, nfun, abserr); + } + else + { + FloatDefQuad dq (quad_float_user_function, a, b); + dq.set_options (quad_opts); + val = dq.float_integrate (ier, nfun, abserr); + } + } + break; + + default: + panic_impossible (); + break; + } + + retval(3) = abserr; + retval(2) = nfun; + retval(1) = ier; + retval(0) = val; + + } + else + { + double a = args(1).double_value (); + + if (error_state) + QUAD_ABORT1 ("expecting second argument to be a scalar"); + + double b = args(2).double_value (); + + if (error_state) + QUAD_ABORT1 ("expecting third argument to be a scalar"); + + int indefinite = 0; + IndefQuad::IntegralType indef_type = IndefQuad::doubly_infinite; + double bound = 0.0; + if (xisinf (a) && xisinf (b)) + { + indefinite = 1; + indef_type = IndefQuad::doubly_infinite; + } + else if (xisinf (a)) + { + indefinite = 1; + bound = b; + indef_type = IndefQuad::neg_inf_to_bound; + } + else if (xisinf (b)) + { + indefinite = 1; + bound = a; + indef_type = IndefQuad::bound_to_inf; + } + + octave_idx_type ier = 0; + octave_idx_type nfun = 0; + double abserr = 0.0; + double val = 0.0; + bool have_sing = false; + ColumnVector sing; + ColumnVector tol; + + switch (nargin) + { + case 5: + if (indefinite) + QUAD_ABORT1 ("singularities not allowed on infinite intervals"); + + have_sing = true; + + sing = ColumnVector (args(4).vector_value ()); + + if (error_state) + QUAD_ABORT1 ("expecting vector of singularities as fourth argument"); + + case 4: + tol = ColumnVector (args(3).vector_value ()); + + if (error_state) + QUAD_ABORT1 ("expecting vector of tolerances as fifth argument"); + + switch (tol.capacity ()) + { + case 2: + quad_opts.set_relative_tolerance (tol (1)); + + case 1: + quad_opts.set_absolute_tolerance (tol (0)); + break; + + default: + QUAD_ABORT1 ("expecting tol to contain no more than two values"); + } + + case 3: + if (indefinite) + { + IndefQuad iq (quad_user_function, bound, indef_type); + iq.set_options (quad_opts); + val = iq.integrate (ier, nfun, abserr); + } + else + { + if (have_sing) + { + DefQuad dq (quad_user_function, a, b, sing); + dq.set_options (quad_opts); + val = dq.integrate (ier, nfun, abserr); + } + else + { + DefQuad dq (quad_user_function, a, b); + dq.set_options (quad_opts); + val = dq.integrate (ier, nfun, abserr); + } + } + break; + + default: + panic_impossible (); + break; + } + + retval(3) = abserr; + retval(2) = nfun; + retval(1) = ier; + retval(0) = val; + } + + if (fcn_name.length ()) + clear_function (fcn_name); + } + else + print_usage (); + + return retval; +} + +/* +%!function y = __f (x) +%! y = x + 1; +%!endfunction + +%!test +%! [v, ier, nfun, err] = quad ("__f", 0, 5); +%! assert (ier, 0); +%! assert (v, 17.5, sqrt (eps)); +%! assert (nfun > 0); +%! assert (err < sqrt (eps)); + +%!test +%! [v, ier, nfun, err] = quad ("__f", single (0), single (5)); +%! assert (ier, 0); +%! assert (v, 17.5, sqrt (eps ("single"))); +%! assert (nfun > 0); +%! assert (err < sqrt (eps ("single"))); + +%!function y = __f (x) +%! y = x .* sin (1 ./ x) .* sqrt (abs (1 - x)); +%!endfunction + +%!test +%! [v, ier, nfun, err] = quad ("__f", 0.001, 3); +%! assert (ier == 0 || ier == 1); +%! assert (v, 1.98194120273598, sqrt (eps)); +%! assert (nfun > 0); + +%!test +%! [v, ier, nfun, err] = quad ("__f", single (0.001), single (3)); +%! assert (ier == 0 || ier == 1); +%! assert (v, 1.98194120273598, sqrt (eps ("single"))); +%! assert (nfun > 0); + +%!error quad () +%!error quad ("__f", 1, 2, 3, 4, 5) + +%!test +%! quad_options ("absolute tolerance", eps); +%! assert (quad_options ("absolute tolerance") == eps); + +%!error quad_options (1, 2, 3) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/quadcc.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,2268 @@ +/* + +Copyright (C) 2010-2012 Pedro Gonnet + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "lo-ieee.h" +#include "parse.h" +#include "variables.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" +#include "utils.h" + +//#include "oct.h" +//#include "defun.h" + +/* Define the size of the interval heap. */ +#define cquad_heapsize 200 + + +/* Data of a single interval */ +typedef struct +{ + double a, b; + double c[64]; + double fx[33]; + double igral, err; + int depth, rdepth, ndiv; +} cquad_ival; + +/* Some constants and matrices that we'll need. */ + +static const double xi[33] = { + -1., -0.99518472667219688624, -0.98078528040323044912, + -0.95694033573220886493, -0.92387953251128675612, + -0.88192126434835502970, -0.83146961230254523708, + -0.77301045336273696082, -0.70710678118654752440, + -0.63439328416364549822, -0.55557023301960222475, + -0.47139673682599764857, -0.38268343236508977173, + -0.29028467725446236764, -0.19509032201612826785, + -0.098017140329560601995, 0., 0.098017140329560601995, + 0.19509032201612826785, 0.29028467725446236764, 0.38268343236508977173, + 0.47139673682599764857, 0.55557023301960222475, 0.63439328416364549822, + 0.70710678118654752440, 0.77301045336273696082, 0.83146961230254523708, + 0.88192126434835502970, 0.92387953251128675612, 0.95694033573220886493, + 0.98078528040323044912, 0.99518472667219688624, 1. +}; + +static const double bee[68] = { + 0.00000000000000e+00, 2.28868854108532e-01, 0.00000000000000e+00, + -8.15740215243451e-01, 0.00000000000000e+00, 5.31212715259731e-01, + 0.00000000000000e+00, 1.38538036812454e-02, 0.00000000000000e+00, + 3.74405228908818e-02, 0.00000000000000e+00, 2.12224115039342e-01, + 0.00000000000000e+00, -8.16362644507898e-01, 0.00000000000000e+00, + 5.35648426691481e-01, 0.00000000000000e+00, 1.52417902753662e-03, + 0.00000000000000e+00, 2.63058840550873e-03, 0.00000000000000e+00, + 4.15292106318904e-03, 0.00000000000000e+00, 6.97106011119775e-03, + 0.00000000000000e+00, 1.35535708431058e-02, 0.00000000000000e+00, + 3.52132898424856e-02, 0.00000000000000e+00, 2.06946714741884e-01, + 0.00000000000000e+00, -8.15674251283876e-01, 0.00000000000000e+00, + 5.38841175520580e-01, 0.00000000000000e+00, 1.84909689577590e-04, + 0.00000000000000e+00, 2.90936325007499e-04, 0.00000000000000e+00, + 3.84877750950089e-04, 0.00000000000000e+00, 4.86436656735046e-04, + 0.00000000000000e+00, 6.08688640346879e-04, 0.00000000000000e+00, + 7.66732830740331e-04, 0.00000000000000e+00, 9.82753336104205e-04, + 0.00000000000000e+00, 1.29359957505615e-03, 0.00000000000000e+00, + 1.76616363801885e-03, 0.00000000000000e+00, 2.53323433039089e-03, + 0.00000000000000e+00, 3.88872172121956e-03, 0.00000000000000e+00, + 6.58635106468291e-03, 0.00000000000000e+00, 1.30326736343254e-02, + 0.00000000000000e+00, 3.44353850696714e-02, 0.00000000000000e+00, + 2.05025409531915e-01, 0.00000000000000e+00, -8.14985893995401e-01, + 0.00000000000000e+00, 5.40679930965238e-01 +}; + +static const double Lalpha[33] = { + 5.77350269189626e-01, 5.16397779494322e-01, 5.07092552837110e-01, + 5.03952630678970e-01, 5.02518907629606e-01, 5.01745206004255e-01, + 5.01280411827603e-01, 5.00979432868120e-01, 5.00773395667191e-01, + 5.00626174321759e-01, 5.00517330712619e-01, 5.00434593736979e-01, + 5.00370233297676e-01, 5.00319182924304e-01, 5.00278009473803e-01, + 5.00244319584578e-01, 5.00216403386025e-01, 5.00193012939056e-01, + 5.00173220168024e-01, 5.00156323280355e-01, 5.00141783641018e-01, + 5.00129182278347e-01, 5.00118189340972e-01, 5.00108542278496e-01, + 5.00100030010004e-01, 5.00092481273333e-01, 5.00085755939229e-01, + 5.00079738458365e-01, 5.00074332862969e-01, 5.00069458915387e-01, + 5.00065049112355e-01, 5.00061046334395e-01, 5.00057401986298e-01 +}; + +static const double Lgamma[33] = { + 0.0, 0.0, 5.16397779494322e-01, 5.07092552837110e-01, 5.03952630678970e-01, + 5.02518907629606e-01, 5.01745206004255e-01, 5.01280411827603e-01, + 5.00979432868120e-01, 5.00773395667191e-01, 5.00626174321759e-01, + 5.00517330712619e-01, 5.00434593736979e-01, 5.00370233297676e-01, + 5.00319182924304e-01, 5.00278009473803e-01, 5.00244319584578e-01, + 5.00216403386025e-01, 5.00193012939056e-01, 5.00173220168024e-01, + 5.00156323280355e-01, 5.00141783641018e-01, 5.00129182278347e-01, + 5.00118189340972e-01, 5.00108542278496e-01, 5.00100030010003e-01, + 5.00092481273333e-01, 5.00085755939229e-01, 5.00079738458365e-01, + 5.00074332862969e-01, 5.00069458915387e-01, 5.00065049112355e-01, + 5.00061046334395e-01 +}; + +static const double V1inv[5 * 5] = { + .47140452079103168293e-1, .37712361663282534635, .56568542494923801952, + .37712361663282534635, .47140452079103168293e-1, + -.81649658092772603273e-1, -.46188021535170061160, 0, + .46188021535170061160, .81649658092772603273e-1, .15058465048420853962, + .12046772038736683169, -.54210474174315074262, .12046772038736683169, + .15058465048420853962, -.21380899352993950775, .30237157840738178177, -0., + -.30237157840738178177, .21380899352993950775, .10774960475223581324, + -.21549920950447162648, .21549920950447162648, -.21549920950447162648, + .10774960475223581324 +}; + +static const double V2inv[9 * 9] = { + .11223917161691230546e-1, .10339219839658349826, .19754094204576565761, + .25577315077753587922, .27835314560994251755, .25577315077753587922, + .19754094204576565761, .10339219839658349826, .11223917161691230546e-1, + -.19440394783993476970e-1, -.16544884625069155470, -.24193725566041460608, + -.16953338808305493604, 0.0, .16953338808305493604, .24193725566041460608, + .16544884625069155470, .19440394783993476970e-1, .26466393115406349388e-1, + .17766815796285469394, .11316664642449611462, -.16306601003711325980, + -.30847037493128779631, -.16306601003711325980, .11316664642449611462, + .17766815796285469394, .26466393115406349388e-1, + -.32395302049990834508e-1, -.15521142532414866547, + .88573492664788602740e-1, .29570405784974857322, 0.0, + -.29570405784974857322, -.88573492664788602740e-1, .15521142532414866547, + .32395302049990834508e-1, .41442155673936851246e-1, + .98186757907405608245e-1, -.23056908429499411784, + -.68047008326360625520e-1, .31797435808002456774, + -.68047008326360625520e-1, -.23056908429499411784, + .98186757907405608245e-1, .41442155673936851246e-1, + -.49981120317798783134e-1, -.24861810572835756217e-1, + .23561326072010832539, -.24472785656448415351, 0.0, .24472785656448415351, + -.23561326072010832539, .24861810572835756217e-1, + .49981120317798783134e-1, .79691635865674781228e-1, + -.95725617891693941833e-1, -.57957553356854386344e-1, + .21164072460540271452, -.27529837844505833514, .21164072460540271452, + -.57957553356854386344e-1, -.95725617891693941833e-1, + .79691635865674781228e-1, + -.10894869830716590913, .20131094491947531782, -.15407672674888869038, + .83385723639789791384e-1, 0.0, -.83385723639789791384e-1, + .15407672674888869038, -.20131094491947531782, .10894869830716590913, + .54581057089643838221e-1, -.10916211417928767644, .10916211417928767644, + -.10916211417928767644, .10916211417928767644, -.10916211417928767644, + .10916211417928767644, -.10916211417928767644, .54581057089643838221e-1 +}; + +static const double V3inv[17 * 17] = { + .27729677693590098996e-2, .26423663180333065153e-1, + .53374068493933898312e-1, .77007854739523195947e-1, + .98257061072911596869e-1, .11538049741786835604, .12832134344120884559, + .13612785914022865001, .13888293186236181317, .13612785914022865001, + .12832134344120884559, .11538049741786835604, .98257061072911596869e-1, + .77007854739523195947e-1, .53374068493933898312e-1, + .26423663180333065153e-1, .27729677693590098996e-2, + -.48029210642807413690e-2, -.44887724635478800254e-1, + -.85409520147301089416e-1, -.11090267822061423050, -.12033983162705862441, + -.11102786862182788886, -.85054870109799336515e-1, + -.45998467987742225160e-1, 0.0, .45998467987742225160e-1, + .85054870109799336515e-1, .11102786862182788886, .12033983162705862441, + .11090267822061423050, .85409520147301089416e-1, .44887724635478800254e-1, + .48029210642807413690e-2, .62758546879582030087e-2, + .55561297093529155869e-1, + .93281491021051539742e-1, .92320151237493695139e-1, + .55077987469605684531e-1, + -.96998141716497488255e-2, -.80285961895427405567e-1, + -.13496839655913850224, + -.15512521776684524331, -.13496839655913850224, -.80285961895427405567e-1, + -.96998141716497488255e-2, .55077987469605684531e-1, + .92320151237493695139e-1, .93281491021051539742e-1, + .55561297093529155869e-1, .62758546879582030087e-2, + -.74850969394858555939e-2, -.61751608943839234096e-1, + -.82974150437304275958e-1, -.38437763431942633378e-1, + .45745502025779701366e-1, .12369235652734542162, .14720439712852868239, + .98768034347019704401e-1, 0.0, + -.98768034347019704401e-1, -.14720439712852868239, -.12369235652734542162, + -.45745502025779701366e-1, .38437763431942633378e-1, + .82974150437304275958e-1, .61751608943839234096e-1, + .74850969394858555939e-2, .86710099994384056338e-2, + .64006230103659573344e-1, .58517426396091675690e-1, + -.29743410528985802680e-1, + -.11934127779157114754, -.12686773515361299409, -.30729137153877447035e-1, + .97307836256600731568e-1, .15635811574451401023, .97307836256600731568e-1, + -.30729137153877447035e-1, -.12686773515361299409, -.11934127779157114754, + -.29743410528985802680e-1, .58517426396091675690e-1, + .64006230103659573344e-1, .86710099994384056338e-2, + -.97486395666294840165e-2, -.62995604908060224672e-1, + -.24373234450275529219e-1, .87760984413626872730e-1, + .12205204576993351394, + .16216004196864002088e-1, -.12422320942156845775, -.13682714580929614678, + 0.0, .13682714580929614678, .12422320942156845775, + -.16216004196864002088e-1, -.12205204576993351394, + -.87760984413626872730e-1, .24373234450275529219e-1, + .62995604908060224672e-1, .97486395666294840165e-2, + .10956271233750488468e-1, .58613204255294358939e-1, + -.13306063940736618859e-1, -.11606666444978454399, + -.52059598001115805639e-1, .10868540217796151849, .12594452879014618005, + -.44678658254872910434e-1, -.15617684362128533405, + -.44678658254872910434e-1, .12594452879014618005, .10868540217796151849, + -.52059598001115805639e-1, -.11606666444978454399, + -.13306063940736618859e-1, .58613204255294358939e-1, + .10956271233750488468e-1, -.12098893000863087230e-1, + -.51626244709126208453e-1, .48919433304746979330e-1, + .10467644465949427090, + -.48729879523084673782e-1, -.13668732103524749234, .28190838706814496438e-1, + .15434223333238741600, 0.0, -.15434223333238741600, + -.28190838706814496438e-1, .13668732103524749234, + .48729879523084673782e-1, -.10467644465949427090, + -.48919433304746979330e-1, .51626244709126208453e-1, + .12098893000863087230e-1, .13542668300437944822e-1, + .41712033418258689308e-1, + -.76190463272803434388e-1, -.58303943170068132010e-1, .12158068748245606853, + .42121099930651007882e-1, -.14684425840766337756, + -.16108203535058647043e-1, .15698075850757976092, + -.16108203535058647043e-1, -.14684425840766337756, + .42121099930651007882e-1, .12158068748245606853, + -.58303943170068132010e-1, -.76190463272803434388e-1, + .41712033418258689308e-1, .13542668300437944822e-1, + -.14939634995117694417e-1, -.30047246373341564039e-1, + .91624635082546425678e-1, -.79133374319110026377e-2, + -.12292558212072233355, .90013382617762643524e-1, + .84013717196539593395e-1, -.14813033309980695856, 0.0, + .14813033309980695856, -.84013717196539593395e-1, + -.90013382617762643524e-1, + .12292558212072233355, .79133374319110026377e-2, -.91624635082546425678e-1, + .30047246373341564039e-1, .14939634995117694417e-1, + .16986031342807474208e-1, + .15760203882617033601e-1, -.91494054040950941996e-1, + .70082459207876130806e-1, + .53390713710144539104e-1, -.14340746778352039430, .84048122493418898508e-1, + .72456667788091316868e-1, -.15564535320096811360, + .72456667788091316868e-1, .84048122493418898508e-1, + -.14340746778352039430, .53390713710144539104e-1, + .70082459207876130806e-1, -.91494054040950941996e-1, + .15760203882617033601e-1, + .16986031342807474208e-1, -.18994065631858742028e-1, + -.82901821370405592927e-3, .77239669773015192888e-1, + -.10850735431039424680, .47524484622086496464e-1, + .69148184871588737021e-1, -.14829314646228194928, .11992057742398672066, + 0.0, -.11992057742398672066, .14829314646228194928, + -.69148184871588737021e-1, -.47524484622086496464e-1, + .10850735431039424680, -.77239669773015192888e-1, + .82901821370405592927e-3, .18994065631858742028e-1, + .22761703826371535132e-1, -.17728848711449643358e-1, + -.47496371572480503788e-1, .10659958402328690063, -.11696013966166296514, + .63073750910894244526e-1, .32928881123602721303e-1, + -.12280950532497593683, .15926189077282729505, -.12280950532497593683, + .32928881123602721303e-1, .63073750910894244526e-1, + -.11696013966166296514, .10659958402328690063, -.47496371572480503788e-1, + -.17728848711449643358e-1, .22761703826371535132e-1, + -.26493215276042203434e-1, .35579780856128386192e-1, + .10447309718398935122e-1, -.68616154085314996709e-1, + .11775363082763954214, -.13918901977011837274, .12312819418827395690, + -.72053565748259077905e-1, 0.0, .72053565748259077905e-1, + -.12312819418827395690, .13918901977011837274, -.11775363082763954214, + .68616154085314996709e-1, -.10447309718398935122e-1, + -.35579780856128386192e-1, + .26493215276042203434e-1, .40742523354399706918e-1, + -.73124912999529117195e-1, .49317266444153837821e-1, + -.13686605413876015320e-1, -.28342624942191100464e-1, + .70371855298258216249e-1, -.10600251632853603875, .12981016288391131812, + -.13817029659318161476, .12981016288391131812, -.10600251632853603875, + .70371855298258216249e-1, -.28342624942191100464e-1, + -.13686605413876015320e-1, + .49317266444153837821e-1, -.73124912999529117195e-1, + .40742523354399706918e-1, -.54944368958699908688e-1, + .10777725663147408190, -.10152395581538265428, .91369146312596428468e-1, + -.77703071757424700773e-1, .61050911730999815031e-1, + -.42052599404498348871e-1, .21438229266251454773e-1, 0.0, + -.21438229266251454773e-1, .42052599404498348871e-1, + -.61050911730999815031e-1, .77703071757424700773e-1, + -.91369146312596428468e-1, + .10152395581538265428, -.10777725663147408190, .54944368958699908688e-1, + .27485608464748840573e-1, -.54971216929497681146e-1, + .54971216929497681146e-1, + -.54971216929497681146e-1, .54971216929497681146e-1, + -.54971216929497681146e-1, .54971216929497681146e-1, + -.54971216929497681146e-1, .54971216929497681146e-1, + -.54971216929497681146e-1, .54971216929497681146e-1, + -.54971216929497681146e-1, .54971216929497681146e-1, + -.54971216929497681146e-1, .54971216929497681146e-1, + -.54971216929497681146e-1, .27485608464748840573e-1 +}; + +static const double V4inv[33 * 33] = { + .69120897476690862600e-3, .66419939766331555194e-2, + .13600665164323186111e-1, .20122785860913684493e-1, + .26583214101668429944e-1, .32712713318999268739e-1, + .38576221976287138036e-1, .44033030938268925133e-1, + .49092709529622799673e-1, .53657949874312515646e-1, + .57724533144734311859e-1, .61219564530655179096e-1, + .64138907503837875026e-1, .66427905189318792009e-1, + .68088956652280022887e-1, .69083051391555695878e-1, + .69422738116739271449e-1, .69083051391555695878e-1, + .68088956652280022887e-1, .66427905189318792009e-1, + .64138907503837875026e-1, .61219564530655179096e-1, + .57724533144734311859e-1, .53657949874312515646e-1, + .49092709529622799673e-1, .44033030938268925133e-1, + .38576221976287138036e-1, .32712713318999268739e-1, + .26583214101668429944e-1, .20122785860913684493e-1, + .13600665164323186111e-1, .66419939766331555194e-2, + .69120897476690862600e-3, -.11972090629438798134e-2, + -.11448874821643225573e-1, -.23104401104002905904e-1, + -.33352899418646530133e-1, -.42538626424075425908e-1, + -.49969730733911825941e-1, -.55555454015360728353e-1, + -.58955533624852604918e-1, -.60126044219122513907e-1, + -.58959430451175833624e-1, -.55546925396227130606e-1, + -.49984739749347973762e-1, -.42513009141170294365e-1, + -.33399140950669746346e-1, -.23007690803851790829e-1, + -.11728275717520066169e-1, 0.0, .11728275717520066169e-1, + .23007690803851790829e-1, .33399140950669746346e-1, + .42513009141170294365e-1, .49984739749347973762e-1, + .55546925396227130606e-1, .58959430451175833624e-1, + .60126044219122513907e-1, .58955533624852604918e-1, + .55555454015360728353e-1, .49969730733911825941e-1, + .42538626424075425908e-1, .33352899418646530133e-1, + .23104401104002905904e-1, .11448874821643225573e-1, + .11972090629438798134e-2, .15501585012936019146e-2, + .14628781502199620482e-1, .28684915921474815271e-1, + .39299396074628048026e-1, .46393418975496284204e-1, + .48756902531094699526e-1, .46331333488337494692e-1, + .39012645376980228775e-1, .27452795421085791153e-1, + .12430953621169863781e-1, -.47682978056024928800e-2, + -.22825828045428973853e-1, + -.40195512090720278312e-1, -.55503004262826221955e-1, + -.67424537752827046308e-1, -.75020199300113606452e-1, + -.77607844312483656131e-1, -.75020199300113606452e-1, + -.67424537752827046308e-1, -.55503004262826221955e-1, + -.40195512090720278312e-1, -.22825828045428973853e-1, + -.47682978056024928800e-2, .12430953621169863781e-1, + .27452795421085791153e-1, .39012645376980228775e-1, + .46331333488337494692e-1, .48756902531094699526e-1, + .46393418975496284204e-1, .39299396074628048026e-1, + .28684915921474815271e-1, .14628781502199620482e-1, + .15501585012936019146e-2, -.18377757558949194214e-2, + -.17050470050949761565e-1, -.31952119564923250836e-1, + -.40197423449026348155e-1, + -.41205649520281371624e-1, -.33909965817492272248e-1, + -.19393664422115332144e-1, .56661049630886784692e-3, + .22948272173686561721e-1, .44489719570904738207e-1, + .61790363672287920596e-1, .72121014727028013894e-1, + .73627151185287858579e-1, .65784665375961398923e-1, + .49369676372333667559e-1, .26444326317059715065e-1, 0.0, + -.26444326317059715065e-1, -.49369676372333667559e-1, + -.65784665375961398923e-1, -.73627151185287858579e-1, + -.72121014727028013894e-1, -.61790363672287920596e-1, + -.44489719570904738207e-1, -.22948272173686561721e-1, + -.56661049630886784692e-3, .19393664422115332144e-1, + .33909965817492272248e-1, .41205649520281371624e-1, + .40197423449026348155e-1, .31952119564923250836e-1, + .17050470050949761565e-1, .18377757558949194214e-2, + .20942714740729767769e-2, .18935902405146518232e-1, + .33335840852491735126e-1, .36770680999102286065e-1, + .28873194534132768509e-1, .10267303017729535513e-1, + -.14607738306201572890e-1, -.40139568545572305818e-1, + -.59808326733858291561e-1, -.68528358823372627506e-1, + -.63306535387619244879e-1, -.44508601817574921056e-1, + -.15449116105605395357e-1, .17941083795006546367e-1, + .48747356011657242123e-1, .70329553984201665523e-1, + .78106117292526169663e-1, .70329553984201665523e-1, + .48747356011657242123e-1, .17941083795006546367e-1, + -.15449116105605395357e-1, -.44508601817574921056e-1, + -.63306535387619244879e-1, -.68528358823372627506e-1, + -.59808326733858291561e-1, + -.40139568545572305818e-1, -.14607738306201572890e-1, + .10267303017729535513e-1, .28873194534132768509e-1, + .36770680999102286065e-1, .33335840852491735126e-1, + .18935902405146518232e-1, .20942714740729767769e-2, + -.23245285491878278419e-2, -.20401404737639389919e-1, + -.33019548231022514097e-1, -.29709828426463720091e-1, + -.11760070922697422156e-1, .15987584743850393793e-1, + .43619012891472813485e-1, .61177322409671487721e-1, + .61144030218486655594e-1, + .41895377620089086167e-1, .80232011820644308033e-2, + -.30574701186675900915e-1, + -.62072243008844865848e-1, -.76336186183574765586e-1, + -.68435466095345537115e-1, -.40237669208466966207e-1, 0.0, + .40237669208466966207e-1, .68435466095345537115e-1, + .76336186183574765586e-1, .62072243008844865848e-1, + .30574701186675900915e-1, -.80232011820644308033e-2, + -.41895377620089086167e-1, -.61144030218486655594e-1, + -.61177322409671487721e-1, -.43619012891472813485e-1, + -.15987584743850393793e-1, .11760070922697422156e-1, + .29709828426463720091e-1, .33019548231022514097e-1, + .20401404737639389919e-1, .23245285491878278419e-2, + .25451717261579269307e-2, .21480418595666878775e-1, + .31177212469293007998e-1, .19816333607013379373e-1, + -.72439496274458793681e-2, -.38404203906598342397e-1, + -.57633632255322221046e-1, -.54070547403585392952e-1, + -.26249823354368866005e-1, .15643058212336881516e-1, + .54539832735118677194e-1, .73283028002473989724e-1, + .62835303524135936213e-1, .26175977027801048141e-1, + -.22193636309998606610e-1, -.62597049956093311234e-1, + -.78206986173170212505e-1, -.62597049956093311234e-1, + -.22193636309998606610e-1, .26175977027801048141e-1, + .62835303524135936213e-1, + .73283028002473989724e-1, .54539832735118677194e-1, + .15643058212336881516e-1, + -.26249823354368866005e-1, -.54070547403585392952e-1, + -.57633632255322221046e-1, -.38404203906598342397e-1, + -.72439496274458793681e-2, .19816333607013379373e-1, + .31177212469293007998e-1, .21480418595666878775e-1, + .25451717261579269307e-2, -.27506573922483820005e-2, + -.22224442095099251870e-1, -.27949927254215773020e-1, + -.80918481053370034987e-2, .25121859354449306916e-1, + .51563535009373061074e-1, .51936965107145960512e-1, + .22146626648171527753e-1, + -.24172689882103382748e-1, -.61731229104853568296e-1, + -.68477262429344201201e-1, -.38311232728303704742e-1, + .14160578713659552679e-1, .61248813427564184033e-1, + .77136328841293031805e-1, .52514801765183697988e-1, 0.0, + -.52514801765183697988e-1, -.77136328841293031805e-1, + -.61248813427564184033e-1, -.14160578713659552679e-1, + .38311232728303704742e-1, + .68477262429344201201e-1, .61731229104853568296e-1, + .24172689882103382748e-1, + -.22146626648171527753e-1, -.51936965107145960512e-1, + -.51563535009373061074e-1, -.25121859354449306916e-1, + .80918481053370034987e-2, .27949927254215773020e-1, + .22224442095099251870e-1, .27506573922483820005e-2, + .29562461131654311467e-2, .22630271480554450613e-1, + .23547399831373800971e-1, -.43964593440902476642e-2, + -.39055315767504970597e-1, -.52369643937940066804e-1, + -.28506131614971613422e-1, .19906048093338832322e-1, + .60408880866392420279e-1, .62493397473656883090e-1, + .21391278377641297859e-1, -.37302864786623254746e-1, + -.73665127933539496872e-1, -.61706142476854010202e-1, + -.78065168882546327888e-2, .52335307373945544428e-1, + .78278746279419264777e-1, .52335307373945544428e-1, + -.78065168882546327888e-2, -.61706142476854010202e-1, + -.73665127933539496872e-1, -.37302864786623254746e-1, + .21391278377641297859e-1, .62493397473656883090e-1, + .60408880866392420279e-1, .19906048093338832322e-1, + -.28506131614971613422e-1, -.52369643937940066804e-1, + -.39055315767504970597e-1, -.43964593440902476642e-2, + .23547399831373800971e-1, .22630271480554450613e-1, + .29562461131654311467e-2, -.31515718415504761303e-2, + -.22739451096655080673e-1, -.18157123602272119779e-1, + .16496480897167303621e-1, .46921166788569301124e-1, + .40644395739978416354e-1, -.46275803430732216900e-2, + -.52883375891308909486e-1, -.61116483226324111734e-1, + -.17411698764545629853e-1, .44773430013166822765e-1, + .73441577962383869198e-1, .42127368371995472815e-1, + -.25504645957196772465e-1, -.74126818045972742488e-1, + -.62780077864719287317e-1, 0.0, .62780077864719287317e-1, + .74126818045972742488e-1, .25504645957196772465e-1, + -.42127368371995472815e-1, -.73441577962383869198e-1, + -.44773430013166822765e-1, .17411698764545629853e-1, + .61116483226324111734e-1, .52883375891308909486e-1, + .46275803430732216900e-2, -.40644395739978416354e-1, + -.46921166788569301124e-1, -.16496480897167303621e-1, + .18157123602272119779e-1, .22739451096655080673e-1, + .31515718415504761303e-2, .33536559294882188208e-2, + .22535348942792006185e-1, + .12048629300953560767e-1, -.27166076791299493403e-1, + -.47492745604230978367e-1, -.19246623430993153174e-1, + .36231297307556299322e-1, .61713617181636122004e-1, + .25928029734266134490e-1, -.40478700752883602818e-1, + -.71053889866326412049e-1, -.31870824482961751482e-1, + .41515251100219081281e-1, .76481960760098381651e-1, + .36726509155999912440e-1, -.40090067032627055969e-1, + -.78270742903374539397e-1, -.40090067032627055969e-1, + .36726509155999912440e-1, .76481960760098381651e-1, + .41515251100219081281e-1, -.31870824482961751482e-1, + -.71053889866326412049e-1, -.40478700752883602818e-1, + .25928029734266134490e-1, .61713617181636122004e-1, + .36231297307556299322e-1, -.19246623430993153174e-1, + -.47492745604230978367e-1, -.27166076791299493403e-1, + .12048629300953560767e-1, .22535348942792006185e-1, + .33536559294882188208e-2, + -.35481220456925318865e-2, -.22062913693073191150e-1, + -.54487362861834144999e-2, .35438821865804087489e-1, + .40733077820527411302e-1, -.67403098138950720914e-2, + -.55559584405239171054e-1, -.42417050790865158745e-1, + .24499901971884704925e-1, .68721232891705409302e-1, + .34086082787461126592e-1, -.43441000373118474002e-1, + -.73878085292669148950e-1, -.18846995664706657127e-1, + .59827776178286834498e-1, .70644634584085901794e-1, 0.0, + -.70644634584085901794e-1, -.59827776178286834498e-1, + .18846995664706657127e-1, .73878085292669148950e-1, + .43441000373118474002e-1, -.34086082787461126592e-1, + -.68721232891705409302e-1, -.24499901971884704925e-1, + .42417050790865158745e-1, .55559584405239171054e-1, + .67403098138950720914e-2, -.40733077820527411302e-1, + -.35438821865804087489e-1, .54487362861834144999e-2, + .22062913693073191150e-1, .35481220456925318865e-2, + .37554176816665075631e-2, .21297045781589919482e-1, + -.13327293083183431816e-2, + -.40635299172764596484e-1, -.27659860508374175359e-1, + .31089232744083445986e-1, .56113781541334176109e-1, + .37577840643257763400e-2, -.60511227350664590865e-1, + -.46670556446129053853e-1, .33263195878575888247e-1, + .72757324720645228775e-1, .15011712351692283635e-1, + -.65601212994924119078e-1, -.60016855838843789772e-1, + .26220858553188665966e-1, .78322776605833552980e-1, + .26220858553188665966e-1, -.60016855838843789772e-1, + -.65601212994924119078e-1, + .15011712351692283635e-1, .72757324720645228775e-1, + .33263195878575888247e-1, + -.46670556446129053853e-1, -.60511227350664590865e-1, + .37577840643257763400e-2, .56113781541334176109e-1, + .31089232744083445986e-1, -.27659860508374175359e-1, + -.40635299172764596484e-1, -.13327293083183431816e-2, + .21297045781589919482e-1, .37554176816665075631e-2, + -.39566995305720591229e-2, -.20291873414438919995e-1, + .80617453830770930551e-2, .42270189157016547906e-1, + .10332624526759093004e-1, -.48054759547616142024e-1, + -.37678032941171643972e-1, + .36617192625732482394e-1, .61009425973424865714e-1, + -.95589113168026591466e-2, + -.71023202645076922361e-1, -.25097788086808784456e-1, + .62406621963267050244e-1, .56907293171100693511e-1, + -.36435383083882206257e-1, -.75790105119208756348e-1, 0.0, + .75790105119208756348e-1, .36435383083882206257e-1, + -.56907293171100693511e-1, -.62406621963267050244e-1, + .25097788086808784456e-1, .71023202645076922361e-1, + .95589113168026591466e-2, + -.61009425973424865714e-1, -.36617192625732482394e-1, + .37678032941171643972e-1, .48054759547616142024e-1, + -.10332624526759093004e-1, -.42270189157016547906e-1, + -.80617453830770930551e-2, .20291873414438919995e-1, + .39566995305720591229e-2, .41776092289182138591e-2, + .19013221163904414395e-1, -.14420609729849899876e-1, + -.40259160586844441220e-1, .86327811113710831649e-2, + .53564430703021034399e-1, .65469185402150431933e-2, + -.60383116311280629856e-1, + -.25657793784058876939e-1, .58745680576829226900e-1, + .45649937869034420296e-1, + -.49167932056844167772e-1, -.62696614328552187977e-1, + .32540234556426699997e-1, .74280410383464269758e-1, + -.11425672633410999870e-1, -.78280649404686404903e-1, + -.11425672633410999870e-1, .74280410383464269758e-1, + .32540234556426699997e-1, -.62696614328552187977e-1, + -.49167932056844167772e-1, .45649937869034420296e-1, + .58745680576829226900e-1, -.25657793784058876939e-1, + -.60383116311280629856e-1, .65469185402150431933e-2, + .53564430703021034399e-1, + .86327811113710831649e-2, -.40259160586844441220e-1, + -.14420609729849899876e-1, .19013221163904414395e-1, + .41776092289182138591e-2, -.43935502082478059199e-2, + -.17528761237509401631e-1, .20208915249153872535e-1, + .34734743119040669109e-1, -.26275910172353637955e-1, + -.46368003346018878786e-1, + .26800056330709381025e-1, .56681476464606609921e-1, + -.24749011438127255898e-1, + -.64934612189056658992e-1, .20333742247679279535e-1, + .71429299070059318651e-1, + -.14452513210428671266e-1, -.75793341281736586582e-1, + .74717094137184935270e-2, .78034921554757317374e-1, 0.0, + -.78034921554757317374e-1, -.74717094137184935270e-2, + .75793341281736586582e-1, .14452513210428671266e-1, + -.71429299070059318651e-1, -.20333742247679279535e-1, + .64934612189056658992e-1, .24749011438127255898e-1, + -.56681476464606609921e-1, + -.26800056330709381025e-1, .46368003346018878786e-1, + .26275910172353637955e-1, + -.34734743119040669109e-1, -.20208915249153872535e-1, + .17528761237509401631e-1, .43935502082478059199e-2, + .46379089482818671473e-2, .15791188144791287229e-1, + -.25134290048737455284e-1, -.26249795071946841205e-1, + .39960457575789924651e-1, .28111892450146525404e-1, + -.51026476400767918226e-1, + -.27266747278681831364e-1, .60708796647861610865e-1, + .23532306960642115854e-1, + -.68169639871532441111e-1, -.18204924701958312032e-1, + .73822890510656128485e-1, .11373392486424717019e-1, + -.77133324017644609416e-1, -.39295877480342619961e-2, + .78351902829418987960e-1, -.39295877480342619961e-2, + -.77133324017644609416e-1, .11373392486424717019e-1, + .73822890510656128485e-1, -.18204924701958312032e-1, + -.68169639871532441111e-1, .23532306960642115854e-1, + .60708796647861610865e-1, -.27266747278681831364e-1, + -.51026476400767918226e-1, .28111892450146525404e-1, + .39960457575789924651e-1, -.26249795071946841205e-1, + -.25134290048737455284e-1, .15791188144791287229e-1, + .46379089482818671473e-2, -.48780095920069827068e-2, + -.13886961667516983541e-1, .29071311049368895844e-1, + .15480559452075811600e-1, -.47527977686242313065e-1, + -.31929089844361042178e-2, .58015667638415922967e-1, + -.14547915466597622925e-1, -.61067668299848923244e-1, + .35093678009090186851e-1, .55378399159800654657e-1, + -.54277226474891610385e-1, -.42023830782434076509e-1, + .69197384645944912066e-1, .22610783557709586445e-1, + -.77269275900637030185e-1, 0.0, .77269275900637030185e-1, + -.22610783557709586445e-1, + -.69197384645944912066e-1, .42023830782434076509e-1, + .54277226474891610385e-1, + -.55378399159800654657e-1, -.35093678009090186851e-1, + .61067668299848923244e-1, .14547915466597622925e-1, + -.58015667638415922967e-1, .31929089844361042178e-2, + .47527977686242313065e-1, -.15480559452075811600e-1, + -.29071311049368895844e-1, .13886961667516983541e-1, + .48780095920069827068e-2, .51591759101720291381e-2, + .11747497650231330965e-1, -.31777863364694653331e-1, + -.34555825499804605557e-2, .47914131921157015198e-1, + -.22573685920142225247e-1, -.45320344390022666738e-1, + .49660630547172186418e-1, .25707858143963615736e-1, + -.68132707341917233933e-1, .67534860185243140399e-2, + .69268150370037450063e-1, -.41585011920451477177e-1, + -.51622397460510041271e-1, .68408139576363036148e-1, + .18981259024768933323e-1, -.78265472429342305554e-1, + .18981259024768933323e-1, .68408139576363036148e-1, + -.51622397460510041271e-1, + -.41585011920451477177e-1, .69268150370037450063e-1, + .67534860185243140399e-2, + -.68132707341917233933e-1, .25707858143963615736e-1, + .49660630547172186418e-1, + -.45320344390022666738e-1, -.22573685920142225247e-1, + .47914131921157015198e-1, -.34555825499804605557e-2, + -.31777863364694653331e-1, .11747497650231330965e-1, + .51591759101720291381e-2, -.54365757412741340377e-2, + -.94862516619529080191e-2, .33240472093448190877e-1, + -.88698898099681552229e-2, + -.40973252097216337576e-1, .42995673349795657065e-1, + .17320914507876958783e-1, + -.62201292691914856803e-1, .24726274174637346693e-1, + .51320859246515407288e-1, + -.62882063373810501763e-1, -.11003569131725622672e-1, + .73842261324108943465e-1, -.39240120294802923208e-1, + -.49293966443941122807e-1, .73552644778818223475e-1, 0.0, + -.73552644778818223475e-1, .49293966443941122807e-1, + .39240120294802923208e-1, -.73842261324108943465e-1, + .11003569131725622672e-1, .62882063373810501763e-1, + -.51320859246515407288e-1, + -.24726274174637346693e-1, .62201292691914856803e-1, + -.17320914507876958783e-1, -.42995673349795657065e-1, + .40973252097216337576e-1, .88698898099681552229e-2, + -.33240472093448190877e-1, .94862516619529080191e-2, + .54365757412741340377e-2, .57750194549356126240e-2, + .69981166020044116791e-2, -.33274982140403110792e-1, + .20297071020698356116e-1, .27898517839646066582e-1, + -.53368678853282030262e-1, .16656482990394548343e-1, + .46342901447260614255e-1, + -.60536796508149003365e-1, .29109107483842596340e-2, + .63224486124385124504e-1, + -.59028872851312033411e-1, -.14783105962696191734e-1, + .74269399241069253865e-1, -.49053677339382384625e-1, + -.33525466624811186739e-1, .78397349622515386647e-1, + -.33525466624811186739e-1, -.49053677339382384625e-1, + .74269399241069253865e-1, -.14783105962696191734e-1, + -.59028872851312033411e-1, + .63224486124385124504e-1, .29109107483842596340e-2, + -.60536796508149003365e-1, + .46342901447260614255e-1, .16656482990394548343e-1, + -.53368678853282030262e-1, + .27898517839646066582e-1, .20297071020698356116e-1, + -.33274982140403110792e-1, + .69981166020044116791e-2, .57750194549356126240e-2, + -.61100308370519200637e-2, -.44383614355738148616e-2, + .32011283412619094811e-1, -.29965011866372897633e-1, + -.10560682331349193348e-1, .51110336443392506342e-1, + -.45012284729681775492e-1, -.94236825555873320102e-2, + .60860695783141264746e-1, + -.55014628647083368926e-1, -.73474782382499482121e-2, + .66640148475243034781e-1, -.62533116045749887988e-1, + -.38650525912400102585e-2, .68429769005837003777e-1, + -.66984505412544901945e-1, 0.0, .66984505412544901945e-1, + -.68429769005837003777e-1, .38650525912400102585e-2, + .62533116045749887988e-1, -.66640148475243034781e-1, + .73474782382499482121e-2, + .55014628647083368926e-1, -.60860695783141264746e-1, + .94236825555873320102e-2, + .45012284729681775492e-1, -.51110336443392506342e-1, + .10560682331349193348e-1, + .29965011866372897633e-1, -.32011283412619094811e-1, + .44383614355738148616e-2, + .61100308370519200637e-2, .65409373892036191538e-2, + .16350101107071157065e-2, -.29301957285983144319e-1, + .36838667173388832579e-1, -.81922703976491586393e-2, + -.36955670021050133434e-1, .58374851095540469865e-1, + -.31977016246946181856e-1, -.25311073698658094646e-1, + .66674413950106952577e-1, + -.54865713324521039571e-1, -.39797027891537985440e-2, + .62830285264808449064e-1, -.72226313251296100676e-1, + .22560232697133353980e-1, .46455784709904033738e-1, + -.78200930751070349956e-1, .46455784709904033738e-1, + .22560232697133353980e-1, -.72226313251296100676e-1, + .62830285264808449064e-1, -.39797027891537985440e-2, + -.54865713324521039571e-1, .66674413950106952577e-1, + -.25311073698658094646e-1, -.31977016246946181856e-1, + .58374851095540469865e-1, -.36955670021050133434e-1, + -.81922703976491586393e-2, .36838667173388832579e-1, + -.29301957285983144319e-1, .16350101107071157065e-2, + .65409373892036191538e-2, -.69686180931868703196e-2, + .11849538727632789870e-2, .25452286414610537766e-1, + -.40522480651713943230e-1, .25694679053362813183e-1, + .14057118113748390637e-1, -.52037614725803488893e-1, + .58849342223684035589e-1, + -.25075229077361409271e-1, -.29559771094034181083e-1, + .68296746944165720199e-1, -.62890462146423984955e-1, + .14457636466274596445e-1, .45787612031322361496e-1, + -.77231759014655809742e-1, .57881203613910543657e-1, 0.0, + -.57881203613910543657e-1, .77231759014655809742e-1, + -.45787612031322361496e-1, -.14457636466274596445e-1, + .62890462146423984955e-1, + -.68296746944165720199e-1, .29559771094034181083e-1, + .25075229077361409271e-1, + -.58849342223684035589e-1, .52037614725803488893e-1, + -.14057118113748390637e-1, -.25694679053362813183e-1, + .40522480651713943230e-1, -.25452286414610537766e-1, + -.11849538727632789870e-2, .69686180931868703196e-2, + .75611653617520254845e-2, -.43290610418608409141e-2, + -.20277062025115566914e-1, + .40362947027704828926e-1, -.38938808024132120254e-1, + .11831186195916702262e-1, + .28476667401744525357e-1, -.59320969056617684621e-1, + .61101629747436200186e-1, + -.29514834848355389223e-1, -.20668001885001084821e-1, + .62923592802445122793e-1, -.73558456263588833115e-1, + .45314556330160999776e-1, .79031645918426015574e-2, + -.58136953576334689357e-1, .78538474524006405758e-1, + -.58136953576334689357e-1, .79031645918426015574e-2, + .45314556330160999776e-1, -.73558456263588833115e-1, + .62923592802445122793e-1, -.20668001885001084821e-1, + -.29514834848355389223e-1, .61101629747436200186e-1, + -.59320969056617684621e-1, .28476667401744525357e-1, + .11831186195916702262e-1, -.38938808024132120254e-1, + .40362947027704828926e-1, -.20277062025115566914e-1, + -.43290610418608409141e-2, .75611653617520254845e-2, + -.81505692478987769484e-2, .74297333588288568430e-2, + .14314212513540223314e-1, -.36711242251332751607e-1, + .46240027755503814626e-1, -.34921532671769023773e-1, + .46930051972353714773e-2, + .32842770336385381562e-1, -.61317813706529588466e-1, + .67000809902468893103e-1, + -.45337449655535622885e-1, .35794459576271920867e-2, + .41830061526027213385e-1, + -.72091371931944711708e-1, .74150028530317793195e-1, + -.46487632538609942002e-1, 0.0, .46487632538609942002e-1, + -.74150028530317793195e-1, .72091371931944711708e-1, + -.41830061526027213385e-1, -.35794459576271920867e-2, + .45337449655535622885e-1, -.67000809902468893103e-1, + .61317813706529588466e-1, -.32842770336385381562e-1, + -.46930051972353714773e-2, .34921532671769023773e-1, + -.46240027755503814626e-1, .36711242251332751607e-1, + -.14314212513540223314e-1, -.74297333588288568430e-2, + .81505692478987769484e-2, .90693182942442189743e-2, + -.11121000903959576737e-1, -.71308296141317458546e-2, + .29219439765986671645e-1, -.45820286629778129593e-1, + .49088381175879124421e-1, -.35614888785023038938e-1, + .78906970900092777895e-2, + .26262843038404929480e-1, -.56143674270125757857e-1, + .71700220472378350694e-1, + -.66963544500697307945e-1, .42215091779892228883e-1, + -.41338867413966866997e-2, -.36164891772995367321e-1, + .66584367783847858225e-1, -.77874712365070098328e-1, + .66584367783847858225e-1, -.36164891772995367321e-1, + -.41338867413966866997e-2, .42215091779892228883e-1, + -.66963544500697307945e-1, + .71700220472378350694e-1, -.56143674270125757857e-1, + .26262843038404929480e-1, + .78906970900092777895e-2, -.35614888785023038938e-1, + .49088381175879124421e-1, + -.45820286629778129593e-1, .29219439765986671645e-1, + -.71308296141317458546e-2, -.11121000903959576737e-1, + .90693182942442189743e-2, -.99848472706332791043e-2, + .14701271465939718856e-1, -.32917820356048383366e-3, + -.19201195309873585230e-1, .38409681836626963278e-1, + -.51647324405878909521e-1, .54522171113149311354e-1, + -.45040302741689006270e-1, .24183738595685990149e-1, + .42204134165479735097e-2, -.34317295181348742251e-1, + .59542472465494579941e-1, -.74135115907618101263e-1, + .74491937840566532596e-1, -.60042604725161994304e-1, + .33437677409000083169e-1, 0.0, + -.33437677409000083169e-1, .60042604725161994304e-1, + -.74491937840566532596e-1, .74135115907618101263e-1, + -.59542472465494579941e-1, .34317295181348742251e-1, + -.42204134165479735097e-2, -.24183738595685990149e-1, + .45040302741689006270e-1, -.54522171113149311354e-1, + .51647324405878909521e-1, -.38409681836626963278e-1, + .19201195309873585230e-1, .32917820356048383366e-3, + -.14701271465939718856e-1, .99848472706332791043e-2, + .11775579274769383373e-1, -.19892153937316935880e-1, + .95335114477449041055e-2, .57661528440359081617e-2, + -.23382690532380910781e-1, .40237257037170725321e-1, + -.53280289903551636474e-1, .59974361806023689068e-1, + -.58701684061992853224e-1, .49033407111597129616e-1, + -.31818835267847249219e-1, .90800541261162098886e-2, + .16272906819312603838e-1, -.40863896581186229487e-1, + .61346046297517367703e-1, + -.74896047554167268919e-1, .79632642148310325817e-1, + -.74896047554167268919e-1, .61346046297517367703e-1, + -.40863896581186229487e-1, .16272906819312603838e-1, + .90800541261162098886e-2, -.31818835267847249219e-1, + .49033407111597129616e-1, -.58701684061992853224e-1, + .59974361806023689068e-1, -.53280289903551636474e-1, + .40237257037170725321e-1, -.23382690532380910781e-1, + .57661528440359081617e-2, .95335114477449041055e-2, + -.19892153937316935880e-1, + .11775579274769383373e-1, -.13562702617218467450e-1, + .24885419969649845849e-1, -.18368693901908875583e-1, + .81673147806084084638e-2, .47890591326129587131e-2, + -.19313752945227974024e-1, .34065953398362954708e-1, + -.47667045133463415672e-1, .58820377816690514309e-1, + -.66424139824618415970e-1, + .69667606260856092515e-1, -.68102459384364543253e-1, + .61683024923302547971e-1, + -.50771943476441639136e-1, .36110771847327189215e-1, + -.18758028464284563358e-1, 0.0, .18758028464284563358e-1, + -.36110771847327189215e-1, .50771943476441639136e-1, + -.61683024923302547971e-1, .68102459384364543253e-1, + -.69667606260856092515e-1, .66424139824618415970e-1, + -.58820377816690514309e-1, .47667045133463415672e-1, + -.34065953398362954708e-1, .19313752945227974024e-1, + -.47890591326129587131e-2, -.81673147806084084638e-2, + .18368693901908875583e-1, -.24885419969649845849e-1, + .13562702617218467450e-1, .20576545037980523979e-1, + -.40093155172981004337e-1, .36954083167944054826e-1, + -.31856506837591907746e-1, .24996323181546255126e-1, + -.16637165210473614136e-1, .71002706773325085237e-2, + .32478629093205201133e-2, + -.14009562579050569518e-1, .24771262248780618922e-1, + -.35119395835433647559e-1, .44656290368574753171e-1, + -.53015448339647394161e-1, .59875631995693046782e-1, + -.64973208326045193862e-1, .68112280331082143373e-1, + -.69172215234062186994e-1, .68112280331082143373e-1, + -.64973208326045193862e-1, .59875631995693046782e-1, + -.53015448339647394161e-1, .44656290368574753171e-1, + -.35119395835433647559e-1, .24771262248780618922e-1, + -.14009562579050569518e-1, .32478629093205201133e-2, + .71002706773325085237e-2, -.16637165210473614136e-1, + .24996323181546255126e-1, -.31856506837591907746e-1, + .36954083167944054826e-1, -.40093155172981004337e-1, + .20576545037980523979e-1, -.27584914609096156163e-1, + .54904171411058497973e-1, -.54109756419563083153e-1, + .52794234894345577483e-1, -.50970276026831042415e-1, + .48655445537990983379e-1, + -.45872036510847994332e-1, .42646854695899611372e-1, + -.39010960357087507670e-1, .34999369144476467749e-1, + -.30650714874402762189e-1, .26006877464703437057e-1, + -.21112579608213651273e-1, .16014956068786763273e-1, + -.10763099747751940252e-1, .54075888924374485533e-2, 0.0, + -.54075888924374485533e-2, .10763099747751940252e-1, + -.16014956068786763273e-1, + .21112579608213651273e-1, -.26006877464703437057e-1, + .30650714874402762189e-1, + -.34999369144476467749e-1, .39010960357087507670e-1, + -.42646854695899611372e-1, .45872036510847994332e-1, + -.48655445537990983379e-1, .50970276026831042415e-1, + -.52794234894345577483e-1, .54109756419563083153e-1, + -.54904171411058497973e-1, .27584914609096156163e-1, + .13794141262469565740e-1, -.27588282524939131481e-1, + .27588282524939131481e-1, -.27588282524939131481e-1, + .27588282524939131481e-1, -.27588282524939131481e-1, + .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .27588282524939131481e-1, + -.27588282524939131481e-1, .13794141262469565740e-1 +}; + +static const double Tleft[33 * 33] = { + 1., -.86602540378443864678, 0., .33071891388307382381, 0., + -.20728904939721249057, 0., .15128841196122722208, 0., + -.11918864298744029244, 0., .98352013661686631224e-1, 0., + -.83727065404940845733e-1, 0., .72893399403505841203e-1, 0., + -.64544632643375022436e-1, 0., .57913170372415565639e-1, 0., + -.52518242575729562263e-1, 0., .48043311993977520457e-1, 0., + -.44271433659733990243e-1, 0., .41048928022856771981e-1, 0., + -.38263878662008271459e-1, 0., .35832844026365304501e-1, 0., 0., + .50000000000000000000, -.96824583655185422130, .57282196186948000082, + .21650635094610966169, -.35903516540862679125, -.97578093724974971969e-1, + .26203921611325660506, .55792409597991015609e-1, -.20644078533943456204, + -.36172381205961199479e-1, .17035068468874958194, + .25371838001497225980e-1, -.14501953125000000000, + -.18786835250972344757e-1, .12625507130328301066, + .14473795929590520582e-1, -.11179458309419422675, + -.11494434254897626155e-1, .10030855351241635862, + .93498556820544479096e-2, -.90964264465390582629e-1, + -.77546391824364392762e-2, .83213457337452292745e-1, + .65358085945588638605e-2, -.76680372422574234569e-1, + -.55835321940047427169e-2, .71098828931825789428e-1, + .48253327982967591019e-2, -.66274981937248958553e-1, + -.42118078245337801387e-2, .62064306433355646267e-1, + .37083386598903548973e-2, 0., 0., .25000000000000000000, + -.73950997288745200531, .83852549156242113615, -.23175620272173946716, + -.37791833195149451496, .25710129174850522325, .21608307321780204633, + -.22844049245646009157, -.14009503000335388415, .19897685605518413847, + .98264706042471226893e-1, -.17445445004279014046, + -.72761100054958328401e-1, .15463589893742108388, + .56056770591708784481e-1, -.13855313872640495158, + -.44517752443294564781e-1, .12534277657695128850, + .36211835346039665762e-1, -.11434398255136139683, + -.30033588409423828125e-1, .10506705408753910481, + .25313077840725783008e-1, -.97149327637744872155e-1, + -.21624927200393328444e-1, .90319582367202122625e-1, + .18688433567711780666e-1, -.84372291635345108584e-1, + -.16312261561845420752e-1, .79149526894804751586e-1, + .14362333871852474757e-1, 0., 0., 0., .12500000000000000000, + -.49607837082461073572, .82265291131801144317, -.59621200088559103072, + -.80054302859059362371e-1, .42612156697795759420, + -.90098145270865592887e-1, -.29769623255090078484, .13630307904779758221, + .21638835185708931831, -.14600247270306082052, -.16348801804014290453, + .14340708728599057249, .12755243353979286190, -.13661523715071346961, + -.10215585947881057394, .12864248070157166547, .83592528025348693602e-1, + -.12066728689302565222, -.69633728678718053052e-1, .11314245177331919532, + .58882939251410088028e-1, -.10621835858758221487, + -.50432266865187597572e-1, .99916834723527771581e-1, + .43672094283057258509e-1, -.94206380251950852413e-1, + -.38181356812697746418e-1, .89035739656537771225e-1, + .33661934598216332678e-1, 0., 0., 0., 0., .62500000000000000000e-1, + -.31093357409581873586, .67604086414949799246, -.75644205980613611039, + .28990586430124175741, .30648508196770360914, -.35801372616842500052, + -.91326869828709014708e-1, .31127929687500000000, + -.90915752838698393094e-2, -.25637381283965534330, + .57601077850322797594e-1, .21019685709225757945, + -.81244992138514014256e-1, -.17375078516720988858, + .92289437277967051125e-1, .14527351914265391374, + -.96675340792832019889e-1, -.12289485697108543415, + .97448175340011084006e-1, .10511755943298339844, + -.96242247086378239657e-1, -.90822942272780513537e-1, + .93966350452322132384e-1, .79189411876493712558e-1, + -.91139307067989309325e-1, -.69613039934383197265e-1, + .88062491671135767870e-1, .61646331729340817494e-1, 0., 0., 0., 0., 0., + .31250000000000000000e-1, -.18684782411095934408, .50176689760410660236, + -.74784031498626095398, .56472001151566251186, .14842464993721351203e-1, + -.41162920273003120936, .20243071230196532282, .23772054897172750436, + -.24963810923972235950, -.12116179938394678936, .24330535483519110663, + .47903849781124471359e-1, -.22133299683101224293, + -.20542915138527200983e-2, .19653465717678146728, + -.26818172626509178444e-1, -.17319122357631210944, + .45065391411065545445e-1, .15253391395444065941, + -.56543897711725408302e-1, -.13469154928743585367, + .63632471400208840155e-1, .11941684923913523817, + -.67828850207933293098e-1, -.10636309084510652670, + .70095786922999181504e-1, .95187373095150709082e-1, 0., 0., 0., 0., 0., + 0., .15625000000000000000e-1, -.10909562534194485289, + .34842348626527747318, -.64461114561628111443, .69382480527334683659, + -.29551102358528827763, -.25527584713978439819, .38878771718544715394, + -.82956185835347407489e-2, -.31183177761966943912, .12831420840372374767, + .22067618205599434368, -.17569196937129496961, -.14598057000132284135, + .18864406621763419484, .89921002550386645767e-1, -.18571835020187122114, + -.48967672227195481777e-1, .17584685670380332798, + .19267984545067426324e-1, -.16335437520503462738, + .22598055455032407594e-2, .15032800884170631129, + -.17883358353754640871e-1, -.13774837869432209951, + .29227555960587143675e-1, .12604194747513151053, 0., 0., 0., 0., 0., 0., + 0., .78125000000000000000e-2, -.62377810244809812496e-1, + .23080781467370883845, -.50841310636012325368, .69834547012574056043, + -.52572723156526459672, .11464215704954976471e-1, .38698869011491210342, + -.26125646622255207507, -.16951698812361607510, .29773875898928782269, + .20130501202570367491e-1, -.26332493149159310198, + .67734613690401207009e-1, .21207315477103762715, -.11541543390889415193, + -.16249634759782417533, .13885887405041735068, .11996491328010275427, + -.14810432001630926895, -.85177658352556243411e-1, .14918860659904380587, + .57317789510444151564e-1, -.14569827645586660151, + -.35213090145965327390e-1, .13975998126844578198, 0., 0., 0., 0., 0., 0., + 0., 0., .39062500000000000000e-2, -.35101954600803571207e-1, + .14761284084133737720, -.37655033076080192966, .62410290231517322776, + -.64335622317683389875, .28188168266139524244, .22488495672137010675, + -.39393811089283576186, .75184777995770096714e-1, .28472023119398293003, + -.20410910833705899572, -.15590046962908511750, .23814567544617953125, + .54442805556829031204e-1, -.22855930338589720954, + .16303223615756629897e-1, .20172722433875559213, + -.62723406421217419404e-1, -.17012230831020922010, + .91754642766136561612e-1, .13927644821381121197, -.10886600968068418181, + -.11139075654373395292, .11797455976331702879, 0., 0., 0., 0., 0., 0., 0., + 0., 0., .19531250000000000000e-2, -.19506820659607596598e-1, + .91865676095362231937e-1, -.26604607809696493849, .51425874205091288223, + -.66047561132505329292, .48660109511591303851, -.17575661168678285615e-1, + -.36594333408055703366, .29088854695378694533, .11318677346656537927, + -.31110645235730182168, .60733219161008787341e-1, .24333848233620420826, + -.15254312332655419708, -.15995968483455388613, .19010344455215289289, + .86040636766440260000e-1, -.19652589954665259945, + -.27633388517205837713e-1, .18660848552712880387, + -.15942583868416775867e-1, -.16902042462382064786, + .47278526495327740646e-1, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .97656250000000000000e-3, -.10731084460857378207e-1, + .55939644713816406331e-1, -.18118487371914493668, .39914857299829864263, + -.60812322949933902435, .60011887183061967583, -.26002695805835928795, + -.20883922404786010096, .38988130966114638081, -.11797833550782589082, + -.25231824756239520077, .24817859972953934712, .90516417677868996417e-1, + -.26079073291293066798, .30259468817169480161e-1, .22178195264114178432, + -.10569877864302048175, -.16679648389266977455, .14637718550245050850, + .11219272032739559870, -.16359363640525750353, -.64358194509092101393e-1, + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .48828125000000000000e-3, + -.58542865274813470967e-2, .33461741635290096452e-1, + -.11979993155896201271, .29580223766987206958, -.51874761979436016742, + .62861483498014306968, -.44868895761051453296, .12567502628371529386e-1, + .35040366183235474275, -.30466868455569500886, -.70903913601490112666e-1, + .30822791893032512740, -.11969443264190207736, -.20764760317621313946, + .20629838355452128532, .95269702915334718507e-1, -.22432624768705133300, + -.33103381593477797101e-2, .20570036048155716333, + -.62208282720094518964e-1, -.17095309330441436348, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., .24414062500000000000e-3, + -.31714797501871532475e-2, .19721062526127334100e-1, + -.77311181185536498246e-1, .21124871792841566575, -.41777980401893650886, + .59401977834943551650, -.56132417807488349048, .23433675061367565951, + .20222775295220942126, -.38280372496506190127, .14443804214023095767, + .22268950939178466797, -.27211314150777981984, -.34184876506180717313e-1, + .26006498895669734842, -.97650425186005090107e-1, -.19024527660129101293, + .16789164198044635671, .10875811641651905252, -.19276785058805921298, 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .12207031250000000000e-3, + -.17078941137247586143e-2, .11477733754843910060e-1, + -.48887017020924625462e-1, .14634927241421789683, -.32156282683019547854, + .52165811920227223937, -.60001958466396926460, .41208501541480733755, + -.11366945503190350975e-2, -.33968093962672089159, .30955190935923386766, + .40657421856578262210e-1, -.29873400409871531764, .16094481791768257440, + .16876122436206497694, -.23650217045022161255, -.33070260090574765012e-1, + .22985258456375907796, -.68645651043827097771e-1, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., .61035156250000000000e-4, + -.91501857608428649078e-3, .66085179496951987952e-2, + -.30383171695850355404e-1, .98840838845366876117e-1, + -.23855447246420318989, .43322017468145613917, -.58049033744876107191, + .52533893203742699346, -.20681056202371946180, -.20180000924562504384, + .37503922291962681797, -.15988102869837429062, -.19823558102762374094, + .28393023878803799622, -.11188133439357510403e-1, -.24730368377168229255, + .14731529061377942839, .14878558042884266021, 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., .30517578125000000000e-4, + -.48804277318479845551e-3, .37696080990601968396e-2, + -.18603912108994738255e-1, .65325006755649582964e-1, + -.17162960707938819795, .34411527956476971322, -.52289350347082497959, + .57319653625674910592, -.37662253421045430413, -.14099055105384663902e-1, + .33265570610216904208, -.30921265572647566661, -.19911390594166455281e-1, + .28738590811031797718, -.18912130469738472647, -.13235936203215819193, + .25076406142356675279, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., .15258789062500000000e-4, -.25928719280954633249e-3, + .21327398937568540428e-2, -.11244626133630732010e-1, + .42375605740664331966e-1, -.12031130345907846211, .26352562258934426830, + -.44590628258512682078, .56682835613700749379, -.49116715128261660395, + .17845943097110339078, .20541650677432497477, -.36739803642257458221, + .16776034069210108273, .17920950989905112908, -.28867732805385066532, + .46473465543376206337e-1, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., .76293945312500000000e-5, -.13727610943181290891e-3, + .11979683091449349286e-2, -.67195313034570709806e-2, + .27044920779931968175e-1, -.82472196498517457862e-1, + .19570475044896150093, -.36391620788543817693, .52241392782736588032, + -.54727504974907879912, .34211551468813581183, .31580472732719957762e-1, + -.32830006549176759667, .30563797665254420769, .64905014620683140120e-2, + -.27642986248995073032, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., .38146972656250000000e-5, + -.72454147007837596854e-4, .66859847582761390285e-3, + -.39751311980366118437e-2, .17015198650201528366e-1, + -.55443621868993855715e-1, .14157060481641692131, -.28641242619559616836, + .45610665490966615415, -.55262786406029265394, .45818352706035500108, + -.14984403004611673047, -.21163807462970713245, .36007252928843413718, + -.17030961385712954159, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., .19073486328125000000e-5, + -.38135049864067468562e-4, .37101393638555730015e-3, + -.23305339886279723213e-2, .10569913448297127219e-1, + -.36640175162216897547e-1, .10010476414320235508, -.21860074212675559892, + .38124757096345313719, -.52020999209879669177, .52172632730659212045, + -.30841620620308814614, -.50322546186721500184e-1, .32577618885114899053, + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., .95367431640625000000e-6, -.20021483206955925244e-4, + .20481807322420625431e-3, -.13553476938058909882e-2, + .64919676350791905019e-2, -.23848725425069251903e-1, + .69384632678886421292e-1, -.16249711393618776934, .30736618106830314788, + -.46399909601971539157, .53765031034002467225, -.42598991476520183929, + .12130445348350215652, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., .47683715820312500000e-6, + -.10487707828484902486e-4, .11254146162337528943e-3, + -.78248929534271987118e-3, .39468337145306794566e-2, + -.15313546659475671763e-1, .47249070825218564146e-1, + -.11804374107101480543, .24031796927792491122, -.39629215049166341285, + .51629108968402548545, -.49622372075429782915, 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .23841857910156250000e-6, -.54823314130625337326e-5, + .61575377321535518154e-4, -.44877834366497538134e-3, + .23774612048621955857e-2, -.97136347645161687796e-2, + .31671599547606636717e-1, -.84028665767000747480e-1, + .18298487576742964949, -.32647878537696945218, .46970971486488895077, 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., .11920928955078125000e-6, -.28604020001177375838e-5, + .33559227978295551013e-4, -.25583821662860610560e-3, + .14201552747787302339e-2, -.60938046986874414969e-2, + .20930869247951926793e-1, -.58745021125678072911e-1, + .13613725780285953720, -.26083988356030237586, 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .59604644775390625000e-7, -.14898180663526043291e-5, + .18224991282807693921e-4, -.14504433444608833821e-3, + .84184722720281809548e-3, -.37846965430000478789e-2, + .13656355548211376864e-1, -.40409541997718853934e-1, + .99226988101858325902e-1, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .29802322387695312500e-7, -.77471708843445529468e-6, + .98649879372606876995e-5, -.81814934772838523887e-4, + .49554483992403011328e-3, -.23290922072351413938e-2, + .88068134250844034186e-2, -.27393666952485719070e-1, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., .14901161193847656250e-7, -.40226235946098233685e-6, + .53236418690561306700e-5, -.45933829691164002269e-4, + .28982005232838857913e-3, -.14212974043211018374e-2, + .56192363087488842264e-2, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .74505805969238281250e-8, -.20858299254133430408e-6, + .28648457300134381744e-5, -.25677535898258910850e-4, + .16849420429491355445e-3, -.86062824010315834002e-3, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., .37252902984619140625e-8, -.10801736017613096861e-6, + .15376606719887104015e-5, -.14296523739727437959e-4, + .97419023656050887203e-4, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .18626451492309570312e-8, -.55871592916438890146e-7, + .82331193828137454068e-6, -.79302250528382787666e-5, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., .93132257461547851562e-9, + -.28867244235852488244e-7, .43982811713864556957e-6, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., .46566128730773925781e-9, + -.14899342093408253335e-7, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., .23283064365386962891e-9 +}; + +static const double Tright[33 * 33] = { + 1., .86602540378443864678, 0., -.33071891388307382381, 0., + .20728904939721249057, 0., -.15128841196122722208, 0., + .11918864298744029244, 0., -.98352013661686631224e-1, 0., + .83727065404940845733e-1, 0., -.72893399403505841203e-1, 0., + .64544632643375022436e-1, 0., -.57913170372415565639e-1, 0., + .52518242575729562263e-1, 0., -.48043311993977520457e-1, 0., + .44271433659733990243e-1, 0., -.41048928022856771981e-1, 0., + .38263878662008271459e-1, 0., -.35832844026365304501e-1, 0., 0., + .50000000000000000000, .96824583655185422130, .57282196186948000082, + -.21650635094610966169, -.35903516540862679125, .97578093724974971969e-1, + .26203921611325660506, -.55792409597991015609e-1, -.20644078533943456204, + .36172381205961199479e-1, .17035068468874958194, + -.25371838001497225980e-1, -.14501953125000000000, + .18786835250972344757e-1, .12625507130328301066, + -.14473795929590520582e-1, -.11179458309419422675, + .11494434254897626155e-1, .10030855351241635862, + -.93498556820544479096e-2, -.90964264465390582629e-1, + .77546391824364392762e-2, .83213457337452292745e-1, + -.65358085945588638605e-2, -.76680372422574234569e-1, + .55835321940047427169e-2, .71098828931825789428e-1, + -.48253327982967591019e-2, -.66274981937248958553e-1, + .42118078245337801387e-2, .62064306433355646267e-1, + -.37083386598903548973e-2, 0., 0., .25000000000000000000, + .73950997288745200531, .83852549156242113615, .23175620272173946716, + -.37791833195149451496, -.25710129174850522325, .21608307321780204633, + .22844049245646009157, -.14009503000335388415, -.19897685605518413847, + .98264706042471226893e-1, .17445445004279014046, + -.72761100054958328401e-1, -.15463589893742108388, + .56056770591708784481e-1, .13855313872640495158, + -.44517752443294564781e-1, -.12534277657695128850, + .36211835346039665762e-1, .11434398255136139683, + -.30033588409423828125e-1, -.10506705408753910481, + .25313077840725783008e-1, .97149327637744872155e-1, + -.21624927200393328444e-1, -.90319582367202122625e-1, + .18688433567711780666e-1, .84372291635345108584e-1, + -.16312261561845420752e-1, -.79149526894804751586e-1, + .14362333871852474757e-1, 0., 0., 0., .12500000000000000000, + .49607837082461073572, .82265291131801144317, .59621200088559103072, + -.80054302859059362371e-1, -.42612156697795759420, + -.90098145270865592887e-1, .29769623255090078484, .13630307904779758221, + -.21638835185708931831, -.14600247270306082052, .16348801804014290453, + .14340708728599057249, -.12755243353979286190, -.13661523715071346961, + .10215585947881057394, .12864248070157166547, -.83592528025348693602e-1, + -.12066728689302565222, .69633728678718053052e-1, .11314245177331919532, + -.58882939251410088028e-1, -.10621835858758221487, + .50432266865187597572e-1, .99916834723527771581e-1, + -.43672094283057258509e-1, -.94206380251950852413e-1, + .38181356812697746418e-1, .89035739656537771225e-1, + -.33661934598216332678e-1, 0., 0., 0., 0., .62500000000000000000e-1, + .31093357409581873586, .67604086414949799246, .75644205980613611039, + .28990586430124175741, -.30648508196770360914, -.35801372616842500052, + .91326869828709014708e-1, .31127929687500000000, .90915752838698393094e-2, + -.25637381283965534330, -.57601077850322797594e-1, .21019685709225757945, + .81244992138514014256e-1, -.17375078516720988858, + -.92289437277967051125e-1, .14527351914265391374, + .96675340792832019889e-1, -.12289485697108543415, + -.97448175340011084006e-1, .10511755943298339844, + .96242247086378239657e-1, -.90822942272780513537e-1, + -.93966350452322132384e-1, .79189411876493712558e-1, + .91139307067989309325e-1, -.69613039934383197265e-1, + -.88062491671135767870e-1, .61646331729340817494e-1, 0., 0., 0., 0., 0., + .31250000000000000000e-1, .18684782411095934408, .50176689760410660236, + .74784031498626095398, .56472001151566251186, -.14842464993721351203e-1, + -.41162920273003120936, -.20243071230196532282, .23772054897172750436, + .24963810923972235950, -.12116179938394678936, -.24330535483519110663, + .47903849781124471359e-1, .22133299683101224293, + -.20542915138527200983e-2, -.19653465717678146728, + -.26818172626509178444e-1, .17319122357631210944, + .45065391411065545445e-1, -.15253391395444065941, + -.56543897711725408302e-1, .13469154928743585367, + .63632471400208840155e-1, -.11941684923913523817, + -.67828850207933293098e-1, .10636309084510652670, + .70095786922999181504e-1, -.95187373095150709082e-1, 0., 0., 0., 0., 0., + 0., .15625000000000000000e-1, .10909562534194485289, + .34842348626527747318, .64461114561628111443, .69382480527334683659, + .29551102358528827763, -.25527584713978439819, -.38878771718544715394, + -.82956185835347407489e-2, .31183177761966943912, .12831420840372374767, + -.22067618205599434368, -.17569196937129496961, .14598057000132284135, + .18864406621763419484, -.89921002550386645767e-1, -.18571835020187122114, + .48967672227195481777e-1, .17584685670380332798, + -.19267984545067426324e-1, -.16335437520503462738, + -.22598055455032407594e-2, .15032800884170631129, + .17883358353754640871e-1, -.13774837869432209951, + -.29227555960587143675e-1, .12604194747513151053, 0., 0., 0., 0., 0., 0., + 0., .78125000000000000000e-2, .62377810244809812496e-1, + .23080781467370883845, .50841310636012325368, .69834547012574056043, + .52572723156526459672, .11464215704954976471e-1, -.38698869011491210342, + -.26125646622255207507, .16951698812361607510, .29773875898928782269, + -.20130501202570367491e-1, -.26332493149159310198, + -.67734613690401207009e-1, .21207315477103762715, .11541543390889415193, + -.16249634759782417533, -.13885887405041735068, .11996491328010275427, + .14810432001630926895, -.85177658352556243411e-1, -.14918860659904380587, + .57317789510444151564e-1, .14569827645586660151, + -.35213090145965327390e-1, -.13975998126844578198, 0., 0., 0., 0., 0., 0., + 0., 0., .39062500000000000000e-2, .35101954600803571207e-1, + .14761284084133737720, .37655033076080192966, .62410290231517322776, + .64335622317683389875, .28188168266139524244, -.22488495672137010675, + -.39393811089283576186, -.75184777995770096714e-1, .28472023119398293003, + .20410910833705899572, -.15590046962908511750, -.23814567544617953125, + .54442805556829031204e-1, .22855930338589720954, .16303223615756629897e-1, + -.20172722433875559213, -.62723406421217419404e-1, .17012230831020922010, + .91754642766136561612e-1, -.13927644821381121197, -.10886600968068418181, + .11139075654373395292, .11797455976331702879, 0., 0., 0., 0., 0., 0., 0., + 0., 0., .19531250000000000000e-2, .19506820659607596598e-1, + .91865676095362231937e-1, .26604607809696493849, .51425874205091288223, + .66047561132505329292, .48660109511591303851, .17575661168678285615e-1, + -.36594333408055703366, -.29088854695378694533, .11318677346656537927, + .31110645235730182168, .60733219161008787341e-1, -.24333848233620420826, + -.15254312332655419708, .15995968483455388613, .19010344455215289289, + -.86040636766440260000e-1, -.19652589954665259945, + .27633388517205837713e-1, .18660848552712880387, .15942583868416775867e-1, + -.16902042462382064786, -.47278526495327740646e-1, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., .97656250000000000000e-3, .10731084460857378207e-1, + .55939644713816406331e-1, .18118487371914493668, .39914857299829864263, + .60812322949933902435, .60011887183061967583, .26002695805835928795, + -.20883922404786010096, -.38988130966114638081, -.11797833550782589082, + .25231824756239520077, .24817859972953934712, -.90516417677868996417e-1, + -.26079073291293066798, -.30259468817169480161e-1, .22178195264114178432, + .10569877864302048175, -.16679648389266977455, -.14637718550245050850, + .11219272032739559870, .16359363640525750353, -.64358194509092101393e-1, + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .48828125000000000000e-3, + .58542865274813470967e-2, .33461741635290096452e-1, .11979993155896201271, + .29580223766987206958, .51874761979436016742, .62861483498014306968, + .44868895761051453296, .12567502628371529386e-1, -.35040366183235474275, + -.30466868455569500886, .70903913601490112666e-1, .30822791893032512740, + .11969443264190207736, -.20764760317621313946, -.20629838355452128532, + .95269702915334718507e-1, .22432624768705133300, + -.33103381593477797101e-2, -.20570036048155716333, + -.62208282720094518964e-1, .17095309330441436348, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., .24414062500000000000e-3, + .31714797501871532475e-2, .19721062526127334100e-1, + .77311181185536498246e-1, .21124871792841566575, .41777980401893650886, + .59401977834943551650, .56132417807488349048, .23433675061367565951, + -.20222775295220942126, -.38280372496506190127, -.14443804214023095767, + .22268950939178466797, .27211314150777981984, -.34184876506180717313e-1, + -.26006498895669734842, -.97650425186005090107e-1, .19024527660129101293, + .16789164198044635671, -.10875811641651905252, -.19276785058805921298, 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .12207031250000000000e-3, + .17078941137247586143e-2, .11477733754843910060e-1, + .48887017020924625462e-1, .14634927241421789683, .32156282683019547854, + .52165811920227223937, .60001958466396926460, .41208501541480733755, + .11366945503190350975e-2, -.33968093962672089159, -.30955190935923386766, + .40657421856578262210e-1, .29873400409871531764, .16094481791768257440, + -.16876122436206497694, -.23650217045022161255, .33070260090574765012e-1, + .22985258456375907796, .68645651043827097771e-1, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., .61035156250000000000e-4, + .91501857608428649078e-3, .66085179496951987952e-2, + .30383171695850355404e-1, .98840838845366876117e-1, .23855447246420318989, + .43322017468145613917, .58049033744876107191, .52533893203742699346, + .20681056202371946180, -.20180000924562504384, -.37503922291962681797, + -.15988102869837429062, .19823558102762374094, .28393023878803799622, + .11188133439357510403e-1, -.24730368377168229255, -.14731529061377942839, + .14878558042884266021, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., .30517578125000000000e-4, .48804277318479845551e-3, + .37696080990601968396e-2, .18603912108994738255e-1, + .65325006755649582964e-1, .17162960707938819795, .34411527956476971322, + .52289350347082497959, .57319653625674910592, .37662253421045430413, + -.14099055105384663902e-1, -.33265570610216904208, -.30921265572647566661, + .19911390594166455281e-1, .28738590811031797718, .18912130469738472647, + -.13235936203215819193, -.25076406142356675279, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .15258789062500000000e-4, + .25928719280954633249e-3, .21327398937568540428e-2, + .11244626133630732010e-1, .42375605740664331966e-1, .12031130345907846211, + .26352562258934426830, .44590628258512682078, .56682835613700749379, + .49116715128261660395, .17845943097110339078, -.20541650677432497477, + -.36739803642257458221, -.16776034069210108273, .17920950989905112908, + .28867732805385066532, .46473465543376206337e-1, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .76293945312500000000e-5, + .13727610943181290891e-3, .11979683091449349286e-2, + .67195313034570709806e-2, .27044920779931968175e-1, + .82472196498517457862e-1, .19570475044896150093, .36391620788543817693, + .52241392782736588032, .54727504974907879912, .34211551468813581183, + -.31580472732719957762e-1, -.32830006549176759667, -.30563797665254420769, + .64905014620683140120e-2, .27642986248995073032, 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .38146972656250000000e-5, + .72454147007837596854e-4, .66859847582761390285e-3, + .39751311980366118437e-2, .17015198650201528366e-1, + .55443621868993855715e-1, .14157060481641692131, .28641242619559616836, + .45610665490966615415, .55262786406029265394, .45818352706035500108, + .14984403004611673047, -.21163807462970713245, -.36007252928843413718, + -.17030961385712954159, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., .19073486328125000000e-5, + .38135049864067468562e-4, .37101393638555730015e-3, + .23305339886279723213e-2, .10569913448297127219e-1, + .36640175162216897547e-1, .10010476414320235508, .21860074212675559892, + .38124757096345313719, .52020999209879669177, .52172632730659212045, + .30841620620308814614, -.50322546186721500184e-1, -.32577618885114899053, + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., .95367431640625000000e-6, .20021483206955925244e-4, + .20481807322420625431e-3, .13553476938058909882e-2, + .64919676350791905019e-2, .23848725425069251903e-1, + .69384632678886421292e-1, .16249711393618776934, .30736618106830314788, + .46399909601971539157, .53765031034002467225, .42598991476520183929, + .12130445348350215652, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., .47683715820312500000e-6, + .10487707828484902486e-4, .11254146162337528943e-3, + .78248929534271987118e-3, .39468337145306794566e-2, + .15313546659475671763e-1, .47249070825218564146e-1, .11804374107101480543, + .24031796927792491122, .39629215049166341285, .51629108968402548545, + .49622372075429782915, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., .23841857910156250000e-6, + .54823314130625337326e-5, .61575377321535518154e-4, + .44877834366497538134e-3, .23774612048621955857e-2, + .97136347645161687796e-2, .31671599547606636717e-1, + .84028665767000747480e-1, .18298487576742964949, .32647878537696945218, + .46970971486488895077, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., .11920928955078125000e-6, + .28604020001177375838e-5, .33559227978295551013e-4, + .25583821662860610560e-3, .14201552747787302339e-2, + .60938046986874414969e-2, .20930869247951926793e-1, + .58745021125678072911e-1, .13613725780285953720, .26083988356030237586, + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., .59604644775390625000e-7, + .14898180663526043291e-5, .18224991282807693921e-4, + .14504433444608833821e-3, .84184722720281809548e-3, + .37846965430000478789e-2, .13656355548211376864e-1, + .40409541997718853934e-1, .99226988101858325902e-1, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., .29802322387695312500e-7, .77471708843445529468e-6, + .98649879372606876995e-5, .81814934772838523887e-4, + .49554483992403011328e-3, .23290922072351413938e-2, + .88068134250844034186e-2, .27393666952485719070e-1, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., .14901161193847656250e-7, .40226235946098233685e-6, + .53236418690561306700e-5, .45933829691164002269e-4, + .28982005232838857913e-3, .14212974043211018374e-2, + .56192363087488842264e-2, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .74505805969238281250e-8, .20858299254133430408e-6, + .28648457300134381744e-5, .25677535898258910850e-4, + .16849420429491355445e-3, .86062824010315834002e-3, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., .37252902984619140625e-8, .10801736017613096861e-6, + .15376606719887104015e-5, .14296523739727437959e-4, + .97419023656050887203e-4, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + .18626451492309570312e-8, .55871592916438890146e-7, + .82331193828137454068e-6, .79302250528382787666e-5, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., .93132257461547851562e-9, + .28867244235852488244e-7, .43982811713864556957e-6, 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., .46566128730773925781e-9, + .14899342093408253335e-7, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., + 0., 0., .23283064365386962891e-9 +}; + +/* Allocates a workspace for the given maximum number of intervals. + Note that if the workspace gets filled, the intervals with the + lowest error estimates are dropped. The maximum number of + intervals is therefore not the maximum number of intervals + that will be computed, but merely the size of the buffer. + */ + +/* Compute the product of the fx with one of the inverse + Vandermonde-like matrices. */ + +void +Vinvfx (const double *fx, double *c, const int d) +{ + + int i, j; + + switch (d) + { + case 0: + for (i = 0; i <= 4; i++) + { + c[i] = 0.0; + for (j = 0; j <= 4; j++) + c[i] += V1inv[i * 5 + j] * fx[j * 8]; + } + break; + case 1: + for (i = 0; i <= 8; i++) + { + c[i] = 0.0; + for (j = 0; j <= 8; j++) + c[i] += V2inv[i * 9 + j] * fx[j * 4]; + } + break; + case 2: + for (i = 0; i <= 16; i++) + { + c[i] = 0.0; + for (j = 0; j <= 16; j++) + c[i] += V3inv[i * 17 + j] * fx[j * 2]; + } + break; + case 3: + for (i = 0; i <= 32; i++) + { + c[i] = 0.0; + for (j = 0; j <= 32; j++) + c[i] += V4inv[i * 33 + j] * fx[j]; + } + break; + } + +} + + +/* Downdate the interpolation given by the n coefficients c + by removing the nodes with indices in nans. */ + +void +downdate (double *c, int n, int d, int *nans, int nnans) +{ + + static const int bidx[4] = { 0, 6, 16, 34 }; + double b_new[34], alpha; + int i, j; + + for (i = 0; i <= n + 1; i++) + b_new[i] = bee[bidx[d] + i]; + for (i = 0; i < nnans; i++) + { + b_new[n + 1] = b_new[n + 1] / Lalpha[n]; + b_new[n] = (b_new[n] + xi[nans[i]] * b_new[n + 1]) / Lalpha[n - 1]; + for (j = n - 1; j > 0; j--) + b_new[j] = + (b_new[j] + xi[nans[i]] * b_new[j + 1] - + Lgamma[j + 1] * b_new[j + 2]) / Lalpha[j - 1]; + for (j = 0; j <= n; j++) + b_new[j] = b_new[j + 1]; + alpha = c[n] / b_new[n]; + for (j = 0; j < n; j++) + c[j] -= alpha * b_new[j]; + c[n] = 0; + n--; + } + +} + + +/* The actual integration routine. */ + +DEFUN (quadcc, args, nargout, +"-*- texinfo -*-\n\ +@deftypefn {Function File} {@var{q} =} quadcc (@var{f}, @var{a}, @var{b})\n\ +@deftypefnx {Function File} {@var{q} =} quadcc (@var{f}, @var{a}, @var{b}, @var{tol})\n\ +@deftypefnx {Function File} {@var{q} =} quadcc (@var{f}, @var{a}, @var{b}, @var{tol}, @var{sing})\n\ +@deftypefnx {Function File} {[@var{q}, @var{err}, @var{nr_points}] =} quadcc (@dots{})\n\ +Numerically evaluate the integral of @var{f} from @var{a} to @var{b}\n\ +using the doubly-adaptive Clenshaw-Curtis quadrature described by P. Gonnet\n\ +in @cite{Increasing the Reliability of Adaptive Quadrature Using Explicit\n\ +Interpolants}.\n\ +@var{f} is a function handle, inline function, or string\n\ +containing the name of the function to evaluate.\n\ +The function @var{f} must be vectorized and must return a vector of output\n\ +values if given a vector of input values. For example,\n\ +\n\ +@example\n\ +f = @@(x) x .* sin (1./x) .* sqrt (abs (1 - x));\n\ +@end example\n\ +\n\ +@noindent\n\ +which uses the element-by-element `dot' form for all operators.\n\ +\n\ +@var{a} and @var{b} are the lower and upper limits of integration. Either\n\ +or both limits may be infinite. @code{quadcc} handles an inifinite limit\n\ +by substituting the variable of integration with @code{x = tan (pi/2*u)}.\n\ +\n\ +The optional argument @var{tol} defines the relative tolerance used to stop\n\ +the integration procedure. The default value is @math{1e^{-6}}.\n\ +\n\ +The optional argument @var{sing} contains a list of points where the\n\ +integrand has known singularities, or discontinuities\n\ +in any of its derivatives, inside the integration interval.\n\ +For the example above, which has a discontinuity at x=1, the call to\n\ +@code{quadcc} would be as follows\n\ +\n\ +@example\n\ +int = quadcc (f, a, b, 1.0e-6, [ 1 ]);\n\ +@end example\n\ +\n\ +The result of the integration is returned in @var{q}.\n\ +@var{err} is an estimate of the absolute integration error and\n\ +@var{nr_points} is the number of points at which the integrand was evaluated.\n\ +If the adaptive integration did not converge, the value of\n\ +@var{err} will be larger than the requested tolerance. Therefore, it is\n\ +recommended to verify this value for difficult integrands.\n\ +\n\ +@code{quadcc} is capable of dealing with non-numeric\n\ +values of the integrand such as @code{NaN} or @code{Inf}.\n\ +If the integral diverges, and @code{quadcc} detects this,\n\ +then a warning is issued and @code{Inf} or @code{-Inf} is returned.\n\ +\n\ +Note: @code{quadcc} is a general purpose quadrature algorithm\n\ +and, as such, may be less efficient for a smooth or otherwise\n\ +well-behaved integrand than other methods such as @code{quadgk}.\n\ +\n\ +The algorithm uses Clenshaw-Curtis quadrature rules of increasing\n\ +degree in each interval and bisects the interval if either the\n\ +function does not appear to be smooth or a rule of maximum\n\ +degree has been reached. The error estimate is computed from the\n\ +L2-norm of the difference between two successive interpolations\n\ +of the integrand over the nodes of the respective quadrature rules.\n\ +\n\ +Reference: P. Gonnet, @cite{Increasing the Reliability of Adaptive\n\ +Quadrature Using Explicit Interpolants}, ACM Transactions on\n\ +Mathematical Software, Vol. 37, Issue 3, Article No. 3, 2010.\n\ +@seealso{quad, quadv, quadl, quadgk, trapz, dblquad, triplequad}\n\ +@end deftypefn") +{ + octave_value_list retval; + + /* Some constants that we will need. */ + static const int n[4] = { 4, 8, 16, 32 }; + static const int skip[4] = { 8, 4, 2, 1 }; + static const int idx[4] = { 0, 5, 14, 31 }; + static const double w = M_SQRT2 / 2; + static const int ndiv_max = 20; + + /* The interval heap. */ + cquad_ival ivals[cquad_heapsize]; + int heap[cquad_heapsize]; + + /* Arguments left and right */ + int nargin = args.length (); + octave_function *fcn; + double a, b, tol, iivals[cquad_heapsize], *sing; + + /* Variables needed for transforming the integrand. */ + bool wrap = false; + double xw; + + /* Stuff we will need to call the integrand. */ + octave_value_list fargs, fvals; + + /* Actual variables (as opposed to constants above). */ + double m, h, ml, hl, mr, hr, temp; + double igral, err, igral_final, err_final; + int nivals, neval = 0; + int i, j, d, split, t; + int nnans, nans[33]; + cquad_ival *iv, *ivl, *ivr; + double nc, ncdiff; + + + /* Parse the input arguments. */ + if (nargin < 3) + { + print_usage (); + return retval; + } + + if (args(0).is_function_handle () || args(0).is_inline_function ()) + fcn = args(0).function_value (); + else + { + std::string fcn_name = unique_symbol_name ("__quadcc_fcn_"); + std::string fname = "function y = "; + fname.append (fcn_name); + fname.append ("(x) y = "); + fcn = extract_function (args(0), "quadcc", fcn_name, fname, + "; endfunction"); + } + + if (!args(1).is_real_scalar ()) + { + error ("quadcc: lower limit of integration (A) must be a single real scalar"); + return retval; + } + else + a = args(1).double_value (); + + if (!args(2).is_real_scalar ()) + { + error ("quadcc: upper limit of integration (B) must be a single real scalar"); + return retval; + } + else + b = args(2).double_value (); + + if (nargin < 4 || args(3).is_empty ()) + tol = 1.0e-6; + else if (!args(3).is_real_scalar () || args(3).double_value () <= 0) + { + error ("quadcc: tolerance (TOL) must be a single real scalar > 0"); + return retval; + } + else + tol = args(3).double_value (); + + if (nargin < 5) + { + nivals = 1; + iivals[0] = a; + iivals[1] = b; + } + else if (!(args(4).is_real_scalar () || args(4).is_real_matrix ())) + { + error ("quadcc: list of singularities (SING) must be a vector of real values"); + return retval; + } + else + { + nivals = 1 + args(4).length (); + if (nivals > cquad_heapsize) + { + error ("quadcc: maximum number of singular points is limited to %i", + cquad_heapsize-1); + return retval; + } + sing = args(4).array_value ().fortran_vec (); + iivals[0] = a; + for (i = 0; i < nivals - 2; i++) + iivals[i + 1] = sing[i]; + iivals[nivals] = b; + } + + /* If a or b are +/-Inf, transform the integral. */ + if (xisinf (a) || xisinf (b)) + { + wrap = true; + for (i = 0; i <= nivals; i++) + if (xisinf (iivals[i])) + iivals[i] = gnulib::copysign (1.0, iivals[i]); + else + iivals[i] = 2.0 * atan (iivals[i]) / M_PI; + } + + + /* Initialize the heaps. */ + for (i = 0; i < cquad_heapsize; i++) + heap[i] = i; + + + /* Create the first interval(s). */ + igral = 0.0; + err = 0.0; + for (j = 0; j < nivals; j++) + { + + /* Initialize the interval. */ + iv = &(ivals[heap[j]]); + m = (iivals[j] + iivals[j + 1]) / 2; + h = (iivals[j + 1] - iivals[j]) / 2; + nnans = 0; + ColumnVector ex (33); + if (wrap) + { + for (i = 0; i <= n[3]; i++) + ex (i) = tan (M_PI / 2 * (m + xi[i] * h)); + } + else + { + for (i = 0; i <= n[3]; i++) + ex (i) = m + xi[i] * h; + } + fargs(0) = ex; + fvals = feval (fcn, fargs, 1); + if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) + { + error ("quadcc: integrand F must return a single, real-valued vector"); + return retval; + } + Matrix effex = fvals(0).matrix_value (); + if (effex.length () != ex.length ()) + { + error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); + return retval; + } + for (i = 0; i <= n[3]; i++) + { + iv->fx[i] = effex (i); + if (wrap) + { + xw = ex(i); + iv->fx[i] *= (1.0 + xw * xw) * M_PI / 2; + } + neval++; + if (!xfinite (iv->fx[i])) + { + nans[nnans++] = i; + iv->fx[i] = 0.0; + } + } + Vinvfx (iv->fx, &(iv->c[idx[3]]), 3); + Vinvfx (iv->fx, &(iv->c[idx[2]]), 2); + Vinvfx (iv->fx, &(iv->c[0]), 0); + for (i = 0; i < nnans; i++) + iv->fx[i] = octave_NaN; + iv->a = iivals[j]; + iv->b = iivals[j + 1]; + iv->depth = 3; + iv->rdepth = 1; + iv->ndiv = 0; + iv->igral = 2 * h * iv->c[idx[3]] * w; + nc = 0.0; + for (i = n[2] + 1; i <= n[3]; i++) + { + temp = iv->c[idx[3] + i]; + nc += temp * temp; + } + ncdiff = nc; + for (i = 0; i <= n[2]; i++) + { + temp = iv->c[idx[2] + i] - iv->c[idx[3] + i]; + ncdiff += temp * temp; + nc += iv->c[idx[3] + i] * iv->c[idx[3] + i]; + } + ncdiff = sqrt (ncdiff); + nc = sqrt (nc); + iv->err = ncdiff * 2 * h; + if (ncdiff / nc > 0.1 && iv->err < 2 * h * nc) + iv->err = 2 * h * nc; + + /* Tabulate this interval's data. */ + igral += iv->igral; + err += iv->err; + + /* Sift it up the heap. */ + i = j; + while (i > 0 && ivals[heap[i / 2]].err < ivals[heap[i]].err) + { + temp = heap[i]; + heap[i] = heap[i / 2]; + heap[i / 2] = temp; + i /= 2; + } + + } + + + /* Initialize some global values. */ + igral_final = 0.0; + err_final = 0.0; + + + /* Main loop. */ + while (nivals > 0 && err > 0.0 && err > fabs (igral) * tol + && !(err_final > fabs (igral) * tol + && err - err_final < fabs (igral) * tol)) + { + + /* Allow the user to interrupt. */ + OCTAVE_QUIT; + + /* Put our finger on the interval with the largest error. */ + iv = &(ivals[heap[0]]); + m = (iv->a + iv->b) / 2; + h = (iv->b - iv->a) / 2; + +/* printf + ("quadcc: processing ival %i (of %i) with [%e,%e] int=%e, err=%e, depth=%i\n", + heap[0], nivals, iv->a, iv->b, iv->igral, iv->err, iv->depth); +*/ + /* Should we try to increase the degree? */ + if (iv->depth < 3) + { + + /* Keep tabs on some variables. */ + d = ++iv->depth; + + /* Get the new (missing) function values */ + { + ColumnVector ex (n[d] / 2); + if (wrap) + { + for (i = 0; i < n[d] / 2; i++) + ex (i) = + tan (M_PI / 2 * (m + xi[(2 * i + 1) * skip[d]] * h)); + } + else + { + for (i = 0; i < n[d] / 2; i++) + ex (i) = m + xi[(2 * i + 1) * skip[d]] * h; + } + fargs(0) = ex; + fvals = feval (fcn, fargs, 1); + if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) + { + error ("quadcc: integrand F must return a single, real-valued vector"); + return retval; + } + Matrix effex = fvals(0).matrix_value (); + if (effex.length () != ex.length ()) + { + error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); + return retval; + } + neval += effex.length (); + for (i = 0; i < n[d] / 2; i++) + { + j = (2 * i + 1) * skip[d]; + iv->fx[j] = effex (i); + if (wrap) + { + xw = ex(i); + iv->fx[j] *= (1.0 + xw * xw) * M_PI / 2; + } + } + } + nnans = 0; + for (i = 0; i <= 32; i += skip[d]) + { + if (!xfinite (iv->fx[i])) + { + nans[nnans++] = i; + iv->fx[i] = 0.0; + } + } + + /* Compute the new coefficients. */ + Vinvfx (iv->fx, &(iv->c[idx[d]]), d); + /* Downdate any NaNs. */ + if (nnans > 0) + { + downdate (&(iv->c[idx[d]]), n[d], d, nans, nnans); + for (i = 0; i < nnans; i++) + iv->fx[i] = octave_NaN; + } + + /* Compute the error estimate. */ + nc = 0.0; + for (i = n[d - 1] + 1; i <= n[d]; i++) + { + temp = iv->c[idx[d] + i]; + nc += temp * temp; + } + ncdiff = nc; + for (i = 0; i <= n[d - 1]; i++) + { + temp = iv->c[idx[d - 1] + i] - iv->c[idx[d] + i]; + ncdiff += temp * temp; + nc += iv->c[idx[d] + i] * iv->c[idx[d] + i]; + } + ncdiff = sqrt (ncdiff); + nc = sqrt (nc); + iv->err = ncdiff * 2 * h; + /* Compute the local integral. */ + iv->igral = 2 * h * w * iv->c[idx[d]]; + /* Split the interval prematurely? */ + split = (nc > 0 && ncdiff / nc > 0.1); + } + + /* Maximum degree reached, just split. */ + else + { + split = 1; + } + + + /* Should we drop this interval? */ + if ((m + h * xi[0]) >= (m + h * xi[1]) + || (m + h * xi[31]) >= (m + h * xi[32]) + || iv->err < fabs (iv->igral) * DBL_EPSILON * 10) + { + +/* printf + ("quadcc: dropping ival %i (of %i) with [%e,%e] int=%e, err=%e, depth=%i\n", + heap[0], nivals, iv->a, iv->b, iv->igral, iv->err, + iv->depth); +*/ + /* Keep this interval's contribution */ + err_final += iv->err; + igral_final += iv->igral; + /* Swap with the last element on the heap */ + t = heap[nivals - 1]; + heap[nivals - 1] = heap[0]; + heap[0] = t; + nivals--; + /* Fix up the heap */ + i = 0; + while (2 * i + 1 < nivals) + { + + /* Get the kids */ + j = 2 * i + 1; + /* If the j+1st entry exists and is larger than the jth, + use it instead. */ + if (j + 1 < nivals + && ivals[heap[j + 1]].err >= ivals[heap[j]].err) + j++; + /* Do we need to move the ith entry up? */ + if (ivals[heap[j]].err <= ivals[heap[i]].err) + break; + else + { + t = heap[j]; + heap[j] = heap[i]; + heap[i] = t; + i = j; + } + } + + } + + /* Do we need to split this interval? */ + else if (split) + { + + /* Some values we will need often... */ + d = iv->depth; + /* Generate the interval on the left */ + ivl = &(ivals[heap[nivals++]]); + ivl->a = iv->a; + ivl->b = m; + ml = (ivl->a + ivl->b) / 2; + hl = h / 2; + ivl->depth = 0; + ivl->rdepth = iv->rdepth + 1; + ivl->fx[0] = iv->fx[0]; + ivl->fx[32] = iv->fx[16]; + { + ColumnVector ex (n[0] - 1); + if (wrap) + { + for (i = 0; i < n[0] - 1; i++) + ex (i) = tan (M_PI / 2 * (ml + xi[(i + 1) * skip[0]] * hl)); + } + else + { + for (i = 0; i < n[0] - 1; i++) + ex (i) = ml + xi[(i + 1) * skip[0]] * hl; + } + fargs(0) = ex; + fvals = feval (fcn, fargs, 1); + if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) + { + error ("quadcc: integrand F must return a single, real-valued vector"); + return retval; + } + Matrix effex = fvals(0).matrix_value (); + if (effex.length () != ex.length ()) + { + error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); + return retval; + } + neval += effex.length (); + for (i = 0; i < n[0] - 1; i++) + { + j = (i + 1) * skip[0]; + ivl->fx[j] = effex (i); + if (wrap) + { + xw = ex(i); + ivl->fx[j] *= (1.0 + xw * xw) * M_PI / 2; + } + } + } + nnans = 0; + for (i = 0; i <= 32; i += skip[0]) + { + if (!xfinite (ivl->fx[i])) + { + nans[nnans++] = i; + ivl->fx[i] = 0.0; + } + } + Vinvfx (ivl->fx, ivl->c, 0); + if (nnans > 0) + { + downdate (ivl->c, n[0], 0, nans, nnans); + for (i = 0; i < nnans; i++) + ivl->fx[i] = octave_NaN; + } + for (i = 0; i <= n[d]; i++) + { + ivl->c[idx[d] + i] = 0.0; + for (j = i; j <= n[d]; j++) + ivl->c[idx[d] + i] += Tleft[i * 33 + j] * iv->c[idx[d] + j]; + } + ncdiff = 0.0; + for (i = 0; i <= n[0]; i++) + { + temp = ivl->c[i] - ivl->c[idx[d] + i]; + ncdiff += temp * temp; + } + for (i = n[0] + 1; i <= n[d]; i++) + { + temp = ivl->c[idx[d] + i]; + ncdiff += temp * temp; + } + ncdiff = sqrt (ncdiff); + ivl->err = ncdiff * h; + /* Check for divergence. */ + ivl->ndiv = iv->ndiv + (fabs (iv->c[0]) > 0 + && ivl->c[0] / iv->c[0] > 2); + if (ivl->ndiv > ndiv_max && 2 * ivl->ndiv > ivl->rdepth) + { + igral = gnulib::copysign (octave_Inf, igral); + warning ("quadcc: divergent integral detected"); + break; + } + + /* Compute the local integral. */ + ivl->igral = h * w * ivl->c[0]; + + + /* Generate the interval on the right */ + ivr = &(ivals[heap[nivals++]]); + ivr->a = m; + ivr->b = iv->b; + mr = (ivr->a + ivr->b) / 2; + hr = h / 2; + ivr->depth = 0; + ivr->rdepth = iv->rdepth + 1; + ivr->fx[0] = iv->fx[16]; + ivr->fx[32] = iv->fx[32]; + { + ColumnVector ex (n[0] - 1); + if (wrap) + { + for (i = 0; i < n[0] - 1; i++) + ex (i) = tan (M_PI / 2 * (mr + xi[(i + 1) * skip[0]] * hr)); + } + else + { + for (i = 0; i < n[0] - 1; i++) + ex (i) = mr + xi[(i + 1) * skip[0]] * hr; + } + fargs(0) = ex; + fvals = feval (fcn, fargs, 1); + if (fvals.length () != 1 || !fvals(0).is_real_matrix ()) + { + error ("quadcc: integrand F must return a single, real-valued vector"); + return retval; + } + Matrix effex = fvals(0).matrix_value (); + if (effex.length () != ex.length ()) + { + error ("quadcc: integrand F must return a single, real-valued vector of the same size as the input"); + return retval; + } + neval += effex.length (); + for (i = 0; i < n[0] - 1; i++) + { + j = (i + 1) * skip[0]; + ivr->fx[j] = effex (i); + if (wrap) + { + xw = ex(i); + ivr->fx[j] *= (1.0 + xw * xw) * M_PI / 2; + } + } + } + nnans = 0; + for (i = 0; i <= 32; i += skip[0]) + { + if (!xfinite (ivr->fx[i])) + { + nans[nnans++] = i; + ivr->fx[i] = 0.0; + } + } + Vinvfx (ivr->fx, ivr->c, 0); + if (nnans > 0) + { + downdate (ivr->c, n[0], 0, nans, nnans); + for (i = 0; i < nnans; i++) + ivr->fx[i] = octave_NaN; + } + for (i = 0; i <= n[d]; i++) + { + ivr->c[idx[d] + i] = 0.0; + for (j = i; j <= n[d]; j++) + ivr->c[idx[d] + i] += Tright[i * 33 + j] * iv->c[idx[d] + j]; + } + ncdiff = 0.0; + for (i = 0; i <= n[0]; i++) + { + temp = ivr->c[i] - ivr->c[idx[d] + i]; + ncdiff += temp * temp; + } + for (i = n[0] + 1; i <= n[d]; i++) + { + temp = ivr->c[idx[d] + i]; + ncdiff += temp * temp; + } + ncdiff = sqrt (ncdiff); + ivr->err = ncdiff * h; + /* Check for divergence. */ + ivr->ndiv = iv->ndiv + (fabs (iv->c[0]) > 0 + && ivr->c[0] / iv->c[0] > 2); + if (ivr->ndiv > ndiv_max && 2 * ivr->ndiv > ivr->rdepth) + { + igral = gnulib::copysign (octave_Inf, igral); + warning ("quadcc: divergent integral detected"); + break; + } + + /* Compute the local integral. */ + ivr->igral = h * w * ivr->c[0]; + + + /* Fix-up the heap: we now have one interval on top + that we don't need any more and two new, unsorted + ones at the bottom. */ + /* Flip the last interval to the top of the heap and + sift down. */ + t = heap[nivals - 1]; + heap[nivals - 1] = heap[0]; + heap[0] = t; + nivals--; + /* Sift this interval back down the heap. */ + i = 0; + while (2 * i + 1 < nivals - 1) + { + j = 2 * i + 1; + if (j + 1 < nivals - 1 + && ivals[heap[j + 1]].err >= ivals[heap[j]].err) + j++; + if (ivals[heap[j]].err <= ivals[heap[i]].err) + break; + else + { + t = heap[j]; + heap[j] = heap[i]; + heap[i] = t; + i = j; + } + } + + /* Now grab the last interval and sift it up the heap. */ + i = nivals - 1; + while (i > 0) + { + j = (i - 1) / 2; + if (ivals[heap[j]].err < ivals[heap[i]].err) + { + t = heap[j]; + heap[j] = heap[i]; + heap[i] = t; + i = j; + } + else + break; + } + + + } + + /* Otherwise, just fix-up the heap. */ + else + { + i = 0; + while (2 * i + 1 < nivals) + { + j = 2 * i + 1; + if (j + 1 < nivals + && ivals[heap[j + 1]].err >= ivals[heap[j]].err) + j++; + if (ivals[heap[j]].err <= ivals[heap[i]].err) + break; + else + { + t = heap[j]; + heap[j] = heap[i]; + heap[i] = t; + i = j; + } + } + + } + + /* If the heap is about to overflow, remove the last two + intervals. */ + while (nivals > cquad_heapsize - 2) + { + iv = &(ivals[heap[nivals - 1]]); +/* printf + ("quadcc: dropping ival %i (of %i) with [%e,%e] int=%e, err=%e, depth=%i\n", + heap[0], nivals, iv->a, iv->b, iv->igral, iv->err, + iv->depth); +*/ + err_final += iv->err; + igral_final += iv->igral; + nivals--; + } + + /* Collect the value of the integral and error. */ + igral = igral_final; + err = err_final; + for (i = 0; i < nivals; i++) + { + igral += ivals[heap[i]].igral; + err += ivals[heap[i]].err; + } + + } + + /* Dump the contents of the heap. */ +/* for (i = 0; i < nivals; i++) + { + iv = &(ivals[heap[i]]); + printf + ("quadcc: ival %i (%i) with [%e,%e], int=%e, err=%e, depth=%i, rdepth=%i, ndiv=%i\n", + i, heap[i], iv->a, iv->b, iv->igral, iv->err, iv->depth, + iv->rdepth, iv->ndiv); + } +*/ + /* Clean up and present the results. */ + if (nargout > 2) + retval(2) = neval; + if (nargout > 1) + retval(1) = err; + retval(0) = igral; + /* All is well that ends well. */ + return retval; +} + + +/* +%!assert (quadcc (@sin, -pi, pi), 0, 1e-6) +%!assert (quadcc (inline ("sin"),- pi, pi), 0, 1e-6) +%!assert (quadcc ("sin", -pi, pi), 0, 1e-6) + +%!assert (quadcc (@sin, -pi, 0), -2, 1e-6) +%!assert (quadcc (@sin, 0, pi), 2, 1e-6) +%!assert (quadcc (@(x) 1./sqrt (x), 0, 1), 2, 1e-6) +%!assert (quadcc (@(x) 1./(sqrt (x).*(x+1)), 0, Inf), pi, 1e-6) + +%!assert (quadcc (@(x) exp (-x .^ 2), -Inf, Inf), sqrt (pi), 1e-6) +%!assert (quadcc (@(x) exp (-x .^ 2), -Inf, 0), sqrt (pi)/2, 1e-6) + +%% Test input validation +%!error (quadcc ()) +%!error (quadcc (@sin)) +%!error (quadcc (@sin, 0)) +%!error (quadcc (@sin, ones (2), pi)) +%!error (quadcc (@sin, -i, pi)) +%!error (quadcc (@sin, 0, ones (2))) +%!error (quadcc (@sin, 0, i)) +%!error (quadcc (@sin, 0, pi, 0)) +%!error (quadcc (@sin, 0, pi, 1e-6, [ i ])) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/qz.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,1278 @@ +/* + +Copyright (C) 1998-2012 A. S. Hodel + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Generalized eigenvalue balancing via LAPACK + +// Author: A. S. Hodel <scotte@eng.auburn.edu> + +#undef DEBUG +#undef DEBUG_SORT +#undef DEBUG_EIG + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <cfloat> + +#include <iostream> +#include <iomanip> + +#include "CmplxQRP.h" +#include "CmplxQR.h" +#include "dbleQR.h" +#include "f77-fcn.h" +#include "lo-math.h" +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "oct-map.h" +#include "ov.h" +#include "pager.h" +#if defined (DEBUG) || defined (DEBUG_SORT) +#include "pr-output.h" +#endif +#include "symtab.h" +#include "utils.h" +#include "variables.h" + +typedef octave_idx_type (*sort_function) (const octave_idx_type& LSIZE, const double& ALPHA, + const double& BETA, const double& S, + const double& P); + +extern "C" +{ + F77_RET_T + F77_FUNC (dggbal, DGGBAL) (F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, double* A, + const octave_idx_type& LDA, double* B, + const octave_idx_type& LDB, octave_idx_type& ILO, + octave_idx_type& IHI, double* LSCALE, + double* RSCALE, double* WORK, + octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL); + +F77_RET_T + F77_FUNC (zggbal, ZGGBAL) (F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, Complex* A, + const octave_idx_type& LDA, Complex* B, + const octave_idx_type& LDB, octave_idx_type& ILO, + octave_idx_type& IHI, double* LSCALE, + double* RSCALE, double* WORK, + octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (dggbak, DGGBAK) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, + const octave_idx_type& ILO, + const octave_idx_type& IHI, + const double* LSCALE, const double* RSCALE, + octave_idx_type& M, double* V, + const octave_idx_type& LDV, octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + +F77_RET_T + F77_FUNC (zggbak, ZGGBAK) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, + const octave_idx_type& ILO, + const octave_idx_type& IHI, + const double* LSCALE, const double* RSCALE, + octave_idx_type& M, Complex* V, + const octave_idx_type& LDV, octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (dgghrd, DGGHRD) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, + const octave_idx_type& ILO, + const octave_idx_type& IHI, double* A, + const octave_idx_type& LDA, double* B, + const octave_idx_type& LDB, double* Q, + const octave_idx_type& LDQ, double* Z, + const octave_idx_type& LDZ, octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (zgghrd, ZGGHRD) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, + const octave_idx_type& ILO, + const octave_idx_type& IHI, Complex* A, + const octave_idx_type& LDA, Complex* B, + const octave_idx_type& LDB, Complex* Q, + const octave_idx_type& LDQ, Complex* Z, + const octave_idx_type& LDZ, octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (dhgeqz, DHGEQZ) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, + const octave_idx_type& ILO, + const octave_idx_type& IHI, + double* A, const octave_idx_type& LDA, double* B, + const octave_idx_type& LDB, double* ALPHAR, + double* ALPHAI, double* BETA, double* Q, + const octave_idx_type& LDQ, double* Z, + const octave_idx_type& LDZ, double* WORK, + const octave_idx_type& LWORK, + octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + +F77_RET_T + F77_FUNC (zhgeqz, ZHGEQZ) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + const octave_idx_type& N, + const octave_idx_type& ILO, + const octave_idx_type& IHI, + Complex* A, const octave_idx_type& LDA, + Complex* B, const octave_idx_type& LDB, + Complex* ALPHA, Complex* BETA, Complex* CQ, + const octave_idx_type& LDQ, + Complex* CZ, const octave_idx_type& LDZ, + Complex* WORK, const octave_idx_type& LWORK, + double* RWORK, octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (dlag2, DLAG2) (const double* A, const octave_idx_type& LDA, + const double* B, const octave_idx_type& LDB, + const double& SAFMIN, double& SCALE1, + double& SCALE2, double& WR1, double& WR2, + double& WI); + + // Van Dooren's code (netlib.org: toms/590) for reordering + // GEP. Only processes Z, not Q. + F77_RET_T + F77_FUNC (dsubsp, DSUBSP) (const octave_idx_type& NMAX, + const octave_idx_type& N, double* A, + double* B, double* Z, sort_function, + const double& EPS, octave_idx_type& NDIM, + octave_idx_type& FAIL, octave_idx_type* IND); + + // Documentation for DTGEVC incorrectly states that VR, VL are + // complex*16; they are declared in DTGEVC as double precision + // (probably a cut and paste problem fro ZTGEVC). + F77_RET_T + F77_FUNC (dtgevc, DTGEVC) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + octave_idx_type* SELECT, + const octave_idx_type& N, double* A, + const octave_idx_type& LDA, double* B, + const octave_idx_type& LDB, double* VL, + const octave_idx_type& LDVL, double* VR, + const octave_idx_type& LDVR, + const octave_idx_type& MM, octave_idx_type& M, + double* WORK, octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + +F77_RET_T + F77_FUNC (ztgevc, ZTGEVC) (F77_CONST_CHAR_ARG_DECL, + F77_CONST_CHAR_ARG_DECL, + octave_idx_type* SELECT, + const octave_idx_type& N, const Complex* A, + const octave_idx_type& LDA,const Complex* B, + const octave_idx_type& LDB, Complex* xVL, + const octave_idx_type& LDVL, Complex* xVR, + const octave_idx_type& LDVR, + const octave_idx_type& MM, octave_idx_type& M, + Complex* CWORK, double* RWORK, + octave_idx_type& INFO + F77_CHAR_ARG_LEN_DECL + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (xdlamch, XDLAMCH) (F77_CONST_CHAR_ARG_DECL, + double& retval + F77_CHAR_ARG_LEN_DECL); + + F77_RET_T + F77_FUNC (xdlange, XDLANGE) (F77_CONST_CHAR_ARG_DECL, + const octave_idx_type&, + const octave_idx_type&, const double*, + const octave_idx_type&, double*, double& + F77_CHAR_ARG_LEN_DECL); +} + +// fcrhp, fin, fout, folhp: +// routines for ordering of generalized eigenvalues +// return 1 if test is passed, 0 otherwise +// fin: |lambda| < 1 +// fout: |lambda| >= 1 +// fcrhp: real(lambda) >= 0 +// folhp: real(lambda) < 0 + +static octave_idx_type +fcrhp (const octave_idx_type& lsize, const double& alpha, + const double& beta, const double& s, const double&) +{ + if (lsize == 1) + return (alpha * beta >= 0 ? 1 : -1); + else + return (s >= 0 ? 1 : -1); +} + +static octave_idx_type +fin (const octave_idx_type& lsize, const double& alpha, + const double& beta, const double&, const double& p) +{ + octave_idx_type retval; + + if (lsize == 1) + retval = (fabs (alpha) < fabs (beta) ? 1 : -1); + else + retval = (fabs (p) < 1 ? 1 : -1); + +#ifdef DEBUG + std::cout << "qz: fin: retval=" << retval << std::endl; +#endif + + return retval; +} + +static octave_idx_type +folhp (const octave_idx_type& lsize, const double& alpha, + const double& beta, const double& s, const double&) +{ + if (lsize == 1) + return (alpha * beta < 0 ? 1 : -1); + else + return (s < 0 ? 1 : -1); +} + +static octave_idx_type +fout (const octave_idx_type& lsize, const double& alpha, + const double& beta, const double&, const double& p) +{ + if (lsize == 1) + return (fabs (alpha) >= fabs (beta) ? 1 : -1); + else + return (fabs (p) >= 1 ? 1 : -1); +} + + +//FIXME: Matlab does not produce lambda as the first output argument. +// Compatibility problem? +DEFUN (qz, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{lambda} =} qz (@var{A}, @var{B})\n\ +@deftypefnx {Built-in Function} {@var{lambda} =} qz (@var{A}, @var{B}, @var{opt})\n\ +QZ@tie{}decomposition of the generalized eigenvalue problem\n\ +(@math{A x = s B x}). There are three ways to call this function:\n\ +@enumerate\n\ +@item @code{@var{lambda} = qz (@var{A}, @var{B})}\n\ +\n\ +Computes the generalized eigenvalues\n\ +@tex\n\ +$\\lambda$\n\ +@end tex\n\ +@ifnottex\n\ +@var{lambda}\n\ +@end ifnottex\n\ +of @math{(A - s B)}.\n\ +\n\ +@item @code{[AA, BB, Q, Z, V, W, @var{lambda}] = qz (@var{A}, @var{B})}\n\ +\n\ +Computes QZ@tie{}decomposition, generalized eigenvectors, and\n\ +generalized eigenvalues of @math{(A - s B)}\n\ +@tex\n\ +$$ AV = BV{ \\rm diag }(\\lambda) $$\n\ +$$ W^T A = { \\rm diag }(\\lambda)W^T B $$\n\ +$$ AA = Q^T AZ, BB = Q^T BZ $$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@group\n\ +\n\ +A * V = B * V * diag (@var{lambda})\n\ +W' * A = diag (@var{lambda}) * W' * B\n\ +AA = Q * A * Z, BB = Q * B * Z\n\ +\n\ +@end group\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +with @var{Q} and @var{Z} orthogonal (unitary)= @var{I}\n\ +\n\ +@item @code{[AA,BB,Z@{, @var{lambda}@}] = qz (@var{A}, @var{B}, @var{opt})}\n\ +\n\ +As in form [2], but allows ordering of generalized eigenpairs\n\ +for (e.g.) solution of discrete time algebraic Riccati equations.\n\ +Form 3 is not available for complex matrices, and does not compute\n\ +the generalized eigenvectors @var{V}, @var{W}, nor the orthogonal matrix\n\ +@var{Q}.\n\ +\n\ +@table @var\n\ +@item opt\n\ +for ordering eigenvalues of the GEP pencil. The leading block\n\ +of the revised pencil contains all eigenvalues that satisfy:\n\ +\n\ +@table @asis\n\ +@item \"N\"\n\ += unordered (default)\n\ +\n\ +@item \"S\"\n\ += small: leading block has all |lambda| @leq{} 1\n\ +\n\ +@item \"B\"\n\ += big: leading block has all |lambda| @geq{} 1\n\ +\n\ +@item \"-\"\n\ += negative real part: leading block has all eigenvalues\n\ +in the open left half-plane\n\ +\n\ +@item \"+\"\n\ += non-negative real part: leading block has all eigenvalues\n\ +in the closed right half-plane\n\ +@end table\n\ +@end table\n\ +@end enumerate\n\ +\n\ +Note: @code{qz} performs permutation balancing, but not scaling\n\ +(@pxref{doc-balance}). The order of output arguments was selected for\n\ +compatibility with @sc{matlab}.\n\ +@seealso{balance, eig, schur}\n\ +@end deftypefn") +{ + octave_value_list retval; + int nargin = args.length (); + +#ifdef DEBUG + std::cout << "qz: nargin = " << nargin << ", nargout = " << nargout << std::endl; +#endif + + if (nargin < 2 || nargin > 3 || nargout > 7) + { + print_usage (); + return retval; + } + else if (nargin == 3 && (nargout < 3 || nargout > 4)) + { + error ("qz: invalid number of output arguments for form [3] call"); + return retval; + } + +#ifdef DEBUG + std::cout << "qz: determine ordering option" << std::endl; +#endif + + // Determine ordering option. + volatile char ord_job = 0; + static double safmin; + + if (nargin == 2) + ord_job = 'N'; + else if (!args(2).is_string ()) + { + error ("qz: OPT must be a string"); + return retval; + } + else + { + std::string tmp = args(2).string_value (); + + if (! tmp.empty ()) + ord_job = tmp[0]; + + if (! (ord_job == 'N' || ord_job == 'n' + || ord_job == 'S' || ord_job == 's' + || ord_job == 'B' || ord_job == 'b' + || ord_job == '+' || ord_job == '-')) + { + error ("qz: invalid order option"); + return retval; + } + + // overflow constant required by dlag2 + F77_FUNC (xdlamch, XDLAMCH) (F77_CONST_CHAR_ARG2 ("S", 1), + safmin + F77_CHAR_ARG_LEN (1)); + +#ifdef DEBUG_EIG + std::cout << "qz: initial value of safmin=" << setiosflags (std::ios::scientific) + << safmin << std::endl; +#endif + + // Some machines (e.g., DEC alpha) get safmin = 0; + // for these, use eps instead to avoid problems in dlag2. + if (safmin == 0) + { +#ifdef DEBUG_EIG + std::cout << "qz: DANGER WILL ROBINSON: safmin is 0!" << std::endl; +#endif + + F77_FUNC (xdlamch, XDLAMCH) (F77_CONST_CHAR_ARG2 ("E", 1), + safmin + F77_CHAR_ARG_LEN (1)); + +#ifdef DEBUG_EIG + std::cout << "qz: safmin set to " << setiosflags (std::ios::scientific) + << safmin << std::endl; +#endif + } + } + +#ifdef DEBUG + std::cout << "qz: check argument 1" << std::endl; +#endif + + // Argument 1: check if it's o.k. dimensioned. + octave_idx_type nn = args(0).rows (); + +#ifdef DEBUG + std::cout << "argument 1 dimensions: (" << nn << "," << args(0).columns () << ")" + << std::endl; +#endif + + int arg_is_empty = empty_arg ("qz", nn, args(0).columns ()); + + if (arg_is_empty < 0) + { + gripe_empty_arg ("qz: parameter 1", 0); + return retval; + } + else if (arg_is_empty > 0) + { + gripe_empty_arg ("qz: parameter 1; continuing", 0); + return octave_value_list (2, Matrix ()); + } + else if (args(0).columns () != nn) + { + gripe_square_matrix_required ("qz"); + return retval; + } + + // Argument 1: dimensions look good; get the value. + Matrix aa; + ComplexMatrix caa; + + if (args(0).is_complex_type ()) + caa = args(0).complex_matrix_value (); + else + aa = args(0).matrix_value (); + + if (error_state) + return retval; + +#ifdef DEBUG + std::cout << "qz: check argument 2" << std::endl; +#endif + + // Extract argument 2 (bb, or cbb if complex). + if ((nn != args(1).columns ()) || (nn != args(1).rows ())) + { + gripe_nonconformant (); + return retval; + } + + Matrix bb; + ComplexMatrix cbb; + + if (args(1).is_complex_type ()) + cbb = args(1).complex_matrix_value (); + else + bb = args(1).matrix_value (); + + if (error_state) + return retval; + + // Both matrices loaded, now let's check what kind of arithmetic: + // declared volatile to avoid compiler warnings about long jumps, + // vforks. + + volatile int complex_case + = (args(0).is_complex_type () || args(1).is_complex_type ()); + + if (nargin == 3 && complex_case) + { + error ("qz: cannot re-order complex qz decomposition"); + return retval; + } + + // First, declare variables used in both the real and complex case. + Matrix QQ(nn,nn), ZZ(nn,nn), VR(nn,nn), VL(nn,nn); + RowVector alphar(nn), alphai(nn), betar(nn); + ComplexRowVector xalpha(nn), xbeta(nn); + ComplexMatrix CQ(nn,nn), CZ(nn,nn), CVR(nn,nn), CVL(nn,nn); + octave_idx_type ilo, ihi, info; + char compq = (nargout >= 3 ? 'V' : 'N'); + char compz = ((nargout >= 4 || nargin == 3)? 'V' : 'N'); + + // Initialize Q, Z to identity if we need either of them. + if (compq == 'V' || compz == 'V') + for (octave_idx_type ii = 0; ii < nn; ii++) + for (octave_idx_type jj = 0; jj < nn; jj++) + { + OCTAVE_QUIT; + QQ(ii,jj) = ZZ(ii,jj) = (ii == jj ? 1.0 : 0.0); + } + + // Always perform permutation balancing. + const char bal_job = 'P'; + RowVector lscale (nn), rscale (nn), work (6 * nn), rwork (nn); + + if (complex_case) + { +#ifdef DEBUG + if (compq == 'V') + std::cout << "qz: performing balancing; CQ=" << std::endl << CQ << std::endl; +#endif + if (args(0).is_real_type ()) + caa = ComplexMatrix (aa); + + if (args(1).is_real_type ()) + cbb = ComplexMatrix (bb); + + if (compq == 'V') + CQ = ComplexMatrix (QQ); + + if (compz == 'V') + CZ = ComplexMatrix (ZZ); + + F77_XFCN (zggbal, ZGGBAL, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + nn, caa.fortran_vec (), nn, cbb.fortran_vec (), + nn, ilo, ihi, lscale.fortran_vec (), + rscale.fortran_vec (), work.fortran_vec (), info + F77_CHAR_ARG_LEN (1))); + } + else + { +#ifdef DEBUG + if (compq == 'V') + std::cout << "qz: performing balancing; QQ=" << std::endl << QQ << std::endl; +#endif + + F77_XFCN (dggbal, DGGBAL, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + nn, aa.fortran_vec (), nn, bb.fortran_vec (), + nn, ilo, ihi, lscale.fortran_vec (), + rscale.fortran_vec (), work.fortran_vec (), info + F77_CHAR_ARG_LEN (1))); + } + + // Since we just want the balancing matrices, we can use dggbal + // for both the real and complex cases; left first + +#if 0 + if (compq == 'V') + { + F77_XFCN (dggbak, DGGBAK, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + F77_CONST_CHAR_ARG2 ("L", 1), + nn, ilo, ihi, lscale.data (), rscale.data (), + nn, QQ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + +#ifdef DEBUG + if (compq == 'V') + std::cout << "qz: balancing done; QQ=" << std::endl << QQ << std::endl; +#endif + } + + // then right + if (compz == 'V') + { + F77_XFCN (dggbak, DGGBAK, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + F77_CONST_CHAR_ARG2 ("R", 1), + nn, ilo, ihi, lscale.data (), rscale.data (), + nn, ZZ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + +#ifdef DEBUG + if (compz == 'V') + std::cout << "qz: balancing done; ZZ=" << std::endl << ZZ << std::endl; +#endif + } +#endif + + static char qz_job; + qz_job = (nargout < 2 ? 'E' : 'S'); + + if (complex_case) + { + // Complex case. + + // The QR decomposition of cbb. + ComplexQR cbqr (cbb); + // The R matrix of QR decomposition for cbb. + cbb = cbqr.R (); + // (Q*)caa for following work. + caa = (cbqr.Q ().hermitian ()) * caa; + CQ = CQ * cbqr.Q (); + + F77_XFCN (zgghrd, ZGGHRD, + (F77_CONST_CHAR_ARG2 (&compq, 1), + F77_CONST_CHAR_ARG2 (&compz, 1), + nn, ilo, ihi, caa.fortran_vec (), + nn, cbb.fortran_vec (), nn, CQ.fortran_vec (), nn, + CZ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + + ComplexRowVector cwork (1 * nn); + + F77_XFCN (zhgeqz, ZHGEQZ, + (F77_CONST_CHAR_ARG2 (&qz_job, 1), + F77_CONST_CHAR_ARG2 (&compq, 1), + F77_CONST_CHAR_ARG2 (&compz, 1), + nn, ilo, ihi, + caa.fortran_vec (), nn, + cbb.fortran_vec (),nn, + xalpha.fortran_vec (), xbeta.fortran_vec (), + CQ.fortran_vec (), nn, + CZ.fortran_vec (), nn, + cwork.fortran_vec (), nn, rwork.fortran_vec (), info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + + if (compq == 'V') + { + // Left eigenvector. + F77_XFCN (zggbak, ZGGBAK, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + F77_CONST_CHAR_ARG2 ("L", 1), + nn, ilo, ihi, lscale.data (), rscale.data (), + nn, CQ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + } + + // Right eigenvector. + if (compz == 'V') + { + F77_XFCN (zggbak, ZGGBAK, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + F77_CONST_CHAR_ARG2 ("R", 1), + nn, ilo, ihi, lscale.data (), rscale.data (), + nn, CZ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + } + + } + else + { +#ifdef DEBUG + std::cout << "qz: peforming qr decomposition of bb" << std::endl; +#endif + + // Compute the QR factorization of bb. + QR bqr (bb); + +#ifdef DEBUG + std::cout << "qz: qr (bb) done; now peforming qz decomposition" << std::endl; +#endif + + bb = bqr.R (); + +#ifdef DEBUG + std::cout << "qz: extracted bb" << std::endl; +#endif + + aa = (bqr.Q ()).transpose () * aa; + +#ifdef DEBUG + std::cout << "qz: updated aa " << std::endl; + std::cout << "bqr.Q () = " << std::endl << bqr.Q () << std::endl; + + if (compq == 'V') + std::cout << "QQ =" << QQ << std::endl; +#endif + + if (compq == 'V') + QQ = QQ * bqr.Q (); + +#ifdef DEBUG + std::cout << "qz: precursors done..." << std::endl; +#endif + +#ifdef DEBUG + std::cout << "qz: compq = " << compq << ", compz = " << compz << std::endl; +#endif + + // Reduce to generalized hessenberg form. + F77_XFCN (dgghrd, DGGHRD, + (F77_CONST_CHAR_ARG2 (&compq, 1), + F77_CONST_CHAR_ARG2 (&compz, 1), + nn, ilo, ihi, aa.fortran_vec (), + nn, bb.fortran_vec (), nn, QQ.fortran_vec (), nn, + ZZ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + + // Check if just computing generalized eigenvalues or if we're + // actually computing the decomposition. + + // Reduce to generalized Schur form. + F77_XFCN (dhgeqz, DHGEQZ, + (F77_CONST_CHAR_ARG2 (&qz_job, 1), + F77_CONST_CHAR_ARG2 (&compq, 1), + F77_CONST_CHAR_ARG2 (&compz, 1), + nn, ilo, ihi, aa.fortran_vec (), nn, bb.fortran_vec (), + nn, alphar.fortran_vec (), alphai.fortran_vec (), + betar.fortran_vec (), QQ.fortran_vec (), nn, + ZZ.fortran_vec (), nn, work.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + + if (compq == 'V') + { + F77_XFCN (dggbak, DGGBAK, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + F77_CONST_CHAR_ARG2 ("L", 1), + nn, ilo, ihi, lscale.data (), rscale.data (), + nn, QQ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + +#ifdef DEBUG + if (compq == 'V') + std::cout << "qz: balancing done; QQ=" << std::endl << QQ << std::endl; +#endif + } + + // then right + if (compz == 'V') + { + F77_XFCN (dggbak, DGGBAK, + (F77_CONST_CHAR_ARG2 (&bal_job, 1), + F77_CONST_CHAR_ARG2 ("R", 1), + nn, ilo, ihi, lscale.data (), rscale.data (), + nn, ZZ.fortran_vec (), nn, info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + +#ifdef DEBUG + if (compz == 'V') + std::cout << "qz: balancing done; ZZ=" << std::endl << ZZ << std::endl; +#endif + } + + } + + // Order the QZ decomposition? + if (! (ord_job == 'N' || ord_job == 'n')) + { + if (complex_case) + { + // Probably not needed, but better be safe. + error ("qz: cannot re-order complex qz decomposition"); + return retval; + } + else + { +#ifdef DEBUG_SORT + std::cout << "qz: ordering eigenvalues: ord_job = " + << ord_job << std::endl; +#endif + + // Declared static to avoid vfork/long jump compiler complaints. + static sort_function sort_test; + sort_test = 0; + + switch (ord_job) + { + case 'S': + case 's': + sort_test = &fin; + break; + + case 'B': + case 'b': + sort_test = &fout; + break; + + case '+': + sort_test = &fcrhp; + break; + + case '-': + sort_test = &folhp; + break; + + default: + // Invalid order option (should never happen, since we + // checked the options at the top). + panic_impossible (); + break; + } + + octave_idx_type ndim, fail; + double inf_norm; + + F77_XFCN (xdlange, XDLANGE, + (F77_CONST_CHAR_ARG2 ("I", 1), + nn, nn, aa.data (), nn, work.fortran_vec (), inf_norm + F77_CHAR_ARG_LEN (1))); + + double eps = DBL_EPSILON * inf_norm * nn; + +#ifdef DEBUG_SORT + std::cout << "qz: calling dsubsp: aa=" << std::endl; + octave_print_internal (std::cout, aa, 0); + std::cout << std::endl << "bb=" << std::endl; + octave_print_internal (std::cout, bb, 0); + if (compz == 'V') + { + std::cout << std::endl << "ZZ=" << std::endl; + octave_print_internal (std::cout, ZZ, 0); + } + std::cout << std::endl; + std::cout << "alphar = " << std::endl; + octave_print_internal (std::cout, (Matrix) alphar, 0); + std::cout << std::endl << "alphai = " << std::endl; + octave_print_internal (std::cout, (Matrix) alphai, 0); + std::cout << std::endl << "beta = " << std::endl; + octave_print_internal (std::cout, (Matrix) betar, 0); + std::cout << std::endl; +#endif + + Array<octave_idx_type> ind (dim_vector (nn, 1)); + + F77_XFCN (dsubsp, DSUBSP, + (nn, nn, aa.fortran_vec (), bb.fortran_vec (), + ZZ.fortran_vec (), sort_test, eps, ndim, fail, + ind.fortran_vec ())); + +#ifdef DEBUG + std::cout << "qz: back from dsubsp: aa=" << std::endl; + octave_print_internal (std::cout, aa, 0); + std::cout << std::endl << "bb=" << std::endl; + octave_print_internal (std::cout, bb, 0); + if (compz == 'V') + { + std::cout << std::endl << "ZZ=" << std::endl; + octave_print_internal (std::cout, ZZ, 0); + } + std::cout << std::endl; +#endif + + // Manually update alphar, alphai, betar. + static int jj; + + jj = 0; + while (jj < nn) + { +#ifdef DEBUG_EIG + std::cout << "computing gen eig #" << jj << std::endl; +#endif + + // Number of zeros in this block. + static int zcnt; + + if (jj == (nn-1)) + zcnt = 1; + else if (aa(jj+1,jj) == 0) + zcnt = 1; + else zcnt = 2; + + if (zcnt == 1) + { + // Real zero. +#ifdef DEBUG_EIG + std::cout << " single gen eig:" << std::endl; + std::cout << " alphar(" << jj << ") = " << aa(jj,jj) << std::endl; + std::cout << " betar( " << jj << ") = " << bb(jj,jj) << std::endl; + std::cout << " alphai(" << jj << ") = 0" << std::endl; +#endif + + alphar(jj) = aa(jj,jj); + alphai(jj) = 0; + betar(jj) = bb(jj,jj); + } + else + { + // Complex conjugate pair. +#ifdef DEBUG_EIG + std::cout << "qz: calling dlag2:" << std::endl; + std::cout << "safmin=" + << setiosflags (std::ios::scientific) << safmin << std::endl; + + for (int idr = jj; idr <= jj+1; idr++) + { + for (int idc = jj; idc <= jj+1; idc++) + { + std::cout << "aa(" << idr << "," << idc << ")=" + << aa(idr,idc) << std::endl; + std::cout << "bb(" << idr << "," << idc << ")=" + << bb(idr,idc) << std::endl; + } + } +#endif + + // FIXME -- probably should be using + // fortran_vec instead of &aa(jj,jj) here. + + double scale1, scale2, wr1, wr2, wi; + const double *aa_ptr = aa.data () + jj * nn + jj; + const double *bb_ptr = bb.data () + jj * nn + jj; + F77_XFCN (dlag2, DLAG2, + (aa_ptr, nn, bb_ptr, nn, safmin, + scale1, scale2, wr1, wr2, wi)); + +#ifdef DEBUG_EIG + std::cout << "dlag2 returns: scale1=" << scale1 + << "\tscale2=" << scale2 << std::endl + << "\twr1=" << wr1 << "\twr2=" << wr2 + << "\twi=" << wi << std::endl; +#endif + + // Just to be safe, check if it's a real pair. + if (wi == 0) + { + alphar(jj) = wr1; + alphai(jj) = 0; + betar(jj) = scale1; + alphar(jj+1) = wr2; + alphai(jj+1) = 0; + betar(jj+1) = scale2; + } + else + { + alphar(jj) = alphar(jj+1) = wr1; + alphai(jj) = -(alphai(jj+1) = wi); + betar(jj) = betar(jj+1) = scale1; + } + } + + // Advance past this block. + jj += zcnt; + } + +#ifdef DEBUG_SORT + std::cout << "qz: back from dsubsp: aa=" << std::endl; + octave_print_internal (std::cout, aa, 0); + std::cout << std::endl << "bb=" << std::endl; + octave_print_internal (std::cout, bb, 0); + + if (compz == 'V') + { + std::cout << std::endl << "ZZ=" << std::endl; + octave_print_internal (std::cout, ZZ, 0); + } + std::cout << std::endl << "qz: ndim=" << ndim << std::endl + << "fail=" << fail << std::endl; + std::cout << "alphar = " << std::endl; + octave_print_internal (std::cout, (Matrix) alphar, 0); + std::cout << std::endl << "alphai = " << std::endl; + octave_print_internal (std::cout, (Matrix) alphai, 0); + std::cout << std::endl << "beta = " << std::endl; + octave_print_internal (std::cout, (Matrix) betar, 0); + std::cout << std::endl; +#endif + } + } + + // Compute generalized eigenvalues? + ComplexColumnVector gev; + + if (nargout < 2 || nargout == 7 || (nargin == 3 && nargout == 4)) + { + if (complex_case) + { + int cnt = 0; + + for (int ii = 0; ii < nn; ii++) + cnt++; + + ComplexColumnVector tmp (cnt); + + cnt = 0; + for (int ii = 0; ii < nn; ii++) + tmp(cnt++) = xalpha(ii) / xbeta(ii); + + gev = tmp; + } + else + { +#ifdef DEBUG + std::cout << "qz: computing generalized eigenvalues" << std::endl; +#endif + + // Return finite generalized eigenvalues. + int cnt = 0; + + for (int ii = 0; ii < nn; ii++) + if (betar(ii) != 0) + cnt++; + + ComplexColumnVector tmp (cnt); + + cnt = 0; + for (int ii = 0; ii < nn; ii++) + if (betar(ii) != 0) + tmp(cnt++) = Complex(alphar(ii), alphai(ii))/betar(ii); + + gev = tmp; + } + } + + // Right, left eigenvector matrices. + if (nargout >= 5) + { + // Which side to compute? + char side = (nargout == 5 ? 'R' : 'B'); + // Compute all of them and backtransform + char howmny = 'B'; + // Dummy pointer; select is not used. + octave_idx_type *select = 0; + + if (complex_case) + { + CVL = CQ; + CVR = CZ; + ComplexRowVector cwork2 (2 * nn); + RowVector rwork2 (8 * nn); + octave_idx_type m; + + F77_XFCN (ztgevc, ZTGEVC, + (F77_CONST_CHAR_ARG2 (&side, 1), + F77_CONST_CHAR_ARG2 (&howmny, 1), + select, nn, caa.fortran_vec (), nn, cbb.fortran_vec (), + nn, CVL.fortran_vec (), nn, CVR.fortran_vec (), nn, nn, + m, cwork2.fortran_vec (), rwork2.fortran_vec (), info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + } + else + { +#ifdef DEBUG + std::cout << "qz: computing generalized eigenvectors" << std::endl; +#endif + + VL = QQ; + VR = ZZ; + octave_idx_type m; + + F77_XFCN (dtgevc, DTGEVC, + (F77_CONST_CHAR_ARG2 (&side, 1), + F77_CONST_CHAR_ARG2 (&howmny, 1), + select, nn, aa.fortran_vec (), nn, bb.fortran_vec (), + nn, VL.fortran_vec (), nn, VR.fortran_vec (), nn, nn, + m, work.fortran_vec (), info + F77_CHAR_ARG_LEN (1) + F77_CHAR_ARG_LEN (1))); + + // Now construct the complex form of VV, WW. + int jj = 0; + + while (jj < nn) + { + OCTAVE_QUIT; + + // See if real or complex eigenvalue. + + // Column increment; assume complex eigenvalue. + int cinc = 2; + + if (jj == (nn-1)) + // Single column. + cinc = 1; + else if (aa(jj+1,jj) == 0) + cinc = 1; + + // Now copy the eigenvector (s) to CVR, CVL. + if (cinc == 1) + { + for (int ii = 0; ii < nn; ii++) + CVR(ii,jj) = VR(ii,jj); + + if (side == 'B') + for (int ii = 0; ii < nn; ii++) + CVL(ii,jj) = VL(ii,jj); + } + else + { + // Double column; complex vector. + + for (int ii = 0; ii < nn; ii++) + { + CVR(ii,jj) = Complex (VR(ii,jj), VR(ii,jj+1)); + CVR(ii,jj+1) = Complex (VR(ii,jj), -VR(ii,jj+1)); + } + + if (side == 'B') + for (int ii = 0; ii < nn; ii++) + { + CVL(ii,jj) = Complex (VL(ii,jj), VL(ii,jj+1)); + CVL(ii,jj+1) = Complex (VL(ii,jj), -VL(ii,jj+1)); + } + } + + // Advance to next eigenvectors (if any). + jj += cinc; + } + } + } + + switch (nargout) + { + case 7: + retval(6) = gev; + + case 6: + // Return eigenvectors. + retval(5) = CVL; + + case 5: + // Return eigenvectors. + retval(4) = CVR; + + case 4: + if (nargin == 3) + { +#ifdef DEBUG + std::cout << "qz: sort: retval(3) = gev = " << std::endl; + octave_print_internal (std::cout, gev); + std::cout << std::endl; +#endif + retval(3) = gev; + } + else + { + if (complex_case) + retval(3) = CZ; + else + retval(3) = ZZ; + } + + case 3: + if (nargin == 3) + { + if (complex_case) + retval(2) = CZ; + else + retval(2) = ZZ; + } + else + { + if (complex_case) + retval(2) = CQ.hermitian (); + else + retval(2) = QQ.transpose (); + } + + case 2: + { + if (complex_case) + { +#ifdef DEBUG + std::cout << "qz: retval(1) = cbb = " << std::endl; + octave_print_internal (std::cout, cbb, 0); + std::cout << std::endl << "qz: retval(0) = caa = " <<std::endl; + octave_print_internal (std::cout, caa, 0); + std::cout << std::endl; +#endif + retval(1) = cbb; + retval(0) = caa; + } + else + { +#ifdef DEBUG + std::cout << "qz: retval(1) = bb = " << std::endl; + octave_print_internal (std::cout, bb, 0); + std::cout << std::endl << "qz: retval(0) = aa = " <<std::endl; + octave_print_internal (std::cout, aa, 0); + std::cout << std::endl; +#endif + retval(1) = bb; + retval(0) = aa; + } + } + break; + + + case 1: + case 0: +#ifdef DEBUG + std::cout << "qz: retval(0) = gev = " << gev << std::endl; +#endif + retval(0) = gev; + break; + + default: + error ("qz: too many return arguments"); + break; + } + +#ifdef DEBUG + std::cout << "qz: exiting (at long last)" << std::endl; +#endif + + return retval; +} + +/* +%!shared a, b, c +%! a = [1 2; 0 3]; +%! b = [1 0; 0 0]; +%! c = [0 1; 0 0]; +%!assert (qz (a,b), 1) +%!assert (isempty (qz (a,c))) + +## Exaple 7.7.3 in Golub & Van Loan +%!test +%! a = [ 10 1 2; +%! 1 2 -1; +%! 1 1 2]; +%! b = reshape (1:9,3,3); +%! [aa, bb, q, z, v, w, lambda] = qz (a, b); +%! sz = length (lambda); +%! observed = (b * v * diag ([lambda;0])) (:, 1:sz); +%! assert ( (a*v) (:, 1:sz), observed, norm (observed) * 1e-14); +%! observed = (diag ([lambda;0]) * w' * b) (1:sz, :); +%! assert ( (w'*a) (1:sz, :) , observed, norm (observed) * 1e-13); +%! assert (q * a * z, aa, norm (aa) * 1e-14); +%! assert (q * b * z, bb, norm (bb) * 1e-14); + +%!test +%! A = [0, 0, -1, 0; 1, 0, 0, 0; -1, 0, -2, -1; 0, -1, 1, 0]; +%! B = [0, 0, 0, 0; 0, 1, 0, 0; 0, 0, 1, 0; 0, 0, 0, 1]; +%! [AA, BB, Q, Z1] = qz (A, B); +%! [AA, BB, Z2] = qz (A, B, '-'); +%! assert (Z1, Z2); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/rand.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,1221 @@ + +/* + +Copyright (C) 1996-2012 John W. Eaton +Copyright (C) 2009 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <ctime> +#if defined (HAVE_UNORDERED_MAP) +#include <unordered_map> +#elif defined (HAVE_TR1_UNORDERED_MAP) +#include <tr1/unordered_map> +#endif +#include <string> + +#include "f77-fcn.h" +#include "lo-mappers.h" +#include "oct-rand.h" +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "unwind-prot.h" +#include "utils.h" +#include "ov-re-mat.h" + +/* +%!shared __random_statistical_tests__ +%! # Flag whether the statistical tests should be run in "make check" or not +%! __random_statistical_tests__ = 0; +*/ + +static octave_value +do_rand (const octave_value_list& args, int nargin, const char *fcn, + const std::string& distribution, bool additional_arg = false) +{ + octave_value retval; + NDArray a; + int idx = 0; + dim_vector dims; + bool is_single = false; + + unwind_protect frame; + // Restore current distribution on any exit. + frame.add_fcn (octave_rand::distribution, + octave_rand::distribution ()); + + octave_rand::distribution (distribution); + + if (nargin > 0 && args(nargin-1).is_string ()) + { + std::string s_arg = args(nargin-1).string_value (); + + if (s_arg == "single") + { + is_single = true; + nargin--; + } + else if (s_arg == "double") + nargin--; + } + + if (additional_arg) + { + if (nargin == 0) + { + error ("%s: expecting at least one argument", fcn); + goto done; + } + else if (args(0).is_string ()) + additional_arg = false; + else + { + a = args(0).array_value (); + if (error_state) + { + error ("%s: expecting scalar or matrix arguments", fcn); + goto done; + } + idx++; + nargin--; + } + } + + switch (nargin) + { + case 0: + { + if (additional_arg) + dims = a.dims (); + else + { + dims.resize (2); + + dims(0) = 1; + dims(1) = 1; + } + goto gen_matrix; + } + break; + + case 1: + { + octave_value tmp = args(idx); + + if (tmp.is_string ()) + { + std::string s_arg = tmp.string_value (); + + if (s_arg == "dist") + { + retval = octave_rand::distribution (); + } + else if (s_arg == "seed") + { + retval = octave_rand::seed (); + } + else if (s_arg == "state" || s_arg == "twister") + { + retval = octave_rand::state (fcn); + } + else if (s_arg == "uniform") + { + octave_rand::uniform_distribution (); + } + else if (s_arg == "normal") + { + octave_rand::normal_distribution (); + } + else if (s_arg == "exponential") + { + octave_rand::exponential_distribution (); + } + else if (s_arg == "poisson") + { + octave_rand::poisson_distribution (); + } + else if (s_arg == "gamma") + { + octave_rand::gamma_distribution (); + } + else + error ("%s: unrecognized string argument", fcn); + } + else if (tmp.is_scalar_type ()) + { + double dval = tmp.double_value (); + + if (xisnan (dval)) + { + error ("%s: NaN is invalid matrix dimension", fcn); + } + else + { + dims.resize (2); + + dims(0) = NINTbig (tmp.double_value ()); + dims(1) = NINTbig (tmp.double_value ()); + + if (! error_state) + goto gen_matrix; + } + } + else if (tmp.is_range ()) + { + Range r = tmp.range_value (); + + if (r.all_elements_are_ints ()) + { + octave_idx_type n = r.nelem (); + + dims.resize (n); + + octave_idx_type base = NINTbig (r.base ()); + octave_idx_type incr = NINTbig (r.inc ()); + + for (octave_idx_type i = 0; i < n; i++) + { + //Negative dimensions are treated as zero for Matlab + //compatibility + dims(i) = base >= 0 ? base : 0; + base += incr; + } + + goto gen_matrix; + + } + else + error ("%s: all elements of range must be integers", + fcn); + } + else if (tmp.is_matrix_type ()) + { + Array<int> iv = tmp.int_vector_value (true); + + if (! error_state) + { + octave_idx_type len = iv.length (); + + dims.resize (len); + + for (octave_idx_type i = 0; i < len; i++) + { + //Negative dimensions are treated as zero for Matlab + //compatibility + octave_idx_type elt = iv(i); + dims(i) = elt >=0 ? elt : 0; + } + + goto gen_matrix; + } + else + error ("%s: expecting integer vector", fcn); + } + else + { + gripe_wrong_type_arg ("rand", tmp); + return retval; + } + } + break; + + default: + { + octave_value tmp = args(idx); + + if (nargin == 2 && tmp.is_string ()) + { + std::string ts = tmp.string_value (); + + if (ts == "seed") + { + if (args(idx+1).is_real_scalar ()) + { + double d = args(idx+1).double_value (); + + if (! error_state) + octave_rand::seed (d); + } + else if (args(idx+1).is_string () + && args(idx+1).string_value () == "reset") + octave_rand::reset (); + else + error ("%s: seed must be a real scalar", fcn); + } + else if (ts == "state" || ts == "twister") + { + if (args(idx+1).is_string () + && args(idx+1).string_value () == "reset") + octave_rand::reset (fcn); + else + { + ColumnVector s = + ColumnVector (args(idx+1).vector_value(false, true)); + + if (! error_state) + octave_rand::state (s, fcn); + } + } + else + error ("%s: unrecognized string argument", fcn); + } + else + { + dims.resize (nargin); + + for (int i = 0; i < nargin; i++) + { + octave_idx_type elt = args(idx+i).int_value (); + if (error_state) + { + error ("%s: expecting integer arguments", fcn); + goto done; + } + //Negative is zero for Matlab compatibility + dims(i) = elt >= 0 ? elt : 0; + } + + goto gen_matrix; + } + } + break; + } + + done: + + return retval; + + gen_matrix: + + dims.chop_trailing_singletons (); + + if (is_single) + { + if (additional_arg) + { + if (a.length () == 1) + return octave_rand::float_nd_array (dims, a(0)); + else + { + if (a.dims () != dims) + { + error ("%s: mismatch in argument size", fcn); + return retval; + } + octave_idx_type len = a.length (); + FloatNDArray m (dims); + float *v = m.fortran_vec (); + for (octave_idx_type i = 0; i < len; i++) + v[i] = octave_rand::float_scalar (a(i)); + return m; + } + } + else + return octave_rand::float_nd_array (dims); + } + else + { + if (additional_arg) + { + if (a.length () == 1) + return octave_rand::nd_array (dims, a(0)); + else + { + if (a.dims () != dims) + { + error ("%s: mismatch in argument size", fcn); + return retval; + } + octave_idx_type len = a.length (); + NDArray m (dims); + double *v = m.fortran_vec (); + for (octave_idx_type i = 0; i < len; i++) + v[i] = octave_rand::scalar (a(i)); + return m; + } + } + else + return octave_rand::nd_array (dims); + } +} + +DEFUN (rand, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} rand (@var{n})\n\ +@deftypefnx {Built-in Function} {} rand (@var{n}, @var{m}, @dots{})\n\ +@deftypefnx {Built-in Function} {} rand ([@var{n} @var{m} @dots{}])\n\ +@deftypefnx {Built-in Function} {@var{v} =} rand (\"state\")\n\ +@deftypefnx {Built-in Function} {} rand (\"state\", @var{v})\n\ +@deftypefnx {Built-in Function} {} rand (\"state\", \"reset\")\n\ +@deftypefnx {Built-in Function} {@var{v} =} rand (\"seed\")\n\ +@deftypefnx {Built-in Function} {} rand (\"seed\", @var{v})\n\ +@deftypefnx {Built-in Function} {} rand (\"seed\", \"reset\")\n\ +@deftypefnx {Built-in Function} {} rand (@dots{}, \"single\")\n\ +@deftypefnx {Built-in Function} {} rand (@dots{}, \"double\")\n\ +Return a matrix with random elements uniformly distributed on the\n\ +interval (0, 1). The arguments are handled the same as the arguments\n\ +for @code{eye}.\n\ +\n\ +You can query the state of the random number generator using the\n\ +form\n\ +\n\ +@example\n\ +v = rand (\"state\")\n\ +@end example\n\ +\n\ +This returns a column vector @var{v} of length 625. Later, you can\n\ +restore the random number generator to the state @var{v}\n\ +using the form\n\ +\n\ +@example\n\ +rand (\"state\", v)\n\ +@end example\n\ +\n\ +@noindent\n\ +You may also initialize the state vector from an arbitrary vector of\n\ +length @leq{} 625 for @var{v}. This new state will be a hash based on the\n\ +value of @var{v}, not @var{v} itself.\n\ +\n\ +By default, the generator is initialized from @code{/dev/urandom} if it is\n\ +available, otherwise from CPU time, wall clock time, and the current\n\ +fraction of a second. Note that this differs from @sc{matlab}, which\n\ +always initializes the state to the same state at startup. To obtain\n\ +behavior comparable to @sc{matlab}, initialize with a deterministic state\n\ +vector in Octave's startup files (@pxref{Startup Files}).\n\ +\n\ +To compute the pseudo-random sequence, @code{rand} uses the Mersenne\n\ +Twister with a period of @math{2^{19937}-1} (See M. Matsumoto and\n\ +T. Nishimura,\n\ +@cite{Mersenne Twister: A 623-dimensionally equidistributed uniform\n\ +pseudorandom number generator}, ACM Trans. on\n\ +Modeling and Computer Simulation Vol. 8, No. 1, pp. 3-30, January 1998,\n\ +@url{http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html}).\n\ +Do @strong{not} use for cryptography without securely hashing\n\ +several returned values together, otherwise the generator state\n\ +can be learned after reading 624 consecutive values.\n\ +\n\ +Older versions of Octave used a different random number generator.\n\ +The new generator is used by default\n\ +as it is significantly faster than the old generator, and produces\n\ +random numbers with a significantly longer cycle time. However, in\n\ +some circumstances it might be desirable to obtain the same random\n\ +sequences as used by the old generators. To do this the keyword\n\ +\"seed\" is used to specify that the old generators should be use,\n\ +as in\n\ +\n\ +@example\n\ +rand (\"seed\", val)\n\ +@end example\n\ +\n\ +@noindent\n\ +which sets the seed of the generator to @var{val}. The seed of the\n\ +generator can be queried with\n\ +\n\ +@example\n\ +s = rand (\"seed\")\n\ +@end example\n\ +\n\ +However, it should be noted that querying the seed will not cause\n\ +@code{rand} to use the old generators, only setting the seed will.\n\ +To cause @code{rand} to once again use the new generators, the\n\ +keyword \"state\" should be used to reset the state of the @code{rand}.\n\ +\n\ +The state or seed of the generator can be reset to a new random value\n\ +using the \"reset\" keyword.\n\ +\n\ +The class of the value returned can be controlled by a trailing \"double\"\n\ +or \"single\" argument. These are the only valid classes.\n\ +@seealso{randn, rande, randg, randp}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + retval = do_rand (args, nargin, "rand", "uniform"); + + return retval; +} + +// FIXME -- The old generator (selected when "seed" is set) will not +// work properly if compiled to use 64-bit integers. + +/* +%!test # "state" can be a scalar +%! rand ("state", 12); x = rand (1,4); +%! rand ("state", 12); y = rand (1,4); +%! assert (x, y); +%!test # "state" can be a vector +%! rand ("state", [12,13]); x = rand (1,4); +%! rand ("state", [12;13]); y = rand (1,4); +%! assert (x, y); +%!test # querying "state" doesn't disturb sequence +%! rand ("state", 12); rand (1,2); x = rand (1,2); +%! rand ("state", 12); rand (1,2); +%! s = rand ("state"); y = rand (1,2); +%! assert (x, y); +%! rand ("state", s); z = rand (1,2); +%! assert (x, z); +%!test # "seed" must be a scalar +%! rand ("seed", 12); x = rand (1,4); +%! rand ("seed", 12); y = rand (1,4); +%! assert (x, y); +%!error <seed must be a real scalar> rand ("seed", [12,13]) +%!test # querying "seed" returns a value which can be used later +%! s = rand ("seed"); x = rand (1,2); +%! rand ("seed", s); y = rand (1,2); +%! assert (x, y); +%!test # querying "seed" doesn't disturb sequence +%! rand ("seed", 12); rand (1,2); x = rand (1,2); +%! rand ("seed", 12); rand (1,2); +%! s = rand ("seed"); y = rand (1,2); +%! assert (x, y); +%! rand ("seed", s); z = rand (1,2); +%! assert (x, z); +*/ + +/* +%!test +%! # Test fixed state +%! rand ("state", 1); +%! assert (rand (1,6), [0.1343642441124013 0.8474337369372327 0.763774618976614 0.2550690257394218 0.495435087091941 0.4494910647887382], 1e-6); +%!test +%! # Test fixed seed +%! rand ("seed", 1); +%! assert (rand (1,6), [0.8668024251237512 0.9126510815694928 0.09366085007786751 0.1664607301354408 0.7408077004365623 0.7615650338120759], 1e-6); +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! rand ("state", 12); +%! x = rand (100000, 1); +%! assert (max (x) < 1); #*** Please report this!!! *** +%! assert (min (x) > 0); #*** Please report this!!! *** +%! assert (mean (x), 0.5, 0.0024); +%! assert (var (x), 1/48, 0.0632); +%! assert (skewness (x), 0, 0.012); +%! assert (kurtosis (x), -6/5, 0.0094); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! rand ("seed", 12); +%! x = rand (100000, 1); +%! assert (max (x) < 1); #*** Please report this!!! *** +%! assert (min (x) > 0); #*** Please report this!!! *** +%! assert (mean (x), 0.5, 0.0024); +%! assert (var (x), 1/48, 0.0632); +%! assert (skewness (x), 0, 0.012); +%! assert (kurtosis (x), -6/5, 0.0094); +%! endif +*/ + +static std::string current_distribution = octave_rand::distribution (); + +DEFUN (randn, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} randn (@var{n})\n\ +@deftypefnx {Built-in Function} {} randn (@var{n}, @var{m}, @dots{})\n\ +@deftypefnx {Built-in Function} {} randn ([@var{n} @var{m} @dots{}])\n\ +@deftypefnx {Built-in Function} {@var{v} =} randn (\"state\")\n\ +@deftypefnx {Built-in Function} {} randn (\"state\", @var{v})\n\ +@deftypefnx {Built-in Function} {} randn (\"state\", \"reset\")\n\ +@deftypefnx {Built-in Function} {@var{v} =} randn (\"seed\")\n\ +@deftypefnx {Built-in Function} {} randn (\"seed\", @var{v})\n\ +@deftypefnx {Built-in Function} {} randn (\"seed\", \"reset\")\n\ +@deftypefnx {Built-in Function} {} randn (@dots{}, \"single\")\n\ +@deftypefnx {Built-in Function} {} randn (@dots{}, \"double\")\n\ +Return a matrix with normally distributed random\n\ +elements having zero mean and variance one. The arguments are\n\ +handled the same as the arguments for @code{rand}.\n\ +\n\ +By default, @code{randn} uses the Marsaglia and Tsang ``Ziggurat technique''\n\ +to transform from a uniform to a normal distribution.\n\ +\n\ +The class of the value returned can be controlled by a trailing \"double\"\n\ +or \"single\" argument. These are the only valid classes.\n\ +\n\ +Reference: G. Marsaglia and W.W. Tsang,\n\ +@cite{Ziggurat Method for Generating Random Variables},\n\ +J. Statistical Software, vol 5, 2000,\n\ +@url{http://www.jstatsoft.org/v05/i08/})\n\ +\n\ +@seealso{rand, rande, randg, randp}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + retval = do_rand (args, nargin, "randn", "normal"); + + return retval; +} + +/* +%!test +%! # Test fixed state +%! randn ("state", 1); +%! assert (randn (1, 6), [-2.666521678978671 -0.7381719971724564 1.507903992673601 0.6019427189162239 -0.450661261143348 -0.7054431351574116], 1e-6); +%!test +%! # Test fixed seed +%! randn ("seed", 1); +%! assert (randn (1, 6), [-1.039402365684509 -1.25938892364502 0.1968704611063004 0.3874166905879974 -0.5976632833480835 -0.6615074276924133], 1e-6); +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randn ("state", 12); +%! x = randn (100000, 1); +%! assert (mean (x), 0, 0.01); +%! assert (var (x), 1, 0.02); +%! assert (skewness (x), 0, 0.02); +%! assert (kurtosis (x), 0, 0.04); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randn ("seed", 12); +%! x = randn (100000, 1); +%! assert (mean (x), 0, 0.01); +%! assert (var (x), 1, 0.02); +%! assert (skewness (x), 0, 0.02); +%! assert (kurtosis (x), 0, 0.04); +%! endif +*/ + +DEFUN (rande, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} rande (@var{n})\n\ +@deftypefnx {Built-in Function} {} rande (@var{n}, @var{m}, @dots{})\n\ +@deftypefnx {Built-in Function} {} rande ([@var{n} @var{m} @dots{}])\n\ +@deftypefnx {Built-in Function} {@var{v} =} rande (\"state\")\n\ +@deftypefnx {Built-in Function} {} rande (\"state\", @var{v})\n\ +@deftypefnx {Built-in Function} {} rande (\"state\", \"reset\")\n\ +@deftypefnx {Built-in Function} {@var{v} =} rande (\"seed\")\n\ +@deftypefnx {Built-in Function} {} rande (\"seed\", @var{v})\n\ +@deftypefnx {Built-in Function} {} rande (\"seed\", \"reset\")\n\ +@deftypefnx {Built-in Function} {} rande (@dots{}, \"single\")\n\ +@deftypefnx {Built-in Function} {} rande (@dots{}, \"double\")\n\ +Return a matrix with exponentially distributed random elements. The\n\ +arguments are handled the same as the arguments for @code{rand}.\n\ +\n\ +By default, @code{randn} uses the Marsaglia and Tsang ``Ziggurat technique''\n\ +to transform from a uniform to an exponential distribution.\n\ +\n\ +The class of the value returned can be controlled by a trailing \"double\"\n\ +or \"single\" argument. These are the only valid classes.\n\ +\n\ +Reference: G. Marsaglia and W.W. Tsang,\n\ +@cite{Ziggurat Method for Generating Random Variables},\n\ +J. Statistical Software, vol 5, 2000,\n\ +@url{http://www.jstatsoft.org/v05/i08/})\n\ +\n\ +@seealso{rand, randn, randg, randp}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + retval = do_rand (args, nargin, "rande", "exponential"); + + return retval; +} + +/* +%!test +%! # Test fixed state +%! rande ("state", 1); +%! assert (rande (1, 6), [3.602973885835625 0.1386190677555021 0.6743112889616958 0.4512830847258422 0.7255744741233175 0.3415969205292291], 1e-6); +%!test +%! # Test fixed seed +%! rande ("seed", 1); +%! assert (rande (1, 6), [0.06492075175653866 1.717980206012726 0.4816154008731246 0.5231300676241517 0.103910739364359 1.668931916356087], 1e-6); +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally +%! rande ("state", 1); +%! x = rande (100000, 1); +%! assert (min (x) > 0); # *** Please report this!!! *** +%! assert (mean (x), 1, 0.01); +%! assert (var (x), 1, 0.03); +%! assert (skewness (x), 2, 0.06); +%! assert (kurtosis (x), 6, 0.7); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally +%! rande ("seed", 1); +%! x = rande (100000, 1); +%! assert (min (x)>0); # *** Please report this!!! *** +%! assert (mean (x), 1, 0.01); +%! assert (var (x), 1, 0.03); +%! assert (skewness (x), 2, 0.06); +%! assert (kurtosis (x), 6, 0.7); +%! endif +*/ + +DEFUN (randg, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} randg (@var{n})\n\ +@deftypefnx {Built-in Function} {} randg (@var{n}, @var{m}, @dots{})\n\ +@deftypefnx {Built-in Function} {} randg ([@var{n} @var{m} @dots{}])\n\ +@deftypefnx {Built-in Function} {@var{v} =} randg (\"state\")\n\ +@deftypefnx {Built-in Function} {} randg (\"state\", @var{v})\n\ +@deftypefnx {Built-in Function} {} randg (\"state\", \"reset\")\n\ +@deftypefnx {Built-in Function} {@var{v} =} randg (\"seed\")\n\ +@deftypefnx {Built-in Function} {} randg (\"seed\", @var{v})\n\ +@deftypefnx {Built-in Function} {} randg (\"seed\", \"reset\")\n\ +@deftypefnx {Built-in Function} {} randg (@dots{}, \"single\")\n\ +@deftypefnx {Built-in Function} {} randg (@dots{}, \"double\")\n\ +Return a matrix with @code{gamma (@var{a},1)} distributed random elements.\n\ +The arguments are handled the same as the arguments for @code{rand},\n\ +except for the argument @var{a}.\n\ +\n\ +This can be used to generate many distributions:\n\ +\n\ +@table @asis\n\ +@item @code{gamma (a, b)} for @code{a > -1}, @code{b > 0}\n\ +\n\ +@example\n\ +r = b * randg (a)\n\ +@end example\n\ +\n\ +@item @code{beta (a, b)} for @code{a > -1}, @code{b > -1}\n\ +\n\ +@example\n\ +@group\n\ +r1 = randg (a, 1)\n\ +r = r1 / (r1 + randg (b, 1))\n\ +@end group\n\ +@end example\n\ +\n\ +@item @code{Erlang (a, n)}\n\ +\n\ +@example\n\ +r = a * randg (n)\n\ +@end example\n\ +\n\ +@item @code{chisq (df)} for @code{df > 0}\n\ +\n\ +@example\n\ +r = 2 * randg (df / 2)\n\ +@end example\n\ +\n\ +@item @code{t (df)} for @code{0 < df < inf} (use randn if df is infinite)\n\ +\n\ +@example\n\ +r = randn () / sqrt (2 * randg (df / 2) / df)\n\ +@end example\n\ +\n\ +@item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2}\n\ +\n\ +@example\n\ +@group\n\ +## r1 equals 1 if n1 is infinite\n\ +r1 = 2 * randg (n1 / 2) / n1\n\ +## r2 equals 1 if n2 is infinite\n\ +r2 = 2 * randg (n2 / 2) / n2\n\ +r = r1 / r2\n\n\ +@end group\n\ +@end example\n\ +\n\ +@item negative @code{binomial (n, p)} for @code{n > 0}, @code{0 < p <= 1}\n\ +\n\ +@example\n\ +r = randp ((1 - p) / p * randg (n))\n\ +@end example\n\ +\n\ +@item non-central @code{chisq (df, L)}, for @code{df >= 0} and @code{L > 0}\n\ +(use chisq if @code{L = 0})\n\ +\n\ +@example\n\ +@group\n\ +r = randp (L / 2)\n\ +r(r > 0) = 2 * randg (r(r > 0))\n\ +r(df > 0) += 2 * randg (df(df > 0)/2)\n\ +@end group\n\ +@end example\n\ +\n\ +@item @code{Dirichlet (a1, @dots{} ak)}\n\ +\n\ +@example\n\ +@group\n\ +r = (randg (a1), @dots{}, randg (ak))\n\ +r = r / sum (r)\n\ +@end group\n\ +@end example\n\ +\n\ +@end table\n\ +\n\ +The class of the value returned can be controlled by a trailing \"double\"\n\ +or \"single\" argument. These are the only valid classes.\n\ +@seealso{rand, randn, rande, randp}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 1) + error ("randg: insufficient arguments"); + else + retval = do_rand (args, nargin, "randg", "gamma", true); + + return retval; +} + +/* +%!test +%! randg ("state", 12) +%! assert (randg ([-inf, -1, 0, inf, nan]), [nan, nan, nan, nan, nan]); # *** Please report + +%!test +%! # Test fixed state +%! randg ("state", 1); +%! assert (randg (0.1, 1, 6), [0.0103951513331241 8.335671459898252e-05 0.00138691397249762 0.000587308416993855 0.495590518784736 2.3921917414795e-12], 1e-6); +%!test +%! # Test fixed state +%! randg ("state", 1); +%! assert (randg (0.95, 1, 6), [3.099382433255327 0.3974529788871218 0.644367450750855 1.143261091802246 1.964111762696822 0.04011915547957939], 1e-6); +%!test +%! # Test fixed state +%! randg ("state", 1); +%! assert (randg (1, 1, 6), [0.2273389379645993 1.288822625058359 0.2406335209340746 1.218869553370733 1.024649860162554 0.09631230343599533], 1e-6); +%!test +%! # Test fixed state +%! randg ("state", 1); +%! assert (randg (10, 1, 6), [3.520369644331133 15.15369864472106 8.332112081991205 8.406211067432674 11.81193475187611 10.88792728177059], 1e-5); +%!test +%! # Test fixed state +%! randg ("state", 1); +%! assert (randg (100, 1, 6), [75.34570255262264 115.4911985594699 95.23493031356388 95.48926019250911 106.2397448229803 103.4813150404118], 1e-4); +%!test +%! # Test fixed seed +%! randg ("seed", 1); +%! assert (randg (0.1, 1, 6), [0.07144210487604141 0.460641473531723 0.4749028384685516 0.06823389977216721 0.000293838675133884 1.802567535340305e-12], 1e-6); +%!test +%! # Test fixed seed +%! randg ("seed", 1); +%! assert (randg (0.95, 1, 6), [1.664905071258545 1.879976987838745 1.905677795410156 0.9948706030845642 0.5606933236122131 0.0766092911362648], 1e-6); +%!test +%! # Test fixed seed +%! randg ("seed", 1); +%! assert (randg (1, 1, 6), [0.03512085229158401 0.6488978862762451 0.8114678859710693 0.1666885763406754 1.60791552066803 1.90356981754303], 1e-6); +%!test +%! # Test fixed seed +%! randg ("seed", 1); +%! assert (randg (10, 1, 6), [6.566435813903809 10.11648464202881 10.73162078857422 7.747178077697754 6.278522491455078 6.240195751190186], 1e-5); +%!test +%! # Test fixed seed +%! randg ("seed", 1); +%! assert (randg (100, 1, 6), [89.40208435058594 101.4734725952148 103.4020004272461 93.62763214111328 88.33104705810547 88.1871337890625], 1e-4); + +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("state", 12); +%! a = 0.1; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.01); +%! assert (var (x), a, 0.01); +%! assert (skewness (x), 2/sqrt (a), 1); +%! assert (kurtosis (x), 6/a, 50); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("state", 12); +%! a = 0.95; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.01); +%! assert (var (x), a, 0.04); +%! assert (skewness (x), 2/sqrt (a), 0.2); +%! assert (kurtosis (x), 6/a, 2); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("state", 12); +%! a = 1; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.01); +%! assert (var (x), a, 0.04); +%! assert (skewness (x), 2/sqrt (a), 0.2); +%! assert (kurtosis (x), 6/a, 2); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("state", 12); +%! a = 10; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.1); +%! assert (var (x), a, 0.5); +%! assert (skewness (x), 2/sqrt (a), 0.1); +%! assert (kurtosis (x), 6/a, 0.5); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("state", 12); +%! a = 100; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.2); +%! assert (var (x), a, 2); +%! assert (skewness (x), 2/sqrt (a), 0.05); +%! assert (kurtosis (x), 6/a, 0.2); +%! endif +%!test +%! randg ("seed", 12); +%!assert (randg ([-inf, -1, 0, inf, nan]), [nan, nan, nan, nan, nan]) # *** Please report +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("seed", 12); +%! a = 0.1; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.01); +%! assert (var (x), a, 0.01); +%! assert (skewness (x), 2/sqrt (a), 1); +%! assert (kurtosis (x), 6/a, 50); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("seed", 12); +%! a = 0.95; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.01); +%! assert (var (x), a, 0.04); +%! assert (skewness (x), 2/sqrt (a), 0.2); +%! assert (kurtosis (x), 6/a, 2); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("seed", 12); +%! a = 1; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.01); +%! assert (var (x), a, 0.04); +%! assert (skewness (x), 2/sqrt (a), 0.2); +%! assert (kurtosis (x), 6/a, 2); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("seed", 12); +%! a = 10; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.1); +%! assert (var (x), a, 0.5); +%! assert (skewness (x), 2/sqrt (a), 0.1); +%! assert (kurtosis (x), 6/a, 0.5); +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randg ("seed", 12); +%! a = 100; +%! x = randg (a, 100000, 1); +%! assert (mean (x), a, 0.2); +%! assert (var (x), a, 2); +%! assert (skewness (x), 2/sqrt (a), 0.05); +%! assert (kurtosis (x), 6/a, 0.2); +%! endif +*/ + +DEFUN (randp, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} randp (@var{l}, @var{n})\n\ +@deftypefnx {Built-in Function} {} randp (@var{l}, @var{n}, @var{m}, @dots{})\n\ +@deftypefnx {Built-in Function} {} randp (@var{l}, [@var{n} @var{m} @dots{}])\n\ +@deftypefnx {Built-in Function} {@var{v} =} randp (\"state\")\n\ +@deftypefnx {Built-in Function} {} randp (\"state\", @var{v})\n\ +@deftypefnx {Built-in Function} {} randp (\"state\", \"reset\")\n\ +@deftypefnx {Built-in Function} {@var{v} =} randp (\"seed\")\n\ +@deftypefnx {Built-in Function} {} randp (\"seed\", @var{v})\n\ +@deftypefnx {Built-in Function} {} randp (\"seed\", \"reset\")\n\ +@deftypefnx {Built-in Function} {} randp (@dots{}, \"single\")\n\ +@deftypefnx {Built-in Function} {} randp (@dots{}, \"double\")\n\ +Return a matrix with Poisson distributed random elements with mean value\n\ +parameter given by the first argument, @var{l}. The arguments\n\ +are handled the same as the arguments for @code{rand}, except for the\n\ +argument @var{l}.\n\ +\n\ +Five different algorithms are used depending on the range of @var{l}\n\ +and whether or not @var{l} is a scalar or a matrix.\n\ +\n\ +@table @asis\n\ +@item For scalar @var{l} @leq{} 12, use direct method.\n\ +W.H. Press, et al., @cite{Numerical Recipes in C},\n\ +Cambridge University Press, 1992.\n\ +\n\ +@item For scalar @var{l} > 12, use rejection method.[1]\n\ +W.H. Press, et al., @cite{Numerical Recipes in C},\n\ +Cambridge University Press, 1992.\n\ +\n\ +@item For matrix @var{l} @leq{} 10, use inversion method.[2]\n\ +E. Stadlober, et al., WinRand source code, available via FTP.\n\ +\n\ +@item For matrix @var{l} > 10, use patchwork rejection method.\n\ +E. Stadlober, et al., WinRand source code, available via FTP, or\n\ +H. Zechner, @cite{Efficient sampling from continuous and discrete\n\ +unimodal distributions}, Doctoral Dissertation, 156pp., Technical\n\ +University Graz, Austria, 1994.\n\ +\n\ +@item For @var{l} > 1e8, use normal approximation.\n\ +L. Montanet, et al., @cite{Review of Particle Properties}, Physical Review\n\ +D 50 p1284, 1994.\n\ +@end table\n\ +\n\ +The class of the value returned can be controlled by a trailing \"double\"\n\ +or \"single\" argument. These are the only valid classes.\n\ +@seealso{rand, randn, rande, randg}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin < 1) + error ("randp: insufficient arguments"); + else + retval = do_rand (args, nargin, "randp", "poisson", true); + + return retval; +} + +/* +%!test +%! randp ("state", 12); +%! assert (randp ([-inf, -1, 0, inf, nan]), [nan, nan, 0, nan, nan]); # *** Please report +%!test +%! # Test fixed state +%! randp ("state", 1); +%! assert (randp (5, 1, 6), [5 5 3 7 7 3]) +%!test +%! # Test fixed state +%! randp ("state", 1); +%! assert (randp (15, 1, 6), [13 15 8 18 18 15]) +%!test +%! # Test fixed state +%! randp ("state", 1); +%! assert (randp (1e9, 1, 6), [999915677 999976657 1000047684 1000019035 999985749 999977692], -1e-6) +%!test +%! # Test fixed state +%! randp ("seed", 1); +%! %%assert (randp (5, 1, 6), [8 2 3 6 6 8]) +%! assert (randp (5, 1, 5), [8 2 3 6 6]) +%!test +%! # Test fixed state +%! randp ("seed", 1); +%! assert (randp (15, 1, 6), [15 16 12 10 10 12]) +%!test +%! # Test fixed state +%! randp ("seed", 1); +%! assert (randp (1e9, 1, 6), [1000006208 1000012224 999981120 999963520 999963072 999981440], -1e-6) +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randp ("state", 12); +%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] +%! x = randp (a (1), 100000, 1); +%! assert (min (x) >= 0); # *** Please report this!!! *** +%! assert (mean (x), a(1), a(2)); +%! assert (var (x), a(1), 0.02*a(1)); +%! assert (skewness (x), 1/sqrt (a(1)), a(3)); +%! assert (kurtosis (x), 1/a(1), 3*a(3)); +%! endfor +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randp ("state", 12); +%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] +%! x = randp (a(1)*ones (100000, 1), 100000, 1); +%! assert (min (x) >= 0); # *** Please report this!!! *** +%! assert (mean (x), a(1), a(2)); +%! assert (var (x), a(1), 0.02*a(1)); +%! assert (skewness (x), 1/sqrt (a(1)), a(3)); +%! assert (kurtosis (x), 1/a(1), 3*a(3)); +%! endfor +%! endif +%!test +%! randp ("seed", 12); +%! assert (randp ([-inf, -1, 0, inf, nan]), [nan, nan, 0, nan, nan]); # *** Please report +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randp ("seed", 12); +%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] +%! x = randp (a(1), 100000, 1); +%! assert (min (x) >= 0); # *** Please report this!!! *** +%! assert (mean (x), a(1), a(2)); +%! assert (var (x), a(1), 0.02*a(1)); +%! assert (skewness (x), 1/sqrt (a(1)), a(3)); +%! assert (kurtosis (x), 1/a(1), 3*a(3)); +%! endfor +%! endif +%!test +%! if (__random_statistical_tests__) +%! # statistical tests may fail occasionally. +%! randp ("seed", 12); +%! for a = [5, 15, 1e9; 0.03, 0.03, -5e-3; 0.03, 0.03, 0.03] +%! x = randp (a(1)*ones (100000, 1), 100000, 1); +%! assert (min (x) >= 0); # *** Please report this!!! *** +%! assert (mean (x), a(1), a(2)); +%! assert (var (x), a(1), 0.02*a(1)); +%! assert (skewness (x), 1/sqrt (a(1)), a(3)); +%! assert (kurtosis (x), 1/a(1), 3*a(3)); +%! endfor +%! endif +*/ + +DEFUN (randperm, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} randperm (@var{n})\n\ +@deftypefnx {Built-in Function} {} randperm (@var{n}, @var{m})\n\ +Return a row vector containing a random permutation of @code{1:@var{n}}.\n\ +If @var{m} is supplied, return @var{m} unique entries, sampled without\n\ +replacement from @code{1:@var{n}}. The complexity is O(@var{n}) in\n\ +memory and O(@var{m}) in time, unless @var{m} < @var{n}/5, in which case\n\ +O(@var{m}) memory is used as well. The randomization is performed using\n\ +rand(). All permutations are equally likely.\n\ +@seealso{perms}\n\ +@end deftypefn") +{ + +#ifdef USE_UNORDERED_MAP_WITH_TR1 +using std::tr1::unordered_map; +#else +using std::unordered_map; +#endif + + int nargin = args.length (); + octave_value retval; + + if (nargin == 1 || nargin == 2) + { + octave_idx_type n, m; + + n = args(0).idx_type_value (true); + + if (nargin == 2) + m = args(1).idx_type_value (true); + else + m = n; + + if (m < 0 || n < 0) + error ("randperm: M and N must be non-negative"); + + if (m > n) + error ("randperm: M must be less than or equal to N"); + + // Quick and dirty heuristic to decide if we allocate or not the + // whole vector for tracking the truncated shuffle. + bool short_shuffle = m < n/5 && m < 1e5; + + if (! error_state) + { + // Generate random numbers. + NDArray r = octave_rand::nd_array (dim_vector (1, m)); + double *rvec = r.fortran_vec (); + + octave_idx_type idx_len = short_shuffle ? m : n; + Array<octave_idx_type> idx (dim_vector (1, idx_len)); + octave_idx_type *ivec = idx.fortran_vec (); + + for (octave_idx_type i = 0; i < idx_len; i++) + ivec[i] = i; + + if (short_shuffle) + { + unordered_map<octave_idx_type, octave_idx_type> map (m); + + // Perform the Knuth shuffle only keeping track of moved + // entries in the map + for (octave_idx_type i = 0; i < m; i++) + { + octave_idx_type k = i + + gnulib::floor (rvec[i] * (n - i)); + + //For shuffling first m entries, no need to use extra + //storage + if (k < m) + { + std::swap (ivec[i], ivec[k]); + } + else + { + if (map.find (k) == map.end ()) + map[k] = k; + + std::swap (ivec[i], map[k]); + } + } + } + else + { + + // Perform the Knuth shuffle of the first m entries + for (octave_idx_type i = 0; i < m; i++) + { + octave_idx_type k = i + + gnulib::floor (rvec[i] * (n - i)); + std::swap (ivec[i], ivec[k]); + } + } + + // Convert to doubles, reusing r. + for (octave_idx_type i = 0; i < m; i++) + rvec[i] = ivec[i] + 1; + + if (m < n) + idx.resize (dim_vector (1, m)); + + // Now create an array object with a cached idx_vector. + retval = new octave_matrix (r, idx_vector (idx)); + } + } + else + print_usage (); + + return retval; +} + +/* +%!assert (sort (randperm (20)), 1:20) +%!assert (length (randperm (20,10)), 10) + +%!test +%! rand ("seed", 0); +%! for i = 1:100 +%! p = randperm (305, 30); +%! assert (length (unique (p)), 30); +%! endfor +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/rcond.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,94 @@ +/* + +Copyright (C) 2008-2012 David Bateman + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (rcond, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{c} =} rcond (@var{A})\n\ +Compute the 1-norm estimate of the reciprocal condition number as returned\n\ +by @sc{lapack}. If the matrix is well-conditioned then @var{c} will be near\n\ +1 and if the matrix is poorly conditioned it will be close to zero.\n\ +\n\ +The matrix @var{A} must not be sparse. If the matrix is sparse then\n\ +@code{condest (@var{A})} or @code{rcond (full (@var{A}))} should be used\n\ +instead.\n\ +@seealso{cond, condest}\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin != 1) + print_usage (); + else if (args(0).is_sparse_type ()) + error ("rcond: for sparse matrices use 'rcond (full (a))' or 'condest (a)' instead"); + else if (args(0).is_single_type ()) + { + if (args(0).is_complex_type ()) + { + FloatComplexMatrix m = args(0).float_complex_matrix_value (); + MatrixType mattyp; + retval = m.rcond (mattyp); + args(0).matrix_type (mattyp); + } + else + { + FloatMatrix m = args(0).float_matrix_value (); + MatrixType mattyp; + retval = m.rcond (mattyp); + args(0).matrix_type (mattyp); + } + } + else if (args(0).is_complex_type ()) + { + ComplexMatrix m = args(0).complex_matrix_value (); + MatrixType mattyp; + retval = m.rcond (mattyp); + args(0).matrix_type (mattyp); + } + else + { + Matrix m = args(0).matrix_value (); + MatrixType mattyp; + retval = m.rcond (mattyp); + args(0).matrix_type (mattyp); + } + + return retval; +} + +/* +%!assert (rcond (eye (2)), 1) +%!assert (rcond (ones (2)), 0) +%!assert (rcond ([1 1; 2 1]), 1/9) +%!assert (rcond (magic (4)), 0, eps) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/regexp.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,1408 @@ +/* + +Copyright (C) 2005-2012 David Bateman +Copyright (C) 2002-2005 Paul Kienzle + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <list> +#include <sstream> + +#include <pcre.h> + +#include "base-list.h" +#include "oct-locbuf.h" +#include "quit.h" +#include "regexp.h" +#include "str-vec.h" + +#include "defun.h" +#include "Cell.h" +#include "error.h" +#include "gripes.h" +#include "oct-map.h" +#include "oct-obj.h" +#include "utils.h" + +// Replace backslash escapes in a string with the real values. We need +// this special function instead of the one in utils.cc because the set +// of escape sequences used in regexps is different from those used in +// the *printf functions. + +static std::string +do_regexp_string_escapes (const std::string& s) +{ + std::string retval; + + size_t i = 0; + size_t j = 0; + size_t len = s.length (); + + retval.resize (len); + + while (j < len) + { + if (s[j] == '\\' && j+1 < len) + { + switch (s[++j]) + { + case '$': + retval[i] = '$'; + break; + + case 'a': + retval[i] = '\a'; + break; + + case 'b': // backspace + retval[i] = '\b'; + break; + + case 'f': // formfeed + retval[i] = '\f'; + break; + + case 'n': // newline + retval[i] = '\n'; + break; + + case 'r': // carriage return + retval[i] = '\r'; + break; + + case 't': // horizontal tab + retval[i] = '\t'; + break; + + case 'v': // vertical tab + retval[i] = '\v'; + break; + + case '\\': // backslash + retval[i] = '\\'; + break; + +#if 0 +// FIXME -- to be complete, we need to handle \oN, \o{N}, \xN, and +// \x{N}. Hex digits may be upper or lower case. Brackets are +// optional, so \x5Bz is the same as \x{5B}z. + + case 'o': // octal number + case 'x': // hex number +#endif + + default: + retval[i] = '\\'; + retval[++i] = s[j]; + break; + } + } + else + { + retval[i] = s[j]; + } + + i++; + j++; + } + + retval.resize (i); + + return retval; +} + +static void +parse_options (regexp::opts& options, const octave_value_list& args, + const std::string& who, int skip, bool& extra_args) +{ + int nargin = args.length (); + + extra_args = false; + + for (int i = skip; i < nargin; i++) + { + std::string str = args(i).string_value (); + + if (error_state) + { + error ("%s: optional arguments must be character strings", + who.c_str ()); + break; + } + + std::transform (str.begin (), str.end (), str.begin (), tolower); + + if (str.find ("once", 0) == 0) + options.once (true); + else if (str.find ("matchcase", 0) == 0) + options.case_insensitive (false); + else if (str.find ("ignorecase", 0) == 0) + options.case_insensitive (true); + else if (str.find ("dotall", 0) == 0) + options.dotexceptnewline (false); + else if (str.find ("stringanchors", 0) == 0) + options.lineanchors (false); + else if (str.find ("literalspacing", 0) == 0) + options.freespacing (false); + else if (str.find ("noemptymatch", 0) == 0) + options.emptymatch (false); + else if (str.find ("dotexceptnewline", 0) == 0) + options.dotexceptnewline (true); + else if (str.find ("lineanchors", 0) == 0) + options.lineanchors (true); + else if (str.find ("freespacing", 0) == 0) + options.freespacing (true); + else if (str.find ("emptymatch", 0) == 0) + options.emptymatch (true); + else if (str.find ("start", 0) == 0 + || str.find ("end", 0) == 0 + || str.find ("tokenextents", 0) == 0 + || str.find ("match", 0) == 0 + || str.find ("tokens", 0) == 0 + || str.find ("names", 0) == 0 + || str.find ("split", 0) == 0) + extra_args = true; + else + error ("%s: unrecognized option", who.c_str ()); + } +} + +static octave_value_list +octregexp (const octave_value_list &args, int nargout, + const std::string &who, bool case_insensitive = false) +{ + octave_value_list retval; + + int nargin = args.length (); + + // Make sure we have string, pattern + const std::string buffer = args(0).string_value (); + if (error_state) + return retval; + + std::string pattern = args(1).string_value (); + if (error_state) + return retval; + // Matlab compatibility. + if (args(1).is_sq_string ()) + pattern = do_regexp_string_escapes (pattern); + + regexp::opts options; + options.case_insensitive (case_insensitive); + bool extra_options = false; + parse_options (options, args, who, 2, extra_options); + if (error_state) + return retval; + + regexp::match_data rx_lst = regexp_match (pattern, buffer, options, who); + + string_vector named_pats = rx_lst.named_patterns (); + + size_t sz = rx_lst.size (); + + if (! error_state) + { + // Converted the linked list in the correct form for the return values + + octave_idx_type i = 0; + octave_scalar_map nmap; + + retval.resize (7); + + if (sz == 1) + { + string_vector named_tokens = rx_lst.begin ()->named_tokens (); + + for (int j = 0; j < named_pats.length (); j++) + nmap.assign (named_pats(j), named_tokens(j)); + + retval(5) = nmap; + } + else + { + for (int j = 0; j < named_pats.length (); j++) + { + Cell tmp (dim_vector (1, sz)); + + i = 0; + for (regexp::match_data::const_iterator p = rx_lst.begin (); + p != rx_lst.end (); p++) + { + string_vector named_tokens = p->named_tokens (); + + tmp(i++) = named_tokens(j); + } + + nmap.assign (named_pats(j), octave_value (tmp)); + } + + retval(5) = nmap; + } + + if (options.once ()) + { + regexp::match_data::const_iterator p = rx_lst.begin (); + + retval(4) = sz ? p->tokens () : Cell (); + retval(3) = sz ? p->match_string () : std::string (); + retval(2) = sz ? p->token_extents () : Matrix (); + + if (sz) + { + double start = p->start (); + double end = p->end (); + + Cell split (dim_vector (1, 2)); + split(0) = buffer.substr (0, start-1); + split(1) = buffer.substr (end); + + retval(6) = split; + retval(1) = end; + retval(0) = start; + } + else + { + retval(6) = buffer; + retval(1) = Matrix (); + retval(0) = Matrix (); + } + } + else + { + Cell tokens (dim_vector (1, sz)); + Cell match_string (dim_vector (1, sz)); + Cell token_extents (dim_vector (1, sz)); + NDArray end (dim_vector (1, sz)); + NDArray start (dim_vector (1, sz)); + Cell split (dim_vector (1, sz+1)); + size_t sp_start = 0; + + i = 0; + for (regexp::match_data::const_iterator p = rx_lst.begin (); + p != rx_lst.end (); p++) + { + double s = p->start (); + double e = p->end (); + + string_vector tmp = p->tokens (); + tokens(i) = Cell (dim_vector (1, tmp.length ()), tmp); + match_string(i) = p->match_string (); + token_extents(i) = p->token_extents (); + end(i) = e; + start(i) = s; + split(i) = buffer.substr (sp_start, s-sp_start-1); + sp_start = e; + i++; + } + + split(i) = buffer.substr (sp_start); + + retval(6) = split; + retval(4) = tokens; + retval(3) = match_string; + retval(2) = token_extents; + retval(1) = end; + retval(0) = start; + } + + // Alter the order of the output arguments + + if (extra_options) + { + int n = 0; + octave_value_list new_retval; + new_retval.resize (nargout); + + OCTAVE_LOCAL_BUFFER (int, arg_used, 6); + for (int j = 0; j < 6; j++) + arg_used[j] = false; + + for (int j = 2; j < nargin; j++) + { + int k = 0; + std::string str = args(j).string_value (); + std::transform (str.begin (), str.end (), str.begin (), tolower); + + if (str.find ("once", 0) == 0 + || str.find ("stringanchors", 0) == 0 + || str.find ("lineanchors", 0) == 0 + || str.find ("matchcase", 0) == 0 + || str.find ("ignorecase", 0) == 0 + || str.find ("dotall", 0) == 0 + || str.find ("dotexceptnewline", 0) == 0 + || str.find ("literalspacing", 0) == 0 + || str.find ("freespacing", 0) == 0 + || str.find ("noemptymatch", 0) == 0 + || str.find ("emptymatch", 0) == 0) + continue; + else if (str.find ("start", 0) == 0) + k = 0; + else if (str.find ("end", 0) == 0) + k = 1; + else if (str.find ("tokenextents", 0) == 0) + k = 2; + else if (str.find ("match", 0) == 0) + k = 3; + else if (str.find ("tokens", 0) == 0) + k = 4; + else if (str.find ("names", 0) == 0) + k = 5; + else if (str.find ("split", 0) == 0) + k = 6; + + new_retval(n++) = retval(k); + arg_used[k] = true; + + if (n == nargout) + break; + } + + // Fill in the rest of the arguments + if (n < nargout) + { + for (int j = 0; j < 6; j++) + { + if (! arg_used[j]) + new_retval(n++) = retval(j); + } + } + + retval = new_retval; + } + } + + return retval; +} + +static octave_value_list +octcellregexp (const octave_value_list &args, int nargout, + const std::string &who, bool case_insensitive = false) +{ + octave_value_list retval; + + if (args(0).is_cell ()) + { + OCTAVE_LOCAL_BUFFER (Cell, newretval, nargout); + octave_value_list new_args = args; + Cell cellstr = args(0).cell_value (); + if (args(1).is_cell ()) + { + Cell cellpat = args(1).cell_value (); + + if (cellpat.numel () == 1) + { + for (int j = 0; j < nargout; j++) + newretval[j].resize (cellstr.dims ()); + + new_args(1) = cellpat(0); + + for (octave_idx_type i = 0; i < cellstr.numel (); i++) + { + new_args(0) = cellstr(i); + octave_value_list tmp = octregexp (new_args, nargout, who, + case_insensitive); + + if (error_state) + break; + + for (int j = 0; j < nargout; j++) + newretval[j](i) = tmp(j); + } + } + else if (cellstr.numel () == 1) + { + for (int j = 0; j < nargout; j++) + newretval[j].resize (cellpat.dims ()); + + new_args(0) = cellstr(0); + + for (octave_idx_type i = 0; i < cellpat.numel (); i++) + { + new_args(1) = cellpat(i); + octave_value_list tmp = octregexp (new_args, nargout, who, + case_insensitive); + + if (error_state) + break; + + for (int j = 0; j < nargout; j++) + newretval[j](i) = tmp(j); + } + } + else if (cellstr.numel () == cellpat.numel ()) + { + + if (cellstr.dims () != cellpat.dims ()) + error ("%s: inconsistent cell array dimensions", who.c_str ()); + else + { + for (int j = 0; j < nargout; j++) + newretval[j].resize (cellstr.dims ()); + + for (octave_idx_type i = 0; i < cellstr.numel (); i++) + { + new_args(0) = cellstr(i); + new_args(1) = cellpat(i); + + octave_value_list tmp = octregexp (new_args, nargout, who, + case_insensitive); + + if (error_state) + break; + + for (int j = 0; j < nargout; j++) + newretval[j](i) = tmp(j); + } + } + } + else + error ("regexp: cell array arguments must be scalar or equal size"); + } + else + { + for (int j = 0; j < nargout; j++) + newretval[j].resize (cellstr.dims ()); + + for (octave_idx_type i = 0; i < cellstr.numel (); i++) + { + new_args(0) = cellstr(i); + octave_value_list tmp = octregexp (new_args, nargout, who, + case_insensitive); + + if (error_state) + break; + + for (int j = 0; j < nargout; j++) + newretval[j](i) = tmp(j); + } + } + + if (!error_state) + for (int j = 0; j < nargout; j++) + retval(j) = octave_value (newretval[j]); + } + else if (args(1).is_cell ()) + { + OCTAVE_LOCAL_BUFFER (Cell, newretval, nargout); + octave_value_list new_args = args; + Cell cellpat = args(1).cell_value (); + + for (int j = 0; j < nargout; j++) + newretval[j].resize (cellpat.dims ()); + + for (octave_idx_type i = 0; i < cellpat.numel (); i++) + { + new_args(1) = cellpat(i); + octave_value_list tmp = octregexp (new_args, nargout, who, + case_insensitive); + + if (error_state) + break; + + for (int j = 0; j < nargout; j++) + newretval[j](i) = tmp(j); + } + + if (!error_state) + { + for (int j = 0; j < nargout; j++) + retval(j) = octave_value (newretval[j]); + } + } + else + retval = octregexp (args, nargout, who, case_insensitive); + + return retval; + +} + +DEFUN (regexp, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{s}, @var{e}, @var{te}, @var{m}, @var{t}, @var{nm}, @var{sp}] =} regexp (@var{str}, @var{pat})\n\ +@deftypefnx {Built-in Function} {[@dots{}] =} regexp (@var{str}, @var{pat}, \"@var{opt1}\", @dots{})\n\ +Regular expression string matching. Search for @var{pat} in @var{str} and\n\ +return the positions and substrings of any matches, or empty values if there\n\ +are none.\n\ +\n\ +The matched pattern @var{pat} can include any of the standard regex\n\ +operators, including:\n\ +\n\ +@table @code\n\ +@item .\n\ +Match any character\n\ +\n\ +@item * + ? @{@}\n\ +Repetition operators, representing\n\ +\n\ +@table @code\n\ +@item *\n\ +Match zero or more times\n\ +\n\ +@item +\n\ +Match one or more times\n\ +\n\ +@item ?\n\ +Match zero or one times\n\ +\n\ +@item @{@var{n}@}\n\ +Match exactly @var{n} times\n\ +\n\ +@item @{@var{n},@}\n\ +Match @var{n} or more times\n\ +\n\ +@item @{@var{m},@var{n}@}\n\ +Match between @var{m} and @var{n} times\n\ +@end table\n\ +\n\ +@item [@dots{}] [^@dots{}]\n\ +\n\ +List operators. The pattern will match any character listed between \"[\"\n\ +and \"]\". If the first character is \"^\" then the pattern is inverted and\n\ +any character except those listed between brackets will match.\n\ +\n\ +Escape sequences defined below can also be used inside list\n\ +operators. For example, a template for a floating point number might be\n\ +@code{[-+.\\d]+}.\n\ +\n\ +@item () (?:)\n\ +Grouping operator. The first form, parentheses only, also creates a token.\n\ +\n\ +@item |\n\ +Alternation operator. Match one of a choice of regular expressions. The\n\ +alternatives must be delimited by the grouping operator @code{()} above.\n\ +\n\ +@item ^ $\n\ +Anchoring operators. Requires pattern to occur at the start (@code{^}) or\n\ +end (@code{$}) of the string.\n\ +@end table\n\ +\n\ +In addition, the following escaped characters have special meaning. Note,\n\ +it is recommended to quote @var{pat} in single quotes, rather than double\n\ +quotes, to avoid the escape sequences being interpreted by Octave before\n\ +being passed to @code{regexp}.\n\ +\n\ +@table @code\n\ +@item \\b\n\ +Match a word boundary\n\ +\n\ +@item \\B\n\ +Match within a word\n\ +\n\ +@item \\w\n\ +Match any word character\n\ +\n\ +@item \\W\n\ +Match any non-word character\n\ +\n\ +@item \\<\n\ +Match the beginning of a word\n\ +\n\ +@item \\>\n\ +Match the end of a word\n\ +\n\ +@item \\s\n\ +Match any whitespace character\n\ +\n\ +@item \\S\n\ +Match any non-whitespace character\n\ +\n\ +@item \\d\n\ +Match any digit\n\ +\n\ +@item \\D\n\ +Match any non-digit\n\ +@end table\n\ +\n\ +The outputs of @code{regexp} default to the order given below\n\ +\n\ +@table @var\n\ +@item s\n\ +The start indices of each matching substring\n\ +\n\ +@item e\n\ +The end indices of each matching substring\n\ +\n\ +@item te\n\ +The extents of each matched token surrounded by @code{(@dots{})} in\n\ +@var{pat}\n\ +\n\ +@item m\n\ +A cell array of the text of each match\n\ +\n\ +@item t\n\ +A cell array of the text of each token matched\n\ +\n\ +@item nm\n\ +A structure containing the text of each matched named token, with the name\n\ +being used as the fieldname. A named token is denoted by\n\ +@code{(?<name>@dots{})}.\n\ +\n\ +@item sp\n\ +A cell array of the text not returned by match, i.e., what remains if you\n\ +split the string based on @var{pat}.\n\ +@end table\n\ +\n\ +Particular output arguments, or the order of the output arguments, can be\n\ +selected by additional @var{opt} arguments. These are strings and the\n\ +correspondence between the output arguments and the optional argument\n\ +are\n\ +\n\ +@multitable @columnfractions 0.2 0.3 0.3 0.2\n\ +@item @tab 'start' @tab @var{s} @tab\n\ +@item @tab 'end' @tab @var{e} @tab\n\ +@item @tab 'tokenExtents' @tab @var{te} @tab\n\ +@item @tab 'match' @tab @var{m} @tab\n\ +@item @tab 'tokens' @tab @var{t} @tab\n\ +@item @tab 'names' @tab @var{nm} @tab\n\ +@item @tab 'split' @tab @var{sp} @tab\n\ +@end multitable\n\ +\n\ +Additional arguments are summarized below.\n\ +\n\ +@table @samp\n\ +@item once\n\ +Return only the first occurrence of the pattern.\n\ +\n\ +@item matchcase\n\ +Make the matching case sensitive. (default)\n\ +\n\ +Alternatively, use (?-i) in the pattern.\n\ +\n\ +@item ignorecase\n\ +Ignore case when matching the pattern to the string.\n\ +\n\ +Alternatively, use (?i) in the pattern.\n\ +\n\ +@item stringanchors\n\ +Match the anchor characters at the beginning and end of the string.\n\ +(default)\n\ +\n\ +Alternatively, use (?-m) in the pattern.\n\ +\n\ +@item lineanchors\n\ +Match the anchor characters at the beginning and end of the line.\n\ +\n\ +Alternatively, use (?m) in the pattern.\n\ +\n\ +@item dotall\n\ +The pattern @code{.} matches all characters including the newline character.\n\ + (default)\n\ +\n\ +Alternatively, use (?s) in the pattern.\n\ +\n\ +@item dotexceptnewline\n\ +The pattern @code{.} matches all characters except the newline character.\n\ +\n\ +Alternatively, use (?-s) in the pattern.\n\ +\n\ +@item literalspacing\n\ +All characters in the pattern, including whitespace, are significant and are\n\ +used in pattern matching. (default)\n\ +\n\ +Alternatively, use (?-x) in the pattern.\n\ +\n\ +@item freespacing\n\ +The pattern may include arbitrary whitespace and also comments beginning with\n\ +the character @samp{#}.\n\ +\n\ +Alternatively, use (?x) in the pattern.\n\ +\n\ +@item noemptymatch\n\ +Zero-length matches are not returned. (default)\n\ +\n\ +@item emptymatch\n\ +Return zero-length matches.\n\ +\n\ +@code{regexp ('a', 'b*', 'emptymatch'} returns @code{[1 2]} because there are\n\ +zero or more 'b' characters at positions 1 and end-of-string.\n\ +\n\ +@end table\n\ +@seealso{regexpi, strfind, regexprep}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin < 2) + print_usage (); + else if (args(0).is_cell () || args(1).is_cell ()) + retval = octcellregexp (args, (nargout > 0 ? nargout : 1), "regexp"); + else + retval = octregexp (args, nargout, "regexp"); + + return retval; +} + +/* +## PCRE_ERROR_MATCHLIMIT test +%!test +%! s = sprintf ('\t4\n0000\t-0.00\t-0.0000\t4\t-0.00\t-0.0000\t4\n0000\t-0.00\t-0.0000\t0\t-0.00\t-'); +%! ws = warning ("query"); +%! unwind_protect +%! warning ("off"); +%! regexp (s, '(\s*-*\d+[.]*\d*\s*)+\n'); +%! unwind_protect_cleanup +%! warning (ws); +%! end_unwind_protect + +## segfault test +%!assert (regexp ("abcde", "."), [1,2,3,4,5]) +## Infinite loop test +%!assert (isempty (regexp ("abcde", ""))) + +## Check that anchoring of pattern works correctly +%!assert (regexp ('abcabc', '^abc'), 1) +%!assert (regexp ('abcabc', 'abc$'), 4) +%!assert (regexp ('abcabc', '^abc$'), zeros (1,0)) + +%!test +%! [s, e, te, m, t] = regexp (' No Match ', 'f(.*)uck'); +%! assert (s, zeros (1,0)); +%! assert (e, zeros (1,0)); +%! assert (te, cell (1,0)); +%! assert (m, cell (1,0)); +%! assert (t, cell (1,0)); + +%!test +%! [s, e, te, m, t] = regexp (' FiRetrUck ', 'f(.*)uck'); +%! assert (s, zeros (1,0)); +%! assert (e, zeros (1,0)); +%! assert (te, cell (1,0)); +%! assert (m, cell (1,0)); +%! assert (t, cell (1,0)); + +%!test +%! [s, e, te, m, t] = regexp (' firetruck ', 'f(.*)uck'); +%! assert (s, 2); +%! assert (e, 10); +%! assert (te{1}, [3, 7]); +%! assert (m{1}, 'firetruck'); +%! assert (t{1}{1}, 'iretr'); + +%!test +%! [s, e, te, m, t] = regexp ('short test string', '\w*r\w*'); +%! assert (s, [1, 12]); +%! assert (e, [5, 17]); +%! assert (size (te), [1, 2]); +%! assert (isempty (te{1})); +%! assert (isempty (te{2})); +%! assert (m{1}, 'short'); +%! assert (m{2}, 'string'); +%! assert (size (t), [1, 2]); +%! assert (isempty (t{1})); +%! assert (isempty (t{2})); + +%!test +%! [s, e, te, m, t] = regexp ('short test string', '\w*r\w*', 'once'); +%! assert (s, 1); +%! assert (e, 5); +%! assert (isempty (te)); +%! assert (m, 'short'); +%! assert (isempty (t)); + +%!test +%! [m, te, e, s, t] = regexp ('short test string', '\w*r\w*', 'once', 'match', 'tokenExtents', 'end', 'start', 'tokens'); +%! assert (s, 1); +%! assert (e, 5); +%! assert (isempty (te)); +%! assert (m, 'short'); +%! assert (isempty (t)); + +%!test +%! [s, e, te, m, t, nm] = regexp ('short test string', '(?<word1>\w*t)\s*(?<word2>\w*t)'); +%! assert (s, 1); +%! assert (e, 10); +%! assert (size (te), [1, 1]); +%! assert (te{1}, [1,5; 7,10]); +%! assert (m{1}, 'short test'); +%! assert (size (t), [1, 1]); +%! assert (t{1}{1}, 'short'); +%! assert (t{1}{2}, 'test'); +%! assert (size (nm), [1, 1]); +%! assert (! isempty (fieldnames (nm))); +%! assert (sort (fieldnames (nm)), {'word1';'word2'}); +%! assert (nm.word1, 'short'); +%! assert (nm.word2, 'test'); + +%!test +%! [nm, m, te, e, s, t] = regexp ('short test string', '(?<word1>\w*t)\s*(?<word2>\w*t)', 'names', 'match', 'tokenExtents', 'end', 'start', 'tokens'); +%! assert (s, 1); +%! assert (e, 10); +%! assert (size (te), [1, 1]); +%! assert (te{1}, [1,5; 7,10]); +%! assert (m{1}, 'short test'); +%! assert (size (t), [1, 1]); +%! assert (t{1}{1}, 'short'); +%! assert (t{1}{2}, 'test'); +%! assert (size (nm), [1, 1]); +%! assert (!isempty (fieldnames (nm))); +%! assert (sort (fieldnames (nm)), {'word1';'word2'}); +%! assert (nm.word1, 'short'); +%! assert (nm.word2, 'test'); + +%!test +%! [t, nm] = regexp ("John Davis\nRogers, James", '(?<first>\w+)\s+(?<last>\w+)|(?<last>\w+),\s+(?<first>\w+)', 'tokens', 'names'); +%! assert (size (t), [1, 2]); +%! assert (t{1}{1}, 'John'); +%! assert (t{1}{2}, 'Davis'); +%! assert (t{2}{1}, 'Rogers'); +%! assert (t{2}{2}, 'James'); +%! assert (size (nm), [1, 1]); +%! assert (nm.first{1}, 'John'); +%! assert (nm.first{2}, 'James'); +%! assert (nm.last{1}, 'Davis'); +%! assert (nm.last{2}, 'Rogers'); + +## Tests for named tokens +%!test +%! # Parenthesis in named token (ie (int)) causes a problem +%! assert (regexp ('qwe int asd', ['(?<typestr>(int))'], 'names'), struct ('typestr', 'int')); + +%!test +%! ## Mix of named and unnamed tokens can cause segfault (bug #35683) +%! str = "abcde"; +%! ptn = '(?<T1>a)(\w+)(?<T2>d\w+)'; +%! tokens = regexp (str, ptn, "names"); +%! assert (isstruct (tokens) && numel (tokens) == 1); +%! assert (tokens.T1, "a"); +%! assert (tokens.T2, "de"); + +%!assert (regexp ("abc\nabc", '.'), [1:7]) +%!assert (regexp ("abc\nabc", '.', 'dotall'), [1:7]) +%!test +%! assert (regexp ("abc\nabc", '(?s).'), [1:7]); +%! assert (regexp ("abc\nabc", '.', 'dotexceptnewline'), [1,2,3,5,6,7]); +%! assert (regexp ("abc\nabc", '(?-s).'), [1,2,3,5,6,7]); + +%!assert (regexp ("caseCaSe", 'case'), 1) +%!assert (regexp ("caseCaSe", 'case', "matchcase"), 1) +%!assert (regexp ("caseCaSe", 'case', "ignorecase"), [1,5]) +%!test +%! assert (regexp ("caseCaSe", '(?-i)case'), 1); +%! assert (regexp ("caseCaSe", '(?i)case'), [1, 5]); + +%!assert (regexp ("abc\nabc", 'c$'), 7) +%!assert (regexp ("abc\nabc", 'c$', "stringanchors"), 7) +%!test +%! assert (regexp ("abc\nabc", '(?-m)c$'), 7); +%! assert (regexp ("abc\nabc", 'c$',"lineanchors"), [3, 7]); +%! assert (regexp ("abc\nabc", '(?m)c$'), [3,7]); + +%!assert (regexp ("this word", 's w'), 4) +%!assert (regexp ("this word", 's w', 'literalspacing'), 4) +%!test +%! assert (regexp ("this word", '(?-x)s w', 'literalspacing'), 4); +%! assert (regexp ("this word", 's w', 'freespacing'), zeros (1,0)); +%! assert (regexp ("this word", '(?x)s w'), zeros (1,0)); + +%!test +%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '[VOCT]*', 'noemptymatch'); +%! assert (s, [1 5]); +%! assert (e, [3 5]); +%! assert (te, { zeros(0,2), zeros(0,2) }); +%! assert (m, { "OCT", "V" }); +%! assert (t, { cell(1,0), cell(1,0) }); +%! assert (isempty (fieldnames (nm))); +%! assert (sp, { "", "A", "E" }); + +%!test +%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '([VOCT]*)', 'noemptymatch'); +%! assert (s, [1 5]); +%! assert (e, [3 5]); +%! assert (te, { [1 3], [5 5] }); +%! assert (m, { "OCT", "V" }); +%! assert (t, { {"OCT"}, {"V"} }); +%! assert (isempty (fieldnames (nm))); +%! assert (sp, { "", "A", "E" }); + +%!test +%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '[VOCT]*', 'emptymatch'); +%! assert (s, [1 4 5 6 7]); +%! assert (e, [3 3 5 5 6]); +%! assert (te, repmat ({zeros(0,2)}, [1, 5])); +%! assert (m, { "OCT", "", "V", "", "" }); +%! assert (t, repmat({cell(1,0)}, [1, 5])); +%! assert (isempty (fieldnames (nm))); +%! assert (sp, { "", "", "A", "", "E", "" }); + +%!test +%! [s, e, te, m, t, nm, sp] = regexp ('OCTAVE', '([VOCT]*)', 'emptymatch'); +%! assert (s, [1 4 5 6 7]); +%! assert (e, [3 3 5 5 6]); +%! assert (te, { [1 3], [4 3], [5 5], [6 5], [7 6] }); +%! assert (m, { "OCT", "", "V", "", "" }); +%! assert (t, { {"OCT"}, {""}, {"V"}, {""}, {""} }); +%! assert (isempty (fieldnames (nm))); +%! assert (sp, { "", "", "A", "", "E", "" }); + +%!error regexp ('string', 'tri', 'BadArg') +%!error regexp ('string') + +%!assert (regexp ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, '-'), {6;[1,5,9];zeros(1,0)}) +%!assert (regexp ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, {'-';'f';'q'}), {6;[3,7];[1,9]}) +%!assert (regexp ('Strings', {'t','s'}), {2, 7}) + +## Test case for lookaround operators +%!test +%! assert (regexp ('Iraq', 'q(?!u)'), 4); +%! assert (regexp ('quit', 'q(?!u)'), zeros (1, 0)); +%! assert (regexp ('quit', 'q(?=u)' , 'match'), {'q'}); +%! assert (regexp ("quit", 'q(?=u+)', 'match'), {'q'}); +%! assert (regexp ("qit", 'q(?=u+)', 'match'), cell (1, 0)); +%! assert (regexp ("qit", 'q(?=u*)', 'match'), {'q'}); +%! assert (regexp ('thingamabob', '(?<=a)b'), 9); + +## Tests for split option. +%!shared str +%! str = "foo bar foo"; +%!test +%! [a, b] = regexp (str, "f..", "match", "split"); +%! assert (a, {"foo", "foo"}); +%! assert (b, {"", " bar ", ""}); +%!test +%! [a, b] = regexp (str, "f..", "match", "split", "once"); +%! assert (a, "foo"); +%! assert (b, {"", " bar foo"}); +%!test +%! [a, b] = regexp (str, "fx.", "match", "split"); +%! assert (a, cell (1, 0)); +%! assert (b, {"foo bar foo"}); +%!test +%! [a, b] = regexp (str, "fx.", "match", "split", "once"); +%! assert (a, "");; +%! assert (b, "foo bar foo"); + +%!shared str +%! str = "foo bar"; +%!test +%! [a, b] = regexp (str, "f..", "match", "split"); +%! assert (a, {"foo"}); +%! assert (b, {"", " bar"}); +%!test +%! [a, b] = regexp (str, "b..", "match", "split"); +%! assert (a, {"bar"}); +%! assert (b, {"foo ", ""}); +%!test +%! [a, b] = regexp (str, "x", "match", "split"); +%! assert (a, cell (1, 0)); +%! assert (b, {"foo bar"}); +%!test +%! [a, b] = regexp (str, "[o]+", "match", "split"); +%! assert (a, {"oo"}); +%! assert (b, {"f", " bar"}); + +%!assert (regexp ("\n", '\n'), 1); +%!assert (regexp ("\n", "\n"), 1); +*/ + +DEFUN (regexpi, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{s}, @var{e}, @var{te}, @var{m}, @var{t}, @var{nm}, @var{sp}] =} regexpi (@var{str}, @var{pat})\n\ +@deftypefnx {Built-in Function} {[@dots{}] =} regexpi (@var{str}, @var{pat}, \"@var{opt1}\", @dots{})\n\ +\n\ +Case insensitive regular expression string matching. Search for @var{pat} in\n\ +@var{str} and return the positions and substrings of any matches, or empty\n\ +values if there are none. @xref{doc-regexp,,regexp}, for details on the\n\ +syntax of the search pattern.\n\ +@seealso{regexp}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin < 2) + print_usage (); + else if (args(0).is_cell () || args(1).is_cell ()) + retval = octcellregexp (args, (nargout > 0 ? nargout : 1), "regexpi", true); + else + retval = octregexp (args, nargout, "regexpi", true); + + return retval; +} + +/* +## segfault test +%!assert (regexpi ("abcde", "."), [1,2,3,4,5]) + +## Check that anchoring of pattern works correctly +%!assert (regexpi ('abcabc', '^ABC'), 1) +%!assert (regexpi ('abcabc', 'ABC$'), 4) +%!assert (regexpi ('abcabc', '^ABC$'), zeros (1,0)) + +%!test +%! [s, e, te, m, t] = regexpi (' No Match ', 'f(.*)uck'); +%! assert (s, zeros (1,0)); +%! assert (e, zeros (1,0)); +%! assert (te, cell (1,0)); +%! assert (m, cell (1,0)); +%! assert (t, cell (1,0)); + +%!test +%! [s, e, te, m, t] = regexpi (' FiRetrUck ', 'f(.*)uck'); +%! assert (s, 2); +%! assert (e, 10); +%! assert (te{1}, [3, 7]); +%! assert (m{1}, 'FiRetrUck'); +%! assert (t{1}{1}, 'iRetr'); + +%!test +%! [s, e, te, m, t] = regexpi (' firetruck ', 'f(.*)uck'); +%! assert (s, 2); +%! assert (e, 10); +%! assert (te{1}, [3, 7]); +%! assert (m{1}, 'firetruck'); +%! assert (t{1}{1}, 'iretr'); + +%!test +%! [s, e, te, m, t] = regexpi ('ShoRt Test String', '\w*r\w*'); +%! assert (s, [1, 12]); +%! assert (e, [5, 17]); +%! assert (size (te), [1, 2]); +%! assert (isempty (te{1})); +%! assert (isempty (te{2})); +%! assert (m{1}, 'ShoRt'); +%! assert (m{2}, 'String'); +%! assert (size (t), [1, 2]); +%! assert (isempty (t{1})); +%! assert (isempty (t{2})); + +%!test +%! [s, e, te, m, t] = regexpi ('ShoRt Test String', '\w*r\w*', 'once'); +%! assert (s, 1); +%! assert (e, 5); +%! assert (isempty (te)); +%! assert (m, 'ShoRt'); +%! assert (isempty (t)); + +%!test +%! [m, te, e, s, t] = regexpi ('ShoRt Test String', '\w*r\w*', 'once', 'match', 'tokenExtents', 'end', 'start', 'tokens'); +%! assert (s, 1); +%! assert (e, 5); +%! assert (isempty (te)); +%! assert (m, 'ShoRt'); +%! assert (isempty (t)); + +%!test +%! [s, e, te, m, t, nm] = regexpi ('ShoRt Test String', '(?<word1>\w*t)\s*(?<word2>\w*t)'); +%! assert (s, 1); +%! assert (e, 10); +%! assert (size (te), [1, 1]); +%! assert (te{1}, [1,5; 7,10]); +%! assert (m{1}, 'ShoRt Test'); +%! assert (size (t), [1, 1]); +%! assert (t{1}{1}, 'ShoRt'); +%! assert (t{1}{2}, 'Test'); +%! assert (size (nm), [1, 1]); +%! assert (! isempty (fieldnames (nm))); +%! assert (sort (fieldnames (nm)), {'word1';'word2'}); +%! assert (nm.word1, 'ShoRt'); +%! assert (nm.word2, 'Test'); + +%!test +%! [nm, m, te, e, s, t] = regexpi ('ShoRt Test String', '(?<word1>\w*t)\s*(?<word2>\w*t)', 'names', 'match', 'tokenExtents', 'end', 'start', 'tokens'); +%! assert (s, 1); +%! assert (e, 10); +%! assert (size (te), [1, 1]); +%! assert (te{1}, [1,5; 7,10]); +%! assert (m{1}, 'ShoRt Test'); +%! assert (size (t), [1, 1]); +%! assert (t{1}{1}, 'ShoRt'); +%! assert (t{1}{2}, 'Test'); +%! assert (size (nm), [1, 1]); +%! assert (!isempty (fieldnames (nm))); +%! assert (sort (fieldnames (nm)), {'word1';'word2'}); +%! assert (nm.word1, 'ShoRt'); +%! assert (nm.word2, 'Test'); + +%!assert (regexpi ("abc\nabc", '.'), [1:7]) +%!assert (regexpi ("abc\nabc", '.', 'dotall'), [1:7]) +%!test +%! assert (regexpi ("abc\nabc", '(?s).'), [1:7]); +%! assert (regexpi ("abc\nabc", '.', 'dotexceptnewline'), [1,2,3,5,6,7]); +%! assert (regexpi ("abc\nabc", '(?-s).'), [1,2,3,5,6,7]); + +%!assert (regexpi ("caseCaSe", 'case'), [1, 5]) +%!assert (regexpi ("caseCaSe", 'case', "matchcase"), 1) +%!assert (regexpi ("caseCaSe", 'case', "ignorecase"), [1, 5]) +%!test +%! assert (regexpi ("caseCaSe", '(?-i)case'), 1); +%! assert (regexpi ("caseCaSe", '(?i)case'), [1, 5]); + +%!assert (regexpi ("abc\nabc", 'C$'), 7) +%!assert (regexpi ("abc\nabc", 'C$', "stringanchors"), 7) +%!test +%! assert (regexpi ("abc\nabc", '(?-m)C$'), 7); +%! assert (regexpi ("abc\nabc", 'C$', "lineanchors"), [3, 7]); +%! assert (regexpi ("abc\nabc", '(?m)C$'), [3, 7]); + +%!assert (regexpi ("this word", 'S w'), 4) +%!assert (regexpi ("this word", 'S w', 'literalspacing'), 4) +%!test +%! assert (regexpi ("this word", '(?-x)S w', 'literalspacing'), 4); +%! assert (regexpi ("this word", 'S w', 'freespacing'), zeros (1,0)); +%! assert (regexpi ("this word", '(?x)S w'), zeros (1,0)); + +%!error regexpi ('string', 'tri', 'BadArg') +%!error regexpi ('string') + +%!assert (regexpi ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, '-'), {6;[1,5,9];zeros(1, 0)}) +%!assert (regexpi ({'asdfg-dfd', '-dfd-dfd-', 'qasfdfdaq'}, '-'), {6, [1,5,9], zeros(1,0)}) +%!assert (regexpi ({'asdfg-dfd';'-dfd-dfd-';'qasfdfdaq'}, {'-';'f';'q'}), {6;[3,7];[1,9]}) +%!assert (regexpi ('Strings', {'t', 's'}), {2, [1, 7]}) + +%!assert (regexpi ("\n", '\n'), 1); +%!assert (regexpi ("\n", "\n"), 1); +*/ + +static octave_value +octregexprep (const octave_value_list &args, const std::string &who) +{ + octave_value retval; + + int nargin = args.length (); + + // Make sure we have string, pattern, replacement + const std::string buffer = args(0).string_value (); + if (error_state) + return retval; + + std::string pattern = args(1).string_value (); + if (error_state) + return retval; + // Matlab compatibility. + if (args(1).is_sq_string ()) + pattern = do_regexp_string_escapes (pattern); + + std::string replacement = args(2).string_value (); + if (error_state) + return retval; + // Matlab compatibility. + if (args(2).is_sq_string ()) + replacement = do_regexp_string_escapes (replacement); + + // Pack options excluding 'tokenize' and various output + // reordering strings into regexp arg list + octave_value_list regexpargs (nargin-3, octave_value ()); + + int len = 0; + for (int i = 3; i < nargin; i++) + { + const std::string opt = args(i).string_value (); + if (opt != "tokenize" && opt != "start" && opt != "end" + && opt != "tokenextents" && opt != "match" && opt != "tokens" + && opt != "names" && opt != "split" && opt != "warnings") + { + regexpargs(len++) = args(i); + } + } + regexpargs.resize (len); + + regexp::opts options; + bool extra_args = false; + parse_options (options, regexpargs, who, 0, extra_args); + if (error_state) + return retval; + + return regexp_replace (pattern, buffer, replacement, options, who); +} + +DEFUN (regexprep, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{outstr} =} regexprep (@var{string}, @var{pat}, @var{repstr})\n\ +@deftypefnx {Built-in Function} {@var{outstr} =} regexprep (@var{string}, @var{pat}, @var{repstr}, \"@var{opt1}\", @dots{})\n\ +Replace occurrences of pattern @var{pat} in @var{string} with @var{repstr}.\n\ +\n\ +The pattern is a regular expression as documented for @code{regexp}.\n\ +@xref{doc-regexp,,regexp}.\n\ +\n\ +The replacement string may contain @code{$i}, which substitutes\n\ +for the ith set of parentheses in the match string. For example,\n\ +\n\ +@example\n\ +regexprep (\"Bill Dunn\", '(\\w+) (\\w+)', '$2, $1')\n\ +@end example\n\ +\n\ +@noindent\n\ +returns \"Dunn, Bill\"\n\ +\n\ +Options in addition to those of @code{regexp} are\n\ +\n\ +@table @samp\n\ +\n\ +@item once\n\ +Replace only the first occurrence of @var{pat} in the result.\n\ +\n\ +@item warnings\n\ +This option is present for compatibility but is ignored.\n\ +\n\ +@end table\n\ +@seealso{regexp, regexpi, strrep}\n\ +@end deftypefn") +{ + octave_value_list retval; + int nargin = args.length (); + + if (nargin < 3) + { + print_usage (); + return retval; + } + + if (args(0).is_cell () || args(1).is_cell () || args(2).is_cell ()) + { + Cell str; + Cell pat; + Cell rep; + dim_vector dv0; + dim_vector dv1 (1, 1); + + if (args(0).is_cell ()) + str = args(0).cell_value (); + else + str = Cell (args(0)); + + if (args(1).is_cell ()) + pat = args(1).cell_value (); + else + pat = Cell (args(1)); + + if (args(2).is_cell ()) + rep = args(2).cell_value (); + else + rep = Cell (args(2)); + + dv0 = str.dims (); + if (pat.numel () != 1) + { + dv1 = pat.dims (); + if (rep.numel () != 1 && dv1 != rep.dims ()) + error ("regexprep: inconsistent cell array dimensions"); + } + else if (rep.numel () != 1) + dv1 = rep.dims (); + + if (!error_state) + { + Cell ret (dv0); + octave_value_list new_args = args; + + for (octave_idx_type i = 0; i < dv0.numel (); i++) + { + new_args(0) = str(i); + if (pat.numel () == 1) + new_args(1) = pat(0); + if (rep.numel () == 1) + new_args(2) = rep(0); + + for (octave_idx_type j = 0; j < dv1.numel (); j++) + { + if (pat.numel () != 1) + new_args(1) = pat(j); + if (rep.numel () != 1) + new_args(2) = rep(j); + new_args(0) = octregexprep (new_args, "regexprep"); + + if (error_state) + break; + } + + if (error_state) + break; + + ret(i) = new_args(0); + } + + if (!error_state) + retval = args(0).is_cell () + ? octave_value (ret) : octave_value (ret(0)); + } + } + else + retval = octregexprep (args, "regexprep"); + + return retval; +} + +/* +%!test # Replace with empty +%! xml = '<!-- This is some XML --> <tag v="hello">some stuff<!-- sample tag--></tag>'; +%! t = regexprep (xml, '<[!?][^>]*>', ''); +%! assert (t, ' <tag v="hello">some stuff</tag>'); + +%!test # Replace with non-empty +%! xml = '<!-- This is some XML --> <tag v="hello">some stuff<!-- sample tag--></tag>'; +%! t = regexprep (xml, '<[!?][^>]*>', '?'); +%! assert (t, '? <tag v="hello">some stuff?</tag>'); + +%!test # Check that 'tokenize' is ignored +%! xml = '<!-- This is some XML --> <tag v="hello">some stuff<!-- sample tag--></tag>'; +%! t = regexprep (xml, '<[!?][^>]*>', '', 'tokenize'); +%! assert (t, ' <tag v="hello">some stuff</tag>'); + +## Test capture replacement +%!test +%! data = "Bob Smith\nDavid Hollerith\nSam Jenkins"; +%! result = "Smith, Bob\nHollerith, David\nJenkins, Sam"; +%! t = regexprep (data, '(?m)^(\w+)\s+(\w+)$', '$2, $1'); +%! assert (t, result); + +## Return the original if no match +%!assert (regexprep ('hello', 'world', 'earth'), 'hello') + +## Test emptymatch +%!assert (regexprep ('World', '^', 'Hello '), 'World') +%!assert (regexprep ('World', '^', 'Hello ', 'emptymatch'), 'Hello World') + +## Test a general replacement +%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Za-z0-9_]", "_"), "a_b_c_d_e_f_g") + +## Make sure it works at the beginning and end +%!assert (regexprep ("a[b]c{d}e-f=g", "a", "_"), "_[b]c{d}e-f=g") +%!assert (regexprep ("a[b]c{d}e-f=g", "g", "_"), "a[b]c{d}e-f=_") + +## Options +%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Za-z0-9_]", "_", "once"), "a_b]c{d}e-f=g") +%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Z0-9_]", "_", "ignorecase"), "a_b_c_d_e_f_g") + +## Option combinations +%!assert (regexprep ("a[b]c{d}e-f=g", "[^A-Z0-9_]", "_", "once", "ignorecase"), "a_b]c{d}e-f=g") + +## End conditions on replacement +%!assert (regexprep ("abc", "(b)", ".$1"), "a.bc"); +%!assert (regexprep ("abc", "(b)", "$1"), "abc"); +%!assert (regexprep ("abc", "(b)", "$1."), "ab.c"); +%!assert (regexprep ("abc", "(b)", "$1.."), "ab..c"); + +## Test cell array arguments +%!assert (regexprep ("abc", {"b","a"}, "?"), "??c") +%!assert (regexprep ({"abc","cba"}, "b", "?"), {"a?c","c?a"}) +%!assert (regexprep ({"abc","cba"}, {"b","a"}, {"?","!"}), {"!?c","c?!"}) + +# Nasty lookbehind expression +%!assert (regexprep ('x^(-1)+y(-1)+z(-1)=0', '(?<=[a-z]+)\(\-[1-9]*\)', '_minus1'),'x^(-1)+y_minus1+z_minus1=0') + +%!assert (regexprep ("\n", '\n', "X"), "X"); +%!assert (regexprep ("\n", "\n", "X"), "X"); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/schur.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,381 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include "CmplxSCHUR.h" +#include "dbleSCHUR.h" +#include "fCmplxSCHUR.h" +#include "floatSCHUR.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +template <class Matrix> +static octave_value +mark_upper_triangular (const Matrix& a) +{ + octave_value retval = a; + + octave_idx_type n = a.rows (); + assert (a.columns () == n); + + const typename Matrix::element_type zero = typename Matrix::element_type (); + + for (octave_idx_type i = 0; i < n; i++) + if (a(i,i) == zero) + return retval; + + retval.matrix_type (MatrixType::Upper); + + return retval; +} + +DEFUN (schur, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{S} =} schur (@var{A})\n\ +@deftypefnx {Built-in Function} {@var{S} =} schur (@var{A}, \"real\")\n\ +@deftypefnx {Built-in Function} {@var{S} =} schur (@var{A}, \"complex\")\n\ +@deftypefnx {Built-in Function} {@var{S} =} schur (@var{A}, @var{opt})\n\ +@deftypefnx {Built-in Function} {[@var{U}, @var{S}] =} schur (@var{A}, @dots{})\n\ +@cindex Schur decomposition\n\ +Compute the Schur@tie{}decomposition of @var{A}\n\ +@tex\n\ +$$\n\ + S = U^T A U\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +@code{@var{S} = @var{U}' * @var{A} * @var{U}}\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +where @var{U} is a unitary matrix\n\ +@tex\n\ +($U^T U$ is identity)\n\ +@end tex\n\ +@ifnottex\n\ +(@code{@var{U}'* @var{U}} is identity)\n\ +@end ifnottex\n\ +and @var{S} is upper triangular. The eigenvalues of @var{A} (and @var{S})\n\ +are the diagonal elements of @var{S}. If the matrix @var{A}\n\ +is real, then the real Schur@tie{}decomposition is computed, in which the\n\ +matrix @var{U} is orthogonal and @var{S} is block upper triangular\n\ +with blocks of size at most\n\ +@tex\n\ +$2 \\times 2$\n\ +@end tex\n\ +@ifnottex\n\ +@code{2 x 2}\n\ +@end ifnottex\n\ +along the diagonal. The diagonal elements of @var{S}\n\ +(or the eigenvalues of the\n\ +@tex\n\ +$2 \\times 2$\n\ +@end tex\n\ +@ifnottex\n\ +@code{2 x 2}\n\ +@end ifnottex\n\ +blocks, when appropriate) are the eigenvalues of @var{A} and @var{S}.\n\ +\n\ +The default for real matrices is a real Schur@tie{}decomposition.\n\ +A complex decomposition may be forced by passing the flag \"complex\".\n\ +\n\ +The eigenvalues are optionally ordered along the diagonal according to\n\ +the value of @var{opt}. @code{@var{opt} = \"a\"} indicates that all\n\ +eigenvalues with negative real parts should be moved to the leading\n\ +block of @var{S}\n\ +(used in @code{are}), @code{@var{opt} = \"d\"} indicates that all eigenvalues\n\ +with magnitude less than one should be moved to the leading block of @var{S}\n\ +(used in @code{dare}), and @code{@var{opt} = \"u\"}, the default, indicates\n\ +that no ordering of eigenvalues should occur. The leading @var{k}\n\ +columns of @var{U} always span the @var{A}-invariant\n\ +subspace corresponding to the @var{k} leading eigenvalues of @var{S}.\n\ +\n\ +The Schur@tie{}decomposition is used to compute eigenvalues of a\n\ +square matrix, and has applications in the solution of algebraic\n\ +Riccati equations in control (see @code{are} and @code{dare}).\n\ +@seealso{rsf2csf}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 2 || nargout > 2) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + + std::string ord; + + if (nargin == 2) + { + ord = args(1).string_value (); + + if (error_state) + { + error ("schur: second argument must be a string"); + return retval; + } + } + + bool force_complex = false; + + if (ord == "real") + { + ord = std::string (); + } + else if (ord == "complex") + { + force_complex = true; + ord = std::string (); + } + else + { + char ord_char = ord.empty () ? 'U' : ord[0]; + + if (ord_char != 'U' && ord_char != 'A' && ord_char != 'D' + && ord_char != 'u' && ord_char != 'a' && ord_char != 'd') + { + warning ("schur: incorrect ordered schur argument `%c'", + ord.c_str ()); + return retval; + } + } + + octave_idx_type nr = arg.rows (); + octave_idx_type nc = arg.columns (); + + if (nr != nc) + { + gripe_square_matrix_required ("schur"); + return retval; + } + + if (! arg.is_numeric_type ()) + gripe_wrong_type_arg ("schur", arg); + else if (arg.is_single_type ()) + { + if (! force_complex && arg.is_real_type ()) + { + FloatMatrix tmp = arg.float_matrix_value (); + + if (! error_state) + { + if (nargout == 0 || nargout == 1) + { + FloatSCHUR result (tmp, ord, false); + retval(0) = result.schur_matrix (); + } + else + { + FloatSCHUR result (tmp, ord, true); + retval(1) = result.schur_matrix (); + retval(0) = result.unitary_matrix (); + } + } + } + else + { + FloatComplexMatrix ctmp = arg.float_complex_matrix_value (); + + if (! error_state) + { + + if (nargout == 0 || nargout == 1) + { + FloatComplexSCHUR result (ctmp, ord, false); + retval(0) = mark_upper_triangular (result.schur_matrix ()); + } + else + { + FloatComplexSCHUR result (ctmp, ord, true); + retval(1) = mark_upper_triangular (result.schur_matrix ()); + retval(0) = result.unitary_matrix (); + } + } + } + } + else + { + if (! force_complex && arg.is_real_type ()) + { + Matrix tmp = arg.matrix_value (); + + if (! error_state) + { + if (nargout == 0 || nargout == 1) + { + SCHUR result (tmp, ord, false); + retval(0) = result.schur_matrix (); + } + else + { + SCHUR result (tmp, ord, true); + retval(1) = result.schur_matrix (); + retval(0) = result.unitary_matrix (); + } + } + } + else + { + ComplexMatrix ctmp = arg.complex_matrix_value (); + + if (! error_state) + { + + if (nargout == 0 || nargout == 1) + { + ComplexSCHUR result (ctmp, ord, false); + retval(0) = mark_upper_triangular (result.schur_matrix ()); + } + else + { + ComplexSCHUR result (ctmp, ord, true); + retval(1) = mark_upper_triangular (result.schur_matrix ()); + retval(0) = result.unitary_matrix (); + } + } + } + } + + return retval; +} + +/* +%!test +%! a = [1, 2, 3; 4, 5, 9; 7, 8, 6]; +%! [u, s] = schur (a); +%! assert (u' * a * u, s, sqrt (eps)); + +%!test +%! a = single ([1, 2, 3; 4, 5, 9; 7, 8, 6]); +%! [u, s] = schur (a); +%! assert (u' * a * u, s, sqrt (eps ("single"))); + +%!test +%! fail ("schur ([1, 2; 3, 4], 2)", "warning"); + +%!error schur () +%!error <argument must be a square matrix> schur ([1, 2, 3; 4, 5, 6]) +*/ + +DEFUN (rsf2csf, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Function File} {[@var{U}, @var{T}] =} rsf2csf (@var{UR}, @var{TR})\n\ +Convert a real, upper quasi-triangular Schur@tie{}form @var{TR} to a complex,\n\ +upper triangular Schur@tie{}form @var{T}.\n\ +\n\ +Note that the following relations hold:\n\ +\n\ +@tex\n\ +$UR \\cdot TR \\cdot {UR}^T = U T U^{\\dagger}$ and\n\ +$U^{\\dagger} U$ is the identity matrix I.\n\ +@end tex\n\ +@ifnottex\n\ +@xcode{@var{UR} * @var{TR} * @var{UR}' = @var{U} * @var{T} * @var{U}'} and\n\ +@code{@var{U}' * @var{U}} is the identity matrix I.\n\ +@end ifnottex\n\ +\n\ +Note also that @var{U} and @var{T} are not unique.\n\ +@seealso{schur}\n\ +@end deftypefn") +{ + octave_value_list retval; + + if (args.length () == 2 && nargout <= 2) + { + if (! args(0).is_numeric_type ()) + gripe_wrong_type_arg ("rsf2csf", args(0)); + else if (! args(1).is_numeric_type ()) + gripe_wrong_type_arg ("rsf2csf", args(1)); + else if (args(0).is_complex_type () || args(1).is_complex_type ()) + error ("rsf2csf: UR and TR must be real matrices"); + else + { + + if (args(0).is_single_type () || args(1).is_single_type ()) + { + FloatMatrix u = args(0).float_matrix_value (); + FloatMatrix t = args(1).float_matrix_value (); + if (! error_state) + { + FloatComplexSCHUR cs (FloatSCHUR (t, u)); + + retval(1) = cs.schur_matrix (); + retval(0) = cs.unitary_matrix (); + } + } + else + { + Matrix u = args(0).matrix_value (); + Matrix t = args(1).matrix_value (); + if (! error_state) + { + ComplexSCHUR cs (SCHUR (t, u)); + + retval(1) = cs.schur_matrix (); + retval(0) = cs.unitary_matrix (); + } + } + } + } + else + print_usage (); + + return retval; +} + +/* +%!test +%! A = [1, 1, 1, 2; 1, 2, 1, 1; 1, 1, 3, 1; -2, 1, 1, 1]; +%! [u, t] = schur (A); +%! [U, T] = rsf2csf (u, t); +%! assert (norm (u * t * u' - U * T * U'), 0, 1e-12); +%! assert (norm (A - U * T * U'), 0, 1e-12); + +%!test +%! A = rand (10); +%! [u, t] = schur (A); +%! [U, T] = rsf2csf (u, t); +%! assert (norm (tril (T, -1)), 0); +%! assert (norm (U * U'), 1, 1e-14); + +%!test +%! A = [0, 1;-1, 0]; +%! [u, t] = schur (A); +%! [U, T] = rsf2csf (u,t); +%! assert (U * T * U', A, 1e-14); +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/spparms.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,208 @@ +/* + +Copyright (C) 2004-2012 David Bateman +Copyright (C) 1998-2004 Andy Adler + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "ov.h" +#include "pager.h" +#include "error.h" +#include "gripes.h" + +#include "oct-spparms.h" + +DEFUN (spparms, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} { } spparms ()\n\ +@deftypefnx {Built-in Function} {@var{vals} =} spparms ()\n\ +@deftypefnx {Built-in Function} {[@var{keys}, @var{vals}] =} spparms ()\n\ +@deftypefnx {Built-in Function} {@var{val} =} spparms (@var{key})\n\ +@deftypefnx {Built-in Function} { } spparms (@var{vals})\n\ +@deftypefnx {Built-in Function} { } spparms (\"defaults\")\n\ +@deftypefnx {Built-in Function} { } spparms (\"tight\")\n\ +@deftypefnx {Built-in Function} { } spparms (@var{key}, @var{val})\n\ +Query or set the parameters used by the sparse solvers and factorization\n\ +functions. The first four calls above get information about the current\n\ +settings, while the others change the current settings. The parameters are\n\ +stored as pairs of keys and values, where the values are all floats and the\n\ +keys are one of the following strings:\n\ +\n\ +@table @samp\n\ +@item spumoni\n\ +Printing level of debugging information of the solvers (default 0)\n\ +\n\ +@item ths_rel\n\ +Included for compatibility. Not used. (default 1)\n\ +\n\ +@item ths_abs\n\ +Included for compatibility. Not used. (default 1)\n\ +\n\ +@item exact_d\n\ +Included for compatibility. Not used. (default 0)\n\ +\n\ +@item supernd\n\ +Included for compatibility. Not used. (default 3)\n\ +\n\ +@item rreduce\n\ +Included for compatibility. Not used. (default 3)\n\ +\n\ +@item wh_frac\n\ +Included for compatibility. Not used. (default 0.5)\n\ +\n\ +@item autommd\n\ +Flag whether the LU/QR and the '\\' and '/' operators will automatically\n\ +use the sparsity preserving mmd functions (default 1)\n\ +\n\ +@item autoamd\n\ +Flag whether the LU and the '\\' and '/' operators will automatically\n\ +use the sparsity preserving amd functions (default 1)\n\ +\n\ +@item piv_tol\n\ +The pivot tolerance of the @sc{umfpack} solvers (default 0.1)\n\ +\n\ +@item sym_tol\n\ +The pivot tolerance of the @sc{umfpack} symmetric solvers (default 0.001)\n\ +\n\ +@item bandden\n\ +The density of non-zero elements in a banded matrix before it is treated\n\ +by the @sc{lapack} banded solvers (default 0.5)\n\ +\n\ +@item umfpack\n\ +Flag whether the @sc{umfpack} or mmd solvers are used for the LU, '\\' and\n\ +'/' operations (default 1)\n\ +@end table\n\ +\n\ +The value of individual keys can be set with\n\ +@code{spparms (@var{key}, @var{val})}.\n\ +The default values can be restored with the special keyword\n\ +\"defaults\". The special keyword \"tight\" can be used to set the mmd\n\ +solvers to attempt a sparser solution at the potential cost of longer\n\ +running time.\n\ +@end deftypefn") +{ + octave_value_list retval; + int nargin = args.length (); + + if (nargin == 0) + { + if (nargout == 0) + octave_sparse_params::print_info (octave_stdout, ""); + else if (nargout == 1) + retval(0) = octave_sparse_params::get_vals (); + else if (nargout == 2) + { + retval(1) = octave_sparse_params::get_vals (); + retval(0) = octave_sparse_params::get_keys (); + } + else + error ("spparms: too many output arguments"); + } + else if (nargin == 1) + { + if (args(0).is_string ()) + { + std::string str = args(0).string_value (); + int len = str.length (); + for (int i = 0; i < len; i++) + str[i] = tolower (str[i]); + + if (str == "defaults") + octave_sparse_params::defaults (); + else if (str == "tight") + octave_sparse_params::tight (); + else + { + double val = octave_sparse_params::get_key (str); + if (xisnan (val)) + error ("spparms: KEY not recognized"); + else + retval(0) = val; + } + } + else + { + NDArray vals = args(0).array_value (); + + if (error_state) + error ("spparms: input must be a string or a vector"); + else if (vals.numel () > OCTAVE_SPARSE_CONTROLS_SIZE) + error ("spparms: too many elements in vector VALS"); + else + octave_sparse_params::set_vals (vals); + } + } + else if (nargin == 2) + { + if (args(0).is_string ()) + { + std::string str = args(0).string_value (); + + double val = args(1).double_value (); + + if (error_state) + error ("spparms: second argument must be a real scalar"); + else if (str == "umfpack") + warning ("spparms: request to disable umfpack solvers ignored"); + else if (!octave_sparse_params::set_key (str, val)) + error ("spparms: KEY not found"); + } + else + error ("spparms: first argument must be a string"); + } + else + error ("spparms: too many input arguments"); + + return retval; +} + +/* +%!test +%! old_vals = spparms (); # save state +%! spparms ("defaults"); +%! vals = spparms (); +%! assert (vals, [0 1 1 0 3 3 0.5 1.0 1.0 0.1 0.5 1.0 0.001]'); +%! [keys, vals] = spparms (); +%! assert (rows (keys), 13); +%! assert (keys(2,:), "ths_rel"); +%! assert (vals, [0 1 1 0 3 3 0.5 1.0 1.0 0.1 0.5 1.0 0.001]'); +%! spparms ([3 2 1]); +%! assert (spparms ()(1:3), [3, 2, 1]'); +%! assert (spparms ("ths_rel"), 2); +%! spparms ("exact_d", 5); +%! assert (spparms ("exact_d"), 5); +%! spparms (old_vals); # restore state + +%% Test input validation +%!error <too many input arguments> spparms (1, 2, 3) +%!error <too many output arguments> [x, y, z] = spparms () +%!error <KEY not recognized> spparms ("UNKNOWN_KEY") +%!#error <input must be a string> spparms ({1, 2, 3}) +%!error spparms ({1, 2, 3}) +%!error <too many elements in vector VALS> spparms (ones (14, 1)) +%!error <first argument must be a string> spparms (1, 1) +%!#error <second argument must be a real scalar> spparms ("ths_rel", "hello") +%!error spparms ("ths_rel", "hello") +%!error <KEY not found> spparms ("UNKNOWN_KEY", 1) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/sqrtm.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,276 @@ +/* + +Copyright (C) 2001-2012 Ross Lippert and Paul Kienzle +Copyright (C) 2010 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <float.h> + +#include "CmplxSCHUR.h" +#include "fCmplxSCHUR.h" +#include "lo-ieee.h" +#include "lo-mappers.h" +#include "oct-norm.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "utils.h" +#include "xnorm.h" + +template <class Matrix> +static void +sqrtm_utri_inplace (Matrix& T) +{ + typedef typename Matrix::element_type element_type; + + const element_type zero = element_type (); + + bool singular = false; + + // The following code is equivalent to this triple loop: + // + // n = rows (T); + // for j = 1:n + // T(j,j) = sqrt (T(j,j)); + // for i = j-1:-1:1 + // T(i,j) /= (T(i,i) + T(j,j)); + // k = 1:i-1; + // T(k,j) -= T(k,i) * T(i,j); + // endfor + // endfor + // + // this is an in-place, cache-aligned variant of the code + // given in Higham's paper. + + const octave_idx_type n = T.rows (); + element_type *Tp = T.fortran_vec (); + for (octave_idx_type j = 0; j < n; j++) + { + element_type *colj = Tp + n*j; + if (colj[j] != zero) + colj[j] = sqrt (colj[j]); + else + singular = true; + + for (octave_idx_type i = j-1; i >= 0; i--) + { + const element_type *coli = Tp + n*i; + const element_type colji = colj[i] /= (coli[i] + colj[j]); + for (octave_idx_type k = 0; k < i; k++) + colj[k] -= coli[k] * colji; + } + } + + if (singular) + warning_with_id ("Octave:sqrtm:SingularMatrix", + "sqrtm: matrix is singular, may not have a square root"); +} + +template <class Matrix, class ComplexMatrix, class ComplexSCHUR> +static octave_value +do_sqrtm (const octave_value& arg) +{ + + octave_value retval; + + MatrixType mt = arg.matrix_type (); + + bool iscomplex = arg.is_complex_type (); + + typedef typename Matrix::element_type real_type; + + real_type cutoff = 0, one = 1; + real_type eps = std::numeric_limits<real_type>::epsilon (); + + if (! iscomplex) + { + Matrix x = octave_value_extract<Matrix> (arg); + + if (mt.is_unknown ()) // if type is not known, compute it now. + arg.matrix_type (mt = MatrixType (x)); + + switch (mt.type ()) + { + case MatrixType::Upper: + case MatrixType::Diagonal: + if (! x.diag ().any_element_is_negative ()) + { + // Do it in real arithmetic. + sqrtm_utri_inplace (x); + retval = x; + retval.matrix_type (mt); + } + else + iscomplex = true; + break; + + case MatrixType::Lower: + if (! x.diag ().any_element_is_negative ()) + { + x = x.transpose (); + sqrtm_utri_inplace (x); + retval = x.transpose (); + retval.matrix_type (mt); + } + else + iscomplex = true; + break; + + default: + iscomplex = true; + break; + } + + if (iscomplex) + cutoff = 10 * x.rows () * eps * xnorm (x, one); + } + + if (iscomplex) + { + ComplexMatrix x = octave_value_extract<ComplexMatrix> (arg); + + if (mt.is_unknown ()) // if type is not known, compute it now. + arg.matrix_type (mt = MatrixType (x)); + + switch (mt.type ()) + { + case MatrixType::Upper: + case MatrixType::Diagonal: + sqrtm_utri_inplace (x); + retval = x; + retval.matrix_type (mt); + break; + + case MatrixType::Lower: + x = x.transpose (); + sqrtm_utri_inplace (x); + retval = x.transpose (); + retval.matrix_type (mt); + break; + + default: + { + ComplexMatrix u; + + do + { + ComplexSCHUR schur (x, std::string (), true); + x = schur.schur_matrix (); + u = schur.unitary_matrix (); + } + while (0); // schur no longer needed. + + sqrtm_utri_inplace (x); + + x = u * x; // original x no longer needed. + ComplexMatrix res = xgemm (x, u, blas_no_trans, blas_conj_trans); + + if (cutoff > 0 && xnorm (imag (res), one) <= cutoff) + retval = real (res); + else + retval = res; + } + break; + } + } + + return retval; +} + +DEFUN (sqrtm, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{s} =} sqrtm (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{s}, @var{error_estimate}] =} sqrtm (@var{A})\n\ +Compute the matrix square root of the square matrix @var{A}.\n\ +\n\ +Ref: N.J. Higham. @cite{A New sqrtm for @sc{matlab}}. Numerical\n\ +Analysis Report No. 336, Manchester @nospell{Centre} for Computational\n\ +Mathematics, Manchester, England, January 1999.\n\ +@seealso{expm, logm}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin != 1) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + + octave_idx_type n = arg.rows (); + octave_idx_type nc = arg.columns (); + + if (n != nc || arg.ndims () > 2) + { + gripe_square_matrix_required ("sqrtm"); + return retval; + } + + if (nargout > 1) + { + retval.resize (1, 2); + retval(2) = -1.0; + } + + if (arg.is_diag_matrix ()) + // sqrtm of a diagonal matrix is just sqrt. + retval(0) = arg.sqrt (); + else if (arg.is_single_type ()) + retval(0) = do_sqrtm<FloatMatrix, FloatComplexMatrix, FloatComplexSCHUR> (arg); + else if (arg.is_numeric_type ()) + retval(0) = do_sqrtm<Matrix, ComplexMatrix, ComplexSCHUR> (arg); + + if (nargout > 1 && ! error_state) + { + // This corresponds to generic code + // + // norm (s*s - x, "fro") / norm (x, "fro"); + + octave_value s = retval(0); + retval(1) = xfrobnorm (s*s - arg) / xfrobnorm (arg); + } + + return retval; +} + +/* +%!assert (sqrtm (2*ones (2)), ones (2), 3*eps) + +## The following two tests are from the reference in the docstring above. +%!test +%! x = [0 1; 0 0]; +%! assert (any (isnan (sqrtm (x))(:))); + +%!test +%! x = eye (4); x(2,2) = x(3,3) = 2^-26; x(1,4) = 1; +%! z = eye (4); z(2,2) = z(3,3) = 2^-13; z(1,4) = 0.5; +%! [y, err] = sqrtm (x); +%! assert (y, z); +%! assert (err, 0); ## Yes, this one has to hold exactly +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/str2double.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,406 @@ +/* + +Copyright (C) 2010-2012 Jaroslav Hajek +Copyright (C) 2010 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> +#include <cctype> +#include <sstream> +#include <algorithm> + +#include "lo-ieee.h" + +#include "Cell.h" +#include "ov.h" +#include "defun.h" +#include "gripes.h" +#include "utils.h" + +static inline bool +is_imag_unit (int c) +{ return c == 'i' || c == 'j'; } + +static std::istringstream& +single_num (std::istringstream& is, double& num) +{ + char c = is.peek (); + + // Skip spaces. + while (isspace (c)) + { + is.get (); + c = is.peek (); + } + + if (std::toupper (c) == 'I') + { + // It's infinity. + is.get (); + char c1 = is.get (), c2 = is.get (); + if (std::tolower (c1) == 'n' && std::tolower (c2) == 'f') + { + num = octave_Inf; + is.peek (); // May set EOF bit. + } + else + is.setstate (std::ios::failbit); // indicate that read has failed. + } + else if (c == 'N') + { + // It's NA or NaN + is.get (); + char c1 = is.get (); + if (c1 == 'A') + { + num = octave_NA; + is.peek (); // May set EOF bit. + } + else + { + char c2 = is.get (); + if (c1 == 'a' && c2 == 'N') + { + num = octave_NaN; + is.peek (); // May set EOF bit. + } + else + is.setstate (std::ios::failbit); // indicate that read has failed. + } + } + else + is >> num; + + return is; +} + +static std::istringstream& +extract_num (std::istringstream& is, double& num, bool& imag, bool& have_sign) +{ + have_sign = imag = false; + + char c = is.peek (); + + // Skip leading spaces. + while (isspace (c)) + { + is.get (); + c = is.peek (); + } + + bool negative = false; + + // Accept leading sign. + if (c == '+' || c == '-') + { + negative = c == '-'; + is.get (); + c = is.peek (); + have_sign = true; + } + + // Skip spaces after sign. + while (isspace (c)) + { + is.get (); + c = is.peek (); + } + + // Imaginary number (i*num or just i), or maybe 'inf'. + if (c == 'i') + { + // possible infinity. + is.get (); + c = is.peek (); + + if (is.eof ()) + { + // just 'i' and string is finished. Return immediately. + imag = true; + num = 1.0; + if (negative) + num = -num; + return is; + } + else + { + if (std::tolower (c) != 'n') + imag = true; + is.unget (); + } + } + else if (c == 'j') + imag = true; + + // It's i*num or just i + if (imag) + { + is.get (); + c = is.peek (); + // Skip spaces after imaginary unit. + while (isspace (c)) + { + is.get (); + c = is.peek (); + } + + if (c == '*') + { + // Multiplier follows, we extract it as a number. + is.get (); + single_num (is, num); + if (is.good ()) + c = is.peek (); + } + else + num = 1.0; + } + else + { + // It's num, num*i, or numi. + single_num (is, num); + if (is.good ()) + { + c = is.peek (); + + // Skip spaces after number. + while (isspace (c)) + { + is.get (); + c = is.peek (); + } + + if (c == '*') + { + is.get (); + c = is.peek (); + + // Skip spaces after operator. + while (isspace (c)) + { + is.get (); + c = is.peek (); + } + + if (is_imag_unit (c)) + { + imag = true; + is.get (); + c = is.peek (); + } + else + is.setstate (std::ios::failbit); // indicate that read has failed. + } + else if (is_imag_unit (c)) + { + imag = true; + is.get (); + c = is.peek (); + } + } + } + + if (is.good ()) + { + // Skip trailing spaces. + while (isspace (c)) + { + is.get (); + c = is.peek (); + } + } + + if (negative) + num = -num; + + return is; +} + +static inline void +set_component (Complex& c, double num, bool imag) +{ +#if defined (HAVE_CXX_COMPLEX_SETTERS) + if (imag) + c.imag (num); + else + c.real (num); +#elif defined (HAVE_CXX_COMPLEX_REFERENCE_ACCESSORS) + if (imag) + c.imag () = num; + else + c.real () = num; +#else + if (imag) + c = Complex (c.real (), num); + else + c = Complex (num, c.imag ()); +#endif +} + +static Complex +str2double1 (const std::string& str_arg) +{ + Complex val (0.0, 0.0); + + std::string str = str_arg; + + // FIXME -- removing all commas does too much... + std::string::iterator se = str.end (); + se = std::remove (str.begin (), se, ','); + str.erase (se, str.end ()); + std::istringstream is (str); + + double num; + bool i1, i2, s1, s2; + + if (is.eof ()) + val = octave_NaN; + else if (! extract_num (is, num, i1, s1)) + val = octave_NaN; + else + { + set_component (val, num, i1); + + if (! is.eof ()) + { + if (! extract_num (is, num, i2, s2) || i1 == i2 || ! s2) + val = octave_NaN; + else + set_component (val, num, i2); + } + } + + return val; +} + +DEFUN (str2double, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} str2double (@var{s})\n\ +Convert a string to a real or complex number.\n\ +\n\ +The string must be in one of the following formats where\n\ +a and b are real numbers and the complex unit is 'i' or 'j':\n\ +\n\ +@itemize\n\ +@item a + bi\n\ +\n\ +@item a + b*i\n\ +\n\ +@item a + i*b\n\ +\n\ +@item bi + a\n\ +\n\ +@item b*i + a\n\ +\n\ +@item i*b + a\n\ +@end itemize\n\ +\n\ +If present, a and/or b are of the form @nospell{[+-]d[,.]d[[eE][+-]d]} where\n\ +the brackets indicate optional arguments and 'd' indicates zero or more\n\ +digits. The special input values @code{Inf}, @code{NaN}, and @code{NA} are\n\ +also accepted.\n\ +\n\ +@var{s} may also be a character matrix, in which case the conversion is\n\ +repeated for each row. Or @var{s} may be a cell array of strings, in which\n\ +case each element is converted and an array of the same dimensions is\n\ +returned.\n\ +\n\ +@code{str2double} returns NaN for elements of @var{s} which cannot be\n\ +converted.\n\ +\n\ +@code{str2double} can replace @code{str2num}, and it avoids the security\n\ +risk of using @code{eval} on unknown data.\n\ +@seealso{str2num}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () != 1) + print_usage (); + else if (args(0).is_string ()) + { + if (args(0).rows () == 1 && args(0).ndims () == 2) + { + retval = str2double1 (args(0).string_value ()); + } + else + { + const string_vector sv = args(0).all_strings (); + if (! error_state) + retval = sv.map<Complex> (str2double1); + } + } + else if (args(0).is_cell ()) + { + const Cell cell = args(0).cell_value (); + + if (! error_state) + { + ComplexNDArray output (cell.dims (), octave_NaN); + for (octave_idx_type i = 0; i < cell.numel (); i++) + { + if (cell(i).is_string ()) + output(i) = str2double1 (cell(i).string_value ()); + } + retval = output; + } + } + else + retval = NDArray (args(0).dims (), octave_NaN); + + + return retval; +} + +/* +%!assert (str2double ("1"), 1) +%!assert (str2double ("-.1e-5"), -1e-6) +%!assert (str2double (char ("1", "2 3", "4i")), [1; NaN; 4i]) +%!assert (str2double ("-.1e-5"), -1e-6) +%!assert (str2double ("1,222.5"), 1222.5) +%!assert (str2double ("i"), i) +%!assert (str2double ("2j"), 2i) +%!assert (str2double ("2 + j"), 2+j) +%!assert (str2double ("i*2 + 3"), 3+2i) +%!assert (str2double (".5*i + 3.5"), 3.5+0.5i) +%!assert (str2double ("1e-3 + i*.25"), 1e-3 + 0.25i) +%!assert (str2double (["2 + j";"1.25e-3";"-05"]), [2+i; 1.25e-3; -5]) +%!assert (str2double ({"2 + j","1.25e-3","-05"}), [2+i, 1.25e-3, -5]) +%!assert (str2double (1), NaN) +%!assert (str2double ("1 2 3 4"), NaN) +%!assert (str2double ("Hello World"), NaN) +%!assert (str2double ("NaN"), NaN) +%!assert (str2double ("NA"), NA) +%!assert (str2double ("Inf"), Inf) +%!assert (str2double ("iNF"), Inf) +%!assert (str2double ("-Inf"), -Inf) +%!assert (str2double ("Inf*i"), complex (0, Inf)) +%!assert (str2double ("iNF*i"), complex (0, Inf)) +%!assert (str2double ("NaN + Inf*i"), complex (NaN, Inf)) +%!assert (str2double ("Inf - Inf*i"), complex (Inf, -Inf)) +%!assert (str2double ("-i*NaN - Inf"), complex (-Inf, -NaN)) +%!assert (str2double ({"abc", "4i"}), [NaN + 0i, 4i]) +%!assert (str2double ({2, "4i"}), [NaN + 0i, 4i]) +%!assert (str2double (zeros (3,1,2)), NaN (3,1,2)) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/strfind.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,415 @@ +/* + +Copyright (C) 2009-2012 Jaroslav Hajek +Copyright (C) 2009-2010 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> +#include <climits> +#include <algorithm> +#include <deque> + +#include "Cell.h" +#include "ov.h" +#include "defun.h" +#include "unwind-prot.h" +#include "gripes.h" +#include "utils.h" + +// This allows safe indexing with char. In C++, char may be (and often is) signed! +#define ORD(ch) static_cast<unsigned char>(ch) +#define TABSIZE (UCHAR_MAX + 1) + +// This is the quick search algorithm, as described at +// http://www-igm.univ-mlv.fr/~lecroq/string/node19.html +static void +qs_preprocess (const Array<char>& needle, + octave_idx_type table[TABSIZE]) +{ + const char *x = needle.data (); + octave_idx_type m = needle.numel (); + + for (octave_idx_type i = 0; i < TABSIZE; i++) + table[i] = m + 1; + for (octave_idx_type i = 0; i < m; i++) + table[ORD(x[i])] = m - i; +} + + +static Array<octave_idx_type> +qs_search (const Array<char>& needle, + const Array<char>& haystack, + const octave_idx_type table[TABSIZE], + bool overlaps = true) +{ + const char *x = needle.data (); + octave_idx_type m = needle.numel (); + const char *y = haystack.data (); + octave_idx_type n = haystack.numel (); + + // We'll use deque because it typically has the most favorable properties for + // the operation we need. + std::deque<octave_idx_type> accum; + if (m == 1) + { + // Looking for a single character. + for (octave_idx_type i = 0; i < n; i++) + { + if (y[i] == x[0]) + accum.push_back (i); + } + } + else if (m == 2) + { + // Two characters. + if (overlaps) + { + for (octave_idx_type i = 0; i < n-1; i++) + { + if (y[i] == x[0] && y[i+1] == x[1]) + accum.push_back (i); + } + } + else + { + for (octave_idx_type i = 0; i < n-1; i++) + { + if (y[i] == x[0] && y[i+1] == x[1]) + accum.push_back (i++); + } + } + } + else if (n >= m) + { + // General case. + octave_idx_type j = 0; + + if (overlaps) + { + while (j < n - m) + { + if (std::equal (x, x + m, y + j)) + accum.push_back (j); + j += table[ORD(y[j + m])]; + } + } + else + { + while (j < n - m) + { + if (std::equal (x, x + m, y + j)) + { + accum.push_back (j); + j += m; + } + else + j += table[ORD(y[j + m])]; + } + } + + if (j == n - m && std::equal (x, x + m, y + j)) + accum.push_back (j); + } + + octave_idx_type nmatch = accum.size (); + octave_idx_type one = 1; + Array<octave_idx_type> result (dim_vector (std::min (one, nmatch), nmatch)); + octave_idx_type k = 0; + for (std::deque<octave_idx_type>::const_iterator iter = accum.begin (); + iter != accum.end (); iter++) + { + result.xelem (k++) = *iter; + } + + return result; +} + +DEFUN (strfind, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{idx} =} strfind (@var{str}, @var{pattern})\n\ +@deftypefnx {Built-in Function} {@var{idx} =} strfind (@var{cellstr}, @var{pattern})\n\ +Search for @var{pattern} in the string @var{str} and return the\n\ +starting index of every such occurrence in the vector @var{idx}.\n\ +If there is no such occurrence, or if @var{pattern} is longer\n\ +than @var{str}, then @var{idx} is the empty array @code{[]}.\n\ +\n\ +If a cell array of strings @var{cellstr} is specified\n\ +then @var{idx} is a cell array of vectors, as specified\n\ +above. Examples:\n\ +\n\ +@example\n\ +@group\n\ +strfind (\"abababa\", \"aba\")\n\ + @result{} [1, 3, 5]\n\ +\n\ +strfind (@{\"abababa\", \"bebebe\", \"ab\"@}, \"aba\")\n\ + @result{}\n\ + @{\n\ + [1,1] =\n\ +\n\ + 1 3 5\n\ +\n\ + [1,2] = [](1x0)\n\ + [1,3] = [](1x0)\n\ + @}\n\ +@end group\n\ +@end example\n\ +@seealso{findstr, strmatch, regexp, regexpi, find}\n\ +@end deftypefn") +{ + octave_value retval; + int nargin = args.length (); + bool overlaps = true; + + if (nargin == 4 && args(2).is_string () && args(3).is_scalar_type ()) + { + std::string opt = args(2).string_value (); + if (opt == "overlaps") + { + overlaps = args(3).bool_value (); + nargin = 2; + } + else + { + error ("strfind: unknown option: %s", opt.c_str ()); + return retval; + } + } + + if (nargin == 2) + { + octave_value argstr = args(0), argpat = args(1); + if (argpat.is_string ()) + { + Array<char> needle = argpat.char_array_value (); + OCTAVE_LOCAL_BUFFER (octave_idx_type, table, TABSIZE); + qs_preprocess (needle, table); + + if (argstr.is_string ()) + retval = octave_value (qs_search (needle, argstr.char_array_value (), + table, overlaps), + true, true); + else if (argstr.is_cell ()) + { + const Cell argsc = argstr.cell_value (); + Cell retc (argsc.dims ()); + octave_idx_type ns = argsc.numel (); + + for (octave_idx_type i = 0; i < ns; i++) + { + octave_value argse = argsc(i); + if (argse.is_string ()) + retc(i) = octave_value (qs_search (needle, argse.char_array_value (), + table, overlaps), + true, true); + else + { + error ("strfind: each element of CELLSTR must be a string"); + break; + } + } + + retval = retc; + } + else + error ("strfind: first argument must be a string or cell array of strings"); + } + else if (argpat.is_cell ()) + retval = do_simple_cellfun (Fstrfind, "strfind", args); + else + error ("strfind: PATTERN must be a string or cell array of strings"); + } + else + print_usage (); + + return retval; +} + +/* +%!assert (strfind ("abababa", "aba"), [1, 3, 5]) +%!assert (strfind ("abababa", "aba", "overlaps", false), [1, 5]) +%!assert (strfind ({"abababa", "bla", "bla"}, "a"), {[1, 3, 5, 7], 3, 3}) +%!assert (strfind ("Linux _is_ user-friendly. It just isn't ignorant-friendly or idiot-friendly.", "friendly"), [17, 50, 68]) + +%!error strfind () +%!error strfind ("foo", "bar", 1) +%!error <PATTERN must be a string> strfind ("foo", 100) +%!error <first argument must be a string> strfind (100, "foo") +*/ + +static Array<char> +qs_replace (const Array<char>& str, const Array<char>& pat, + const Array<char>& rep, + const octave_idx_type table[TABSIZE], + bool overlaps = true) +{ + Array<char> ret = str; + + octave_idx_type siz = str.numel (), psiz = pat.numel (), rsiz = rep.numel (); + + if (psiz != 0) + { + // Look up matches, without overlaps. + const Array<octave_idx_type> idx = qs_search (pat, str, table, overlaps); + octave_idx_type nidx = idx.numel (); + + if (nidx) + { + // Compute result size. + octave_idx_type retsiz; + if (overlaps) + { + retsiz = 0; + // OMG. Is this the "right answer" MW always looks for, or + // someone was just lazy? + octave_idx_type k = 0; + for (octave_idx_type i = 0; i < nidx; i++) + { + octave_idx_type j = idx(i); + if (j >= k) + retsiz += j - k; + retsiz += rsiz; + k = j + psiz; + } + + retsiz += siz - k; + } + else + retsiz = siz + nidx * (rsiz - psiz); + + ret.clear (dim_vector (1, retsiz)); + const char *src = str.data (), *reps = rep.data (); + char *dest = ret.fortran_vec (); + + octave_idx_type k = 0; + for (octave_idx_type i = 0; i < nidx; i++) + { + octave_idx_type j = idx(i); + if (j >= k) + dest = std::copy (src + k, src + j, dest); + dest = std::copy (reps, reps + rsiz, dest); + k = j + psiz; + } + + std::copy (src + k, src + siz, dest); + } + } + + return ret; +} + +DEFUN (strrep, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} strrep (@var{s}, @var{ptn}, @var{rep})\n\ +@deftypefnx {Built-in Function} {} strrep (@var{s}, @var{ptn}, @var{rep}, \"overlaps\", @var{o})\n\ +Replace all occurrences of the substring @var{ptn} in the string @var{s}\n\ +with the string @var{rep} and return the result. For example:\n\ +\n\ +@example\n\ +@group\n\ +strrep (\"This is a test string\", \"is\", \"&%$\")\n\ + @result{} \"Th&%$ &%$ a test string\"\n\ +@end group\n\ +@end example\n\ +\n\ +@var{s} may also be a cell array of strings, in which case the replacement is\n\ +done for each element and a cell array is returned.\n\ +@seealso{regexprep, strfind, findstr}\n\ +@end deftypefn") +{ + octave_value retval; + int nargin = args.length (); + bool overlaps = true; + + if (nargin == 5 && args(3).is_string () && args(4).is_scalar_type ()) + { + std::string opt = args(3).string_value (); + if (opt == "overlaps") + { + overlaps = args(4).bool_value (); + nargin = 3; + } + else + { + error ("strrep: unknown option: %s", opt.c_str ()); + return retval; + } + } + + if (nargin == 3) + { + octave_value argstr = args(0), argpat = args(1), argrep = args(2); + if (argpat.is_string () && argrep.is_string ()) + { + const Array<char> pat = argpat.char_array_value (); + const Array<char> rep = argrep.char_array_value (); + + OCTAVE_LOCAL_BUFFER (octave_idx_type, table, TABSIZE); + qs_preprocess (pat, table); + + if (argstr.is_string ()) + retval = qs_replace (argstr.char_array_value (), pat, rep, table, overlaps); + else if (argstr.is_cell ()) + { + const Cell argsc = argstr.cell_value (); + Cell retc (argsc.dims ()); + octave_idx_type ns = argsc.numel (); + + for (octave_idx_type i = 0; i < ns; i++) + { + octave_value argse = argsc(i); + if (argse.is_string ()) + retc(i) = qs_replace (argse.char_array_value (), pat, rep, table, overlaps); + else + { + error ("strrep: each element of S must be a string"); + break; + } + } + + retval = retc; + } + else + error ("strrep: S must be a string or cell array of strings"); + } + else if (argpat.is_cell () || argrep.is_cell ()) + retval = do_simple_cellfun (Fstrrep, "strrep", args); + else + error ("strrep: PTN and REP arguments must be strings or cell arrays of strings"); + } + else + print_usage (); + + return retval; +} + +/* +%!assert (strrep ("This is a test string", "is", "&%$"), +%! "Th&%$ &%$ a test string") +%!assert (strrep ("abababc", "abab", "xyz"), "xyzxyzc") +%!assert (strrep ("abababc", "abab", "xyz", "overlaps", false), "xyzabc") + +%!error strrep () +%!error strrep ("foo", "bar", 3, 4) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/sub2ind.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,209 @@ +/* + +Copyright (C) 2009-2012 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "quit.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" + + +static dim_vector +get_dim_vector (const octave_value& val, const char *name) +{ + RowVector dimsv = val.row_vector_value (false, true); + dim_vector dv; + octave_idx_type n = dimsv.length (); + + if (n < 1) + error ("%s: dimension vector DIMS must not be empty", name); + else + { + dv.resize (std::max (n, static_cast<octave_idx_type> (2))); + dv(1) = 1; + for (octave_idx_type i = 0; i < n; i++) + { + octave_idx_type ii = dimsv(i); + if (ii == dimsv(i) && ii >= 0) + dv(i) = ii; + else + { + error ("%s: dimension vector DIMS must contain integers", name); + break; + } + } + } + + return dv; +} + +DEFUN (sub2ind, args, , + "-*- texinfo -*-\n\ +@deftypefn {Function File} {@var{ind} =} sub2ind (@var{dims}, @var{i}, @var{j})\n\ +@deftypefnx {Function File} {@var{ind} =} sub2ind (@var{dims}, @var{s1}, @var{s2}, @dots{}, @var{sN})\n\ +Convert subscripts to a linear index.\n\ +\n\ +The following example shows how to convert the two-dimensional\n\ +index @code{(2,3)} of a 3-by-3 matrix to a linear index. The matrix\n\ +is linearly indexed moving from one column to next, filling up\n\ +all rows in each column.\n\ +\n\ +@example\n\ +@group\n\ +linear_index = sub2ind ([3, 3], 2, 3)\n\ +@result{} 8\n\ +@end group\n\ +@end example\n\ +@seealso{ind2sub}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value retval; + + if (nargin < 2) + print_usage (); + else + { + dim_vector dv = get_dim_vector (args(0), "sub2ind"); + Array<idx_vector> idxa (dim_vector (nargin-1, 1)); + + if (! error_state) + { + dv = dv.redim (nargin - 1); + for (int j = 0; j < nargin - 1; j++) + { + if (args(j+1).is_numeric_type ()) + { + idxa(j) = args(j+1).index_vector (); + if (error_state) + break; + else if (j > 0 && args(j+1).dims () != args(1).dims ()) + error ("sub2ind: all subscripts must be of the same size"); + } + else + error ("sub2ind: subscripts must be numeric"); + + if (error_state) + break; + } + } + + if (! error_state) + { + idx_vector idx = sub2ind (dv, idxa); + retval = idx; + } + } + + return retval; +} + +/* +## Test evaluation +%!test +%! s1 = [ 1 1 1 1 ; 2 2 2 2 ]; +%! s2 = [ 1 1 2 2 ; 1 1 2 2 ]; +%! s3 = [ 1 2 1 2 ; 1 2 1 2 ]; +%! in = [ 1 101 11 111 ; 2 102 12 112 ]; +%! assert (sub2ind ([10 10 10], s1, s2, s3), in); + +# Test low index +%!assert (sub2ind ([10 10 10], 1, 1, 1), 1) +%!error <subscript indices> sub2ind ([10 10 10], 0, 1, 1) +%!error <subscript indices> sub2ind ([10 10 10], 1, 0, 1) +%!error <subscript indices> sub2ind ([10 10 10], 1, 1, 0) + +# Test high index +%!assert (sub2ind ([10 10 10], 10, 10, 10), 1000) +%!error <index out of range> sub2ind ([10 10 10], 11, 10, 10) +%!error <index out of range> sub2ind ([10 10 10], 10, 11, 10) +%!error <index out of range> sub2ind ([10 10 10], 10, 10, 11) + +# Test high index in the trailing dimensions +%!assert (sub2ind ([10, 1], 2, 1, 1), 2) +%!error <index out of range> sub2ind ([10, 1], 1, 2, 1) +%!error <index out of range> sub2ind ([10, 1], 1, 1, 2) +%!assert (sub2ind ([10 10], 2, 2, 1), 12) +%!error <index out of range> sub2ind ([10 10], 2, 1, 2) +%!error <index out of range> sub2ind ([10 10], 1, 2, 2) + +# Test handling of empty arguments +%!assert (sub2ind ([10 10], zeros (0,0), zeros (0,0)), zeros (0,0)) +%!assert (sub2ind ([10 10], zeros (2,0), zeros (2,0)), zeros (2,0)) +%!assert (sub2ind ([10 10], zeros (0,2), zeros (0,2)), zeros (0,2)) +%!error <all subscripts .* same size> sub2ind ([10 10 10], zeros (0,2), zeros (2,0)) + +# Test handling of arguments of different size +%!error <all subscripts .* same size> sub2ind ([10 10], ones (1,2), ones (1,3)) +%!error <all subscripts .* same size> sub2ind ([10 10], ones (1,2), ones (2,1)) + +## Test input validation +%!error <dimension vector> sub2ind ([10 10.5], 1, 1) +%!error <subscript indices> sub2ind ([10 10], 1.5, 1) +%!error <subscript indices> sub2ind ([10 10], 1, 1.5) +*/ + +DEFUN (ind2sub, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Function File} {[@var{s1}, @var{s2}, @dots{}, @var{sN}] =} ind2sub (@var{dims}, @var{ind})\n\ +Convert a linear index to subscripts.\n\ +\n\ +The following example shows how to convert the linear index @code{8}\n\ +in a 3-by-3 matrix into a subscript. The matrix is linearly indexed\n\ +moving from one column to next, filling up all rows in each column.\n\ +\n\ +@example\n\ +@group\n\ +[r, c] = ind2sub ([3, 3], 8)\n\ + @result{} r = 2\n\ + @result{} c = 3\n\ +@end group\n\ +@end example\n\ +@seealso{sub2ind}\n\ +@end deftypefn") +{ + int nargin = args.length (); + octave_value_list retval; + + if (nargin != 2) + print_usage (); + else + { + dim_vector dv = get_dim_vector (args(0), "ind2sub"); + idx_vector idx = args(1).index_vector (); + if (! error_state) + { + if (nargout > dv.length ()) + dv = dv.redim (nargout); + + Array<idx_vector> idxa = ind2sub (dv, idx); + retval = Array<octave_value> (idxa); + } + } + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/svd.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,423 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "CmplxSVD.h" +#include "dbleSVD.h" +#include "fCmplxSVD.h" +#include "floatSVD.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "pr-output.h" +#include "utils.h" +#include "variables.h" + +static int Vsvd_driver = SVD::GESVD; + +DEFUN (svd, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{s} =} svd (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{U}, @var{S}, @var{V}] =} svd (@var{A})\n\ +@deftypefnx {Built-in Function} {[@var{U}, @var{S}, @var{V}] =} svd (@var{A}, @var{econ})\n\ +@cindex singular value decomposition\n\ +Compute the singular value decomposition of @var{A}\n\ +@tex\n\ +$$\n\ + A = U S V^{\\dagger}\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +A = U*S*V'\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +\n\ +The function @code{svd} normally returns only the vector of singular values.\n\ +When called with three return values, it computes\n\ +@tex\n\ +$U$, $S$, and $V$.\n\ +@end tex\n\ +@ifnottex\n\ +@var{U}, @var{S}, and @var{V}.\n\ +@end ifnottex\n\ +For example,\n\ +\n\ +@example\n\ +svd (hilb (3))\n\ +@end example\n\ +\n\ +@noindent\n\ +returns\n\ +\n\ +@example\n\ +@group\n\ +ans =\n\ +\n\ + 1.4083189\n\ + 0.1223271\n\ + 0.0026873\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +and\n\ +\n\ +@example\n\ +[u, s, v] = svd (hilb (3))\n\ +@end example\n\ +\n\ +@noindent\n\ +returns\n\ +\n\ +@example\n\ +@group\n\ +u =\n\ +\n\ + -0.82704 0.54745 0.12766\n\ + -0.45986 -0.52829 -0.71375\n\ + -0.32330 -0.64901 0.68867\n\ +\n\ +s =\n\ +\n\ + 1.40832 0.00000 0.00000\n\ + 0.00000 0.12233 0.00000\n\ + 0.00000 0.00000 0.00269\n\ +\n\ +v =\n\ +\n\ + -0.82704 0.54745 0.12766\n\ + -0.45986 -0.52829 -0.71375\n\ + -0.32330 -0.64901 0.68867\n\ +@end group\n\ +@end example\n\ +\n\ +If given a second argument, @code{svd} returns an economy-sized\n\ +decomposition, eliminating the unnecessary rows or columns of @var{U} or\n\ +@var{V}.\n\ +@seealso{svd_driver, svds, eig}\n\ +@end deftypefn") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin < 1 || nargin > 2 || nargout == 2 || nargout > 3) + { + print_usage (); + return retval; + } + + octave_value arg = args(0); + + octave_idx_type nr = arg.rows (); + octave_idx_type nc = arg.columns (); + + if (arg.ndims () != 2) + { + error ("svd: A must be a 2-D matrix"); + return retval; + } + + bool isfloat = arg.is_single_type (); + + SVD::type type = ((nargout == 0 || nargout == 1) + ? SVD::sigma_only + : (nargin == 2) ? SVD::economy : SVD::std); + + SVD::driver driver = static_cast<SVD::driver> (Vsvd_driver); + + if (nr == 0 || nc == 0) + { + if (isfloat) + { + switch (type) + { + case SVD::std: + retval(2) = FloatDiagMatrix (nc, nc, 1.0f); + retval(1) = FloatMatrix (nr, nc); + retval(0) = FloatDiagMatrix (nr, nr, 1.0f); + break; + case SVD::economy: + retval(2) = FloatDiagMatrix (0, nc, 1.0f); + retval(1) = FloatMatrix (0, 0); + retval(0) = FloatDiagMatrix (nr, 0, 1.0f); + break; + case SVD::sigma_only: default: + retval(0) = FloatMatrix (0, 1); + break; + } + } + else + { + switch (type) + { + case SVD::std: + retval(2) = DiagMatrix (nc, nc, 1.0); + retval(1) = Matrix (nr, nc); + retval(0) = DiagMatrix (nr, nr, 1.0); + break; + case SVD::economy: + retval(2) = DiagMatrix (0, nc, 1.0); + retval(1) = Matrix (0, 0); + retval(0) = DiagMatrix (nr, 0, 1.0); + break; + case SVD::sigma_only: default: + retval(0) = Matrix (0, 1); + break; + } + } + } + else + { + if (isfloat) + { + if (arg.is_real_type ()) + { + FloatMatrix tmp = arg.float_matrix_value (); + + if (! error_state) + { + if (tmp.any_element_is_inf_or_nan ()) + { + error ("svd: cannot take SVD of matrix containing Inf or NaN values"); + return retval; + } + + FloatSVD result (tmp, type, driver); + + FloatDiagMatrix sigma = result.singular_values (); + + if (nargout == 0 || nargout == 1) + { + retval(0) = sigma.diag (); + } + else + { + retval(2) = result.right_singular_matrix (); + retval(1) = sigma; + retval(0) = result.left_singular_matrix (); + } + } + } + else if (arg.is_complex_type ()) + { + FloatComplexMatrix ctmp = arg.float_complex_matrix_value (); + + if (! error_state) + { + if (ctmp.any_element_is_inf_or_nan ()) + { + error ("svd: cannot take SVD of matrix containing Inf or NaN values"); + return retval; + } + + FloatComplexSVD result (ctmp, type, driver); + + FloatDiagMatrix sigma = result.singular_values (); + + if (nargout == 0 || nargout == 1) + { + retval(0) = sigma.diag (); + } + else + { + retval(2) = result.right_singular_matrix (); + retval(1) = sigma; + retval(0) = result.left_singular_matrix (); + } + } + } + } + else + { + if (arg.is_real_type ()) + { + Matrix tmp = arg.matrix_value (); + + if (! error_state) + { + if (tmp.any_element_is_inf_or_nan ()) + { + error ("svd: cannot take SVD of matrix containing Inf or NaN values"); + return retval; + } + + SVD result (tmp, type, driver); + + DiagMatrix sigma = result.singular_values (); + + if (nargout == 0 || nargout == 1) + { + retval(0) = sigma.diag (); + } + else + { + retval(2) = result.right_singular_matrix (); + retval(1) = sigma; + retval(0) = result.left_singular_matrix (); + } + } + } + else if (arg.is_complex_type ()) + { + ComplexMatrix ctmp = arg.complex_matrix_value (); + + if (! error_state) + { + if (ctmp.any_element_is_inf_or_nan ()) + { + error ("svd: cannot take SVD of matrix containing Inf or NaN values"); + return retval; + } + + ComplexSVD result (ctmp, type, driver); + + DiagMatrix sigma = result.singular_values (); + + if (nargout == 0 || nargout == 1) + { + retval(0) = sigma.diag (); + } + else + { + retval(2) = result.right_singular_matrix (); + retval(1) = sigma; + retval(0) = result.left_singular_matrix (); + } + } + } + else + { + gripe_wrong_type_arg ("svd", arg); + return retval; + } + } + } + + return retval; +} + +/* +%!assert (svd ([1, 2; 2, 1]), [3; 1], sqrt (eps)) + +%!test +%! [u, s, v] = svd ([1, 2; 2, 1]); +%! x = 1 / sqrt (2); +%! assert (u, [-x, -x; -x, x], sqrt (eps)); +%! assert (s, [3, 0; 0, 1], sqrt (eps)); +%! assert (v, [-x, x; -x, -x], sqrt (eps)); + +%!test +%! a = [1, 2, 3; 4, 5, 6]; +%! [u, s, v] = svd (a); +%! assert (u * s * v', a, sqrt (eps)); + +%!test +%! a = [1, 2; 3, 4; 5, 6]; +%! [u, s, v] = svd (a); +%! assert (u * s * v', a, sqrt (eps)); + +%!test +%! a = [1, 2, 3; 4, 5, 6]; +%! [u, s, v] = svd (a, 1); +%! assert (u * s * v', a, sqrt (eps)); + +%!test +%! a = [1, 2; 3, 4; 5, 6]; +%! [u, s, v] = svd (a, 1); +%! assert (u * s * v', a, sqrt (eps)); + +%!assert (svd (single ([1, 2; 2, 1])), single ([3; 1]), sqrt (eps ("single"))) + +%!test +%! [u, s, v] = svd (single ([1, 2; 2, 1])); +%! x = single (1 / sqrt (2)); +%! assert (u, [-x, -x; -x, x], sqrt (eps ("single"))); +%! assert (s, single ([3, 0; 0, 1]), sqrt (eps ("single"))); +%! assert (v, [-x, x; -x, -x], sqrt (eps ("single"))); + +%!test +%! a = single ([1, 2, 3; 4, 5, 6]); +%! [u, s, v] = svd (a); +%! assert (u * s * v', a, sqrt (eps ("single"))); + +%!test +%! a = single ([1, 2; 3, 4; 5, 6]); +%! [u, s, v] = svd (a); +%! assert (u * s * v', a, sqrt (eps ("single"))); + +%!test +%! a = single ([1, 2, 3; 4, 5, 6]); +%! [u, s, v] = svd (a, 1); +%! assert (u * s * v', a, sqrt (eps ("single"))); + +%!test +%! a = single ([1, 2; 3, 4; 5, 6]); +%! [u, s, v] = svd (a, 1); +%! assert (u * s * v', a, sqrt (eps ("single"))); + +%!test +%! a = zeros (0, 5); +%! [u, s, v] = svd (a); +%! assert (size (u), [0, 0]); +%! assert (size (s), [0, 5]); +%! assert (size (v), [5, 5]); + +%!test +%! a = zeros (5, 0); +%! [u, s, v] = svd (a, 1); +%! assert (size (u), [5, 0]); +%! assert (size (s), [0, 0]); +%! assert (size (v), [0, 0]); + +%!error svd () +%!error svd ([1, 2; 4, 5], 2, 3) +%!error [u, v] = svd ([1, 2; 3, 4]) +*/ + +DEFUN (svd_driver, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{val} =} svd_driver ()\n\ +@deftypefnx {Built-in Function} {@var{old_val} =} svd_driver (@var{new_val})\n\ +@deftypefnx {Built-in Function} {} svd_driver (@var{new_val}, \"local\")\n\ +Query or set the underlying @sc{lapack} driver used by @code{svd}.\n\ +Currently recognized values are \"gesvd\" and \"gesdd\". The default\n\ +is \"gesvd\".\n\ +\n\ +When called from inside a function with the \"local\" option, the variable is\n\ +changed locally for the function and any subroutines it calls. The original\n\ +variable value is restored when exiting the function.\n\ +@seealso{svd}\n\ +@end deftypefn") +{ + static const char *driver_names[] = { "gesvd", "gesdd", 0 }; + + return SET_INTERNAL_VARIABLE_CHOICES (svd_driver, driver_names); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/syl.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,218 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Author: A. S. Hodel <scotte@eng.auburn.edu> + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "utils.h" + +DEFUN (syl, args, nargout, + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{x} =} syl (@var{A}, @var{B}, @var{C})\n\ +Solve the Sylvester equation\n\ +@tex\n\ +$$\n\ + A X + X B + C = 0\n\ +$$\n\ +@end tex\n\ +@ifnottex\n\ +\n\ +@example\n\ +A X + X B + C = 0\n\ +@end example\n\ +\n\ +@end ifnottex\n\ +using standard @sc{lapack} subroutines. For example:\n\ +\n\ +@example\n\ +@group\n\ +syl ([1, 2; 3, 4], [5, 6; 7, 8], [9, 10; 11, 12])\n\ + @result{} [ -0.50000, -0.66667; -0.66667, -0.50000 ]\n\ +@end group\n\ +@end example\n\ +@end deftypefn") +{ + octave_value retval; + + int nargin = args.length (); + + if (nargin != 3 || nargout > 1) + { + print_usage (); + return retval; + } + + octave_value arg_a = args(0); + octave_value arg_b = args(1); + octave_value arg_c = args(2); + + octave_idx_type a_nr = arg_a.rows (); + octave_idx_type a_nc = arg_a.columns (); + + octave_idx_type b_nr = arg_b.rows (); + octave_idx_type b_nc = arg_b.columns (); + + octave_idx_type c_nr = arg_c.rows (); + octave_idx_type c_nc = arg_c.columns (); + + int arg_a_is_empty = empty_arg ("syl", a_nr, a_nc); + int arg_b_is_empty = empty_arg ("syl", b_nr, b_nc); + int arg_c_is_empty = empty_arg ("syl", c_nr, c_nc); + + bool isfloat = arg_a.is_single_type () || arg_b.is_single_type () || + arg_c.is_single_type (); + + if (arg_a_is_empty > 0 && arg_b_is_empty > 0 && arg_c_is_empty > 0) + if (isfloat) + return octave_value (FloatMatrix ()); + else + return octave_value (Matrix ()); + else if (arg_a_is_empty || arg_b_is_empty || arg_c_is_empty) + return retval; + + // Arguments are not empty, so check for correct dimensions. + + if (a_nr != a_nc || b_nr != b_nc) + { + gripe_square_matrix_required ("syl: first two parameters:"); + return retval; + } + else if (a_nr != c_nr || b_nr != c_nc) + { + gripe_nonconformant (); + return retval; + } + + // Dimensions look o.k., let's solve the problem. + if (isfloat) + { + if (arg_a.is_complex_type () + || arg_b.is_complex_type () + || arg_c.is_complex_type ()) + { + // Do everything in complex arithmetic; + + FloatComplexMatrix ca = arg_a.float_complex_matrix_value (); + + if (error_state) + return retval; + + FloatComplexMatrix cb = arg_b.float_complex_matrix_value (); + + if (error_state) + return retval; + + FloatComplexMatrix cc = arg_c.float_complex_matrix_value (); + + if (error_state) + return retval; + + retval = Sylvester (ca, cb, cc); + } + else + { + // Do everything in real arithmetic. + + FloatMatrix ca = arg_a.float_matrix_value (); + + if (error_state) + return retval; + + FloatMatrix cb = arg_b.float_matrix_value (); + + if (error_state) + return retval; + + FloatMatrix cc = arg_c.float_matrix_value (); + + if (error_state) + return retval; + + retval = Sylvester (ca, cb, cc); + } + } + else + { + if (arg_a.is_complex_type () + || arg_b.is_complex_type () + || arg_c.is_complex_type ()) + { + // Do everything in complex arithmetic; + + ComplexMatrix ca = arg_a.complex_matrix_value (); + + if (error_state) + return retval; + + ComplexMatrix cb = arg_b.complex_matrix_value (); + + if (error_state) + return retval; + + ComplexMatrix cc = arg_c.complex_matrix_value (); + + if (error_state) + return retval; + + retval = Sylvester (ca, cb, cc); + } + else + { + // Do everything in real arithmetic. + + Matrix ca = arg_a.matrix_value (); + + if (error_state) + return retval; + + Matrix cb = arg_b.matrix_value (); + + if (error_state) + return retval; + + Matrix cc = arg_c.matrix_value (); + + if (error_state) + return retval; + + retval = Sylvester (ca, cb, cc); + } + } + + return retval; +} + +/* +%!assert (syl ([1, 2; 3, 4], [5, 6; 7, 8], [9, 10; 11, 12]), [-1/2, -2/3; -2/3, -1/2], sqrt (eps)) +%!assert (syl (single ([1, 2; 3, 4]), single ([5, 6; 7, 8]), single ([9, 10; 11, 12])), single ([-1/2, -2/3; -2/3, -1/2]), sqrt (eps ("single"))) + +%!error syl () +%!error syl (1, 2, 3, 4) +%!error <must be a square matrix> syl ([1, 2; 3, 4], [1, 2, 3; 4, 5, 6], [4, 3]) +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/time.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,539 @@ +/* + +Copyright (C) 1996-2012 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <string> + +#include "defun.h" +#include "error.h" +#include "oct-map.h" +#include "oct-time.h" +#include "ov.h" +#include "oct-obj.h" + +// Date and time functions. + +static octave_scalar_map +mk_tm_map (const octave_base_tm& t) +{ + octave_scalar_map m; + + m.assign ("usec", static_cast<double> (t.usec ())); + m.assign ("sec", static_cast<double> (t.sec ())); + m.assign ("min", static_cast<double> (t.min ())); + m.assign ("hour", static_cast<double> (t.hour ())); + m.assign ("mday", static_cast<double> (t.mday ())); + m.assign ("mon", static_cast<double> (t.mon ())); + m.assign ("year", static_cast<double> (t.year ())); + m.assign ("wday", static_cast<double> (t.wday ())); + m.assign ("yday", static_cast<double> (t.yday ())); + m.assign ("isdst", static_cast<double> (t.isdst ())); + m.assign ("zone", t.zone ()); + + return m; +} + +static inline int +intfield (const octave_scalar_map& m, const std::string& k) +{ + int retval = 0; + + octave_value v = m.getfield (k); + + if (! v.is_empty ()) + retval = v.int_value (); + + return retval; +} + +static inline std::string +stringfield (const octave_scalar_map& m, const std::string& k) +{ + std::string retval; + + octave_value v = m.getfield (k); + + if (! v.is_empty ()) + retval = v.string_value (); + + return retval; +} + +static octave_base_tm +extract_tm (const octave_scalar_map& m) +{ + octave_base_tm tm; + + tm.usec (intfield (m, "usec")); + tm.sec (intfield (m, "sec")); + tm.min (intfield (m, "min")); + tm.hour (intfield (m, "hour")); + tm.mday (intfield (m, "mday")); + tm.mon (intfield (m, "mon")); + tm.year (intfield (m, "year")); + tm.wday (intfield (m, "wday")); + tm.yday (intfield (m, "yday")); + tm.isdst (intfield (m, "isdst")); + tm.zone (stringfield (m, "zone")); + + return tm; +} + +DEFUN (time, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{seconds} =} time ()\n\ +Return the current time as the number of seconds since the epoch. The\n\ +epoch is referenced to 00:00:00 CUT (Coordinated Universal Time) 1 Jan\n\ +1970. For example, on Monday February 17, 1997 at 07:15:06 CUT, the\n\ +value returned by @code{time} was 856163706.\n\ +@seealso{strftime, strptime, localtime, gmtime, mktime, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 0) + retval = octave_time (); + else + print_usage (); + + return retval; +} + +/* +%!assert (time () > 0) +*/ + +DEFUN (gmtime, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{tm_struct} =} gmtime (@var{t})\n\ +Given a value returned from @code{time}, or any non-negative integer,\n\ +return a time structure corresponding to CUT (Coordinated Universal Time).\n\ +For example:\n\ +\n\ +@example\n\ +@group\n\ +gmtime (time ())\n\ + @result{} @{\n\ + usec = 0\n\ + sec = 6\n\ + min = 15\n\ + hour = 7\n\ + mday = 17\n\ + mon = 1\n\ + year = 97\n\ + wday = 1\n\ + yday = 47\n\ + isdst = 0\n\ + zone = CST\n\ + @}\n\ +@end group\n\ +@end example\n\ +@seealso{strftime, strptime, localtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 1) + { + double tmp = args(0).double_value (); + + if (! error_state) + retval = octave_value (mk_tm_map (octave_gmtime (tmp))); + } + else + print_usage (); + + return retval; +} + +/* +%!test +%! ts = gmtime (time ()); +%! assert (isstruct (ts)); +%! assert (isfield (ts, "usec")); +%! assert (isfield (ts, "year")); +%! assert (isfield (ts, "mon")); +%! assert (isfield (ts, "mday")); +%! assert (isfield (ts, "sec")); +%! assert (isfield (ts, "min")); +%! assert (isfield (ts, "wday")); +%! assert (isfield (ts, "hour")); +%! assert (isfield (ts, "isdst")); +%! assert (isfield (ts, "yday")); + +%!error gmtime () +%!error gmtime (1, 2) +*/ + +DEFUN (localtime, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{tm_struct} =} localtime (@var{t})\n\ +Given a value returned from @code{time}, or any non-negative integer,\n\ +return a time structure corresponding to the local time zone.\n\ +\n\ +@example\n\ +@group\n\ +localtime (time ())\n\ + @result{} @{\n\ + usec = 0\n\ + sec = 6\n\ + min = 15\n\ + hour = 1\n\ + mday = 17\n\ + mon = 1\n\ + year = 97\n\ + wday = 1\n\ + yday = 47\n\ + isdst = 0\n\ + zone = CST\n\ + @}\n\ +@end group\n\ +@end example\n\ +@seealso{strftime, strptime, gmtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 1) + { + double tmp = args(0).double_value (); + + if (! error_state) + retval = octave_value (mk_tm_map (octave_localtime (tmp))); + } + else + print_usage (); + + return retval; +} + +/* +%!test +%! ts = localtime (time ()); +%! assert (isstruct (ts)); +%! assert (isfield (ts, "usec")); +%! assert (isfield (ts, "year")); +%! assert (isfield (ts, "mon")); +%! assert (isfield (ts, "mday")); +%! assert (isfield (ts, "sec")); +%! assert (isfield (ts, "min")); +%! assert (isfield (ts, "wday")); +%! assert (isfield (ts, "hour")); +%! assert (isfield (ts, "isdst")); +%! assert (isfield (ts, "yday")); + +%!error localtime () +%!error localtime (1, 2) +*/ + +DEFUN (mktime, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{seconds} =} mktime (@var{tm_struct})\n\ +Convert a time structure corresponding to the local time to the number\n\ +of seconds since the epoch. For example:\n\ +\n\ +@example\n\ +@group\n\ +mktime (localtime (time ()))\n\ + @result{} 856163706\n\ +@end group\n\ +@end example\n\ +@seealso{strftime, strptime, localtime, gmtime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 1) + { + octave_scalar_map map = args(0).scalar_map_value (); + + if (! error_state) + { + octave_base_tm tm = extract_tm (map); + + if (! error_state) + retval = octave_time (tm); + else + error ("mktime: invalid TM_STRUCT argument"); + } + else + error ("mktime: TM_STRUCT argument must be a structure"); + } + else + print_usage (); + + return retval; +} + +/* +%!test +%! t = time (); +%! assert (fix (mktime (localtime (t))) == fix (t)); + +## These tests fail on systems with mktime functions of limited +## intelligence: +%!assert (datestr (datenum (1969, 1, 1), 0), "01-Jan-1969 00:00:00") +%!assert (datestr (datenum (1901, 1, 1), 0), "01-Jan-1901 00:00:00") +%!assert (datestr (datenum (1795, 1, 1), 0), "01-Jan-1795 00:00:00") + +%!error mktime () +%!error mktime (1, 2, 3) +*/ + +DEFUN (strftime, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} strftime (@var{fmt}, @var{tm_struct})\n\ +Format the time structure @var{tm_struct} in a flexible way using the\n\ +format string @var{fmt} that contains @samp{%} substitutions\n\ +similar to those in @code{printf}. Except where noted, substituted\n\ +fields have a fixed size; numeric fields are padded if necessary.\n\ +Padding is with zeros by default; for fields that display a single\n\ +number, padding can be changed or inhibited by following the @samp{%}\n\ +with one of the modifiers described below. Unknown field specifiers are\n\ +copied as normal characters. All other characters are copied to the\n\ +output without change. For example:\n\ +\n\ +@example\n\ +@group\n\ +strftime (\"%r (%Z) %A %e %B %Y\", localtime (time ()))\n\ + @result{} \"01:15:06 AM (CST) Monday 17 February 1997\"\n\ +@end group\n\ +@end example\n\ +\n\ +Octave's @code{strftime} function supports a superset of the ANSI C\n\ +field specifiers.\n\ +\n\ +@noindent\n\ +Literal character fields:\n\ +\n\ +@table @code\n\ +@item %%\n\ +% character.\n\ +\n\ +@item %n\n\ +Newline character.\n\ +\n\ +@item %t\n\ +Tab character.\n\ +@end table\n\ +\n\ +@noindent\n\ +Numeric modifiers (a nonstandard extension):\n\ +\n\ +@table @code\n\ +@item - (dash)\n\ +Do not pad the field.\n\ +\n\ +@item _ (underscore)\n\ +Pad the field with spaces.\n\ +@end table\n\ +\n\ +@noindent\n\ +Time fields:\n\ +\n\ +@table @code\n\ +@item %H\n\ +Hour (00-23).\n\ +\n\ +@item %I\n\ +Hour (01-12).\n\ +\n\ +@item %k\n\ +Hour (0-23).\n\ +\n\ +@item %l\n\ +Hour (1-12).\n\ +\n\ +@item %M\n\ +Minute (00-59).\n\ +\n\ +@item %p\n\ +Locale's AM or PM.\n\ +\n\ +@item %r\n\ +Time, 12-hour (hh:mm:ss [AP]M).\n\ +\n\ +@item %R\n\ +Time, 24-hour (hh:mm).\n\ +\n\ +@item %s\n\ +Time in seconds since 00:00:00, Jan 1, 1970 (a nonstandard extension).\n\ +\n\ +@item %S\n\ +Second (00-61).\n\ +\n\ +@item %T\n\ +Time, 24-hour (hh:mm:ss).\n\ +\n\ +@item %X\n\ +Locale's time representation (%H:%M:%S).\n\ +\n\ +@item %Z\n\ +Time zone (EDT), or nothing if no time zone is determinable.\n\ +@end table\n\ +\n\ +@noindent\n\ +Date fields:\n\ +\n\ +@table @code\n\ +@item %a\n\ +Locale's abbreviated weekday name (Sun-Sat).\n\ +\n\ +@item %A\n\ +Locale's full weekday name, variable length (Sunday-Saturday).\n\ +\n\ +@item %b\n\ +Locale's abbreviated month name (Jan-Dec).\n\ +\n\ +@item %B\n\ +Locale's full month name, variable length (January-December).\n\ +\n\ +@item %c\n\ +Locale's date and time (Sat Nov 04 12:02:33 EST 1989).\n\ +\n\ +@item %C\n\ +Century (00-99).\n\ +\n\ +@item %d\n\ +Day of month (01-31).\n\ +\n\ +@item %e\n\ +Day of month ( 1-31).\n\ +\n\ +@item %D\n\ +Date (mm/dd/yy).\n\ +\n\ +@item %h\n\ +Same as %b.\n\ +\n\ +@item %j\n\ +Day of year (001-366).\n\ +\n\ +@item %m\n\ +Month (01-12).\n\ +\n\ +@item %U\n\ +Week number of year with Sunday as first day of week (00-53).\n\ +\n\ +@item %w\n\ +Day of week (0-6).\n\ +\n\ +@item %W\n\ +Week number of year with Monday as first day of week (00-53).\n\ +\n\ +@item %x\n\ +Locale's date representation (mm/dd/yy).\n\ +\n\ +@item %y\n\ +Last two digits of year (00-99).\n\ +\n\ +@item %Y\n\ +Year (1970-).\n\ +@end table\n\ +@seealso{strptime, localtime, gmtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 2) + { + std::string fmt = args(0).string_value (); + + if (! error_state) + { + octave_scalar_map map = args(1).scalar_map_value (); + + if (! error_state) + { + octave_base_tm tm = extract_tm (map); + + if (! error_state) + retval = tm.strftime (fmt); + else + error ("strftime: invalid TM_STRUCT argument"); + } + else + error ("strftime: TM_STRUCT must be a structure"); + } + else + error ("strftime: FMT must be a string"); + } + else + print_usage (); + + return retval; +} + +/* +%!assert (ischar (strftime ("%%%n%t%H%I%k%l", localtime (time ())))); +%!assert (ischar (strftime ("%M%p%r%R%s%S%T", localtime (time ())))); +%!assert (ischar (strftime ("%X%Z%z%a%A%b%B", localtime (time ())))); +%!assert (ischar (strftime ("%c%C%d%e%D%h%j", localtime (time ())))); +%!assert (ischar (strftime ("%m%U%w%W%x%y%Y", localtime (time ())))); + +%!error strftime () +%!error strftime ("foo", localtime (time ()), 1) +*/ + +DEFUN (strptime, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {[@var{tm_struct}, @var{nchars}] =} strptime (@var{str}, @var{fmt})\n\ +Convert the string @var{str} to the time structure @var{tm_struct} under\n\ +the control of the format string @var{fmt}.\n\ +\n\ +If @var{fmt} fails to match, @var{nchars} is 0; otherwise, it is set to the\n\ +position of last matched character plus 1. Always check for this unless\n\ +you're absolutely sure the date string will be parsed correctly.\n\ +@seealso{strftime, localtime, gmtime, mktime, time, now, date, clock, datenum, datestr, datevec, calendar, weekday}\n\ +@end deftypefn") +{ + octave_value_list retval; + + if (args.length () == 2) + { + std::string str = args(0).string_value (); + + if (! error_state) + { + std::string fmt = args(1).string_value (); + + if (! error_state) + { + octave_strptime t (str, fmt); + + retval(1) = t.characters_converted (); + retval(0) = octave_value (mk_tm_map (t)); + } + else + error ("strptime: FMT must be a string"); + } + else + error ("strptime: argument STR must be a string"); + } + else + print_usage (); + + return retval; +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/tril.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,430 @@ +/* + +Copyright (C) 2004-2012 David Bateman +Copyright (C) 2009 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <algorithm> +#include "Array.h" +#include "Sparse.h" +#include "mx-base.h" + +#include "ov.h" +#include "Cell.h" + +#include "defun.h" +#include "error.h" +#include "oct-obj.h" + +// The bulk of the work. +template <class T> +static Array<T> +do_tril (const Array<T>& a, octave_idx_type k, bool pack) +{ + octave_idx_type nr = a.rows (), nc = a.columns (); + const T *avec = a.fortran_vec (); + octave_idx_type zero = 0; + + if (pack) + { + octave_idx_type j1 = std::min (std::max (zero, k), nc); + octave_idx_type j2 = std::min (std::max (zero, nr + k), nc); + octave_idx_type n = j1 * nr + ((j2 - j1) * (nr-(j1-k) + nr-(j2-1-k))) / 2; + Array<T> r (dim_vector (n, 1)); + T *rvec = r.fortran_vec (); + for (octave_idx_type j = 0; j < nc; j++) + { + octave_idx_type ii = std::min (std::max (zero, j - k), nr); + rvec = std::copy (avec + ii, avec + nr, rvec); + avec += nr; + } + + return r; + } + else + { + Array<T> r (a.dims ()); + T *rvec = r.fortran_vec (); + for (octave_idx_type j = 0; j < nc; j++) + { + octave_idx_type ii = std::min (std::max (zero, j - k), nr); + std::fill (rvec, rvec + ii, T ()); + std::copy (avec + ii, avec + nr, rvec + ii); + avec += nr; + rvec += nr; + } + + return r; + } +} + +template <class T> +static Array<T> +do_triu (const Array<T>& a, octave_idx_type k, bool pack) +{ + octave_idx_type nr = a.rows (), nc = a.columns (); + const T *avec = a.fortran_vec (); + octave_idx_type zero = 0; + + if (pack) + { + octave_idx_type j1 = std::min (std::max (zero, k), nc); + octave_idx_type j2 = std::min (std::max (zero, nr + k), nc); + octave_idx_type n = ((j2 - j1) * ((j1+1-k) + (j2-k))) / 2 + (nc - j2) * nr; + Array<T> r (dim_vector (n, 1)); + T *rvec = r.fortran_vec (); + for (octave_idx_type j = 0; j < nc; j++) + { + octave_idx_type ii = std::min (std::max (zero, j + 1 - k), nr); + rvec = std::copy (avec, avec + ii, rvec); + avec += nr; + } + + return r; + } + else + { + NoAlias<Array<T> > r (a.dims ()); + T *rvec = r.fortran_vec (); + for (octave_idx_type j = 0; j < nc; j++) + { + octave_idx_type ii = std::min (std::max (zero, j + 1 - k), nr); + std::copy (avec, avec + ii, rvec); + std::fill (rvec + ii, rvec + nr, T ()); + avec += nr; + rvec += nr; + } + + return r; + } +} + +// These two are by David Bateman. +// FIXME: optimizations possible. "pack" support missing. + +template <class T> +static Sparse<T> +do_tril (const Sparse<T>& a, octave_idx_type k, bool pack) +{ + if (pack) // FIXME + { + error ("tril: \"pack\" not implemented for sparse matrices"); + return Sparse<T> (); + } + + Sparse<T> m = a; + octave_idx_type nc = m.cols (); + + for (octave_idx_type j = 0; j < nc; j++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) + if (m.ridx (i) < j-k) + m.data(i) = 0.; + + m.maybe_compress (true); + return m; +} + +template <class T> +static Sparse<T> +do_triu (const Sparse<T>& a, octave_idx_type k, bool pack) +{ + if (pack) // FIXME + { + error ("triu: \"pack\" not implemented for sparse matrices"); + return Sparse<T> (); + } + + Sparse<T> m = a; + octave_idx_type nc = m.cols (); + + for (octave_idx_type j = 0; j < nc; j++) + for (octave_idx_type i = m.cidx (j); i < m.cidx (j+1); i++) + if (m.ridx (i) > j-k) + m.data(i) = 0.; + + m.maybe_compress (true); + return m; +} + +// Convenience dispatchers. +template <class T> +static Array<T> +do_trilu (const Array<T>& a, octave_idx_type k, bool lower, bool pack) +{ + return lower ? do_tril (a, k, pack) : do_triu (a, k, pack); +} + +template <class T> +static Sparse<T> +do_trilu (const Sparse<T>& a, octave_idx_type k, bool lower, bool pack) +{ + return lower ? do_tril (a, k, pack) : do_triu (a, k, pack); +} + +static octave_value +do_trilu (const std::string& name, + const octave_value_list& args) +{ + bool lower = name == "tril"; + + octave_value retval; + int nargin = args.length (); + octave_idx_type k = 0; + bool pack = false; + if (nargin >= 2 && args(nargin-1).is_string ()) + { + pack = args(nargin-1).string_value () == "pack"; + nargin--; + } + + if (nargin == 2) + { + k = args(1).int_value (true); + + if (error_state) + return retval; + } + + if (nargin < 1 || nargin > 2) + print_usage (); + else + { + octave_value arg = args (0); + + dim_vector dims = arg.dims (); + if (dims.length () != 2) + error ("%s: need a 2-D matrix", name.c_str ()); + else if (k < -dims (0) || k > dims(1)) + error ("%s: requested diagonal out of range", name.c_str ()); + else + { + switch (arg.builtin_type ()) + { + case btyp_double: + if (arg.is_sparse_type ()) + retval = do_trilu (arg.sparse_matrix_value (), k, lower, pack); + else + retval = do_trilu (arg.array_value (), k, lower, pack); + break; + case btyp_complex: + if (arg.is_sparse_type ()) + retval = do_trilu (arg.sparse_complex_matrix_value (), k, lower, pack); + else + retval = do_trilu (arg.complex_array_value (), k, lower, pack); + break; + case btyp_bool: + if (arg.is_sparse_type ()) + retval = do_trilu (arg.sparse_bool_matrix_value (), k, lower, pack); + else + retval = do_trilu (arg.bool_array_value (), k, lower, pack); + break; +#define ARRAYCASE(TYP) \ + case btyp_ ## TYP: \ + retval = do_trilu (arg.TYP ## _array_value (), k, lower, pack); \ + break + ARRAYCASE (float); + ARRAYCASE (float_complex); + ARRAYCASE (int8); + ARRAYCASE (int16); + ARRAYCASE (int32); + ARRAYCASE (int64); + ARRAYCASE (uint8); + ARRAYCASE (uint16); + ARRAYCASE (uint32); + ARRAYCASE (uint64); + ARRAYCASE (char); +#undef ARRAYCASE + default: + { + // Generic code that works on octave-values, that is slow + // but will also work on arbitrary user types + + if (pack) // FIXME + { + error ("%s: \"pack\" not implemented for class %s", + name.c_str (), arg.class_name ().c_str ()); + return octave_value (); + } + + octave_value tmp = arg; + if (arg.numel () == 0) + return arg; + + octave_idx_type nr = dims(0), nc = dims (1); + + // The sole purpose of the below is to force the correct + // matrix size. This would not be necessary if the + // octave_value resize function allowed a fill_value. + // It also allows odd attributes in some user types + // to be handled. With a fill_value ot should be replaced + // with + // + // octave_value_list ov_idx; + // tmp = tmp.resize(dim_vector (0,0)).resize (dims, fill_value); + + octave_value_list ov_idx; + std::list<octave_value_list> idx_tmp; + ov_idx(1) = static_cast<double> (nc+1); + ov_idx(0) = Range (1, nr); + idx_tmp.push_back (ov_idx); + ov_idx(1) = static_cast<double> (nc); + tmp = tmp.resize (dim_vector (0,0)); + tmp = tmp.subsasgn ("(",idx_tmp, arg.do_index_op (ov_idx)); + tmp = tmp.resize (dims); + + if (lower) + { + octave_idx_type st = nc < nr + k ? nc : nr + k; + + for (octave_idx_type j = 1; j <= st; j++) + { + octave_idx_type nr_limit = 1 > j - k ? 1 : j - k; + ov_idx(1) = static_cast<double> (j); + ov_idx(0) = Range (nr_limit, nr); + std::list<octave_value_list> idx; + idx.push_back (ov_idx); + + tmp = tmp.subsasgn ("(", idx, arg.do_index_op (ov_idx)); + + if (error_state) + return retval; + } + } + else + { + octave_idx_type st = k + 1 > 1 ? k + 1 : 1; + + for (octave_idx_type j = st; j <= nc; j++) + { + octave_idx_type nr_limit = nr < j - k ? nr : j - k; + ov_idx(1) = static_cast<double> (j); + ov_idx(0) = Range (1, nr_limit); + std::list<octave_value_list> idx; + idx.push_back (ov_idx); + + tmp = tmp.subsasgn ("(", idx, arg.do_index_op (ov_idx)); + + if (error_state) + return retval; + } + } + + retval = tmp; + } + } + } + } + + return retval; +} + +DEFUN (tril, args, , + "-*- texinfo -*-\n\ +@deftypefn {Function File} {} tril (@var{A})\n\ +@deftypefnx {Function File} {} tril (@var{A}, @var{k})\n\ +@deftypefnx {Function File} {} tril (@var{A}, @var{k}, @var{pack})\n\ +@deftypefnx {Function File} {} triu (@var{A})\n\ +@deftypefnx {Function File} {} triu (@var{A}, @var{k})\n\ +@deftypefnx {Function File} {} triu (@var{A}, @var{k}, @var{pack})\n\ +Return a new matrix formed by extracting the lower (@code{tril})\n\ +or upper (@code{triu}) triangular part of the matrix @var{A}, and\n\ +setting all other elements to zero. The second argument is optional,\n\ +and specifies how many diagonals above or below the main diagonal should\n\ +also be set to zero.\n\ +\n\ +The default value of @var{k} is zero, so that @code{triu} and\n\ +@code{tril} normally include the main diagonal as part of the result.\n\ +\n\ +If the value of @var{k} is negative, additional elements above (for\n\ +@code{tril}) or below (for @code{triu}) the main diagonal are also\n\ +selected.\n\ +\n\ +The absolute value of @var{k} must not be greater than the number of\n\ +sub-diagonals or super-diagonals.\n\ +\n\ +For example:\n\ +\n\ +@example\n\ +@group\n\ +tril (ones (3), -1)\n\ + @result{} 0 0 0\n\ + 1 0 0\n\ + 1 1 0\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +and\n\ +\n\ +@example\n\ +@group\n\ +tril (ones (3), 1)\n\ + @result{} 1 1 0\n\ + 1 1 1\n\ + 1 1 1\n\ +@end group\n\ +@end example\n\ +\n\ +If the option \"pack\" is given as third argument, the extracted elements\n\ +are not inserted into a matrix, but rather stacked column-wise one above\n\ +other.\n\ +@seealso{diag}\n\ +@end deftypefn") +{ + return do_trilu ("tril", args); +} + +DEFUN (triu, args, , + "-*- texinfo -*-\n\ +@deftypefn {Function File} {} triu (@var{A})\n\ +@deftypefnx {Function File} {} triu (@var{A}, @var{k})\n\ +@deftypefnx {Function File} {} triu (@var{A}, @var{k}, @var{pack})\n\ +See the documentation for the @code{tril} function (@pxref{tril}).\n\ +@end deftypefn") +{ + return do_trilu ("triu", args); +} + +/* +%!test +%! a = [1, 2, 3; 4, 5, 6; 7, 8, 9; 10, 11, 12]; +%! +%! l0 = [1, 0, 0; 4, 5, 0; 7, 8, 9; 10, 11, 12]; +%! l1 = [1, 2, 0; 4, 5, 6; 7, 8, 9; 10, 11, 12]; +%! l2 = [1, 2, 3; 4, 5, 6; 7, 8, 9; 10, 11, 12]; +%! lm1 = [0, 0, 0; 4, 0, 0; 7, 8, 0; 10, 11, 12]; +%! lm2 = [0, 0, 0; 0, 0, 0; 7, 0, 0; 10, 11, 0]; +%! lm3 = [0, 0, 0; 0, 0, 0; 0, 0, 0; 10, 0, 0]; +%! lm4 = [0, 0, 0; 0, 0, 0; 0, 0, 0; 0, 0, 0]; +%! +%! assert (tril (a, -4), lm4); +%! assert (tril (a, -3), lm3); +%! assert (tril (a, -2), lm2); +%! assert (tril (a, -1), lm1); +%! assert (tril (a), l0); +%! assert (tril (a, 1), l1); +%! assert (tril (a, 2), l2); + +%!error tril () +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/corefcn/typecast.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,460 @@ +/* + +Copyright (C) 2007-2012 David Bateman +Copyright (C) 2009 VZLU Prague + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "mx-base.h" + +#include "defun.h" +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "unwind-prot.h" + +static dim_vector +get_vec_dims (const dim_vector& old_dims, octave_idx_type n) +{ + if (old_dims.length () == 2 && old_dims(0) == 1) + return dim_vector (1, n); + else if (old_dims.length () == 2 && old_dims (0) == 0 && old_dims (1) == 0) + return dim_vector (); + else + return dim_vector (n, 1); +} + +template <class ArrayType> +static void +get_data_and_bytesize (const ArrayType& array, + const void *& data, + octave_idx_type& byte_size, + dim_vector& old_dims, + unwind_protect& frame) +{ + // The array given may be a temporary, constructed from a scalar or sparse + // array. This will ensure the data will be deallocated after we exit. + frame.add_delete (new ArrayType (array)); + + data = reinterpret_cast<const void *> (array.data ()); + byte_size = array.byte_size (); + + old_dims = array.dims (); +} + +template <class ArrayType> +static ArrayType +reinterpret_copy (const void *data, octave_idx_type byte_size, + const dim_vector& old_dims) +{ + typedef typename ArrayType::element_type T; + octave_idx_type n = byte_size / sizeof (T); + + if (n * static_cast<int> (sizeof (T)) == byte_size) + { + ArrayType retval (get_vec_dims (old_dims, n)); + T *dest = retval.fortran_vec (); + std::memcpy (dest, data, n * sizeof (T)); + + return retval; + } + else + { + error ("typecast: incorrect number of input values to make output value"); + return ArrayType (); + } +} + + +DEFUN (typecast, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {} typecast (@var{x}, @var{class})\n\ +Return a new array @var{y} resulting from interpreting the data of\n\ +@var{x} in memory as data of the numeric class @var{class}. Both the class\n\ +of @var{x} and @var{class} must be one of the built-in numeric classes:\n\ +\n\ +@example\n\ +@group\n\ +\"logical\"\n\ +\"char\"\n\ +\"int8\"\n\ +\"int16\"\n\ +\"int32\"\n\ +\"int64\"\n\ +\"uint8\"\n\ +\"uint16\"\n\ +\"uint32\"\n\ +\"uint64\"\n\ +\"double\"\n\ +\"single\"\n\ +\"double complex\"\n\ +\"single complex\"\n\ +@end group\n\ +@end example\n\ +\n\ +@noindent\n\ +the last two are reserved for @var{class}; they indicate that a\n\ +complex-valued result is requested. Complex arrays are stored in memory as\n\ +consecutive pairs of real numbers. The sizes of integer types are given by\n\ +their bit counts. Both logical and char are typically one byte wide;\n\ +however, this is not guaranteed by C++. If your system is IEEE conformant,\n\ +single and double should be 4 bytes and 8 bytes wide, respectively.\n\ +\"logical\" is not allowed for @var{class}. If the input is a row vector,\n\ +the return value is a row vector, otherwise it is a column vector. If the\n\ +bit length of @var{x} is not divisible by that of @var{class}, an error\n\ +occurs.\n\ +\n\ +An example of the use of typecast on a little-endian machine is\n\ +\n\ +@example\n\ +@group\n\ +@var{x} = uint16 ([1, 65535]);\n\ +typecast (@var{x}, \"uint8\")\n\ + @result{} [ 0, 1, 255, 255]\n\ +@end group\n\ +@end example\n\ +@seealso{cast, bitunpack, bitpack, swapbytes}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 2) + { + unwind_protect frame; + const void *data = 0; + octave_idx_type byte_size = 0; + dim_vector old_dims; + + octave_value array = args(0); + + if (array.is_bool_type ()) + get_data_and_bytesize (array.bool_array_value (), data, byte_size, old_dims, frame); + else if (array.is_string ()) + get_data_and_bytesize (array.char_array_value (), data, byte_size, old_dims, frame); + else if (array.is_integer_type ()) + { + if (array.is_int8_type ()) + get_data_and_bytesize (array.int8_array_value (), data, byte_size, old_dims, frame); + else if (array.is_int16_type ()) + get_data_and_bytesize (array.int16_array_value (), data, byte_size, old_dims, frame); + else if (array.is_int32_type ()) + get_data_and_bytesize (array.int32_array_value (), data, byte_size, old_dims, frame); + else if (array.is_int64_type ()) + get_data_and_bytesize (array.int64_array_value (), data, byte_size, old_dims, frame); + else if (array.is_uint8_type ()) + get_data_and_bytesize (array.uint8_array_value (), data, byte_size, old_dims, frame); + else if (array.is_uint16_type ()) + get_data_and_bytesize (array.uint16_array_value (), data, byte_size, old_dims, frame); + else if (array.is_uint32_type ()) + get_data_and_bytesize (array.uint32_array_value (), data, byte_size, old_dims, frame); + else if (array.is_uint64_type ()) + get_data_and_bytesize (array.uint64_array_value (), data, byte_size, old_dims, frame); + else + assert (0); + } + else if (array.is_complex_type ()) + { + if (array.is_single_type ()) + get_data_and_bytesize (array.float_complex_array_value (), data, byte_size, old_dims, frame); + else + get_data_and_bytesize (array.complex_array_value (), data, byte_size, old_dims, frame); + } + else if (array.is_real_type ()) + { + if (array.is_single_type ()) + get_data_and_bytesize (array.float_array_value (), data, byte_size, old_dims, frame); + else + get_data_and_bytesize (array.array_value (), data, byte_size, old_dims, frame); + } + else + error ("typecast: invalid input class: %s", array.class_name ().c_str ()); + + std::string numclass = args(1).string_value (); + + if (error_state || numclass.size () == 0) + ; + else if (numclass == "char") + retval = octave_value (reinterpret_copy<charNDArray> (data, byte_size, old_dims), array.is_dq_string () ? '"' : '\''); + else if (numclass[0] == 'i') + { + if (numclass == "int8") + retval = reinterpret_copy<int8NDArray> (data, byte_size, old_dims); + else if (numclass == "int16") + retval = reinterpret_copy<int16NDArray> (data, byte_size, old_dims); + else if (numclass == "int32") + retval = reinterpret_copy<int32NDArray> (data, byte_size, old_dims); + else if (numclass == "int64") + retval = reinterpret_copy<int64NDArray> (data, byte_size, old_dims); + } + else if (numclass[0] == 'u') + { + if (numclass == "uint8") + retval = reinterpret_copy<uint8NDArray> (data, byte_size, old_dims); + else if (numclass == "uint16") + retval = reinterpret_copy<uint16NDArray> (data, byte_size, old_dims); + else if (numclass == "uint32") + retval = reinterpret_copy<uint32NDArray> (data, byte_size, old_dims); + else if (numclass == "uint64") + retval = reinterpret_copy<uint64NDArray> (data, byte_size, old_dims); + } + else if (numclass == "single") + retval = reinterpret_copy<FloatNDArray> (data, byte_size, old_dims); + else if (numclass == "double") + retval = reinterpret_copy<NDArray> (data, byte_size, old_dims); + else if (numclass == "single complex") + retval = reinterpret_copy<FloatComplexNDArray> (data, byte_size, old_dims); + else if (numclass == "double complex") + retval = reinterpret_copy<ComplexNDArray> (data, byte_size, old_dims); + + if (! error_state && retval.is_undefined ()) + error ("typecast: cannot convert to %s class", numclass.c_str ()); + } + else + print_usage (); + + return retval; +} + +template <class ArrayType> +ArrayType +do_bitpack (const boolNDArray& bitp) +{ + typedef typename ArrayType::element_type T; + octave_idx_type n = bitp.numel () / (sizeof (T) * CHAR_BIT); + + if (n * static_cast<int> (sizeof (T)) * CHAR_BIT == bitp.numel ()) + { + + ArrayType retval (get_vec_dims (bitp.dims (), n)); + + const bool *bits = bitp.fortran_vec (); + char *packed = reinterpret_cast<char *> (retval.fortran_vec ()); + + octave_idx_type m = n * sizeof (T); + + for (octave_idx_type i = 0; i < m; i++) + { + char c = bits[0]; + for (int j = 1; j < CHAR_BIT; j++) + c |= bits[j] << j; + + packed[i] = c; + bits += CHAR_BIT; + } + + return retval; + } + else + { + error ("bitpack: incorrect number of bits to make up output value"); + return ArrayType (); + } +} + +DEFUN (bitpack, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{y} =} bitpack (@var{x}, @var{class})\n\ +Return a new array @var{y} resulting from interpreting an array\n\ +@var{x} as raw bit patterns for data of the numeric class @var{class}.\n\ +@var{class} must be one of the built-in numeric classes:\n\ +\n\ +@example\n\ +@group\n\ +\"char\"\n\ +\"int8\"\n\ +\"int16\"\n\ +\"int32\"\n\ +\"int64\"\n\ +\"uint8\"\n\ +\"uint16\"\n\ +\"uint32\"\n\ +\"uint64\"\n\ +\"double\"\n\ +\"single\"\n\ +@end group\n\ +@end example\n\ +\n\ +The number of elements of @var{x} should be divisible by the bit length of\n\ +@var{class}. If it is not, excess bits are discarded. Bits come in\n\ +increasing order of significance, i.e., @code{x(1)} is bit 0, @code{x(2)} is\n\ +bit 1, etc. The result is a row vector if @var{x} is a row vector, otherwise\n\ +it is a column vector.\n\ +@seealso{bitunpack, typecast}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 2 && args(0).is_bool_type ()) + { + boolNDArray bitp = args(0).bool_array_value (); + + std::string numclass = args(1).string_value (); + + if (error_state || numclass.size () == 0) + ; + else if (numclass == "char") + retval = octave_value (do_bitpack<charNDArray> (bitp), '\''); + else if (numclass[0] == 'i') + { + if (numclass == "int8") + retval = do_bitpack<int8NDArray> (bitp); + else if (numclass == "int16") + retval = do_bitpack<int16NDArray> (bitp); + else if (numclass == "int32") + retval = do_bitpack<int32NDArray> (bitp); + else if (numclass == "int64") + retval = do_bitpack<int64NDArray> (bitp); + } + else if (numclass[0] == 'u') + { + if (numclass == "uint8") + retval = do_bitpack<uint8NDArray> (bitp); + else if (numclass == "uint16") + retval = do_bitpack<uint16NDArray> (bitp); + else if (numclass == "uint32") + retval = do_bitpack<uint32NDArray> (bitp); + else if (numclass == "uint64") + retval = do_bitpack<uint64NDArray> (bitp); + } + else if (numclass == "single") + retval = do_bitpack<FloatNDArray> (bitp); + else if (numclass == "double") + retval = do_bitpack<NDArray> (bitp); + else if (numclass == "single complex") + retval = do_bitpack<FloatComplexNDArray> (bitp); + else if (numclass == "double complex") + retval = do_bitpack<ComplexNDArray> (bitp); + + if (! error_state && retval.is_undefined ()) + error ("bitpack: cannot pack to %s class", numclass.c_str ()); + } + else + print_usage (); + + return retval; +} + +template <class ArrayType> +boolNDArray +do_bitunpack (const ArrayType& array) +{ + typedef typename ArrayType::element_type T; + octave_idx_type n = array.numel () * sizeof (T) * CHAR_BIT; + + boolNDArray retval (get_vec_dims (array.dims (), n)); + + const char *packed = reinterpret_cast<const char *> (array.fortran_vec ()); + bool *bits = retval.fortran_vec (); + + octave_idx_type m = n / CHAR_BIT; + + for (octave_idx_type i = 0; i < m; i++) + { + char c = packed[i]; + bits[0] = c & 1; + for (int j = 1; j < CHAR_BIT; j++) + bits[j] = (c >>= 1) & 1; + bits += CHAR_BIT; + } + + return retval; +} + +DEFUN (bitunpack, args, , + "-*- texinfo -*-\n\ +@deftypefn {Built-in Function} {@var{y} =} bitunpack (@var{x})\n\ +Return an array @var{y} corresponding to the raw bit patterns of\n\ +@var{x}. @var{x} must belong to one of the built-in numeric classes:\n\ +\n\ +@example\n\ +@group\n\ +\"char\"\n\ +\"int8\"\n\ +\"int16\"\n\ +\"int32\"\n\ +\"int64\"\n\ +\"uint8\"\n\ +\"uint16\"\n\ +\"uint32\"\n\ +\"uint64\"\n\ +\"double\"\n\ +\"single\"\n\ +@end group\n\ +@end example\n\ +\n\ +The result is a row vector if @var{x} is a row vector; otherwise, it is a\n\ +column vector.\n\ +@seealso{bitpack, typecast}\n\ +@end deftypefn") +{ + octave_value retval; + + if (args.length () == 1 && (args(0).is_numeric_type () || args(0).is_string ())) + { + octave_value array = args(0); + + if (array.is_string ()) + retval = do_bitunpack (array.char_array_value ()); + else if (array.is_integer_type ()) + { + if (array.is_int8_type ()) + retval = do_bitunpack (array.int8_array_value ()); + else if (array.is_int16_type ()) + retval = do_bitunpack (array.int16_array_value ()); + else if (array.is_int32_type ()) + retval = do_bitunpack (array.int32_array_value ()); + else if (array.is_int64_type ()) + retval = do_bitunpack (array.int64_array_value ()); + else if (array.is_uint8_type ()) + retval = do_bitunpack (array.uint8_array_value ()); + else if (array.is_uint16_type ()) + retval = do_bitunpack (array.uint16_array_value ()); + else if (array.is_uint32_type ()) + retval = do_bitunpack (array.uint32_array_value ()); + else if (array.is_uint64_type ()) + retval = do_bitunpack (array.uint64_array_value ()); + else + assert (0); + } + else if (array.is_complex_type ()) + { + if (array.is_single_type ()) + retval = do_bitunpack (array.float_complex_array_value ()); + else + retval = do_bitunpack (array.complex_array_value ()); + } + else if (array.is_real_type ()) + { + if (array.is_single_type ()) + retval = do_bitunpack (array.float_array_value ()); + else + retval = do_bitunpack (array.array_value ()); + } + else + error ("bitunpack: invalid input class: %s", array.class_name ().c_str ()); + } + else + print_usage (); + + return retval; +}
--- a/src/data.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/data.cc Sat Jul 28 12:06:34 2012 -0400 @@ -214,6 +214,7 @@ Compute atan (@var{y} / @var{x}) for corresponding elements of @var{y}\n\ and @var{x}. Signal an error if @var{y} and @var{x} do not match in size\n\ and orientation.\n\ +@seealso{tan, tand, tanh, atanh}\n\ @end deftypefn") { octave_value retval; @@ -2370,6 +2371,7 @@ Return the \"length\" of the object @var{a}. For matrix objects, the\n\ length is the number of rows or columns, whichever is greater (this\n\ odd definition is used for compatibility with @sc{matlab}).\n\ +@seealso{size}\n\ @end deftypefn") { octave_value retval; @@ -2395,6 +2397,7 @@ @result{} 3\n\ @end group\n\ @end example\n\ +@seealso{size}\n\ @end deftypefn") { octave_value retval; @@ -2488,7 +2491,7 @@ \n\ @noindent\n\ returns the number of columns in the given matrix.\n\ -@seealso{numel}\n\ +@seealso{numel, ndims, length, rows, columns}\n\ @end deftypefn") { octave_value_list retval; @@ -2551,7 +2554,7 @@ Return true if the dimensions of all arguments agree.\n\ Trailing singleton dimensions are ignored.\n\ Called with a single or no argument, size_equal returns true.\n\ -@seealso{size, numel}\n\ +@seealso{size, numel, ndims}\n\ @end deftypefn") { octave_value retval; @@ -2583,7 +2586,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {@var{scalar} =} nnz (@var{a})\n\ Return the number of non zero elements in @var{a}.\n\ -@seealso{sparse}\n\ +@seealso{sparse, nzmax}\n\ @end deftypefn") { octave_value retval; @@ -2604,7 +2607,7 @@ for sparse objects. There are some cases of user created sparse objects\n\ where the value returned by @dfn{nzmax} will not be the same as @dfn{nnz},\n\ but in general they will give the same result.\n\ -@seealso{sparse, spalloc}\n\ +@seealso{nnz, spalloc, sparse}\n\ @end deftypefn") { octave_value retval; @@ -2882,7 +2885,7 @@ \n\ @noindent\n\ but it uses less memory and avoids calling @code{conj} if @var{x} is real.\n\ -@seealso{sum}\n\ +@seealso{sum, prod}\n\ @end deftypefn") { DATA_REDUCTION (sumsq); @@ -2963,7 +2966,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} iscomplex (@var{x})\n\ Return true if @var{x} is a complex-valued numeric object.\n\ -@seealso{isreal, isnumeric}\n\ +@seealso{isreal, isnumeric, islogical, ischar, isfloat, isa}\n\ @end deftypefn") { octave_value retval; @@ -3013,7 +3016,7 @@ @result{} [ 1 + 3i 2 + 4i ]\n\ @end group\n\ @end example\n\ -@seealso{real, imag, iscomplex}\n\ +@seealso{real, imag, iscomplex, abs, arg}\n\ @end deftypefn") { octave_value retval; @@ -3292,7 +3295,7 @@ Return true if @var{x} is a non-complex matrix or scalar.\n\ For compatibility with @sc{matlab}, this includes logical and character\n\ matrices.\n\ -@seealso{iscomplex, isnumeric}\n\ +@seealso{iscomplex, isnumeric, isa}\n\ @end deftypefn") { octave_value retval; @@ -3310,7 +3313,7 @@ @deftypefn {Built-in Function} {} isempty (@var{a})\n\ Return true if @var{a} is an empty matrix (any one of its dimensions is\n\ zero). Otherwise, return false.\n\ -@seealso{isnull}\n\ +@seealso{isnull, isa}\n\ @end deftypefn") { octave_value retval = false; @@ -3329,7 +3332,7 @@ Return true if @var{x} is a numeric object, i.e., an integer, real, or\n\ complex array. Logical and character arrays are not considered to be\n\ numeric.\n\ -@seealso{isinteger, isfloat, isreal, iscomplex, islogical, ischar, iscell, isstruct}\n\ +@seealso{isinteger, isfloat, isreal, iscomplex, islogical, ischar, iscell, isstruct, isa}\n\ @end deftypefn") { octave_value retval; @@ -3365,7 +3368,7 @@ Scalars (1x1 matrices) and vectors (@nospell{1xN} or @nospell{Nx1} matrices)\n\ are subsets of the more general N-dimensional matrix and @code{ismatrix}\n\ will return true for these objects as well.\n\ -@seealso{isscalar, isvector, iscell, isstruct, issparse}\n\ +@seealso{isscalar, isvector, iscell, isstruct, issparse, isa}\n\ @end deftypefn") { octave_value retval = false; @@ -3947,7 +3950,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ -@seealso{isinf}\n\ +@seealso{isinf, NaN}\n\ @end deftypefn") { return fill_matrix (args, lo_ieee_inf_value (), @@ -4006,7 +4009,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ -@seealso{isnan}\n\ +@seealso{isnan, Inf}\n\ @end deftypefn") { return fill_matrix (args, lo_ieee_nan_value (), @@ -4055,6 +4058,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ +@seealso{log, exp, pi, i, j}\n\ @end deftypefn") { #if defined (M_E) @@ -4095,6 +4099,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ +@seealso{realmax, realmin, intmax, bitmax}\n\ @end deftypefn") { int nargin = args.length (); @@ -4210,6 +4215,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ +@seealso{e, i, j}\n\ @end deftypefn") { #if defined (M_PI) @@ -4248,7 +4254,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ -@seealso{realmin, intmax, bitmax}\n\ +@seealso{realmin, intmax, bitmax, eps}\n\ @end deftypefn") { return fill_matrix (args, DBL_MAX, FLT_MAX, "realmax"); @@ -4281,7 +4287,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ -@seealso{realmax, intmin}\n\ +@seealso{realmax, intmin, eps}\n\ @end deftypefn") { return fill_matrix (args, DBL_MIN, FLT_MIN, "realmin"); @@ -4307,7 +4313,8 @@ @ifnottex\n\ @code{sqrt (-1)}.\n\ @end ifnottex\n\ - I, and its equivalents i, J, and j, are functions so any of the names may\n\ +\n\ +I, and its equivalents i, j, and J, are functions so any of the names may\n\ be reused for other purposes (such as i for a counter variable).\n\ \n\ When called with no arguments, return a scalar with the value @math{i}. When\n\ @@ -4317,6 +4324,7 @@ arguments specify additional matrix dimensions.\n\ The optional argument @var{class} specifies the return type and may be\n\ either \"double\" or \"single\".\n\ +@seealso{e, pi, log, exp, i, j, J}\n\ @end deftypefn") { return fill_matrix (args, Complex (0.0, 1.0), "I"); @@ -4549,7 +4557,7 @@ Calling @code{eye} with no arguments is equivalent to calling it\n\ with an argument of 1. Any negative dimensions are treated as zero. \n\ These odd definitions are for compatibility with @sc{matlab}.\n\ -@seealso{speye}\n\ +@seealso{speye, ones, zeros}\n\ @end deftypefn") { octave_value retval; @@ -4679,6 +4687,7 @@ \n\ For compatibility with @sc{matlab}, return the second argument (@var{limit})\n\ if fewer than two values are requested.\n\ +@seealso{logspace}\n\ @end deftypefn") { octave_value retval; @@ -4786,7 +4795,7 @@ An object can be resized to more dimensions than it has;\n\ in such case the missing dimensions are assumed to be 1.\n\ Resizing an object to fewer dimensions is not possible.\n\ -@seealso{reshape, postpad}\n\ +@seealso{reshape, postpad, prepad, cat}\n\ @end deftypefn") { octave_value retval; @@ -4861,7 +4870,7 @@ A single dimension of the return matrix may be left unspecified and Octave\n\ will determine its size automatically. An empty matrix ([]) is used to flag\n\ the unspecified dimension.\n\ -@seealso{resize}\n\ +@seealso{resize, vec, postpad, cat, squeeze}\n\ @end deftypefn") { octave_value retval; @@ -4979,7 +4988,7 @@ @code{@var{x}(:)}. If @var{dim} is supplied, the dimensions of @var{v}\n\ are set to @var{dim} with all elements along the last dimension.\n\ This is equivalent to @code{shiftdim (@var{x}(:), 1-@var{dim})}.\n\ -@seealso{vech}\n\ +@seealso{vech, resize, cat}\n\ @end deftypefn") { octave_value retval; @@ -5042,6 +5051,7 @@ Remove singleton dimensions from @var{x} and return the result.\n\ Note that for compatibility with @sc{matlab}, all objects have\n\ a minimum of two dimensions and row vectors are left unchanged.\n\ +@seealso{reshape}\n\ @end deftypefn") { octave_value retval; @@ -5056,7 +5066,7 @@ DEFUN (full, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{FM} =} full (@var{SM})\n\ +@deftypefn {Built-in Function} {@var{FM} =} full (@var{SM})\n\ Return a full storage matrix from a sparse, diagonal, permutation matrix\n\ or a range.\n\ @seealso{sparse}\n\ @@ -5281,6 +5291,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} uplus (@var{x})\n\ This function and @w{@xcode{+ x}} are equivalent.\n\ +@seealso{uminus, plus, minus}\n\ @end deftypefn") { return unary_op_defun_body (octave_value::op_uplus, args); @@ -5290,6 +5301,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} uminus (@var{x})\n\ This function and @w{@xcode{- x}} are equivalent.\n\ +@seealso{uplus, minus}\n\ @end deftypefn") { return unary_op_defun_body (octave_value::op_uminus, args); @@ -5413,7 +5425,7 @@ @end example\n\ \n\ At least one argument is required.\n\ -@seealso{minus}\n\ +@seealso{minus, uplus}\n\ @end deftypefn") { return binary_assoc_op_defun_body (octave_value::op_add, @@ -5424,7 +5436,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} minus (@var{x}, @var{y})\n\ This function and @w{@xcode{x - y}} are equivalent.\n\ -@seealso{plus}\n\ +@seealso{plus, uminus}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_sub, args); @@ -5444,7 +5456,7 @@ @end example\n\ \n\ At least one argument is required.\n\ -@seealso{times}\n\ +@seealso{times, plus, minus, rdivide, mrdivide, mldivide, mpower}\n\ @end deftypefn") { return binary_assoc_op_defun_body (octave_value::op_mul, @@ -5456,7 +5468,7 @@ @deftypefn {Built-in Function} {} mrdivide (@var{x}, @var{y})\n\ Return the matrix right division of @var{x} and @var{y}.\n\ This function and @w{@xcode{x / y}} are equivalent.\n\ -@seealso{mldivide, rdivide}\n\ +@seealso{mldivide, rdivide, plus, minus}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_div, args); @@ -5467,7 +5479,7 @@ @deftypefn {Built-in Function} {} mpower (@var{x}, @var{y})\n\ Return the matrix power operation of @var{x} raised to the @var{y} power.\n\ This function and @w{@xcode{x ^ y}} are equivalent.\n\ -@seealso{power}\n\ +@seealso{power, mtimes, plus, minus}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_pow, args); @@ -5478,7 +5490,7 @@ @deftypefn {Built-in Function} {} mldivide (@var{x}, @var{y})\n\ Return the matrix left division of @var{x} and @var{y}.\n\ This function and @w{@xcode{x @xbackslashchar{} y}} are equivalent.\n\ -@seealso{mrdivide, ldivide}\n\ +@seealso{mrdivide, ldivide, rdivide}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_ldiv, args); @@ -5488,6 +5500,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} lt (@var{x}, @var{y})\n\ This function is equivalent to @w{@code{x < y}}.\n\ +@seealso{le, eq, ge, gt, ne}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_lt, args); @@ -5497,6 +5510,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} le (@var{x}, @var{y})\n\ This function is equivalent to @w{@code{x <= y}}.\n\ +@seealso{eq, ge, gt, ne, lt}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_le, args); @@ -5507,7 +5521,7 @@ @deftypefn {Built-in Function} {} eq (@var{x}, @var{y})\n\ Return true if the two inputs are equal.\n\ This function is equivalent to @w{@code{x == y}}.\n\ -@seealso{ne, isequal}\n\ +@seealso{ne, isequal, le, ge, gt, ne, lt}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_eq, args); @@ -5517,6 +5531,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} ge (@var{x}, @var{y})\n\ This function is equivalent to @w{@code{x >= y}}.\n\ +@seealso{le, eq, gt, ne, lt}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_ge, args); @@ -5526,6 +5541,7 @@ "-*- texinfo -*-\n\ @deftypefn {Built-in Function} {} gt (@var{x}, @var{y})\n\ This function is equivalent to @w{@code{x > y}}.\n\ +@seealso{le, eq, ge, ne, lt}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_gt, args); @@ -5536,7 +5552,7 @@ @deftypefn {Built-in Function} {} ne (@var{x}, @var{y})\n\ Return true if the two inputs are not equal.\n\ This function is equivalent to @w{@code{x != y}}.\n\ -@seealso{eq, isequal}\n\ +@seealso{eq, isequal, le, ge, lt}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_ne, args); @@ -5556,7 +5572,7 @@ @end example\n\ \n\ At least one argument is required.\n\ -@seealso{mtimes}\n\ +@seealso{mtimes, rdivide}\n\ @end deftypefn") { return binary_assoc_op_defun_body (octave_value::op_el_mul, @@ -5568,7 +5584,7 @@ @deftypefn {Built-in Function} {} rdivide (@var{x}, @var{y})\n\ Return the element-by-element right division of @var{x} and @var{y}.\n\ This function and @w{@xcode{x ./ y}} are equivalent.\n\ -@seealso{ldivide, mrdivide}\n\ +@seealso{ldivide, mrdivide, times, plus}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_el_div, args); @@ -5595,7 +5611,7 @@ @deftypefn {Built-in Function} {} ldivide (@var{x}, @var{y})\n\ Return the element-by-element left division of @var{x} and @var{y}.\n\ This function and @w{@xcode{x .@xbackslashchar{} y}} are equivalent.\n\ -@seealso{rdivide, mldivide}\n\ +@seealso{rdivide, mldivide, times, plus}\n\ @end deftypefn") { return binary_op_defun_body (octave_value::op_el_ldiv, args); @@ -5686,6 +5702,7 @@ @code{toc} functions report the actual wall clock time that elapsed\n\ between the calls. This may include time spent processing other jobs or\n\ doing nothing at all.\n\ +@seealso{toc, cputime}\n\ @end deftypefn") { octave_value retval; @@ -5718,7 +5735,7 @@ @deftypefn {Built-in Function} {} toc ()\n\ @deftypefnx {Built-in Function} {} toc (@var{id})\n\ @deftypefnx {Built-in Function} {@var{val} =} toc (@dots{})\n\ -See tic.\n\ +@seealso{tic, cputime}\n\ @end deftypefn") { octave_value retval; @@ -5790,6 +5807,7 @@ Note that because Octave used some CPU time to start, it is reasonable\n\ to check to see if @code{cputime} works by checking to see if the total\n\ CPU time used is nonzero.\n\ +@seealso{tic, toc}\n\ @end deftypefn") { octave_value_list retval; @@ -5847,10 +5865,10 @@ DEFUN (sort, args, nargout, "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{s}, @var{i}] =} sort (@var{x})\n\ -@deftypefnx {Loadable Function} {[@var{s}, @var{i}] =} sort (@var{x}, @var{dim})\n\ -@deftypefnx {Loadable Function} {[@var{s}, @var{i}] =} sort (@var{x}, @var{mode})\n\ -@deftypefnx {Loadable Function} {[@var{s}, @var{i}] =} sort (@var{x}, @var{dim}, @var{mode})\n\ +@deftypefn {Built-in Function} {[@var{s}, @var{i}] =} sort (@var{x})\n\ +@deftypefnx {Built-in Function} {[@var{s}, @var{i}] =} sort (@var{x}, @var{dim})\n\ +@deftypefnx {Built-in Function} {[@var{s}, @var{i}] =} sort (@var{x}, @var{mode})\n\ +@deftypefnx {Built-in Function} {[@var{s}, @var{i}] =} sort (@var{x}, @var{dim}, @var{mode})\n\ Return a copy of @var{x} with the elements arranged in increasing\n\ order. For matrices, @code{sort} orders the elements within columns\n\ \n\ @@ -5910,6 +5928,7 @@ \n\ The algorithm used in @code{sort} is optimized for the sorting of partially\n\ ordered lists.\n\ +@seealso{sortrows, issorted}\n\ @end deftypefn") { octave_value_list retval; @@ -6799,7 +6818,7 @@ \n\ @var{mask} can also be arbitrary numeric type, in which case\n\ it is first converted to logical.\n\ -@seealso{logical}\n\ +@seealso{logical, diff}\n\ @end deftypefn") { int nargin = args.length (); @@ -7027,6 +7046,7 @@ @var{k}-th order differences are calculated along this dimension.\n\ In the case where @var{k} exceeds @code{size (@var{x}, @var{dim})}\n\ an empty matrix is returned.\n\ +@seealso{sort, merge}\n\ @end deftypefn") { int nargin = args.length (); @@ -7137,7 +7157,7 @@ endfor\n\ @end group\n\ @end example\n\ -@seealso{repmat}\n\ +@seealso{repmat, cat}\n\ @end deftypefn") { octave_value retval;
--- a/src/debug.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/debug.cc Sat Jul 28 12:06:34 2012 -0400 @@ -504,8 +504,8 @@ DEFUN (dbstop, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{rline} =} dbstop (\"@var{func}\")\n\ -@deftypefnx {Loadable Function} {@var{rline} =} dbstop (\"@var{func}\", @var{line}, @dots{})\n\ +@deftypefn {Built-in Function} {@var{rline} =} dbstop (\"@var{func}\")\n\ +@deftypefnx {Built-in Function} {@var{rline} =} dbstop (\"@var{func}\", @var{line}, @dots{})\n\ Set a breakpoint in function @var{func}.\n\ \n\ Arguments are\n\ @@ -548,8 +548,8 @@ DEFUN (dbclear, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dbclear (\"@var{func}\")\n\ -@deftypefnx {Loadable Function} {} dbclear (\"@var{func}\", @var{line}, @dots{})\n\ +@deftypefn {Built-in Function} {} dbclear (\"@var{func}\")\n\ +@deftypefnx {Built-in Function} {} dbclear (\"@var{func}\", @var{line}, @dots{})\n\ Delete a breakpoint in the function @var{func}.\n\ \n\ Arguments are\n\ @@ -585,9 +585,9 @@ DEFUN (dbstatus, args, nargout, "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dbstatus ()\n\ -@deftypefnx {Loadable Function} {@var{brk_list} =} dbstatus ()\n\ -@deftypefnx {Loadable Function} {@var{brk_list} =} dbstatus (\"@var{func}\")\n\ +@deftypefn {Built-in Function} {} dbstatus ()\n\ +@deftypefnx {Built-in Function} {@var{brk_list} =} dbstatus ()\n\ +@deftypefnx {Built-in Function} {@var{brk_list} =} dbstatus (\"@var{func}\")\n\ Report the location of active breakpoints.\n\ \n\ When called with no input or output arguments, print the list of\n\ @@ -701,7 +701,7 @@ DEFUN (dbwhere, , , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dbwhere ()\n\ +@deftypefn {Built-in Function} {} dbwhere ()\n\ In debugging mode, report the current file and line number where\n\ execution is stopped.\n\ @seealso{dbstatus, dbcont, dbstep, dbup}\n\ @@ -794,13 +794,13 @@ DEFUN (dbtype, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dbtype ()\n\ -@deftypefnx {Loadable Function} {} dbtype (\"startl:endl\")\n\ -@deftypefnx {Loadable Function} {} dbtype (\"startl:end\")\n\ -@deftypefnx {Loadable Function} {} dbtype (\"@var{func}\")\n\ -@deftypefnx {Loadable Function} {} dbtype (\"@var{func}\", \"startl\")\n\ -@deftypefnx {Loadable Function} {} dbtype (\"@var{func}\", \"startl:endl\")\n\ -@deftypefnx {Loadable Function} {} dbtype (\"@var{func}\", \"startl:end\")\n\ +@deftypefn {Built-in Function} {} dbtype ()\n\ +@deftypefnx {Built-in Function} {} dbtype (\"startl:endl\")\n\ +@deftypefnx {Built-in Function} {} dbtype (\"startl:end\")\n\ +@deftypefnx {Built-in Function} {} dbtype (\"@var{func}\")\n\ +@deftypefnx {Built-in Function} {} dbtype (\"@var{func}\", \"startl\")\n\ +@deftypefnx {Built-in Function} {} dbtype (\"@var{func}\", \"startl:endl\")\n\ +@deftypefnx {Built-in Function} {} dbtype (\"@var{func}\", \"startl:end\")\n\ When in debugging mode and called with no arguments, list the script file\n\ being debugged with line numbers. An optional range specification,\n\ specified as a string, can be used to list only a portion of the file.\n\ @@ -1022,9 +1022,9 @@ DEFUN (dbstack, args, nargout, "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dbstack ()\n\ -@deftypefnx {Loadable Function} {} dbstack (@var{n})\n\ -@deftypefnx {Loadable Function} {[@var{stack}, @var{idx}] =} dbstack (@dots{})\n\ +@deftypefn {Built-in Function} {} dbstack ()\n\ +@deftypefnx {Built-in Function} {} dbstack (@var{n})\n\ +@deftypefnx {Built-in Function} {[@var{stack}, @var{idx}] =} dbstack (@dots{})\n\ Display or return current debugging function stack information.\n\ With optional argument @var{n}, omit the @var{n} innermost stack frames.\n\ \n\ @@ -1090,8 +1090,8 @@ DEFUN (dbup, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dbup\n\ -@deftypefnx {Loadable Function} {} dbup (@var{n})\n\ +@deftypefn {Built-in Function} {} dbup\n\ +@deftypefnx {Built-in Function} {} dbup (@var{n})\n\ In debugging mode, move up the execution stack @var{n} frames.\n\ If @var{n} is omitted, move up one frame.\n\ @seealso{dbstack, dbdown}\n\ @@ -1106,8 +1106,8 @@ DEFUN (dbdown, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} dbdown\n\ -@deftypefnx {Loadable Function} {} dbdown (@var{n})\n\ +@deftypefn {Built-in Function} {} dbdown\n\ +@deftypefnx {Built-in Function} {} dbdown (@var{n})\n\ In debugging mode, move down the execution stack @var{n} frames.\n\ If @var{n} is omitted, move down one frame.\n\ @seealso{dbstack, dbup}\n\ @@ -1252,7 +1252,7 @@ DEFUN (isdebugmode, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} isdebugmode ()\n\ +@deftypefn {Built-in Function} {} isdebugmode ()\n\ Return true if in debugging mode, otherwise false.\n\ @seealso{dbwhere, dbstack, dbstatus}\n\ @end deftypefn")
--- a/src/defun-int.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/defun-int.h Sat Jul 28 12:06:34 2012 -0400 @@ -39,7 +39,7 @@ extern OCTINTERP_API void install_builtin_function (octave_builtin::fcn f, const std::string& name, - const std::string& doc, + const std::string& file, const std::string& doc, bool can_hide_function = true); extern OCTINTERP_API void
--- a/src/defun.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/defun.cc Sat Jul 28 12:06:34 2012 -0400 @@ -80,10 +80,10 @@ void install_builtin_function (octave_builtin::fcn f, const std::string& name, - const std::string& doc, + const std::string& file, const std::string& doc, bool /* can_hide_function -- not yet implemented */) { - octave_value fcn (new octave_builtin (f, name, doc)); + octave_value fcn (new octave_builtin (f, name, file, doc)); symbol_table::install_built_in_function (name, fcn); }
--- a/src/find-defun-files.sh Sat Jul 28 15:17:57 2012 +0200 +++ b/src/find-defun-files.sh Sat Jul 28 12:06:34 2012 -0400 @@ -21,6 +21,6 @@ file="$srcdir/$arg" fi if [ "`$EGREP -l "$DEFUN_PATTERN" $file`" ]; then - echo "$file" | $SED 's,.*/,,; s/\.cc$/.df/; s/\.ll$/.df/; s/\.yy$/.df/'; + echo "$file" | $SED "s,\\$srcdir/,," | $SED 's/\.cc$/.df/; s/\.ll$/.df/; s/\.yy$/.df/'; fi done
--- a/src/graphics.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/graphics.cc Sat Jul 28 12:06:34 2012 -0400 @@ -6833,9 +6833,9 @@ v(1) += delta_el; - if(v(1) > 90) + if (v(1) > 90) v(1) = 90; - if(v(1) < -90) + if (v(1) < -90) v(1) = -90; v(0) = fmod (v(0) - delta_az + 720,360);
--- a/src/help.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/help.cc Sat Jul 28 12:06:34 2012 -0400 @@ -762,7 +762,7 @@ string_vector retval (lst.size ()); int j = 0; for (map_iter iter = lst.begin (); iter != lst.end (); iter ++) - retval [j++] = iter->first; + retval[j++] = iter->first; return retval; } @@ -954,7 +954,7 @@ } DEFUN (get_help_text, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{text}, @var{format}] =} get_help_text (@var{name})\n\ +@deftypefn {Built-in Function} {[@var{text}, @var{format}] =} get_help_text (@var{name})\n\ Return the raw help text of function @var{name}.\n\ \n\ The raw help text is returned in @var{text} and the format in @var{format}\n\ @@ -1023,7 +1023,7 @@ DEFUN (get_help_text_from_file, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {[@var{text}, @var{format}] =} get_help_text_from_file (@var{fname})\n\ +@deftypefn {Built-in Function} {[@var{text}, @var{format}] =} get_help_text_from_file (@var{fname})\n\ Return the raw help text from the file @var{fname}.\n\ \n\ The raw help text is returned in @var{text} and the format in @var{format}\n\ @@ -1118,7 +1118,10 @@ if (fcn->is_user_function ()) type = "command-line function"; else - type = "built-in function"; + { + file = fcn->src_file_name (); + type = "built-in function"; + } } else type = val.is_user_script () @@ -1215,11 +1218,11 @@ { const int dir_len = dir.size (); const int filename_len = filename.size (); - const int max_allowed_seps = file_ops::is_dir_sep (dir [dir_len-1]) ? 0 : 1; + const int max_allowed_seps = file_ops::is_dir_sep (dir[dir_len-1]) ? 0 : 1; int num_seps = 0; for (int i = dir_len; i < filename_len; i++) - if (file_ops::is_dir_sep (filename [i])) + if (file_ops::is_dir_sep (filename[i])) num_seps ++; return (num_seps <= max_allowed_seps);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jit-ir.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,601 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// defines required by llvm +#define __STDC_LIMIT_MACROS +#define __STDC_CONSTANT_MACROS + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#ifdef HAVE_LLVM + +#include "jit-ir.h" + +#include <llvm/BasicBlock.h> +#include <llvm/Instructions.h> + +#include "error.h" +#include "pt-jit.h" + +// -------------------- jit_use -------------------- +jit_block * +jit_use::user_parent (void) const +{ + return muser->parent (); +} + +// -------------------- jit_value -------------------- +jit_value::~jit_value (void) +{} + +jit_block * +jit_value::first_use_block (void) +{ + jit_use *use = first_use (); + while (use) + { + if (! isa<jit_error_check> (use->user ())) + return use->user_parent (); + + use = use->next (); + } + + return 0; +} + +void +jit_value::replace_with (jit_value *value) +{ + while (first_use ()) + { + jit_instruction *user = first_use ()->user (); + size_t idx = first_use ()->index (); + user->stash_argument (idx, value); + } +} + +#define JIT_METH(clname) \ + void \ + jit_ ## clname::accept (jit_ir_walker& walker) \ + { \ + walker.visit (*this); \ + } + +JIT_VISIT_IR_NOTEMPLATE +#undef JIT_METH + +std::ostream& +operator<< (std::ostream& os, const jit_value& value) +{ + return value.short_print (os); +} + +std::ostream& +jit_print (std::ostream& os, jit_value *avalue) +{ + if (avalue) + return avalue->print (os); + return os << "NULL"; +} + +// -------------------- jit_instruction -------------------- +void +jit_instruction::remove (void) +{ + if (mparent) + mparent->remove (mlocation); + resize_arguments (0); +} + +llvm::BasicBlock * +jit_instruction::parent_llvm (void) const +{ + return mparent->to_llvm (); +} + +std::ostream& +jit_instruction::short_print (std::ostream& os) const +{ + if (type ()) + jit_print (os, type ()) << ": "; + return os << "#" << mid; +} + +void +jit_instruction::do_construct_ssa (size_t start, size_t end) +{ + for (size_t i = start; i < end; ++i) + { + jit_value *arg = argument (i); + jit_variable *var = dynamic_cast<jit_variable *> (arg); + if (var && var->has_top ()) + stash_argument (i, var->top ()); + } +} + +// -------------------- jit_block -------------------- +void +jit_block::replace_with (jit_value *value) +{ + assert (isa<jit_block> (value)); + jit_block *block = static_cast<jit_block *> (value); + + jit_value::replace_with (block); + + while (ILIST_T::first_use ()) + { + jit_phi_incomming *incomming = ILIST_T::first_use (); + incomming->stash_value (block); + } +} + +void +jit_block::replace_in_phi (jit_block *ablock, jit_block *with) +{ + jit_phi_incomming *node = ILIST_T::first_use (); + while (node) + { + jit_phi_incomming *prev = node; + node = node->next (); + + if (prev->user_parent () == ablock) + prev->stash_value (with); + } +} + +jit_block * +jit_block::maybe_merge () +{ + if (successor_count () == 1 && successor (0) != this + && (successor (0)->use_count () == 1 || instructions.size () == 1)) + { + jit_block *to_merge = successor (0); + merge (*to_merge); + return to_merge; + } + + return 0; +} + +void +jit_block::merge (jit_block& block) +{ + // the merge block will contain a new terminator + jit_terminator *old_term = terminator (); + if (old_term) + old_term->remove (); + + bool was_empty = end () == begin (); + iterator merge_begin = end (); + if (! was_empty) + --merge_begin; + + instructions.splice (end (), block.instructions); + if (was_empty) + merge_begin = begin (); + else + ++merge_begin; + + // now merge_begin points to the start of the new instructions, we must + // update their parent information + for (iterator iter = merge_begin; iter != end (); ++iter) + { + jit_instruction *instr = *iter; + instr->stash_parent (this, iter); + } + + block.replace_with (this); +} + +jit_instruction * +jit_block::prepend (jit_instruction *instr) +{ + instructions.push_front (instr); + instr->stash_parent (this, instructions.begin ()); + return instr; +} + +jit_instruction * +jit_block::prepend_after_phi (jit_instruction *instr) +{ + // FIXME: Make this O(1) + for (iterator iter = begin (); iter != end (); ++iter) + { + jit_instruction *temp = *iter; + if (! isa<jit_phi> (temp)) + { + insert_before (iter, instr); + return instr; + } + } + + return append (instr); +} + +void +jit_block::internal_append (jit_instruction *instr) +{ + instructions.push_back (instr); + instr->stash_parent (this, --instructions.end ()); +} + +jit_instruction * +jit_block::insert_before (iterator loc, jit_instruction *instr) +{ + iterator iloc = instructions.insert (loc, instr); + instr->stash_parent (this, iloc); + return instr; +} + +jit_instruction * +jit_block::insert_after (iterator loc, jit_instruction *instr) +{ + ++loc; + iterator iloc = instructions.insert (loc, instr); + instr->stash_parent (this, iloc); + return instr; +} + +jit_terminator * +jit_block::terminator (void) const +{ + assert (this); + if (instructions.empty ()) + return 0; + + jit_instruction *last = instructions.back (); + return dynamic_cast<jit_terminator *> (last); +} + +bool +jit_block::branch_alive (jit_block *asucc) const +{ + return terminator ()->alive (asucc); +} + +jit_block * +jit_block::successor (size_t i) const +{ + jit_terminator *term = terminator (); + return term->successor (i); +} + +size_t +jit_block::successor_count (void) const +{ + jit_terminator *term = terminator (); + return term ? term->successor_count () : 0; +} + +llvm::BasicBlock * +jit_block::to_llvm (void) const +{ + return llvm::cast<llvm::BasicBlock> (llvm_value); +} + +std::ostream& +jit_block::print_dom (std::ostream& os) const +{ + short_print (os); + os << ":\n"; + os << " mid: " << mid << std::endl; + os << " predecessors: "; + for (jit_use *use = first_use (); use; use = use->next ()) + os << *use->user_parent () << " "; + os << std::endl; + + os << " successors: "; + for (size_t i = 0; i < successor_count (); ++i) + os << *successor (i) << " "; + os << std::endl; + + os << " idom: "; + if (idom) + os << *idom; + else + os << "NULL"; + os << std::endl; + os << " df: "; + for (df_iterator iter = df_begin (); iter != df_end (); ++iter) + os << **iter << " "; + os << std::endl; + + os << " dom_succ: "; + for (size_t i = 0; i < dom_succ.size (); ++i) + os << *dom_succ[i] << " "; + + return os << std::endl; +} + +void +jit_block::compute_df (size_t avisit_count) +{ + if (visited (avisit_count)) + return; + + if (use_count () >= 2) + { + for (jit_use *use = first_use (); use; use = use->next ()) + { + jit_block *runner = use->user_parent (); + while (runner != idom) + { + runner->mdf.insert (this); + runner = runner->idom; + } + } + } + + for (size_t i = 0; i < successor_count (); ++i) + successor (i)->compute_df (avisit_count); +} + +bool +jit_block::update_idom (size_t avisit_count) +{ + if (visited (avisit_count) || ! use_count ()) + return false; + + bool changed = false; + for (jit_use *use = first_use (); use; use = use->next ()) + { + jit_block *pred = use->user_parent (); + changed = pred->update_idom (avisit_count) || changed; + } + + jit_use *use = first_use (); + jit_block *new_idom = use->user_parent (); + use = use->next (); + + for (; use; use = use->next ()) + { + jit_block *pred = use->user_parent (); + jit_block *pidom = pred->idom; + if (pidom) + new_idom = idom_intersect (pidom, new_idom); + } + + if (idom != new_idom) + { + idom = new_idom; + return true; + } + + return changed; +} + +void +jit_block::pop_all (void) +{ + for (iterator iter = begin (); iter != end (); ++iter) + { + jit_instruction *instr = *iter; + instr->pop_variable (); + } +} + +jit_block * +jit_block::maybe_split (jit_convert& convert, jit_block *asuccessor) +{ + if (successor_count () > 1) + { + jit_terminator *term = terminator (); + size_t idx = term->successor_index (asuccessor); + jit_block *split = convert.create<jit_block> ("phi_split", mvisit_count); + + // try to place splits where they make sense + if (id () < asuccessor->id ()) + convert.insert_before (asuccessor, split); + else + convert.insert_after (this, split); + + term->stash_argument (idx, split); + jit_branch *br = split->append (convert.create<jit_branch> (asuccessor)); + replace_in_phi (asuccessor, split); + + if (alive ()) + { + split->mark_alive (); + br->infer (); + } + + return split; + } + + return this; +} + +void +jit_block::create_dom_tree (size_t avisit_count) +{ + if (visited (avisit_count)) + return; + + if (idom != this) + idom->dom_succ.push_back (this); + + for (size_t i = 0; i < successor_count (); ++i) + successor (i)->create_dom_tree (avisit_count); +} + +jit_block * +jit_block::idom_intersect (jit_block *i, jit_block *j) +{ + while (i && j && i != j) + { + while (i && i->id () > j->id ()) + i = i->idom; + + while (i && j && j->id () > i->id ()) + j = j->idom; + } + + return i ? i : j; +} + +// -------------------- jit_phi_incomming -------------------- + +jit_block * +jit_phi_incomming::user_parent (void) const +{ return muser->parent (); } + +// -------------------- jit_phi -------------------- +bool +jit_phi::prune (void) +{ + jit_block *p = parent (); + size_t new_idx = 0; + jit_value *unique = argument (1); + + for (size_t i = 0; i < argument_count (); ++i) + { + jit_block *inc = incomming (i); + if (inc->branch_alive (p)) + { + if (unique != argument (i)) + unique = 0; + + if (new_idx != i) + { + stash_argument (new_idx, argument (i)); + mincomming[new_idx].stash_value (inc); + } + + ++new_idx; + } + } + + if (new_idx != argument_count ()) + { + resize_arguments (new_idx); + mincomming.resize (new_idx); + } + + assert (argument_count () > 0); + if (unique) + { + replace_with (unique); + return true; + } + + return false; +} + +bool +jit_phi::infer (void) +{ + jit_block *p = parent (); + if (! p->alive ()) + return false; + + jit_type *infered = 0; + for (size_t i = 0; i < argument_count (); ++i) + { + jit_block *inc = incomming (i); + if (inc->branch_alive (p)) + infered = jit_typeinfo::join (infered, argument_type (i)); + } + + if (infered != type ()) + { + stash_type (infered); + return true; + } + + return false; +} + +llvm::PHINode * +jit_phi::to_llvm (void) const +{ + return llvm::cast<llvm::PHINode> (jit_value::to_llvm ()); +} + +// -------------------- jit_terminator -------------------- +size_t +jit_terminator::successor_index (const jit_block *asuccessor) const +{ + size_t scount = successor_count (); + for (size_t i = 0; i < scount; ++i) + if (successor (i) == asuccessor) + return i; + + panic_impossible (); +} + +bool +jit_terminator::infer (void) +{ + if (! parent ()->alive ()) + return false; + + bool changed = false; + for (size_t i = 0; i < malive.size (); ++i) + if (! malive[i] && check_alive (i)) + { + changed = true; + malive[i] = true; + successor (i)->mark_alive (); + } + + return changed; +} + +llvm::TerminatorInst * +jit_terminator::to_llvm (void) const +{ + return llvm::cast<llvm::TerminatorInst> (jit_value::to_llvm ()); +} + +// -------------------- jit_call -------------------- +bool +jit_call::infer (void) +{ + // FIXME: explain algorithm + for (size_t i = 0; i < argument_count (); ++i) + { + already_infered[i] = argument_type (i); + if (! already_infered[i]) + return false; + } + + jit_type *infered = moperation.result (already_infered); + if (! infered && use_count ()) + { + std::stringstream ss; + ss << "Missing overload in type inference for "; + print (ss, 0); + throw jit_fail_exception (ss.str ()); + } + + if (infered != type ()) + { + stash_type (infered); + return true; + } + + return false; +} + +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jit-ir.h Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,1247 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#if !defined (octave_jit_ir_h) +#define octave_jit_ir_h 1 + +#ifdef HAVE_LLVM + +#include <list> +#include <stack> +#include <set> + +#include "jit-typeinfo.h" + +// The low level octave jit ir +// this ir is close to llvm, but contains information for doing type inference. +// We convert the octave parse tree to this IR directly. + +#define JIT_VISIT_IR_NOTEMPLATE \ + JIT_METH(block); \ + JIT_METH(branch); \ + JIT_METH(cond_branch); \ + JIT_METH(call); \ + JIT_METH(extract_argument); \ + JIT_METH(store_argument); \ + JIT_METH(phi); \ + JIT_METH(variable); \ + JIT_METH(error_check); \ + JIT_METH(assign) \ + JIT_METH(argument) + +#define JIT_VISIT_IR_CONST \ + JIT_METH(const_bool); \ + JIT_METH(const_scalar); \ + JIT_METH(const_complex); \ + JIT_METH(const_index); \ + JIT_METH(const_string); \ + JIT_METH(const_range) + +#define JIT_VISIT_IR_CLASSES \ + JIT_VISIT_IR_NOTEMPLATE \ + JIT_VISIT_IR_CONST + +// forward declare all ir classes +#define JIT_METH(cname) \ + class jit_ ## cname; + +JIT_VISIT_IR_NOTEMPLATE + +#undef JIT_METH + +class jit_convert; + +// ABCs which aren't included in JIT_VISIT_IR_ALL +class jit_instruction; +class jit_terminator; + +template <typename T, jit_type *(*EXTRACT_T)(void), typename PASS_T = T, + bool QUOTE=false> +class jit_const; + +typedef jit_const<bool, jit_typeinfo::get_bool> jit_const_bool; +typedef jit_const<double, jit_typeinfo::get_scalar> jit_const_scalar; +typedef jit_const<Complex, jit_typeinfo::get_complex> jit_const_complex; +typedef jit_const<octave_idx_type, jit_typeinfo::get_index> jit_const_index; + +typedef jit_const<std::string, jit_typeinfo::get_string, const std::string&, + true> jit_const_string; +typedef jit_const<jit_range, jit_typeinfo::get_range, const jit_range&> +jit_const_range; + +class jit_ir_walker; +class jit_use; + +class +jit_value : public jit_internal_list<jit_value, jit_use> +{ +public: + jit_value (void) : llvm_value (0), ty (0), mlast_use (0), + min_worklist (false) {} + + virtual ~jit_value (void); + + bool in_worklist (void) const + { + return min_worklist; + } + + void stash_in_worklist (bool ain_worklist) + { + min_worklist = ain_worklist; + } + + // The block of the first use which is not a jit_error_check + // So this is not necessarily first_use ()->parent (). + jit_block *first_use_block (void); + + // replace all uses with + virtual void replace_with (jit_value *value); + + jit_type *type (void) const { return ty; } + + llvm::Type *type_llvm (void) const + { + return ty ? ty->to_llvm () : 0; + } + + const std::string& type_name (void) const + { + return ty->name (); + } + + void stash_type (jit_type *new_ty) { ty = new_ty; } + + std::string print_string (void) + { + std::stringstream ss; + print (ss); + return ss.str (); + } + + jit_instruction *last_use (void) const { return mlast_use; } + + void stash_last_use (jit_instruction *alast_use) + { + mlast_use = alast_use; + } + + virtual bool needs_release (void) const { return false; } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const = 0; + + virtual std::ostream& short_print (std::ostream& os) const + { return print (os); } + + virtual void accept (jit_ir_walker& walker) = 0; + + bool has_llvm (void) const + { + return llvm_value; + } + + llvm::Value *to_llvm (void) const + { + assert (llvm_value); + return llvm_value; + } + + void stash_llvm (llvm::Value *compiled) + { + llvm_value = compiled; + } + +protected: + std::ostream& print_indent (std::ostream& os, size_t indent = 0) const + { + for (size_t i = 0; i < indent * 8; ++i) + os << " "; + return os; + } + + llvm::Value *llvm_value; +private: + jit_type *ty; + jit_instruction *mlast_use; + bool min_worklist; +}; + +std::ostream& operator<< (std::ostream& os, const jit_value& value); +std::ostream& jit_print (std::ostream& os, jit_value *avalue); + +class +jit_use : public jit_internal_node<jit_value, jit_use> +{ +public: + jit_use (void) : muser (0), mindex (0) {} + + // we should really have a move operator, but not until c++11 :( + jit_use (const jit_use& use) : muser (0), mindex (0) + { + *this = use; + } + + jit_use& operator= (const jit_use& use) + { + stash_value (use.value (), use.user (), use.index ()); + return *this; + } + + size_t index (void) const { return mindex; } + + jit_instruction *user (void) const { return muser; } + + jit_block *user_parent (void) const; + + std::list<jit_block *> user_parent_location (void) const; + + void stash_value (jit_value *avalue, jit_instruction *auser = 0, + size_t aindex = -1) + { + jit_internal_node::stash_value (avalue); + mindex = aindex; + muser = auser; + } +private: + jit_instruction *muser; + size_t mindex; +}; + +class +jit_instruction : public jit_value +{ +public: + // FIXME: this code could be so much pretier with varadic templates... + jit_instruction (void) : mid (next_id ()), mparent (0) + {} + + jit_instruction (size_t nargs) : mid (next_id ()), mparent (0) + { + already_infered.reserve (nargs); + marguments.reserve (nargs); + } + +#define STASH_ARG(i) stash_argument (i, arg ## i); +#define JIT_INSTRUCTION_CTOR(N) \ + jit_instruction (OCT_MAKE_DECL_LIST (jit_value *, arg, N)) \ + : already_infered (N), marguments (N), mid (next_id ()), mparent (0) \ + { \ + OCT_ITERATE_MACRO (STASH_ARG, N); \ + } + + JIT_INSTRUCTION_CTOR(1) + JIT_INSTRUCTION_CTOR(2) + JIT_INSTRUCTION_CTOR(3) + JIT_INSTRUCTION_CTOR(4) + +#undef STASH_ARG +#undef JIT_INSTRUCTION_CTOR + + static void reset_ids (void) + { + next_id (true); + } + + jit_value *argument (size_t i) const + { + return marguments[i].value (); + } + + llvm::Value *argument_llvm (size_t i) const + { + assert (argument (i)); + return argument (i)->to_llvm (); + } + + jit_type *argument_type (size_t i) const + { + return argument (i)->type (); + } + + llvm::Type *argument_type_llvm (size_t i) const + { + assert (argument (i)); + return argument_type (i)->to_llvm (); + } + + std::ostream& print_argument (std::ostream& os, size_t i) const + { + if (argument (i)) + return argument (i)->short_print (os); + else + return os << "NULL"; + } + + void stash_argument (size_t i, jit_value *arg) + { + marguments[i].stash_value (arg, this, i); + } + + void push_argument (jit_value *arg) + { + marguments.push_back (jit_use ()); + stash_argument (marguments.size () - 1, arg); + already_infered.push_back (0); + } + + size_t argument_count (void) const + { + return marguments.size (); + } + + void resize_arguments (size_t acount, jit_value *adefault = 0) + { + size_t old = marguments.size (); + marguments.resize (acount); + already_infered.resize (acount); + + if (adefault) + for (size_t i = old; i < acount; ++i) + stash_argument (i, adefault); + } + + const std::vector<jit_use>& arguments (void) const { return marguments; } + + // argument types which have been infered already + const std::vector<jit_type *>& argument_types (void) const + { return already_infered; } + + virtual void push_variable (void) {} + + virtual void pop_variable (void) {} + + virtual void construct_ssa (void) + { + do_construct_ssa (0, argument_count ()); + } + + virtual bool infer (void) { return false; } + + void remove (void); + + virtual std::ostream& short_print (std::ostream& os) const; + + jit_block *parent (void) const { return mparent; } + + std::list<jit_instruction *>::iterator location (void) const + { + return mlocation; + } + + llvm::BasicBlock *parent_llvm (void) const; + + void stash_parent (jit_block *aparent, + std::list<jit_instruction *>::iterator alocation) + { + mparent = aparent; + mlocation = alocation; + } + + size_t id (void) const { return mid; } +protected: + + // Do SSA replacement on arguments in [start, end) + void do_construct_ssa (size_t start, size_t end); + + std::vector<jit_type *> already_infered; +private: + static size_t next_id (bool reset = false) + { + static size_t ret = 0; + if (reset) + return ret = 0; + + return ret++; + } + + std::vector<jit_use> marguments; + + size_t mid; + jit_block *mparent; + std::list<jit_instruction *>::iterator mlocation; +}; + +// defnie accept methods for subclasses +#define JIT_VALUE_ACCEPT \ + virtual void accept (jit_ir_walker& walker); + +// for use as a dummy argument during conversion to LLVM +class +jit_argument : public jit_value +{ +public: + jit_argument (jit_type *atype, llvm::Value *avalue) + { + stash_type (atype); + stash_llvm (avalue); + } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent); + return jit_print (os, type ()) << ": DUMMY"; + } + + JIT_VALUE_ACCEPT; +}; + +template <typename T, jit_type *(*EXTRACT_T)(void), typename PASS_T, + bool QUOTE> +class +jit_const : public jit_value +{ +public: + typedef PASS_T pass_t; + + jit_const (PASS_T avalue) : mvalue (avalue) + { + stash_type (EXTRACT_T ()); + } + + PASS_T value (void) const { return mvalue; } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent); + jit_print (os, type ()) << ": "; + if (QUOTE) + os << "\""; + os << mvalue; + if (QUOTE) + os << "\""; + return os; + } + + JIT_VALUE_ACCEPT; +private: + T mvalue; +}; + +class jit_phi_incomming; + +class +jit_block : public jit_value, public jit_internal_list<jit_block, + jit_phi_incomming> +{ + typedef jit_internal_list<jit_block, jit_phi_incomming> ILIST_T; +public: + typedef std::list<jit_instruction *> instruction_list; + typedef instruction_list::iterator iterator; + typedef instruction_list::const_iterator const_iterator; + + typedef std::set<jit_block *> df_set; + typedef df_set::const_iterator df_iterator; + + static const size_t NO_ID = static_cast<size_t> (-1); + + jit_block (const std::string& aname, size_t avisit_count = 0) + : mvisit_count (avisit_count), mid (NO_ID), idom (0), mname (aname), + malive (false) + {} + + virtual void replace_with (jit_value *value); + + void replace_in_phi (jit_block *ablock, jit_block *with); + + // we have a new internal list, but we want to stay compatable with jit_value + jit_use *first_use (void) const { return jit_value::first_use (); } + + size_t use_count (void) const { return jit_value::use_count (); } + + // if a block is alive, then it might be visited during execution + bool alive (void) const { return malive; } + + void mark_alive (void) { malive = true; } + + // If we can merge with a successor, do so and return the now empty block + jit_block *maybe_merge (); + + // merge another block into this block, leaving the merge block empty + void merge (jit_block& merge); + + const std::string& name (void) const { return mname; } + + jit_instruction *prepend (jit_instruction *instr); + + jit_instruction *prepend_after_phi (jit_instruction *instr); + + template <typename T> + T *append (T *instr) + { + internal_append (instr); + return instr; + } + + jit_instruction *insert_before (iterator loc, jit_instruction *instr); + + jit_instruction *insert_before (jit_instruction *loc, jit_instruction *instr) + { + return insert_before (loc->location (), instr); + } + + jit_instruction *insert_after (iterator loc, jit_instruction *instr); + + jit_instruction *insert_after (jit_instruction *loc, jit_instruction *instr) + { + return insert_after (loc->location (), instr); + } + + iterator remove (iterator iter) + { + jit_instruction *instr = *iter; + iter = instructions.erase (iter); + instr->stash_parent (0, instructions.end ()); + return iter; + } + + jit_terminator *terminator (void) const; + + // is the jump from pred alive? + bool branch_alive (jit_block *asucc) const; + + jit_block *successor (size_t i) const; + + size_t successor_count (void) const; + + iterator begin (void) { return instructions.begin (); } + + const_iterator begin (void) const { return instructions.begin (); } + + iterator end (void) { return instructions.end (); } + + const_iterator end (void) const { return instructions.end (); } + + iterator phi_begin (void); + + iterator phi_end (void); + + iterator nonphi_begin (void); + + // must label before id is valid + size_t id (void) const { return mid; } + + // dominance frontier + const df_set& df (void) const { return mdf; } + + df_iterator df_begin (void) const { return mdf.begin (); } + + df_iterator df_end (void) const { return mdf.end (); } + + // label with a RPO walk + void label (void) + { + size_t number = 0; + label (mvisit_count, number); + } + + void label (size_t avisit_count, size_t& number) + { + if (visited (avisit_count)) + return; + + for (jit_use *use = first_use (); use; use = use->next ()) + { + jit_block *pred = use->user_parent (); + pred->label (avisit_count, number); + } + + mid = number++; + } + + // See for idom computation algorithm + // Cooper, Keith D.; Harvey, Timothy J; and Kennedy, Ken (2001). + // "A Simple, Fast Dominance Algorithm" + void compute_idom (jit_block *entry_block) + { + bool changed; + entry_block->idom = entry_block; + do + changed = update_idom (mvisit_count); + while (changed); + } + + // compute dominance frontier + void compute_df (void) + { + compute_df (mvisit_count); + } + + void create_dom_tree (void) + { + create_dom_tree (mvisit_count); + } + + jit_block *dom_successor (size_t idx) const + { + return dom_succ[idx]; + } + + size_t dom_successor_count (void) const + { + return dom_succ.size (); + } + + // call pop_varaible on all instructions + void pop_all (void); + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent); + short_print (os) << ": %pred = "; + for (jit_use *use = first_use (); use; use = use->next ()) + { + jit_block *pred = use->user_parent (); + os << *pred; + if (use->next ()) + os << ", "; + } + os << std::endl; + + for (const_iterator iter = begin (); iter != end (); ++iter) + { + jit_instruction *instr = *iter; + instr->print (os, indent + 1) << std::endl; + } + return os; + } + + // ... + jit_block *maybe_split (jit_convert& convert, jit_block *asuccessor); + + jit_block *maybe_split (jit_convert& convert, jit_block& asuccessor) + { + return maybe_split (convert, &asuccessor); + } + + // print dominator infomration + std::ostream& print_dom (std::ostream& os) const; + + virtual std::ostream& short_print (std::ostream& os) const + { + os << mname; + if (mid != NO_ID) + os << mid; + return os; + } + + llvm::BasicBlock *to_llvm (void) const; + + std::list<jit_block *>::iterator location (void) const + { return mlocation; } + + void stash_location (std::list<jit_block *>::iterator alocation) + { mlocation = alocation; } + + // used to prevent visiting the same node twice in the graph + size_t visit_count (void) const { return mvisit_count; } + + // check if this node has been visited yet at the given visit count. If we + // have not been visited yet, mark us as visited. + bool visited (size_t avisit_count) + { + if (mvisit_count <= avisit_count) + { + mvisit_count = avisit_count + 1; + return false; + } + + return true; + } + + JIT_VALUE_ACCEPT; +private: + void internal_append (jit_instruction *instr); + + void compute_df (size_t avisit_count); + + bool update_idom (size_t avisit_count); + + void create_dom_tree (size_t avisit_count); + + static jit_block *idom_intersect (jit_block *i, jit_block *j); + + size_t mvisit_count; + size_t mid; + jit_block *idom; + df_set mdf; + std::vector<jit_block *> dom_succ; + std::string mname; + instruction_list instructions; + bool malive; + std::list<jit_block *>::iterator mlocation; +}; + +// keeps track of phi functions that use a block on incomming edges +class +jit_phi_incomming : public jit_internal_node<jit_block, jit_phi_incomming> +{ +public: + jit_phi_incomming (void) : muser (0) {} + + jit_phi_incomming (jit_phi *auser) : muser (auser) {} + + jit_phi_incomming (const jit_phi_incomming& use) : jit_internal_node () + { + *this = use; + } + + jit_phi_incomming& operator= (const jit_phi_incomming& use) + { + stash_value (use.value ()); + muser = use.muser; + return *this; + } + + jit_phi *user (void) const { return muser; } + + jit_block *user_parent (void) const; +private: + jit_phi *muser; +}; + +// A non-ssa variable +class +jit_variable : public jit_value +{ +public: + jit_variable (const std::string& aname) : mname (aname), mlast_use (0) {} + + const std::string &name (void) const { return mname; } + + // manipulate the value_stack, for use during SSA construction. The top of the + // value stack represents the current value for this variable + bool has_top (void) const + { + return ! value_stack.empty (); + } + + jit_value *top (void) const + { + return value_stack.top (); + } + + void push (jit_instruction *v) + { + value_stack.push (v); + mlast_use = v; + } + + void pop (void) + { + value_stack.pop (); + } + + jit_instruction *last_use (void) const + { + return mlast_use; + } + + void stash_last_use (jit_instruction *instr) + { + mlast_use = instr; + } + + // blocks in which we are used + void use_blocks (jit_block::df_set& result) + { + jit_use *use = first_use (); + while (use) + { + result.insert (use->user_parent ()); + use = use->next (); + } + } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + return print_indent (os, indent) << mname; + } + + JIT_VALUE_ACCEPT; +private: + std::string mname; + std::stack<jit_value *> value_stack; + jit_instruction *mlast_use; +}; + +class +jit_assign_base : public jit_instruction +{ +public: + jit_assign_base (jit_variable *adest) : jit_instruction (), mdest (adest) {} + + jit_assign_base (jit_variable *adest, size_t npred) : jit_instruction (npred), + mdest (adest) {} + + jit_assign_base (jit_variable *adest, jit_value *arg0, jit_value *arg1) + : jit_instruction (arg0, arg1), mdest (adest) {} + + jit_variable *dest (void) const { return mdest; } + + virtual void push_variable (void) + { + mdest->push (this); + } + + virtual void pop_variable (void) + { + mdest->pop (); + } + + virtual std::ostream& short_print (std::ostream& os) const + { + if (type ()) + jit_print (os, type ()) << ": "; + + dest ()->short_print (os); + return os << "#" << id (); + } +private: + jit_variable *mdest; +}; + +class +jit_assign : public jit_assign_base +{ +public: + jit_assign (jit_variable *adest, jit_value *asrc) + : jit_assign_base (adest, adest, asrc), martificial (false) {} + + jit_value *overwrite (void) const + { + return argument (0); + } + + jit_value *src (void) const + { + return argument (1); + } + + // variables don't get modified in an SSA, but COW requires we modify + // variables. An artificial assign is for when a variable gets modified. We + // need an assign in the SSA, but the reference counts shouldn't be updated. + bool artificial (void) const { return martificial; } + + void mark_artificial (void) { martificial = true; } + + virtual bool infer (void) + { + jit_type *stype = src ()->type (); + if (stype != type()) + { + stash_type (stype); + return true; + } + + return false; + } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent) << *this << " = " << *src (); + + if (artificial ()) + os << " [artificial]"; + + return os; + } + + JIT_VALUE_ACCEPT; +private: + bool martificial; +}; + +class +jit_phi : public jit_assign_base +{ +public: + jit_phi (jit_variable *adest, size_t npred) + : jit_assign_base (adest, npred) + { + mincomming.reserve (npred); + } + + // removes arguments form dead incomming jumps + bool prune (void); + + void add_incomming (jit_block *from, jit_value *value) + { + push_argument (value); + mincomming.push_back (jit_phi_incomming (this)); + mincomming[mincomming.size () - 1].stash_value (from); + } + + jit_block *incomming (size_t i) const + { + return mincomming[i].value (); + } + + llvm::BasicBlock *incomming_llvm (size_t i) const + { + return incomming (i)->to_llvm (); + } + + virtual void construct_ssa (void) {} + + virtual bool infer (void); + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + std::stringstream ss; + print_indent (ss, indent); + short_print (ss) << " phi "; + std::string ss_str = ss.str (); + std::string indent_str (ss_str.size (), ' '); + os << ss_str; + + for (size_t i = 0; i < argument_count (); ++i) + { + if (i > 0) + os << indent_str; + os << "| "; + + os << *incomming (i) << " -> "; + os << *argument (i); + + if (i + 1 < argument_count ()) + os << std::endl; + } + + return os; + } + + llvm::PHINode *to_llvm (void) const; + + JIT_VALUE_ACCEPT; +private: + std::vector<jit_phi_incomming> mincomming; +}; + +class +jit_terminator : public jit_instruction +{ +public: +#define JIT_TERMINATOR_CONST(N) \ + jit_terminator (size_t asuccessor_count, \ + OCT_MAKE_DECL_LIST (jit_value *, arg, N)) \ + : jit_instruction (OCT_MAKE_ARG_LIST (arg, N)), \ + malive (asuccessor_count, false) {} + + JIT_TERMINATOR_CONST (1) + JIT_TERMINATOR_CONST (2) + JIT_TERMINATOR_CONST (3) + +#undef JIT_TERMINATOR_CONST + + jit_block *successor (size_t idx = 0) const + { + return static_cast<jit_block *> (argument (idx)); + } + + llvm::BasicBlock *successor_llvm (size_t idx = 0) const + { + return successor (idx)->to_llvm (); + } + + size_t successor_index (const jit_block *asuccessor) const; + + std::ostream& print_successor (std::ostream& os, size_t idx = 0) const + { + if (alive (idx)) + os << "[live] "; + else + os << "[dead] "; + + return successor (idx)->short_print (os); + } + + // Check if the jump to successor is live + bool alive (const jit_block *asuccessor) const + { + return alive (successor_index (asuccessor)); + } + + bool alive (size_t idx) const { return malive[idx]; } + + bool alive (int idx) const { return malive[idx]; } + + size_t successor_count (void) const { return malive.size (); } + + virtual bool infer (void); + + llvm::TerminatorInst *to_llvm (void) const; +protected: + virtual bool check_alive (size_t) const { return true; } +private: + std::vector<bool> malive; +}; + +class +jit_branch : public jit_terminator +{ +public: + jit_branch (jit_block *succ) : jit_terminator (1, succ) {} + + virtual size_t successor_count (void) const { return 1; } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent) << "branch: "; + return print_successor (os); + } + + JIT_VALUE_ACCEPT; +}; + +class +jit_cond_branch : public jit_terminator +{ +public: + jit_cond_branch (jit_value *c, jit_block *ctrue, jit_block *cfalse) + : jit_terminator (2, ctrue, cfalse, c) {} + + jit_value *cond (void) const { return argument (2); } + + std::ostream& print_cond (std::ostream& os) const + { + return cond ()->short_print (os); + } + + llvm::Value *cond_llvm (void) const + { + return cond ()->to_llvm (); + } + + virtual size_t successor_count (void) const { return 2; } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent) << "cond_branch: "; + print_cond (os) << ", "; + print_successor (os, 0) << ", "; + return print_successor (os, 1); + } + + JIT_VALUE_ACCEPT; +}; + +class +jit_call : public jit_instruction +{ +public: +#define JIT_CALL_CONST(N) \ + jit_call (const jit_operation& aoperation, \ + OCT_MAKE_DECL_LIST (jit_value *, arg, N)) \ + : jit_instruction (OCT_MAKE_ARG_LIST (arg, N)), moperation (aoperation) {} \ + \ + jit_call (const jit_operation& (*aoperation) (void), \ + OCT_MAKE_DECL_LIST (jit_value *, arg, N)) \ + : jit_instruction (OCT_MAKE_ARG_LIST (arg, N)), moperation (aoperation ()) \ + {} + + JIT_CALL_CONST (1) + JIT_CALL_CONST (2) + JIT_CALL_CONST (3) + JIT_CALL_CONST (4) + +#undef JIT_CALL_CONST + + + const jit_operation& operation (void) const { return moperation; } + + bool can_error (void) const + { + return overload ().can_error (); + } + + const jit_function& overload (void) const + { + return moperation.overload (argument_types ()); + } + + virtual bool needs_release (void) const + { + return type () && jit_typeinfo::get_release (type ()).valid (); + } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent); + + if (use_count ()) + short_print (os) << " = "; + os << "call " << moperation.name () << " ("; + + for (size_t i = 0; i < argument_count (); ++i) + { + print_argument (os, i); + if (i + 1 < argument_count ()) + os << ", "; + } + return os << ")"; + } + + virtual bool infer (void); + + JIT_VALUE_ACCEPT; +private: + const jit_operation& moperation; +}; + +// FIXME: This is just ugly... +// checks error_state, if error_state is false then goto the normal branche, +// otherwise goto the error branch +class +jit_error_check : public jit_terminator +{ +public: + jit_error_check (jit_call *acheck_for, jit_block *normal, jit_block *error) + : jit_terminator (2, error, normal, acheck_for) {} + + jit_call *check_for (void) const + { + return static_cast<jit_call *> (argument (2)); + } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent) << "error_check " << *check_for () << ", "; + print_successor (os, 1) << ", "; + return print_successor (os, 0); + } + + JIT_VALUE_ACCEPT; +protected: + virtual bool check_alive (size_t idx) const + { + return idx == 1 ? true : check_for ()->can_error (); + } +}; + +class +jit_extract_argument : public jit_assign_base +{ +public: + jit_extract_argument (jit_type *atype, jit_variable *adest) + : jit_assign_base (adest) + { + stash_type (atype); + } + + const std::string& name (void) const + { + return dest ()->name (); + } + + const jit_function& overload (void) const + { + return jit_typeinfo::cast (type (), jit_typeinfo::get_any ()); + } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + print_indent (os, indent); + + return short_print (os) << " = extract " << name (); + } + + JIT_VALUE_ACCEPT; +}; + +class +jit_store_argument : public jit_instruction +{ +public: + jit_store_argument (jit_variable *var) + : jit_instruction (var), dest (var) + {} + + const std::string& name (void) const + { + return dest->name (); + } + + const jit_function& overload (void) const + { + return jit_typeinfo::cast (jit_typeinfo::get_any (), result_type ()); + } + + jit_value *result (void) const + { + return argument (0); + } + + jit_type *result_type (void) const + { + return result ()->type (); + } + + llvm::Value *result_llvm (void) const + { + return result ()->to_llvm (); + } + + virtual std::ostream& print (std::ostream& os, size_t indent = 0) const + { + jit_value *res = result (); + print_indent (os, indent) << "store "; + dest->short_print (os); + + if (! isa<jit_variable> (res)) + { + os << " = "; + res->short_print (os); + } + + return os; + } + + JIT_VALUE_ACCEPT; +private: + jit_variable *dest; +}; + +class +jit_ir_walker +{ +public: + virtual ~jit_ir_walker () {} + +#define JIT_METH(clname) \ + virtual void visit (jit_ ## clname&) = 0; + + JIT_VISIT_IR_CLASSES; + +#undef JIT_METH +}; + +template <typename T, jit_type *(*EXTRACT_T)(void), typename PASS_T, bool QUOTE> +void +jit_const<T, EXTRACT_T, PASS_T, QUOTE>::accept (jit_ir_walker& walker) +{ + walker.visit (*this); +} + +#undef JIT_VALUE_ACCEPT + +#endif +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jit-typeinfo.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,1819 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// defines required by llvm +#define __STDC_LIMIT_MACROS +#define __STDC_CONSTANT_MACROS + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#ifdef HAVE_LLVM + +#include "jit-typeinfo.h" + +#include <llvm/Analysis/Verifier.h> +#include <llvm/GlobalVariable.h> +#include <llvm/ExecutionEngine/ExecutionEngine.h> +#include <llvm/LLVMContext.h> +#include <llvm/Function.h> +#include <llvm/Instructions.h> +#include <llvm/Intrinsics.h> +#include <llvm/Support/IRBuilder.h> +#include <llvm/Support/raw_os_ostream.h> + +#include "jit-ir.h" +#include "ov.h" +#include "ov-builtin.h" +#include "ov-complex.h" +#include "ov-scalar.h" +#include "pager.h" + +static llvm::LLVMContext& context = llvm::getGlobalContext (); + +jit_typeinfo *jit_typeinfo::instance = 0; + +std::ostream& jit_print (std::ostream& os, jit_type *atype) +{ + if (! atype) + return os << "null"; + return os << atype->name (); +} + +// function that jit code calls +extern "C" void +octave_jit_print_any (const char *name, octave_base_value *obv) +{ + obv->print_with_name (octave_stdout, name, true); +} + +extern "C" void +octave_jit_print_scalar (const char *name, double value) +{ + // FIXME: We should avoid allocating a new octave_scalar each time + octave_value ov (value); + ov.print_with_name (octave_stdout, name); +} + +extern "C" octave_base_value* +octave_jit_binary_any_any (octave_value::binary_op op, octave_base_value *lhs, + octave_base_value *rhs) +{ + octave_value olhs (lhs, true); + octave_value orhs (rhs, true); + octave_value result = do_binary_op (op, olhs, orhs); + octave_base_value *rep = result.internal_rep (); + rep->grab (); + return rep; +} + +extern "C" octave_idx_type +octave_jit_compute_nelem (double base, double limit, double inc) +{ + Range rng = Range (base, limit, inc); + return rng.nelem (); +} + +extern "C" void +octave_jit_release_any (octave_base_value *obv) +{ + obv->release (); +} + +extern "C" void +octave_jit_release_matrix (jit_matrix *m) +{ + delete m->array; +} + +extern "C" octave_base_value * +octave_jit_grab_any (octave_base_value *obv) +{ + obv->grab (); + return obv; +} + +extern "C" void +octave_jit_grab_matrix (jit_matrix *result, jit_matrix *m) +{ + *result = *m->array; +} + +extern "C" octave_base_value * +octave_jit_cast_any_matrix (jit_matrix *m) +{ + octave_value ret (*m->array); + octave_base_value *rep = ret.internal_rep (); + rep->grab (); + delete m->array; + + return rep; +} + +extern "C" void +octave_jit_cast_matrix_any (jit_matrix *ret, octave_base_value *obv) +{ + NDArray m = obv->array_value (); + *ret = m; + obv->release (); +} + +extern "C" octave_base_value * +octave_jit_cast_any_range (jit_range *rng) +{ + Range temp (*rng); + octave_value ret (temp); + octave_base_value *rep = ret.internal_rep (); + rep->grab (); + + return rep; +} +extern "C" void +octave_jit_cast_range_any (jit_range *ret, octave_base_value *obv) +{ + + jit_range r (obv->range_value ()); + *ret = r; + obv->release (); +} + +extern "C" double +octave_jit_cast_scalar_any (octave_base_value *obv) +{ + double ret = obv->double_value (); + obv->release (); + return ret; +} + +extern "C" octave_base_value * +octave_jit_cast_any_scalar (double value) +{ + return new octave_scalar (value); +} + +extern "C" Complex +octave_jit_cast_complex_any (octave_base_value *obv) +{ + Complex ret = obv->complex_value (); + obv->release (); + return ret; +} + +extern "C" octave_base_value * +octave_jit_cast_any_complex (Complex c) +{ + if (c.imag () == 0) + return new octave_scalar (c.real ()); + else + return new octave_complex (c); +} + +extern "C" void +octave_jit_gripe_nan_to_logical_conversion (void) +{ + try + { + gripe_nan_to_logical_conversion (); + } + catch (const octave_execution_exception&) + { + gripe_library_execution_error (); + } +} + +extern "C" void +octave_jit_ginvalid_index (void) +{ + try + { + gripe_invalid_index (); + } + catch (const octave_execution_exception&) + { + gripe_library_execution_error (); + } +} + +extern "C" void +octave_jit_gindex_range (int nd, int dim, octave_idx_type iext, + octave_idx_type ext) +{ + try + { + gripe_index_out_of_range (nd, dim, iext, ext); + } + catch (const octave_execution_exception&) + { + gripe_library_execution_error (); + } +} + +extern "C" void +octave_jit_paren_subsasgn_impl (jit_matrix *ret, jit_matrix *mat, + octave_idx_type index, double value) +{ + NDArray *array = mat->array; + if (array->nelem () < index) + array->resize1 (index); + + double *data = array->fortran_vec (); + data[index - 1] = value; + + mat->update (); + *ret = *mat; +} + +extern "C" void +octave_jit_paren_subsasgn_matrix_range (jit_matrix *result, jit_matrix *mat, + jit_range *index, double value) +{ + NDArray *array = mat->array; + bool done = false; + + // optimize for the simple case (no resizing and no errors) + if (*array->jit_ref_count () == 1 + && index->all_elements_are_ints ()) + { + // this code is similar to idx_vector::fill, but we avoid allocating an + // idx_vector and its associated rep + octave_idx_type start = static_cast<octave_idx_type> (index->base) - 1; + octave_idx_type step = static_cast<octave_idx_type> (index->inc); + octave_idx_type nelem = index->nelem; + octave_idx_type final = start + nelem * step; + if (step < 0) + { + step = -step; + std::swap (final, start); + } + + if (start >= 0 && final < mat->slice_len) + { + done = true; + + double *data = array->jit_slice_data (); + if (step == 1) + std::fill (data + start, data + start + nelem, value); + else + { + for (octave_idx_type i = start; i < final; i += step) + data[i] = value; + } + } + } + + if (! done) + { + idx_vector idx (*index); + NDArray avalue (dim_vector (1, 1)); + avalue.xelem (0) = value; + array->assign (idx, avalue); + } + + result->update (array); +} + +extern "C" Complex +octave_jit_complex_div (Complex lhs, Complex rhs) +{ + // see src/OPERATORS/op-cs-cs.cc + if (rhs == 0.0) + gripe_divide_by_zero (); + + return lhs / rhs; +} + +// FIXME: CP form src/xpow.cc +static inline int +xisint (double x) +{ + return (D_NINT (x) == x + && ((x >= 0 && x < INT_MAX) + || (x <= 0 && x > INT_MIN))); +} + +extern "C" Complex +octave_jit_pow_scalar_scalar (double lhs, double rhs) +{ + // FIXME: almost CP from src/xpow.cc + if (lhs < 0.0 && ! xisint (rhs)) + return std::pow (Complex (lhs), rhs); + return std::pow (lhs, rhs); +} + +extern "C" Complex +octave_jit_pow_complex_complex (Complex lhs, Complex rhs) +{ + if (lhs.imag () == 0 && rhs.imag () == 0) + return octave_jit_pow_scalar_scalar (lhs.real (), rhs.real ()); + return std::pow (lhs, rhs); +} + +extern "C" Complex +octave_jit_pow_complex_scalar (Complex lhs, double rhs) +{ + if (lhs.imag () == 0) + return octave_jit_pow_scalar_scalar (lhs.real (), rhs); + return std::pow (lhs, rhs); +} + +extern "C" Complex +octave_jit_pow_scalar_complex (double lhs, Complex rhs) +{ + if (rhs.imag () == 0) + return octave_jit_pow_scalar_scalar (lhs, rhs.real ()); + return std::pow (lhs, rhs); +} + +extern "C" void +octave_jit_print_matrix (jit_matrix *m) +{ + std::cout << *m << std::endl; +} + +static void +gripe_bad_result (void) +{ + error ("incorrect type information given to the JIT compiler"); +} + +// FIXME: Add support for multiple outputs +extern "C" octave_base_value * +octave_jit_call (octave_builtin::fcn fn, size_t nargin, + octave_base_value **argin, jit_type *result_type) +{ + octave_value_list ovl (nargin); + for (size_t i = 0; i < nargin; ++i) + ovl.xelem (i) = octave_value (argin[i]); + + ovl = fn (ovl, 1); + + // These type checks are not strictly required, but I'm guessing that + // incorrect types will be entered on occasion. This will be very difficult to + // debug unless we do the sanity check here. + if (result_type) + { + if (ovl.length () != 1) + { + gripe_bad_result (); + return 0; + } + + octave_value& result = ovl.xelem (0); + jit_type *jtype = jit_typeinfo::join (jit_typeinfo::type_of (result), + result_type); + if (jtype != result_type) + { + gripe_bad_result (); + return 0; + } + + octave_base_value *ret = result.internal_rep (); + ret->grab (); + return ret; + } + + if (! (ovl.length () == 0 + || (ovl.length () == 1 && ovl.xelem (0).is_undefined ()))) + gripe_bad_result (); + + return 0; +} + +// -------------------- jit_range -------------------- +bool +jit_range::all_elements_are_ints () const +{ + Range r (*this); + return r.all_elements_are_ints (); +} + +std::ostream& +operator<< (std::ostream& os, const jit_range& rng) +{ + return os << "Range[" << rng.base << ", " << rng.limit << ", " << rng.inc + << ", " << rng.nelem << "]"; +} + +// -------------------- jit_matrix -------------------- + +std::ostream& +operator<< (std::ostream& os, const jit_matrix& mat) +{ + return os << "Matrix[" << mat.ref_count << ", " << mat.slice_data << ", " + << mat.slice_len << ", " << mat.dimensions << ", " + << mat.array << "]"; +} + +// -------------------- jit_type -------------------- +jit_type::jit_type (const std::string& aname, jit_type *aparent, + llvm::Type *allvm_type, int aid) : + mname (aname), mparent (aparent), llvm_type (allvm_type), mid (aid), + mdepth (aparent ? aparent->mdepth + 1 : 0) +{ + std::memset (msret, 0, sizeof (msret)); + std::memset (mpointer_arg, 0, sizeof (mpointer_arg)); + std::memset (mpack, 0, sizeof (mpack)); + std::memset (munpack, 0, sizeof (munpack)); + + for (size_t i = 0; i < jit_convention::length; ++i) + mpacked_type[i] = llvm_type; +} + +llvm::Type * +jit_type::to_llvm_arg (void) const +{ + return llvm_type ? llvm_type->getPointerTo () : 0; +} + +// -------------------- jit_function -------------------- +jit_function::jit_function () : module (0), llvm_function (0), mresult (0), + call_conv (jit_convention::length), + mcan_error (false) +{} + +jit_function::jit_function (llvm::Module *amodule, + jit_convention::type acall_conv, + const llvm::Twine& aname, jit_type *aresult, + const std::vector<jit_type *>& aargs) + : module (amodule), mresult (aresult), args (aargs), call_conv (acall_conv), + mcan_error (false) +{ + llvm::SmallVector<llvm::Type *, 15> llvm_args; + + llvm::Type *rtype = llvm::Type::getVoidTy (context); + if (mresult) + { + rtype = mresult->packed_type (call_conv); + if (sret ()) + { + llvm_args.push_back (rtype->getPointerTo ()); + rtype = llvm::Type::getVoidTy (context); + } + } + + for (std::vector<jit_type *>::const_iterator iter = args.begin (); + iter != args.end (); ++iter) + { + jit_type *ty = *iter; + assert (ty); + llvm::Type *argty = ty->packed_type (call_conv); + if (ty->pointer_arg (call_conv)) + argty = argty->getPointerTo (); + + llvm_args.push_back (argty); + } + + // we mark all functinos as external linkage because this prevents llvm + // from getting rid of always inline functions + llvm::FunctionType *ft = llvm::FunctionType::get (rtype, llvm_args, false); + llvm_function = llvm::Function::Create (ft, llvm::Function::ExternalLinkage, + aname, module); + if (call_conv == jit_convention::internal) + llvm_function->addFnAttr (llvm::Attribute::AlwaysInline); +} + +jit_function::jit_function (const jit_function& fn, jit_type *aresult, + const std::vector<jit_type *>& aargs) + : module (fn.module), llvm_function (fn.llvm_function), mresult (aresult), + args (aargs), call_conv (fn.call_conv), mcan_error (fn.mcan_error) +{ +} + +jit_function::jit_function (const jit_function& fn) + : module (fn.module), llvm_function (fn.llvm_function), mresult (fn.mresult), + args (fn.args), call_conv (fn.call_conv), mcan_error (fn.mcan_error) +{} + +std::string +jit_function::name (void) const +{ + return llvm_function->getName (); +} + +llvm::BasicBlock * +jit_function::new_block (const std::string& aname, + llvm::BasicBlock *insert_before) +{ + return llvm::BasicBlock::Create (context, aname, llvm_function, + insert_before); +} + +llvm::Value * +jit_function::call (llvm::IRBuilderD& builder, + const std::vector<jit_value *>& in_args) const +{ + assert (in_args.size () == args.size ()); + + std::vector<llvm::Value *> llvm_args (args.size ()); + for (size_t i = 0; i < in_args.size (); ++i) + llvm_args[i] = in_args[i]->to_llvm (); + + return call (builder, llvm_args); +} + +llvm::Value * +jit_function::call (llvm::IRBuilderD& builder, + const std::vector<llvm::Value *>& in_args) const +{ + assert (valid ()); + assert (in_args.size () == args.size ()); + llvm::Function *stacksave + = llvm::Intrinsic::getDeclaration (module, llvm::Intrinsic::stacksave); + llvm::SmallVector<llvm::Value *, 10> llvm_args; + llvm_args.reserve (in_args.size () + sret ()); + + llvm::Value *sret_mem = 0; + llvm::Value *saved_stack = 0; + if (sret ()) + { + saved_stack = builder.CreateCall (stacksave); + sret_mem = builder.CreateAlloca (mresult->packed_type (call_conv)); + llvm_args.push_back (sret_mem); + } + + for (size_t i = 0; i < in_args.size (); ++i) + { + llvm::Value *arg = in_args[i]; + jit_type::convert_fn convert = args[i]->pack (call_conv); + if (convert) + arg = convert (builder, arg); + + if (args[i]->pointer_arg (call_conv)) + { + if (! saved_stack) + saved_stack = builder.CreateCall (stacksave); + + arg = builder.CreateAlloca (args[i]->to_llvm ()); + builder.CreateStore (in_args[i], arg); + } + + llvm_args.push_back (arg); + } + + llvm::Value *ret = builder.CreateCall (llvm_function, llvm_args); + if (sret_mem) + ret = builder.CreateLoad (sret_mem); + + if (mresult) + { + jit_type::convert_fn unpack = mresult->unpack (call_conv); + if (unpack) + ret = unpack (builder, ret); + } + + if (saved_stack) + { + llvm::Function *stackrestore + = llvm::Intrinsic::getDeclaration (module, + llvm::Intrinsic::stackrestore); + builder.CreateCall (stackrestore, saved_stack); + } + + return ret; +} + +llvm::Value * +jit_function::argument (llvm::IRBuilderD& builder, size_t idx) const +{ + assert (idx < args.size ()); + + // FIXME: We should be treating arguments like a list, not a vector. Shouldn't + // matter much for now, as the number of arguments shouldn't be much bigger + // than 4 + llvm::Function::arg_iterator iter = llvm_function->arg_begin (); + if (sret ()) + ++iter; + + for (size_t i = 0; i < idx; ++i, ++iter); + + if (args[idx]->pointer_arg (call_conv)) + return builder.CreateLoad (iter); + + return iter; +} + +void +jit_function::do_return (llvm::IRBuilderD& builder, llvm::Value *rval) +{ + assert (! rval == ! mresult); + + if (rval) + { + jit_type::convert_fn convert = mresult->pack (call_conv); + if (convert) + rval = convert (builder, rval); + + if (sret ()) + builder.CreateStore (rval, llvm_function->arg_begin ()); + else + builder.CreateRet (rval); + } + else + builder.CreateRetVoid (); + + llvm::verifyFunction (*llvm_function); +} + +void +jit_function::do_add_mapping (llvm::ExecutionEngine *engine, void *fn) +{ + assert (valid ()); + engine->addGlobalMapping (llvm_function, fn); +} + +std::ostream& +operator<< (std::ostream& os, const jit_function& fn) +{ + llvm::Function *lfn = fn.to_llvm (); + os << "jit_function: cc=" << fn.call_conv; + llvm::raw_os_ostream llvm_out (os); + lfn->print (llvm_out); + llvm_out.flush (); + return os; +} + +// -------------------- jit_operation -------------------- +void +jit_operation::add_overload (const jit_function& func, + const std::vector<jit_type*>& args) +{ + if (args.size () >= overloads.size ()) + overloads.resize (args.size () + 1); + + Array<jit_function>& over = overloads[args.size ()]; + dim_vector dv (over.dims ()); + Array<octave_idx_type> idx = to_idx (args); + bool must_resize = false; + + if (dv.length () != idx.numel ()) + { + dv.resize (idx.numel ()); + must_resize = true; + } + + for (octave_idx_type i = 0; i < dv.length (); ++i) + if (dv(i) <= idx(i)) + { + must_resize = true; + dv(i) = idx(i) + 1; + } + + if (must_resize) + over.resize (dv); + + over(idx) = func; +} + +const jit_function& +jit_operation::overload (const std::vector<jit_type*>& types) const +{ + // FIXME: We should search for the next best overload on failure + static jit_function null_overload; + if (types.size () >= overloads.size ()) + return null_overload; + + for (size_t i =0; i < types.size (); ++i) + if (! types[i]) + return null_overload; + + const Array<jit_function>& over = overloads[types.size ()]; + dim_vector dv (over.dims ()); + Array<octave_idx_type> idx = to_idx (types); + for (octave_idx_type i = 0; i < dv.length (); ++i) + if (idx(i) >= dv(i)) + return null_overload; + + return over(idx); +} + +Array<octave_idx_type> +jit_operation::to_idx (const std::vector<jit_type*>& types) const +{ + octave_idx_type numel = types.size (); + if (numel == 1) + numel = 2; + + Array<octave_idx_type> idx (dim_vector (1, numel)); + for (octave_idx_type i = 0; i < static_cast<octave_idx_type> (types.size ()); + ++i) + idx(i) = types[i]->type_id (); + + if (types.size () == 1) + { + idx(1) = idx(0); + idx(0) = 0; + } + + return idx; +} + +// -------------------- jit_typeinfo -------------------- +void +jit_typeinfo::initialize (llvm::Module *m, llvm::ExecutionEngine *e) +{ + new jit_typeinfo (m, e); +} + +jit_typeinfo::jit_typeinfo (llvm::Module *m, llvm::ExecutionEngine *e) + : module (m), engine (e), next_id (0), + builder (*new llvm::IRBuilderD (context)) +{ + instance = this; + + // FIXME: We should be registering types like in octave_value_typeinfo + llvm::Type *any_t = llvm::StructType::create (context, "octave_base_value"); + any_t = any_t->getPointerTo (); + + llvm::Type *scalar_t = llvm::Type::getDoubleTy (context); + llvm::Type *bool_t = llvm::Type::getInt1Ty (context); + llvm::Type *string_t = llvm::Type::getInt8Ty (context); + string_t = string_t->getPointerTo (); + llvm::Type *index_t = llvm::Type::getIntNTy (context, + sizeof(octave_idx_type) * 8); + + llvm::StructType *range_t = llvm::StructType::create (context, "range"); + std::vector<llvm::Type *> range_contents (4, scalar_t); + range_contents[3] = index_t; + range_t->setBody (range_contents); + + llvm::Type *refcount_t = llvm::Type::getIntNTy (context, sizeof(int) * 8); + + llvm::StructType *matrix_t = llvm::StructType::create (context, "matrix"); + llvm::Type *matrix_contents[5]; + matrix_contents[0] = refcount_t->getPointerTo (); + matrix_contents[1] = scalar_t->getPointerTo (); + matrix_contents[2] = index_t; + matrix_contents[3] = index_t->getPointerTo (); + matrix_contents[4] = string_t; + matrix_t->setBody (llvm::makeArrayRef (matrix_contents, 5)); + + llvm::Type *complex_t = llvm::VectorType::get (scalar_t, 2); + + // complex_ret is what is passed to C functions in order to get calling + // convention right + complex_ret = llvm::StructType::create (context, "complex_ret"); + llvm::Type *complex_ret_contents[] = {scalar_t, scalar_t}; + complex_ret->setBody (complex_ret_contents); + + // create types + any = new_type ("any", 0, any_t); + matrix = new_type ("matrix", any, matrix_t); + complex = new_type ("complex", any, complex_t); + scalar = new_type ("scalar", complex, scalar_t); + range = new_type ("range", any, range_t); + string = new_type ("string", any, string_t); + boolean = new_type ("bool", any, bool_t); + index = new_type ("index", any, index_t); + + create_int (8); + create_int (16); + create_int (32); + create_int (64); + + casts.resize (next_id + 1); + identities.resize (next_id + 1); + + // specify calling conventions + // FIXME: We should detect architecture and do something sane based on that + // here we assume x86 or x86_64 + matrix->mark_sret (); + matrix->mark_pointer_arg (); + + range->mark_sret (); + range->mark_pointer_arg (); + + complex->set_pack (jit_convention::external, &jit_typeinfo::pack_complex); + complex->set_unpack (jit_convention::external, &jit_typeinfo::unpack_complex); + complex->set_packed_type (jit_convention::external, complex_ret); + + if (sizeof (void *) == 4) + complex->mark_sret (); + + // bind global variables + lerror_state = new llvm::GlobalVariable (*module, bool_t, false, + llvm::GlobalValue::ExternalLinkage, + 0, "error_state"); + engine->addGlobalMapping (lerror_state, + reinterpret_cast<void *> (&error_state)); + + // any with anything is an any op + jit_function fn; + jit_type *binary_op_type = intN (sizeof (octave_value::binary_op) * 8); + llvm::Type *llvm_bo_type = binary_op_type->to_llvm (); + jit_function any_binary = create_function (jit_convention::external, + "octave_jit_binary_any_any", + any, binary_op_type, any, any); + any_binary.add_mapping (engine, &octave_jit_binary_any_any); + any_binary.mark_can_error (); + binary_ops.resize (octave_value::num_binary_ops); + for (size_t i = 0; i < octave_value::num_binary_ops; ++i) + { + octave_value::binary_op op = static_cast<octave_value::binary_op> (i); + std::string op_name = octave_value::binary_op_as_string (op); + binary_ops[i].stash_name ("binary" + op_name); + } + + for (int op = 0; op < octave_value::num_binary_ops; ++op) + { + llvm::Twine fn_name ("octave_jit_binary_any_any_"); + fn_name = fn_name + llvm::Twine (op); + + fn = create_function (jit_convention::internal, fn_name, any, any, any); + fn.mark_can_error (); + llvm::BasicBlock *block = fn.new_block (); + builder.SetInsertPoint (block); + llvm::APInt op_int(sizeof (octave_value::binary_op) * 8, op, + std::numeric_limits<octave_value::binary_op>::is_signed); + llvm::Value *op_as_llvm = llvm::ConstantInt::get (llvm_bo_type, op_int); + llvm::Value *ret = any_binary.call (builder, op_as_llvm, + fn.argument (builder, 0), + fn.argument (builder, 1)); + fn.do_return (builder, ret); + binary_ops[op].add_overload (fn); + } + + // grab any + fn = create_function (jit_convention::external, "octave_jit_grab_any", any, + any); + fn.add_mapping (engine, &octave_jit_grab_any); + grab_fn.add_overload (fn); + grab_fn.stash_name ("grab"); + + // grab matrix + fn = create_function (jit_convention::external, "octave_jit_grab_matrix", + matrix, matrix); + fn.add_mapping (engine, &octave_jit_grab_matrix); + grab_fn.add_overload (fn); + + // release any + fn = create_function (jit_convention::external, "octave_jit_release_any", 0, + any); + fn.add_mapping (engine, &octave_jit_release_any); + release_fn.add_overload (fn); + release_fn.stash_name ("release"); + + // release matrix + fn = create_function (jit_convention::external, "octave_jit_release_matrix", + 0, matrix); + fn.add_mapping (engine, &octave_jit_release_matrix); + release_fn.add_overload (fn); + + // release scalar + fn = create_identity (scalar); + release_fn.add_overload (fn); + + // release complex + fn = create_identity (complex); + release_fn.add_overload (fn); + + // release index + fn = create_identity (index); + release_fn.add_overload (fn); + + // now for binary scalar operations + // FIXME: Finish all operations + add_binary_op (scalar, octave_value::op_add, llvm::Instruction::FAdd); + add_binary_op (scalar, octave_value::op_sub, llvm::Instruction::FSub); + add_binary_op (scalar, octave_value::op_mul, llvm::Instruction::FMul); + add_binary_op (scalar, octave_value::op_el_mul, llvm::Instruction::FMul); + + add_binary_fcmp (scalar, octave_value::op_lt, llvm::CmpInst::FCMP_ULT); + add_binary_fcmp (scalar, octave_value::op_le, llvm::CmpInst::FCMP_ULE); + add_binary_fcmp (scalar, octave_value::op_eq, llvm::CmpInst::FCMP_UEQ); + add_binary_fcmp (scalar, octave_value::op_ge, llvm::CmpInst::FCMP_UGE); + add_binary_fcmp (scalar, octave_value::op_gt, llvm::CmpInst::FCMP_UGT); + add_binary_fcmp (scalar, octave_value::op_ne, llvm::CmpInst::FCMP_UNE); + + jit_function gripe_div0 = create_function (jit_convention::external, + "gripe_divide_by_zero", 0); + gripe_div0.add_mapping (engine, &gripe_divide_by_zero); + gripe_div0.mark_can_error (); + + // divide is annoying because it might error + fn = create_function (jit_convention::internal, + "octave_jit_div_scalar_scalar", scalar, scalar, scalar); + fn.mark_can_error (); + + llvm::BasicBlock *body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::BasicBlock *warn_block = fn.new_block ("warn"); + llvm::BasicBlock *normal_block = fn.new_block ("normal"); + + llvm::Value *zero = llvm::ConstantFP::get (scalar_t, 0); + llvm::Value *check = builder.CreateFCmpUEQ (zero, fn.argument (builder, 0)); + builder.CreateCondBr (check, warn_block, normal_block); + + builder.SetInsertPoint (warn_block); + gripe_div0.call (builder); + builder.CreateBr (normal_block); + + builder.SetInsertPoint (normal_block); + llvm::Value *ret = builder.CreateFDiv (fn.argument (builder, 0), + fn.argument (builder, 1)); + fn.do_return (builder, ret); + } + binary_ops[octave_value::op_div].add_overload (fn); + binary_ops[octave_value::op_el_div].add_overload (fn); + + // ldiv is the same as div with the operators reversed + fn = mirror_binary (fn); + binary_ops[octave_value::op_ldiv].add_overload (fn); + binary_ops[octave_value::op_el_ldiv].add_overload (fn); + + // In general, the result of scalar ^ scalar is a complex number. We might be + // able to improve on this if we keep track of the range of values varaibles + // can take on. + fn = create_function (jit_convention::external, + "octave_jit_pow_scalar_scalar", complex, scalar, + scalar); + fn.add_mapping (engine, &octave_jit_pow_scalar_scalar); + binary_ops[octave_value::op_pow].add_overload (fn); + binary_ops[octave_value::op_el_pow].add_overload (fn); + + // now for binary complex operations + add_binary_op (complex, octave_value::op_add, llvm::Instruction::FAdd); + add_binary_op (complex, octave_value::op_sub, llvm::Instruction::FSub); + + fn = create_function (jit_convention::internal, + "octave_jit_*_complex_complex", complex, complex, + complex); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + // (x0*x1 - y0*y1, x0*y1 + y0*x1) = (x0,y0) * (x1,y1) + // We compute this in one vectorized multiplication, a subtraction, and an + // addition. + llvm::Value *lhs = fn.argument (builder, 0); + llvm::Value *rhs = fn.argument (builder, 1); + + // FIXME: We need a better way of doing this, working with llvm's IR + // directly is sort of a pain. + llvm::Value *zero = builder.getInt32 (0); + llvm::Value *one = builder.getInt32 (1); + llvm::Value *two = builder.getInt32 (2); + llvm::Value *three = builder.getInt32 (3); + + llvm::Type *vec4 = llvm::VectorType::get (scalar_t, 4); + llvm::Value *mlhs = llvm::UndefValue::get (vec4); + llvm::Value *mrhs = mlhs; + + llvm::Value *temp = complex_real (lhs); + mlhs = builder.CreateInsertElement (mlhs, temp, zero); + mlhs = builder.CreateInsertElement (mlhs, temp, two); + temp = complex_imag (lhs); + mlhs = builder.CreateInsertElement (mlhs, temp, one); + mlhs = builder.CreateInsertElement (mlhs, temp, three); + + temp = complex_real (rhs); + mrhs = builder.CreateInsertElement (mrhs, temp, zero); + mrhs = builder.CreateInsertElement (mrhs, temp, three); + temp = complex_imag (rhs); + mrhs = builder.CreateInsertElement (mrhs, temp, one); + mrhs = builder.CreateInsertElement (mrhs, temp, two); + + llvm::Value *mres = builder.CreateFMul (mlhs, mrhs); + llvm::Value *tlhs = builder.CreateExtractElement (mres, zero); + llvm::Value *trhs = builder.CreateExtractElement (mres, one); + llvm::Value *ret_real = builder.CreateFSub (tlhs, trhs); + + tlhs = builder.CreateExtractElement (mres, two); + trhs = builder.CreateExtractElement (mres, three); + llvm::Value *ret_imag = builder.CreateFAdd (tlhs, trhs); + fn.do_return (builder, complex_new (ret_real, ret_imag)); + } + + binary_ops[octave_value::op_mul].add_overload (fn); + binary_ops[octave_value::op_el_mul].add_overload (fn); + + jit_function complex_div = create_function (jit_convention::external, + "octave_jit_complex_div", + complex, complex, complex); + complex_div.add_mapping (engine, &octave_jit_complex_div); + complex_div.mark_can_error (); + binary_ops[octave_value::op_div].add_overload (fn); + binary_ops[octave_value::op_ldiv].add_overload (fn); + + fn = mirror_binary (complex_div); + binary_ops[octave_value::op_ldiv].add_overload (fn); + binary_ops[octave_value::op_el_ldiv].add_overload (fn); + + fn = create_function (jit_convention::external, + "octave_jit_pow_complex_complex", complex, complex, + complex); + fn.add_mapping (engine, &octave_jit_pow_complex_complex); + binary_ops[octave_value::op_pow].add_overload (fn); + binary_ops[octave_value::op_el_pow].add_overload (fn); + + fn = create_function (jit_convention::internal, + "octave_jit_*_scalar_complex", complex, scalar, + complex); + jit_function mul_scalar_complex = fn; + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *lhs = fn.argument (builder, 0); + llvm::Value *tlhs = complex_new (lhs, lhs); + llvm::Value *rhs = fn.argument (builder, 1); + fn.do_return (builder, builder.CreateFMul (tlhs, rhs)); + } + binary_ops[octave_value::op_mul].add_overload (fn); + binary_ops[octave_value::op_el_mul].add_overload (fn); + + + fn = mirror_binary (mul_scalar_complex); + binary_ops[octave_value::op_mul].add_overload (fn); + binary_ops[octave_value::op_el_mul].add_overload (fn); + + fn = create_function (jit_convention::internal, "octave_jit_+_scalar_complex", + complex, scalar, complex); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *lhs = fn.argument (builder, 0); + llvm::Value *rhs = fn.argument (builder, 1); + llvm::Value *real = builder.CreateFAdd (lhs, complex_real (rhs)); + fn.do_return (builder, complex_real (rhs, real)); + } + binary_ops[octave_value::op_add].add_overload (fn); + + fn = mirror_binary (fn); + binary_ops[octave_value::op_add].add_overload (fn); + + fn = create_function (jit_convention::internal, "octave_jit_-_complex_scalar", + complex, complex, scalar); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *lhs = fn.argument (builder, 0); + llvm::Value *rhs = fn.argument (builder, 1); + llvm::Value *real = builder.CreateFSub (complex_real (lhs), rhs); + fn.do_return (builder, complex_real (lhs, real)); + } + binary_ops[octave_value::op_sub].add_overload (fn); + + fn = create_function (jit_convention::internal, "octave_jit_-_scalar_complex", + complex, scalar, complex); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *lhs = fn.argument (builder, 0); + llvm::Value *rhs = fn.argument (builder, 1); + llvm::Value *real = builder.CreateFSub (lhs, complex_real (rhs)); + fn.do_return (builder, complex_real (rhs, real)); + } + binary_ops[octave_value::op_sub].add_overload (fn); + + fn = create_function (jit_convention::external, + "octave_jit_pow_scalar_complex", complex, scalar, + complex); + fn.add_mapping (engine, &octave_jit_pow_scalar_complex); + binary_ops[octave_value::op_pow].add_overload (fn); + binary_ops[octave_value::op_el_pow].add_overload (fn); + + fn = create_function (jit_convention::external, + "octave_jit_pow_complex_scalar", complex, complex, + scalar); + fn.add_mapping (engine, &octave_jit_pow_complex_scalar); + binary_ops[octave_value::op_pow].add_overload (fn); + binary_ops[octave_value::op_el_pow].add_overload (fn); + + // now for binary index operators + add_binary_op (index, octave_value::op_add, llvm::Instruction::Add); + + // and binary bool operators + add_binary_op (boolean, octave_value::op_el_or, llvm::Instruction::Or); + add_binary_op (boolean, octave_value::op_el_and, llvm::Instruction::And); + + // now for printing functions + print_fn.stash_name ("print"); + add_print (any, reinterpret_cast<void *> (&octave_jit_print_any)); + add_print (scalar, reinterpret_cast<void *> (&octave_jit_print_scalar)); + + // initialize for loop + for_init_fn.stash_name ("for_init"); + + fn = create_function (jit_convention::internal, "octave_jit_for_range_init", + index, range); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *zero = llvm::ConstantInt::get (index_t, 0); + fn.do_return (builder, zero); + } + for_init_fn.add_overload (fn); + + // bounds check for for loop + for_check_fn.stash_name ("for_check"); + + fn = create_function (jit_convention::internal, "octave_jit_for_range_check", + boolean, range, index); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *nelem + = builder.CreateExtractValue (fn.argument (builder, 0), 3); + llvm::Value *idx = fn.argument (builder, 1); + llvm::Value *ret = builder.CreateICmpULT (idx, nelem); + fn.do_return (builder, ret); + } + for_check_fn.add_overload (fn); + + // index variabe for for loop + for_index_fn.stash_name ("for_index"); + + fn = create_function (jit_convention::internal, "octave_jit_for_range_idx", + scalar, range, index); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *idx = fn.argument (builder, 1); + llvm::Value *didx = builder.CreateSIToFP (idx, scalar_t); + llvm::Value *rng = fn.argument (builder, 0); + llvm::Value *base = builder.CreateExtractValue (rng, 0); + llvm::Value *inc = builder.CreateExtractValue (rng, 2); + + llvm::Value *ret = builder.CreateFMul (didx, inc); + ret = builder.CreateFAdd (base, ret); + fn.do_return (builder, ret); + } + for_index_fn.add_overload (fn); + + // logically true + logically_true_fn.stash_name ("logically_true"); + + jit_function gripe_nantl + = create_function (jit_convention::external, + "octave_jit_gripe_nan_to_logical_conversion", 0); + gripe_nantl.add_mapping (engine, &octave_jit_gripe_nan_to_logical_conversion); + gripe_nantl.mark_can_error (); + + fn = create_function (jit_convention::internal, + "octave_jit_logically_true_scalar", boolean, scalar); + fn.mark_can_error (); + + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::BasicBlock *error_block = fn.new_block ("error"); + llvm::BasicBlock *normal_block = fn.new_block ("normal"); + + llvm::Value *check = builder.CreateFCmpUNE (fn.argument (builder, 0), + fn.argument (builder, 0)); + builder.CreateCondBr (check, error_block, normal_block); + + builder.SetInsertPoint (error_block); + gripe_nantl.call (builder); + builder.CreateBr (normal_block); + builder.SetInsertPoint (normal_block); + + llvm::Value *zero = llvm::ConstantFP::get (scalar_t, 0); + llvm::Value *ret = builder.CreateFCmpONE (fn.argument (builder, 0), zero); + fn.do_return (builder, ret); + } + logically_true_fn.add_overload (fn); + + // logically_true boolean + fn = create_identity (boolean); + logically_true_fn.add_overload (fn); + + // make_range + // FIXME: May be benificial to implement all in LLVM + make_range_fn.stash_name ("make_range"); + jit_function compute_nelem + = create_function (jit_convention::external, "octave_jit_compute_nelem", + index, scalar, scalar, scalar); + compute_nelem.add_mapping (engine, &octave_jit_compute_nelem); + + fn = create_function (jit_convention::internal, "octave_jit_make_range", + range, scalar, scalar, scalar); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *base = fn.argument (builder, 0); + llvm::Value *limit = fn.argument (builder, 1); + llvm::Value *inc = fn.argument (builder, 2); + llvm::Value *nelem = compute_nelem.call (builder, base, limit, inc); + + llvm::Value *dzero = llvm::ConstantFP::get (scalar_t, 0); + llvm::Value *izero = llvm::ConstantInt::get (index_t, 0); + llvm::Value *rng = llvm::ConstantStruct::get (range_t, dzero, dzero, dzero, + izero, NULL); + rng = builder.CreateInsertValue (rng, base, 0); + rng = builder.CreateInsertValue (rng, limit, 1); + rng = builder.CreateInsertValue (rng, inc, 2); + rng = builder.CreateInsertValue (rng, nelem, 3); + fn.do_return (builder, rng); + } + make_range_fn.add_overload (fn); + + // paren_subsref + jit_type *jit_int = intN (sizeof (int) * 8); + llvm::Type *int_t = jit_int->to_llvm (); + jit_function ginvalid_index + = create_function (jit_convention::external, "octave_jit_ginvalid_index", + 0); + ginvalid_index.add_mapping (engine, &octave_jit_ginvalid_index); + jit_function gindex_range = create_function (jit_convention::external, + "octave_jit_gindex_range", + 0, jit_int, jit_int, index, + index); + gindex_range.add_mapping (engine, &octave_jit_gindex_range); + + fn = create_function (jit_convention::internal, "()subsref", scalar, matrix, + scalar); + fn.mark_can_error (); + + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *one = llvm::ConstantInt::get (index_t, 1); + llvm::Value *ione; + if (index_t == int_t) + ione = one; + else + ione = llvm::ConstantInt::get (int_t, 1); + + llvm::Value *undef = llvm::UndefValue::get (scalar_t); + llvm::Value *mat = fn.argument (builder, 0); + llvm::Value *idx = fn.argument (builder, 1); + + // convert index to scalar to integer, and check index >= 1 + llvm::Value *int_idx = builder.CreateFPToSI (idx, index_t); + llvm::Value *check_idx = builder.CreateSIToFP (int_idx, scalar_t); + llvm::Value *cond0 = builder.CreateFCmpUNE (idx, check_idx); + llvm::Value *cond1 = builder.CreateICmpSLT (int_idx, one); + llvm::Value *cond = builder.CreateOr (cond0, cond1); + + llvm::BasicBlock *done = fn.new_block ("done"); + llvm::BasicBlock *conv_error = fn.new_block ("conv_error", done); + llvm::BasicBlock *normal = fn.new_block ("normal", done); + builder.CreateCondBr (cond, conv_error, normal); + + builder.SetInsertPoint (conv_error); + ginvalid_index.call (builder); + builder.CreateBr (done); + + builder.SetInsertPoint (normal); + llvm::Value *len = builder.CreateExtractValue (mat, + llvm::ArrayRef<unsigned> (2)); + cond = builder.CreateICmpSGT (int_idx, len); + + + llvm::BasicBlock *bounds_error = fn.new_block ("bounds_error", done); + llvm::BasicBlock *success = fn.new_block ("success", done); + builder.CreateCondBr (cond, bounds_error, success); + + builder.SetInsertPoint (bounds_error); + gindex_range.call (builder, ione, ione, int_idx, len); + builder.CreateBr (done); + + builder.SetInsertPoint (success); + llvm::Value *data = builder.CreateExtractValue (mat, + llvm::ArrayRef<unsigned> (1)); + llvm::Value *gep = builder.CreateInBoundsGEP (data, int_idx); + llvm::Value *ret = builder.CreateLoad (gep); + builder.CreateBr (done); + + builder.SetInsertPoint (done); + + llvm::PHINode *merge = llvm::PHINode::Create (scalar_t, 3); + builder.Insert (merge); + merge->addIncoming (undef, conv_error); + merge->addIncoming (undef, bounds_error); + merge->addIncoming (ret, success); + fn.do_return (builder, merge); + } + paren_subsref_fn.add_overload (fn); + + // paren subsasgn + paren_subsasgn_fn.stash_name ("()subsasgn"); + + jit_function resize_paren_subsasgn + = create_function (jit_convention::external, + "octave_jit_paren_subsasgn_impl", matrix, matrix, index, + scalar); + resize_paren_subsasgn.add_mapping (engine, &octave_jit_paren_subsasgn_impl); + fn = create_function (jit_convention::internal, "octave_jit_paren_subsasgn", + matrix, matrix, scalar, scalar); + fn.mark_can_error (); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *one = llvm::ConstantInt::get (index_t, 1); + + llvm::Value *mat = fn.argument (builder, 0); + llvm::Value *idx = fn.argument (builder, 1); + llvm::Value *value = fn.argument (builder, 2); + + llvm::Value *int_idx = builder.CreateFPToSI (idx, index_t); + llvm::Value *check_idx = builder.CreateSIToFP (int_idx, scalar_t); + llvm::Value *cond0 = builder.CreateFCmpUNE (idx, check_idx); + llvm::Value *cond1 = builder.CreateICmpSLT (int_idx, one); + llvm::Value *cond = builder.CreateOr (cond0, cond1); + + llvm::BasicBlock *done = fn.new_block ("done"); + + llvm::BasicBlock *conv_error = fn.new_block ("conv_error", done); + llvm::BasicBlock *normal = fn.new_block ("normal", done); + builder.CreateCondBr (cond, conv_error, normal); + builder.SetInsertPoint (conv_error); + ginvalid_index.call (builder); + builder.CreateBr (done); + + builder.SetInsertPoint (normal); + llvm::Value *len = builder.CreateExtractValue (mat, + llvm::ArrayRef<unsigned> (2)); + cond0 = builder.CreateICmpSGT (int_idx, len); + + llvm::Value *rcount = builder.CreateExtractValue (mat, 0); + rcount = builder.CreateLoad (rcount); + cond1 = builder.CreateICmpSGT (rcount, one); + cond = builder.CreateOr (cond0, cond1); + + llvm::BasicBlock *bounds_error = fn.new_block ("bounds_error", done); + llvm::BasicBlock *success = fn.new_block ("success", done); + builder.CreateCondBr (cond, bounds_error, success); + + // resize on out of bounds access + builder.SetInsertPoint (bounds_error); + llvm::Value *resize_result = resize_paren_subsasgn.call (builder, mat, + int_idx, value); + builder.CreateBr (done); + + builder.SetInsertPoint (success); + llvm::Value *data = builder.CreateExtractValue (mat, + llvm::ArrayRef<unsigned> (1)); + llvm::Value *gep = builder.CreateInBoundsGEP (data, int_idx); + builder.CreateStore (value, gep); + builder.CreateBr (done); + + builder.SetInsertPoint (done); + + llvm::PHINode *merge = llvm::PHINode::Create (matrix_t, 3); + builder.Insert (merge); + merge->addIncoming (mat, conv_error); + merge->addIncoming (resize_result, bounds_error); + merge->addIncoming (mat, success); + fn.do_return (builder, merge); + } + paren_subsasgn_fn.add_overload (fn); + + fn = create_function (jit_convention::external, + "octave_jit_paren_subsasgn_matrix_range", matrix, + matrix, range, scalar); + fn.add_mapping (engine, &octave_jit_paren_subsasgn_matrix_range); + fn.mark_can_error (); + paren_subsasgn_fn.add_overload (fn); + + casts[any->type_id ()].stash_name ("(any)"); + casts[scalar->type_id ()].stash_name ("(scalar)"); + casts[complex->type_id ()].stash_name ("(complex)"); + casts[matrix->type_id ()].stash_name ("(matrix)"); + casts[any->type_id ()].stash_name ("(range)"); + + // cast any <- matrix + fn = create_function (jit_convention::external, "octave_jit_cast_any_matrix", + any, matrix); + fn.add_mapping (engine, &octave_jit_cast_any_matrix); + casts[any->type_id ()].add_overload (fn); + + // cast matrix <- any + fn = create_function (jit_convention::external, "octave_jit_cast_matrix_any", + matrix, any); + fn.add_mapping (engine, &octave_jit_cast_matrix_any); + casts[matrix->type_id ()].add_overload (fn); + + // cast any <- range + fn = create_function (jit_convention::external, "octave_jit_cast_any_range", + any, range); + fn.add_mapping (engine, &octave_jit_cast_any_range); + casts[any->type_id ()].add_overload (fn); + + // cast range <- any + fn = create_function (jit_convention::external, "octave_jit_cast_range_any", + range, any); + fn.add_mapping (engine, &octave_jit_cast_range_any); + casts[range->type_id ()].add_overload (fn); + + // cast any <- scalar + fn = create_function (jit_convention::external, "octave_jit_cast_any_scalar", + any, scalar); + fn.add_mapping (engine, &octave_jit_cast_any_scalar); + casts[any->type_id ()].add_overload (fn); + + // cast scalar <- any + fn = create_function (jit_convention::external, "octave_jit_cast_scalar_any", + scalar, any); + fn.add_mapping (engine, &octave_jit_cast_scalar_any); + casts[scalar->type_id ()].add_overload (fn); + + // cast any <- complex + fn = create_function (jit_convention::external, "octave_jit_cast_any_complex", + any, complex); + fn.add_mapping (engine, &octave_jit_cast_any_complex); + casts[any->type_id ()].add_overload (fn); + + // cast complex <- any + fn = create_function (jit_convention::external, "octave_jit_cast_complex_any", + complex, any); + fn.add_mapping (engine, &octave_jit_cast_complex_any); + casts[complex->type_id ()].add_overload (fn); + + // cast complex <- scalar + fn = create_function (jit_convention::internal, + "octave_jit_cast_complex_scalar", complex, scalar); + body = fn.new_block (); + builder.SetInsertPoint (body); + { + llvm::Value *zero = llvm::ConstantFP::get (scalar_t, 0); + fn.do_return (builder, complex_new (fn.argument (builder, 0), zero)); + } + casts[complex->type_id ()].add_overload (fn); + + // cast scalar <- complex + fn = create_function (jit_convention::internal, + "octave_jit_cast_scalar_complex", scalar, complex); + body = fn.new_block (); + builder.SetInsertPoint (body); + fn.do_return (builder, complex_real (fn.argument (builder, 0))); + casts[scalar->type_id ()].add_overload (fn); + + // cast any <- any + fn = create_identity (any); + casts[any->type_id ()].add_overload (fn); + + // cast scalar <- scalar + fn = create_identity (scalar); + casts[scalar->type_id ()].add_overload (fn); + + // cast complex <- complex + fn = create_identity (complex); + casts[complex->type_id ()].add_overload (fn); + + // -------------------- builtin functions -------------------- + add_builtin ("#unknown_function"); + unknown_function = builtins["#unknown_function"]; + + add_builtin ("sin"); + register_intrinsic ("sin", llvm::Intrinsic::sin, scalar, scalar); + register_generic ("sin", matrix, matrix); + + add_builtin ("cos"); + register_intrinsic ("cos", llvm::Intrinsic::cos, scalar, scalar); + register_generic ("cos", matrix, matrix); + + add_builtin ("exp"); + register_intrinsic ("exp", llvm::Intrinsic::cos, scalar, scalar); + register_generic ("exp", matrix, matrix); + + casts.resize (next_id + 1); + jit_function any_id = create_identity (any); + jit_function release_any = get_release (any); + std::vector<jit_type *> args; + args.resize (1); + + for (std::map<std::string, jit_type *>::iterator iter = builtins.begin (); + iter != builtins.end (); ++iter) + { + jit_type *btype = iter->second; + args[0] = btype; + + release_fn.add_overload (jit_function (release_any, 0, args)); + casts[any->type_id ()].add_overload (jit_function (any_id, any, args)); + + args[0] = any; + casts[btype->type_id ()].add_overload (jit_function (any_id, btype, + args)); + } +} + +void +jit_typeinfo::add_print (jit_type *ty, void *fptr) +{ + std::stringstream name; + name << "octave_jit_print_" << ty->name (); + jit_function fn = create_function (jit_convention::external, name.str (), 0, + intN (8), ty); + fn.add_mapping (engine, fptr); + print_fn.add_overload (fn); +} + +// FIXME: cp between add_binary_op, add_binary_icmp, and add_binary_fcmp +void +jit_typeinfo::add_binary_op (jit_type *ty, int op, int llvm_op) +{ + std::stringstream fname; + octave_value::binary_op ov_op = static_cast<octave_value::binary_op>(op); + fname << "octave_jit_" << octave_value::binary_op_as_string (ov_op) + << "_" << ty->name (); + + jit_function fn = create_function (jit_convention::internal, fname.str (), + ty, ty, ty); + llvm::BasicBlock *block = fn.new_block (); + builder.SetInsertPoint (block); + llvm::Instruction::BinaryOps temp + = static_cast<llvm::Instruction::BinaryOps>(llvm_op); + + llvm::Value *ret = builder.CreateBinOp (temp, fn.argument (builder, 0), + fn.argument (builder, 1)); + fn.do_return (builder, ret); + binary_ops[op].add_overload (fn); +} + +void +jit_typeinfo::add_binary_icmp (jit_type *ty, int op, int llvm_op) +{ + std::stringstream fname; + octave_value::binary_op ov_op = static_cast<octave_value::binary_op>(op); + fname << "octave_jit" << octave_value::binary_op_as_string (ov_op) + << "_" << ty->name (); + + jit_function fn = create_function (jit_convention::internal, fname.str (), + boolean, ty, ty); + llvm::BasicBlock *block = fn.new_block (); + builder.SetInsertPoint (block); + llvm::CmpInst::Predicate temp + = static_cast<llvm::CmpInst::Predicate>(llvm_op); + llvm::Value *ret = builder.CreateICmp (temp, fn.argument (builder, 0), + fn.argument (builder, 1)); + fn.do_return (builder, ret); + binary_ops[op].add_overload (fn); +} + +void +jit_typeinfo::add_binary_fcmp (jit_type *ty, int op, int llvm_op) +{ + std::stringstream fname; + octave_value::binary_op ov_op = static_cast<octave_value::binary_op>(op); + fname << "octave_jit" << octave_value::binary_op_as_string (ov_op) + << "_" << ty->name (); + + jit_function fn = create_function (jit_convention::internal, fname.str (), + boolean, ty, ty); + llvm::BasicBlock *block = fn.new_block (); + builder.SetInsertPoint (block); + llvm::CmpInst::Predicate temp + = static_cast<llvm::CmpInst::Predicate>(llvm_op); + llvm::Value *ret = builder.CreateFCmp (temp, fn.argument (builder, 0), + fn.argument (builder, 1)); + fn.do_return (builder, ret); + binary_ops[op].add_overload (fn); +} + +jit_function +jit_typeinfo::create_function (jit_convention::type cc, const llvm::Twine& name, + jit_type *ret, + const std::vector<jit_type *>& args) +{ + jit_function result (module, cc, name, ret, args); + return result; +} + +jit_function +jit_typeinfo::create_identity (jit_type *type) +{ + size_t id = type->type_id (); + if (id >= identities.size ()) + identities.resize (id + 1); + + if (! identities[id].valid ()) + { + jit_function fn = create_function (jit_convention::internal, "id", type, + type); + llvm::BasicBlock *body = fn.new_block (); + builder.SetInsertPoint (body); + fn.do_return (builder, fn.argument (builder, 0)); + return identities[id] = fn; + } + + return identities[id]; +} + +llvm::Value * +jit_typeinfo::do_insert_error_check (llvm::IRBuilderD& abuilder) +{ + return abuilder.CreateLoad (lerror_state); +} + +void +jit_typeinfo::add_builtin (const std::string& name) +{ + jit_type *btype = new_type (name, any, any->to_llvm ()); + builtins[name] = btype; + + octave_builtin *ov_builtin = find_builtin (name); + if (ov_builtin) + ov_builtin->stash_jit (*btype); +} + +void +jit_typeinfo::register_intrinsic (const std::string& name, size_t iid, + jit_type *result, + const std::vector<jit_type *>& args) +{ + jit_type *builtin_type = builtins[name]; + size_t nargs = args.size (); + llvm::SmallVector<llvm::Type *, 5> llvm_args (nargs); + for (size_t i = 0; i < nargs; ++i) + llvm_args[i] = args[i]->to_llvm (); + + llvm::Intrinsic::ID id = static_cast<llvm::Intrinsic::ID> (iid); + llvm::Function *ifun = llvm::Intrinsic::getDeclaration (module, id, + llvm_args); + std::stringstream fn_name; + fn_name << "octave_jit_" << name; + + std::vector<jit_type *> args1 (nargs + 1); + args1[0] = builtin_type; + std::copy (args.begin (), args.end (), args1.begin () + 1); + + // The first argument will be the Octave function, but we already know that + // the function call is the equivalent of the intrinsic, so we ignore it and + // call the intrinsic with the remaining arguments. + jit_function fn = create_function (jit_convention::internal, fn_name.str (), + result, args1); + llvm::BasicBlock *body = fn.new_block (); + builder.SetInsertPoint (body); + + llvm::SmallVector<llvm::Value *, 5> fargs (nargs); + for (size_t i = 0; i < nargs; ++i) + fargs[i] = fn.argument (builder, i + 1); + + llvm::Value *ret = builder.CreateCall (ifun, fargs); + fn.do_return (builder, ret); + paren_subsref_fn.add_overload (fn); +} + +octave_builtin * +jit_typeinfo::find_builtin (const std::string& name) +{ + // FIXME: Finalize what we want to store in octave_builtin, then add functions + // to access these values in octave_value + octave_value ov_builtin = symbol_table::find (name); + return dynamic_cast<octave_builtin *> (ov_builtin.internal_rep ()); +} + +void +jit_typeinfo::register_generic (const std::string&, jit_type *, + const std::vector<jit_type *>&) +{ + // FIXME: Implement +} + +jit_function +jit_typeinfo::mirror_binary (const jit_function& fn) +{ + jit_function ret = create_function (jit_convention::internal, + fn.name () + "_reverse", + fn.result (), fn.argument_type (1), + fn.argument_type (0)); + if (fn.can_error ()) + ret.mark_can_error (); + + llvm::BasicBlock *body = ret.new_block (); + builder.SetInsertPoint (body); + llvm::Value *result = fn.call (builder, ret.argument (builder, 1), + ret.argument (builder, 0)); + if (ret.result ()) + ret.do_return (builder, result); + else + ret.do_return (builder); + + return ret; +} + +llvm::Value * +jit_typeinfo::pack_complex (llvm::IRBuilderD& bld, llvm::Value *cplx) +{ + llvm::Type *complex_ret = instance->complex_ret; + llvm::Value *real = bld.CreateExtractElement (cplx, bld.getInt32 (0)); + llvm::Value *imag = bld.CreateExtractElement (cplx, bld.getInt32 (1)); + llvm::Value *ret = llvm::UndefValue::get (complex_ret); + ret = bld.CreateInsertValue (ret, real, 0); + return bld.CreateInsertValue (ret, imag, 1); +} + +llvm::Value * +jit_typeinfo::unpack_complex (llvm::IRBuilderD& bld, llvm::Value *result) +{ + llvm::Type *complex_t = get_complex ()->to_llvm (); + llvm::Value *real = bld.CreateExtractValue (result, 0); + llvm::Value *imag = bld.CreateExtractValue (result, 1); + llvm::Value *ret = llvm::UndefValue::get (complex_t); + ret = bld.CreateInsertElement (ret, real, bld.getInt32 (0)); + return bld.CreateInsertElement (ret, imag, bld.getInt32 (1)); +} + +llvm::Value * +jit_typeinfo::complex_real (llvm::Value *cx) +{ + return builder.CreateExtractElement (cx, builder.getInt32 (0)); +} + +llvm::Value * +jit_typeinfo::complex_real (llvm::Value *cx, llvm::Value *real) +{ + return builder.CreateInsertElement (cx, real, builder.getInt32 (0)); +} + +llvm::Value * +jit_typeinfo::complex_imag (llvm::Value *cx) +{ + return builder.CreateExtractElement (cx, builder.getInt32 (1)); +} + +llvm::Value * +jit_typeinfo::complex_imag (llvm::Value *cx, llvm::Value *imag) +{ + return builder.CreateInsertElement (cx, imag, builder.getInt32 (1)); +} + +llvm::Value * +jit_typeinfo::complex_new (llvm::Value *real, llvm::Value *imag) +{ + llvm::Value *ret = llvm::UndefValue::get (complex->to_llvm ()); + ret = complex_real (ret, real); + return complex_imag (ret, imag); +} + +void +jit_typeinfo::create_int (size_t nbits) +{ + std::stringstream tname; + tname << "int" << nbits; + ints[nbits] = new_type (tname.str (), any, llvm::Type::getIntNTy (context, + nbits)); +} + +jit_type * +jit_typeinfo::intN (size_t nbits) const +{ + std::map<size_t, jit_type *>::const_iterator iter = ints.find (nbits); + if (iter != ints.end ()) + return iter->second; + + throw jit_fail_exception ("No such integer type"); +} + +jit_type * +jit_typeinfo::do_type_of (const octave_value &ov) const +{ + if (ov.is_function ()) + { + // FIXME: This is ugly, we need to finalize how we want to to this, then + // have octave_value fully support the needed functionality + octave_builtin *builtin + = dynamic_cast<octave_builtin *> (ov.internal_rep ()); + return builtin && builtin->to_jit () ? builtin->to_jit () + : unknown_function; + } + + if (ov.is_range ()) + return get_range (); + + if (ov.is_double_type ()) + { + if (ov.is_real_scalar ()) + return get_scalar (); + + if (ov.is_matrix_type ()) + return get_matrix (); + } + + if (ov.is_complex_scalar ()) + return get_complex (); + + return get_any (); +} + +jit_type* +jit_typeinfo::new_type (const std::string& name, jit_type *parent, + llvm::Type *llvm_type) +{ + jit_type *ret = new jit_type (name, parent, llvm_type, next_id++); + id_to_type.push_back (ret); + return ret; +} + +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jit-typeinfo.h Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,669 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#if !defined (octave_jit_typeinfo_h) +#define octave_jit_typeinfo_h 1 + +#ifdef HAVE_LLVM + +#include <map> +#include <vector> + +#include "Range.h" +#include "jit-util.h" + +// Defines the type system used by jit and a singleton class, jit_typeinfo, to +// manage the types. +// +// FIXME: +// Operations are defined and implemented in jit_typeinfo. Eventually they +// should be moved elsewhere. (just like with octave_typeinfo) + +// jit_range is compatable with the llvm range structure +struct +jit_range +{ + jit_range (const Range& from) : base (from.base ()), limit (from.limit ()), + inc (from.inc ()), nelem (from.nelem ()) + {} + + operator Range () const + { + return Range (base, limit, inc); + } + + bool all_elements_are_ints () const; + + double base; + double limit; + double inc; + octave_idx_type nelem; +}; + +std::ostream& operator<< (std::ostream& os, const jit_range& rng); + +// jit_array is compatable with the llvm array/matrix structures +template <typename T, typename U> +struct +jit_array +{ + jit_array (T& from) : array (new T (from)) + { + update (); + } + + void update (void) + { + ref_count = array->jit_ref_count (); + slice_data = array->jit_slice_data () - 1; + slice_len = array->capacity (); + dimensions = array->jit_dimensions (); + } + + void update (T *aarray) + { + array = aarray; + update (); + } + + operator T () const + { + return *array; + } + + int *ref_count; + + U *slice_data; + octave_idx_type slice_len; + octave_idx_type *dimensions; + + T *array; +}; + +typedef jit_array<NDArray, double> jit_matrix; + +std::ostream& operator<< (std::ostream& os, const jit_matrix& mat); + +// calling convention +namespace +jit_convention +{ + enum + type + { + // internal to jit + internal, + + // an external C call + external, + + length + }; +} + +// Used to keep track of estimated (infered) types during JIT. This is a +// hierarchical type system which includes both concrete and abstract types. +// +// The types form a lattice. Currently we only allow for one parent type, but +// eventually we may allow for multiple predecessors. +class +jit_type +{ +public: + typedef llvm::Value *(*convert_fn) (llvm::IRBuilderD&, llvm::Value *); + + jit_type (const std::string& aname, jit_type *aparent, llvm::Type *allvm_type, + int aid); + + // a user readable type name + const std::string& name (void) const { return mname; } + + // a unique id for the type + int type_id (void) const { return mid; } + + // An abstract base type, may be null + jit_type *parent (void) const { return mparent; } + + // convert to an llvm type + llvm::Type *to_llvm (void) const { return llvm_type; } + + // how this type gets passed as a function argument + llvm::Type *to_llvm_arg (void) const; + + size_t depth (void) const { return mdepth; } + + // -------------------- Calling Convention information -------------------- + + // A function declared like: mytype foo (int arg0, int arg1); + // Will be converted to: void foo (mytype *retval, int arg0, int arg1) + // if mytype is sret. The caller is responsible for allocating space for + // retval. (on the stack) + bool sret (jit_convention::type cc) const { return msret[cc]; } + + void mark_sret (jit_convention::type cc = jit_convention::external) + { msret[cc] = true; } + + // A function like: void foo (mytype arg0) + // Will be converted to: void foo (mytype *arg0) + // Basically just pass by reference. + bool pointer_arg (jit_convention::type cc) const { return mpointer_arg[cc]; } + + void mark_pointer_arg (jit_convention::type cc = jit_convention::external) + { mpointer_arg[cc] = true; } + + // Convert into an equivalent form before calling. For example, complex is + // represented as two values llvm vector, but we need to pass it as a two + // valued llvm structure to C functions. + convert_fn pack (jit_convention::type cc) { return mpack[cc]; } + + void set_pack (jit_convention::type cc, convert_fn fn) { mpack[cc] = fn; } + + // The inverse operation of pack. + convert_fn unpack (jit_convention::type cc) { return munpack[cc]; } + + void set_unpack (jit_convention::type cc, convert_fn fn) + { munpack[cc] = fn; } + + // The resulting type after pack is called. + llvm::Type *packed_type (jit_convention::type cc) + { return mpacked_type[cc]; } + + void set_packed_type (jit_convention::type cc, llvm::Type *ty) + { mpacked_type[cc] = ty; } +private: + std::string mname; + jit_type *mparent; + llvm::Type *llvm_type; + int mid; + size_t mdepth; + + bool msret[jit_convention::length]; + bool mpointer_arg[jit_convention::length]; + + convert_fn mpack[jit_convention::length]; + convert_fn munpack[jit_convention::length]; + + llvm::Type *mpacked_type[jit_convention::length]; +}; + +// seperate print function to allow easy printing if type is null +std::ostream& jit_print (std::ostream& os, jit_type *atype); + +class jit_value; + +// An abstraction for calling llvm functions with jit_values. Deals with calling +// convention details. +class +jit_function +{ + friend std::ostream& operator<< (std::ostream& os, const jit_function& fn); +public: + // create a function in an invalid state + jit_function (); + + jit_function (llvm::Module *amodule, jit_convention::type acall_conv, + const llvm::Twine& aname, jit_type *aresult, + const std::vector<jit_type *>& aargs); + + // Use an existing function, but change the argument types. The new argument + // types must behave the same for the current calling convention. + jit_function (const jit_function& fn, jit_type *aresult, + const std::vector<jit_type *>& aargs); + + jit_function (const jit_function& fn); + + template <typename T> + void add_mapping (llvm::ExecutionEngine *engine, T fn) + { + do_add_mapping (engine, reinterpret_cast<void *> (fn)); + } + + bool valid (void) const { return llvm_function; } + + std::string name (void) const; + + llvm::BasicBlock *new_block (const std::string& aname = "body", + llvm::BasicBlock *insert_before = 0); + + llvm::Value *call (llvm::IRBuilderD& builder, + const std::vector<jit_value *>& in_args) const; + + llvm::Value *call (llvm::IRBuilderD& builder, + const std::vector<llvm::Value *>& in_args + = std::vector<llvm::Value *> ()) const; + +#define JIT_PARAM_ARGS llvm::IRBuilderD& builder, +#define JIT_PARAMS builder, +#define JIT_CALL(N) JIT_EXPAND (llvm::Value *, call, llvm::Value *, const, N) + + JIT_CALL (1) + JIT_CALL (2) + JIT_CALL (3) + JIT_CALL (4) + JIT_CALL (5) + +#undef JIT_CALL + +#define JIT_CALL(N) JIT_EXPAND (llvm::Value *, call, jit_value *, const, N) + + JIT_CALL (1); + JIT_CALL (2); + +#undef JIT_CALL +#undef JIT_PARAMS +#undef JIT_PARAM_ARGS + + llvm::Value *argument (llvm::IRBuilderD& builder, size_t idx) const; + + void do_return (llvm::IRBuilderD& builder, llvm::Value *rval = 0); + + llvm::Function *to_llvm (void) const { return llvm_function; } + + // If true, then the return value is passed as a pointer in the first argument + bool sret (void) const { return mresult && mresult->sret (call_conv); } + + bool can_error (void) const { return mcan_error; } + + void mark_can_error (void) { mcan_error = true; } + + jit_type *result (void) const { return mresult; } + + jit_type *argument_type (size_t idx) const + { + assert (idx < args.size ()); + return args[idx]; + } + + const std::vector<jit_type *>& arguments (void) const { return args; } +private: + void do_add_mapping (llvm::ExecutionEngine *engine, void *fn); + + llvm::Module *module; + llvm::Function *llvm_function; + jit_type *mresult; + std::vector<jit_type *> args; + jit_convention::type call_conv; + bool mcan_error; +}; + +std::ostream& operator<< (std::ostream& os, const jit_function& fn); + + +// Keeps track of information about how to implement operations (+, -, *, ect) +// and their resulting types. +class +jit_operation +{ +public: + void add_overload (const jit_function& func) + { + add_overload (func, func.arguments ()); + } + + void add_overload (const jit_function& func, + const std::vector<jit_type*>& args); + + const jit_function& overload (const std::vector<jit_type *>& types) const; + + jit_type *result (const std::vector<jit_type *>& types) const + { + const jit_function& temp = overload (types); + return temp.result (); + } + +#define JIT_PARAMS +#define JIT_PARAM_ARGS +#define JIT_OVERLOAD(N) \ + JIT_EXPAND (const jit_function&, overload, jit_type *, const, N) \ + JIT_EXPAND (jit_type *, result, jit_type *, const, N) + + JIT_OVERLOAD (1); + JIT_OVERLOAD (2); + JIT_OVERLOAD (3); + +#undef JIT_PARAMS +#undef JIT_PARAM_ARGS + + const std::string& name (void) const { return mname; } + + void stash_name (const std::string& aname) { mname = aname; } +private: + Array<octave_idx_type> to_idx (const std::vector<jit_type*>& types) const; + + std::vector<Array<jit_function> > overloads; + + std::string mname; +}; + +// A singleton class which handles the construction of jit_types and +// jit_operations. +class +jit_typeinfo +{ +public: + static void initialize (llvm::Module *m, llvm::ExecutionEngine *e); + + static jit_type *join (jit_type *lhs, jit_type *rhs) + { + return instance->do_join (lhs, rhs); + } + + static jit_type *get_any (void) { return instance->any; } + + static jit_type *get_matrix (void) { return instance->matrix; } + + static jit_type *get_scalar (void) { return instance->scalar; } + + static llvm::Type *get_scalar_llvm (void) + { return instance->scalar->to_llvm (); } + + static jit_type *get_range (void) { return instance->range; } + + static jit_type *get_string (void) { return instance->string; } + + static jit_type *get_bool (void) { return instance->boolean; } + + static jit_type *get_index (void) { return instance->index; } + + static llvm::Type *get_index_llvm (void) + { return instance->index->to_llvm (); } + + static jit_type *get_complex (void) { return instance->complex; } + + // Get the jit_type of an octave_value + static jit_type *type_of (const octave_value& ov) + { + return instance->do_type_of (ov); + } + + static const jit_operation& binary_op (int op) + { + return instance->do_binary_op (op); + } + + static const jit_operation& grab (void) { return instance->grab_fn; } + + static const jit_function& get_grab (jit_type *type) + { + return instance->grab_fn.overload (type); + } + + static const jit_operation& release (void) + { + return instance->release_fn; + } + + static const jit_function& get_release (jit_type *type) + { + return instance->release_fn.overload (type); + } + + static const jit_operation& print_value (void) + { + return instance->print_fn; + } + + static const jit_operation& for_init (void) + { + return instance->for_init_fn; + } + + static const jit_operation& for_check (void) + { + return instance->for_check_fn; + } + + static const jit_operation& for_index (void) + { + return instance->for_index_fn; + } + + static const jit_operation& make_range (void) + { + return instance->make_range_fn; + } + + static const jit_operation& paren_subsref (void) + { + return instance->paren_subsref_fn; + } + + static const jit_operation& paren_subsasgn (void) + { + return instance->paren_subsasgn_fn; + } + + static const jit_operation& logically_true (void) + { + return instance->logically_true_fn; + } + + static const jit_operation& cast (jit_type *result) + { + return instance->do_cast (result); + } + + static const jit_function& cast (jit_type *to, jit_type *from) + { + return instance->do_cast (to, from); + } + + static llvm::Value *insert_error_check (llvm::IRBuilderD& bld) + { + return instance->do_insert_error_check (bld); + } +private: + jit_typeinfo (llvm::Module *m, llvm::ExecutionEngine *e); + + // FIXME: Do these methods really need to be in jit_typeinfo? + jit_type *do_join (jit_type *lhs, jit_type *rhs) + { + // empty case + if (! lhs) + return rhs; + + if (! rhs) + return lhs; + + // check for a shared parent + while (lhs != rhs) + { + if (lhs->depth () > rhs->depth ()) + lhs = lhs->parent (); + else if (lhs->depth () < rhs->depth ()) + rhs = rhs->parent (); + else + { + // we MUST have depth > 0 as any is the base type of everything + do + { + lhs = lhs->parent (); + rhs = rhs->parent (); + } + while (lhs != rhs); + } + } + + return lhs; + } + + jit_type *do_difference (jit_type *lhs, jit_type *) + { + // FIXME: Maybe we can do something smarter? + return lhs; + } + + jit_type *do_type_of (const octave_value &ov) const; + + const jit_operation& do_binary_op (int op) const + { + assert (static_cast<size_t>(op) < binary_ops.size ()); + return binary_ops[op]; + } + + const jit_operation& do_cast (jit_type *to) + { + static jit_operation null_function; + if (! to) + return null_function; + + size_t id = to->type_id (); + if (id >= casts.size ()) + return null_function; + return casts[id]; + } + + const jit_function& do_cast (jit_type *to, jit_type *from) + { + return do_cast (to).overload (from); + } + + jit_type *new_type (const std::string& name, jit_type *parent, + llvm::Type *llvm_type); + + + void add_print (jit_type *ty, void *fptr); + + void add_binary_op (jit_type *ty, int op, int llvm_op); + + void add_binary_icmp (jit_type *ty, int op, int llvm_op); + + void add_binary_fcmp (jit_type *ty, int op, int llvm_op); + + jit_function create_function (jit_convention::type cc, + const llvm::Twine& name, jit_type *ret, + const std::vector<jit_type *>& args + = std::vector<jit_type *> ()); + +#define JIT_PARAM_ARGS jit_convention::type cc, const llvm::Twine& name, \ + jit_type *ret, +#define JIT_PARAMS cc, name, ret, +#define CREATE_FUNCTION(N) JIT_EXPAND(jit_function, create_function, \ + jit_type *, /* empty */, N) + + CREATE_FUNCTION(1); + CREATE_FUNCTION(2); + CREATE_FUNCTION(3); + CREATE_FUNCTION(4); + +#undef JIT_PARAM_ARGS +#undef JIT_PARAMS +#undef CREATE_FUNCTION + + jit_function create_identity (jit_type *type); + + llvm::Value *do_insert_error_check (llvm::IRBuilderD& bld); + + void add_builtin (const std::string& name); + + void register_intrinsic (const std::string& name, size_t id, + jit_type *result, jit_type *arg0) + { + std::vector<jit_type *> args (1, arg0); + register_intrinsic (name, id, result, args); + } + + void register_intrinsic (const std::string& name, size_t id, jit_type *result, + const std::vector<jit_type *>& args); + + void register_generic (const std::string& name, jit_type *result, + jit_type *arg0) + { + std::vector<jit_type *> args (1, arg0); + register_generic (name, result, args); + } + + void register_generic (const std::string& name, jit_type *result, + const std::vector<jit_type *>& args); + + octave_builtin *find_builtin (const std::string& name); + + jit_function mirror_binary (const jit_function& fn); + + llvm::Function *wrap_complex (llvm::Function *wrap); + + static llvm::Value *pack_complex (llvm::IRBuilderD& bld, + llvm::Value *cplx); + + static llvm::Value *unpack_complex (llvm::IRBuilderD& bld, + llvm::Value *result); + + llvm::Value *complex_real (llvm::Value *cx); + + llvm::Value *complex_real (llvm::Value *cx, llvm::Value *real); + + llvm::Value *complex_imag (llvm::Value *cx); + + llvm::Value *complex_imag (llvm::Value *cx, llvm::Value *imag); + + llvm::Value *complex_new (llvm::Value *real, llvm::Value *imag); + + void create_int (size_t nbits); + + jit_type *intN (size_t nbits) const; + + static jit_typeinfo *instance; + + llvm::Module *module; + llvm::ExecutionEngine *engine; + int next_id; + + llvm::GlobalVariable *lerror_state; + + std::vector<jit_type*> id_to_type; + jit_type *any; + jit_type *matrix; + jit_type *scalar; + jit_type *range; + jit_type *string; + jit_type *boolean; + jit_type *index; + jit_type *complex; + jit_type *unknown_function; + std::map<size_t, jit_type *> ints; + std::map<std::string, jit_type *> builtins; + + llvm::StructType *complex_ret; + + std::vector<jit_operation> binary_ops; + jit_operation grab_fn; + jit_operation release_fn; + jit_operation print_fn; + jit_operation for_init_fn; + jit_operation for_check_fn; + jit_operation for_index_fn; + jit_operation logically_true_fn; + jit_operation make_range_fn; + jit_operation paren_subsref_fn; + jit_operation paren_subsasgn_fn; + + // type id -> cast function TO that type + std::vector<jit_operation> casts; + + // type id -> identity function + std::vector<jit_function> identities; + + llvm::IRBuilderD& builder; +}; + +#endif +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jit-util.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,44 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// defines required by llvm +#define __STDC_LIMIT_MACROS +#define __STDC_CONSTANT_MACROS + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#ifdef HAVE_LLVM + +#include <llvm/Value.h> +#include <llvm/Support/raw_os_ostream.h> + +std::ostream& +operator<< (std::ostream& os, const llvm::Value& v) +{ + llvm::raw_os_ostream llvm_out (os); + v.print (llvm_out); + return os; +} + +#endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/jit-util.h Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,203 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +// Some utility classes and functions used throughout jit + +#if !defined (octave_jit_util_h) +#define octave_jit_util_h 1 + +#ifdef HAVE_LLVM + +#include <stdexcept> + +// we don't want to include llvm headers here, as they require +// __STDC_LIMIT_MACROS and __STDC_CONSTANT_MACROS be defined in the entire +// compilation unit +namespace llvm +{ + class Value; + class Module; + class FunctionPassManager; + class PassManager; + class ExecutionEngine; + class Function; + class BasicBlock; + class LLVMContext; + class Type; + class StructType; + class Twine; + class GlobalVariable; + class TerminatorInst; + class PHINode; + + class ConstantFolder; + + template <bool preserveNames> + class IRBuilderDefaultInserter; + + template <bool preserveNames, typename T, typename Inserter> + class IRBuilder; + +typedef IRBuilder<true, ConstantFolder, IRBuilderDefaultInserter<true> > +IRBuilderD; +} + +class octave_base_value; +class octave_builtin; +class octave_value; +class tree; +class tree_expression; + +// thrown when we should give up on JIT and interpret +class jit_fail_exception : public std::runtime_error +{ +public: + jit_fail_exception (void) : std::runtime_error ("unknown"), mknown (false) {} + jit_fail_exception (const std::string& reason) : std::runtime_error (reason), + mknown (true) + {} + + bool known (void) const { return mknown; } +private: + bool mknown; +}; + +// llvm doesn't provide this, and it's really useful for debugging +std::ostream& operator<< (std::ostream& os, const llvm::Value& v); + +template <typename HOLDER_T, typename SUB_T> +class jit_internal_node; + +// jit_internal_list and jit_internal_node implement generic embedded doubly +// linked lists. List items extend from jit_internal_list, and can be placed +// in nodes of type jit_internal_node. We use CRTP twice. +template <typename LIST_T, typename NODE_T> +class +jit_internal_list +{ + friend class jit_internal_node<LIST_T, NODE_T>; +public: + jit_internal_list (void) : use_head (0), use_tail (0), muse_count (0) {} + + virtual ~jit_internal_list (void) + { + while (use_head) + use_head->stash_value (0); + } + + NODE_T *first_use (void) const { return use_head; } + + size_t use_count (void) const { return muse_count; } +private: + NODE_T *use_head; + NODE_T *use_tail; + size_t muse_count; +}; + +// a node for internal linked lists +template <typename LIST_T, typename NODE_T> +class +jit_internal_node +{ +public: + typedef jit_internal_list<LIST_T, NODE_T> jit_ilist; + + jit_internal_node (void) : mvalue (0), mnext (0), mprev (0) {} + + ~jit_internal_node (void) { remove (); } + + LIST_T *value (void) const { return mvalue; } + + void stash_value (LIST_T *avalue) + { + remove (); + + mvalue = avalue; + + if (mvalue) + { + jit_ilist *ilist = mvalue; + NODE_T *sthis = static_cast<NODE_T *> (this); + if (ilist->use_head) + { + ilist->use_tail->mnext = sthis; + mprev = ilist->use_tail; + } + else + ilist->use_head = sthis; + + ilist->use_tail = sthis; + ++ilist->muse_count; + } + } + + NODE_T *next (void) const { return mnext; } + + NODE_T *prev (void) const { return mprev; } +private: + void remove () + { + if (mvalue) + { + jit_ilist *ilist = mvalue; + if (mprev) + mprev->mnext = mnext; + else + // we are the use_head + ilist->use_head = mnext; + + if (mnext) + mnext->mprev = mprev; + else + // we are the use tail + ilist->use_tail = mprev; + + mnext = mprev = 0; + --ilist->muse_count; + mvalue = 0; + } + } + + LIST_T *mvalue; + NODE_T *mnext; + NODE_T *mprev; +}; + +// Use like: isa<jit_phi> (value) +// basically just a short cut type typing dyanmic_cast. +template <typename T, typename U> +bool isa (U *value) +{ + return dynamic_cast<T *> (value); +} + +#define JIT_ASSIGN_ARG(i) the_args[i] = arg ## i; +#define JIT_EXPAND(ret, fname, type, isconst, N) \ + ret fname (JIT_PARAM_ARGS OCT_MAKE_DECL_LIST (type, arg, N)) isconst \ + { \ + std::vector<type> the_args (N); \ + OCT_ITERATE_MACRO (JIT_ASSIGN_ARG, N); \ + return fname (JIT_PARAMS the_args); \ + } + +#endif +#endif
--- a/src/link-deps.mk Sat Jul 28 15:17:57 2012 +0200 +++ b/src/link-deps.mk Sat Jul 28 12:06:34 2012 -0400 @@ -11,16 +11,21 @@ $(FT2_LIBS) \ $(HDF5_LIBS) \ $(Z_LIBS) \ + $(FFTW_XLIBS) \ + $(REGEX_LIBS) \ $(OPENGL_LIBS) \ $(X11_LIBS) \ - $(CARBON_LIBS) + $(CARBON_LIBS) \ + $(LLVM_LIBS) LIBOCTINTERP_LINK_OPTS = \ $(GRAPHICS_LDFLAGS) \ $(FT2_LDFLAGS) \ $(HDF5_LDFLAGS) \ $(Z_LDFLAGS) \ - $(REGEX_LDFLAGS) + $(REGEX_LDFLAGS) \ + $(FFTW_XLDFLAGS) \ + $(LLVM_LDFLAGS) OCT_LINK_DEPS =
--- a/src/load-path.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/load-path.cc Sat Jul 28 12:06:34 2012 -0400 @@ -523,36 +523,9 @@ } void -load_path::do_clear (std::set<std::string>& new_elts) +load_path::do_clear (void) { - bool warn_default_path_clobbered = false; - for (dir_info_list_iterator i = dir_info_list.begin (); - i != dir_info_list.end (); - /* conditionally advance iterator in loop body */) - { - //Don't remove it if it's gonna be added again, but remove it from - //list of items to add, to avoid duplicates later on - std::set<std::string>::iterator j = new_elts.find (i->dir_name); - if (j != new_elts.end ()) - { - new_elts.erase (j); - i++; - } - else - { - //Warn if removing a default directory and not immediately adding - //it back again - if (i->is_init) - warn_default_path_clobbered = true; - i = dir_info_list.erase (i); - } - } - - if (warn_default_path_clobbered) - warning_with_id ("Octave:remove-init-dir", - "default load path altered. Some built-in functions may " - "not be found. Try restoredefaultpath() to recover it."); - + dir_info_list.clear (); fcn_map.clear (); private_fcn_map.clear (); method_map.clear (); @@ -594,8 +567,27 @@ void load_path::do_set (const std::string& p, bool warn, bool is_init) { - std::list<std::string> elts_l = split_path (p); - std::set<std::string> elts(elts_l.begin (), elts_l.end ()); + // Use a list when we need to preserve order. + std::list<std::string> elts = split_path (p); + + // Use a set when we need to search and order is not important. + std::set<std::string> elts_set (elts.begin (), elts.end ()); + + if (is_init) + init_dirs = elts_set; + else + { + for (std::set<std::string>::const_iterator it = init_dirs.begin (); + it != init_dirs.end (); it++) + { + if (elts_set.find (*it) == elts_set.end ()) + { + warning_with_id ("Octave:remove-init-dir", + "default load path altered. Some built-in functions may not be found. Try restoredefaultpath() to recover it."); + break; + } + } + } // Temporarily disable add hook. @@ -604,12 +596,11 @@ add_hook = 0; - do_clear (elts); - - for (std::set<std::string>::const_iterator i = elts.begin (); - i != elts.end (); - i++) - do_append (*i, warn, is_init); + do_clear (); + + for (std::list<std::string>::const_iterator i = elts.begin (); + i != elts.end (); i++) + do_append (*i, warn); // Restore add hook and execute for all newly added directories. frame.run_top (); @@ -627,10 +618,10 @@ } void -load_path::do_append (const std::string& dir, bool warn, bool is_init) +load_path::do_append (const std::string& dir, bool warn) { if (! dir.empty ()) - do_add (dir, true, warn, is_init); + do_add (dir, true, warn); } void @@ -659,8 +650,7 @@ } void -load_path::do_add (const std::string& dir_arg, bool at_end, bool warn, - bool is_init) +load_path::do_add (const std::string& dir_arg, bool at_end, bool warn) { size_t len = dir_arg.length (); @@ -685,7 +675,6 @@ if (fs.is_dir ()) { dir_info di (dir); - di.is_init = is_init; if (! error_state) { @@ -1798,7 +1787,11 @@ // way we look for old.dir_name in sys_path to avoid // partial matches? - if (sys_path.find (old.dir_name) != std::string::npos + // Don't warn about Contents.m files since we expect + // more than one to exist in the load path. + + if (fname != "Contents.m" + && sys_path.find (old.dir_name) != std::string::npos && in_path_list (sys_path, old.dir_name)) { std::string fcn_path = file_ops::concat (dir_name, fname);
--- a/src/load-path.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/load-path.h Sat Jul 28 12:06:34 2012 -0400 @@ -39,7 +39,8 @@ protected: load_path (void) - : dir_info_list (), fcn_map (), private_fcn_map (), method_map () { } + : dir_info_list (), fcn_map (), private_fcn_map (), method_map (), + init_dirs () { } public: @@ -56,10 +57,7 @@ static void clear (void) { if (instance_ok ()) - { - std::set<std::string> no_new_elts; - instance->do_clear (no_new_elts); - } + instance->do_clear (); } static void set (const std::string& p, bool warn = false) @@ -297,13 +295,13 @@ // constructor for any other purpose. dir_info (void) : dir_name (), abs_dir_name (), is_relative (false), - is_init (false), dir_mtime (), dir_time_last_checked (), + dir_mtime (), dir_time_last_checked (), all_files (), fcn_files (), private_file_map (), method_file_map () { } dir_info (const std::string& d) : dir_name (d), abs_dir_name (), is_relative (false), - is_init (false), dir_mtime (), dir_time_last_checked (), + dir_mtime (), dir_time_last_checked (), all_files (), fcn_files (), private_file_map (), method_file_map () { initialize (); @@ -312,7 +310,6 @@ dir_info (const dir_info& di) : dir_name (di.dir_name), abs_dir_name (di.abs_dir_name), is_relative (di.is_relative), - is_init (di.is_init), dir_mtime (di.dir_mtime), dir_time_last_checked (di.dir_time_last_checked), all_files (di.all_files), fcn_files (di.fcn_files), @@ -328,7 +325,6 @@ dir_name = di.dir_name; abs_dir_name = di.abs_dir_name; is_relative = di.is_relative; - is_init = di.is_init; dir_mtime = di.dir_mtime; dir_time_last_checked = di.dir_time_last_checked; all_files = di.all_files; @@ -345,7 +341,6 @@ std::string dir_name; std::string abs_dir_name; bool is_relative; - bool is_init; //Was this directory set by init? Warn when clearing it. octave_time dir_mtime; octave_time dir_time_last_checked; string_vector all_files; @@ -447,6 +442,8 @@ mutable method_map_type method_map; + mutable std::set<std::string> init_dirs; + static load_path *instance; static void cleanup_instance (void) { delete instance; instance = 0; } @@ -477,16 +474,15 @@ void do_initialize (bool set_initial_path); - void do_clear (std::set<std::string>& new_elts); + void do_clear (void); - void do_set (const std::string& p, bool warn, bool is_init=false); + void do_set (const std::string& p, bool warn, bool is_init = false); - void do_append (const std::string& dir, bool warn, bool is_init=false); + void do_append (const std::string& dir, bool warn); void do_prepend (const std::string& dir, bool warn); - void do_add (const std::string& dir, bool at_end, bool warn, - bool is_init=false); + void do_add (const std::string& dir, bool at_end, bool warn); void remove_fcn_map (const std::string& dir, const string_vector& fcn_files);
--- a/src/load-save.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/load-save.cc Sat Jul 28 12:06:34 2012 -0400 @@ -91,7 +91,7 @@ #include "zfstream.h" #endif -// Write octave-core file if Octave crashes or is killed by a signal. +// Write octave-workspace file if Octave crashes or is killed by a signal. static bool Vcrash_dumps_octave_core = true; // The maximum amount of memory (in kilobytes) that we will attempt to @@ -99,7 +99,7 @@ static double Voctave_core_file_limit = -1.0; // The name of the Octave core file. -static std::string Voctave_core_file_name = "octave-core"; +static std::string Voctave_core_file_name = "octave-workspace"; // The default output format. May be one of "binary", "text", // "mat-binary", or "hdf5". @@ -1751,7 +1751,7 @@ @deftypefnx {Built-in Function} {@var{old_val} =} crash_dumps_octave_core (@var{new_val})\n\ @deftypefnx {Built-in Function} {} crash_dumps_octave_core (@var{new_val}, \"local\")\n\ Query or set the internal variable that controls whether Octave tries\n\ -to save all current variables to the file \"octave-core\" if it\n\ +to save all current variables to the file \"octave-workspace\" if it\n\ crashes or receives a hangup, terminate or similar signal.\n\ \n\ When called from inside a function with the \"local\" option, the variable is\n\ @@ -1812,7 +1812,7 @@ @deftypefnx {Built-in Function} {} octave_core_file_name (@var{new_val}, \"local\")\n\ Query or set the internal variable that specifies the name of the file\n\ used for saving data from the top-level workspace if Octave aborts.\n\ -The default value is @code{\"octave-core\"}\n\ +The default value is @code{\"octave-workspace\"}\n\ \n\ When called from inside a function with the \"local\" option, the variable is\n\ changed locally for the function and any subroutines it calls. The original\n\
--- a/src/ls-mat5.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/ls-mat5.cc Sat Jul 28 12:06:34 2012 -0400 @@ -1936,7 +1936,7 @@ bool too_large_for_float = false; for (octave_idx_type i = 0; i < nel; i++) { - double tmp = val [i]; + double tmp = val[i]; if (! (xisnan (tmp) || xisinf (tmp)) && fabs (tmp) > FLT_MAX)
--- a/src/mkbuiltins Sat Jul 28 15:17:57 2012 +0200 +++ b/src/mkbuiltins Sat Jul 28 12:06:34 2012 -0400 @@ -57,19 +57,20 @@ #endif -#define XDEFUN_FILE_NAME(name) +#define XDEFUN_FILE_NAME(name) \ + std::string file = name; #define XDEFUN_INTERNAL(name, args_name, nargout_name, doc) \ extern DECLARE_FUN (name, args_name, nargout_name); \ - install_builtin_function (F ## name, #name, doc); \ + install_builtin_function (F ## name, #name, file, doc); \ #define XDEFCONSTFUN_INTERNAL(name, args_name, nargout_name, doc) \ extern DECLARE_FUN (name, args_name, nargout_name); \ - install_builtin_function (F ## name, #name, doc, false); \ + install_builtin_function (F ## name, #name, file, doc, false); \ #define XDEFUNX_INTERNAL(name, fname, args_name, nargout_name, doc) \ extern DECLARE_FUNX (fname, args_name, nargout_name); \ - install_builtin_function (fname, name, doc); \ + install_builtin_function (fname, name, file, doc); \ #define XDEFALIAS_INTERNAL(alias, name) \ alias_builtin (#alias, #name);
--- a/src/oct-conf.in.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/oct-conf.in.h Sat Jul 28 12:06:34 2012 -0400 @@ -384,6 +384,18 @@ #define OCTAVE_CONF_MAGICK_LIBS %OCTAVE_CONF_MAGICK_LIBS% #endif +#ifndef OCTAVE_CONF_LLVM_CPPFLAGS +#define OCTAVE_CONF_LLVM_CPPFLAGS %OCTAVE_CONF_LLVM_CPPFLAGS% +#endif + +#ifndef OCTAVE_CONF_LLVM_LDFLAGS +#define OCTAVE_CONF_LLVM_LDFLAGS %OCTAVE_CONF_LLVM_LDFLAGS% +#endif + +#ifndef OCTAVE_CONF_LLVM_LIBS +#define OCTAVE_CONF_LLVM_LIBS %OCTAVE_CONF_LLVM_LIBS% +#endif + #ifndef OCTAVE_CONF_MKOCTFILE_DL_LDFLAGS #define OCTAVE_CONF_MKOCTFILE_DL_LDFLAGS %OCTAVE_CONF_MKOCTFILE_DL_LDFLAGS% #endif
--- a/src/ov-base.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/ov-base.h Sat Jul 28 12:06:34 2012 -0400 @@ -756,6 +756,21 @@ virtual bool fast_elem_insert_self (void *where, builtin_type_t btyp) const; + // Grab the reference count. For use by jit. + void + grab (void) + { + ++count; + } + + // Release the reference count. For use by jit. + void + release (void) + { + if (--count == 0) + delete this; + } + protected: // This should only be called for derived types.
--- a/src/ov-builtin.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/ov-builtin.cc Sat Jul 28 12:06:34 2012 -0400 @@ -152,5 +152,22 @@ return retval; } +jit_type * +octave_builtin::to_jit (void) const +{ + return jtype; +} + +void +octave_builtin::stash_jit (jit_type &type) +{ + jtype = &type; +} + +octave_builtin::fcn +octave_builtin::function (void) const +{ + return f; +} const std::list<octave_lvalue> *octave_builtin::curr_lvalue_list = 0;
--- a/src/ov-builtin.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/ov-builtin.h Sat Jul 28 12:06:34 2012 -0400 @@ -30,6 +30,7 @@ class octave_value; class octave_value_list; +class jit_type; // Builtin functions. @@ -39,16 +40,22 @@ { public: - octave_builtin (void) : octave_function (), f (0) { } + octave_builtin (void) : octave_function (), f (0), file (), jtype (0) { } typedef octave_value_list (*fcn) (const octave_value_list&, int); octave_builtin (fcn ff, const std::string& nm = std::string (), const std::string& ds = std::string ()) - : octave_function (nm, ds), f (ff) { } + : octave_function (nm, ds), f (ff), file (), jtype (0) { } + + octave_builtin (fcn ff, const std::string& nm, const std::string& fnm, + const std::string& ds) + : octave_function (nm, ds), f (ff), file (fnm), jtype (0) { } ~octave_builtin (void) { } + std::string src_file_name (void) const { return file; } + octave_value subsref (const std::string& type, const std::list<octave_value_list>& idx) { @@ -75,6 +82,12 @@ do_multi_index_op (int nargout, const octave_value_list& args, const std::list<octave_lvalue>* lvalue_list); + jit_type *to_jit (void) const; + + void stash_jit (jit_type& type); + + fcn function (void) const; + static const std::list<octave_lvalue> *curr_lvalue_list; protected: @@ -82,6 +95,12 @@ // A pointer to the actual function. fcn f; + // The name of the file where this function was defined. + std::string file; + + // A pointer to the jit type that represents the function. + jit_type *jtype; + private: // No copying!
--- a/src/ov-class.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/ov-class.cc Sat Jul 28 12:06:34 2012 -0400 @@ -1277,7 +1277,7 @@ if ( val(0).is_object () ) { dbgstr = "blork"; - if( key == val(0).class_name () ) + if ( key == val(0).class_name () ) { might_have_inheritance = true; dbgstr = "cork";
--- a/src/ov-fcn.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/ov-fcn.h Sat Jul 28 12:06:34 2012 -0400 @@ -61,6 +61,8 @@ virtual std::string fcn_file_name (void) const { return std::string (); } + virtual std::string src_file_name (void) const { return std::string (); } + // The name to show in the profiler (also used as map-key). virtual std::string profiler_name (void) const { return name (); }
--- a/src/ov-oncleanup.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/ov-oncleanup.cc Sat Jul 28 12:06:34 2012 -0400 @@ -191,7 +191,7 @@ DEFUN (onCleanup, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{c} =} onCleanup (@var{action})\n\ +@deftypefn {Built-in Function} {@var{c} =} onCleanup (@var{action})\n\ Create a special object that executes a given function upon destruction.\n\ If the object is copied to multiple variables (or cell or struct array\n\ elements) or returned from a function, @var{action} will be executed after\n\
--- a/src/pt-eval.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/pt-eval.cc Sat Jul 28 12:06:34 2012 -0400 @@ -44,6 +44,12 @@ #include "symtab.h" #include "unwind-prot.h" +#if HAVE_LLVM +//FIXME: This should be part of tree_evaluator +#include "pt-jit.h" +static tree_jit jiter; +#endif + static tree_evaluator std_evaluator; tree_evaluator *current_evaluator = &std_evaluator; @@ -303,6 +309,11 @@ octave_value rhs = expr->rvalue1 (); +#if HAVE_LLVM + if (jiter.execute (cmd, rhs)) + return; +#endif + if (error_state || rhs.is_undefined ()) return; @@ -1023,6 +1034,11 @@ if (error_state) return; +#if HAVE_LLVM + if (jiter.execute (cmd)) + return; +#endif + unwind_protect frame; frame.protect_var (in_loop_command);
--- a/src/pt-id.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/pt-id.cc Sat Jul 28 12:06:34 2012 -0400 @@ -65,7 +65,7 @@ if (error_state) return retval; - octave_value val = xsym ().find (); + octave_value val = sym->find (); if (val.is_defined ()) { @@ -116,7 +116,7 @@ octave_lvalue tree_identifier::lvalue (void) { - return octave_lvalue (&(xsym ().varref ())); + return octave_lvalue (&(sym->varref ())); } tree_identifier *
--- a/src/pt-id.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/pt-id.h Sat Jul 28 12:06:34 2012 -0400 @@ -46,12 +46,12 @@ public: tree_identifier (int l = -1, int c = -1) - : tree_expression (l, c), sym (), scope (-1) { } + : tree_expression (l, c) { } tree_identifier (const symbol_table::symbol_record& s, int l = -1, int c = -1, symbol_table::scope_id sc = symbol_table::current_scope ()) - : tree_expression (l, c), sym (s), scope (sc) { } + : tree_expression (l, c), sym (s, sc) { } ~tree_identifier (void) { } @@ -63,9 +63,9 @@ // accessing it through sym so that this function may remain const. std::string name (void) const { return sym.name (); } - bool is_defined (void) { return xsym ().is_defined (); } + bool is_defined (void) { return sym->is_defined (); } - virtual bool is_variable (void) { return xsym ().is_variable (); } + virtual bool is_variable (void) { return sym->is_variable (); } virtual bool is_black_hole (void) { return false; } @@ -87,14 +87,14 @@ octave_value do_lookup (const octave_value_list& args = octave_value_list ()) { - return xsym ().find (args); + return sym->find (args); } - void mark_global (void) { xsym ().mark_global (); } + void mark_global (void) { sym->mark_global (); } - void mark_as_static (void) { xsym ().init_persistent (); } + void mark_as_static (void) { sym->init_persistent (); } - void mark_as_formal_parameter (void) { xsym ().mark_formal (); } + void mark_as_formal_parameter (void) { sym->mark_formal (); } // We really need to know whether this symbol referst to a variable // or a function, but we may not know that yet. @@ -114,28 +114,14 @@ void accept (tree_walker& tw); + symbol_table::symbol_reference symbol (void) const + { + return sym; + } private: // The symbol record that this identifier references. - symbol_table::symbol_record sym; - - symbol_table::scope_id scope; - - // A script may be executed in multiple scopes. If the last one was - // different from the one we are in now, update sym to be from the - // new scope. - symbol_table::symbol_record& xsym (void) - { - symbol_table::scope_id curr_scope = symbol_table::current_scope (); - - if (scope != curr_scope || ! sym.is_valid ()) - { - scope = curr_scope; - sym = symbol_table::insert (sym.name ()); - } - - return sym; - } + symbol_table::symbol_reference sym; // No copying!
--- a/src/pt-idx.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/pt-idx.cc Sat Jul 28 12:06:34 2012 -0400 @@ -532,7 +532,7 @@ && (tmp.is_matrix_type () || tmp.is_string () || tmp.is_cell ())); - if (i > 0 && type [i-1] == '(') + if (i > 0 && type[i-1] == '(') { octave_value_list pidx = idx.back ();
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pt-jit.cc Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,1826 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#define __STDC_LIMIT_MACROS +#define __STDC_CONSTANT_MACROS + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#ifdef HAVE_LLVM + +#include "pt-jit.h" + +#include <llvm/Analysis/CallGraph.h> +#include <llvm/Analysis/Passes.h> +#include <llvm/Analysis/Verifier.h> +#include <llvm/LLVMContext.h> +#include <llvm/ExecutionEngine/ExecutionEngine.h> +#include <llvm/ExecutionEngine/JIT.h> +#include <llvm/Module.h> +#include <llvm/PassManager.h> +#include <llvm/Support/IRBuilder.h> +#include <llvm/Support/raw_os_ostream.h> +#include <llvm/Support/TargetSelect.h> +#include <llvm/Target/TargetData.h> +#include <llvm/Transforms/IPO.h> +#include <llvm/Transforms/Scalar.h> + +#ifdef OCTAVE_JIT_DEBUG +#include <llvm/Bitcode/ReaderWriter.h> +#endif + +#include "symtab.h" +#include "pt-all.h" + +static llvm::IRBuilder<> builder (llvm::getGlobalContext ()); + +static llvm::LLVMContext& context = llvm::getGlobalContext (); + +// -------------------- jit_convert -------------------- +jit_convert::jit_convert (llvm::Module *module, tree &tee, + jit_type *for_bounds) + : iterator_count (0), for_bounds_count (0), short_count (0), breaking (false) +{ + jit_instruction::reset_ids (); + + entry_block = create<jit_block> ("body"); + final_block = create<jit_block> ("final"); + append (entry_block); + entry_block->mark_alive (); + block = entry_block; + + if (for_bounds) + create_variable (next_for_bounds (false), for_bounds); + + visit (tee); + + // FIXME: Remove if we no longer only compile loops + assert (! breaking); + assert (breaks.empty ()); + assert (continues.empty ()); + + block->append (create<jit_branch> (final_block)); + append (final_block); + + for (vmap_t::iterator iter = vmap.begin (); iter != vmap.end (); ++iter) + { + jit_variable *var = iter->second; + const std::string& name = var->name (); + if (name.size () && name[0] != '#') + final_block->append (create<jit_store_argument> (var)); + } + + construct_ssa (); + + // initialize the worklist to instructions derived from constants + for (std::list<jit_value *>::iterator iter = constants.begin (); + iter != constants.end (); ++iter) + append_users (*iter); + + // the entry block terminator may be a regular branch statement + if (entry_block->terminator ()) + push_worklist (entry_block->terminator ()); + + // FIXME: Describe algorithm here + while (worklist.size ()) + { + jit_instruction *next = worklist.front (); + worklist.pop_front (); + next->stash_in_worklist (false); + + if (next->infer ()) + { + // terminators need to be handles specially + if (jit_terminator *term = dynamic_cast<jit_terminator *> (next)) + append_users_term (term); + else + append_users (next); + } + } + + remove_dead (); + merge_blocks (); + final_block->label (); + place_releases (); + simplify_phi (); + +#ifdef OCTAVE_JIT_DEBUG + final_block->label (); + std::cout << "-------------------- Compiling tree --------------------\n"; + std::cout << tee.str_print_code () << std::endl; + print_blocks ("octave jit ir"); +#endif + + // for now just init arguments from entry, later we will have to do something + // more interesting + for (jit_block::iterator iter = entry_block->begin (); + iter != entry_block->end (); ++iter) + if (jit_extract_argument *extract + = dynamic_cast<jit_extract_argument *> (*iter)) + arguments.push_back (std::make_pair (extract->name (), true)); + + convert_llvm to_llvm (*this); + function = to_llvm.convert (module, arguments, blocks, constants); + +#ifdef OCTAVE_JIT_DEBUG + std::cout << "-------------------- llvm ir --------------------"; + llvm::raw_os_ostream llvm_cout (std::cout); + function->print (llvm_cout); + std::cout << std::endl; + llvm::verifyFunction (*function); +#endif +} + +jit_convert::~jit_convert (void) +{ + for (std::list<jit_value *>::iterator iter = all_values.begin (); + iter != all_values.end (); ++iter) + delete *iter; +} + +void +jit_convert::visit_anon_fcn_handle (tree_anon_fcn_handle&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_argument_list (tree_argument_list&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_binary_expression (tree_binary_expression& be) +{ + if (be.op_type () >= octave_value::num_binary_ops) + { + tree_boolean_expression *boole; + boole = dynamic_cast<tree_boolean_expression *> (&be); + assert (boole); + bool is_and = boole->op_type () == tree_boolean_expression::bool_and; + + std::string short_name = next_shortcircut_result (); + jit_variable *short_result = create<jit_variable> (short_name); + vmap[short_name] = short_result; + + jit_block *done = create<jit_block> (block->name ()); + tree_expression *lhs = be.lhs (); + jit_value *lhsv = visit (lhs); + lhsv = create_checked (&jit_typeinfo::logically_true, lhsv); + + jit_block *short_early = create<jit_block> ("short_early"); + append (short_early); + + jit_block *short_cont = create<jit_block> ("short_cont"); + + if (is_and) + block->append (create<jit_cond_branch> (lhsv, short_cont, short_early)); + else + block->append (create<jit_cond_branch> (lhsv, short_early, short_cont)); + + block = short_early; + + jit_value *early_result = create<jit_const_bool> (! is_and); + block->append (create<jit_assign> (short_result, early_result)); + block->append (create<jit_branch> (done)); + + append (short_cont); + block = short_cont; + + tree_expression *rhs = be.rhs (); + jit_value *rhsv = visit (rhs); + rhsv = create_checked (&jit_typeinfo::logically_true, rhsv); + block->append (create<jit_assign> (short_result, rhsv)); + block->append (create<jit_branch> (done)); + + append (done); + block = done; + result = short_result; + } + else + { + tree_expression *lhs = be.lhs (); + jit_value *lhsv = visit (lhs); + + tree_expression *rhs = be.rhs (); + jit_value *rhsv = visit (rhs); + + const jit_operation& fn = jit_typeinfo::binary_op (be.op_type ()); + result = create_checked (fn, lhsv, rhsv); + } +} + +void +jit_convert::visit_break_command (tree_break_command&) +{ + breaks.push_back (block); + breaking = true; +} + +void +jit_convert::visit_colon_expression (tree_colon_expression& expr) +{ + // in the futher we need to add support for classes and deal with rvalues + jit_value *base = visit (expr.base ()); + jit_value *limit = visit (expr.limit ()); + jit_value *increment; + tree_expression *tinc = expr.increment (); + + if (tinc) + increment = visit (tinc); + else + increment = create<jit_const_scalar> (1); + + result = block->append (create<jit_call> (jit_typeinfo::make_range, base, + limit, increment)); +} + +void +jit_convert::visit_continue_command (tree_continue_command&) +{ + continues.push_back (block); + breaking = true; +} + +void +jit_convert::visit_global_command (tree_global_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_persistent_command (tree_persistent_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_decl_elt (tree_decl_elt&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_decl_init_list (tree_decl_init_list&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_simple_for_command (tree_simple_for_command& cmd) +{ + // Note we do an initial check to see if the loop will run atleast once. + // This allows us to get better type inference bounds on variables defined + // and used only inside the for loop (e.g. the index variable) + + // If we are a nested for loop we need to store the previous breaks + assert (! breaking); + unwind_protect prot; + prot.protect_var (breaks); + prot.protect_var (continues); + prot.protect_var (breaking); + breaks.clear (); + continues.clear (); + + // we need a variable for our iterator, because it is used in multiple blocks + std::string iter_name = next_iterator (); + jit_variable *iterator = create<jit_variable> (iter_name); + create<jit_variable> (iter_name); + vmap[iter_name] = iterator; + + jit_block *body = create<jit_block> ("for_body"); + append (body); + + jit_block *tail = create<jit_block> ("for_tail"); + + // do control expression, iter init, and condition check in prev_block (block) + // if we are the top level for loop, the bounds is an input argument. + jit_value *control = find_variable (next_for_bounds ()); + if (! control) + control = visit (cmd.control_expr ()); + jit_call *init_iter = create<jit_call> (jit_typeinfo::for_init, control); + block->append (init_iter); + block->append (create<jit_assign> (iterator, init_iter)); + + jit_value *check = block->append (create<jit_call> (jit_typeinfo::for_check, + control, iterator)); + block->append (create<jit_cond_branch> (check, body, tail)); + block = body; + + // compute the syntactical iterator + jit_call *idx_rhs = create<jit_call> (jit_typeinfo::for_index, control, + iterator); + block->append (idx_rhs); + do_assign (cmd.left_hand_side (), idx_rhs); + + // do loop + tree_statement_list *pt_body = cmd.body (); + pt_body->accept (*this); + + if (breaking && continues.empty ()) + { + // WTF are you doing user? Every branch was a continue, why did you have + // a loop??? Users are silly people... + finish_breaks (tail, breaks); + append (tail); + block = tail; + return; + } + + // check our condition, continues jump to this block + jit_block *check_block = create<jit_block> ("for_check"); + append (check_block); + + if (! breaking) + block->append (create<jit_branch> (check_block)); + finish_breaks (check_block, continues); + + block = check_block; + const jit_operation& add_fn = jit_typeinfo::binary_op (octave_value::op_add); + jit_value *one = create<jit_const_index> (1); + jit_call *iter_inc = create<jit_call> (add_fn, iterator, one); + block->append (iter_inc); + block->append (create<jit_assign> (iterator, iter_inc)); + check = block->append (create<jit_call> (jit_typeinfo::for_check, control, + iterator)); + block->append (create<jit_cond_branch> (check, body, tail)); + + // breaks will go to our tail + append (tail); + finish_breaks (tail, breaks); + block = tail; +} + +void +jit_convert::visit_complex_for_command (tree_complex_for_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_octave_user_script (octave_user_script&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_octave_user_function (octave_user_function&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_octave_user_function_header (octave_user_function&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_octave_user_function_trailer (octave_user_function&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_function_def (tree_function_def&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_identifier (tree_identifier& ti) +{ + result = get_variable (ti.name ()); +} + +void +jit_convert::visit_if_clause (tree_if_clause&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_if_command (tree_if_command& cmd) +{ + tree_if_command_list *lst = cmd.cmd_list (); + assert (lst); // jwe: Can this be null? + lst->accept (*this); +} + +void +jit_convert::visit_if_command_list (tree_if_command_list& lst) +{ + tree_if_clause *last = lst.back (); + size_t last_else = static_cast<size_t> (last->is_else_clause ()); + + // entry_blocks represents the block you need to enter in order to execute + // the condition check for the ith clause. For the else, it is simple the + // else body. If there is no else body, then it is padded with the tail + std::vector<jit_block *> entry_blocks (lst.size () + 1 - last_else); + std::vector<jit_block *> branch_blocks (lst.size (), 0); // final blocks + entry_blocks[0] = block; + + // we need to construct blocks first, because they have jumps to eachother + tree_if_command_list::iterator iter = lst.begin (); + ++iter; + for (size_t i = 1; iter != lst.end (); ++iter, ++i) + { + tree_if_clause *tic = *iter; + if (tic->is_else_clause ()) + entry_blocks[i] = create<jit_block> ("else"); + else + entry_blocks[i] = create<jit_block> ("ifelse_cond"); + } + + jit_block *tail = create<jit_block> ("if_tail"); + if (! last_else) + entry_blocks[entry_blocks.size () - 1] = tail; + + size_t num_incomming = 0; // number of incomming blocks to our tail + iter = lst.begin (); + for (size_t i = 0; iter != lst.end (); ++iter, ++i) + { + tree_if_clause *tic = *iter; + block = entry_blocks[i]; + assert (block); + + if (i) // the first block is prev_block, so it has already been added + append (entry_blocks[i]); + + if (! tic->is_else_clause ()) + { + tree_expression *expr = tic->condition (); + jit_value *cond = visit (expr); + jit_call *check = create_checked (&jit_typeinfo::logically_true, + cond); + jit_block *body = create<jit_block> (i == 0 ? "if_body" + : "ifelse_body"); + append (body); + + jit_instruction *br = create<jit_cond_branch> (check, body, + entry_blocks[i + 1]); + block->append (br); + block = body; + } + + tree_statement_list *stmt_lst = tic->commands (); + assert (stmt_lst); // jwe: Can this be null? + stmt_lst->accept (*this); + + if (breaking) + breaking = false; + else + { + ++num_incomming; + block->append (create<jit_branch> (tail)); + } + } + + if (num_incomming || ! last_else) + { + append (tail); + block = tail; + } + else + // every branch broke, so we don't have a tail + breaking = true; +} + +void +jit_convert::visit_index_expression (tree_index_expression& exp) +{ + std::pair<jit_value *, jit_value *> res = resolve (exp); + jit_value *object = res.first; + jit_value *index = res.second; + + result = create_checked (jit_typeinfo::paren_subsref, object, index); +} + +void +jit_convert::visit_matrix (tree_matrix&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_cell (tree_cell&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_multi_assignment (tree_multi_assignment&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_no_op_command (tree_no_op_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_constant (tree_constant& tc) +{ + octave_value v = tc.rvalue1 (); + if (v.is_real_scalar () && v.is_double_type ()) + { + double dv = v.double_value (); + result = create<jit_const_scalar> (dv); + } + else if (v.is_range ()) + { + Range rv = v.range_value (); + result = create<jit_const_range> (rv); + } + else if (v.is_complex_scalar ()) + { + Complex cv = v.complex_value (); + result = create<jit_const_complex> (cv); + } + else + throw jit_fail_exception ("Unknown constant"); +} + +void +jit_convert::visit_fcn_handle (tree_fcn_handle&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_parameter_list (tree_parameter_list&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_postfix_expression (tree_postfix_expression&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_prefix_expression (tree_prefix_expression&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_return_command (tree_return_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_return_list (tree_return_list&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_simple_assignment (tree_simple_assignment& tsa) +{ + if (tsa.op_type () != octave_value::op_asn_eq) + throw jit_fail_exception ("Unsupported assign"); + + // resolve rhs + tree_expression *rhs = tsa.right_hand_side (); + jit_value *rhsv = visit (rhs); + + result = do_assign (tsa.left_hand_side (), rhsv); +} + +void +jit_convert::visit_statement (tree_statement& stmt) +{ + tree_command *cmd = stmt.command (); + tree_expression *expr = stmt.expression (); + + if (cmd) + visit (cmd); + else + { + // stolen from tree_evaluator::visit_statement + bool do_bind_ans = false; + + if (expr->is_identifier ()) + { + tree_identifier *id = dynamic_cast<tree_identifier *> (expr); + + do_bind_ans = (! id->is_variable ()); + } + else + do_bind_ans = (! expr->is_assignment_expression ()); + + jit_value *expr_result = visit (expr); + + if (do_bind_ans) + do_assign ("ans", expr_result, expr->print_result ()); + else if (expr->is_identifier () && expr->print_result ()) + { + // FIXME: ugly hack, we need to come up with a way to pass + // nargout to visit_identifier + const jit_operation& fn = jit_typeinfo::print_value (); + jit_const_string *name = create<jit_const_string> (expr->name ()); + block->append (create<jit_call> (fn, name, expr_result)); + } + } +} + +void +jit_convert::visit_statement_list (tree_statement_list& lst) +{ + for (tree_statement_list::iterator iter = lst.begin (); iter != lst.end(); + ++iter) + { + tree_statement *elt = *iter; + // jwe: Can this ever be null? + assert (elt); + elt->accept (*this); + + if (breaking) + break; + } +} + +void +jit_convert::visit_switch_case (tree_switch_case&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_switch_case_list (tree_switch_case_list&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_switch_command (tree_switch_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_try_catch_command (tree_try_catch_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_unwind_protect_command (tree_unwind_protect_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::visit_while_command (tree_while_command& wc) +{ + assert (! breaking); + unwind_protect prot; + prot.protect_var (breaks); + prot.protect_var (continues); + prot.protect_var (breaking); + breaks.clear (); + continues.clear (); + + jit_block *cond_check = create<jit_block> ("while_cond_check"); + block->append (create<jit_branch> (cond_check)); + append (cond_check); + block = cond_check; + + tree_expression *expr = wc.condition (); + assert (expr && "While expression can not be null"); + jit_value *check = visit (expr); + check = create_checked (&jit_typeinfo::logically_true, check); + + jit_block *body = create<jit_block> ("while_body"); + append (body); + + jit_block *tail = create<jit_block> ("while_tail"); + block->append (create<jit_cond_branch> (check, body, tail)); + block = body; + + tree_statement_list *loop_body = wc.body (); + if (loop_body) + loop_body->accept (*this); + + finish_breaks (tail, breaks); + finish_breaks (cond_check, continues); + + if (! breaking) + block->append (create<jit_branch> (cond_check)); + + append (tail); + block = tail; +} + +void +jit_convert::visit_do_until_command (tree_do_until_command&) +{ + throw jit_fail_exception (); +} + +void +jit_convert::append (jit_block *ablock) +{ + blocks.push_back (ablock); + ablock->stash_location (--blocks.end ()); +} + +void +jit_convert::insert_before (block_iterator iter, jit_block *ablock) +{ + iter = blocks.insert (iter, ablock); + ablock->stash_location (iter); +} + +void +jit_convert::insert_after (block_iterator iter, jit_block *ablock) +{ + ++iter; + insert_before (iter, ablock); +} + +jit_variable * +jit_convert::find_variable (const std::string& vname) const +{ + vmap_t::const_iterator iter; + iter = vmap.find (vname); + return iter != vmap.end () ? iter->second : 0; +} + +jit_variable * +jit_convert::get_variable (const std::string& vname) +{ + jit_variable *ret = find_variable (vname); + if (ret) + return ret; + + octave_value val = symbol_table::find (vname); + jit_type *type = jit_typeinfo::type_of (val); + return create_variable (vname, type); +} + +jit_variable * +jit_convert::create_variable (const std::string& vname, jit_type *type) +{ + jit_variable *var = create<jit_variable> (vname); + jit_extract_argument *extract; + extract = create<jit_extract_argument> (type, var); + entry_block->prepend (extract); + return vmap[vname] = var; +} + +std::string +jit_convert::next_name (const char *prefix, size_t& count, bool inc) +{ + std::stringstream ss; + ss << prefix << count; + if (inc) + ++count; + return ss.str (); +} + +std::pair<jit_value *, jit_value *> +jit_convert::resolve (tree_index_expression& exp) +{ + std::string type = exp.type_tags (); + if (! (type.size () == 1 && type[0] == '(')) + throw jit_fail_exception ("Unsupported index operation"); + + std::list<tree_argument_list *> args = exp.arg_lists (); + if (args.size () != 1) + throw jit_fail_exception ("Bad number of arguments in tree_index_expression"); + + tree_argument_list *arg_list = args.front (); + if (! arg_list) + throw jit_fail_exception ("null argument list"); + + if (arg_list->size () != 1) + throw jit_fail_exception ("Bad number of arguments in arg_list"); + + tree_expression *tree_object = exp.expression (); + jit_value *object = visit (tree_object); + tree_expression *arg0 = arg_list->front (); + jit_value *index = visit (arg0); + + return std::make_pair (object, index); +} + +jit_value * +jit_convert::do_assign (tree_expression *exp, jit_value *rhs, bool artificial) +{ + if (! exp) + throw jit_fail_exception ("NULL lhs in assign"); + + if (isa<tree_identifier> (exp)) + return do_assign (exp->name (), rhs, exp->print_result (), artificial); + else if (tree_index_expression *idx + = dynamic_cast<tree_index_expression *> (exp)) + { + std::pair<jit_value *, jit_value *> res = resolve (*idx); + jit_value *object = res.first; + jit_value *index = res.second; + jit_call *new_object = create<jit_call> (&jit_typeinfo::paren_subsasgn, + object, index, rhs); + block->append (new_object); + do_assign (idx->expression (), new_object, true); + create_check (new_object); + + // FIXME: Will not work for values that must be release/grabed + return rhs; + } + else + throw jit_fail_exception ("Unsupported assignment"); +} + +jit_value * +jit_convert::do_assign (const std::string& lhs, jit_value *rhs, + bool print, bool artificial) +{ + jit_variable *var = get_variable (lhs); + jit_assign *assign = block->append (create<jit_assign> (var, rhs)); + + if (artificial) + assign->mark_artificial (); + + if (print) + { + const jit_operation& print_fn = jit_typeinfo::print_value (); + jit_const_string *name = create<jit_const_string> (lhs); + block->append (create<jit_call> (print_fn, name, var)); + } + + return var; +} + +jit_value * +jit_convert::visit (tree& tee) +{ + result = 0; + tee.accept (*this); + + jit_value *ret = result; + result = 0; + return ret; +} + +void +jit_convert::append_users_term (jit_terminator *term) +{ + for (size_t i = 0; i < term->successor_count (); ++i) + { + if (term->alive (i)) + { + jit_block *succ = term->successor (i); + for (jit_block::iterator iter = succ->begin (); iter != succ->end () + && isa<jit_phi> (*iter); ++iter) + push_worklist (*iter); + + jit_terminator *sterm = succ->terminator (); + if (sterm) + push_worklist (sterm); + } + } +} + +void +jit_convert::merge_blocks (void) +{ + std::vector<jit_block *> dead; + for (block_list::iterator iter = blocks.begin (); iter != blocks.end (); + ++iter) + { + jit_block *b = *iter; + jit_block *merged = b->maybe_merge (); + + if (merged) + { + if (merged == final_block) + final_block = b; + + if (merged == entry_block) + entry_block = b; + + dead.push_back (merged); + } + } + + for (size_t i = 0; i < dead.size (); ++i) + blocks.erase (dead[i]->location ()); +} + +void +jit_convert::construct_ssa (void) +{ + merge_blocks (); + final_block->label (); + final_block->compute_idom (entry_block); + entry_block->compute_df (); + entry_block->create_dom_tree (); + + // insert phi nodes where needed, this is done on a per variable basis + for (vmap_t::iterator iter = vmap.begin (); iter != vmap.end (); ++iter) + { + jit_block::df_set visited, added_phi; + std::list<jit_block *> ssa_worklist; + iter->second->use_blocks (visited); + ssa_worklist.insert (ssa_worklist.begin (), visited.begin (), + visited.end ()); + + while (ssa_worklist.size ()) + { + jit_block *b = ssa_worklist.front (); + ssa_worklist.pop_front (); + + for (jit_block::df_iterator diter = b->df_begin (); + diter != b->df_end (); ++diter) + { + jit_block *dblock = *diter; + if (! added_phi.count (dblock)) + { + jit_phi *phi = create<jit_phi> (iter->second, + dblock->use_count ()); + dblock->prepend (phi); + added_phi.insert (dblock); + } + + if (! visited.count (dblock)) + { + ssa_worklist.push_back (dblock); + visited.insert (dblock); + } + } + } + } + + do_construct_ssa (*entry_block, entry_block->visit_count ()); +} + +void +jit_convert::do_construct_ssa (jit_block& ablock, size_t avisit_count) +{ + if (ablock.visited (avisit_count)) + return; + + // replace variables with their current SSA value + for (jit_block::iterator iter = ablock.begin (); iter != ablock.end (); ++iter) + { + jit_instruction *instr = *iter; + instr->construct_ssa (); + instr->push_variable (); + } + + // finish phi nodes of successors + for (size_t i = 0; i < ablock.successor_count (); ++i) + { + jit_block *finish = ablock.successor (i); + + for (jit_block::iterator iter = finish->begin (); iter != finish->end () + && isa<jit_phi> (*iter);) + { + jit_phi *phi = static_cast<jit_phi *> (*iter); + jit_variable *var = phi->dest (); + if (var->has_top ()) + { + phi->add_incomming (&ablock, var->top ()); + ++iter; + } + else + { + // temporaries may have extranious phi nodes which can be removed + assert (! phi->use_count ()); + assert (var->name ().size () && var->name ()[0] == '#'); + iter = finish->remove (iter); + } + } + } + + for (size_t i = 0; i < ablock.dom_successor_count (); ++i) + do_construct_ssa (*ablock.dom_successor (i), avisit_count); + + ablock.pop_all (); +} + +void +jit_convert::remove_dead () +{ + block_list::iterator biter; + for (biter = blocks.begin (); biter != blocks.end (); ++biter) + { + jit_block *b = *biter; + if (b->alive ()) + { + for (jit_block::iterator iter = b->begin (); iter != b->end () + && isa<jit_phi> (*iter);) + { + jit_phi *phi = static_cast<jit_phi *> (*iter); + if (phi->prune ()) + iter = b->remove (iter); + else + ++iter; + } + } + } + + for (biter = blocks.begin (); biter != blocks.end ();) + { + jit_block *b = *biter; + if (b->alive ()) + { + // FIXME: A special case for jit_error_check, if we generalize to + // we will need to change! + jit_terminator *term = b->terminator (); + if (term && term->successor_count () == 2 && ! term->alive (0)) + { + jit_block *succ = term->successor (1); + term->remove (); + jit_branch *abreak = b->append (create<jit_branch> (succ)); + abreak->infer (); + } + + ++biter; + } + else + { + jit_terminator *term = b->terminator (); + if (term) + term->remove (); + biter = blocks.erase (biter); + } + } +} + +void +jit_convert::place_releases (void) +{ + std::set<jit_value *> temporaries; + for (block_list::iterator iter = blocks.begin (); iter != blocks.end (); + ++iter) + { + jit_block& ablock = **iter; + if (ablock.id () != jit_block::NO_ID) + { + release_temp (ablock, temporaries); + release_dead_phi (ablock); + } + } +} + +void +jit_convert::release_temp (jit_block& ablock, std::set<jit_value *>& temp) +{ + for (jit_block::iterator iter = ablock.begin (); iter != ablock.end (); + ++iter) + { + jit_instruction *instr = *iter; + + // check for temporaries that require release and live across + // multiple blocks + if (instr->needs_release ()) + { + jit_block *fu_block = instr->first_use_block (); + if (fu_block && fu_block != &ablock) + temp.insert (instr); + } + + if (isa<jit_call> (instr)) + { + // place releases for temporary arguments + for (size_t i = 0; i < instr->argument_count (); ++i) + { + jit_value *arg = instr->argument (i); + if (arg->needs_release ()) + { + jit_call *release = create<jit_call> (&jit_typeinfo::release, + arg); + release->infer (); + ablock.insert_after (iter, release); + ++iter; + temp.erase (arg); + } + } + } + } + + if (! temp.size () || ! isa<jit_error_check> (ablock.terminator ())) + return; + + // FIXME: If we support try/catch or unwind_protect final_block may not be the + // destination + jit_block *split = ablock.maybe_split (*this, final_block); + jit_terminator *term = split->terminator (); + for (std::set<jit_value *>::const_iterator iter = temp.begin (); + iter != temp.end (); ++iter) + { + jit_value *value = *iter; + jit_call *release = create<jit_call> (&jit_typeinfo::release, value); + split->insert_before (term, release); + release->infer (); + } +} + +void +jit_convert::release_dead_phi (jit_block& ablock) +{ + jit_block::iterator iter = ablock.begin (); + while (iter != ablock.end () && isa<jit_phi> (*iter)) + { + jit_phi *phi = static_cast<jit_phi *> (*iter); + ++iter; + + jit_use *use = phi->first_use (); + if (phi->use_count () == 1 && isa<jit_assign> (use->user ())) + { + // instead of releasing on assign, release on all incomming branches, + // this can get rid of casts inside loops + for (size_t i = 0; i < phi->argument_count (); ++i) + { + jit_value *arg = phi->argument (i); + jit_block *inc = phi->incomming (i); + jit_block *split = inc->maybe_split (*this, ablock); + jit_terminator *term = split->terminator (); + jit_call *release = create<jit_call> (jit_typeinfo::release, arg); + release->infer (); + split->insert_before (term, release); + } + + phi->replace_with (0); + phi->remove (); + } + } +} + +void +jit_convert::simplify_phi (void) +{ + for (block_list::iterator biter = blocks.begin (); biter != blocks.end (); + ++biter) + { + jit_block &ablock = **biter; + for (jit_block::iterator iter = ablock.begin (); iter != ablock.end () + && isa<jit_phi> (*iter); ++iter) + simplify_phi (*static_cast<jit_phi *> (*iter)); + } +} + +void +jit_convert::simplify_phi (jit_phi& phi) +{ + jit_block& pblock = *phi.parent (); + const jit_operation& cast_fn = jit_typeinfo::cast (phi.type ()); + jit_variable *dest = phi.dest (); + for (size_t i = 0; i < phi.argument_count (); ++i) + { + jit_value *arg = phi.argument (i); + if (arg->type () != phi.type ()) + { + jit_block *pred = phi.incomming (i); + jit_block *split = pred->maybe_split (*this, pblock); + jit_terminator *term = split->terminator (); + jit_instruction *cast = create<jit_call> (cast_fn, arg); + jit_assign *assign = create<jit_assign> (dest, cast); + + split->insert_before (term, cast); + split->insert_before (term, assign); + cast->infer (); + assign->infer (); + phi.stash_argument (i, assign); + } + } +} + +void +jit_convert::finish_breaks (jit_block *dest, const block_list& lst) +{ + for (block_list::const_iterator iter = lst.begin (); iter != lst.end (); + ++iter) + { + jit_block *b = *iter; + b->append (create<jit_branch> (dest)); + } +} + +// -------------------- jit_convert::convert_llvm -------------------- +llvm::Function * +jit_convert::convert_llvm::convert (llvm::Module *module, + const std::vector<std::pair< std::string, bool> >& args, + const std::list<jit_block *>& blocks, + const std::list<jit_value *>& constants) +{ + jit_type *any = jit_typeinfo::get_any (); + + // argument is an array of octave_base_value*, or octave_base_value** + llvm::Type *arg_type = any->to_llvm (); // this is octave_base_value* + arg_type = arg_type->getPointerTo (); + llvm::FunctionType *ft = llvm::FunctionType::get (llvm::Type::getVoidTy (context), + arg_type, false); + function = llvm::Function::Create (ft, llvm::Function::ExternalLinkage, + "foobar", module); + + try + { + prelude = llvm::BasicBlock::Create (context, "prelude", function); + builder.SetInsertPoint (prelude); + + llvm::Value *arg = function->arg_begin (); + for (size_t i = 0; i < args.size (); ++i) + { + llvm::Value *loaded_arg = builder.CreateConstInBoundsGEP1_32 (arg, i); + arguments[args[i].first] = loaded_arg; + } + + std::list<jit_block *>::const_iterator biter; + for (biter = blocks.begin (); biter != blocks.end (); ++biter) + { + jit_block *jblock = *biter; + llvm::BasicBlock *block = llvm::BasicBlock::Create (context, + jblock->name (), + function); + jblock->stash_llvm (block); + } + + jit_block *first = *blocks.begin (); + builder.CreateBr (first->to_llvm ()); + + // constants aren't in the IR, we visit those first + for (std::list<jit_value *>::const_iterator iter = constants.begin (); + iter != constants.end (); ++iter) + if (! isa<jit_instruction> (*iter)) + visit (*iter); + + // convert all instructions + for (biter = blocks.begin (); biter != blocks.end (); ++biter) + visit (*biter); + + // now finish phi nodes + for (biter = blocks.begin (); biter != blocks.end (); ++biter) + { + jit_block& block = **biter; + for (jit_block::iterator piter = block.begin (); + piter != block.end () && isa<jit_phi> (*piter); ++piter) + { + jit_instruction *phi = *piter; + finish_phi (static_cast<jit_phi *> (phi)); + } + } + + jit_block *last = blocks.back (); + builder.SetInsertPoint (last->to_llvm ()); + builder.CreateRetVoid (); + } catch (const jit_fail_exception& e) + { + function->eraseFromParent (); + throw; + } + + return function; +} + +void +jit_convert::convert_llvm::finish_phi (jit_phi *phi) +{ + llvm::PHINode *llvm_phi = phi->to_llvm (); + for (size_t i = 0; i < phi->argument_count (); ++i) + { + llvm::BasicBlock *pred = phi->incomming_llvm (i); + llvm_phi->addIncoming (phi->argument_llvm (i), pred); + } +} + +void +jit_convert::convert_llvm::visit (jit_const_string& cs) +{ + cs.stash_llvm (builder.CreateGlobalStringPtr (cs.value ())); +} + +void +jit_convert::convert_llvm::visit (jit_const_bool& cb) +{ + cb.stash_llvm (llvm::ConstantInt::get (cb.type_llvm (), cb.value ())); +} + +void +jit_convert::convert_llvm::visit (jit_const_scalar& cs) +{ + cs.stash_llvm (llvm::ConstantFP::get (cs.type_llvm (), cs.value ())); +} + +void +jit_convert::convert_llvm::visit (jit_const_complex& cc) +{ + llvm::Type *scalar_t = jit_typeinfo::get_scalar_llvm (); + llvm::Constant *values[2]; + Complex value = cc.value (); + values[0] = llvm::ConstantFP::get (scalar_t, value.real ()); + values[1] = llvm::ConstantFP::get (scalar_t, value.imag ()); + cc.stash_llvm (llvm::ConstantVector::get (values)); +} + +void jit_convert::convert_llvm::visit (jit_const_index& ci) +{ + ci.stash_llvm (llvm::ConstantInt::get (ci.type_llvm (), ci.value ())); +} + +void +jit_convert::convert_llvm::visit (jit_const_range& cr) +{ + llvm::StructType *stype = llvm::cast<llvm::StructType>(cr.type_llvm ()); + llvm::Type *scalar_t = jit_typeinfo::get_scalar_llvm (); + llvm::Type *idx = jit_typeinfo::get_index_llvm (); + const jit_range& rng = cr.value (); + + llvm::Constant *constants[4]; + constants[0] = llvm::ConstantFP::get (scalar_t, rng.base); + constants[1] = llvm::ConstantFP::get (scalar_t, rng.limit); + constants[2] = llvm::ConstantFP::get (scalar_t, rng.inc); + constants[3] = llvm::ConstantInt::get (idx, rng.nelem); + + llvm::Value *as_llvm; + as_llvm = llvm::ConstantStruct::get (stype, + llvm::makeArrayRef (constants, 4)); + cr.stash_llvm (as_llvm); +} + +void +jit_convert::convert_llvm::visit (jit_block& b) +{ + llvm::BasicBlock *block = b.to_llvm (); + builder.SetInsertPoint (block); + for (jit_block::iterator iter = b.begin (); iter != b.end (); ++iter) + visit (*iter); +} + +void +jit_convert::convert_llvm::visit (jit_branch& b) +{ + b.stash_llvm (builder.CreateBr (b.successor_llvm ())); +} + +void +jit_convert::convert_llvm::visit (jit_cond_branch& cb) +{ + llvm::Value *cond = cb.cond_llvm (); + llvm::Value *br; + br = builder.CreateCondBr (cond, cb.successor_llvm (0), + cb.successor_llvm (1)); + cb.stash_llvm (br); +} + +void +jit_convert::convert_llvm::visit (jit_call& call) +{ + const jit_function& ol = call.overload (); + + std::vector<jit_value *> args (call.arguments ().size ()); + for (size_t i = 0; i < args.size (); ++i) + args[i] = call.argument (i); + + llvm::Value *ret = ol.call (builder, args); + call.stash_llvm (ret); +} + +void +jit_convert::convert_llvm::visit (jit_extract_argument& extract) +{ + llvm::Value *arg = arguments[extract.name ()]; + assert (arg); + arg = builder.CreateLoad (arg); + + const jit_function& ol = extract.overload (); + extract.stash_llvm (ol.call (builder, arg)); +} + +void +jit_convert::convert_llvm::visit (jit_store_argument& store) +{ + const jit_function& ol = store.overload (); + llvm::Value *arg_value = ol.call (builder, store.result ()); + llvm::Value *arg = arguments[store.name ()]; + store.stash_llvm (builder.CreateStore (arg_value, arg)); +} + +void +jit_convert::convert_llvm::visit (jit_phi& phi) +{ + // we might not have converted all incoming branches, so we don't + // set incomming branches now + llvm::PHINode *node = llvm::PHINode::Create (phi.type_llvm (), + phi.argument_count ()); + builder.Insert (node); + phi.stash_llvm (node); +} + +void +jit_convert::convert_llvm::visit (jit_variable&) +{ + throw jit_fail_exception ("ERROR: SSA construction should remove all variables"); +} + +void +jit_convert::convert_llvm::visit (jit_error_check& check) +{ + llvm::Value *cond = jit_typeinfo::insert_error_check (builder); + llvm::Value *br = builder.CreateCondBr (cond, check.successor_llvm (0), + check.successor_llvm (1)); + check.stash_llvm (br); +} + +void +jit_convert::convert_llvm::visit (jit_assign& assign) +{ + jit_value *new_value = assign.src (); + assign.stash_llvm (new_value->to_llvm ()); + + if (assign.artificial ()) + return; + + if (isa<jit_assign_base> (new_value)) + { + const jit_function& ol = jit_typeinfo::get_grab (new_value->type ()); + if (ol.valid ()) + assign.stash_llvm (ol.call (builder, new_value)); + } + + jit_value *overwrite = assign.overwrite (); + if (isa<jit_assign_base> (overwrite)) + { + const jit_function& ol = jit_typeinfo::get_release (overwrite->type ()); + ol.call (builder, overwrite); + } +} + +void +jit_convert::convert_llvm::visit (jit_argument&) +{} + +// -------------------- tree_jit -------------------- + +tree_jit::tree_jit (void) : module (0), engine (0) +{ +} + +tree_jit::~tree_jit (void) +{} + +bool +tree_jit::execute (tree_simple_for_command& cmd, const octave_value& bounds) +{ + const size_t MIN_TRIP_COUNT = 1000; + + size_t tc = trip_count (bounds); + if (! tc || ! initialize ()) + return false; + + jit_info::vmap extra_vars; + extra_vars["#for_bounds0"] = &bounds; + + jit_info *info = cmd.get_info (); + if (! info || ! info->match (extra_vars)) + { + if (tc < MIN_TRIP_COUNT) + return false; + + delete info; + info = new jit_info (*this, cmd, bounds); + cmd.stash_info (info); + } + + return info->execute (extra_vars); +} + +bool +tree_jit::execute (tree_while_command& cmd) +{ + if (! initialize ()) + return false; + + jit_info *info = cmd.get_info (); + if (! info || ! info->match ()) + { + delete info; + info = new jit_info (*this, cmd); + cmd.stash_info (info); + } + + return info->execute (); +} + +bool +tree_jit::initialize (void) +{ + if (engine) + return true; + + if (! module) + { + llvm::InitializeNativeTarget (); + module = new llvm::Module ("octave", context); + } + + // sometimes this fails pre main + engine = llvm::ExecutionEngine::createJIT (module); + + if (! engine) + return false; + + module_pass_manager = new llvm::PassManager (); + module_pass_manager->add (llvm::createAlwaysInlinerPass ()); + + pass_manager = new llvm::FunctionPassManager (module); + pass_manager->add (new llvm::TargetData(*engine->getTargetData ())); + pass_manager->add (llvm::createBasicAliasAnalysisPass ()); + pass_manager->add (llvm::createPromoteMemoryToRegisterPass ()); + pass_manager->add (llvm::createInstructionCombiningPass ()); + pass_manager->add (llvm::createReassociatePass ()); + pass_manager->add (llvm::createGVNPass ()); + pass_manager->add (llvm::createCFGSimplificationPass ()); + pass_manager->doInitialization (); + + jit_typeinfo::initialize (module, engine); + + return true; +} + +size_t +tree_jit::trip_count (const octave_value& bounds) const +{ + if (bounds.is_range ()) + { + Range rng = bounds.range_value (); + return rng.nelem (); + } + + // unsupported type + return 0; +} + + +void +tree_jit::optimize (llvm::Function *fn) +{ + module_pass_manager->run (*module); + pass_manager->run (*fn); + +#ifdef OCTAVE_JIT_DEBUG + std::string error; + llvm::raw_fd_ostream fout ("test.bc", error, + llvm::raw_fd_ostream::F_Binary); + llvm::WriteBitcodeToFile (module, fout); +#endif +} + +// -------------------- jit_info -------------------- +jit_info::jit_info (tree_jit& tjit, tree& tee) + : engine (tjit.get_engine ()), function (0), llvm_function (0) +{ + try + { + jit_convert conv (tjit.get_module (), tee); + initialize (tjit, conv); + } + catch (const jit_fail_exception& e) + { +#ifdef OCTAVE_JIT_DEBUG + if (e.known ()) + std::cout << "jit fail: " << e.what () << std::endl; +#endif + } +} + +jit_info::jit_info (tree_jit& tjit, tree& tee, const octave_value& for_bounds) + : engine (tjit.get_engine ()), function (0), llvm_function (0) +{ + try + { + jit_convert conv (tjit.get_module (), tee, + jit_typeinfo::type_of (for_bounds)); + initialize (tjit, conv); + } + catch (const jit_fail_exception& e) + { +#ifdef OCTAVE_JIT_DEBUG + if (e.known ()) + std::cout << "jit fail: " << e.what () << std::endl; +#endif + } +} + +jit_info::~jit_info (void) +{ + if (llvm_function) + llvm_function->eraseFromParent (); +} + +bool +jit_info::execute (const vmap& extra_vars) const +{ + if (! function) + return false; + + std::vector<octave_base_value *> real_arguments (arguments.size ()); + for (size_t i = 0; i < arguments.size (); ++i) + { + if (arguments[i].second) + { + octave_value current = find (extra_vars, arguments[i].first); + octave_base_value *obv = current.internal_rep (); + obv->grab (); + real_arguments[i] = obv; + } + } + + function (&real_arguments[0]); + + for (size_t i = 0; i < arguments.size (); ++i) + { + const std::string& name = arguments[i].first; + + // do not store for loop bounds temporary + if (name.size () && name[0] != '#') + symbol_table::varref (arguments[i].first) = real_arguments[i]; + } + + return true; +} + +bool +jit_info::match (const vmap& extra_vars) const +{ + if (! function) + return true; + + for (size_t i = 0; i < bounds.size (); ++i) + { + const std::string& arg_name = bounds[i].second; + octave_value value = find (extra_vars, arg_name); + jit_type *type = jit_typeinfo::type_of (value); + + // FIXME: Check for a parent relationship + if (type != bounds[i].first) + return false; + } + + return true; +} + +void +jit_info::initialize (tree_jit& tjit, jit_convert& conv) +{ + llvm_function = conv.get_function (); + arguments = conv.get_arguments (); + bounds = conv.get_bounds (); + + if (llvm_function) + { + tjit.optimize (llvm_function); + +#ifdef OCTAVE_JIT_DEBUG + std::cout << "-------------------- optimized llvm ir " + << "--------------------\n"; + llvm::raw_os_ostream llvm_cout (std::cout); + llvm_function->print (llvm_cout); + llvm_cout.flush (); + std::cout << std::endl; +#endif + + void *void_fn = engine->getPointerToFunction (llvm_function); + function = reinterpret_cast<jited_function> (void_fn); + } +} + +octave_value +jit_info::find (const vmap& extra_vars, const std::string& vname) const +{ + vmap::const_iterator iter = extra_vars.find (vname); + return iter == extra_vars.end () ? symbol_table::varval (vname) + : *iter->second; +} + +#endif + + +/* +Test some simple cases that compile. + +%!test +%! inc = 1e-5; +%! result = 0; +%! for ii = 0:inc:1 +%! result = result + inc * (1/3 * ii * ii); +%! endfor +%! assert (abs (result - 1/9) < 1e-5); + +%!test +%! inc = 1e-5; +%! result = 0; +%! for ii = 0:inc:1 +%! # the ^ operator's result is complex +%! result = result + inc * (1/3 * ii ^ 2); +%! endfor +%! assert (abs (result - 1/9) < 1e-5); + +%!test +%! nr = 1001; +%! mat = zeros (1, nr); +%! for i = 1:nr +%! mat(i) = i; +%! endfor +%! assert (mat == 1:nr); + +%!test +%! nr = 1001; +%! mat = 1:nr; +%! mat(end) = 0; # force mat to a matrix +%! total = 0; +%! for i = 1:nr +%! total = mat(i) + total; +%! endfor +%! assert (sum (mat) == total); + +%!test +%! nr = 1001; +%! mat = [3 1 5]; +%! try +%! for i = 1:nr +%! if i > 500 +%! result = mat(100); +%! else +%! result = i; +%! endif +%! endfor +%! catch +%! end +%! assert (result == 500); + +%!function result = gen_test (n) +%! result = double (rand (1, n) > .01); +%!endfunction + +%!function z = vectorized (A, K) +%! temp = ones (1, K); +%! z = conv (A, temp); +%! z = z > K-1; +%! z = conv (z, temp); +%! z = z(K:end-K+1); +%! z = z >= 1; +%!endfunction + +%!function z = loopy (A, K) +%! z = A; +%! n = numel (A); +%! counter = 0; +%! for ii=1:n +%! if z(ii) +%! counter = counter + 1; +%! else +%! if counter > 0 && counter < K +%! z(ii-counter:ii-1) = 0; +%! endif +%! counter = 0; +%! endif +%! endfor +%! +%! if counter > 0 && counter < K +%! z(end-counter+1:end) = 0; +%! endif +%!endfunction + +%!test +%! test_set = gen_test (10000); +%! assert (all (vectorized (test_set, 3) == loopy (test_set, 3))); + +%!test +%! niter = 1001; +%! i = 0; +%! while (i < niter) +%! i = i + 1; +%! endwhile +%! assert (i == niter); + +*/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pt-jit.h Sat Jul 28 12:06:34 2012 -0400 @@ -0,0 +1,487 @@ +/* + +Copyright (C) 2012 Max Brister <max@2bass.com> + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, see +<http://www.gnu.org/licenses/>. + +*/ + +#if !defined (octave_tree_jit_h) +#define octave_tree_jit_h 1 + +#ifdef HAVE_LLVM + +#include "jit-ir.h" + +#include "pt-walk.h" + +// -------------------- Current status -------------------- +// Simple binary operations (+-*/) on octave_scalar's (doubles) are optimized. +// a = 5; +// b = a * 5 + a; +// +// Indexing matrices with scalars works. +// +// if, elseif, else, break, continue, and for compile. Compilation is triggered +// at the start of a simple for loop. +// +// The octave low level IR is a linear IR, it works by converting everything to +// calls to jit_operations. This turns expressions like c = a + b into +// c = call binary+ (a, b) +// The jit_operations contain information about overloads for different types. +// For, example, if we know a and b are scalars, then c must also be a scalar. +// +// Support for function calls is in progress. Currently, calls to sin with a +// scalar argument will compile. +// +// TODO: +// 1. Function calls (In progress) +// 2. Cleanup/documentation +// 3. ... +// --------------------------------------------------------- + +// convert between IRs +// FIXME: Class relationships are messy from here on down. They need to be +// cleaned up. +class +jit_convert : public tree_walker +{ +public: + typedef std::pair<jit_type *, std::string> type_bound; + typedef std::vector<type_bound> type_bound_vector; + + jit_convert (llvm::Module *module, tree &tee, jit_type *for_bounds = 0); + + ~jit_convert (void); + + llvm::Function *get_function (void) const { return function; } + + const std::vector<std::pair<std::string, bool> >& get_arguments(void) const + { return arguments; } + + const type_bound_vector& get_bounds (void) const { return bounds; } + + void visit_anon_fcn_handle (tree_anon_fcn_handle&); + + void visit_argument_list (tree_argument_list&); + + void visit_binary_expression (tree_binary_expression&); + + void visit_break_command (tree_break_command&); + + void visit_colon_expression (tree_colon_expression&); + + void visit_continue_command (tree_continue_command&); + + void visit_global_command (tree_global_command&); + + void visit_persistent_command (tree_persistent_command&); + + void visit_decl_elt (tree_decl_elt&); + + void visit_decl_init_list (tree_decl_init_list&); + + void visit_simple_for_command (tree_simple_for_command&); + + void visit_complex_for_command (tree_complex_for_command&); + + void visit_octave_user_script (octave_user_script&); + + void visit_octave_user_function (octave_user_function&); + + void visit_octave_user_function_header (octave_user_function&); + + void visit_octave_user_function_trailer (octave_user_function&); + + void visit_function_def (tree_function_def&); + + void visit_identifier (tree_identifier&); + + void visit_if_clause (tree_if_clause&); + + void visit_if_command (tree_if_command&); + + void visit_if_command_list (tree_if_command_list&); + + void visit_index_expression (tree_index_expression&); + + void visit_matrix (tree_matrix&); + + void visit_cell (tree_cell&); + + void visit_multi_assignment (tree_multi_assignment&); + + void visit_no_op_command (tree_no_op_command&); + + void visit_constant (tree_constant&); + + void visit_fcn_handle (tree_fcn_handle&); + + void visit_parameter_list (tree_parameter_list&); + + void visit_postfix_expression (tree_postfix_expression&); + + void visit_prefix_expression (tree_prefix_expression&); + + void visit_return_command (tree_return_command&); + + void visit_return_list (tree_return_list&); + + void visit_simple_assignment (tree_simple_assignment&); + + void visit_statement (tree_statement&); + + void visit_statement_list (tree_statement_list&); + + void visit_switch_case (tree_switch_case&); + + void visit_switch_case_list (tree_switch_case_list&); + + void visit_switch_command (tree_switch_command&); + + void visit_try_catch_command (tree_try_catch_command&); + + void visit_unwind_protect_command (tree_unwind_protect_command&); + + void visit_while_command (tree_while_command&); + + void visit_do_until_command (tree_do_until_command&); + + // this would be easier with variadic templates + template <typename T> + T *create (void) + { + T *ret = new T(); + track_value (ret); + return ret; + } + +#define DECL_ARG(n) const ARG ## n& arg ## n +#define JIT_CREATE(N) \ + template <typename T, OCT_MAKE_DECL_LIST (typename, ARG, N)> \ + T *create (OCT_MAKE_LIST (DECL_ARG, N)) \ + { \ + T *ret = new T (OCT_MAKE_ARG_LIST (arg, N)); \ + track_value (ret); \ + return ret; \ + } + + JIT_CREATE (1) + JIT_CREATE (2) + JIT_CREATE (3) + JIT_CREATE (4) + +#undef JIT_CREATE + +#define JIT_CREATE_CHECKED(N) \ + template <OCT_MAKE_DECL_LIST (typename, ARG, N)> \ + jit_call *create_checked (OCT_MAKE_LIST (DECL_ARG, N)) \ + { \ + jit_call *ret = create<jit_call> (OCT_MAKE_ARG_LIST (arg, N)); \ + return create_checked_impl (ret); \ + } + + JIT_CREATE_CHECKED (1) + JIT_CREATE_CHECKED (2) + JIT_CREATE_CHECKED (3) + JIT_CREATE_CHECKED (4) + +#undef JIT_CREATE_CHECKED +#undef DECL_ARG + + typedef std::list<jit_block *> block_list; + typedef block_list::iterator block_iterator; + + void append (jit_block *ablock); + + void insert_before (block_iterator iter, jit_block *ablock); + + void insert_before (jit_block *loc, jit_block *ablock) + { + insert_before (loc->location (), ablock); + } + + void insert_after (block_iterator iter, jit_block *ablock); + + void insert_after (jit_block *loc, jit_block *ablock) + { + insert_after (loc->location (), ablock); + } +private: + std::vector<std::pair<std::string, bool> > arguments; + type_bound_vector bounds; + + // used instead of return values from visit_* functions + jit_value *result; + + jit_block *entry_block; + + jit_block *final_block; + + jit_block *block; + + llvm::Function *function; + + std::list<jit_block *> blocks; + + std::list<jit_instruction *> worklist; + + std::list<jit_value *> constants; + + std::list<jit_value *> all_values; + + size_t iterator_count; + size_t for_bounds_count; + size_t short_count; + + typedef std::map<std::string, jit_variable *> vmap_t; + vmap_t vmap; + + jit_call *create_checked_impl (jit_call *ret) + { + block->append (ret); + create_check (ret); + return ret; + } + + jit_error_check *create_check (jit_call *call) + { + jit_block *normal = create<jit_block> (block->name ()); + jit_error_check *ret + = block->append (create<jit_error_check> (call, normal, final_block)); + append (normal); + block = normal; + + return ret; + } + + // get an existing vairable. If the variable does not exist, it will not be + // created + jit_variable *find_variable (const std::string& vname) const; + + // get a variable, create it if it does not exist. The type will default to + // the variable's current type in the symbol table. + jit_variable *get_variable (const std::string& vname); + + // create a variable of the given name and given type. Will also insert an + // extract statement + jit_variable *create_variable (const std::string& vname, jit_type *type); + + // The name of the next for loop iterator. If inc is false, then the iterator + // counter will not be incremented. + std::string next_iterator (bool inc = true) + { return next_name ("#iter", iterator_count, inc); } + + std::string next_for_bounds (bool inc = true) + { return next_name ("#for_bounds", for_bounds_count, inc); } + + std::string next_shortcircut_result (bool inc = true) + { return next_name ("#shortcircut_result", short_count, inc); } + + std::string next_name (const char *prefix, size_t& count, bool inc); + + std::pair<jit_value *, jit_value *> resolve (tree_index_expression& exp); + + jit_value *do_assign (tree_expression *exp, jit_value *rhs, + bool artificial = false); + + jit_value *do_assign (const std::string& lhs, jit_value *rhs, bool print, + bool artificial = false); + + jit_value *visit (tree *tee) { return visit (*tee); } + + jit_value *visit (tree& tee); + + void push_worklist (jit_instruction *instr) + { + if (! instr->in_worklist ()) + { + instr->stash_in_worklist (true); + worklist.push_back (instr); + } + } + + void append_users (jit_value *v) + { + for (jit_use *use = v->first_use (); use; use = use->next ()) + push_worklist (use->user ()); + } + + void append_users_term (jit_terminator *term); + + void track_value (jit_value *value) + { + if (value->type ()) + constants.push_back (value); + all_values.push_back (value); + } + + void merge_blocks (void); + + void construct_ssa (void); + + void do_construct_ssa (jit_block& block, size_t avisit_count); + + void remove_dead (); + + void place_releases (void); + + void release_temp (jit_block& ablock, std::set<jit_value *>& temp); + + void release_dead_phi (jit_block& ablock); + + void simplify_phi (void); + + void simplify_phi (jit_phi& phi); + + void print_blocks (const std::string& header) + { + std::cout << "-------------------- " << header << " --------------------\n"; + for (std::list<jit_block *>::iterator iter = blocks.begin (); + iter != blocks.end (); ++iter) + { + assert (*iter); + (*iter)->print (std::cout, 0); + } + std::cout << std::endl; + } + + void print_dom (void) + { + std::cout << "-------------------- dom info --------------------\n"; + for (std::list<jit_block *>::iterator iter = blocks.begin (); + iter != blocks.end (); ++iter) + { + assert (*iter); + (*iter)->print_dom (std::cout); + } + std::cout << std::endl; + } + + bool breaking; // true if we are breaking OR continuing + block_list breaks; + block_list continues; + + void finish_breaks (jit_block *dest, const block_list& lst); + + // this case is much simpler, just convert from the jit ir to llvm + class + convert_llvm : public jit_ir_walker + { + public: + convert_llvm (jit_convert& jc) : jthis (jc) {} + + llvm::Function *convert (llvm::Module *module, + const std::vector<std::pair<std::string, bool> >& args, + const std::list<jit_block *>& blocks, + const std::list<jit_value *>& constants); + +#define JIT_METH(clname) \ + virtual void visit (jit_ ## clname&); + + JIT_VISIT_IR_CLASSES; + +#undef JIT_METH + private: + // name -> llvm argument + std::map<std::string, llvm::Value *> arguments; + + void finish_phi (jit_phi *phi); + + void visit (jit_value *jvalue) + { + return visit (*jvalue); + } + + void visit (jit_value &jvalue) + { + jvalue.accept (*this); + } + private: + jit_convert &jthis; + llvm::Function *function; + llvm::BasicBlock *prelude; + }; +}; + +class jit_info; + +class +tree_jit +{ +public: + tree_jit (void); + + ~tree_jit (void); + + bool execute (tree_simple_for_command& cmd, const octave_value& bounds); + + bool execute (tree_while_command& cmd); + + llvm::ExecutionEngine *get_engine (void) const { return engine; } + + llvm::Module *get_module (void) const { return module; } + + void optimize (llvm::Function *fn); + private: + bool initialize (void); + + size_t trip_count (const octave_value& bounds) const; + + // FIXME: Temorary hack to test + typedef std::map<tree *, jit_info *> compiled_map; + llvm::Module *module; + llvm::PassManager *module_pass_manager; + llvm::FunctionPassManager *pass_manager; + llvm::ExecutionEngine *engine; +}; + +class +jit_info +{ +public: + // we use a pointer here so we don't have to include ov.h + typedef std::map<std::string, const octave_value *> vmap; + + jit_info (tree_jit& tjit, tree& tee); + + jit_info (tree_jit& tjit, tree& tee, const octave_value& for_bounds); + + ~jit_info (void); + + bool execute (const vmap& extra_vars = vmap ()) const; + + bool match (const vmap& extra_vars = vmap ()) const; +private: + typedef jit_convert::type_bound type_bound; + typedef jit_convert::type_bound_vector type_bound_vector; + typedef void (*jited_function)(octave_base_value**); + + void initialize (tree_jit& tjit, jit_convert& conv); + + octave_value find (const vmap& extra_vars, const std::string& vname) const; + + llvm::ExecutionEngine *engine; + jited_function function; + llvm::Function *llvm_function; + + std::vector<std::pair<std::string, bool> > arguments; + type_bound_vector bounds; +}; + +#endif +#endif
--- a/src/pt-loop.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/pt-loop.cc Sat Jul 28 12:06:34 2012 -0400 @@ -35,6 +35,7 @@ #include "pt-bp.h" #include "pt-cmd.h" #include "pt-exp.h" +#include "pt-jit.h" #include "pt-jump.h" #include "pt-loop.h" #include "pt-stmt.h" @@ -49,6 +50,9 @@ delete list; delete lead_comm; delete trail_comm; +#ifdef HAVE_LLVM + delete compiled; +#endif } tree_command * @@ -97,6 +101,9 @@ delete list; delete lead_comm; delete trail_comm; +#ifdef HAVE_LLVM + delete compiled; +#endif } tree_command *
--- a/src/pt-loop.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/pt-loop.h Sat Jul 28 12:06:34 2012 -0400 @@ -36,6 +36,8 @@ #include "pt-cmd.h" #include "symtab.h" +class jit_info; + // While. class @@ -45,21 +47,33 @@ tree_while_command (int l = -1, int c = -1) : tree_command (l, c), expr (0), list (0), lead_comm (0), - trail_comm (0) { } + trail_comm (0) +#ifdef HAVE_LLVM + , compiled (0) +#endif + { } tree_while_command (tree_expression *e, octave_comment_list *lc = 0, octave_comment_list *tc = 0, int l = -1, int c = -1) : tree_command (l, c), expr (e), list (0), lead_comm (lc), - trail_comm (tc) { } + trail_comm (tc) +#ifdef HAVE_LLVM + , compiled (0) +#endif + { } tree_while_command (tree_expression *e, tree_statement_list *lst, octave_comment_list *lc = 0, octave_comment_list *tc = 0, int l = -1, int c = -1) : tree_command (l, c), expr (e), list (lst), lead_comm (lc), - trail_comm (tc) { } + trail_comm (tc) +#ifdef HAVE_LLVM + , compiled (0) +#endif + { } ~tree_while_command (void); @@ -76,6 +90,19 @@ void accept (tree_walker& tw); +#ifdef HAVE_LLVM + // some functions use by tree_jit + jit_info *get_info (void) const + { + return compiled; + } + + void stash_info (jit_info *jinfo) + { + compiled = jinfo; + } +#endif + protected: // Expression to test. @@ -92,6 +119,11 @@ private: +#ifdef HAVE_LLVM + // compiled version of the loop + jit_info *compiled; +#endif + // No copying! tree_while_command (const tree_while_command&); @@ -146,7 +178,11 @@ tree_simple_for_command (int l = -1, int c = -1) : tree_command (l, c), parallel (false), lhs (0), expr (0), - maxproc (0), list (0), lead_comm (0), trail_comm (0) { } + maxproc (0), list (0), lead_comm (0), trail_comm (0) +#ifdef HAVE_LLVM + , compiled (0) +#endif + { } tree_simple_for_command (bool parallel_arg, tree_expression *le, tree_expression *re, @@ -157,7 +193,11 @@ int l = -1, int c = -1) : tree_command (l, c), parallel (parallel_arg), lhs (le), expr (re), maxproc (maxproc_arg), list (lst), - lead_comm (lc), trail_comm (tc) { } + lead_comm (lc), trail_comm (tc) +#ifdef HAVE_LLVM + , compiled (0) +#endif + { } ~tree_simple_for_command (void); @@ -180,8 +220,20 @@ void accept (tree_walker& tw); +#ifdef HAVE_LLVM + // some functions use by tree_jit + jit_info *get_info (void) const + { + return compiled; + } + + void stash_info (jit_info *jinfo) + { + compiled = jinfo; + } +#endif + private: - // TRUE means operate in parallel (subject to the value of the // maxproc expression). bool parallel; @@ -205,6 +257,9 @@ // Comment preceding ENDFOR token. octave_comment_list *trail_comm; + // compiled version of the loop + jit_info *compiled; + // No copying! tree_simple_for_command (const tree_simple_for_command&);
--- a/src/pt-stmt.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/pt-stmt.h Sat Jul 28 12:06:34 2012 -0400 @@ -35,12 +35,13 @@ #include "base-list.h" #include "comment-list.h" #include "symtab.h" +#include "pt.h" // A statement is either a command to execute or an expression to // evaluate. class -tree_statement +tree_statement : public tree { public:
--- a/src/sighandlers.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/sighandlers.cc Sat Jul 28 12:06:34 2012 -0400 @@ -63,7 +63,7 @@ // TRUE means we should try to enter the debugger on SIGINT. static bool Vdebug_on_interrupt = false; -// Allow users to avoid writing octave-core for SIGHUP (sent by +// Allow users to avoid writing octave-workspace for SIGHUP (sent by // closing gnome-terminal, for example). Note that this variable has // no effect if Vcrash_dumps_octave_core is FALSE. static bool Vsighup_dumps_octave_core = true; @@ -147,12 +147,12 @@ #endif case SIGFPE: - std::cerr << "warning: floating point exception -- trying to return to prompt" << std::endl; + std::cerr << "warning: floating point exception" << std::endl; break; #ifdef SIGPIPE case SIGPIPE: - std::cerr << "warning: broken pipe -- some output may be lost" << std::endl; + std::cerr << "warning: broken pipe" << std::endl; break; #endif } @@ -1001,7 +1001,7 @@ @deftypefnx {Built-in Function} {@var{old_val} =} sighup_dumps_octave_core (@var{new_val})\n\ @deftypefnx {Built-in Function} {} sighup_dumps_octave_core (@var{new_val}, \"local\")\n\ Query or set the internal variable that controls whether Octave tries\n\ -to save all current variables to the file \"octave-core\" if it receives\n\ +to save all current variables to the file \"octave-workspace\" if it receives\n\ a hangup signal.\n\ \n\ When called from inside a function with the \"local\" option, the variable is\n\ @@ -1030,7 +1030,7 @@ @deftypefnx {Built-in Function} {@var{old_val} =} sigterm_dumps_octave_core (@var{new_val})\n\ @deftypefnx {Built-in Function} {} sigterm_dumps_octave_core (@var{new_val}, \"local\")\n\ Query or set the internal variable that controls whether Octave tries\n\ -to save all current variables to the file \"octave-core\" if it receives\n\ +to save all current variables to the file \"octave-workspace\" if it receives\n\ a terminate signal.\n\ \n\ When called from inside a function with the \"local\" option, the variable is\n\
--- a/src/sparse.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/sparse.cc Sat Jul 28 12:06:34 2012 -0400 @@ -43,7 +43,7 @@ DEFUN (issparse, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {} issparse (@var{x})\n\ +@deftypefn {Built-in Function} {} issparse (@var{x})\n\ Return true if @var{x} is a sparse matrix.\n\ @seealso{ismatrix}\n\ @end deftypefn") @@ -59,11 +59,11 @@ DEFUN (sparse, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{s} =} sparse (@var{a})\n\ -@deftypefnx {Loadable Function} {@var{s} =} sparse (@var{i}, @var{j}, @var{sv}, @var{m}, @var{n}, @var{nzmax})\n\ -@deftypefnx {Loadable Function} {@var{s} =} sparse (@var{i}, @var{j}, @var{sv})\n\ -@deftypefnx {Loadable Function} {@var{s} =} sparse (@var{i}, @var{j}, @var{s}, @var{m}, @var{n}, \"unique\")\n\ -@deftypefnx {Loadable Function} {@var{s} =} sparse (@var{m}, @var{n})\n\ +@deftypefn {Built-in Function} {@var{s} =} sparse (@var{a})\n\ +@deftypefnx {Built-in Function} {@var{s} =} sparse (@var{i}, @var{j}, @var{sv}, @var{m}, @var{n}, @var{nzmax})\n\ +@deftypefnx {Built-in Function} {@var{s} =} sparse (@var{i}, @var{j}, @var{sv})\n\ +@deftypefnx {Built-in Function} {@var{s} =} sparse (@var{i}, @var{j}, @var{s}, @var{m}, @var{n}, \"unique\")\n\ +@deftypefnx {Built-in Function} {@var{s} =} sparse (@var{m}, @var{n})\n\ Create a sparse matrix from the full matrix or row, column, value triplets.\n\ If @var{a} is a full matrix, convert it to a sparse matrix representation,\n\ removing all zero values in the process.\n\ @@ -209,7 +209,7 @@ DEFUN (spalloc, args, , "-*- texinfo -*-\n\ -@deftypefn {Loadable Function} {@var{s} =} spalloc (@var{m}, @var{n}, @var{nz})\n\ +@deftypefn {Built-in Function} {@var{s} =} spalloc (@var{m}, @var{n}, @var{nz})\n\ Create an @var{m}-by-@var{n} sparse matrix with pre-allocated space for at\n\ most @var{nz} nonzero elements. This is useful for building the matrix\n\ incrementally by a sequence of indexed assignments. Subsequent indexed\n\
--- a/src/symtab.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/symtab.cc Sat Jul 28 12:06:34 2012 -0400 @@ -1713,3 +1713,32 @@ return retval; } #endif + + +/* +bug #34497: 'clear -f' does not work for command line functions + +This test relies on bar being a core function that is implemented in an m-file. +If the first assert fails, this is no longer the case and the tests need to be +updated to use some other function. + +%!assert (! strcmp (which ("bar"), "")); + +%!function x = bar () +%! x = 5; +%!endfunction +%!test +%! assert (bar == 5); +%! assert (strcmp (which ("bar"), "")); +%! clear -f bar; +%! assert (! strcmp (which ("bar"), "")); + +%!function x = bar () +%! x = 5; +%!endfunction +%!test +%! assert (bar == 5); +%! assert (strcmp (which ("bar"), "")); +%! clear bar; +%! assert (! strcmp (which ("bar"), "")); + */
--- a/src/symtab.h Sat Jul 28 15:17:57 2012 +0200 +++ b/src/symtab.h Sat Jul 28 12:06:34 2012 -0400 @@ -484,7 +484,7 @@ return symbol_record (rep->dup (new_scope)); } - std::string name (void) const { return rep->name; } + const std::string& name (void) const { return rep->name; } octave_value find (const octave_value_list& args = octave_value_list ()) const; @@ -581,6 +581,66 @@ symbol_record (symbol_record_rep *new_rep) : rep (new_rep) { } }; + // Always access a symbol from the current scope. + // Useful for scripts, as they may be executed in more than one scope. + class + symbol_reference + { + public: + symbol_reference (void) : scope (-1) {} + + symbol_reference (symbol_record record, + scope_id curr_scope = symbol_table::current_scope ()) + : scope (curr_scope), sym (record) + {} + + symbol_reference& operator = (const symbol_reference& ref) + { + scope = ref.scope; + sym = ref.sym; + return *this; + } + + // The name is the same regardless of scope. + const std::string& name (void) const { return sym.name (); } + + symbol_record *operator-> (void) + { + update (); + return &sym; + } + + symbol_record *operator-> (void) const + { + update (); + return &sym; + } + + // can be used to place symbol_reference in maps, we don't overload < as + // it doesn't make any sense for symbol_reference + struct comparator + { + bool operator ()(const symbol_reference& lhs, + const symbol_reference& rhs) const + { + return lhs.name () < rhs.name (); + } + }; + private: + void update (void) const + { + scope_id curr_scope = symbol_table::current_scope (); + if (scope != curr_scope || ! sym.is_valid ()) + { + scope = curr_scope; + sym = symbol_table::insert (sym.name ()); + } + } + + mutable scope_id scope; + mutable symbol_record sym; + }; + class fcn_info { @@ -708,20 +768,14 @@ } } - void clear_cmdline_function (void) - { - if (! cmdline_function.islocked ()) - cmdline_function = octave_value (); - } - void clear_autoload_function (void) { if (! autoload_function.islocked ()) autoload_function = octave_value (); } - // FIXME -- should this also clear the cmdline and other "user - // defined" functions? + // We also clear command line functions here, as these are both + // "user defined" void clear_user_function (void) { if (! function_on_path.islocked ()) @@ -730,6 +784,9 @@ function_on_path = octave_value (); } + + if (! cmdline_function.islocked ()) + cmdline_function = octave_value (); } void clear_mex_function (void) @@ -744,7 +801,6 @@ clear_unlocked (private_functions); clear_unlocked (class_constructors); clear_unlocked (class_methods); - clear_cmdline_function (); clear_autoload_function (); clear_user_function (); }
--- a/src/toplev.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/toplev.cc Sat Jul 28 12:06:34 2012 -0400 @@ -1325,6 +1325,9 @@ { false, "MAGICK_CPPFLAGS", OCTAVE_CONF_MAGICK_CPPFLAGS }, { false, "MAGICK_LDFLAGS", OCTAVE_CONF_MAGICK_LDFLAGS }, { false, "MAGICK_LIBS", OCTAVE_CONF_MAGICK_LIBS }, + { false, "LLVM_CPPFLAGS", OCTAVE_CONF_LLVM_CPPFLAGS }, + { false, "LLVM_LDFLAGS", OCTAVE_CONF_LLVM_LDFLAGS }, + { false, "LLVM_LIBS", OCTAVE_CONF_LLVM_LIBS }, { false, "MKOCTFILE_DL_LDFLAGS", OCTAVE_CONF_MKOCTFILE_DL_LDFLAGS }, { false, "OCTAVE_LINK_DEPS", OCTAVE_CONF_OCTAVE_LINK_DEPS }, { false, "OCTAVE_LINK_OPTS", OCTAVE_CONF_OCTAVE_LINK_OPTS },
--- a/src/utils.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/utils.cc Sat Jul 28 12:06:34 2012 -0400 @@ -470,7 +470,7 @@ if (fs.exists ()) retval = name; } - else if (len > 2 && name [len - 2] == '.' && name [len - 1] == 'm') + else if (len > 2 && name[len - 2] == '.' && name[len - 1] == 'm') retval = load_path::find_fcn_file (name.substr (0, len-2)); else { @@ -527,8 +527,8 @@ if (fs.exists ()) retval = name; } - else if (len > 4 && name [len - 4] == '.' && name [len - 3] == 'o' - && name [len - 2] == 'c' && name [len - 1] == 't') + else if (len > 4 && name[len - 4] == '.' && name[len - 3] == 'o' + && name[len - 2] == 'c' && name[len - 1] == 't') retval = load_path::find_oct_file (name.substr (0, len-4)); else retval = load_path::find_oct_file (name); @@ -556,8 +556,8 @@ if (fs.exists ()) retval = name; } - else if (len > 4 && name [len - 4] == '.' && name [len - 3] == 'm' - && name [len - 2] == 'e' && name [len - 1] == 'x') + else if (len > 4 && name[len - 4] == '.' && name[len - 3] == 'm' + && name[len - 2] == 'e' && name[len - 1] == 'x') retval = load_path::find_mex_file (name.substr (0, len-4)); else retval = load_path::find_mex_file (name);
--- a/src/variables.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/variables.cc Sat Jul 28 12:06:34 2012 -0400 @@ -548,6 +548,7 @@ @item \"dir\"\n\ Check only for directories.\n\ @end table\n\ +\n\ @seealso{file_in_loadpath}\n\ @end deftypefn") { @@ -1558,7 +1559,7 @@ error ("whos: -file argument must be followed by a file name"); else { - std::string nm = argv [i + 1]; + std::string nm = argv[i + 1]; unwind_protect frame; @@ -2324,6 +2325,7 @@ The arguments are treated as regular expressions as any variables that\n\ match will be cleared.\n\ @end table\n\ +\n\ With the exception of @code{exclusive}, all long options can be used\n\ without the dash as well.\n\ @end deftypefn")
--- a/src/zfstream.cc Sat Jul 28 15:17:57 2012 +0200 +++ b/src/zfstream.cc Sat Jul 28 12:06:34 2012 -0400 @@ -403,7 +403,7 @@ if (buffer_size > 0) { // Allocate internal buffer - buffer = new char_type[buffer_size]; + buffer = new char_type [buffer_size]; // Get area starts empty and will be expanded by underflow as need arises this->setg (buffer, buffer, buffer); // Setup entire internal buffer as put area. @@ -416,7 +416,7 @@ { // Even in "unbuffered" case, (small?) get buffer is still required buffer_size = SMALLBUFSIZE; - buffer = new char_type[buffer_size]; + buffer = new char_type [buffer_size]; this->setg (buffer, buffer, buffer); // "Unbuffered" means no put buffer this->setp (0, 0);