#! /bin/sh # # To apply this patch, cd to the top level Octave source directory and # run this file through /bin/sh. It will first remove any files that # have been deleted from the source distribution since the last # release and then update the sources with patch(1). # # Diffs for updating *.ps, *.dvi, *.info*, and *.html files are not # included because they can be recreated from the Texinfo files using # TeX, makeinfo, or texi2html. # # Diffs for updating parse.cc and y.tab.h are not included because # they can be recreated from the file parse.y using bison. # # Diffs for updating lex.cc are not included because it can be # recreated from lex.l using flex. # # John W. Eaton # jwe@bevo.che.wisc.edu # University of Wisconsin-Madison # Department of Chemical Engineering if test -f src/octave.cc ; then true else echo '***********************************************************' 1>&2 echo 'You must run this script in the top-level octave directory!' 1>&2 echo '***********************************************************' 1>&2 exit 1 fi ### ### Special commands should go here. ### echo 'patching existing files' patch -p1 << \PATCH_EOF diff -cNr octave-2.9.15/ChangeLog octave-2.9.16/ChangeLog *** octave-2.9.15/ChangeLog Fri Oct 12 17:27:11 2007 --- octave-2.9.16/ChangeLog Wed Oct 31 16:35:10 2007 *************** *** 1,3 **** --- 1,61 ---- + 2007-10-31 John W. Eaton + + * README.binary-dist: Delete. + + * README.MachTen: Delete. + * octMakefile.in (DISTFILES): Remove it from the list. + + 2007-10-30 David Bateman + + * examples/addtwomatrices.cc, examples/celldemo.cc, + examples/firstmexdemo.c, examples/fortdemo.cc, examples/fortsub.f, + examples/funcdemo.cc, examples/globaldemo.cc, + examples/helloworld.cc, examples/mycell.c, examples/myfeval.c, + examples/myfunc.c, examples/mypow2.c, examples/mysparse.c, + examples/mystring.c, examples/mystruct.c, examples/paramdemo.cc, + examples/stringdemo.cc, examples/structdemo.cc, + examples/unwinddemo.cc: Doc fixes for small book format. + + 2007-10-26 Michael Goffioul + + * Makeconf.in: Remove UNSETCOMSPEC trick. + + 2007-10-25 John W. Eaton + + * configure.in (AH_BOTTOM): Define OCTAVE_EMPTY_CPP_ARG here. + + 2007-10-24 John W. Eaton + + * octMakefile.in (maintainer-clean distclean): No need to delete + Makefrag.f77 and Makerules.f77. + * Makeconf.in: Include rules for making .o files from .f files + instead of substituting @f77_rules_frag@. + * configure.in): Delete handling of --with-f2c and --with-f77 + options. No need to call OCTAVE_CHECK_EXCLUSIVE_WITH_OPTIONS. + Delete all special cases for f2c. + * aclocal.m4 (OCTAVE_CHECK_EXCLUSIVE_WITH_OPTIONS): Delete macro. + + * FLEX.patch: Delete obsolete file. + * octMakefile.in (DISTFILES): Remove it from the list. + + * acx_blas.m4: Use "-Wl,-framework -Wl,vecLib" instead of + just "-framework vecLib" in test for Mac OS X test. + + * configure.in, aclocal.m4: Avoid AC_TRY_EVAL. + + * aclocal.m4 (OCTAVE_STRPTIME_BROKEN): New macro. + * configure.in: Use it. + + 2007-10-23 John W. Eaton + + * configure.in: When checking for -lf2c, set F2CLIBS instad of + FLIBS, then set FLIBS to $F2CLIBS just before printing the summary. + Check for BLAS library calling convention compatibility. + + 2007-10-17 John W. Eaton + + * configure.in: Delete checks for METIS. + 2007-10-12 John W. Eaton * mk-opts.pl (parse_input): Allow comment lines beginning with #. diff -cNr octave-2.9.15/FLEX.patch octave-2.9.16/FLEX.patch *** octave-2.9.15/FLEX.patch Thu Aug 19 17:13:18 1999 --- octave-2.9.16/FLEX.patch Wed Dec 31 19:00:00 1969 *************** *** 1,16 **** - *** flex.skl~ Tue Sep 10 18:58:54 1996 - --- flex.skl Tue Nov 24 23:10:34 1998 - *************** - *** 1179,1185 **** - --- 1179,1189 ---- - %- - #ifndef YY_ALWAYS_INTERACTIVE - #ifndef YY_NEVER_INTERACTIVE - + #ifdef __cplusplus - + extern "C" int isatty YY_PROTO(( int )); - + #else - extern int isatty YY_PROTO(( int )); - + #endif - #endif - #endif - --- 0 ---- diff -cNr octave-2.9.15/INSTALL.OCTAVE octave-2.9.16/INSTALL.OCTAVE *** octave-2.9.15/INSTALL.OCTAVE Sat Oct 13 11:12:40 2007 --- octave-2.9.16/INSTALL.OCTAVE Wed Oct 31 18:10:58 2007 *************** *** 24,74 **** `--srcdir=DIR' Look for Octave sources in the directory DIR. ! `--with-f2c' ! Use `f2c' even if a Fortran compiler is available. ! ! `--with-f77' ! Use `f77' to compile Fortran code. You may also specify the ! name of the compiler to use as an optional argument. For ! example, `--with-f77=g77' sets the name of the Fortran ! compiler to `g77'. `--enable-shared' ! Create shared libraries. If you are planning to use ! `--enable-lite-kernel' or the dynamic loading features, you ! will probably want to use this option. It will make your ! `.oct' files much smaller and on some systems it may be ! necessary to build shared libraries in order to use ! dynamically linked functions. You may also want to build a shared version of `libstdc++', ! if your system doesn't already have one. Note that a patch ! is needed to build shared versions of version 2.7.2 of ! `libstdc++' on the HP-PA architecture. You can find the ! patch at ! `ftp://ftp.cygnus.com/pub/g++/libg++-2.7.2-hppa-gcc-fix'. `--enable-dl' Use `dlopen' and friends to make Octave capable of dynamically ! linking externally compiled functions. This only works on systems that actually have these functions. If you plan on using this feature, you should probably also use `--enable-shared' to reduce the size of your `.oct' files. - `--enable-shl' - Use `shl_load' and friends to make Octave capable of - dynamically linking externally compiled functions. This only - works on systems that actually have these functions (only - HP-UX systems). If you plan on using this feature, you - should probably also use `--enable-shared' to reduce the size - of your `.oct' files. - - `--enable-lite-kernel' - Compile smaller kernel. This currently requires the dynamic - linking functions `dlopen' or `shl_load' and friends so that - Octave can load functions at run time that are not loaded at - compile time. - `--without-blas' Compile and use the generic BLAS and LAPACK versions included with Octave. By default, configure first looks for BLAS and --- 24,65 ---- `--srcdir=DIR' Look for Octave sources in the directory DIR. ! `--enable-bounds-check' ! Enable bounds checking for indexing operators in the internal ! array classes. This option is primarily used for debugging ! Octave. Building Octave with this option has a negative ! impact on performace and is not recommended for general use. ! ! `--enable-64' ! This is an *experimental* option to enable Octave to use ! 64-bit integers for array dimensions and indexing on 64-bit ! platforms. You probably don't want to use this option unless ! you know what you are doing. ! ! If you use `--enable-64', you must ensure that your Fortran ! compiler generates code with 8 byte signed `INTEGER' values, ! and that your BLAS and LAPACK libraries are compiled to use 8 ! byte signed integers for array dimensions and indexing. `--enable-shared' ! Create shared libraries (this is the default). If you are ! planning to use the dynamic loading features, you will ! probably want to use this option. It will make your `.oct' ! files much smaller and on some systems it may be necessary to ! build shared libraries in order to use dynamically linked ! functions. You may also want to build a shared version of `libstdc++', ! if your system doesn't already have one. `--enable-dl' Use `dlopen' and friends to make Octave capable of dynamically ! linking externally compiled functions (this is the default if ! `--enable-shared' is specified). This option only works on systems that actually have these functions. If you plan on using this feature, you should probably also use `--enable-shared' to reduce the size of your `.oct' files. `--without-blas' Compile and use the generic BLAS and LAPACK versions included with Octave. By default, configure first looks for BLAS and *************** *** 81,86 **** --- 72,118 ---- `--with-blas=lib' to specify a particular BLAS library `-llib' that configure doesn't check for automatically. + `--without-ccolamd' + Don't use CCOLAMD, disable some sparse matrix functionality. + + `--without-colamd' + Don't use COLAMD, disable some sparse matrix functionality. + + `--without-curl' + Don't use the cURL, disable the `urlread' and `urlwrite' + functions. + + `--without-cxsparse' + Don't use CXSPARSE, disable some sparse matrix functionality. + + `--without-umfpack' + Don't use UMFPACK, disable some sparse matrix functionality. + + `--without-fftw' + Use the included fftpack library instead of the FFTW library. + + `--without-glpk' + Don't use the GLPK library for linear programming. + + `--without-hdf5' + Don't use the HDF5 library for reading and writing HDF5 files. + + `--without-zlib' + Don't use the zlib library, disable data file compression and + support for recent MAT file formats. + + `--without-lapack' + Compile and use the generic BLAS and LAPACK versions included + with Octave. By default, configure first looks for BLAS and + LAPACK matrix libraries on your system, including optimized + BLAS implementations such as the free ATLAS 3.0, as well as + vendor-tuned libraries. (The use of an optimized BLAS will + generally result in several-times faster matrix operations.) + Only use this option if your system has BLAS/LAPACK libraries + that cause problems for some reason. You can also use + `--with-blas=lib' to specify a particular BLAS library + `-llib' that configure doesn't check for automatically. + `--help' Print a summary of the options recognized by the configure script. *************** *** 102,117 **** `gnu' in gnuplot is a coincidence--it is not related to the GNU project or the FSF in any but the most peripheral sense. ! To compile Octave, you will need a recent version of GNU Make. You ! will also need `g++' 2.7.2 or later. Version 2.8.0 or `egcs' ! 1.0.x should work. Later versions may work, but C++ is still ! evolving, so don't be too surprised if you run into some trouble. ! ! It is no longer necessary to have `libg++', but you do need to have ! the GNU implementation of `libstdc++'. If you are using `g++' ! 2.7.2, `libstdc++' is distributed along with `libg++', but for ! later versions, `libstdc++' is distributed separately. For ! `egcs', `libstdc++' is included with the compiler distribution. If you plan to modify the parser you will also need GNU `bison' and `flex'. If you modify the documentation, you will need GNU --- 134,145 ---- `gnu' in gnuplot is a coincidence--it is not related to the GNU project or the FSF in any but the most peripheral sense. ! To compile Octave, you will need a recent version of GNU Make. ! You will also need a recent version of `g++' or other ANSI C++ ! compiler. You will also need a Fortran 77 compiler or `f2c'. If ! you use `f2c', you will need a script like `fort77' that works ! like a normal Fortran compiler by combining `f2c' with your C ! compiler in a single script. If you plan to modify the parser you will also need GNU `bison' and `flex'. If you modify the documentation, you will need GNU *************** *** 124,141 **** of sites that mirror the software on `ftp.gnu.org' is available by anonymous ftp from `ftp://ftp.gnu.org/pub/gnu/GNUinfo/FTP'. ! If you don't have a Fortran compiler, or if your Fortran compiler ! doesn't work like the traditional Unix f77, you will need to have ! the Fortran to C translator `f2c'. You can get `f2c' from any ! number of anonymous ftp archives. The most recent version of `f2c' ! is always available from `netlib.att.com'. ! ! On an otherwise idle Pentium 133 running Linux, it will take ! somewhere between 1-1/2 to 3 hours to compile everything, ! depending on whether you are building shared libraries. You will ! need about 100 megabytes of disk storage to work with ! (considerably less if you don't compile with debugging symbols). ! To do that, use the command make CFLAGS=-O CXXFLAGS=-O LDFLAGS= --- 152,160 ---- of sites that mirror the software on `ftp.gnu.org' is available by anonymous ftp from `ftp://ftp.gnu.org/pub/gnu/GNUinfo/FTP'. ! You will need about 925 megabytes of disk storage to work with when ! building Octave from source (considerably less if you don't ! compile with debugging symbols). To do that, use the command make CFLAGS=-O CXXFLAGS=-O LDFLAGS= *************** *** 239,245 **** or ! warning: ANSI C++ prohibits conversion from `(int)' to `(...)' while compiling `sighandlers.cc', you may need to edit some files in the `gcc' include subdirectory to add proper prototypes for --- 258,265 ---- or ! warning: ANSI C++ prohibits conversion from `(int)' ! to `(...)' while compiling `sighandlers.cc', you may need to edit some files in the `gcc' include subdirectory to add proper prototypes for *************** *** 296,303 **** * On NeXT systems, if you get errors like this: ! /usr/tmp/cc007458.s:unknown:Undefined local symbol LBB7656 ! /usr/tmp/cc007458.s:unknown:Undefined local symbol LBE7656 when compiling `Array.cc' and `Matrix.cc', try recompiling these files without `-g'. --- 316,325 ---- * On NeXT systems, if you get errors like this: ! /usr/tmp/cc007458.s:unknown:Undefined local ! symbol LBB7656 ! /usr/tmp/cc007458.s:unknown:Undefined local ! symbol LBE7656 when compiling `Array.cc' and `Matrix.cc', try recompiling these files without `-g'. diff -cNr octave-2.9.15/Makeconf.in octave-2.9.16/Makeconf.in *** octave-2.9.15/Makeconf.in Fri Oct 12 17:27:12 2007 --- octave-2.9.16/Makeconf.in Fri Oct 26 14:22:04 2007 *************** *** 75,88 **** TEXI2DVI = @TEXI2DVI@ TEXI2PDF = @TEXI2PDF@ - # Both texi2dvi and texi2pdf check COMSPEC to decide what path - # separator to use. We build Octave with a Unixy shell, even on - # Windows sytems, so we need to unset COMSPEC when invoking these - # scripts. Used in the doc/*/Makefiles. - ifneq ($(COMSPEC),) - UNSETCOMSPEC = COMSPEC= - endif - GHOSTSCRIPT = @GHOSTSCRIPT@ DEFAULT_PAGER = @DEFAULT_PAGER@ --- 75,80 ---- *************** *** 370,396 **** # The following pattern rules and the substitution functions require # GNU make. If you don't have it, get it! - # Rules for making object files from Fortran source. - # - # If we are using f2c there will be a command for the `%.c : %.f' - # pattern and no command for the `%.o : %.f' pattern, so that make - # will not invoke the fortran compiler by mistake. - # - # If we are not using f2c, it should be ok to have an empty rule for - # the pattern `%.c : %.f', but we don't want to replace make's default - # rule for making object from Fortran source files, so there should be - # no pattern or command for that. - - @f77_rules_frag@ - # How to make .o files: %.o : %.c $(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) $< -o $@ %.o : %.cc $(CXX) -c $(CPPFLAGS) $(ALL_CXXFLAGS) $< -o $@ pic/%.o : %.c $(CC) -c $(CPPFLAGS) $(CPICFLAG) $(ALL_CFLAGS) $< -o $@ --- 362,381 ---- # The following pattern rules and the substitution functions require # GNU make. If you don't have it, get it! # How to make .o files: + %.o : %.f + $(FC) -c $(ALL_FFLAGS) -o $@ $< + %.o : %.c $(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) $< -o $@ %.o : %.cc $(CXX) -c $(CPPFLAGS) $(ALL_CXXFLAGS) $< -o $@ + pic/%.o : %.f + $(FC) -c $(FPICFLAG) $(ALL_FFLAGS) $< -o $@ + pic/%.o : %.c $(CC) -c $(CPPFLAGS) $(CPICFLAG) $(ALL_CFLAGS) $< -o $@ diff -cNr octave-2.9.15/NEWS octave-2.9.16/NEWS *** octave-2.9.15/NEWS Mon Aug 27 15:27:39 2007 --- octave-2.9.16/NEWS Fri Oct 19 12:05:48 2007 *************** *** 6,12 **** Graphics (tm): + You can make a subplot and then use the print function to ! generate file with the plot. + RGB line colors are supported if you use gnuplot 4.2. Octave can still use gnuplot 4.0, but there is no way to set arbitrary --- 6,12 ---- Graphics (tm): + You can make a subplot and then use the print function to ! generate a file with the plot. + RGB line colors are supported if you use gnuplot 4.2. Octave can still use gnuplot 4.0, but there is no way to set arbitrary *************** *** 34,43 **** this allows you to plot additional 2-d data on top of a contour plot. ! + It is no longer possible to mix Matlab-style plot commands with ! the old (and now considered obsolete) style of plot commands ! (__gnuplot_set__, etc.). You can do one or the other, but not ! both for the same plot. + Plot property values are not extensively checked. Specifying invalid property values may produce unpredictible results. --- 34,51 ---- this allows you to plot additional 2-d data on top of a contour plot. ! + The following plot commands are now considered obsolete and will ! be removed from a future version of Octave: ! ! __gnuplot_set__ ! __gnuplot_show__ ! __gnuplot_plot__ ! __gnuplot_splot__ ! __gnuplot_replot__ ! ! Additionally, these functions no longer have any effect on plots ! created with the Matlab-style plot commands (plot, line, mesh, ! semilogx, etc.). + Plot property values are not extensively checked. Specifying invalid property values may produce unpredictible results. *************** *** 47,53 **** cluttering /tmp with data files, it is no longer possible to use the mouse to zoom in on plots. This is a limitation of gnuplot, which is unable to zoom when the data it plots is not stored in ! a file. ** The way Octave handles search paths has changed. Instead of setting the built-in variable LOADPATH, you must use addpath, --- 55,66 ---- cluttering /tmp with data files, it is no longer possible to use the mouse to zoom in on plots. This is a limitation of gnuplot, which is unable to zoom when the data it plots is not stored in ! a file. Some work has been done to fix this problem in newer ! versions of gnuplot (> 4.2.2). See for example, this thread ! ! http://www.nabble.com/zooming-of-inline-data-tf4357017.html#a12416496 ! ! on the gnuplot development list. ** The way Octave handles search paths has changed. Instead of setting the built-in variable LOADPATH, you must use addpath, diff -cNr octave-2.9.15/PROJECTS octave-2.9.16/PROJECTS *** octave-2.9.15/PROJECTS Wed Sep 26 15:56:54 2007 --- octave-2.9.16/PROJECTS Fri Oct 26 11:52:57 2007 *************** *** 66,72 **** * Consider making the behavior of the / and \ operators for non-square systems compatible with Matlab. Currently, they return ! the minimum norm solution from DGELSY, which behaves differently. --------------- Sparse Matrices: --- 66,72 ---- * Consider making the behavior of the / and \ operators for non-square systems compatible with Matlab. Currently, they return ! the minimum norm solution from DGELSD, which behaves differently. --------------- Sparse Matrices: diff -cNr octave-2.9.15/README octave-2.9.16/README *** octave-2.9.15/README Fri Oct 12 02:40:56 2007 --- octave-2.9.16/README Wed Oct 31 16:35:10 2007 *************** *** 2,9 **** Copyright (C) 1996, 1997, 1998, 2002, 2007 John W. Eaton - Last updated: Thu, 11 Oct 2007 19:26:42 EDT - Overview -------- --- 2,7 ---- *************** *** 34,56 **** Installation and Bugs --------------------- ! Octave requires approximately 125MB of disk storage to unpack and compile from source (significantly less if you don't compile with ! debugging symbols or create shared libraries). Once installed, Octave ! requires approximately 65MB of disk space (again, considerably less if ! you don't build shared libraries or the binaries and libraries do not ! include debugging symbols). To compile Octave, you will need a recent version of GNU Make. You ! will also need g++ 2.7.2 or later. Version 2.8.0 or egcs 1.0.x should ! work. Later versions may work, but C++ is still evolving, so don't be ! too surprised if you run into some trouble. ! ! It is no longer necessary to have libg++, but you do need to have the ! GNU implementation of libstdc++. If you are using g++ 2.7.2, ! libstdc++ is distributed along with libg++, but for later versions, ! libstdc++ is distributed separately. For egcs, libstdc++ is included ! with the compiler distribution. YOU MUST HAVE GNU MAKE TO COMPILE OCTAVE. Octave's Makefiles use features of GNU Make that are not present in other versions of make. --- 32,49 ---- Installation and Bugs --------------------- ! Octave requires approximately 925MB of disk storage to unpack and compile from source (significantly less if you don't compile with ! debugging symbols). Once installed, Octave requires approximately ! 350MB of disk space (again, considerably less if you don't build ! shared libraries or the binaries and libraries do not include ! debugging symbols). To compile Octave, you will need a recent version of GNU Make. You ! will also need a recent version of g++ or other ANSI C++ compiler. ! You will also need a Fortran 77 compiler or f2c. If you use f2c, you ! will need a script like fort77 that works like a normal Fortran ! compiler by combining f2c with your C compiler in a single script. YOU MUST HAVE GNU MAKE TO COMPILE OCTAVE. Octave's Makefiles use features of GNU Make that are not present in other versions of make. *************** *** 66,113 **** Documentation ------------- ! Octave's manual has been revised for version 2.0, but it is lagging a bit behind the development of the software. In particular, there is ! currently no complete documentation of the C++ class libraries or the ! support for dynamic linking and user-defined data types. If you ! notice ommissions or inconsistencies, please report them as bugs to ! bug@octave.org. Specific suggestions for ways to improve Octave and ! its documentation are always welcome. ! ! Implementation ! -------------- ! ! Octave is being developed with the Free Software Foundation's make, ! bison (a replacement for YACC), flex (a replacement for lex), gcc/g++, ! and libstdc++ on an Intel Pentium II system running Linux/GNU. It ! should be possible to install it on any machine that runs GCC/G++. It ! may also be possible to install it using other implementations of ! these tools, but it will most certainly require much more work. Do ! yourself a favor and get the GNU development tools, either via ! anonymous ftp from ftp.gnu.org or by writing the Free Software ! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ! 02110-1301, USA. ! ! The underlying numerical solvers are currently standard Fortran ones ! like Lapack, Linpack, Odepack, the Blas, etc., packaged in a library ! of C++ classes (see the files in the libcruft and liboctave ! subdirectories). If possible, the Fortran subroutines are compiled ! with the system's Fortran compiler, and called directly from the C++ ! functions. If that's not possible, they are translated with f2c and ! compiled with a C compiler. Better performance is usually achieved if ! the intermediate translation to C is avoided. ! ! The library of C++ classes may also be useful by itself. Additional Information ---------------------- Up to date information about Octave is available on the WWW at the ! URL http://www.octave.org, including archives of the help-octave, ! bug-octave, and octave-sources mailing lists. - -- John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical Engineering --- 59,83 ---- Documentation ------------- ! Octave's manual has been revised for version 3.0, but it is lagging a bit behind the development of the software. In particular, there is ! currently no complete documentation of the C++ class libraries. If ! you notice ommissions or inconsistencies, please report them as bugs ! to bug@octave.org. Specific suggestions for ways to improve Octave ! and its documentation are always welcome. Reports with patches are ! even more welcome. Additional Information ---------------------- Up to date information about Octave is available on the WWW at the ! URL http://www.octave.org, including archives of the help, bug, and ! maintainers mailing lists. ! John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical & Biological Engineering ! ! Last updated: Thu, 11 Oct 2007 19:26:42 EDT diff -cNr octave-2.9.15/README.Cygwin octave-2.9.16/README.Cygwin *** octave-2.9.15/README.Cygwin Thu Nov 2 11:54:27 2006 --- octave-2.9.16/README.Cygwin Wed Oct 31 16:35:10 2007 *************** *** 1,73 **** ! Octave is now part of the normal net distribution of Cygwin, available ! from http://www.cygwin.com. To install the Cygwin package of Octave: ! ! 1. Use your favorite browser to view the page http://www.cygwin.com ! ! 2. Click on the "Install or update now" link. ! ! 3. A dialog should appear with the option to run the setup program ! from its current location or save it to disk. Either will work, ! but I usually choose to save the setup program to disk so that it ! is possible to run it later to update the installation without ! having to go back to the web page using a browser. ! ! 4. Run the setup program. ! ! 5. Choose "Install from Internet". ! ! 6. Select a root install directory. You may choose any directory, but ! it needs to have enough space for Octave and all the related ! tools. Sorry, I don't know how much space that is at present. ! ! 7. Select a local package directory. This is a directory that the ! setup program will use to temporarily store package files before ! installing them. It should have plenty of space (probably 70MB ! or more). You may delete this directory once the installation is ! complete. ! ! 8. Select your Internet Connection. Probably "Direct Connection" is ! OK unless you are behind a firewall of some kind that limits your ! access to the Internet. ! ! 9. Choose a download site. One that is "near" you on the net is ! probably best. ! ! 10. Select packages. Choose Octave from the Math category and gnuplot ! from the graphics category. ! ! 11. Once the download and file installation is done, click Finish. I ! usually choose to create an icon on the desktop and put an icon in ! the start menu. After you click finish, a series of scripts will ! run, displaying some output in a terminal window. It will take a ! few minutes. ! ! 12. To run Octave, start Cygwin. This will bring up a terminal ! window. In that window type ! ! startx ! ! (a running X server is needed for plotting). Running startx will ! bring up a new window. In that window, type ! ! octave ! ! That should present you with an Octave prompt. Type ! ! sombrero (41) ! ! at this prompt and a new window with the sombrero plot should appear. ! ! 13. IMPORTANT: to build .oct files (dynamically loaded functions) for ! Octave, you will also need the octave-headers package. Currently, ! due to some bugs in the most recent version of the C++ compiler ! and libraries for Cygwin, you will also need gcc and g++ 3.3 ! rather than 3.4. You can use the setup.exe installer to select ! and install the older version. John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical Engineering ! Tue Apr 18 15:22:59 2006 --- 1,21 ---- ! An obsolete version of Octave (2.1.73) is part of the normal net ! distribution of Cygwin, available from http://www.cygwin.com. Check ! the package list in Cygwin's setup.exe installer if you would like to ! try using it. However, 2.1.73 is unsupported and we STRONGLY ! recommended that you use a more recent version of Octave. ! ! It should be possible to build Octave on Windows systems with Cygwin, ! but at the time of this writing, there are some performance problems ! related to the way C++ exception handling is implemented with the ! default Cygwin compiler. This is a known problem with a long history. ! If you would like to see this problem corrected, please search the ! Cygwin mailing lists for threads related to "sjlj exception handling" ! (or similar). John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical & Biological Engineering ! Last updated: Wed, 31 Oct 2007 16:21:43 EDT diff -cNr octave-2.9.15/README.Linux octave-2.9.16/README.Linux *** octave-2.9.15/README.Linux Fri Oct 1 14:12:10 2004 --- octave-2.9.16/README.Linux Wed Oct 31 16:35:10 2007 *************** *** 1,88 **** ! NOTE: This file was originally written several years ago, when many ! people were complaining that Octave would not work for them on Linux ! systems. Generally, the problems were not actually bugs in Octave. ! More recently, the compilers are better, most distributions are more ! complete, and it seems harder to install incompatible sets of ! libraries or header files (but some people still manage to do it). ! Since July 1996, most work on Octave has been done using a Linux ! system, and a number of people who regularly test Octave snapshot ! releases also primarily use Linux systems. Because of this, I believe ! Octave should run reasonably well on most current Linux systems. ! However, there have been some problems in the past, usually the result ! of improper installation of compilers or libraries. Sometimes the ! problems have happened because of a botched upgrade or even a buggy ! Linux distribution. - If you can, you should probably install Octave using one of the Debian - or RPM packages for Octave that are available with the major Linux - distributions. For example, Dirk Eddelbuettel - maintains the Debian Octave package and usually has them ready within - a day or so of new Octave releases. They are available via the WWW at - http://www.debian.org/distrib/packages. - - If for some reason you can't (or choose not to) install Octave from - one of the binary distributions or by using one of the Debian or RPM - packages and something goes wrong, please check the following list to - see if your problem is already well known before reporting a bug. - - Octave compiles, but it won't run - --------------------------------- - - If you can compile Octave, but it crashes with a segmentation fault - right away, you probably have incompatible versions of libc and - libstdc++ installed, or you have a version of the dynamic loader, - ld.so, that is incompatible with your versions of the libraries, or - both. - - Octave won't even compile - ------------------------- - - If you can't compile Octave, you should first check to see that your - compiler and header files are properly installed. Do you have - multiple versions of the g++ include files on your system? Are you - sure that your copy of g++ is finding the right set? You can find out - by compiling a simple C++ program with -v: - - bash$ cat foo.cc - #include - int main (void) { cerr << "yo\n"; return 0; } - - bash$ g++ -v foo.cc - gcc -v foo.cc -lstdc++ -lm - Reading specs from /usr/lib/gcc-lib/i486-linux/2.7.2/specs - gcc version 2.7.2 - /usr/lib/gcc-lib/i486-linux/2.7.2/cpp -lang-c++ -v -undef ... - #include "..." search starts here: - #include <...> search starts here: - /usr/lib/g++-include - /usr/local/include - /usr/i486-linux/include - /usr/lib/gcc-lib/i486-linux/2.7.2/include - /usr/include - End of search list. - ... - - If the location of the correct set of include files is not listed in - the search path, then you might be able to fix that with a symbolic - link. However, if your version of libstdc++ was not compiled with your - current version of gcc, you are likely to run into more trouble. - - I/O in dynamically loaded .oct files doesn't work - ------------------------------------------------- - - If Octave prints things like `%.-1e' instead of numbers when you use a - dynamically linked .oct file, you probably need to create shared - versions of the Octave libraries. To do that, configure Octave with - --enable-shared, recompile, and reinstall. - - - If you have comments or suggestions for this document, please contact - bug@octave.org. John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical Engineering ! Fri Oct 1 13:04:36 2004 --- 1,12 ---- ! There are binary packages for Debian, Fedora, and other GNU/Linux ! distributions. ! Octave should build cleanly from source on most GNU/Linux systems. John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical & Biological Engineering ! Last updated: Wed, 31 Oct 2007 16:22:26 EDT diff -cNr octave-2.9.15/README.MachTen octave-2.9.16/README.MachTen *** octave-2.9.15/README.MachTen Fri Nov 15 15:38:11 2002 --- octave-2.9.16/README.MachTen Wed Dec 31 19:00:00 1969 *************** *** 1,185 **** - The information in this file is from A. Scottedward Hodel - . - - * 11/15/2002: Power MachTen is no longer supported by Tenon Intersystems - * since Mac OS X permits running Octave directly on its BSD-based OS. - * See http://fink.sourceforge.net for directions on installation of Octave - * on Macintosh. - - I've installed and run Octave 2.0.12 on Power MachTen 4.1. I've - also installed Octave-2.1.14 on Power MachTen 4.1.1 (the process is slightly - different). This note contains instructions on how to port octave to MachTen - 4.1/4.1.1. - - Many thanks to Tenon Intersystems support for their help in porting to - Machten 4.1.1. - - Contents: - (1) Definitions - (2) Future work - (3) Instructions for installation of Octave 2.0.12 on MachTen 4.1. - (4) Instructions for installation of Octave 2.1.14 on MachTen 4.1.1. - - (1) Definitions: - ============ - Power MachTen: Unix that runs simultaneously with MacOS on Mac computers. - see http://tenon.com for more information. - - Octave: a Matlab-like programming language that is freely distributable - under the terms of the gnu copyright rules. Octave is NOT - (and will not) be a MATLAB(tm) clone; however, the functionality - of the program is similar. - - see: http://bevo.che.wisc.edu/octave for more information. - a control systems toolbox is available at - ftp://ftp.eng.auburn.edu/pub/hodel/OCST* - - (2) Future work: - ============= - Dynamic linking is apparently not yet supported, so .oct files cannot be used - (yet) in Power MachTen. - - (3) To install Octave on MachTen 4.1: - ============= - Short instructions: MachTen automatically defines __MACHTEN_PPC__ on - power MachTen. The octave configure script sets most everything up properly. - Here's a few details that also need done: - - (a) Put libncurses into the Tenon Application Library Folder - (b) Replace the MT /usr/bin/sed with gnu sed (I used 2-0.5). - (c) : Is fixed in MachTen 4.1.1 - (d) Set virtual memory to a huge number (I used 200Mb) - (f) make all; it will fail on toplev.cc due to a problem with src/oct-conf.h - (g) Fix src/oct-conf.h and make all again. - (g) make install - - Here are the details for the above items: - (a) Be sure that libncurses is in the Tenon Application Library in - the Extensions folder: - - (i) use resedit. - (ii) Open the libncurses file in folder: - Extensions/Tenon Applications Library/disabled - (iii) Open the cfrag resource. Scroll down a bit and you will find the - string libcurses. Change it to libncurses. Save. - (iv) Change (File Menu/File Information) the file creator to MUMM. Save. - (v) now move libncurses out of the disabled folder to - Extensions/Tenon Applications Library - (vi) Reboot. - - (b) Replace the MT /usr/bin/sed with gnu sed (I used 2-0.5). - This fixes a problem with the kpathsea/klibtool script. - - (c) Login as root and apply the following patch to /usr/include/sys/signal.h: - Otherwise src/sighandlers.cc will not compile properly. (The change - is consistent with headers on our sun network as well.) - - *** signal.h.old Thu May 7 13:16:11 1998 - --- signal.h Thu May 7 13:34:27 1998 - *************** - *** 253,260 **** - /* - * Signal vector "template" used in sigaction call. - */ - ! #struct sigaction { - void (*sa_handler)(); /* signal handler */ - sigset_t sa_mask; /* signal mask to apply */ - int sa_flags; /* see signal options below */ - }; - --- 253,264 ---- - /* - * Signal vector "template" used in sigaction call. - */ - ! struct sigaction { - ! #ifdef __cplusplus - ! void (*sa_handler)(int); /* signal handler */ - ! #else - void (*sa_handler)(); /* signal handler */ - + #endif - sigset_t sa_mask; /* signal mask to apply */ - int sa_flags; /* see signal options below */ - }; - - - (d) Set virtual memory to a huge number (I used 120Mb). Otherwise compiles - will fail. - - (e) (cd src ; make oct-conf.h) - - (f) Fix src/oct-conf.h - - You'll need to change the line - - #define DEFS "-DOCTAVE_SOURCE=1 -DSEPCHAR=':' -DSEPCHAR_STR=":" - to - #define DEFS "-DOCTAVE_SOURCE=1 -DSEPCHAR=':' -DSEPCHAR_STR=\":\" - - It should have been done automatically (take a look at UGLY_DEFS in - the toplevel Makeconf), but for some reason it doesn't go. Failure to - edit oct-conf.h results in a compilation error in toplev.cc. - - (g) make all - (h) make install - - And that should do it. - - (4) To install Octave on MachTen 4.1.1: - ============= - Short instructions: MachTen automatically defines __MACHTEN_PPC__ on - power MachTen. The octave configure script sets most everything up properly. - Here's a few details that also need done: - - (a) libncurses, sed, and : are fixed in PowerMachTen 4.1.1 (but not in - 4.1) - (b) Power MachTen uses gcc-2.8.1, which requires more memory than the - version used in PowerMachTen 4.1. I set virtual memory to 200 Mb. - (c) From Tenon technical support: (Thanks!) - >I think that we have compiling Octave on MachTen. The problem results - >from the fact that the stack space on the f771 application is not set. - >This results in f771 running out of memory and corrupting the system - >process manager heap. To fix this, try: - > - >setstackspace 0x100000 /usr/lib/gcc-lib/powerpc-apple/machten4/2.8.1/f771 - - For some reason my system didn't follow the soft links to - /usr/macppc/lib/gcc-lib/powerpc-apple-machten4/2.8.1/f771. I was - able to do the command manually with the above path. - - (d) For increased speed in compiling and decreased disk space requirements, - you may also wish to omit the "-g" flag from compiler options: - in the configure script: - - search for machten (line 2651 in 0ctave-2.1.14). - - modify so that this section reads - powerpc-apple-machten*) - FFLAGS= - # remove -g to keep binary size down - CFLAGS=`echo ${CFLAGS} | sed '1,$s/-g//'` - CXXFLAGS=`echo ${CXXFLAGS} | sed '1,$s/-g//'` - LDFLAGS=`echo ${LDFLAGS} | sed '1,$s/-g//'` - ;; - - Also remove -g from: - LDFLAGS in readline/examples/Makefile.in - - (e) Run configure (use the --prefix flag if desired) - - (f) (cd src ; make oct-conf.h) - - (g) Fix src/oct-conf.h - - You'll need to change the line - - #define DEFS "-DOCTAVE_SOURCE=1 -DSEPCHAR=':' -DSEPCHAR_STR=":" - to - #define DEFS "-DOCTAVE_SOURCE=1 -DSEPCHAR=':' -DSEPCHAR_STR=\":\" - - It should have been done automatically (take a look at UGLY_DEFS in - the toplevel Makeconf), but for some reason it doesn't go. Failure to - edit oct-conf.h results in a compilation error in toplev.cc. - - (h) make all - - Be prepared to wait quite awhile. Most of the time is spent waiting - for individual ar commands to build the libraries. - - (i) make install --- 0 ---- diff -cNr octave-2.9.15/README.Windows octave-2.9.16/README.Windows *** octave-2.9.15/README.Windows Thu Nov 2 11:54:27 2006 --- octave-2.9.16/README.Windows Wed Oct 31 16:35:10 2007 *************** *** 3,5 **** --- 3,13 ---- See the file README.MSVC for instructions for compiling Octave with the MSVC compiler. + + + John W. Eaton + jwe@bevo.che.wisc.edu + University of Wisconsin-Madison + Department of Chemical & Biological Engineering + + Last updated: Wed, 31 Oct 2007 16:34:12 EDT diff -cNr octave-2.9.15/README.kpathsea octave-2.9.16/README.kpathsea *** octave-2.9.15/README.kpathsea Fri May 2 21:48:10 2003 --- octave-2.9.16/README.kpathsea Wed Oct 31 16:35:10 2007 *************** *** 163,165 **** --- 163,173 ---- Only filenames that are absolute are recorded, to preserve some semblance of privacy. + + + John W. Eaton + jwe@bevo.che.wisc.edu + University of Wisconsin-Madison + Department of Chemical & Biological Engineering + + Last updated: Wed, 31 Oct 2007 16:33:13 EDT diff -cNr octave-2.9.15/ROADMAP octave-2.9.16/ROADMAP *** octave-2.9.15/ROADMAP Fri Aug 10 16:14:19 2007 --- octave-2.9.16/ROADMAP Wed Oct 31 16:44:43 2007 *************** *** 70,73 **** John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical Engineering --- 70,75 ---- John W. Eaton jwe@bevo.che.wisc.edu University of Wisconsin-Madison ! Department of Chemical & Biological Engineering ! ! Last updated: Wed, 31 Oct 2007 16:44:04 EDT diff -cNr octave-2.9.15/THANKS octave-2.9.16/THANKS *** octave-2.9.15/THANKS Thu Jul 18 21:41:47 1996 --- octave-2.9.16/THANKS Wed Oct 31 17:03:48 2007 *************** *** 1,11 **** Special thanks to the following people and organizations for supporting the development of Octave: ! * Digital Equipment Corporation, for a one year grant as part of their External Research Program. * Sun Microsystems, Inc., for an Academic Equipment grant. * The University of Texas College of Engineering, for providing a Challenge for Excellence Research Supplement, and for providing an Academic Development Funds grant. --- 1,33 ---- Special thanks to the following people and organizations for supporting the development of Octave: ! * The United States Department of Energy, through grant number ! DE-FG02-04ER25635. ! ! * Ashok Krishnamurthy, David Hudak, Juan Carlos Chaves, and Stanley ! C. Ahalt of the Ohio Supercomputer Center. ! ! * The National Science Foundation, through grant numbers ! CTS-0105360, CTS-9708497, CTS-9311420, CTS-8957123, and ! CNS-0540147. ! ! * The industrial members of the Texas-Wisconsin Modeling and Control ! Consortium (TWMCC) http://www.che.utexas.edu/twmcc. ! ! * The Paul A. Elfers Endowed Chair in Chemical Engineering at the ! University of Wisconsin-Madison. ! ! * Digital Equipment Corporation, for an equipment grant as part of their External Research Program. * Sun Microsystems, Inc., for an Academic Equipment grant. + * International Business Machines, Inc., for providing equipment as + part of a grant to the University of Texas College of Engineering. + + * Texaco Chemical Company, for providing funding to continue the + development of this software. + * The University of Texas College of Engineering, for providing a Challenge for Excellence Research Supplement, and for providing an Academic Development Funds grant. *************** *** 13,22 **** * The State of Texas, for providing funding through the Texas Advanced Technology Program under Grant No. 003658-078. - * Texaco Chemical Company, for providing funding to continue the - development of this software. - * Noel Bell, Senior Engineer, Texaco Chemical Company, Austin Texas. ! * James B. Rawlings, Associate Professor, Department of Chemical ! Engineering, The University of Texas at Austin. --- 35,47 ---- * The State of Texas, for providing funding through the Texas Advanced Technology Program under Grant No. 003658-078. * Noel Bell, Senior Engineer, Texaco Chemical Company, Austin Texas. ! * John A. Turner, Group Leader, Continuum Dynamics (CCS-2), Los ! Alamos National Laboratory, for registering the octave.org domain ! name. ! ! * James B. Rawlings, Professor, University of Wisconsin-Madison, ! Department of Chemical and Biological Engineering. ! ! * Richard Stallman. diff -cNr octave-2.9.15/aclocal.m4 octave-2.9.16/aclocal.m4 *** octave-2.9.15/aclocal.m4 Fri Oct 12 17:27:12 2007 --- octave-2.9.16/aclocal.m4 Wed Oct 24 16:35:20 2007 *************** *** 45,63 **** AC_MSG_RESULT([defining $1 to be $$1]) AC_SUBST($1)]) dnl - dnl - dnl OCTAVE_CHECK_EXCLUSIVE_WITH_OPTIONS - AC_DEFUN(OCTAVE_CHECK_EXCLUSIVE_WITH_OPTIONS, - [if test "${with_$1+set}" = set; then - if test "${with_$2+set}" = set; then - if test "$with_$2" = no; then - true - else - $3 - fi - fi - fi]) - dnl dnl Check for ar. dnl AC_DEFUN(OCTAVE_PROG_AR, --- 45,50 ---- *************** *** 117,122 **** --- 104,136 ---- AC_LANG_POP(C++) ]) dnl + dnl Check for broken strptime + dnl + AC_DEFUN(OCTAVE_STRPTIME_BROKEN, + [AC_CACHE_CHECK([whether strptime is broken], + octave_cv_strptime_broken, + [AC_LANG_PUSH(C) + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #define _XOPEN_SOURCE + #if defined (HAVE_SYS_TYPES_H) + #include + #if defined (HAVE_UNISTD_H) + #include + #endif + #endif + #include + #include + ]], [[ + struct tm t; + char *q = strptime ("09/13", "%m/%d/%y", &t); + return q ? 1 : 0; + ]])], [octave_cv_strptime_broken=no], [octave_cv_strptime_broken=yes])]) + if test $octave_cv_strptime_broken = yes; then + AC_DEFINE(OCTAVE_HAVE_BROKEN_STRPTIME, 1, [Define if strptime is broken on your system]) + fi + AC_LANG_POP(C) + ]) + dnl dnl The following test is from Karl Berry's Kpathseach library. I'm dnl including it here in case we someday want to make the use of dnl kpathsea optional. *************** *** 632,638 **** cat > conftest.$ac_ext < conftest.$ac_ext <&AS_MESSAGE_LOG_FD; then if test "`${NM-nm} conftest.$ac_objext | grep _FSmy_dld_fcn`" != ""; then octave_cv_cxx_prepends_underscore=yes fi *************** *** 741,747 **** cat > conftest.$ac_ext < conftest.$ac_ext <&AS_MESSAGE_LOG_FD; then if test "`${NM-nm} conftest.$ac_objext | grep FSmy_dld_fcn__Fv`" != ""; then octave_cv_cxx_abi='gnu_v2' fi *************** *** 1013,1019 **** EOF octave_qhull_try="${CC-cc} $CFLAGS $CPPFLAGS $LDFLAGS conftest.c -o conftest -lqhull $LIBS" ! if AC_TRY_EVAL(octave_qhull_try) && test -s conftest ; then octave_cv_lib_qhull_version=yes else octave_cv_lib_qhull_version=no --- 1027,1033 ---- EOF octave_qhull_try="${CC-cc} $CFLAGS $CPPFLAGS $LDFLAGS conftest.c -o conftest -lqhull $LIBS" ! if (eval "$octave_qhull_try") 2>&AS_MESSAGE_LOG_FD && test -s conftest ; then octave_cv_lib_qhull_version=yes else octave_cv_lib_qhull_version=no diff -cNr octave-2.9.15/acx_blas.m4 octave-2.9.16/acx_blas.m4 *** octave-2.9.15/acx_blas.m4 Wed Dec 6 15:23:18 2006 --- octave-2.9.16/acx_blas.m4 Wed Oct 24 15:57:57 2007 *************** *** 90,96 **** # BLAS in Apple vecLib framework? (Mac OS X) if test $acx_blas_ok = no; then ! vlib_flags="-framework vecLib" save_LIBS="$LIBS"; LIBS="$vlib_flags $LIBS" AC_MSG_CHECKING([for $sgemm in $vlib_flags]) AC_LINK_IFELSE([AC_LANG_CALL([], [$sgemm])], --- 90,96 ---- # BLAS in Apple vecLib framework? (Mac OS X) if test $acx_blas_ok = no; then ! vlib_flags="-Wl,-framework -Wl,vecLib" save_LIBS="$LIBS"; LIBS="$vlib_flags $LIBS" AC_MSG_CHECKING([for $sgemm in $vlib_flags]) AC_LINK_IFELSE([AC_LANG_CALL([], [$sgemm])], diff -cNr octave-2.9.15/config.h.in octave-2.9.16/config.h.in *** octave-2.9.15/config.h.in Sat Oct 13 10:35:58 2007 --- octave-2.9.16/config.h.in Wed Oct 31 17:30:48 2007 *************** *** 220,228 **** /* Define to 1 if you have the `exp2' function. */ #undef HAVE_EXP2 - /* Define if we are using f2c. */ - #undef HAVE_F2C - /* Define to 1 if you have the `fcntl' function. */ #undef HAVE_FCNTL --- 220,225 ---- *************** *** 409,423 **** /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H - /* Define if the METIS library is used. */ - #undef HAVE_METIS - - /* Define to 1 if you have the header file. */ - #undef HAVE_METIS_H - - /* Define to 1 if you have the header file. */ - #undef HAVE_METIS_METIS_H - /* Define to 1 if you have the `mkdir' function. */ #undef HAVE_MKDIR --- 406,411 ---- *************** *** 625,633 **** /* Define to 1 if you have the header file. */ #undef HAVE_SUITESPARSE_CS_H - /* Define to 1 if you have the header file. */ - #undef HAVE_SUITESPARSE_METIS_H - /* Define to 1 if you have the header file. */ #undef HAVE_SUITESPARSE_UMFPACK_H --- 613,618 ---- *************** *** 716,724 **** /* Define to 1 if you have the header file. */ #undef HAVE_UFSPARSE_CS_H - /* Define to 1 if you have the header file. */ - #undef HAVE_UFSPARSE_METIS_H - /* Define to 1 if you have the header file. */ #undef HAVE_UFSPARSE_UMFPACK_H --- 701,706 ---- *************** *** 818,823 **** --- 800,808 ---- /* Define (to string::npos) if doesn't */ #undef NPOS + /* Define if strptime is broken on your system */ + #undef OCTAVE_HAVE_BROKEN_STRPTIME + /* Define if this is Octave. */ #undef OCTAVE_SOURCE *************** *** 1079,1084 **** --- 1064,1071 ---- #define SIZEOF_OCTAVE_IDX_TYPE SIZEOF_INT #endif + #define OCTAVE_EMPTY_CPP_ARG + #include "oct-dlldefs.h" #include "oct-types.h" diff -cNr octave-2.9.15/configure octave-2.9.16/configure *** octave-2.9.15/configure Sat Oct 13 10:35:52 2007 --- octave-2.9.16/configure Wed Oct 31 17:30:44 2007 *************** *** 726,733 **** FFLAGS ac_ct_F77 FLIBS - F2C - F2CFLAGS F77_TOLOWER F77_APPEND_UNDERSCORE F77_APPEND_EXTRA_UNDERSCORE --- 726,731 ---- *************** *** 839,846 **** BUILD_EXEEXT F77 FFLAGS - F2C - F2CFLAGS YACC YFLAGS' ac_subdirs_all='scripts' --- 837,842 ---- *************** *** 1415,1421 **** Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] ! --enable-bounds-check for internal array classes (default is no) --enable-64 (EXPERIMENTAL) use 64-bit integers for array dimensions and indexing --enable-static create static libraries --- 1411,1418 ---- Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] ! --enable-bounds-check bounds checking for indexing in internal array ! classes (default is no) --enable-64 (EXPERIMENTAL) use 64-bit integers for array dimensions and indexing --enable-static create static libraries *************** *** 1431,1438 **** --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-sepchar= use as the path separation character - --with-f2c use f2c even if Fortran compiler is available - --with-f77 use f77 to compile Fortran subroutines --without-zlib don't use zlib --without-hdf5 don't use HDF5 --without-fftw use included fftpack instead of installed fftw --- 1428,1433 ---- *************** *** 1471,1478 **** build system executable extension (used if cross compiling) F77 Fortran 77 compiler command FFLAGS Fortran 77 compiler flags - F2C Fortran to C translator command - F2CFLAGS Fortran to C translator flags YACC The `Yet Another C Compiler' implementation to use. Defaults to the first program found out of: `bison -y', `byacc', `yacc'. YFLAGS The list of arguments that will be passed by default to $YACC. --- 1466,1471 ---- *************** *** 3998,4041 **** config_opts=$ac_configure_args - ### Allow the user to force us to use f2c. - - - # Check whether --with-f2c was given. - if test "${with_f2c+set}" = set; then - withval=$with_f2c; if test "$withval" = no; then use_f2c=false; else use_f2c=true; fi - else - use_f2c=false - fi - - - ### Allow the user to force us to use f77. - - - # Check whether --with-f77 was given. - if test "${with_f77+set}" = set; then - withval=$with_f77; if test "$withval" = no; then use_f77=false; else use_f77=true; fi - else - use_f77=false - fi - - - ### Make sure only one of the above options for Fortran compilers was - ### specified (multiple "no" or --without-FOO options are ok). - - if test "${with_f77+set}" = set; then - if test "${with_f2c+set}" = set; then - if test "$with_f2c" = no; then - true - else - warn_f2c_and_f77="--with-f2c and --with-f77 both specified! Using f77..." - { echo "$as_me:$LINENO: WARNING: $warn_f2c_and_f77" >&5 - echo "$as_me: WARNING: $warn_f2c_and_f77" >&2;} - use_f2c=false - fi - fi - fi - ### Make it possible to have Octave's array and matrix classes do bounds ### checking on element references. This slows some operations down a ### bit, so it is turned off by default. --- 3991,3996 ---- *************** *** 6260,6270 **** cat > conftest.$ac_ext <&5 ! (eval $ac_compile) 2>&5 ! ac_status=$? ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); }; then if test "`${NM-nm} conftest.$ac_objext | grep FSmy_dld_fcn__Fv`" != ""; then octave_cv_cxx_abi='gnu_v2' fi --- 6215,6221 ---- cat > conftest.$ac_ext <&5; then if test "`${NM-nm} conftest.$ac_objext | grep FSmy_dld_fcn__Fv`" != ""; then octave_cv_cxx_abi='gnu_v2' fi *************** *** 8036,8046 **** cat > conftest.$ac_ext <&5 ! (eval $ac_compile) 2>&5 ! ac_status=$? ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); }; then if test "`${NM-nm} conftest.$ac_objext | grep _FSmy_dld_fcn`" != ""; then octave_cv_cxx_prepends_underscore=yes fi --- 7987,7993 ---- cat > conftest.$ac_ext <&5; then if test "`${NM-nm} conftest.$ac_objext | grep _FSmy_dld_fcn`" != ""; then octave_cv_cxx_prepends_underscore=yes fi *************** *** 8497,8507 **** EOF octave_qhull_try="${CC-cc} $CFLAGS $CPPFLAGS $LDFLAGS conftest.c -o conftest -lqhull $LIBS" ! if { (eval echo "$as_me:$LINENO: \"$octave_qhull_try\"") >&5 ! (eval $octave_qhull_try) 2>&5 ! ac_status=$? ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && test -s conftest ; then octave_cv_lib_qhull_version=yes else octave_cv_lib_qhull_version=no --- 8444,8450 ---- EOF octave_qhull_try="${CC-cc} $CFLAGS $CPPFLAGS $LDFLAGS conftest.c -o conftest -lqhull $LIBS" ! if (eval "$octave_qhull_try") 2>&5 && test -s conftest ; then octave_cv_lib_qhull_version=yes else octave_cv_lib_qhull_version=no *************** *** 10728,10735 **** # ---------------------------------------------------------------------- - ### We need these before trying to find libf2c. - if test -z "$AR"; then AR=ar fi --- 10671,10676 ---- *************** *** 10838,10876 **** fi ! ### If we haven't been forced to use a particular Fortran compiler, ! ### try to find one using any one of several common Un*x Fortran ! ### compiler names using the AC_PROG_F77 macro. ! ### ! ### The configure options --with-f77 or --with-f2c ! ### force f77 or f2c to be used. It is also possible to use ! ### these options to specify the name of the compiler. For example, ! ### `--with-f77=g77' says that we are using g77 as the Fortran compiler. ! ! if $use_f77; then ! if test "$with_f77" = yes; then ! F77=f77 ! else ! F77="$with_f77" ! fi ! { echo "$as_me:$LINENO: defining F77 to be $F77" >&5 ! echo "$as_me: defining F77 to be $F77" >&6;} ! elif $use_f2c; then ! F77= ! if test "$with_f2c" = yes; then ! F2C=f2c ! else ! F2C="$with_f2c" ! fi ! { echo "$as_me:$LINENO: defining F2C to be $F2C" >&5 ! echo "$as_me: defining F2C to be $F2C" >&6;} ! fi ! if test "x$FFLAGS" = x; then ! FFLAGS="-O" # override -g -O default by AC_PROG_F77 fi ! # the F77 variable, if set, overrides AC_PROG_F77 automatically ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' --- 10779,10790 ---- fi ! ## Default FFLAGS is -O. if test "x$FFLAGS" = x; then ! FFLAGS="-O" fi ! ## the F77 variable, if set, overrides AC_PROG_F77 automatically ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' *************** *** 11132,11148 **** ac_compiler_gnu=$ac_cv_c_compiler_gnu - have_fortran_compiler=false - have_f2c=false - - F77_TOLOWER=true - F77_APPEND_UNDERSCORE=true - F77_APPEND_EXTRA_UNDERSCORE=true - if $use_f2c; then - have_f2c=true - else - if test -n "$F77"; then - ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' --- 11046,11051 ---- *************** *** 11467,11473 **** ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ! ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu --- 11370,11376 ---- ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ! ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu *************** *** 11636,11642 **** ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ! ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu --- 11539,11545 ---- ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ! ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu *************** *** 11968,11986 **** ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu - case "$ac_cv_f77_mangling" in - "upper case") F77_TOLOWER=false ;; - esac - case "$ac_cv_f77_mangling" in - "no underscore") F77_APPEND_UNDERSCORE=false ;; - esac - case "$ac_cv_f77_mangling" in - "no extra underscore") F77_APPEND_EXTRA_UNDERSCORE=false ;; - esac ! case "$canonical_host_type" in ! i[3456789]86-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ac_safe=`echo "-mieee-fp" | sed 'y%./+-:=%__p___%'` { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -mieee-fp" >&5 --- 11871,11894 ---- ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ! F77_TOLOWER=true ! F77_APPEND_UNDERSCORE=true ! F77_APPEND_EXTRA_UNDERSCORE=true ! ! case "$ac_cv_f77_mangling" in ! "upper case") F77_TOLOWER=false ;; ! esac ! case "$ac_cv_f77_mangling" in ! "no underscore") F77_APPEND_UNDERSCORE=false ;; ! esac ! case "$ac_cv_f77_mangling" in ! "no extra underscore") F77_APPEND_EXTRA_UNDERSCORE=false ;; ! esac ! ! case "$canonical_host_type" in ! i[3456789]86-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ac_safe=`echo "-mieee-fp" | sed 'y%./+-:=%__p___%'` { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -mieee-fp" >&5 *************** *** 12052,12062 **** fi ! ### OCTAVE_F77_FLAG(-ffloat-store) ! fi ! ;; ! alpha*-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ac_safe=`echo "-mieee" | sed 'y%./+-:=%__p___%'` { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -mieee" >&5 --- 11960,11970 ---- fi ! ### OCTAVE_F77_FLAG(-ffloat-store) ! fi ! ;; ! alpha*-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ac_safe=`echo "-mieee" | sed 'y%./+-:=%__p___%'` { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -mieee" >&5 *************** *** 12128,12134 **** fi ! else ac_safe=`echo "-ieee" | sed 'y%./+-:=%__p___%'` { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -ieee" >&5 --- 12036,12042 ---- fi ! else ac_safe=`echo "-ieee" | sed 'y%./+-:=%__p___%'` { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -ieee" >&5 *************** *** 12271,12416 **** fi - fi - ;; - powerpc-apple-machten*) - FFLAGS= - ;; - esac - if test -n "$FFLAGS"; then - { echo "$as_me:$LINENO: defining FFLAGS to be $FFLAGS" >&5 - echo "$as_me: defining FFLAGS to be $FFLAGS" >&6;} fi ! have_fortran_compiler=true ! else ! # Extract the first word of "f2c", so it can be a program name with args. ! set dummy f2c; ac_word=$2 ! { echo "$as_me:$LINENO: checking for $ac_word" >&5 ! echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } ! if test "${ac_cv_prog_F2C+set}" = set; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! if test -n "$F2C"; then ! ac_cv_prog_F2C="$F2C" # Let the user override the test. ! else ! as_save_IFS=$IFS; IFS=$PATH_SEPARATOR ! for as_dir in $PATH ! do ! IFS=$as_save_IFS ! test -z "$as_dir" && as_dir=. ! for ac_exec_ext in '' $ac_executable_extensions; do ! if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ! ac_cv_prog_F2C="f2c" ! echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 ! break 2 ! fi ! done ! done ! IFS=$as_save_IFS ! ! fi ! fi ! F2C=$ac_cv_prog_F2C ! if test -n "$F2C"; then ! { echo "$as_me:$LINENO: result: $F2C" >&5 ! echo "${ECHO_T}$F2C" >&6; } ! else ! { echo "$as_me:$LINENO: result: no" >&5 ! echo "${ECHO_T}no" >&6; } ! fi ! ! ! ! if test -n "$F2C"; then ! have_f2c=true ! fi ! fi fi - f77_rules_frag=/dev/null - if $have_fortran_compiler; then - f77_rules_frag=Makefrag.f77 - cat << \EOF > $f77_rules_frag - - %.c : %.f ! %.o : %.f ! $(FC) -c $(ALL_FFLAGS) -o $@ $< ! pic/%.o : %.f ! $(FC) -c $(FPICFLAG) $(ALL_FFLAGS) $< -o $@ - EOF - elif $have_f2c; then ! cat >>confdefs.h <<\_ACEOF ! #define HAVE_F2C 1 ! _ACEOF - ### FIXME -- these shouldn't be fixed names, eh? - oct_conflib=libconflib.a - oct_obj_ext=o ! CONFLIB_ARG= ! if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ! (eval $ac_compile) 2>&5 ! ac_status=$? ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); }; then ! $AR $ARFLAGS $oct_conflib conftest.$oct_obj_ext 1>&5 ! if test -n "$RANLIB"; then ! $RANLIB $oct_conflib 1>&5 ! fi ! CONFLIB_ARG="-L. -lconflib" ! fi ! rm -f conftest* ! case "$canonical_host_type" in ! *-*-msdosmsvc) ! CONFLIB_ARG="-MD" ! ;; ! esac ! { echo "$as_me:$LINENO: checking for f_open in -lf2c" >&5 ! echo $ECHO_N "checking for f_open in -lf2c... $ECHO_C" >&6; } ! if test "${ac_cv_lib_f2c_f_open+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - ac_check_lib_save_LIBS=$LIBS - LIBS="-lf2c $CONFLIB_ARG $LIBS" - cat >conftest.$ac_ext <<_ACEOF - /* confdefs.h. */ - _ACEOF - cat confdefs.h >>conftest.$ac_ext - cat >>conftest.$ac_ext <<_ACEOF - /* end confdefs.h. */ ! /* Override any GCC internal prototype to avoid an error. ! Use char because int might match the return type of a GCC ! builtin and then its argument prototype would still apply. */ ! #ifdef __cplusplus ! extern "C" ! #endif ! char f_open (); ! #ifdef F77_DUMMY_MAIN ! # ifdef __cplusplus ! extern "C" ! # endif ! int F77_DUMMY_MAIN() { return 1; } ! #endif ! int ! main () ! { ! return f_open (); ! ; ! return 0; ! } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" --- 12179,12244 ---- fi fi ! ;; ! powerpc-apple-machten*) ! FFLAGS= ! ;; ! esac ! if test -n "$FFLAGS"; then ! { echo "$as_me:$LINENO: defining FFLAGS to be $FFLAGS" >&5 ! echo "$as_me: defining FFLAGS to be $FFLAGS" >&6;} fi ! if test -z "$F77"; then ! { echo "$as_me:$LINENO: WARNING: in order to build octave, you must have a compatible" >&5 ! echo "$as_me: WARNING: in order to build octave, you must have a compatible" >&2;} ! { echo "$as_me:$LINENO: WARNING: Fortran compiler or wrapper script for f2c that functions" >&5 ! echo "$as_me: WARNING: Fortran compiler or wrapper script for f2c that functions" >&2;} ! { echo "$as_me:$LINENO: WARNING: as a Fortran compiler installed and in your path." >&5 ! echo "$as_me: WARNING: as a Fortran compiler installed and in your path." >&2;} ! { { echo "$as_me:$LINENO: error: See the file INSTALL for more information." >&5 ! echo "$as_me: error: See the file INSTALL for more information." >&2;} ! { (exit 1); exit 1; }; } ! fi ! XTRA_CRUFT_SH_LDFLAGS= ! case "$canonical_host_type" in ! *-*-msdosmsvc) ! FLIBS="$FLIBS -lkernel32" ! XTRA_CRUFT_SH_LDFLAGS="-Wl,-def:cruft.def" ! ;; ! esac ! FC=$F77 ! ac_safe=`echo "-ffloat-store" | sed 'y%./+-:=%__p___%'` ! { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -ffloat-store" >&5 ! echo $ECHO_N "checking whether ${F77-g77} accepts -ffloat-store... $ECHO_C" >&6; } ! if { as_var=octave_cv_f77_flag_$ac_safe; eval "test \"\${$as_var+set}\" = set"; }; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ! ac_ext=f ! ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ! ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ! ac_compiler_gnu=$ac_cv_f77_compiler_gnu ! XFFLAGS="$FFLAGS" ! FFLAGS="$FFLAGS -ffloat-store" ! cat >conftest.$ac_ext <<_ACEOF ! program main ! end _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" *************** *** 12426,12721 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ! test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && $as_test_x conftest$ac_exeext; then ! ac_cv_lib_f2c_f_open=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ! ac_cv_lib_f2c_f_open=no fi rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext ! LIBS=$ac_check_lib_save_LIBS ! fi ! { echo "$as_me:$LINENO: result: $ac_cv_lib_f2c_f_open" >&5 ! echo "${ECHO_T}$ac_cv_lib_f2c_f_open" >&6; } ! if test $ac_cv_lib_f2c_f_open = yes; then ! FLIBS=-lf2c ! else ! FLIBS= fi ! rm -f $oct_conflib ! if test -z "$FLIBS"; then ! { echo "$as_me:$LINENO: checking for d_sin in -lF77" >&5 ! echo $ECHO_N "checking for d_sin in -lF77... $ECHO_C" >&6; } ! if test "${ac_cv_lib_F77_d_sin+set}" = set; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! ac_check_lib_save_LIBS=$LIBS ! LIBS="-lF77 $LIBS" ! cat >conftest.$ac_ext <<_ACEOF ! /* confdefs.h. */ ! _ACEOF ! cat confdefs.h >>conftest.$ac_ext ! cat >>conftest.$ac_ext <<_ACEOF ! /* end confdefs.h. */ - /* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ - #ifdef __cplusplus - extern "C" - #endif - char d_sin (); - #ifdef F77_DUMMY_MAIN ! # ifdef __cplusplus ! extern "C" ! # endif ! int F77_DUMMY_MAIN() { return 1; } ! #endif ! int ! main () ! { ! return d_sin (); ! ; ! return 0; ! } ! _ACEOF ! rm -f conftest.$ac_objext conftest$ac_exeext ! if { (ac_try="$ac_link" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_link") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && { ! test -z "$ac_c_werror_flag" || ! test ! -s conftest.err ! } && test -s conftest$ac_exeext && ! $as_test_x conftest$ac_exeext; then ! ac_cv_lib_F77_d_sin=yes ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! ac_cv_lib_F77_d_sin=no ! fi ! ! rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ ! conftest$ac_exeext conftest.$ac_ext ! LIBS=$ac_check_lib_save_LIBS ! fi ! { echo "$as_me:$LINENO: result: $ac_cv_lib_F77_d_sin" >&5 ! echo "${ECHO_T}$ac_cv_lib_F77_d_sin" >&6; } ! if test $ac_cv_lib_F77_d_sin = yes; then ! FLIBS=-lF77 ! else ! FLIBS= ! fi ! ! if test -n "$FLIBS"; then ! { echo "$as_me:$LINENO: checking for f_rew in -lI77" >&5 ! echo $ECHO_N "checking for f_rew in -lI77... $ECHO_C" >&6; } ! if test "${ac_cv_lib_I77_f_rew+set}" = set; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! ac_check_lib_save_LIBS=$LIBS ! LIBS="-lI77 -lF77 $LIBS" ! cat >conftest.$ac_ext <<_ACEOF ! /* confdefs.h. */ ! _ACEOF ! cat confdefs.h >>conftest.$ac_ext ! cat >>conftest.$ac_ext <<_ACEOF ! /* end confdefs.h. */ ! ! /* Override any GCC internal prototype to avoid an error. ! Use char because int might match the return type of a GCC ! builtin and then its argument prototype would still apply. */ ! #ifdef __cplusplus ! extern "C" ! #endif ! char f_rew (); ! #ifdef F77_DUMMY_MAIN ! ! # ifdef __cplusplus ! extern "C" ! # endif ! int F77_DUMMY_MAIN() { return 1; } ! ! #endif ! int ! main () ! { ! return f_rew (); ! ; ! return 0; ! } ! _ACEOF ! rm -f conftest.$ac_objext conftest$ac_exeext ! if { (ac_try="$ac_link" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_link") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && { ! test -z "$ac_c_werror_flag" || ! test ! -s conftest.err ! } && test -s conftest$ac_exeext && ! $as_test_x conftest$ac_exeext; then ! ac_cv_lib_I77_f_rew=yes ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! ac_cv_lib_I77_f_rew=no ! fi ! ! rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ ! conftest$ac_exeext conftest.$ac_ext ! LIBS=$ac_check_lib_save_LIBS ! fi ! { echo "$as_me:$LINENO: result: $ac_cv_lib_I77_f_rew" >&5 ! echo "${ECHO_T}$ac_cv_lib_I77_f_rew" >&6; } ! if test $ac_cv_lib_I77_f_rew = yes; then ! FLIBS="$FLIBS -lI77" ! else ! FLIBS= ! fi ! ! fi ! fi ! ! if test -z "$FLIBS"; then ! warn_f2c_no_lib="I found f2c but not libf2c.a, or libF77.a and libI77.a" ! { echo "$as_me:$LINENO: WARNING: $warn_f2c_no_lib" >&5 ! echo "$as_me: WARNING: $warn_f2c_no_lib" >&2;} ! fi ! f77_rules_frag=Makefrag.f77 ! cat << \EOF > $f77_rules_frag ! ! %.c : %.f ! $(F2C) $(F2CFLAGS) < $< > $(@F) ! ! %.o : %.f ! ! EOF ! else ! { echo "$as_me:$LINENO: WARNING: in order to build octave, you must have a compatible" >&5 ! echo "$as_me: WARNING: in order to build octave, you must have a compatible" >&2;} ! { echo "$as_me:$LINENO: WARNING: Fortran compiler or f2c installed and in your path." >&5 ! echo "$as_me: WARNING: Fortran compiler or f2c installed and in your path." >&2;} ! { { echo "$as_me:$LINENO: error: See the file INSTALL for more information." >&5 ! echo "$as_me: error: See the file INSTALL for more information." >&2;} ! { (exit 1); exit 1; }; } ! fi ! ! XTRA_CRUFT_SH_LDFLAGS= ! case "$canonical_host_type" in ! *-*-msdosmsvc) ! FLIBS="$FLIBS -lkernel32" ! XTRA_CRUFT_SH_LDFLAGS="-Wl,-def:cruft.def" ! ;; ! esac ! ! ! FC=$F77 ! ! ! ! ! ac_safe=`echo "-ffloat-store" | sed 'y%./+-:=%__p___%'` ! { echo "$as_me:$LINENO: checking whether ${F77-g77} accepts -ffloat-store" >&5 ! echo $ECHO_N "checking whether ${F77-g77} accepts -ffloat-store... $ECHO_C" >&6; } ! if { as_var=octave_cv_f77_flag_$ac_safe; eval "test \"\${$as_var+set}\" = set"; }; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! ! ac_ext=f ! ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ! ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ! ac_compiler_gnu=$ac_cv_f77_compiler_gnu ! ! XFFLAGS="$FFLAGS" ! FFLAGS="$FFLAGS -ffloat-store" ! cat >conftest.$ac_ext <<_ACEOF ! program main ! ! end ! _ACEOF ! rm -f conftest.$ac_objext conftest$ac_exeext ! if { (ac_try="$ac_link" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_link") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && { ! test -z "$ac_f77_werror_flag" || ! test ! -s conftest.err ! } && test -s conftest$ac_exeext && ! $as_test_x conftest$ac_exeext; then ! eval "octave_cv_f77_flag_$ac_safe=yes" ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! eval "octave_cv_f77_flag_$ac_safe=no" ! fi ! ! rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ ! conftest$ac_exeext conftest.$ac_ext ! FFLAGS="$XFFLAGS" ! ac_ext=c ! ac_cpp='$CPP $CPPFLAGS' ! ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ! ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ! ac_compiler_gnu=$ac_cv_c_compiler_gnu ! ! ! fi ! ! if eval "test \"`echo '$octave_cv_f77_flag_'$ac_safe`\" = yes"; then ! { echo "$as_me:$LINENO: result: yes" >&5 ! echo "${ECHO_T}yes" >&6; } ! ! { echo "$as_me:$LINENO: result: setting F77_FLOAT_STORE_FLAG to -ffloat-store" >&5 ! echo "${ECHO_T}setting F77_FLOAT_STORE_FLAG to -ffloat-store" >&6; } ! F77_FLOAT_STORE_FLAG=-ffloat-store ! ! ! else ! { echo "$as_me:$LINENO: result: no" >&5 ! echo "${ECHO_T}no" >&6; } ! ! fi ### Checks for BLAS and LAPACK libraries: --- 12254,12297 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ! test -z "$ac_f77_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && $as_test_x conftest$ac_exeext; then ! eval "octave_cv_f77_flag_$ac_safe=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ! eval "octave_cv_f77_flag_$ac_safe=no" fi rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext ! FFLAGS="$XFFLAGS" ! ac_ext=c ! ac_cpp='$CPP $CPPFLAGS' ! ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ! ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ! ac_compiler_gnu=$ac_cv_c_compiler_gnu ! ! fi ! if eval "test \"`echo '$octave_cv_f77_flag_'$ac_safe`\" = yes"; then ! { echo "$as_me:$LINENO: result: yes" >&5 ! echo "${ECHO_T}yes" >&6; } ! { echo "$as_me:$LINENO: result: setting F77_FLOAT_STORE_FLAG to -ffloat-store" >&5 ! echo "${ECHO_T}setting F77_FLOAT_STORE_FLAG to -ffloat-store" >&6; } ! F77_FLOAT_STORE_FLAG=-ffloat-store ! else ! { echo "$as_me:$LINENO: result: no" >&5 ! echo "${ECHO_T}no" >&6; } ! fi ### Checks for BLAS and LAPACK libraries: *************** *** 13187,13193 **** # BLAS in Apple vecLib framework? (Mac OS X) if test $acx_blas_ok = no; then ! vlib_flags="-framework vecLib" save_LIBS="$LIBS"; LIBS="$vlib_flags $LIBS" { echo "$as_me:$LINENO: checking for $sgemm in $vlib_flags" >&5 echo $ECHO_N "checking for $sgemm in $vlib_flags... $ECHO_C" >&6; } --- 12763,12769 ---- # BLAS in Apple vecLib framework? (Mac OS X) if test $acx_blas_ok = no; then ! vlib_flags="-Wl,-framework -Wl,vecLib" save_LIBS="$LIBS"; LIBS="$vlib_flags $LIBS" { echo "$as_me:$LINENO: checking for $sgemm in $vlib_flags" >&5 echo $ECHO_N "checking for $sgemm in $vlib_flags... $ECHO_C" >&6; } *************** *** 14516,14521 **** --- 14092,14155 ---- + + { echo "$as_me:$LINENO: checking BLAS library calling convention compatibility" >&5 + echo $ECHO_N "checking BLAS library calling convention compatibility... $ECHO_C" >&6; } + cat << EOF > conftest.f + program foo + double complex zdotu, zx(10), zy(10), retval + integer n, incx, incy + n = 10 + incx = 1 + incy = 1 + do 10 i = 1, n + zx(i) = dcmplx (i, 0) + zy(i) = dcmplx (0, i) + 10 continue + retval = zdotu (n, zx, incx, zy, incy) + if (retval .eq. dcmplx (0, 385)) then + print *, 'succeeded' + else + print *, 'failed' + print *, retval + endif + end + EOF + XLIBS="$LIBS" + LIBS="$BLAS_LIBS $FLIBS $LIBS" + ac_ext=f + ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' + ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_f77_compiler_gnu + + (eval "$ac_compile"; eval "$ac_link") 2>&5 + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + + LIBS="$XLIBS" + case "`./conftest$ac_exeext`" in + *succeeded*) + { echo "$as_me:$LINENO: result: yes" >&5 + echo "${ECHO_T}yes" >&6; } + ;; + *) + { echo "$as_me:$LINENO: result: no" >&5 + echo "${ECHO_T}no" >&6; } + { echo "$as_me:$LINENO: WARNING: Your BLAS library was apparently compiled with a Fortran" >&5 + echo "$as_me: WARNING: Your BLAS library was apparently compiled with a Fortran" >&2;} + { echo "$as_me:$LINENO: WARNING: compiler that uses a different calling convention from" >&5 + echo "$as_me: WARNING: compiler that uses a different calling convention from" >&2;} + { echo "$as_me:$LINENO: WARNING: the one used by the selected compiler, $F77." >&5 + echo "$as_me: WARNING: the one used by the selected compiler, $F77." >&2;} + { { echo "$as_me:$LINENO: error: You must correct this problem before building Octave." >&5 + echo "$as_me: error: You must correct this problem before building Octave." >&2;} + { (exit 1); exit 1; }; } + ;; + esac + # Check for AMD library AMD_LIBS= *************** *** 15712,16114 **** fi ac_res=`eval echo '${'$as_ac_Header'}'` { echo "$as_me:$LINENO: result: $ac_res" >&5 ! echo "${ECHO_T}$ac_res" >&6; } ! else ! # Is the header compilable? ! { echo "$as_me:$LINENO: checking $ac_header usability" >&5 ! echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; } ! cat >conftest.$ac_ext <<_ACEOF ! /* confdefs.h. */ ! _ACEOF ! cat confdefs.h >>conftest.$ac_ext ! cat >>conftest.$ac_ext <<_ACEOF ! /* end confdefs.h. */ ! $ac_includes_default ! #include <$ac_header> ! _ACEOF ! rm -f conftest.$ac_objext ! if { (ac_try="$ac_compile" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_compile") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && { ! test -z "$ac_c_werror_flag" || ! test ! -s conftest.err ! } && test -s conftest.$ac_objext; then ! ac_header_compiler=yes ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! ac_header_compiler=no ! fi ! ! rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ! { echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 ! echo "${ECHO_T}$ac_header_compiler" >&6; } ! ! # Is the header present? ! { echo "$as_me:$LINENO: checking $ac_header presence" >&5 ! echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; } ! cat >conftest.$ac_ext <<_ACEOF ! /* confdefs.h. */ ! _ACEOF ! cat confdefs.h >>conftest.$ac_ext ! cat >>conftest.$ac_ext <<_ACEOF ! /* end confdefs.h. */ ! #include <$ac_header> ! _ACEOF ! if { (ac_try="$ac_cpp conftest.$ac_ext" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } >/dev/null && { ! test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || ! test ! -s conftest.err ! }; then ! ac_header_preproc=yes ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! ac_header_preproc=no ! fi ! ! rm -f conftest.err conftest.$ac_ext ! { echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 ! echo "${ECHO_T}$ac_header_preproc" >&6; } ! ! # So? What about this header? ! case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in ! yes:no: ) ! { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 ! echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 ! echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ! ac_header_preproc=yes ! ;; ! no:yes:* ) ! { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 ! echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 ! echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 ! echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 ! echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 ! echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 ! echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ! ! ;; ! esac ! { echo "$as_me:$LINENO: checking for $ac_header" >&5 ! echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } ! if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! eval "$as_ac_Header=\$ac_header_preproc" ! fi ! ac_res=`eval echo '${'$as_ac_Header'}'` ! { echo "$as_me:$LINENO: result: $ac_res" >&5 ! echo "${ECHO_T}$ac_res" >&6; } ! ! fi ! if test `eval echo '${'$as_ac_Header'}'` = yes; then ! cat >>confdefs.h <<_ACEOF ! #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 ! _ACEOF ! ! ! ! ! ! for ac_header in suitesparse/metis.h ufsparse/metis.h metis/metis.h metis.h ! do ! as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` ! if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then ! { echo "$as_me:$LINENO: checking for $ac_header" >&5 ! echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } ! if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! fi ! ac_res=`eval echo '${'$as_ac_Header'}'` ! { echo "$as_me:$LINENO: result: $ac_res" >&5 ! echo "${ECHO_T}$ac_res" >&6; } ! else ! # Is the header compilable? ! { echo "$as_me:$LINENO: checking $ac_header usability" >&5 ! echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; } ! cat >conftest.$ac_ext <<_ACEOF ! /* confdefs.h. */ ! _ACEOF ! cat confdefs.h >>conftest.$ac_ext ! cat >>conftest.$ac_ext <<_ACEOF ! /* end confdefs.h. */ ! $ac_includes_default ! #include <$ac_header> ! _ACEOF ! rm -f conftest.$ac_objext ! if { (ac_try="$ac_compile" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_compile") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && { ! test -z "$ac_c_werror_flag" || ! test ! -s conftest.err ! } && test -s conftest.$ac_objext; then ! ac_header_compiler=yes ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! ac_header_compiler=no ! fi ! ! rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ! { echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 ! echo "${ECHO_T}$ac_header_compiler" >&6; } ! ! # Is the header present? ! { echo "$as_me:$LINENO: checking $ac_header presence" >&5 ! echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; } ! cat >conftest.$ac_ext <<_ACEOF ! /* confdefs.h. */ ! _ACEOF ! cat confdefs.h >>conftest.$ac_ext ! cat >>conftest.$ac_ext <<_ACEOF ! /* end confdefs.h. */ ! #include <$ac_header> ! _ACEOF ! if { (ac_try="$ac_cpp conftest.$ac_ext" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } >/dev/null && { ! test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || ! test ! -s conftest.err ! }; then ! ac_header_preproc=yes ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! ac_header_preproc=no ! fi ! ! rm -f conftest.err conftest.$ac_ext ! { echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 ! echo "${ECHO_T}$ac_header_preproc" >&6; } ! ! # So? What about this header? ! case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in ! yes:no: ) ! { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 ! echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 ! echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ! ac_header_preproc=yes ! ;; ! no:yes:* ) ! { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 ! echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 ! echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 ! echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 ! echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 ! echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 ! echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ! ! ;; ! esac ! { echo "$as_me:$LINENO: checking for $ac_header" >&5 ! echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } ! if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! eval "$as_ac_Header=\$ac_header_preproc" ! fi ! ac_res=`eval echo '${'$as_ac_Header'}'` ! { echo "$as_me:$LINENO: result: $ac_res" >&5 ! echo "${ECHO_T}$ac_res" >&6; } ! ! fi ! if test `eval echo '${'$as_ac_Header'}'` = yes; then ! cat >>confdefs.h <<_ACEOF ! #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 ! _ACEOF ! ! { echo "$as_me:$LINENO: checking for METIS_NodeND in -lmetis" >&5 ! echo $ECHO_N "checking for METIS_NodeND in -lmetis... $ECHO_C" >&6; } ! if test "${ac_cv_lib_metis_METIS_NodeND+set}" = set; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! ac_check_lib_save_LIBS=$LIBS ! LIBS="-lmetis $LIBS" ! cat >conftest.$ac_ext <<_ACEOF ! /* confdefs.h. */ ! _ACEOF ! cat confdefs.h >>conftest.$ac_ext ! cat >>conftest.$ac_ext <<_ACEOF ! /* end confdefs.h. */ ! ! /* Override any GCC internal prototype to avoid an error. ! Use char because int might match the return type of a GCC ! builtin and then its argument prototype would still apply. */ ! #ifdef __cplusplus ! extern "C" ! #endif ! char METIS_NodeND (); ! #ifdef F77_DUMMY_MAIN ! ! # ifdef __cplusplus ! extern "C" ! # endif ! int F77_DUMMY_MAIN() { return 1; } ! ! #endif ! int ! main () ! { ! return METIS_NodeND (); ! ; ! return 0; ! } ! _ACEOF ! rm -f conftest.$ac_objext conftest$ac_exeext ! if { (ac_try="$ac_link" ! case "(($ac_try" in ! *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; ! *) ac_try_echo=$ac_try;; ! esac ! eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_link") 2>conftest.er1 ! ac_status=$? ! grep -v '^ *+' conftest.er1 >conftest.err ! rm -f conftest.er1 ! cat conftest.err >&5 ! echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && { ! test -z "$ac_c_werror_flag" || ! test ! -s conftest.err ! } && test -s conftest$ac_exeext && ! $as_test_x conftest$ac_exeext; then ! ac_cv_lib_metis_METIS_NodeND=yes ! else ! echo "$as_me: failed program was:" >&5 ! sed 's/^/| /' conftest.$ac_ext >&5 ! ! ac_cv_lib_metis_METIS_NodeND=no ! fi ! ! rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ ! conftest$ac_exeext conftest.$ac_ext ! LIBS=$ac_check_lib_save_LIBS ! fi ! { echo "$as_me:$LINENO: result: $ac_cv_lib_metis_METIS_NodeND" >&5 ! echo "${ECHO_T}$ac_cv_lib_metis_METIS_NodeND" >&6; } ! if test $ac_cv_lib_metis_METIS_NodeND = yes; then ! with_metis=yes ! else ! with_metis=no ! fi ! ! break ! else ! with_metis=no ! fi ! ! done ! ! ! if test "$with_metis" = yes; then ! ! cat >>confdefs.h <<\_ACEOF ! #define HAVE_METIS 1 ! _ACEOF ! ! { echo "$as_me:$LINENO: checking for cholmod_start in -lcholmod" >&5 ! echo $ECHO_N "checking for cholmod_start in -lcholmod... $ECHO_C" >&6; } ! if test "${ac_cv_lib_cholmod_cholmod_start+set}" = set; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 else ! ac_check_lib_save_LIBS=$LIBS ! LIBS="-lcholmod $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS -lmetis $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ ! ! /* Override any GCC internal prototype to avoid an error. ! Use char because int might match the return type of a GCC ! builtin and then its argument prototype would still apply. */ ! #ifdef __cplusplus ! extern "C" ! #endif ! char cholmod_start (); ! #ifdef F77_DUMMY_MAIN ! ! # ifdef __cplusplus ! extern "C" ! # endif ! int F77_DUMMY_MAIN() { return 1; } ! ! #endif ! int ! main () ! { ! return cholmod_start (); ! ; ! return 0; ! } _ACEOF ! rm -f conftest.$ac_objext conftest$ac_exeext ! if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 --- 15346,15373 ---- fi ac_res=`eval echo '${'$as_ac_Header'}'` { echo "$as_me:$LINENO: result: $ac_res" >&5 ! echo "${ECHO_T}$ac_res" >&6; } else ! # Is the header compilable? ! { echo "$as_me:$LINENO: checking $ac_header usability" >&5 ! echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ ! $ac_includes_default ! #include <$ac_header> _ACEOF ! rm -f conftest.$ac_objext ! if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 *************** *** 16117,16220 **** (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err ! } && test -s conftest$ac_exeext && ! $as_test_x conftest$ac_exeext; then ! ac_cv_lib_cholmod_cholmod_start=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ! ac_cv_lib_cholmod_cholmod_start=no fi ! rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ ! conftest$ac_exeext conftest.$ac_ext ! LIBS=$ac_check_lib_save_LIBS ! fi ! { echo "$as_me:$LINENO: result: $ac_cv_lib_cholmod_cholmod_start" >&5 ! echo "${ECHO_T}$ac_cv_lib_cholmod_cholmod_start" >&6; } ! if test $ac_cv_lib_cholmod_cholmod_start = yes; then ! CHOLMOD_LIBS="-lcholmod -lmetis"; ! with_cholmod=yes ! else ! { echo "$as_me:$LINENO: checking for cholmod_start in -lcholmod" >&5 ! echo $ECHO_N "checking for cholmod_start in -lcholmod... $ECHO_C" >&6; } ! if test "${ac_cv_lib_cholmod_cholmod_start+set}" = set; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! ac_check_lib_save_LIBS=$LIBS ! LIBS="-lcholmod $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS -lmetis $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ ! ! /* Override any GCC internal prototype to avoid an error. ! Use char because int might match the return type of a GCC ! builtin and then its argument prototype would still apply. */ ! #ifdef __cplusplus ! extern "C" ! #endif ! char cholmod_start (); ! #ifdef F77_DUMMY_MAIN ! ! # ifdef __cplusplus ! extern "C" ! # endif ! int F77_DUMMY_MAIN() { return 1; } ! ! #endif ! int ! main () ! { ! return cholmod_start (); ! ; ! return 0; ! } _ACEOF ! rm -f conftest.$ac_objext conftest$ac_exeext ! if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } && { ! test -z "$ac_c_werror_flag" || test ! -s conftest.err ! } && test -s conftest$ac_exeext && ! $as_test_x conftest$ac_exeext; then ! ac_cv_lib_cholmod_cholmod_start=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ! ac_cv_lib_cholmod_cholmod_start=no fi ! rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ ! conftest$ac_exeext conftest.$ac_ext ! LIBS=$ac_check_lib_save_LIBS ! fi ! { echo "$as_me:$LINENO: result: $ac_cv_lib_cholmod_cholmod_start" >&5 ! echo "${ECHO_T}$ac_cv_lib_cholmod_cholmod_start" >&6; } ! if test $ac_cv_lib_cholmod_cholmod_start = yes; then ! CHOLMOD_LIBS="-lcholmod -cblas -lmetis"; with_cholmod=yes fi fi ! else ! { echo "$as_me:$LINENO: checking for cholmod_start in -lcholmod" >&5 echo $ECHO_N "checking for cholmod_start in -lcholmod... $ECHO_C" >&6; } if test "${ac_cv_lib_cholmod_cholmod_start+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 --- 15376,15476 ---- (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err ! } && test -s conftest.$ac_objext; then ! ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ! ac_header_compiler=no fi ! rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ! { echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 ! echo "${ECHO_T}$ac_header_compiler" >&6; } ! # Is the header present? ! { echo "$as_me:$LINENO: checking $ac_header presence" >&5 ! echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ ! #include <$ac_header> _ACEOF ! if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 ! (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 ! (exit $ac_status); } >/dev/null && { ! test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err ! }; then ! ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ! ac_header_preproc=no fi ! rm -f conftest.err conftest.$ac_ext ! { echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 ! echo "${ECHO_T}$ac_header_preproc" >&6; } ! ! # So? What about this header? ! case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in ! yes:no: ) ! { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 ! echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 ! echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ! ac_header_preproc=yes ! ;; ! no:yes:* ) ! { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 ! echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 ! echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 ! echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 ! echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 ! echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} ! { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 ! echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ! ! ;; ! esac ! { echo "$as_me:$LINENO: checking for $ac_header" >&5 ! echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } ! if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then ! echo $ECHO_N "(cached) $ECHO_C" >&6 ! else ! eval "$as_ac_Header=\$ac_header_preproc" fi + ac_res=`eval echo '${'$as_ac_Header'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 + echo "${ECHO_T}$ac_res" >&6; } fi + if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF + #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 + _ACEOF ! { echo "$as_me:$LINENO: checking for cholmod_start in -lcholmod" >&5 echo $ECHO_N "checking for cholmod_start in -lcholmod... $ECHO_C" >&6; } if test "${ac_cv_lib_cholmod_cholmod_start+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 *************** *** 16285,16294 **** echo "${ECHO_T}$ac_cv_lib_cholmod_cholmod_start" >&6; } if test $ac_cv_lib_cholmod_cholmod_start = yes; then CHOLMOD_LIBS="-lcholmod"; ! with_cholmod=yes else ! { echo "$as_me:$LINENO: checking for cholmod_start in -lcholmod" >&5 echo $ECHO_N "checking for cholmod_start in -lcholmod... $ECHO_C" >&6; } if test "${ac_cv_lib_cholmod_cholmod_start+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 --- 15541,15550 ---- echo "${ECHO_T}$ac_cv_lib_cholmod_cholmod_start" >&6; } if test $ac_cv_lib_cholmod_cholmod_start = yes; then CHOLMOD_LIBS="-lcholmod"; ! with_cholmod=yes else ! { echo "$as_me:$LINENO: checking for cholmod_start in -lcholmod" >&5 echo $ECHO_N "checking for cholmod_start in -lcholmod... $ECHO_C" >&6; } if test "${ac_cv_lib_cholmod_cholmod_start+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 *************** *** 16359,16370 **** echo "${ECHO_T}$ac_cv_lib_cholmod_cholmod_start" >&6; } if test $ac_cv_lib_cholmod_cholmod_start = yes; then CHOLMOD_LIBS="-lcholmod -cblas"; ! with_cholmod=yes fi fi - fi if test "$with_cholmod" = yes; then --- 15615,15625 ---- echo "${ECHO_T}$ac_cv_lib_cholmod_cholmod_start" >&6; } if test $ac_cv_lib_cholmod_cholmod_start = yes; then CHOLMOD_LIBS="-lcholmod -cblas"; ! with_cholmod=yes fi fi if test "$with_cholmod" = yes; then *************** *** 23380,23385 **** --- 22635,22745 ---- ;; esac + { echo "$as_me:$LINENO: checking whether strptime is broken" >&5 + echo $ECHO_N "checking whether strptime is broken... $ECHO_C" >&6; } + if test "${octave_cv_strptime_broken+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + + if test "$cross_compiling" = yes; then + { { echo "$as_me:$LINENO: error: cannot run test program while cross compiling + See \`config.log' for more details." >&5 + echo "$as_me: error: cannot run test program while cross compiling + See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + #define _XOPEN_SOURCE + #if defined (HAVE_SYS_TYPES_H) + #include + #if defined (HAVE_UNISTD_H) + #include + #endif + #endif + #include + #include + + #ifdef F77_DUMMY_MAIN + + # ifdef __cplusplus + extern "C" + # endif + int F77_DUMMY_MAIN() { return 1; } + + #endif + int + main () + { + + struct tm t; + char *q = strptime ("09/13", "%m/%d/%y", &t); + return q ? 1 : 0; + + ; + return 0; + } + _ACEOF + rm -f conftest$ac_exeext + if { (ac_try="$ac_link" + case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; + esac + eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; + esac + eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + octave_cv_strptime_broken=no + else + echo "$as_me: program exited with status $ac_status" >&5 + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ( exit $ac_status ) + octave_cv_strptime_broken=yes + fi + rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext + fi + + + fi + { echo "$as_me:$LINENO: result: $octave_cv_strptime_broken" >&5 + echo "${ECHO_T}$octave_cv_strptime_broken" >&6; } + if test $octave_cv_strptime_broken = yes; then + + cat >>confdefs.h <<\_ACEOF + #define OCTAVE_HAVE_BROKEN_STRPTIME 1 + _ACEOF + + fi + ac_ext=c + ac_cpp='$CPP $CPPFLAGS' + ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' + ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' + ac_compiler_gnu=$ac_cv_c_compiler_gnu + + { echo "$as_me:$LINENO: checking whether putenv uses malloc" >&5 echo $ECHO_N "checking whether putenv uses malloc... $ECHO_C" >&6; } if test "${octave_cv_func_putenv_malloc+set}" = set; then *************** *** 29748,29755 **** FFLAGS!$FFLAGS$ac_delim ac_ct_F77!$ac_ct_F77$ac_delim FLIBS!$FLIBS$ac_delim - F2C!$F2C$ac_delim - F2CFLAGS!$F2CFLAGS$ac_delim F77_TOLOWER!$F77_TOLOWER$ac_delim F77_APPEND_UNDERSCORE!$F77_APPEND_UNDERSCORE$ac_delim F77_APPEND_EXTRA_UNDERSCORE!$F77_APPEND_EXTRA_UNDERSCORE$ac_delim --- 29108,29113 ---- *************** *** 29824,29829 **** --- 29182,29189 ---- INSTALL_PROGRAM!$INSTALL_PROGRAM$ac_delim INSTALL_SCRIPT!$INSTALL_SCRIPT$ac_delim INSTALL_DATA!$INSTALL_DATA$ac_delim + DESKTOP_FILE_INSTALL!$DESKTOP_FILE_INSTALL$ac_delim + GNUPLOT_BINARY!$GNUPLOT_BINARY$ac_delim _ACEOF if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then *************** *** 29865,29872 **** ac_delim='%!_!# ' for ac_last_try in false false false false false :; do cat >conf$$subs.sed <<_ACEOF - DESKTOP_FILE_INSTALL!$DESKTOP_FILE_INSTALL$ac_delim - GNUPLOT_BINARY!$GNUPLOT_BINARY$ac_delim DEFAULT_PAGER!$DEFAULT_PAGER$ac_delim GPERF!$GPERF$ac_delim GHOSTSCRIPT!$GHOSTSCRIPT$ac_delim --- 29225,29230 ---- *************** *** 29881,29887 **** LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF ! if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 14; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 --- 29239,29245 ---- LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF ! if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 12; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 *************** *** 30587,30598 **** fi fi - if test -n "$warn_f2c_and_f77"; then - { echo "$as_me:$LINENO: WARNING: $warn_f2c_and_f77" >&5 - echo "$as_me: WARNING: $warn_f2c_and_f77" >&2;} - warn_msg_printed=true - fi - if test -n "$gxx_only"; then { echo "$as_me:$LINENO: WARNING: $gxx_only" >&5 echo "$as_me: WARNING: $gxx_only" >&2;} --- 29945,29950 ---- *************** *** 30611,30622 **** warn_msg_printed=true fi - if test -n "$warn_f2c_no_lib"; then - { echo "$as_me:$LINENO: WARNING: $warn_f2c_no_lib" >&5 - echo "$as_me: WARNING: $warn_f2c_no_lib" >&2;} - warn_msg_printed=true - fi - if test -n "$warn_readline"; then { echo "$as_me:$LINENO: WARNING: $warn_readline" >&5 echo "$as_me: WARNING: $warn_readline" >&2;} --- 29963,29968 ---- diff -cNr octave-2.9.15/configure.in octave-2.9.16/configure.in *** octave-2.9.15/configure.in Fri Oct 12 17:27:12 2007 --- octave-2.9.16/configure.in Wed Oct 31 17:26:39 2007 *************** *** 119,147 **** config_opts=$ac_configure_args AC_SUBST(config_opts) - ### Allow the user to force us to use f2c. - - AC_ARG_WITH(f2c, - [AS_HELP_STRING([--with-f2c], - [use f2c even if Fortran compiler is available])], - [if test "$withval" = no; then use_f2c=false; else use_f2c=true; fi], - use_f2c=false) - - ### Allow the user to force us to use f77. - - AC_ARG_WITH(f77, - [AS_HELP_STRING([--with-f77], [use f77 to compile Fortran subroutines])], - [if test "$withval" = no; then use_f77=false; else use_f77=true; fi], - use_f77=false) - - ### Make sure only one of the above options for Fortran compilers was - ### specified (multiple "no" or --without-FOO options are ok). - - OCTAVE_CHECK_EXCLUSIVE_WITH_OPTIONS(f77, f2c, - [warn_f2c_and_f77="--with-f2c and --with-f77 both specified! Using f77..." - AC_MSG_WARN($warn_f2c_and_f77) - use_f2c=false]) - ### Make it possible to have Octave's array and matrix classes do bounds ### checking on element references. This slows some operations down a ### bit, so it is turned off by default. --- 119,124 ---- *************** *** 149,155 **** BOUNDS_CHECKING=false AC_ARG_ENABLE(bounds-check, [AS_HELP_STRING([--enable-bounds-check], ! [for internal array classes (default is no)])], [if test "$enableval" = yes; then BOUNDS_CHECKING=true; fi], []) if $BOUNDS_CHECKING; then AC_DEFINE(BOUNDS_CHECKING, 1, [Define to use internal bounds checking.]) --- 126,132 ---- BOUNDS_CHECKING=false AC_ARG_ENABLE(bounds-check, [AS_HELP_STRING([--enable-bounds-check], ! [bounds checking for indexing in internal array classes (default is no)])], [if test "$enableval" = yes; then BOUNDS_CHECKING=true; fi], []) if $BOUNDS_CHECKING; then AC_DEFINE(BOUNDS_CHECKING, 1, [Define to use internal bounds checking.]) *************** *** 661,826 **** # ---------------------------------------------------------------------- - ### We need these before trying to find libf2c. - OCTAVE_PROG_AR AC_PROG_RANLIB ! ### If we haven't been forced to use a particular Fortran compiler, ! ### try to find one using any one of several common Un*x Fortran ! ### compiler names using the AC_PROG_F77 macro. ! ### ! ### The configure options --with-f77 or --with-f2c ! ### force f77 or f2c to be used. It is also possible to use ! ### these options to specify the name of the compiler. For example, ! ### `--with-f77=g77' says that we are using g77 as the Fortran compiler. ! ! if $use_f77; then ! if test "$with_f77" = yes; then ! F77=f77 ! else ! F77="$with_f77" ! fi ! AC_MSG_NOTICE([defining F77 to be $F77]) ! elif $use_f2c; then ! F77= ! if test "$with_f2c" = yes; then ! F2C=f2c ! else ! F2C="$with_f2c" ! fi ! AC_MSG_NOTICE([defining F2C to be $F2C]) ! fi ! if test "x$FFLAGS" = x; then ! FFLAGS="-O" # override -g -O default by AC_PROG_F77 fi ! # the F77 variable, if set, overrides AC_PROG_F77 automatically AC_PROG_F77 ! ! have_fortran_compiler=false ! have_f2c=false F77_TOLOWER=true F77_APPEND_UNDERSCORE=true F77_APPEND_EXTRA_UNDERSCORE=true - if $use_f2c; then - have_f2c=true - else - if test -n "$F77"; then - AC_F77_LIBRARY_LDFLAGS - AC_F77_DUMMY_MAIN - AC_F77_WRAPPERS - case "$ac_cv_f77_mangling" in - "upper case") F77_TOLOWER=false ;; - esac - case "$ac_cv_f77_mangling" in - "no underscore") F77_APPEND_UNDERSCORE=false ;; - esac - case "$ac_cv_f77_mangling" in - "no extra underscore") F77_APPEND_EXTRA_UNDERSCORE=false ;; - esac ! case "$canonical_host_type" in ! i[[3456789]]86-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ! OCTAVE_F77_FLAG(-mieee-fp) ! ### OCTAVE_F77_FLAG(-ffloat-store) ! fi ! ;; ! alpha*-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ! OCTAVE_F77_FLAG(-mieee) ! else ! OCTAVE_F77_FLAG(-ieee) ! OCTAVE_F77_FLAG(-fpe1) ! fi ! ;; ! powerpc-apple-machten*) ! FFLAGS= ! ;; ! esac ! if test -n "$FFLAGS"; then ! AC_MSG_NOTICE([defining FFLAGS to be $FFLAGS]) fi ! have_fortran_compiler=true ! else ! AC_CHECK_PROG(F2C, f2c, f2c, []) ! AC_ARG_VAR(F2C, [Fortran to C translator command]) ! AC_ARG_VAR(F2CFLAGS, [Fortran to C translator flags]) ! if test -n "$F2C"; then ! have_f2c=true fi ! fi fi AC_SUBST(F77_TOLOWER) AC_SUBST(F77_APPEND_UNDERSCORE) AC_SUBST(F77_APPEND_EXTRA_UNDERSCORE) ! f77_rules_frag=/dev/null ! if $have_fortran_compiler; then ! f77_rules_frag=Makefrag.f77 ! cat << \EOF > $f77_rules_frag ! ! %.c : %.f ! ! %.o : %.f ! $(FC) -c $(ALL_FFLAGS) -o $@ $< ! ! pic/%.o : %.f ! $(FC) -c $(FPICFLAG) $(ALL_FFLAGS) $< -o $@ ! ! EOF ! elif $have_f2c; then ! AC_DEFINE(HAVE_F2C, 1, [Define if we are using f2c.]) ! ! ### FIXME -- these shouldn't be fixed names, eh? ! ! oct_conflib=libconflib.a ! oct_obj_ext=o ! ! CONFLIB_ARG= ! if AC_TRY_EVAL(ac_compile); then ! $AR $ARFLAGS $oct_conflib conftest.$oct_obj_ext 1>&AS_MESSAGE_LOG_FD() ! if test -n "$RANLIB"; then ! $RANLIB $oct_conflib 1>&AS_MESSAGE_LOG_FD() ! fi ! CONFLIB_ARG="-L. -lconflib" ! fi ! rm -f conftest* ! case "$canonical_host_type" in ! *-*-msdosmsvc) ! CONFLIB_ARG="-MD" ! ;; ! esac ! AC_CHECK_LIB(f2c, f_open, FLIBS=-lf2c, FLIBS=, $CONFLIB_ARG) ! rm -f $oct_conflib ! ! if test -z "$FLIBS"; then ! AC_CHECK_LIB(F77, d_sin, FLIBS=-lF77, FLIBS=) ! if test -n "$FLIBS"; then ! AC_CHECK_LIB(I77, f_rew, FLIBS="$FLIBS -lI77", FLIBS=, -lF77) ! fi ! fi ! ! if test -z "$FLIBS"; then ! warn_f2c_no_lib="I found f2c but not libf2c.a, or libF77.a and libI77.a" ! AC_MSG_WARN($warn_f2c_no_lib) ! fi ! f77_rules_frag=Makefrag.f77 ! cat << \EOF > $f77_rules_frag ! ! %.c : %.f ! $(F2C) $(F2CFLAGS) < $< > $(@F) ! ! %.o : %.f ! ! EOF ! else AC_MSG_WARN([in order to build octave, you must have a compatible]) ! AC_MSG_WARN([Fortran compiler or f2c installed and in your path.]) AC_MSG_ERROR([See the file INSTALL for more information.]) fi --- 638,704 ---- # ---------------------------------------------------------------------- OCTAVE_PROG_AR AC_PROG_RANLIB ! ## Default FFLAGS is -O. if test "x$FFLAGS" = x; then ! FFLAGS="-O" fi ! ## the F77 variable, if set, overrides AC_PROG_F77 automatically AC_PROG_F77 ! AC_F77_LIBRARY_LDFLAGS ! AC_F77_DUMMY_MAIN ! AC_F77_WRAPPERS F77_TOLOWER=true F77_APPEND_UNDERSCORE=true F77_APPEND_EXTRA_UNDERSCORE=true ! case "$ac_cv_f77_mangling" in ! "upper case") F77_TOLOWER=false ;; ! esac ! case "$ac_cv_f77_mangling" in ! "no underscore") F77_APPEND_UNDERSCORE=false ;; ! esac ! case "$ac_cv_f77_mangling" in ! "no extra underscore") F77_APPEND_EXTRA_UNDERSCORE=false ;; ! esac ! ! case "$canonical_host_type" in ! i[[3456789]]86-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ! OCTAVE_F77_FLAG(-mieee-fp) ! ### OCTAVE_F77_FLAG(-ffloat-store) fi ! ;; ! alpha*-*-*) ! if test "$ac_cv_f77_compiler_gnu" = yes; then ! OCTAVE_F77_FLAG(-mieee) ! else ! OCTAVE_F77_FLAG(-ieee) ! OCTAVE_F77_FLAG(-fpe1) fi ! ;; ! powerpc-apple-machten*) ! FFLAGS= ! ;; ! esac ! ! if test -n "$FFLAGS"; then ! AC_MSG_NOTICE([defining FFLAGS to be $FFLAGS]) fi + AC_SUBST(F77_TOLOWER) AC_SUBST(F77_APPEND_UNDERSCORE) AC_SUBST(F77_APPEND_EXTRA_UNDERSCORE) ! if test -z "$F77"; then AC_MSG_WARN([in order to build octave, you must have a compatible]) ! AC_MSG_WARN([Fortran compiler or wrapper script for f2c that functions]) ! AC_MSG_WARN([as a Fortran compiler installed and in your path.]) AC_MSG_ERROR([See the file INSTALL for more information.]) fi *************** *** 853,858 **** --- 731,779 ---- AC_SUBST(BLAS_DIR) AC_SUBST(LAPACK_DIR) + dnl I see no clean way to do the following check with autoconf macros, + dnl hence the big mess. + + AC_MSG_CHECKING([BLAS library calling convention compatibility]) + cat << EOF > conftest.f + program foo + double complex zdotu, zx(10), zy(10), retval + integer n, incx, incy + n = 10 + incx = 1 + incy = 1 + do 10 i = 1, n + zx(i) = dcmplx (i, 0) + zy(i) = dcmplx (0, i) + 10 continue + retval = zdotu (n, zx, incx, zy, incy) + if (retval .eq. dcmplx (0, 385)) then + print *, 'succeeded' + else + print *, 'failed' + print *, retval + endif + end + EOF + XLIBS="$LIBS" + LIBS="$BLAS_LIBS $FLIBS $LIBS" + AC_LANG_PUSH(Fortran 77) + (eval "$ac_compile"; eval "$ac_link") 2>&AS_MESSAGE_LOG_FD + AC_LANG_POP(Fortran 77) + LIBS="$XLIBS" + case "`./conftest$ac_exeext`" in + *succeeded*) + AC_MSG_RESULT(yes) + ;; + *) + AC_MSG_RESULT(no) + AC_MSG_WARN([Your BLAS library was apparently compiled with a Fortran]) + AC_MSG_WARN([compiler that uses a different calling convention from]) + AC_MSG_WARN([the one used by the selected compiler, $F77.]) + AC_MSG_ERROR([You must correct this problem before building Octave.]) + ;; + esac + # Check for AMD library AMD_LIBS= AC_SUBST(AMD_LIBS) *************** *** 968,994 **** test "$with_ccolamd" = yes && test "$with_amd" = yes; then with_cholmod=no AC_CHECK_HEADERS([suitesparse/cholmod.h ufsparse/cholmod.h cholmod/cholmod.h cholmod.h], [ ! AC_CHECK_HEADERS([suitesparse/metis.h ufsparse/metis.h metis/metis.h metis.h], [ ! AC_CHECK_LIB(metis, METIS_NodeND, with_metis=yes, with_metis=no) ! break], ! with_metis=no) ! ! if test "$with_metis" = yes; then ! AC_DEFINE(HAVE_METIS, 1, [Define if the METIS library is used.]) ! AC_CHECK_LIB(cholmod, cholmod_start, [CHOLMOD_LIBS="-lcholmod -lmetis"; ! with_cholmod=yes], [ ! AC_CHECK_LIB(cholmod, cholmod_start, ! [CHOLMOD_LIBS="-lcholmod -cblas -lmetis"; with_cholmod=yes], [], ! $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS -lmetis)], ! $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS -lmetis) ! else ! AC_CHECK_LIB(cholmod, cholmod_start, [CHOLMOD_LIBS="-lcholmod"; ! with_cholmod=yes], [ ! AC_CHECK_LIB(cholmod, cholmod_start, [CHOLMOD_LIBS="-lcholmod -cblas"; ! with_cholmod=yes], [], ! $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS)], ! $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS) ! fi if test "$with_cholmod" = yes; then AC_DEFINE(HAVE_CHOLMOD, 1, [Define if the CHOLMOD library is used.]) --- 889,900 ---- test "$with_ccolamd" = yes && test "$with_amd" = yes; then with_cholmod=no AC_CHECK_HEADERS([suitesparse/cholmod.h ufsparse/cholmod.h cholmod/cholmod.h cholmod.h], [ ! AC_CHECK_LIB(cholmod, cholmod_start, [CHOLMOD_LIBS="-lcholmod"; ! with_cholmod=yes], [ ! AC_CHECK_LIB(cholmod, cholmod_start, [CHOLMOD_LIBS="-lcholmod -cblas"; ! with_cholmod=yes], [], ! $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS)], ! $CAMD_LIBS $AMD_LIBS $COLAMD_LIBS $CCOLAMD_LIBS $BLAS_LIBS $FLIBS) if test "$with_cholmod" = yes; then AC_DEFINE(HAVE_CHOLMOD, 1, [Define if the CHOLMOD library is used.]) *************** *** 1452,1457 **** --- 1358,1364 ---- ;; esac + OCTAVE_STRPTIME_BROKEN OCTAVE_SMART_PUTENV case "$canonical_host_type" in *************** *** 1983,1988 **** --- 1890,1897 ---- #define SIZEOF_OCTAVE_IDX_TYPE SIZEOF_INT #endif + #define OCTAVE_EMPTY_CPP_ARG + #include "oct-dlldefs.h" #include "oct-types.h" ]) *************** *** 2063,2073 **** fi fi - if test -n "$warn_f2c_and_f77"; then - AC_MSG_WARN($warn_f2c_and_f77) - warn_msg_printed=true - fi - if test -n "$gxx_only"; then AC_MSG_WARN($gxx_only) warn_msg_printed=true --- 1972,1977 ---- *************** *** 2083,2093 **** warn_msg_printed=true fi - if test -n "$warn_f2c_no_lib"; then - AC_MSG_WARN($warn_f2c_no_lib) - warn_msg_printed=true - fi - if test -n "$warn_readline"; then AC_MSG_WARN($warn_readline) warn_msg_printed=true --- 1987,1992 ---- diff -cNr octave-2.9.15/doc/ChangeLog octave-2.9.16/doc/ChangeLog *** octave-2.9.15/doc/ChangeLog Fri Oct 12 02:40:56 2007 --- octave-2.9.16/doc/ChangeLog Tue Oct 30 21:08:14 2007 *************** *** 1,3 **** --- 1,33 ---- + 2007-10-30 David Bateman + + * interpreter/dynamic.txi, interpreter/install.txi, + interpreter/stats.txi, interpreter/strings.txi, + interpreter/testfun.txi, interpreter/tips.txi: + Doc fixes for small book format. + + 2007-10-26 Michael Goffioul + + * interpreter/Makefile.in, faq/Makefile.in, liboctave/Makefile.in: + Use temporary renamed files instead of Don't use --output option + argument for texi2[dvi|pdf]. Use $(sepchar) for path element + separation when building TEXINPUTS. Remove use of UNSETCOMSPEC trick. + + 2007-10-22 Kim Hansen + + * interpreter/munge-texi.cc: Include and . + + 2007-10-19 David Bateman + + * refcard/refcard.tex: Update for 3.0. + + 2007-10-15 Søren Hauberg + + * interpreter/preface.txi, interpreter/basics.txi, + interpreter/strings.txi, interpreter/container.txi, + interpreter/var.txi, interpreter/expr.txi, interpreter/errors.txi, + interpreter/io.txi, interpreter/func.txi, interpreter/package.txi: + Make text fit on pages when using smallbook. + 2007-10-12 John W. Eaton * Change copyright notices in all files that are part of Octave to *************** *** 828,834 **** 2003-05-14 John W. Eaton ! * interpreter/Makefile.in, doc/liboctave/Makefile.in: Handle DESTDIR. 2003-02-19 John W. Eaton --- 858,864 ---- 2003-05-14 John W. Eaton ! * interpreter/Makefile.in, liboctave/Makefile.in: Handle DESTDIR. 2003-02-19 John W. Eaton diff -cNr octave-2.9.15/doc/conf.texi octave-2.9.16/doc/conf.texi *** octave-2.9.15/doc/conf.texi Sat Oct 13 11:10:13 2007 --- octave-2.9.16/doc/conf.texi Wed Oct 31 18:08:45 2007 *************** *** 20,26 **** @set top_srcdir .. @set abs_top_srcdir /tmp/jwe/octave @set OCTAVEHOME /usr/local ! @set VERSION 2.9.15 @set HAVE_COLAMD @set HAVE_CHOLMOD @set HAVE_UMFPACK --- 20,26 ---- @set top_srcdir .. @set abs_top_srcdir /tmp/jwe/octave @set OCTAVEHOME /usr/local ! @set VERSION 2.9.16 @set HAVE_COLAMD @set HAVE_CHOLMOD @set HAVE_UMFPACK diff -cNr octave-2.9.15/doc/faq/Makefile.in octave-2.9.16/doc/faq/Makefile.in *** octave-2.9.15/doc/faq/Makefile.in Fri Oct 12 17:27:12 2007 --- octave-2.9.16/doc/faq/Makefile.in Fri Oct 26 14:22:05 2007 *************** *** 54,67 **** Octave-FAQ.dvi: $(TEXINFO) -TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(UNSETCOMSPEC) $(TEXI2DVI) $< Octave-FAQ.ps: Octave-FAQ.dvi -dvips -o $@ $< Octave-FAQ.pdf: $(TEXINFO) -TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(UNSETCOMSPEC) $(TEXI2PDF) $< Octave-FAQ.html: $(TEXINFO) -$(MAKEINFO) --html --ifinfo --no-split --output=$@ -I.. -I$(srcdir) -I$(srcdir)/.. $< --- 54,67 ---- Octave-FAQ.dvi: $(TEXINFO) -TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(TEXI2DVI) $< Octave-FAQ.ps: Octave-FAQ.dvi -dvips -o $@ $< Octave-FAQ.pdf: $(TEXINFO) -TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(TEXI2PDF) $< Octave-FAQ.html: $(TEXINFO) -$(MAKEINFO) --html --ifinfo --no-split --output=$@ -I.. -I$(srcdir) -I$(srcdir)/.. $< Binary files octave-2.9.15/doc/faq/Octave-FAQ.pdf and octave-2.9.16/doc/faq/Octave-FAQ.pdf differ Binary files octave-2.9.15/doc/interpreter/HTML/errorbar.png and octave-2.9.16/doc/interpreter/HTML/errorbar.png differ Binary files octave-2.9.15/doc/interpreter/HTML/grid.png and octave-2.9.16/doc/interpreter/HTML/grid.png differ Binary files octave-2.9.15/doc/interpreter/HTML/griddata.png and octave-2.9.16/doc/interpreter/HTML/griddata.png differ Binary files octave-2.9.15/doc/interpreter/HTML/hist.png and octave-2.9.16/doc/interpreter/HTML/hist.png differ Binary files octave-2.9.15/doc/interpreter/HTML/interpn.png and octave-2.9.16/doc/interpreter/HTML/interpn.png differ Binary files octave-2.9.15/doc/interpreter/HTML/mesh.png and octave-2.9.16/doc/interpreter/HTML/mesh.png differ Binary files octave-2.9.15/doc/interpreter/HTML/plot3.png and octave-2.9.16/doc/interpreter/HTML/plot3.png differ diff -cNr octave-2.9.15/doc/interpreter/Makefile.in octave-2.9.16/doc/interpreter/Makefile.in *** octave-2.9.15/doc/interpreter/Makefile.in Fri Oct 12 17:27:12 2007 --- octave-2.9.16/doc/interpreter/Makefile.in Fri Oct 26 14:22:05 2007 *************** *** 111,121 **** TEXINFO := $(TEXINFO_SOURCE) ../conf.texi ! TEXI2DVICOMMAND = TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(UNSETCOMSPEC) $(TEXI2DVI) $(MAIN_TEXINFO) --output $@ ! TEXI2PDFCOMMAND = TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(UNSETCOMSPEC) $(TEXI2PDF) $(MAIN_TEXINFO) --output $@ FORMATTED = octave.info octave.pdf octave-a4.pdf octave.info-[0-9]* --- 111,127 ---- TEXINFO := $(TEXINFO_SOURCE) ../conf.texi ! # Do not use --output option argument, because this is not supported ! # by MiKTeX (compilation under Windows/MSVC assumes the use of MiKTeX ! # to build the doc). Instead, copy the source .texi using the ! # targeted file name (e.g. to generate octave-a4.pdf, copy to ! # octave-a4.texi) and call texi2[dvi|pdf] on it. ! TEXI2DVICOMMAND = TEXINPUTS="..$(sepchar)$(srcdir)$(sepchar)$(srcdir)/..$(sepchar)$(TEXINPUTS)$(sepchar)" \ ! $(TEXI2DVI) ! ! TEXI2PDFCOMMAND = TEXINPUTS="..$(sepchar)$(srcdir)$(sepchar)$(srcdir)/..$(sepchar)$(TEXINPUTS)$(sepchar)" \ ! $(TEXI2PDF) FORMATTED = octave.info octave.pdf octave-a4.pdf octave.info-[0-9]* *************** *** 165,170 **** --- 171,182 ---- $(AWK) -f $(srcdir)/mkcontrib.awk $(srcdir)/contributors.in > $@-t @$(simple-move-if-change-rule) + octave-a4.texi: $(MAIN_TEXINFO) + cp $< $@ + + octave-smallbook.texi: $(MAIN_TEXINFO) + cp $< $@ + $(SUB_TEXINFO) : %.texi : %.txi @echo making $@ from $< @./munge-texi \ *************** *** 176,189 **** -$(MAKEINFO) -I.. -I$(srcdir) -I$(srcdir)/.. $(MAIN_TEXINFO) octave.dvi: $(IMAGES_EPS) $(TEXINFO) $(EXAMPLE_FILES) ! -TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(UNSETCOMSPEC) $(TEXI2DVI) $(MAIN_TEXINFO) ! octave-a4.dvi: $(IMAGES_EPS) $(TEXINFO) $(EXAMPLE_FILES) ! -$(TEXI2DVICOMMAND) -t @afourpaper ! octave-smallbook.dvi: $(IMAGES_EPS) $(TEXINFO) $(EXAMPLE_FILES) ! -$(TEXI2DVICOMMAND) -t @smallbook octave.ps: octave.dvi -dvips -o $@ $< --- 188,201 ---- -$(MAKEINFO) -I.. -I$(srcdir) -I$(srcdir)/.. $(MAIN_TEXINFO) octave.dvi: $(IMAGES_EPS) $(TEXINFO) $(EXAMPLE_FILES) ! -TEXINPUTS="..$(sepchar)$(srcdir)$(sepchar)$(srcdir)/..$(sepchar)$(TEXINPUTS)$(sepchar)" \ ! $(TEXI2DVI) $(MAIN_TEXINFO) ! octave-a4.dvi: $(IMAGES_EPS) $(TEXINFO) $(EXAMPLE_FILES) octave-a4.texi ! -$(TEXI2DVICOMMAND) octave-a4.texi -t @afourpaper ! octave-smallbook.dvi: $(IMAGES_EPS) $(TEXINFO) $(EXAMPLE_FILES) octave-smallbook.texi ! -$(TEXI2DVICOMMAND) octave-smallbook.texi -t @smallbook octave.ps: octave.dvi -dvips -o $@ $< *************** *** 195,207 **** -dvips -o $@ $< octave.pdf: $(IMAGES_PDF) $(TEXINFO) $(EXAMPLE_FILES) ! -$(TEXI2PDFCOMMAND) ! octave-a4.pdf: $(IMAGES_PDF) $(TEXINFO) $(EXAMPLE_FILES) ! -$(TEXI2PDFCOMMAND) -t @afourpaper ! octave-smallbook.pdf: $(IMAGES_PDF) $(TEXINFO) $(EXAMPLE_FILES) ! -$(TEXI2PDFCOMMAND) -t @smallbook ../../INSTALL.OCTAVE: install.texi rm -f INSTALL --- 207,219 ---- -dvips -o $@ $< octave.pdf: $(IMAGES_PDF) $(TEXINFO) $(EXAMPLE_FILES) ! -$(TEXI2PDFCOMMAND) $(MAIN_TEXINFO) ! octave-a4.pdf: $(IMAGES_PDF) $(TEXINFO) $(EXAMPLE_FILES) octave-a4.texi ! -$(TEXI2PDFCOMMAND) octave-a4.texi -t @afourpaper ! octave-smallbook.pdf: $(IMAGES_PDF) $(TEXINFO) $(EXAMPLE_FILES) octave-smallbook.texi ! -$(TEXI2PDFCOMMAND) octave-smallbook.texi -t @smallbook ../../INSTALL.OCTAVE: install.texi rm -f INSTALL *************** *** 318,324 **** octave.cps octave.fns octave.ins octave.kys octave.ops \ octave.pgs octave.rds octave.tps octave.vrs octave.aux \ octave.log octave.toc \ ! munge-texi$(BUILD_EXEEXT) munge-texi.o .PHONY: mostlyclean clean distclean: clean --- 330,346 ---- octave.cps octave.fns octave.ins octave.kys octave.ops \ octave.pgs octave.rds octave.tps octave.vrs octave.aux \ octave.log octave.toc \ ! munge-texi$(BUILD_EXEEXT) munge-texi.o \ ! octave-a4.cp octave-a4.fn octave-a4.in \ ! octave-a4.ky octave-a4.op octave-a4.pg octave-a4.rd octave-a4.tp octave-a4.vr \ ! octave-a4.cps octave-a4.fns octave-a4.ins octave-a4.kys octave-a4.ops \ ! octave-a4.pgs octave-a4.rds octave-a4.tps octave-a4.vrs octave-a4.aux \ ! octave-a4.log octave-a4.toc \ ! octave-smallbook.cp octave-smallbook.fn octave-smallbook.in \ ! octave-smallbook.ky octave-smallbook.op octave-smallbook.pg octave-smallbook.rd octave-smallbook.tp octave-smallbook.vr \ ! octave-smallbook.cps octave-smallbook.fns octave-smallbook.ins octave-smallbook.kys octave-smallbook.ops \ ! octave-smallbook.pgs octave-smallbook.rds octave-smallbook.tps octave-smallbook.vrs octave-smallbook.aux \ ! octave-smallbook.log octave-smallbook.toc .PHONY: mostlyclean clean distclean: clean *************** *** 332,338 **** .PHONY: maintainer-clean clean-texi: ! rm -f $(SUB_TEXINFO) contributors.texi .PHONY: clean-texi dist: clean-texi all --- 354,360 ---- .PHONY: maintainer-clean clean-texi: ! rm -f $(SUB_TEXINFO) contributors.texi octave-a4.texi octave-smallbook.texi .PHONY: clean-texi dist: clean-texi all diff -cNr octave-2.9.15/doc/interpreter/arith.texi octave-2.9.16/doc/interpreter/arith.texi *** octave-2.9.15/doc/interpreter/arith.texi Sat Oct 13 11:12:43 2007 --- octave-2.9.16/doc/interpreter/arith.texi Wed Oct 31 18:11:01 2007 *************** *** 68,76 **** error. Note that there are no guarantees on the order of the returned pairs with identical real parts but differing imaginary parts. ! @example cplxpair (exp(2i*pi*[0:4]'/5)) == exp(2i*pi*[3; 2; 4; 1; 0]/5) ! @end example @end deftypefn --- 68,77 ---- error. Note that there are no guarantees on the order of the returned pairs with identical real parts but differing imaginary parts. ! @c Using 'smallexample' to make text fit in page when using 'smallbook' ! @smallexample cplxpair (exp(2i*pi*[0:4]'/5)) == exp(2i*pi*[3; 2; 4; 1; 0]/5) ! @end smallexample @end deftypefn *************** *** 1035,1046 **** derivatives. @example ! K Function Scale factor (if a third argument is supplied) ! --- -------- ---------------------------------------------- ! 0 Ai (Z) exp ((2/3) * Z * sqrt (Z)) ! 1 dAi(Z)/dZ exp ((2/3) * Z * sqrt (Z)) ! 2 Bi (Z) exp (-abs (real ((2/3) * Z *sqrt (Z)))) ! 3 dBi(Z)/dZ exp (-abs (real ((2/3) * Z *sqrt (Z)))) @end example The function call @code{airy (@var{z})} is equivalent to --- 1036,1047 ---- derivatives. @example ! K Function Scale factor (if 'opt' is supplied) ! --- -------- --------------------------------------- ! 0 Ai (Z) exp ((2/3) * Z * sqrt (Z)) ! 1 dAi(Z)/dZ exp ((2/3) * Z * sqrt (Z)) ! 2 Bi (Z) exp (-abs (real ((2/3) * Z *sqrt (Z)))) ! 3 dBi(Z)/dZ exp (-abs (real ((2/3) * Z *sqrt (Z)))) @end example The function call @code{airy (@var{z})} is equivalent to diff -cNr octave-2.9.15/doc/interpreter/basics.texi octave-2.9.16/doc/interpreter/basics.texi *** octave-2.9.15/doc/interpreter/basics.texi Sat Oct 13 11:12:44 2007 --- octave-2.9.16/doc/interpreter/basics.texi Wed Oct 31 18:11:01 2007 *************** *** 189,203 **** @example @group ! PS1 = ">> " ! PS2 = "" ! beep_on_error = true ! crash_dumps_octave_core = false ! default_save_options = "-mat-binary" ! fixed_point_format = true ! history_timestamp_format_string = "%%-- %D %I:%M %p --%%" ! page_screen_output = false ! print_empty_dimensions = false @end group @end example --- 189,204 ---- @example @group ! PS1 = ">> " ! PS2 = "" ! beep_on_error = true ! crash_dumps_octave_core = false ! default_save_options = "-mat-binary" ! fixed_point_format = true ! history_timestamp_format_string ! = "%%-- %D %I:%M %p --%%" ! page_screen_output = false ! print_empty_dimensions = false @end group @end example *************** *** 205,213 **** and disable the following warnings @example @group ! Octave:fopen-file-in-path ! Octave:function-name-clash ! Octave:load-file-in-path @end group @end example --- 206,214 ---- and disable the following warnings @example @group ! Octave:fopen-file-in-path ! Octave:function-name-clash ! Octave:load-file-in-path @end group @end example *************** *** 1181,1194 **** @noindent Octave will respond with ! @example @group error: `x' undefined near line 1 column 24 error: evaluating expression near line 1, column 24 error: evaluating assignment expression near line 1, column 22 error: called from `f' @end group ! @end example @noindent This error message has several parts, and gives you quite a bit of --- 1182,1196 ---- @noindent Octave will respond with ! @c Using 'smallexample' to make text fit on page when creating smallbook. ! @smallexample @group error: `x' undefined near line 1 column 24 error: evaluating expression near line 1, column 24 error: evaluating assignment expression near line 1, column 22 error: called from `f' @end group ! @end smallexample @noindent This error message has several parts, and gives you quite a bit of diff -cNr octave-2.9.15/doc/interpreter/basics.txi octave-2.9.16/doc/interpreter/basics.txi *** octave-2.9.15/doc/interpreter/basics.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/basics.txi Mon Oct 15 11:30:03 2007 *************** *** 187,201 **** @example @group ! PS1 = ">> " ! PS2 = "" ! beep_on_error = true ! crash_dumps_octave_core = false ! default_save_options = "-mat-binary" ! fixed_point_format = true ! history_timestamp_format_string = "%%-- %D %I:%M %p --%%" ! page_screen_output = false ! print_empty_dimensions = false @end group @end example --- 187,202 ---- @example @group ! PS1 = ">> " ! PS2 = "" ! beep_on_error = true ! crash_dumps_octave_core = false ! default_save_options = "-mat-binary" ! fixed_point_format = true ! history_timestamp_format_string ! = "%%-- %D %I:%M %p --%%" ! page_screen_output = false ! print_empty_dimensions = false @end group @end example *************** *** 203,211 **** and disable the following warnings @example @group ! Octave:fopen-file-in-path ! Octave:function-name-clash ! Octave:load-file-in-path @end group @end example --- 204,212 ---- and disable the following warnings @example @group ! Octave:fopen-file-in-path ! Octave:function-name-clash ! Octave:load-file-in-path @end group @end example *************** *** 762,775 **** @noindent Octave will respond with ! @example @group error: `x' undefined near line 1 column 24 error: evaluating expression near line 1, column 24 error: evaluating assignment expression near line 1, column 22 error: called from `f' @end group ! @end example @noindent This error message has several parts, and gives you quite a bit of --- 763,777 ---- @noindent Octave will respond with ! @c Using 'smallexample' to make text fit on page when creating smallbook. ! @smallexample @group error: `x' undefined near line 1 column 24 error: evaluating expression near line 1, column 24 error: evaluating assignment expression near line 1, column 22 error: called from `f' @end group ! @end smallexample @noindent This error message has several parts, and gives you quite a bit of diff -cNr octave-2.9.15/doc/interpreter/container.texi octave-2.9.16/doc/interpreter/container.texi *** octave-2.9.15/doc/interpreter/container.texi Sat Oct 13 11:12:44 2007 --- octave-2.9.16/doc/interpreter/container.texi Wed Oct 31 18:11:01 2007 *************** *** 318,324 **** @example @group ! in = struct ('call1', @{x, Inf, 'last'@}, 'call2', @{x, Inf, 'first'@}); in (1, :) = [] @result{} in = @{ --- 318,325 ---- @example @group ! in = struct ("call1", @{x, Inf, "last"@}, ! "call2", @{x, Inf, "first"@}); in (1, :) = [] @result{} in = @{ *************** *** 351,357 **** @example @group ! struct ('field1', 1, 'field2', 2) @result{} ans = @{ field1 = 1 --- 352,358 ---- @example @group ! struct ("field1", 1, "field2", 2) @result{} ans = @{ field1 = 1 *************** *** 366,372 **** @example @group ! struct ('field1', @{1, 'one'@}, 'field2', @{2, 'two'@}, 'field3', 3); @result{} ans = @{ field1 = --- 367,374 ---- @example @group ! struct ("field1", @{1, "one"@}, "field2", @{2, "two"@}, ! "field3", 3) @result{} ans = @{ field1 = *************** *** 833,839 **** @example @group ! x = @{'1', '2'; '3', '4'@}; x@{1, :@} = [] @result{} x = @{ --- 835,841 ---- @example @group ! x = @{"1", "2"; "3", "4"@}; x@{1, :@} = [] @result{} x = @{ *************** *** 1047,1053 **** @example @group ! A = cell2struct (@{'Peter', 'Hannah', 'Robert'; 185, 170, 168@}, @{'Name','Height'@}, 1); A(1) @result{} ans = --- 1049,1056 ---- @example @group ! A = cell2struct (@{'Peter', 'Hannah', 'Robert'; ! 185, 170, 168@}, @{'Name','Height'@}, 1); A(1) @result{} ans = *************** *** 1078,1084 **** example @example ! [@var{i}, @var{j}] = ceil (find (@var{x}, [], 'last')); @end example @noindent --- 1081,1087 ---- example @example ! [@var{i}, @var{j}] = ceil (find (@var{x}, [], "last")); @end example @noindent *************** *** 1155,1162 **** @group in @{1@} = ceil (rand (10, 1)); in @{2@} = []; ! in @{3@} = 'last'; ! in @{4@} = 'first'; out = cell (4, 1); [out@{1:2@}] = find (in@{1 : 3@}); [out@{3:4@}] = find (in@{[1, 2, 4]@}); --- 1158,1165 ---- @group in @{1@} = ceil (rand (10, 1)); in @{2@} = []; ! in @{3@} = "last"; ! in @{4@} = "first"; out = cell (4, 1); [out@{1:2@}] = find (in@{1 : 3@}); [out@{3:4@}] = find (in@{[1, 2, 4]@}); *************** *** 1170,1177 **** @example @group x = ceil (randn (10, 1)); ! in = struct ('call1', @{x, Inf, 'last'@}, 'call2', @{x, Inf, 'first'@}); ! out = struct ('call1', cell (2, 1), 'call2', cell (2, 1)); [out.call1] = find (in.call1); [out.call2] = find (in.call2); @end group --- 1173,1181 ---- @example @group x = ceil (randn (10, 1)); ! in = struct ("call1", @{x, Inf, "last"@}, ! "call2", @{x, Inf, "first"@}); ! out = struct ("call1", cell (2, 1), "call2", cell (2, 1)); [out.call1] = find (in.call1); [out.call2] = find (in.call2); @end group diff -cNr octave-2.9.15/doc/interpreter/container.txi octave-2.9.16/doc/interpreter/container.txi *** octave-2.9.15/doc/interpreter/container.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/container.txi Mon Oct 15 11:31:21 2007 *************** *** 310,316 **** @example @group ! in = struct ('call1', @{x, Inf, 'last'@}, 'call2', @{x, Inf, 'first'@}); in (1, :) = [] @result{} in = @{ --- 310,317 ---- @example @group ! in = struct ("call1", @{x, Inf, "last"@}, ! "call2", @{x, Inf, "first"@}); in (1, :) = [] @result{} in = @{ *************** *** 343,349 **** @example @group ! struct ('field1', 1, 'field2', 2) @result{} ans = @{ field1 = 1 --- 344,350 ---- @example @group ! struct ("field1", 1, "field2", 2) @result{} ans = @{ field1 = 1 *************** *** 358,364 **** @example @group ! struct ('field1', @{1, 'one'@}, 'field2', @{2, 'two'@}, 'field3', 3); @result{} ans = @{ field1 = --- 359,366 ---- @example @group ! struct ("field1", @{1, "one"@}, "field2", @{2, "two"@}, ! "field3", 3) @result{} ans = @{ field1 = *************** *** 605,611 **** @example @group ! x = @{'1', '2'; '3', '4'@}; x@{1, :@} = [] @result{} x = @{ --- 607,613 ---- @example @group ! x = @{"1", "2"; "3", "4"@}; x@{1, :@} = [] @result{} x = @{ *************** *** 709,715 **** example @example ! [@var{i}, @var{j}] = ceil (find (@var{x}, [], 'last')); @end example @noindent --- 711,717 ---- example @example ! [@var{i}, @var{j}] = ceil (find (@var{x}, [], "last")); @end example @noindent *************** *** 786,793 **** @group in @{1@} = ceil (rand (10, 1)); in @{2@} = []; ! in @{3@} = 'last'; ! in @{4@} = 'first'; out = cell (4, 1); [out@{1:2@}] = find (in@{1 : 3@}); [out@{3:4@}] = find (in@{[1, 2, 4]@}); --- 788,795 ---- @group in @{1@} = ceil (rand (10, 1)); in @{2@} = []; ! in @{3@} = "last"; ! in @{4@} = "first"; out = cell (4, 1); [out@{1:2@}] = find (in@{1 : 3@}); [out@{3:4@}] = find (in@{[1, 2, 4]@}); *************** *** 801,808 **** @example @group x = ceil (randn (10, 1)); ! in = struct ('call1', @{x, Inf, 'last'@}, 'call2', @{x, Inf, 'first'@}); ! out = struct ('call1', cell (2, 1), 'call2', cell (2, 1)); [out.call1] = find (in.call1); [out.call2] = find (in.call2); @end group --- 803,811 ---- @example @group x = ceil (randn (10, 1)); ! in = struct ("call1", @{x, Inf, "last"@}, ! "call2", @{x, Inf, "first"@}); ! out = struct ("call1", cell (2, 1), "call2", cell (2, 1)); [out.call1] = find (in.call1); [out.call2] = find (in.call2); @end group diff -cNr octave-2.9.15/doc/interpreter/control.texi octave-2.9.16/doc/interpreter/control.texi *** octave-2.9.15/doc/interpreter/control.texi Sat Oct 13 11:12:44 2007 --- octave-2.9.16/doc/interpreter/control.texi Wed Oct 31 18:11:01 2007 *************** *** 46,52 **** @example @group octave:1> DEMOcontrol - O C T A V E C O N T R O L S Y S T E M S T O O L B O X Octave Controls System Toolbox Demo [ 1] System representation --- 46,51 ---- *************** *** 439,445 **** octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 --- 438,445 ---- octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, ... ! > @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 *************** *** 481,487 **** @anchor{doc-ss2sys} ! @deftypefn {Function File} {} ss (@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}, @var{n}, @var{nz}, @var{stname}, @var{inname}, @var{outname}, @var{outlist}) Create system structure from state-space data. May be continuous, discrete, or mixed (sampled data) --- 481,487 ---- @anchor{doc-ss2sys} ! @deftypefn {Function File} {} ss2sys (@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}, @var{n}, @var{nz}, @var{stname}, @var{inname}, @var{outname}, @var{outlist}) Create system structure from state-space data. May be continuous, discrete, or mixed (sampled data) *************** *** 604,610 **** octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 --- 604,611 ---- octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, ! > @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 *************** *** 1160,1167 **** @strong{Example} @example ! octave:1> sys=ss([1 2; 3 4],[5;6],[7 8]); ! octave:2> sys = syssetsignals(sys,"st",str2mat("Posx","Velx")); octave:3> sysout(sys) Input(s) 1: u_1 --- 1161,1169 ---- @strong{Example} @example ! octave:1> sys=ss ([1 2; 3 4],[5;6],[7 8]); ! octave:2> sys = syssetsignals (sys, "st", ! > str2mat("Posx","Velx")); octave:3> sysout(sys) Input(s) 1: u_1 *************** *** 1868,1878 **** @table @var @item retsys resulting open loop system: ! @example ----------- ------- ----------- u --->| inscale |--->| sys |--->| outscale |---> y ----------- ------- ----------- ! @end example @end table If the input names and output names (each a list of strings) are not given and the scaling matrices --- 1870,1880 ---- @table @var @item retsys resulting open loop system: ! @smallexample ----------- ------- ----------- u --->| inscale |--->| sys |--->| outscale |---> y ----------- ------- ----------- ! @end smallexample @end table If the input names and output names (each a list of strings) are not given and the scaling matrices *************** *** 3671,3677 **** @end example @end ifinfo ! @example @group +----+ --- 3673,3679 ---- @end example @end ifinfo ! @smallexample @group +----+ *************** *** 3687,3693 **** -----| K |<------- +---+ @end group ! @end example @iftex @tex --- 3689,3695 ---- -----| K |<------- +---+ @end group ! @end smallexample @iftex @tex *************** *** 3716,3722 **** @end ifinfo norm of the augmented plant @var{P} (mixed-sensitivity problem): ! @example @group w 1 -----------+ --- 3718,3724 ---- @end ifinfo norm of the augmented plant @var{P} (mixed-sensitivity problem): ! @smallexample @group w 1 -----------+ *************** *** 3733,3739 **** u y (to K) (from controller K) @end group ! @end example @iftex @tex --- 3735,3741 ---- u y (to K) (from controller K) @end group ! @end smallexample @iftex @tex *************** *** 3746,3752 **** @end tex @end iftex @ifinfo ! @example @group + + + + | z | | w | --- 3748,3754 ---- @end tex @end iftex @ifinfo ! @smallexample @group + + + + | z | | w | *************** *** 3756,3762 **** | y | | u | + + + + @end group ! @end example @end ifinfo @item Discrete system: --- 3758,3764 ---- | y | | u | + + + + @end group ! @end smallexample @end ifinfo @item Discrete system: *************** *** 3801,3807 **** @end example @end ifinfo ! @example @group +----+ --- 3803,3809 ---- @end example @end ifinfo ! @smallexample @group +----+ *************** *** 3817,3823 **** -----| K |<------- +---+ @end group ! @end example @iftex @tex $$ { \rm min } \Vert T_{vz} \Vert _\infty $$ --- 3819,3825 ---- -----| K |<------- +---+ @end group ! @end smallexample @iftex @tex $$ { \rm min } \Vert T_{vz} \Vert _\infty $$ *************** *** 4456,4463 **** @end example or @example ! x(k+1) = A x(k) + B u(k) + G w(k) [w]=N(0,[Sigw 0 ]) ! y(k) = C x(k) + v(k) [v] ( 0 Sigv ]) @end example @strong{Inputs} --- 4458,4465 ---- @end example or @example ! x(k+1) = A x(k) + B u(k) + G w(k) [w]=N(0,[Sigw 0 ]) ! y(k) = C x(k) + v(k) [v] ( 0 Sigv ]) @end example @strong{Inputs} diff -cNr octave-2.9.15/doc/interpreter/convhull.eps octave-2.9.16/doc/interpreter/convhull.eps *** octave-2.9.15/doc/interpreter/convhull.eps Sat Oct 13 11:11:05 2007 --- octave-2.9.16/doc/interpreter/convhull.eps Wed Oct 31 18:09:32 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: convhull.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:05 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: convhull.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:32 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:05 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:32 2007) /DOCINFO pdfmark end } ifelse diff -cNr octave-2.9.15/doc/interpreter/convhull.pdf octave-2.9.16/doc/interpreter/convhull.pdf *** octave-2.9.15/doc/interpreter/convhull.pdf Sat Oct 13 11:11:06 2007 --- octave-2.9.16/doc/interpreter/convhull.pdf Wed Oct 31 18:09:34 2007 *************** *** 59,66 **** endobj 2 0 obj <> startxref 3987 --- 80,86 ---- 0000003669 00000 n trailer << /Size 11 /Root 1 0 R /Info 2 0 R ! /ID [(þÊ{GxØõ±F&Ë{)(þÊ{GxØõ±F&Ë{)] >> startxref 3987 diff -cNr octave-2.9.15/doc/interpreter/debug.texi octave-2.9.16/doc/interpreter/debug.texi *** octave-2.9.15/doc/interpreter/debug.texi Sat Oct 13 11:12:44 2007 --- octave-2.9.16/doc/interpreter/debug.texi Wed Oct 31 18:11:02 2007 *************** *** 96,102 **** function. @anchor{doc-dbstop} ! @deftypefn {Loadable Function} {rline =} dbstop (func, line, @dots{}) Set a breakpoint in a function @table @code @item func --- 96,102 ---- function. @anchor{doc-dbstop} ! @deftypefn {Loadable Function} {rline =} dbstop (@var{func}, @var{line}, @dots{}) Set a breakpoint in a function @table @code @item func *************** *** 133,139 **** be queried with the @code{dbstatus} function. @anchor{doc-dbstatus} ! @deftypefn {Loadable Function} {lst =} dbstatus ([func]) Return a vector containing the lines on which a function has breakpoints set. @table @code --- 133,139 ---- be queried with the @code{dbstatus} function. @anchor{doc-dbstatus} ! @deftypefn {Loadable Function} {lst =} dbstatus (@var{func}) Return a vector containing the lines on which a function has breakpoints set. @table @code *************** *** 150,156 **** 27. The breakpoints can then be cleared with the @code{dbclear} function @anchor{doc-dbclear} ! @deftypefn {Loadable Function} {} dbclear (func, line, @dots{}) Delete a breakpoint in a function @table @code @item func --- 150,156 ---- 27. The breakpoints can then be cleared with the @code{dbclear} function @anchor{doc-dbclear} ! @deftypefn {Loadable Function} {} dbclear (@var{func}, @var{line}, @dots{}) Delete a breakpoint in a function @table @code @item func diff -cNr octave-2.9.15/doc/interpreter/delaunay.eps octave-2.9.16/doc/interpreter/delaunay.eps *** octave-2.9.15/doc/interpreter/delaunay.eps Sat Oct 13 11:11:07 2007 --- octave-2.9.16/doc/interpreter/delaunay.eps Wed Oct 31 18:09:34 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: delaunay.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:07 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: delaunay.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:34 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:07 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:34 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/delaunay.pdf and octave-2.9.16/doc/interpreter/delaunay.pdf differ diff -cNr octave-2.9.15/doc/interpreter/diffeq.texi octave-2.9.16/doc/interpreter/diffeq.texi *** octave-2.9.15/doc/interpreter/diffeq.texi Sat Oct 13 11:12:44 2007 --- octave-2.9.16/doc/interpreter/diffeq.texi Wed Oct 31 18:11:02 2007 *************** *** 189,195 **** The local error test applied at each integration step is @example ! abs (local error in x(i)) <= rtol * abs (y(i)) + atol(i) @end example @item "integration method" A string specifying the method of integration to use to solve the ODE --- 189,196 ---- The local error test applied at each integration step is @example ! abs (local error in x(i)) <= ... ! rtol * abs (y(i)) + atol(i) @end example @item "integration method" A string specifying the method of integration to use to solve the ODE *************** *** 695,701 **** The local error test applied at each integration step is @example ! abs (local error in x(i)) <= rtol(i) * abs (Y(i)) + atol(i) @end example @item "initial step size" Differential-algebraic problems may occasionally suffer from severe --- 696,703 ---- The local error test applied at each integration step is @example ! abs (local error in x(i)) <= ... ! rtol(i) * abs (Y(i)) + atol(i) @end example @item "initial step size" Differential-algebraic problems may occasionally suffer from severe diff -cNr octave-2.9.15/doc/interpreter/dynamic.texi octave-2.9.16/doc/interpreter/dynamic.texi *** octave-2.9.15/doc/interpreter/dynamic.texi Sat Oct 13 11:12:44 2007 --- octave-2.9.16/doc/interpreter/dynamic.texi Wed Oct 31 18:11:02 2007 *************** *** 455,461 **** In Octave a character string is just a special @code{Array} class. Consider the example ! @examplefile{stringdemo.cc} An example of the of the use of this function is --- 455,461 ---- In Octave a character string is just a special @code{Array} class. Consider the example ! @longexamplefile{stringdemo.cc} An example of the of the use of this function is *************** *** 483,491 **** @example @group if (args(0).is_sq_string ()) ! octave_stdout << "First argument is a singularly quoted string\n"; else if (args(0).is_dq_string ()) ! octave_stdout << "First argument is a doubly quoted string\n"; @end group @end example --- 483,493 ---- @example @group if (args(0).is_sq_string ()) ! octave_stdout << ! "First argument is a singularly quoted string\n"; else if (args(0).is_dq_string ()) ! octave_stdout << ! "First argument is a doubly quoted string\n"; @end group @end example *************** *** 544,550 **** A simple example demonstrating the use of structures within oct-files is ! @examplefile{structdemo.cc} An example of its use is --- 546,552 ---- A simple example demonstrating the use of structures within oct-files is ! @longexamplefile{structdemo.cc} An example of its use is *************** *** 833,839 **** @} sm.cidx(j+1) = ii; @} ! sm.maybe_compress (); // If don't know a-priori the final no of nz. @end group @end example --- 835,842 ---- @} sm.cidx(j+1) = ii; @} ! sm.maybe_compress (); // If don't know a-priori ! // the final no of nz. @end group @end example *************** *** 874,880 **** @} sm.cidx(j+1) = ii; @} ! sm.maybe_mutate (); // If don't know a-priori the final no of nz. @end group @end example --- 877,884 ---- @} sm.cidx(j+1) = ii; @} ! sm.maybe_mutate (); // If don't know a-priori ! // the final no of nz. @end group @end example *************** *** 898,904 **** octave_value_list retval; SparseMatrix sm = args(0).sparse_matrix_value (); ! SparseComplexMatrix scm = args(1).sparse_complex_matrix_value (); SparseBoolMatrix sbm = args(2).sparse_bool_matrix_value (); @dots{} retval(2) = sbm; --- 902,909 ---- octave_value_list retval; SparseMatrix sm = args(0).sparse_matrix_value (); ! SparseComplexMatrix scm = ! args(1).sparse_complex_matrix_value (); SparseBoolMatrix sbm = args(2).sparse_bool_matrix_value (); @dots{} retval(2) = sbm; *************** *** 922,928 **** that no global variable of the desired name is found. An example of the use of these two functions is ! @examplefile{globaldemo.cc} An example of its use is --- 927,933 ---- that no global variable of the desired name is found. An example of the use of these two functions is ! @longexamplefile{globaldemo.cc} An example of its use is *************** *** 961,967 **** The example below demonstrates an example that accepts all four means of passing a function to an oct-file. ! @examplefile{funcdemo.cc} The first argument to this demonstration is the user supplied function and the following arguments are all passed to the user function. --- 966,972 ---- The example below demonstrates an example that accepts all four means of passing a function to an oct-file. ! @longexamplefile{funcdemo.cc} The first argument to this demonstration is the user supplied function and the following arguments are all passed to the user function. *************** *** 1056,1067 **** An example of the inclusion of a Fortran function in an oct-file is given in the following example, where the C++ wrapper is ! @examplefile{fortdemo.cc} @noindent and the fortran function is ! @examplefile{fortsub.f} This example demonstrates most of the features needed to link to an external Fortran function, including passing arrays and strings, as well --- 1061,1072 ---- An example of the inclusion of a Fortran function in an oct-file is given in the following example, where the C++ wrapper is ! @longexamplefile{fortdemo.cc} @noindent and the fortran function is ! @longexamplefile{fortsub.f} This example demonstrates most of the features needed to link to an external Fortran function, including passing arrays and strings, as well *************** *** 1118,1124 **** more specialized functions. Some of the more common ones are demonstrated in the following example ! @examplefile{paramdemo.cc} @noindent and an example of its use is --- 1123,1129 ---- more specialized functions. Some of the more common ones are demonstrated in the following example ! @longexamplefile{paramdemo.cc} @noindent and an example of its use is *************** *** 1187,1193 **** to allow variables, etc to be restored even if an exception occurs. An example of the use of this mechanism is ! @examplefile{unwinddemo.cc} As can be seen in the example --- 1192,1198 ---- to allow variables, etc to be restored even if an exception occurs. An example of the use of this mechanism is ! @longexamplefile{unwinddemo.cc} As can be seen in the example *************** *** 1223,1230 **** DEFUN_DLD (do_what_i_want, args, nargout, "-*- texinfo -*-\n\ @@deftypefn @{Function File@} @{@} do_what_i_say (@@var@{n@})\n\ ! A function that does what the user actually wants rather than what\n\ ! they requested.\n\ @@end deftypefn") @{ @dots{} --- 1228,1235 ---- DEFUN_DLD (do_what_i_want, args, nargout, "-*- texinfo -*-\n\ @@deftypefn @{Function File@} @{@} do_what_i_say (@@var@{n@})\n\ ! A function that does what the user actually wants rather\n\ ! than what they requested.\n\ @@end deftypefn") @{ @dots{} *************** *** 1457,1463 **** double precision arrays is given by the file @file{mypow2.c} as given below. ! @examplefile{mypow2.c} @noindent with an example of its use --- 1462,1468 ---- double precision arrays is given by the file @file{mypow2.c} as given below. ! @longexamplefile{mypow2.c} @noindent with an example of its use *************** *** 1471,1478 **** @end example ! The example above uses the @code{mxGetNumberOfElements}, ! @code{mxGetNumberOfDimensions} and @code{mxGetDimensions}, to work with the dimensional parameters of multi-dimensional arrays. The also exists the functions @code{mxGetM}, and @code{mxGetN} that probe the number of rows and columns in a matrix. --- 1476,1483 ---- @end example ! The example above uses @code{mxGetDimensions}, ! @code{mxGetNumberOfElements}, @code{mxGetNumberOfDimensions}, to work with the dimensional parameters of multi-dimensional arrays. The also exists the functions @code{mxGetM}, and @code{mxGetN} that probe the number of rows and columns in a matrix. *************** *** 1486,1492 **** use, that parallels the demo in @file{stringdemo.cc}, is given in the file @file{mystring.c}, as seen below. ! @examplefile{mystring.c} @noindent An example of its expected output is --- 1491,1497 ---- use, that parallels the demo in @file{stringdemo.cc}, is given in the file @file{mystring.c}, as seen below. ! @longexamplefile{mystring.c} @noindent An example of its expected output is *************** *** 1560,1568 **** @example @group ! mxArray *mxCreateStructArray (int ndims, int *dims, int num_keys, const char **keys); ! mxArray *mxCreateStructMatrix (int rows, int cols, int num_keys, const char **keys); @end group @end example --- 1565,1575 ---- @example @group ! mxArray *mxCreateStructArray (int ndims, int *dims, ! int num_keys, const char **keys); ! mxArray *mxCreateStructMatrix (int rows, int cols, ! int num_keys, const char **keys); @end group @end example *************** *** 1573,1579 **** @example @group ! mxArray *mxGetField (const mxArray *ptr, mwIndex index, const char *key); mxArray *mxGetFieldByNumber (const mxArray *ptr, mwIndex index, int key_num); void mxSetField (mxArray *ptr, mwIndex index, --- 1580,1587 ---- @example @group ! mxArray *mxGetField (const mxArray *ptr, mwIndex index, ! const char *key); mxArray *mxGetFieldByNumber (const mxArray *ptr, mwIndex index, int key_num); void mxSetField (mxArray *ptr, mwIndex index, *************** *** 1592,1604 **** An example that demonstrates the use of structures in mex-file can be found in the file @file{mystruct.c}, as seen below ! @examplefile{mystruct.c} An example of the behavior of this function within Octave is then @example @group ! a(1).f1 = "f11"; a(1).f2 = "f12"; a(2).f1 = "f21"; a(2).f2 = "f22"; b = mystruct(a) @result{} field f1(0) = f11 field f1(1) = f21 --- 1600,1613 ---- An example that demonstrates the use of structures in mex-file can be found in the file @file{mystruct.c}, as seen below ! @longexamplefile{mystruct.c} An example of the behavior of this function within Octave is then @example @group ! a(1).f1 = "f11"; a(1).f2 = "f12"; ! a(2).f1 = "f21"; a(2).f2 = "f22"; b = mystruct(a) @result{} field f1(0) = f11 field f1(1) = f21 *************** *** 1691,1697 **** using @code{mexCallMATLAB}. An example of the use of @code{mexCallMATLAB} can be see in the example below ! @examplefile{myfeval.c} If this code is in the file @file{myfeval.c}, and is compiled to @file{myfeval.mex}, then an example of its use is --- 1700,1706 ---- using @code{mexCallMATLAB}. An example of the use of @code{mexCallMATLAB} can be see in the example below ! @longexamplefile{myfeval.c} If this code is in the file @file{myfeval.c}, and is compiled to @file{myfeval.mex}, then an example of its use is diff -cNr octave-2.9.15/doc/interpreter/dynamic.txi octave-2.9.16/doc/interpreter/dynamic.txi *** octave-2.9.15/doc/interpreter/dynamic.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/dynamic.txi Tue Oct 30 21:08:14 2007 *************** *** 353,359 **** In Octave a character string is just a special @code{Array} class. Consider the example ! @examplefile{stringdemo.cc} An example of the of the use of this function is --- 353,359 ---- In Octave a character string is just a special @code{Array} class. Consider the example ! @longexamplefile{stringdemo.cc} An example of the of the use of this function is *************** *** 381,389 **** @example @group if (args(0).is_sq_string ()) ! octave_stdout << "First argument is a singularly quoted string\n"; else if (args(0).is_dq_string ()) ! octave_stdout << "First argument is a doubly quoted string\n"; @end group @end example --- 381,391 ---- @example @group if (args(0).is_sq_string ()) ! octave_stdout << ! "First argument is a singularly quoted string\n"; else if (args(0).is_dq_string ()) ! octave_stdout << ! "First argument is a doubly quoted string\n"; @end group @end example *************** *** 442,448 **** A simple example demonstrating the use of structures within oct-files is ! @examplefile{structdemo.cc} An example of its use is --- 444,450 ---- A simple example demonstrating the use of structures within oct-files is ! @longexamplefile{structdemo.cc} An example of its use is *************** *** 731,737 **** @} sm.cidx(j+1) = ii; @} ! sm.maybe_compress (); // If don't know a-priori the final no of nz. @end group @end example --- 733,740 ---- @} sm.cidx(j+1) = ii; @} ! sm.maybe_compress (); // If don't know a-priori ! // the final no of nz. @end group @end example *************** *** 772,778 **** @} sm.cidx(j+1) = ii; @} ! sm.maybe_mutate (); // If don't know a-priori the final no of nz. @end group @end example --- 775,782 ---- @} sm.cidx(j+1) = ii; @} ! sm.maybe_mutate (); // If don't know a-priori ! // the final no of nz. @end group @end example *************** *** 796,802 **** octave_value_list retval; SparseMatrix sm = args(0).sparse_matrix_value (); ! SparseComplexMatrix scm = args(1).sparse_complex_matrix_value (); SparseBoolMatrix sbm = args(2).sparse_bool_matrix_value (); @dots{} retval(2) = sbm; --- 800,807 ---- octave_value_list retval; SparseMatrix sm = args(0).sparse_matrix_value (); ! SparseComplexMatrix scm = ! args(1).sparse_complex_matrix_value (); SparseBoolMatrix sbm = args(2).sparse_bool_matrix_value (); @dots{} retval(2) = sbm; *************** *** 820,826 **** that no global variable of the desired name is found. An example of the use of these two functions is ! @examplefile{globaldemo.cc} An example of its use is --- 825,831 ---- that no global variable of the desired name is found. An example of the use of these two functions is ! @longexamplefile{globaldemo.cc} An example of its use is *************** *** 859,865 **** The example below demonstrates an example that accepts all four means of passing a function to an oct-file. ! @examplefile{funcdemo.cc} The first argument to this demonstration is the user supplied function and the following arguments are all passed to the user function. --- 864,870 ---- The example below demonstrates an example that accepts all four means of passing a function to an oct-file. ! @longexamplefile{funcdemo.cc} The first argument to this demonstration is the user supplied function and the following arguments are all passed to the user function. *************** *** 954,965 **** An example of the inclusion of a Fortran function in an oct-file is given in the following example, where the C++ wrapper is ! @examplefile{fortdemo.cc} @noindent and the fortran function is ! @examplefile{fortsub.f} This example demonstrates most of the features needed to link to an external Fortran function, including passing arrays and strings, as well --- 959,970 ---- An example of the inclusion of a Fortran function in an oct-file is given in the following example, where the C++ wrapper is ! @longexamplefile{fortdemo.cc} @noindent and the fortran function is ! @longexamplefile{fortsub.f} This example demonstrates most of the features needed to link to an external Fortran function, including passing arrays and strings, as well *************** *** 1016,1022 **** more specialized functions. Some of the more common ones are demonstrated in the following example ! @examplefile{paramdemo.cc} @noindent and an example of its use is --- 1021,1027 ---- more specialized functions. Some of the more common ones are demonstrated in the following example ! @longexamplefile{paramdemo.cc} @noindent and an example of its use is *************** *** 1085,1091 **** to allow variables, etc to be restored even if an exception occurs. An example of the use of this mechanism is ! @examplefile{unwinddemo.cc} As can be seen in the example --- 1090,1096 ---- to allow variables, etc to be restored even if an exception occurs. An example of the use of this mechanism is ! @longexamplefile{unwinddemo.cc} As can be seen in the example *************** *** 1121,1128 **** DEFUN_DLD (do_what_i_want, args, nargout, "-*- texinfo -*-\n\ @@deftypefn @{Function File@} @{@} do_what_i_say (@@var@{n@})\n\ ! A function that does what the user actually wants rather than what\n\ ! they requested.\n\ @@end deftypefn") @{ @dots{} --- 1126,1133 ---- DEFUN_DLD (do_what_i_want, args, nargout, "-*- texinfo -*-\n\ @@deftypefn @{Function File@} @{@} do_what_i_say (@@var@{n@})\n\ ! A function that does what the user actually wants rather\n\ ! than what they requested.\n\ @@end deftypefn") @{ @dots{} *************** *** 1345,1351 **** double precision arrays is given by the file @file{mypow2.c} as given below. ! @examplefile{mypow2.c} @noindent with an example of its use --- 1350,1356 ---- double precision arrays is given by the file @file{mypow2.c} as given below. ! @longexamplefile{mypow2.c} @noindent with an example of its use *************** *** 1359,1366 **** @end example ! The example above uses the @code{mxGetNumberOfElements}, ! @code{mxGetNumberOfDimensions} and @code{mxGetDimensions}, to work with the dimensional parameters of multi-dimensional arrays. The also exists the functions @code{mxGetM}, and @code{mxGetN} that probe the number of rows and columns in a matrix. --- 1364,1371 ---- @end example ! The example above uses @code{mxGetDimensions}, ! @code{mxGetNumberOfElements}, @code{mxGetNumberOfDimensions}, to work with the dimensional parameters of multi-dimensional arrays. The also exists the functions @code{mxGetM}, and @code{mxGetN} that probe the number of rows and columns in a matrix. *************** *** 1374,1380 **** use, that parallels the demo in @file{stringdemo.cc}, is given in the file @file{mystring.c}, as seen below. ! @examplefile{mystring.c} @noindent An example of its expected output is --- 1379,1385 ---- use, that parallels the demo in @file{stringdemo.cc}, is given in the file @file{mystring.c}, as seen below. ! @longexamplefile{mystring.c} @noindent An example of its expected output is *************** *** 1448,1456 **** @example @group ! mxArray *mxCreateStructArray (int ndims, int *dims, int num_keys, const char **keys); ! mxArray *mxCreateStructMatrix (int rows, int cols, int num_keys, const char **keys); @end group @end example --- 1453,1463 ---- @example @group ! mxArray *mxCreateStructArray (int ndims, int *dims, ! int num_keys, const char **keys); ! mxArray *mxCreateStructMatrix (int rows, int cols, ! int num_keys, const char **keys); @end group @end example *************** *** 1461,1467 **** @example @group ! mxArray *mxGetField (const mxArray *ptr, mwIndex index, const char *key); mxArray *mxGetFieldByNumber (const mxArray *ptr, mwIndex index, int key_num); void mxSetField (mxArray *ptr, mwIndex index, --- 1468,1475 ---- @example @group ! mxArray *mxGetField (const mxArray *ptr, mwIndex index, ! const char *key); mxArray *mxGetFieldByNumber (const mxArray *ptr, mwIndex index, int key_num); void mxSetField (mxArray *ptr, mwIndex index, *************** *** 1480,1492 **** An example that demonstrates the use of structures in mex-file can be found in the file @file{mystruct.c}, as seen below ! @examplefile{mystruct.c} An example of the behavior of this function within Octave is then @example @group ! a(1).f1 = "f11"; a(1).f2 = "f12"; a(2).f1 = "f21"; a(2).f2 = "f22"; b = mystruct(a) @result{} field f1(0) = f11 field f1(1) = f21 --- 1488,1501 ---- An example that demonstrates the use of structures in mex-file can be found in the file @file{mystruct.c}, as seen below ! @longexamplefile{mystruct.c} An example of the behavior of this function within Octave is then @example @group ! a(1).f1 = "f11"; a(1).f2 = "f12"; ! a(2).f1 = "f21"; a(2).f2 = "f22"; b = mystruct(a) @result{} field f1(0) = f11 field f1(1) = f21 *************** *** 1579,1585 **** using @code{mexCallMATLAB}. An example of the use of @code{mexCallMATLAB} can be see in the example below ! @examplefile{myfeval.c} If this code is in the file @file{myfeval.c}, and is compiled to @file{myfeval.mex}, then an example of its use is --- 1588,1594 ---- using @code{mexCallMATLAB}. An example of the use of @code{mexCallMATLAB} can be see in the example below ! @longexamplefile{myfeval.c} If this code is in the file @file{myfeval.c}, and is compiled to @file{myfeval.mex}, then an example of its use is diff -cNr octave-2.9.15/doc/interpreter/errorbar.eps octave-2.9.16/doc/interpreter/errorbar.eps *** octave-2.9.15/doc/interpreter/errorbar.eps Sat Oct 13 11:11:17 2007 --- octave-2.9.16/doc/interpreter/errorbar.eps Wed Oct 31 18:09:43 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: errorbar.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:17 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: errorbar.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:43 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:17 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:43 2007) /DOCINFO pdfmark end } ifelse *************** *** 458,509 **** (Helvetica) findfont 140 scalefont setfont 1.000 UL LTb ! 574 647 M 63 0 V 6325 0 R -63 0 V stroke ! 490 647 M [ [(Helvetica) 140.0 0.0 true true 0 (-1)] ] -46.7 MRshow 1.000 UL LTb ! 574 1566 M 63 0 V 6325 0 R -63 0 V stroke ! 490 1566 M [ [(Helvetica) 140.0 0.0 true true 0 (-0.5)] ] -46.7 MRshow 1.000 UL LTb ! 574 2484 M 63 0 V 6325 0 R -63 0 V stroke ! 490 2484 M [ [(Helvetica) 140.0 0.0 true true 0 (0)] ] -46.7 MRshow 1.000 UL LTb ! 574 3403 M 63 0 V 6325 0 R -63 0 V stroke ! 490 3403 M [ [(Helvetica) 140.0 0.0 true true 0 (0.5)] ] -46.7 MRshow 1.000 UL LTb ! 574 4321 M 63 0 V 6325 0 R -63 0 V stroke ! 490 4321 M [ [(Helvetica) 140.0 0.0 true true 0 (1)] ] -46.7 MRshow 1.000 UL --- 458,509 ---- (Helvetica) findfont 140 scalefont setfont 1.000 UL LTb ! 574 663 M 63 0 V 6325 0 R -63 0 V stroke ! 490 663 M [ [(Helvetica) 140.0 0.0 true true 0 (-1)] ] -46.7 MRshow 1.000 UL LTb ! 574 1619 M 63 0 V 6325 0 R -63 0 V stroke ! 490 1619 M [ [(Helvetica) 140.0 0.0 true true 0 (-0.5)] ] -46.7 MRshow 1.000 UL LTb ! 574 2576 M 63 0 V 6325 0 R -63 0 V stroke ! 490 2576 M [ [(Helvetica) 140.0 0.0 true true 0 (0)] ] -46.7 MRshow 1.000 UL LTb ! 574 3533 M 63 0 V 6325 0 R -63 0 V stroke ! 490 3533 M [ [(Helvetica) 140.0 0.0 true true 0 (0.5)] ] -46.7 MRshow 1.000 UL LTb ! 574 4489 M 63 0 V 6325 0 R -63 0 V stroke ! 490 4489 M [ [(Helvetica) 140.0 0.0 true true 0 (1)] ] -46.7 MRshow 1.000 UL *************** *** 582,1294 **** 1.000 UP 1.000 UL LT0 ! 574 2274 M ! 0 150 V ! 543 2274 M 62 0 V ! -62 150 R 62 0 V ! 33 229 R ! 0 154 V ! 607 2653 M 62 0 V ! -62 154 R 62 0 V ! 33 154 R ! 0 -119 V ! -31 119 R 62 0 V ! 671 2842 M 62 0 V ! 33 -204 R ! 0 754 V ! 735 2638 M 62 0 V ! -62 754 R 62 0 V ! 33 -161 R ! 0 124 V ! 799 3231 M 62 0 V ! -62 124 R 62 0 V ! 32 -114 R ! 0 135 V ! 862 3241 M 62 0 V ! -62 135 R 62 0 V ! 33 356 R ! 0 89 V ! -31 -89 R 62 0 V ! -62 89 R 62 0 V ! 33 -342 R 0 116 V ! 990 3479 M 62 0 V -62 116 R 62 0 V ! 33 300 R ! 0 -13 V ! -31 13 R 62 0 V ! -62 -13 R 62 0 V ! 33 88 R ! 0 -162 V ! -31 162 R 62 0 V ! -62 -162 R 62 0 V ! 33 295 R ! 0 250 V ! -31 -250 R 62 0 V ! -62 250 R 62 0 V ! 33 -43 R ! 0 -218 V ! -31 218 R 62 0 V ! -62 -218 R 62 0 V ! 33 269 R ! 0 31 V ! -31 -31 R 62 0 V ! -62 31 R 62 0 V ! 32 -260 R ! 0 -82 V ! -31 82 R 62 0 V ! -62 -82 R 62 0 V ! 33 486 R 0 -198 V -31 198 R 62 0 V -62 -198 R 62 0 V ! 33 347 R ! 0 -168 V ! -31 168 R ! 62 0 V ! -62 -168 R 62 0 V ! 33 -116 R ! 0 -314 V ! -31 314 R 62 0 V ! -62 -314 R 62 0 V ! 33 105 R ! 0 52 V ! -31 -52 R ! 1691 4192 L ! -62 52 R 62 0 V ! 33 -99 R ! 0 71 V ! -31 -71 R 62 0 V ! -62 71 R 62 0 V ! 33 -393 R ! 0 291 V ! -31 -291 R 62 0 V ! -62 291 R 62 0 V ! 33 377 R ! 0 -182 V ! -31 182 R 62 0 V ! -62 -182 R 62 0 V ! 32 -326 R ! 0 12 V ! -31 -12 R 62 0 V ! -62 12 R 62 0 V ! 33 2 R ! 0 273 V ! -31 -273 R 62 0 V ! -62 273 R 62 0 V ! 33 -347 R ! 0 -17 V ! -31 17 R 62 0 V ! -62 -17 R 62 0 V ! 33 -283 R ! 0 503 V ! -31 -503 R 62 0 V ! -62 503 R 62 0 V ! 33 -343 R ! 0 -236 V ! -31 236 R 62 0 V ! -62 -236 R 62 0 V ! 33 -141 R ! 0 300 V ! -31 -300 R 62 0 V ! -62 300 R 62 0 V ! 33 -560 R ! 0 -66 V ! -31 66 R 62 0 V ! -62 -66 R 62 0 V ! 33 -90 R ! 0 52 V ! -31 -52 R 62 0 V ! -62 52 R 62 0 V ! 33 -63 R ! 0 -452 V ! -31 452 R 62 0 V ! -62 -452 R 62 0 V ! 32 83 R ! 0 -52 V ! -31 52 R 62 0 V ! -62 -52 R 62 0 V ! 33 -13 R ! 0 -23 V ! -31 23 R 62 0 V ! -62 -23 R 62 0 V ! 33 37 R ! 0 -329 V ! -31 329 R 62 0 V ! -62 -329 R 62 0 V ! 33 252 R ! 0 -426 V ! -31 426 R 62 0 V ! -62 -426 R 62 0 V ! 33 -273 R ! 0 150 V ! -31 -150 R 62 0 V ! -62 150 R 62 0 V ! 33 -70 R ! 2810 2042 L ! -31 -179 R 62 0 V ! -62 179 R 62 0 V ! 33 -129 R ! 0 -530 V ! -31 530 R 62 0 V ! -62 -530 R 62 0 V ! 33 229 R ! 0 -66 V ! -31 66 R 62 0 V ! -62 -66 R 62 0 V ! 32 -487 R ! 0 255 V ! -31 -255 R 62 0 V ! -62 255 R 62 0 V ! 33 -27 R ! 0 -32 V ! -31 32 R 62 0 V ! -62 -32 R 62 0 V ! 33 -134 R ! 0 293 V ! -31 -293 R 62 0 V ! -62 293 R 62 0 V ! 33 -282 R ! 0 274 V ! -31 -274 R 62 0 V ! -62 274 R 62 0 V ! 33 -471 R ! 0 70 V ! -31 -70 R 62 0 V ! -62 70 R 62 0 V ! 33 -355 R ! 0 153 V ! 3290 650 M 62 0 V ! -62 153 R 62 0 V ! 33 200 R ! 0 -332 V ! -31 332 R 62 0 V ! 3354 671 M 62 0 V ! 33 -29 R ! 0 289 V ! 3418 642 M 62 0 V ! -62 289 R 62 0 V ! 32 -551 R ! 0 96 V ! -31 -96 R 62 0 V ! -62 96 R 62 0 V ! 33 88 R ! 0 225 V ! 3545 564 M 62 0 V ! -62 225 R 62 0 V ! 33 -220 R ! 0 -234 V ! -31 234 R 62 0 V ! 3609 335 M 62 0 V ! 33 633 R ! 0 -8 V ! -31 8 R 62 0 V ! -62 -8 R 62 0 V ! 33 -93 R ! 0 -182 V ! -31 182 R 62 0 V ! 3737 685 M 62 0 V ! 33 132 R ! 0 -37 V ! -31 37 R 62 0 V ! -62 -37 R 62 0 V ! 33 -114 R ! 0 325 V ! 3865 666 M 62 0 V ! -62 325 R ! 3927 991 L ! 33 201 R ! 0 -284 V ! -31 284 R 62 0 V ! 3929 908 M 62 0 V ! 33 213 R 0 76 V -31 -76 R 62 0 V -62 76 R 62 0 V ! 32 -150 R ! 0 405 V ! -31 -405 R 62 0 V ! -62 405 R 62 0 V ! 33 -354 R ! 0 -2 V ! -31 2 R 62 0 V ! -62 -2 R 62 0 V ! 33 224 R ! 0 -125 V ! -31 125 R 62 0 V ! -62 -125 R 62 0 V ! 33 984 R ! 0 -587 V ! -31 587 R 62 0 V ! -62 -587 R 62 0 V ! 33 430 R ! 0 -210 V ! -31 210 R 62 0 V ! -62 -210 R 62 0 V ! 33 44 R ! 0 -228 V ! -31 228 R 62 0 V ! -62 -228 R 62 0 V ! 33 621 R ! 0 -223 V ! -31 223 R 62 0 V ! -62 -223 R 62 0 V ! 33 293 R ! 0 147 V ! -31 -147 R 62 0 V ! -62 147 R 62 0 V ! 32 -310 R ! 0 276 V ! -31 -276 R 62 0 V ! -62 276 R 62 0 V ! 33 -2 R ! 0 243 V ! -31 -243 R 62 0 V ! -62 243 R 62 0 V ! 33 256 R ! 0 76 V ! -31 -76 R 62 0 V ! -62 76 R 62 0 V ! 33 322 R ! 0 -283 V ! -31 283 R 62 0 V ! -62 -283 R 62 0 V ! 33 229 R ! 0 242 V ! -31 -242 R 62 0 V ! -62 242 R 62 0 V ! 33 -362 R ! 0 437 V ! -31 -437 R 62 0 V ! -62 437 R 62 0 V ! 33 -273 R ! 0 239 V ! -31 -239 R 62 0 V ! -62 239 R 62 0 V ! 33 378 R ! 0 -205 V ! -31 205 R ! 5077 3934 L ! -62 -205 R ! 62 0 V ! 32 89 R ! 0 -103 V ! -31 103 R 62 0 V ! -62 -103 R 62 0 V ! 33 342 R ! 0 -162 V ! -31 162 R 62 0 V ! -62 -162 R 62 0 V ! 33 253 R ! 0 -198 V ! -31 198 R 62 0 V ! -62 -198 R 62 0 V ! 33 256 R ! 0 -98 V ! -31 98 R 62 0 V ! -62 -98 R 62 0 V ! 33 546 R ! 0 -576 V ! -31 576 R 62 0 V ! -62 -576 R 62 0 V ! 33 97 R ! 0 20 V ! -31 -20 R 62 0 V ! -62 20 R 62 0 V ! 33 115 R ! 0 283 V ! -31 -283 R 62 0 V ! -62 283 R 62 0 V ! 33 -265 R ! 0 134 V ! -31 -134 R 62 0 V ! -62 134 R 62 0 V ! 33 254 R ! 0 -582 V ! -31 582 R 62 0 V ! -62 -582 R 62 0 V ! 32 130 R ! 0 264 V ! -31 -264 R 62 0 V ! -62 264 R 62 0 V ! 33 -375 R ! 0 163 V ! -31 -163 R 62 0 V ! -62 163 R 62 0 V ! 33 414 R ! 0 -535 V ! -31 535 R 62 0 V ! -62 -535 R 62 0 V ! 33 6 R ! 0 -206 V ! -31 206 R 62 0 V ! -62 -206 R 62 0 V ! 33 377 R ! 0 -281 V ! -31 281 R 62 0 V ! -62 -281 R 62 0 V ! 33 -91 R ! 0 -408 V ! -31 408 R 62 0 V ! -62 -408 R 62 0 V ! 33 225 R ! 0 -545 V ! -31 545 R 62 0 V ! -62 -545 R 62 0 V ! 33 552 R ! 0 191 V ! -31 -191 R 62 0 V ! -62 191 R 62 0 V ! 32 -560 R ! 6195 3524 L ! -31 -69 R 62 0 V ! -62 69 R 62 0 V ! 33 -513 R ! 0 187 V ! -31 -187 R 62 0 V ! -62 187 R 62 0 V ! 33 78 R ! 0 -7 V ! -31 7 R 62 0 V ! -62 -7 R 62 0 V ! 33 -80 R ! 0 4 V ! -31 -4 R 62 0 V ! -62 4 R 62 0 V ! 33 -354 R ! 0 -6 V ! -31 6 R 62 0 V ! -62 -6 R 62 0 V ! 33 -193 R ! 0 302 V ! -31 -302 R 62 0 V ! -62 302 R 62 0 V ! 33 -437 R ! 0 -112 V ! -31 112 R 62 0 V ! -62 -112 R 62 0 V ! 33 53 R ! 0 -271 V ! -31 271 R 62 0 V ! -62 -271 R 62 0 V ! 32 -298 R ! 0 147 V ! -31 -147 R ! 62 0 V ! -62 147 R ! 62 0 V ! 33 223 R ! 0 -380 V ! -31 380 R ! 62 0 V ! -62 -380 R ! 62 0 V ! 33 -543 R ! 0 344 V ! -31 -344 R ! 62 0 V ! -62 344 R ! 62 0 V ! 33 73 R ! 0 -134 V ! -31 134 R ! 62 0 V ! -62 -134 R ! 62 0 V ! 33 73 R ! 0 -451 V ! -31 451 R ! 62 0 V ! -62 -451 R ! 62 0 V ! 574 2484 Pls ! 638 2668 Pls ! 702 2849 Pls ! 766 3027 Pls ! 830 3199 Pls ! 893 3365 Pls ! 957 3521 Pls ! 1021 3667 Pls ! 1085 3802 Pls ! 1149 3923 Pls ! 1213 4030 Pls ! 1277 4121 Pls ! 1341 4196 Pls ! 1404 4254 Pls ! 1468 4294 Pls ! 1532 4316 Pls ! 1596 4320 Pls ! 1660 4306 Pls ! 1724 4273 Pls ! 1788 4222 Pls ! 1852 4154 Pls ! 1915 4070 Pls ! 1979 3969 Pls ! 2043 3854 Pls ! 2107 3725 Pls ! 2171 3583 Pls ! 2235 3431 Pls ! 2299 3269 Pls ! 2363 3099 Pls ! 2427 2924 Pls ! 2490 2743 Pls ! 2554 2561 Pls ! 2618 2377 Pls ! 2682 2194 Pls ! 2746 2015 Pls ! 2810 1840 Pls ! 2874 1671 Pls ! 2938 1511 Pls ! 3001 1360 Pls ! 3065 1221 Pls ! 3129 1094 Pls ! 3193 981 Pls ! 3257 883 Pls ! 3321 801 Pls ! 3385 736 Pls ! 3449 689 Pls ! 3512 659 Pls ! 3576 648 Pls ! 3640 654 Pls ! 3704 680 Pls ! 3768 723 Pls ! 3832 784 Pls ! 3896 861 Pls ! 3960 955 Pls ! 4024 1065 Pls ! 4087 1188 Pls ! 4151 1325 Pls ! 4215 1473 Pls ! 4279 1631 Pls ! 4343 1797 Pls ! 4407 1971 Pls ! 4471 2150 Pls ! 4535 2332 Pls ! 4598 2515 Pls ! 4662 2698 Pls ! 4726 2879 Pls ! 4790 3056 Pls ! 4854 3228 Pls ! 4918 3392 Pls ! 4982 3547 Pls ! 5046 3691 Pls ! 5109 3823 Pls ! 5173 3942 Pls ! 5237 4046 Pls ! 5301 4135 Pls ! 5365 4207 Pls ! 5429 4262 Pls ! 5493 4299 Pls ! 5557 4318 Pls ! 5621 4319 Pls ! 5684 4301 Pls ! 5748 4266 Pls ! 5812 4212 Pls ! 5876 4141 Pls ! 5940 4054 Pls ! 6004 3951 Pls ! 6068 3833 Pls ! 6132 3702 Pls ! 6195 3559 Pls ! 6259 3404 Pls ! 6323 3241 Pls ! 6387 3070 Pls ! 6451 2894 Pls ! 6515 2713 Pls ! 6579 2530 Pls ! 6643 2346 Pls ! 6706 2164 Pls ! 6770 1985 Pls ! 6834 1811 Pls ! 6898 1644 Pls ! 6962 1485 Pls 1.000 UL LTb 574 4872 N --- 582,1294 ---- 1.000 UP 1.000 UL LT0 ! 574 2318 M ! 0 328 V ! 543 2318 M 62 0 V ! -62 328 R 62 0 V ! 33 -28 R ! 0 85 V ! -31 -85 R 62 0 V ! -62 85 R 62 0 V ! 33 556 R ! 0 -436 V ! -31 436 R 62 0 V ! 671 2823 M 62 0 V ! 33 205 R ! 0 157 V ! 735 3028 M 62 0 V ! -62 157 R 62 0 V ! 33 -160 R ! 0 521 V ! 799 3025 M 62 0 V ! -62 521 R 62 0 V ! 32 25 R ! 0 -43 V ! -31 43 R 62 0 V ! -62 -43 R 62 0 V ! 33 85 R ! 0 152 V ! 926 3613 M 62 0 V ! -62 152 R 62 0 V ! 33 50 R 0 116 V ! 990 3815 M 62 0 V -62 116 R 62 0 V ! 33 -243 R ! 0 130 V ! -31 -130 R 62 0 V ! -62 130 R 62 0 V ! 33 257 R ! 0 -223 V ! -31 223 R ! 62 0 V ! -62 -223 R ! 62 0 V ! 33 417 R ! 0 306 V ! -31 -306 R ! 62 0 V ! -62 306 R ! 62 0 V ! 33 -695 R ! 0 495 V ! -31 -495 R ! 62 0 V ! -62 495 R 62 0 V ! 33 188 R ! 0 -254 V ! -31 254 R 62 0 V ! -62 -254 R ! 62 0 V ! 32 27 R ! 0 -315 V ! -31 315 R ! 62 0 V ! -62 -315 R ! 62 0 V ! 33 359 R ! 0 71 V ! -31 -71 R ! 62 0 V ! -62 71 R 62 0 V ! 33 207 R ! 0 -600 V ! -31 600 R 62 0 V ! -62 -600 R 62 0 V ! 33 374 R ! 0 -138 V ! -31 138 R 62 0 V ! -62 -138 R 62 0 V ! 33 96 R ! 0 176 V ! -31 -176 R ! 1691 4390 L ! -62 176 R 62 0 V ! 33 -183 R ! 0 -204 V ! -31 204 R 62 0 V ! -62 -204 R 62 0 V ! 33 -168 R ! 0 549 V ! -31 -549 R ! 62 0 V ! -62 549 R ! 62 0 V ! 33 -200 R 0 -198 V -31 198 R 62 0 V -62 -198 R 62 0 V ! 32 218 R ! 0 20 V ! -31 -20 R 62 0 V ! -62 20 R 62 0 V ! 33 -111 R ! 0 -271 V ! -31 271 R 62 0 V ! -62 -271 R 62 0 V ! 33 40 R ! 0 157 V ! -31 -157 R 62 0 V ! -62 157 R 62 0 V ! 33 -482 R ! 0 -80 V ! -31 80 R 62 0 V ! -62 -80 R 62 0 V ! 33 -110 R ! 0 28 V ! -31 -28 R 62 0 V ! -62 28 R 62 0 V ! 33 339 R ! 0 -350 V ! -31 350 R 62 0 V ! -62 -350 R 62 0 V ! 33 -54 R ! 0 -2 V ! -31 2 R 62 0 V ! -62 -2 R 62 0 V ! 33 -555 R ! 0 247 V ! -31 -247 R 62 0 V ! -62 247 R 62 0 V ! 33 -88 R ! 0 120 V ! -31 -120 R 62 0 V ! -62 120 R 62 0 V ! 32 -480 R ! 0 108 V ! -31 -108 R 62 0 V ! -62 108 R 62 0 V ! 33 -186 R ! 0 -246 V ! -31 246 R 62 0 V ! -62 -246 R 62 0 V ! 33 -109 R ! 0 -121 V ! -31 121 R 62 0 V ! -62 -121 R 62 0 V ! 33 6 R ! 0 83 V ! -31 -83 R 62 0 V ! -62 83 R 62 0 V ! 33 85 R ! 0 -112 V ! -31 112 R 62 0 V ! -62 -112 R 62 0 V ! 33 -367 R ! 2810 1832 L ! -31 57 R 62 0 V ! -62 -57 R 62 0 V ! 33 30 R ! 0 -661 V ! -31 661 R 62 0 V ! -62 -661 R 62 0 V ! 33 504 R ! 0 -320 V ! -31 320 R 62 0 V ! -62 -320 R 62 0 V ! 32 242 R ! 0 -338 V ! -31 338 R 62 0 V ! -62 -338 R 62 0 V ! 33 -199 R ! 0 493 V ! -31 -493 R 62 0 V ! -62 493 R 62 0 V ! 33 -464 R ! 0 -293 V ! -31 293 R 62 0 V ! 3098 826 M 62 0 V ! 33 217 R ! 0 228 V ! -31 -228 R 62 0 V ! -62 228 R 62 0 V ! 33 -191 R ! 0 -31 V ! -31 31 R 62 0 V ! -62 -31 R 62 0 V ! 33 -196 R ! 0 -17 V ! -31 17 R 62 0 V ! -62 -17 R 62 0 V ! 33 3 R ! 0 -228 V ! -31 228 R 62 0 V ! 3354 611 M 62 0 V ! 33 211 R ! 0 -58 V ! -31 58 R 62 0 V ! -62 -58 R 62 0 V ! 32 -49 R ! 0 -167 V ! -31 167 R 62 0 V ! 3481 548 M 62 0 V ! 33 -223 R ! 0 166 V ! 3545 325 M 62 0 V ! -62 166 R 62 0 V ! 33 187 R ! 0 24 V ! -31 -24 R 62 0 V ! -62 24 R 62 0 V ! 33 -116 R ! 0 42 V ! -31 -42 R 62 0 V ! -62 42 R 62 0 V ! 33 211 R ! 0 -146 V ! -31 146 R 62 0 V ! 3737 693 M 62 0 V ! 33 376 R ! 0 -364 V ! -31 364 R 62 0 V ! 3801 705 M 62 0 V ! 33 -139 R ! 0 47 V ! -31 -47 R 62 0 V ! -62 47 R ! 3927 613 L ! 33 -11 R ! 0 393 V ! 3929 602 M 62 0 V ! -62 393 R 62 0 V ! 33 -33 R ! 0 53 V ! -31 -53 R 62 0 V ! -62 53 R 62 0 V ! 32 41 R ! 0 -93 V ! -31 93 R 62 0 V ! -62 -93 R 62 0 V ! 33 519 R ! 0 -159 V ! -31 159 R 62 0 V ! -62 -159 R 62 0 V ! 33 234 R ! 0 -73 V ! -31 73 R 62 0 V ! -62 -73 R 62 0 V ! 33 331 R ! 0 -11 V ! -31 11 R 62 0 V ! -62 -11 R 62 0 V ! 33 173 R 0 76 V -31 -76 R 62 0 V -62 76 R 62 0 V ! 33 -70 R ! 0 164 V ! -31 -164 R 62 0 V ! -62 164 R 62 0 V ! 33 -137 R ! 0 106 V ! -31 -106 R 62 0 V ! -62 106 R 62 0 V ! 33 148 R ! 0 -161 V ! -31 161 R 62 0 V ! -62 -161 R 62 0 V ! 32 285 R ! 0 361 V ! -31 -361 R 62 0 V ! -62 361 R 62 0 V ! 33 120 R ! 0 -47 V ! -31 47 R 62 0 V ! -62 -47 R 62 0 V ! 33 342 R ! 0 -330 V ! -31 330 R 62 0 V ! -62 -330 R 62 0 V ! 33 239 R ! 0 214 V ! -31 -214 R 62 0 V ! -62 214 R 62 0 V ! 33 126 R ! 0 110 V ! -31 -110 R 62 0 V ! -62 110 R 62 0 V ! 33 -171 R ! 0 -154 V ! -31 154 R 62 0 V ! -62 -154 R 62 0 V ! 33 313 R ! 0 183 V ! -31 -183 R 62 0 V ! -62 183 R 62 0 V ! 33 25 R ! 0 226 V ! -31 -226 R ! 5077 3719 L ! -62 226 R 62 0 V ! 32 54 R ! 0 -17 V ! -31 17 R 62 0 V ! -62 -17 R 62 0 V ! 33 -90 R ! 0 419 V ! -31 -419 R 62 0 V ! -62 419 R 62 0 V ! 33 -197 R ! 0 -91 V ! -31 91 R 62 0 V ! -62 -91 R 62 0 V ! 33 311 R ! 0 405 V ! -31 -405 R 62 0 V ! -62 405 R 62 0 V ! 33 -113 R ! 0 -238 V ! -31 238 R 62 0 V ! -62 -238 R 62 0 V ! 33 227 R ! 0 -383 V ! -31 383 R 62 0 V ! -62 -383 R 62 0 V ! 33 -52 R ! 0 317 V ! -31 -317 R 62 0 V ! -62 317 R 62 0 V ! 33 -391 R ! 0 381 V ! -31 -381 R 62 0 V ! -62 381 R 62 0 V ! 33 -37 R ! 0 110 V ! -31 -110 R 62 0 V ! -62 110 R 62 0 V ! 32 -158 R ! 0 169 V ! -31 -169 R 62 0 V ! -62 169 R 62 0 V ! 33 -150 R ! 0 -264 V ! -31 264 R 62 0 V ! -62 -264 R 62 0 V ! 33 235 R ! 0 38 V ! -31 -38 R 62 0 V ! -62 38 R 62 0 V ! 33 -315 R ! 0 -52 V ! -31 52 R 62 0 V ! -62 -52 R 62 0 V ! 33 182 R ! 0 179 V ! -31 -179 R 62 0 V ! -62 179 R 62 0 V ! 33 -386 R ! 0 -77 V ! -31 77 R 62 0 V ! -62 -77 R 62 0 V ! 33 32 R ! 0 -3 V ! -31 3 R 62 0 V ! -62 -3 R 62 0 V ! 33 -60 R ! 0 -389 V ! -31 389 R 62 0 V ! -62 -389 R 62 0 V ! 32 -313 R ! 6195 3626 L ! -31 -398 R 62 0 V ! -62 398 R 62 0 V ! 33 -237 R ! 0 255 V ! -31 -255 R 62 0 V ! -62 255 R 62 0 V ! 33 -299 R ! 0 -41 V ! -31 41 R 62 0 V ! -62 -41 R 62 0 V ! 33 -380 R ! 0 239 V ! -31 -239 R 62 0 V ! -62 239 R 62 0 V ! 33 -269 R ! 0 -24 V ! -31 24 R 62 0 V ! -62 -24 R 62 0 V ! 33 -343 R ! 0 265 V ! -31 -265 R 62 0 V ! -62 265 R 62 0 V ! 33 -408 R ! 0 85 V ! -31 -85 R 62 0 V ! -62 85 R 62 0 V ! 33 257 R ! 0 -186 V ! -31 186 R 62 0 V ! -62 -186 R 62 0 V ! 32 -313 R ! 0 -64 V ! -31 64 R 62 0 V ! -62 -64 R 62 0 V ! 33 129 R ! 0 -195 V ! -31 195 R 62 0 V ! -62 -195 R 62 0 V ! 33 -373 R ! 0 498 V ! -31 -498 R 62 0 V ! -62 498 R 62 0 V ! 33 -542 R ! 0 48 V ! -31 -48 R 62 0 V ! -62 48 R 62 0 V ! 33 37 R ! 0 4 V ! -31 -4 R ! 62 0 V ! -62 4 R 62 0 V ! 574 2576 Pls ! 638 2767 Pls ! 702 2956 Pls ! 766 3141 Pls ! 830 3321 Pls ! 893 3493 Pls ! 957 3656 Pls ! 1021 3809 Pls ! 1085 3949 Pls ! 1149 4075 Pls ! 1213 4186 Pls ! 1277 4281 Pls ! 1341 4359 Pls ! 1404 4420 Pls ! 1468 4461 Pls ! 1532 4485 Pls ! 1596 4489 Pls ! 1660 4473 Pls ! 1724 4439 Pls ! 1788 4387 Pls ! 1852 4316 Pls ! 1915 4228 Pls ! 1979 4123 Pls ! 2043 4003 Pls ! 2107 3868 Pls ! 2171 3721 Pls ! 2235 3562 Pls ! 2299 3394 Pls ! 2363 3217 Pls ! 2427 3034 Pls ! 2490 2846 Pls ! 2554 2656 Pls ! 2618 2464 Pls ! 2682 2274 Pls ! 2746 2087 Pls ! 2810 1905 Pls ! 2874 1729 Pls ! 2938 1562 Pls ! 3001 1405 Pls ! 3065 1260 Pls ! 3129 1128 Pls ! 3193 1010 Pls ! 3257 908 Pls ! 3321 823 Pls ! 3385 755 Pls ! 3449 706 Pls ! 3512 675 Pls ! 3576 663 Pls ! 3640 670 Pls ! 3704 696 Pls ! 3768 741 Pls ! 3832 805 Pls ! 3896 886 Pls ! 3960 984 Pls ! 4024 1097 Pls ! 4087 1226 Pls ! 4151 1368 Pls ! 4215 1522 Pls ! 4279 1687 Pls ! 4343 1861 Pls ! 4407 2041 Pls ! 4471 2227 Pls ! 4535 2417 Pls ! 4598 2608 Pls ! 4662 2799 Pls ! 4726 2988 Pls ! 4790 3172 Pls ! 4854 3351 Pls ! 4918 3521 Pls ! 4982 3683 Pls ! 5046 3833 Pls ! 5109 3971 Pls ! 5173 4095 Pls ! 5237 4203 Pls ! 5301 4296 Pls ! 5365 4371 Pls ! 5429 4428 Pls ! 5493 4467 Pls ! 5557 4487 Pls ! 5621 4487 Pls ! 5684 4469 Pls ! 5748 4432 Pls ! 5812 4376 Pls ! 5876 4302 Pls ! 5940 4211 Pls ! 6004 4104 Pls ! 6068 3981 Pls ! 6132 3844 Pls ! 6195 3695 Pls ! 6259 3535 Pls ! 6323 3365 Pls ! 6387 3187 Pls ! 6451 3002 Pls ! 6515 2814 Pls ! 6579 2623 Pls ! 6643 2432 Pls ! 6706 2242 Pls ! 6770 2056 Pls ! 6834 1875 Pls ! 6898 1701 Pls ! 6962 1535 Pls 1.000 UL LTb 574 4872 N Binary files octave-2.9.15/doc/interpreter/errorbar.pdf and octave-2.9.16/doc/interpreter/errorbar.pdf differ Binary files octave-2.9.15/doc/interpreter/errorbar.png and octave-2.9.16/doc/interpreter/errorbar.png differ diff -cNr octave-2.9.15/doc/interpreter/errors.texi octave-2.9.16/doc/interpreter/errors.texi *** octave-2.9.15/doc/interpreter/errors.texi Sat Oct 13 11:12:45 2007 --- octave-2.9.16/doc/interpreter/errors.texi Wed Oct 31 18:11:02 2007 *************** *** 100,106 **** calling the function @code{f} will result in a list of messages that can help you to quickly locate the exact location of the error: ! @example @group f () error: nargin != 1 --- 100,106 ---- calling the function @code{f} will result in a list of messages that can help you to quickly locate the exact location of the error: ! @smallexample @group f () error: nargin != 1 *************** *** 110,116 **** error: called from `g' error: called from `f' @end group ! @end example If the error message ends in a new line character, Octave will print the message but will not display any traceback messages as it returns --- 110,116 ---- error: called from `g' error: called from `f' @end group ! @end smallexample If the error message ends in a new line character, Octave will print the message but will not display any traceback messages as it returns *************** *** 393,402 **** @example a = -1; if (a < 0) ! warning ("'a' must be non-negative number. Setting 'a' to zero."); a = 0; endif ! @print{} 'a' must be non-negative number. Setting 'a' to zero. @end example Since warnings aren't fatal to a running program, it is not possible --- 393,402 ---- @example a = -1; if (a < 0) ! warning ("'a' must be non-negative. Setting 'a' to zero."); a = 0; endif ! @print{} 'a' must be non-negative. Setting 'a' to zero. @end example Since warnings aren't fatal to a running program, it is not possible *************** *** 459,465 **** @example warning ("non-negative-variable", ! "'a' must be non-negative number. Setting 'a' to zero."); @end example @noindent --- 459,465 ---- @example warning ("non-negative-variable", ! "'a' must be non-negative. Setting 'a' to zero."); @end example @noindent *************** *** 468,474 **** @example warning ("off", "non-negative-variable"); warning ("non-negative-variable", ! "'a' must be non-negative number. Setting 'a' to zero."); @end example The functions distributed with Octave can issue one of the following --- 468,474 ---- @example warning ("off", "non-negative-variable"); warning ("non-negative-variable", ! "'a' must be non-negative. Setting 'a' to zero."); @end example The functions distributed with Octave can issue one of the following diff -cNr octave-2.9.15/doc/interpreter/errors.txi octave-2.9.16/doc/interpreter/errors.txi *** octave-2.9.15/doc/interpreter/errors.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/errors.txi Mon Oct 15 11:30:04 2007 *************** *** 226,235 **** @example a = -1; if (a < 0) ! warning ("'a' must be non-negative number. Setting 'a' to zero."); a = 0; endif ! @print{} 'a' must be non-negative number. Setting 'a' to zero. @end example Since warnings aren't fatal to a running program, it is not possible --- 226,235 ---- @example a = -1; if (a < 0) ! warning ("'a' must be non-negative. Setting 'a' to zero."); a = 0; endif ! @print{} 'a' must be non-negative. Setting 'a' to zero. @end example Since warnings aren't fatal to a running program, it is not possible *************** *** 260,266 **** @example warning ("non-negative-variable", ! "'a' must be non-negative number. Setting 'a' to zero."); @end example @noindent --- 260,266 ---- @example warning ("non-negative-variable", ! "'a' must be non-negative. Setting 'a' to zero."); @end example @noindent *************** *** 269,275 **** @example warning ("off", "non-negative-variable"); warning ("non-negative-variable", ! "'a' must be non-negative number. Setting 'a' to zero."); @end example The functions distributed with Octave can issue one of the following --- 269,275 ---- @example warning ("off", "non-negative-variable"); warning ("non-negative-variable", ! "'a' must be non-negative. Setting 'a' to zero."); @end example The functions distributed with Octave can issue one of the following diff -cNr octave-2.9.15/doc/interpreter/expr.texi octave-2.9.16/doc/interpreter/expr.texi *** octave-2.9.15/doc/interpreter/expr.texi Sat Oct 13 11:12:45 2007 --- octave-2.9.16/doc/interpreter/expr.texi Wed Oct 31 18:11:02 2007 *************** *** 1022,1032 **** not exceed the number of values on the right side. For example, the following will produce an error. ! @example [a, b, c, d] = [u, s, v] = svd (a) ! @print{} error: element number 4 undefined in return list ! error: evaluating assignment expression near line 8, column 15 ! @end example @opindex += A very common programming pattern is to increment an existing variable --- 1022,1033 ---- not exceed the number of values on the right side. For example, the following will produce an error. ! @c Using 'smallexample' to make text fit on page when creating smallbook. ! @smallexample [a, b, c, d] = [u, s, v] = svd (a) ! @print{} error: element number 4 undefined in return list ! @print{} error: evaluating assignment expression near line 8, column 15 ! @end smallexample @opindex += A very common programming pattern is to increment an existing variable diff -cNr octave-2.9.15/doc/interpreter/expr.txi octave-2.9.16/doc/interpreter/expr.txi *** octave-2.9.15/doc/interpreter/expr.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/expr.txi Mon Oct 15 11:30:04 2007 *************** *** 943,953 **** not exceed the number of values on the right side. For example, the following will produce an error. ! @example [a, b, c, d] = [u, s, v] = svd (a) ! @print{} error: element number 4 undefined in return list ! error: evaluating assignment expression near line 8, column 15 ! @end example @opindex += A very common programming pattern is to increment an existing variable --- 943,954 ---- not exceed the number of values on the right side. For example, the following will produce an error. ! @c Using 'smallexample' to make text fit on page when creating smallbook. ! @smallexample [a, b, c, d] = [u, s, v] = svd (a) ! @print{} error: element number 4 undefined in return list ! @print{} error: evaluating assignment expression near line 8, column 15 ! @end smallexample @opindex += A very common programming pattern is to increment an existing variable diff -cNr octave-2.9.15/doc/interpreter/func.texi octave-2.9.16/doc/interpreter/func.texi *** octave-2.9.15/doc/interpreter/func.texi Sat Oct 13 11:12:45 2007 --- octave-2.9.16/doc/interpreter/func.texi Wed Oct 31 18:11:02 2007 *************** *** 1056,1062 **** @group function count_calls() persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction mlock ("count_calls"); --- 1056,1063 ---- @group function count_calls() persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction mlock ("count_calls"); *************** *** 1079,1085 **** function count_calls () mlock (); persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction @end group @end example --- 1080,1087 ---- function count_calls () mlock (); persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction @end group @end example diff -cNr octave-2.9.15/doc/interpreter/func.txi octave-2.9.16/doc/interpreter/func.txi *** octave-2.9.15/doc/interpreter/func.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/func.txi Mon Oct 15 11:30:04 2007 *************** *** 775,781 **** @group function count_calls() persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction mlock ("count_calls"); --- 775,782 ---- @group function count_calls() persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction mlock ("count_calls"); *************** *** 798,804 **** function count_calls () mlock (); persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction @end group @end example --- 799,806 ---- function count_calls () mlock (); persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction @end group @end example diff -cNr octave-2.9.15/doc/interpreter/gplot.eps octave-2.9.16/doc/interpreter/gplot.eps *** octave-2.9.15/doc/interpreter/gplot.eps Sat Oct 13 11:10:32 2007 --- octave-2.9.16/doc/interpreter/gplot.eps Wed Oct 31 18:09:03 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: gplot.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:32 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: gplot.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:03 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:32 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:03 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/gplot.pdf and octave-2.9.16/doc/interpreter/gplot.pdf differ diff -cNr octave-2.9.15/doc/interpreter/grid.eps octave-2.9.16/doc/interpreter/grid.eps *** octave-2.9.15/doc/interpreter/grid.eps Sat Oct 13 11:10:36 2007 --- octave-2.9.16/doc/interpreter/grid.eps Wed Oct 31 18:09:06 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: grid.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:36 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: grid.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:06 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:36 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:06 2007) /DOCINFO pdfmark end } ifelse *************** *** 663,675 **** LTb 2039 1588 M 62 -1 V - stroke - LTa - 1370 1151 M - 669 437 V - 3791 -77 V - stroke - LTb 1370 1151 M 63 0 V stroke --- 663,668 ---- *************** *** 679,689 **** 1.000 UL LTb 1.000 UL - LTa - 1370 1655 M - 669 437 V - 3791 -77 V - stroke LTb 1370 1655 M 63 0 V --- 672,677 ---- *************** *** 694,704 **** 1.000 UL LTb 1.000 UL - LTa - 1370 2158 M - 669 437 V - 3791 -76 V - stroke LTb 1370 2158 M 63 0 V --- 682,687 ---- *************** *** 709,719 **** 1.000 UL LTb 1.000 UL - LTa - 1370 2661 M - 669 438 V - 3791 -77 V - stroke LTb 1370 2661 M 63 0 V --- 692,697 ---- *************** *** 724,734 **** 1.000 UL LTb 1.000 UL - LTa - 1370 3165 M - 669 438 V - 3791 -78 V - stroke LTb 1370 3165 M 63 0 V --- 702,707 ---- *************** *** 739,749 **** 1.000 UL LTb 1.000 UL - LTa - 1370 3669 M - 669 437 V - 3791 -77 V - stroke LTb 1370 3669 M 63 0 V --- 712,717 ---- Binary files octave-2.9.15/doc/interpreter/grid.pdf and octave-2.9.16/doc/interpreter/grid.pdf differ Binary files octave-2.9.15/doc/interpreter/grid.png and octave-2.9.16/doc/interpreter/grid.png differ diff -cNr octave-2.9.15/doc/interpreter/griddata.eps octave-2.9.16/doc/interpreter/griddata.eps *** octave-2.9.15/doc/interpreter/griddata.eps Sat Oct 13 11:11:02 2007 --- octave-2.9.16/doc/interpreter/griddata.eps Wed Oct 31 18:09:30 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: griddata.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:02 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: griddata.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:30 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:02 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:30 2007) /DOCINFO pdfmark end } ifelse *************** *** 5385,5396 **** 1.000 UL LTb 1.000 UL - LTa - 901 1601 M - 2047 521 V - 6299 1365 M - 4105 2314 L - stroke LTb 964 1601 M -63 0 V --- 5385,5390 ---- *************** *** 5401,5418 **** 1.000 UL LTb 1.000 UL - LTa - 1158 1983 M - 1712 436 V - 901 1917 M - 247 63 V - 6299 1681 M - -240 104 V - -37 16 R - -2 1 V - -2 1 R - 4326 2535 L - stroke LTb 964 1917 M -63 0 V --- 5395,5400 ---- *************** *** 5423,5440 **** 1.000 UL LTb 1.000 UL - LTa - 1249 2322 M - 1491 380 V - 901 2234 M - 330 84 V - 6299 1998 M - -311 134 V - -28 13 R - -2 0 V - -59 26 R - 4511 2771 L - stroke LTb 964 2234 M -63 0 V --- 5405,5410 ---- *************** *** 5445,5462 **** 1.000 UL LTb 1.000 UL - LTa - 1353 2664 M - 1195 305 V - 901 2550 M - 418 106 V - 6299 2314 M - -390 169 V - -63 27 R - -2 1 V - -84 36 R - 4683 3013 L - stroke LTb 964 2550 M -63 0 V --- 5415,5420 ---- *************** *** 5467,5486 **** 1.000 UL LTb 1.000 UL - LTa - 1467 3010 M - 856 218 V - 901 2866 M - 521 132 V - 3358 289 R - -1 1 V - 6299 2630 M - -474 205 V - -32 13 R - -1 1 V - -257 111 R - -627 272 V - stroke LTb 964 2866 M -63 0 V --- 5425,5430 ---- *************** *** 5491,5516 **** 1.000 UL LTb 1.000 UL - LTa - 1622 3366 M - 2 0 V - 1698 433 R - 2 1 V - 2123 3494 M - 3 0 V - -125 -31 R - 7 1 V - 901 3182 M - 643 164 V - 2989 365 R - -6 2 V - 232 -100 R - -4 2 V - 6299 2946 M - -593 257 V - -503 218 R - -12 5 V - stroke LTb 964 3182 M -63 0 V --- 5435,5440 ---- *************** *** 5521,5542 **** 1.000 UL LTb 1.000 UL - LTa - 3794 4236 M - 161 41 V - 3063 4050 M - 7 2 V - 901 3499 M - 848 216 V - 2324 511 R - -118 51 V - 5142 3763 M - -7 4 V - 6299 3263 M - -766 331 V - -193 84 R - -4 1 V - stroke LTb 964 3499 M -63 0 V --- 5445,5450 ---- *************** *** 5547,5558 **** 1.000 UL LTb 1.000 UL - LTa - 901 3815 M - 3054 779 V - 6299 3579 M - 3955 4594 L - stroke LTb 964 3815 M -63 0 V --- 5455,5460 ---- Binary files octave-2.9.15/doc/interpreter/griddata.pdf and octave-2.9.16/doc/interpreter/griddata.pdf differ Binary files octave-2.9.15/doc/interpreter/griddata.png and octave-2.9.16/doc/interpreter/griddata.png differ diff -cNr octave-2.9.15/doc/interpreter/hist.eps octave-2.9.16/doc/interpreter/hist.eps *** octave-2.9.15/doc/interpreter/hist.eps Sat Oct 13 11:11:15 2007 --- octave-2.9.16/doc/interpreter/hist.eps Wed Oct 31 18:09:41 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: hist.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:15 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: hist.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:41 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:15 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:41 2007) /DOCINFO pdfmark end } ifelse *************** *** 503,1116 **** } ifelse 1.000 UL LTb ! 490 280 M 63 0 V ! 6409 0 R -63 0 V stroke ! 406 280 M [ [(Helvetica) 140.0 0.0 true true 0 (0)] ] -46.7 MRshow 1.000 UL LTb ! 490 758 M ! 63 0 V ! 6409 0 R ! -63 0 V ! stroke ! 406 758 M ! [ [(Helvetica) 140.0 0.0 true true 0 (100)] ! ] -46.7 MRshow ! 1.000 UL ! LTb ! 490 1237 M 63 0 V ! 6409 0 R -63 0 V stroke ! 406 1237 M [ [(Helvetica) 140.0 0.0 true true 0 (200)] ] -46.7 MRshow 1.000 UL LTb ! 490 1715 M 63 0 V ! 6409 0 R -63 0 V stroke ! 406 1715 M ! [ [(Helvetica) 140.0 0.0 true true 0 (300)] ! ] -46.7 MRshow ! 1.000 UL ! LTb ! 490 2193 M ! 63 0 V ! 6409 0 R ! -63 0 V ! stroke ! 406 2193 M [ [(Helvetica) 140.0 0.0 true true 0 (400)] ] -46.7 MRshow 1.000 UL LTb ! 490 2672 M 63 0 V ! 6409 0 R -63 0 V stroke ! 406 2672 M ! [ [(Helvetica) 140.0 0.0 true true 0 (500)] ! ] -46.7 MRshow ! 1.000 UL ! LTb ! 490 3150 M ! 63 0 V ! 6409 0 R ! -63 0 V ! stroke ! 406 3150 M [ [(Helvetica) 140.0 0.0 true true 0 (600)] ] -46.7 MRshow 1.000 UL LTb ! 490 3628 M ! 63 0 V ! 6409 0 R ! -63 0 V ! stroke ! 406 3628 M ! [ [(Helvetica) 140.0 0.0 true true 0 (700)] ! ] -46.7 MRshow ! 1.000 UL ! LTb ! 490 4107 M 63 0 V ! 6409 0 R -63 0 V stroke ! 406 4107 M [ [(Helvetica) 140.0 0.0 true true 0 (800)] ] -46.7 MRshow 1.000 UL LTb ! 490 4585 M 63 0 V ! 6409 0 R -63 0 V stroke ! 406 4585 M ! [ [(Helvetica) 140.0 0.0 true true 0 (900)] ] -46.7 MRshow 1.000 UL LTb ! 1277 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 1277 140 M [ [(Helvetica) 140.0 0.0 true true 0 (-3)] ] -46.7 MCshow 1.000 UL LTb ! 2152 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 2152 140 M [ [(Helvetica) 140.0 0.0 true true 0 (-2)] ] -46.7 MCshow 1.000 UL LTb ! 3026 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 3026 140 M [ [(Helvetica) 140.0 0.0 true true 0 (-1)] ] -46.7 MCshow 1.000 UL LTb ! 3901 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 3901 140 M [ [(Helvetica) 140.0 0.0 true true 0 (0)] ] -46.7 MCshow 1.000 UL LTb ! 4776 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 4776 140 M [ [(Helvetica) 140.0 0.0 true true 0 (1)] ] -46.7 MCshow 1.000 UL LTb ! 5650 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 5650 140 M [ [(Helvetica) 140.0 0.0 true true 0 (2)] ] -46.7 MCshow 1.000 UL LTb ! 6525 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 6525 140 M [ [(Helvetica) 140.0 0.0 true true 0 (3)] ] -46.7 MCshow 1.000 UL LTb 1.000 UL LTb ! 490 4872 N ! 490 280 L ! 6472 0 V 0 4592 V ! -6472 0 V Z stroke 1.000 UP 1.000 UL LTb 1.000 UL LT0 ! 1.00 0.00 0.00 C gsave 509 280 N 0 0 V 0 5 V 212 0 V 0 -5 V 1 PolyFill ! 509 280 M ! 0 5 V ! 212 0 V ! 0 -5 V stroke LT1 ! 0.00 0.00 0.00 C 509 280 M ! 0 5 V ! 212 0 V ! 0 -5 V ! -212 0 V ! stroke ! LT2 ! 1.00 0.00 0.00 C gsave 721 280 N 0 0 V 0 14 V 213 0 V 0 -14 V 1 PolyFill ! 721 280 M 0 14 V ! 213 0 V 0 -14 V stroke LT3 ! 0.00 0.00 0.00 C 721 280 M ! 0 14 V ! 213 0 V ! 0 -14 V ! -213 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 934 280 N 0 0 V 0 19 V 212 0 V 0 -19 V 1 PolyFill ! 934 280 M ! 0 19 V ! 212 0 V ! 0 -19 V stroke LT5 ! 0.00 0.00 0.00 C 934 280 M ! 0 19 V ! 212 0 V ! 0 -19 V ! -212 0 V stroke LT6 ! 1.00 0.00 0.00 C gsave 1146 280 N 0 0 V 0 81 V 213 0 V 0 -81 V 1 PolyFill ! 1146 280 M ! 0 81 V ! 213 0 V ! 0 -81 V stroke LT7 ! 0.00 0.00 0.00 C 1146 280 M ! 0 81 V ! 213 0 V ! 0 -81 V ! -213 0 V stroke LT8 ! 1.00 0.00 0.00 C gsave 1359 280 N 0 0 V 0 124 V 212 0 V 0 -124 V 1 PolyFill ! 1359 280 M ! 0 124 V ! 212 0 V ! 0 -124 V stroke LT0 ! 0.00 0.00 0.00 C 1359 280 M ! 0 124 V ! 212 0 V ! 0 -124 V ! -212 0 V stroke LT1 ! 1.00 0.00 0.00 C gsave 1571 280 N 0 0 V 0 220 V 213 0 V 0 -220 V 1 PolyFill ! 1571 280 M ! 0 220 V ! 213 0 V ! 0 -220 V stroke LT2 ! 0.00 0.00 0.00 C 1571 280 M ! 0 220 V ! 213 0 V ! 0 -220 V ! -213 0 V stroke LT3 ! 1.00 0.00 0.00 C gsave 1784 280 N 0 0 V 0 320 V 212 0 V 0 -320 V 1 PolyFill ! 1784 280 M ! 0 320 V ! 212 0 V ! 0 -320 V stroke LT4 ! 0.00 0.00 0.00 C 1784 280 M ! 0 320 V ! 212 0 V ! 0 -320 V ! -212 0 V stroke LT5 ! 1.00 0.00 0.00 C gsave 1996 280 N 0 0 V 0 588 V 213 0 V 0 -588 V 1 PolyFill ! 1996 280 M ! 0 588 V ! 213 0 V ! 0 -588 V stroke LT6 ! 0.00 0.00 0.00 C 1996 280 M ! 0 588 V ! 213 0 V ! 0 -588 V ! -213 0 V stroke LT7 ! 1.00 0.00 0.00 C gsave 2209 280 N 0 0 V 0 952 V 213 0 V 0 -952 V 1 PolyFill ! 2209 280 M ! 0 952 V ! 213 0 V ! 0 -952 V stroke LT8 ! 0.00 0.00 0.00 C 2209 280 M ! 0 952 V ! 213 0 V ! 0 -952 V ! -213 0 V stroke LT0 ! 1.00 0.00 0.00 C gsave 2422 280 N 0 0 V 0 1229 V 212 0 V 0 -1229 V 1 PolyFill ! 2422 280 M ! 0 1229 V ! 212 0 V ! 0 -1229 V stroke LT1 ! 0.00 0.00 0.00 C 2422 280 M ! 0 1229 V ! 212 0 V ! 0 -1229 V ! -212 0 V stroke LT2 ! 1.00 0.00 0.00 C gsave 2634 280 N 0 0 V 0 1976 V 213 0 V 0 -1976 V 1 PolyFill ! 2634 280 M ! 0 1976 V ! 213 0 V ! 0 -1976 V stroke LT3 ! 0.00 0.00 0.00 C 2634 280 M ! 0 1976 V ! 213 0 V ! 0 -1976 V ! -213 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 2847 280 N 0 0 V 0 2550 V 212 0 V 0 -2550 V 1 PolyFill ! 2847 280 M ! 0 2550 V ! 212 0 V ! 0 -2550 V stroke LT5 ! 0.00 0.00 0.00 C 2847 280 M ! 0 2550 V ! 212 0 V ! 0 -2550 V ! -212 0 V stroke LT6 ! 1.00 0.00 0.00 C gsave 3059 280 N 0 0 V 0 3095 V 213 0 V 0 -3095 V 1 PolyFill ! 3059 280 M ! 0 3095 V ! 213 0 V ! 0 -3095 V stroke LT7 ! 0.00 0.00 0.00 C 3059 280 M ! 0 3095 V ! 213 0 V ! 0 -3095 V ! -213 0 V stroke LT8 ! 1.00 0.00 0.00 C gsave 3272 280 N 0 0 V 0 4042 V 212 0 V 0 -4042 V 1 PolyFill ! 3272 280 M ! 0 4042 V ! 212 0 V ! 0 -4042 V stroke LT0 ! 0.00 0.00 0.00 C 3272 280 M ! 0 4042 V ! 212 0 V ! 0 -4042 V ! -212 0 V stroke LT1 ! 1.00 0.00 0.00 C gsave 3484 280 N 0 0 V 0 4147 V 213 0 V 0 -4147 V 1 PolyFill ! 3484 280 M ! 0 4147 V ! 213 0 V ! 0 -4147 V stroke LT2 ! 0.00 0.00 0.00 C 3484 280 M ! 0 4147 V ! 213 0 V ! 0 -4147 V ! -213 0 V stroke LT3 ! 1.00 0.00 0.00 C gsave 3697 280 N 0 0 V 0 4592 V 212 0 V 0 -4592 V 1 PolyFill ! 3697 280 M 0 4592 V ! 212 0 V 0 -4592 V stroke LT4 ! 0.00 0.00 0.00 C 3697 280 M 0 4592 V ! 212 0 V 0 -4592 V ! -212 0 V stroke LT5 ! 1.00 0.00 0.00 C gsave 3909 280 N 0 0 V 0 4592 V 213 0 V 0 -4592 V 1 PolyFill ! 3909 280 M ! 0 4592 V ! 213 0 V ! 0 -4592 V stroke LT6 ! 0.00 0.00 0.00 C 3909 280 M ! 0 4592 V ! 213 0 V ! 0 -4592 V ! -213 0 V stroke LT7 ! 1.00 0.00 0.00 C gsave 4122 280 N 0 0 V 0 4310 V 212 0 V 0 -4310 V 1 PolyFill ! 4122 280 M ! 0 4310 V ! 212 0 V ! 0 -4310 V stroke LT8 ! 0.00 0.00 0.00 C 4122 280 M ! 0 4310 V ! 212 0 V ! 0 -4310 V ! -212 0 V stroke LT0 ! 1.00 0.00 0.00 C gsave 4334 280 N 0 0 V 0 3745 V 213 0 V 0 -3745 V 1 PolyFill ! 4334 280 M ! 0 3745 V ! 213 0 V ! 0 -3745 V stroke LT1 ! 0.00 0.00 0.00 C 4334 280 M ! 0 3745 V ! 213 0 V ! 0 -3745 V ! -213 0 V stroke LT2 ! 1.00 0.00 0.00 C gsave 4547 280 N 0 0 V 0 3119 V 212 0 V 0 -3119 V 1 PolyFill ! 4547 280 M ! 0 3119 V ! 212 0 V ! 0 -3119 V stroke LT3 ! 0.00 0.00 0.00 C 4547 280 M ! 0 3119 V ! 212 0 V ! 0 -3119 V ! -212 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 4759 280 N 0 0 V 0 2449 V 213 0 V 0 -2449 V 1 PolyFill ! 4759 280 M ! 0 2449 V ! 213 0 V ! 0 -2449 V stroke LT5 ! 0.00 0.00 0.00 C 4759 280 M ! 0 2449 V ! 213 0 V ! 0 -2449 V ! -213 0 V stroke LT6 ! 1.00 0.00 0.00 C gsave 4972 280 N 0 0 V 0 2009 V 212 0 V 0 -2009 V 1 PolyFill ! 4972 280 M ! 0 2009 V ! 212 0 V ! 0 -2009 V stroke LT7 ! 0.00 0.00 0.00 C 4972 280 M ! 0 2009 V ! 212 0 V ! 0 -2009 V ! -212 0 V stroke LT8 ! 1.00 0.00 0.00 C gsave 5184 280 N 0 0 V 0 1387 V 213 0 V 0 -1387 V 1 PolyFill ! 5184 280 M ! 0 1387 V ! 213 0 V ! 0 -1387 V stroke LT0 ! 0.00 0.00 0.00 C 5184 280 M ! 0 1387 V ! 213 0 V ! 0 -1387 V ! -213 0 V stroke LT1 ! 1.00 0.00 0.00 C gsave 5397 280 N 0 0 V 0 971 V 212 0 V 0 -971 V 1 PolyFill ! 5397 280 M ! 0 971 V ! 212 0 V ! 0 -971 V stroke LT2 ! 0.00 0.00 0.00 C 5397 280 M ! 0 971 V ! 212 0 V ! 0 -971 V ! -212 0 V stroke LT3 ! 1.00 0.00 0.00 C gsave 5609 280 N 0 0 V 0 627 V 213 0 V 0 -627 V 1 PolyFill ! 5609 280 M ! 0 627 V ! 213 0 V ! 0 -627 V stroke LT4 ! 0.00 0.00 0.00 C 5609 280 M ! 0 627 V ! 213 0 V ! 0 -627 V ! -213 0 V stroke LT5 ! 1.00 0.00 0.00 C gsave 5822 280 N 0 0 V 0 277 V 212 0 V 0 -277 V 1 PolyFill ! 5822 280 M ! 0 277 V ! 212 0 V ! 0 -277 V stroke LT6 ! 0.00 0.00 0.00 C 5822 280 M ! 0 277 V ! 212 0 V ! 0 -277 V ! -212 0 V stroke LT7 ! 1.00 0.00 0.00 C gsave 6034 280 N 0 0 V 0 187 V 213 0 V 0 -187 V 1 PolyFill ! 6034 280 M ! 0 187 V ! 213 0 V ! 0 -187 V stroke LT8 ! 0.00 0.00 0.00 C 6034 280 M ! 0 187 V ! 213 0 V ! 0 -187 V ! -213 0 V stroke LT0 ! 1.00 0.00 0.00 C gsave 6247 280 N 0 0 V 0 115 V 213 0 V 0 -115 V 1 PolyFill ! 6247 280 M ! 0 115 V ! 213 0 V ! 0 -115 V stroke LT1 ! 0.00 0.00 0.00 C 6247 280 M ! 0 115 V ! 213 0 V ! 0 -115 V ! -213 0 V stroke LT2 ! 1.00 0.00 0.00 C gsave 6460 280 N 0 0 V 0 57 V 212 0 V 0 -57 V 1 PolyFill ! 6460 280 M ! 0 57 V ! 212 0 V ! 0 -57 V stroke LT3 ! 0.00 0.00 0.00 C 6460 280 M ! 0 57 V ! 212 0 V ! 0 -57 V ! -212 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 6672 280 N 0 0 V 0 33 V 213 0 V 0 -33 V 1 PolyFill ! 6672 280 M ! 0 33 V ! 213 0 V ! 0 -33 V stroke LT5 ! 0.00 0.00 0.00 C 6672 280 M ! 0 33 V ! 213 0 V ! 0 -33 V ! -213 0 V stroke LTb ! 490 4872 N ! 490 280 L ! 6472 0 V 0 4592 V ! -6472 0 V Z stroke 1.000 UP 1.000 UL --- 503,1076 ---- } ifelse 1.000 UL LTb ! 574 280 M 63 0 V ! 6325 0 R -63 0 V stroke ! 490 280 M [ [(Helvetica) 140.0 0.0 true true 0 (0)] ] -46.7 MRshow 1.000 UL LTb ! 574 1198 M 63 0 V ! 6325 0 R -63 0 V stroke ! 490 1198 M [ [(Helvetica) 140.0 0.0 true true 0 (200)] ] -46.7 MRshow 1.000 UL LTb ! 574 2117 M 63 0 V ! 6325 0 R -63 0 V stroke ! 490 2117 M [ [(Helvetica) 140.0 0.0 true true 0 (400)] ] -46.7 MRshow 1.000 UL LTb ! 574 3035 M 63 0 V ! 6325 0 R -63 0 V stroke ! 490 3035 M [ [(Helvetica) 140.0 0.0 true true 0 (600)] ] -46.7 MRshow 1.000 UL LTb ! 574 3954 M 63 0 V ! 6325 0 R -63 0 V stroke ! 490 3954 M [ [(Helvetica) 140.0 0.0 true true 0 (800)] ] -46.7 MRshow 1.000 UL LTb ! 574 4872 M 63 0 V ! 6325 0 R -63 0 V stroke ! 490 4872 M ! [ [(Helvetica) 140.0 0.0 true true 0 (1000)] ] -46.7 MRshow 1.000 UL LTb ! 1255 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 1255 140 M [ [(Helvetica) 140.0 0.0 true true 0 (-3)] ] -46.7 MCshow 1.000 UL LTb ! 2107 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 2107 140 M [ [(Helvetica) 140.0 0.0 true true 0 (-2)] ] -46.7 MCshow 1.000 UL LTb ! 2959 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 2959 140 M [ [(Helvetica) 140.0 0.0 true true 0 (-1)] ] -46.7 MCshow 1.000 UL LTb ! 3811 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 3811 140 M [ [(Helvetica) 140.0 0.0 true true 0 (0)] ] -46.7 MCshow 1.000 UL LTb ! 4662 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 4662 140 M [ [(Helvetica) 140.0 0.0 true true 0 (1)] ] -46.7 MCshow 1.000 UL LTb ! 5514 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 5514 140 M [ [(Helvetica) 140.0 0.0 true true 0 (2)] ] -46.7 MCshow 1.000 UL LTb ! 6366 280 M 0 63 V 0 4529 R 0 -63 V stroke ! 6366 140 M [ [(Helvetica) 140.0 0.0 true true 0 (3)] ] -46.7 MCshow 1.000 UL LTb 1.000 UL LTb ! 574 4872 N ! 574 280 L ! 6388 0 V 0 4592 V ! -6388 0 V Z stroke 1.000 UP 1.000 UL LTb 1.000 UL LT0 ! 1.00 0.00 0.00 C gsave 612 280 N 0 0 V 0 14 V 211 0 V 0 -14 V 1 PolyFill ! 612 280 M ! 0 14 V ! 211 0 V ! 0 -14 V stroke LT1 ! 0.00 0.00 0.00 C 612 280 M 0 14 V ! 211 0 V 0 -14 V + -211 0 V + stroke + LT2 + 1.00 0.00 0.00 C gsave 823 280 N 0 0 V 0 9 V 210 0 V 0 -9 V 1 PolyFill + 823 280 M + 0 9 V + 210 0 V + 0 -9 V stroke LT3 ! 0.00 0.00 0.00 C 823 280 M ! 0 9 V ! 210 0 V ! 0 -9 V ! -210 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 1033 280 N 0 0 V 0 46 V 210 0 V 0 -46 V 1 PolyFill ! 1033 280 M ! 0 46 V ! 210 0 V ! 0 -46 V stroke LT5 ! 0.00 0.00 0.00 C 1033 280 M ! 0 46 V ! 210 0 V ! 0 -46 V ! -210 0 V stroke LT6 ! 1.00 0.00 0.00 C gsave 1243 280 N 0 0 V 0 92 V 211 0 V 0 -92 V 1 PolyFill ! 1243 280 M ! 0 92 V ! 211 0 V ! 0 -92 V stroke LT7 ! 0.00 0.00 0.00 C 1243 280 M ! 0 92 V ! 211 0 V ! 0 -92 V ! -211 0 V stroke LT8 ! 1.00 0.00 0.00 C gsave 1454 280 N 0 0 V 0 115 V 210 0 V 0 -115 V 1 PolyFill ! 1454 280 M ! 0 115 V ! 210 0 V ! 0 -115 V stroke LT0 ! 0.00 0.00 0.00 C 1454 280 M ! 0 115 V ! 210 0 V ! 0 -115 V ! -210 0 V stroke LT1 ! 1.00 0.00 0.00 C gsave 1664 280 N 0 0 V 0 216 V 210 0 V 0 -216 V 1 PolyFill ! 1664 280 M ! 0 216 V ! 210 0 V ! 0 -216 V stroke LT2 ! 0.00 0.00 0.00 C 1664 280 M ! 0 216 V ! 210 0 V ! 0 -216 V ! -210 0 V stroke LT3 ! 1.00 0.00 0.00 C gsave 1874 280 N 0 0 V 0 432 V 211 0 V 0 -432 V 1 PolyFill ! 1874 280 M ! 0 432 V ! 211 0 V ! 0 -432 V stroke LT4 ! 0.00 0.00 0.00 C 1874 280 M ! 0 432 V ! 211 0 V ! 0 -432 V ! -211 0 V stroke LT5 ! 1.00 0.00 0.00 C gsave 2085 280 N 0 0 V 0 716 V 210 0 V 0 -716 V 1 PolyFill ! 2085 280 M ! 0 716 V ! 210 0 V ! 0 -716 V stroke LT6 ! 0.00 0.00 0.00 C 2085 280 M ! 0 716 V ! 210 0 V ! 0 -716 V ! -210 0 V stroke LT7 ! 1.00 0.00 0.00 C gsave 2295 280 N 0 0 V 0 1254 V 210 0 V 0 -1254 V 1 PolyFill ! 2295 280 M ! 0 1254 V ! 210 0 V ! 0 -1254 V stroke LT8 ! 0.00 0.00 0.00 C 2295 280 M ! 0 1254 V ! 210 0 V ! 0 -1254 V ! -210 0 V stroke LT0 ! 1.00 0.00 0.00 C gsave 2505 280 N 0 0 V 0 1828 V 211 0 V 0 -1828 V 1 PolyFill ! 2505 280 M ! 0 1828 V ! 211 0 V ! 0 -1828 V stroke LT1 ! 0.00 0.00 0.00 C 2505 280 M ! 0 1828 V ! 211 0 V ! 0 -1828 V ! -211 0 V stroke LT2 ! 1.00 0.00 0.00 C gsave 2716 280 N 0 0 V 0 2475 V 210 0 V 0 -2475 V 1 PolyFill ! 2716 280 M ! 0 2475 V ! 210 0 V ! 0 -2475 V stroke LT3 ! 0.00 0.00 0.00 C 2716 280 M ! 0 2475 V ! 210 0 V ! 0 -2475 V ! -210 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 2926 280 N 0 0 V 0 3049 V 210 0 V 0 -3049 V 1 PolyFill ! 2926 280 M ! 0 3049 V ! 210 0 V ! 0 -3049 V stroke LT5 ! 0.00 0.00 0.00 C 2926 280 M ! 0 3049 V ! 210 0 V ! 0 -3049 V ! -210 0 V stroke LT6 ! 1.00 0.00 0.00 C gsave 3136 280 N 0 0 V 0 3527 V 211 0 V 0 -3527 V 1 PolyFill ! 3136 280 M ! 0 3527 V ! 211 0 V ! 0 -3527 V stroke LT7 ! 0.00 0.00 0.00 C 3136 280 M ! 0 3527 V ! 211 0 V ! 0 -3527 V ! -211 0 V stroke LT8 ! 1.00 0.00 0.00 C gsave 3347 280 N 0 0 V 0 4004 V 210 0 V 0 -4004 V 1 PolyFill ! 3347 280 M ! 0 4004 V ! 210 0 V ! 0 -4004 V stroke LT0 ! 0.00 0.00 0.00 C 3347 280 M ! 0 4004 V ! 210 0 V ! 0 -4004 V ! -210 0 V stroke LT1 ! 1.00 0.00 0.00 C gsave 3557 280 N 0 0 V 0 4427 V 210 0 V 0 -4427 V 1 PolyFill ! 3557 280 M ! 0 4427 V ! 210 0 V ! 0 -4427 V stroke LT2 ! 0.00 0.00 0.00 C 3557 280 M ! 0 4427 V ! 210 0 V ! 0 -4427 V ! -210 0 V stroke LT3 ! 1.00 0.00 0.00 C gsave 3767 280 N 0 0 V 0 4592 V 211 0 V 0 -4592 V 1 PolyFill ! 3767 280 M 0 4592 V ! 211 0 V 0 -4592 V stroke LT4 ! 0.00 0.00 0.00 C 3767 280 M 0 4592 V ! 211 0 V 0 -4592 V ! -211 0 V stroke LT5 ! 1.00 0.00 0.00 C gsave 3978 280 N 0 0 V 0 4229 V 210 0 V 0 -4229 V 1 PolyFill ! 3978 280 M ! 0 4229 V ! 210 0 V ! 0 -4229 V stroke LT6 ! 0.00 0.00 0.00 C 3978 280 M ! 0 4229 V ! 210 0 V ! 0 -4229 V ! -210 0 V stroke LT7 ! 1.00 0.00 0.00 C gsave 4188 280 N 0 0 V 0 3830 V 211 0 V 0 -3830 V 1 PolyFill ! 4188 280 M ! 0 3830 V ! 211 0 V ! 0 -3830 V stroke LT8 ! 0.00 0.00 0.00 C 4188 280 M ! 0 3830 V ! 211 0 V ! 0 -3830 V ! -211 0 V stroke LT0 ! 1.00 0.00 0.00 C gsave 4399 280 N 0 0 V 0 3150 V 210 0 V 0 -3150 V 1 PolyFill ! 4399 280 M ! 0 3150 V ! 210 0 V ! 0 -3150 V stroke LT1 ! 0.00 0.00 0.00 C 4399 280 M ! 0 3150 V ! 210 0 V ! 0 -3150 V ! -210 0 V stroke LT2 ! 1.00 0.00 0.00 C gsave 4609 280 N 0 0 V 0 2599 V 210 0 V 0 -2599 V 1 PolyFill ! 4609 280 M ! 0 2599 V ! 210 0 V ! 0 -2599 V stroke LT3 ! 0.00 0.00 0.00 C 4609 280 M ! 0 2599 V ! 210 0 V ! 0 -2599 V ! -210 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 4819 280 N 0 0 V 0 1906 V 211 0 V 0 -1906 V 1 PolyFill ! 4819 280 M ! 0 1906 V ! 211 0 V ! 0 -1906 V stroke LT5 ! 0.00 0.00 0.00 C 4819 280 M ! 0 1906 V ! 211 0 V ! 0 -1906 V ! -211 0 V stroke LT6 ! 1.00 0.00 0.00 C gsave 5030 280 N 0 0 V 0 1295 V 210 0 V 0 -1295 V 1 PolyFill ! 5030 280 M ! 0 1295 V ! 210 0 V ! 0 -1295 V stroke LT7 ! 0.00 0.00 0.00 C 5030 280 M ! 0 1295 V ! 210 0 V ! 0 -1295 V ! -210 0 V stroke LT8 ! 1.00 0.00 0.00 C gsave 5240 280 N 0 0 V 0 914 V 210 0 V 0 -914 V 1 PolyFill ! 5240 280 M ! 0 914 V ! 210 0 V ! 0 -914 V stroke LT0 ! 0.00 0.00 0.00 C 5240 280 M ! 0 914 V ! 210 0 V ! 0 -914 V ! -210 0 V stroke LT1 ! 1.00 0.00 0.00 C gsave 5450 280 N 0 0 V 0 556 V 211 0 V 0 -556 V 1 PolyFill ! 5450 280 M ! 0 556 V ! 211 0 V ! 0 -556 V stroke LT2 ! 0.00 0.00 0.00 C 5450 280 M ! 0 556 V ! 211 0 V ! 0 -556 V ! -211 0 V stroke LT3 ! 1.00 0.00 0.00 C gsave 5661 280 N 0 0 V 0 257 V 210 0 V 0 -257 V 1 PolyFill ! 5661 280 M ! 0 257 V ! 210 0 V ! 0 -257 V stroke LT4 ! 0.00 0.00 0.00 C 5661 280 M ! 0 257 V ! 210 0 V ! 0 -257 V ! -210 0 V stroke LT5 ! 1.00 0.00 0.00 C gsave 5871 280 N 0 0 V 0 193 V 210 0 V 0 -193 V 1 PolyFill ! 5871 280 M ! 0 193 V ! 210 0 V ! 0 -193 V stroke LT6 ! 0.00 0.00 0.00 C 5871 280 M ! 0 193 V ! 210 0 V ! 0 -193 V ! -210 0 V stroke LT7 ! 1.00 0.00 0.00 C gsave 6081 280 N 0 0 V 0 110 V 211 0 V 0 -110 V 1 PolyFill ! 6081 280 M ! 0 110 V ! 211 0 V ! 0 -110 V stroke LT8 ! 0.00 0.00 0.00 C 6081 280 M ! 0 110 V ! 211 0 V ! 0 -110 V ! -211 0 V stroke LT0 ! 1.00 0.00 0.00 C gsave 6292 280 N 0 0 V 0 55 V 210 0 V 0 -55 V 1 PolyFill ! 6292 280 M ! 0 55 V ! 210 0 V ! 0 -55 V stroke LT1 ! 0.00 0.00 0.00 C 6292 280 M ! 0 55 V ! 210 0 V ! 0 -55 V ! -210 0 V stroke LT2 ! 1.00 0.00 0.00 C gsave 6502 280 N 0 0 V 0 23 V 210 0 V 0 -23 V 1 PolyFill ! 6502 280 M ! 0 23 V ! 210 0 V ! 0 -23 V stroke LT3 ! 0.00 0.00 0.00 C 6502 280 M ! 0 23 V ! 210 0 V ! 0 -23 V ! -210 0 V stroke LT4 ! 1.00 0.00 0.00 C gsave 6712 280 N 0 0 V 0 9 V 211 0 V 0 -9 V 1 PolyFill ! 6712 280 M ! 0 9 V ! 211 0 V ! 0 -9 V stroke LT5 ! 0.00 0.00 0.00 C 6712 280 M ! 0 9 V ! 211 0 V ! 0 -9 V ! -211 0 V stroke LTb ! 574 4872 N ! 574 280 L ! 6388 0 V 0 4592 V ! -6388 0 V Z stroke 1.000 UP 1.000 UL Binary files octave-2.9.15/doc/interpreter/hist.pdf and octave-2.9.16/doc/interpreter/hist.pdf differ Binary files octave-2.9.15/doc/interpreter/hist.png and octave-2.9.16/doc/interpreter/hist.png differ diff -cNr octave-2.9.15/doc/interpreter/image.texi octave-2.9.16/doc/interpreter/image.texi *** octave-2.9.15/doc/interpreter/image.texi Sat Oct 13 11:12:45 2007 --- octave-2.9.16/doc/interpreter/image.texi Wed Oct 31 18:11:03 2007 *************** *** 120,132 **** @deftypefn {Function File} {} imshow (@var{im}) @deftypefnx {Function File} {} imshow (@var{im}, @var{limits}) @deftypefnx {Function File} {} imshow (@var{im}, @var{map}) ! @deftypefnx {Function File} {} imshow (@var{R}, @var{G}, @var{B}, @dots{}) @deftypefnx {Function File} {} imshow (@var{filename}) @deftypefnx {Function File} {} imshow (@dots{}, @var{string_param1}, @var{value1}, @dots{}) Display the image @var{im}, where @var{im} can be a 2-dimensional ! (gray-scale image) or a 3-dimensional (RGB image) matrix. If three matrices ! of the same size are given as arguments, they will be concatenated into ! 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 --- 120,130 ---- @deftypefn {Function File} {} imshow (@var{im}) @deftypefnx {Function File} {} imshow (@var{im}, @var{limits}) @deftypefnx {Function File} {} imshow (@var{im}, @var{map}) ! @deftypefnx {Function File} {} imshow (@var{rgb}, @dots{}) @deftypefnx {Function File} {} imshow (@var{filename}) @deftypefnx {Function File} {} imshow (@dots{}, @var{string_param1}, @var{value1}, @dots{}) Display the image @var{im}, where @var{im} can be a 2-dimensional ! (gray-scale 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 diff -cNr octave-2.9.15/doc/interpreter/inpolygon.eps octave-2.9.16/doc/interpreter/inpolygon.eps *** octave-2.9.15/doc/interpreter/inpolygon.eps Sat Oct 13 11:11:10 2007 --- octave-2.9.16/doc/interpreter/inpolygon.eps Wed Oct 31 18:09:37 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: inpolygon.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:10 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: inpolygon.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:37 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:10 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:37 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/inpolygon.pdf and octave-2.9.16/doc/interpreter/inpolygon.pdf differ diff -cNr octave-2.9.15/doc/interpreter/install.texi octave-2.9.16/doc/interpreter/install.texi *** octave-2.9.15/doc/interpreter/install.texi Sat Oct 13 11:12:45 2007 --- octave-2.9.16/doc/interpreter/install.texi Wed Oct 31 18:11:03 2007 *************** *** 61,107 **** @item --srcdir=@var{dir} Look for Octave sources in the directory @var{dir}. ! @item --with-f2c ! Use @code{f2c} even if a Fortran compiler is available. ! ! @item --with-f77 ! Use @code{f77} to compile Fortran code. You may also specify the name ! of the compiler to use as an optional argument. For example, ! @code{--with-f77=g77} sets the name of the Fortran compiler to ! @code{g77}. @item --enable-shared ! Create shared libraries. If you are planning to use ! @code{--enable-lite-kernel} or the dynamic loading features, you will ! probably want to use this option. It will make your @file{.oct} files ! much smaller and on some systems it may be necessary to build shared ! libraries in order to use dynamically linked functions. You may also want to build a shared version of @code{libstdc++}, if your ! system doesn't already have one. Note that a patch is needed to build ! shared versions of version 2.7.2 of @code{libstdc++} on the HP-PA ! architecture. You can find the patch at ! @url{ftp://ftp.cygnus.com/pub/g++/libg++-2.7.2-hppa-gcc-fix}. @item --enable-dl Use @code{dlopen} and friends to make Octave capable of dynamically ! linking externally compiled functions. This only works on systems that ! actually have these functions. If you plan on using this feature, you should probably also use @code{--enable-shared} to reduce the size of your @file{.oct} files. - @item --enable-shl - Use @code{shl_load} and friends to make Octave capable of dynamically - linking externally compiled functions. This only works on systems that - actually have these functions (only HP-UX systems). If you plan on - using this feature, you should probably also use @code{--enable-shared} - to reduce the size of your @file{.oct} files. - - @item --enable-lite-kernel - Compile smaller kernel. This currently requires the dynamic linking - functions @code{dlopen} or @code{shl_load} and friends so that Octave - can load functions at run time that are not loaded at compile time. - @item --without-blas Compile and use the generic BLAS and LAPACK versions included with Octave. By default, configure first looks for BLAS and LAPACK matrix --- 61,101 ---- @item --srcdir=@var{dir} Look for Octave sources in the directory @var{dir}. ! @item --enable-bounds-check ! Enable bounds checking for indexing operators in the internal array ! classes. This option is primarily used for debugging Octave. Building ! Octave with this option has a negative impact on performace and is not ! recommended for general use. ! ! @item --enable-64 ! This is an @strong{experimental} option to enable Octave to use 64-bit ! integers for array dimensions and indexing on 64-bit platforms. You ! probably don't want to use this option unless you know what you are ! doing. ! ! If you use @code{--enable-64}, you must ensure that your Fortran ! compiler generates code with 8 byte signed @code{INTEGER} values, and ! that your BLAS and LAPACK libraries are compiled to use 8 byte ! signed integers for array dimensions and indexing. @item --enable-shared ! Create shared libraries (this is the default). If you are planning to ! use the dynamic loading features, you will probably want to use this ! option. It will make your @file{.oct} files much smaller and on some ! systems it may be necessary to build shared libraries in order to use ! dynamically linked functions. You may also want to build a shared version of @code{libstdc++}, if your ! system doesn't already have one. @item --enable-dl Use @code{dlopen} and friends to make Octave capable of dynamically ! linking externally compiled functions (this is the default if ! @code{--enable-shared} is specified). This option only works on systems ! that actually have these functions. If you plan on using this feature, you should probably also use @code{--enable-shared} to reduce the size of your @file{.oct} files. @item --without-blas Compile and use the generic BLAS and LAPACK versions included with Octave. By default, configure first looks for BLAS and LAPACK matrix *************** *** 113,118 **** --- 107,152 ---- @code{--with-blas=lib} to specify a particular BLAS library @code{-llib} that configure doesn't check for automatically. + @item --without-ccolamd + Don't use CCOLAMD, disable some sparse matrix functionality. + + @item --without-colamd + Don't use COLAMD, disable some sparse matrix functionality. + + @item --without-curl + Don't use the cURL, disable the @code{urlread} and @code{urlwrite} + functions. + + @item --without-cxsparse + Don't use CXSPARSE, disable some sparse matrix functionality. + + @item --without-umfpack + Don't use UMFPACK, disable some sparse matrix functionality. + + @item --without-fftw + Use the included fftpack library instead of the FFTW library. + + @item --without-glpk + Don't use the GLPK library for linear programming. + + @item --without-hdf5 + Don't use the HDF5 library for reading and writing HDF5 files. + + @item --without-zlib + Don't use the zlib library, disable data file compression and support + for recent MAT file formats. + + @item --without-lapack + Compile and use the generic BLAS and LAPACK versions included with + Octave. By default, configure first looks for BLAS and LAPACK matrix + libraries on your system, including optimized BLAS implementations such + as the free ATLAS 3.0, as well as vendor-tuned libraries. (The use of + an optimized BLAS will generally result in several-times faster matrix + operations.) Only use this option if your system has BLAS/LAPACK + libraries that cause problems for some reason. You can also use + @code{--with-blas=lib} to specify a particular BLAS library + @code{-llib} that configure doesn't check for automatically. + @item --help Print a summary of the options recognized by the configure script. @end table *************** *** 134,150 **** is a coincidence---it is not related to the GNU project or the FSF in any but the most peripheral sense. ! To compile Octave, you will need a recent version of GNU Make. You ! will also need @code{g++} 2.7.2 or later. Version 2.8.0 or @code{egcs} ! 1.0.x should work. Later versions may work, but C++ is still evolving, ! so don't be too surprised if you run into some trouble. ! ! It is no longer necessary to have @code{libg++}, but you do need to have ! the GNU implementation of @code{libstdc++}. If you are using @code{g++} ! 2.7.2, @code{libstdc++} is distributed along with @code{libg++}, but for ! later versions, @code{libstdc++} is distributed separately. For ! @code{egcs}, @code{libstdc++} is included with the compiler ! distribution. If you plan to modify the parser you will also need GNU @code{bison} and @code{flex}. If you modify the documentation, you will need GNU --- 168,179 ---- is a coincidence---it is not related to the GNU project or the FSF in any but the most peripheral sense. ! To compile Octave, you will need a recent version of GNU Make. You will ! also need a recent version of @code{g++} or other ANSI C++ compiler. You ! will also need a Fortran 77 compiler or @code{f2c}. If you use ! @code{f2c}, you will need a script like @code{fort77} that works like a ! normal Fortran compiler by combining @code{f2c} with your C compiler in ! a single script. If you plan to modify the parser you will also need GNU @code{bison} and @code{flex}. If you modify the documentation, you will need GNU *************** *** 158,174 **** @url{ftp.gnu.org} is available by anonymous ftp from @url{ftp://ftp.gnu.org/pub/gnu/GNUinfo/FTP}. ! If you don't have a Fortran compiler, or if your Fortran compiler ! doesn't work like the traditional Unix f77, you will need to have the ! Fortran to C translator @code{f2c}. You can get @code{f2c} from any ! number of anonymous ftp archives. The most recent version of @code{f2c} ! is always available from @url{netlib.att.com}. ! ! On an otherwise idle Pentium 133 running Linux, it will take somewhere ! between 1-1/2 to 3 hours to compile everything, depending on whether you ! are building shared libraries. You will need about 100 megabytes of disk ! storage to work with (considerably less if you don't compile with debugging ! symbols). To do that, use the command @example make CFLAGS=-O CXXFLAGS=-O LDFLAGS= --- 187,195 ---- @url{ftp.gnu.org} is available by anonymous ftp from @url{ftp://ftp.gnu.org/pub/gnu/GNUinfo/FTP}. ! You will need about 925 megabytes of disk storage to work with when ! building Octave from source (considerably less if you don't compile with ! debugging symbols). To do that, use the command @example make CFLAGS=-O CXXFLAGS=-O LDFLAGS= *************** *** 308,314 **** or @example ! warning: ANSI C++ prohibits conversion from `(int)' to `(...)' @end example @noindent --- 329,336 ---- or @example ! warning: ANSI C++ prohibits conversion from `(int)' ! to `(...)' @end example @noindent *************** *** 382,389 **** On NeXT systems, if you get errors like this: @example ! /usr/tmp/cc007458.s:unknown:Undefined local symbol LBB7656 ! /usr/tmp/cc007458.s:unknown:Undefined local symbol LBE7656 @end example @noindent --- 404,413 ---- On NeXT systems, if you get errors like this: @example ! /usr/tmp/cc007458.s:unknown:Undefined local ! symbol LBB7656 ! /usr/tmp/cc007458.s:unknown:Undefined local ! symbol LBE7656 @end example @noindent diff -cNr octave-2.9.15/doc/interpreter/install.txi octave-2.9.16/doc/interpreter/install.txi *** octave-2.9.15/doc/interpreter/install.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/install.txi Wed Oct 31 17:29:24 2007 *************** *** 59,105 **** @item --srcdir=@var{dir} Look for Octave sources in the directory @var{dir}. ! @item --with-f2c ! Use @code{f2c} even if a Fortran compiler is available. ! ! @item --with-f77 ! Use @code{f77} to compile Fortran code. You may also specify the name ! of the compiler to use as an optional argument. For example, ! @code{--with-f77=g77} sets the name of the Fortran compiler to ! @code{g77}. @item --enable-shared ! Create shared libraries. If you are planning to use ! @code{--enable-lite-kernel} or the dynamic loading features, you will ! probably want to use this option. It will make your @file{.oct} files ! much smaller and on some systems it may be necessary to build shared ! libraries in order to use dynamically linked functions. You may also want to build a shared version of @code{libstdc++}, if your ! system doesn't already have one. Note that a patch is needed to build ! shared versions of version 2.7.2 of @code{libstdc++} on the HP-PA ! architecture. You can find the patch at ! @url{ftp://ftp.cygnus.com/pub/g++/libg++-2.7.2-hppa-gcc-fix}. @item --enable-dl Use @code{dlopen} and friends to make Octave capable of dynamically ! linking externally compiled functions. This only works on systems that ! actually have these functions. If you plan on using this feature, you should probably also use @code{--enable-shared} to reduce the size of your @file{.oct} files. - @item --enable-shl - Use @code{shl_load} and friends to make Octave capable of dynamically - linking externally compiled functions. This only works on systems that - actually have these functions (only HP-UX systems). If you plan on - using this feature, you should probably also use @code{--enable-shared} - to reduce the size of your @file{.oct} files. - - @item --enable-lite-kernel - Compile smaller kernel. This currently requires the dynamic linking - functions @code{dlopen} or @code{shl_load} and friends so that Octave - can load functions at run time that are not loaded at compile time. - @item --without-blas Compile and use the generic BLAS and LAPACK versions included with Octave. By default, configure first looks for BLAS and LAPACK matrix --- 59,99 ---- @item --srcdir=@var{dir} Look for Octave sources in the directory @var{dir}. ! @item --enable-bounds-check ! Enable bounds checking for indexing operators in the internal array ! classes. This option is primarily used for debugging Octave. Building ! Octave with this option has a negative impact on performace and is not ! recommended for general use. ! ! @item --enable-64 ! This is an @strong{experimental} option to enable Octave to use 64-bit ! integers for array dimensions and indexing on 64-bit platforms. You ! probably don't want to use this option unless you know what you are ! doing. ! ! If you use @code{--enable-64}, you must ensure that your Fortran ! compiler generates code with 8 byte signed @code{INTEGER} values, and ! that your BLAS and LAPACK libraries are compiled to use 8 byte ! signed integers for array dimensions and indexing. @item --enable-shared ! Create shared libraries (this is the default). If you are planning to ! use the dynamic loading features, you will probably want to use this ! option. It will make your @file{.oct} files much smaller and on some ! systems it may be necessary to build shared libraries in order to use ! dynamically linked functions. You may also want to build a shared version of @code{libstdc++}, if your ! system doesn't already have one. @item --enable-dl Use @code{dlopen} and friends to make Octave capable of dynamically ! linking externally compiled functions (this is the default if ! @code{--enable-shared} is specified). This option only works on systems ! that actually have these functions. If you plan on using this feature, you should probably also use @code{--enable-shared} to reduce the size of your @file{.oct} files. @item --without-blas Compile and use the generic BLAS and LAPACK versions included with Octave. By default, configure first looks for BLAS and LAPACK matrix *************** *** 111,116 **** --- 105,150 ---- @code{--with-blas=lib} to specify a particular BLAS library @code{-llib} that configure doesn't check for automatically. + @item --without-ccolamd + Don't use CCOLAMD, disable some sparse matrix functionality. + + @item --without-colamd + Don't use COLAMD, disable some sparse matrix functionality. + + @item --without-curl + Don't use the cURL, disable the @code{urlread} and @code{urlwrite} + functions. + + @item --without-cxsparse + Don't use CXSPARSE, disable some sparse matrix functionality. + + @item --without-umfpack + Don't use UMFPACK, disable some sparse matrix functionality. + + @item --without-fftw + Use the included fftpack library instead of the FFTW library. + + @item --without-glpk + Don't use the GLPK library for linear programming. + + @item --without-hdf5 + Don't use the HDF5 library for reading and writing HDF5 files. + + @item --without-zlib + Don't use the zlib library, disable data file compression and support + for recent MAT file formats. + + @item --without-lapack + Compile and use the generic BLAS and LAPACK versions included with + Octave. By default, configure first looks for BLAS and LAPACK matrix + libraries on your system, including optimized BLAS implementations such + as the free ATLAS 3.0, as well as vendor-tuned libraries. (The use of + an optimized BLAS will generally result in several-times faster matrix + operations.) Only use this option if your system has BLAS/LAPACK + libraries that cause problems for some reason. You can also use + @code{--with-blas=lib} to specify a particular BLAS library + @code{-llib} that configure doesn't check for automatically. + @item --help Print a summary of the options recognized by the configure script. @end table *************** *** 132,148 **** is a coincidence---it is not related to the GNU project or the FSF in any but the most peripheral sense. ! To compile Octave, you will need a recent version of GNU Make. You ! will also need @code{g++} 2.7.2 or later. Version 2.8.0 or @code{egcs} ! 1.0.x should work. Later versions may work, but C++ is still evolving, ! so don't be too surprised if you run into some trouble. ! ! It is no longer necessary to have @code{libg++}, but you do need to have ! the GNU implementation of @code{libstdc++}. If you are using @code{g++} ! 2.7.2, @code{libstdc++} is distributed along with @code{libg++}, but for ! later versions, @code{libstdc++} is distributed separately. For ! @code{egcs}, @code{libstdc++} is included with the compiler ! distribution. If you plan to modify the parser you will also need GNU @code{bison} and @code{flex}. If you modify the documentation, you will need GNU --- 166,177 ---- is a coincidence---it is not related to the GNU project or the FSF in any but the most peripheral sense. ! To compile Octave, you will need a recent version of GNU Make. You will ! also need a recent version of @code{g++} or other ANSI C++ compiler. You ! will also need a Fortran 77 compiler or @code{f2c}. If you use ! @code{f2c}, you will need a script like @code{fort77} that works like a ! normal Fortran compiler by combining @code{f2c} with your C compiler in ! a single script. If you plan to modify the parser you will also need GNU @code{bison} and @code{flex}. If you modify the documentation, you will need GNU *************** *** 156,172 **** @url{ftp.gnu.org} is available by anonymous ftp from @url{ftp://ftp.gnu.org/pub/gnu/GNUinfo/FTP}. ! If you don't have a Fortran compiler, or if your Fortran compiler ! doesn't work like the traditional Unix f77, you will need to have the ! Fortran to C translator @code{f2c}. You can get @code{f2c} from any ! number of anonymous ftp archives. The most recent version of @code{f2c} ! is always available from @url{netlib.att.com}. ! ! On an otherwise idle Pentium 133 running Linux, it will take somewhere ! between 1-1/2 to 3 hours to compile everything, depending on whether you ! are building shared libraries. You will need about 100 megabytes of disk ! storage to work with (considerably less if you don't compile with debugging ! symbols). To do that, use the command @example make CFLAGS=-O CXXFLAGS=-O LDFLAGS= --- 185,193 ---- @url{ftp.gnu.org} is available by anonymous ftp from @url{ftp://ftp.gnu.org/pub/gnu/GNUinfo/FTP}. ! You will need about 925 megabytes of disk storage to work with when ! building Octave from source (considerably less if you don't compile with ! debugging symbols). To do that, use the command @example make CFLAGS=-O CXXFLAGS=-O LDFLAGS= *************** *** 306,312 **** or @example ! warning: ANSI C++ prohibits conversion from `(int)' to `(...)' @end example @noindent --- 327,334 ---- or @example ! warning: ANSI C++ prohibits conversion from `(int)' ! to `(...)' @end example @noindent *************** *** 380,387 **** On NeXT systems, if you get errors like this: @example ! /usr/tmp/cc007458.s:unknown:Undefined local symbol LBB7656 ! /usr/tmp/cc007458.s:unknown:Undefined local symbol LBE7656 @end example @noindent --- 402,411 ---- On NeXT systems, if you get errors like this: @example ! /usr/tmp/cc007458.s:unknown:Undefined local ! symbol LBB7656 ! /usr/tmp/cc007458.s:unknown:Undefined local ! symbol LBE7656 @end example @noindent diff -cNr octave-2.9.15/doc/interpreter/interpderiv1.eps octave-2.9.16/doc/interpreter/interpderiv1.eps *** octave-2.9.15/doc/interpreter/interpderiv1.eps Sat Oct 13 11:10:52 2007 --- octave-2.9.16/doc/interpreter/interpderiv1.eps Wed Oct 31 18:09:20 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpderiv1.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:52 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpderiv1.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:20 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:52 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:20 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/interpderiv1.pdf and octave-2.9.16/doc/interpreter/interpderiv1.pdf differ diff -cNr octave-2.9.15/doc/interpreter/interpderiv2.eps octave-2.9.16/doc/interpreter/interpderiv2.eps *** octave-2.9.15/doc/interpreter/interpderiv2.eps Sat Oct 13 11:10:54 2007 --- octave-2.9.16/doc/interpreter/interpderiv2.eps Wed Oct 31 18:09:23 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpderiv2.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:54 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpderiv2.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:23 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:54 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:23 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/interpderiv2.pdf and octave-2.9.16/doc/interpreter/interpderiv2.pdf differ diff -cNr octave-2.9.15/doc/interpreter/interpft.eps octave-2.9.16/doc/interpreter/interpft.eps *** octave-2.9.15/doc/interpreter/interpft.eps Sat Oct 13 11:10:46 2007 --- octave-2.9.16/doc/interpreter/interpft.eps Wed Oct 31 18:09:16 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpft.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:46 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpft.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:16 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:46 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:16 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/interpft.pdf and octave-2.9.16/doc/interpreter/interpft.pdf differ diff -cNr octave-2.9.15/doc/interpreter/interpn.eps octave-2.9.16/doc/interpreter/interpn.eps *** octave-2.9.15/doc/interpreter/interpn.eps Sat Oct 13 11:10:49 2007 --- octave-2.9.16/doc/interpreter/interpn.eps Wed Oct 31 18:09:18 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpn.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:49 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: interpn.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:18 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:49 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:18 2007) /DOCINFO pdfmark end } ifelse *************** *** 3749,3766 **** LTb 3905 2367 M 50 13 V - stroke - LTa - 901 1702 M - 571 145 V - 3652 127 R - 4061 2434 L - 5473 1823 M - -42 18 V - 868 -375 R - -818 354 V - stroke - LTb 964 1702 M -63 0 V stroke --- 3749,3754 ---- *************** *** 3770,3785 **** 1.000 UL LTb 1.000 UL - LTa - 3912 2972 M - 6 1 V - 2467 2603 M - 15 4 V - 901 2205 M - 278 71 V - 6299 1969 M - -265 114 V - stroke LTb 964 2205 M -63 0 V --- 3758,3763 ---- *************** *** 3789,3815 **** ] -46.7 MRshow 1.000 UL LTb - 1.000 UL - LTa - 3535 3379 M - 3 1 V - 4879 3086 M - -924 400 V - stroke 775 2708 M [ [(Helvetica) 140.0 0.0 true true 0 (1)] ] -46.7 MRshow 1.000 UL LTb 1.000 UL - LTa - 3360 3838 M - 595 152 V - 901 3211 M - 345 88 V - 6299 2975 M - 3955 3990 L - stroke LTb 964 3211 M -63 0 V --- 3767,3778 ---- *************** *** 3820,3833 **** 1.000 UL LTb 1.000 UL - LTa - 2429 4104 M - 1526 389 V - 901 3714 M - 1066 272 V - 6299 3478 M - 3955 4493 L - stroke LTb 964 3714 M -63 0 V --- 3783,3788 ---- Binary files octave-2.9.15/doc/interpreter/interpn.pdf and octave-2.9.16/doc/interpreter/interpn.pdf differ Binary files octave-2.9.15/doc/interpreter/interpn.png and octave-2.9.16/doc/interpreter/interpn.png differ diff -cNr octave-2.9.15/doc/interpreter/io.texi octave-2.9.16/doc/interpreter/io.texi *** octave-2.9.15/doc/interpreter/io.texi Sat Oct 13 11:12:46 2007 --- octave-2.9.16/doc/interpreter/io.texi Wed Oct 31 18:11:03 2007 *************** *** 711,719 **** the header comment is omitted from text-format data files. The default value is ! @example "# Created by Octave VERSION, %a %b %d %H:%M:%S %Y %Z " ! @end example @seealso{strftime} @end deftypefn --- 711,719 ---- the header comment is omitted from text-format data files. The default value is ! @smallexample "# Created by Octave VERSION, %a %b %d %H:%M:%S %Y %Z " ! @end smallexample @seealso{strftime} @end deftypefn *************** *** 848,855 **** by @var{tol} using a continued fraction expansion. E.g, @example ! rat(pi) = 3 + 1/(7 + 1/16) = 355/113 ! rat(e) = 3 + 1/(-4 + 1/(2 + 1/(5 + 1/(-2 + 1/(-7))))) = 1457/536 @end example Called with two arguments returns the numerator and denominator separately --- 848,856 ---- by @var{tol} using a continued fraction expansion. E.g, @example ! rat(pi) = 3 + 1/(7 + 1/16) = 355/113 ! rat(e) = 3 + 1/(-4 + 1/(2 + 1/(5 + 1/(-2 + 1/(-7))))) ! = 1457/536 @end example Called with two arguments returns the numerator and denominator separately *************** *** 1203,1217 **** @example pct = 37; filename = "foo.txt"; ! printf ("Processing of `%s' is %d%% finished.\nPlease be patient.\n", ! filename, pct); @end example @noindent produces output like @example ! Processing of `foo.txt' is 37% finished. Please be patient. @end example --- 1204,1218 ---- @example pct = 37; filename = "foo.txt"; ! printf ("Processed %d%% of `%s'.\nPlease be patient.\n", ! pct, filename); @end example @noindent produces output like @example ! Processed 37% of `foo.txt'. Please be patient. @end example diff -cNr octave-2.9.15/doc/interpreter/io.txi octave-2.9.16/doc/interpreter/io.txi *** octave-2.9.15/doc/interpreter/io.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/io.txi Mon Oct 15 11:30:04 2007 *************** *** 376,390 **** @example pct = 37; filename = "foo.txt"; ! printf ("Processing of `%s' is %d%% finished.\nPlease be patient.\n", ! filename, pct); @end example @noindent produces output like @example ! Processing of `foo.txt' is 37% finished. Please be patient. @end example --- 376,390 ---- @example pct = 37; filename = "foo.txt"; ! printf ("Processed %d%% of `%s'.\nPlease be patient.\n", ! pct, filename); @end example @noindent produces output like @example ! Processed 37% of `foo.txt'. Please be patient. @end example diff -cNr octave-2.9.15/doc/interpreter/linalg.texi octave-2.9.16/doc/interpreter/linalg.texi *** octave-2.9.15/doc/interpreter/linalg.texi Sat Oct 13 11:12:46 2007 --- octave-2.9.16/doc/interpreter/linalg.texi Wed Oct 31 18:11:03 2007 *************** *** 65,71 **** @item If the matrix is not square, or any of the previous solvers flags a singular or near singular matrix, find a least squares solution using ! the @sc{Lapack} xGELSY function. @end enumerate The user can force the type of the matrix with the @code{matrix_type} --- 65,71 ---- @item If the matrix is not square, or any of the previous solvers flags a singular or near singular matrix, find a least squares solution using ! the @sc{Lapack} xGELSD function. @end enumerate The user can force the type of the matrix with the @code{matrix_type} diff -cNr octave-2.9.15/doc/interpreter/linalg.txi octave-2.9.16/doc/interpreter/linalg.txi *** octave-2.9.15/doc/interpreter/linalg.txi Fri Oct 12 20:52:12 2007 --- octave-2.9.16/doc/interpreter/linalg.txi Fri Oct 26 11:52:57 2007 *************** *** 63,69 **** @item If the matrix is not square, or any of the previous solvers flags a singular or near singular matrix, find a least squares solution using ! the @sc{Lapack} xGELSY function. @end enumerate The user can force the type of the matrix with the @code{matrix_type} --- 63,69 ---- @item If the matrix is not square, or any of the previous solvers flags a singular or near singular matrix, find a least squares solution using ! the @sc{Lapack} xGELSD function. @end enumerate The user can force the type of the matrix with the @code{matrix_type} diff -cNr octave-2.9.15/doc/interpreter/matrix.texi octave-2.9.16/doc/interpreter/matrix.texi *** octave-2.9.15/doc/interpreter/matrix.texi Sat Oct 13 11:12:46 2007 --- octave-2.9.16/doc/interpreter/matrix.texi Wed Oct 31 18:11:03 2007 *************** *** 1073,1080 **** @end example @item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2} @example ! r1 = 2 * randg (n1 / 2) / n1 or 1 if n1 is infinite ! r2 = 2 * randg (n2 / 2) / n2 or 1 if n2 is infinite r = r1 / r2 @end example --- 1073,1080 ---- @end example @item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2} @example ! r1 = 2 * randg (n1 / 2) / n1 ## r1 equals 1 if n1 is infinite ! r2 = 2 * randg (n2 / 2) / n2 ## r2 equals 1 if n2 is infinite r = r1 / r2 @end example diff -cNr octave-2.9.15/doc/interpreter/mesh.eps octave-2.9.16/doc/interpreter/mesh.eps *** octave-2.9.15/doc/interpreter/mesh.eps Sat Oct 13 11:11:22 2007 --- octave-2.9.16/doc/interpreter/mesh.eps Wed Oct 31 18:09:47 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: mesh.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:22 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: mesh.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:47 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:22 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:47 2007) /DOCINFO pdfmark end } ifelse *************** *** 9692,9711 **** 1.000 UL LTb 1.000 UL - LTa - 1962 2042 M - 3 0 V - 901 1771 M - 704 180 V - 3158 249 R - -36 16 V - 404 -175 R - -3 1 V - 80 -34 R - -2 0 V - 6299 1535 M - -335 145 V - stroke LTb 964 1771 M -63 0 V --- 9692,9697 ---- *************** *** 9716,9735 **** 1.000 UL LTb 1.000 UL - LTa - 2117 2422 M - 6 2 V - 901 2112 M - 577 147 V - 6299 1876 M - -443 191 V - -319 139 R - -14 6 V - 4118 2819 M - -61 27 V - -80 34 R - -4 2 V - stroke LTb 964 2112 M -63 0 V --- 9702,9707 ---- *************** *** 9740,9753 **** 1.000 UL LTb 1.000 UL - LTa - 3924 3223 M - 31 8 V - 901 2453 M - 2307 587 V - 6299 2217 M - 3955 3231 L - stroke LTb 964 2453 M -63 0 V --- 9712,9717 ---- *************** *** 9758,9771 **** 1.000 UL LTb 1.000 UL - LTa - 3786 3528 M - 169 43 V - 901 2793 M - 2457 626 V - 6299 2558 M - 3955 3571 L - stroke LTb 964 2793 M -63 0 V --- 9722,9727 ---- *************** *** 9776,9787 **** 1.000 UL LTb 1.000 UL - LTa - 901 3134 M - 3054 778 V - 6299 2897 M - 3955 3912 L - stroke LTb 964 3134 M -63 0 V --- 9732,9737 ---- *************** *** 9792,9803 **** 1.000 UL LTb 1.000 UL - LTa - 901 3474 M - 3054 779 V - 6299 3238 M - 3955 4253 L - stroke LTb 964 3474 M -63 0 V --- 9742,9747 ---- *************** *** 9808,9819 **** 1.000 UL LTb 1.000 UL - LTa - 901 3815 M - 3054 779 V - 6299 3579 M - 3955 4594 L - stroke LTb 964 3815 M -63 0 V --- 9752,9757 ---- Binary files octave-2.9.15/doc/interpreter/mesh.pdf and octave-2.9.16/doc/interpreter/mesh.pdf differ Binary files octave-2.9.15/doc/interpreter/mesh.png and octave-2.9.16/doc/interpreter/mesh.png differ diff -cNr octave-2.9.15/doc/interpreter/munge-texi.cc octave-2.9.16/doc/interpreter/munge-texi.cc *** octave-2.9.15/doc/interpreter/munge-texi.cc Fri Oct 12 17:27:12 2007 --- octave-2.9.16/doc/interpreter/munge-texi.cc Mon Oct 22 12:55:41 2007 *************** *** 30,35 **** --- 30,38 ---- #include #include + #include + #include + static const char doc_delim = ''; static std::map help_text; Binary files octave-2.9.15/doc/interpreter/octave-a4.pdf and octave-2.9.16/doc/interpreter/octave-a4.pdf differ Binary files octave-2.9.15/doc/interpreter/octave.pdf and octave-2.9.16/doc/interpreter/octave.pdf differ diff -cNr octave-2.9.15/doc/interpreter/optim.texi octave-2.9.16/doc/interpreter/optim.texi *** octave-2.9.15/doc/interpreter/optim.texi Sat Oct 13 11:12:46 2007 --- octave-2.9.16/doc/interpreter/optim.texi Wed Oct 31 18:11:04 2007 *************** *** 645,651 **** If supplied, the gradient function must be of the form @example ! g = gradient (x) @end example @noindent --- 645,651 ---- If supplied, the gradient function must be of the form @example ! g = gradient (x) @end example @noindent *************** *** 654,660 **** If supplied, the hessian function must be of the form @example ! h = hessian (x) @end example @noindent --- 654,660 ---- If supplied, the hessian function must be of the form @example ! h = hessian (x) @end example @noindent *************** *** 671,677 **** of the form @example ! r = f (x) @end example @noindent --- 671,677 ---- of the form @example ! r = f (x) @end example @noindent *************** *** 702,736 **** Here is an example of calling @code{sqp}: @example ! function r = g (x) ! r = [ sumsq(x)-10; x(2)*x(3)-5*x(4)*x(5); x(1)^3+x(2)^3+1]; ! endfunction ! ! function obj = phi (x) ! obj = exp(prod(x)) - 0.5*(x(1)^3+x(2)^3+1)^2; ! endfunction ! ! x0 = [-1.8; 1.7; 1.9; -0.8; -0.8]; ! ! [x, obj, info, iter, nf, lambda] = sqp (x0, @@phi, @@g, []) ! ! x = ! ! -1.71714 ! 1.59571 ! 1.82725 ! -0.76364 ! -0.76364 ! ! obj = 0.053950 ! info = 101 ! iter = 8 ! nf = 10 ! lambda = ! -0.0401627 ! 0.0379578 ! -0.0052227 @end example The value returned in @var{info} may be one of the following: --- 702,738 ---- Here is an example of calling @code{sqp}: @example ! function r = g (x) ! r = [ sumsq(x)-10; ! x(2)*x(3)-5*x(4)*x(5); ! x(1)^3+x(2)^3+1 ]; ! endfunction ! ! function obj = phi (x) ! obj = exp(prod(x)) - 0.5*(x(1)^3+x(2)^3+1)^2; ! endfunction ! ! x0 = [-1.8; 1.7; 1.9; -0.8; -0.8]; ! ! [x, obj, info, iter, nf, lambda] = sqp (x0, @@phi, @@g, []) ! ! x = ! ! -1.71714 ! 1.59571 ! 1.82725 ! -0.76364 ! -0.76364 ! obj = 0.053950 ! info = 101 ! iter = 8 ! nf = 10 ! lambda = ! ! -0.0401627 ! 0.0379578 ! -0.0052227 @end example The value returned in @var{info} may be one of the following: diff -cNr octave-2.9.15/doc/interpreter/package.texi octave-2.9.16/doc/interpreter/package.texi *** octave-2.9.15/doc/interpreter/package.texi Sat Oct 13 11:12:46 2007 --- octave-2.9.16/doc/interpreter/package.texi Wed Oct 31 18:11:04 2007 *************** *** 65,73 **** @example @group pkg list ! @print{} Package Name | Version | Installation directory ! @print{} --------------+---------+----------------------- ! @print{} image *| 1.0.0 | /home/jwe/octave/image-1.0.0 @end group @end example --- 65,73 ---- @example @group pkg list ! @print{} Package Name | Version | Installation directory ! @print{} --------------+---------+----------------------- ! @print{} image *| 1.0.0 | /home/jwe/octave/image-1.0.0 @end group @end example *************** *** 309,319 **** Version: 1.0.0 Date: 2007-18-04 Author: The name (and possibly email) of the package author. ! Maintainer: The name (and possibly email) of the current package maintainer. Title: The title of the package ! Description: A short description of the package. If this description ! gets too long for one line it can continue on the next by adding a ! space to the beginning of the following lines. License: GPL version 3 or later @end example --- 309,321 ---- Version: 1.0.0 Date: 2007-18-04 Author: The name (and possibly email) of the package author. ! Maintainer: The name (and possibly email) of the current ! package maintainer. Title: The title of the package ! Description: A short description of the package. If this ! description gets too long for one line it can continue ! on the next by adding a space to the beginning of the ! following lines. License: GPL version 3 or later @end example diff -cNr octave-2.9.15/doc/interpreter/package.txi octave-2.9.16/doc/interpreter/package.txi *** octave-2.9.15/doc/interpreter/package.txi Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/interpreter/package.txi Mon Oct 15 11:30:04 2007 *************** *** 63,71 **** @example @group pkg list ! @print{} Package Name | Version | Installation directory ! @print{} --------------+---------+----------------------- ! @print{} image *| 1.0.0 | /home/jwe/octave/image-1.0.0 @end group @end example --- 63,71 ---- @example @group pkg list ! @print{} Package Name | Version | Installation directory ! @print{} --------------+---------+----------------------- ! @print{} image *| 1.0.0 | /home/jwe/octave/image-1.0.0 @end group @end example *************** *** 307,317 **** Version: 1.0.0 Date: 2007-18-04 Author: The name (and possibly email) of the package author. ! Maintainer: The name (and possibly email) of the current package maintainer. Title: The title of the package ! Description: A short description of the package. If this description ! gets too long for one line it can continue on the next by adding a ! space to the beginning of the following lines. License: GPL version 3 or later @end example --- 307,319 ---- Version: 1.0.0 Date: 2007-18-04 Author: The name (and possibly email) of the package author. ! Maintainer: The name (and possibly email) of the current ! package maintainer. Title: The title of the package ! Description: A short description of the package. If this ! description gets too long for one line it can continue ! on the next by adding a space to the beginning of the ! following lines. License: GPL version 3 or later @end example diff -cNr octave-2.9.15/doc/interpreter/plot.eps octave-2.9.16/doc/interpreter/plot.eps *** octave-2.9.15/doc/interpreter/plot.eps Sat Oct 13 11:11:12 2007 --- octave-2.9.16/doc/interpreter/plot.eps Wed Oct 31 18:09:39 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: plot.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:12 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: plot.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:39 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:12 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:39 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/plot.pdf and octave-2.9.16/doc/interpreter/plot.pdf differ diff -cNr octave-2.9.15/doc/interpreter/plot.texi octave-2.9.16/doc/interpreter/plot.texi *** octave-2.9.15/doc/interpreter/plot.texi Sat Oct 13 11:12:46 2007 --- octave-2.9.16/doc/interpreter/plot.texi Wed Oct 31 18:11:04 2007 *************** *** 313,319 **** @end float @anchor{doc-bar} ! @deftypefn {Function File} {@var{h} =} bar (@var{x}, @var{y}, @var{style}) @deftypefnx {Function File} {[@var{xb}, @var{yb}] =} bar (@dots{}) Given two vectors of x-y data, @code{bar} produce a bar graph. --- 313,319 ---- @end float @anchor{doc-bar} ! @deftypefn {Function File} {@var{h} =} bar (@var{x}, @var{y}, @var{p1}, @var{v1}, @dots{}) @deftypefnx {Function File} {[@var{xb}, @var{yb}] =} bar (@dots{}) Given two vectors of x-y data, @code{bar} produce a bar graph. *************** *** 323,329 **** If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values 'group' (the default), or 'stack'. If two output arguments are specified, the data are generated but not plotted. For example, --- 323,330 ---- If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values @code{"grouped"} (the default), ! or @code{"stacked"}. If two output arguments are specified, the data are generated but not plotted. For example, *************** *** 357,363 **** If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values 'group' (the default), or 'stack'. If two output arguments are specified, the data are generated but not plotted. For example, --- 358,365 ---- If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values @code{"grouped"} (the default), ! or @code{"stacked"}. If two output arguments are specified, the data are generated but not plotted. For example, *************** *** 1226,1233 **** \vskip 10pt \hfil\vbox{\offinterlineskip\hrule \halign{\vrule#&&\qquad\hfil#\hfil\qquad\vrule\cr ! height13pt&1&2&3&4\cr height12pt&&&&\cr\noalign{\hrule} ! height13pt&5&6&7&8\cr height12pt&&&&\cr\noalign{\hrule}}} \hfil \vskip 10pt @end tex --- 1228,1235 ---- \vskip 10pt \hfil\vbox{\offinterlineskip\hrule \halign{\vrule#&&\qquad\hfil#\hfil\qquad\vrule\cr ! height13pt&1&2&3\cr height12pt&&&&\cr\noalign{\hrule} ! height13pt&4&5&6\cr height12pt&&&&\cr\noalign{\hrule}}} \hfil \vskip 10pt @end tex *************** *** 1237,1247 **** @group @example ! +-----+-----+-----+-----+ ! | 1 | 2 | 3 | 4 | ! +-----+-----+-----+-----+ ! | 5 | 6 | 7 | 8 | ! +-----+-----+-----+-----+ @end example @end group @end display --- 1239,1249 ---- @group @example ! +-----+-----+-----+ ! | 1 | 2 | 3 | ! +-----+-----+-----+ ! | 4 | 5 | 6 | ! +-----+-----+-----+ @end example @end group @end display *************** *** 1347,1353 **** @item emf Microsoft Enhanced Metafile @item fig ! XFig @item hpgl HP plotter language @item mf --- 1349,1358 ---- @item emf Microsoft Enhanced Metafile @item fig ! XFig. If this format is selected the additional options ! @code{-textspecial} or @code{-textnormal} can be used to control ! whether the special flag should be set for the text in the figure ! (default is @code{-textnormal}). @item hpgl HP plotter language @item mf diff -cNr octave-2.9.15/doc/interpreter/plot3.eps octave-2.9.16/doc/interpreter/plot3.eps *** octave-2.9.15/doc/interpreter/plot3.eps Sat Oct 13 11:11:25 2007 --- octave-2.9.16/doc/interpreter/plot3.eps Wed Oct 31 18:09:49 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: plot3.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:25 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: plot3.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:49 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:25 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:49 2007) /DOCINFO pdfmark end } ifelse *************** *** 699,711 **** LTb 3955 2380 M -50 -13 V - stroke - LTa - 901 1601 M - 3054 779 V - 6299 1365 L - stroke - LTb 901 1601 M 63 0 V stroke --- 699,704 ---- *************** *** 715,725 **** 1.000 UL LTb 1.000 UL - LTa - 901 2044 M - 3054 778 V - 6299 1808 L - stroke LTb 901 2044 M 63 0 V --- 708,713 ---- *************** *** 730,740 **** 1.000 UL LTb 1.000 UL - LTa - 901 2487 M - 3054 778 V - 6299 2251 L - stroke LTb 901 2487 M 63 0 V --- 718,723 ---- *************** *** 745,755 **** 1.000 UL LTb 1.000 UL - LTa - 901 2929 M - 3054 779 V - 6299 2693 L - stroke LTb 901 2929 M 63 0 V --- 728,733 ---- *************** *** 760,770 **** 1.000 UL LTb 1.000 UL - LTa - 901 3372 M - 3054 779 V - 6299 3136 L - stroke LTb 901 3372 M 63 0 V --- 738,743 ---- *************** *** 775,785 **** 1.000 UL LTb 1.000 UL - LTa - 901 3815 M - 3054 779 V - 6299 3579 L - stroke LTb 901 3815 M 63 0 V --- 748,753 ---- Binary files octave-2.9.15/doc/interpreter/plot3.pdf and octave-2.9.16/doc/interpreter/plot3.pdf differ Binary files octave-2.9.15/doc/interpreter/plot3.png and octave-2.9.16/doc/interpreter/plot3.png differ diff -cNr octave-2.9.15/doc/interpreter/polar.eps octave-2.9.16/doc/interpreter/polar.eps *** octave-2.9.15/doc/interpreter/polar.eps Sat Oct 13 11:11:20 2007 --- octave-2.9.16/doc/interpreter/polar.eps Wed Oct 31 18:09:45 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: polar.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:11:20 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: polar.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:45 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:11:20 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:45 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/polar.pdf and octave-2.9.16/doc/interpreter/polar.pdf differ diff -cNr octave-2.9.15/doc/interpreter/poly.texi octave-2.9.16/doc/interpreter/poly.texi *** octave-2.9.15/doc/interpreter/poly.texi Sat Oct 13 11:12:46 2007 --- octave-2.9.16/doc/interpreter/poly.texi Wed Oct 31 18:11:04 2007 *************** *** 273,279 **** @example polygcd (poly(1:8), poly(3:12)) - poly(3:8) @result{} [ 0, 0, 0, 0, 0, 0, 0 ] ! deconv (poly(1:8), polygcd (poly(1:8), poly(3:12))) - poly(1:2) @result{} [ 0, 0, 0 ] @end example @seealso{poly, polyinteg, polyderiv, polyreduce, roots, conv, deconv, --- 273,280 ---- @example polygcd (poly(1:8), poly(3:12)) - poly(3:8) @result{} [ 0, 0, 0, 0, 0, 0, 0 ] ! deconv (poly(1:8), polygcd (poly(1:8), poly(3:12))) ... ! - poly(1:2) @result{} [ 0, 0, 0 ] @end example @seealso{poly, polyinteg, polyderiv, polyreduce, roots, conv, deconv, diff -cNr octave-2.9.15/doc/interpreter/preface.texi octave-2.9.16/doc/interpreter/preface.texi *** octave-2.9.15/doc/interpreter/preface.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/preface.texi Wed Oct 31 18:11:04 2007 *************** *** 85,92 **** @itemize @bullet @item The National Science Foundation, through grant numbers CTS-0105360, ! CTS-9708497, CTS-9311420, and CTS-8957123. @item The industrial members of the Texas-Wisconsin Modeling and Control --- 85,100 ---- @itemize @bullet @item + The United States Department of Energy, through grant number + DE-FG02-04ER25635. + + @item + Ashok Krishnamurthy, David Hudak, Juan Carlos Chaves, and Stanley + C. Ahalt of the Ohio Supercomputer Center. + + @item The National Science Foundation, through grant numbers CTS-0105360, ! CTS-9708497, CTS-9311420, CTS-8957123, and CNS-0540147. @item The industrial members of the Texas-Wisconsin Modeling and Control *************** *** 181,187 **** Boston, MA 02110-1301--1307@* USA @end quotation ! ! Octave is also available on the Internet from ! @url{ftp://ftp.octave.org/pub/octave}, and additional information is ! available from @url{http://www.octave.org}. --- 189,194 ---- Boston, MA 02110-1301--1307@* USA @end quotation ! ! Octave can also be downloaded from @url{http://www.octave.org}, where ! additional information also is available. diff -cNr octave-2.9.15/doc/interpreter/preface.txi octave-2.9.16/doc/interpreter/preface.txi *** octave-2.9.15/doc/interpreter/preface.txi Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/interpreter/preface.txi Wed Oct 31 17:03:48 2007 *************** *** 83,90 **** @itemize @bullet @item The National Science Foundation, through grant numbers CTS-0105360, ! CTS-9708497, CTS-9311420, and CTS-8957123. @item The industrial members of the Texas-Wisconsin Modeling and Control --- 83,98 ---- @itemize @bullet @item + The United States Department of Energy, through grant number + DE-FG02-04ER25635. + + @item + Ashok Krishnamurthy, David Hudak, Juan Carlos Chaves, and Stanley + C. Ahalt of the Ohio Supercomputer Center. + + @item The National Science Foundation, through grant numbers CTS-0105360, ! CTS-9708497, CTS-9311420, CTS-8957123, and CNS-0540147. @item The industrial members of the Texas-Wisconsin Modeling and Control *************** *** 179,185 **** Boston, MA 02110-1301--1307@* USA @end quotation ! ! Octave is also available on the Internet from ! @url{ftp://ftp.octave.org/pub/octave}, and additional information is ! available from @url{http://www.octave.org}. --- 187,192 ---- Boston, MA 02110-1301--1307@* USA @end quotation ! ! Octave can also be downloaded from @url{http://www.octave.org}, where ! additional information also is available. diff -cNr octave-2.9.15/doc/interpreter/signal.texi octave-2.9.16/doc/interpreter/signal.texi *** octave-2.9.15/doc/interpreter/signal.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/signal.texi Wed Oct 31 18:11:04 2007 *************** *** 475,491 **** coefficients @var{b} and CH coefficients @var{a}. I.e., the result @math{y(t)} follows the model ! @example y(t) = b(1) + b(2) * y(t-1) + @dots{} + b(lb) * y(t-lb+1) + e(t), ! @end example @noindent where @math{e(t)}, given @var{y} up to time @math{t-1}, is @math{N(0, h(t))}, with ! @example h(t) = a(1) + a(2) * e(t-1)^2 + @dots{} + a(la) * e(t-la+1)^2 ! @end example @end deftypefn --- 475,491 ---- coefficients @var{b} and CH coefficients @var{a}. I.e., the result @math{y(t)} follows the model ! @smallexample y(t) = b(1) + b(2) * y(t-1) + @dots{} + b(lb) * y(t-lb+1) + e(t), ! @end smallexample @noindent where @math{e(t)}, given @var{y} up to time @math{t-1}, is @math{N(0, h(t))}, with ! @smallexample h(t) = a(1) + a(2) * e(t-1)^2 + @dots{} + a(la) * e(t-la+1)^2 ! @end smallexample @end deftypefn diff -cNr octave-2.9.15/doc/interpreter/sparse.texi octave-2.9.16/doc/interpreter/sparse.texi *** octave-2.9.15/doc/interpreter/sparse.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/sparse.texi Wed Oct 31 18:11:04 2007 *************** *** 2118,2124 **** y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec, eigest] = pcg (A, b, [], [], "applyM"); semilogy (1:iter+1, resvec); @end group @end example --- 2118,2125 ---- y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec, eigest] = ... ! pcg (A, b, [], [], "applyM"); semilogy (1:iter+1, resvec); @end group @end example *************** *** 2274,2280 **** y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = pcr(A,b,[],[],'applyM') semilogy([1:iter+1], resvec); @end group @end example --- 2275,2282 ---- y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = ... ! pcr(A, b, [], [], 'applyM') semilogy([1:iter+1], resvec); @end group @end example *************** *** 2289,2295 **** y = x; y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = pcr(A,b,[],[],'applyM',[],3) @end group @end example --- 2291,2298 ---- y = x; y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = ... ! pcr(A, b, [], [], 'applyM', [], 3) @end group @end example diff -cNr octave-2.9.15/doc/interpreter/spchol.eps octave-2.9.16/doc/interpreter/spchol.eps *** octave-2.9.15/doc/interpreter/spchol.eps Sat Oct 13 11:10:41 2007 --- octave-2.9.16/doc/interpreter/spchol.eps Wed Oct 31 18:09:11 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: spchol.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:41 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: spchol.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:11 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:41 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:11 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/spchol.pdf and octave-2.9.16/doc/interpreter/spchol.pdf differ diff -cNr octave-2.9.15/doc/interpreter/spcholperm.eps octave-2.9.16/doc/interpreter/spcholperm.eps *** octave-2.9.15/doc/interpreter/spcholperm.eps Sat Oct 13 11:10:44 2007 --- octave-2.9.16/doc/interpreter/spcholperm.eps Wed Oct 31 18:09:13 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: spcholperm.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:44 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: spcholperm.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:13 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:44 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:13 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/spcholperm.pdf and octave-2.9.16/doc/interpreter/spcholperm.pdf differ diff -cNr octave-2.9.15/doc/interpreter/spmatrix.eps octave-2.9.16/doc/interpreter/spmatrix.eps *** octave-2.9.15/doc/interpreter/spmatrix.eps Sat Oct 13 11:10:38 2007 --- octave-2.9.16/doc/interpreter/spmatrix.eps Wed Oct 31 18:09:08 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: spmatrix.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:38 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: spmatrix.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:08 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:38 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:08 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/spmatrix.pdf and octave-2.9.16/doc/interpreter/spmatrix.pdf differ diff -cNr octave-2.9.15/doc/interpreter/stats.texi octave-2.9.16/doc/interpreter/stats.texi *** octave-2.9.15/doc/interpreter/stats.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/stats.texi Wed Oct 31 18:11:04 2007 *************** *** 746,751 **** --- 746,780 ---- Octave can perform several different statistical tests. The following table summarizes the available tests. + @iftex + @tex + \vskip 6pt + {\hbox to \hsize {\hfill\vbox{\offinterlineskip \tabskip=0pt + \halign{ + \vrule height2.0ex depth1.ex width 0.6pt #\tabskip=0.3em & + # \hfil & \vrule # & # \hfil & # \vrule width 0.6pt \tabskip=0pt\cr + \noalign{\hrule height 0.6pt} + & @strong{Hypothesis} && {\bf Test Functions} &\cr + \noalign{\hrule} + & Equal mean values && anova, hotelling\_test2, t\_test\_2, &\cr + & && welch\_test, wilcoxon\_test, z\_test\_2 &\cr + & Equal medians && kruskal\_wallis\_test, sign\_test &\cr + & Equal variances && bartlett\_test, manova, var\_test &\cr + & Equal distributions && chisquare\_test\_homogeneity, &\cr + & && kolmogorov\_smirnov\_test\_2, u\_test &\cr + & Equal marginal frequencies && mcnemar\_test &\cr + & Equal success probabilities && prop\_test\_2 &\cr + & Independent observations && chisquare\_test\_independence, &\cr + & && run\_test &\cr + & Uncorrelated observations && cor\_test &\cr + & Given mean value && hotelling\_test, t\_test, z\_test &\cr + & Observations from distribution && kolmogorov\_smirnov\_test &\cr + & Regression && f\_test\_regression, t\_test\_regression &\cr + \noalign{\hrule height 0.6pt} + }}\hfill}} + @end tex + @end iftex + @ifnottex @multitable @columnfractions .4 .5 @item @strong{Hypothesis} @tab @strong{Test Functions} *************** *** 774,779 **** --- 803,809 ---- @item Regression @tab @code{f_test_regression}, @code{t_test_regression} @end multitable + @end ifnottex The tests return a p-value that describes the outcome of the test. Assuming that the test hypothesis is true, the p-value is the probability *************** *** 1361,1367 **** fits the model @example ! logit (gamma_i (x)) = theta_i - beta' * x, i = 1, ..., k-1 @end example The number of ordinal categories, @var{k}, is taken to be the number --- 1391,1397 ---- fits the model @example ! logit (gamma_i (x)) = theta_i - beta' * x, i = 1...k-1 @end example The number of ordinal categories, @var{k}, is taken to be the number *************** *** 1410,1416 **** The following table summarizes the supported distributions (in alphabetical order). ! @multitable @columnfractions .4 .2 .2 .2 @item @strong{Distribution} @tab @strong{PDF} @tab @strong{CDF} --- 1440,1486 ---- The following table summarizes the supported distributions (in alphabetical order). ! @c Do the table explicitly in TeX if possible to get a better layout. ! @iftex ! @tex ! \vskip 6pt ! {\hbox to \hsize {\hfill\vbox{\offinterlineskip \tabskip=0pt ! \halign{ ! \vrule height2.0ex depth1.ex width 0.6pt #\tabskip=0.3em & ! # \hfil & \vrule # & # \hfil & \vrule # & # \hfil & \vrule # & # \hfil & ! # \vrule width 0.6pt \tabskip=0pt\cr ! \noalign{\hrule height 0.6pt} ! & {\bf Distribution} && {\bf PDF} && {\bf CDF} && {\bf Quantile}&\cr ! \noalign{\hrule} ! &Beta && betapdf && betacdf && betainv&\cr ! &Binomial && binopdf && binocdf && binoinv&\cr ! &Cauchy && cauchy\_pdf && cauchy\_cdf && cauchy\_inv&\cr ! &Chi-Square && chi2pdf && chi2cdf && chi2inv&\cr ! &Univariate Discrete && discrete\_pdf && discrete\_cdf && discrete\_inv&\cr ! &Empirical && empirical\_pdf && empirical\_cdf && empirical\_inv&\cr ! &Exponential && exppdf && expcdf && expinv&\cr ! &F && fpdf && fcdf && finv&\cr ! &Gamma && gampdf && gamcdf && gaminv&\cr ! &Geometric && geopdf && geocdf && geoinv&\cr ! &Hypergeometric && hygepdf && hygecdf && hygeinv&\cr ! &Kolmogorov Smirnov && {\it Not Available} && kolmogorov\_&& {\it Not Available}&\cr ! & && && smirnov\_cdf &&&\cr ! &Laplace && laplace\_pdf && laplace\_cdf && laplace\_inv&\cr ! &Logistic && logistic\_pdf && logistic\_cdf && logistic\_inv&\cr ! &Log-Normal && lognpdf && logncdf && logninv&\cr ! &Pascal && nbinpdf && nbincdf && nbininv&\cr ! &Univariate Normal && normpdf && normcdf && norminv&\cr ! &Poisson && poisspdf && poisscdf && poissinv&\cr ! &t (Student) && tpdf && tcdf && tinv&\cr ! &Univariate Discrete && unidpdf && unidcdf && unidinv&\cr ! &Uniform && unifpdf && unifcdf && unifinv&\cr ! &Weibull && wblpdf && wblcdf && wblinv&\cr ! \noalign{\hrule height 0.6pt} ! }}\hfill}} ! @end tex ! @end iftex ! @ifnottex ! @multitable @columnfractions .31 .23 .23 .23 @item @strong{Distribution} @tab @strong{PDF} @tab @strong{CDF} *************** *** 1491,1497 **** @tab @code{tpdf} @tab @code{tcdf} @tab @code{tinv} ! @item Univariate Discrete Distribution @tab @code{unidpdf} @tab @code{unidcdf} @tab @code{unidinv} --- 1561,1567 ---- @tab @code{tpdf} @tab @code{tcdf} @tab @code{tinv} ! @item Univariate Discrete Distribution @tab @code{unidpdf} @tab @code{unidcdf} @tab @code{unidinv} *************** *** 1504,1509 **** --- 1574,1580 ---- @tab @code{wblcdf} @tab @code{wblinv} @end multitable + @end ifnottex @anchor{doc-betacdf} @deftypefn {Function File} {} betacdf (@var{x}, @var{a}, @var{b}) *************** *** 2110,2115 **** --- 2181,2223 ---- The following table summarizes the available random number generators (in alphabetical order). + @iftex + @tex + \vskip 6pt + {\hbox to \hsize {\hfill\vbox{\offinterlineskip \tabskip=0pt + \halign{ + \vrule height2.0ex depth1.ex width 0.6pt #\tabskip=0.3em & + # \hfil & \vrule # & # \hfil & # \vrule width 0.6pt \tabskip=0pt\cr + \noalign{\hrule height 0.6pt} + & {\bf Distribution} && {\bf Function} &\cr + \noalign{\hrule} + & Beta Distribution && betarnd &\cr + & Binomial Distribution && binornd &\cr + & Cauchy Distribution && cauchy\_rnd &\cr + & Chi-Square Distribution && chi2rnd &\cr + & Univariate Discrete Distribution && discrete\_rnd &\cr + & Empirical Distribution && empirical\_rnd &\cr + & Exponential Distribution && exprnd &\cr + & F Distribution && frnd &\cr + & Gamma Distribution && gamrnd &\cr + & Geometric Distribution && geornd &\cr + & Hypergeometric Distribution && hygernd &\cr + & Laplace Distribution && laplace\_rnd &\cr + & Logistic Distribution && logistic\_rnd &\cr + & Log-Normal Distribution && lognrnd &\cr + & Pascal Distribution && nbinrnd &\cr + & Univariate Normal Distribution && normrnd &\cr + & Poisson Distribution && poissrnd &\cr + & t (Student) Distribution && trnd &\cr + & Univariate Discrete Distribution && unidrnd &\cr + & Uniform Distribution && unifrnd &\cr + & Weibull Distribution && wblrnd &\cr + & Wiener Process && wienrnd &\cr + \noalign{\hrule height 0.6pt} + }}\hfill}} + @end tex + @end iftex + @ifnottex @multitable @columnfractions .4 .3 @item @strong{Distribution} @tab @strong{Function} @item Beta Distribution @tab @code{betarnd} *************** *** 2135,2140 **** --- 2243,2249 ---- @item Weibull Distribution @tab @code{wblrnd} @item Wiener Process @tab @code{wienrnd} @end multitable + @end ifnottex @anchor{doc-betarnd} @deftypefn {Function File} {} betarnd (@var{a}, @var{b}, @var{r}, @var{c}) diff -cNr octave-2.9.15/doc/interpreter/stats.txi octave-2.9.16/doc/interpreter/stats.txi *** octave-2.9.15/doc/interpreter/stats.txi Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/interpreter/stats.txi Tue Oct 30 21:08:15 2007 *************** *** 146,151 **** --- 146,180 ---- Octave can perform several different statistical tests. The following table summarizes the available tests. + @iftex + @tex + \vskip 6pt + {\hbox to \hsize {\hfill\vbox{\offinterlineskip \tabskip=0pt + \halign{ + \vrule height2.0ex depth1.ex width 0.6pt #\tabskip=0.3em & + # \hfil & \vrule # & # \hfil & # \vrule width 0.6pt \tabskip=0pt\cr + \noalign{\hrule height 0.6pt} + & @strong{Hypothesis} && {\bf Test Functions} &\cr + \noalign{\hrule} + & Equal mean values && anova, hotelling\_test2, t\_test\_2, &\cr + & && welch\_test, wilcoxon\_test, z\_test\_2 &\cr + & Equal medians && kruskal\_wallis\_test, sign\_test &\cr + & Equal variances && bartlett\_test, manova, var\_test &\cr + & Equal distributions && chisquare\_test\_homogeneity, &\cr + & && kolmogorov\_smirnov\_test\_2, u\_test &\cr + & Equal marginal frequencies && mcnemar\_test &\cr + & Equal success probabilities && prop\_test\_2 &\cr + & Independent observations && chisquare\_test\_independence, &\cr + & && run\_test &\cr + & Uncorrelated observations && cor\_test &\cr + & Given mean value && hotelling\_test, t\_test, z\_test &\cr + & Observations from distribution && kolmogorov\_smirnov\_test &\cr + & Regression && f\_test\_regression, t\_test\_regression &\cr + \noalign{\hrule height 0.6pt} + }}\hfill}} + @end tex + @end iftex + @ifnottex @multitable @columnfractions .4 .5 @item @strong{Hypothesis} @tab @strong{Test Functions} *************** *** 174,179 **** --- 203,209 ---- @item Regression @tab @code{f_test_regression}, @code{t_test_regression} @end multitable + @end ifnottex The tests return a p-value that describes the outcome of the test. Assuming that the test hypothesis is true, the p-value is the probability *************** *** 246,252 **** The following table summarizes the supported distributions (in alphabetical order). ! @multitable @columnfractions .4 .2 .2 .2 @item @strong{Distribution} @tab @strong{PDF} @tab @strong{CDF} --- 276,322 ---- The following table summarizes the supported distributions (in alphabetical order). ! @c Do the table explicitly in TeX if possible to get a better layout. ! @iftex ! @tex ! \vskip 6pt ! {\hbox to \hsize {\hfill\vbox{\offinterlineskip \tabskip=0pt ! \halign{ ! \vrule height2.0ex depth1.ex width 0.6pt #\tabskip=0.3em & ! # \hfil & \vrule # & # \hfil & \vrule # & # \hfil & \vrule # & # \hfil & ! # \vrule width 0.6pt \tabskip=0pt\cr ! \noalign{\hrule height 0.6pt} ! & {\bf Distribution} && {\bf PDF} && {\bf CDF} && {\bf Quantile}&\cr ! \noalign{\hrule} ! &Beta && betapdf && betacdf && betainv&\cr ! &Binomial && binopdf && binocdf && binoinv&\cr ! &Cauchy && cauchy\_pdf && cauchy\_cdf && cauchy\_inv&\cr ! &Chi-Square && chi2pdf && chi2cdf && chi2inv&\cr ! &Univariate Discrete && discrete\_pdf && discrete\_cdf && discrete\_inv&\cr ! &Empirical && empirical\_pdf && empirical\_cdf && empirical\_inv&\cr ! &Exponential && exppdf && expcdf && expinv&\cr ! &F && fpdf && fcdf && finv&\cr ! &Gamma && gampdf && gamcdf && gaminv&\cr ! &Geometric && geopdf && geocdf && geoinv&\cr ! &Hypergeometric && hygepdf && hygecdf && hygeinv&\cr ! &Kolmogorov Smirnov && {\it Not Available} && kolmogorov\_&& {\it Not Available}&\cr ! & && && smirnov\_cdf &&&\cr ! &Laplace && laplace\_pdf && laplace\_cdf && laplace\_inv&\cr ! &Logistic && logistic\_pdf && logistic\_cdf && logistic\_inv&\cr ! &Log-Normal && lognpdf && logncdf && logninv&\cr ! &Pascal && nbinpdf && nbincdf && nbininv&\cr ! &Univariate Normal && normpdf && normcdf && norminv&\cr ! &Poisson && poisspdf && poisscdf && poissinv&\cr ! &t (Student) && tpdf && tcdf && tinv&\cr ! &Univariate Discrete && unidpdf && unidcdf && unidinv&\cr ! &Uniform && unifpdf && unifcdf && unifinv&\cr ! &Weibull && wblpdf && wblcdf && wblinv&\cr ! \noalign{\hrule height 0.6pt} ! }}\hfill}} ! @end tex ! @end iftex ! @ifnottex ! @multitable @columnfractions .31 .23 .23 .23 @item @strong{Distribution} @tab @strong{PDF} @tab @strong{CDF} *************** *** 327,333 **** @tab @code{tpdf} @tab @code{tcdf} @tab @code{tinv} ! @item Univariate Discrete Distribution @tab @code{unidpdf} @tab @code{unidcdf} @tab @code{unidinv} --- 397,403 ---- @tab @code{tpdf} @tab @code{tcdf} @tab @code{tinv} ! @item Univariate Discrete Distribution @tab @code{unidpdf} @tab @code{unidcdf} @tab @code{unidinv} *************** *** 340,345 **** --- 410,416 ---- @tab @code{wblcdf} @tab @code{wblinv} @end multitable + @end ifnottex @DOCSTRING(betacdf) *************** *** 480,485 **** --- 551,593 ---- The following table summarizes the available random number generators (in alphabetical order). + @iftex + @tex + \vskip 6pt + {\hbox to \hsize {\hfill\vbox{\offinterlineskip \tabskip=0pt + \halign{ + \vrule height2.0ex depth1.ex width 0.6pt #\tabskip=0.3em & + # \hfil & \vrule # & # \hfil & # \vrule width 0.6pt \tabskip=0pt\cr + \noalign{\hrule height 0.6pt} + & {\bf Distribution} && {\bf Function} &\cr + \noalign{\hrule} + & Beta Distribution && betarnd &\cr + & Binomial Distribution && binornd &\cr + & Cauchy Distribution && cauchy\_rnd &\cr + & Chi-Square Distribution && chi2rnd &\cr + & Univariate Discrete Distribution && discrete\_rnd &\cr + & Empirical Distribution && empirical\_rnd &\cr + & Exponential Distribution && exprnd &\cr + & F Distribution && frnd &\cr + & Gamma Distribution && gamrnd &\cr + & Geometric Distribution && geornd &\cr + & Hypergeometric Distribution && hygernd &\cr + & Laplace Distribution && laplace\_rnd &\cr + & Logistic Distribution && logistic\_rnd &\cr + & Log-Normal Distribution && lognrnd &\cr + & Pascal Distribution && nbinrnd &\cr + & Univariate Normal Distribution && normrnd &\cr + & Poisson Distribution && poissrnd &\cr + & t (Student) Distribution && trnd &\cr + & Univariate Discrete Distribution && unidrnd &\cr + & Uniform Distribution && unifrnd &\cr + & Weibull Distribution && wblrnd &\cr + & Wiener Process && wienrnd &\cr + \noalign{\hrule height 0.6pt} + }}\hfill}} + @end tex + @end iftex + @ifnottex @multitable @columnfractions .4 .3 @item @strong{Distribution} @tab @strong{Function} @item Beta Distribution @tab @code{betarnd} *************** *** 505,510 **** --- 613,619 ---- @item Weibull Distribution @tab @code{wblrnd} @item Wiener Process @tab @code{wienrnd} @end multitable + @end ifnottex @DOCSTRING(betarnd) diff -cNr octave-2.9.15/doc/interpreter/strings.texi octave-2.9.16/doc/interpreter/strings.texi *** octave-2.9.15/doc/interpreter/strings.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/strings.texi Wed Oct 31 18:11:05 2007 *************** *** 350,357 **** @example GNU = "GNU's Not UNIX"; spaces = (GNU == " ") ! @result{} spaces = ! 0 0 0 0 0 1 0 0 0 1 0 0 0 0 @end example @noindent --- 350,357 ---- @example GNU = "GNU's Not UNIX"; spaces = (GNU == " ") ! @result{} spaces = ! 0 0 0 0 0 1 0 0 0 1 0 0 0 0 @end example @noindent *************** *** 454,462 **** all blank characters with underscores. @example ! quote = "First things first, but not necessarily in that order"; quote( quote == " " ) = "_" ! @print{} quote = First_things_first,_but_not_necessarily_in_that_order @end example For more complex manipulations, such as searching, replacing, and --- 454,464 ---- all blank characters with underscores. @example ! quote = ... ! "First things first, but not necessarily in that order"; quote( quote == " " ) = "_" ! @result{} quote = ! First_things_first,_but_not_necessarily_in_that_order @end example For more complex manipulations, such as searching, replacing, and *************** *** 995,1006 **** 3.1400 4.4440 0.7000 -10.0000 NaN NaN ! line = "200,300,400,NaN,-inf,cd,yes,no,999,maybe,NaN"; [x, status] = str2double (line) ! x = ! 200 300 400 NaN -Inf NaN NaN NaN 999 NaN NaN ! status = ! 0 0 0 0 0 -1 -1 -1 0 -1 0 @end example @end deftypefn --- 997,1008 ---- 3.1400 4.4440 0.7000 -10.0000 NaN NaN ! line = "200, 300, NaN, -inf, yes, no, 999, maybe, NaN"; [x, status] = str2double (line) ! @result{} x = ! 200 300 NaN -Inf NaN NaN 999 NaN NaN ! @result{} status = ! 0 0 0 0 -1 -1 0 -1 0 @end example @end deftypefn diff -cNr octave-2.9.15/doc/interpreter/strings.txi octave-2.9.16/doc/interpreter/strings.txi *** octave-2.9.15/doc/interpreter/strings.txi Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/interpreter/strings.txi Tue Oct 30 21:08:15 2007 *************** *** 211,218 **** @example GNU = "GNU's Not UNIX"; spaces = (GNU == " ") ! @result{} spaces = ! 0 0 0 0 0 1 0 0 0 1 0 0 0 0 @end example @noindent --- 211,218 ---- @example GNU = "GNU's Not UNIX"; spaces = (GNU == " ") ! @result{} spaces = ! 0 0 0 0 0 1 0 0 0 1 0 0 0 0 @end example @noindent *************** *** 237,245 **** all blank characters with underscores. @example ! quote = "First things first, but not necessarily in that order"; quote( quote == " " ) = "_" ! @print{} quote = First_things_first,_but_not_necessarily_in_that_order @end example For more complex manipulations, such as searching, replacing, and --- 237,247 ---- all blank characters with underscores. @example ! quote = ... ! "First things first, but not necessarily in that order"; quote( quote == " " ) = "_" ! @result{} quote = ! First_things_first,_but_not_necessarily_in_that_order @end example For more complex manipulations, such as searching, replacing, and diff -cNr octave-2.9.15/doc/interpreter/system.texi octave-2.9.16/doc/interpreter/system.texi *** octave-2.9.15/doc/interpreter/system.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/system.texi Wed Oct 31 18:11:05 2007 *************** *** 437,443 **** @anchor{doc-cputime} ! @deftypefn {Function File} {[@var{total}, @var{user}, @var{system}] =} cputime (); Return the CPU time used by your Octave session. The first output is the total time spent executing your process and is equal to the sum of second and third outputs, which are the number of CPU seconds spent --- 437,443 ---- @anchor{doc-cputime} ! @deftypefn {Built-in Function} {[@var{total}, @var{user}, @var{system}] =} cputime (); Return the CPU time used by your Octave session. The first output is the total time spent executing your process and is equal to the sum of second and third outputs, which are the number of CPU seconds spent *************** *** 466,480 **** @anchor{doc-tic} ! @deftypefn {Function File} {} tic () ! @deftypefnx {Function File} {} toc () Set or check a wall-clock timer. Calling @code{tic} without an output argument sets the timer. Subsequent calls to @code{toc} return the number of seconds since the timer was set. For example, @example tic (); ! many computations later... elapsed_time = toc (); @end example --- 466,480 ---- @anchor{doc-tic} ! @deftypefn {Built-in Function} {} tic () ! @deftypefnx {Built-in Function} {} toc () Set or check a wall-clock timer. Calling @code{tic} without an output argument sets the timer. Subsequent calls to @code{toc} return the number of seconds since the timer was set. For example, @example tic (); ! # many computations later... elapsed_time = toc (); @end example *************** *** 488,494 **** @example @group t = tic; sleep (5); (double (tic ()) - double (t)) * 1e-6 ! @result{} 5 @end group @end example --- 488,494 ---- @example @group t = tic; sleep (5); (double (tic ()) - double (t)) * 1e-6 ! @result{} 5 @end group @end example *************** *** 505,513 **** @example @group tic (); sleep (5); toc () ! @result{} 5 t = cputime (); sleep (5); cputime () - t ! @result{} 0 @end group @end example --- 505,513 ---- @example @group tic (); sleep (5); toc () ! @result{} 5 t = cputime (); sleep (5); cputime () - t ! @result{} 0 @end group @end example *************** *** 1260,1266 **** URL. For example, @example ! s = urlread ("http://username:password@@example.com/file.txt"); @end example GET and POST requests can be specified by @var{method} and @var{param}. --- 1260,1266 ---- URL. For example, @example ! s = urlread ("http://user:password@@example.com/file.txt"); @end example GET and POST requests can be specified by @var{method} and @var{param}. *************** *** 1285,1291 **** @var{localfile}. For example, @example ! urlwrite ("ftp://ftp.octave.org/pub/octave/README", "README.txt"); @end example The full path of the downloaded file is returned in @var{f}. The --- 1285,1292 ---- @var{localfile}. For example, @example ! urlwrite ("ftp://ftp.octave.org/pub/octave/README", ! "README.txt"); @end example The full path of the downloaded file is returned in @var{f}. The diff -cNr octave-2.9.15/doc/interpreter/testfun.texi octave-2.9.16/doc/interpreter/testfun.texi *** octave-2.9.15/doc/interpreter/testfun.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/testfun.texi Wed Oct 31 18:11:05 2007 *************** *** 100,106 **** @example @group %!test error ("this test fails!"); ! %!test "this test doesn't fail since it doesn't generate an error"; @end group @end example --- 100,106 ---- @example @group %!test error ("this test fails!"); ! %!test "test doesn't fail. it doesn't generate an error"; @end group @end example *************** *** 364,373 **** lists or structures. @item assert(@var{observed}, @var{expected}, @var{tol}) ! Produce an error if relative error is less than tolerance. That is, ! @code{abs(@var{observed} - @var{expected}) > @var{tol} * @var{expected}}. ! Absolute error @code{abs(@var{observed} - @var{expected}) > abs(@var{tol})} ! will be used when tolerance is negative or when the expected value is zero. @end table @seealso{test} @end deftypefn --- 364,375 ---- lists or structures. @item assert(@var{observed}, @var{expected}, @var{tol}) ! Accept a tolerance when comparing numbers. ! If @var{tol} is possitive use it as an absolute tolerance, will produce an error if ! @code{abs(@var{observed} - @var{expected}) > abs(@var{tol})}. ! If @var{tol} is negative use it as a relative tolerance, will produce an error if ! @code{abs(@var{observed} - @var{expected}) > abs(@var{tol} * @var{expected})}. ! If @var{expected} is zero @var{tol} will always be used as an absolute tolerance. @end table @seealso{test} @end deftypefn diff -cNr octave-2.9.15/doc/interpreter/testfun.txi octave-2.9.16/doc/interpreter/testfun.txi *** octave-2.9.15/doc/interpreter/testfun.txi Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/interpreter/testfun.txi Tue Oct 30 21:08:15 2007 *************** *** 47,53 **** @example @group %!test error ("this test fails!"); ! %!test "this test doesn't fail since it doesn't generate an error"; @end group @end example --- 47,53 ---- @example @group %!test error ("this test fails!"); ! %!test "test doesn't fail. it doesn't generate an error"; @end group @end example diff -cNr octave-2.9.15/doc/interpreter/tips.texi octave-2.9.16/doc/interpreter/tips.texi *** octave-2.9.15/doc/interpreter/tips.texi Sat Oct 13 11:12:47 2007 --- octave-2.9.16/doc/interpreter/tips.texi Wed Oct 31 18:11:05 2007 *************** *** 185,192 **** ## 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 --- 185,192 ---- ## 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 *************** *** 384,395 **** @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{return_value@} = @} function_name (@dots{}) @@cindex index term ! Help text in Texinfo format. Code samples should be marked like ! @@code@{sample of code@} and variables should be marked as ! @@var@{variable@}. ! @@seealso@{function2@} @@end deftypefn @end group @end example --- 384,395 ---- @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{ret@} = @} fn (@dots{}) @@cindex index term ! Help text in Texinfo format. Code samples should be marked ! like @@code@{sample of code@} and variables should be marked ! as @@var@{variable@}. ! @@seealso@{fn2@} @@end deftypefn @end group @end example *************** *** 493,500 **** @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{a@} = @} function_name (@@var@{x@}, @dots{}) ! @@deftypefnx@{Function File@} @{@@var@{a@} = @} function_name (@@var@{y@}, @dots{}) Help text in Texinfo format. @@end deftypefn @end group --- 493,500 ---- @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{a@} = @} fn (@@var@{x@}, @dots{}) ! @@deftypefnx@{Function File@} @{@@var@{a@} = @} fn (@@var@{y@}, @dots{}) Help text in Texinfo format. @@end deftypefn @end group *************** *** 508,518 **** @example @group -*- texinfo -*- ! @@deftypefn @{Function File@} @{@@var@{c@} =@} nchoosek (@@var@{n@}, @@var@{k@}) ! Compute the binomial coefficient or all combinations of @@var@{n@}. ! If @@var@{n@} is a scalar then, calculate the binomial coefficient ! of @@var@{n@} and @@var@{k@}, defined as @@iftex @@tex --- 508,518 ---- @example @group -*- texinfo -*- ! @@deftypefn @{Function File@} @{@} nchoosek (@@var@{n@}, @@var@{k@}) ! Compute the binomial coefficient or all combinations of ! @@var@{n@}. If @@var@{n@} is a scalar then, calculate the ! binomial coefficient of @@var@{n@} and @@var@{k@}, defined as @@iftex @@tex *************** *** 534,543 **** @@end example @@end ifinfo ! If @@var@{n@} is a vector, this generates all combinations of the elements ! of @@var@{n@}, taken @@var@{k@} at a time, one row per combination. The ! resulting @@var@{c@} has size @@code@{[nchoosek (length (@@var@{n@}), ! @@var@{k@}), @@var@{k@}]@}. @@seealso@{bincoeff@} @@end deftypefn --- 534,543 ---- @@end example @@end ifinfo ! If @@var@{n@} is a vector, this generates all combinations ! of the elements of @@var@{n@}, taken @@var@{k@} at a time, ! one row per combination. The resulting @@var@{c@} has size ! @@code@{[nchoosek (length (@@var@{n@}),@@var@{k@}), @@var@{k@}]@}. @@seealso@{bincoeff@} @@end deftypefn *************** *** 554,572 **** @example @group -- Function File: C = nchoosek (N, K) ! Compute the binomial coefficient or all combinations of N. If N ! is a scalar then, calculate the binomial coefficient of N and K, ! defined as / \ ! | n | n (n-1) (n-2) ... (n-k+1) ! | | = ------------------------- ! | k | k! \ / ! If N is a vector generate all combinations of the elements of N, ! taken K at a time, one row per combination. The resulting C has ! size `[nchoosek (length (N), K), K]'. See also: bincoeff. --- 554,573 ---- @example @group -- Function File: C = nchoosek (N, K) ! Compute the binomial coefficient or all combinations ! of N. If N is a scalar then, calculate the binomial ! coefficient of N and K, defined as / \ ! | n | n (n-1) (n-2) ... (n-k+1) n! ! | | = ------------------------- = --------- ! | k | k! k! (n-k)! \ / ! If N is a vector generate all combinations of the ! elements of N, taken K at a time, one row per ! combination. The resulting C has size `[nchoosek ! (length (N), K), K]'. See also: bincoeff. diff -cNr octave-2.9.15/doc/interpreter/tips.txi octave-2.9.16/doc/interpreter/tips.txi *** octave-2.9.15/doc/interpreter/tips.txi Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/interpreter/tips.txi Tue Oct 30 21:08:15 2007 *************** *** 183,190 **** ## 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 --- 183,190 ---- ## 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 *************** *** 382,393 **** @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{return_value@} = @} function_name (@dots{}) @@cindex index term ! Help text in Texinfo format. Code samples should be marked like ! @@code@{sample of code@} and variables should be marked as ! @@var@{variable@}. ! @@seealso@{function2@} @@end deftypefn @end group @end example --- 382,393 ---- @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{ret@} = @} fn (@dots{}) @@cindex index term ! Help text in Texinfo format. Code samples should be marked ! like @@code@{sample of code@} and variables should be marked ! as @@var@{variable@}. ! @@seealso@{fn2@} @@end deftypefn @end group @end example *************** *** 491,498 **** @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{a@} = @} function_name (@@var@{x@}, @dots{}) ! @@deftypefnx@{Function File@} @{@@var@{a@} = @} function_name (@@var@{y@}, @dots{}) Help text in Texinfo format. @@end deftypefn @end group --- 491,498 ---- @example @group -*- texinfo -*- ! @@deftypefn@{Function File@} @{@@var@{a@} = @} fn (@@var@{x@}, @dots{}) ! @@deftypefnx@{Function File@} @{@@var@{a@} = @} fn (@@var@{y@}, @dots{}) Help text in Texinfo format. @@end deftypefn @end group *************** *** 506,516 **** @example @group -*- texinfo -*- ! @@deftypefn @{Function File@} @{@@var@{c@} =@} nchoosek (@@var@{n@}, @@var@{k@}) ! Compute the binomial coefficient or all combinations of @@var@{n@}. ! If @@var@{n@} is a scalar then, calculate the binomial coefficient ! of @@var@{n@} and @@var@{k@}, defined as @@iftex @@tex --- 506,516 ---- @example @group -*- texinfo -*- ! @@deftypefn @{Function File@} @{@} nchoosek (@@var@{n@}, @@var@{k@}) ! Compute the binomial coefficient or all combinations of ! @@var@{n@}. If @@var@{n@} is a scalar then, calculate the ! binomial coefficient of @@var@{n@} and @@var@{k@}, defined as @@iftex @@tex *************** *** 532,541 **** @@end example @@end ifinfo ! If @@var@{n@} is a vector, this generates all combinations of the elements ! of @@var@{n@}, taken @@var@{k@} at a time, one row per combination. The ! resulting @@var@{c@} has size @@code@{[nchoosek (length (@@var@{n@}), ! @@var@{k@}), @@var@{k@}]@}. @@seealso@{bincoeff@} @@end deftypefn --- 532,541 ---- @@end example @@end ifinfo ! If @@var@{n@} is a vector, this generates all combinations ! of the elements of @@var@{n@}, taken @@var@{k@} at a time, ! one row per combination. The resulting @@var@{c@} has size ! @@code@{[nchoosek (length (@@var@{n@}),@@var@{k@}), @@var@{k@}]@}. @@seealso@{bincoeff@} @@end deftypefn *************** *** 552,570 **** @example @group -- Function File: C = nchoosek (N, K) ! Compute the binomial coefficient or all combinations of N. If N ! is a scalar then, calculate the binomial coefficient of N and K, ! defined as / \ ! | n | n (n-1) (n-2) ... (n-k+1) ! | | = ------------------------- ! | k | k! \ / ! If N is a vector generate all combinations of the elements of N, ! taken K at a time, one row per combination. The resulting C has ! size `[nchoosek (length (N), K), K]'. See also: bincoeff. --- 552,571 ---- @example @group -- Function File: C = nchoosek (N, K) ! Compute the binomial coefficient or all combinations ! of N. If N is a scalar then, calculate the binomial ! coefficient of N and K, defined as / \ ! | n | n (n-1) (n-2) ... (n-k+1) n! ! | | = ------------------------- = --------- ! | k | k! k! (n-k)! \ / ! If N is a vector generate all combinations of the ! elements of N, taken K at a time, one row per ! combination. The resulting C has size `[nchoosek ! (length (N), K), K]'. See also: bincoeff. diff -cNr octave-2.9.15/doc/interpreter/triplot.eps octave-2.9.16/doc/interpreter/triplot.eps *** octave-2.9.15/doc/interpreter/triplot.eps Sat Oct 13 11:10:59 2007 --- octave-2.9.16/doc/interpreter/triplot.eps Wed Oct 31 18:09:28 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: triplot.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:59 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: triplot.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:28 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:59 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:28 2007) /DOCINFO pdfmark end } ifelse diff -cNr octave-2.9.15/doc/interpreter/triplot.pdf octave-2.9.16/doc/interpreter/triplot.pdf *** octave-2.9.15/doc/interpreter/triplot.pdf Sat Oct 13 11:11:01 2007 --- octave-2.9.16/doc/interpreter/triplot.pdf Wed Oct 31 18:09:29 2007 *************** *** 48,55 **** endobj 2 0 obj <> startxref 1591 --- 69,75 ---- 0000001274 00000 n trailer << /Size 11 /Root 1 0 R /Info 2 0 R ! /ID [(–Q~Ù«™\r­=¸º!'¶)(–Q~Ù«™\r­=¸º!'¶)] >> startxref 1591 diff -cNr octave-2.9.15/doc/interpreter/var.texi octave-2.9.16/doc/interpreter/var.texi *** octave-2.9.15/doc/interpreter/var.texi Sat Oct 13 11:12:48 2007 --- octave-2.9.16/doc/interpreter/var.texi Wed Oct 31 18:11:05 2007 *************** *** 212,218 **** @group function count_calls () persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction for i = 1:3 --- 212,219 ---- @group function count_calls () persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction for i = 1:3 *************** *** 267,273 **** if (isempty (calls)) calls = 0; endif ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction @end group @end example --- 268,275 ---- if (isempty (calls)) calls = 0; endif ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction @end group @end example *************** *** 415,421 **** @end table A command is composed like this: ! %[modifier][:size_of_parameter[:center-specific[:print_dims[:balance]]]]; Command and modifier is already explained. Size_of_parameter tells how many columns the parameter will need for printing. --- 417,427 ---- @end table A command is composed like this: ! ! @example ! %[modifier][:size_of_parameter[:center-specific[ ! :print_dims[:balance]]]]; ! @end example Command and modifier is already explained. Size_of_parameter tells how many columns the parameter will need for printing. diff -cNr octave-2.9.15/doc/interpreter/var.txi octave-2.9.16/doc/interpreter/var.txi *** octave-2.9.15/doc/interpreter/var.txi Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/interpreter/var.txi Mon Oct 15 11:30:04 2007 *************** *** 193,199 **** @group function count_calls () persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction for i = 1:3 --- 193,200 ---- @group function count_calls () persistent calls = 0; ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction for i = 1:3 *************** *** 248,254 **** if (isempty (calls)) calls = 0; endif ! printf ("'count_calls' has been called %d times\n", ++calls); endfunction @end group @end example --- 249,256 ---- if (isempty (calls)) calls = 0; endif ! printf ("'count_calls' has been called %d times\n", ! ++calls); endfunction @end group @end example diff -cNr octave-2.9.15/doc/interpreter/voronoi.eps octave-2.9.16/doc/interpreter/voronoi.eps *** octave-2.9.15/doc/interpreter/voronoi.eps Sat Oct 13 11:10:57 2007 --- octave-2.9.16/doc/interpreter/voronoi.eps Wed Oct 31 18:09:25 2007 *************** *** 1,7 **** %!PS-Adobe-2.0 EPSF-2.0 %%Title: voronoi.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Sat Oct 13 11:10:57 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments --- 1,7 ---- %!PS-Adobe-2.0 EPSF-2.0 %%Title: voronoi.eps %%Creator: gnuplot 4.2 patchlevel 0 ! %%CreationDate: Wed Oct 31 18:09:25 2007 %%DocumentFonts: (atend) %%BoundingBox: 50 50 410 302 %%EndComments *************** *** 48,54 **** /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Sat Oct 13 11:10:57 2007) /DOCINFO pdfmark end } ifelse --- 48,54 ---- /Author (John W. Eaton,,,) % /Producer (gnuplot) % /Keywords () ! /CreationDate (Wed Oct 31 18:09:25 2007) /DOCINFO pdfmark end } ifelse Binary files octave-2.9.15/doc/interpreter/voronoi.pdf and octave-2.9.16/doc/interpreter/voronoi.pdf differ diff -cNr octave-2.9.15/doc/liboctave/Makefile.in octave-2.9.16/doc/liboctave/Makefile.in *** octave-2.9.15/doc/liboctave/Makefile.in Fri Oct 12 17:27:12 2007 --- octave-2.9.16/doc/liboctave/Makefile.in Fri Oct 26 14:22:05 2007 *************** *** 66,80 **** -$(MAKEINFO) -I.. -I$(srcdir) -I$(srcdir)/.. $< liboctave.dvi: $(TEXINFO) ! -TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(UNSETCOMSPEC) $(TEXI2DVI) $< liboctave.ps: liboctave.dvi -dvips -o $@ $< liboctave.pdf: $(TEXINFO) ! -TEXINPUTS="..:$(srcdir):$(srcdir)/..:$(TEXINPUTS):" \ ! $(UNSETCOMSPEC) $(TEXI2PDF) $< HTML/index.html: $(TEXINFO) -$(MAKEINFO) --html --ifinfo --output=HTML -I.. -I$(srcdir) -I$(srcdir)/.. $< --- 66,80 ---- -$(MAKEINFO) -I.. -I$(srcdir) -I$(srcdir)/.. $< liboctave.dvi: $(TEXINFO) ! -TEXINPUTS="..$(sepchar)$(srcdir)$(sepchar)$(srcdir)/..$(sepchar)$(TEXINPUTS)$(sepchar)" \ ! $(TEXI2DVI) $< liboctave.ps: liboctave.dvi -dvips -o $@ $< liboctave.pdf: $(TEXINFO) ! -TEXINPUTS="..$(sepchar)$(srcdir)$(sepchar)$(srcdir)/..$(sepchar)$(TEXINPUTS)$(sepchar)" \ ! $(TEXI2PDF) $< HTML/index.html: $(TEXINFO) -$(MAKEINFO) --html --ifinfo --output=HTML -I.. -I$(srcdir) -I$(srcdir)/.. $< Binary files octave-2.9.15/doc/liboctave/liboctave.pdf and octave-2.9.16/doc/liboctave/liboctave.pdf differ Binary files octave-2.9.15/doc/refcard/refcard-a4.pdf and octave-2.9.16/doc/refcard/refcard-a4.pdf differ Binary files octave-2.9.15/doc/refcard/refcard-legal.pdf and octave-2.9.16/doc/refcard/refcard-legal.pdf differ Binary files octave-2.9.15/doc/refcard/refcard-letter.pdf and octave-2.9.16/doc/refcard/refcard-letter.pdf differ diff -cNr octave-2.9.15/doc/refcard/refcard.tex octave-2.9.16/doc/refcard/refcard.tex *** octave-2.9.15/doc/refcard/refcard.tex Fri Oct 12 20:52:13 2007 --- octave-2.9.16/doc/refcard/refcard.tex Fri Oct 19 14:24:19 2007 *************** *** 50,57 **** % I chose to omit. In general, not all synonyms for commands are % covered, nor all variations of a command. ! \def\octaveversion{1.1.1} ! \def\refcardedition{1.1} % ------------------ % multicolumn format --- 50,57 ---- % I chose to omit. In general, not all synonyms for commands are % covered, nor all variations of a command. ! \def\octaveversion{3.0.0} ! \def\refcardedition{2.0} % ------------------ % multicolumn format *************** *** 378,383 **** --- 378,384 ---- \sec Starting Octave; octave&start interactive Octave session\cr octave {\it file}&run Octave on commands in {\it file}\cr + octave --eval {\it code}&Evaluate {\it code} using Octave\cr octave --help&describe command line options\cr \endsec *************** *** 390,397 **** \sec Getting Help; help&list all commands and built-in variables\cr help {\it command}&briefly describe {\it command}\cr ! help -i&use Info to browse Octave manual\cr ! help -i {\it command}&search for {\it command\/} in Octave manual\cr \endsec \sec Motion in Info; --- 391,399 ---- \sec Getting Help; help&list all commands and built-in variables\cr help {\it command}&briefly describe {\it command}\cr ! doc&use Info to browse Octave manual\cr ! doc {\it command}&search for {\it command} in Octave manual\cr ! lookfor {\it str}&search for {\it command} based on {\it str}\cr \endsec \sec Motion in Info; *************** *** 448,454 **** \line{\smrm \opt{ } surround optional arguments \hfill ... show one or more arguments} \vskip0.25\baselineskip - \centerline{\smrm Copyright 1996, 1997 John W. Eaton\qquad Permissions on back} \eject \sec Killing and Yanking; --- 450,455 ---- *************** *** 505,517 **** Square brackets delimit literal matrices. Commas separate elements on the same row. Semicolons separate rows. Commas may be replaced by spaces, and semicolons may be replaced by one or more newlines. ! Elements of a matrix may be arbitrary expressions, provided that all the dimensions agree.\vskip0.75ex}\span\cr [ {\it x}, {\it y}, ... ]&enter a row vector\cr [ {\it x}; {\it y}; ... ]&enter a column vector\cr [ {\it w}, {\it x}; {\it y}, {\it z} ]&enter a 2$\times$2 matrix\cr \endsec \sec Ranges; {\it base} : {\it limit}\cr {\it base} : {\it incr} : {\it limit}\cr --- 506,544 ---- Square brackets delimit literal matrices. Commas separate elements on the same row. Semicolons separate rows. Commas may be replaced by spaces, and semicolons may be replaced by one or more newlines. ! Elements of a matrix may be arbitrary expressions, assuming all the dimensions agree.\vskip0.75ex}\span\cr [ {\it x}, {\it y}, ... ]&enter a row vector\cr [ {\it x}; {\it y}; ... ]&enter a column vector\cr [ {\it w}, {\it x}; {\it y}, {\it z} ]&enter a 2$\times$2 matrix\cr \endsec + \sec Multi-dimensional Arrays; + \omit\vbox{\rm\vskip0.25ex + Multi-dimensional arrays may be created with the {\it cat} or + {\it reshape} commands from two-dimensional sub-matrices. + \vskip0.75ex}\span\cr + squeeze ({\it arr})&remove singleton dimensions of the array.\cr + ndims ({\it arr})&number of dimensions in the array.\cr + permute ({\it arr}, {\it p})&permute the dimensions of an array.\cr + ipermute ({\it arr}, {\it p})&array inverse permutation.\cr + \endsec + + \vfill\eject + + \sec ; + shiftdim ({\it arr}, {\it s})&rotate the array dimensions.\cr + circshift ({\it arr}, {\it s})&rotate the array elements.\cr + \endsec + + \sec Sparse Matrices; + sparse (...)&create a sparse matrix.\cr + speye ({\it n)}&create sparse identify matrix.\cr + sprand ({\it n}, {\it m}, {\it d})&sparse rand matrix of density {\it d}.\cr + spdiags (...)&sparse generalization of {\it diag}.\cr + nnz ({\it s})&No. non-zero elements in sparse matrix.\cr + \endsec + \sec Ranges; {\it base} : {\it limit}\cr {\it base} : {\it incr} : {\it limit}\cr *************** *** 521,532 **** {\it incr\/} is 1. Negative increments are permitted.}\span\cr \endsec - \vfill\eject - \sec Strings and Common Escape Sequences; \omit\vbox{\rm\vskip0.5ex A {\it string constant\/} consists of a sequence of characters ! enclosed in either double-quote or single-quote marks.\vskip0.75ex}\span\cr \char'134\char'134&a literal backslash\cr \char'134 "&a literal double-quote character\cr \char'134 '&a literal single-quote character\cr --- 548,559 ---- {\it incr\/} is 1. Negative increments are permitted.}\span\cr \endsec \sec Strings and Common Escape Sequences; \omit\vbox{\rm\vskip0.5ex A {\it string constant\/} consists of a sequence of characters ! enclosed in either double-quote or single-quote marks. Strings ! in double-quotes allow the use of the escape sequences below. ! \vskip0.75ex}\span\cr \char'134\char'134&a literal backslash\cr \char'134 "&a literal double-quote character\cr \char'134 '&a literal single-quote character\cr *************** *** 546,571 **** \quad :&select all rows (columns)\cr \endsec ! \sec Global Variables; global {\it var1} ...&Declare variables global.\cr ! \omit\hfill\vbox{\hsize=\idnwid\rm\vskip0.25ex Global variables may be accessed inside the body of a function without having to be passed in the function parameter list provided ! they are also declared global within the function.}\span\cr \endsec \sec Selected Built-in Functions; EDITOR&editor to use with {\tt edit\_history}\cr Inf, NaN&IEEE infinity, NaN\cr PAGER&program to use to paginate output\cr ans&last result not explicitly assigned\cr eps&machine precision\cr pi&$\pi$\cr realmax&maximum representable value\cr realmin&minimum representable value\cr \endsec ! \vfill\eject \sec Arithmetic and Increment Operators; {\it x} + {\it y}&addition\cr --- 573,613 ---- \quad :&select all rows (columns)\cr \endsec ! \sec Global and Persistent Variables; global {\it var1} ...&Declare variables global.\cr ! global {\it var1} = {\it val}&Declare variable global. Set intial value.\cr ! persistent {\it var1}&Declare a variable as static to a function.\cr ! persistent {\it var1} = {\it val}&Declare a variable as static to a ! function and set its initial value.\cr ! \omit\hfill\vbox{\rm\vskip0.25ex Global variables may be accessed inside the body of a function without having to be passed in the function parameter list provided ! they are declared global when used.}\span\cr \endsec \sec Selected Built-in Functions; EDITOR&editor to use with {\tt edit\_history}\cr Inf, NaN&IEEE infinity, NaN\cr + NA&Missing value\cr PAGER&program to use to paginate output\cr ans&last result not explicitly assigned\cr eps&machine precision\cr pi&$\pi$\cr + 1i&$\sqrt{-1}$\cr realmax&maximum representable value\cr realmin&minimum representable value\cr \endsec ! \vfill ! \centerline{\smrm Copyright 1996, 1997, 2007 John W. Eaton\qquad Permissions on back} ! \eject ! ! \sec Assignment Expressions; ! {\it var} = {\it expr}&assign expression to variable\cr ! {\it var} ({\it idx}) = {\it expr}&assign expression to indexed variable\cr ! {\it var} ({\it idx}) = []&delete the indexed elements.\cr ! {\it var} $\{${\it idx}$\}$ = {\it expr}&assign elements of a cell array.\cr ! \endsec \sec Arithmetic and Increment Operators; {\it x} + {\it y}&addition\cr *************** *** 584,600 **** + {\it x}&unary plus (a no-op)\cr {\it x} '&complex conjugate transpose\cr {\it x} .'&transpose\cr ! ++ {\it x}\quad{\rm(}-- {\it x}{\rm)}&increment (decrement) {\it x}, return {\it new\/} value\cr ! {\it x} ++\quad{\rm(}{\it x} --{\rm)}&increment (decrement) {\it x}, return {\it old\/} value\cr \endsec - \sec Assignment Expressions; - {\it var} = {\it expr}&assign expression to variable\cr - {\it var} ({\it idx}) = {\it expr}&assign expression to indexed variable\cr - \endsec - \sec Comparison and Boolean Operators; \omit \vbox{\rm\vskip0.75ex These operators work on an element-by-element basis. Both arguments --- 626,637 ---- + {\it x}&unary plus (a no-op)\cr {\it x} '&complex conjugate transpose\cr {\it x} .'&transpose\cr ! ++ {\it x}\quad{\rm(}-- {\it x}{\rm)}&increment (decrement), return {\it new\/} value\cr ! {\it x} ++\quad{\rm(}{\it x} --{\rm)}&increment (decrement), return {\it old\/} value\cr \endsec \sec Comparison and Boolean Operators; \omit \vbox{\rm\vskip0.75ex These operators work on an element-by-element basis. Both arguments *************** *** 612,628 **** \sec Short-circuit Boolean Operators; \omit \vbox{\rm\vskip0.75ex ! Operators evaluate left-to-right, expecting scalar operands. ! Operands are only evaluated if necessary, stopping once overall ! truth value can be determined. Operands are converted to scalars by ! applying the {\tt all} function.\vskip0.75ex}\span\cr {\it x} \&\& {\it y}&true if both {\it x\/} and {\it y\/} are true\cr {\it x} || {\it y}&true if at least one of {\it x\/} or {\it y\/} is true\cr \endsec \sec Operator Precedence; \omit \vbox{\rm\vskip0.5ex ! Here is a table of the operators in Octave, in order of increasing precedence.\vskip0.75ex}\span\cr ;\ \ ,&statement separators\cr =&assignment, groups left to right\cr --- 649,665 ---- \sec Short-circuit Boolean Operators; \omit \vbox{\rm\vskip0.75ex ! Operators evaluate left-to-right. Operands are only evaluated if ! necessary, stopping once overall truth value can be determined. ! Operands are converted to scalars using the {\tt all} ! function.\vskip0.75ex}\span\cr {\it x} \&\& {\it y}&true if both {\it x\/} and {\it y\/} are true\cr {\it x} || {\it y}&true if at least one of {\it x\/} or {\it y\/} is true\cr \endsec \sec Operator Precedence; \omit \vbox{\rm\vskip0.5ex ! Table of Octave operators, in order of increasing precedence.\vskip0.75ex}\span\cr ;\ \ ,&statement separators\cr =&assignment, groups left to right\cr *************** *** 639,644 **** --- 676,697 ---- \vfill\eject + \sec Paths and Packages; + path&display the current Octave cunction path.\cr + pathdef&display the default path.\cr + addpath({\it dir})&add a directory to the path.\cr + EXEC\_PATH&manipulate the Octave executable path.\cr + pkg list&display installed packages.\cr + pkg load {\it pack}&Load an installed package.\cr + \endsec + + \sec Cells and Structures; + {\it{var}}.{\it{field}} = ...&set a field of a structure.\cr + {\it{var}}$\{${\it{idx}}$\}$ = ...&set an element of a cell array.\cr + cellfun({\it f}, {\it c})&apply a function to elements of cell array.\cr + fieldnames({\it s})&returns the fields of a structure.\cr + \endsec + \widesec Statements; for {\it identifier} = {\it expr} {\it stmt-list} endfor\cr \hfill\vbox{\hsize=\idnwid\rm\vskip0.25ex *************** *** 671,676 **** --- 724,739 ---- \hfill\vbox{\hsize=\idnwid\rm\vskip0.25ex Execute {\it body}. Execute {\it cleanup} no matter how control exits {\it body}.}\cr + try {\it body} catch {\it cleanup} end\cr + \hfill\vbox{\hsize=\idnwid\rm\vskip0.25ex + Execute {\it body}. Execute {\it cleanup} if {\it body} fails.}\cr + \endsec + + \altsec Strings; + strcmp ({\it s}, {\it t})&compare strings\cr + strcat ({\it s}, {\it t}, ...)&concatenate strings\cr + regexp ({\it str}, {\it pat})&strings matching regular expression\cr + regexprep ({\it str}, {\it pat}, {\it rep})&Match and replace sub-strings\cr \endsec \widesec Defining Functions; *************** *** 684,694 **** --- 747,787 ---- be empty.}\cr \endsec + \vfill\eject + + \sec Function Handles; + @{\it{func}}& Define a function handle to {\it func}.\cr + @({\it var1}, ...) {\it expr}&Define an anonymous function handle.\cr + str2func ({\it str})&Create a function handle from a string.\cr + functions ({\it handle})&Return information about a function handle.\cr + func2str ({\it handle})&Return a string representation of a + function handle.\cr + {\it handle} ({\it arg1}, ...)&Evaluate a function handle.\cr + feval ({\it func}, {\it arg1}, ...)&Evaluate a function handle or + string, passing remaining args to {\it func}\cr + \omit\vbox{\rm\vskip0.25ex + Anonymous function handles take a copy of the variables in the + current workspace.\vskip0.75ex}\span\cr + \endsec + + \sec Miscellaneous Functions; + eval ({\it str})&evaluate {\it str} as a command\cr + error ({\it message})&print message and return to top level\cr + warning ({\it message})&print a warning message\cr + clear {\it pattern}&clear variables matching pattern\cr + exist ({\it str})&check existence of variable or function\cr + who, whos&list current variables\cr + whos {\it var}&details of the varibale {\it var}\cr + \endsec + \sec Basic Matrix Manipulations; rows ({\it a})&return number of rows of {\it a}\cr columns ({\it a})&return number of columns of {\it a}\cr all ({\it a})&check if all elements of {\it a\/} nonzero\cr any ({\it a})&check if any elements of {\it a\/} nonzero\cr + \endsec + + \sec ; find ({\it a})&return indices of nonzero elements\cr sort ({\it a})&order elements in each column of {\it a}\cr sum ({\it a})&sum elements in columns of {\it a}\cr *************** *** 697,703 **** max ({\it args})&find maximum values\cr rem ({\it x}, {\it y})&find remainder of {\it x}/{\it y}\cr reshape ({\it a}, {\it m}, {\it n})&reformat {\it a} to be {\it m} by ! {\it n}\cr\cr diag ({\it v}, {\it k})&create diagonal matrices\cr linspace ({\it b}, {\it l}, {\it n})&create vector of linearly-spaced elements\cr --- 790,796 ---- max ({\it args})&find maximum values\cr rem ({\it x}, {\it y})&find remainder of {\it x}/{\it y}\cr reshape ({\it a}, {\it m}, {\it n})&reformat {\it a} to be {\it m} by ! {\it n}\cr diag ({\it v}, {\it k})&create diagonal matrices\cr linspace ({\it b}, {\it l}, {\it n})&create vector of linearly-spaced elements\cr *************** *** 710,717 **** values\cr \endsec - \vfill\eject - % sin({\it a}) cos({\it a}) tan({\it a})&trigonometric functions\cr % asin({\it a}) acos({\it a}) atan({\it a})&inverse trigonometric functions\cr % sinh({\it a}) cosh({\it a}) tanh({\it a})&hyperbolic trig functions\cr --- 803,808 ---- *************** *** 729,744 **** pinv ({\it a})&compute pseudoinverse of {\it a}\cr qr ({\it a})&compute the QR factorization of a matrix\cr rank ({\it a})&matrix rank\cr schur ({\it a})&Schur decomposition of a matrix\cr svd ({\it a})&singular value decomposition\cr syl ({\it a}, {\it b}, {\it c})&solve the Sylvester equation\cr \endsec \sec Equations, ODEs, DAEs, Quadrature; *fsolve&solve nonlinear algebraic equations\cr *lsode&integrate nonlinear ODEs\cr *dassl&integrate nonlinear DAEs\cr ! *quad&integrate nonlinear functions\cr\cr perror ({\it nm}, {\it code})&for functions that return numeric codes, print error message for named function and given error code\cr\cr --- 820,838 ---- pinv ({\it a})&compute pseudoinverse of {\it a}\cr qr ({\it a})&compute the QR factorization of a matrix\cr rank ({\it a})&matrix rank\cr + sprank ({\it a})&structrual matrix rank\cr schur ({\it a})&Schur decomposition of a matrix\cr svd ({\it a})&singular value decomposition\cr syl ({\it a}, {\it b}, {\it c})&solve the Sylvester equation\cr \endsec + \vfill\eject + \sec Equations, ODEs, DAEs, Quadrature; *fsolve&solve nonlinear algebraic equations\cr *lsode&integrate nonlinear ODEs\cr *dassl&integrate nonlinear DAEs\cr ! *quad&integrate nonlinear functions\cr perror ({\it nm}, {\it code})&for functions that return numeric codes, print error message for named function and given error code\cr\cr *************** *** 747,757 **** arguments for these functions.}\span\cr \endsec \sec Signal Processing; ! fft ({\it a})&Fast Fourier Transform using FFTPACK\cr ! ifft ({\it a})&inverse FFT using FFTPACK\cr freqz ({\it args})&FIR filter frequency response\cr ! sinc ({\it x})&returns {\tt sin ($\pi$ x)/($\pi$ x)}\cr \endsec \altsec Image Processing; --- 841,861 ---- arguments for these functions.}\span\cr \endsec + % \altsec Sets; + % create\_set ({\it a}, {\it b})&create row vector of unique values\cr + % complement ({\it a}, {\it b})&elements of {\it b} not in {\it a}\cr + % intersection ({\it a}, {\it b})&intersection of sets {\it a} and {\it b}\cr + % union ({\it a}, {\it b})&union of sets {\it a} and {\it b}\cr + % \endsec + \sec Signal Processing; ! fft ({\it a})&Fast Fourier Transform using FFTW\cr ! ifft ({\it a})&inverse FFT using FFTW\cr freqz ({\it args})&FIR filter frequency response\cr ! filter ({\it a}, {\it b}, {\it x})&filter by transfer function\cr ! conv ({\it a}, {\it b})&convolve two vectors\cr ! hamming ({\it n})&return Hamming window coefficents\cr ! hanning ({\it n})&return Hanning window coefficents\cr \endsec \altsec Image Processing; *************** *** 770,789 **** save a matrix to {\it file}\span\cr \endsec - \altsec Sets; - create\_set ({\it a}, {\it b})&create row vector of unique values\cr - complement ({\it a}, {\it b})&elements of {\it b} not in {\it a}\cr - intersection ({\it a}, {\it b})&intersection of sets {\it a} and {\it b}\cr - union ({\it a}, {\it b})&union of sets {\it a} and {\it b}\cr - \endsec - - \altsec Strings; - strcmp ({\it s}, {\it t})&compare strings\cr - strcat ({\it s}, {\it t}, ...)&concatenate strings\cr - \endsec - - \vfill\eject - \altsec C-style Input and Output; fopen ({\it name}, {\it mode})&open file {\it name}\cr fclose ({\it file})&close {\it file}\cr --- 874,879 ---- *************** *** 813,827 **** disp ({\it var})&display value of {\it var} to screen\cr \endsec ! \sec Miscellaneous Functions; ! eval ({\it str})&evaluate {\it str} as a command\cr ! feval ({\it str}, ...)&evaluate function named by {\it str}, ! passing remaining args to called function\cr\cr ! error ({\it message})&print message and return to top level\cr\cr ! clear {\it pattern}&clear variables matching pattern\cr ! exist ({\it str})&check existence of variable or function\cr ! who&list current variables\cr ! \endsec \sec Polynomials; compan ({\it p})&companion matrix\cr --- 903,909 ---- disp ({\it var})&display value of {\it var} to screen\cr \endsec ! \vfill\eject \sec Polynomials; compan ({\it p})&companion matrix\cr *************** *** 846,881 **** var ({\it a})&variance\cr \endsec - \vfill\eject - \sec Plotting Functions; plot ({\it args})&2D plot with linear axes\cr plot3 ({\it args})&3D plot with linear axes\cr line ({\it args})&2D or 3D line\cr semilogx ({\it args})&2D plot with logarithmic x-axis\cr semilogy ({\it args})&2D plot with logarithmic y-axis\cr loglog ({\it args})&2D plot with logarithmic axes\cr bar ({\it args})&plot bar charts\cr stairs ({\it x}, {\it y})&plot stairsteps\cr ! hist ({\it y}, {\it x})&plot histograms\cr\cr ! title ({\it string})&set plot title\cr\cr axis ({\it limits})&set axis ranges\cr xlabel ({\it string})&set x-axis label\cr ylabel ({\it string})&set y-axis label\cr zlabel ({\it string})&set z-axis label\cr legend ({\it string})&set label in plot key\cr grid \opt{on$|$off}&set grid state\cr hold \opt{on$|$off}&set hold state\cr ! ishold&return 1 if hold is on, 0 otherwise\cr\cr mesh ({\it x}, {\it y}, {\it z})&plot 3D surface\cr ! meshdom ({\it x}, {\it y})&create mesh coordinate matrices\cr \endsec \vskip 0pt plus 2fill \hrule width \hsize \par\vskip10pt {\smrm\parskip=6pt ! Edition \refcardedition for Octave Version \octaveversion. Copyright 1996, 2007, John W. Eaton (jwe@bevo.che.wisc.edu). The author assumes no responsibility for any errors on this card. --- 928,965 ---- var ({\it a})&variance\cr \endsec \sec Plotting Functions; plot ({\it args})&2D plot with linear axes\cr plot3 ({\it args})&3D plot with linear axes\cr line ({\it args})&2D or 3D line\cr + patch ({\it args})&2D patch\cr semilogx ({\it args})&2D plot with logarithmic x-axis\cr semilogy ({\it args})&2D plot with logarithmic y-axis\cr loglog ({\it args})&2D plot with logarithmic axes\cr bar ({\it args})&plot bar charts\cr stairs ({\it x}, {\it y})&plot stairsteps\cr ! stem ({\it x}, {it y})&plot a stem graph\cr ! hist ({\it y}, {\it x})&plot histograms\cr ! contour ({\it x}, {\it y}, {\it z})&contour plot\cr ! title ({\it string})&set plot title\cr axis ({\it limits})&set axis ranges\cr xlabel ({\it string})&set x-axis label\cr ylabel ({\it string})&set y-axis label\cr zlabel ({\it string})&set z-axis label\cr + text ({\it x}, {\it y}, {\it str})&add text to a plot\cr legend ({\it string})&set label in plot key\cr grid \opt{on$|$off}&set grid state\cr hold \opt{on$|$off}&set hold state\cr ! ishold&return 1 if hold is on, 0 otherwise\cr mesh ({\it x}, {\it y}, {\it z})&plot 3D surface\cr ! meshgrid ({\it x}, {\it y})&create mesh coordinate matrices\cr \endsec \vskip 0pt plus 2fill \hrule width \hsize \par\vskip10pt {\smrm\parskip=6pt ! Edition \refcardedition\ for Octave Version \octaveversion. Copyright 1996, 2007, John W. Eaton (jwe@bevo.che.wisc.edu). The author assumes no responsibility for any errors on this card. diff -cNr octave-2.9.15/examples/addtwomatrices.cc octave-2.9.16/examples/addtwomatrices.cc *** octave-2.9.15/examples/addtwomatrices.cc Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/addtwomatrices.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ diff -cNr octave-2.9.15/examples/celldemo.cc octave-2.9.16/examples/celldemo.cc *** octave-2.9.15/examples/celldemo.cc Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/celldemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ diff -cNr octave-2.9.15/examples/firstmexdemo.c octave-2.9.16/examples/firstmexdemo.c *** octave-2.9.15/examples/firstmexdemo.c Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/firstmexdemo.c Tue Oct 30 21:08:15 2007 *************** *** 1,29 **** /* ! Copyright (C) 2007 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 ! . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[]) { mxArray *v = mxCreateDoubleMatrix (1, 1, mxREAL); double *data = mxGetPr (v); --- 1,31 ---- /* ! Copyright (C) 2006, 2007 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 . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, ! const mxArray *prhs[]) { mxArray *v = mxCreateDoubleMatrix (1, 1, mxREAL); double *data = mxGetPr (v); diff -cNr octave-2.9.15/examples/fortdemo.cc octave-2.9.16/examples/fortdemo.cc *** octave-2.9.15/examples/fortdemo.cc Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/fortdemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ *************** *** 47,53 **** OCTAVE_LOCAL_BUFFER (char, ctmp, 128); F77_XFCN (fortsub, FORTSUB, (na, av, ctmp ! F77_CHAR_ARG_LEN (128))); if (f77_exception_encountered) error ("fortdemo: error in fortran"); --- 48,54 ---- OCTAVE_LOCAL_BUFFER (char, ctmp, 128); F77_XFCN (fortsub, FORTSUB, (na, av, ctmp ! F77_CHAR_ARG_LEN (128))); if (f77_exception_encountered) error ("fortdemo: error in fortran"); diff -cNr octave-2.9.15/examples/fortsub.f octave-2.9.16/examples/fortsub.f *** octave-2.9.15/examples/fortsub.f Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/fortsub.f Tue Oct 30 21:08:15 2007 *************** *** 2,20 **** c c This file is part of Octave. c ! c Octave is free software; you can redistribute it and/or modify it ! c under the terms of the GNU General Public License as published by the ! c Free Software Foundation; either version 3 of the License, or (at your ! c option) any later version. c ! c Octave is distributed in the hope that it will be useful, but WITHOUT ! c ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ! c FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ! c for more details. c ! c You should have received a copy of the GNU General Public License ! c along with Octave; see the file COPYING. If not, see ! c . subroutine fortsub (n, a, s) implicit none --- 2,22 ---- c c This file is part of Octave. c ! c Octave is free software; you can redistribute it and/or ! c modify it under the terms of the GNU General Public ! c License as published by the Free Software Foundation; ! c either version 3 of the License, or (at your option) any ! c later version. c ! c Octave is distributed in the hope that it will be useful, ! c but WITHOUT ANY WARRANTY; without even the implied ! c warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ! c PURPOSE. See the GNU General Public License for more ! c details. c ! c You should have received a copy of the GNU General Public ! c License along with Octave; see the file COPYING. If not, ! c see . subroutine fortsub (n, a, s) implicit none *************** *** 29,36 **** endif enddo write (unit = s, fmt = '(a,i3,a,a)', iostat = ioerr) ! $ 'There are ', n, ' values in the input vector', ! $ char(0) if (ioerr .ne. 0) then call xstopx ('fortsub: error writing string') endif --- 31,38 ---- endif enddo write (unit = s, fmt = '(a,i3,a,a)', iostat = ioerr) ! $ 'There are ', n, ! $ ' values in the input vector', char(0) if (ioerr .ne. 0) then call xstopx ('fortsub: error writing string') endif diff -cNr octave-2.9.15/examples/funcdemo.cc octave-2.9.16/examples/funcdemo.cc *** octave-2.9.15/examples/funcdemo.cc Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/funcdemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ *************** *** 49,55 **** retval = feval (fcn, newargs, nargout); } else ! error ("funcdemo: expected string, inline or function handle"); } return retval; } --- 50,57 ---- retval = feval (fcn, newargs, nargout); } else ! error ("funcdemo: expected string,", ! " inline or function handle"); } return retval; } diff -cNr octave-2.9.15/examples/globaldemo.cc octave-2.9.16/examples/globaldemo.cc *** octave-2.9.15/examples/globaldemo.cc Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/globaldemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ diff -cNr octave-2.9.15/examples/helloworld.cc octave-2.9.16/examples/helloworld.cc *** octave-2.9.15/examples/helloworld.cc Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/helloworld.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ diff -cNr octave-2.9.15/examples/mycell.c octave-2.9.16/examples/mycell.c *** octave-2.9.15/examples/mycell.c Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/mycell.c Tue Oct 30 21:08:15 2007 *************** *** 1,29 **** /* ! Copyright (C) 2007 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 ! . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, const mxArray* prhs[]) { mwSize n; mwIndex i; --- 1,31 ---- /* ! Copyright (C) 2006, 2007 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 . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, ! const mxArray* prhs[]) { mwSize n; mwIndex i; diff -cNr octave-2.9.15/examples/myfeval.c octave-2.9.16/examples/myfeval.c *** octave-2.9.15/examples/myfeval.c Fri Oct 12 21:42:20 2007 --- octave-2.9.16/examples/myfeval.c Tue Oct 30 21:08:15 2007 *************** *** 4,42 **** 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 ! . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, const mxArray* prhs[]) { char *str; mexPrintf ("Hello, World!\n"); ! mexPrintf ("I have %d inputs and %d outputs\n", nrhs, nlhs); if (nrhs < 1 || ! mxIsString (prhs[0])) mexErrMsgTxt ("function name expected"); str = mxArrayToString (prhs[0]); ! mexPrintf ("I'm going to call the interpreter function %s\n", str); mexCallMATLAB (nlhs, plhs, nrhs-1, prhs+1, str); --- 4,45 ---- 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 . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, ! const mxArray* prhs[]) { char *str; mexPrintf ("Hello, World!\n"); ! mexPrintf ("I have %d inputs and %d outputs\n", nrhs, ! nlhs); if (nrhs < 1 || ! mxIsString (prhs[0])) mexErrMsgTxt ("function name expected"); str = mxArrayToString (prhs[0]); ! mexPrintf ("I'm going to call the function %s\n", str); mexCallMATLAB (nlhs, plhs, nrhs-1, prhs+1, str); diff -cNr octave-2.9.15/examples/myfunc.c octave-2.9.16/examples/myfunc.c *** octave-2.9.15/examples/myfunc.c Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/myfunc.c Tue Oct 30 21:08:15 2007 *************** *** 1,29 **** /* ! Copyright (C) 2007 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 ! . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[]) { const char *nm; nm = mexFunctionName (); --- 1,31 ---- /* ! Copyright (C) 2006, 2007 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 . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, ! const mxArray *prhs[]) { const char *nm; nm = mexFunctionName (); diff -cNr octave-2.9.15/examples/mypow2.c octave-2.9.16/examples/mypow2.c *** octave-2.9.15/examples/mypow2.c Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/mypow2.c Tue Oct 30 21:08:15 2007 *************** *** 1,29 **** /* ! Copyright (C) 2007 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 ! . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, const mxArray* prhs[]) { mwIndex i; mwSize n; --- 1,31 ---- /* ! Copyright (C) 2006, 2007 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 . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, ! const mxArray* prhs[]) { mwIndex i; mwSize n; diff -cNr octave-2.9.15/examples/mysparse.c octave-2.9.16/examples/mysparse.c *** octave-2.9.15/examples/mysparse.c Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/mysparse.c Tue Oct 30 21:08:15 2007 *************** *** 4,29 **** 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 ! . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[]) { mwSize n, m, nz; mxArray *v; --- 4,31 ---- 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 . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, ! const mxArray *prhs[]) { mwSize n, m, nz; mxArray *v; *************** *** 42,48 **** if (mxIsComplex (prhs[0])) { ! mexPrintf ("Matrix is %d-by-%d complex sparse matrix", m, n); mexPrintf (" with %d elements\n", nz); pr = mxGetPr (prhs[0]); --- 44,51 ---- if (mxIsComplex (prhs[0])) { ! mexPrintf ("Matrix is %d-by-%d complex", ! " sparse matrix", m, n); mexPrintf (" with %d elements\n", nz); pr = mxGetPr (prhs[0]); *************** *** 52,59 **** i = n; while (jc[i] == jc[i-1] && i != 0) i--; ! mexPrintf ("last non-zero element (%d, %d) = (%g, %g)\n", ! ir[nz-1]+ 1, i, pr[nz-1], pi[nz-1]); v = mxCreateSparse (m, n, nz, mxCOMPLEX); pr2 = mxGetPr (v); --- 55,63 ---- i = n; while (jc[i] == jc[i-1] && i != 0) i--; ! mexPrintf ("last non-zero element (%d, %d) =", ! ir[nz-1]+ 1, i); ! mexPrintf (" (%g, %g)\n", pr[nz-1], pi[nz-1]); v = mxCreateSparse (m, n, nz, mxCOMPLEX); pr2 = mxGetPr (v); *************** *** 76,82 **** else if (mxIsLogical (prhs[0])) { bool *pbr, *pbr2; ! mexPrintf ("Matrix is %d-by-%d logical sparse matrix", m, n); mexPrintf (" with %d elements\n", nz); pbr = mxGetLogicals (prhs[0]); --- 80,87 ---- else if (mxIsLogical (prhs[0])) { bool *pbr, *pbr2; ! mexPrintf ("Matrix is %d-by-%d logical", ! " sparse matrix", m, n); mexPrintf (" with %d elements\n", nz); pbr = mxGetLogicals (prhs[0]); *************** *** 85,92 **** i = n; while (jc[i] == jc[i-1] && i != 0) i--; ! mexPrintf ("last non-zero element (%d, %d) = %d\n", ir[nz-1]+ 1, ! i, pbr[nz-1]); v = mxCreateSparseLogicalMatrix (m, n, nz); pbr2 = mxGetLogicals (v); --- 90,97 ---- i = n; while (jc[i] == jc[i-1] && i != 0) i--; ! mexPrintf ("last non-zero element (%d, %d) = %d\n", ! ir[nz-1]+ 1, i, pbr[nz-1]); v = mxCreateSparseLogicalMatrix (m, n, nz); pbr2 = mxGetLogicals (v); *************** *** 106,112 **** } else { ! mexPrintf ("Matrix is %d-by-%d real sparse matrix", m, n); mexPrintf (" with %d elements\n", nz); pr = mxGetPr (prhs[0]); --- 111,118 ---- } else { ! mexPrintf ("Matrix is %d-by-%d real", ! " sparse matrix", m, n); mexPrintf (" with %d elements\n", nz); pr = mxGetPr (prhs[0]); *************** *** 115,122 **** i = n; while (jc[i] == jc[i-1] && i != 0) i--; ! mexPrintf ("last non-zero element (%d, %d) = %g\n", ir[nz-1]+ 1, ! i, pr[nz-1]); v = mxCreateSparse (m, n, nz, mxREAL); pr2 = mxGetPr (v); --- 121,128 ---- i = n; while (jc[i] == jc[i-1] && i != 0) i--; ! mexPrintf ("last non-zero element (%d, %d) = %g\n", ! ir[nz-1]+ 1, i, pr[nz-1]); v = mxCreateSparse (m, n, nz, mxREAL); pr2 = mxGetPr (v); diff -cNr octave-2.9.15/examples/mystring.c octave-2.9.16/examples/mystring.c *** octave-2.9.15/examples/mystring.c Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/mystring.c Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ *************** *** 24,30 **** #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[]) { mwIndex i, j; mwSize m, n; --- 25,32 ---- #include "mex.h" void ! mexFunction (int nlhs, mxArray *plhs[], int nrhs, ! const mxArray *prhs[]) { mwIndex i, j; mwSize m, n; *************** *** 37,43 **** m = mxGetM (prhs[0]); n = mxGetN (prhs[0]); pi = mxGetChars (prhs[0]); ! plhs[0] = mxCreateNumericMatrix (m, n, mxCHAR_CLASS, mxREAL); po = mxGetChars (plhs[0]); for (j = 0; j < n; j++) --- 39,46 ---- m = mxGetM (prhs[0]); n = mxGetN (prhs[0]); pi = mxGetChars (prhs[0]); ! plhs[0] = mxCreateNumericMatrix (m, n, mxCHAR_CLASS, ! mxREAL); po = mxGetChars (plhs[0]); for (j = 0; j < n; j++) diff -cNr octave-2.9.15/examples/mystruct.c octave-2.9.16/examples/mystruct.c *** octave-2.9.15/examples/mystruct.c Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/mystruct.c Tue Oct 30 21:08:15 2007 *************** *** 4,29 **** 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 ! . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, const mxArray* prhs[]) { int i; mwIndex j; --- 4,31 ---- 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 . */ #include "mex.h" void ! mexFunction (int nlhs, mxArray* plhs[], int nrhs, ! const mxArray* prhs[]) { int i; mwIndex j; diff -cNr octave-2.9.15/examples/paramdemo.cc octave-2.9.16/examples/paramdemo.cc *** octave-2.9.15/examples/paramdemo.cc Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/paramdemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,28 **** /* ! Copyright (C) 2007 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 ! . */ #include ! DEFUN_DLD (paramdemo, args, nargout, "Parameter Check Demo.") { int nargin = args.length (); octave_value retval; --- 1,30 ---- /* ! Copyright (C) 2006, 2007 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 . */ #include ! DEFUN_DLD (paramdemo, args, nargout, ! "Parameter Check Demo.") { int nargin = args.length (); octave_value retval; *************** *** 42,52 **** if (m.any_element_is_inf_or_nan()) octave_stdout << " includes Inf or NaN values\n"; if (m.any_element_not_one_or_zero()) ! octave_stdout << " includes other values than 1 and 0\n"; if (m.all_elements_are_int_or_inf_or_nan()) ! octave_stdout << " includes only int, Inf or NaN values\n"; if (m.all_integers (min_val, max_val)) ! octave_stdout << " includes only integers in [-10,10]\n"; } return retval; } --- 44,57 ---- if (m.any_element_is_inf_or_nan()) octave_stdout << " includes Inf or NaN values\n"; if (m.any_element_not_one_or_zero()) ! octave_stdout << ! " includes other values than 1 and 0\n"; if (m.all_elements_are_int_or_inf_or_nan()) ! octave_stdout << ! " includes only int, Inf or NaN values\n"; if (m.all_integers (min_val, max_val)) ! octave_stdout << ! " includes only integers in [-10,10]\n"; } return retval; } diff -cNr octave-2.9.15/examples/stringdemo.cc octave-2.9.16/examples/stringdemo.cc *** octave-2.9.15/examples/stringdemo.cc Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/stringdemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ *************** *** 44,50 **** for (octave_idx_type i = 0; i < nr / 2; i++) { std::string tmp = ch.row_as_string (i); ! ch.insert (ch.row_as_string(nr-i-1).c_str(), i, 0); ch.insert (tmp.c_str(), nr-i-1, 0); } retval(0) = octave_value (ch, true); --- 45,52 ---- for (octave_idx_type i = 0; i < nr / 2; i++) { std::string tmp = ch.row_as_string (i); ! ch.insert (ch.row_as_string(nr-i-1).c_str(), ! i, 0); ch.insert (tmp.c_str(), nr-i-1, 0); } retval(0) = octave_value (ch, true); diff -cNr octave-2.9.15/examples/structdemo.cc octave-2.9.16/examples/structdemo.cc *** octave-2.9.15/examples/structdemo.cc Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/structdemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ *************** *** 39,45 **** { // The following two lines might be written as // octave_value tmp; ! // for (Octave_map::iterator p0 = arg0.begin() ; // p0 != arg0.end(); p0++ ) // if (arg0.key (p0) == arg1) // { --- 40,47 ---- { // The following two lines might be written as // octave_value tmp; ! // for (Octave_map::iterator p0 = ! // arg0.begin(); // p0 != arg0.end(); p0++ ) // if (arg0.key (p0) == arg1) // { diff -cNr octave-2.9.15/examples/unwinddemo.cc octave-2.9.16/examples/unwinddemo.cc *** octave-2.9.15/examples/unwinddemo.cc Fri Oct 12 21:42:21 2007 --- octave-2.9.16/examples/unwinddemo.cc Tue Oct 30 21:08:15 2007 *************** *** 1,22 **** /* ! Copyright (C) 2007 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 ! . */ --- 1,23 ---- /* ! Copyright (C) 2006, 2007 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 . */ *************** *** 43,49 **** if (! error_state) { unwind_protect::begin_frame ("Funwinddemo"); ! unwind_protect_ptr (current_liboctave_warning_handler); set_liboctave_warning_handler(err_hand); retval = octave_value (quotient (a, b)); unwind_protect::run_frame ("Funwinddemo"); --- 44,51 ---- if (! error_state) { unwind_protect::begin_frame ("Funwinddemo"); ! unwind_protect_ptr ! (current_liboctave_warning_handler); set_liboctave_warning_handler(err_hand); retval = octave_value (quotient (a, b)); unwind_protect::run_frame ("Funwinddemo"); diff -cNr octave-2.9.15/libcruft/ChangeLog octave-2.9.16/libcruft/ChangeLog *** octave-2.9.15/libcruft/ChangeLog Fri Oct 12 02:40:57 2007 --- octave-2.9.16/libcruft/ChangeLog Fri Oct 26 11:52:57 2007 *************** *** 1,3 **** --- 1,35 ---- + 2007-10-26 John W. Eaton + + * lapack/dlals0.f: New file. + * lapack/Makefile.in (FSRC): Add it to the list. + + 2007-10-26 David Bateman + + * lapack/dgelsd.f, lapack/dlalsd.f, lapack/dlalsa.f, + lapack/dlasda.f, lapack/dlasdt.f, lapack/dlasdq.f + lapack/dlamrg.f, lapack/dlasd0.f, lapack/dlasd1.f, + lapack/dlasd2.f, lapack/dlasd3.f, lapack/dlasd4.f, + lapack/dlasd5.f, lapack/dlasd6.f, lapack/dlasd7.f, + lapack/dlasd8.f, lapack/dlaed6.f, lapack/zgelsd.f, + lapack/zlalsd.f , lapack/zlalsa.f, lapack/zlals0.f: New files. + * lapack/Makefile.in (FSRC): Include them here. + + 2007-10-23 John W. Eaton + + * lapack/dgtts2.f, lapack/zgtts2.f: New files. + * lapack/Makefile.in (FSRC): Add them to the list. + + 2007-10-16 John W. Eaton + + * lapack/dlacn2.f, lapack/dlacn2.f, lapack/dlahr2.f, + lapack/dlahr2.f, lapack/dlaqr0.f, lapack/dlazq3.f, + lapack/dlazq3.f, lapack/dormr3.f, lapack/dormrz.f, + lapack/iparmq.f, lapack/iparmq.f, lapack/zlacn2.f, + lapack/zlahr2.f, lapack/zlaqr0.f: New files. + * lapack/Makefile.in (FSRC): Add them to the list. + + * lapack: Update all files to current versions from Lapack 3.1.1. + 2007-10-12 John W. Eaton * Change copyright notices in all files that are part of Octave to diff -cNr octave-2.9.15/libcruft/lapack/Makefile.in octave-2.9.16/libcruft/lapack/Makefile.in *** octave-2.9.15/libcruft/lapack/Makefile.in Fri Oct 12 17:27:12 2007 --- octave-2.9.16/libcruft/lapack/Makefile.in Fri Oct 26 11:52:57 2007 *************** *** 26,71 **** EXTERNAL_DISTFILES = $(DISTFILES) ! FSRC = dbdsqr.f dgbcon.f dgbtf2.f dgbtrf.f dgbtrs.f dgebak.f \ ! dgebal.f dgebd2.f dgebrd.f dgecon.f dgeesx.f dgeev.f dgehd2.f\ ! dgehrd.f dgelq2.f dgelqf.f dgelss.f dgelsy.f dgeqp3.f dgeqpf.f \ ! dgeqr2.f dgeqrf.f dgesvd.f dgesv.f dgetf2.f dgetrf.f dgetri.f \ dgetrs.f dggbak.f dggbal.f dgghrd.f dgtsv.f dgttrf.f dgttrs.f \ ! dhgeqz.f dhseqr.f dlabad.f dlabrd.f dlacon.f dlacpy.f dladiv.f \ ! dlae2.f dlaev2.f dlaexc.f dlag2.f dlahqr.f dlahrd.f dlaic1.f \ ! dlaln2.f dlamc1.f dlamc2.f dlamc3.f dlamc4.f dlamc5.f dlamch.f \ ! dlange.f dlanhs.f dlanst.f dlansy.f dlantr.f dlanv2.f dlapy2.f \ ! dlapy3.f dlaqp2.f dlaqps.f dlarfb.f dlarf.f dlarfg.f dlarft.f \ ! dlarfx.f dlartg.f dlarzb.f dlarz.f dlarzt.f dlas2.f dlascl.f \ ! dlaset.f dlasq1.f dlasq2.f dlasq3.f dlasq4.f dlasq5.f dlasq6.f \ ! dlasr.f dlasrt.f dlassq.f dlasv2.f dlaswp.f dlasy2.f dlatbs.f \ ! dlatrd.f dlatrs.f dlatrz.f dlauu2.f dlauum.f dorg2l.f dorg2r.f \ dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgtr.f \ ! dorm2r.f dormbr.f dorml2.f dormlq.f dormqr.f dpbcon.f dpbtf2.f \ ! dpbtrf.f dpbtrs.f dpocon.f dpotf2.f dpotrf.f dpotri.f dpotrs.f \ ! dptsv.f dpttrf.f dpttrs.f dptts2.f drscl.f dsteqr.f dsterf.f \ ! dsyev.f dsytd2.f dsytrd.f dtgevc.f dtrcon.f dtrevc.f dtrexc.f \ ! dtrsen.f dtrsyl.f dtrti2.f dtrtri.f dtrtrs.f dtzrzf.f dzsum1.f \ ! ieeeck.f ilaenv.f izmax1.f spotf2.f spotrf.f zbdsqr.f zdrscl.f \ ! zgbcon.f zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f \ ! zgebrd.f zgecon.f zgeesx.f zgeev.f zgehd2.f zgehrd.f zgelq2.f \ ! zgelqf.f zgelss.f zgelsy.f zgeqp3.f zgeqpf.f zgeqr2.f zgeqrf.f \ ! zgesvd.f zgesv.f zgetf2.f zgetrf.f zgetri.f zgetrs.f zggbal.f \ ! zgtsv.f zgttrf.f zgttrs.f zheev.f zhetd2.f zhetrd.f zhseqr.f \ ! zlabrd.f zlacgv.f zlacon.f zlacpy.f zladiv.f zlahqr.f zlahrd.f \ ! zlaic1.f zlange.f zlanhe.f zlanhs.f zlantr.f zlaqp2.f zlaqps.f \ ! zlarfb.f zlarf.f zlarfg.f zlarft.f zlarfx.f zlartg.f zlarzb.f \ ! zlarz.f zlarzt.f zlascl.f zlaset.f zlasr.f zlassq.f zlaswp.f \ ! zlatbs.f zlatrd.f zlatrs.f zlatrz.f zlauu2.f zlauum.f zpbcon.f \ ! zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpotf2.f zpotrf.f zpotri.f \ ! zpotrs.f zptsv.f zpttrf.f zpttrs.f zptts2.f zrot.f zsteqr.f \ ! ztrcon.f ztrevc.f ztrexc.f ztrsen.f ztrsyl.f ztrti2.f ztrtri.f \ ! ztrtrs.f ztzrzf.f zung2l.f zung2r.f zungbr.f zunghr.f zungl2.f \ ! zunglq.f zungql.f zungqr.f zungtr.f zunm2r.f zunmbr.f zunml2.f \ ! zunmlq.f zunmqr.f zunmr3.f zunmrz.f include $(TOPDIR)/Makeconf dlamc1.o pic/dlamc1.o: FFLAGS += $(F77_FLOAT_STORE_FLAG) include ../Makerules --- 26,78 ---- EXTERNAL_DISTFILES = $(DISTFILES) ! FSRC = dbdsqr.f dgbcon.f dgbtf2.f dgbtrf.f dgbtrs.f dgebak.f dgebal.f \ ! dgebd2.f dgebrd.f dgecon.f dgeesx.f dgeev.f dgehd2.f dgehrd.f \ ! dgelq2.f dgelqf.f dgelsd.f dgelss.f dgelsy.f dgeqp3.f dgeqpf.f \ ! dgeqr2.f dgeqrf.f dgesv.f dgesvd.f dgetf2.f dgetrf.f dgetri.f \ dgetrs.f dggbak.f dggbal.f dgghrd.f dgtsv.f dgttrf.f dgttrs.f \ ! dgtts2.f dhgeqz.f dhseqr.f dlabad.f dlabrd.f dlacn2.f dlacon.f \ ! dlacpy.f dladiv.f dlae2.f dlaed6.f dlaev2.f dlaexc.f dlag2.f \ ! dlahqr.f dlahr2.f dlahrd.f dlaic1.f dlaln2.f dlals0.f dlalsa.f \ ! dlalsd.f dlamc1.f dlamc2.f dlamc3.f dlamc4.f dlamc5.f dlamch.f \ ! dlamrg.f dlange.f dlanhs.f dlanst.f dlansy.f dlantr.f dlanv2.f \ ! dlapy2.f dlapy3.f dlaqp2.f dlaqps.f dlaqr0.f dlaqr1.f dlaqr2.f \ ! dlaqr3.f dlaqr4.f dlaqr5.f dlarf.f dlarfb.f dlarfg.f dlarft.f \ ! dlarfx.f dlartg.f dlarz.f dlarzb.f dlarzt.f dlas2.f dlascl.f \ ! dlasd0.f dlasd1.f dlasd2.f dlasd3.f dlasd4.f dlasd5.f dlasd6.f \ ! dlasd7.f dlasd8.f dlasda.f dlasdq.f dlasdt.f dlaset.f dlasq1.f \ ! dlasq2.f dlasq3.f dlasq4.f dlasq5.f dlasq6.f dlasr.f dlasrt.f \ ! dlassq.f dlasv2.f dlaswp.f dlasy2.f dlatbs.f dlatrd.f dlatrs.f \ ! dlatrz.f dlauu2.f dlauum.f dlazq3.f dlazq4.f dorg2l.f dorg2r.f \ dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgtr.f \ ! dorm2r.f dormbr.f dorml2.f dormlq.f dormqr.f dormr3.f dormrz.f \ ! dpbcon.f dpbtf2.f dpbtrf.f dpbtrs.f dpocon.f dpotf2.f dpotrf.f \ ! dpotri.f dpotrs.f dptsv.f dpttrf.f dpttrs.f dptts2.f drscl.f \ ! dsteqr.f dsterf.f dsyev.f dsytd2.f dsytrd.f dtgevc.f dtrcon.f \ ! dtrevc.f dtrexc.f dtrsen.f dtrsyl.f dtrti2.f dtrtri.f dtrtrs.f \ ! dtzrzf.f dzsum1.f ieeeck.f ilaenv.f iparmq.f izmax1.f spotf2.f \ ! spotrf.f zbdsqr.f zdrscl.f zgbcon.f zgbtf2.f zgbtrf.f zgbtrs.f \ ! zgebak.f zgebal.f zgebd2.f zgebrd.f zgecon.f zgeesx.f zgeev.f \ ! zgehd2.f zgehrd.f zgelq2.f zgelqf.f zgelsd.f zgelss.f zgelsy.f \ ! zgeqp3.f zgeqpf.f zgeqr2.f zgeqrf.f zgesv.f zgesvd.f zgetf2.f \ ! zgetrf.f zgetri.f zgetrs.f zggbal.f zgtsv.f zgttrf.f zgttrs.f \ ! zgtts2.f zheev.f zhetd2.f zhetrd.f zhseqr.f zlabrd.f zlacgv.f \ ! zlacn2.f zlacon.f zlacpy.f zladiv.f zlahqr.f zlahr2.f zlahrd.f \ ! zlaic1.f zlals0.f zlalsa.f zlalsd.f zlange.f zlanhe.f zlanhs.f \ ! zlantr.f zlaqp2.f zlaqps.f zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f \ ! zlaqr4.f zlaqr5.f zlarf.f zlarfb.f zlarfg.f zlarft.f zlarfx.f \ ! zlartg.f zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f \ ! zlassq.f zlaswp.f zlatbs.f zlatrd.f zlatrs.f zlatrz.f zlauu2.f \ ! zlauum.f zpbcon.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpotf2.f \ ! zpotrf.f zpotri.f zpotrs.f zptsv.f zpttrf.f zpttrs.f zptts2.f zrot.f \ ! zsteqr.f ztrcon.f ztrevc.f ztrexc.f ztrsen.f ztrsyl.f ztrti2.f \ ! ztrtri.f ztrtrs.f ztzrzf.f zung2l.f zung2r.f zungbr.f zunghr.f \ ! zungl2.f zunglq.f zungql.f zungqr.f zungtr.f zunm2r.f zunmbr.f \ ! zunml2.f zunmlq.f zunmqr.f zunmr3.f zunmrz.f include $(TOPDIR)/Makeconf dlamc1.o pic/dlamc1.o: FFLAGS += $(F77_FLOAT_STORE_FLAG) include ../Makerules + diff -cNr octave-2.9.15/libcruft/lapack/dbdsqr.f octave-2.9.16/libcruft/lapack/dbdsqr.f *** octave-2.9.15/libcruft/lapack/dbdsqr.f Thu Feb 10 04:26:48 2000 --- octave-2.9.16/libcruft/lapack/dbdsqr.f Tue Oct 16 14:54:19 2007 *************** *** 1,10 **** SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,9 ---- SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * ! * -- LAPACK routine (version 3.1.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * January 2007 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 18,31 **** * Purpose * ======= * ! * DBDSQR computes the singular value decomposition (SVD) of a real ! * N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' ! * denotes the transpose of P), where S is a diagonal matrix with ! * non-negative diagonal elements (the singular values of B), and Q ! * and P are orthogonal matrices. * ! * The routine computes S, and optionally computes U * Q, P' * VT, ! * or Q' * C, for given real input matrices U, VT, and C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, --- 17,42 ---- * Purpose * ======= * ! * DBDSQR computes the singular values and, optionally, the right and/or ! * left singular vectors from the singular value decomposition (SVD) of ! * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit ! * zero-shift QR algorithm. The SVD of B has the form ! * ! * B = Q * S * P**T ! * ! * where S is the diagonal matrix of singular values, Q is an orthogonal ! * matrix of left singular vectors, and P is an orthogonal matrix of ! * right singular vectors. If left singular vectors are requested, this ! * subroutine actually returns U*Q instead of Q, and, if right singular ! * vectors are requested, this subroutine returns P**T*VT instead of ! * P**T, for given real input matrices U and VT. When U and VT are the ! * orthogonal matrices that reduce a general matrix A to bidiagonal ! * form: A = U*B*VT, as computed by DGEBRD, then * ! * A = (U*Q) * S * (P**T*VT) ! * ! * is the SVD of A. Optionally, the subroutine may also compute Q**T*C ! * for a given real input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, *************** *** 60,78 **** * On exit, if INFO=0, the singular values of B in decreasing * order. * ! * E (input/output) DOUBLE PRECISION array, dimension (N) ! * On entry, the elements of E contain the ! * offdiagonal elements of the bidiagonal matrix whose SVD ! * is desired. On normal exit (INFO = 0), E is destroyed. ! * If the algorithm does not converge (INFO > 0), D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given ! * as input. E(N) is used for workspace. * * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. ! * On exit, VT is overwritten by P' * VT. ! * VT is not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. --- 71,88 ---- * On exit, if INFO=0, the singular values of B in decreasing * order. * ! * E (input/output) DOUBLE PRECISION array, dimension (N-1) ! * On entry, the N-1 offdiagonal elements of the bidiagonal ! * matrix B. ! * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given ! * as input. * * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. ! * On exit, VT is overwritten by P**T * VT. ! * Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. *************** *** 81,101 **** * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. ! * U is not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. ! * On exit, C is overwritten by Q' * C. ! * C is not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * ! * WORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * INFO (output) INTEGER * = 0: successful exit --- 91,112 ---- * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. ! * Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. ! * On exit, C is overwritten by Q**T * C. ! * Not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * ! * WORK (workspace) DOUBLE PRECISION array, dimension (2*N) ! * if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise * * INFO (output) INTEGER * = 0: successful exit *************** *** 155,161 **** $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, ! $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. --- 166,172 ---- $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, ! $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. *************** *** 415,421 **** E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 100 CONTINUE --- 426,431 ---- *************** *** 444,450 **** E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 110 CONTINUE --- 454,459 ---- diff -cNr octave-2.9.15/libcruft/lapack/dgbcon.f octave-2.9.16/libcruft/lapack/dgbcon.f *** octave-2.9.15/libcruft/lapack/dgbcon.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dgbcon.f Tue Oct 16 14:54:19 2007 *************** *** 1,10 **** SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER NORM --- 1,11 ---- SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM *************** *** 87,92 **** --- 88,96 ---- INTEGER IX, J, JP, KASE, KASE1, KD, LM DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX *************** *** 94,100 **** EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DAXPY, DLACON, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN --- 98,104 ---- EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DAXPY, DLACN2, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN *************** *** 148,154 **** LNOTI = KL.GT.0 KASE = 0 10 CONTINUE ! CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * --- 152,158 ---- LNOTI = KL.GT.0 KASE = 0 10 CONTINUE ! CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/dgbtf2.f octave-2.9.16/libcruft/lapack/dgbtf2.f *** octave-2.9.15/libcruft/lapack/dgbtf2.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dgbtf2.f Tue Oct 16 14:54:19 2007 *************** *** 1,9 **** SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N --- 1,8 ---- SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff -cNr octave-2.9.15/libcruft/lapack/dgbtrf.f octave-2.9.16/libcruft/lapack/dgbtrf.f *** octave-2.9.15/libcruft/lapack/dgbtrf.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dgbtrf.f Tue Oct 16 14:54:19 2007 *************** *** 1,9 **** SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N --- 1,8 ---- SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff -cNr octave-2.9.15/libcruft/lapack/dgbtrs.f octave-2.9.16/libcruft/lapack/dgbtrs.f *** octave-2.9.15/libcruft/lapack/dgbtrs.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dgbtrs.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANS --- 1,9 ---- SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS diff -cNr octave-2.9.15/libcruft/lapack/dgebak.f octave-2.9.16/libcruft/lapack/dgebak.f *** octave-2.9.15/libcruft/lapack/dgebak.f Wed Nov 3 14:54:16 1999 --- octave-2.9.16/libcruft/lapack/dgebak.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB, SIDE --- 1,9 ---- SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff -cNr octave-2.9.15/libcruft/lapack/dgebal.f octave-2.9.16/libcruft/lapack/dgebal.f *** octave-2.9.15/libcruft/lapack/dgebal.f Wed Nov 3 14:54:16 1999 --- octave-2.9.16/libcruft/lapack/dgebal.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOB --- 1,8 ---- SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOB *************** *** 105,111 **** DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC ! PARAMETER ( SCLFAC = 0.8D+1 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. --- 104,110 ---- DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC ! PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. diff -cNr octave-2.9.15/libcruft/lapack/dgebd2.f octave-2.9.16/libcruft/lapack/dgebd2.f *** octave-2.9.15/libcruft/lapack/dgebd2.f Wed Nov 3 14:54:17 1999 --- octave-2.9.16/libcruft/lapack/dgebd2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N *************** *** 169,176 **** * * Apply H(i) to A(i:m,i+1:n) from the left * ! CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), ! $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN --- 168,176 ---- * * Apply H(i) to A(i:m,i+1:n) from the left * ! IF( I.LT.N ) ! $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), ! $ A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN *************** *** 207,214 **** * * Apply G(i) to A(i+1:m,i:n) from the right * ! CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), ! $ A( MIN( I+1, M ), I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN --- 207,215 ---- * * Apply G(i) to A(i+1:m,i:n) from the right * ! IF( I.LT.M ) ! $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, ! $ TAUP( I ), A( I+1, I ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN diff -cNr octave-2.9.15/libcruft/lapack/dgebrd.f octave-2.9.16/libcruft/lapack/dgebrd.f *** octave-2.9.15/libcruft/lapack/dgebrd.f Wed Nov 3 14:54:17 1999 --- octave-2.9.16/libcruft/lapack/dgebrd.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N --- 1,9 ---- SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N *************** *** 70,76 **** * The scalar factors of the elementary reflectors which * represent the orthogonal matrix P. See Further Details. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 69,75 ---- * The scalar factors of the elementary reflectors which * represent the orthogonal matrix P. See Further Details. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dgecon.f octave-2.9.16/libcruft/lapack/dgecon.f *** octave-2.9.15/libcruft/lapack/dgecon.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dgecon.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER NORM --- 1,11 ---- SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM *************** *** 74,79 **** --- 75,83 ---- INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX *************** *** 81,87 **** EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DLACON, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX --- 85,91 ---- EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX *************** *** 129,135 **** END IF KASE = 0 10 CONTINUE ! CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * --- 133,139 ---- END IF KASE = 0 10 CONTINUE ! CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/dgeesx.f octave-2.9.16/libcruft/lapack/dgeesx.f *** octave-2.9.15/libcruft/lapack/dgeesx.f Wed Nov 3 14:54:17 1999 --- octave-2.9.16/libcruft/lapack/dgeesx.f Tue Oct 16 14:54:20 2007 *************** *** 2,11 **** $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT --- 2,10 ---- $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT *************** *** 63,69 **** * = 'N': Eigenvalues are not ordered; * = 'S': Eigenvalues are ordered (see SELECT). * ! * SELECT (input) LOGICAL FUNCTION of two DOUBLE PRECISION arguments * SELECT must be declared EXTERNAL in the calling subroutine. * If SORT = 'S', SELECT is used to select eigenvalues to sort * to the top left of the Schur form. --- 62,68 ---- * = 'N': Eigenvalues are not ordered; * = 'S': Eigenvalues are ordered (see SELECT). * ! * SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments * SELECT must be declared EXTERNAL in the calling subroutine. * If SORT = 'S', SELECT is used to select eigenvalues to sort * to the top left of the Schur form. *************** *** 129,135 **** * condition number for the selected right invariant subspace. * Not referenced if SENSE = 'N' or 'E'. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 128,134 ---- * condition number for the selected right invariant subspace. * Not referenced if SENSE = 'N' or 'E'. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 137,152 **** * Also, if SENSE = 'E' or 'V' or 'B', * LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of * selected eigenvalues computed by this routine. Note that ! * N+2*SDIM*(N-SDIM) <= N+N*N/2. * For good performance, LWORK must generally be larger. * ! * IWORK (workspace/output) INTEGER array, dimension (LIWORK) ! * Not referenced if SENSE = 'N' or 'E'. * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). * * BWORK (workspace) LOGICAL array, dimension (N) * Not referenced if SORT = 'N'. --- 136,167 ---- * Also, if SENSE = 'E' or 'V' or 'B', * LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of * selected eigenvalues computed by this routine. Note that ! * N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only ! * returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or ! * 'B' this may not be large enough. * For good performance, LWORK must generally be larger. * ! * If LWORK = -1, then a workspace query is assumed; the routine ! * only calculates upper bounds on the optimal sizes of the ! * arrays WORK and IWORK, returns these values as the first ! * entries of the WORK and IWORK arrays, and no error messages ! * related to LWORK or LIWORK are issued by XERBLA. ! * ! * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). + * Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is + * only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this + * may not be large enough. + * + * If LIWORK = -1, then a workspace query is assumed; the + * routine only calculates upper bounds on the optimal sizes of + * the arrays WORK and IWORK, returns these values as the first + * entries of the WORK and IWORK arrays, and no error messages + * related to LWORK or LIWORK are issued by XERBLA. * * BWORK (workspace) LOGICAL array, dimension (N) * Not referenced if SORT = 'N'. *************** *** 175,184 **** PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. ! LOGICAL CURSL, LASTSL, LST2SL, SCALEA, WANTSB, WANTSE, ! $ WANTSN, WANTST, WANTSV, WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, ! $ IHI, ILO, INXT, IP, ITAU, IWRK, K, MAXB, $ MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM * .. --- 190,199 ---- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. ! LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB, ! $ WANTSE, WANTSN, WANTST, WANTSV, WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, ! $ IHI, ILO, INXT, IP, ITAU, IWRK, LIWRK, LWRK, $ MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM * .. *************** *** 193,202 **** LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE ! EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * --- 208,217 ---- LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE ! EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * *************** *** 209,214 **** --- 224,230 ---- WANTSE = LSAME( SENSE, 'E' ) WANTSV = LSAME( SENSE, 'V' ) WANTSB = LSAME( SENSE, 'B' ) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN *************** *** 238,270 **** * depends on SDIM, which is computed by the routine DTRSEN later * in the code.) * ! MINWRK = 1 ! IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN ! MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) ! MINWRK = MAX( 1, 3*N ) ! IF( .NOT.WANTVS ) THEN ! MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SN', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) ELSE ! MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* ! $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) ! MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, N+HSWORK, 1 ) END IF - WORK( 1 ) = MAXWRK - END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -16 - END IF - IF( LIWORK.LT.1 ) THEN - INFO = -18 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEESX', -INFO ) RETURN --- 254,295 ---- * depends on SDIM, which is computed by the routine DTRSEN later * in the code.) * ! IF( INFO.EQ.0 ) THEN ! LIWRK = 1 ! IF( N.EQ.0 ) THEN ! MINWRK = 1 ! LWRK = 1 ELSE ! MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) ! MINWRK = 3*N ! * ! CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, ! $ WORK, -1, IEVAL ) ! HSWORK = WORK( 1 ) ! * ! IF( .NOT.WANTVS ) THEN ! MAXWRK = MAX( MAXWRK, N + HSWORK ) ! ELSE ! MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, ! $ 'DORGHR', ' ', N, 1, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, N + HSWORK ) ! END IF ! LWRK = MAXWRK ! IF( .NOT.WANTSN ) ! $ LWRK = MAX( LWRK, N + ( N*N )/2 ) ! IF( WANTSV .OR. WANTSB ) ! $ LIWRK = ( N*N )/4 ! END IF ! IWORK( 1 ) = LIWRK ! WORK( 1 ) = LWRK ! * ! IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN ! INFO = -16 ! ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN ! INFO = -18 END IF END IF + * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEESX', -INFO ) RETURN *************** *** 490,496 **** * WORK( 1 ) = MAXWRK IF( WANTSV .OR. WANTSB ) THEN ! IWORK( 1 ) = SDIM*( N-SDIM ) ELSE IWORK( 1 ) = 1 END IF --- 515,521 ---- * WORK( 1 ) = MAXWRK IF( WANTSV .OR. WANTSB ) THEN ! IWORK( 1 ) = MAX( 1, SDIM*( N-SDIM ) ) ELSE IWORK( 1 ) = 1 END IF diff -cNr octave-2.9.15/libcruft/lapack/dgeev.f octave-2.9.16/libcruft/lapack/dgeev.f *** octave-2.9.15/libcruft/lapack/dgeev.f Thu Feb 10 04:20:48 2000 --- octave-2.9.16/libcruft/lapack/dgeev.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * December 8, 1999 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR --- 1,9 ---- SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR *************** *** 90,96 **** * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 89,95 ---- * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 121,127 **** LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, ! $ MAXB, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. --- 120,126 ---- LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, ! $ MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. *************** *** 130,137 **** DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. ! EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, ! $ DLASCL, DORGHR, DROT, DSCAL, DTREVC, XERBLA * .. * .. External Functions .. LOGICAL LSAME --- 129,137 ---- DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. ! EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, ! $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC, ! $ XERBLA * .. * .. External Functions .. LOGICAL LSAME *************** *** 141,147 **** $ DNRM2 * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * --- 141,147 ---- $ DNRM2 * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * *************** *** 175,206 **** * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * ! MINWRK = 1 ! IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN ! MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) ! IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN ! MINWRK = MAX( 1, 3*N ) ! MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) ELSE ! MINWRK = MAX( 1, 4*N ) ! MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* ! $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) ! MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) ! MAXWRK = MAX( MAXWRK, 4*N ) END IF WORK( 1 ) = MAXWRK END IF ! IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN ! INFO = -13 ! END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEV ', -INFO ) RETURN --- 175,220 ---- * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * ! IF( INFO.EQ.0 ) THEN ! IF( N.EQ.0 ) THEN ! MINWRK = 1 ! MAXWRK = 1 ELSE ! MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) ! IF( WANTVL ) THEN ! MINWRK = 4*N ! MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, ! $ 'DORGHR', ' ', N, 1, N, -1 ) ) ! CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, ! $ WORK, -1, INFO ) ! HSWORK = WORK( 1 ) ! MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) ! MAXWRK = MAX( MAXWRK, 4*N ) ! ELSE IF( WANTVR ) THEN ! MINWRK = 4*N ! MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, ! $ 'DORGHR', ' ', N, 1, N, -1 ) ) ! CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, ! $ WORK, -1, INFO ) ! HSWORK = WORK( 1 ) ! MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) ! MAXWRK = MAX( MAXWRK, 4*N ) ! ELSE ! MINWRK = 3*N ! CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, ! $ WORK, -1, INFO ) ! HSWORK = WORK( 1 ) ! MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) ! END IF ! MAXWRK = MAX( MAXWRK, MINWRK ) END IF WORK( 1 ) = MAXWRK + * + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF END IF ! * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEV ', -INFO ) RETURN diff -cNr octave-2.9.15/libcruft/lapack/dgehd2.f octave-2.9.16/libcruft/lapack/dgehd2.f *** octave-2.9.15/libcruft/lapack/dgehd2.f Wed Nov 3 14:54:17 1999 --- octave-2.9.16/libcruft/lapack/dgehd2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N --- 1,8 ---- SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N diff -cNr octave-2.9.15/libcruft/lapack/dgehrd.f octave-2.9.16/libcruft/lapack/dgehrd.f *** octave-2.9.15/libcruft/lapack/dgehrd.f Wed Nov 3 14:54:18 1999 --- octave-2.9.16/libcruft/lapack/dgehrd.f Tue Oct 16 14:54:20 2007 *************** *** 1,15 **** SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose --- 1,14 ---- SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose *************** *** 98,122 **** * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) ! DOUBLE PRECISION ZERO, ONE ! PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY ! INTEGER I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, ! $ NH, NX ! DOUBLE PRECISION EI * .. * .. Local Arrays .. ! DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Subroutines .. ! EXTERNAL DGEHD2, DGEMM, DLAHRD, DLARFB, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN --- 97,127 ---- * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * + * This file is a slight modification of LAPACK-3.0's DGEHRD + * subroutine incorporating improvements proposed by Quintana-Orti and + * Van de Geijn (2005). + * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) ! DOUBLE PRECISION ZERO, ONE ! PARAMETER ( ZERO = 0.0D+0, ! $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY ! INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, ! $ NBMIN, NH, NX ! DOUBLE PRECISION EI * .. * .. Local Arrays .. ! DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Subroutines .. ! EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM, ! $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN *************** *** 169,175 **** RETURN END IF * ! * Determine the block size. * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 --- 174,180 ---- RETURN END IF * ! * Determine the block size * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 *************** *** 177,195 **** IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code ! * (last block is always handled by unblocked code). * NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * ! * Determine if workspace is large enough for blocked code. * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of ! * unblocked code. * NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, $ -1 ) ) --- 182,200 ---- IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code ! * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * ! * Determine if workspace is large enough for blocked code * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of ! * unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, $ -1 ) ) *************** *** 213,246 **** * * Use blocked code * ! DO 30 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * ! CALL DLAHRD( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set ! * to 1. * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE ! CALL DGEMM( 'No transpose', 'Transpose', IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * ! CALL DLARFB( 'Left', 'Transpose', 'Forward', 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, $ A( I+1, I+IB ), LDA, WORK, LDWORK ) ! 30 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix --- 218,264 ---- * * Use blocked code * ! DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * ! CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set ! * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE ! CALL DGEMM( 'No transpose', 'Transpose', ! $ IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * + * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the + * right + * + CALL DTRMM( 'Right', 'Lower', 'Transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE + * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * ! CALL DLARFB( 'Left', 'Transpose', 'Forward', ! $ 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, $ A( I+1, I+IB ), LDA, WORK, LDWORK ) ! 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix diff -cNr octave-2.9.15/libcruft/lapack/dgelq2.f octave-2.9.16/libcruft/lapack/dgelq2.f *** octave-2.9.15/libcruft/lapack/dgelq2.f Wed Nov 3 14:54:18 1999 --- octave-2.9.16/libcruft/lapack/dgelq2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/dgelqf.f octave-2.9.16/libcruft/lapack/dgelqf.f *** octave-2.9.15/libcruft/lapack/dgelqf.f Wed Nov 3 14:54:18 1999 --- octave-2.9.16/libcruft/lapack/dgelqf.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N *************** *** 42,48 **** * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 41,47 ---- * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dgelsd.f octave-2.9.16/libcruft/lapack/dgelsd.f *** octave-2.9.15/libcruft/lapack/dgelsd.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dgelsd.f Fri Oct 26 11:52:57 2007 *************** *** 0 **** --- 1,528 ---- + SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, + $ WORK, LWORK, IWORK, INFO ) + * + * -- LAPACK driver routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND + * .. + * .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * DGELSD computes the minimum-norm solution to a real linear least + * squares problem: + * minimize 2-norm(| b - A*x |) + * using the singular value decomposition (SVD) of A. A is an M-by-N + * matrix which may be rank-deficient. + * + * Several right hand side vectors b and solution vectors x can be + * handled in a single call; they are stored as the columns of the + * M-by-NRHS right hand side matrix B and the N-by-NRHS solution + * matrix X. + * + * The problem is solved in three steps: + * (1) Reduce the coefficient matrix A to bidiagonal form with + * Householder transformations, reducing the original problem + * into a "bidiagonal least squares problem" (BLS) + * (2) Solve the BLS using a divide and conquer approach. + * (3) Apply back all the Householder tranformations to solve + * the original least squares problem. + * + * The effective rank of A is determined by treating as zero those + * singular values which are less than RCOND times the largest singular + * value. + * + * The divide and conquer algorithm makes very mild assumptions about + * floating point arithmetic. It will work on machines with a guard + * digit in add/subtract, or on those binary machines without guard + * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or + * Cray-2. It could conceivably fail on hexadecimal or decimal machines + * without guard digits, but we know of none. + * + * Arguments + * ========= + * + * M (input) INTEGER + * The number of rows of A. M >= 0. + * + * N (input) INTEGER + * The number of columns of A. N >= 0. + * + * NRHS (input) INTEGER + * The number of right hand sides, i.e., the number of columns + * of the matrices B and X. NRHS >= 0. + * + * A (input) DOUBLE PRECISION array, dimension (LDA,N) + * On entry, the M-by-N matrix A. + * On exit, A has been destroyed. + * + * LDA (input) INTEGER + * The leading dimension of the array A. LDA >= max(1,M). + * + * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) + * On entry, the M-by-NRHS right hand side matrix B. + * On exit, B is overwritten by the N-by-NRHS solution + * matrix X. If m >= n and RANK = n, the residual + * sum-of-squares for the solution in the i-th column is given + * by the sum of squares of elements n+1:m in that column. + * + * LDB (input) INTEGER + * The leading dimension of the array B. LDB >= max(1,max(M,N)). + * + * S (output) DOUBLE PRECISION array, dimension (min(M,N)) + * The singular values of A in decreasing order. + * The condition number of A in the 2-norm = S(1)/S(min(m,n)). + * + * RCOND (input) DOUBLE PRECISION + * RCOND is used to determine the effective rank of A. + * Singular values S(i) <= RCOND*S(1) are treated as zero. + * If RCOND < 0, machine precision is used instead. + * + * RANK (output) INTEGER + * The effective rank of A, i.e., the number of singular values + * which are greater than RCOND*S(1). + * + * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) + * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + * + * LWORK (input) INTEGER + * The dimension of the array WORK. LWORK must be at least 1. + * The exact minimum amount of workspace needed depends on M, + * N and NRHS. As long as LWORK is at least + * 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, + * if M is greater than or equal to N or + * 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, + * if M is less than N, the code will execute correctly. + * SMLSIZ is returned by ILAENV and is equal to the maximum + * size of the subproblems at the bottom of the computation + * tree (usually about 25), and + * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) + * For good performance, LWORK should generally be larger. + * + * If LWORK = -1, then a workspace query is assumed; the routine + * only calculates the optimal size of the WORK array, returns + * this value as the first entry of the WORK array, and no error + * message related to LWORK is issued by XERBLA. + * + * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) + * LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, + * where MINMN = MIN( M,N ). + * + * INFO (output) INTEGER + * = 0: successful exit + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: the algorithm for computing the SVD failed to converge; + * if INFO = i, i off-diagonal elements of an intermediate + * bidiagonal form did not converge to zero. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + * .. + * .. Local Scalars .. + LOGICAL LQUERY + INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, + $ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM, + $ MNTHR, NLVL, NWORK, SMLSIZ, WLALSD + DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM + * .. + * .. External Subroutines .. + EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD, + $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA + * .. + * .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL ILAENV, DLAMCH, DLANGE + * .. + * .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN + * .. + * .. Executable Statements .. + * + * Test the input arguments. + * + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN + INFO = -7 + END IF + * + SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 ) + * + * Compute workspace. + * (Note: Comments in the code beginning "Workspace:" describe the + * minimal amount of workspace needed at that point in the code, + * as well as the preferred amount for good performance. + * NB refers to the optimal block size for the immediately + * following subroutine, as returned by ILAENV.) + * + MINWRK = 1 + MINMN = MAX( 1, MINMN ) + NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / + $ LOG( TWO ) ) + 1, 0 ) + * + IF( INFO.EQ.0 ) THEN + MAXWRK = 0 + MM = M + IF( M.GE.N .AND. M.GE.MNTHR ) THEN + * + * Path 1a - overdetermined, with many more rows than columns. + * + MM = N + MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, + $ -1, -1 ) ) + MAXWRK = MAX( MAXWRK, N+NRHS* + $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) + END IF + IF( M.GE.N ) THEN + * + * Path 1 - overdetermined or exactly determined. + * + MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* + $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+NRHS* + $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* + $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) ) + WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2 + MAXWRK = MAX( MAXWRK, 3*N+WLALSD ) + MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD ) + END IF + IF( N.GT.M ) THEN + WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2 + IF( N.GE.MNTHR ) THEN + * + * Path 2a - underdetermined, with many more columns + * than rows. + * + MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) + MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* + $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* + $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* + $ ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) ) + IF( NRHS.GT.1 ) THEN + MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) + ELSE + MAXWRK = MAX( MAXWRK, M*M+2*M ) + END IF + MAXWRK = MAX( MAXWRK, M+NRHS* + $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD ) + ELSE + * + * Path 2 - remaining underdetermined cases. + * + MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, + $ -1, -1 ) + MAXWRK = MAX( MAXWRK, 3*M+NRHS* + $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+M* + $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*M+WLALSD ) + END IF + MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD ) + END IF + MINWRK = MIN( MINWRK, MAXWRK ) + WORK( 1 ) = MAXWRK + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF + * + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGELSD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + GO TO 10 + END IF + * + * Quick return if possible. + * + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RANK = 0 + RETURN + END IF + * + * Get machine parameters. + * + EPS = DLAMCH( 'P' ) + SFMIN = DLAMCH( 'S' ) + SMLNUM = SFMIN / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + * + * Scale A if max entry outside range [SMLNUM,BIGNUM]. + * + ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + * + * Scale matrix norm up to SMLNUM. + * + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN + * + * Scale matrix norm down to BIGNUM. + * + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN + * + * Matrix all zero. Return zero solution. + * + CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) + RANK = 0 + GO TO 10 + END IF + * + * Scale B if max entry outside range [SMLNUM,BIGNUM]. + * + BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + * + * Scale matrix norm up to SMLNUM. + * + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN + * + * Scale matrix norm down to BIGNUM. + * + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF + * + * If M < N make sure certain entries of B are zero. + * + IF( M.LT.N ) + $ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) + * + * Overdetermined case. + * + IF( M.GE.N ) THEN + * + * Path 1 - overdetermined or exactly determined. + * + MM = M + IF( M.GE.MNTHR ) THEN + * + * Path 1a - overdetermined, with many more rows than columns. + * + MM = N + ITAU = 1 + NWORK = ITAU + N + * + * Compute A=Q*R. + * (Workspace: need 2*N, prefer N+N*NB) + * + CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Multiply B by transpose(Q). + * (Workspace: need N+NRHS, prefer N+NRHS*NB) + * + CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + * Zero out below R. + * + IF( N.GT.1 ) THEN + CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) + END IF + END IF + * + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + NWORK = ITAUP + N + * + * Bidiagonalize R in A. + * (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) + * + CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ INFO ) + * + * Multiply B by transpose of left bidiagonalizing vectors of R. + * (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) + * + CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + * Solve the bidiagonal least squares problem. + * + CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF + * + * Multiply B by right bidiagonalizing vectors of R. + * + CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ + $ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN + * + * Path 2a - underdetermined, with many more columns than rows + * and sufficient workspace for an efficient algorithm. + * + LDWORK = M + IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), + $ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA + ITAU = 1 + NWORK = M + 1 + * + * Compute A=L*Q. + * (Workspace: need 2*M, prefer M+M*NB) + * + CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + IL = NWORK + * + * Copy L to WORK(IL), zeroing out above its diagonal. + * + CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) + CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), + $ LDWORK ) + IE = IL + LDWORK*M + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M + * + * Bidiagonalize L in WORK(IL). + * (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) + * + CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Multiply B by transpose of left bidiagonalizing vectors of L. + * (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) + * + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUQ ), B, LDB, WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Solve the bidiagonal least squares problem. + * + CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF + * + * Multiply B by right bidiagonalizing vectors of L. + * + CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUP ), B, LDB, WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Zero out below first M rows of B. + * + CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) + NWORK = ITAU + M + * + * Multiply transpose(Q) by B. + * (Workspace: need M+NRHS, prefer M+NRHS*NB) + * + CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + ELSE + * + * Path 2 - remaining underdetermined cases. + * + IE = 1 + ITAUQ = IE + M + ITAUP = ITAUQ + M + NWORK = ITAUP + M + * + * Bidiagonalize A. + * (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) + * + CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ INFO ) + * + * Multiply B by transpose of left bidiagonalizing vectors. + * (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) + * + CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + * Solve the bidiagonal least squares problem. + * + CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF + * + * Multiply B by right bidiagonalizing vectors of A. + * + CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + END IF + * + * Undo scaling. + * + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF + * + 10 CONTINUE + WORK( 1 ) = MAXWRK + RETURN + * + * End of DGELSD + * + END diff -cNr octave-2.9.15/libcruft/lapack/dgelss.f octave-2.9.16/libcruft/lapack/dgelss.f *** octave-2.9.15/libcruft/lapack/dgelss.f Thu Dec 14 16:57:14 2000 --- octave-2.9.16/libcruft/lapack/dgelss.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK --- 1,9 ---- SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK *************** *** 78,84 **** * The effective rank of A, i.e., the number of singular values * which are greater than RCOND*S(1). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 77,83 ---- * The effective rank of A, i.e., the number of singular values * which are greater than RCOND*S(1). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 134,140 **** INFO = 0 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) - MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 --- 133,138 ---- *************** *** 155,239 **** * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * ! MINWRK = 1 ! IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN ! MAXWRK = 0 ! MM = M ! IF( M.GE.N .AND. M.GE.MNTHR ) THEN ! * ! * Path 1a - overdetermined, with many more rows than columns ! * ! MM = N ! MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, ! $ -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, N+NRHS* ! $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) ! END IF ! IF( M.GE.N ) THEN * ! * Path 1 - overdetermined or exactly determined * ! * Compute workspace needed for DBDSQR * ! BDSPAC = MAX( 1, 5*N ) ! MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* ! $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*N+NRHS* ! $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* ! $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, BDSPAC ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) ! MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC ) ! MAXWRK = MAX( MINWRK, MAXWRK ) ! END IF ! IF( N.GT.M ) THEN * ! * Compute workspace needed for DBDSQR * ! BDSPAC = MAX( 1, 5*M ) ! MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) ! IF( N.GE.MNTHR ) THEN ! * ! * Path 2a - underdetermined, with many more columns ! * than rows ! * ! MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) ! MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* ! $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* ! $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* ! $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC ) ! IF( NRHS.GT.1 ) THEN ! MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) ELSE - MAXWRK = MAX( MAXWRK, M*M+2*M ) - END IF - MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) - ELSE * ! * Path 2 - underdetermined * ! MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, ! $ -1, -1 ) ! MAXWRK = MAX( MAXWRK, 3*M+NRHS* ! $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*M+M* ! $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, BDSPAC ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) END IF END IF - MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK END IF * - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSS', -INFO ) RETURN --- 153,243 ---- * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * ! IF( INFO.EQ.0 ) THEN ! MINWRK = 1 ! MAXWRK = 1 ! IF( MINMN.GT.0 ) THEN ! MM = M ! MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) ! IF( M.GE.N .AND. M.GE.MNTHR ) THEN ! * ! * Path 1a - overdetermined, with many more rows than ! * columns ! * ! MM = N ! MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'DGEQRF', ' ', M, ! $ N, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'DORMQR', 'LT', ! $ M, NRHS, N, -1 ) ) ! END IF ! IF( M.GE.N ) THEN * ! * Path 1 - overdetermined or exactly determined * ! * Compute workspace needed for DBDSQR * ! BDSPAC = MAX( 1, 5*N ) ! MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1, ! $ 'DGEBRD', ' ', MM, N, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'DORMBR', ! $ 'QLT', MM, NRHS, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1, ! $ 'DORGBR', 'P', N, N, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, BDSPAC ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) ! MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC ) ! MAXWRK = MAX( MINWRK, MAXWRK ) ! END IF ! IF( N.GT.M ) THEN * ! * Compute workspace needed for DBDSQR * ! BDSPAC = MAX( 1, 5*M ) ! MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) ! IF( N.GE.MNTHR ) THEN ! * ! * Path 2a - underdetermined, with many more columns ! * than rows ! * ! MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, ! $ -1 ) ! MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1, ! $ 'DGEBRD', ' ', M, M, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1, ! $ 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, M*M + 4*M + ! $ ( M - 1 )*ILAENV( 1, 'DORGBR', 'P', M, ! $ M, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC ) ! IF( NRHS.GT.1 ) THEN ! MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) ! ELSE ! MAXWRK = MAX( MAXWRK, M*M + 2*M ) ! END IF ! MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'DORMLQ', ! $ 'LT', N, NRHS, M, -1 ) ) ELSE * ! * Path 2 - underdetermined * ! MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'DGEBRD', ' ', M, ! $ N, -1, -1 ) ! MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'DORMBR', ! $ 'QLT', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'DORGBR', ! $ 'P', M, N, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, BDSPAC ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) ! END IF END IF + MAXWRK = MAX( MINWRK, MAXWRK ) END IF WORK( 1 ) = MAXWRK + * + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSS', -INFO ) RETURN diff -cNr octave-2.9.15/libcruft/lapack/dgeqpf.f octave-2.9.16/libcruft/lapack/dgeqpf.f *** octave-2.9.15/libcruft/lapack/dgeqpf.f Wed Nov 3 14:54:18 1999 --- octave-2.9.16/libcruft/lapack/dgeqpf.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * ! * -- LAPACK test routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * ! * -- LAPACK deprecated driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N *************** *** 75,80 **** --- 74,85 ---- * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * + * Partial column norm updating strategy modified by + * Z. Drmac and Z. Bujanovic, Dept. of Mathematics, + * University of Zagreb, Croatia. + * June 2006. + * For more details see LAPACK Working Note 176. + * * ===================================================================== * * .. Parameters .. *************** *** 83,89 **** * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT ! DOUBLE PRECISION AII, TEMP, TEMP2 * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA --- 88,94 ---- * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT ! DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA *************** *** 93,100 **** * .. * .. External Functions .. INTEGER IDAMAX ! DOUBLE PRECISION DNRM2 ! EXTERNAL IDAMAX, DNRM2 * .. * .. Executable Statements .. * --- 98,105 ---- * .. * .. External Functions .. INTEGER IDAMAX ! DOUBLE PRECISION DLAMCH, DNRM2 ! EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. Executable Statements .. * *************** *** 114,119 **** --- 119,125 ---- END IF * MN = MIN( M, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) * * Move initial columns up front * *************** *** 195,205 **** * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN ! TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2 ! TEMP = MAX( TEMP, ZERO ) ! TEMP2 = ONE + 0.05D0*TEMP* ! $ ( WORK( J ) / WORK( N+J ) )**2 ! IF( TEMP2.EQ.ONE ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) --- 201,214 ---- * DO 30 J = I + 1, N IF( WORK( J ).NE.ZERO ) THEN ! * ! * NOTE: The following 4 lines follow from the analysis in ! * Lapack Working Note 176. ! * ! TEMP = ABS( A( I, J ) ) / WORK( J ) ! TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) ! TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2 ! IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) WORK( N+J ) = WORK( J ) diff -cNr octave-2.9.15/libcruft/lapack/dgeqr2.f octave-2.9.16/libcruft/lapack/dgeqr2.f *** octave-2.9.15/libcruft/lapack/dgeqr2.f Wed Nov 3 14:54:18 1999 --- octave-2.9.16/libcruft/lapack/dgeqr2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/dgeqrf.f octave-2.9.16/libcruft/lapack/dgeqrf.f *** octave-2.9.15/libcruft/lapack/dgeqrf.f Wed Nov 3 14:54:19 1999 --- octave-2.9.16/libcruft/lapack/dgeqrf.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N *************** *** 43,49 **** * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 42,48 ---- * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dgesv.f octave-2.9.16/libcruft/lapack/dgesv.f *** octave-2.9.15/libcruft/lapack/dgesv.f Wed Nov 3 14:54:19 1999 --- octave-2.9.16/libcruft/lapack/dgesv.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS --- 1,8 ---- SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/dgesvd.f octave-2.9.16/libcruft/lapack/dgesvd.f *** octave-2.9.15/libcruft/lapack/dgesvd.f Thu Feb 10 04:26:49 2000 --- octave-2.9.16/libcruft/lapack/dgesvd.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT --- 1,9 ---- SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT *************** *** 105,111 **** * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK; * if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged * superdiagonal elements of an upper bidiagonal matrix B --- 104,110 ---- * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK; * if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged * superdiagonal elements of an upper bidiagonal matrix B *************** *** 114,121 **** * as A, and singular vectors related by U and VT. * * LWORK (input) INTEGER ! * The dimension of the array WORK. LWORK >= 1. ! * LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine --- 113,120 ---- * as A, and singular vectors related by U and VT. * * LWORK (input) INTEGER ! * The dimension of the array WORK. ! * LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine *************** *** 169,175 **** * INFO = 0 MINMN = MIN( M, N ) - MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) WNTUA = LSAME( JOBU, 'A' ) WNTUS = LSAME( JOBU, 'S' ) WNTUAS = WNTUA .OR. WNTUS --- 168,173 ---- *************** *** 180,186 **** WNTVAS = WNTVA .OR. WNTVS WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) - MINWRK = 1 LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN --- 178,183 ---- *************** *** 208,219 **** * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * ! IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. ! $ N.GT.0 ) THEN ! IF( M.GE.N ) THEN * * Compute space needed for DBDSQR * BDSPAC = 5*N IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN --- 205,218 ---- * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * ! IF( INFO.EQ.0 ) THEN ! MINWRK = 1 ! MAXWRK = 1 ! IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Compute space needed for DBDSQR * + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) BDSPAC = 5*N IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN *************** *** 229,235 **** $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') --- 228,233 ---- *************** *** 244,250 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or --- 242,247 ---- *************** *** 262,268 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N ) MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') --- 259,264 ---- *************** *** 277,283 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') --- 273,278 ---- *************** *** 294,300 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or --- 289,294 ---- *************** *** 312,318 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') --- 306,311 ---- *************** *** 327,333 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') --- 320,325 ---- *************** *** 344,350 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or --- 336,341 ---- *************** *** 362,368 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF ELSE * --- 353,358 ---- *************** *** 381,392 **** $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*N+M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF ! ELSE * * Compute space needed for DBDSQR * BDSPAC = 5*M IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN --- 371,382 ---- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*N+M, BDSPAC ) END IF ! ELSE IF( MINMN.GT.0 ) THEN * * Compute space needed for DBDSQR * + MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) BDSPAC = 5*M IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN *************** *** 402,408 **** $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*M, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') --- 392,397 ---- *************** *** 417,423 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', --- 406,411 ---- *************** *** 435,441 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M ) MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') --- 423,428 ---- *************** *** 450,456 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') --- 437,442 ---- *************** *** 467,473 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', --- 453,458 ---- *************** *** 485,491 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') --- 470,475 ---- *************** *** 500,506 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') --- 484,489 ---- *************** *** 517,523 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', --- 500,505 ---- *************** *** 535,541 **** WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF ELSE * --- 517,522 ---- *************** *** 554,568 **** $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*M+N, BDSPAC ) - MAXWRK = MAX( MAXWRK, MINWRK ) END IF END IF WORK( 1 ) = MAXWRK - END IF * ! IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN ! INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVD', -INFO ) RETURN --- 535,550 ---- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*M+N, BDSPAC ) END IF END IF + MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK * ! IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN ! INFO = -13 ! END IF END IF + * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVD', -INFO ) RETURN *************** *** 573,580 **** * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * --- 555,560 ---- *************** *** 822,829 **** * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), ! $ LDVT ) * * Generate Q in A * (Workspace: need N*N+2*N, prefer N*N+N+N*NB) --- 802,810 ---- * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, ! $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (Workspace: need N*N+2*N, prefer N*N+N+N*NB) *************** *** 896,903 **** * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), ! $ LDVT ) * * Generate Q in A * (Workspace: need 2*N, prefer N+N*NB) --- 877,885 ---- * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, ! $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (Workspace: need 2*N, prefer N+N*NB) *************** *** 1358,1365 **** * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), ! $ LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N --- 1340,1348 ---- * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, ! $ VT( 2, 1 ), LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N *************** *** 1834,1841 **** * Copy R from A to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), ! $ LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N --- 1817,1825 ---- * Copy R from A to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, ! $ VT( 2, 1 ), LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N diff -cNr octave-2.9.15/libcruft/lapack/dgetf2.f octave-2.9.16/libcruft/lapack/dgetf2.f *** octave-2.9.15/libcruft/lapack/dgetf2.f Wed Nov 3 14:54:19 1999 --- octave-2.9.16/libcruft/lapack/dgetf2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N *************** *** 63,73 **** PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. ! INTEGER J, JP * .. * .. External Functions .. INTEGER IDAMAX ! EXTERNAL IDAMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA --- 62,74 ---- PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. ! DOUBLE PRECISION SFMIN ! INTEGER I, J, JP * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH INTEGER IDAMAX ! EXTERNAL DLAMCH, IDAMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA *************** *** 97,102 **** --- 98,107 ---- IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * + * Compute machine safe minimum + * + SFMIN = DLAMCH('S') + * DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. *************** *** 112,119 **** * * Compute elements J+1:M of J-th column. * ! IF( J.LT.M ) ! $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) * ELSE IF( INFO.EQ.0 ) THEN * --- 117,131 ---- * * Compute elements J+1:M of J-th column. * ! IF( J.LT.M ) THEN ! IF( ABS(A( J, J )) .GE. SFMIN ) THEN ! CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) ! ELSE ! DO 20 I = 1, M-J ! A( J+I, J ) = A( J+I, J ) / A( J, J ) ! 20 CONTINUE ! END IF ! END IF * ELSE IF( INFO.EQ.0 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/dgetrf.f octave-2.9.16/libcruft/lapack/dgetrf.f *** octave-2.9.15/libcruft/lapack/dgetrf.f Wed Nov 3 14:54:20 1999 --- octave-2.9.16/libcruft/lapack/dgetrf.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/dgetri.f octave-2.9.16/libcruft/lapack/dgetri.f *** octave-2.9.15/libcruft/lapack/dgetri.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dgetri.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N --- 1,8 ---- SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N *************** *** 40,46 **** * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO=0, then WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 39,45 ---- * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO=0, then WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dgetrs.f octave-2.9.16/libcruft/lapack/dgetrs.f *** octave-2.9.15/libcruft/lapack/dgetrs.f Wed Nov 3 14:54:20 1999 --- octave-2.9.16/libcruft/lapack/dgetrs.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANS --- 1,8 ---- SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS diff -cNr octave-2.9.15/libcruft/lapack/dggbak.f octave-2.9.16/libcruft/lapack/dggbak.f *** octave-2.9.15/libcruft/lapack/dggbak.f Wed Nov 3 14:54:20 1999 --- octave-2.9.16/libcruft/lapack/dggbak.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB, SIDE --- 1,9 ---- SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE *************** *** 108,117 **** INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ! ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN ! INFO = -6 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF --- 107,121 ---- INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ! ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN ! INFO = -4 ! ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) ) ! $ THEN ! INFO = -5 ! ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN ! INFO = -8 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF diff -cNr octave-2.9.15/libcruft/lapack/dggbal.f octave-2.9.16/libcruft/lapack/dggbal.f *** octave-2.9.15/libcruft/lapack/dggbal.f Wed Nov 3 14:54:20 1999 --- octave-2.9.16/libcruft/lapack/dggbal.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB --- 1,9 ---- SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOB *************** *** 88,94 **** * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * ! * WORK (workspace) DOUBLE PRECISION array, dimension (6*N) * * INFO (output) INTEGER * = 0: successful exit --- 87,95 ---- * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * ! * WORK (workspace) REAL array, dimension (lwork) ! * lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and ! * at least 1 when JOB = 'N' or 'P'. * * INFO (output) INTEGER * = 0: successful exit *************** *** 141,179 **** ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN ! INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAL', -INFO ) RETURN END IF * - K = 1 - L = N - * * Quick return if possible * ! IF( N.EQ.0 ) ! $ RETURN ! * ! IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N - DO 10 I = 1, N - LSCALE( I ) = ONE - RSCALE( I ) = ONE - 10 CONTINUE RETURN END IF * ! IF( K.EQ.L ) THEN ILO = 1 ! IHI = 1 LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * --- 142,182 ---- ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN ! INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGBAL', -INFO ) RETURN END IF * * Quick return if possible * ! IF( N.EQ.0 ) THEN ILO = 1 IHI = N RETURN END IF * ! IF( N.EQ.1 ) THEN ILO = 1 ! IHI = N LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * + IF( LSAME( JOB, 'N' ) ) THEN + ILO = 1 + IHI = N + DO 10 I = 1, N + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 10 CONTINUE + RETURN + END IF + * + K = 1 + L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * *************** *** 188,195 **** IF( L.NE.1 ) $ GO TO 30 * ! RSCALE( 1 ) = 1 ! LSCALE( 1 ) = 1 GO TO 190 * 30 CONTINUE --- 191,198 ---- IF( L.NE.1 ) $ GO TO 30 * ! RSCALE( 1 ) = ONE ! LSCALE( 1 ) = ONE GO TO 190 * 30 CONTINUE *************** *** 269,278 **** ILO = K IHI = L * ! IF( ILO.EQ.IHI ) ! $ RETURN * ! IF( LSAME( JOB, 'P' ) ) $ RETURN * * Balance the submatrix in rows ILO to IHI. --- 272,286 ---- ILO = K IHI = L * ! IF( LSAME( JOB, 'P' ) ) THEN ! DO 195 I = ILO, IHI ! LSCALE( I ) = ONE ! RSCALE( I ) = ONE ! 195 CONTINUE ! RETURN ! END IF * ! IF( ILO.EQ.IHI ) $ RETURN * * Balance the submatrix in rows ILO to IHI. *************** *** 424,430 **** DO 360 I = ILO, IHI IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) ! IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDA ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) --- 432,438 ---- DO 360 I = ILO, IHI IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) ! IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) diff -cNr octave-2.9.15/libcruft/lapack/dgghrd.f octave-2.9.16/libcruft/lapack/dgghrd.f *** octave-2.9.15/libcruft/lapack/dgghrd.f Wed Nov 3 14:54:20 1999 --- octave-2.9.16/libcruft/lapack/dgghrd.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ --- 1,9 ---- SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ *************** *** 20,35 **** * * DGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a ! * general matrix and B is upper triangular: Q' * A * Z = H and ! * Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, ! * and Q and Z are orthogonal, and ' means transpose. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * ! * Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' ! * Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' * * Arguments * ========= --- 19,50 ---- * * DGGHRD reduces a pair of real matrices (A,B) to generalized upper * Hessenberg form using orthogonal transformations, where A is a ! * general matrix and B is upper triangular. The form of the ! * generalized eigenvalue problem is ! * A*x = lambda*B*x, ! * and B is typically made upper triangular by computing its QR ! * factorization and moving the orthogonal matrix Q to the left side ! * of the equation. ! * ! * This subroutine simultaneously reduces A to a Hessenberg matrix H: ! * Q**T*A*Z = H ! * and transforms B to another upper triangular matrix T: ! * Q**T*B*Z = T ! * in order to reduce the problem to its standard form ! * H*y = lambda*T*y ! * where y = Z**T*x. * * The orthogonal matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * ! * Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T ! * ! * Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T ! * ! * If Q1 is the orthogonal matrix from the QR factorization of B in the ! * original equation A*x = lambda*B*x, then DGGHRD reduces the original ! * problem to generalized Hessenberg form. * * Arguments * ========= *************** *** 53,62 **** * * ILO (input) INTEGER * IHI (input) INTEGER ! * It is assumed that A is already upper triangular in rows and ! * columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set ! * by a previous call to DGGBAL; otherwise they should be set ! * to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) --- 68,78 ---- * * ILO (input) INTEGER * IHI (input) INTEGER ! * ILO and IHI mark the rows and columns of A which are to be ! * reduced. It is assumed that A is already upper triangular ! * in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are ! * normally set by a previous call to SGGBAL; otherwise they ! * should be set to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) *************** *** 70,102 **** * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. ! * On exit, the upper triangular matrix T = Q' B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) ! * If COMPQ='N': Q is not referenced. ! * If COMPQ='I': on entry, Q need not be set, and on exit it ! * contains the orthogonal matrix Q, where Q' ! * is the product of the Givens transformations ! * which are applied to A and B on the left. ! * If COMPQ='V': on entry, Q must contain an orthogonal matrix ! * Q1, and on exit this is overwritten by Q1*Q. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) ! * If COMPZ='N': Z is not referenced. ! * If COMPZ='I': on entry, Z need not be set, and on exit it ! * contains the orthogonal matrix Z, which is ! * the product of the Givens transformations ! * which are applied to A and B on the right. ! * If COMPZ='V': on entry, Z must contain an orthogonal matrix ! * Z1, and on exit this is overwritten by Z1*Z. * * LDZ (input) INTEGER * The leading dimension of the array Z. --- 86,113 ---- * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. ! * On exit, the upper triangular matrix T = Q**T B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) ! * On entry, if COMPQ = 'V', the orthogonal matrix Q1, ! * typically from the QR factorization of B. ! * On exit, if COMPQ='I', the orthogonal matrix Q, and if ! * COMPQ = 'V', the product Q1*Q. ! * Not referenced if COMPQ='N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) ! * On entry, if COMPZ = 'V', the orthogonal matrix Z1. ! * On exit, if COMPZ='I', the orthogonal matrix Z, and if ! * COMPZ = 'V', the product Z1*Z. ! * Not referenced if COMPZ='N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. diff -cNr octave-2.9.15/libcruft/lapack/dgtsv.f octave-2.9.16/libcruft/lapack/dgtsv.f *** octave-2.9.15/libcruft/lapack/dgtsv.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dgtsv.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS --- 1,8 ---- SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/dgttrf.f octave-2.9.16/libcruft/lapack/dgttrf.f *** octave-2.9.15/libcruft/lapack/dgttrf.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dgttrf.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * ! * -- LAPACK routine (version 2.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, N --- 1,8 ---- SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N *************** *** 29,56 **** * ========= * * N (input) INTEGER ! * The order of the matrix A. N >= 0. * * DL (input/output) DOUBLE PRECISION array, dimension (N-1) ! * On entry, DL must contain the (n-1) subdiagonal elements of * A. * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D must contain the diagonal elements of A. * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) DOUBLE PRECISION array, dimension (N-1) ! * On entry, DU must contain the (n-1) superdiagonal elements * of A. * On exit, DU is overwritten by the (n-1) elements of the first ! * superdiagonal of U. * * DU2 (output) DOUBLE PRECISION array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the ! * second superdiagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was --- 28,58 ---- * ========= * * N (input) INTEGER ! * The order of the matrix A. * * DL (input/output) DOUBLE PRECISION array, dimension (N-1) ! * On entry, DL must contain the (n-1) sub-diagonal elements of * A. + * * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D must contain the diagonal elements of A. + * * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) DOUBLE PRECISION array, dimension (N-1) ! * On entry, DU must contain the (n-1) super-diagonal elements * of A. + * * On exit, DU is overwritten by the (n-1) elements of the first ! * super-diagonal of U. * * DU2 (output) DOUBLE PRECISION array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the ! * second super-diagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was *************** *** 60,73 **** * * INFO (output) INTEGER * = 0: successful exit ! * < 0: if INFO = -i, the i-th argument had an illegal value ! * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Local Scalars .. INTEGER I DOUBLE PRECISION FACT, TEMP --- 62,79 ---- * * INFO (output) INTEGER * = 0: successful exit ! * < 0: if INFO = -k, the k-th argument had an illegal value ! * > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * + * .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION FACT, TEMP *************** *** 78,87 **** * .. External Subroutines .. EXTERNAL XERBLA * .. - * .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - * .. * .. Executable Statements .. * INFO = 0 --- 84,89 ---- *************** *** 96,125 **** IF( N.EQ.0 ) $ RETURN * ! * Initialize IPIV(i) = i * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE * ! DO 20 I = 1, N - 1 ! IF( DL( I ).EQ.ZERO ) THEN ! * ! * Subdiagonal is zero, no elimination is required. ! * ! IF( D( I ).EQ.ZERO .AND. INFO.EQ.0 ) ! $ INFO = I ! IF( I.LT.N-1 ) ! $ DU2( I ) = ZERO ! ELSE IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * ! FACT = DL( I ) / D( I ) ! DL( I ) = FACT ! D( I+1 ) = D( I+1 ) - FACT*DU( I ) ! IF( I.LT.N-1 ) ! $ DU2( I ) = ZERO ELSE * * Interchange rows I and I+1, eliminate DL(I) --- 98,122 ---- IF( N.EQ.0 ) $ RETURN * ! * Initialize IPIV(i) = i and DU2(I) = 0 * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE + DO 20 I = 1, N - 2 + DU2( I ) = ZERO + 20 CONTINUE * ! DO 30 I = 1, N - 2 ! IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * ! IF( D( I ).NE.ZERO ) THEN ! FACT = DL( I ) / D( I ) ! DL( I ) = FACT ! D( I+1 ) = D( I+1 ) - FACT*DU( I ) ! END IF ELSE * * Interchange rows I and I+1, eliminate DL(I) *************** *** 130,147 **** TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) ! IF( I.LT.N-1 ) THEN ! DU2( I ) = DU( I+1 ) ! DU( I+1 ) = -FACT*DU( I+1 ) END IF ! IPIV( I ) = IPIV( I ) + 1 END IF - 20 CONTINUE - IF( D( N ).EQ.ZERO .AND. INFO.EQ.0 ) THEN - INFO = N - RETURN END IF * RETURN * * End of DGTTRF --- 127,166 ---- TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) ! DU2( I ) = DU( I+1 ) ! DU( I+1 ) = -FACT*DU( I+1 ) ! IPIV( I ) = I + 1 ! END IF ! 30 CONTINUE ! IF( N.GT.1 ) THEN ! I = N - 1 ! IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN ! IF( D( I ).NE.ZERO ) THEN ! FACT = DL( I ) / D( I ) ! DL( I ) = FACT ! D( I+1 ) = D( I+1 ) - FACT*DU( I ) END IF ! ELSE ! FACT = D( I ) / DL( I ) ! D( I ) = DL( I ) ! DL( I ) = FACT ! TEMP = DU( I ) ! DU( I ) = D( I+1 ) ! D( I+1 ) = TEMP - FACT*D( I+1 ) ! IPIV( I ) = I + 1 END IF END IF * + * Check for a zero on the diagonal of U. + * + DO 40 I = 1, N + IF( D( I ).EQ.ZERO ) THEN + INFO = I + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE + * RETURN * * End of DGTTRF diff -cNr octave-2.9.15/libcruft/lapack/dgttrs.f octave-2.9.16/libcruft/lapack/dgttrs.f *** octave-2.9.15/libcruft/lapack/dgttrs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dgttrs.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 2.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER TRANS --- 1,9 ---- SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS *************** *** 26,39 **** * Arguments * ========= * ! * TRANS (input) CHARACTER ! * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER ! * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns --- 25,38 ---- * Arguments * ========= * ! * TRANS (input) CHARACTER*1 ! * Specifies the form of the system of equations. * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER ! * The order of the matrix A. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns *************** *** 48,57 **** * the LU factorization of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) ! * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) DOUBLE PRECISION array, dimension (N-2) ! * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was --- 47,56 ---- * the LU factorization of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) ! * The (n-1) elements of the first super-diagonal of U. * * DU2 (input) DOUBLE PRECISION array, dimension (N-2) ! * The (n-2) elements of the second super-diagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was *************** *** 60,67 **** * required. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) ! * On entry, the right hand side matrix B. ! * On exit, B is overwritten by the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). --- 59,66 ---- * required. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) ! * On entry, the matrix of right hand side vectors B. ! * On exit, B is overwritten by the solution vectors X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). *************** *** 74,98 **** * * .. Local Scalars .. LOGICAL NOTRAN ! INTEGER I, J ! DOUBLE PRECISION TEMP * .. * .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME * .. * .. External Subroutines .. ! EXTERNAL XERBLA * .. * .. Intrinsic Functions .. ! INTRINSIC MAX * .. * .. Executable Statements .. * INFO = 0 ! NOTRAN = LSAME( TRANS, 'N' ) ! IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. ! $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 --- 73,96 ---- * * .. Local Scalars .. LOGICAL NOTRAN ! INTEGER ITRANS, J, JB, NB * .. * .. External Functions .. ! INTEGER ILAENV ! EXTERNAL ILAENV * .. * .. External Subroutines .. ! EXTERNAL DGTTS2, XERBLA * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 ! NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) ! IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. ! $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 *************** *** 111,174 **** IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * ! IF( NOTRAN ) THEN ! * ! * Solve A*X = B using the LU factorization of A, ! * overwriting each right hand side vector with its solution. ! * ! DO 30 J = 1, NRHS * ! * Solve L*x = b. ! * ! DO 10 I = 1, N - 1 ! IF( IPIV( I ).EQ.I ) THEN ! B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) ! ELSE ! TEMP = B( I, J ) ! B( I, J ) = B( I+1, J ) ! B( I+1, J ) = TEMP - DL( I )*B( I, J ) ! END IF ! 10 CONTINUE ! * ! * Solve U*x = b. ! * ! B( N, J ) = B( N, J ) / D( N ) ! IF( N.GT.1 ) ! $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / ! $ D( N-1 ) ! DO 20 I = N - 2, 1, -1 ! B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* ! $ B( I+2, J ) ) / D( I ) ! 20 CONTINUE ! 30 CONTINUE ELSE * ! * Solve A' * X = B. ! * ! DO 60 J = 1, NRHS * ! * Solve U'*x = b. * ! B( 1, J ) = B( 1, J ) / D( 1 ) ! IF( N.GT.1 ) ! $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) ! DO 40 I = 3, N ! B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* ! $ B( I-2, J ) ) / D( I ) ! 40 CONTINUE ! * ! * Solve L'*x = b. ! * ! DO 50 I = N - 1, 1, -1 ! IF( IPIV( I ).EQ.I ) THEN ! B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) ! ELSE ! TEMP = B( I+1, J ) ! B( I+1, J ) = B( I, J ) - DL( I )*TEMP ! B( I, J ) = TEMP ! END IF ! 50 CONTINUE ! 60 CONTINUE END IF * * End of DGTTRS --- 109,138 ---- IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * ! * Decode TRANS * ! IF( NOTRAN ) THEN ! ITRANS = 0 ELSE + ITRANS = 1 + END IF * ! * Determine the number of right-hand sides to solve at a time. * ! IF( NRHS.EQ.1 ) THEN ! NB = 1 ! ELSE ! NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) ) ! END IF * ! IF( NB.GE.NRHS ) THEN ! CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) ! ELSE ! DO 10 J = 1, NRHS, NB ! JB = MIN( NRHS-J+1, NB ) ! CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), ! $ LDB ) ! 10 CONTINUE END IF * * End of DGTTRS diff -cNr octave-2.9.15/libcruft/lapack/dgtts2.f octave-2.9.16/libcruft/lapack/dgtts2.f *** octave-2.9.15/libcruft/lapack/dgtts2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dgtts2.f Tue Oct 23 19:17:36 2007 *************** *** 0 **** --- 1,196 ---- + SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER ITRANS, LDB, N, NRHS + * .. + * .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) + * .. + * + * Purpose + * ======= + * + * DGTTS2 solves one of the systems of equations + * A*X = B or A'*X = B, + * with a tridiagonal matrix A using the LU factorization computed + * by DGTTRF. + * + * Arguments + * ========= + * + * ITRANS (input) INTEGER + * Specifies the form of the system of equations. + * = 0: A * X = B (No transpose) + * = 1: A'* X = B (Transpose) + * = 2: A'* X = B (Conjugate transpose = Transpose) + * + * N (input) INTEGER + * The order of the matrix A. + * + * NRHS (input) INTEGER + * The number of right hand sides, i.e., the number of columns + * of the matrix B. NRHS >= 0. + * + * DL (input) DOUBLE PRECISION array, dimension (N-1) + * The (n-1) multipliers that define the matrix L from the + * LU factorization of A. + * + * D (input) DOUBLE PRECISION array, dimension (N) + * The n diagonal elements of the upper triangular matrix U from + * the LU factorization of A. + * + * DU (input) DOUBLE PRECISION array, dimension (N-1) + * The (n-1) elements of the first super-diagonal of U. + * + * DU2 (input) DOUBLE PRECISION array, dimension (N-2) + * The (n-2) elements of the second super-diagonal of U. + * + * IPIV (input) INTEGER array, dimension (N) + * The pivot indices; for 1 <= i <= n, row i of the matrix was + * interchanged with row IPIV(i). IPIV(i) will always be either + * i or i+1; IPIV(i) = i indicates a row interchange was not + * required. + * + * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) + * On entry, the matrix of right hand side vectors B. + * On exit, B is overwritten by the solution vectors X. + * + * LDB (input) INTEGER + * The leading dimension of the array B. LDB >= max(1,N). + * + * ===================================================================== + * + * .. Local Scalars .. + INTEGER I, IP, J + DOUBLE PRECISION TEMP + * .. + * .. Executable Statements .. + * + * Quick return if possible + * + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN + * + IF( ITRANS.EQ.0 ) THEN + * + * Solve A*X = B using the LU factorization of A, + * overwriting each right hand side vector with its solution. + * + IF( NRHS.LE.1 ) THEN + J = 1 + 10 CONTINUE + * + * Solve L*x = b. + * + DO 20 I = 1, N - 1 + IP = IPIV( I ) + TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J ) + B( I, J ) = B( IP, J ) + B( I+1, J ) = TEMP + 20 CONTINUE + * + * Solve U*x = b. + * + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 30 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* + $ B( I+2, J ) ) / D( I ) + 30 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 10 + END IF + ELSE + DO 60 J = 1, NRHS + * + * Solve L*x = b. + * + DO 40 I = 1, N - 1 + IF( IPIV( I ).EQ.I ) THEN + B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) + ELSE + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - DL( I )*B( I, J ) + END IF + 40 CONTINUE + * + * Solve U*x = b. + * + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 50 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* + $ B( I+2, J ) ) / D( I ) + 50 CONTINUE + 60 CONTINUE + END IF + ELSE + * + * Solve A' * X = B. + * + IF( NRHS.LE.1 ) THEN + * + * Solve U'*x = b. + * + J = 1 + 70 CONTINUE + B( 1, J ) = B( 1, J ) / D( 1 ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) + DO 80 I = 3, N + B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* + $ B( I-2, J ) ) / D( I ) + 80 CONTINUE + * + * Solve L'*x = b. + * + DO 90 I = N - 1, 1, -1 + IP = IPIV( I ) + TEMP = B( I, J ) - DL( I )*B( I+1, J ) + B( I, J ) = B( IP, J ) + B( IP, J ) = TEMP + 90 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 70 + END IF + * + ELSE + DO 120 J = 1, NRHS + * + * Solve U'*x = b. + * + B( 1, J ) = B( 1, J ) / D( 1 ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) + DO 100 I = 3, N + B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- + $ DU2( I-2 )*B( I-2, J ) ) / D( I ) + 100 CONTINUE + DO 110 I = N - 1, 1, -1 + IF( IPIV( I ).EQ.I ) THEN + B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) + ELSE + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - DL( I )*TEMP + B( I, J ) = TEMP + END IF + 110 CONTINUE + 120 CONTINUE + END IF + END IF + * + * End of DGTTS2 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dhgeqz.f octave-2.9.16/libcruft/lapack/dhgeqz.f *** octave-2.9.15/libcruft/lapack/dhgeqz.f Wed Nov 3 14:54:21 1999 --- octave-2.9.16/libcruft/lapack/dhgeqz.f Tue Oct 16 14:54:20 2007 *************** *** 1,56 **** ! SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB ! INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N * .. * .. Array Arguments .. ! DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), ! $ B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ), ! $ Z( LDZ, * ) * .. * * Purpose * ======= * ! * DHGEQZ implements a single-/double-shift version of the QZ method for ! * finding the generalized eigenvalues ! * ! * w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation ! * ! * det( A - w(i) B ) = 0 ! * ! * In addition, the pair A,B may be reduced to generalized Schur form: ! * B is upper triangular, and A is block upper triangular, where the ! * diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having ! * complex generalized eigenvalues (see the description of the argument ! * JOB.) ! * ! * If JOB='S', then the pair (A,B) is simultaneously reduced to Schur ! * form by applying one orthogonal tranformation (usually called Q) on ! * the left and another (usually called Z) on the right. The 2-by-2 ! * upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks ! * of A will be reduced to positive diagonal matrices. (I.e., ! * if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and ! * B(j+1,j+1) will be positive.) ! * ! * If JOB='E', then at each iteration, the same transformations ! * are computed, but they are only applied to those parts of A and B ! * which are needed to compute ALPHAR, ALPHAI, and BETAR. ! * ! * If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal ! * transformations used to reduce (A,B) are accumulated into the arrays ! * Q and Z s.t.: ! * ! * Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* ! * Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), --- 1,74 ---- ! SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB ! INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N * .. * .. Array Arguments .. ! DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), ! $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), ! $ WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * ! * DHGEQZ computes the eigenvalues of a real matrix pair (H,T), ! * where H is an upper Hessenberg matrix and T is upper triangular, ! * using the double-shift QZ method. ! * Matrix pairs of this type are produced by the reduction to ! * generalized upper Hessenberg form of a real matrix pair (A,B): ! * ! * A = Q1*H*Z1**T, B = Q1*T*Z1**T, ! * ! * as computed by DGGHRD. ! * ! * If JOB='S', then the Hessenberg-triangular pair (H,T) is ! * also reduced to generalized Schur form, ! * ! * H = Q*S*Z**T, T = Q*P*Z**T, ! * ! * where Q and Z are orthogonal matrices, P is an upper triangular ! * matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 ! * diagonal blocks. ! * ! * The 1-by-1 blocks correspond to real eigenvalues of the matrix pair ! * (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of ! * eigenvalues. ! * ! * Additionally, the 2-by-2 upper triangular diagonal blocks of P ! * corresponding to 2-by-2 blocks of S are reduced to positive diagonal ! * form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, ! * P(j,j) > 0, and P(j+1,j+1) > 0. ! * ! * Optionally, the orthogonal matrix Q from the generalized Schur ! * factorization may be postmultiplied into an input matrix Q1, and the ! * orthogonal matrix Z may be postmultiplied into an input matrix Z1. ! * If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced ! * the matrix pair (A,B) to generalized upper Hessenberg form, then the ! * output matrices Q1*Q and Z1*Z are the orthogonal factors from the ! * generalized Schur factorization of (A,B): ! * ! * A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. ! * ! * To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, ! * of (A,B)) are computed as a pair of values (alpha,beta), where alpha is ! * complex and beta real. ! * If beta is nonzero, lambda = alpha / beta is an eigenvalue of the ! * generalized nonsymmetric eigenvalue problem (GNEP) ! * A*x = lambda*B*x ! * and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the ! * alternate form of the GNEP ! * mu*A*y = B*y. ! * Real eigenvalues can be read directly from the generalized Schur ! * form: ! * alpha = S(i,i), beta = P(i,i). * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), *************** *** 60,179 **** * ========= * * JOB (input) CHARACTER*1 ! * = 'E': compute only ALPHAR, ALPHAI, and BETA. A and B will ! * not necessarily be put into generalized Schur form. ! * = 'S': put A and B into generalized Schur form, as well ! * as computing ALPHAR, ALPHAI, and BETA. * * COMPQ (input) CHARACTER*1 ! * = 'N': do not modify Q. ! * = 'V': multiply the array Q on the right by the transpose of ! * the orthogonal tranformation that is applied to the ! * left side of A and B to reduce them to Schur form. ! * = 'I': like COMPQ='V', except that Q will be initialized to ! * the identity first. * * COMPZ (input) CHARACTER*1 ! * = 'N': do not modify Z. ! * = 'V': multiply the array Z on the right by the orthogonal ! * tranformation that is applied to the right side of ! * A and B to reduce them to Schur form. ! * = 'I': like COMPZ='V', except that Z will be initialized to ! * the identity first. * * N (input) INTEGER ! * The order of the matrices A, B, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER ! * It is assumed that A is already upper triangular in rows and ! * columns 1:ILO-1 and IHI+1:N. ! * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! * ! * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) ! * On entry, the N-by-N upper Hessenberg matrix A. Elements ! * below the subdiagonal must be zero. ! * If JOB='S', then on exit A and B will have been ! * simultaneously reduced to generalized Schur form. ! * If JOB='E', then on exit A will have been destroyed. ! * The diagonal blocks will be correct, but the off-diagonal ! * portion will be meaningless. ! * ! * LDA (input) INTEGER ! * The leading dimension of the array A. LDA >= max( 1, N ). ! * ! * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) ! * On entry, the N-by-N upper triangular matrix B. Elements ! * below the diagonal must be zero. 2-by-2 blocks in B ! * corresponding to 2-by-2 blocks in A will be reduced to ! * positive diagonal form. (I.e., if A(j+1,j) is non-zero, ! * then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be ! * positive.) ! * If JOB='S', then on exit A and B will have been ! * simultaneously reduced to Schur form. ! * If JOB='E', then on exit B will have been destroyed. ! * Elements corresponding to diagonal blocks of A will be ! * correct, but the off-diagonal portion will be meaningless. * ! * LDB (input) INTEGER ! * The leading dimension of the array B. LDB >= max( 1, N ). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) ! * ALPHAR(1:N) will be set to real parts of the diagonal ! * elements of A that would result from reducing A and B to ! * Schur form and then further reducing them both to triangular ! * form using unitary transformations s.t. the diagonal of B ! * was non-negative real. Thus, if A(j,j) is in a 1-by-1 block ! * (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j). ! * Note that the (real or complex) values ! * (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the ! * generalized eigenvalues of the matrix pencil A - wB. * * ALPHAI (output) DOUBLE PRECISION array, dimension (N) ! * ALPHAI(1:N) will be set to imaginary parts of the diagonal ! * elements of A that would result from reducing A and B to ! * Schur form and then further reducing them both to triangular ! * form using unitary transformations s.t. the diagonal of B ! * was non-negative real. Thus, if A(j,j) is in a 1-by-1 block ! * (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0. ! * Note that the (real or complex) values ! * (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the ! * generalized eigenvalues of the matrix pencil A - wB. * * BETA (output) DOUBLE PRECISION array, dimension (N) ! * BETA(1:N) will be set to the (real) diagonal elements of B ! * that would result from reducing A and B to Schur form and ! * then further reducing them both to triangular form using ! * unitary transformations s.t. the diagonal of B was ! * non-negative real. Thus, if A(j,j) is in a 1-by-1 block ! * (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j). ! * Note that the (real or complex) values ! * (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the ! * generalized eigenvalues of the matrix pencil A - wB. ! * (Note that BETA(1:N) will always be non-negative, and no ! * BETAI is necessary.) * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) ! * If COMPQ='N', then Q will not be referenced. ! * If COMPQ='V' or 'I', then the transpose of the orthogonal ! * transformations which are applied to A and B on the left ! * will be applied to the array Q on the right. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) ! * If COMPZ='N', then Z will not be referenced. ! * If COMPZ='V' or 'I', then the orthogonal transformations ! * which are applied to A and B on the right will be applied ! * to the array Z on the right. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. * If COMPZ='V' or 'I', then LDZ >= N. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 78,181 ---- * ========= * * JOB (input) CHARACTER*1 ! * = 'E': Compute eigenvalues only; ! * = 'S': Compute eigenvalues and the Schur form. * * COMPQ (input) CHARACTER*1 ! * = 'N': Left Schur vectors (Q) are not computed; ! * = 'I': Q is initialized to the unit matrix and the matrix Q ! * of left Schur vectors of (H,T) is returned; ! * = 'V': Q must contain an orthogonal matrix Q1 on entry and ! * the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 ! * = 'N': Right Schur vectors (Z) are not computed; ! * = 'I': Z is initialized to the unit matrix and the matrix Z ! * of right Schur vectors of (H,T) is returned; ! * = 'V': Z must contain an orthogonal matrix Z1 on entry and ! * the product Z1*Z is returned. * * N (input) INTEGER ! * The order of the matrices H, T, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER ! * ILO and IHI mark the rows and columns of H which are in ! * Hessenberg form. It is assumed that A is already upper ! * triangular in rows and columns 1:ILO-1 and IHI+1:N. ! * If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. ! * ! * H (input/output) DOUBLE PRECISION array, dimension (LDH, N) ! * On entry, the N-by-N upper Hessenberg matrix H. ! * On exit, if JOB = 'S', H contains the upper quasi-triangular ! * matrix S from the generalized Schur factorization; ! * 2-by-2 diagonal blocks (corresponding to complex conjugate ! * pairs of eigenvalues) are returned in standard form, with ! * H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. ! * If JOB = 'E', the diagonal blocks of H match those of S, but ! * the rest of H is unspecified. ! * ! * LDH (input) INTEGER ! * The leading dimension of the array H. LDH >= max( 1, N ). ! * ! * T (input/output) DOUBLE PRECISION array, dimension (LDT, N) ! * On entry, the N-by-N upper triangular matrix T. ! * On exit, if JOB = 'S', T contains the upper triangular ! * matrix P from the generalized Schur factorization; ! * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S ! * are reduced to positive diagonal form, i.e., if H(j+1,j) is ! * non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and ! * T(j+1,j+1) > 0. ! * If JOB = 'E', the diagonal blocks of T match those of P, but ! * the rest of T is unspecified. * ! * LDT (input) INTEGER ! * The leading dimension of the array T. LDT >= max( 1, N ). * * ALPHAR (output) DOUBLE PRECISION array, dimension (N) ! * The real parts of each scalar alpha defining an eigenvalue ! * of GNEP. * * ALPHAI (output) DOUBLE PRECISION array, dimension (N) ! * The imaginary parts of each scalar alpha defining an ! * eigenvalue of GNEP. ! * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if ! * positive, then the j-th and (j+1)-st eigenvalues are a ! * complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). * * BETA (output) DOUBLE PRECISION array, dimension (N) ! * The scalars beta that define the eigenvalues of GNEP. ! * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and ! * beta = BETA(j) represent the j-th eigenvalue of the matrix ! * pair (A,B), in one of the forms lambda = alpha/beta or ! * mu = beta/alpha. Since either lambda or mu may overflow, ! * they should not, in general, be computed. * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) ! * On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in ! * the reduction of (A,B) to generalized Hessenberg form. ! * On exit, if COMPZ = 'I', the orthogonal matrix of left Schur ! * vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix ! * of left Schur vectors of (A,B). ! * Not referenced if COMPZ = 'N'. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) ! * On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in ! * the reduction of (A,B) to generalized Hessenberg form. ! * On exit, if COMPZ = 'I', the orthogonal matrix of ! * right Schur vectors of (H,T), and if COMPZ = 'V', the ! * orthogonal matrix of right Schur vectors of (A,B). ! * Not referenced if COMPZ = 'N'. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. * If COMPZ='V' or 'I', then LDZ >= N. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 187,199 **** * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value ! * = 1,...,N: the QZ iteration did not converge. (A,B) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. ! * = N+1,...,2*N: the shift calculation failed. (A,B) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. - * > 2*N: various "impossible" errors. * * Further Details * =============== --- 189,200 ---- * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value ! * = 1,...,N: the QZ iteration did not converge. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO+1,...,N should be correct. ! * = N+1,...,2*N: the shift calculation failed. (H,T) is not * in Schur form, but ALPHAR(i), ALPHAI(i), and * BETA(i), i=INFO-N+1,...,N should be correct. * * Further Details * =============== *************** *** 225,231 **** $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, ! $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 --- 226,232 ---- $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, ! $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ WR2 *************** *** 302,310 **** INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ! ELSE IF( LDA.LT.N ) THEN INFO = -8 ! ELSE IF( LDB.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 --- 303,311 ---- INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ! ELSE IF( LDH.LT.N ) THEN INFO = -8 ! ELSE IF( LDT.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -15 *************** *** 340,347 **** SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) ! ANORM = DLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK ) ! BNORM = DLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) --- 341,348 ---- SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) ! ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) ! BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) *************** *** 350,364 **** * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N ! IF( B( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J ! A( JR, J ) = -A( JR, J ) ! B( JR, J ) = -B( JR, J ) 10 CONTINUE ELSE ! A( J, J ) = -A( J, J ) ! B( J, J ) = -B( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N --- 351,365 ---- * Set Eigenvalues IHI+1:N * DO 30 J = IHI + 1, N ! IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 10 JR = 1, J ! H( JR, J ) = -H( JR, J ) ! T( JR, J ) = -T( JR, J ) 10 CONTINUE ELSE ! H( J, J ) = -H( J, J ) ! T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 20 JR = 1, N *************** *** 366,374 **** 20 CONTINUE END IF END IF ! ALPHAR( J ) = A( J, J ) ALPHAI( J ) = ZERO ! BETA( J ) = B( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps --- 367,375 ---- 20 CONTINUE END IF END IF ! ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO ! BETA( J ) = T( J, J ) 30 CONTINUE * * If IHI < ILO, skip QZ steps *************** *** 408,415 **** * Split the matrix if possible. * * Two tests: ! * 1: A(j,j-1)=0 or j=ILO ! * 2: B(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * --- 409,416 ---- * Split the matrix if possible. * * Two tests: ! * 1: H(j,j-1)=0 or j=ILO ! * 2: T(j,j)=0 * IF( ILAST.EQ.ILO ) THEN * *************** *** 417,430 **** * GO TO 80 ELSE ! IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN ! A( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * ! IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN ! B( ILAST, ILAST ) = ZERO GO TO 70 END IF * --- 418,431 ---- * GO TO 80 ELSE ! IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN ! H( ILAST, ILAST-1 ) = ZERO GO TO 80 END IF END IF * ! IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN ! T( ILAST, ILAST ) = ZERO GO TO 70 END IF * *************** *** 432,467 **** * DO 60 J = ILAST - 1, ILO, -1 * ! * Test 1: for A(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE ! IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN ! A( J, J-1 ) = ZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * ! * Test 2: for B(j,j)=0 * ! IF( ABS( B( J, J ) ).LT.BTOL ) THEN ! B( J, J ) = ZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN ! TEMP = ABS( A( J, J-1 ) ) ! TEMP2 = ABS( A( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF ! IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2* $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. END IF * --- 433,468 ---- * DO 60 J = ILAST - 1, ILO, -1 * ! * Test 1: for H(j,j-1)=0 or j=ILO * IF( J.EQ.ILO ) THEN ILAZRO = .TRUE. ELSE ! IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN ! H( J, J-1 ) = ZERO ILAZRO = .TRUE. ELSE ILAZRO = .FALSE. END IF END IF * ! * Test 2: for T(j,j)=0 * ! IF( ABS( T( J, J ) ).LT.BTOL ) THEN ! T( J, J ) = ZERO * * Test 1a: Check for 2 consecutive small subdiagonals in A * ILAZR2 = .FALSE. IF( .NOT.ILAZRO ) THEN ! TEMP = ABS( H( J, J-1 ) ) ! TEMP2 = ABS( H( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF ! IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2* $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. END IF * *************** *** 473,493 **** * IF( ILAZRO .OR. ILAZR2 ) THEN DO 40 JCH = J, ILAST - 1 ! TEMP = A( JCH, JCH ) ! CALL DLARTG( TEMP, A( JCH+1, JCH ), C, S, ! $ A( JCH, JCH ) ) ! A( JCH+1, JCH ) = ZERO ! CALL DROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, ! $ A( JCH+1, JCH+1 ), LDA, C, S ) ! CALL DROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, ! $ B( JCH+1, JCH+1 ), LDB, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) IF( ILAZR2 ) ! $ A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C ILAZR2 = .FALSE. ! IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 80 ELSE --- 474,494 ---- * IF( ILAZRO .OR. ILAZR2 ) THEN DO 40 JCH = J, ILAST - 1 ! TEMP = H( JCH, JCH ) ! CALL DLARTG( TEMP, H( JCH+1, JCH ), C, S, ! $ H( JCH, JCH ) ) ! H( JCH+1, JCH ) = ZERO ! CALL DROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, ! $ H( JCH+1, JCH+1 ), LDH, C, S ) ! CALL DROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, ! $ T( JCH+1, JCH+1 ), LDT, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) IF( ILAZR2 ) ! $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C ILAZR2 = .FALSE. ! IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN IF( JCH+1.GE.ILAST ) THEN GO TO 80 ELSE *************** *** 495,529 **** GO TO 110 END IF END IF ! B( JCH+1, JCH+1 ) = ZERO 40 CONTINUE GO TO 70 ELSE * ! * Only test 2 passed -- chase the zero to B(ILAST,ILAST) ! * Then process as in the case B(ILAST,ILAST)=0 * DO 50 JCH = J, ILAST - 1 ! TEMP = B( JCH, JCH+1 ) ! CALL DLARTG( TEMP, B( JCH+1, JCH+1 ), C, S, ! $ B( JCH, JCH+1 ) ) ! B( JCH+1, JCH+1 ) = ZERO IF( JCH.LT.ILASTM-1 ) ! $ CALL DROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, ! $ B( JCH+1, JCH+2 ), LDB, C, S ) ! CALL DROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, ! $ A( JCH+1, JCH-1 ), LDA, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) ! TEMP = A( JCH+1, JCH ) ! CALL DLARTG( TEMP, A( JCH+1, JCH-1 ), C, S, ! $ A( JCH+1, JCH ) ) ! A( JCH+1, JCH-1 ) = ZERO ! CALL DROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, ! $ A( IFRSTM, JCH-1 ), 1, C, S ) ! CALL DROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, ! $ B( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) --- 496,530 ---- GO TO 110 END IF END IF ! T( JCH+1, JCH+1 ) = ZERO 40 CONTINUE GO TO 70 ELSE * ! * Only test 2 passed -- chase the zero to T(ILAST,ILAST) ! * Then process as in the case T(ILAST,ILAST)=0 * DO 50 JCH = J, ILAST - 1 ! TEMP = T( JCH, JCH+1 ) ! CALL DLARTG( TEMP, T( JCH+1, JCH+1 ), C, S, ! $ T( JCH, JCH+1 ) ) ! T( JCH+1, JCH+1 ) = ZERO IF( JCH.LT.ILASTM-1 ) ! $ CALL DROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, ! $ T( JCH+1, JCH+2 ), LDT, C, S ) ! CALL DROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, ! $ H( JCH+1, JCH-1 ), LDH, C, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, $ C, S ) ! TEMP = H( JCH+1, JCH ) ! CALL DLARTG( TEMP, H( JCH+1, JCH-1 ), C, S, ! $ H( JCH+1, JCH ) ) ! H( JCH+1, JCH-1 ) = ZERO ! CALL DROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, ! $ H( IFRSTM, JCH-1 ), 1, C, S ) ! CALL DROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, ! $ T( IFRSTM, JCH-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, $ C, S ) *************** *** 547,580 **** INFO = N + 1 GO TO 420 * ! * B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a * 1x1 block. * 70 CONTINUE ! TEMP = A( ILAST, ILAST ) ! CALL DLARTG( TEMP, A( ILAST, ILAST-1 ), C, S, ! $ A( ILAST, ILAST ) ) ! A( ILAST, ILAST-1 ) = ZERO ! CALL DROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, ! $ A( IFRSTM, ILAST-1 ), 1, C, S ) ! CALL DROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, ! $ B( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * ! * A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, * and BETA * 80 CONTINUE ! IF( B( ILAST, ILAST ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 90 J = IFRSTM, ILAST ! A( J, ILAST ) = -A( J, ILAST ) ! B( J, ILAST ) = -B( J, ILAST ) 90 CONTINUE ELSE ! A( ILAST, ILAST ) = -A( ILAST, ILAST ) ! B( ILAST, ILAST ) = -B( ILAST, ILAST ) END IF IF( ILZ ) THEN DO 100 J = 1, N --- 548,581 ---- INFO = N + 1 GO TO 420 * ! * T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a * 1x1 block. * 70 CONTINUE ! TEMP = H( ILAST, ILAST ) ! CALL DLARTG( TEMP, H( ILAST, ILAST-1 ), C, S, ! $ H( ILAST, ILAST ) ) ! H( ILAST, ILAST-1 ) = ZERO ! CALL DROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, ! $ H( IFRSTM, ILAST-1 ), 1, C, S ) ! CALL DROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, ! $ T( IFRSTM, ILAST-1 ), 1, C, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) * ! * H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, * and BETA * 80 CONTINUE ! IF( T( ILAST, ILAST ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 90 J = IFRSTM, ILAST ! H( J, ILAST ) = -H( J, ILAST ) ! T( J, ILAST ) = -T( J, ILAST ) 90 CONTINUE ELSE ! H( ILAST, ILAST ) = -H( ILAST, ILAST ) ! T( ILAST, ILAST ) = -T( ILAST, ILAST ) END IF IF( ILZ ) THEN DO 100 J = 1, N *************** *** 582,590 **** 100 CONTINUE END IF END IF ! ALPHAR( ILAST ) = A( ILAST, ILAST ) ALPHAI( ILAST ) = ZERO ! BETA( ILAST ) = B( ILAST, ILAST ) * * Go to next block -- exit if finished. * --- 583,591 ---- 100 CONTINUE END IF END IF ! ALPHAR( ILAST ) = H( ILAST, ILAST ) ALPHAI( ILAST ) = ZERO ! BETA( ILAST ) = T( ILAST, ILAST ) * * Go to next block -- exit if finished. * *************** *** 617,623 **** * Compute single shifts. * * At this point, IFIRST < ILAST, and the diagonal elements of ! * B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.EQ.IITER ) THEN --- 618,624 ---- * Compute single shifts. * * At this point, IFIRST < ILAST, and the diagonal elements of ! * T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in * magnitude) * IF( ( IITER / 10 )*10.EQ.IITER ) THEN *************** *** 625,634 **** * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * ! IF( ( DBLE( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT. ! $ ABS( B( ILAST-1, ILAST-1 ) ) ) THEN ! ESHIFT = ESHIFT + A( ILAST-1, ILAST ) / ! $ B( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) ) END IF --- 626,635 ---- * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * ! IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. ! $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN ! ESHIFT = ESHIFT + H( ILAST-1, ILAST ) / ! $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) ) END IF *************** *** 641,648 **** * bottom-right 2x2 block of A and B. The first eigenvalue * returned by DLAG2 is the Wilkinson shift (AEP p.512), * ! CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, ! $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) --- 642,649 ---- * bottom-right 2x2 block of A and B. The first eigenvalue * returned by DLAG2 is the Wilkinson shift (AEP p.512), * ! CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, ! $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) *************** *** 669,682 **** * DO 120 J = ILAST - 1, IFIRST + 1, -1 ISTART = J ! TEMP = ABS( S1*A( J, J-1 ) ) ! TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF ! IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* $ TEMP2 )GO TO 130 120 CONTINUE * --- 670,683 ---- * DO 120 J = ILAST - 1, IFIRST + 1, -1 ISTART = J ! TEMP = ABS( S1*H( J, J-1 ) ) ! TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) ) TEMPR = MAX( TEMP, TEMP2 ) IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN TEMP = TEMP / TEMPR TEMP2 = TEMP2 / TEMPR END IF ! IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* $ TEMP2 )GO TO 130 120 CONTINUE * *************** *** 687,712 **** * * Initial Q * ! TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART ) ! TEMP2 = S1*A( ISTART+1, ISTART ) CALL DLARTG( TEMP, TEMP2, C, S, TEMPR ) * * Sweep * DO 190 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN ! TEMP = A( J, J-1 ) ! CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) ! A( J+1, J-1 ) = ZERO END IF * DO 140 JC = J, ILASTM ! TEMP = C*A( J, JC ) + S*A( J+1, JC ) ! A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) ! A( J, JC ) = TEMP ! TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) ! B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) ! B( J, JC ) = TEMP2 140 CONTINUE IF( ILQ ) THEN DO 150 JR = 1, N --- 688,713 ---- * * Initial Q * ! TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART ) ! TEMP2 = S1*H( ISTART+1, ISTART ) CALL DLARTG( TEMP, TEMP2, C, S, TEMPR ) * * Sweep * DO 190 J = ISTART, ILAST - 1 IF( J.GT.ISTART ) THEN ! TEMP = H( J, J-1 ) ! CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) ! H( J+1, J-1 ) = ZERO END IF * DO 140 JC = J, ILASTM ! TEMP = C*H( J, JC ) + S*H( J+1, JC ) ! H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) ! H( J, JC ) = TEMP ! TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) ! T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) ! T( J, JC ) = TEMP2 140 CONTINUE IF( ILQ ) THEN DO 150 JR = 1, N *************** *** 716,734 **** 150 CONTINUE END IF * ! TEMP = B( J+1, J+1 ) ! CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) ! B( J+1, J ) = ZERO * DO 160 JR = IFRSTM, MIN( J+2, ILAST ) ! TEMP = C*A( JR, J+1 ) + S*A( JR, J ) ! A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) ! A( JR, J+1 ) = TEMP 160 CONTINUE DO 170 JR = IFRSTM, J ! TEMP = C*B( JR, J+1 ) + S*B( JR, J ) ! B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) ! B( JR, J+1 ) = TEMP 170 CONTINUE IF( ILZ ) THEN DO 180 JR = 1, N --- 717,735 ---- 150 CONTINUE END IF * ! TEMP = T( J+1, J+1 ) ! CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) ! T( J+1, J ) = ZERO * DO 160 JR = IFRSTM, MIN( J+2, ILAST ) ! TEMP = C*H( JR, J+1 ) + S*H( JR, J ) ! H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) ! H( JR, J+1 ) = TEMP 160 CONTINUE DO 170 JR = IFRSTM, J ! TEMP = C*T( JR, J+1 ) + S*T( JR, J ) ! T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) ! T( JR, J+1 ) = TEMP 170 CONTINUE IF( ILZ ) THEN DO 180 JR = 1, N *************** *** 759,766 **** * B = ( ) with B11 non-negative. * ( 0 B22 ) * ! CALL DLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ), ! $ B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) * IF( B11.LT.ZERO ) THEN CR = -CR --- 760,767 ---- * B = ( ) with B11 non-negative. * ( 0 B22 ) * ! CALL DLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ), ! $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) * IF( B11.LT.ZERO ) THEN CR = -CR *************** *** 769,785 **** B22 = -B22 END IF * ! CALL DROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA, ! $ A( ILAST, ILAST-1 ), LDA, CL, SL ) ! CALL DROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1, ! $ A( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILAST.LT.ILASTM ) ! $ CALL DROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB, ! $ B( ILAST, ILAST+1 ), LDA, CL, SL ) IF( IFRSTM.LT.ILAST-1 ) ! $ CALL DROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1, ! $ B( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILQ ) $ CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, --- 770,786 ---- B22 = -B22 END IF * ! CALL DROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH, ! $ H( ILAST, ILAST-1 ), LDH, CL, SL ) ! CALL DROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1, ! $ H( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILAST.LT.ILASTM ) ! $ CALL DROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT, ! $ T( ILAST, ILAST+1 ), LDH, CL, SL ) IF( IFRSTM.LT.ILAST-1 ) ! $ CALL DROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1, ! $ T( IFRSTM, ILAST ), 1, CR, SR ) * IF( ILQ ) $ CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, *************** *** 788,804 **** $ CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, $ SR ) * ! B( ILAST-1, ILAST-1 ) = B11 ! B( ILAST-1, ILAST ) = ZERO ! B( ILAST, ILAST-1 ) = ZERO ! B( ILAST, ILAST ) = B22 * * If B22 is negative, negate column ILAST * IF( B22.LT.ZERO ) THEN DO 210 J = IFRSTM, ILAST ! A( J, ILAST ) = -A( J, ILAST ) ! B( J, ILAST ) = -B( J, ILAST ) 210 CONTINUE * IF( ILZ ) THEN --- 789,805 ---- $ CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, $ SR ) * ! T( ILAST-1, ILAST-1 ) = B11 ! T( ILAST-1, ILAST ) = ZERO ! T( ILAST, ILAST-1 ) = ZERO ! T( ILAST, ILAST ) = B22 * * If B22 is negative, negate column ILAST * IF( B22.LT.ZERO ) THEN DO 210 J = IFRSTM, ILAST ! H( J, ILAST ) = -H( J, ILAST ) ! T( J, ILAST ) = -T( J, ILAST ) 210 CONTINUE * IF( ILZ ) THEN *************** *** 812,819 **** * * Recompute shift * ! CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, ! $ B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, $ TEMP, WR, TEMP2, WI ) * * If standardization has perturbed the shift onto real line, --- 813,820 ---- * * Recompute shift * ! CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH, ! $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ TEMP, WR, TEMP2, WI ) * * If standardization has perturbed the shift onto real line, *************** *** 825,834 **** * * Do EISPACK (QZVAL) computation of alpha and beta * ! A11 = A( ILAST-1, ILAST-1 ) ! A21 = A( ILAST, ILAST-1 ) ! A12 = A( ILAST-1, ILAST ) ! A22 = A( ILAST, ILAST ) * * Compute complex Givens rotation on right * (Assume some element of C = (sA - wB) > unfl ) --- 826,835 ---- * * Do EISPACK (QZVAL) computation of alpha and beta * ! A11 = H( ILAST-1, ILAST-1 ) ! A21 = H( ILAST, ILAST-1 ) ! A12 = H( ILAST-1, ILAST ) ! A22 = H( ILAST, ILAST ) * * Compute complex Givens rotation on right * (Assume some element of C = (sA - wB) > unfl ) *************** *** 845,854 **** * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN ! T = DLAPY3( C12, C11R, C11I ) ! CZ = C12 / T ! SZR = -C11R / T ! SZI = -C11I / T ELSE CZ = DLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN --- 846,855 ---- * IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ $ ABS( C22R )+ABS( C22I ) ) THEN ! T1 = DLAPY3( C12, C11R, C11I ) ! CZ = C12 / T1 ! SZR = -C11R / T1 ! SZI = -C11I / T1 ELSE CZ = DLAPY2( C22R, C22I ) IF( CZ.LE.SAFMIN ) THEN *************** *** 858,867 **** ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ ! T = DLAPY2( CZ, C21 ) ! CZ = CZ / T ! SZR = -C21*TEMPR / T ! SZI = C21*TEMPI / T END IF END IF * --- 859,868 ---- ELSE TEMPR = C22R / CZ TEMPI = C22I / CZ ! T1 = DLAPY2( CZ, C21 ) ! CZ = CZ / T1 ! SZR = -C21*TEMPR / T1 ! SZI = C21*TEMPI / T1 END IF END IF * *************** *** 895,904 **** SQI = TEMPI*A2R - TEMPR*A2I END IF END IF ! T = DLAPY3( CQ, SQR, SQI ) ! CQ = CQ / T ! SQR = SQR / T ! SQI = SQI / T * * Compute diagonal elements of QBZ * --- 896,905 ---- SQI = TEMPI*A2R - TEMPR*A2I END IF END IF ! T1 = DLAPY3( CQ, SQR, SQI ) ! CQ = CQ / T1 ! SQR = SQR / T1 ! SQI = SQI / T1 * * Compute diagonal elements of QBZ * *************** *** 950,975 **** * * We assume that the block is at least 3x3 * ! AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / ! $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) ! AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / ! $ ( BSCALE*B( ILAST-1, ILAST-1 ) ) ! AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / ! $ ( BSCALE*B( ILAST, ILAST ) ) ! AD22 = ( ASCALE*A( ILAST, ILAST ) ) / ! $ ( BSCALE*B( ILAST, ILAST ) ) ! U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST ) ! AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) / ! $ ( BSCALE*B( IFIRST, IFIRST ) ) ! AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) / ! $ ( BSCALE*B( IFIRST, IFIRST ) ) ! AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) / ! $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) ! AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) / ! $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) ! AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) / ! $ ( BSCALE*B( IFIRST+1, IFIRST+1 ) ) ! U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L --- 951,976 ---- * * We assume that the block is at least 3x3 * ! AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / ! $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) ! AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / ! $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) ! AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / ! $ ( BSCALE*T( ILAST, ILAST ) ) ! AD22 = ( ASCALE*H( ILAST, ILAST ) ) / ! $ ( BSCALE*T( ILAST, ILAST ) ) ! U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) ! AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / ! $ ( BSCALE*T( IFIRST, IFIRST ) ) ! AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / ! $ ( BSCALE*T( IFIRST, IFIRST ) ) ! AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / ! $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) ! AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / ! $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) ! AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / ! $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) ! U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) * V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L *************** *** 991,1017 **** * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN ! V( 1 ) = A( J, J-1 ) ! V( 2 ) = A( J+1, J-1 ) ! V( 3 ) = A( J+2, J-1 ) * ! CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE ! A( J+1, J-1 ) = ZERO ! A( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM ! TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )* ! $ A( J+2, JC ) ) ! A( J, JC ) = A( J, JC ) - TEMP ! A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 ) ! A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 ) ! TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )* ! $ B( J+2, JC ) ) ! B( J, JC ) = B( J, JC ) - TEMP2 ! B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 ) ! B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N --- 992,1018 ---- * Zero (j-1)st column of A * IF( J.GT.ISTART ) THEN ! V( 1 ) = H( J, J-1 ) ! V( 2 ) = H( J+1, J-1 ) ! V( 3 ) = H( J+2, J-1 ) * ! CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) V( 1 ) = ONE ! H( J+1, J-1 ) = ZERO ! H( J+2, J-1 ) = ZERO END IF * DO 230 JC = J, ILASTM ! TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* ! $ H( J+2, JC ) ) ! H( J, JC ) = H( J, JC ) - TEMP ! H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) ! H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) ! TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* ! $ T( J+2, JC ) ) ! T( J, JC ) = T( J, JC ) - TEMP2 ! T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) ! T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N *************** *** 1028,1054 **** * Swap rows to pivot * ILPIVT = .FALSE. ! TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) ) ! TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN ! W11 = B( J+1, J+1 ) ! W21 = B( J+2, J+1 ) ! W12 = B( J+1, J+2 ) ! W22 = B( J+2, J+2 ) ! U1 = B( J+1, J ) ! U2 = B( J+2, J ) ELSE ! W21 = B( J+1, J+1 ) ! W11 = B( J+2, J+1 ) ! W22 = B( J+1, J+2 ) ! W12 = B( J+2, J+2 ) ! U2 = B( J+1, J ) ! U1 = B( J+2, J ) END IF * * Swap columns if nec. --- 1029,1055 ---- * Swap rows to pivot * ILPIVT = .FALSE. ! TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) ! TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN SCALE = ZERO U1 = ONE U2 = ZERO GO TO 250 ELSE IF( TEMP.GE.TEMP2 ) THEN ! W11 = T( J+1, J+1 ) ! W21 = T( J+2, J+1 ) ! W12 = T( J+1, J+2 ) ! W22 = T( J+2, J+2 ) ! U1 = T( J+1, J ) ! U2 = T( J+2, J ) ELSE ! W21 = T( J+1, J+1 ) ! W11 = T( J+2, J+1 ) ! W22 = T( J+1, J+2 ) ! W12 = T( J+2, J+2 ) ! U2 = T( J+1, J ) ! U1 = T( J+2, J ) END IF * * Swap columns if nec. *************** *** 1098,1106 **** * * Compute Householder Vector * ! T = SQRT( SCALE**2+U1**2+U2**2 ) ! TAU = ONE + SCALE / T ! VS = -ONE / ( SCALE+T ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 --- 1099,1107 ---- * * Compute Householder Vector * ! T1 = SQRT( SCALE**2+U1**2+U2**2 ) ! TAU = ONE + SCALE / T1 ! VS = -ONE / ( SCALE+T1 ) V( 1 ) = ONE V( 2 ) = VS*U1 V( 3 ) = VS*U2 *************** *** 1108,1125 **** * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) ! TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )* ! $ A( JR, J+2 ) ) ! A( JR, J ) = A( JR, J ) - TEMP ! A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 ) ! A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 ! TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )* ! $ B( JR, J+2 ) ) ! B( JR, J ) = B( JR, J ) - TEMP ! B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 ) ! B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N --- 1109,1126 ---- * Apply transformations from the right. * DO 260 JR = IFRSTM, MIN( J+3, ILAST ) ! TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* ! $ H( JR, J+2 ) ) ! H( JR, J ) = H( JR, J ) - TEMP ! H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) ! H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 260 CONTINUE DO 270 JR = IFRSTM, J + 2 ! TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* ! $ T( JR, J+2 ) ) ! T( JR, J ) = T( JR, J ) - TEMP ! T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) ! T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N *************** *** 1130,1137 **** Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF ! B( J+1, J ) = ZERO ! B( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations --- 1131,1138 ---- Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 280 CONTINUE END IF ! T( J+1, J ) = ZERO ! T( J+2, J ) = ZERO 290 CONTINUE * * Last elements: Use Givens rotations *************** *** 1139,1155 **** * Rotations from the left * J = ILAST - 1 ! TEMP = A( J, J-1 ) ! CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) ) ! A( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM ! TEMP = C*A( J, JC ) + S*A( J+1, JC ) ! A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC ) ! A( J, JC ) = TEMP ! TEMP2 = C*B( J, JC ) + S*B( J+1, JC ) ! B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC ) ! B( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N --- 1140,1156 ---- * Rotations from the left * J = ILAST - 1 ! TEMP = H( J, J-1 ) ! CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) ! H( J+1, J-1 ) = ZERO * DO 300 JC = J, ILASTM ! TEMP = C*H( J, JC ) + S*H( J+1, JC ) ! H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) ! H( J, JC ) = TEMP ! TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) ! T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) ! T( J, JC ) = TEMP2 300 CONTINUE IF( ILQ ) THEN DO 310 JR = 1, N *************** *** 1161,1179 **** * * Rotations from the right. * ! TEMP = B( J+1, J+1 ) ! CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) ) ! B( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST ! TEMP = C*A( JR, J+1 ) + S*A( JR, J ) ! A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J ) ! A( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 ! TEMP = C*B( JR, J+1 ) + S*B( JR, J ) ! B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J ) ! B( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N --- 1162,1180 ---- * * Rotations from the right. * ! TEMP = T( J+1, J+1 ) ! CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) ! T( J+1, J ) = ZERO * DO 320 JR = IFRSTM, ILAST ! TEMP = C*H( JR, J+1 ) + S*H( JR, J ) ! H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) ! H( JR, J+1 ) = TEMP 320 CONTINUE DO 330 JR = IFRSTM, ILAST - 1 ! TEMP = C*T( JR, J+1 ) + S*T( JR, J ) ! T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) ! T( JR, J+1 ) = TEMP 330 CONTINUE IF( ILZ ) THEN DO 340 JR = 1, N *************** *** 1196,1202 **** * * Drop-through = non-convergence * - 370 CONTINUE INFO = ILAST GO TO 420 * --- 1197,1202 ---- *************** *** 1207,1221 **** * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 ! IF( B( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J ! A( JR, J ) = -A( JR, J ) ! B( JR, J ) = -B( JR, J ) 390 CONTINUE ELSE ! A( J, J ) = -A( J, J ) ! B( J, J ) = -B( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N --- 1207,1221 ---- * Set Eigenvalues 1:ILO-1 * DO 410 J = 1, ILO - 1 ! IF( T( J, J ).LT.ZERO ) THEN IF( ILSCHR ) THEN DO 390 JR = 1, J ! H( JR, J ) = -H( JR, J ) ! T( JR, J ) = -T( JR, J ) 390 CONTINUE ELSE ! H( J, J ) = -H( J, J ) ! T( J, J ) = -T( J, J ) END IF IF( ILZ ) THEN DO 400 JR = 1, N *************** *** 1223,1231 **** 400 CONTINUE END IF END IF ! ALPHAR( J ) = A( J, J ) ALPHAI( J ) = ZERO ! BETA( J ) = B( J, J ) 410 CONTINUE * * Normal Termination --- 1223,1231 ---- 400 CONTINUE END IF END IF ! ALPHAR( J ) = H( J, J ) ALPHAI( J ) = ZERO ! BETA( J ) = T( J, J ) 410 CONTINUE * * Normal Termination diff -cNr octave-2.9.15/libcruft/lapack/dhseqr.f octave-2.9.16/libcruft/lapack/dhseqr.f *** octave-2.9.15/libcruft/lapack/dhseqr.f Wed Nov 3 14:54:21 1999 --- octave-2.9.16/libcruft/lapack/dhseqr.f Tue Oct 16 14:54:20 2007 *************** *** 1,160 **** SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. - CHARACTER COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * ! * Purpose ! * ======= ! * ! * DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H ! * and, optionally, the matrices T and Z from the Schur decomposition ! * H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur ! * form), and Z is the orthogonal matrix of Schur vectors. ! * ! * Optionally Z may be postmultiplied into an input orthogonal matrix Q, ! * so that this routine can give the Schur factorization of a matrix A ! * which has been reduced to the Hessenberg form H by the orthogonal ! * matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. ! * ! * Arguments ! * ========= ! * ! * JOB (input) CHARACTER*1 ! * = 'E': compute eigenvalues only; ! * = 'S': compute eigenvalues and the Schur form T. ! * ! * COMPZ (input) CHARACTER*1 ! * = 'N': no Schur vectors are computed; ! * = 'I': Z is initialized to the unit matrix and the matrix Z ! * of Schur vectors of H is returned; ! * = 'V': Z must contain an orthogonal matrix Q on entry, and ! * the product Q*Z is returned. ! * ! * N (input) INTEGER ! * The order of the matrix H. N >= 0. ! * ! * ILO (input) INTEGER ! * IHI (input) INTEGER ! * It is assumed that H is already upper triangular in rows ! * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally ! * set by a previous call to DGEBAL, and then passed to SGEHRD ! * when the matrix output by DGEBAL is reduced to Hessenberg ! * form. Otherwise ILO and IHI should be set to 1 and N ! * respectively. ! * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! * ! * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) ! * On entry, the upper Hessenberg matrix H. ! * On exit, if JOB = 'S', H contains the upper quasi-triangular ! * matrix T from the Schur decomposition (the Schur form); ! * 2-by-2 diagonal blocks (corresponding to complex conjugate ! * pairs of eigenvalues) are returned in standard form, with ! * H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', ! * the contents of H are unspecified on exit. ! * ! * LDH (input) INTEGER ! * The leading dimension of the array H. LDH >= max(1,N). ! * ! * WR (output) DOUBLE PRECISION array, dimension (N) ! * WI (output) DOUBLE PRECISION array, dimension (N) ! * The real and imaginary parts, respectively, of the computed ! * eigenvalues. If two eigenvalues are computed as a complex ! * conjugate pair, they are stored in consecutive elements of ! * WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and ! * WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the ! * same order as on the diagonal of the Schur form returned in ! * H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 ! * diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and ! * WI(i+1) = -WI(i). ! * ! * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) ! * If COMPZ = 'N': Z is not referenced. ! * If COMPZ = 'I': on entry, Z need not be set, and on exit, Z ! * contains the orthogonal matrix Z of the Schur vectors of H. ! * If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, ! * which is assumed to be equal to the unit matrix except for ! * the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. ! * Normally Q is the orthogonal matrix generated by DORGHR after ! * the call to DGEHRD which formed the Hessenberg matrix H. ! * ! * LDZ (input) INTEGER ! * The leading dimension of the array Z. ! * LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. ! * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) ! * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! * ! * LWORK (input) INTEGER ! * The dimension of the array WORK. LWORK >= max(1,N). ! * ! * If LWORK = -1, then a workspace query is assumed; the routine ! * only calculates the optimal size of the WORK array, returns ! * this value as the first entry of the WORK array, and no error ! * message related to LWORK is issued by XERBLA. ! * ! * INFO (output) INTEGER ! * = 0: successful exit ! * < 0: if INFO = -i, the i-th argument had an illegal value ! * > 0: if INFO = i, DHSEQR failed to compute all of the ! * eigenvalues in a total of 30*(IHI-ILO+1) iterations; ! * elements 1:ilo-1 and i+1:n of WR and WI contain those ! * eigenvalues which have been successfully computed. ! * ! * ===================================================================== * * .. Parameters .. ! DOUBLE PRECISION ZERO, ONE, TWO ! PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) ! DOUBLE PRECISION CONST ! PARAMETER ( CONST = 1.5D+0 ) ! INTEGER NSMAX, LDS ! PARAMETER ( NSMAX = 15, LDS = NSMAX ) * .. * .. Local Scalars .. LOGICAL INITZ, LQUERY, WANTT, WANTZ - INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L, - $ MAXB, NH, NR, NS, NV - DOUBLE PRECISION ABSW, OVFL, SMLNUM, TAU, TEMP, TST1, ULP, UNFL - * .. - * .. Local Arrays .. - DOUBLE PRECISION S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 ) * .. * .. External Functions .. LOGICAL LSAME ! INTEGER IDAMAX, ILAENV ! DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2 ! EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2 * .. * .. External Subroutines .. ! EXTERNAL DCOPY, DGEMV, DLACPY, DLAHQR, DLARFG, DLARFX, ! $ DLASET, DSCAL, XERBLA * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * ! * Decode and test the input parameters * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) * INFO = 0 - WORK( 1 ) = MAX( 1, N ) - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN --- 1,276 ---- SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. + * Purpose + * ======= * ! * DHSEQR computes the eigenvalues of a Hessenberg matrix H ! * and, optionally, the matrices T and Z from the Schur decomposition ! * H = Z T Z**T, where T is an upper quasi-triangular matrix (the ! * Schur form), and Z is the orthogonal matrix of Schur vectors. ! * ! * Optionally Z may be postmultiplied into an input orthogonal ! * matrix Q so that this routine can give the Schur factorization ! * of a matrix A which has been reduced to the Hessenberg form H ! * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. ! * ! * Arguments ! * ========= ! * ! * JOB (input) CHARACTER*1 ! * = 'E': compute eigenvalues only; ! * = 'S': compute eigenvalues and the Schur form T. ! * ! * COMPZ (input) CHARACTER*1 ! * = 'N': no Schur vectors are computed; ! * = 'I': Z is initialized to the unit matrix and the matrix Z ! * of Schur vectors of H is returned; ! * = 'V': Z must contain an orthogonal matrix Q on entry, and ! * the product Q*Z is returned. ! * ! * N (input) INTEGER ! * The order of the matrix H. N .GE. 0. ! * ! * ILO (input) INTEGER ! * IHI (input) INTEGER ! * It is assumed that H is already upper triangular in rows ! * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally ! * set by a previous call to DGEBAL, and then passed to DGEHRD ! * when the matrix output by DGEBAL is reduced to Hessenberg ! * form. Otherwise ILO and IHI should be set to 1 and N ! * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. ! * If N = 0, then ILO = 1 and IHI = 0. ! * ! * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) ! * On entry, the upper Hessenberg matrix H. ! * On exit, if INFO = 0 and JOB = 'S', then H contains the ! * upper quasi-triangular matrix T from the Schur decomposition ! * (the Schur form); 2-by-2 diagonal blocks (corresponding to ! * complex conjugate pairs of eigenvalues) are returned in ! * standard form, with H(i,i) = H(i+1,i+1) and ! * H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the ! * contents of H are unspecified on exit. (The output value of ! * H when INFO.GT.0 is given under the description of INFO ! * below.) ! * ! * Unlike earlier versions of DHSEQR, this subroutine may ! * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 ! * or j = IHI+1, IHI+2, ... N. ! * ! * LDH (input) INTEGER ! * The leading dimension of the array H. LDH .GE. max(1,N). ! * ! * WR (output) DOUBLE PRECISION array, dimension (N) ! * WI (output) DOUBLE PRECISION array, dimension (N) ! * The real and imaginary parts, respectively, of the computed ! * eigenvalues. If two eigenvalues are computed as a complex ! * conjugate pair, they are stored in consecutive elements of ! * WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and ! * WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in ! * the same order as on the diagonal of the Schur form returned ! * in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 ! * diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and ! * WI(i+1) = -WI(i). ! * ! * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) ! * If COMPZ = 'N', Z is not referenced. ! * If COMPZ = 'I', on entry Z need not be set and on exit, ! * if INFO = 0, Z contains the orthogonal matrix Z of the Schur ! * vectors of H. If COMPZ = 'V', on entry Z must contain an ! * N-by-N matrix Q, which is assumed to be equal to the unit ! * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, ! * if INFO = 0, Z contains Q*Z. ! * Normally Q is the orthogonal matrix generated by DORGHR ! * after the call to DGEHRD which formed the Hessenberg matrix ! * H. (The output value of Z when INFO.GT.0 is given under ! * the description of INFO below.) ! * ! * LDZ (input) INTEGER ! * The leading dimension of the array Z. if COMPZ = 'I' or ! * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. ! * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) ! * On exit, if INFO = 0, WORK(1) returns an estimate of ! * the optimal value for LWORK. ! * ! * LWORK (input) INTEGER ! * The dimension of the array WORK. LWORK .GE. max(1,N) ! * is sufficient, but LWORK typically as large as 6*N may ! * be required for optimal performance. A workspace query ! * to determine the optimal workspace size is recommended. ! * ! * If LWORK = -1, then DHSEQR does a workspace query. ! * In this case, DHSEQR checks the input parameters and ! * estimates the optimal workspace size for the given ! * values of N, ILO and IHI. The estimate is returned ! * in WORK(1). No error message related to LWORK is ! * issued by XERBLA. Neither H nor Z are accessed. ! * ! * ! * INFO (output) INTEGER ! * = 0: successful exit ! * .LT. 0: if INFO = -i, the i-th argument had an illegal ! * value ! * .GT. 0: if INFO = i, DHSEQR failed to compute all of ! * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR ! * and WI contain those eigenvalues which have been ! * successfully computed. (Failures are rare.) ! * ! * If INFO .GT. 0 and JOB = 'E', then on exit, the ! * remaining unconverged eigenvalues are the eigen- ! * values of the upper Hessenberg matrix rows and ! * columns ILO through INFO of the final, output ! * value of H. ! * ! * If INFO .GT. 0 and JOB = 'S', then on exit ! * ! * (*) (initial value of H)*U = U*(final value of H) ! * ! * where U is an orthogonal matrix. The final ! * value of H is upper Hessenberg and quasi-triangular ! * in rows and columns INFO+1 through IHI. ! * ! * If INFO .GT. 0 and COMPZ = 'V', then on exit ! * ! * (final value of Z) = (initial value of Z)*U ! * ! * where U is the orthogonal matrix in (*) (regard- ! * less of the value of JOB.) ! * ! * If INFO .GT. 0 and COMPZ = 'I', then on exit ! * (final value of Z) = U ! * where U is the orthogonal matrix in (*) (regard- ! * less of the value of JOB.) ! * ! * If INFO .GT. 0 and COMPZ = 'N', then Z is not ! * accessed. ! * ! * ================================================================ ! * Default values supplied by ! * ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). ! * It is suggested that these defaults be adjusted in order ! * to attain best performance in each particular ! * computational environment. ! * ! * ISPEC=1: The DLAHQR vs DLAQR0 crossover point. ! * Default: 75. (Must be at least 11.) ! * ! * ISPEC=2: Recommended deflation window size. ! * This depends on ILO, IHI and NS. NS is the ! * number of simultaneous shifts returned ! * by ILAENV(ISPEC=4). (See ISPEC=4 below.) ! * The default for (IHI-ILO+1).LE.500 is NS. ! * The default for (IHI-ILO+1).GT.500 is 3*NS/2. ! * ! * ISPEC=3: Nibble crossover point. (See ILAENV for ! * details.) Default: 14% of deflation window ! * size. ! * ! * ISPEC=4: Number of simultaneous shifts, NS, in ! * a multi-shift QR iteration. ! * ! * If IHI-ILO+1 is ... ! * ! * greater than ...but less ... the ! * or equal to ... than default is ! * ! * 1 30 NS - 2(+) ! * 30 60 NS - 4(+) ! * 60 150 NS = 10(+) ! * 150 590 NS = ** ! * 590 3000 NS = 64 ! * 3000 6000 NS = 128 ! * 6000 infinity NS = 256 ! * ! * (+) By default some or all matrices of this order ! * are passed to the implicit double shift routine ! * DLAHQR and NS is ignored. See ISPEC=1 above ! * and comments in IPARM for details. ! * ! * The asterisks (**) indicate an ad-hoc ! * function of N increasing from 10 to 64. ! * ! * ISPEC=5: Select structured matrix multiply. ! * (See ILAENV for details.) Default: 3. ! * ! * ================================================================ ! * Based on contributions by ! * Karen Braman and Ralph Byers, Department of Mathematics, ! * University of Kansas, USA ! * ! * ================================================================ ! * References: ! * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR ! * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 ! * Performance, SIAM Journal of Matrix Analysis, volume 23, pages ! * 929--947, 2002. ! * ! * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR ! * Algorithm Part II: Aggressive Early Deflation, SIAM Journal ! * of Matrix Analysis, volume 23, pages 948--973, 2002. * + * ================================================================ * .. Parameters .. ! * ! * ==== Matrices of order NTINY or smaller must be processed by ! * . DLAHQR because of insufficient subdiagonal scratch space. ! * . (This is a hard limit.) ==== ! * ! * ==== NL allocates some local workspace to help small matrices ! * . through a rare DLAHQR failure. NL .GT. NTINY = 11 is ! * . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- ! * . mended. (The default value of NMIN is 75.) Using NL = 49 ! * . allows up to six simultaneous shifts and a 16-by-16 ! * . deflation window. ==== ! * ! INTEGER NTINY ! PARAMETER ( NTINY = 11 ) ! INTEGER NL ! PARAMETER ( NL = 49 ) ! DOUBLE PRECISION ZERO, ONE ! PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) ! * .. ! * .. Local Arrays .. ! DOUBLE PRECISION HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. + INTEGER I, KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. + INTEGER ILAENV LOGICAL LSAME ! EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. ! EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA * .. * .. Intrinsic Functions .. ! INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * ! * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DBLE( MAX( 1, N ) ) + LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN *************** *** 167,467 **** INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ! ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DHSEQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF - * - * Initialize Z, if necessary * ! IF( INITZ ) ! $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * ! * Store the eigenvalues isolated by DGEBAL. * ! DO 10 I = 1, ILO - 1 ! WR( I ) = H( I, I ) ! WI( I ) = ZERO ! 10 CONTINUE ! DO 20 I = IHI + 1, N ! WR( I ) = H( I, I ) ! WI( I ) = ZERO ! 20 CONTINUE ! * ! * Quick return if possible. ! * ! IF( N.EQ.0 ) ! $ RETURN ! IF( ILO.EQ.IHI ) THEN ! WR( ILO ) = H( ILO, ILO ) ! WI( ILO ) = ZERO RETURN - END IF * ! * Set rows and columns ILO to IHI to zero below the first ! * subdiagonal. * ! DO 40 J = ILO, IHI - 2 ! DO 30 I = J + 2, N ! H( I, J ) = ZERO ! 30 CONTINUE ! 40 CONTINUE ! NH = IHI - ILO + 1 ! * ! * Determine the order of the multi-shift QR algorithm to be used. ! * ! NS = ILAENV( 4, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) ! MAXB = ILAENV( 8, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) ! IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN * - * Use the standard double-shift algorithm - * - CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, - $ IHI, Z, LDZ, INFO ) RETURN - END IF - MAXB = MAX( 3, MAXB ) - NS = MIN( NS, MAXB, NSMAX ) - * - * Now 2 < NS <= MAXB < NH. * ! * Set machine-dependent constants for the stopping criterion. ! * If norm(H) <= sqrt(OVFL), overflow should not occur. ! * ! UNFL = DLAMCH( 'Safe minimum' ) ! OVFL = ONE / UNFL ! CALL DLABAD( UNFL, OVFL ) ! ULP = DLAMCH( 'Precision' ) ! SMLNUM = UNFL*( NH / ULP ) ! * ! * I1 and I2 are the indices of the first row and last column of H ! * to which transformations must be applied. If eigenvalues only are ! * being computed, I1 and I2 are set inside the main loop. ! * ! IF( WANTT ) THEN ! I1 = 1 ! I2 = N ! END IF * ! * ITN is the total number of multiple-shift QR iterations allowed. * ! ITN = 30*NH * ! * The main loop begins here. I is the loop index and decreases from ! * IHI to ILO in steps of at most MAXB. Each iteration of the loop ! * works with the active submatrix in rows and columns L to I. ! * Eigenvalues I+1 to IHI have already converged. Either L = ILO or ! * H(L,L-1) is negligible so that the matrix splits. ! * ! I = IHI ! 50 CONTINUE ! L = ILO ! IF( I.LT.ILO ) ! $ GO TO 170 ! * ! * Perform multiple-shift QR iterations on rows and columns ILO to I ! * until a submatrix of order at most MAXB splits off at the bottom ! * because a subdiagonal element has become negligible. ! * ! DO 150 ITS = 0, ITN ! * ! * Look for a single small subdiagonal element. ! * ! DO 60 K = I, L + 1, -1 ! TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) ! IF( TST1.EQ.ZERO ) ! $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) ! IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) ! $ GO TO 70 ! 60 CONTINUE ! 70 CONTINUE ! L = K ! IF( L.GT.ILO ) THEN * ! * H(L,L-1) is negligible. * ! H( L, L-1 ) = ZERO END IF * ! * Exit from loop if a submatrix of order <= MAXB has split off. ! * ! IF( L.GE.I-MAXB+1 ) ! $ GO TO 160 ! * ! * Now the active submatrix is in rows and columns L to I. If ! * eigenvalues only are being computed, only the active submatrix ! * need be transformed. ! * ! IF( .NOT.WANTT ) THEN ! I1 = L ! I2 = I ! END IF * ! IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN * ! * Exceptional shifts. * ! DO 80 II = I - NS + 1, I ! WR( II ) = CONST*( ABS( H( II, II-1 ) )+ ! $ ABS( H( II, II ) ) ) ! WI( II ) = ZERO ! 80 CONTINUE ELSE * ! * Use eigenvalues of trailing submatrix of order NS as shifts. * ! CALL DLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S, ! $ LDS ) ! CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS, ! $ WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ, ! $ IERR ) ! IF( IERR.GT.0 ) THEN ! * ! * If DLAHQR failed to compute all NS eigenvalues, use the ! * unconverged diagonal elements as the remaining shifts. ! * ! DO 90 II = 1, IERR ! WR( I-NS+II ) = S( II, II ) ! WI( I-NS+II ) = ZERO ! 90 CONTINUE ! END IF ! END IF * ! * Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) ! * where G is the Hessenberg submatrix H(L:I,L:I) and w is ! * the vector of shifts (stored in WR and WI). The result is ! * stored in the local array V. ! * ! V( 1 ) = ONE ! DO 100 II = 2, NS + 1 ! V( II ) = ZERO ! 100 CONTINUE ! NV = 1 ! DO 120 J = I - NS + 1, I ! IF( WI( J ).GE.ZERO ) THEN ! IF( WI( J ).EQ.ZERO ) THEN ! * ! * real shift ! * ! CALL DCOPY( NV+1, V, 1, VV, 1 ) ! CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), ! $ LDH, VV, 1, -WR( J ), V, 1 ) ! NV = NV + 1 ! ELSE IF( WI( J ).GT.ZERO ) THEN ! * ! * complex conjugate pair of shifts ! * ! CALL DCOPY( NV+1, V, 1, VV, 1 ) ! CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), ! $ LDH, V, 1, -TWO*WR( J ), VV, 1 ) ! ITEMP = IDAMAX( NV+1, VV, 1 ) ! TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM ) ! CALL DSCAL( NV+1, TEMP, VV, 1 ) ! ABSW = DLAPY2( WR( J ), WI( J ) ) ! TEMP = ( TEMP*ABSW )*ABSW ! CALL DGEMV( 'No transpose', NV+2, NV+1, ONE, ! $ H( L, L ), LDH, VV, 1, TEMP, V, 1 ) ! NV = NV + 2 ! END IF * ! * Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, ! * reset it to the unit vector. * ! ITEMP = IDAMAX( NV, V, 1 ) ! TEMP = ABS( V( ITEMP ) ) ! IF( TEMP.EQ.ZERO ) THEN ! V( 1 ) = ONE ! DO 110 II = 2, NV ! V( II ) = ZERO ! 110 CONTINUE ! ELSE ! TEMP = MAX( TEMP, SMLNUM ) ! CALL DSCAL( NV, ONE / TEMP, V, 1 ) ! END IF ! END IF ! 120 CONTINUE * ! * Multiple-shift QR step ! * ! DO 140 K = L, I - 1 ! * ! * The first iteration of this loop determines a reflection G ! * from the vector V and applies it from left and right to H, ! * thus creating a nonzero bulge below the subdiagonal. ! * ! * Each subsequent iteration determines a reflection G to ! * restore the Hessenberg form in the (K-1)th column, and thus ! * chases the bulge one step toward the bottom of the active ! * submatrix. NR is the order of G. ! * ! NR = MIN( NS+1, I-K+1 ) ! IF( K.GT.L ) ! $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) ! CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) ! IF( K.GT.L ) THEN ! H( K, K-1 ) = V( 1 ) ! DO 130 II = K + 1, I ! H( II, K-1 ) = ZERO ! 130 CONTINUE ! END IF ! V( 1 ) = ONE * ! * Apply G from the left to transform the rows of the matrix in ! * columns K to I2. * ! CALL DLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH, ! $ WORK ) * ! * Apply G from the right to transform the columns of the ! * matrix in rows I1 to min(K+NR,I). ! * ! CALL DLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU, ! $ H( I1, K ), LDH, WORK ) ! * ! IF( WANTZ ) THEN ! * ! * Accumulate transformations in the matrix Z * ! CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ, ! $ WORK ) END IF ! 140 CONTINUE ! * ! 150 CONTINUE ! * ! * Failure to converge in remaining number of iterations ! * ! INFO = I ! RETURN ! * ! 160 CONTINUE ! * ! * A submatrix of order <= MAXB in rows and columns L to I has split ! * off. Use the double-shift QR algorithm to handle it. * ! CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z, ! $ LDZ, INFO ) ! IF( INFO.GT.0 ) ! $ RETURN * ! * Decrement number of remaining iterations, and return to start of ! * the main loop with a new value of I. * ! ITN = ITN - ITS ! I = L - 1 ! GO TO 50 * ! 170 CONTINUE ! WORK( 1 ) = MAX( 1, N ) ! RETURN * ! * End of DHSEQR * END --- 283,407 ---- INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ! ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * ! IF( INFO.NE.0 ) THEN * ! * ==== Quick return in case of invalid argument. ==== * ! CALL XERBLA( 'DHSEQR', -INFO ) RETURN * ! ELSE IF( N.EQ.0 ) THEN * ! * ==== Quick return in case N = 0; nothing to do. ==== * RETURN * ! ELSE IF( LQUERY ) THEN * ! * ==== Quick return in case of a workspace query ==== * ! CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, ! $ IHI, Z, LDZ, WORK, LWORK, INFO ) ! * ==== Ensure reported workspace size is backward-compatible with ! * . previous LAPACK versions. ==== ! WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) ! RETURN * ! ELSE * ! * ==== copy eigenvalues isolated by DGEBAL ==== * ! DO 10 I = 1, ILO - 1 ! WR( I ) = H( I, I ) ! WI( I ) = ZERO ! 10 CONTINUE ! DO 20 I = IHI + 1, N ! WR( I ) = H( I, I ) ! WI( I ) = ZERO ! 20 CONTINUE ! * ! * ==== Initialize Z, if requested ==== ! * ! IF( INITZ ) ! $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) ! * ! * ==== Quick return if possible ==== ! * ! IF( ILO.EQ.IHI ) THEN ! WR( ILO ) = H( ILO, ILO ) ! WI( ILO ) = ZERO ! RETURN END IF * ! * ==== DLAHQR/DLAQR0 crossover point ==== * ! NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ! $ ILO, IHI, LWORK ) ! NMIN = MAX( NTINY, NMIN ) * ! * ==== DLAQR0 for big matrices; DLAHQR for small ones ==== * ! IF( N.GT.NMIN ) THEN ! CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, ! $ IHI, Z, LDZ, WORK, LWORK, INFO ) ELSE * ! * ==== Small matrix ==== * ! CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, ! $ IHI, Z, LDZ, INFO ) * ! IF( INFO.GT.0 ) THEN * ! * ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds ! * . when DLAHQR fails. ==== * ! KBOT = INFO * ! IF( N.GE.NL ) THEN * ! * ==== Larger matrices have enough subdiagonal scratch ! * . space to call DLAQR0 directly. ==== * ! CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, ! $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ! ELSE * ! * ==== Tiny matrices don't have enough subdiagonal ! * . scratch space to benefit from DLAQR0. Hence, ! * . tiny matrices must be copied into a larger ! * . array before calling DLAQR0. ==== ! * ! CALL DLACPY( 'A', N, N, H, LDH, HL, NL ) ! HL( N+1, N ) = ZERO ! CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), ! $ NL ) ! CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, ! $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) ! IF( WANTT .OR. INFO.NE.0 ) ! $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH ) ! END IF END IF ! END IF * ! * ==== Clear out the trash, if necessary. ==== * ! IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) ! $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * ! * ==== Ensure reported workspace size is backward-compatible with ! * . previous LAPACK versions. ==== * ! WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) ! END IF * ! * ==== End of DHSEQR ==== * END diff -cNr octave-2.9.15/libcruft/lapack/dlabad.f octave-2.9.16/libcruft/lapack/dlabad.f *** octave-2.9.15/libcruft/lapack/dlabad.f Wed Nov 3 14:54:21 1999 --- octave-2.9.16/libcruft/lapack/dlabad.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLABAD( SMALL, LARGE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL --- 1,8 ---- SUBROUTINE DLABAD( SMALL, LARGE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL diff -cNr octave-2.9.15/libcruft/lapack/dlabrd.f octave-2.9.16/libcruft/lapack/dlabrd.f *** octave-2.9.15/libcruft/lapack/dlabrd.f Wed Nov 3 14:54:21 1999 --- octave-2.9.16/libcruft/lapack/dlabrd.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB --- 1,9 ---- SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB *************** *** 87,93 **** * The n-by-nb matrix Y required to update the unreduced part * of A. * ! * LDY (output) INTEGER * The leading dimension of the array Y. LDY >= N. * * Further Details --- 86,92 ---- * The n-by-nb matrix Y required to update the unreduced part * of A. * ! * LDY (input) INTEGER * The leading dimension of the array Y. LDY >= N. * * Further Details diff -cNr octave-2.9.15/libcruft/lapack/dlacn2.f octave-2.9.16/libcruft/lapack/dlacn2.f *** octave-2.9.15/libcruft/lapack/dlacn2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlacn2.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,214 ---- + SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST + * .. + * .. Array Arguments .. + INTEGER ISGN( * ), ISAVE( 3 ) + DOUBLE PRECISION V( * ), X( * ) + * .. + * + * Purpose + * ======= + * + * DLACN2 estimates the 1-norm of a square, real matrix A. + * Reverse communication is used for evaluating matrix-vector products. + * + * Arguments + * ========= + * + * N (input) INTEGER + * The order of the matrix. N >= 1. + * + * V (workspace) DOUBLE PRECISION array, dimension (N) + * On the final return, V = A*W, where EST = norm(V)/norm(W) + * (W is not returned). + * + * X (input/output) DOUBLE PRECISION array, dimension (N) + * On an intermediate return, X should be overwritten by + * A * X, if KASE=1, + * A' * X, if KASE=2, + * and DLACN2 must be re-called with all the other parameters + * unchanged. + * + * ISGN (workspace) INTEGER array, dimension (N) + * + * EST (input/output) DOUBLE PRECISION + * On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be + * unchanged from the previous call to DLACN2. + * On exit, EST is an estimate (a lower bound) for norm(A). + * + * KASE (input/output) INTEGER + * On the initial call to DLACN2, KASE should be 0. + * On an intermediate return, KASE will be 1 or 2, indicating + * whether X should be overwritten by A * X or A' * X. + * On the final return from DLACN2, KASE will again be 0. + * + * ISAVE (input/output) INTEGER array, dimension (3) + * ISAVE is used to save variables between calls to DLACN2 + * + * Further Details + * ======= ======= + * + * Contributed by Nick Higham, University of Manchester. + * Originally named SONEST, dated March 16, 1988. + * + * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of + * a real or complex matrix, with applications to condition estimation", + * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. + * + * This is a thread safe version of DLACON, which uses the array ISAVE + * in place of a SAVE statement, as follows: + * + * DLACON DLACN2 + * JUMP ISAVE(1) + * J ISAVE(2) + * ITER ISAVE(3) + * + * ===================================================================== + * + * .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER I, JLAST + DOUBLE PRECISION ALTSGN, ESTOLD, TEMP + * .. + * .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM + EXTERNAL IDAMAX, DASUM + * .. + * .. External Subroutines .. + EXTERNAL DCOPY + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, NINT, SIGN + * .. + * .. Executable Statements .. + * + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = ONE / DBLE( N ) + 10 CONTINUE + KASE = 1 + ISAVE( 1 ) = 1 + RETURN + END IF + * + GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) + * + * ................ ENTRY (ISAVE( 1 ) = 1) + * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. + * + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) + * ... QUIT + GO TO 150 + END IF + EST = DASUM( N, X, 1 ) + * + DO 30 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 30 CONTINUE + KASE = 2 + ISAVE( 1 ) = 2 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 2) + * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. + * + 40 CONTINUE + ISAVE( 2 ) = IDAMAX( N, X, 1 ) + ISAVE( 3 ) = 2 + * + * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. + * + 50 CONTINUE + DO 60 I = 1, N + X( I ) = ZERO + 60 CONTINUE + X( ISAVE( 2 ) ) = ONE + KASE = 1 + ISAVE( 1 ) = 3 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 3) + * X HAS BEEN OVERWRITTEN BY A*X. + * + 70 CONTINUE + CALL DCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DASUM( N, V, 1 ) + DO 80 I = 1, N + IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) + $ GO TO 90 + 80 CONTINUE + * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. + GO TO 120 + * + 90 CONTINUE + * TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 120 + * + DO 100 I = 1, N + X( I ) = SIGN( ONE, X( I ) ) + ISGN( I ) = NINT( X( I ) ) + 100 CONTINUE + KASE = 2 + ISAVE( 1 ) = 4 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 4) + * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. + * + 110 CONTINUE + JLAST = ISAVE( 2 ) + ISAVE( 2 ) = IDAMAX( N, X, 1 ) + IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. + $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN + ISAVE( 3 ) = ISAVE( 3 ) + 1 + GO TO 50 + END IF + * + * ITERATION COMPLETE. FINAL STAGE. + * + 120 CONTINUE + ALTSGN = ONE + DO 130 I = 1, N + X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) + ALTSGN = -ALTSGN + 130 CONTINUE + KASE = 1 + ISAVE( 1 ) = 5 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 5) + * X HAS BEEN OVERWRITTEN BY A*X. + * + 140 CONTINUE + TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL DCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF + * + 150 CONTINUE + KASE = 0 + RETURN + * + * End of DLACN2 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlacon.f octave-2.9.16/libcruft/lapack/dlacon.f *** octave-2.9.15/libcruft/lapack/dlacon.f Wed Nov 3 14:54:21 1999 --- octave-2.9.16/libcruft/lapack/dlacon.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER KASE, N --- 1,8 ---- SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER KASE, N *************** *** 39,46 **** * * ISGN (workspace) INTEGER array, dimension (N) * ! * EST (output) DOUBLE PRECISION ! * An estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to DLACON, KASE should be 0. --- 38,47 ---- * * ISGN (workspace) INTEGER array, dimension (N) * ! * EST (input/output) DOUBLE PRECISION ! * On entry with KASE = 1 or 2 and JUMP = 3, EST should be ! * unchanged from the previous call to DLACON. ! * On exit, EST is an estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to DLACON, KASE should be 0. *************** *** 118,124 **** RETURN * * ................ ENTRY (JUMP = 2) ! * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. * 40 CONTINUE J = IDAMAX( N, X, 1 ) --- 119,125 ---- RETURN * * ................ ENTRY (JUMP = 2) ! * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE J = IDAMAX( N, X, 1 ) *************** *** 163,169 **** RETURN * * ................ ENTRY (JUMP = 4) ! * X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. * 110 CONTINUE JLAST = J --- 164,170 ---- RETURN * * ................ ENTRY (JUMP = 4) ! * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = J diff -cNr octave-2.9.15/libcruft/lapack/dlacpy.f octave-2.9.16/libcruft/lapack/dlacpy.f *** octave-2.9.15/libcruft/lapack/dlacpy.f Wed Nov 3 14:54:22 1999 --- octave-2.9.16/libcruft/lapack/dlacpy.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dladiv.f octave-2.9.16/libcruft/lapack/dladiv.f *** octave-2.9.15/libcruft/lapack/dladiv.f Wed Nov 3 14:54:22 1999 --- octave-2.9.16/libcruft/lapack/dladiv.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLADIV( A, B, C, D, P, Q ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q --- 1,8 ---- SUBROUTINE DLADIV( A, B, C, D, P, Q ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q diff -cNr octave-2.9.15/libcruft/lapack/dlae2.f octave-2.9.16/libcruft/lapack/dlae2.f *** octave-2.9.15/libcruft/lapack/dlae2.f Wed Nov 3 14:54:22 1999 --- octave-2.9.16/libcruft/lapack/dlae2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 --- 1,8 ---- SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 diff -cNr octave-2.9.15/libcruft/lapack/dlaed6.f octave-2.9.16/libcruft/lapack/dlaed6.f *** octave-2.9.15/libcruft/lapack/dlaed6.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlaed6.f Fri Oct 26 11:52:57 2007 *************** *** 0 **** --- 1,327 ---- + SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) + * + * -- LAPACK routine (version 3.1.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * February 2007 + * + * .. Scalar Arguments .. + LOGICAL ORGATI + INTEGER INFO, KNITER + DOUBLE PRECISION FINIT, RHO, TAU + * .. + * .. Array Arguments .. + DOUBLE PRECISION D( 3 ), Z( 3 ) + * .. + * + * Purpose + * ======= + * + * DLAED6 computes the positive or negative root (closest to the origin) + * of + * z(1) z(2) z(3) + * f(x) = rho + --------- + ---------- + --------- + * d(1)-x d(2)-x d(3)-x + * + * It is assumed that + * + * if ORGATI = .true. the root is between d(2) and d(3); + * otherwise it is between d(1) and d(2) + * + * This routine will be called by DLAED4 when necessary. In most cases, + * the root sought is the smallest in magnitude, though it might not be + * in some extremely rare situations. + * + * Arguments + * ========= + * + * KNITER (input) INTEGER + * Refer to DLAED4 for its significance. + * + * ORGATI (input) LOGICAL + * If ORGATI is true, the needed root is between d(2) and + * d(3); otherwise it is between d(1) and d(2). See + * DLAED4 for further details. + * + * RHO (input) DOUBLE PRECISION + * Refer to the equation f(x) above. + * + * D (input) DOUBLE PRECISION array, dimension (3) + * D satisfies d(1) < d(2) < d(3). + * + * Z (input) DOUBLE PRECISION array, dimension (3) + * Each of the elements in z must be positive. + * + * FINIT (input) DOUBLE PRECISION + * The value of f at 0. It is more accurate than the one + * evaluated inside this routine (if someone wants to do + * so). + * + * TAU (output) DOUBLE PRECISION + * The root of the equation f(x). + * + * INFO (output) INTEGER + * = 0: successful exit + * > 0: if INFO = 1, failure to converge + * + * Further Details + * =============== + * + * 30/06/99: Based on contributions by + * Ren-Cang Li, Computer Science Division, University of California + * at Berkeley, USA + * + * 10/02/03: This version has a few statements commented out for thread + * safety (machine parameters are computed on each entry). SJH. + * + * 05/10/06: Modified from a new version of Ren-Cang Li, use + * Gragg-Thornton-Warner cubic convergent scheme for better stability. + * + * ===================================================================== + * + * .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 40 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + * .. + * .. Local Arrays .. + DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) + * .. + * .. Local Scalars .. + LOGICAL SCALE + INTEGER I, ITER, NITER + DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, + $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, + $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, + $ LBD, UBD + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT + * .. + * .. Executable Statements .. + * + INFO = 0 + * + IF( ORGATI ) THEN + LBD = D(2) + UBD = D(3) + ELSE + LBD = D(1) + UBD = D(2) + END IF + IF( FINIT .LT. ZERO )THEN + LBD = ZERO + ELSE + UBD = ZERO + END IF + * + NITER = 1 + TAU = ZERO + IF( KNITER.EQ.2 ) THEN + IF( ORGATI ) THEN + TEMP = ( D( 3 )-D( 2 ) ) / TWO + C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) + A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) + B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) + ELSE + TEMP = ( D( 1 )-D( 2 ) ) / TWO + C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) + A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) + B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) + END IF + TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) + A = A / TEMP + B = B / TEMP + C = C / TEMP + IF( C.EQ.ZERO ) THEN + TAU = B / A + ELSE IF( A.LE.ZERO ) THEN + TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + IF( TAU .LT. LBD .OR. TAU .GT. UBD ) + $ TAU = ( LBD+UBD )/TWO + IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN + TAU = ZERO + ELSE + TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) + + $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) + + $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) ) + IF( TEMP .LE. ZERO )THEN + LBD = TAU + ELSE + UBD = TAU + END IF + IF( ABS( FINIT ).LE.ABS( TEMP ) ) + $ TAU = ZERO + END IF + END IF + * + * get machine parameters for possible scaling to avoid overflow + * + * modified by Sven: parameters SMALL1, SMINV1, SMALL2, + * SMINV2, EPS are not SAVEd anymore between one call to the + * others but recomputed at each call + * + EPS = DLAMCH( 'Epsilon' ) + BASE = DLAMCH( 'Base' ) + SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / + $ THREE ) ) + SMINV1 = ONE / SMALL1 + SMALL2 = SMALL1*SMALL1 + SMINV2 = SMINV1*SMINV1 + * + * Determine if scaling of inputs necessary to avoid overflow + * when computing 1/TEMP**3 + * + IF( ORGATI ) THEN + TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) + ELSE + TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) + END IF + SCALE = .FALSE. + IF( TEMP.LE.SMALL1 ) THEN + SCALE = .TRUE. + IF( TEMP.LE.SMALL2 ) THEN + * + * Scale up by power of radix nearest 1/SAFMIN**(2/3) + * + SCLFAC = SMINV2 + SCLINV = SMALL2 + ELSE + * + * Scale up by power of radix nearest 1/SAFMIN**(1/3) + * + SCLFAC = SMINV1 + SCLINV = SMALL1 + END IF + * + * Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) + * + DO 10 I = 1, 3 + DSCALE( I ) = D( I )*SCLFAC + ZSCALE( I ) = Z( I )*SCLFAC + 10 CONTINUE + TAU = TAU*SCLFAC + LBD = LBD*SCLFAC + UBD = UBD*SCLFAC + ELSE + * + * Copy D and Z to DSCALE and ZSCALE + * + DO 20 I = 1, 3 + DSCALE( I ) = D( I ) + ZSCALE( I ) = Z( I ) + 20 CONTINUE + END IF + * + FC = ZERO + DF = ZERO + DDF = ZERO + DO 30 I = 1, 3 + TEMP = ONE / ( DSCALE( I )-TAU ) + TEMP1 = ZSCALE( I )*TEMP + TEMP2 = TEMP1*TEMP + TEMP3 = TEMP2*TEMP + FC = FC + TEMP1 / DSCALE( I ) + DF = DF + TEMP2 + DDF = DDF + TEMP3 + 30 CONTINUE + F = FINIT + TAU*FC + * + IF( ABS( F ).LE.ZERO ) + $ GO TO 60 + IF( F .LE. ZERO )THEN + LBD = TAU + ELSE + UBD = TAU + END IF + * + * Iteration begins -- Use Gragg-Thornton-Warner cubic convergent + * scheme + * + * It is not hard to see that + * + * 1) Iterations will go up monotonically + * if FINIT < 0; + * + * 2) Iterations will go down monotonically + * if FINIT > 0. + * + ITER = NITER + 1 + * + DO 50 NITER = ITER, MAXIT + * + IF( ORGATI ) THEN + TEMP1 = DSCALE( 2 ) - TAU + TEMP2 = DSCALE( 3 ) - TAU + ELSE + TEMP1 = DSCALE( 1 ) - TAU + TEMP2 = DSCALE( 2 ) - TAU + END IF + A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF + B = TEMP1*TEMP2*F + C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF + TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) + A = A / TEMP + B = B / TEMP + C = C / TEMP + IF( C.EQ.ZERO ) THEN + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + IF( F*ETA.GE.ZERO ) THEN + ETA = -F / DF + END IF + * + TAU = TAU + ETA + IF( TAU .LT. LBD .OR. TAU .GT. UBD ) + $ TAU = ( LBD + UBD )/TWO + * + FC = ZERO + ERRETM = ZERO + DF = ZERO + DDF = ZERO + DO 40 I = 1, 3 + TEMP = ONE / ( DSCALE( I )-TAU ) + TEMP1 = ZSCALE( I )*TEMP + TEMP2 = TEMP1*TEMP + TEMP3 = TEMP2*TEMP + TEMP4 = TEMP1 / DSCALE( I ) + FC = FC + TEMP4 + ERRETM = ERRETM + ABS( TEMP4 ) + DF = DF + TEMP2 + DDF = DDF + TEMP3 + 40 CONTINUE + F = FINIT + TAU*FC + ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + + $ ABS( TAU )*DF + IF( ABS( F ).LE.EPS*ERRETM ) + $ GO TO 60 + IF( F .LE. ZERO )THEN + LBD = TAU + ELSE + UBD = TAU + END IF + 50 CONTINUE + INFO = 1 + 60 CONTINUE + * + * Undo scaling + * + IF( SCALE ) + $ TAU = TAU*SCLINV + RETURN + * + * End of DLAED6 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlaev2.f octave-2.9.16/libcruft/lapack/dlaev2.f *** octave-2.9.15/libcruft/lapack/dlaev2.f Wed Nov 3 14:54:22 1999 --- octave-2.9.16/libcruft/lapack/dlaev2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 --- 1,8 ---- SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 diff -cNr octave-2.9.15/libcruft/lapack/dlaexc.f octave-2.9.16/libcruft/lapack/dlaexc.f *** octave-2.9.15/libcruft/lapack/dlaexc.f Wed Nov 3 14:54:22 1999 --- octave-2.9.16/libcruft/lapack/dlaexc.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. LOGICAL WANTQ --- 1,9 ---- SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL WANTQ diff -cNr octave-2.9.15/libcruft/lapack/dlag2.f octave-2.9.16/libcruft/lapack/dlag2.f *** octave-2.9.15/libcruft/lapack/dlag2.f Wed Nov 3 14:54:22 1999 --- octave-2.9.16/libcruft/lapack/dlag2.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. INTEGER LDA, LDB --- 1,9 ---- SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER LDA, LDB diff -cNr octave-2.9.15/libcruft/lapack/dlahqr.f octave-2.9.16/libcruft/lapack/dlahqr.f *** octave-2.9.15/libcruft/lapack/dlahqr.f Wed Nov 3 14:54:23 1999 --- octave-2.9.16/libcruft/lapack/dlahqr.f Tue Oct 16 14:54:20 2007 *************** *** 1,42 **** SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. - LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * ! * Purpose ! * ======= * ! * DLAHQR is an auxiliary routine called by DHSEQR to update the ! * eigenvalues and Schur decomposition already computed by DHSEQR, by ! * dealing with the Hessenberg submatrix in rows and columns ILO to IHI. * ! * Arguments ! * ========= * ! * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * ! * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * ! * N (input) INTEGER * The order of the matrix H. N >= 0. * ! * ILO (input) INTEGER ! * IHI (input) INTEGER * It is assumed that H is already upper quasi-triangular in * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless * ILO = 1). DLAHQR works primarily with the Hessenberg --- 1,42 ---- SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * ! * Purpose ! * ======= * ! * DLAHQR is an auxiliary routine called by DHSEQR to update the ! * eigenvalues and Schur decomposition already computed by DHSEQR, by ! * dealing with the Hessenberg submatrix in rows and columns ILO to ! * IHI. * ! * Arguments ! * ========= * ! * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * ! * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * ! * N (input) INTEGER * The order of the matrix H. N >= 0. * ! * ILO (input) INTEGER ! * IHI (input) INTEGER * It is assumed that H is already upper quasi-triangular in * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless * ILO = 1). DLAHQR works primarily with the Hessenberg *************** *** 44,61 **** * transformations to all of H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * ! * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. ! * On exit, if WANTT is .TRUE., H is upper quasi-triangular in ! * rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in ! * standard form. If WANTT is .FALSE., the contents of H are ! * unspecified on exit. * ! * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * ! * WR (output) DOUBLE PRECISION array, dimension (N) ! * WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues ILO to IHI are stored in the corresponding * elements of WR and WI. If two eigenvalues are computed as a --- 44,63 ---- * transformations to all of H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * ! * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. ! * On exit, if INFO is zero and if WANTT is .TRUE., H is upper ! * quasi-triangular in rows and columns ILO:IHI, with any ! * 2-by-2 diagonal blocks in standard form. If INFO is zero ! * and WANTT is .FALSE., the contents of H are unspecified on ! * exit. The output state of H if INFO is nonzero is given ! * below under the description of INFO. * ! * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * ! * WR (output) DOUBLE PRECISION array, dimension (N) ! * WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues ILO to IHI are stored in the corresponding * elements of WR and WI. If two eigenvalues are computed as a *************** *** 67,128 **** * H(i:i+1,i:i+1) is a 2-by-2 diagonal block, * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). * ! * ILOZ (input) INTEGER ! * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * ! * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by DHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * ! * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * ! * INFO (output) INTEGER ! * = 0: successful exit ! * > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI ! * in a total of 30*(IHI-ILO+1) iterations; if INFO = i, ! * elements i+1:ihi of WR and WI contain those eigenvalues ! * which have been successfully computed. * ! * Further Details ! * =============== * ! * 2-96 Based on modifications by * David Day, Sandia National Laboratory, USA * ! * ===================================================================== * * .. Parameters .. ! DOUBLE PRECISION ZERO, ONE, HALF ! PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D0 ) DOUBLE PRECISION DAT1, DAT2 ! PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) * .. * .. Local Scalars .. ! INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ ! DOUBLE PRECISION AVE, CS, DISC, H00, H10, H11, H12, H21, H22, ! $ H33, H33S, H43H34, H44, H44S, OVFL, S, SMLNUM, ! $ SN, SUM, T1, T2, T3, TST1, ULP, UNFL, V1, V2, ! $ V3 * .. * .. Local Arrays .. ! DOUBLE PRECISION V( 3 ), WORK( 1 ) * .. * .. External Functions .. ! DOUBLE PRECISION DLAMCH, DLANHS ! EXTERNAL DLAMCH, DLANHS * .. * .. External Subroutines .. ! EXTERNAL DCOPY, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * --- 69,158 ---- * H(i:i+1,i:i+1) is a 2-by-2 diagonal block, * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). * ! * ILOZ (input) INTEGER ! * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * ! * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by DHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * ! * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * ! * INFO (output) INTEGER ! * = 0: successful exit ! * .GT. 0: If INFO = i, DLAHQR failed to compute all the ! * eigenvalues ILO to IHI in a total of 30 iterations ! * per eigenvalue; elements i+1:ihi of WR and WI ! * contain those eigenvalues which have been ! * successfully computed. ! * ! * If INFO .GT. 0 and WANTT is .FALSE., then on exit, ! * the remaining unconverged eigenvalues are the ! * eigenvalues of the upper Hessenberg matrix rows ! * and columns ILO thorugh INFO of the final, output ! * value of H. ! * ! * If INFO .GT. 0 and WANTT is .TRUE., then on exit ! * (*) (initial value of H)*U = U*(final value of H) ! * where U is an orthognal matrix. The final ! * value of H is upper Hessenberg and triangular in ! * rows and columns INFO+1 through IHI. ! * ! * If INFO .GT. 0 and WANTZ is .TRUE., then on exit ! * (final value of Z) = (initial value of Z)*U ! * where U is the orthogonal matrix in (*) ! * (regardless of the value of WANTT.) * ! * Further Details ! * =============== * ! * 02-96 Based on modifications by * David Day, Sandia National Laboratory, USA * ! * 12-04 Further modifications by ! * Ralph Byers, University of Kansas, USA ! * ! * This is a modified version of DLAHQR from LAPACK version 3.0. ! * It is (1) more robust against overflow and underflow and ! * (2) adopts the more conservative Ahues & Tisseur stopping ! * criterion (LAWN 122, 1997). ! * ! * ========================================================= * * .. Parameters .. ! INTEGER ITMAX ! PARAMETER ( ITMAX = 30 ) ! DOUBLE PRECISION ZERO, ONE, TWO ! PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 ) DOUBLE PRECISION DAT1, DAT2 ! PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 ) * .. * .. Local Scalars .. ! DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, ! $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, ! $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, ! $ ULP, V2, V3 ! INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ * .. * .. Local Arrays .. ! DOUBLE PRECISION V( 3 ) * .. * .. External Functions .. ! DOUBLE PRECISION DLAMCH ! EXTERNAL DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * *************** *** 138,154 **** RETURN END IF * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. - * If norm(H) <= sqrt(OVFL), overflow should not occur. * ! UNFL = DLAMCH( 'Safe minimum' ) ! OVFL = ONE / UNFL ! CALL DLABAD( UNFL, OVFL ) ! ULP = DLAMCH( 'Precision' ) ! SMLNUM = UNFL*( NH / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are --- 168,191 ---- RETURN END IF * + * ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO + * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * ! SAFMIN = DLAMCH( 'SAFE MINIMUM' ) ! SAFMAX = ONE / SAFMIN ! CALL DLABAD( SAFMIN, SAFMAX ) ! ULP = DLAMCH( 'PRECISION' ) ! SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are *************** *** 159,168 **** I2 = N END IF * - * ITN is the total number of QR iterations allowed. - * - ITN = 30*NH - * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works * with the active submatrix in rows and columns L to I. --- 196,201 ---- *************** *** 170,196 **** * H(L,L-1) is negligible so that the matrix splits. * I = IHI ! 10 CONTINUE L = ILO IF( I.LT.ILO ) ! $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * ! DO 130 ITS = 0, ITN * * Look for a single small subdiagonal element. * ! DO 20 K = I, L + 1, -1 ! TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) ! IF( TST1.EQ.ZERO ) ! $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) ! IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) ! $ GO TO 30 ! 20 CONTINUE 30 CONTINUE L = K IF( L.GT.ILO ) THEN * --- 203,248 ---- * H(L,L-1) is negligible so that the matrix splits. * I = IHI ! 20 CONTINUE L = ILO IF( I.LT.ILO ) ! $ GO TO 160 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * ! DO 140 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * ! DO 30 K = I, L + 1, -1 ! IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) ! $ GO TO 40 ! TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) ! IF( TST.EQ.ZERO ) THEN ! IF( K-2.GE.ILO ) ! $ TST = TST + ABS( H( K-1, K-2 ) ) ! IF( K+1.LE.IHI ) ! $ TST = TST + ABS( H( K+1, K ) ) ! END IF ! * ==== The following is a conservative small subdiagonal ! * . deflation criterion due to Ahues & Tisseur (LAWN 122, ! * . 1997). It has better mathematical foundation and ! * . improves accuracy in some cases. ==== ! IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN ! AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) ! BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) ! AA = MAX( ABS( H( K, K ) ), ! $ ABS( H( K-1, K-1 )-H( K, K ) ) ) ! BB = MIN( ABS( H( K, K ) ), ! $ ABS( H( K-1, K-1 )-H( K, K ) ) ) ! S = AA + AB ! IF( BA*( AB / S ).LE.MAX( SMLNUM, ! $ ULP*( BB*( AA / S ) ) ) )GO TO 40 ! END IF 30 CONTINUE + 40 CONTINUE L = K IF( L.GT.ILO ) THEN * *************** *** 202,208 **** * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) ! $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix --- 254,260 ---- * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) ! $ GO TO 150 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix *************** *** 217,290 **** * * Exceptional shift. * ! S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) ! H44 = DAT1*S + H( I, I ) ! H33 = H44 ! H43H34 = DAT2*S*S ELSE * * Prepare to use Francis' double shift * (i.e. 2nd degree generalized Rayleigh quotient) * ! H44 = H( I, I ) ! H33 = H( I-1, I-1 ) ! H43H34 = H( I, I-1 )*H( I-1, I ) ! S = H( I-1, I-2 )*H( I-1, I-2 ) ! DISC = ( H33-H44 )*HALF ! DISC = DISC*DISC + H43H34 ! IF( DISC.GT.ZERO ) THEN ! * ! * Real roots: use Wilkinson's shift twice ! * ! DISC = SQRT( DISC ) ! AVE = HALF*( H33+H44 ) ! IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN ! H33 = H33*H44 - H43H34 ! H44 = H33 / ( SIGN( DISC, AVE )+AVE ) ELSE ! H44 = SIGN( DISC, AVE ) + AVE END IF ! H33 = H44 ! H43H34 = ZERO END IF END IF * * Look for two consecutive small subdiagonal elements. * ! DO 40 M = I - 2, L, -1 * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) ! * negligible. * ! H11 = H( M, M ) ! H22 = H( M+1, M+1 ) ! H21 = H( M+1, M ) ! H12 = H( M, M+1 ) ! H44S = H44 - H11 ! H33S = H33 - H11 ! V1 = ( H33S*H44S-H43H34 ) / H21 + H12 ! V2 = H22 - H11 - H33S - H44S ! V3 = H( M+2, M+1 ) ! S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) ! V1 = V1 / S ! V2 = V2 / S ! V3 = V3 / S ! V( 1 ) = V1 ! V( 2 ) = V2 ! V( 3 ) = V3 IF( M.EQ.L ) ! $ GO TO 50 ! H00 = H( M-1, M-1 ) ! H10 = H( M, M-1 ) ! TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) ) ! IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 ) ! $ GO TO 50 ! 40 CONTINUE 50 CONTINUE * * Double-shift QR step * ! DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, --- 269,358 ---- * * Exceptional shift. * ! H11 = DAT1*S + H( I, I ) ! H12 = DAT2*S ! H21 = S ! H22 = H11 ELSE * * Prepare to use Francis' double shift * (i.e. 2nd degree generalized Rayleigh quotient) * ! H11 = H( I-1, I-1 ) ! H21 = H( I, I-1 ) ! H12 = H( I-1, I ) ! H22 = H( I, I ) ! END IF ! S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) ! IF( S.EQ.ZERO ) THEN ! RT1R = ZERO ! RT1I = ZERO ! RT2R = ZERO ! RT2I = ZERO ! ELSE ! H11 = H11 / S ! H21 = H21 / S ! H12 = H12 / S ! H22 = H22 / S ! TR = ( H11+H22 ) / TWO ! DET = ( H11-TR )*( H22-TR ) - H12*H21 ! RTDISC = SQRT( ABS( DET ) ) ! IF( DET.GE.ZERO ) THEN ! * ! * ==== complex conjugate shifts ==== ! * ! RT1R = TR*S ! RT2R = RT1R ! RT1I = RTDISC*S ! RT2I = -RT1I ! ELSE ! * ! * ==== real shifts (use only one of them) ==== ! * ! RT1R = TR + RTDISC ! RT2R = TR - RTDISC ! IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN ! RT1R = RT1R*S ! RT2R = RT1R ELSE ! RT2R = RT2R*S ! RT1R = RT2R END IF ! RT1I = ZERO ! RT2I = ZERO END IF END IF * * Look for two consecutive small subdiagonal elements. * ! DO 50 M = I - 2, L, -1 * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) ! * negligible. (The following uses scaling to avoid ! * overflows and most underflows.) * ! H21S = H( M+1, M ) ! S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) ! H21S = H( M+1, M ) / S ! V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* ! $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) ! V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) ! V( 3 ) = H21S*H( M+2, M+1 ) ! S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) ! V( 1 ) = V( 1 ) / S ! V( 2 ) = V( 2 ) / S ! V( 3 ) = V( 3 ) / S IF( M.EQ.L ) ! $ GO TO 60 ! IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. ! $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, ! $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 50 CONTINUE + 60 CONTINUE * * Double-shift QR step * ! DO 130 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, *************** *** 316,390 **** * Apply G from the left to transform the rows of the matrix * in columns K to I2. * ! DO 60 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 ! 60 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * ! DO 70 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 ! 70 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * ! DO 80 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 ! 80 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * ! DO 90 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 ! 90 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * ! DO 100 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 ! 100 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * ! DO 110 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 ! 110 CONTINUE END IF END IF ! 120 CONTINUE * ! 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * ! 140 CONTINUE * IF( L.EQ.I ) THEN * --- 384,458 ---- * Apply G from the left to transform the rows of the matrix * in columns K to I2. * ! DO 70 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 ! 70 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * ! DO 80 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 ! 80 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * ! DO 90 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 ! 90 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * ! DO 100 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 ! 100 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * ! DO 110 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 ! 110 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * ! DO 120 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 ! 120 CONTINUE END IF END IF ! 130 CONTINUE * ! 140 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * ! 150 CONTINUE * IF( L.EQ.I ) THEN * *************** *** 420,433 **** END IF END IF * ! * Decrement number of remaining iterations, and return to start of ! * the main loop with new value of I. * - ITN = ITN - ITS I = L - 1 ! GO TO 10 * ! 150 CONTINUE RETURN * * End of DLAHQR --- 488,499 ---- END IF END IF * ! * return to start of the main loop with new value of I. * I = L - 1 ! GO TO 20 * ! 160 CONTINUE RETURN * * End of DLAHQR diff -cNr octave-2.9.15/libcruft/lapack/dlahr2.f octave-2.9.16/libcruft/lapack/dlahr2.f *** octave-2.9.15/libcruft/lapack/dlahr2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlahr2.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,238 ---- + SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB + * .. + * .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) + * .. + * + * Purpose + * ======= + * + * DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) + * matrix A so that elements below the k-th subdiagonal are zero. The + * reduction is performed by an orthogonal similarity transformation + * Q' * A * Q. The routine returns the matrices V and T which determine + * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. + * + * This is an auxiliary routine called by DGEHRD. + * + * Arguments + * ========= + * + * N (input) INTEGER + * The order of the matrix A. + * + * K (input) INTEGER + * The offset for the reduction. Elements below the k-th + * subdiagonal in the first NB columns are reduced to zero. + * K < N. + * + * NB (input) INTEGER + * The number of columns to be reduced. + * + * A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) + * On entry, the n-by-(n-k+1) general matrix A. + * On exit, the elements on and above the k-th subdiagonal in + * the first NB columns are overwritten with the corresponding + * elements of the reduced matrix; the elements below the k-th + * subdiagonal, with the array TAU, represent the matrix Q as a + * product of elementary reflectors. The other columns of A are + * unchanged. See Further Details. + * + * LDA (input) INTEGER + * The leading dimension of the array A. LDA >= max(1,N). + * + * TAU (output) DOUBLE PRECISION array, dimension (NB) + * The scalar factors of the elementary reflectors. See Further + * Details. + * + * T (output) DOUBLE PRECISION array, dimension (LDT,NB) + * The upper triangular matrix T. + * + * LDT (input) INTEGER + * The leading dimension of the array T. LDT >= NB. + * + * Y (output) DOUBLE PRECISION array, dimension (LDY,NB) + * The n-by-nb matrix Y. + * + * LDY (input) INTEGER + * The leading dimension of the array Y. LDY >= N. + * + * Further Details + * =============== + * + * The matrix Q is represented as a product of nb elementary reflectors + * + * Q = H(1) H(2) . . . H(nb). + * + * Each H(i) has the form + * + * H(i) = I - tau * v * v' + * + * where tau is a real scalar, and v is a real vector with + * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in + * A(i+k+1:n,i), and tau in TAU(i). + * + * The elements of the vectors v together form the (n-k+1)-by-nb matrix + * V which is needed, with T and Y, to apply the transformation to the + * unreduced part of the matrix, using an update of the form: + * A := (I - V*T*V') * (A - Y*V'). + * + * The contents of A on exit are illustrated by the following example + * with n = 7, k = 3 and nb = 2: + * + * ( a a a a a ) + * ( a a a a a ) + * ( a a a a a ) + * ( h h a a a ) + * ( v1 h a a a ) + * ( v1 v2 a a a ) + * ( v1 v2 a a a ) + * + * where a denotes an element of the original matrix A, h denotes a + * modified element of the upper Hessenberg matrix H, and vi denotes an + * element of the vector defining H(i). + * + * This file is a slight modification of LAPACK-3.0's DLAHRD + * incorporating improvements proposed by Quintana-Orti and Van de + * Gejin. Note that the entries of A(1:K,2:NB) differ from those + * returned by the original LAPACK routine. This function is + * not backward compatible with LAPACK3.0. + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER I + DOUBLE PRECISION EI + * .. + * .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, + $ DLARFG, DSCAL, DTRMM, DTRMV + * .. + * .. Intrinsic Functions .. + INTRINSIC MIN + * .. + * .. Executable Statements .. + * + * Quick return if possible + * + IF( N.LE.1 ) + $ RETURN + * + DO 10 I = 1, NB + IF( I.GT.1 ) THEN + * + * Update A(K+1:N,I) + * + * Update I-th column of A - Y * V' + * + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) + * + * Apply I - V * T' * V' to this column (call it b) from the + * left, using the last column of T as workspace + * + * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) + * ( V2 ) ( b2 ) + * + * where V1 is unit lower triangular + * + * w := V1' * b1 + * + CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL DTRMV( 'Lower', 'Transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) + * + * w := w + V2'*b2 + * + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) + * + * w := T'*w + * + CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) + * + * b2 := b2 - V2*w + * + CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) + * + * b1 := b1 - V1*w + * + CALL DTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) + * + A( K+I-1, I-1 ) = EI + END IF + * + * Generate the elementary reflector H(I) to annihilate + * A(K+I+1:N,I) + * + CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE + * + * Compute Y(K+1:N,I) + * + CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) + * + * Compute T(1:I,I) + * + CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + * + 10 CONTINUE + A( K+NB, NB ) = EI + * + * Compute Y(1:K,1:NB) + * + CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) + * + RETURN + * + * End of DLAHR2 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlahrd.f octave-2.9.16/libcruft/lapack/dlahrd.f *** octave-2.9.15/libcruft/lapack/dlahrd.f Wed Nov 3 14:54:23 1999 --- octave-2.9.16/libcruft/lapack/dlahrd.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB --- 1,8 ---- SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB *************** *** 22,28 **** * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * ! * This is an auxiliary routine called by DGEHRD. * * Arguments * ========= --- 21,29 ---- * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * ! * This is an OBSOLETE auxiliary routine. ! * This routine will be 'deprecated' in a future release. ! * Please use the new routine DLAHR2 instead. * * Arguments * ========= diff -cNr octave-2.9.15/libcruft/lapack/dlaln2.f octave-2.9.16/libcruft/lapack/dlaln2.f *** octave-2.9.15/libcruft/lapack/dlaln2.f Wed Nov 3 14:54:23 1999 --- octave-2.9.16/libcruft/lapack/dlaln2.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. LOGICAL LTRANS --- 1,9 ---- SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL LTRANS diff -cNr octave-2.9.15/libcruft/lapack/dlals0.f octave-2.9.16/libcruft/lapack/dlals0.f *** octave-2.9.15/libcruft/lapack/dlals0.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlals0.f Fri Oct 26 11:52:57 2007 *************** *** 0 **** --- 1,377 ---- + SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, + $ LDGNUM, NL, NR, NRHS, SQRE + DOUBLE PRECISION C, S + * .. + * .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), PERM( * ) + DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ), + $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), + $ POLES( LDGNUM, * ), WORK( * ), Z( * ) + * .. + * + * Purpose + * ======= + * + * DLALS0 applies back the multiplying factors of either the left or the + * right singular vector matrix of a diagonal matrix appended by a row + * to the right hand side matrix B in solving the least squares problem + * using the divide-and-conquer SVD approach. + * + * For the left singular vector matrix, three types of orthogonal + * matrices are involved: + * + * (1L) Givens rotations: the number of such rotations is GIVPTR; the + * pairs of columns/rows they were applied to are stored in GIVCOL; + * and the C- and S-values of these rotations are stored in GIVNUM. + * + * (2L) Permutation. The (NL+1)-st row of B is to be moved to the first + * row, and for J=2:N, PERM(J)-th row of B is to be moved to the + * J-th row. + * + * (3L) The left singular vector matrix of the remaining matrix. + * + * For the right singular vector matrix, four types of orthogonal + * matrices are involved: + * + * (1R) The right singular vector matrix of the remaining matrix. + * + * (2R) If SQRE = 1, one extra Givens rotation to generate the right + * null space. + * + * (3R) The inverse transformation of (2L). + * + * (4R) The inverse transformation of (1L). + * + * Arguments + * ========= + * + * ICOMPQ (input) INTEGER + * Specifies whether singular vectors are to be computed in + * factored form: + * = 0: Left singular vector matrix. + * = 1: Right singular vector matrix. + * + * NL (input) INTEGER + * The row dimension of the upper block. NL >= 1. + * + * NR (input) INTEGER + * The row dimension of the lower block. NR >= 1. + * + * SQRE (input) INTEGER + * = 0: the lower block is an NR-by-NR square matrix. + * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + * + * The bidiagonal matrix has row dimension N = NL + NR + 1, + * and column dimension M = N + SQRE. + * + * NRHS (input) INTEGER + * The number of columns of B and BX. NRHS must be at least 1. + * + * B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) + * On input, B contains the right hand sides of the least + * squares problem in rows 1 through M. On output, B contains + * the solution X in rows 1 through N. + * + * LDB (input) INTEGER + * The leading dimension of B. LDB must be at least + * max(1,MAX( M, N ) ). + * + * BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) + * + * LDBX (input) INTEGER + * The leading dimension of BX. + * + * PERM (input) INTEGER array, dimension ( N ) + * The permutations (from deflation and sorting) applied + * to the two blocks. + * + * GIVPTR (input) INTEGER + * The number of Givens rotations which took place in this + * subproblem. + * + * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) + * Each pair of numbers indicates a pair of rows/columns + * involved in a Givens rotation. + * + * LDGCOL (input) INTEGER + * The leading dimension of GIVCOL, must be at least N. + * + * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + * Each number indicates the C or S value used in the + * corresponding Givens rotation. + * + * LDGNUM (input) INTEGER + * The leading dimension of arrays DIFR, POLES and + * GIVNUM, must be at least K. + * + * POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + * On entry, POLES(1:K, 1) contains the new singular + * values obtained from solving the secular equation, and + * POLES(1:K, 2) is an array containing the poles in the secular + * equation. + * + * DIFL (input) DOUBLE PRECISION array, dimension ( K ). + * On entry, DIFL(I) is the distance between I-th updated + * (undeflated) singular value and the I-th (undeflated) old + * singular value. + * + * DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). + * On entry, DIFR(I, 1) contains the distances between I-th + * updated (undeflated) singular value and the I+1-th + * (undeflated) old singular value. And DIFR(I, 2) is the + * normalizing factor for the I-th right singular vector. + * + * Z (input) DOUBLE PRECISION array, dimension ( K ) + * Contain the components of the deflation-adjusted updating row + * vector. + * + * K (input) INTEGER + * Contains the dimension of the non-deflated matrix, + * This is the order of the related secular equation. 1 <= K <=N. + * + * C (input) DOUBLE PRECISION + * C contains garbage if SQRE =0 and the C-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * S (input) DOUBLE PRECISION + * S contains garbage if SQRE =0 and the S-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * WORK (workspace) DOUBLE PRECISION array, dimension ( K ) + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ONE, ZERO, NEGONE + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 ) + * .. + * .. Local Scalars .. + INTEGER I, J, M, N, NLP1 + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL, + $ XERBLA + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 + * .. + * .. Intrinsic Functions .. + INTRINSIC MAX + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + END IF + * + N = NL + NR + 1 + * + IF( NRHS.LT.1 ) THEN + INFO = -5 + ELSE IF( LDB.LT.N ) THEN + INFO = -7 + ELSE IF( LDBX.LT.N ) THEN + INFO = -9 + ELSE IF( GIVPTR.LT.0 ) THEN + INFO = -11 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -13 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -15 + ELSE IF( K.LT.1 ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALS0', -INFO ) + RETURN + END IF + * + M = N + SQRE + NLP1 = NL + 1 + * + IF( ICOMPQ.EQ.0 ) THEN + * + * Apply back orthogonal transformations from the left. + * + * Step (1L): apply back the Givens rotations performed. + * + DO 10 I = 1, GIVPTR + CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ GIVNUM( I, 1 ) ) + 10 CONTINUE + * + * Step (2L): permute rows of B. + * + CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX ) + DO 20 I = 2, N + CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX ) + 20 CONTINUE + * + * Step (3L): apply the inverse of the left singular vector + * matrix to BX. + * + IF( K.EQ.1 ) THEN + CALL DCOPY( NRHS, BX, LDBX, B, LDB ) + IF( Z( 1 ).LT.ZERO ) THEN + CALL DSCAL( NRHS, NEGONE, B, LDB ) + END IF + ELSE + DO 50 J = 1, K + DIFLJ = DIFL( J ) + DJ = POLES( J, 1 ) + DSIGJ = -POLES( J, 2 ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -POLES( J+1, 2 ) + END IF + IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) ) + $ THEN + WORK( J ) = ZERO + ELSE + WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ / + $ ( POLES( J, 2 )+DJ ) + END IF + DO 30 I = 1, J - 1 + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJ )- + $ DIFLJ ) / ( POLES( I, 2 )+DJ ) + END IF + 30 CONTINUE + DO 40 I = J + 1, K + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJP )+ + $ DIFRJ ) / ( POLES( I, 2 )+DJ ) + END IF + 40 CONTINUE + WORK( 1 ) = NEGONE + TEMP = DNRM2( K, WORK, 1 ) + CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, + $ B( J, 1 ), LDB ) + CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ), + $ LDB, INFO ) + 50 CONTINUE + END IF + * + * Move the deflated rows of BX to B also. + * + IF( K.LT.MAX( M, N ) ) + $ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX, + $ B( K+1, 1 ), LDB ) + ELSE + * + * Apply back the right orthogonal transformations. + * + * Step (1R): apply back the new right singular vector matrix + * to B. + * + IF( K.EQ.1 ) THEN + CALL DCOPY( NRHS, B, LDB, BX, LDBX ) + ELSE + DO 80 J = 1, K + DSIGJ = POLES( J, 2 ) + IF( Z( J ).EQ.ZERO ) THEN + WORK( J ) = ZERO + ELSE + WORK( J ) = -Z( J ) / DIFL( J ) / + $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 ) + END IF + DO 60 I = 1, J - 1 + IF( Z( J ).EQ.ZERO ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1, + $ 2 ) )-DIFR( I, 1 ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 60 CONTINUE + DO 70 I = J + 1, K + IF( Z( J ).EQ.ZERO ) THEN + WORK( I ) = ZERO + ELSE + WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I, + $ 2 ) )-DIFL( I ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 70 CONTINUE + CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, + $ BX( J, 1 ), LDBX ) + 80 CONTINUE + END IF + * + * Step (2R): if SQRE = 1, apply back the rotation that is + * related to the right null space of the subproblem. + * + IF( SQRE.EQ.1 ) THEN + CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX ) + CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S ) + END IF + IF( K.LT.MAX( M, N ) ) + $ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ), + $ LDBX ) + * + * Step (3R): permute rows of B. + * + CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB ) + IF( SQRE.EQ.1 ) THEN + CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB ) + END IF + DO 90 I = 2, N + CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB ) + 90 CONTINUE + * + * Step (4R): apply back the Givens rotations performed. + * + DO 100 I = GIVPTR, 1, -1 + CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ -GIVNUM( I, 1 ) ) + 100 CONTINUE + END IF + * + RETURN + * + * End of DLALS0 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlalsa.f octave-2.9.16/libcruft/lapack/dlalsa.f *** octave-2.9.15/libcruft/lapack/dlalsa.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlalsa.f Fri Oct 26 11:52:57 2007 *************** *** 0 **** --- 1,362 ---- + SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, + $ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, + $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, + $ IWORK, INFO ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, + $ SMLSIZ + * .. + * .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ), + $ DIFL( LDU, * ), DIFR( LDU, * ), + $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), + $ U( LDU, * ), VT( LDU, * ), WORK( * ), + $ Z( LDU, * ) + * .. + * + * Purpose + * ======= + * + * DLALSA is an itermediate step in solving the least squares problem + * by computing the SVD of the coefficient matrix in compact form (The + * singular vectors are computed as products of simple orthorgonal + * matrices.). + * + * If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector + * matrix of an upper bidiagonal matrix to the right hand side; and if + * ICOMPQ = 1, DLALSA applies the right singular vector matrix to the + * right hand side. The singular vector matrices were generated in + * compact form by DLALSA. + * + * Arguments + * ========= + * + * + * ICOMPQ (input) INTEGER + * Specifies whether the left or the right singular vector + * matrix is involved. + * = 0: Left singular vector matrix + * = 1: Right singular vector matrix + * + * SMLSIZ (input) INTEGER + * The maximum size of the subproblems at the bottom of the + * computation tree. + * + * N (input) INTEGER + * The row and column dimensions of the upper bidiagonal matrix. + * + * NRHS (input) INTEGER + * The number of columns of B and BX. NRHS must be at least 1. + * + * B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) + * On input, B contains the right hand sides of the least + * squares problem in rows 1 through M. + * On output, B contains the solution X in rows 1 through N. + * + * LDB (input) INTEGER + * The leading dimension of B in the calling subprogram. + * LDB must be at least max(1,MAX( M, N ) ). + * + * BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) + * On exit, the result of applying the left or right singular + * vector matrix to B. + * + * LDBX (input) INTEGER + * The leading dimension of BX. + * + * U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). + * On entry, U contains the left singular vector matrices of all + * subproblems at the bottom level. + * + * LDU (input) INTEGER, LDU = > N. + * The leading dimension of arrays U, VT, DIFL, DIFR, + * POLES, GIVNUM, and Z. + * + * VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). + * On entry, VT' contains the right singular vector matrices of + * all subproblems at the bottom level. + * + * K (input) INTEGER array, dimension ( N ). + * + * DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). + * where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. + * + * DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). + * On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record + * distances between singular values on the I-th level and + * singular values on the (I -1)-th level, and DIFR(*, 2 * I) + * record the normalizing factors of the right singular vectors + * matrices of subproblems on I-th level. + * + * Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). + * On entry, Z(1, I) contains the components of the deflation- + * adjusted updating row vector for subproblems on the I-th + * level. + * + * POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). + * On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old + * singular values involved in the secular equations on the I-th + * level. + * + * GIVPTR (input) INTEGER array, dimension ( N ). + * On entry, GIVPTR( I ) records the number of Givens + * rotations performed on the I-th problem on the computation + * tree. + * + * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). + * On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the + * locations of Givens rotations performed on the I-th level on + * the computation tree. + * + * LDGCOL (input) INTEGER, LDGCOL = > N. + * The leading dimension of arrays GIVCOL and PERM. + * + * PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). + * On entry, PERM(*, I) records permutations done on the I-th + * level of the computation tree. + * + * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). + * On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- + * values of Givens rotations performed on the I-th level on the + * computation tree. + * + * C (input) DOUBLE PRECISION array, dimension ( N ). + * On entry, if the I-th subproblem is not square, + * C( I ) contains the C-value of a Givens rotation related to + * the right null space of the I-th subproblem. + * + * S (input) DOUBLE PRECISION array, dimension ( N ). + * On entry, if the I-th subproblem is not square, + * S( I ) contains the S-value of a Givens rotation related to + * the right null space of the I-th subproblem. + * + * WORK (workspace) DOUBLE PRECISION array. + * The dimension must be at least N. + * + * IWORK (workspace) INTEGER array. + * The dimension must be at least 3 * N + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + * .. + * .. Local Scalars .. + INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2, + $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL, + $ NR, NRF, NRP1, SQRE + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.SMLSIZ ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( LDB.LT.N ) THEN + INFO = -6 + ELSE IF( LDBX.LT.N ) THEN + INFO = -8 + ELSE IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALSA', -INFO ) + RETURN + END IF + * + * Book-keeping and setting up the computation tree. + * + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + * + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) + * + * The following code applies back the left singular vector factors. + * For applying back the right singular vector factors, go to 50. + * + IF( ICOMPQ.EQ.1 ) THEN + GO TO 50 + END IF + * + * The nodes on the bottom level of the tree were solved + * by DLASDQ. The corresponding left and right singular vector + * matrices are in explicit form. First apply back the left + * singular vector matrices. + * + NDB1 = ( ND+1 ) / 2 + DO 10 I = NDB1, ND + * + * IC : center row of each node + * NL : number of rows of left subproblem + * NR : number of rows of right subproblem + * NLF: starting row of the left subproblem + * NRF: starting row of the right subproblem + * + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, + $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, + $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + 10 CONTINUE + * + * Next copy the rows of B that correspond to unchanged rows + * in the bidiagonal matrix to BX. + * + DO 20 I = 1, ND + IC = IWORK( INODE+I-1 ) + CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX ) + 20 CONTINUE + * + * Finally go through the left singular vector matrices of all + * the other subproblems bottom-up on the tree. + * + J = 2**NLVL + SQRE = 0 + * + DO 40 LVL = NLVL, 1, -1 + LVL2 = 2*LVL - 1 + * + * find the first node LF and last node LL on + * the current level LVL + * + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 30 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + J = J - 1 + CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX, + $ B( NLF, 1 ), LDB, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, + $ INFO ) + 30 CONTINUE + 40 CONTINUE + GO TO 90 + * + * ICOMPQ = 1: applying back the right singular vector factors. + * + 50 CONTINUE + * + * First now go through the right singular vector matrices of all + * the tree nodes top-down. + * + J = 0 + DO 70 LVL = 1, NLVL + LVL2 = 2*LVL - 1 + * + * Find the first node LF and last node LL on + * the current level LVL. + * + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 60 I = LL, LF, -1 + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQRE = 0 + ELSE + SQRE = 1 + END IF + J = J + 1 + CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB, + $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, + $ INFO ) + 60 CONTINUE + 70 CONTINUE + * + * The nodes on the bottom level of the tree were solved + * by DLASDQ. The corresponding right singular vector + * matrices are in explicit form. Apply them back. + * + NDB1 = ( ND+1 ) / 2 + DO 80 I = NDB1, ND + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLP1 = NL + 1 + IF( I.EQ.ND ) THEN + NRP1 = NR + ELSE + NRP1 = NR + 1 + END IF + NLF = IC - NL + NRF = IC + 1 + CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, + $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, + $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + 80 CONTINUE + * + 90 CONTINUE + * + RETURN + * + * End of DLALSA + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlalsd.f octave-2.9.16/libcruft/lapack/dlalsd.f *** octave-2.9.15/libcruft/lapack/dlalsd.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlalsd.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,434 ---- + SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, + $ RANK, WORK, IWORK, INFO ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ + DOUBLE PRECISION RCOND + * .. + * .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * DLALSD uses the singular value decomposition of A to solve the least + * squares problem of finding X to minimize the Euclidean norm of each + * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B + * are N-by-NRHS. The solution X overwrites B. + * + * The singular values of A smaller than RCOND times the largest + * singular value are treated as zero in solving the least squares + * problem; in this case a minimum norm solution is returned. + * The actual singular values are returned in D in ascending order. + * + * This code makes very mild assumptions about floating point + * arithmetic. It will work on machines with a guard digit in + * add/subtract, or on those binary machines without guard digits + * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. + * It could conceivably fail on hexadecimal or decimal machines + * without guard digits, but we know of none. + * + * Arguments + * ========= + * + * UPLO (input) CHARACTER*1 + * = 'U': D and E define an upper bidiagonal matrix. + * = 'L': D and E define a lower bidiagonal matrix. + * + * SMLSIZ (input) INTEGER + * The maximum size of the subproblems at the bottom of the + * computation tree. + * + * N (input) INTEGER + * The dimension of the bidiagonal matrix. N >= 0. + * + * NRHS (input) INTEGER + * The number of columns of B. NRHS must be at least 1. + * + * D (input/output) DOUBLE PRECISION array, dimension (N) + * On entry D contains the main diagonal of the bidiagonal + * matrix. On exit, if INFO = 0, D contains its singular values. + * + * E (input/output) DOUBLE PRECISION array, dimension (N-1) + * Contains the super-diagonal entries of the bidiagonal matrix. + * On exit, E has been destroyed. + * + * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) + * On input, B contains the right hand sides of the least + * squares problem. On output, B contains the solution X. + * + * LDB (input) INTEGER + * The leading dimension of B in the calling subprogram. + * LDB must be at least max(1,N). + * + * RCOND (input) DOUBLE PRECISION + * The singular values of A less than or equal to RCOND times + * the largest singular value are treated as zero in solving + * the least squares problem. If RCOND is negative, + * machine precision is used instead. + * For example, if diag(S)*X=B were the least squares problem, + * where diag(S) is a diagonal matrix of singular values, the + * solution would be X(i) = B(i) / S(i) if S(i) is greater than + * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to + * RCOND*max(S). + * + * RANK (output) INTEGER + * The number of singular values of A greater than RCOND times + * the largest singular value. + * + * WORK (workspace) DOUBLE PRECISION array, dimension at least + * (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), + * where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). + * + * IWORK (workspace) INTEGER array, dimension at least + * (3*N*NLVL + 11*N) + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: The algorithm failed to compute an singular value while + * working on the submatrix lying in rows and columns + * INFO/(N+1) through MOD(INFO,N+1). + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + * .. + * .. Local Scalars .. + INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM, + $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL, + $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI, + $ SMLSZP, SQRE, ST, ST1, U, VT, Z + DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL + * .. + * .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL IDAMAX, DLAMCH, DLANST + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL, + $ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG, SIGN + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLALSD', -INFO ) + RETURN + END IF + * + EPS = DLAMCH( 'Epsilon' ) + * + * Set up the tolerance. + * + IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN + RCND = EPS + ELSE + RCND = RCOND + END IF + * + RANK = 0 + * + * Quick return if possible. + * + IF( N.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN + IF( D( 1 ).EQ.ZERO ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB ) + ELSE + RANK = 1 + CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO ) + D( 1 ) = ABS( D( 1 ) ) + END IF + RETURN + END IF + * + * Rotate the matrix if it is lower bidiagonal. + * + IF( UPLO.EQ.'L' ) THEN + DO 10 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( NRHS.EQ.1 ) THEN + CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN ) + ELSE + WORK( I*2-1 ) = CS + WORK( I*2 ) = SN + END IF + 10 CONTINUE + IF( NRHS.GT.1 ) THEN + DO 30 I = 1, NRHS + DO 20 J = 1, N - 1 + CS = WORK( J*2-1 ) + SN = WORK( J*2 ) + CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN ) + 20 CONTINUE + 30 CONTINUE + END IF + END IF + * + * Scale. + * + NM1 = N - 1 + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.EQ.ZERO ) THEN + CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB ) + RETURN + END IF + * + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO ) + * + * If N is smaller than the minimum divide size SMLSIZ, then solve + * the problem with another solver. + * + IF( N.LE.SMLSIZ ) THEN + NWORK = 1 + N*N + CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N ) + CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B, + $ LDB, WORK( NWORK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) + DO 40 I = 1, N + IF( D( I ).LE.TOL ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) + ELSE + CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ), + $ LDB, INFO ) + RANK = RANK + 1 + END IF + 40 CONTINUE + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, + $ WORK( NWORK ), N ) + CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB ) + * + * Unscale. + * + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) + * + RETURN + END IF + * + * Book-keeping and setting up some constants. + * + NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 + * + SMLSZP = SMLSIZ + 1 + * + U = 1 + VT = 1 + SMLSIZ*N + DIFL = VT + SMLSZP*N + DIFR = DIFL + NLVL*N + Z = DIFR + NLVL*N*2 + C = Z + NLVL*N + S = C + N + POLES = S + N + GIVNUM = POLES + 2*NLVL*N + BX = GIVNUM + 2*NLVL*N + NWORK = BX + N*NRHS + * + SIZEI = 1 + N + K = SIZEI + N + GIVPTR = K + N + PERM = GIVPTR + N + GIVCOL = PERM + NLVL*N + IWK = GIVCOL + NLVL*N*2 + * + ST = 1 + SQRE = 0 + ICMPQ1 = 1 + ICMPQ2 = 0 + NSUB = 0 + * + DO 50 I = 1, N + IF( ABS( D( I ) ).LT.EPS ) THEN + D( I ) = SIGN( EPS, D( I ) ) + END IF + 50 CONTINUE + * + DO 60 I = 1, NM1 + IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN + NSUB = NSUB + 1 + IWORK( NSUB ) = ST + * + * Subproblem found. First determine its size and then + * apply divide and conquer on it. + * + IF( I.LT.NM1 ) THEN + * + * A subproblem with E(I) small for I < NM1. + * + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE IF( ABS( E( I ) ).GE.EPS ) THEN + * + * A subproblem with E(NM1) not too small but I = NM1. + * + NSIZE = N - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE + * + * A subproblem with E(NM1) small. This implies an + * 1-by-1 subproblem at D(N), which is not solved + * explicitly. + * + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + NSUB = NSUB + 1 + IWORK( NSUB ) = N + IWORK( SIZEI+NSUB-1 ) = 1 + CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N ) + END IF + ST1 = ST - 1 + IF( NSIZE.EQ.1 ) THEN + * + * This is a 1-by-1 subproblem and is not solved + * explicitly. + * + CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN + * + * This is a small subproblem and is solved by DLASDQ. + * + CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, + $ WORK( VT+ST1 ), N ) + CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ), + $ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ), + $ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB, + $ WORK( BX+ST1 ), N ) + ELSE + * + * A large problem. Solve it using divide and conquer. + * + CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ), + $ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ), + $ IWORK( K+ST1 ), WORK( DIFL+ST1 ), + $ WORK( DIFR+ST1 ), WORK( Z+ST1 ), + $ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ), + $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ), + $ WORK( GIVNUM+ST1 ), WORK( C+ST1 ), + $ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ), + $ INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + BXST = BX + ST1 + CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ), + $ LDB, WORK( BXST ), N, WORK( U+ST1 ), N, + $ WORK( VT+ST1 ), IWORK( K+ST1 ), + $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), + $ WORK( Z+ST1 ), WORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), + $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), + $ IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + ST = I + 1 + END IF + 60 CONTINUE + * + * Apply the singular values and treat the tiny ones as zero. + * + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) + * + DO 70 I = 1, N + * + * Some of the elements in D can be negative because 1-by-1 + * subproblems were not solved explicitly. + * + IF( ABS( D( I ) ).LE.TOL ) THEN + CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N ) + ELSE + RANK = RANK + 1 + CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, + $ WORK( BX+I-1 ), N, INFO ) + END IF + D( I ) = ABS( D( I ) ) + 70 CONTINUE + * + * Now apply back the right singular vectors. + * + ICMPQ2 = 1 + DO 80 I = 1, NSUB + ST = IWORK( I ) + ST1 = ST - 1 + NSIZE = IWORK( SIZEI+I-1 ) + BXST = BX + ST1 + IF( NSIZE.EQ.1 ) THEN + CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN + CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + $ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO, + $ B( ST, 1 ), LDB ) + ELSE + CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N, + $ B( ST, 1 ), LDB, WORK( U+ST1 ), N, + $ WORK( VT+ST1 ), IWORK( K+ST1 ), + $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), + $ WORK( Z+ST1 ), WORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), + $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), + $ IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + 80 CONTINUE + * + * Unscale and sort the singular values. + * + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) + * + RETURN + * + * End of DLALSD + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlamc1.f octave-2.9.16/libcruft/lapack/dlamc1.f *** octave-2.9.15/libcruft/lapack/dlamc1.f Thu Nov 4 11:24:30 1999 --- octave-2.9.16/libcruft/lapack/dlamc1.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE1, RND --- 1,8 ---- SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL IEEE1, RND *************** *** 68,74 **** * .. Executable Statements .. * IF( FIRST ) THEN - FIRST = .FALSE. ONE = 1 * * LBETA, LIEEE1, LT and LRND are the local values of BETA, --- 67,72 ---- *************** *** 177,182 **** --- 175,181 ---- T = LT RND = LRND IEEE1 = LIEEE1 + FIRST = .FALSE. RETURN * * End of DLAMC1 diff -cNr octave-2.9.15/libcruft/lapack/dlamc2.f octave-2.9.16/libcruft/lapack/dlamc2.f *** octave-2.9.15/libcruft/lapack/dlamc2.f Thu Nov 4 11:24:31 1999 --- octave-2.9.16/libcruft/lapack/dlamc2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. LOGICAL RND --- 1,8 ---- SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL RND *************** *** 90,96 **** * .. Executable Statements .. * IF( FIRST ) THEN - FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 --- 89,94 ---- *************** *** 204,209 **** --- 202,208 ---- * ( A guess; no known machine ) IWARN = .TRUE. END IF + FIRST = .FALSE. *** * Comment out this if block if EMIN is ok IF( IWARN ) THEN diff -cNr octave-2.9.15/libcruft/lapack/dlamc3.f octave-2.9.16/libcruft/lapack/dlamc3.f *** octave-2.9.15/libcruft/lapack/dlamc3.f Thu Nov 4 11:24:31 1999 --- octave-2.9.16/libcruft/lapack/dlamc3.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B --- 1,8 ---- DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B *************** *** 19,25 **** * Arguments * ========= * ! * A, B (input) DOUBLE PRECISION * The values A and B. * * ===================================================================== --- 18,25 ---- * Arguments * ========= * ! * A (input) DOUBLE PRECISION ! * B (input) DOUBLE PRECISION * The values A and B. * * ===================================================================== diff -cNr octave-2.9.15/libcruft/lapack/dlamc4.f octave-2.9.16/libcruft/lapack/dlamc4.f *** octave-2.9.15/libcruft/lapack/dlamc4.f Thu Nov 4 11:24:31 1999 --- octave-2.9.16/libcruft/lapack/dlamc4.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLAMC4( EMIN, START, BASE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. INTEGER BASE, EMIN --- 1,8 ---- SUBROUTINE DLAMC4( EMIN, START, BASE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER BASE, EMIN *************** *** 18,24 **** * Arguments * ========= * ! * EMIN (output) EMIN * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered. --- 17,23 ---- * Arguments * ========= * ! * EMIN (output) INTEGER * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered. diff -cNr octave-2.9.15/libcruft/lapack/dlamc5.f octave-2.9.16/libcruft/lapack/dlamc5.f *** octave-2.9.15/libcruft/lapack/dlamc5.f Thu Nov 4 11:24:31 1999 --- octave-2.9.16/libcruft/lapack/dlamc5.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE --- 1,8 ---- SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL IEEE diff -cNr octave-2.9.15/libcruft/lapack/dlamch.f octave-2.9.16/libcruft/lapack/dlamch.f *** octave-2.9.15/libcruft/lapack/dlamch.f Thu Nov 4 11:24:31 1999 --- octave-2.9.16/libcruft/lapack/dlamch.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER CMACH --- 1,8 ---- DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER CMACH *************** *** 72,78 **** * .. Executable Statements .. * IF( FIRST ) THEN - FIRST = .FALSE. CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT --- 71,76 ---- *************** *** 120,125 **** --- 118,124 ---- END IF * DLAMCH = RMACH + FIRST = .FALSE. RETURN * * End of DLAMCH diff -cNr octave-2.9.15/libcruft/lapack/dlamrg.f octave-2.9.16/libcruft/lapack/dlamrg.f *** octave-2.9.15/libcruft/lapack/dlamrg.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlamrg.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,103 ---- + SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER DTRD1, DTRD2, N1, N2 + * .. + * .. Array Arguments .. + INTEGER INDEX( * ) + DOUBLE PRECISION A( * ) + * .. + * + * Purpose + * ======= + * + * DLAMRG will create a permutation list which will merge the elements + * of A (which is composed of two independently sorted sets) into a + * single set which is sorted in ascending order. + * + * Arguments + * ========= + * + * N1 (input) INTEGER + * N2 (input) INTEGER + * These arguements contain the respective lengths of the two + * sorted lists to be merged. + * + * A (input) DOUBLE PRECISION array, dimension (N1+N2) + * The first N1 elements of A contain a list of numbers which + * are sorted in either ascending or descending order. Likewise + * for the final N2 elements. + * + * DTRD1 (input) INTEGER + * DTRD2 (input) INTEGER + * These are the strides to be taken through the array A. + * Allowable strides are 1 and -1. They indicate whether a + * subset of A is sorted in ascending (DTRDx = 1) or descending + * (DTRDx = -1) order. + * + * INDEX (output) INTEGER array, dimension (N1+N2) + * On exit this array will contain a permutation such that + * if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be + * sorted in ascending order. + * + * ===================================================================== + * + * .. Local Scalars .. + INTEGER I, IND1, IND2, N1SV, N2SV + * .. + * .. Executable Statements .. + * + N1SV = N1 + N2SV = N2 + IF( DTRD1.GT.0 ) THEN + IND1 = 1 + ELSE + IND1 = N1 + END IF + IF( DTRD2.GT.0 ) THEN + IND2 = 1 + N1 + ELSE + IND2 = N1 + N2 + END IF + I = 1 + * while ( (N1SV > 0) & (N2SV > 0) ) + 10 CONTINUE + IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN + IF( A( IND1 ).LE.A( IND2 ) ) THEN + INDEX( I ) = IND1 + I = I + 1 + IND1 = IND1 + DTRD1 + N1SV = N1SV - 1 + ELSE + INDEX( I ) = IND2 + I = I + 1 + IND2 = IND2 + DTRD2 + N2SV = N2SV - 1 + END IF + GO TO 10 + END IF + * end while + IF( N1SV.EQ.0 ) THEN + DO 20 N1SV = 1, N2SV + INDEX( I ) = IND2 + I = I + 1 + IND2 = IND2 + DTRD2 + 20 CONTINUE + ELSE + * N2SV .EQ. 0 + DO 30 N2SV = 1, N1SV + INDEX( I ) = IND1 + I = I + 1 + IND1 = IND1 + DTRD1 + 30 CONTINUE + END IF + * + RETURN + * + * End of DLAMRG + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlange.f octave-2.9.16/libcruft/lapack/dlange.f *** octave-2.9.15/libcruft/lapack/dlange.f Wed Nov 3 14:54:23 1999 --- octave-2.9.16/libcruft/lapack/dlange.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM --- 1,8 ---- DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER NORM *************** *** 36,42 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 35,41 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 59,65 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * --- 58,64 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * diff -cNr octave-2.9.15/libcruft/lapack/dlanhs.f octave-2.9.16/libcruft/lapack/dlanhs.f *** octave-2.9.15/libcruft/lapack/dlanhs.f Wed Nov 3 14:54:24 1999 --- octave-2.9.16/libcruft/lapack/dlanhs.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM --- 1,8 ---- DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER NORM *************** *** 36,42 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 35,41 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 56,62 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * --- 55,61 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * diff -cNr octave-2.9.15/libcruft/lapack/dlanst.f octave-2.9.16/libcruft/lapack/dlanst.f *** octave-2.9.15/libcruft/lapack/dlanst.f Wed Nov 3 14:54:24 1999 --- octave-2.9.16/libcruft/lapack/dlanst.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER NORM --- 1,8 ---- DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER NORM *************** *** 36,42 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 35,41 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= diff -cNr octave-2.9.15/libcruft/lapack/dlansy.f octave-2.9.16/libcruft/lapack/dlansy.f *** octave-2.9.15/libcruft/lapack/dlansy.f Wed Nov 3 14:54:24 1999 --- octave-2.9.16/libcruft/lapack/dlansy.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM, UPLO --- 1,8 ---- DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER NORM, UPLO *************** *** 36,42 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 35,41 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 67,73 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * --- 66,72 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * diff -cNr octave-2.9.15/libcruft/lapack/dlantr.f octave-2.9.16/libcruft/lapack/dlantr.f *** octave-2.9.15/libcruft/lapack/dlantr.f Mon May 22 01:45:46 2006 --- octave-2.9.16/libcruft/lapack/dlantr.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO --- 1,9 ---- DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO *************** *** 37,43 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 36,42 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 79,85 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * --- 78,84 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * diff -cNr octave-2.9.15/libcruft/lapack/dlanv2.f octave-2.9.16/libcruft/lapack/dlanv2.f *** octave-2.9.15/libcruft/lapack/dlanv2.f Wed Nov 3 14:54:24 1999 --- octave-2.9.16/libcruft/lapack/dlanv2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN --- 1,8 ---- SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN diff -cNr octave-2.9.15/libcruft/lapack/dlapy2.f octave-2.9.16/libcruft/lapack/dlapy2.f *** octave-2.9.15/libcruft/lapack/dlapy2.f Wed Nov 3 14:54:24 1999 --- octave-2.9.16/libcruft/lapack/dlapy2.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y --- 1,8 ---- DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y diff -cNr octave-2.9.15/libcruft/lapack/dlapy3.f octave-2.9.16/libcruft/lapack/dlapy3.f *** octave-2.9.15/libcruft/lapack/dlapy3.f Wed Nov 3 14:54:25 1999 --- octave-2.9.16/libcruft/lapack/dlapy3.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z --- 1,8 ---- DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z *************** *** 42,48 **** ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN ! DLAPY3 = ZERO ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) --- 41,50 ---- ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN ! * W can be zero for max(0,nan,0) ! * adding all three entries together will make sure ! * NaN will not disappear. ! DLAPY3 = XABS + YABS + ZABS ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) diff -cNr octave-2.9.15/libcruft/lapack/dlaqr0.f octave-2.9.16/libcruft/lapack/dlaqr0.f *** octave-2.9.15/libcruft/lapack/dlaqr0.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlaqr0.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,642 ---- + SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) + * .. + * + * Purpose + * ======= + * + * DLAQR0 computes the eigenvalues of a Hessenberg matrix H + * and, optionally, the matrices T and Z from the Schur decomposition + * H = Z T Z**T, where T is an upper quasi-triangular matrix (the + * Schur form), and Z is the orthogonal matrix of Schur vectors. + * + * Optionally Z may be postmultiplied into an input orthogonal + * matrix Q so that this routine can give the Schur factorization + * of a matrix A which has been reduced to the Hessenberg form H + * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. + * + * Arguments + * ========= + * + * WANTT (input) LOGICAL + * = .TRUE. : the full Schur form T is required; + * = .FALSE.: only eigenvalues are required. + * + * WANTZ (input) LOGICAL + * = .TRUE. : the matrix of Schur vectors Z is required; + * = .FALSE.: Schur vectors are not required. + * + * N (input) INTEGER + * The order of the matrix H. N .GE. 0. + * + * ILO (input) INTEGER + * IHI (input) INTEGER + * It is assumed that H is already upper triangular in rows + * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, + * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a + * previous call to DGEBAL, and then passed to DGEHRD when the + * matrix output by DGEBAL is reduced to Hessenberg form. + * Otherwise, ILO and IHI should be set to 1 and N, + * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. + * If N = 0, then ILO = 1 and IHI = 0. + * + * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) + * On entry, the upper Hessenberg matrix H. + * On exit, if INFO = 0 and WANTT is .TRUE., then H contains + * the upper quasi-triangular matrix T from the Schur + * decomposition (the Schur form); 2-by-2 diagonal blocks + * (corresponding to complex conjugate pairs of eigenvalues) + * are returned in standard form, with H(i,i) = H(i+1,i+1) + * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is + * .FALSE., then the contents of H are unspecified on exit. + * (The output value of H when INFO.GT.0 is given under the + * description of INFO below.) + * + * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and + * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. + * + * LDH (input) INTEGER + * The leading dimension of the array H. LDH .GE. max(1,N). + * + * WR (output) DOUBLE PRECISION array, dimension (IHI) + * WI (output) DOUBLE PRECISION array, dimension (IHI) + * The real and imaginary parts, respectively, of the computed + * eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) + * and WI(ILO:IHI). If two eigenvalues are computed as a + * complex conjugate pair, they are stored in consecutive + * elements of WR and WI, say the i-th and (i+1)th, with + * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then + * the eigenvalues are stored in the same order as on the + * diagonal of the Schur form returned in H, with + * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal + * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and + * WI(i+1) = -WI(i). + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. + * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. + * + * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) + * If WANTZ is .FALSE., then Z is not referenced. + * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is + * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the + * orthogonal Schur factor of H(ILO:IHI,ILO:IHI). + * (The output value of Z when INFO.GT.0 is given under + * the description of INFO below.) + * + * LDZ (input) INTEGER + * The leading dimension of the array Z. if WANTZ is .TRUE. + * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. + * + * WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK + * On exit, if LWORK = -1, WORK(1) returns an estimate of + * the optimal value for LWORK. + * + * LWORK (input) INTEGER + * The dimension of the array WORK. LWORK .GE. max(1,N) + * is sufficient, but LWORK typically as large as 6*N may + * be required for optimal performance. A workspace query + * to determine the optimal workspace size is recommended. + * + * If LWORK = -1, then DLAQR0 does a workspace query. + * In this case, DLAQR0 checks the input parameters and + * estimates the optimal workspace size for the given + * values of N, ILO and IHI. The estimate is returned + * in WORK(1). No error message related to LWORK is + * issued by XERBLA. Neither H nor Z are accessed. + * + * + * INFO (output) INTEGER + * = 0: successful exit + * .GT. 0: if INFO = i, DLAQR0 failed to compute all of + * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR + * and WI contain those eigenvalues which have been + * successfully computed. (Failures are rare.) + * + * If INFO .GT. 0 and WANT is .FALSE., then on exit, + * the remaining unconverged eigenvalues are the eigen- + * values of the upper Hessenberg matrix rows and + * columns ILO through INFO of the final, output + * value of H. + * + * If INFO .GT. 0 and WANTT is .TRUE., then on exit + * + * (*) (initial value of H)*U = U*(final value of H) + * + * where U is an orthogonal matrix. The final + * value of H is upper Hessenberg and quasi-triangular + * in rows and columns INFO+1 through IHI. + * + * If INFO .GT. 0 and WANTZ is .TRUE., then on exit + * + * (final value of Z(ILO:IHI,ILOZ:IHIZ) + * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U + * + * where U is the orthogonal matrix in (*) (regard- + * less of the value of WANTT.) + * + * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not + * accessed. + * + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================ + * + * References: + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + * Performance, SIAM Journal of Matrix Analysis, volume 23, pages + * 929--947, 2002. + * + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part II: Aggressive Early Deflation, SIAM Journal + * of Matrix Analysis, volume 23, pages 948--973, 2002. + * + * ================================================================ + * .. Parameters .. + * + * ==== Matrices of order NTINY or smaller must be processed by + * . DLAHQR because of insufficient subdiagonal scratch space. + * . (This is a hard limit.) ==== + * + * ==== Exceptional deflation windows: try to cure rare + * . slow convergence by increasing the size of the + * . deflation window after KEXNW iterations. ===== + * + * ==== Exceptional shifts: try to cure rare slow convergence + * . with ad-hoc exceptional shifts every KEXSH iterations. + * . The constants WILK1 and WILK2 are used to form the + * . exceptional shifts. ==== + * + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) + * .. + * .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 + * .. + * .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV + * .. + * .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) + * .. + * .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5 + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD + * .. + * .. Executable Statements .. + INFO = 0 + * + * ==== Quick return for N = 0: nothing to do. ==== + * + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF + * + * ==== Set up job flags for ILAENV. ==== + * + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF + * + * ==== Tiny matrices must use DLAHQR. ==== + * + IF( N.LE.NTINY ) THEN + * + * ==== Estimate optimal workspace. ==== + * + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE + * + * ==== Use small bulge multi-shift QR with aggressive early + * . deflation on larger-than-tiny matrices. ==== + * + * ==== Hope for the best. ==== + * + INFO = 0 + * + * ==== NWR = recommended deflation window size. At this + * . point, N .GT. NTINY = 11, so there is enough + * . subdiagonal workspace for NWR.GE.2 as required. + * . (In fact, there is enough subdiagonal space for + * . NWR.GE.3.) ==== + * + NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR + * + * ==== NSR = recommended number of simultaneous shifts. + * . At this point N .GT. NTINY = 11, so there is at + * . enough subdiagonal workspace for NSR to be even + * . and greater than or equal to two as required. ==== + * + NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) + * + * ==== Estimate optimal workspace ==== + * + * ==== Workspace query call to DLAQR3 ==== + * + CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) + * + * ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== + * + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF + * + * ==== DLAHQR/DLAQR0 crossover point ==== + * + NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) + * + * ==== Nibble crossover point ==== + * + NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) + * + * ==== Accumulate reflections during ttswp? Use block + * . 2-by-2 structure during matrix-matrix multiply? ==== + * + KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) + * + * ==== NWMAX = the largest possible deflation window for + * . which there is sufficient workspace. ==== + * + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + * + * ==== NSMAX = the Largest number of simultaneous shifts + * . for which there is sufficient workspace. ==== + * + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) + * + * ==== NDFL: an iteration count restarted at deflation. ==== + * + NDFL = 1 + * + * ==== ITMAX = iteration limit ==== + * + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) + * + * ==== Last row and column in the active block ==== + * + KBOT = IHI + * + * ==== Main Loop ==== + * + DO 80 IT = 1, ITMAX + * + * ==== Done when KBOT falls below ILO ==== + * + IF( KBOT.LT.ILO ) + $ GO TO 90 + * + * ==== Locate active block ==== + * + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K + * + * ==== Select deflation window size ==== + * + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN + * + * ==== Typical deflation window. If possible and + * . advisable, nibble the entire active block. + * . If not, use size NWR or NWR+1 depending upon + * . which has the smaller corresponding subdiagonal + * . entry (a heuristic). ==== + * + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE + * + * ==== Exceptional deflation window. If there have + * . been no deflations in KEXNW or more iterations, + * . then vary the deflation window size. At first, + * . because, larger windows are, in general, more + * . powerful than smaller ones, rapidly increase the + * . window up to the maximum reasonable and possible. + * . Then maybe try a slightly smaller window. ==== + * + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF + * + * ==== Aggressive early deflation: + * . split workspace under the subdiagonal into + * . - an nw-by-nw work array V in the lower + * . left-hand-corner, + * . - an NW-by-at-least-NW-but-more-is-better + * . (NW-by-NHO) horizontal work array along + * . the bottom edge, + * . - an at-least-NW-but-more-is-better (NHV-by-NW) + * . vertical work array along the left-hand-edge. + * . ==== + * + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 + * + * ==== Aggressive early deflation ==== + * + CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) + * + * ==== Adjust KBOT accounting for new deflations. ==== + * + KBOT = KBOT - LD + * + * ==== KS points to the shifts. ==== + * + KS = KBOT - LS + 1 + * + * ==== Skip an expensive QR sweep if there is a (partly + * . heuristic) reason to expect that many eigenvalues + * . will deflate without it. Here, the QR sweep is + * . skipped if many eigenvalues have just been deflated + * . or if the remaining active block is small. + * + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN + * + * ==== NS = nominal number of simultaneous shifts. + * . This may be lowered (slightly) if DLAQR3 + * . did not provide that many shifts. ==== + * + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) + * + * ==== If there have been no deflations + * . in a multiple of KEXSH iterations, + * . then try exceptional shifts. + * . Otherwise use shifts provided by + * . DLAQR3 above or from the eigenvalues + * . of a trailing principal submatrix. ==== + * + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + ELSE + * + * ==== Got NS/2 or fewer shifts? Use DLAQR4 or + * . DLAHQR on a trailing principal submatrix to + * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, + * . there is enough space below the subdiagonal + * . to fit an NS-by-NS scratch array.) ==== + * + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL DLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, WORK, + $ LWORK, INF ) + ELSE + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, INF ) + END IF + KS = KS + INF + * + * ==== In case of a rare QR failure use + * . eigenvalues of the trailing 2-by-2 + * . principal submatrix. ==== + * + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF + * + IF( KBOT-KS+1.GT.NS ) THEN + * + * ==== Sort the shifts (Helps a little) + * . Bubble sort keeps complex conjugate + * . pairs together. ==== + * + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + SORTED = .false. + * + SWAP = WR( I ) + WR( I ) = WR( I+1 ) + WR( I+1 ) = SWAP + * + SWAP = WI( I ) + WI( I ) = WI( I+1 ) + WI( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + * + * ==== Shuffle shifts into pairs of real shifts + * . and pairs of complex conjugate shifts + * . assuming complex conjugate shifts are + * . already adjacent to one another. (Yes, + * . they are.) ==== + * + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN + * + SWAP = WR( I ) + WR( I ) = WR( I-1 ) + WR( I-1 ) = WR( I-2 ) + WR( I-2 ) = SWAP + * + SWAP = WI( I ) + WI( I ) = WI( I-1 ) + WI( I-1 ) = WI( I-2 ) + WI( I-2 ) = SWAP + END IF + 70 CONTINUE + END IF + * + * ==== If there are only two shifts and both are + * . real, then use only one. ==== + * + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF + * + * ==== Use up to NS of the the smallest magnatiude + * . shifts. If there aren't NS shifts available, + * . then use them all, possibly dropping one to + * . make the number of shifts even. ==== + * + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 + * + * ==== Small-bulge multi-shift QR sweep: + * . split workspace under the subdiagonal into + * . - a KDU-by-KDU work array U in the lower + * . left-hand-corner, + * . - a KDU-by-at-least-KDU-but-more-is-better + * . (KDU-by-NHo) horizontal work array WH along + * . the bottom edge, + * . - and an at-least-KDU-but-more-is-better-by-KDU + * . (NVE-by-KDU) vertical work WV arrow along + * . the left-hand-edge. ==== + * + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 + * + * ==== Small-bulge multi-shift QR sweep ==== + * + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF + * + * ==== Note progress (or the lack of it). ==== + * + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF + * + * ==== End of main loop ==== + 80 CONTINUE + * + * ==== Iteration limit exceeded. Set INFO to show where + * . the problem occurred and exit. ==== + * + INFO = KBOT + 90 CONTINUE + END IF + * + * ==== Return the optimal value of LWORK. ==== + * + WORK( 1 ) = DBLE( LWKOPT ) + * + * ==== End of DLAQR0 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlaqr1.f octave-2.9.16/libcruft/lapack/dlaqr1.f *** octave-2.9.15/libcruft/lapack/dlaqr1.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlaqr1.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,97 ---- + SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + DOUBLE PRECISION SI1, SI2, SR1, SR2 + INTEGER LDH, N + * .. + * .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), V( * ) + * .. + * + * Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a + * scalar multiple of the first column of the product + * + * (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) + * + * scaling to avoid overflows and most underflows. It + * is assumed that either + * + * 1) sr1 = sr2 and si1 = -si2 + * or + * 2) si1 = si2 = 0. + * + * This is useful for starting double implicit shift bulges + * in the QR algorithm. + * + * + * N (input) integer + * Order of the matrix H. N must be either 2 or 3. + * + * H (input) DOUBLE PRECISION array of dimension (LDH,N) + * The 2-by-2 or 3-by-3 matrix H in (*). + * + * LDH (input) integer + * The leading dimension of H as declared in + * the calling procedure. LDH.GE.N + * + * SR1 (input) DOUBLE PRECISION + * SI1 The shifts in (*). + * SR2 + * SI2 + * + * V (output) DOUBLE PRECISION array of dimension N + * A scalar multiple of the first column of the + * matrix K in (*). + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================ + * + * .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0d0 ) + * .. + * .. Local Scalars .. + DOUBLE PRECISION H21S, H31S, S + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS + * .. + * .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* + $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + END IF + ELSE + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + + $ ABS( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - + $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + + $ H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + + $ H21S*H( 3, 2 ) + END IF + END IF + END diff -cNr octave-2.9.15/libcruft/lapack/dlaqr2.f octave-2.9.16/libcruft/lapack/dlaqr2.f *** octave-2.9.15/libcruft/lapack/dlaqr2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlaqr2.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,551 ---- + SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) + * .. + * + * This subroutine is identical to DLAQR3 except that it avoids + * recursion by calling DLAHQR instead of DLAQR4. + * + * + * ****************************************************************** + * Aggressive early deflation: + * + * This subroutine accepts as input an upper Hessenberg matrix + * H and performs an orthogonal similarity transformation + * designed to detect and deflate fully converged eigenvalues from + * a trailing principal submatrix. On output H has been over- + * written by a new Hessenberg matrix that is a perturbation of + * an orthogonal similarity transformation of H. It is to be + * hoped that the final version of H has many zero subdiagonal + * entries. + * + * ****************************************************************** + * WANTT (input) LOGICAL + * If .TRUE., then the Hessenberg matrix H is fully updated + * so that the quasi-triangular Schur factor may be + * computed (in cooperation with the calling subroutine). + * If .FALSE., then only enough of H is updated to preserve + * the eigenvalues. + * + * WANTZ (input) LOGICAL + * If .TRUE., then the orthogonal matrix Z is updated so + * so that the orthogonal Schur factor may be computed + * (in cooperation with the calling subroutine). + * If .FALSE., then Z is not referenced. + * + * N (input) INTEGER + * The order of the matrix H and (if WANTZ is .TRUE.) the + * order of the orthogonal matrix Z. + * + * KTOP (input) INTEGER + * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. + * KBOT and KTOP together determine an isolated block + * along the diagonal of the Hessenberg matrix. + * + * KBOT (input) INTEGER + * It is assumed without a check that either + * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together + * determine an isolated block along the diagonal of the + * Hessenberg matrix. + * + * NW (input) INTEGER + * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). + * + * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) + * On input the initial N-by-N section of H stores the + * Hessenberg matrix undergoing aggressive early deflation. + * On output H has been transformed by an orthogonal + * similarity transformation, perturbed, and the returned + * to Hessenberg form that (it is to be hoped) has some + * zero subdiagonal entries. + * + * LDH (input) integer + * Leading dimension of H just as declared in the calling + * subroutine. N .LE. LDH + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. + * + * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) + * IF WANTZ is .TRUE., then on output, the orthogonal + * similarity transformation mentioned above has been + * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. + * If WANTZ is .FALSE., then Z is unreferenced. + * + * LDZ (input) integer + * The leading dimension of Z just as declared in the + * calling subroutine. 1 .LE. LDZ. + * + * NS (output) integer + * The number of unconverged (ie approximate) eigenvalues + * returned in SR and SI that may be used as shifts by the + * calling subroutine. + * + * ND (output) integer + * The number of converged eigenvalues uncovered by this + * subroutine. + * + * SR (output) DOUBLE PRECISION array, dimension KBOT + * SI (output) DOUBLE PRECISION array, dimension KBOT + * On output, the real and imaginary parts of approximate + * eigenvalues that may be used for shifts are stored in + * SR(KBOT-ND-NS+1) through SR(KBOT-ND) and + * SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. + * The real and imaginary parts of converged eigenvalues + * are stored in SR(KBOT-ND+1) through SR(KBOT) and + * SI(KBOT-ND+1) through SI(KBOT), respectively. + * + * V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) + * An NW-by-NW work array. + * + * LDV (input) integer scalar + * The leading dimension of V just as declared in the + * calling subroutine. NW .LE. LDV + * + * NH (input) integer scalar + * The number of columns of T. NH.GE.NW. + * + * T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) + * + * LDT (input) integer + * The leading dimension of T just as declared in the + * calling subroutine. NW .LE. LDT + * + * NV (input) integer + * The number of rows of work array WV available for + * workspace. NV.GE.NW. + * + * WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) + * + * LDWV (input) integer + * The leading dimension of W just as declared in the + * calling subroutine. NW .LE. LDV + * + * WORK (workspace) DOUBLE PRECISION array, dimension LWORK. + * On exit, WORK(1) is set to an estimate of the optimal value + * of LWORK for the given values of N, NW, KTOP and KBOT. + * + * LWORK (input) integer + * The dimension of the work array WORK. LWORK = 2*NW + * suffices, but greater efficiency may result from larger + * values of LWORK. + * + * If LWORK = -1, then a workspace query is assumed; DLAQR2 + * only estimates the optimal workspace size for the given + * values of N, NW, KTOP and KBOT. The estimate is returned + * in WORK(1). No error message related to LWORK is issued + * by XERBLA. Neither H nor Z are accessed. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================ + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) + * .. + * .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, + $ LWKOPT + LOGICAL BULGE, SORTED + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLARF, DLARFG, DLASET, DORGHR, DTREXC + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT + * .. + * .. Executable Statements .. + * + * ==== Estimate optimal workspace. ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE + * + * ==== Workspace query call to DGEHRD ==== + * + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) + * + * ==== Workspace query call to DORGHR ==== + * + CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) + * + * ==== Optimal workspace ==== + * + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF + * + * ==== Nothing to do ... + * ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN + * ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN + * + * ==== Machine constants ==== + * + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) + * + * ==== Setup deflation window ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF + * + IF( KBOT.EQ.KWTOP ) THEN + * + * ==== 1-by-1 deflation window: not much to do ==== + * + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF + * + * ==== Convert to spike-triangular form. (In case of a + * . rare QR failure, this routine continues to do + * . aggressive early deflation using that part of + * . the deflation window that converged using INFQR + * . here and there to keep track.) ==== + * + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + * + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) + * + * ==== DTREXC needs a clean margin near the diagonal ==== + * + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO + * + * ==== Deflation detection loop ==== + * + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF + * + * ==== Small spike tip test for deflation ==== + * + IF( .NOT.BULGE ) THEN + * + * ==== Real eigenvalue ==== + * + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN + * + * ==== Deflatable ==== + * + NS = NS - 1 + ELSE + * + * ==== Undeflatable. Move it up out of the way. + * . (DTREXC can not fail in this case.) ==== + * + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE + * + * ==== Complex conjugate pair ==== + * + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN + * + * ==== Deflatable ==== + * + NS = NS - 2 + ELSE + * + * ==== Undflatable. Move them up out of the way. + * . Fortunately, DTREXC does the right thing with + * . ILST in case of a rare exchange failure. ==== + * + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF + * + * ==== End deflation detection loop ==== + * + GO TO 20 + END IF + * + * ==== Return to Hessenberg form ==== + * + IF( NS.EQ.0 ) + $ S = ZERO + * + IF( NS.LT.JW ) THEN + * + * ==== sorting diagonal blocks of T improves accuracy for + * . graded matrices. Bubble sort deals well with + * . exchange failures. ==== + * + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. + * + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF + * + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF + * + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF + * + * ==== Restore shift/eigenvalue array from T ==== + * + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF + * + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + * + * ==== Reflect spike back into lower triangle ==== + * + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE + * + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + * + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) + * + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF + * + * ==== Copy updated reduced window into place ==== + * + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) + * + * ==== Accumulate orthogonal matrix in order update + * . H and Z, if requested. (A modified version + * . of DORGHR that accumulates block Householder + * . transformations into V directly might be + * . marginally more efficient than the following.) ==== + * + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF + * + * ==== Update vertical slab in H ==== + * + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE + * + * ==== Update horizontal slab in H ==== + * + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF + * + * ==== Update vertical slab in Z ==== + * + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF + * + * ==== Return the number of deflations ... ==== + * + ND = JW - NS + * + * ==== ... and the number of shifts. (Subtracting + * . INFQR from the spike length takes care + * . of the case of a rare QR failure while + * . calculating eigenvalues of the deflation + * . window.) ==== + * + NS = NS - INFQR + * + * ==== Return optimal workspace. ==== + * + WORK( 1 ) = DBLE( LWKOPT ) + * + * ==== End of DLAQR2 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlaqr3.f octave-2.9.16/libcruft/lapack/dlaqr3.f *** octave-2.9.15/libcruft/lapack/dlaqr3.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlaqr3.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,561 ---- + SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) + * .. + * + * ****************************************************************** + * Aggressive early deflation: + * + * This subroutine accepts as input an upper Hessenberg matrix + * H and performs an orthogonal similarity transformation + * designed to detect and deflate fully converged eigenvalues from + * a trailing principal submatrix. On output H has been over- + * written by a new Hessenberg matrix that is a perturbation of + * an orthogonal similarity transformation of H. It is to be + * hoped that the final version of H has many zero subdiagonal + * entries. + * + * ****************************************************************** + * WANTT (input) LOGICAL + * If .TRUE., then the Hessenberg matrix H is fully updated + * so that the quasi-triangular Schur factor may be + * computed (in cooperation with the calling subroutine). + * If .FALSE., then only enough of H is updated to preserve + * the eigenvalues. + * + * WANTZ (input) LOGICAL + * If .TRUE., then the orthogonal matrix Z is updated so + * so that the orthogonal Schur factor may be computed + * (in cooperation with the calling subroutine). + * If .FALSE., then Z is not referenced. + * + * N (input) INTEGER + * The order of the matrix H and (if WANTZ is .TRUE.) the + * order of the orthogonal matrix Z. + * + * KTOP (input) INTEGER + * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. + * KBOT and KTOP together determine an isolated block + * along the diagonal of the Hessenberg matrix. + * + * KBOT (input) INTEGER + * It is assumed without a check that either + * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together + * determine an isolated block along the diagonal of the + * Hessenberg matrix. + * + * NW (input) INTEGER + * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). + * + * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) + * On input the initial N-by-N section of H stores the + * Hessenberg matrix undergoing aggressive early deflation. + * On output H has been transformed by an orthogonal + * similarity transformation, perturbed, and the returned + * to Hessenberg form that (it is to be hoped) has some + * zero subdiagonal entries. + * + * LDH (input) integer + * Leading dimension of H just as declared in the calling + * subroutine. N .LE. LDH + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. + * + * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) + * IF WANTZ is .TRUE., then on output, the orthogonal + * similarity transformation mentioned above has been + * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. + * If WANTZ is .FALSE., then Z is unreferenced. + * + * LDZ (input) integer + * The leading dimension of Z just as declared in the + * calling subroutine. 1 .LE. LDZ. + * + * NS (output) integer + * The number of unconverged (ie approximate) eigenvalues + * returned in SR and SI that may be used as shifts by the + * calling subroutine. + * + * ND (output) integer + * The number of converged eigenvalues uncovered by this + * subroutine. + * + * SR (output) DOUBLE PRECISION array, dimension KBOT + * SI (output) DOUBLE PRECISION array, dimension KBOT + * On output, the real and imaginary parts of approximate + * eigenvalues that may be used for shifts are stored in + * SR(KBOT-ND-NS+1) through SR(KBOT-ND) and + * SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. + * The real and imaginary parts of converged eigenvalues + * are stored in SR(KBOT-ND+1) through SR(KBOT) and + * SI(KBOT-ND+1) through SI(KBOT), respectively. + * + * V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) + * An NW-by-NW work array. + * + * LDV (input) integer scalar + * The leading dimension of V just as declared in the + * calling subroutine. NW .LE. LDV + * + * NH (input) integer scalar + * The number of columns of T. NH.GE.NW. + * + * T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) + * + * LDT (input) integer + * The leading dimension of T just as declared in the + * calling subroutine. NW .LE. LDT + * + * NV (input) integer + * The number of rows of work array WV available for + * workspace. NV.GE.NW. + * + * WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) + * + * LDWV (input) integer + * The leading dimension of W just as declared in the + * calling subroutine. NW .LE. LDV + * + * WORK (workspace) DOUBLE PRECISION array, dimension LWORK. + * On exit, WORK(1) is set to an estimate of the optimal value + * of LWORK for the given values of N, NW, KTOP and KBOT. + * + * LWORK (input) integer + * The dimension of the work array WORK. LWORK = 2*NW + * suffices, but greater efficiency may result from larger + * values of LWORK. + * + * If LWORK = -1, then a workspace query is assumed; DLAQR3 + * only estimates the optimal workspace size for the given + * values of N, NW, KTOP and KBOT. The estimate is returned + * in WORK(1). No error message related to LWORK is issued + * by XERBLA. Neither H nor Z are accessed. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================== + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) + * .. + * .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN + LOGICAL BULGE, SORTED + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORGHR, + $ DTREXC + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT + * .. + * .. Executable Statements .. + * + * ==== Estimate optimal workspace. ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE + * + * ==== Workspace query call to DGEHRD ==== + * + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) + * + * ==== Workspace query call to DORGHR ==== + * + CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) + * + * ==== Workspace query call to DLAQR4 ==== + * + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, + $ V, LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) + * + * ==== Optimal workspace ==== + * + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF + * + * ==== Nothing to do ... + * ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN + * ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN + * + * ==== Machine constants ==== + * + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) + * + * ==== Setup deflation window ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF + * + IF( KBOT.EQ.KWTOP ) THEN + * + * ==== 1-by-1 deflation window: not much to do ==== + * + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF + * + * ==== Convert to spike-triangular form. (In case of a + * . rare QR failure, this routine continues to do + * . aggressive early deflation using that part of + * . the deflation window that converged using INFQR + * . here and there to keep track.) ==== + * + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + * + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) + END IF + * + * ==== DTREXC needs a clean margin near the diagonal ==== + * + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO + * + * ==== Deflation detection loop ==== + * + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF + * + * ==== Small spike tip test for deflation ==== + * + IF( .NOT.BULGE ) THEN + * + * ==== Real eigenvalue ==== + * + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN + * + * ==== Deflatable ==== + * + NS = NS - 1 + ELSE + * + * ==== Undeflatable. Move it up out of the way. + * . (DTREXC can not fail in this case.) ==== + * + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE + * + * ==== Complex conjugate pair ==== + * + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN + * + * ==== Deflatable ==== + * + NS = NS - 2 + ELSE + * + * ==== Undflatable. Move them up out of the way. + * . Fortunately, DTREXC does the right thing with + * . ILST in case of a rare exchange failure. ==== + * + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF + * + * ==== End deflation detection loop ==== + * + GO TO 20 + END IF + * + * ==== Return to Hessenberg form ==== + * + IF( NS.EQ.0 ) + $ S = ZERO + * + IF( NS.LT.JW ) THEN + * + * ==== sorting diagonal blocks of T improves accuracy for + * . graded matrices. Bubble sort deals well with + * . exchange failures. ==== + * + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. + * + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF + * + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF + * + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF + * + * ==== Restore shift/eigenvalue array from T ==== + * + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF + * + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + * + * ==== Reflect spike back into lower triangle ==== + * + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE + * + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + * + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) + * + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF + * + * ==== Copy updated reduced window into place ==== + * + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) + * + * ==== Accumulate orthogonal matrix in order update + * . H and Z, if requested. (A modified version + * . of DORGHR that accumulates block Householder + * . transformations into V directly might be + * . marginally more efficient than the following.) ==== + * + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF + * + * ==== Update vertical slab in H ==== + * + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE + * + * ==== Update horizontal slab in H ==== + * + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF + * + * ==== Update vertical slab in Z ==== + * + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF + * + * ==== Return the number of deflations ... ==== + * + ND = JW - NS + * + * ==== ... and the number of shifts. (Subtracting + * . INFQR from the spike length takes care + * . of the case of a rare QR failure while + * . calculating eigenvalues of the deflation + * . window.) ==== + * + NS = NS - INFQR + * + * ==== Return optimal workspace. ==== + * + WORK( 1 ) = DBLE( LWKOPT ) + * + * ==== End of DLAQR3 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlaqr4.f octave-2.9.16/libcruft/lapack/dlaqr4.f *** octave-2.9.15/libcruft/lapack/dlaqr4.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlaqr4.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,640 ---- + SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) + * .. + * + * This subroutine implements one level of recursion for DLAQR0. + * It is a complete implementation of the small bulge multi-shift + * QR algorithm. It may be called by DLAQR0 and, for large enough + * deflation window size, it may be called by DLAQR3. This + * subroutine is identical to DLAQR0 except that it calls DLAQR2 + * instead of DLAQR3. + * + * Purpose + * ======= + * + * DLAQR4 computes the eigenvalues of a Hessenberg matrix H + * and, optionally, the matrices T and Z from the Schur decomposition + * H = Z T Z**T, where T is an upper quasi-triangular matrix (the + * Schur form), and Z is the orthogonal matrix of Schur vectors. + * + * Optionally Z may be postmultiplied into an input orthogonal + * matrix Q so that this routine can give the Schur factorization + * of a matrix A which has been reduced to the Hessenberg form H + * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. + * + * Arguments + * ========= + * + * WANTT (input) LOGICAL + * = .TRUE. : the full Schur form T is required; + * = .FALSE.: only eigenvalues are required. + * + * WANTZ (input) LOGICAL + * = .TRUE. : the matrix of Schur vectors Z is required; + * = .FALSE.: Schur vectors are not required. + * + * N (input) INTEGER + * The order of the matrix H. N .GE. 0. + * + * ILO (input) INTEGER + * IHI (input) INTEGER + * It is assumed that H is already upper triangular in rows + * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, + * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a + * previous call to DGEBAL, and then passed to DGEHRD when the + * matrix output by DGEBAL is reduced to Hessenberg form. + * Otherwise, ILO and IHI should be set to 1 and N, + * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. + * If N = 0, then ILO = 1 and IHI = 0. + * + * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) + * On entry, the upper Hessenberg matrix H. + * On exit, if INFO = 0 and WANTT is .TRUE., then H contains + * the upper quasi-triangular matrix T from the Schur + * decomposition (the Schur form); 2-by-2 diagonal blocks + * (corresponding to complex conjugate pairs of eigenvalues) + * are returned in standard form, with H(i,i) = H(i+1,i+1) + * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is + * .FALSE., then the contents of H are unspecified on exit. + * (The output value of H when INFO.GT.0 is given under the + * description of INFO below.) + * + * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and + * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. + * + * LDH (input) INTEGER + * The leading dimension of the array H. LDH .GE. max(1,N). + * + * WR (output) DOUBLE PRECISION array, dimension (IHI) + * WI (output) DOUBLE PRECISION array, dimension (IHI) + * The real and imaginary parts, respectively, of the computed + * eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) + * and WI(ILO:IHI). If two eigenvalues are computed as a + * complex conjugate pair, they are stored in consecutive + * elements of WR and WI, say the i-th and (i+1)th, with + * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then + * the eigenvalues are stored in the same order as on the + * diagonal of the Schur form returned in H, with + * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal + * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and + * WI(i+1) = -WI(i). + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. + * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. + * + * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) + * If WANTZ is .FALSE., then Z is not referenced. + * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is + * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the + * orthogonal Schur factor of H(ILO:IHI,ILO:IHI). + * (The output value of Z when INFO.GT.0 is given under + * the description of INFO below.) + * + * LDZ (input) INTEGER + * The leading dimension of the array Z. if WANTZ is .TRUE. + * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. + * + * WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK + * On exit, if LWORK = -1, WORK(1) returns an estimate of + * the optimal value for LWORK. + * + * LWORK (input) INTEGER + * The dimension of the array WORK. LWORK .GE. max(1,N) + * is sufficient, but LWORK typically as large as 6*N may + * be required for optimal performance. A workspace query + * to determine the optimal workspace size is recommended. + * + * If LWORK = -1, then DLAQR4 does a workspace query. + * In this case, DLAQR4 checks the input parameters and + * estimates the optimal workspace size for the given + * values of N, ILO and IHI. The estimate is returned + * in WORK(1). No error message related to LWORK is + * issued by XERBLA. Neither H nor Z are accessed. + * + * + * INFO (output) INTEGER + * = 0: successful exit + * .GT. 0: if INFO = i, DLAQR4 failed to compute all of + * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR + * and WI contain those eigenvalues which have been + * successfully computed. (Failures are rare.) + * + * If INFO .GT. 0 and WANT is .FALSE., then on exit, + * the remaining unconverged eigenvalues are the eigen- + * values of the upper Hessenberg matrix rows and + * columns ILO through INFO of the final, output + * value of H. + * + * If INFO .GT. 0 and WANTT is .TRUE., then on exit + * + * (*) (initial value of H)*U = U*(final value of H) + * + * where U is an orthogonal matrix. The final + * value of H is upper Hessenberg and quasi-triangular + * in rows and columns INFO+1 through IHI. + * + * If INFO .GT. 0 and WANTZ is .TRUE., then on exit + * + * (final value of Z(ILO:IHI,ILOZ:IHIZ) + * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U + * + * where U is the orthogonal matrix in (*) (regard- + * less of the value of WANTT.) + * + * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not + * accessed. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================ + * References: + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + * Performance, SIAM Journal of Matrix Analysis, volume 23, pages + * 929--947, 2002. + * + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part II: Aggressive Early Deflation, SIAM Journal + * of Matrix Analysis, volume 23, pages 948--973, 2002. + * + * ================================================================ + * .. Parameters .. + * + * ==== Matrices of order NTINY or smaller must be processed by + * . DLAHQR because of insufficient subdiagonal scratch space. + * . (This is a hard limit.) ==== + * + * ==== Exceptional deflation windows: try to cure rare + * . slow convergence by increasing the size of the + * . deflation window after KEXNW iterations. ===== + * + * ==== Exceptional shifts: try to cure rare slow convergence + * . with ad-hoc exceptional shifts every KEXSH iterations. + * . The constants WILK1 and WILK2 are used to form the + * . exceptional shifts. ==== + * + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) + * .. + * .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 + * .. + * .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV + * .. + * .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) + * .. + * .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5 + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD + * .. + * .. Executable Statements .. + INFO = 0 + * + * ==== Quick return for N = 0: nothing to do. ==== + * + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF + * + * ==== Set up job flags for ILAENV. ==== + * + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF + * + * ==== Tiny matrices must use DLAHQR. ==== + * + IF( N.LE.NTINY ) THEN + * + * ==== Estimate optimal workspace. ==== + * + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE + * + * ==== Use small bulge multi-shift QR with aggressive early + * . deflation on larger-than-tiny matrices. ==== + * + * ==== Hope for the best. ==== + * + INFO = 0 + * + * ==== NWR = recommended deflation window size. At this + * . point, N .GT. NTINY = 11, so there is enough + * . subdiagonal workspace for NWR.GE.2 as required. + * . (In fact, there is enough subdiagonal space for + * . NWR.GE.3.) ==== + * + NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR + * + * ==== NSR = recommended number of simultaneous shifts. + * . At this point N .GT. NTINY = 11, so there is at + * . enough subdiagonal workspace for NSR to be even + * . and greater than or equal to two as required. ==== + * + NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) + * + * ==== Estimate optimal workspace ==== + * + * ==== Workspace query call to DLAQR2 ==== + * + CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) + * + * ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== + * + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF + * + * ==== DLAHQR/DLAQR0 crossover point ==== + * + NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) + * + * ==== Nibble crossover point ==== + * + NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) + * + * ==== Accumulate reflections during ttswp? Use block + * . 2-by-2 structure during matrix-matrix multiply? ==== + * + KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) + * + * ==== NWMAX = the largest possible deflation window for + * . which there is sufficient workspace. ==== + * + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + * + * ==== NSMAX = the Largest number of simultaneous shifts + * . for which there is sufficient workspace. ==== + * + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) + * + * ==== NDFL: an iteration count restarted at deflation. ==== + * + NDFL = 1 + * + * ==== ITMAX = iteration limit ==== + * + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) + * + * ==== Last row and column in the active block ==== + * + KBOT = IHI + * + * ==== Main Loop ==== + * + DO 80 IT = 1, ITMAX + * + * ==== Done when KBOT falls below ILO ==== + * + IF( KBOT.LT.ILO ) + $ GO TO 90 + * + * ==== Locate active block ==== + * + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K + * + * ==== Select deflation window size ==== + * + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN + * + * ==== Typical deflation window. If possible and + * . advisable, nibble the entire active block. + * . If not, use size NWR or NWR+1 depending upon + * . which has the smaller corresponding subdiagonal + * . entry (a heuristic). ==== + * + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE + * + * ==== Exceptional deflation window. If there have + * . been no deflations in KEXNW or more iterations, + * . then vary the deflation window size. At first, + * . because, larger windows are, in general, more + * . powerful than smaller ones, rapidly increase the + * . window up to the maximum reasonable and possible. + * . Then maybe try a slightly smaller window. ==== + * + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF + * + * ==== Aggressive early deflation: + * . split workspace under the subdiagonal into + * . - an nw-by-nw work array V in the lower + * . left-hand-corner, + * . - an NW-by-at-least-NW-but-more-is-better + * . (NW-by-NHO) horizontal work array along + * . the bottom edge, + * . - an at-least-NW-but-more-is-better (NHV-by-NW) + * . vertical work array along the left-hand-edge. + * . ==== + * + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 + * + * ==== Aggressive early deflation ==== + * + CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) + * + * ==== Adjust KBOT accounting for new deflations. ==== + * + KBOT = KBOT - LD + * + * ==== KS points to the shifts. ==== + * + KS = KBOT - LS + 1 + * + * ==== Skip an expensive QR sweep if there is a (partly + * . heuristic) reason to expect that many eigenvalues + * . will deflate without it. Here, the QR sweep is + * . skipped if many eigenvalues have just been deflated + * . or if the remaining active block is small. + * + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN + * + * ==== NS = nominal number of simultaneous shifts. + * . This may be lowered (slightly) if DLAQR2 + * . did not provide that many shifts. ==== + * + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) + * + * ==== If there have been no deflations + * . in a multiple of KEXSH iterations, + * . then try exceptional shifts. + * . Otherwise use shifts provided by + * . DLAQR2 above or from the eigenvalues + * . of a trailing principal submatrix. ==== + * + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + ELSE + * + * ==== Got NS/2 or fewer shifts? Use DLAHQR + * . on a trailing principal submatrix to + * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, + * . there is enough space below the subdiagonal + * . to fit an NS-by-NS scratch array.) ==== + * + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), + $ 1, 1, ZDUM, 1, INF ) + KS = KS + INF + * + * ==== In case of a rare QR failure use + * . eigenvalues of the trailing 2-by-2 + * . principal submatrix. ==== + * + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF + * + IF( KBOT-KS+1.GT.NS ) THEN + * + * ==== Sort the shifts (Helps a little) + * . Bubble sort keeps complex conjugate + * . pairs together. ==== + * + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + SORTED = .false. + * + SWAP = WR( I ) + WR( I ) = WR( I+1 ) + WR( I+1 ) = SWAP + * + SWAP = WI( I ) + WI( I ) = WI( I+1 ) + WI( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + * + * ==== Shuffle shifts into pairs of real shifts + * . and pairs of complex conjugate shifts + * . assuming complex conjugate shifts are + * . already adjacent to one another. (Yes, + * . they are.) ==== + * + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN + * + SWAP = WR( I ) + WR( I ) = WR( I-1 ) + WR( I-1 ) = WR( I-2 ) + WR( I-2 ) = SWAP + * + SWAP = WI( I ) + WI( I ) = WI( I-1 ) + WI( I-1 ) = WI( I-2 ) + WI( I-2 ) = SWAP + END IF + 70 CONTINUE + END IF + * + * ==== If there are only two shifts and both are + * . real, then use only one. ==== + * + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF + * + * ==== Use up to NS of the the smallest magnatiude + * . shifts. If there aren't NS shifts available, + * . then use them all, possibly dropping one to + * . make the number of shifts even. ==== + * + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 + * + * ==== Small-bulge multi-shift QR sweep: + * . split workspace under the subdiagonal into + * . - a KDU-by-KDU work array U in the lower + * . left-hand-corner, + * . - a KDU-by-at-least-KDU-but-more-is-better + * . (KDU-by-NHo) horizontal work array WH along + * . the bottom edge, + * . - and an at-least-KDU-but-more-is-better-by-KDU + * . (NVE-by-KDU) vertical work WV arrow along + * . the left-hand-edge. ==== + * + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 + * + * ==== Small-bulge multi-shift QR sweep ==== + * + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF + * + * ==== Note progress (or the lack of it). ==== + * + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF + * + * ==== End of main loop ==== + 80 CONTINUE + * + * ==== Iteration limit exceeded. Set INFO to show where + * . the problem occurred and exit. ==== + * + INFO = KBOT + 90 CONTINUE + END IF + * + * ==== Return the optimal value of LWORK. ==== + * + WORK( 1 ) = DBLE( LWKOPT ) + * + * ==== End of DLAQR4 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlaqr5.f octave-2.9.16/libcruft/lapack/dlaqr5.f *** octave-2.9.15/libcruft/lapack/dlaqr5.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlaqr5.f Tue Oct 16 14:54:20 2007 *************** *** 0 **** --- 1,812 ---- + SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, + $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, + $ LDU, NV, WV, LDWV, NH, WH, LDWH ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), + $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), + $ Z( LDZ, * ) + * .. + * + * This auxiliary subroutine called by DLAQR0 performs a + * single small-bulge multi-shift QR sweep. + * + * WANTT (input) logical scalar + * WANTT = .true. if the quasi-triangular Schur factor + * is being computed. WANTT is set to .false. otherwise. + * + * WANTZ (input) logical scalar + * WANTZ = .true. if the orthogonal Schur factor is being + * computed. WANTZ is set to .false. otherwise. + * + * KACC22 (input) integer with value 0, 1, or 2. + * Specifies the computation mode of far-from-diagonal + * orthogonal updates. + * = 0: DLAQR5 does not accumulate reflections and does not + * use matrix-matrix multiply to update far-from-diagonal + * matrix entries. + * = 1: DLAQR5 accumulates reflections and uses matrix-matrix + * multiply to update the far-from-diagonal matrix entries. + * = 2: DLAQR5 accumulates reflections, uses matrix-matrix + * multiply to update the far-from-diagonal matrix entries, + * and takes advantage of 2-by-2 block structure during + * matrix multiplies. + * + * N (input) integer scalar + * N is the order of the Hessenberg matrix H upon which this + * subroutine operates. + * + * KTOP (input) integer scalar + * KBOT (input) integer scalar + * These are the first and last rows and columns of an + * isolated diagonal block upon which the QR sweep is to be + * applied. It is assumed without a check that + * either KTOP = 1 or H(KTOP,KTOP-1) = 0 + * and + * either KBOT = N or H(KBOT+1,KBOT) = 0. + * + * NSHFTS (input) integer scalar + * NSHFTS gives the number of simultaneous shifts. NSHFTS + * must be positive and even. + * + * SR (input) DOUBLE PRECISION array of size (NSHFTS) + * SI (input) DOUBLE PRECISION array of size (NSHFTS) + * SR contains the real parts and SI contains the imaginary + * parts of the NSHFTS shifts of origin that define the + * multi-shift QR sweep. + * + * H (input/output) DOUBLE PRECISION array of size (LDH,N) + * On input H contains a Hessenberg matrix. On output a + * multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied + * to the isolated diagonal block in rows and columns KTOP + * through KBOT. + * + * LDH (input) integer scalar + * LDH is the leading dimension of H just as declared in the + * calling procedure. LDH.GE.MAX(1,N). + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N + * + * Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI) + * If WANTZ = .TRUE., then the QR Sweep orthogonal + * similarity transformation is accumulated into + * Z(ILOZ:IHIZ,ILO:IHI) from the right. + * If WANTZ = .FALSE., then Z is unreferenced. + * + * LDZ (input) integer scalar + * LDA is the leading dimension of Z just as declared in + * the calling procedure. LDZ.GE.N. + * + * V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2) + * + * LDV (input) integer scalar + * LDV is the leading dimension of V as declared in the + * calling procedure. LDV.GE.3. + * + * U (workspace) DOUBLE PRECISION array of size + * (LDU,3*NSHFTS-3) + * + * LDU (input) integer scalar + * LDU is the leading dimension of U just as declared in the + * in the calling subroutine. LDU.GE.3*NSHFTS-3. + * + * NH (input) integer scalar + * NH is the number of columns in array WH available for + * workspace. NH.GE.1. + * + * WH (workspace) DOUBLE PRECISION array of size (LDWH,NH) + * + * LDWH (input) integer scalar + * Leading dimension of WH just as declared in the + * calling procedure. LDWH.GE.3*NSHFTS-3. + * + * NV (input) integer scalar + * NV is the number of rows in WV agailable for workspace. + * NV.GE.1. + * + * WV (workspace) DOUBLE PRECISION array of size + * (LDWV,3*NSHFTS-3) + * + * LDWV (input) integer scalar + * LDWV is the leading dimension of WV as declared in the + * in the calling subroutine. LDWV.GE.NV. + * + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ============================================================ + * Reference: + * + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part I: Maintaining Well Focused Shifts, and + * Level 3 Performance, SIAM Journal of Matrix Analysis, + * volume 23, pages 929--947, 2002. + * + * ============================================================ + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) + * .. + * .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM, + $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, + $ ULP + INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, + $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, + $ NS, NU + LOGICAL ACCUM, BLK22, BMP22 + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + * .. + * .. Intrinsic Functions .. + * + INTRINSIC ABS, DBLE, MAX, MIN, MOD + * .. + * .. Local Arrays .. + DOUBLE PRECISION VT( 3 ) + * .. + * .. External Subroutines .. + EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, + $ DTRMM + * .. + * .. Executable Statements .. + * + * ==== If there are no shifts, then there is nothing to do. ==== + * + IF( NSHFTS.LT.2 ) + $ RETURN + * + * ==== If the active block is empty or 1-by-1, then there + * . is nothing to do. ==== + * + IF( KTOP.GE.KBOT ) + $ RETURN + * + * ==== Shuffle shifts into pairs of real shifts and pairs + * . of complex conjugate shifts assuming complex + * . conjugate shifts are already adjacent to one + * . another. ==== + * + DO 10 I = 1, NSHFTS - 2, 2 + IF( SI( I ).NE.-SI( I+1 ) ) THEN + * + SWAP = SR( I ) + SR( I ) = SR( I+1 ) + SR( I+1 ) = SR( I+2 ) + SR( I+2 ) = SWAP + * + SWAP = SI( I ) + SI( I ) = SI( I+1 ) + SI( I+1 ) = SI( I+2 ) + SI( I+2 ) = SWAP + END IF + 10 CONTINUE + * + * ==== NSHFTS is supposed to be even, but if is odd, + * . then simply reduce it by one. The shuffle above + * . ensures that the dropped shift is real and that + * . the remaining shifts are paired. ==== + * + NS = NSHFTS - MOD( NSHFTS, 2 ) + * + * ==== Machine constants for deflation ==== + * + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) + * + * ==== Use accumulated reflections to update far-from-diagonal + * . entries ? ==== + * + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) + * + * ==== If so, exploit the 2-by-2 block structure? ==== + * + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) + * + * ==== clear trash ==== + * + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO + * + * ==== NBMPS = number of 2-shift bulges in the chain ==== + * + NBMPS = NS / 2 + * + * ==== KDU = width of slab ==== + * + KDU = 6*NBMPS - 3 + * + * ==== Create and chase chains of NBMPS bulges ==== + * + DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) + * + * ==== Near-the-diagonal bulge chase. The following loop + * . performs the near-the-diagonal part of a small bulge + * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal + * . chunk extends from column INCOL to column NDCOL + * . (including both column INCOL and column NDCOL). The + * . following loop chases a 3*NBMPS column long chain of + * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL + * . may be less than KTOP and and NDCOL may be greater than + * . KBOT indicating phantom columns from which to chase + * . bulges before they are actually introduced or to which + * . to chase bulges beyond column KBOT.) ==== + * + DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) + * + * ==== Bulges number MTOP to MBOT are active double implicit + * . shift bulges. There may or may not also be small + * . 2-by-2 bulge, if there is room. The inactive bulges + * . (if any) must wait until the active bulges have moved + * . down the diagonal to make room. The phantom matrix + * . paradigm described above helps keep track. ==== + * + MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) + MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) + M22 = MBOT + 1 + BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. + $ ( KBOT-2 ) + * + * ==== Generate reflections to chase the chain right + * . one column. (The minimum value of K is KTOP-1.) ==== + * + DO 20 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ V( 1, M ) ) + ALPHA = V( 1, M ) + CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M ) = H( K+2, K ) + V( 3, M ) = H( K+3, K ) + CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) + * + * ==== A Bulge may collapse because of vigilant + * . deflation or destructive underflow. (The + * . initial bulge is always collapsed.) Use + * . the two-small-subdiagonals trick to try + * . to get it started again. If V(2,M).NE.0 and + * . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then + * . this bulge is collapsing into a zero + * . subdiagonal. It will be restarted next + * . trip through the loop.) + * + IF( V( 1, M ).NE.ZERO .AND. + $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, + $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) + $ THEN + * + * ==== Typical case: not collapsed (yet). ==== + * + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE + * + * ==== Atypical case: collapsed. Attempt to + * . reintroduce ignoring H(K+1,K). If the + * . fill resulting from the new reflector + * . is too large, then abandon it. + * . Otherwise, use the new one. ==== + * + CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ VT ) + SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) + + $ ABS( VT( 3 ) ) + IF( SCL.NE.ZERO ) THEN + VT( 1 ) = VT( 1 ) / SCL + VT( 2 ) = VT( 2 ) / SCL + VT( 3 ) = VT( 3 ) / SCL + END IF + * + * ==== The following is the traditional and + * . conservative two-small-subdiagonals + * . test. ==== + * . + IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+ + $ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )* + $ ( ABS( H( K, K ) )+ABS( H( K+1, + $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN + * + * ==== Starting a new bulge here would + * . create non-negligible fill. If + * . the old reflector is diagonal (only + * . possible with underflows), then + * . change it to I. Otherwise, use + * . it with trepidation. ==== + * + IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) + $ THEN + V( 1, M ) = ZERO + ELSE + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + END IF + ELSE + * + * ==== Stating a new bulge here would + * . create only negligible fill. + * . Replace the old reflector with + * . the new one. ==== + * + ALPHA = VT( 1 ) + CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) + + $ H( K+3, K )*VT( 3 ) + H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + V( 1, M ) = VT( 1 ) + V( 2, M ) = VT( 2 ) + V( 3, M ) = VT( 3 ) + END IF + END IF + END IF + 20 CONTINUE + * + * ==== Generate a 2-by-2 reflection, if needed. ==== + * + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), + $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), + $ V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + ELSE + * + * ==== Initialize V(1,M22) here to avoid possible undefined + * . variable problems later. ==== + * + V( 1, M22 ) = ZERO + END IF + * + * ==== Multiply H by reflections from the left ==== + * + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 40 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 30 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* + $ H( K+2, J )+V( 3, M )*H( K+3, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) + H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) + 30 CONTINUE + 40 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 50 J = MAX( K+1, KTOP ), JBOT + REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* + $ H( K+2, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) + 50 CONTINUE + END IF + * + * ==== Multiply H by reflections from the right. + * . Delay filling in the last row until the + * . vigilant deflation check is complete. ==== + * + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 90 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 60 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* + $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M ) + H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) + 60 CONTINUE + * + IF( ACCUM ) THEN + * + * ==== Accumulate U. (If necessary, update Z later + * . with with an efficient matrix-matrix + * . multiply.) ==== + * + KMS = K - INCOL + DO 70 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* + $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M ) + U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) + 70 CONTINUE + ELSE IF( WANTZ ) THEN + * + * ==== U is not accumulated, so update Z + * . now by multiplying by reflections + * . from the right. ==== + * + DO 80 J = ILOZ, IHIZ + REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* + $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M ) + Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) + 80 CONTINUE + END IF + END IF + 90 CONTINUE + * + * ==== Special case: 2-by-2 reflection (if needed) ==== + * + K = KRCOL + 3*( M22-1 ) + IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN + DO 100 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* + $ H( J, K+2 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 ) + 100 CONTINUE + * + IF( ACCUM ) THEN + KMS = K - INCOL + DO 110 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* + $ U( J, KMS+2 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 ) + 110 CONTINUE + ELSE IF( WANTZ ) THEN + DO 120 J = ILOZ, IHIZ + REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* + $ Z( J, K+2 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 ) + 120 CONTINUE + END IF + END IF + * + * ==== Vigilant deflation check ==== + * + MSTART = MTOP + IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) + $ MSTART = MSTART + 1 + MEND = MBOT + IF( BMP22 ) + $ MEND = MEND + 1 + IF( KRCOL.EQ.KBOT-2 ) + $ MEND = MEND + 1 + DO 130 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) + * + * ==== The following convergence test requires that + * . the tradition small-compared-to-nearby-diagonals + * . criterion and the Ahues & Tisseur (LAWN 122, 1997) + * . criteria both be satisfied. The latter improves + * . accuracy in some examples. Falling back on an + * . alternate convergence criterion when TST1 or TST2 + * . is zero (as done here) is traditional but probably + * . unnecessary. ==== + * + IF( H( K+1, K ).NE.ZERO ) THEN + TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) + IF( TST1.EQ.ZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + ABS( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + ABS( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + ABS( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) + END IF + IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H11 = MAX( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) + * + IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 130 CONTINUE + * + * ==== Fill in the last row of each bulge. ==== + * + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 140 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) + H( K+4, K+1 ) = -REFSUM + H( K+4, K+2 ) = -REFSUM*V( 2, M ) + H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) + 140 CONTINUE + * + * ==== End of near-the-diagonal bulge chase. ==== + * + 150 CONTINUE + * + * ==== Use U (if accumulated) to update far-from-diagonal + * . entries in H. If required, use U to update Z as + * . well. ==== + * + IF( ACCUM ) THEN + IF( WANTT ) THEN + JTOP = 1 + JBOT = N + ELSE + JTOP = KTOP + JBOT = KBOT + END IF + IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. + $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN + * + * ==== Updates not exploiting the 2-by-2 block + * . structure of U. K1 and NU keep track of + * . the location and size of U in the special + * . cases of introducing bulges and chasing + * . bulges off the bottom. In these special + * . cases and in case the number of shifts + * . is NS = 2, there is no 2-by-2 block + * . structure to exploit. ==== + * + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 + * + * ==== Horizontal Multiply ==== + * + DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 160 CONTINUE + * + * ==== Vertical multiply ==== + * + DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 170 CONTINUE + * + * ==== Z multiply (also vertical) ==== + * + IF( WANTZ ) THEN + DO 180 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 180 CONTINUE + END IF + ELSE + * + * ==== Updates exploiting U's 2-by-2 block structure. + * . (I2, I4, J2, J4 are the last rows and columns + * . of the blocks.) ==== + * + I2 = ( KDU+1 ) / 2 + I4 = KDU + J2 = I4 - I2 + J4 = KDU + * + * ==== KZS and KNZ deal with the band of zeros + * . along the diagonal of one of the triangular + * . blocks. ==== + * + KZS = ( J4-J2 ) - ( NS+1 ) + KNZ = NS + 1 + * + * ==== Horizontal multiply ==== + * + DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + * + * ==== Copy bottom of H to top+KZS of scratch ==== + * (The first KZS rows get multiplied by zero.) ==== + * + CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) + * + * ==== Multiply by U21' ==== + * + CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) + * + * ==== Multiply top of H by U11' ==== + * + CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) + * + * ==== Copy top of H bottom of WH ==== + * + CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) + * + * ==== Multiply by U21' ==== + * + CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) + * + * ==== Multiply by U22 ==== + * + CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, + $ U( J2+1, I2+1 ), LDU, + $ H( INCOL+1+J2, JCOL ), LDH, ONE, + $ WH( I2+1, 1 ), LDWH ) + * + * ==== Copy it back ==== + * + CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 190 CONTINUE + * + * ==== Vertical multiply ==== + * + DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) + * + * ==== Copy right of H to scratch (the first KZS + * . columns get multiplied by zero) ==== + * + CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) + * + * ==== Multiply by U21 ==== + * + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) + * + * ==== Multiply by U11 ==== + * + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) + * + * ==== Copy left of H to right of scratch ==== + * + CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) + * + * ==== Multiply by U21 ==== + * + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) + * + * ==== Multiply by U22 ==== + * + CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ H( JROW, INCOL+1+J2 ), LDH, + $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), + $ LDWV ) + * + * ==== Copy it back ==== + * + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 200 CONTINUE + * + * ==== Multiply Z (also vertical) ==== + * + IF( WANTZ ) THEN + DO 210 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + * + * ==== Copy right of Z to left of scratch (first + * . KZS columns get multiplied by zero) ==== + * + CALL DLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) + * + * ==== Multiply by U12 ==== + * + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) + * + * ==== Multiply by U11 ==== + * + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) + * + * ==== Copy left of Z to right of scratch ==== + * + CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) + * + * ==== Multiply by U21 ==== + * + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) + * + * ==== Multiply by U22 ==== + * + CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ U( J2+1, I2+1 ), LDU, ONE, + $ WV( 1, 1+I2 ), LDWV ) + * + * ==== Copy the result back to Z ==== + * + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 210 CONTINUE + END IF + END IF + END IF + 220 CONTINUE + * + * ==== End of DLAQR5 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlarf.f octave-2.9.16/libcruft/lapack/dlarf.f *** octave-2.9.15/libcruft/lapack/dlarf.f Wed Nov 3 14:54:25 1999 --- octave-2.9.16/libcruft/lapack/dlarf.f Tue Oct 16 14:54:20 2007 *************** *** 1,9 **** SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE --- 1,8 ---- SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE diff -cNr octave-2.9.15/libcruft/lapack/dlarfb.f octave-2.9.16/libcruft/lapack/dlarfb.f *** octave-2.9.15/libcruft/lapack/dlarfb.f Wed Nov 3 14:54:25 1999 --- octave-2.9.16/libcruft/lapack/dlarfb.f Tue Oct 16 14:54:20 2007 *************** *** 1,10 **** SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS --- 1,9 ---- SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS diff -cNr octave-2.9.15/libcruft/lapack/dlarfg.f octave-2.9.16/libcruft/lapack/dlarfg.f *** octave-2.9.15/libcruft/lapack/dlarfg.f Wed Nov 3 14:54:25 1999 --- octave-2.9.16/libcruft/lapack/dlarfg.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/dlarft.f octave-2.9.16/libcruft/lapack/dlarft.f *** octave-2.9.15/libcruft/lapack/dlarft.f Wed Nov 3 14:54:28 1999 --- octave-2.9.16/libcruft/lapack/dlarft.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV --- 1,8 ---- SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV diff -cNr octave-2.9.15/libcruft/lapack/dlarfx.f octave-2.9.16/libcruft/lapack/dlarfx.f *** octave-2.9.15/libcruft/lapack/dlarfx.f Wed Nov 3 14:54:28 1999 --- octave-2.9.16/libcruft/lapack/dlarfx.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE --- 1,8 ---- SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE diff -cNr octave-2.9.15/libcruft/lapack/dlartg.f octave-2.9.16/libcruft/lapack/dlartg.f *** octave-2.9.15/libcruft/lapack/dlartg.f Wed Nov 3 14:54:28 1999 --- octave-2.9.16/libcruft/lapack/dlartg.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLARTG( F, G, CS, SN, R ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN --- 1,8 ---- SUBROUTINE DLARTG( F, G, CS, SN, R ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN *************** *** 45,50 **** --- 44,52 ---- * R (output) DOUBLE PRECISION * The nonzero component of the rotated vector. * + * This version has a few statements commented out for thread safety + * (machine parameters are computed on each entry). 10 feb 03, SJH. + * * ===================================================================== * * .. Parameters .. *************** *** 56,62 **** PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. ! LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. --- 58,64 ---- PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. ! * LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. *************** *** 68,88 **** INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. ! SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. ! DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * ! IF( FIRST ) THEN ! FIRST = .FALSE. SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 ! END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO --- 70,90 ---- INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. ! * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. ! * DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * ! * IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 ! * FIRST = .FALSE. ! * END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO diff -cNr octave-2.9.15/libcruft/lapack/dlas2.f octave-2.9.16/libcruft/lapack/dlas2.f *** octave-2.9.15/libcruft/lapack/dlas2.f Wed Nov 3 14:54:28 1999 --- octave-2.9.16/libcruft/lapack/dlas2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. DOUBLE PRECISION F, G, H, SSMAX, SSMIN --- 1,8 ---- SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION F, G, H, SSMAX, SSMIN diff -cNr octave-2.9.15/libcruft/lapack/dlascl.f octave-2.9.16/libcruft/lapack/dlascl.f *** octave-2.9.15/libcruft/lapack/dlascl.f Wed Nov 3 14:54:28 1999 --- octave-2.9.16/libcruft/lapack/dlascl.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE --- 1,8 ---- SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TYPE *************** *** 62,68 **** * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * ! * A (input/output) DOUBLE PRECISION array, dimension (LDA,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * --- 61,67 ---- * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * ! * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * diff -cNr octave-2.9.15/libcruft/lapack/dlasd0.f octave-2.9.16/libcruft/lapack/dlasd0.f *** octave-2.9.15/libcruft/lapack/dlasd0.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd0.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,230 ---- + SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, + $ WORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE + * .. + * .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), + $ WORK( * ) + * .. + * + * Purpose + * ======= + * + * Using a divide and conquer approach, DLASD0 computes the singular + * value decomposition (SVD) of a real upper bidiagonal N-by-M + * matrix B with diagonal D and offdiagonal E, where M = N + SQRE. + * The algorithm computes orthogonal matrices U and VT such that + * B = U * S * VT. The singular values S are overwritten on D. + * + * A related subroutine, DLASDA, computes only the singular values, + * and optionally, the singular vectors in compact form. + * + * Arguments + * ========= + * + * N (input) INTEGER + * On entry, the row dimension of the upper bidiagonal matrix. + * This is also the dimension of the main diagonal array D. + * + * SQRE (input) INTEGER + * Specifies the column dimension of the bidiagonal matrix. + * = 0: The bidiagonal matrix has column dimension M = N; + * = 1: The bidiagonal matrix has column dimension M = N+1; + * + * D (input/output) DOUBLE PRECISION array, dimension (N) + * On entry D contains the main diagonal of the bidiagonal + * matrix. + * On exit D, if INFO = 0, contains its singular values. + * + * E (input) DOUBLE PRECISION array, dimension (M-1) + * Contains the subdiagonal entries of the bidiagonal matrix. + * On exit, E has been destroyed. + * + * U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) + * On exit, U contains the left singular vectors. + * + * LDU (input) INTEGER + * On entry, leading dimension of U. + * + * VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) + * On exit, VT' contains the right singular vectors. + * + * LDVT (input) INTEGER + * On entry, leading dimension of VT. + * + * SMLSIZ (input) INTEGER + * On entry, maximum size of the subproblems at the + * bottom of the computation tree. + * + * IWORK (workspace) INTEGER work array. + * Dimension must be at least (8 * N) + * + * WORK (workspace) DOUBLE PRECISION work array. + * Dimension must be at least (3 * M**2 + 2 * M) + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: if INFO = 1, an singular value did not converge + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Local Scalars .. + INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK, + $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR, + $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI + DOUBLE PRECISION ALPHA, BETA + * .. + * .. External Subroutines .. + EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -2 + END IF + * + M = N + SQRE + * + IF( LDU.LT.N ) THEN + INFO = -6 + ELSE IF( LDVT.LT.M ) THEN + INFO = -8 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD0', -INFO ) + RETURN + END IF + * + * If the input matrix is too small, call DLASDQ to find the SVD. + * + IF( N.LE.SMLSIZ ) THEN + CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U, + $ LDU, WORK, INFO ) + RETURN + END IF + * + * Set up the computation tree. + * + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + IDXQ = NDIMR + N + IWK = IDXQ + N + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) + * + * For the nodes on bottom level of the tree, solve + * their subproblems by DLASDQ. + * + NDB1 = ( ND+1 ) / 2 + NCC = 0 + DO 30 I = NDB1, ND + * + * IC : center row of each node + * NL : number of rows of left subproblem + * NR : number of rows of right subproblem + * NLF: starting row of the left subproblem + * NRF: starting row of the right subproblem + * + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NLP1 = NL + 1 + NR = IWORK( NDIMR+I1 ) + NRP1 = NR + 1 + NLF = IC - NL + NRF = IC + 1 + SQREI = 1 + CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ), + $ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU, + $ U( NLF, NLF ), LDU, WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + ITEMP = IDXQ + NLF - 2 + DO 10 J = 1, NL + IWORK( ITEMP+J ) = J + 10 CONTINUE + IF( I.EQ.ND ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + NRP1 = NR + SQREI + CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ), + $ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU, + $ U( NRF, NRF ), LDU, WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + ITEMP = IDXQ + IC + DO 20 J = 1, NR + IWORK( ITEMP+J-1 ) = J + 20 CONTINUE + 30 CONTINUE + * + * Now conquer each subproblem bottom-up. + * + DO 50 LVL = NLVL, 1, -1 + * + * Find the first node LF and last node LL on the + * current level LVL. + * + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 40 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + IDXQC = IDXQ + NLF - 1 + ALPHA = D( IC ) + BETA = E( IC ) + CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA, + $ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT, + $ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + 40 CONTINUE + 50 CONTINUE + * + RETURN + * + * End of DLASD0 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd1.f octave-2.9.16/libcruft/lapack/dlasd1.f *** octave-2.9.15/libcruft/lapack/dlasd1.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd1.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,232 ---- + SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, + $ IDXQ, IWORK, WORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER INFO, LDU, LDVT, NL, NR, SQRE + DOUBLE PRECISION ALPHA, BETA + * .. + * .. Array Arguments .. + INTEGER IDXQ( * ), IWORK( * ) + DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, + * where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. + * + * A related subroutine DLASD7 handles the case in which the singular + * values (and the singular vectors in factored form) are desired. + * + * DLASD1 computes the SVD as follows: + * + * ( D1(in) 0 0 0 ) + * B = U(in) * ( Z1' a Z2' b ) * VT(in) + * ( 0 0 D2(in) 0 ) + * + * = U(out) * ( D(out) 0) * VT(out) + * + * where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M + * with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros + * elsewhere; and the entry b is empty if SQRE = 0. + * + * The left singular vectors of the original matrix are stored in U, and + * the transpose of the right singular vectors are stored in VT, and the + * singular values are in D. The algorithm consists of three stages: + * + * The first stage consists of deflating the size of the problem + * when there are multiple singular values or when there are zeros in + * the Z vector. For each such occurence the dimension of the + * secular equation problem is reduced by one. This stage is + * performed by the routine DLASD2. + * + * The second stage consists of calculating the updated + * singular values. This is done by finding the square roots of the + * roots of the secular equation via the routine DLASD4 (as called + * by DLASD3). This routine also calculates the singular vectors of + * the current problem. + * + * The final stage consists of computing the updated singular vectors + * directly using the updated singular values. The singular vectors + * for the current problem are multiplied with the singular vectors + * from the overall problem. + * + * Arguments + * ========= + * + * NL (input) INTEGER + * The row dimension of the upper block. NL >= 1. + * + * NR (input) INTEGER + * The row dimension of the lower block. NR >= 1. + * + * SQRE (input) INTEGER + * = 0: the lower block is an NR-by-NR square matrix. + * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + * + * The bidiagonal matrix has row dimension N = NL + NR + 1, + * and column dimension M = N + SQRE. + * + * D (input/output) DOUBLE PRECISION array, + * dimension (N = NL+NR+1). + * On entry D(1:NL,1:NL) contains the singular values of the + * upper block; and D(NL+2:N) contains the singular values of + * the lower block. On exit D(1:N) contains the singular values + * of the modified matrix. + * + * ALPHA (input/output) DOUBLE PRECISION + * Contains the diagonal element associated with the added row. + * + * BETA (input/output) DOUBLE PRECISION + * Contains the off-diagonal element associated with the added + * row. + * + * U (input/output) DOUBLE PRECISION array, dimension(LDU,N) + * On entry U(1:NL, 1:NL) contains the left singular vectors of + * the upper block; U(NL+2:N, NL+2:N) contains the left singular + * vectors of the lower block. On exit U contains the left + * singular vectors of the bidiagonal matrix. + * + * LDU (input) INTEGER + * The leading dimension of the array U. LDU >= max( 1, N ). + * + * VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) + * where M = N + SQRE. + * On entry VT(1:NL+1, 1:NL+1)' contains the right singular + * vectors of the upper block; VT(NL+2:M, NL+2:M)' contains + * the right singular vectors of the lower block. On exit + * VT' contains the right singular vectors of the + * bidiagonal matrix. + * + * LDVT (input) INTEGER + * The leading dimension of the array VT. LDVT >= max( 1, M ). + * + * IDXQ (output) INTEGER array, dimension(N) + * This contains the permutation which will reintegrate the + * subproblem just solved back into sorted order, i.e. + * D( IDXQ( I = 1, N ) ) will be in ascending order. + * + * IWORK (workspace) INTEGER array, dimension( 4 * N ) + * + * WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: if INFO = 1, an singular value did not converge + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + * + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2, + $ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2 + DOUBLE PRECISION ORGNRM + * .. + * .. External Subroutines .. + EXTERNAL DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, MAX + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD1', -INFO ) + RETURN + END IF + * + N = NL + NR + 1 + M = N + SQRE + * + * The following values are for bookkeeping purposes only. They are + * integer pointers which indicate the portion of the workspace + * used by a particular array in DLASD2 and DLASD3. + * + LDU2 = N + LDVT2 = M + * + IZ = 1 + ISIGMA = IZ + M + IU2 = ISIGMA + N + IVT2 = IU2 + LDU2*N + IQ = IVT2 + LDVT2*M + * + IDX = 1 + IDXC = IDX + N + COLTYP = IDXC + N + IDXP = COLTYP + N + * + * Scale. + * + ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) + D( NL+1 ) = ZERO + DO 10 I = 1, N + IF( ABS( D( I ) ).GT.ORGNRM ) THEN + ORGNRM = ABS( D( I ) ) + END IF + 10 CONTINUE + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + ALPHA = ALPHA / ORGNRM + BETA = BETA / ORGNRM + * + * Deflate singular values. + * + CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU, + $ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2, + $ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ), + $ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO ) + * + * Solve Secular Equation and update singular vectors. + * + LDQ = K + CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ), + $ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ), + $ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ), + $ INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + * + * Unscale. + * + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + * + * Prepare the IDXQ sorting permutation. + * + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) + * + RETURN + * + * End of DLASD1 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd2.f octave-2.9.16/libcruft/lapack/dlasd2.f *** octave-2.9.15/libcruft/lapack/dlasd2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd2.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,512 ---- + SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, + $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, + $ IDXC, IDXQ, COLTYP, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE + DOUBLE PRECISION ALPHA, BETA + * .. + * .. Array Arguments .. + INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), + $ IDXQ( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), + $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), + $ Z( * ) + * .. + * + * Purpose + * ======= + * + * DLASD2 merges the two sets of singular values together into a single + * sorted set. Then it tries to deflate the size of the problem. + * There are two ways in which deflation can occur: when two or more + * singular values are close together or if there is a tiny entry in the + * Z vector. For each such occurrence the order of the related secular + * equation problem is reduced by one. + * + * DLASD2 is called from DLASD1. + * + * Arguments + * ========= + * + * NL (input) INTEGER + * The row dimension of the upper block. NL >= 1. + * + * NR (input) INTEGER + * The row dimension of the lower block. NR >= 1. + * + * SQRE (input) INTEGER + * = 0: the lower block is an NR-by-NR square matrix. + * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + * + * The bidiagonal matrix has N = NL + NR + 1 rows and + * M = N + SQRE >= N columns. + * + * K (output) INTEGER + * Contains the dimension of the non-deflated matrix, + * This is the order of the related secular equation. 1 <= K <=N. + * + * D (input/output) DOUBLE PRECISION array, dimension(N) + * On entry D contains the singular values of the two submatrices + * to be combined. On exit D contains the trailing (N-K) updated + * singular values (those which were deflated) sorted into + * increasing order. + * + * Z (output) DOUBLE PRECISION array, dimension(N) + * On exit Z contains the updating row vector in the secular + * equation. + * + * ALPHA (input) DOUBLE PRECISION + * Contains the diagonal element associated with the added row. + * + * BETA (input) DOUBLE PRECISION + * Contains the off-diagonal element associated with the added + * row. + * + * U (input/output) DOUBLE PRECISION array, dimension(LDU,N) + * On entry U contains the left singular vectors of two + * submatrices in the two square blocks with corners at (1,1), + * (NL, NL), and (NL+2, NL+2), (N,N). + * On exit U contains the trailing (N-K) updated left singular + * vectors (those which were deflated) in its last N-K columns. + * + * LDU (input) INTEGER + * The leading dimension of the array U. LDU >= N. + * + * VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) + * On entry VT' contains the right singular vectors of two + * submatrices in the two square blocks with corners at (1,1), + * (NL+1, NL+1), and (NL+2, NL+2), (M,M). + * On exit VT' contains the trailing (N-K) updated right singular + * vectors (those which were deflated) in its last N-K columns. + * In case SQRE =1, the last row of VT spans the right null + * space. + * + * LDVT (input) INTEGER + * The leading dimension of the array VT. LDVT >= M. + * + * DSIGMA (output) DOUBLE PRECISION array, dimension (N) + * Contains a copy of the diagonal elements (K-1 singular values + * and one zero) in the secular equation. + * + * U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) + * Contains a copy of the first K-1 left singular vectors which + * will be used by DLASD3 in a matrix multiply (DGEMM) to solve + * for the new left singular vectors. U2 is arranged into four + * blocks. The first block contains a column with 1 at NL+1 and + * zero everywhere else; the second block contains non-zero + * entries only at and above NL; the third contains non-zero + * entries only below NL+1; and the fourth is dense. + * + * LDU2 (input) INTEGER + * The leading dimension of the array U2. LDU2 >= N. + * + * VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) + * VT2' contains a copy of the first K right singular vectors + * which will be used by DLASD3 in a matrix multiply (DGEMM) to + * solve for the new right singular vectors. VT2 is arranged into + * three blocks. The first block contains a row that corresponds + * to the special 0 diagonal element in SIGMA; the second block + * contains non-zeros only at and before NL +1; the third block + * contains non-zeros only at and after NL +2. + * + * LDVT2 (input) INTEGER + * The leading dimension of the array VT2. LDVT2 >= M. + * + * IDXP (workspace) INTEGER array dimension(N) + * This will contain the permutation used to place deflated + * values of D at the end of the array. On output IDXP(2:K) + * points to the nondeflated D-values and IDXP(K+1:N) + * points to the deflated singular values. + * + * IDX (workspace) INTEGER array dimension(N) + * This will contain the permutation used to sort the contents of + * D into ascending order. + * + * IDXC (output) INTEGER array dimension(N) + * This will contain the permutation used to arrange the columns + * of the deflated U matrix into three groups: the first group + * contains non-zero entries only at and above NL, the second + * contains non-zero entries only below NL+2, and the third is + * dense. + * + * IDXQ (input/output) INTEGER array dimension(N) + * This contains the permutation which separately sorts the two + * sub-problems in D into ascending order. Note that entries in + * the first hlaf of this permutation must first be moved one + * position backward; and entries in the second half + * must first have NL+1 added to their values. + * + * COLTYP (workspace/output) INTEGER array dimension(N) + * As workspace, this will contain a label which will indicate + * which of the following types a column in the U2 matrix or a + * row in the VT2 matrix is: + * 1 : non-zero in the upper half only + * 2 : non-zero in the lower half only + * 3 : dense + * 4 : deflated + * + * On exit, it is an array of dimension 4, with COLTYP(I) being + * the dimension of the I-th type columns. + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ EIGHT = 8.0D+0 ) + * .. + * .. Local Arrays .. + INTEGER CTOT( 4 ), PSM( 4 ) + * .. + * .. Local Scalars .. + INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, + $ N, NLP1, NLP2 + DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1 + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, MAX + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN + INFO = -3 + END IF + * + N = NL + NR + 1 + M = N + SQRE + * + IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDVT.LT.M ) THEN + INFO = -12 + ELSE IF( LDU2.LT.N ) THEN + INFO = -15 + ELSE IF( LDVT2.LT.M ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD2', -INFO ) + RETURN + END IF + * + NLP1 = NL + 1 + NLP2 = NL + 2 + * + * Generate the first part of the vector Z; and move the singular + * values in the first part of D one position backward. + * + Z1 = ALPHA*VT( NLP1, NLP1 ) + Z( 1 ) = Z1 + DO 10 I = NL, 1, -1 + Z( I+1 ) = ALPHA*VT( I, NLP1 ) + D( I+1 ) = D( I ) + IDXQ( I+1 ) = IDXQ( I ) + 1 + 10 CONTINUE + * + * Generate the second part of the vector Z. + * + DO 20 I = NLP2, M + Z( I ) = BETA*VT( I, NLP2 ) + 20 CONTINUE + * + * Initialize some reference arrays. + * + DO 30 I = 2, NLP1 + COLTYP( I ) = 1 + 30 CONTINUE + DO 40 I = NLP2, N + COLTYP( I ) = 2 + 40 CONTINUE + * + * Sort the singular values into increasing order + * + DO 50 I = NLP2, N + IDXQ( I ) = IDXQ( I ) + NLP1 + 50 CONTINUE + * + * DSIGMA, IDXC, IDXC, and the first column of U2 + * are used as storage space. + * + DO 60 I = 2, N + DSIGMA( I ) = D( IDXQ( I ) ) + U2( I, 1 ) = Z( IDXQ( I ) ) + IDXC( I ) = COLTYP( IDXQ( I ) ) + 60 CONTINUE + * + CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) + * + DO 70 I = 2, N + IDXI = 1 + IDX( I ) + D( I ) = DSIGMA( IDXI ) + Z( I ) = U2( IDXI, 1 ) + COLTYP( I ) = IDXC( IDXI ) + 70 CONTINUE + * + * Calculate the allowable deflation tolerance + * + EPS = DLAMCH( 'Epsilon' ) + TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) + TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) + * + * There are 2 kinds of deflation -- first a value in the z-vector + * is small, second two (or more) singular values are very close + * together (their difference is small). + * + * If the value in the z-vector is small, we simply permute the + * array so that the corresponding singular value is moved to the + * end. + * + * If two values in the D-vector are close, we perform a two-sided + * rotation designed to make one of the corresponding z-vector + * entries zero, and then permute the array so that the deflated + * singular value is moved to the end. + * + * If there are multiple singular values then the problem deflates. + * Here the number of equal singular values are found. As each equal + * singular value is found, an elementary reflector is computed to + * rotate the corresponding singular subspace so that the + * corresponding components of Z are zero in this new basis. + * + K = 1 + K2 = N + 1 + DO 80 J = 2, N + IF( ABS( Z( J ) ).LE.TOL ) THEN + * + * Deflate due to small z component. + * + K2 = K2 - 1 + IDXP( K2 ) = J + COLTYP( J ) = 4 + IF( J.EQ.N ) + $ GO TO 120 + ELSE + JPREV = J + GO TO 90 + END IF + 80 CONTINUE + 90 CONTINUE + J = JPREV + 100 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 110 + IF( ABS( Z( J ) ).LE.TOL ) THEN + * + * Deflate due to small z component. + * + K2 = K2 - 1 + IDXP( K2 ) = J + COLTYP( J ) = 4 + ELSE + * + * Check if singular values are close enough to allow deflation. + * + IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN + * + * Deflation is possible. + * + S = Z( JPREV ) + C = Z( J ) + * + * Find sqrt(a**2+b**2) without overflow or + * destructive underflow. + * + TAU = DLAPY2( C, S ) + C = C / TAU + S = -S / TAU + Z( J ) = TAU + Z( JPREV ) = ZERO + * + * Apply back the Givens rotation to the left and right + * singular vector matrices. + * + IDXJP = IDXQ( IDX( JPREV )+1 ) + IDXJ = IDXQ( IDX( J )+1 ) + IF( IDXJP.LE.NLP1 ) THEN + IDXJP = IDXJP - 1 + END IF + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S ) + CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, + $ S ) + IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN + COLTYP( J ) = 3 + END IF + COLTYP( JPREV ) = 4 + K2 = K2 - 1 + IDXP( K2 ) = JPREV + JPREV = J + ELSE + K = K + 1 + U2( K, 1 ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + JPREV = J + END IF + END IF + GO TO 100 + 110 CONTINUE + * + * Record the last singular value. + * + K = K + 1 + U2( K, 1 ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + * + 120 CONTINUE + * + * Count up the total number of the various types of columns, then + * form a permutation which positions the four column types into + * four groups of uniform structure (although one or more of these + * groups may be empty). + * + DO 130 J = 1, 4 + CTOT( J ) = 0 + 130 CONTINUE + DO 140 J = 2, N + CT = COLTYP( J ) + CTOT( CT ) = CTOT( CT ) + 1 + 140 CONTINUE + * + * PSM(*) = Position in SubMatrix (of types 1 through 4) + * + PSM( 1 ) = 2 + PSM( 2 ) = 2 + CTOT( 1 ) + PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) + PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) + * + * Fill out the IDXC array so that the permutation which it induces + * will place all type-1 columns first, all type-2 columns next, + * then all type-3's, and finally all type-4's, starting from the + * second column. This applies similarly to the rows of VT. + * + DO 150 J = 2, N + JP = IDXP( J ) + CT = COLTYP( JP ) + IDXC( PSM( CT ) ) = J + PSM( CT ) = PSM( CT ) + 1 + 150 CONTINUE + * + * Sort the singular values and corresponding singular vectors into + * DSIGMA, U2, and VT2 respectively. The singular values/vectors + * which were not deflated go into the first K slots of DSIGMA, U2, + * and VT2 respectively, while those which were deflated go into the + * last N - K slots, except that the first column/row will be treated + * separately. + * + DO 160 J = 2, N + JP = IDXP( J ) + DSIGMA( J ) = D( JP ) + IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 ) + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 ) + CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 ) + 160 CONTINUE + * + * Determine DSIGMA(1), DSIGMA(2) and Z(1) + * + DSIGMA( 1 ) = ZERO + HLFTOL = TOL / TWO + IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) + $ DSIGMA( 2 ) = HLFTOL + IF( M.GT.N ) THEN + Z( 1 ) = DLAPY2( Z1, Z( M ) ) + IF( Z( 1 ).LE.TOL ) THEN + C = ONE + S = ZERO + Z( 1 ) = TOL + ELSE + C = Z1 / Z( 1 ) + S = Z( M ) / Z( 1 ) + END IF + ELSE + IF( ABS( Z1 ).LE.TOL ) THEN + Z( 1 ) = TOL + ELSE + Z( 1 ) = Z1 + END IF + END IF + * + * Move the rest of the updating row to Z. + * + CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 ) + * + * Determine the first column of U2, the first row of VT2 and the + * last row of VT. + * + CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 ) + U2( NLP1, 1 ) = ONE + IF( M.GT.N ) THEN + DO 170 I = 1, NLP1 + VT( M, I ) = -S*VT( NLP1, I ) + VT2( 1, I ) = C*VT( NLP1, I ) + 170 CONTINUE + DO 180 I = NLP2, M + VT2( 1, I ) = S*VT( M, I ) + VT( M, I ) = C*VT( M, I ) + 180 CONTINUE + ELSE + CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 ) + END IF + IF( M.GT.N ) THEN + CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 ) + END IF + * + * The deflated singular values and their corresponding vectors go + * into the back of D, U, and V respectively. + * + IF( N.GT.K ) THEN + CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) + CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), + $ LDU ) + CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), + $ LDVT ) + END IF + * + * Copy CTOT into COLTYP for referencing in DLASD3. + * + DO 190 J = 1, 4 + COLTYP( J ) = CTOT( J ) + 190 CONTINUE + * + RETURN + * + * End of DLASD2 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd3.f octave-2.9.16/libcruft/lapack/dlasd3.f *** octave-2.9.15/libcruft/lapack/dlasd3.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd3.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,358 ---- + SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, + $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, + $ INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, + $ SQRE + * .. + * .. Array Arguments .. + INTEGER CTOT( * ), IDXC( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), + $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), + $ Z( * ) + * .. + * + * Purpose + * ======= + * + * DLASD3 finds all the square roots of the roots of the secular + * equation, as defined by the values in D and Z. It makes the + * appropriate calls to DLASD4 and then updates the singular + * vectors by matrix multiplication. + * + * This code makes very mild assumptions about floating point + * arithmetic. It will work on machines with a guard digit in + * add/subtract, or on those binary machines without guard digits + * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. + * It could conceivably fail on hexadecimal or decimal machines + * without guard digits, but we know of none. + * + * DLASD3 is called from DLASD1. + * + * Arguments + * ========= + * + * NL (input) INTEGER + * The row dimension of the upper block. NL >= 1. + * + * NR (input) INTEGER + * The row dimension of the lower block. NR >= 1. + * + * SQRE (input) INTEGER + * = 0: the lower block is an NR-by-NR square matrix. + * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + * + * The bidiagonal matrix has N = NL + NR + 1 rows and + * M = N + SQRE >= N columns. + * + * K (input) INTEGER + * The size of the secular equation, 1 =< K = < N. + * + * D (output) DOUBLE PRECISION array, dimension(K) + * On exit the square roots of the roots of the secular equation, + * in ascending order. + * + * Q (workspace) DOUBLE PRECISION array, + * dimension at least (LDQ,K). + * + * LDQ (input) INTEGER + * The leading dimension of the array Q. LDQ >= K. + * + * DSIGMA (input) DOUBLE PRECISION array, dimension(K) + * The first K elements of this array contain the old roots + * of the deflated updating problem. These are the poles + * of the secular equation. + * + * U (output) DOUBLE PRECISION array, dimension (LDU, N) + * The last N - K columns of this matrix contain the deflated + * left singular vectors. + * + * LDU (input) INTEGER + * The leading dimension of the array U. LDU >= N. + * + * U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N) + * The first K columns of this matrix contain the non-deflated + * left singular vectors for the split problem. + * + * LDU2 (input) INTEGER + * The leading dimension of the array U2. LDU2 >= N. + * + * VT (output) DOUBLE PRECISION array, dimension (LDVT, M) + * The last M - K columns of VT' contain the deflated + * right singular vectors. + * + * LDVT (input) INTEGER + * The leading dimension of the array VT. LDVT >= N. + * + * VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) + * The first K columns of VT2' contain the non-deflated + * right singular vectors for the split problem. + * + * LDVT2 (input) INTEGER + * The leading dimension of the array VT2. LDVT2 >= N. + * + * IDXC (input) INTEGER array, dimension ( N ) + * The permutation used to arrange the columns of U (and rows of + * VT) into three groups: the first group contains non-zero + * entries only at and above (or before) NL +1; the second + * contains non-zero entries only at and below (or after) NL+2; + * and the third is dense. The first column of U and the row of + * VT are treated separately, however. + * + * The rows of the singular vectors found by DLASD4 + * must be likewise permuted before the matrix multiplies can + * take place. + * + * CTOT (input) INTEGER array, dimension ( 4 ) + * A count of the total number of the various types of columns + * in U (or rows in VT), as described in IDXC. The fourth column + * type is any column which has been deflated. + * + * Z (input) DOUBLE PRECISION array, dimension (K) + * The first K elements of this array contain the components + * of the deflation-adjusted updating row vector. + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: if INFO = 1, an singular value did not converge + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ONE, ZERO, NEGONE + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ NEGONE = -1.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1 + DOUBLE PRECISION RHO, TEMP + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( NL.LT.1 ) THEN + INFO = -1 + ELSE IF( NR.LT.1 ) THEN + INFO = -2 + ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN + INFO = -3 + END IF + * + N = NL + NR + 1 + M = N + SQRE + NLP1 = NL + 1 + NLP2 = NL + 2 + * + IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.K ) THEN + INFO = -7 + ELSE IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDU2.LT.N ) THEN + INFO = -12 + ELSE IF( LDVT.LT.M ) THEN + INFO = -14 + ELSE IF( LDVT2.LT.M ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD3', -INFO ) + RETURN + END IF + * + * Quick return if possible + * + IF( K.EQ.1 ) THEN + D( 1 ) = ABS( Z( 1 ) ) + CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT ) + IF( Z( 1 ).GT.ZERO ) THEN + CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 ) + ELSE + DO 10 I = 1, N + U( I, 1 ) = -U2( I, 1 ) + 10 CONTINUE + END IF + RETURN + END IF + * + * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can + * be computed with high relative accuracy (barring over/underflow). + * This is a problem on machines without a guard digit in + * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). + * The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), + * which on any of these machines zeros out the bottommost + * bit of DSIGMA(I) if it is 1; this makes the subsequent + * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation + * occurs. On binary machines with a guard digit (almost all + * machines) it does not change DSIGMA(I) at all. On hexadecimal + * and decimal machines with a guard digit, it slightly + * changes the bottommost bits of DSIGMA(I). It does not account + * for hexadecimal or decimal machines without guard digits + * (we know of none). We use a subroutine call to compute + * 2*DSIGMA(I) to prevent optimizing compilers from eliminating + * this code. + * + DO 20 I = 1, K + DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) + 20 CONTINUE + * + * Keep a copy of Z. + * + CALL DCOPY( K, Z, 1, Q, 1 ) + * + * Normalize Z. + * + RHO = DNRM2( K, Z, 1 ) + CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) + RHO = RHO*RHO + * + * Find the new singular values. + * + DO 30 J = 1, K + CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ), + $ VT( 1, J ), INFO ) + * + * If the zero finder fails, the computation is terminated. + * + IF( INFO.NE.0 ) THEN + RETURN + END IF + 30 CONTINUE + * + * Compute updated Z. + * + DO 60 I = 1, K + Z( I ) = U( I, K )*VT( I, K ) + DO 40 J = 1, I - 1 + Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / + $ ( DSIGMA( I )-DSIGMA( J ) ) / + $ ( DSIGMA( I )+DSIGMA( J ) ) ) + 40 CONTINUE + DO 50 J = I, K - 1 + Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / + $ ( DSIGMA( I )-DSIGMA( J+1 ) ) / + $ ( DSIGMA( I )+DSIGMA( J+1 ) ) ) + 50 CONTINUE + Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) ) + 60 CONTINUE + * + * Compute left singular vectors of the modified diagonal matrix, + * and store related information for the right singular vectors. + * + DO 90 I = 1, K + VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I ) + U( 1, I ) = NEGONE + DO 70 J = 2, K + VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I ) + U( J, I ) = DSIGMA( J )*VT( J, I ) + 70 CONTINUE + TEMP = DNRM2( K, U( 1, I ), 1 ) + Q( 1, I ) = U( 1, I ) / TEMP + DO 80 J = 2, K + JC = IDXC( J ) + Q( J, I ) = U( JC, I ) / TEMP + 80 CONTINUE + 90 CONTINUE + * + * Update the left singular vector matrix. + * + IF( K.EQ.2 ) THEN + CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U, + $ LDU ) + GO TO 100 + END IF + IF( CTOT( 1 ).GT.0 ) THEN + CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2, + $ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) + IF( CTOT( 3 ).GT.0 ) THEN + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), + $ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU ) + END IF + ELSE IF( CTOT( 3 ).GT.0 ) THEN + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), + $ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) + ELSE + CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU ) + END IF + CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU ) + KTEMP = 2 + CTOT( 1 ) + CTEMP = CTOT( 2 ) + CTOT( 3 ) + CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2, + $ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU ) + * + * Generate the right singular vectors. + * + 100 CONTINUE + DO 120 I = 1, K + TEMP = DNRM2( K, VT( 1, I ), 1 ) + Q( I, 1 ) = VT( 1, I ) / TEMP + DO 110 J = 2, K + JC = IDXC( J ) + Q( I, J ) = VT( JC, I ) / TEMP + 110 CONTINUE + 120 CONTINUE + * + * Update the right singular vector matrix. + * + IF( K.EQ.2 ) THEN + CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO, + $ VT, LDVT ) + RETURN + END IF + KTEMP = 1 + CTOT( 1 ) + CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ, + $ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT ) + KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) + IF( KTEMP.LE.LDVT2 ) + $ CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ), + $ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ), + $ LDVT ) + * + KTEMP = CTOT( 1 ) + 1 + NRP1 = NR + SQRE + IF( KTEMP.GT.1 ) THEN + DO 130 I = 1, K + Q( I, KTEMP ) = Q( I, 1 ) + 130 CONTINUE + DO 140 I = NLP2, M + VT2( KTEMP, I ) = VT2( 1, I ) + 140 CONTINUE + END IF + CTEMP = 1 + CTOT( 2 ) + CTOT( 3 ) + CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ, + $ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT ) + * + RETURN + * + * End of DLASD3 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd4.f octave-2.9.16/libcruft/lapack/dlasd4.f *** octave-2.9.15/libcruft/lapack/dlasd4.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd4.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,890 ---- + SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER I, INFO, N + DOUBLE PRECISION RHO, SIGMA + * .. + * .. Array Arguments .. + DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) + * .. + * + * Purpose + * ======= + * + * This subroutine computes the square root of the I-th updated + * eigenvalue of a positive symmetric rank-one modification to + * a positive diagonal matrix whose entries are given as the squares + * of the corresponding entries in the array d, and that + * + * 0 <= D(i) < D(j) for i < j + * + * and that RHO > 0. This is arranged by the calling routine, and is + * no loss in generality. The rank-one modified system is thus + * + * diag( D ) * diag( D ) + RHO * Z * Z_transpose. + * + * where we assume the Euclidean norm of Z is 1. + * + * The method consists of approximating the rational functions in the + * secular equation by simpler interpolating rational functions. + * + * Arguments + * ========= + * + * N (input) INTEGER + * The length of all arrays. + * + * I (input) INTEGER + * The index of the eigenvalue to be computed. 1 <= I <= N. + * + * D (input) DOUBLE PRECISION array, dimension ( N ) + * The original eigenvalues. It is assumed that they are in + * order, 0 <= D(I) < D(J) for I < J. + * + * Z (input) DOUBLE PRECISION array, dimension ( N ) + * The components of the updating vector. + * + * DELTA (output) DOUBLE PRECISION array, dimension ( N ) + * If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th + * component. If N = 1, then DELTA(1) = 1. The vector DELTA + * contains the information necessary to construct the + * (singular) eigenvectors. + * + * RHO (input) DOUBLE PRECISION + * The scalar in the symmetric updating formula. + * + * SIGMA (output) DOUBLE PRECISION + * The computed sigma_I, the I-th updated eigenvalue. + * + * WORK (workspace) DOUBLE PRECISION array, dimension ( N ) + * If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th + * component. If N = 1, then WORK( 1 ) = 1. + * + * INFO (output) INTEGER + * = 0: successful exit + * > 0: if INFO = 1, the updating process failed. + * + * Internal Parameters + * =================== + * + * Logical variable ORGATI (origin-at-i?) is used for distinguishing + * whether D(i) or D(i+1) is treated as the origin. + * + * ORGATI = .true. origin at i + * ORGATI = .false. origin at i+1 + * + * Logical variable SWTCH3 (switch-for-3-poles?) is for noting + * if we are working with THREE poles! + * + * MAXIT is the maximum number of iterations allowed for each + * eigenvalue. + * + * Further Details + * =============== + * + * Based on contributions by + * Ren-Cang Li, Computer Science Division, University of California + * at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 20 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0, + $ TEN = 10.0D+0 ) + * .. + * .. Local Scalars .. + LOGICAL ORGATI, SWTCH, SWTCH3 + INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER + DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM, + $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS, + $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB, + $ SG2UB, TAU, TEMP, TEMP1, TEMP2, W + * .. + * .. Local Arrays .. + DOUBLE PRECISION DD( 3 ), ZZ( 3 ) + * .. + * .. External Subroutines .. + EXTERNAL DLAED6, DLASD5 + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT + * .. + * .. Executable Statements .. + * + * Since this routine is called in an inner loop, we do no argument + * checking. + * + * Quick return for N=1 and 2. + * + INFO = 0 + IF( N.EQ.1 ) THEN + * + * Presumably, I=1 upon entry + * + SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) ) + DELTA( 1 ) = ONE + WORK( 1 ) = ONE + RETURN + END IF + IF( N.EQ.2 ) THEN + CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK ) + RETURN + END IF + * + * Compute machine epsilon + * + EPS = DLAMCH( 'Epsilon' ) + RHOINV = ONE / RHO + * + * The case I = N + * + IF( I.EQ.N ) THEN + * + * Initialize some basic variables + * + II = N - 1 + NITER = 1 + * + * Calculate initial guess + * + TEMP = RHO / TWO + * + * If ||Z||_2 is not one, then TEMP should be set to + * RHO * ||Z||_2^2 / TWO + * + TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) ) + DO 10 J = 1, N + WORK( J ) = D( J ) + D( N ) + TEMP1 + DELTA( J ) = ( D( J )-D( N ) ) - TEMP1 + 10 CONTINUE + * + PSI = ZERO + DO 20 J = 1, N - 2 + PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) ) + 20 CONTINUE + * + C = RHOINV + PSI + W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) + + $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) ) + * + IF( W.LE.ZERO ) THEN + TEMP1 = SQRT( D( N )*D( N )+RHO ) + TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )* + $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) + + $ Z( N )*Z( N ) / RHO + * + * The following TAU is to approximate + * SIGMA_n^2 - D( N )*D( N ) + * + IF( C.LE.TEMP ) THEN + TAU = RHO + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + END IF + * + * It can be proved that + * D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO + * + ELSE + DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) + A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) + B = Z( N )*Z( N )*DELSQ + * + * The following TAU is to approximate + * SIGMA_n^2 - D( N )*D( N ) + * + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) + ELSE + TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) + END IF + * + * It can be proved that + * D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 + * + END IF + * + * The following ETA is to approximate SIGMA_n - D( N ) + * + ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) ) + * + SIGMA = D( N ) + ETA + DO 30 J = 1, N + DELTA( J ) = ( D( J )-D( I ) ) - ETA + WORK( J ) = D( J ) + D( I ) + ETA + 30 CONTINUE + * + * Evaluate PSI and the derivative DPSI + * + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 40 J = 1, II + TEMP = Z( J ) / ( DELTA( J )*WORK( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 40 CONTINUE + ERRETM = ABS( ERRETM ) + * + * Evaluate PHI and the derivative DPHI + * + TEMP = Z( N ) / ( DELTA( N )*WORK( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) + * + W = RHOINV + PHI + PSI + * + * Test for convergence + * + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF + * + * Calculate the new step + * + NITER = NITER + 1 + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI ) + B = DTNSQ*DTNSQ1*W + IF( C.LT.ZERO ) + $ C = ABS( C ) + IF( C.EQ.ZERO ) THEN + ETA = RHO - SIGMA*SIGMA + ELSE IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + * + * Note, eta should be positive if w is negative, and + * eta should be negative otherwise. However, + * if for some reason caused by roundoff, eta*w > 0, + * we simply use one Newton step instead. This way + * will guarantee eta*w < 0. + * + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.GT.RHO ) + $ ETA = RHO + DTNSQ + * + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + DO 50 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 50 CONTINUE + * + SIGMA = SIGMA + ETA + * + * Evaluate PSI and the derivative DPSI + * + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 60 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 60 CONTINUE + ERRETM = ABS( ERRETM ) + * + * Evaluate PHI and the derivative DPHI + * + TEMP = Z( N ) / ( WORK( N )*DELTA( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) + * + W = RHOINV + PHI + PSI + * + * Main loop to update the values of the array DELTA + * + ITER = NITER + 1 + * + DO 90 NITER = ITER, MAXIT + * + * Test for convergence + * + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF + * + * Calculate the new step + * + DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) + DTNSQ = WORK( N )*DELTA( N ) + C = W - DTNSQ1*DPSI - DTNSQ*DPHI + A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI ) + B = DTNSQ1*DTNSQ*W + IF( A.GE.ZERO ) THEN + ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + * + * Note, eta should be positive if w is negative, and + * eta should be negative otherwise. However, + * if for some reason caused by roundoff, eta*w > 0, + * we simply use one Newton step instead. This way + * will guarantee eta*w < 0. + * + IF( W*ETA.GT.ZERO ) + $ ETA = -W / ( DPSI+DPHI ) + TEMP = ETA - DTNSQ + IF( TEMP.LE.ZERO ) + $ ETA = ETA / TWO + * + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) + DO 70 J = 1, N + DELTA( J ) = DELTA( J ) - ETA + WORK( J ) = WORK( J ) + ETA + 70 CONTINUE + * + SIGMA = SIGMA + ETA + * + * Evaluate PSI and the derivative DPSI + * + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 80 J = 1, II + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 80 CONTINUE + ERRETM = ABS( ERRETM ) + * + * Evaluate PHI and the derivative DPHI + * + TEMP = Z( N ) / ( WORK( N )*DELTA( N ) ) + PHI = Z( N )*TEMP + DPHI = TEMP*TEMP + ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + + $ ABS( TAU )*( DPSI+DPHI ) + * + W = RHOINV + PHI + PSI + 90 CONTINUE + * + * Return with INFO = 1, NITER = MAXIT and not converged + * + INFO = 1 + GO TO 240 + * + * End for the case I = N + * + ELSE + * + * The case for I < N + * + NITER = 1 + IP1 = I + 1 + * + * Calculate initial guess + * + DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) ) + DELSQ2 = DELSQ / TWO + TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) ) + DO 100 J = 1, N + WORK( J ) = D( J ) + D( I ) + TEMP + DELTA( J ) = ( D( J )-D( I ) ) - TEMP + 100 CONTINUE + * + PSI = ZERO + DO 110 J = 1, I - 1 + PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 110 CONTINUE + * + PHI = ZERO + DO 120 J = N, I + 2, -1 + PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) + 120 CONTINUE + C = RHOINV + PSI + PHI + W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) + + $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) ) + * + IF( W.GT.ZERO ) THEN + * + * d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 + * + * We choose d(i) as origin. + * + ORGATI = .TRUE. + SG2LB = ZERO + SG2UB = DELSQ2 + A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) + B = Z( I )*Z( I )*DELSQ + IF( A.GT.ZERO ) THEN + TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + ELSE + TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + END IF + * + * TAU now is an estimation of SIGMA^2 - D( I )^2. The + * following, however, is the corresponding estimation of + * SIGMA - D( I ). + * + ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) ) + ELSE + * + * (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 + * + * We choose d(i+1) as origin. + * + ORGATI = .FALSE. + SG2LB = -DELSQ2 + SG2UB = ZERO + A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) + B = Z( IP1 )*Z( IP1 )*DELSQ + IF( A.LT.ZERO ) THEN + TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) + ELSE + TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) + END IF + * + * TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The + * following, however, is the corresponding estimation of + * SIGMA - D( IP1 ). + * + ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+ + $ TAU ) ) ) + END IF + * + IF( ORGATI ) THEN + II = I + SIGMA = D( I ) + ETA + DO 130 J = 1, N + WORK( J ) = D( J ) + D( I ) + ETA + DELTA( J ) = ( D( J )-D( I ) ) - ETA + 130 CONTINUE + ELSE + II = I + 1 + SIGMA = D( IP1 ) + ETA + DO 140 J = 1, N + WORK( J ) = D( J ) + D( IP1 ) + ETA + DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA + 140 CONTINUE + END IF + IIM1 = II - 1 + IIP1 = II + 1 + * + * Evaluate PSI and the derivative DPSI + * + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 150 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 150 CONTINUE + ERRETM = ABS( ERRETM ) + * + * Evaluate PHI and the derivative DPHI + * + DPHI = ZERO + PHI = ZERO + DO 160 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 160 CONTINUE + * + W = RHOINV + PHI + PSI + * + * W is the value of the secular function with + * its ii-th element removed. + * + SWTCH3 = .FALSE. + IF( ORGATI ) THEN + IF( W.LT.ZERO ) + $ SWTCH3 = .TRUE. + ELSE + IF( W.GT.ZERO ) + $ SWTCH3 = .TRUE. + END IF + IF( II.EQ.1 .OR. II.EQ.N ) + $ SWTCH3 = .FALSE. + * + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = W + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW + * + * Test for convergence + * + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF + * + IF( W.LE.ZERO ) THEN + SG2LB = MAX( SG2LB, TAU ) + ELSE + SG2UB = MIN( SG2UB, TAU ) + END IF + * + * Calculate the new step + * + NITER = NITER + 1 + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI ) + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE + * + * Interpolation using THREE most relevant poles + * + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIP*( DPSI+DPHI ) ) - + $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + C = ( TEMP - DTIIM*( DPSI+DPHI ) ) - + $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + ZZ( 2 ) = Z( II )*Z( II ) + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 240 + END IF + * + * Note, eta should be positive if w is negative, and + * eta should be negative otherwise. However, + * if for some reason caused by roundoff, eta*w > 0, + * we simply use one Newton step instead. This way + * will guarantee eta*w < 0. + * + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW + IF( ORGATI ) THEN + TEMP1 = WORK( I )*DELTA( I ) + TEMP = ETA - TEMP1 + ELSE + TEMP1 = WORK( IP1 )*DELTA( IP1 ) + TEMP = ETA - TEMP1 + END IF + IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SG2UB-TAU ) / TWO + ELSE + ETA = ( SG2LB-TAU ) / TWO + END IF + END IF + * + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) + * + PREW = W + * + SIGMA = SIGMA + ETA + DO 170 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 170 CONTINUE + * + * Evaluate PSI and the derivative DPSI + * + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 180 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 180 CONTINUE + ERRETM = ABS( ERRETM ) + * + * Evaluate PHI and the derivative DPHI + * + DPHI = ZERO + PHI = ZERO + DO 190 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 190 CONTINUE + * + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW + * + IF( W.LE.ZERO ) THEN + SG2LB = MAX( SG2LB, TAU ) + ELSE + SG2UB = MIN( SG2UB, TAU ) + END IF + * + SWTCH = .FALSE. + IF( ORGATI ) THEN + IF( -W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + ELSE + IF( W.GT.ABS( PREW ) / TEN ) + $ SWTCH = .TRUE. + END IF + * + * Main loop to update the values of the array DELTA and WORK + * + ITER = NITER + 1 + * + DO 230 NITER = ITER, MAXIT + * + * Test for convergence + * + IF( ABS( W ).LE.EPS*ERRETM ) THEN + GO TO 240 + END IF + * + * Calculate the new step + * + IF( .NOT.SWTCH3 ) THEN + DTIPSQ = WORK( IP1 )*DELTA( IP1 ) + DTISQ = WORK( I )*DELTA( I ) + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 + ELSE + C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 + END IF + ELSE + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + IF( ORGATI ) THEN + DPSI = DPSI + TEMP*TEMP + ELSE + DPHI = DPHI + TEMP*TEMP + END IF + C = W - DTISQ*DPSI - DTIPSQ*DPHI + END IF + A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW + B = DTIPSQ*DTISQ*W + IF( C.EQ.ZERO ) THEN + IF( A.EQ.ZERO ) THEN + IF( .NOT.SWTCH ) THEN + IF( ORGATI ) THEN + A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* + $ ( DPSI+DPHI ) + ELSE + A = Z( IP1 )*Z( IP1 ) + + $ DTISQ*DTISQ*( DPSI+DPHI ) + END IF + ELSE + A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI + END IF + END IF + ETA = B / A + ELSE IF( A.LE.ZERO ) THEN + ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) + ELSE + ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) + END IF + ELSE + * + * Interpolation using THREE most relevant poles + * + DTIIM = WORK( IIM1 )*DELTA( IIM1 ) + DTIIP = WORK( IIP1 )*DELTA( IIP1 ) + TEMP = RHOINV + PSI + PHI + IF( SWTCH ) THEN + C = TEMP - DTIIM*DPSI - DTIIP*DPHI + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + IF( ORGATI ) THEN + TEMP1 = Z( IIM1 ) / DTIIM + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIM1 )-D( IIP1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2 + ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) + IF( DPSI.LT.TEMP1 ) THEN + ZZ( 3 ) = DTIIP*DTIIP*DPHI + ELSE + ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) + END IF + ELSE + TEMP1 = Z( IIP1 ) / DTIIP + TEMP1 = TEMP1*TEMP1 + TEMP2 = ( D( IIP1 )-D( IIM1 ) )* + $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 + C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2 + IF( DPHI.LT.TEMP1 ) THEN + ZZ( 1 ) = DTIIM*DTIIM*DPSI + ELSE + ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) + END IF + ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) + END IF + END IF + DD( 1 ) = DTIIM + DD( 2 ) = DELTA( II )*WORK( II ) + DD( 3 ) = DTIIP + CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 240 + END IF + * + * Note, eta should be positive if w is negative, and + * eta should be negative otherwise. However, + * if for some reason caused by roundoff, eta*w > 0, + * we simply use one Newton step instead. This way + * will guarantee eta*w < 0. + * + IF( W*ETA.GE.ZERO ) + $ ETA = -W / DW + IF( ORGATI ) THEN + TEMP1 = WORK( I )*DELTA( I ) + TEMP = ETA - TEMP1 + ELSE + TEMP1 = WORK( IP1 )*DELTA( IP1 ) + TEMP = ETA - TEMP1 + END IF + IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN + IF( W.LT.ZERO ) THEN + ETA = ( SG2UB-TAU ) / TWO + ELSE + ETA = ( SG2LB-TAU ) / TWO + END IF + END IF + * + TAU = TAU + ETA + ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) + * + SIGMA = SIGMA + ETA + DO 200 J = 1, N + WORK( J ) = WORK( J ) + ETA + DELTA( J ) = DELTA( J ) - ETA + 200 CONTINUE + * + PREW = W + * + * Evaluate PSI and the derivative DPSI + * + DPSI = ZERO + PSI = ZERO + ERRETM = ZERO + DO 210 J = 1, IIM1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PSI = PSI + Z( J )*TEMP + DPSI = DPSI + TEMP*TEMP + ERRETM = ERRETM + PSI + 210 CONTINUE + ERRETM = ABS( ERRETM ) + * + * Evaluate PHI and the derivative DPHI + * + DPHI = ZERO + PHI = ZERO + DO 220 J = N, IIP1, -1 + TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) + PHI = PHI + Z( J )*TEMP + DPHI = DPHI + TEMP*TEMP + ERRETM = ERRETM + PHI + 220 CONTINUE + * + TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) + DW = DPSI + DPHI + TEMP*TEMP + TEMP = Z( II )*TEMP + W = RHOINV + PHI + PSI + TEMP + ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + + $ THREE*ABS( TEMP ) + ABS( TAU )*DW + IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) + $ SWTCH = .NOT.SWTCH + * + IF( W.LE.ZERO ) THEN + SG2LB = MAX( SG2LB, TAU ) + ELSE + SG2UB = MIN( SG2UB, TAU ) + END IF + * + 230 CONTINUE + * + * Return with INFO = 1, NITER = MAXIT and not converged + * + INFO = 1 + * + END IF + * + 240 CONTINUE + RETURN + * + * End of DLASD4 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd5.f octave-2.9.16/libcruft/lapack/dlasd5.f *** octave-2.9.15/libcruft/lapack/dlasd5.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd5.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,163 ---- + SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER I + DOUBLE PRECISION DSIGMA, RHO + * .. + * .. Array Arguments .. + DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) + * .. + * + * Purpose + * ======= + * + * This subroutine computes the square root of the I-th eigenvalue + * of a positive symmetric rank-one modification of a 2-by-2 diagonal + * matrix + * + * diag( D ) * diag( D ) + RHO * Z * transpose(Z) . + * + * The diagonal entries in the array D are assumed to satisfy + * + * 0 <= D(i) < D(j) for i < j . + * + * We also assume RHO > 0 and that the Euclidean norm of the vector + * Z is one. + * + * Arguments + * ========= + * + * I (input) INTEGER + * The index of the eigenvalue to be computed. I = 1 or I = 2. + * + * D (input) DOUBLE PRECISION array, dimension ( 2 ) + * The original eigenvalues. We assume 0 <= D(1) < D(2). + * + * Z (input) DOUBLE PRECISION array, dimension ( 2 ) + * The components of the updating vector. + * + * DELTA (output) DOUBLE PRECISION array, dimension ( 2 ) + * Contains (D(j) - sigma_I) in its j-th component. + * The vector DELTA contains the information necessary + * to construct the eigenvectors. + * + * RHO (input) DOUBLE PRECISION + * The scalar in the symmetric updating formula. + * + * DSIGMA (output) DOUBLE PRECISION + * The computed sigma_I, the I-th updated eigenvalue. + * + * WORK (workspace) DOUBLE PRECISION array, dimension ( 2 ) + * WORK contains (D(j) + sigma_I) in its j-th component. + * + * Further Details + * =============== + * + * Based on contributions by + * Ren-Cang Li, Computer Science Division, University of California + * at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0, FOUR = 4.0D+0 ) + * .. + * .. Local Scalars .. + DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, SQRT + * .. + * .. Executable Statements .. + * + DEL = D( 2 ) - D( 1 ) + DELSQ = DEL*( D( 2 )+D( 1 ) ) + IF( I.EQ.1 ) THEN + W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )- + $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL + IF( W.GT.ZERO ) THEN + B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 1 )*Z( 1 )*DELSQ + * + * B > ZERO, always + * + * The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) + * + TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) + * + * The following TAU is DSIGMA - D( 1 ) + * + TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) ) + DSIGMA = D( 1 ) + TAU + DELTA( 1 ) = -TAU + DELTA( 2 ) = DEL - TAU + WORK( 1 ) = TWO*D( 1 ) + TAU + WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 ) + * DELTA( 1 ) = -Z( 1 ) / TAU + * DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) + ELSE + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ + * + * The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) + * + IF( B.GT.ZERO ) THEN + TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) + ELSE + TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO + END IF + * + * The following TAU is DSIGMA - D( 2 ) + * + TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU + * DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) + * DELTA( 2 ) = -Z( 2 ) / TAU + END IF + * TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) + * DELTA( 1 ) = DELTA( 1 ) / TEMP + * DELTA( 2 ) = DELTA( 2 ) / TEMP + ELSE + * + * Now I=2 + * + B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) + C = RHO*Z( 2 )*Z( 2 )*DELSQ + * + * The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) + * + IF( B.GT.ZERO ) THEN + TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO + ELSE + TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) + END IF + * + * The following TAU is DSIGMA - D( 2 ) + * + TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) ) + DSIGMA = D( 2 ) + TAU + DELTA( 1 ) = -( DEL+TAU ) + DELTA( 2 ) = -TAU + WORK( 1 ) = D( 1 ) + TAU + D( 2 ) + WORK( 2 ) = TWO*D( 2 ) + TAU + * DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) + * DELTA( 2 ) = -Z( 2 ) / TAU + * TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) + * DELTA( 1 ) = DELTA( 1 ) / TEMP + * DELTA( 2 ) = DELTA( 2 ) / TEMP + END IF + RETURN + * + * End of DLASD5 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd6.f octave-2.9.16/libcruft/lapack/dlasd6.f *** octave-2.9.15/libcruft/lapack/dlasd6.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd6.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,305 ---- + SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, + $ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, + $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, + $ IWORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S + * .. + * .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), + $ PERM( * ) + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), + $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), + $ VF( * ), VL( * ), WORK( * ), Z( * ) + * .. + * + * Purpose + * ======= + * + * DLASD6 computes the SVD of an updated upper bidiagonal matrix B + * obtained by merging two smaller ones by appending a row. This + * routine is used only for the problem which requires all singular + * values and optionally singular vector matrices in factored form. + * B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. + * A related subroutine, DLASD1, handles the case in which all singular + * values and singular vectors of the bidiagonal matrix are desired. + * + * DLASD6 computes the SVD as follows: + * + * ( D1(in) 0 0 0 ) + * B = U(in) * ( Z1' a Z2' b ) * VT(in) + * ( 0 0 D2(in) 0 ) + * + * = U(out) * ( D(out) 0) * VT(out) + * + * where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M + * with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros + * elsewhere; and the entry b is empty if SQRE = 0. + * + * The singular values of B can be computed using D1, D2, the first + * components of all the right singular vectors of the lower block, and + * the last components of all the right singular vectors of the upper + * block. These components are stored and updated in VF and VL, + * respectively, in DLASD6. Hence U and VT are not explicitly + * referenced. + * + * The singular values are stored in D. The algorithm consists of two + * stages: + * + * The first stage consists of deflating the size of the problem + * when there are multiple singular values or if there is a zero + * in the Z vector. For each such occurence the dimension of the + * secular equation problem is reduced by one. This stage is + * performed by the routine DLASD7. + * + * The second stage consists of calculating the updated + * singular values. This is done by finding the roots of the + * secular equation via the routine DLASD4 (as called by DLASD8). + * This routine also updates VF and VL and computes the distances + * between the updated singular values and the old singular + * values. + * + * DLASD6 is called from DLASDA. + * + * Arguments + * ========= + * + * ICOMPQ (input) INTEGER + * Specifies whether singular vectors are to be computed in + * factored form: + * = 0: Compute singular values only. + * = 1: Compute singular vectors in factored form as well. + * + * NL (input) INTEGER + * The row dimension of the upper block. NL >= 1. + * + * NR (input) INTEGER + * The row dimension of the lower block. NR >= 1. + * + * SQRE (input) INTEGER + * = 0: the lower block is an NR-by-NR square matrix. + * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + * + * The bidiagonal matrix has row dimension N = NL + NR + 1, + * and column dimension M = N + SQRE. + * + * D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ). + * On entry D(1:NL,1:NL) contains the singular values of the + * upper block, and D(NL+2:N) contains the singular values + * of the lower block. On exit D(1:N) contains the singular + * values of the modified matrix. + * + * VF (input/output) DOUBLE PRECISION array, dimension ( M ) + * On entry, VF(1:NL+1) contains the first components of all + * right singular vectors of the upper block; and VF(NL+2:M) + * contains the first components of all right singular vectors + * of the lower block. On exit, VF contains the first components + * of all right singular vectors of the bidiagonal matrix. + * + * VL (input/output) DOUBLE PRECISION array, dimension ( M ) + * On entry, VL(1:NL+1) contains the last components of all + * right singular vectors of the upper block; and VL(NL+2:M) + * contains the last components of all right singular vectors of + * the lower block. On exit, VL contains the last components of + * all right singular vectors of the bidiagonal matrix. + * + * ALPHA (input/output) DOUBLE PRECISION + * Contains the diagonal element associated with the added row. + * + * BETA (input/output) DOUBLE PRECISION + * Contains the off-diagonal element associated with the added + * row. + * + * IDXQ (output) INTEGER array, dimension ( N ) + * This contains the permutation which will reintegrate the + * subproblem just solved back into sorted order, i.e. + * D( IDXQ( I = 1, N ) ) will be in ascending order. + * + * PERM (output) INTEGER array, dimension ( N ) + * The permutations (from deflation and sorting) to be applied + * to each block. Not referenced if ICOMPQ = 0. + * + * GIVPTR (output) INTEGER + * The number of Givens rotations which took place in this + * subproblem. Not referenced if ICOMPQ = 0. + * + * GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) + * Each pair of numbers indicates a pair of columns to take place + * in a Givens rotation. Not referenced if ICOMPQ = 0. + * + * LDGCOL (input) INTEGER + * leading dimension of GIVCOL, must be at least N. + * + * GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + * Each number indicates the C or S value to be used in the + * corresponding Givens rotation. Not referenced if ICOMPQ = 0. + * + * LDGNUM (input) INTEGER + * The leading dimension of GIVNUM and POLES, must be at least N. + * + * POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + * On exit, POLES(1,*) is an array containing the new singular + * values obtained from solving the secular equation, and + * POLES(2,*) is an array containing the poles in the secular + * equation. Not referenced if ICOMPQ = 0. + * + * DIFL (output) DOUBLE PRECISION array, dimension ( N ) + * On exit, DIFL(I) is the distance between I-th updated + * (undeflated) singular value and the I-th (undeflated) old + * singular value. + * + * DIFR (output) DOUBLE PRECISION array, + * dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and + * dimension ( N ) if ICOMPQ = 0. + * On exit, DIFR(I, 1) is the distance between I-th updated + * (undeflated) singular value and the I+1-th (undeflated) old + * singular value. + * + * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the + * normalizing factors for the right singular vector matrix. + * + * See DLASD8 for details on DIFL and DIFR. + * + * Z (output) DOUBLE PRECISION array, dimension ( M ) + * The first elements of this array contain the components + * of the deflation-adjusted updating row vector. + * + * K (output) INTEGER + * Contains the dimension of the non-deflated matrix, + * This is the order of the related secular equation. 1 <= K <=N. + * + * C (output) DOUBLE PRECISION + * C contains garbage if SQRE =0 and the C-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * S (output) DOUBLE PRECISION + * S contains garbage if SQRE =0 and the S-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M ) + * + * IWORK (workspace) INTEGER array, dimension ( 3 * N ) + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: if INFO = 1, an singular value did not converge + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M, + $ N, N1, N2 + DOUBLE PRECISION ORGNRM + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, MAX + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + N = NL + NR + 1 + M = N + SQRE + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -14 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD6', -INFO ) + RETURN + END IF + * + * The following values are for bookkeeping purposes only. They are + * integer pointers which indicate the portion of the workspace + * used by a particular array in DLASD7 and DLASD8. + * + ISIGMA = 1 + IW = ISIGMA + N + IVFW = IW + M + IVLW = IVFW + M + * + IDX = 1 + IDXC = IDX + N + IDXP = IDXC + N + * + * Scale. + * + ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) + D( NL+1 ) = ZERO + DO 10 I = 1, N + IF( ABS( D( I ) ).GT.ORGNRM ) THEN + ORGNRM = ABS( D( I ) ) + END IF + 10 CONTINUE + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + ALPHA = ALPHA / ORGNRM + BETA = BETA / ORGNRM + * + * Sort and Deflate singular values. + * + CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF, + $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA, + $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, + $ INFO ) + * + * Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. + * + CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM, + $ WORK( ISIGMA ), WORK( IW ), INFO ) + * + * Save the poles if ICOMPQ = 1. + * + IF( ICOMPQ.EQ.1 ) THEN + CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 ) + CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 ) + END IF + * + * Unscale. + * + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + * + * Prepare the IDXQ sorting permutation. + * + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) + * + RETURN + * + * End of DLASD6 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd7.f octave-2.9.16/libcruft/lapack/dlasd7.f *** octave-2.9.15/libcruft/lapack/dlasd7.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd7.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,444 ---- + SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, + $ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ C, S, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, + $ NR, SQRE + DOUBLE PRECISION ALPHA, BETA, C, S + * .. + * .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), + $ IDXQ( * ), PERM( * ) + DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), + $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), + $ ZW( * ) + * .. + * + * Purpose + * ======= + * + * DLASD7 merges the two sets of singular values together into a single + * sorted set. Then it tries to deflate the size of the problem. There + * are two ways in which deflation can occur: when two or more singular + * values are close together or if there is a tiny entry in the Z + * vector. For each such occurrence the order of the related + * secular equation problem is reduced by one. + * + * DLASD7 is called from DLASD6. + * + * Arguments + * ========= + * + * ICOMPQ (input) INTEGER + * Specifies whether singular vectors are to be computed + * in compact form, as follows: + * = 0: Compute singular values only. + * = 1: Compute singular vectors of upper + * bidiagonal matrix in compact form. + * + * NL (input) INTEGER + * The row dimension of the upper block. NL >= 1. + * + * NR (input) INTEGER + * The row dimension of the lower block. NR >= 1. + * + * SQRE (input) INTEGER + * = 0: the lower block is an NR-by-NR square matrix. + * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + * + * The bidiagonal matrix has + * N = NL + NR + 1 rows and + * M = N + SQRE >= N columns. + * + * K (output) INTEGER + * Contains the dimension of the non-deflated matrix, this is + * the order of the related secular equation. 1 <= K <=N. + * + * D (input/output) DOUBLE PRECISION array, dimension ( N ) + * On entry D contains the singular values of the two submatrices + * to be combined. On exit D contains the trailing (N-K) updated + * singular values (those which were deflated) sorted into + * increasing order. + * + * Z (output) DOUBLE PRECISION array, dimension ( M ) + * On exit Z contains the updating row vector in the secular + * equation. + * + * ZW (workspace) DOUBLE PRECISION array, dimension ( M ) + * Workspace for Z. + * + * VF (input/output) DOUBLE PRECISION array, dimension ( M ) + * On entry, VF(1:NL+1) contains the first components of all + * right singular vectors of the upper block; and VF(NL+2:M) + * contains the first components of all right singular vectors + * of the lower block. On exit, VF contains the first components + * of all right singular vectors of the bidiagonal matrix. + * + * VFW (workspace) DOUBLE PRECISION array, dimension ( M ) + * Workspace for VF. + * + * VL (input/output) DOUBLE PRECISION array, dimension ( M ) + * On entry, VL(1:NL+1) contains the last components of all + * right singular vectors of the upper block; and VL(NL+2:M) + * contains the last components of all right singular vectors + * of the lower block. On exit, VL contains the last components + * of all right singular vectors of the bidiagonal matrix. + * + * VLW (workspace) DOUBLE PRECISION array, dimension ( M ) + * Workspace for VL. + * + * ALPHA (input) DOUBLE PRECISION + * Contains the diagonal element associated with the added row. + * + * BETA (input) DOUBLE PRECISION + * Contains the off-diagonal element associated with the added + * row. + * + * DSIGMA (output) DOUBLE PRECISION array, dimension ( N ) + * Contains a copy of the diagonal elements (K-1 singular values + * and one zero) in the secular equation. + * + * IDX (workspace) INTEGER array, dimension ( N ) + * This will contain the permutation used to sort the contents of + * D into ascending order. + * + * IDXP (workspace) INTEGER array, dimension ( N ) + * This will contain the permutation used to place deflated + * values of D at the end of the array. On output IDXP(2:K) + * points to the nondeflated D-values and IDXP(K+1:N) + * points to the deflated singular values. + * + * IDXQ (input) INTEGER array, dimension ( N ) + * This contains the permutation which separately sorts the two + * sub-problems in D into ascending order. Note that entries in + * the first half of this permutation must first be moved one + * position backward; and entries in the second half + * must first have NL+1 added to their values. + * + * PERM (output) INTEGER array, dimension ( N ) + * The permutations (from deflation and sorting) to be applied + * to each singular block. Not referenced if ICOMPQ = 0. + * + * GIVPTR (output) INTEGER + * The number of Givens rotations which took place in this + * subproblem. Not referenced if ICOMPQ = 0. + * + * GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) + * Each pair of numbers indicates a pair of columns to take place + * in a Givens rotation. Not referenced if ICOMPQ = 0. + * + * LDGCOL (input) INTEGER + * The leading dimension of GIVCOL, must be at least N. + * + * GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + * Each number indicates the C or S value to be used in the + * corresponding Givens rotation. Not referenced if ICOMPQ = 0. + * + * LDGNUM (input) INTEGER + * The leading dimension of GIVNUM, must be at least N. + * + * C (output) DOUBLE PRECISION + * C contains garbage if SQRE =0 and the C-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * S (output) DOUBLE PRECISION + * S contains garbage if SQRE =0 and the S-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ EIGHT = 8.0D+0 ) + * .. + * .. Local Scalars .. + * + INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, + $ NLP1, NLP2 + DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1 + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DLAMRG, DROT, XERBLA + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, MAX + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + N = NL + NR + 1 + M = N + SQRE + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -22 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD7', -INFO ) + RETURN + END IF + * + NLP1 = NL + 1 + NLP2 = NL + 2 + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = 0 + END IF + * + * Generate the first part of the vector Z and move the singular + * values in the first part of D one position backward. + * + Z1 = ALPHA*VL( NLP1 ) + VL( NLP1 ) = ZERO + TAU = VF( NLP1 ) + DO 10 I = NL, 1, -1 + Z( I+1 ) = ALPHA*VL( I ) + VL( I ) = ZERO + VF( I+1 ) = VF( I ) + D( I+1 ) = D( I ) + IDXQ( I+1 ) = IDXQ( I ) + 1 + 10 CONTINUE + VF( 1 ) = TAU + * + * Generate the second part of the vector Z. + * + DO 20 I = NLP2, M + Z( I ) = BETA*VF( I ) + VF( I ) = ZERO + 20 CONTINUE + * + * Sort the singular values into increasing order + * + DO 30 I = NLP2, N + IDXQ( I ) = IDXQ( I ) + NLP1 + 30 CONTINUE + * + * DSIGMA, IDXC, IDXC, and ZW are used as storage space. + * + DO 40 I = 2, N + DSIGMA( I ) = D( IDXQ( I ) ) + ZW( I ) = Z( IDXQ( I ) ) + VFW( I ) = VF( IDXQ( I ) ) + VLW( I ) = VL( IDXQ( I ) ) + 40 CONTINUE + * + CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) + * + DO 50 I = 2, N + IDXI = 1 + IDX( I ) + D( I ) = DSIGMA( IDXI ) + Z( I ) = ZW( IDXI ) + VF( I ) = VFW( IDXI ) + VL( I ) = VLW( IDXI ) + 50 CONTINUE + * + * Calculate the allowable deflation tolerence + * + EPS = DLAMCH( 'Epsilon' ) + TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) + TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) + * + * There are 2 kinds of deflation -- first a value in the z-vector + * is small, second two (or more) singular values are very close + * together (their difference is small). + * + * If the value in the z-vector is small, we simply permute the + * array so that the corresponding singular value is moved to the + * end. + * + * If two values in the D-vector are close, we perform a two-sided + * rotation designed to make one of the corresponding z-vector + * entries zero, and then permute the array so that the deflated + * singular value is moved to the end. + * + * If there are multiple singular values then the problem deflates. + * Here the number of equal singular values are found. As each equal + * singular value is found, an elementary reflector is computed to + * rotate the corresponding singular subspace so that the + * corresponding components of Z are zero in this new basis. + * + K = 1 + K2 = N + 1 + DO 60 J = 2, N + IF( ABS( Z( J ) ).LE.TOL ) THEN + * + * Deflate due to small z component. + * + K2 = K2 - 1 + IDXP( K2 ) = J + IF( J.EQ.N ) + $ GO TO 100 + ELSE + JPREV = J + GO TO 70 + END IF + 60 CONTINUE + 70 CONTINUE + J = JPREV + 80 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 90 + IF( ABS( Z( J ) ).LE.TOL ) THEN + * + * Deflate due to small z component. + * + K2 = K2 - 1 + IDXP( K2 ) = J + ELSE + * + * Check if singular values are close enough to allow deflation. + * + IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN + * + * Deflation is possible. + * + S = Z( JPREV ) + C = Z( J ) + * + * Find sqrt(a**2+b**2) without overflow or + * destructive underflow. + * + TAU = DLAPY2( C, S ) + Z( J ) = TAU + Z( JPREV ) = ZERO + C = C / TAU + S = -S / TAU + * + * Record the appropriate Givens rotation + * + IF( ICOMPQ.EQ.1 ) THEN + GIVPTR = GIVPTR + 1 + IDXJP = IDXQ( IDX( JPREV )+1 ) + IDXJ = IDXQ( IDX( J )+1 ) + IF( IDXJP.LE.NLP1 ) THEN + IDXJP = IDXJP - 1 + END IF + IF( IDXJ.LE.NLP1 ) THEN + IDXJ = IDXJ - 1 + END IF + GIVCOL( GIVPTR, 2 ) = IDXJP + GIVCOL( GIVPTR, 1 ) = IDXJ + GIVNUM( GIVPTR, 2 ) = C + GIVNUM( GIVPTR, 1 ) = S + END IF + CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S ) + CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S ) + K2 = K2 - 1 + IDXP( K2 ) = JPREV + JPREV = J + ELSE + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + JPREV = J + END IF + END IF + GO TO 80 + 90 CONTINUE + * + * Record the last singular value. + * + K = K + 1 + ZW( K ) = Z( JPREV ) + DSIGMA( K ) = D( JPREV ) + IDXP( K ) = JPREV + * + 100 CONTINUE + * + * Sort the singular values into DSIGMA. The singular values which + * were not deflated go into the first K slots of DSIGMA, except + * that DSIGMA(1) is treated separately. + * + DO 110 J = 2, N + JP = IDXP( J ) + DSIGMA( J ) = D( JP ) + VFW( J ) = VF( JP ) + VLW( J ) = VL( JP ) + 110 CONTINUE + IF( ICOMPQ.EQ.1 ) THEN + DO 120 J = 2, N + JP = IDXP( J ) + PERM( J ) = IDXQ( IDX( JP )+1 ) + IF( PERM( J ).LE.NLP1 ) THEN + PERM( J ) = PERM( J ) - 1 + END IF + 120 CONTINUE + END IF + * + * The deflated singular values go back into the last N - K slots of + * D. + * + CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) + * + * Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and + * VL(M). + * + DSIGMA( 1 ) = ZERO + HLFTOL = TOL / TWO + IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) + $ DSIGMA( 2 ) = HLFTOL + IF( M.GT.N ) THEN + Z( 1 ) = DLAPY2( Z1, Z( M ) ) + IF( Z( 1 ).LE.TOL ) THEN + C = ONE + S = ZERO + Z( 1 ) = TOL + ELSE + C = Z1 / Z( 1 ) + S = -Z( M ) / Z( 1 ) + END IF + CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S ) + CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S ) + ELSE + IF( ABS( Z1 ).LE.TOL ) THEN + Z( 1 ) = TOL + ELSE + Z( 1 ) = Z1 + END IF + END IF + * + * Restore Z, VF, and VL. + * + CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 ) + CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 ) + CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 ) + * + RETURN + * + * End of DLASD7 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasd8.f octave-2.9.16/libcruft/lapack/dlasd8.f *** octave-2.9.15/libcruft/lapack/dlasd8.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasd8.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,253 ---- + SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, + $ DSIGMA, WORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, K, LDDIFR + * .. + * .. Array Arguments .. + DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), + $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), + $ Z( * ) + * .. + * + * Purpose + * ======= + * + * DLASD8 finds the square roots of the roots of the secular equation, + * as defined by the values in DSIGMA and Z. It makes the appropriate + * calls to DLASD4, and stores, for each element in D, the distance + * to its two nearest poles (elements in DSIGMA). It also updates + * the arrays VF and VL, the first and last components of all the + * right singular vectors of the original bidiagonal matrix. + * + * DLASD8 is called from DLASD6. + * + * Arguments + * ========= + * + * ICOMPQ (input) INTEGER + * Specifies whether singular vectors are to be computed in + * factored form in the calling routine: + * = 0: Compute singular values only. + * = 1: Compute singular vectors in factored form as well. + * + * K (input) INTEGER + * The number of terms in the rational function to be solved + * by DLASD4. K >= 1. + * + * D (output) DOUBLE PRECISION array, dimension ( K ) + * On output, D contains the updated singular values. + * + * Z (input) DOUBLE PRECISION array, dimension ( K ) + * The first K elements of this array contain the components + * of the deflation-adjusted updating row vector. + * + * VF (input/output) DOUBLE PRECISION array, dimension ( K ) + * On entry, VF contains information passed through DBEDE8. + * On exit, VF contains the first K components of the first + * components of all right singular vectors of the bidiagonal + * matrix. + * + * VL (input/output) DOUBLE PRECISION array, dimension ( K ) + * On entry, VL contains information passed through DBEDE8. + * On exit, VL contains the first K components of the last + * components of all right singular vectors of the bidiagonal + * matrix. + * + * DIFL (output) DOUBLE PRECISION array, dimension ( K ) + * On exit, DIFL(I) = D(I) - DSIGMA(I). + * + * DIFR (output) DOUBLE PRECISION array, + * dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and + * dimension ( K ) if ICOMPQ = 0. + * On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not + * defined and will not be referenced. + * + * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the + * normalizing factors for the right singular vector matrix. + * + * LDDIFR (input) INTEGER + * The leading dimension of DIFR, must be at least K. + * + * DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) + * The first K elements of this array contain the old roots + * of the deflated updating problem. These are the poles + * of the secular equation. + * + * WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: if INFO = 1, an singular value did not converge + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA + * .. + * .. External Functions .. + DOUBLE PRECISION DDOT, DLAMC3, DNRM2 + EXTERNAL DDOT, DLAMC3, DNRM2 + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( K.LT.1 ) THEN + INFO = -2 + ELSE IF( LDDIFR.LT.K ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASD8', -INFO ) + RETURN + END IF + * + * Quick return if possible + * + IF( K.EQ.1 ) THEN + D( 1 ) = ABS( Z( 1 ) ) + DIFL( 1 ) = D( 1 ) + IF( ICOMPQ.EQ.1 ) THEN + DIFL( 2 ) = ONE + DIFR( 1, 2 ) = ONE + END IF + RETURN + END IF + * + * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can + * be computed with high relative accuracy (barring over/underflow). + * This is a problem on machines without a guard digit in + * add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). + * The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), + * which on any of these machines zeros out the bottommost + * bit of DSIGMA(I) if it is 1; this makes the subsequent + * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation + * occurs. On binary machines with a guard digit (almost all + * machines) it does not change DSIGMA(I) at all. On hexadecimal + * and decimal machines with a guard digit, it slightly + * changes the bottommost bits of DSIGMA(I). It does not account + * for hexadecimal or decimal machines without guard digits + * (we know of none). We use a subroutine call to compute + * 2*DSIGMA(I) to prevent optimizing compilers from eliminating + * this code. + * + DO 10 I = 1, K + DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) + 10 CONTINUE + * + * Book keeping. + * + IWK1 = 1 + IWK2 = IWK1 + K + IWK3 = IWK2 + K + IWK2I = IWK2 - 1 + IWK3I = IWK3 - 1 + * + * Normalize Z. + * + RHO = DNRM2( K, Z, 1 ) + CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) + RHO = RHO*RHO + * + * Initialize WORK(IWK3). + * + CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K ) + * + * Compute the updated singular values, the arrays DIFL, DIFR, + * and the updated Z. + * + DO 40 J = 1, K + CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), + $ WORK( IWK2 ), INFO ) + * + * If the root finder fails, the computation is terminated. + * + IF( INFO.NE.0 ) THEN + RETURN + END IF + WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J ) + DIFL( J ) = -WORK( J ) + DIFR( J, 1 ) = -WORK( J+1 ) + DO 20 I = 1, J - 1 + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 20 CONTINUE + DO 30 I = J + 1, K + WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* + $ WORK( IWK2I+I ) / ( DSIGMA( I )- + $ DSIGMA( J ) ) / ( DSIGMA( I )+ + $ DSIGMA( J ) ) + 30 CONTINUE + 40 CONTINUE + * + * Compute updated Z. + * + DO 50 I = 1, K + Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) ) + 50 CONTINUE + * + * Update VF and VL. + * + DO 80 J = 1, K + DIFLJ = DIFL( J ) + DJ = D( J ) + DSIGJ = -DSIGMA( J ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -DSIGMA( J+1 ) + END IF + WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ ) + DO 60 I = 1, J - 1 + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) + $ / ( DSIGMA( I )+DJ ) + 60 CONTINUE + DO 70 I = J + 1, K + WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) + $ / ( DSIGMA( I )+DJ ) + 70 CONTINUE + TEMP = DNRM2( K, WORK, 1 ) + WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP + WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP + IF( ICOMPQ.EQ.1 ) THEN + DIFR( J, 2 ) = TEMP + END IF + 80 CONTINUE + * + CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 ) + CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 ) + * + RETURN + * + * End of DLASD8 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasda.f octave-2.9.16/libcruft/lapack/dlasda.f *** octave-2.9.15/libcruft/lapack/dlasda.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasda.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,390 ---- + SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, + $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, + $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE + * .. + * .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), + $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), + $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), + $ Z( LDU, * ) + * .. + * + * Purpose + * ======= + * + * Using a divide and conquer approach, DLASDA computes the singular + * value decomposition (SVD) of a real upper bidiagonal N-by-M matrix + * B with diagonal D and offdiagonal E, where M = N + SQRE. The + * algorithm computes the singular values in the SVD B = U * S * VT. + * The orthogonal matrices U and VT are optionally computed in + * compact form. + * + * A related subroutine, DLASD0, computes the singular values and + * the singular vectors in explicit form. + * + * Arguments + * ========= + * + * ICOMPQ (input) INTEGER + * Specifies whether singular vectors are to be computed + * in compact form, as follows + * = 0: Compute singular values only. + * = 1: Compute singular vectors of upper bidiagonal + * matrix in compact form. + * + * SMLSIZ (input) INTEGER + * The maximum size of the subproblems at the bottom of the + * computation tree. + * + * N (input) INTEGER + * The row dimension of the upper bidiagonal matrix. This is + * also the dimension of the main diagonal array D. + * + * SQRE (input) INTEGER + * Specifies the column dimension of the bidiagonal matrix. + * = 0: The bidiagonal matrix has column dimension M = N; + * = 1: The bidiagonal matrix has column dimension M = N + 1. + * + * D (input/output) DOUBLE PRECISION array, dimension ( N ) + * On entry D contains the main diagonal of the bidiagonal + * matrix. On exit D, if INFO = 0, contains its singular values. + * + * E (input) DOUBLE PRECISION array, dimension ( M-1 ) + * Contains the subdiagonal entries of the bidiagonal matrix. + * On exit, E has been destroyed. + * + * U (output) DOUBLE PRECISION array, + * dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced + * if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left + * singular vector matrices of all subproblems at the bottom + * level. + * + * LDU (input) INTEGER, LDU = > N. + * The leading dimension of arrays U, VT, DIFL, DIFR, POLES, + * GIVNUM, and Z. + * + * VT (output) DOUBLE PRECISION array, + * dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced + * if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right + * singular vector matrices of all subproblems at the bottom + * level. + * + * K (output) INTEGER array, + * dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. + * If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th + * secular equation on the computation tree. + * + * DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ), + * where NLVL = floor(log_2 (N/SMLSIZ))). + * + * DIFR (output) DOUBLE PRECISION array, + * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and + * dimension ( N ) if ICOMPQ = 0. + * If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) + * record distances between singular values on the I-th + * level and singular values on the (I -1)-th level, and + * DIFR(1:N, 2 * I ) contains the normalizing factors for + * the right singular vector matrix. See DLASD8 for details. + * + * Z (output) DOUBLE PRECISION array, + * dimension ( LDU, NLVL ) if ICOMPQ = 1 and + * dimension ( N ) if ICOMPQ = 0. + * The first K elements of Z(1, I) contain the components of + * the deflation-adjusted updating row vector for subproblems + * on the I-th level. + * + * POLES (output) DOUBLE PRECISION array, + * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced + * if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and + * POLES(1, 2*I) contain the new and old singular values + * involved in the secular equations on the I-th level. + * + * GIVPTR (output) INTEGER array, + * dimension ( N ) if ICOMPQ = 1, and not referenced if + * ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records + * the number of Givens rotations performed on the I-th + * problem on the computation tree. + * + * GIVCOL (output) INTEGER array, + * dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not + * referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, + * GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations + * of Givens rotations performed on the I-th level on the + * computation tree. + * + * LDGCOL (input) INTEGER, LDGCOL = > N. + * The leading dimension of arrays GIVCOL and PERM. + * + * PERM (output) INTEGER array, + * dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced + * if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records + * permutations done on the I-th level of the computation tree. + * + * GIVNUM (output) DOUBLE PRECISION array, + * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not + * referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, + * GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- + * values of Givens rotations performed on the I-th level on + * the computation tree. + * + * C (output) DOUBLE PRECISION array, + * dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. + * If ICOMPQ = 1 and the I-th subproblem is not square, on exit, + * C( I ) contains the C-value of a Givens rotation related to + * the right null space of the I-th subproblem. + * + * S (output) DOUBLE PRECISION array, dimension ( N ) if + * ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 + * and the I-th subproblem is not square, on exit, S( I ) + * contains the S-value of a Givens rotation related to + * the right null space of the I-th subproblem. + * + * WORK (workspace) DOUBLE PRECISION array, dimension + * (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). + * + * IWORK (workspace) INTEGER array. + * Dimension must be at least (7 * N). + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: if INFO = 1, an singular value did not converge + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK, + $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML, + $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU, + $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI + DOUBLE PRECISION ALPHA, BETA + * .. + * .. External Subroutines .. + EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + ELSE IF( LDU.LT.( N+SQRE ) ) THEN + INFO = -8 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDA', -INFO ) + RETURN + END IF + * + M = N + SQRE + * + * If the input matrix is too small, call DLASDQ to find the SVD. + * + IF( N.LE.SMLSIZ ) THEN + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + ELSE + CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU, + $ U, LDU, WORK, INFO ) + END IF + RETURN + END IF + * + * Book-keeping and set up the computation tree. + * + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + IDXQ = NDIMR + N + IWK = IDXQ + N + * + NCC = 0 + NRU = 0 + * + SMLSZP = SMLSIZ + 1 + VF = 1 + VL = VF + M + NWORK1 = VL + M + NWORK2 = NWORK1 + SMLSZP*SMLSZP + * + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) + * + * for the nodes on bottom level of the tree, solve + * their subproblems by DLASDQ. + * + NDB1 = ( ND+1 ) / 2 + DO 30 I = NDB1, ND + * + * IC : center row of each node + * NL : number of rows of left subproblem + * NR : number of rows of right subproblem + * NLF: starting row of the left subproblem + * NRF: starting row of the right subproblem + * + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NLP1 = NL + 1 + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + IDXQI = IDXQ + NLF - 2 + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + SQREI = 1 + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ), + $ E( NLF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + NL*SMLSZP + CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU ) + CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), + $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU, + $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 10 J = 1, NL + IWORK( IDXQI+J ) = J + 10 CONTINUE + IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN + SQREI = 0 + ELSE + SQREI = 1 + END IF + IDXQI = IDXQI + NLP1 + VFI = VFI + NLP1 + VLI = VLI + NLP1 + NRP1 = NR + SQREI + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ), + $ SMLSZP ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ), + $ E( NRF ), WORK( NWORK1 ), SMLSZP, + $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR, + $ WORK( NWORK2 ), INFO ) + ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP + CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) + ELSE + CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU ) + CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU ) + CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), + $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU, + $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO ) + CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 ) + CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + DO 20 J = 1, NR + IWORK( IDXQI+J ) = J + 20 CONTINUE + 30 CONTINUE + * + * Now conquer each subproblem bottom-up. + * + J = 2**NLVL + DO 50 LVL = NLVL, 1, -1 + LVL2 = LVL*2 - 1 + * + * Find the first node LF and last node LL on + * the current level LVL. + * + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 40 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQREI = SQRE + ELSE + SQREI = 1 + END IF + VFI = VF + NLF - 1 + VLI = VL + NLF - 1 + IDXQI = IDXQ + NLF - 1 + ALPHA = D( IC ) + BETA = E( IC ) + IF( ICOMPQ.EQ.0 ) THEN + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL, + $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z, + $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + ELSE + J = J - 1 + CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), + $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, + $ IWORK( IDXQI ), PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, + $ POLES( NLF, LVL2 ), DIFL( NLF, LVL ), + $ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ), + $ C( J ), S( J ), WORK( NWORK1 ), + $ IWORK( IWK ), INFO ) + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + 40 CONTINUE + 50 CONTINUE + * + RETURN + * + * End of DLASDA + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasdq.f octave-2.9.16/libcruft/lapack/dlasdq.f *** octave-2.9.15/libcruft/lapack/dlasdq.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasdq.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,316 ---- + SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, + $ U, LDU, C, LDC, WORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE + * .. + * .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), + $ VT( LDVT, * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * DLASDQ computes the singular value decomposition (SVD) of a real + * (upper or lower) bidiagonal matrix with diagonal D and offdiagonal + * E, accumulating the transformations if desired. Letting B denote + * the input bidiagonal matrix, the algorithm computes orthogonal + * matrices Q and P such that B = Q * S * P' (P' denotes the transpose + * of P). The singular values S are overwritten on D. + * + * The input matrix U is changed to U * Q if desired. + * The input matrix VT is changed to P' * VT if desired. + * The input matrix C is changed to Q' * C if desired. + * + * See "Computing Small Singular Values of Bidiagonal Matrices With + * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, + * LAPACK Working Note #3, for a detailed description of the algorithm. + * + * Arguments + * ========= + * + * UPLO (input) CHARACTER*1 + * On entry, UPLO specifies whether the input bidiagonal matrix + * is upper or lower bidiagonal, and wether it is square are + * not. + * UPLO = 'U' or 'u' B is upper bidiagonal. + * UPLO = 'L' or 'l' B is lower bidiagonal. + * + * SQRE (input) INTEGER + * = 0: then the input matrix is N-by-N. + * = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and + * (N+1)-by-N if UPLU = 'L'. + * + * The bidiagonal matrix has + * N = NL + NR + 1 rows and + * M = N + SQRE >= N columns. + * + * N (input) INTEGER + * On entry, N specifies the number of rows and columns + * in the matrix. N must be at least 0. + * + * NCVT (input) INTEGER + * On entry, NCVT specifies the number of columns of + * the matrix VT. NCVT must be at least 0. + * + * NRU (input) INTEGER + * On entry, NRU specifies the number of rows of + * the matrix U. NRU must be at least 0. + * + * NCC (input) INTEGER + * On entry, NCC specifies the number of columns of + * the matrix C. NCC must be at least 0. + * + * D (input/output) DOUBLE PRECISION array, dimension (N) + * On entry, D contains the diagonal entries of the + * bidiagonal matrix whose SVD is desired. On normal exit, + * D contains the singular values in ascending order. + * + * E (input/output) DOUBLE PRECISION array. + * dimension is (N-1) if SQRE = 0 and N if SQRE = 1. + * On entry, the entries of E contain the offdiagonal entries + * of the bidiagonal matrix whose SVD is desired. On normal + * exit, E will contain 0. If the algorithm does not converge, + * D and E will contain the diagonal and superdiagonal entries + * of a bidiagonal matrix orthogonally equivalent to the one + * given as input. + * + * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) + * On entry, contains a matrix which on exit has been + * premultiplied by P', dimension N-by-NCVT if SQRE = 0 + * and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). + * + * LDVT (input) INTEGER + * On entry, LDVT specifies the leading dimension of VT as + * declared in the calling (sub) program. LDVT must be at + * least 1. If NCVT is nonzero LDVT must also be at least N. + * + * U (input/output) DOUBLE PRECISION array, dimension (LDU, N) + * On entry, contains a matrix which on exit has been + * postmultiplied by Q, dimension NRU-by-N if SQRE = 0 + * and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). + * + * LDU (input) INTEGER + * On entry, LDU specifies the leading dimension of U as + * declared in the calling (sub) program. LDU must be at + * least max( 1, NRU ) . + * + * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) + * On entry, contains an N-by-NCC matrix which on exit + * has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 + * and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). + * + * LDC (input) INTEGER + * On entry, LDC specifies the leading dimension of C as + * declared in the calling (sub) program. LDC must be at + * least 1. If NCC is nonzero, LDC must also be at least N. + * + * WORK (workspace) DOUBLE PRECISION array, dimension (4*N) + * Workspace. Only referenced if one of NCVT, NRU, or NCC is + * nonzero, and if N is at least 2. + * + * INFO (output) INTEGER + * On exit, a value of 0 indicates a successful exit. + * If INFO < 0, argument number -INFO is illegal. + * If INFO > 0, the algorithm did not converge, and INFO + * specifies how many superdiagonals did not converge. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + * .. + * .. Local Scalars .. + LOGICAL ROTATE + INTEGER I, ISUB, IUPLO, J, NP1, SQRE1 + DOUBLE PRECISION CS, R, SMIN, SN + * .. + * .. External Subroutines .. + EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA + * .. + * .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME + * .. + * .. Intrinsic Functions .. + INTRINSIC MAX + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + IUPLO = 0 + IF( LSAME( UPLO, 'U' ) ) + $ IUPLO = 1 + IF( LSAME( UPLO, 'L' ) ) + $ IUPLO = 2 + IF( IUPLO.EQ.0 ) THEN + INFO = -1 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NCVT.LT.0 ) THEN + INFO = -4 + ELSE IF( NRU.LT.0 ) THEN + INFO = -5 + ELSE IF( NCC.LT.0 ) THEN + INFO = -6 + ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. + $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN + INFO = -12 + ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. + $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASDQ', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN + * + * ROTATE is true if any singular vectors desired, false otherwise + * + ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) + NP1 = N + 1 + SQRE1 = SQRE + * + * If matrix non-square upper bidiagonal, rotate to be lower + * bidiagonal. The rotations are on the right. + * + IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN + DO 10 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 10 CONTINUE + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + E( N ) = ZERO + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + IUPLO = 2 + SQRE1 = 0 + * + * Update singular vectors if desired. + * + IF( NCVT.GT.0 ) + $ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ), + $ WORK( NP1 ), VT, LDVT ) + END IF + * + * If matrix lower bidiagonal, rotate to be upper bidiagonal + * by applying Givens rotations on the left. + * + IF( IUPLO.EQ.2 ) THEN + DO 20 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( ROTATE ) THEN + WORK( I ) = CS + WORK( N+I ) = SN + END IF + 20 CONTINUE + * + * If matrix (N+1)-by-N lower bidiagonal, one additional + * rotation is needed. + * + IF( SQRE1.EQ.1 ) THEN + CALL DLARTG( D( N ), E( N ), CS, SN, R ) + D( N ) = R + IF( ROTATE ) THEN + WORK( N ) = CS + WORK( N+N ) = SN + END IF + END IF + * + * Update singular vectors if desired. + * + IF( NRU.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + ELSE + CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ), + $ WORK( NP1 ), U, LDU ) + END IF + END IF + IF( NCC.GT.0 ) THEN + IF( SQRE1.EQ.0 ) THEN + CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + ELSE + CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ), + $ WORK( NP1 ), C, LDC ) + END IF + END IF + END IF + * + * Call DBDSQR to compute the SVD of the reduced real + * N-by-N upper bidiagonal matrix. + * + CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, + $ LDC, WORK, INFO ) + * + * Sort the singular values into ascending order (insertion sort on + * singular values, but only one transposition per singular vector) + * + DO 40 I = 1, N + * + * Scan for smallest D(I). + * + ISUB = I + SMIN = D( I ) + DO 30 J = I + 1, N + IF( D( J ).LT.SMIN ) THEN + ISUB = J + SMIN = D( J ) + END IF + 30 CONTINUE + IF( ISUB.NE.I ) THEN + * + * Swap singular values and vectors. + * + D( ISUB ) = D( I ) + D( I ) = SMIN + IF( NCVT.GT.0 ) + $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT ) + IF( NRU.GT.0 ) + $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 ) + IF( NCC.GT.0 ) + $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC ) + END IF + 40 CONTINUE + * + RETURN + * + * End of DLASDQ + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlasdt.f octave-2.9.16/libcruft/lapack/dlasdt.f *** octave-2.9.15/libcruft/lapack/dlasdt.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlasdt.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,105 ---- + SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER LVL, MSUB, N, ND + * .. + * .. Array Arguments .. + INTEGER INODE( * ), NDIML( * ), NDIMR( * ) + * .. + * + * Purpose + * ======= + * + * DLASDT creates a tree of subproblems for bidiagonal divide and + * conquer. + * + * Arguments + * ========= + * + * N (input) INTEGER + * On entry, the number of diagonal elements of the + * bidiagonal matrix. + * + * LVL (output) INTEGER + * On exit, the number of levels on the computation tree. + * + * ND (output) INTEGER + * On exit, the number of nodes on the tree. + * + * INODE (output) INTEGER array, dimension ( N ) + * On exit, centers of subproblems. + * + * NDIML (output) INTEGER array, dimension ( N ) + * On exit, row dimensions of left children. + * + * NDIMR (output) INTEGER array, dimension ( N ) + * On exit, row dimensions of right children. + * + * MSUB (input) INTEGER. + * On entry, the maximum row dimension each subproblem at the + * bottom of the tree can be of. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Huan Ren, Computer Science Division, University of + * California at Berkeley, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D+0 ) + * .. + * .. Local Scalars .. + INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL + DOUBLE PRECISION TEMP + * .. + * .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX + * .. + * .. Executable Statements .. + * + * Find the number of levels on the tree. + * + MAXN = MAX( 1, N ) + TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO ) + LVL = INT( TEMP ) + 1 + * + I = N / 2 + INODE( 1 ) = I + 1 + NDIML( 1 ) = I + NDIMR( 1 ) = N - I - 1 + IL = 0 + IR = 1 + LLST = 1 + DO 20 NLVL = 1, LVL - 1 + * + * Constructing the tree at (NLVL+1)-st level. The number of + * nodes created on this level is LLST * 2. + * + DO 10 I = 0, LLST - 1 + IL = IL + 2 + IR = IR + 2 + NCRNT = LLST + I + NDIML( IL ) = NDIML( NCRNT ) / 2 + NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1 + INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1 + NDIML( IR ) = NDIMR( NCRNT ) / 2 + NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1 + INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1 + 10 CONTINUE + LLST = LLST*2 + 20 CONTINUE + ND = LLST*2 - 1 + * + RETURN + * + * End of DLASDT + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlaset.f octave-2.9.16/libcruft/lapack/dlaset.f *** octave-2.9.15/libcruft/lapack/dlaset.f Wed Nov 3 14:54:29 1999 --- octave-2.9.16/libcruft/lapack/dlaset.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dlasq1.f octave-2.9.16/libcruft/lapack/dlasq1.f *** octave-2.9.15/libcruft/lapack/dlasq1.f Thu Feb 10 04:26:49 2000 --- octave-2.9.16/libcruft/lapack/dlasq1.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. INTEGER INFO, N --- 1,8 ---- SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N *************** *** 67,73 **** DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX * .. * .. External Subroutines .. ! EXTERNAL DLAS2, DLASQ2, DLASRT, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH --- 66,72 ---- DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX * .. * .. External Subroutines .. ! EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH diff -cNr octave-2.9.15/libcruft/lapack/dlasq2.f octave-2.9.16/libcruft/lapack/dlasq2.f *** octave-2.9.15/libcruft/lapack/dlasq2.f Thu Feb 10 04:26:49 2000 --- octave-2.9.16/libcruft/lapack/dlasq2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASQ2( N, Z, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. INTEGER INFO, N --- 1,10 ---- SUBROUTINE DLASQ2( N, Z, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH. * * .. Scalar Arguments .. INTEGER INFO, N *************** *** 29,35 **** * Note : DLASQ2 defines a logical variable, IEEE, which is true * on machines which follow ieee-754 floating-point standard in their * handling of infinities and NaNs, and false otherwise. This variable ! * is passed to DLASQ3. * * Arguments * ========= --- 30,36 ---- * Note : DLASQ2 defines a logical variable, IEEE, which is true * on machines which follow ieee-754 floating-point standard in their * handling of infinities and NaNs, and false otherwise. This variable ! * is passed to DLAZQ3. * * Arguments * ========= *************** *** 76,88 **** * .. Local Scalars .. LOGICAL IEEE INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, ! $ N0, NBIG, NDIV, NFAIL, PP, SPLT ! DOUBLE PRECISION D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN, ! $ QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL, ! $ TOL2, TRACE, ZMAX * .. * .. External Subroutines .. ! EXTERNAL DLASQ3, DLASRT, XERBLA * .. * .. External Functions .. INTEGER ILAENV --- 77,89 ---- * .. Local Scalars .. LOGICAL IEEE INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, ! $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE ! DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E, ! $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN, ! $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX * .. * .. External Subroutines .. ! EXTERNAL DLAZQ3, DLASRT, XERBLA * .. * .. External Functions .. INTEGER ILAENV *************** *** 90,96 **** EXTERNAL DLAMCH, ILAENV * .. * .. Intrinsic Functions .. ! INTRINSIC DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * --- 91,97 ---- EXTERNAL DLAMCH, ILAENV * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * *************** *** 286,291 **** --- 287,302 ---- PP = 1 - PP 80 CONTINUE * + * Initialise variables to pass to DLAZQ3 + * + TTYPE = 0 + DMIN1 = ZERO + DMIN2 = ZERO + DN = ZERO + DN1 = ZERO + DN2 = ZERO + TAU = ZERO + * ITER = 2 NFAIL = 0 NDIV = 2*( N0-I0 ) *************** *** 336,342 **** 100 CONTINUE I0 = I4 / 4 * ! * Store EMIN for passing to DLASQ3. * Z( 4*N0-1 ) = EMIN * --- 347,353 ---- 100 CONTINUE I0 = I4 / 4 * ! * Store EMIN for passing to DLAZQ3. * Z( 4*N0-1 ) = EMIN * *************** *** 355,362 **** * * While submatrix unfinished take a good dqds step. * ! CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ! $ ITER, NDIV, IEEE ) * PP = 1 - PP * --- 366,374 ---- * * While submatrix unfinished take a good dqds step. * ! CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ! $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, ! $ DN2, TAU ) * PP = 1 - PP * diff -cNr octave-2.9.15/libcruft/lapack/dlasq3.f octave-2.9.16/libcruft/lapack/dlasq3.f *** octave-2.9.15/libcruft/lapack/dlasq3.f Mon Aug 13 13:26:42 2001 --- octave-2.9.16/libcruft/lapack/dlasq3.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * May 17, 2000 * * .. Scalar Arguments .. LOGICAL IEEE --- 1,9 ---- SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL IEEE *************** *** 86,92 **** EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, MIN, SQRT * .. * .. Save statement .. SAVE TTYPE --- 85,91 ---- EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Save statement .. SAVE TTYPE *************** *** 197,204 **** END IF END IF * - 70 CONTINUE - * IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN * --- 196,201 ---- diff -cNr octave-2.9.15/libcruft/lapack/dlasq4.f octave-2.9.16/libcruft/lapack/dlasq4.f *** octave-2.9.15/libcruft/lapack/dlasq4.f Thu Feb 10 04:26:50 2000 --- octave-2.9.16/libcruft/lapack/dlasq4.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE --- 1,9 ---- SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE *************** *** 32,38 **** * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * ! * NOIN (input) INTEGER * The value of N0 at start of EIGTEST. * * DMIN (input) DOUBLE PRECISION --- 31,37 ---- * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * ! * N0IN (input) INTEGER * The value of N0 at start of EIGTEST. * * DMIN (input) DOUBLE PRECISION diff -cNr octave-2.9.15/libcruft/lapack/dlasq5.f octave-2.9.16/libcruft/lapack/dlasq5.f *** octave-2.9.15/libcruft/lapack/dlasq5.f Mon Aug 13 13:26:42 2001 --- octave-2.9.16/libcruft/lapack/dlasq5.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2, IEEE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * May 17, 2000 * * .. Scalar Arguments .. LOGICAL IEEE --- 1,9 ---- SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2, IEEE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL IEEE diff -cNr octave-2.9.15/libcruft/lapack/dlasq6.f octave-2.9.16/libcruft/lapack/dlasq6.f *** octave-2.9.15/libcruft/lapack/dlasq6.f Thu Feb 10 04:26:50 2000 --- octave-2.9.16/libcruft/lapack/dlasq6.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. INTEGER I0, N0, PP --- 1,9 ---- SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER I0, N0, PP diff -cNr octave-2.9.15/libcruft/lapack/dlasr.f octave-2.9.16/libcruft/lapack/dlasr.f *** octave-2.9.15/libcruft/lapack/dlasr.f Wed Nov 3 14:54:29 1999 --- octave-2.9.16/libcruft/lapack/dlasr.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE --- 1,8 ---- SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE *************** *** 16,59 **** * Purpose * ======= * ! * DLASR performs the transformation ! * ! * A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) ! * ! * A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) ! * ! * where A is an m by n real matrix and P is an orthogonal matrix, ! * consisting of a sequence of plane rotations determined by the ! * parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' ! * and z = n when SIDE = 'R' or 'r' ): ! * ! * When DIRECT = 'F' or 'f' ( Forward sequence ) then ! * ! * P = P( z - 1 )*...*P( 2 )*P( 1 ), ! * ! * and when DIRECT = 'B' or 'b' ( Backward sequence ) then ! * ! * P = P( 1 )*P( 2 )*...*P( z - 1 ), ! * ! * where P( k ) is a plane rotation matrix for the following planes: ! * ! * when PIVOT = 'V' or 'v' ( Variable pivot ), ! * the plane ( k, k + 1 ) ! * ! * when PIVOT = 'T' or 't' ( Top pivot ), ! * the plane ( 1, k + 1 ) ! * ! * when PIVOT = 'B' or 'b' ( Bottom pivot ), ! * the plane ( k, z ) ! * ! * c( k ) and s( k ) must contain the cosine and sine that define the ! * matrix P( k ). The two by two plane rotation part of the matrix ! * P( k ), R( k ), is assumed to be of the form ! * ! * R( k ) = ( c( k ) s( k ) ). ! * ( -s( k ) c( k ) ) ! * ! * This version vectorises across rows of the array A when SIDE = 'L'. * * Arguments * ========= --- 15,91 ---- * Purpose * ======= * ! * DLASR applies a sequence of plane rotations to a real matrix A, ! * from either the left or the right. ! * ! * When SIDE = 'L', the transformation takes the form ! * ! * A := P*A ! * ! * and when SIDE = 'R', the transformation takes the form ! * ! * A := A*P**T ! * ! * where P is an orthogonal matrix consisting of a sequence of z plane ! * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', ! * and P**T is the transpose of P. ! * ! * When DIRECT = 'F' (Forward sequence), then ! * ! * P = P(z-1) * ... * P(2) * P(1) ! * ! * and when DIRECT = 'B' (Backward sequence), then ! * ! * P = P(1) * P(2) * ... * P(z-1) ! * ! * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation ! * ! * R(k) = ( c(k) s(k) ) ! * = ( -s(k) c(k) ). ! * ! * When PIVOT = 'V' (Variable pivot), the rotation is performed ! * for the plane (k,k+1), i.e., P(k) has the form ! * ! * P(k) = ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( c(k) s(k) ) ! * ( -s(k) c(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ! * where R(k) appears as a rank-2 modification to the identity matrix in ! * rows and columns k and k+1. ! * ! * When PIVOT = 'T' (Top pivot), the rotation is performed for the ! * plane (1,k+1), so P(k) has the form ! * ! * P(k) = ( c(k) s(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( -s(k) c(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ! * where R(k) appears in rows and columns 1 and k+1. ! * ! * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is ! * performed for the plane (k,z), giving P(k) the form ! * ! * P(k) = ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( c(k) s(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( -s(k) c(k) ) ! * ! * where R(k) appears in rows and columns k and z. The rotations are ! * performed without ever forming P(k) explicitly. * * Arguments * ========= *************** *** 62,74 **** * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A ! * = 'R': Right, compute A:= A*P' ! * ! * DIRECT (input) CHARACTER*1 ! * Specifies whether P is a forward or backward sequence of ! * plane rotations. ! * = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) ! * = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation --- 94,100 ---- * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A ! * = 'R': Right, compute A:= A*P**T * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation *************** *** 77,82 **** --- 103,114 ---- * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * + * DIRECT (input) CHARACTER*1 + * Specifies whether P is a forward or backward sequence of + * plane rotations. + * = 'F': Forward, P = P(z-1)*...*P(2)*P(1) + * = 'B': Backward, P = P(1)*P(2)*...*P(z-1) + * * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. *************** *** 85,102 **** * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * ! * C, S (input) DOUBLE PRECISION arrays, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' ! * c(k) and s(k) contain the cosine and sine that define the ! * matrix P(k). The two by two plane rotation part of the ! * matrix P(k), R(k), is assumed to be of the form ! * R( k ) = ( c( k ) s( k ) ). ! * ( -s( k ) c( k ) ) * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) ! * The m by n matrix A. On exit, A is overwritten by P*A if ! * SIDE = 'R' or by A*P' if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). --- 117,138 ---- * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * ! * C (input) DOUBLE PRECISION array, dimension ! * (M-1) if SIDE = 'L' ! * (N-1) if SIDE = 'R' ! * The cosines c(k) of the plane rotations. ! * ! * S (input) DOUBLE PRECISION array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' ! * The sines s(k) of the plane rotations. The 2-by-2 plane ! * rotation part of the matrix P(k), R(k), has the form ! * R(k) = ( c(k) s(k) ) ! * ( -s(k) c(k) ). * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) ! * The M-by-N matrix A. On exit, A is overwritten by P*A if ! * SIDE = 'R' or by A*P**T if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). diff -cNr octave-2.9.15/libcruft/lapack/dlasrt.f octave-2.9.16/libcruft/lapack/dlasrt.f *** octave-2.9.15/libcruft/lapack/dlasrt.f Wed Nov 3 14:54:29 1999 --- octave-2.9.16/libcruft/lapack/dlasrt.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASRT( ID, N, D, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER ID --- 1,8 ---- SUBROUTINE DLASRT( ID, N, D, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER ID diff -cNr octave-2.9.15/libcruft/lapack/dlassq.f octave-2.9.16/libcruft/lapack/dlassq.f *** octave-2.9.15/libcruft/lapack/dlassq.f Wed Nov 3 14:54:29 1999 --- octave-2.9.16/libcruft/lapack/dlassq.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/dlasv2.f octave-2.9.16/libcruft/lapack/dlasv2.f *** octave-2.9.15/libcruft/lapack/dlasv2.f Wed Nov 3 14:54:30 1999 --- octave-2.9.16/libcruft/lapack/dlasv2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN --- 1,8 ---- SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN diff -cNr octave-2.9.15/libcruft/lapack/dlaswp.f octave-2.9.16/libcruft/lapack/dlaswp.f *** octave-2.9.15/libcruft/lapack/dlaswp.f Wed Nov 3 14:54:30 1999 --- octave-2.9.16/libcruft/lapack/dlaswp.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N --- 1,8 ---- SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N *************** *** 41,47 **** * The last element of IPIV for which a row interchange will * be done. * ! * IPIV (input) INTEGER array, dimension (M*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. --- 40,46 ---- * The last element of IPIV for which a row interchange will * be done. * ! * IPIV (input) INTEGER array, dimension (K2*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. diff -cNr octave-2.9.15/libcruft/lapack/dlasy2.f octave-2.9.16/libcruft/lapack/dlasy2.f *** octave-2.9.15/libcruft/lapack/dlasy2.f Wed Nov 3 14:54:30 1999 --- octave-2.9.16/libcruft/lapack/dlasy2.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR --- 1,9 ---- SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR diff -cNr octave-2.9.15/libcruft/lapack/dlatbs.f octave-2.9.16/libcruft/lapack/dlatbs.f *** octave-2.9.15/libcruft/lapack/dlatbs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dlatbs.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO --- 1,9 ---- SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff -cNr octave-2.9.15/libcruft/lapack/dlatrd.f octave-2.9.16/libcruft/lapack/dlatrd.f *** octave-2.9.15/libcruft/lapack/dlatrd.f Wed Nov 3 14:54:30 1999 --- octave-2.9.16/libcruft/lapack/dlatrd.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 31,37 **** * Arguments * ========= * ! * UPLO (input) CHARACTER * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored: * = 'U': Upper triangular --- 30,36 ---- * Arguments * ========= * ! * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored: * = 'U': Upper triangular diff -cNr octave-2.9.15/libcruft/lapack/dlatrs.f octave-2.9.16/libcruft/lapack/dlatrs.f *** octave-2.9.15/libcruft/lapack/dlatrs.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dlatrs.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO --- 1,9 ---- SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff -cNr octave-2.9.15/libcruft/lapack/dlauu2.f octave-2.9.16/libcruft/lapack/dlauu2.f *** octave-2.9.15/libcruft/lapack/dlauu2.f Fri May 6 12:26:58 2005 --- octave-2.9.16/libcruft/lapack/dlauu2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dlauum.f octave-2.9.16/libcruft/lapack/dlauum.f *** octave-2.9.15/libcruft/lapack/dlauum.f Fri May 6 12:26:58 2005 --- octave-2.9.16/libcruft/lapack/dlauum.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dlazq3.f octave-2.9.16/libcruft/lapack/dlazq3.f *** octave-2.9.15/libcruft/lapack/dlazq3.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlazq3.f Tue Oct 16 14:54:21 2007 *************** *** 0 **** --- 1,302 ---- + SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + LOGICAL IEEE + INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE + DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX, + $ SIGMA, TAU + * .. + * .. Array Arguments .. + DOUBLE PRECISION Z( * ) + * .. + * + * Purpose + * ======= + * + * DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. + * In case of failure it changes shifts, and tries again until output + * is positive. + * + * Arguments + * ========= + * + * I0 (input) INTEGER + * First index. + * + * N0 (input) INTEGER + * Last index. + * + * Z (input) DOUBLE PRECISION array, dimension ( 4*N ) + * Z holds the qd array. + * + * PP (input) INTEGER + * PP=0 for ping, PP=1 for pong. + * + * DMIN (output) DOUBLE PRECISION + * Minimum value of d. + * + * SIGMA (output) DOUBLE PRECISION + * Sum of shifts used in current segment. + * + * DESIG (input/output) DOUBLE PRECISION + * Lower order part of SIGMA + * + * QMAX (input) DOUBLE PRECISION + * Maximum value of q. + * + * NFAIL (output) INTEGER + * Number of times shift was too big. + * + * ITER (output) INTEGER + * Number of iterations. + * + * NDIV (output) INTEGER + * Number of divisions. + * + * IEEE (input) LOGICAL + * Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). + * + * TTYPE (input/output) INTEGER + * Shift type. TTYPE is passed as an argument in order to save + * its value between calls to DLAZQ3 + * + * DMIN1 (input/output) REAL + * DMIN2 (input/output) REAL + * DN (input/output) REAL + * DN1 (input/output) REAL + * DN2 (input/output) REAL + * TAU (input/output) REAL + * These are passed as arguments in order to save their values + * between calls to DLAZQ3 + * + * This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1, + * DMIN2, DN, DN1. DN2 and TAU through the argument list in place of + * declaring them in a SAVE statment. + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION CBIAS + PARAMETER ( CBIAS = 1.50D0 ) + DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD + PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, + $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) + * .. + * .. Local Scalars .. + INTEGER IPN4, J4, N0IN, NN + DOUBLE PRECISION EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2 + * .. + * .. External Subroutines .. + EXTERNAL DLASQ5, DLASQ6, DLAZQ4 + * .. + * .. External Function .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SQRT + * .. + * .. Executable Statements .. + * + N0IN = N0 + EPS = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + TOL = EPS*HUNDRD + TOL2 = TOL**2 + G = ZERO + * + * Check for deflation. + * + 10 CONTINUE + * + IF( N0.LT.I0 ) + $ RETURN + IF( N0.EQ.I0 ) + $ GO TO 20 + NN = 4*N0 + PP + IF( N0.EQ.( I0+1 ) ) + $ GO TO 40 + * + * Check whether E(N0-1) is negligible, 1 eigenvalue. + * + IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. + $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) + $ GO TO 30 + * + 20 CONTINUE + * + Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA + N0 = N0 - 1 + GO TO 10 + * + * Check whether E(N0-2) is negligible, 2 eigenvalues. + * + 30 CONTINUE + * + IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. + $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) + $ GO TO 50 + * + 40 CONTINUE + * + IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN + S = Z( NN-3 ) + Z( NN-3 ) = Z( NN-7 ) + Z( NN-7 ) = S + END IF + IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN + T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) + S = Z( NN-3 )*( Z( NN-5 ) / T ) + IF( S.LE.T ) THEN + S = Z( NN-3 )*( Z( NN-5 ) / + $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) + ELSE + S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) + END IF + T = Z( NN-7 ) + ( S+Z( NN-5 ) ) + Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) + Z( NN-7 ) = T + END IF + Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA + Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA + N0 = N0 - 2 + GO TO 10 + * + 50 CONTINUE + * + * Reverse the qd-array, if warranted. + * + IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN + IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN + IPN4 = 4*( I0+N0 ) + DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( J4-3 ) + Z( J4-3 ) = Z( IPN4-J4-3 ) + Z( IPN4-J4-3 ) = TEMP + TEMP = Z( J4-2 ) + Z( J4-2 ) = Z( IPN4-J4-2 ) + Z( IPN4-J4-2 ) = TEMP + TEMP = Z( J4-1 ) + Z( J4-1 ) = Z( IPN4-J4-5 ) + Z( IPN4-J4-5 ) = TEMP + TEMP = Z( J4 ) + Z( J4 ) = Z( IPN4-J4-4 ) + Z( IPN4-J4-4 ) = TEMP + 60 CONTINUE + IF( N0-I0.LE.4 ) THEN + Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) + Z( 4*N0-PP ) = Z( 4*I0-PP ) + END IF + DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) + Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), + $ Z( 4*I0+PP+3 ) ) + Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), + $ Z( 4*I0-PP+4 ) ) + QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) + DMIN = -ZERO + END IF + END IF + * + IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), + $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN + * + * Choose a shift. + * + CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE, G ) + * + * Call dqds until DMIN > 0. + * + 80 CONTINUE + * + CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, IEEE ) + * + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 + * + * Check status. + * + IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN + * + * Success. + * + GO TO 100 + * + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. + $ ABS( DN ).LT.TOL*SIGMA ) THEN + * + * Convergence hidden by negative DN. + * + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ZERO + GO TO 100 + ELSE IF( DMIN.LT.ZERO ) THEN + * + * TAU too big. Select new TAU and try again. + * + NFAIL = NFAIL + 1 + IF( TTYPE.LT.-22 ) THEN + * + * Failed twice. Play it safe. + * + TAU = ZERO + ELSE IF( DMIN1.GT.ZERO ) THEN + * + * Late failure. Gives excellent shift. + * + TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) + TTYPE = TTYPE - 11 + ELSE + * + * Early failure. Divide by 4. + * + TAU = QURTR*TAU + TTYPE = TTYPE - 12 + END IF + GO TO 80 + ELSE IF( DMIN.NE.DMIN ) THEN + * + * NaN. + * + TAU = ZERO + GO TO 80 + ELSE + * + * Possible underflow. Play it safe. + * + GO TO 90 + END IF + END IF + * + * Risk of underflow. + * + 90 CONTINUE + CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 + TAU = ZERO + * + 100 CONTINUE + IF( TAU.LT.SIGMA ) THEN + DESIG = DESIG + TAU + T = SIGMA + DESIG + DESIG = DESIG - ( T-SIGMA ) + ELSE + T = SIGMA + TAU + DESIG = SIGMA - ( T-TAU ) + DESIG + END IF + SIGMA = T + * + RETURN + * + * End of DLAZQ3 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dlazq4.f octave-2.9.16/libcruft/lapack/dlazq4.f *** octave-2.9.15/libcruft/lapack/dlazq4.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dlazq4.f Tue Oct 16 14:54:21 2007 *************** *** 0 **** --- 1,330 ---- + SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, TAU, TTYPE, G ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER I0, N0, N0IN, PP, TTYPE + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU + * .. + * .. Array Arguments .. + DOUBLE PRECISION Z( * ) + * .. + * + * Purpose + * ======= + * + * DLAZQ4 computes an approximation TAU to the smallest eigenvalue + * using values of d from the previous transform. + * + * I0 (input) INTEGER + * First index. + * + * N0 (input) INTEGER + * Last index. + * + * Z (input) DOUBLE PRECISION array, dimension ( 4*N ) + * Z holds the qd array. + * + * PP (input) INTEGER + * PP=0 for ping, PP=1 for pong. + * + * N0IN (input) INTEGER + * The value of N0 at start of EIGTEST. + * + * DMIN (input) DOUBLE PRECISION + * Minimum value of d. + * + * DMIN1 (input) DOUBLE PRECISION + * Minimum value of d, excluding D( N0 ). + * + * DMIN2 (input) DOUBLE PRECISION + * Minimum value of d, excluding D( N0 ) and D( N0-1 ). + * + * DN (input) DOUBLE PRECISION + * d(N) + * + * DN1 (input) DOUBLE PRECISION + * d(N-1) + * + * DN2 (input) DOUBLE PRECISION + * d(N-2) + * + * TAU (output) DOUBLE PRECISION + * This is the shift. + * + * TTYPE (output) INTEGER + * Shift type. + * + * G (input/output) DOUBLE PRECISION + * G is passed as an argument in order to save its value between + * calls to DLAZQ4 + * + * Further Details + * =============== + * CNST1 = 9/16 + * + * This is a thread safe version of DLASQ4, which passes G through the + * argument list in place of declaring G in a SAVE statment. + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION CNST1, CNST2, CNST3 + PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, + $ CNST3 = 1.050D0 ) + DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD + PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, + $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, + $ TWO = 2.0D0, HUNDRD = 100.0D0 ) + * .. + * .. Local Scalars .. + INTEGER I4, NN, NP + DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S + * .. + * .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT + * .. + * .. Executable Statements .. + * + * A negative DMIN forces the shift to take that absolute value + * TTYPE records the type of shift. + * + IF( DMIN.LE.ZERO ) THEN + TAU = -DMIN + TTYPE = -1 + RETURN + END IF + * + NN = 4*N0 + PP + IF( N0IN.EQ.N0 ) THEN + * + * No eigenvalues deflated. + * + IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN + * + B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) + B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) + A2 = Z( NN-7 ) + Z( NN-5 ) + * + * Cases 2 and 3. + * + IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN + GAP2 = DMIN2 - A2 - DMIN2*QURTR + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN + GAP1 = A2 - DN - ( B2 / GAP2 )*B2 + ELSE + GAP1 = A2 - DN - ( B1+B2 ) + END IF + IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN + S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) + TTYPE = -2 + ELSE + S = ZERO + IF( DN.GT.B1 ) + $ S = DN - B1 + IF( A2.GT.( B1+B2 ) ) + $ S = MIN( S, A2-( B1+B2 ) ) + S = MAX( S, THIRD*DMIN ) + TTYPE = -3 + END IF + ELSE + * + * Case 4. + * + TTYPE = -4 + S = QURTR*DMIN + IF( DMIN.EQ.DN ) THEN + GAM = DN + A2 = ZERO + IF( Z( NN-5 ) .GT. Z( NN-7 ) ) + $ RETURN + B2 = Z( NN-5 ) / Z( NN-7 ) + NP = NN - 9 + ELSE + NP = NN - 2*PP + B2 = Z( NP-2 ) + GAM = DN1 + IF( Z( NP-4 ) .GT. Z( NP-2 ) ) + $ RETURN + A2 = Z( NP-4 ) / Z( NP-2 ) + IF( Z( NN-9 ) .GT. Z( NN-11 ) ) + $ RETURN + B2 = Z( NN-9 ) / Z( NN-11 ) + NP = NN - 13 + END IF + * + * Approximate contribution to norm squared from I < NN-1. + * + A2 = A2 + B2 + DO 10 I4 = NP, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 20 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 20 + 10 CONTINUE + 20 CONTINUE + A2 = CNST3*A2 + * + * Rayleigh quotient residual bound. + * + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + END IF + ELSE IF( DMIN.EQ.DN2 ) THEN + * + * Case 5. + * + TTYPE = -5 + S = QURTR*DMIN + * + * Compute contribution to norm squared from I > NN-2. + * + NP = NN - 2*PP + B1 = Z( NP-2 ) + B2 = Z( NP-6 ) + GAM = DN2 + IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) + $ RETURN + A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) + * + * Approximate contribution to norm squared from I < NN-2. + * + IF( N0-I0.GT.2 ) THEN + B2 = Z( NN-13 ) / Z( NN-15 ) + A2 = A2 + B2 + DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 + IF( B2.EQ.ZERO ) + $ GO TO 40 + B1 = B2 + IF( Z( I4 ) .GT. Z( I4-2 ) ) + $ RETURN + B2 = B2*( Z( I4 ) / Z( I4-2 ) ) + A2 = A2 + B2 + IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) + $ GO TO 40 + 30 CONTINUE + 40 CONTINUE + A2 = CNST3*A2 + END IF + * + IF( A2.LT.CNST1 ) + $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) + ELSE + * + * Case 6, no information to guide us. + * + IF( TTYPE.EQ.-6 ) THEN + G = G + THIRD*( ONE-G ) + ELSE IF( TTYPE.EQ.-18 ) THEN + G = QURTR*THIRD + ELSE + G = QURTR + END IF + S = G*DMIN + TTYPE = -6 + END IF + * + ELSE IF( N0IN.EQ.( N0+1 ) ) THEN + * + * One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. + * + IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN + * + * Cases 7 and 8. + * + TTYPE = -7 + S = THIRD*DMIN1 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 60 + DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + A2 = B1 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) + $ GO TO 60 + 50 CONTINUE + 60 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN1 / ( ONE+B2**2 ) + GAP2 = HALF*DMIN2 - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + TTYPE = -8 + END IF + ELSE + * + * Case 9. + * + S = QURTR*DMIN1 + IF( DMIN1.EQ.DN1 ) + $ S = HALF*DMIN1 + TTYPE = -9 + END IF + * + ELSE IF( N0IN.EQ.( N0+2 ) ) THEN + * + * Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. + * + * Cases 10 and 11. + * + IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN + TTYPE = -10 + S = THIRD*DMIN2 + IF( Z( NN-5 ).GT.Z( NN-7 ) ) + $ RETURN + B1 = Z( NN-5 ) / Z( NN-7 ) + B2 = B1 + IF( B2.EQ.ZERO ) + $ GO TO 80 + DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 + IF( Z( I4 ).GT.Z( I4-2 ) ) + $ RETURN + B1 = B1*( Z( I4 ) / Z( I4-2 ) ) + B2 = B2 + B1 + IF( HUNDRD*B1.LT.B2 ) + $ GO TO 80 + 70 CONTINUE + 80 CONTINUE + B2 = SQRT( CNST3*B2 ) + A2 = DMIN2 / ( ONE+B2**2 ) + GAP2 = Z( NN-7 ) + Z( NN-9 ) - + $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 + IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN + S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) + ELSE + S = MAX( S, A2*( ONE-CNST2*B2 ) ) + END IF + ELSE + S = QURTR*DMIN2 + TTYPE = -11 + END IF + ELSE IF( N0IN.GT.( N0+2 ) ) THEN + * + * Case 12, more than two eigenvalues deflated. No information. + * + S = ZERO + TTYPE = -12 + END IF + * + TAU = S + RETURN + * + * End of DLAZQ4 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dorg2l.f octave-2.9.16/libcruft/lapack/dorg2l.f *** octave-2.9.15/libcruft/lapack/dorg2l.f Wed Nov 3 14:54:30 1999 --- octave-2.9.16/libcruft/lapack/dorg2l.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N --- 1,8 ---- SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/dorg2r.f octave-2.9.16/libcruft/lapack/dorg2r.f *** octave-2.9.15/libcruft/lapack/dorg2r.f Wed Nov 3 14:54:30 1999 --- octave-2.9.16/libcruft/lapack/dorg2r.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N --- 1,8 ---- SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/dorgbr.f octave-2.9.16/libcruft/lapack/dorgbr.f *** octave-2.9.15/libcruft/lapack/dorgbr.f Wed Nov 3 14:54:31 1999 --- octave-2.9.16/libcruft/lapack/dorgbr.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER VECT --- 1,8 ---- SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER VECT *************** *** 76,82 **** * reflector H(i) or G(i), which determines Q or P**T, as * returned by DGEBRD in its array argument TAUQ or TAUP. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 75,81 ---- * reflector H(i) or G(i), which determines Q or P**T, as * returned by DGEBRD in its array argument TAUQ or TAUP. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dorghr.f octave-2.9.16/libcruft/lapack/dorghr.f *** octave-2.9.15/libcruft/lapack/dorghr.f Wed Nov 3 14:54:31 1999 --- octave-2.9.16/libcruft/lapack/dorghr.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N --- 1,8 ---- SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N *************** *** 46,52 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEHRD. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 45,51 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEHRD. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dorgl2.f octave-2.9.16/libcruft/lapack/dorgl2.f *** octave-2.9.15/libcruft/lapack/dorgl2.f Wed Nov 3 14:54:31 1999 --- octave-2.9.16/libcruft/lapack/dorgl2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N --- 1,8 ---- SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/dorglq.f octave-2.9.16/libcruft/lapack/dorglq.f *** octave-2.9.15/libcruft/lapack/dorglq.f Wed Nov 3 14:54:31 1999 --- octave-2.9.16/libcruft/lapack/dorglq.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N *************** *** 49,55 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGELQF. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 48,54 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGELQF. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dorgql.f octave-2.9.16/libcruft/lapack/dorgql.f *** octave-2.9.15/libcruft/lapack/dorgql.f Wed Nov 3 14:54:31 1999 --- octave-2.9.16/libcruft/lapack/dorgql.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N *************** *** 50,56 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQLF. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 49,55 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQLF. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 93,101 **** * Test the input arguments * INFO = 0 - NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 --- 92,97 ---- *************** *** 105,113 **** INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQL', -INFO ) RETURN --- 101,122 ---- INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF + * + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT + * + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF + * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQL', -INFO ) RETURN *************** *** 118,124 **** * Quick return if possible * IF( N.LE.0 ) THEN - WORK( 1 ) = 1 RETURN END IF * --- 127,132 ---- diff -cNr octave-2.9.15/libcruft/lapack/dorgqr.f octave-2.9.16/libcruft/lapack/dorgqr.f *** octave-2.9.15/libcruft/lapack/dorgqr.f Wed Nov 3 14:54:31 1999 --- octave-2.9.16/libcruft/lapack/dorgqr.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N *************** *** 50,56 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 49,55 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dorgtr.f octave-2.9.16/libcruft/lapack/dorgtr.f *** octave-2.9.15/libcruft/lapack/dorgtr.f Wed Nov 3 14:54:31 1999 --- octave-2.9.16/libcruft/lapack/dorgtr.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 48,54 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DSYTRD. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 47,53 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DSYTRD. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dorm2r.f octave-2.9.16/libcruft/lapack/dorm2r.f *** octave-2.9.15/libcruft/lapack/dorm2r.f Wed Nov 3 14:54:32 1999 --- octave-2.9.16/libcruft/lapack/dorm2r.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff -cNr octave-2.9.15/libcruft/lapack/dormbr.f octave-2.9.16/libcruft/lapack/dormbr.f *** octave-2.9.15/libcruft/lapack/dormbr.f Wed Nov 3 14:54:32 1999 --- octave-2.9.16/libcruft/lapack/dormbr.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT --- 1,9 ---- SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT *************** *** 98,104 **** * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 97,103 ---- * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dorml2.f octave-2.9.16/libcruft/lapack/dorml2.f *** octave-2.9.15/libcruft/lapack/dorml2.f Wed Nov 3 14:54:32 1999 --- octave-2.9.16/libcruft/lapack/dorml2.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff -cNr octave-2.9.15/libcruft/lapack/dormlq.f octave-2.9.16/libcruft/lapack/dormlq.f *** octave-2.9.15/libcruft/lapack/dormlq.f Wed Nov 3 14:54:32 1999 --- octave-2.9.16/libcruft/lapack/dormlq.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS *************** *** 76,82 **** * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 75,81 ---- * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dormqr.f octave-2.9.16/libcruft/lapack/dormqr.f *** octave-2.9.15/libcruft/lapack/dormqr.f Wed Nov 3 14:54:32 1999 --- octave-2.9.16/libcruft/lapack/dormqr.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS *************** *** 76,82 **** * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 75,81 ---- * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dormr3.f octave-2.9.16/libcruft/lapack/dormr3.f *** octave-2.9.15/libcruft/lapack/dormr3.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dormr3.f Tue Oct 16 14:54:21 2007 *************** *** 0 **** --- 1,206 ---- + SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, M, N + * .. + * .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * DORMR3 overwrites the general real m by n matrix C with + * + * Q * C if SIDE = 'L' and TRANS = 'N', or + * + * Q'* C if SIDE = 'L' and TRANS = 'T', or + * + * C * Q if SIDE = 'R' and TRANS = 'N', or + * + * C * Q' if SIDE = 'R' and TRANS = 'T', + * + * where Q is a real orthogonal matrix defined as the product of k + * elementary reflectors + * + * Q = H(1) H(2) . . . H(k) + * + * as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n + * if SIDE = 'R'. + * + * Arguments + * ========= + * + * SIDE (input) CHARACTER*1 + * = 'L': apply Q or Q' from the Left + * = 'R': apply Q or Q' from the Right + * + * TRANS (input) CHARACTER*1 + * = 'N': apply Q (No transpose) + * = 'T': apply Q' (Transpose) + * + * M (input) INTEGER + * The number of rows of the matrix C. M >= 0. + * + * N (input) INTEGER + * The number of columns of the matrix C. N >= 0. + * + * K (input) INTEGER + * The number of elementary reflectors whose product defines + * the matrix Q. + * If SIDE = 'L', M >= K >= 0; + * if SIDE = 'R', N >= K >= 0. + * + * L (input) INTEGER + * The number of columns of the matrix A containing + * the meaningful part of the Householder reflectors. + * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. + * + * A (input) DOUBLE PRECISION array, dimension + * (LDA,M) if SIDE = 'L', + * (LDA,N) if SIDE = 'R' + * The i-th row must contain the vector which defines the + * elementary reflector H(i), for i = 1,2,...,k, as returned by + * DTZRZF in the last k rows of its array argument A. + * A is modified by the routine but restored on exit. + * + * LDA (input) INTEGER + * The leading dimension of the array A. LDA >= max(1,K). + * + * TAU (input) DOUBLE PRECISION array, dimension (K) + * TAU(i) must contain the scalar factor of the elementary + * reflector H(i), as returned by DTZRZF. + * + * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + * On entry, the m-by-n matrix C. + * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. + * + * LDC (input) INTEGER + * The leading dimension of the array C. LDC >= max(1,M). + * + * WORK (workspace) DOUBLE PRECISION array, dimension + * (N) if SIDE = 'L', + * (M) if SIDE = 'R' + * + * INFO (output) INTEGER + * = 0: successful exit + * < 0: if INFO = -i, the i-th argument had an illegal value + * + * Further Details + * =============== + * + * Based on contributions by + * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA + * + * ===================================================================== + * + * .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ + * .. + * .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME + * .. + * .. External Subroutines .. + EXTERNAL DLARZ, XERBLA + * .. + * .. Intrinsic Functions .. + INTRINSIC MAX + * .. + * .. Executable Statements .. + * + * Test the input arguments + * + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + * + * NQ is the order of Q + * + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMR3', -INFO ) + RETURN + END IF + * + * Quick return if possible + * + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN + * + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF + * + IF( LEFT ) THEN + NI = N + JA = M - L + 1 + JC = 1 + ELSE + MI = M + JA = N - L + 1 + IC = 1 + END IF + * + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN + * + * H(i) or H(i)' is applied to C(i:m,1:n) + * + MI = M - I + 1 + IC = I + ELSE + * + * H(i) or H(i)' is applied to C(1:m,i:n) + * + NI = N - I + 1 + JC = I + END IF + * + * Apply H(i) or H(i)' + * + CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) + * + 10 CONTINUE + * + RETURN + * + * End of DORMR3 + * + END diff -cNr octave-2.9.15/libcruft/lapack/dormrz.f octave-2.9.16/libcruft/lapack/dormrz.f *** octave-2.9.15/libcruft/lapack/dormrz.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/dormrz.f Tue Oct 16 14:54:21 2007 *************** *** 0 **** --- 1,293 ---- + SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) + * + * -- LAPACK routine (version 3.1.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * January 2007 + * + * .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, L, LDA, LDC, LWORK, M, N + * .. + * .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * DORMRZ overwrites the general real M-by-N matrix C with + * + * SIDE = 'L' SIDE = 'R' + * TRANS = 'N': Q * C C * Q + * TRANS = 'T': Q**T * C C * Q**T + * + * where Q is a real orthogonal matrix defined as the product of k + * elementary reflectors + * + * Q = H(1) H(2) . . . H(k) + * + * as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N + * if SIDE = 'R'. + * + * Arguments + * ========= + * + * SIDE (input) CHARACTER*1 + * = 'L': apply Q or Q**T from the Left; + * = 'R': apply Q or Q**T from the Right. + * + * TRANS (input) CHARACTER*1 + * = 'N': No transpose, apply Q; + * = 'T': Transpose, apply Q**T. + * + * M (input) INTEGER + * The number of rows of the matrix C. M >= 0. + * + * N (input) INTEGER + * The number of columns of the matrix C. N >= 0. + * + * K (input) INTEGER + * The number of elementary reflectors whose product defines + * the matrix Q. + * If SIDE = 'L', M >= K >= 0; + * if SIDE = 'R', N >= K >= 0. + * + * L (input) INTEGER + * The number of columns of the matrix A containing + * the meaningful part of the Householder reflectors. + * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. + * + * A (input) DOUBLE PRECISION array, dimension + * (LDA,M) if SIDE = 'L', + * (LDA,N) if SIDE = 'R' + * The i-th row must contain the vector which defines the + * elementary reflector H(i), for i = 1,2,...,k, as returned by + * DTZRZF in the last k rows of its array argument A. + * A is modified by the routine but restored on exit. + * + * LDA (input) INTEGER + * The leading dimension of the array A. LDA >= max(1,K). + * + * TAU (input) DOUBLE PRECISION array, dimension (K) + * TAU(i) must contain the scalar factor of the elementary + * reflector H(i), as returned by DTZRZF. + * + * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + * On entry, the M-by-N matrix C. + * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. + * + * LDC (input) INTEGER + * The leading dimension of the array C. LDC >= max(1,M). + * + * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) + * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + * + * LWORK (input) INTEGER + * The dimension of the array WORK. + * If SIDE = 'L', LWORK >= max(1,N); + * if SIDE = 'R', LWORK >= max(1,M). + * For optimum performance LWORK >= N*NB if SIDE = 'L', and + * LWORK >= M*NB if SIDE = 'R', where NB is the optimal + * blocksize. + * + * If LWORK = -1, then a workspace query is assumed; the routine + * only calculates the optimal size of the WORK array, returns + * this value as the first entry of the WORK array, and no error + * message related to LWORK is issued by XERBLA. + * + * INFO (output) INTEGER + * = 0: successful exit + * < 0: if INFO = -i, the i-th argument had an illegal value + * + * Further Details + * =============== + * + * Based on contributions by + * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA + * + * ===================================================================== + * + * .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + * .. + * .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC, + $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW + * .. + * .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) + * .. + * .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV + * .. + * .. External Subroutines .. + EXTERNAL DLARZB, DLARZT, DORMR3, XERBLA + * .. + * .. Intrinsic Functions .. + INTRINSIC MAX, MIN + * .. + * .. Executable Statements .. + * + * Test the input arguments + * + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) + * + * NQ is the order of Q and NW is the minimum dimension of WORK + * + IF( LEFT ) THEN + NQ = M + NW = MAX( 1, N ) + ELSE + NQ = N + NW = MAX( 1, M ) + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. + $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + * + IF( INFO.EQ.0 ) THEN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + * + * Determine the block size. NB may be at most NBMAX, where + * NBMAX is used to define the local array T. + * + NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, + $ K, -1 ) ) + LWKOPT = NW*NB + END IF + WORK( 1 ) = LWKOPT + * + IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF + * + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMRZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF + * + * Quick return if possible + * + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF + * + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF + * + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN + * + * Use unblocked code + * + CALL DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, + $ WORK, IINFO ) + ELSE + * + * Use blocked code + * + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF + * + IF( LEFT ) THEN + NI = N + JC = 1 + JA = M - L + 1 + ELSE + MI = M + IC = 1 + JA = N - L + 1 + END IF + * + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF + * + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) + * + * Form the triangular factor of the block reflector + * H = H(i+ib-1) . . . H(i+1) H(i) + * + CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA, + $ TAU( I ), T, LDT ) + * + IF( LEFT ) THEN + * + * H or H' is applied to C(i:m,1:n) + * + MI = M - I + 1 + IC = I + ELSE + * + * H or H' is applied to C(1:m,i:n) + * + NI = N - I + 1 + JC = I + END IF + * + * Apply H or H' + * + CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, + $ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ), + $ LDC, WORK, LDWORK ) + 10 CONTINUE + * + END IF + * + WORK( 1 ) = LWKOPT + * + RETURN + * + * End of DORMRZ + * + END diff -cNr octave-2.9.15/libcruft/lapack/dpbcon.f octave-2.9.16/libcruft/lapack/dpbcon.f *** octave-2.9.15/libcruft/lapack/dpbcon.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dpbcon.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,11 ---- SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 79,84 **** --- 80,88 ---- INTEGER IX, KASE DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX *************** *** 86,92 **** EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DLACON, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS --- 90,96 ---- EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS *************** *** 130,136 **** KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * --- 134,140 ---- KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/dpbtf2.f octave-2.9.16/libcruft/lapack/dpbtf2.f *** octave-2.9.15/libcruft/lapack/dpbtf2.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dpbtf2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dpbtrf.f octave-2.9.16/libcruft/lapack/dpbtrf.f *** octave-2.9.15/libcruft/lapack/dpbtrf.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dpbtrf.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dpbtrs.f octave-2.9.16/libcruft/lapack/dpbtrs.f *** octave-2.9.15/libcruft/lapack/dpbtrs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dpbtrs.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dpocon.f octave-2.9.16/libcruft/lapack/dpocon.f *** octave-2.9.15/libcruft/lapack/dpocon.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/dpocon.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,11 ---- SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 71,76 **** --- 72,80 ---- INTEGER IX, KASE DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX *************** *** 78,84 **** EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DLACON, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX --- 82,88 ---- EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX *************** *** 120,126 **** KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * --- 124,130 ---- KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/dpotf2.f octave-2.9.16/libcruft/lapack/dpotf2.f *** octave-2.9.15/libcruft/lapack/dpotf2.f Wed Nov 3 14:54:32 1999 --- octave-2.9.16/libcruft/lapack/dpotf2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dpotrf.f octave-2.9.16/libcruft/lapack/dpotrf.f *** octave-2.9.15/libcruft/lapack/dpotrf.f Wed Nov 3 14:54:33 1999 --- octave-2.9.16/libcruft/lapack/dpotrf.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dpotri.f octave-2.9.16/libcruft/lapack/dpotri.f *** octave-2.9.15/libcruft/lapack/dpotri.f Fri May 6 12:26:58 2005 --- octave-2.9.16/libcruft/lapack/dpotri.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dpotrs.f octave-2.9.16/libcruft/lapack/dpotrs.f *** octave-2.9.15/libcruft/lapack/dpotrs.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/dpotrs.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dptsv.f octave-2.9.16/libcruft/lapack/dptsv.f *** octave-2.9.15/libcruft/lapack/dptsv.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dptsv.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 25, 1997 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS --- 1,8 ---- SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/dpttrf.f octave-2.9.16/libcruft/lapack/dpttrf.f *** octave-2.9.15/libcruft/lapack/dpttrf.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dpttrf.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPTTRF( N, D, E, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, N --- 1,8 ---- SUBROUTINE DPTTRF( N, D, E, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N *************** *** 43,49 **** * > 0: if INFO = k, the leading minor of order k is not * positive definite; if k < N, the factorization could not * be completed, while if k = N, the factorization was ! * completed, but D(N) = 0. * * ===================================================================== * --- 42,48 ---- * > 0: if INFO = k, the leading minor of order k is not * positive definite; if k < N, the factorization could not * be completed, while if k = N, the factorization was ! * completed, but D(N) <= 0. * * ===================================================================== * diff -cNr octave-2.9.15/libcruft/lapack/dpttrs.f octave-2.9.16/libcruft/lapack/dpttrs.f *** octave-2.9.15/libcruft/lapack/dpttrs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dpttrs.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS --- 1,8 ---- SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/dptts2.f octave-2.9.16/libcruft/lapack/dptts2.f *** octave-2.9.15/libcruft/lapack/dptts2.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/dptts2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER LDB, N, NRHS --- 1,8 ---- SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/drscl.f octave-2.9.16/libcruft/lapack/drscl.f *** octave-2.9.15/libcruft/lapack/drscl.f Wed Nov 3 14:54:33 1999 --- octave-2.9.16/libcruft/lapack/drscl.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DRSCL( N, SA, SX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- SUBROUTINE DRSCL( N, SA, SX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/dsteqr.f octave-2.9.16/libcruft/lapack/dsteqr.f *** octave-2.9.15/libcruft/lapack/dsteqr.f Wed Nov 3 14:54:33 1999 --- octave-2.9.16/libcruft/lapack/dsteqr.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPZ --- 1,8 ---- SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER COMPZ diff -cNr octave-2.9.15/libcruft/lapack/dsterf.f octave-2.9.16/libcruft/lapack/dsterf.f *** octave-2.9.15/libcruft/lapack/dsterf.f Wed Nov 3 14:54:33 1999 --- octave-2.9.16/libcruft/lapack/dsterf.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DSTERF( N, D, E, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, N --- 1,8 ---- SUBROUTINE DSTERF( N, D, E, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N diff -cNr octave-2.9.15/libcruft/lapack/dsyev.f octave-2.9.16/libcruft/lapack/dsyev.f *** octave-2.9.15/libcruft/lapack/dsyev.f Wed Nov 3 14:54:33 1999 --- octave-2.9.16/libcruft/lapack/dsyev.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO --- 1,8 ---- SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO *************** *** 51,57 **** * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 50,56 ---- * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 80,86 **** * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, ! $ LLWORK, LOPT, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. --- 79,85 ---- * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, ! $ LLWORK, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. *************** *** 114,127 **** INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+2 )*N ) WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN --- 113,127 ---- INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+2 )*N ) WORK( 1 ) = LWKOPT + * + IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 END IF * IF( INFO.NE.0 ) THEN *************** *** 134,146 **** * Quick return if possible * IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) ! WORK( 1 ) = 3 IF( WANTZ ) $ A( 1, 1 ) = ONE RETURN --- 134,145 ---- * Quick return if possible * IF( N.EQ.0 ) THEN RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) ! WORK( 1 ) = 2 IF( WANTZ ) $ A( 1, 1 ) = ONE RETURN *************** *** 177,183 **** LLWORK = LWORK - INDWRK + 1 CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) - LOPT = 2*N + WORK( INDWRK ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * DORGTR to generate the orthogonal matrix, then call DSTEQR. --- 176,181 ---- diff -cNr octave-2.9.15/libcruft/lapack/dsytd2.f octave-2.9.16/libcruft/lapack/dsytd2.f *** octave-2.9.15/libcruft/lapack/dsytd2.f Wed Nov 3 14:54:33 1999 --- octave-2.9.16/libcruft/lapack/dsytd2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/dsytrd.f octave-2.9.16/libcruft/lapack/dsytrd.f *** octave-2.9.15/libcruft/lapack/dsytrd.f Wed Nov 3 14:54:34 1999 --- octave-2.9.16/libcruft/lapack/dsytrd.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 65,71 **** * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 64,70 ---- * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/dtgevc.f octave-2.9.16/libcruft/lapack/dtgevc.f *** octave-2.9.15/libcruft/lapack/dtgevc.f Wed Nov 3 14:54:34 1999 --- octave-2.9.16/libcruft/lapack/dtgevc.f Tue Oct 16 14:54:21 2007 *************** *** 1,18 **** ! SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE ! INTEGER INFO, LDA, LDB, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) ! DOUBLE PRECISION A( LDA, * ), B( LDB, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * --- 1,17 ---- ! SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE ! INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) ! DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * *************** *** 20,54 **** * Purpose * ======= * ! * DTGEVC computes some or all of the right and/or left generalized ! * eigenvectors of a pair of real upper triangular matrices (A,B). ! * ! * The right generalized eigenvector x and the left generalized ! * eigenvector y of (A,B) corresponding to a generalized eigenvalue ! * w are defined by: ! * ! * (A - wB) * x = 0 and y**H * (A - wB) = 0 ! * * where y**H denotes the conjugate tranpose of y. ! * ! * If an eigenvalue w is determined by zero diagonal elements of both A ! * and B, a unit vector is returned as the corresponding eigenvector. ! * ! * If all eigenvectors are requested, the routine may either return ! * the matrices X and/or Y of right or left eigenvectors of (A,B), or ! * the products Z*X and/or Q*Y, where Z and Q are input orthogonal ! * matrices. If (A,B) was obtained from the generalized real-Schur ! * factorization of an original pair of matrices ! * (A0,B0) = (Q*A*Z**H,Q*B*Z**H), ! * then Z*X and Q*Y are the matrices of right or left eigenvectors of ! * A. ! * ! * A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal ! * blocks. Corresponding to each 2-by-2 diagonal block is a complex ! * conjugate pair of eigenvalues and eigenvectors; only one ! * eigenvector of the pair is computed, namely the one corresponding ! * to the eigenvalue with positive imaginary part. ! * * Arguments * ========= * --- 19,49 ---- * Purpose * ======= * ! * DTGEVC computes some or all of the right and/or left eigenvectors of ! * a pair of real matrices (S,P), where S is a quasi-triangular matrix ! * and P is upper triangular. Matrix pairs of this type are produced by ! * the generalized Schur factorization of a matrix pair (A,B): ! * ! * A = Q*S*Z**T, B = Q*P*Z**T ! * ! * as computed by DGGHRD + DHGEQZ. ! * ! * The right eigenvector x and the left eigenvector y of (S,P) ! * corresponding to an eigenvalue w are defined by: ! * ! * S*x = w*P*x, (y**H)*S = w*(y**H)*P, ! * * where y**H denotes the conjugate tranpose of y. ! * The eigenvalues are not input to this routine, but are computed ! * directly from the diagonal blocks of S and P. ! * ! * This routine returns the matrices X and/or Y of right and left ! * eigenvectors of (S,P), or the products Z*X and/or Q*Y, ! * where Z and Q are input matrices. ! * If Q and Z are the orthogonal factors from the generalized Schur ! * factorization of a matrix pair (A,B), then Z*X and Q*Y ! * are the matrices of right and left eigenvectors of (A,B). ! * * Arguments * ========= * *************** *** 59,136 **** * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; ! * = 'B': compute all right and/or left eigenvectors, and ! * backtransform them using the input matrices supplied ! * in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be ! * computed. ! * If HOWMNY='A' or 'B', SELECT is not referenced. ! * To select the real eigenvector corresponding to the real ! * eigenvalue w(j), SELECT(j) must be set to .TRUE. To select ! * the complex eigenvector corresponding to a complex conjugate ! * pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must ! * be set to .TRUE.. * * N (input) INTEGER ! * The order of the matrices A and B. N >= 0. * ! * A (input) DOUBLE PRECISION array, dimension (LDA,N) ! * The upper quasi-triangular matrix A. * ! * LDA (input) INTEGER ! * The leading dimension of array A. LDA >= max(1, N). ! * ! * B (input) DOUBLE PRECISION array, dimension (LDB,N) ! * The upper triangular matrix B. If A has a 2-by-2 diagonal ! * block, then the corresponding 2-by-2 block of B must be ! * diagonal with positive elements. ! * ! * LDB (input) INTEGER ! * The leading dimension of array B. LDB >= max(1,N). * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of left Schur vectors returned by DHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: ! * if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); * if HOWMNY = 'B', the matrix Q*Y; ! * if HOWMNY = 'S', the left eigenvectors of (A,B) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. - * If SIDE = 'R', VL is not referenced. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * * LDVL (input) INTEGER ! * The leading dimension of array VL. ! * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must ! * contain an N-by-N matrix Q (usually the orthogonal matrix Z * of right Schur vectors returned by DHGEQZ). * On exit, if SIDE = 'R' or 'B', VR contains: ! * if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); ! * if HOWMNY = 'B', the matrix Z*X; ! * if HOWMNY = 'S', the right eigenvectors of (A,B) specified by ! * SELECT, stored consecutively in the columns of ! * VR, in the same order as their eigenvalues. ! * If SIDE = 'L', VR is not referenced. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. * * LDVR (input) INTEGER ! * The leading dimension of the array VR. ! * LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. --- 54,137 ---- * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; ! * = 'B': compute all right and/or left eigenvectors, ! * backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY='S', SELECT specifies the eigenvectors to be ! * computed. If w(j) is a real eigenvalue, the corresponding ! * real eigenvector is computed if SELECT(j) is .TRUE.. ! * If w(j) and w(j+1) are the real and imaginary parts of a ! * complex eigenvalue, the corresponding complex eigenvector ! * is computed if either SELECT(j) or SELECT(j+1) is .TRUE., ! * and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is ! * set to .FALSE.. ! * Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER ! * The order of the matrices S and P. N >= 0. * ! * S (input) DOUBLE PRECISION array, dimension (LDS,N) ! * The upper quasi-triangular matrix S from a generalized Schur ! * factorization, as computed by DHGEQZ. ! * ! * LDS (input) INTEGER ! * The leading dimension of array S. LDS >= max(1,N). ! * ! * P (input) DOUBLE PRECISION array, dimension (LDP,N) ! * The upper triangular matrix P from a generalized Schur ! * factorization, as computed by DHGEQZ. ! * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks ! * of S must be in positive diagonal form. * ! * LDP (input) INTEGER ! * The leading dimension of array P. LDP >= max(1,N). * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of left Schur vectors returned by DHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: ! * if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); * if HOWMNY = 'B', the matrix Q*Y; ! * if HOWMNY = 'S', the left eigenvectors of (S,P) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * + * Not referenced if SIDE = 'R'. + * * LDVL (input) INTEGER ! * The leading dimension of array VL. LDVL >= 1, and if ! * SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must ! * contain an N-by-N matrix Z (usually the orthogonal matrix Z * of right Schur vectors returned by DHGEQZ). + * * On exit, if SIDE = 'R' or 'B', VR contains: ! * if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); ! * if HOWMNY = 'B' or 'b', the matrix Z*X; ! * if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) ! * specified by SELECT, stored consecutively in the ! * columns of VR, in the same order as their ! * eigenvalues. * * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. + * + * Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER ! * The leading dimension of the array VR. LDVR >= 1, and if ! * SIDE = 'R' or 'B', LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. *************** *** 199,205 **** * partial sums. Since FORTRAN arrays are stored columnwise, this has * the advantage that at each step, the elements of C that are accessed * are adjacent to one another, whereas with the rowwise method, the ! * elements accessed at a step are spaced LDA (and LDB) words apart. * * When finding left eigenvectors, the matrix in question is the * transpose of the one in storage, so the rowwise method then --- 200,206 ---- * partial sums. Since FORTRAN arrays are stored columnwise, this has * the advantage that at each step, the elements of C that are accessed * are adjacent to one another, whereas with the rowwise method, the ! * elements accessed at a step are spaced LDS (and LDP) words apart. * * When finding left eigenvectors, the matrix in question is the * transpose of the one in storage, so the rowwise method then *************** *** 226,233 **** $ XSCALE * .. * .. Local Arrays .. ! DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ), ! $ SUMB( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME --- 227,234 ---- $ XSCALE * .. * .. Local Arrays .. ! DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), ! $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME *************** *** 235,241 **** EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DGEMV, DLACPY, DLAG2, DLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN --- 236,242 ---- EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN *************** *** 252,258 **** IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ! ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. --- 253,259 ---- IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ! ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. *************** *** 284,292 **** INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ! ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ! ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN --- 285,293 ---- INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ! ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 ! ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN *************** *** 305,311 **** GO TO 10 END IF IF( J.LT.N ) THEN ! IF( A( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN --- 306,312 ---- GO TO 10 END IF IF( J.LT.N ) THEN ! IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN *************** *** 325,335 **** ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 ! IF( A( J+1, J ).NE.ZERO ) THEN ! IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR. ! $ B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN ! IF( A( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF --- 326,336 ---- ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 ! IF( S( J+1, J ).NE.ZERO ) THEN ! IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. ! $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN ! IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF *************** *** 372,401 **** * blocks) of A and B to check for possible overflow in the * triangular solver. * ! ANORM = ABS( A( 1, 1 ) ) IF( N.GT.1 ) ! $ ANORM = ANORM + ABS( A( 2, 1 ) ) ! BNORM = ABS( B( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO ! IF( A( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND ! TEMP = TEMP + ABS( A( I, J ) ) ! TEMP2 = TEMP2 + ABS( B( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) ! TEMP = TEMP + ABS( A( I, J ) ) ! TEMP2 = TEMP2 + ABS( B( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) --- 373,402 ---- * blocks) of A and B to check for possible overflow in the * triangular solver. * ! ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) ! $ ANORM = ANORM + ABS( S( 2, 1 ) ) ! BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO ! IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND ! TEMP = TEMP + ABS( S( I, J ) ) ! TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) ! TEMP = TEMP + ABS( S( I, J ) ) ! TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) *************** *** 425,431 **** END IF NW = 1 IF( JE.LT.N ) THEN ! IF( A( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF --- 426,432 ---- END IF NW = 1 IF( JE.LT.N ) THEN ! IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF *************** *** 444,451 **** * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN ! IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. ! $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * --- 445,452 ---- * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN ! IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. ! $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * *************** *** 472,481 **** * * Real eigenvalue * ! TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, ! $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) ! SALFAR = ( TEMP*A( JE, JE ) )*ASCALE ! SBETA = ( TEMP*B( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO --- 473,482 ---- * * Real eigenvalue * ! TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, ! $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) ! SALFAR = ( TEMP*S( JE, JE ) )*ASCALE ! SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO *************** *** 517,523 **** * * Complex eigenvalue * ! CALL DLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI --- 518,524 ---- * * Complex eigenvalue * ! CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI *************** *** 549,557 **** * * Compute first two components of eigenvector * ! TEMP = ACOEF*A( JE+1, JE ) ! TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) ! TEMP2I = -BCOEFI*B( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO --- 550,558 ---- * * Compute first two components of eigenvector * ! TEMP = ACOEF*S( JE+1, JE ) ! TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) ! TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO *************** *** 560,569 **** ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO ! TEMP = ACOEF*A( JE, JE+1 ) ! WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF* ! $ A( JE+1, JE+1 ) ) / TEMP ! WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) --- 561,570 ---- ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO ! TEMP = ACOEF*S( JE, JE+1 ) ! WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* ! $ S( JE+1, JE+1 ) ) / TEMP ! WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) *************** *** 586,596 **** END IF * NA = 1 ! BDIAG( 1 ) = B( J, J ) IF( J.LT.N ) THEN ! IF( A( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. ! BDIAG( 2 ) = B( J+1, J+1 ) NA = 2 END IF END IF --- 587,597 ---- END IF * NA = 1 ! BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN ! IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. ! BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 END IF END IF *************** *** 616,628 **** * Compute dot products * * j-1 ! * SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 ! * a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close --- 617,629 ---- * Compute dot products * * j-1 ! * SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 ! * a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close *************** *** 659,673 **** *$PL$ CMCHAR='*' * DO 110 JA = 1, NA ! SUMA( JA, JW ) = ZERO ! SUMB( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 ! SUMA( JA, JW ) = SUMA( JA, JW ) + ! $ A( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) ! SUMB( JA, JW ) = SUMB( JA, JW ) + ! $ B( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE --- 660,674 ---- *$PL$ CMCHAR='*' * DO 110 JA = 1, NA ! SUMS( JA, JW ) = ZERO ! SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 ! SUMS( JA, JW ) = SUMS( JA, JW ) + ! $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) ! SUMP( JA, JW ) = SUMP( JA, JW ) + ! $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE *************** *** 687,701 **** * DO 130 JA = 1, NA IF( ILCPLX ) THEN ! SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + ! $ BCOEFR*SUMB( JA, 1 ) - ! $ BCOEFI*SUMB( JA, 2 ) ! SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) + ! $ BCOEFR*SUMB( JA, 2 ) + ! $ BCOEFI*SUMB( JA, 1 ) ELSE ! SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + ! $ BCOEFR*SUMB( JA, 1 ) END IF 130 CONTINUE * --- 688,702 ---- * DO 130 JA = 1, NA IF( ILCPLX ) THEN ! SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + ! $ BCOEFR*SUMP( JA, 1 ) - ! $ BCOEFI*SUMP( JA, 2 ) ! SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + ! $ BCOEFR*SUMP( JA, 2 ) + ! $ BCOEFI*SUMP( JA, 1 ) ELSE ! SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + ! $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * *************** *** 703,709 **** * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * ! CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) --- 704,710 ---- * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * ! CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) *************** *** 790,796 **** END IF NW = 1 IF( JE.GT.1 ) THEN ! IF( A( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF --- 791,797 ---- END IF NW = 1 IF( JE.GT.1 ) THEN ! IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF *************** *** 809,816 **** * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN ! IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. ! $ ABS( B( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * --- 810,817 ---- * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN ! IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. ! $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * *************** *** 839,848 **** * * Real eigenvalue * ! TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, ! $ ABS( B( JE, JE ) )*BSCALE, SAFMIN ) ! SALFAR = ( TEMP*A( JE, JE ) )*ASCALE ! SBETA = ( TEMP*B( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO --- 840,849 ---- * * Real eigenvalue * ! TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, ! $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) ! SALFAR = ( TEMP*S( JE, JE ) )*ASCALE ! SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO *************** *** 885,898 **** * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 ! WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) - ! $ ACOEF*A( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * ! CALL DLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN --- 886,899 ---- * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 ! WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - ! $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * ! CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN *************** *** 924,932 **** * Compute first two components of eigenvector * and contribution to sums * ! TEMP = ACOEF*A( JE, JE-1 ) ! TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE ) ! TEMP2I = -BCOEFI*B( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO --- 925,933 ---- * Compute first two components of eigenvector * and contribution to sums * ! TEMP = ACOEF*S( JE, JE-1 ) ! TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) ! TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO *************** *** 935,944 **** ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO ! TEMP = ACOEF*A( JE-1, JE ) ! WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF* ! $ A( JE-1, JE-1 ) ) / TEMP ! WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), --- 936,945 ---- ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO ! TEMP = ACOEF*S( JE-1, JE ) ! WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* ! $ S( JE-1, JE-1 ) ) / TEMP ! WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), *************** *** 958,969 **** CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 ! WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) + ! $ CREALB*B( JR, JE-1 ) - ! $ CRE2A*A( JR, JE ) + CRE2B*B( JR, JE ) ! WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) + ! $ CIMAGB*B( JR, JE-1 ) - ! $ CIM2A*A( JR, JE ) + CIM2B*B( JR, JE ) 270 CONTINUE END IF * --- 959,970 ---- CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 ! WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + ! $ CREALB*P( JR, JE-1 ) - ! $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) ! WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + ! $ CIMAGB*P( JR, JE-1 ) - ! $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * *************** *** 978,1000 **** * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN ! IF( A( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF ! BDIAG( 1 ) = B( J, J ) IF( IL2BY2 ) THEN NA = 2 ! BDIAG( 2 ) = B( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * ! CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ), ! $ LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN --- 979,1001 ---- * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN ! IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF ! BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 ! BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * ! CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), ! $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN *************** *** 1014,1020 **** 300 CONTINUE 310 CONTINUE * ! * w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling * IF( J.GT.1 ) THEN * --- 1015,1021 ---- 300 CONTINUE 310 CONTINUE * ! * w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * *************** *** 1052,1070 **** $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - ! $ CREALA*A( JR, J+JA-1 ) + ! $ CREALB*B( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - ! $ CIMAGA*A( JR, J+JA-1 ) + ! $ CIMAGB*B( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - ! $ CREALA*A( JR, J+JA-1 ) + ! $ CREALB*B( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE --- 1053,1071 ---- $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - ! $ CREALA*S( JR, J+JA-1 ) + ! $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - ! $ CIMAGA*S( JR, J+JA-1 ) + ! $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - ! $ CREALA*S( JR, J+JA-1 ) + ! $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE diff -cNr octave-2.9.15/libcruft/lapack/dtrcon.f octave-2.9.16/libcruft/lapack/dtrcon.f *** octave-2.9.15/libcruft/lapack/dtrcon.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/dtrcon.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO --- 1,11 ---- SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO *************** *** 84,89 **** --- 85,93 ---- INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX *************** *** 91,97 **** EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR * .. * .. External Subroutines .. ! EXTERNAL DLACON, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX --- 95,101 ---- EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR * .. * .. External Subroutines .. ! EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX *************** *** 150,156 **** END IF KASE = 0 10 CONTINUE ! CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * --- 154,160 ---- END IF KASE = 0 10 CONTINUE ! CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/dtrevc.f octave-2.9.16/libcruft/lapack/dtrevc.f *** octave-2.9.15/libcruft/lapack/dtrevc.f Wed Nov 3 14:54:34 1999 --- octave-2.9.16/libcruft/lapack/dtrevc.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE --- 1,9 ---- SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE *************** *** 21,48 **** * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. ! * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: ! * ! * T*x = w*x, y'*T = w*y' ! * ! * where y' denotes the conjugate transpose of the vector y. ! * ! * If all eigenvectors are requested, the routine may either return the ! * matrices X and/or Y of right or left eigenvectors of T, or the ! * products Q*X and/or Q*Y, where Q is an input orthogonal ! * matrix. If T was obtained from the real-Schur factorization of an ! * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of ! * right or left eigenvectors of A. ! * ! * T must be in Schur canonical form (as returned by DHSEQR), that is, ! * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each ! * 2-by-2 diagonal block has its diagonal elements equal and its ! * off-diagonal elements of opposite sign. Corresponding to each 2-by-2 ! * diagonal block is a complex conjugate pair of eigenvalues and ! * eigenvectors; only one eigenvector of the pair is computed, namely ! * the one corresponding to the eigenvalue with positive imaginary part. * * Arguments * ========= --- 20,42 ---- * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. ! * Matrices of this type are produced by the Schur factorization of ! * a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. ! * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: ! * ! * T*x = w*x, (y**H)*T = w*(y**H) ! * ! * where y**H denotes the conjugate transpose of y. ! * The eigenvalues are not input to this routine, but are read directly ! * from the diagonal blocks of T. ! * ! * This routine returns the matrices X and/or Y of right and left ! * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an ! * input matrix. If Q is the orthogonal factor that reduces a matrix ! * A to Schur form T, then Q*X and Q*Y are the matrices of right and ! * left eigenvectors of A. * * Arguments * ========= *************** *** 55,75 **** * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, ! * and backtransform them using the input matrices ! * supplied in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, ! * specified by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. ! * If HOWMNY = 'A' or 'B', SELECT is not referenced. ! * To select the real eigenvector corresponding to a real ! * eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select ! * the complex eigenvector corresponding to a complex conjugate ! * pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be ! * set to .TRUE.; then on exit SELECT(j) is .TRUE. and ! * SELECT(j+1) is .FALSE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. --- 49,69 ---- * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, ! * backtransformed by the matrices in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, ! * as indicated by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. ! * If w(j) is a real eigenvalue, the corresponding real ! * eigenvector is computed if SELECT(j) is .TRUE.. ! * If w(j) and w(j+1) are the real and imaginary parts of a ! * complex eigenvalue, the corresponding complex eigenvector is ! * computed if either SELECT(j) or SELECT(j+1) is .TRUE., and ! * on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to ! * .FALSE.. ! * Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. *************** *** 86,100 **** * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; - * VL has the same quasi-lower triangular form - * as T'. If T(i,i) is a real eigenvalue, then - * the i-th column VL(i) of VL is its - * corresponding eigenvector. If T(i:i+1,i:i+1) - * is a 2-by-2 block whose eigenvalues are - * complex-conjugate eigenvalues of T, then - * VL(i)+sqrt(-1)*VL(i+1) is the complex - * eigenvector corresponding to the eigenvalue - * with positive real part. * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns --- 80,85 ---- *************** *** 103,113 **** * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. ! * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER ! * The leading dimension of the array VL. LDVL >= max(1,N) if ! * SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must --- 88,98 ---- * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. ! * Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER ! * The leading dimension of the array VL. LDVL >= 1, and if ! * SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must *************** *** 115,129 **** * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; - * VR has the same quasi-upper triangular form - * as T. If T(i,i) is a real eigenvalue, then - * the i-th column VR(i) of VR is its - * corresponding eigenvector. If T(i:i+1,i:i+1) - * is a 2-by-2 block whose eigenvalues are - * complex-conjugate eigenvalues of T, then - * VR(i)+sqrt(-1)*VR(i+1) is the complex - * eigenvector corresponding to the eigenvalue - * with positive real part. * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns --- 100,105 ---- *************** *** 132,142 **** * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. ! * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER ! * The leading dimension of the array VR. LDVR >= max(1,N) if ! * SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. --- 108,118 ---- * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. ! * Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER ! * The leading dimension of the array VR. LDVR >= 1, and if ! * SIDE = 'R' or 'B', LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. *************** *** 940,946 **** * * Copy the vector x or Q*x to VL and normalize. * - 210 CONTINUE IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), --- 916,921 ---- diff -cNr octave-2.9.15/libcruft/lapack/dtrexc.f octave-2.9.16/libcruft/lapack/dtrexc.f *** octave-2.9.15/libcruft/lapack/dtrexc.f Wed Nov 3 14:54:34 1999 --- octave-2.9.16/libcruft/lapack/dtrexc.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ --- 1,9 ---- SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ diff -cNr octave-2.9.15/libcruft/lapack/dtrsen.f octave-2.9.16/libcruft/lapack/dtrsen.f *** octave-2.9.15/libcruft/lapack/dtrsen.f Wed Nov 3 14:54:34 1999 --- octave-2.9.16/libcruft/lapack/dtrsen.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB --- 1,9 ---- SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB *************** *** 112,138 **** * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= max(1,N); ! * if JOB = 'E', LWORK >= M*(N-M); ! * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * ! * IWORK (workspace) INTEGER array, dimension (LIWORK) ! * IF JOB = 'N' or 'E', IWORK is not referenced. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * If JOB = 'N' or 'E', LIWORK >= 1; ! * if JOB = 'V' or 'B', LIWORK >= M*(N-M). * * If LIWORK = -1, then a workspace query is assumed; the * routine only calculates the optimal size of the IWORK array, --- 111,137 ---- * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * ! * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= max(1,N); ! * if JOB = 'E', LWORK >= max(1,M*(N-M)); ! * if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * ! * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) ! * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * If JOB = 'N' or 'E', LIWORK >= 1; ! * if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). * * If LIWORK = -1, then a workspace query is assumed; the * routine only calculates the optimal size of the IWORK array, *************** *** 233,245 **** $ NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE EXTERNAL LSAME, DLANGE * .. * .. External Subroutines .. ! EXTERNAL DLACON, DLACPY, DTREXC, DTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT --- 232,247 ---- $ NN DOUBLE PRECISION EST, RNORM, SCALE * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE EXTERNAL LSAME, DLANGE * .. * .. External Subroutines .. ! EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT *************** *** 408,414 **** EST = ZERO KASE = 0 30 CONTINUE ! CALL DLACON( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * --- 410,416 ---- EST = ZERO KASE = 0 30 CONTINUE ! CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/dtrsyl.f octave-2.9.16/libcruft/lapack/dtrsyl.f *** octave-2.9.15/libcruft/lapack/dtrsyl.f Wed Nov 3 14:54:35 1999 --- octave-2.9.16/libcruft/lapack/dtrsyl.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB --- 1,9 ---- SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB *************** *** 111,117 **** EXTERNAL LSAME, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. ! EXTERNAL DLALN2, DLASY2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN --- 110,116 ---- EXTERNAL LSAME, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. ! EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN diff -cNr octave-2.9.15/libcruft/lapack/dtrti2.f octave-2.9.16/libcruft/lapack/dtrti2.f *** octave-2.9.15/libcruft/lapack/dtrti2.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dtrti2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO --- 1,8 ---- SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff -cNr octave-2.9.15/libcruft/lapack/dtrtri.f octave-2.9.16/libcruft/lapack/dtrtri.f *** octave-2.9.15/libcruft/lapack/dtrtri.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/dtrtri.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO --- 1,8 ---- SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff -cNr octave-2.9.15/libcruft/lapack/dtrtrs.f octave-2.9.16/libcruft/lapack/dtrtrs.f *** octave-2.9.15/libcruft/lapack/dtrtrs.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/dtrtrs.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO --- 1,9 ---- SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff -cNr octave-2.9.15/libcruft/lapack/dzsum1.f octave-2.9.16/libcruft/lapack/dzsum1.f *** octave-2.9.15/libcruft/lapack/dzsum1.f Wed Nov 3 14:54:35 1999 --- octave-2.9.16/libcruft/lapack/dzsum1.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/ieeeck.f octave-2.9.16/libcruft/lapack/ieeeck.f *** octave-2.9.15/libcruft/lapack/ieeeck.f Wed Nov 3 14:53:59 1999 --- octave-2.9.16/libcruft/lapack/ieeeck.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1998 * * .. Scalar Arguments .. INTEGER ISPEC --- 1,8 ---- INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER ISPEC diff -cNr octave-2.9.15/libcruft/lapack/ilaenv.f octave-2.9.16/libcruft/lapack/ilaenv.f *** octave-2.9.15/libcruft/lapack/ilaenv.f Wed Nov 3 14:54:35 1999 --- octave-2.9.16/libcruft/lapack/ilaenv.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** ! INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, ! $ N4 ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS --- 1,8 ---- ! INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * ! * -- LAPACK auxiliary routine (version 3.1.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * January 2007 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS *************** *** 18,23 **** --- 16,25 ---- * parameters for the local environment. See ISPEC for a description of * the parameters. * + * ILAENV returns an INTEGER + * if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC + * if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. + * * This version provides a set of parameters which should give good, * but not optimal, performance on many of the currently available * computers. Users are encouraged to modify this subroutine to set *************** *** 41,47 **** * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric ! * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) --- 43,49 ---- * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric ! * eigenvalue routines (DEPRECATED) * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) *************** *** 50,62 **** * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors ! * = 8: the crossover point for the multishift QR and QZ methods ! * for nonsymmetric eigenvalue problems. * = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * =10: ieee NaN arithmetic can be trusted not to trap * =11: infinity arithmetic can be trusted not to trap * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or --- 52,67 ---- * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors ! * = 8: the crossover point for the multishift QR method ! * for nonsymmetric eigenvalue problems (DEPRECATED) * = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * =10: ieee NaN arithmetic can be trusted not to trap * =11: infinity arithmetic can be trusted not to trap + * 12 <= ISPEC <= 16: + * xHSEQR or one of its subroutines, + * see IPARMQ for detailed explanation * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or *************** *** 75,84 **** * Problem dimensions for the subroutine NAME; these may not all * be required. * - * (ILAENV) (output) INTEGER - * >= 0: the value of the parameter specified by ISPEC - * < 0: if ILAENV = -k, the k-th argument had an illegal value. - * * Further Details * =============== * --- 80,85 ---- *************** *** 102,150 **** * ===================================================================== * * .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. ! INTEGER IEEECK ! EXTERNAL IEEECK * .. * .. Executable Statements .. * ! GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, ! $ 1100 ) ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * ! 100 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME ! IC = ICHAR( SUBNAM( 1:1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN ! SUBNAM( 1:1 ) = CHAR( IC-32 ) ! DO 10 I = 2, 6 ! IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) ! $ SUBNAM( I:I ) = CHAR( IC-32 ) ! 10 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN --- 103,148 ---- * ===================================================================== * * .. Local Scalars .. INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. ! INTEGER IEEECK, IPARMQ ! EXTERNAL IEEECK, IPARMQ * .. * .. Executable Statements .. * ! GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, ! $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * ! 10 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME ! IC = ICHAR( SUBNAM( 1: 1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN ! SUBNAM( 1: 1 ) = CHAR( IC-32 ) ! DO 20 I = 2, 6 ! IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) ! $ SUBNAM( I: I ) = CHAR( IC-32 ) ! 20 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN *************** *** 154,167 **** IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN ! SUBNAM( 1:1 ) = CHAR( IC+64 ) ! DO 20 I = 2, 6 ! IC = ICHAR( SUBNAM( I:I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. ! $ ( IC.GE.162 .AND. IC.LE.169 ) ) ! $ SUBNAM( I:I ) = CHAR( IC+64 ) ! 20 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN --- 152,165 ---- IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN ! SUBNAM( 1: 1 ) = CHAR( IC+64 ) ! DO 30 I = 2, 6 ! IC = ICHAR( SUBNAM( I: I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. ! $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: ! $ I ) = CHAR( IC+64 ) ! 30 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN *************** *** 169,195 **** * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN ! SUBNAM( 1:1 ) = CHAR( IC-32 ) ! DO 30 I = 2, 6 ! IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) ! $ SUBNAM( I:I ) = CHAR( IC-32 ) ! 30 CONTINUE END IF END IF * ! C1 = SUBNAM( 1:1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN ! C2 = SUBNAM( 2:3 ) ! C3 = SUBNAM( 4:6 ) ! C4 = C3( 2:3 ) * ! GO TO ( 110, 200, 300 ) ISPEC * ! 110 CONTINUE * * ISPEC = 1: block size * --- 167,193 ---- * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN ! SUBNAM( 1: 1 ) = CHAR( IC-32 ) ! DO 40 I = 2, 6 ! IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) ! $ SUBNAM( I: I ) = CHAR( IC-32 ) ! 40 CONTINUE END IF END IF * ! C1 = SUBNAM( 1: 1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN ! C2 = SUBNAM( 2: 3 ) ! C3 = SUBNAM( 4: 6 ) ! C4 = C3( 2: 3 ) * ! GO TO ( 50, 60, 70 )ISPEC * ! 50 CONTINUE * * ISPEC = 1: block size * *************** *** 261,290 **** NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN ! IF( C3( 1:1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NB = 32 END IF ! ELSE IF( C3( 1:1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN ! IF( C3( 1:1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NB = 32 END IF ! ELSE IF( C3( 1:1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF --- 259,288 ---- NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN ! IF( C3( 1: 1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NB = 32 END IF ! ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN ! IF( C3( 1: 1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NB = 32 END IF ! ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NB = 32 END IF END IF *************** *** 344,357 **** ILAENV = NB RETURN * ! 200 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN ! IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. ! $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE --- 342,355 ---- ILAENV = NB RETURN * ! 60 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN ! IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. ! $ 'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE *************** *** 391,420 **** NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN ! IF( C3( 1:1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ! ELSE IF( C3( 1:1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN ! IF( C3( 1:1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ! ELSE IF( C3( 1:1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF --- 389,418 ---- NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN ! IF( C3( 1: 1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NBMIN = 2 END IF ! ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN ! IF( C3( 1: 1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NBMIN = 2 END IF ! ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NBMIN = 2 END IF END IF *************** *** 422,435 **** ILAENV = NBMIN RETURN * ! 300 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN ! IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. ! $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE --- 420,433 ---- ILAENV = NBMIN RETURN * ! 70 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN ! IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. ! $ 'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE *************** *** 457,474 **** NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN ! IF( C3( 1:1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN ! IF( C3( 1:1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. ! $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. ! $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF --- 455,472 ---- NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN ! IF( C3( 1: 1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN ! IF( C3( 1: 1 ).EQ.'G' ) THEN ! IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. ! $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) ! $ THEN NX = 128 END IF END IF *************** *** 476,517 **** ILAENV = NX RETURN * ! 400 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * ! 500 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * ! 600 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * ! 700 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * ! 800 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * ! 900 CONTINUE * * ISPEC = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm --- 474,515 ---- ILAENV = NX RETURN * ! 80 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * ! 90 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * ! 100 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * ! 110 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * ! 120 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * ! 130 CONTINUE * * ISPEC = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm *************** *** 520,547 **** ILAENV = 25 RETURN * ! 1000 CONTINUE * * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap * ! C ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ! ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN * ! 1100 CONTINUE * * ISPEC = 11: infinity arithmetic can be trusted not to trap * ! C ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ! ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN * * End of ILAENV * END --- 518,552 ---- ILAENV = 25 RETURN * ! 140 CONTINUE * * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap * ! * ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ! ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN * ! 150 CONTINUE * * ISPEC = 11: infinity arithmetic can be trusted not to trap * ! * ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ! ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN * + 160 CONTINUE + * + * 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. + * + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN + * * End of ILAENV * END diff -cNr octave-2.9.15/libcruft/lapack/iparmq.f octave-2.9.16/libcruft/lapack/iparmq.f *** octave-2.9.15/libcruft/lapack/iparmq.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/iparmq.f Tue Oct 16 14:54:21 2007 *************** *** 0 **** --- 1,253 ---- + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) + * + * Purpose + * ======= + * + * This program sets problem and machine dependent parameters + * useful for xHSEQR and its subroutines. It is called whenever + * ILAENV is called with 12 <= ISPEC <= 16 + * + * Arguments + * ========= + * + * ISPEC (input) integer scalar + * ISPEC specifies which tunable parameter IPARMQ should + * return. + * + * ISPEC=12: (INMIN) Matrices of order nmin or less + * are sent directly to xLAHQR, the implicit + * double shift QR algorithm. NMIN must be + * at least 11. + * + * ISPEC=13: (INWIN) Size of the deflation window. + * This is best set greater than or equal to + * the number of simultaneous shifts NS. + * Larger matrices benefit from larger deflation + * windows. + * + * ISPEC=14: (INIBL) Determines when to stop nibbling and + * invest in an (expensive) multi-shift QR sweep. + * If the aggressive early deflation subroutine + * finds LD converged eigenvalues from an order + * NW deflation window and LD.GT.(NW*NIBBLE)/100, + * then the next QR sweep is skipped and early + * deflation is applied immediately to the + * remaining active diagonal block. Setting + * IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a + * multi-shift QR sweep whenever early deflation + * finds a converged eigenvalue. Setting + * IPARMQ(ISPEC=14) greater than or equal to 100 + * prevents TTQRE from skipping a multi-shift + * QR sweep. + * + * ISPEC=15: (NSHFTS) The number of simultaneous shifts in + * a multi-shift QR iteration. + * + * ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the + * following meanings. + * 0: During the multi-shift QR sweep, + * xLAQR5 does not accumulate reflections and + * does not use matrix-matrix multiply to + * update the far-from-diagonal matrix + * entries. + * 1: During the multi-shift QR sweep, + * xLAQR5 and/or xLAQRaccumulates reflections and uses + * matrix-matrix multiply to update the + * far-from-diagonal matrix entries. + * 2: During the multi-shift QR sweep. + * xLAQR5 accumulates reflections and takes + * advantage of 2-by-2 block structure during + * matrix-matrix multiplies. + * (If xTRMM is slower than xGEMM, then + * IPARMQ(ISPEC=16)=1 may be more efficient than + * IPARMQ(ISPEC=16)=2 despite the greater level of + * arithmetic work implied by the latter choice.) + * + * NAME (input) character string + * Name of the calling subroutine + * + * OPTS (input) character string + * This is a concatenation of the string arguments to + * TTQRE. + * + * N (input) integer scalar + * N is the order of the Hessenberg matrix H. + * + * ILO (input) INTEGER + * IHI (input) INTEGER + * It is assumed that H is already upper triangular + * in rows and columns 1:ILO-1 and IHI+1:N. + * + * LWORK (input) integer scalar + * The amount of workspace available. + * + * Further Details + * =============== + * + * Little is known about how best to choose these parameters. + * It is possible to use different values of the parameters + * for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. + * + * It is probably best to choose different parameters for + * different matrices and different parameters at different + * times during the iteration, but this has not been + * implemented --- yet. + * + * + * The best choices of most of the parameters depend + * in an ill-understood way on the relative execution + * rate of xLAQR3 and xLAQR5 and on the nature of each + * particular eigenvalue problem. Experiment may be the + * only practical way to determine which choices are most + * effective. + * + * Following is a list of default values supplied by IPARMQ. + * These defaults may be adjusted in order to attain better + * performance in any particular computational environment. + * + * IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. + * Default: 75. (Must be at least 11.) + * + * IPARMQ(ISPEC=13) Recommended deflation window size. + * This depends on ILO, IHI and NS, the + * number of simultaneous shifts returned + * by IPARMQ(ISPEC=15). The default for + * (IHI-ILO+1).LE.500 is NS. The default + * for (IHI-ILO+1).GT.500 is 3*NS/2. + * + * IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. + * + * IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. + * a multi-shift QR iteration. + * + * If IHI-ILO+1 is ... + * + * greater than ...but less ... the + * or equal to ... than default is + * + * 0 30 NS = 2+ + * 30 60 NS = 4+ + * 60 150 NS = 10 + * 150 590 NS = ** + * 590 3000 NS = 64 + * 3000 6000 NS = 128 + * 6000 infinity NS = 256 + * + * (+) By default matrices of this order are + * passed to the implicit double shift routine + * xLAHQR. See IPARMQ(ISPEC=12) above. These + * values of NS are used only in case of a rare + * xLAHQR failure. + * + * (**) The asterisks (**) indicate an ad-hoc + * function increasing from 10 to 64. + * + * IPARMQ(ISPEC=16) Select structured matrix multiply. + * (See ISPEC=16 above for details.) + * Default: 3. + * + * ================================================================ + * .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) + * .. + * .. Local Scalars .. + INTEGER NH, NS + * .. + * .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL + * .. + * .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN + * + * ==== Set the number simultaneous shifts ==== + * + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF + * + IF( ISPEC.EQ.INMIN ) THEN + * + * + * ===== Matrices of order smaller than NMIN get sent + * . to xLAHQR, the classic double shift algorithm. + * . This must be at least 11. ==== + * + IPARMQ = NMIN + * + ELSE IF( ISPEC.EQ.INIBL ) THEN + * + * ==== INIBL: skip a multi-shift qr iteration and + * . whenever aggressive early deflation finds + * . at least (NIBBLE*(window size)/100) deflations. ==== + * + IPARMQ = NIBBLE + * + ELSE IF( ISPEC.EQ.ISHFTS ) THEN + * + * ==== NSHFTS: The number of simultaneous shifts ===== + * + IPARMQ = NS + * + ELSE IF( ISPEC.EQ.INWIN ) THEN + * + * ==== NW: deflation window size. ==== + * + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF + * + ELSE IF( ISPEC.EQ.IACC22 ) THEN + * + * ==== IACC22: Whether to accumulate reflections + * . before updating the far-from-diagonal elements + * . and whether to use 2-by-2 block structure while + * . doing it. A small amount of work could be saved + * . by making this choice dependent also upon the + * . NH=IHI-ILO+1. + * + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + * + ELSE + * ===== invalid value of ispec ===== + IPARMQ = -1 + * + END IF + * + * ==== End of IPARMQ ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/izmax1.f octave-2.9.16/libcruft/lapack/izmax1.f *** octave-2.9.15/libcruft/lapack/izmax1.f Wed Nov 3 14:54:35 1999 --- octave-2.9.16/libcruft/lapack/izmax1.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** INTEGER FUNCTION IZMAX1( N, CX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- INTEGER FUNCTION IZMAX1( N, CX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N *************** *** 43,49 **** COMPLEX*16 ZDUM * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 --- 42,48 ---- COMPLEX*16 ZDUM * .. * .. Intrinsic Functions .. ! INTRINSIC ABS * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 diff -cNr octave-2.9.15/libcruft/lapack/spotf2.f octave-2.9.16/libcruft/lapack/spotf2.f *** octave-2.9.15/libcruft/lapack/spotf2.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/spotf2.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/spotrf.f octave-2.9.16/libcruft/lapack/spotrf.f *** octave-2.9.15/libcruft/lapack/spotrf.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/spotrf.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zbdsqr.f octave-2.9.16/libcruft/lapack/zbdsqr.f *** octave-2.9.15/libcruft/lapack/zbdsqr.f Wed Sep 14 14:55:04 2005 --- octave-2.9.16/libcruft/lapack/zbdsqr.f Tue Oct 16 14:54:21 2007 *************** *** 1,10 **** SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,9 ---- SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 18,31 **** * Purpose * ======= * ! * ZBDSQR computes the singular value decomposition (SVD) of a real ! * N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' ! * denotes the transpose of P), where S is a diagonal matrix with ! * non-negative diagonal elements (the singular values of B), and Q ! * and P are orthogonal matrices. ! * ! * The routine computes S, and optionally computes U * Q, P' * VT, ! * or Q' * C, for given complex input matrices U, VT, and C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, --- 17,42 ---- * Purpose * ======= * ! * ZBDSQR computes the singular values and, optionally, the right and/or ! * left singular vectors from the singular value decomposition (SVD) of ! * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit ! * zero-shift QR algorithm. The SVD of B has the form ! * ! * B = Q * S * P**H ! * ! * where S is the diagonal matrix of singular values, Q is an orthogonal ! * matrix of left singular vectors, and P is an orthogonal matrix of ! * right singular vectors. If left singular vectors are requested, this ! * subroutine actually returns U*Q instead of Q, and, if right singular ! * vectors are requested, this subroutine returns P**H*VT instead of ! * P**H, for given complex input matrices U and VT. When U and VT are ! * the unitary matrices that reduce a general matrix A to bidiagonal ! * form: A = U*B*VT, as computed by ZGEBRD, then ! * ! * A = (U*Q) * S * (P**H*VT) ! * ! * is the SVD of A. Optionally, the subroutine may also compute Q**H*C ! * for a given complex input matrix C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, *************** *** 60,78 **** * On exit, if INFO=0, the singular values of B in decreasing * order. * ! * E (input/output) DOUBLE PRECISION array, dimension (N) ! * On entry, the elements of E contain the ! * offdiagonal elements of the bidiagonal matrix whose SVD ! * is desired. On normal exit (INFO = 0), E is destroyed. ! * If the algorithm does not converge (INFO > 0), D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given ! * as input. E(N) is used for workspace. * * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. ! * On exit, VT is overwritten by P' * VT. ! * VT is not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. --- 71,88 ---- * On exit, if INFO=0, the singular values of B in decreasing * order. * ! * E (input/output) DOUBLE PRECISION array, dimension (N-1) ! * On entry, the N-1 offdiagonal elements of the bidiagonal ! * matrix B. ! * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given ! * as input. * * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. ! * On exit, VT is overwritten by P**H * VT. ! * Not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. *************** *** 81,101 **** * U (input/output) COMPLEX*16 array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. ! * U is not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) COMPLEX*16 array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. ! * On exit, C is overwritten by Q' * C. ! * C is not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * ! * RWORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * INFO (output) INTEGER * = 0: successful exit --- 91,112 ---- * U (input/output) COMPLEX*16 array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. ! * Not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) COMPLEX*16 array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. ! * On exit, C is overwritten by Q**H * C. ! * Not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * ! * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) ! * if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise * * INFO (output) INTEGER * = 0: successful exit *************** *** 155,161 **** $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, ! $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. --- 166,172 ---- $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, ! $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. *************** *** 415,421 **** E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 100 CONTINUE --- 426,431 ---- *************** *** 444,450 **** E( LLL ) = ZERO GO TO 60 END IF - SMINLO = SMINL MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 110 CONTINUE --- 454,459 ---- diff -cNr octave-2.9.15/libcruft/lapack/zdrscl.f octave-2.9.16/libcruft/lapack/zdrscl.f *** octave-2.9.15/libcruft/lapack/zdrscl.f Wed Nov 3 14:54:35 1999 --- octave-2.9.16/libcruft/lapack/zdrscl.f Tue Oct 16 14:54:21 2007 *************** *** 1,9 **** SUBROUTINE ZDRSCL( N, SA, SX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- SUBROUTINE ZDRSCL( N, SA, SX, INCX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/zgbcon.f octave-2.9.16/libcruft/lapack/zgbcon.f *** octave-2.9.15/libcruft/lapack/zgbcon.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zgbcon.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, RWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER NORM --- 1,11 ---- SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, RWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM *************** *** 89,94 **** --- 90,98 ---- DOUBLE PRECISION AINVNM, SCALE, SMLNUM COMPLEX*16 T, ZDUM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX *************** *** 97,103 **** EXTERNAL LSAME, IZAMAX, DLAMCH, ZDOTC * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZAXPY, ZDRSCL, ZLACON, ZLATBS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MIN --- 101,107 ---- EXTERNAL LSAME, IZAMAX, DLAMCH, ZDOTC * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZAXPY, ZDRSCL, ZLACN2, ZLATBS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MIN *************** *** 157,163 **** LNOTI = KL.GT.0 KASE = 0 10 CONTINUE ! CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * --- 161,167 ---- LNOTI = KL.GT.0 KASE = 0 10 CONTINUE ! CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/zgbtf2.f octave-2.9.16/libcruft/lapack/zgbtf2.f *** octave-2.9.15/libcruft/lapack/zgbtf2.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zgbtf2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N --- 1,8 ---- SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff -cNr octave-2.9.15/libcruft/lapack/zgbtrf.f octave-2.9.16/libcruft/lapack/zgbtrf.f *** octave-2.9.15/libcruft/lapack/zgbtrf.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zgbtrf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N --- 1,8 ---- SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N diff -cNr octave-2.9.15/libcruft/lapack/zgbtrs.f octave-2.9.16/libcruft/lapack/zgbtrs.f *** octave-2.9.15/libcruft/lapack/zgbtrs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zgbtrs.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER TRANS --- 1,9 ---- SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS diff -cNr octave-2.9.15/libcruft/lapack/zgebak.f octave-2.9.16/libcruft/lapack/zgebak.f *** octave-2.9.15/libcruft/lapack/zgebak.f Wed Nov 3 14:54:36 1999 --- octave-2.9.16/libcruft/lapack/zgebak.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB, SIDE --- 1,9 ---- SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOB, SIDE diff -cNr octave-2.9.15/libcruft/lapack/zgebal.f octave-2.9.16/libcruft/lapack/zgebal.f *** octave-2.9.15/libcruft/lapack/zgebal.f Wed Nov 3 14:54:36 1999 --- octave-2.9.16/libcruft/lapack/zgebal.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOB --- 1,8 ---- SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOB *************** *** 106,112 **** DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC ! PARAMETER ( SCLFAC = 0.8D+1 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. --- 105,111 ---- DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC ! PARAMETER ( SCLFAC = 2.0D+0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. diff -cNr octave-2.9.15/libcruft/lapack/zgebd2.f octave-2.9.16/libcruft/lapack/zgebd2.f *** octave-2.9.15/libcruft/lapack/zgebd2.f Wed Nov 3 14:54:36 1999 --- octave-2.9.16/libcruft/lapack/zgebd2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N *************** *** 172,179 **** * * Apply H(i)' to A(i:m,i+1:n) from the left * ! CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, ! $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN --- 171,179 ---- * * Apply H(i)' to A(i:m,i+1:n) from the left * ! IF( I.LT.N ) ! $ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, ! $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN *************** *** 215,222 **** * * Apply G(i) to A(i+1:m,i:n) from the right * ! CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), ! $ A( MIN( I+1, M ), I ), LDA, WORK ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * --- 215,223 ---- * * Apply G(i) to A(i+1:m,i:n) from the right * ! IF( I.LT.M ) ! $ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, ! $ TAUP( I ), A( I+1, I ), LDA, WORK ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * diff -cNr octave-2.9.15/libcruft/lapack/zgebrd.f octave-2.9.16/libcruft/lapack/zgebrd.f *** octave-2.9.15/libcruft/lapack/zgebrd.f Wed Nov 3 14:54:36 1999 --- octave-2.9.16/libcruft/lapack/zgebrd.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N --- 1,9 ---- SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N *************** *** 70,76 **** * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 69,75 ---- * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zgecon.f octave-2.9.16/libcruft/lapack/zgecon.f *** octave-2.9.15/libcruft/lapack/zgecon.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/zgecon.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER NORM --- 1,11 ---- SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER NORM *************** *** 75,80 **** --- 76,84 ---- DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU COMPLEX*16 ZDUM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX *************** *** 82,88 **** EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX --- 86,92 ---- EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX *************** *** 136,142 **** END IF KASE = 0 10 CONTINUE ! CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * --- 140,146 ---- END IF KASE = 0 10 CONTINUE ! CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/zgeesx.f octave-2.9.16/libcruft/lapack/zgeesx.f *** octave-2.9.15/libcruft/lapack/zgeesx.f Wed Nov 3 14:54:36 1999 --- octave-2.9.16/libcruft/lapack/zgeesx.f Tue Oct 16 14:54:22 2007 *************** *** 2,11 **** $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT --- 2,10 ---- $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT *************** *** 56,62 **** * = 'N': Eigenvalues are not ordered; * = 'S': Eigenvalues are ordered (see SELECT). * ! * SELECT (input) LOGICAL FUNCTION of one COMPLEX*16 argument * SELECT must be declared EXTERNAL in the calling subroutine. * If SORT = 'S', SELECT is used to select eigenvalues to order * to the top left of the Schur form. --- 55,61 ---- * = 'N': Eigenvalues are not ordered; * = 'S': Eigenvalues are ordered (see SELECT). * ! * SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument * SELECT must be declared EXTERNAL in the calling subroutine. * If SORT = 'S', SELECT is used to select eigenvalues to order * to the top left of the Schur form. *************** *** 109,124 **** * condition number for the selected right invariant subspace. * Not referenced if SENSE = 'N' or 'E'. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,2*N). * Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), * where SDIM is the number of selected eigenvalues computed by ! * this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. * For good performance, LWORK must generally be larger. * * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * BWORK (workspace) LOGICAL array, dimension (N) --- 108,131 ---- * condition number for the selected right invariant subspace. * Not referenced if SENSE = 'N' or 'E'. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,2*N). * Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), * where SDIM is the number of selected eigenvalues computed by ! * this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also ! * that an error is only returned if LWORK < max(1,2*N), but if ! * SENSE = 'E' or 'V' or 'B' this may not be large enough. * For good performance, LWORK must generally be larger. * + * If LWORK = -1, then a workspace query is assumed; the routine + * only calculates upper bound on the optimal size of the + * array WORK, returns this value as the first entry of the WORK + * array, and no error message related to LWORK is issued by + * XERBLA. + * * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * BWORK (workspace) LOGICAL array, dimension (N) *************** *** 151,165 **** LOGICAL SCALEA, WANTSB, WANTSE, WANTSN, WANTST, WANTSV, $ WANTVS INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, ! $ ITAU, IWRK, K, MAXB, MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. ! EXTERNAL DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD, ! $ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME --- 158,172 ---- LOGICAL SCALEA, WANTSB, WANTSE, WANTSN, WANTST, WANTSV, $ WANTVS INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO, ! $ ITAU, IWRK, LWRK, MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. ! EXTERNAL DLABAD, DLASCL, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ! $ ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME *************** *** 168,174 **** EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * --- 175,181 ---- EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * *************** *** 210,239 **** * depends on SDIM, which is computed by the routine ZTRSEN later * in the code.) * ! MINWRK = 1 ! IF( INFO.EQ.0 .AND. ( LWORK.GE.1 ) ) THEN ! MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) ! MINWRK = MAX( 1, 2*N ) ! IF( .NOT.WANTVS ) THEN ! MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SN', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SN', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, HSWORK, 1 ) ELSE ! MAXWRK = MAX( MAXWRK, N+( N-1 )* ! $ ILAENV( 1, 'ZUNGHR', ' ', N, 1, N, -1 ) ) ! MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SV', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SV', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, HSWORK, 1 ) END IF - WORK( 1 ) = MAXWRK - END IF - IF( LWORK.LT.MINWRK ) THEN - INFO = -15 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEESX', -INFO ) RETURN --- 217,252 ---- * depends on SDIM, which is computed by the routine ZTRSEN later * in the code.) * ! IF( INFO.EQ.0 ) THEN ! IF( N.EQ.0 ) THEN ! MINWRK = 1 ! LWRK = 1 ELSE ! MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) ! MINWRK = 2*N ! * ! CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS, ! $ WORK, -1, IEVAL ) ! HSWORK = WORK( 1 ) ! * ! IF( .NOT.WANTVS ) THEN ! MAXWRK = MAX( MAXWRK, HSWORK ) ! ELSE ! MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', ! $ ' ', N, 1, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, HSWORK ) ! END IF ! LWRK = MAXWRK ! IF( .NOT.WANTSN ) ! $ LWRK = MAX( LWRK, ( N*N )/2 ) ! END IF ! WORK( 1 ) = LWRK ! * ! IF( LWORK.LT.MINWRK ) THEN ! INFO = -15 END IF END IF + * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEESX', -INFO ) RETURN diff -cNr octave-2.9.15/libcruft/lapack/zgeev.f octave-2.9.16/libcruft/lapack/zgeev.f *** octave-2.9.15/libcruft/lapack/zgeev.f Wed Nov 3 14:54:36 1999 --- octave-2.9.16/libcruft/lapack/zgeev.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR --- 1,9 ---- SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR *************** *** 78,84 **** * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 77,83 ---- * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 110,116 **** LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, ! $ IWRK, K, MAXB, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM COMPLEX*16 TMP * .. --- 109,115 ---- LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, ! $ IWRK, K, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM COMPLEX*16 TMP * .. *************** *** 119,126 **** DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, ZHSEQR, ! $ ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME --- 118,125 ---- DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. ! EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, ! $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR * .. * .. External Functions .. LOGICAL LSAME *************** *** 129,135 **** EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE * .. * .. Intrinsic Functions .. ! INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN, SQRT * .. * .. Executable Statements .. * --- 128,134 ---- EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE * .. * .. Intrinsic Functions .. ! INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT * .. * .. Executable Statements .. * *************** *** 164,194 **** * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * ! MINWRK = 1 ! IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN ! MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) ! IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN ! MINWRK = MAX( 1, 2*N ) ! MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'EN', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'EN', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, HSWORK ) ELSE ! MINWRK = MAX( 1, 2*N ) ! MAXWRK = MAX( MAXWRK, N+( N-1 )* ! $ ILAENV( 1, 'ZUNGHR', ' ', N, 1, N, -1 ) ) ! MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SV', N, 1, N, -1 ), 2 ) ! K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SV', N, 1, ! $ N, -1 ) ) ) ! HSWORK = MAX( K*( K+2 ), 2*N ) ! MAXWRK = MAX( MAXWRK, HSWORK, 2*N ) END IF WORK( 1 ) = MAXWRK END IF ! IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN ! INFO = -12 ! END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEEV ', -INFO ) RETURN --- 163,199 ---- * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * ! IF( INFO.EQ.0 ) THEN ! IF( N.EQ.0 ) THEN ! MINWRK = 1 ! MAXWRK = 1 ELSE ! MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) ! MINWRK = 2*N ! IF( WANTVL ) THEN ! MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', ! $ ' ', N, 1, N, -1 ) ) ! CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, ! $ WORK, -1, INFO ) ! ELSE IF( WANTVR ) THEN ! MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', ! $ ' ', N, 1, N, -1 ) ) ! CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, ! $ WORK, -1, INFO ) ! ELSE ! CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, ! $ WORK, -1, INFO ) ! END IF ! HSWORK = WORK( 1 ) ! MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) END IF WORK( 1 ) = MAXWRK + * + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF END IF ! * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEEV ', -INFO ) RETURN diff -cNr octave-2.9.15/libcruft/lapack/zgehd2.f octave-2.9.16/libcruft/lapack/zgehd2.f *** octave-2.9.15/libcruft/lapack/zgehd2.f Wed Nov 3 14:54:37 1999 --- octave-2.9.16/libcruft/lapack/zgehd2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N --- 1,8 ---- SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N diff -cNr octave-2.9.15/libcruft/lapack/zgehrd.f octave-2.9.16/libcruft/lapack/zgehrd.f *** octave-2.9.15/libcruft/lapack/zgehrd.f Wed Nov 3 14:54:37 1999 --- octave-2.9.16/libcruft/lapack/zgehrd.f Tue Oct 16 14:54:22 2007 *************** *** 1,22 **** SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. ! COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * ! * ZGEHRD reduces a complex general matrix A to upper Hessenberg form H ! * by a unitary similarity transformation: Q' * A * Q = H . * * Arguments * ========= --- 1,21 ---- SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. ! COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * ! * ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by ! * an unitary similarity transformation: Q' * A * Q = H . * * Arguments * ========= *************** *** 98,123 **** * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) ! COMPLEX*16 ZERO, ONE ! PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), ! $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY ! INTEGER I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, ! $ NH, NX ! COMPLEX*16 EI * .. * .. Local Arrays .. ! COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZGEHD2, ZGEMM, ZLAHRD, ZLARFB * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN --- 97,127 ---- * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * + * This file is a slight modification of LAPACK-3.0's ZGEHRD + * subroutine incorporating improvements proposed by Quintana-Orti and + * Van de Geijn (2005). + * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) ! COMPLEX*16 ZERO, ONE ! PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), ! $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY ! INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, ! $ NBMIN, NH, NX ! COMPLEX*16 EI * .. * .. Local Arrays .. ! COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Subroutines .. ! EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, ! $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN *************** *** 170,193 **** RETURN END IF * NBMIN = 2 IWS = 1 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code ! * (last block is always handled by unblocked code). * NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * ! * Determine if workspace is large enough for blocked code. * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of ! * unblocked code. * NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, $ -1 ) ) --- 174,200 ---- RETURN END IF * + * Determine the block size + * + NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IWS = 1 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code ! * (last block is always handled by unblocked code) * NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * ! * Determine if workspace is large enough for blocked code * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of ! * unblocked code * NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, $ -1 ) ) *************** *** 211,245 **** * * Use blocked code * ! DO 30 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * ! CALL ZLAHRD( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set ! * to 1. * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE ! CALL ZGEMM( 'No transpose', 'Conjugate transpose', IHI, ! $ IHI-I-IB+1, IB, -ONE, WORK, LDWORK, ! $ A( I+IB, I ), LDA, ONE, A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', ! $ 'Columnwise', IHI-I, N-I-IB+1, IB, A( I+1, I ), ! $ LDA, T, LDT, A( I+1, I+IB ), LDA, WORK, ! $ LDWORK ) ! 30 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix --- 218,264 ---- * * Use blocked code * ! DO 40 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * ! CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set ! * to 1 * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE ! CALL ZGEMM( 'No transpose', 'Conjugate transpose', ! $ IHI, IHI-I-IB+1, ! $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, ! $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * + * Apply the block reflector H to A(1:i,i+1:i+ib-1) from the + * right + * + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE + * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', ! $ 'Columnwise', ! $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, ! $ A( I+1, I+IB ), LDA, WORK, LDWORK ) ! 40 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix diff -cNr octave-2.9.15/libcruft/lapack/zgelq2.f octave-2.9.16/libcruft/lapack/zgelq2.f *** octave-2.9.15/libcruft/lapack/zgelq2.f Wed Nov 3 14:54:37 1999 --- octave-2.9.16/libcruft/lapack/zgelq2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/zgelqf.f octave-2.9.16/libcruft/lapack/zgelqf.f *** octave-2.9.15/libcruft/lapack/zgelqf.f Wed Nov 3 14:54:37 1999 --- octave-2.9.16/libcruft/lapack/zgelqf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N *************** *** 42,48 **** * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 41,47 ---- * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zgelsd.f octave-2.9.16/libcruft/lapack/zgelsd.f *** octave-2.9.15/libcruft/lapack/zgelsd.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zgelsd.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,566 ---- + SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, + $ WORK, LWORK, RWORK, IWORK, INFO ) + * + * -- LAPACK driver routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND + * .. + * .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION RWORK( * ), S( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * ZGELSD computes the minimum-norm solution to a real linear least + * squares problem: + * minimize 2-norm(| b - A*x |) + * using the singular value decomposition (SVD) of A. A is an M-by-N + * matrix which may be rank-deficient. + * + * Several right hand side vectors b and solution vectors x can be + * handled in a single call; they are stored as the columns of the + * M-by-NRHS right hand side matrix B and the N-by-NRHS solution + * matrix X. + * + * The problem is solved in three steps: + * (1) Reduce the coefficient matrix A to bidiagonal form with + * Householder tranformations, reducing the original problem + * into a "bidiagonal least squares problem" (BLS) + * (2) Solve the BLS using a divide and conquer approach. + * (3) Apply back all the Householder tranformations to solve + * the original least squares problem. + * + * The effective rank of A is determined by treating as zero those + * singular values which are less than RCOND times the largest singular + * value. + * + * The divide and conquer algorithm makes very mild assumptions about + * floating point arithmetic. It will work on machines with a guard + * digit in add/subtract, or on those binary machines without guard + * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or + * Cray-2. It could conceivably fail on hexadecimal or decimal machines + * without guard digits, but we know of none. + * + * Arguments + * ========= + * + * M (input) INTEGER + * The number of rows of the matrix A. M >= 0. + * + * N (input) INTEGER + * The number of columns of the matrix A. N >= 0. + * + * NRHS (input) INTEGER + * The number of right hand sides, i.e., the number of columns + * of the matrices B and X. NRHS >= 0. + * + * A (input) COMPLEX*16 array, dimension (LDA,N) + * On entry, the M-by-N matrix A. + * On exit, A has been destroyed. + * + * LDA (input) INTEGER + * The leading dimension of the array A. LDA >= max(1,M). + * + * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) + * On entry, the M-by-NRHS right hand side matrix B. + * On exit, B is overwritten by the N-by-NRHS solution matrix X. + * If m >= n and RANK = n, the residual sum-of-squares for + * the solution in the i-th column is given by the sum of + * squares of the modulus of elements n+1:m in that column. + * + * LDB (input) INTEGER + * The leading dimension of the array B. LDB >= max(1,M,N). + * + * S (output) DOUBLE PRECISION array, dimension (min(M,N)) + * The singular values of A in decreasing order. + * The condition number of A in the 2-norm = S(1)/S(min(m,n)). + * + * RCOND (input) DOUBLE PRECISION + * RCOND is used to determine the effective rank of A. + * Singular values S(i) <= RCOND*S(1) are treated as zero. + * If RCOND < 0, machine precision is used instead. + * + * RANK (output) INTEGER + * The effective rank of A, i.e., the number of singular values + * which are greater than RCOND*S(1). + * + * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) + * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + * + * LWORK (input) INTEGER + * The dimension of the array WORK. LWORK must be at least 1. + * The exact minimum amount of workspace needed depends on M, + * N and NRHS. As long as LWORK is at least + * 2*N + N*NRHS + * if M is greater than or equal to N or + * 2*M + M*NRHS + * if M is less than N, the code will execute correctly. + * For good performance, LWORK should generally be larger. + * + * If LWORK = -1, then a workspace query is assumed; the routine + * only calculates the optimal size of the array WORK and the + * minimum sizes of the arrays RWORK and IWORK, and returns + * these values as the first entries of the WORK, RWORK and + * IWORK arrays, and no error message related to LWORK is issued + * by XERBLA. + * + * RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) + * LRWORK >= + * 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + + * (SMLSIZ+1)**2 + * if M is greater than or equal to N or + * 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS + + * (SMLSIZ+1)**2 + * if M is less than N, the code will execute correctly. + * SMLSIZ is returned by ILAENV and is equal to the maximum + * size of the subproblems at the bottom of the computation + * tree (usually about 25), and + * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) + * On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK. + * + * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) + * LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), + * where MINMN = MIN( M,N ). + * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. + * + * INFO (output) INTEGER + * = 0: successful exit + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: the algorithm for computing the SVD failed to converge; + * if INFO = i, i off-diagonal elements of an intermediate + * bidiagonal form did not converge to zero. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + * .. + * .. Local Scalars .. + LOGICAL LQUERY + INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, + $ LDWORK, LIWORK, LRWORK, MAXMN, MAXWRK, MINMN, + $ MINWRK, MM, MNTHR, NLVL, NRWORK, NWORK, SMLSIZ + DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM + * .. + * .. External Subroutines .. + EXTERNAL DLABAD, DLASCL, DLASET, XERBLA, ZGEBRD, ZGELQF, + $ ZGEQRF, ZLACPY, ZLALSD, ZLASCL, ZLASET, ZUNMBR, + $ ZUNMLQ, ZUNMQR + * .. + * .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL ILAENV, DLAMCH, ZLANGE + * .. + * .. Intrinsic Functions .. + INTRINSIC INT, LOG, MAX, MIN, DBLE + * .. + * .. Executable Statements .. + * + * Test the input arguments. + * + INFO = 0 + MINMN = MIN( M, N ) + MAXMN = MAX( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN + INFO = -7 + END IF + * + * Compute workspace. + * (Note: Comments in the code beginning "Workspace:" describe the + * minimal amount of workspace needed at that point in the code, + * as well as the preferred amount for good performance. + * NB refers to the optimal block size for the immediately + * following subroutine, as returned by ILAENV.) + * + IF( INFO.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + LIWORK = 1 + LRWORK = 1 + IF( MINMN.GT.0 ) THEN + SMLSIZ = ILAENV( 9, 'ZGELSD', ' ', 0, 0, 0, 0 ) + MNTHR = ILAENV( 6, 'ZGELSD', ' ', M, N, NRHS, -1 ) + NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ + 1 ) ) / + $ LOG( TWO ) ) + 1, 0 ) + LIWORK = 3*MINMN*NLVL + 11*MINMN + MM = M + IF( M.GE.N .AND. M.GE.MNTHR ) THEN + * + * Path 1a - overdetermined, with many more rows than + * columns. + * + MM = N + MAXWRK = MAX( MAXWRK, N*ILAENV( 1, 'ZGEQRF', ' ', M, N, + $ -1, -1 ) ) + MAXWRK = MAX( MAXWRK, NRHS*ILAENV( 1, 'ZUNMQR', 'LC', M, + $ NRHS, N, -1 ) ) + END IF + IF( M.GE.N ) THEN + * + * Path 1 - overdetermined or exactly determined. + * + LRWORK = 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + + $ ( SMLSIZ + 1 )**2 + MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1, + $ 'ZGEBRD', ' ', MM, N, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'ZUNMBR', + $ 'QLC', MM, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'ZUNMBR', 'PLN', N, NRHS, N, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*N + N*NRHS ) + MINWRK = MAX( 2*N + MM, 2*N + N*NRHS ) + END IF + IF( N.GT.M ) THEN + LRWORK = 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS + + $ ( SMLSIZ + 1 )**2 + IF( N.GE.MNTHR ) THEN + * + * Path 2a - underdetermined, with many more columns + * than rows. + * + MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, + $ -1 ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1, + $ 'ZGEBRD', ' ', M, M, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1, + $ 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1, + $ 'ZUNMLQ', 'LC', N, NRHS, M, -1 ) ) + IF( NRHS.GT.1 ) THEN + MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) + ELSE + MAXWRK = MAX( MAXWRK, M*M + 2*M ) + END IF + MAXWRK = MAX( MAXWRK, M*M + 4*M + M*NRHS ) + ELSE + * + * Path 2 - underdetermined. + * + MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'ZGEBRD', ' ', M, + $ N, -1, -1 ) + MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'ZUNMBR', + $ 'QLC', M, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'ZUNMBR', + $ 'PLN', N, NRHS, M, -1 ) ) + MAXWRK = MAX( MAXWRK, 2*M + M*NRHS ) + END IF + MINWRK = MAX( 2*M + N, 2*M + M*NRHS ) + END IF + END IF + MINWRK = MIN( MINWRK, MAXWRK ) + WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWORK + RWORK( 1 ) = LRWORK + * + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF + * + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGELSD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF + * + * Quick return if possible. + * + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + RANK = 0 + RETURN + END IF + * + * Get machine parameters. + * + EPS = DLAMCH( 'P' ) + SFMIN = DLAMCH( 'S' ) + SMLNUM = SFMIN / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + * + * Scale A if max entry outside range [SMLNUM,BIGNUM]. + * + ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + * + * Scale matrix norm up to SMLNUM + * + CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN + * + * Scale matrix norm down to BIGNUM. + * + CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN + * + * Matrix all zero. Return zero solution. + * + CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB ) + CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) + RANK = 0 + GO TO 10 + END IF + * + * Scale B if max entry outside range [SMLNUM,BIGNUM]. + * + BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + * + * Scale matrix norm up to SMLNUM. + * + CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN + * + * Scale matrix norm down to BIGNUM. + * + CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) + IBSCL = 2 + END IF + * + * If M < N make sure B(M+1:N,:) = 0 + * + IF( M.LT.N ) + $ CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB ) + * + * Overdetermined case. + * + IF( M.GE.N ) THEN + * + * Path 1 - overdetermined or exactly determined. + * + MM = M + IF( M.GE.MNTHR ) THEN + * + * Path 1a - overdetermined, with many more rows than columns + * + MM = N + ITAU = 1 + NWORK = ITAU + N + * + * Compute A=Q*R. + * (RWorkspace: need N) + * (CWorkspace: need N, prefer N*NB) + * + CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Multiply B by transpose(Q). + * (RWorkspace: need N) + * (CWorkspace: need NRHS, prefer NRHS*NB) + * + CALL ZUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + * Zero out below R. + * + IF( N.GT.1 ) THEN + CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), + $ LDA ) + END IF + END IF + * + ITAUQ = 1 + ITAUP = ITAUQ + N + NWORK = ITAUP + N + IE = 1 + NRWORK = IE + N + * + * Bidiagonalize R in A. + * (RWorkspace: need N) + * (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) + * + CALL ZGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ INFO ) + * + * Multiply B by transpose of left bidiagonalizing vectors of R. + * (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) + * + CALL ZUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + * Solve the bidiagonal least squares problem. + * + CALL ZLALSD( 'U', SMLSIZ, N, NRHS, S, RWORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ), + $ IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF + * + * Multiply B by right bidiagonalizing vectors of R. + * + CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ + $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN + * + * Path 2a - underdetermined, with many more columns than rows + * and sufficient workspace for an efficient algorithm. + * + LDWORK = M + IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), + $ M*LDA+M+M*NRHS ) )LDWORK = LDA + ITAU = 1 + NWORK = M + 1 + * + * Compute A=L*Q. + * (CWorkspace: need 2*M, prefer M+M*NB) + * + CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + IL = NWORK + * + * Copy L to WORK(IL), zeroing out above its diagonal. + * + CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) + CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ), + $ LDWORK ) + ITAUQ = IL + LDWORK*M + ITAUP = ITAUQ + M + NWORK = ITAUP + M + IE = 1 + NRWORK = IE + M + * + * Bidiagonalize L in WORK(IL). + * (RWorkspace: need M) + * (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB) + * + CALL ZGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ), + $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Multiply B by transpose of left bidiagonalizing vectors of L. + * (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) + * + CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUQ ), B, LDB, WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Solve the bidiagonal least squares problem. + * + CALL ZLALSD( 'U', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ), + $ IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF + * + * Multiply B by right bidiagonalizing vectors of L. + * + CALL ZUNMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK, + $ WORK( ITAUP ), B, LDB, WORK( NWORK ), + $ LWORK-NWORK+1, INFO ) + * + * Zero out below first M rows of B. + * + CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB ) + NWORK = ITAU + M + * + * Multiply transpose(Q) by B. + * (CWorkspace: need NRHS, prefer NRHS*NB) + * + CALL ZUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B, + $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + ELSE + * + * Path 2 - remaining underdetermined cases. + * + ITAUQ = 1 + ITAUP = ITAUQ + M + NWORK = ITAUP + M + IE = 1 + NRWORK = IE + M + * + * Bidiagonalize A. + * (RWorkspace: need M) + * (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) + * + CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), + $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, + $ INFO ) + * + * Multiply B by transpose of left bidiagonalizing vectors. + * (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) + * + CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + * Solve the bidiagonal least squares problem. + * + CALL ZLALSD( 'L', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB, + $ RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ), + $ IWORK, INFO ) + IF( INFO.NE.0 ) THEN + GO TO 10 + END IF + * + * Multiply B by right bidiagonalizing vectors of A. + * + CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ), + $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) + * + END IF + * + * Undo scaling. + * + IF( IASCL.EQ.1 ) THEN + CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) + CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, + $ INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) + END IF + * + 10 CONTINUE + WORK( 1 ) = MAXWRK + IWORK( 1 ) = LIWORK + RWORK( 1 ) = LRWORK + RETURN + * + * End of ZGELSD + * + END diff -cNr octave-2.9.15/libcruft/lapack/zgelss.f octave-2.9.16/libcruft/lapack/zgelss.f *** octave-2.9.15/libcruft/lapack/zgelss.f Thu Dec 14 16:57:14 2000 --- octave-2.9.16/libcruft/lapack/zgelss.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK --- 1,9 ---- SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK *************** *** 61,67 **** * On exit, B is overwritten by the N-by-NRHS solution matrix X. * If m >= n and RANK = n, the residual sum-of-squares for * the solution in the i-th column is given by the sum of ! * squares of elements n+1:m in that column. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M,N). --- 60,66 ---- * On exit, B is overwritten by the N-by-NRHS solution matrix X. * If m >= n and RANK = n, the residual sum-of-squares for * the solution in the i-th column is given by the sum of ! * squares of the modulus of elements n+1:m in that column. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M,N). *************** *** 79,85 **** * The effective rank of A, i.e., the number of singular values * which are greater than RCOND*S(1). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 78,84 ---- * The effective rank of A, i.e., the number of singular values * which are greater than RCOND*S(1). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 141,147 **** INFO = 0 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) - MNTHR = ILAENV( 6, 'ZGELSS', ' ', M, N, NRHS, -1 ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 --- 140,145 ---- *************** *** 163,244 **** * to real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * ! MINWRK = 1 ! IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN ! MAXWRK = 0 ! MM = M ! IF( M.GE.N .AND. M.GE.MNTHR ) THEN ! * ! * Path 1a - overdetermined, with many more rows than columns ! * ! * Space needed for ZBDSQR is BDSPAC = 5*N ! * ! MM = N ! MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'ZGEQRF', ' ', M, N, ! $ -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, N+NRHS* ! $ ILAENV( 1, 'ZUNMQR', 'LC', M, NRHS, N, -1 ) ) ! END IF ! IF( M.GE.N ) THEN ! * ! * Path 1 - overdetermined or exactly determined * ! * Space needed for ZBDSQR is BDSPC = 7*N+12 * ! MAXWRK = MAX( MAXWRK, 2*N+( MM+N )* ! $ ILAENV( 1, 'ZGEBRD', ' ', MM, N, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, 2*N+NRHS* ! $ ILAENV( 1, 'ZUNMBR', 'QLC', MM, NRHS, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* ! $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) ! MINWRK = 2*N + MAX( NRHS, M ) ! END IF ! IF( N.GT.M ) THEN ! MINWRK = 2*M + MAX( NRHS, N ) ! IF( N.GE.MNTHR ) THEN ! * ! * Path 2a - underdetermined, with many more columns ! * than rows ! * ! * Space needed for ZBDSQR is BDSPAC = 5*M ! * ! MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) ! MAXWRK = MAX( MAXWRK, 3*M+M*M+2*M* ! $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*M+M*M+NRHS* ! $ ILAENV( 1, 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*M+M*M+( M-1 )* ! $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) ! IF( NRHS.GT.1 ) THEN ! MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) ELSE - MAXWRK = MAX( MAXWRK, M*M+2*M ) - END IF - MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M, -1 ) ) - ELSE * ! * Path 2 - underdetermined * ! * Space needed for ZBDSQR is BDSPAC = 5*M ! * ! MAXWRK = 2*M + ( N+M )*ILAENV( 1, 'ZGEBRD', ' ', M, N, ! $ -1, -1 ) ! MAXWRK = MAX( MAXWRK, 2*M+NRHS* ! $ ILAENV( 1, 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, 2*M+M* ! $ ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) END IF END IF - MINWRK = MAX( MINWRK, 1 ) - MAXWRK = MAX( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK END IF * - IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) - $ INFO = -12 IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELSS', -INFO ) RETURN --- 161,239 ---- * to real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * ! IF( INFO.EQ.0 ) THEN ! MINWRK = 1 ! MAXWRK = 1 ! IF( MINMN.GT.0 ) THEN ! MM = M ! MNTHR = ILAENV( 6, 'ZGELSS', ' ', M, N, NRHS, -1 ) ! IF( M.GE.N .AND. M.GE.MNTHR ) THEN ! * ! * Path 1a - overdetermined, with many more rows than ! * columns ! * ! MM = N ! MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'ZGEQRF', ' ', M, ! $ N, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'ZUNMQR', 'LC', ! $ M, NRHS, N, -1 ) ) ! END IF ! IF( M.GE.N ) THEN * ! * Path 1 - overdetermined or exactly determined * ! MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1, ! $ 'ZGEBRD', ' ', MM, N, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'ZUNMBR', ! $ 'QLC', MM, NRHS, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, ! $ 'ZUNGBR', 'P', N, N, N, -1 ) ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) ! MINWRK = 2*N + MAX( NRHS, M ) ! END IF ! IF( N.GT.M ) THEN ! MINWRK = 2*M + MAX( NRHS, N ) ! IF( N.GE.MNTHR ) THEN ! * ! * Path 2a - underdetermined, with many more columns ! * than rows ! * ! MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, ! $ -1 ) ! MAXWRK = MAX( MAXWRK, 3*M + M*M + 2*M*ILAENV( 1, ! $ 'ZGEBRD', ' ', M, M, -1, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*M + M*M + NRHS*ILAENV( 1, ! $ 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, 3*M + M*M + ( M - 1 )*ILAENV( 1, ! $ 'ZUNGBR', 'P', M, M, M, -1 ) ) ! IF( NRHS.GT.1 ) THEN ! MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) ! ELSE ! MAXWRK = MAX( MAXWRK, M*M + 2*M ) ! END IF ! MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'ZUNMLQ', ! $ 'LC', N, NRHS, M, -1 ) ) ELSE * ! * Path 2 - underdetermined * ! MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'ZGEBRD', ' ', M, ! $ N, -1, -1 ) ! MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'ZUNMBR', ! $ 'QLC', M, NRHS, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'ZUNGBR', ! $ 'P', M, N, M, -1 ) ) ! MAXWRK = MAX( MAXWRK, N*NRHS ) ! END IF END IF + MAXWRK = MAX( MINWRK, MAXWRK ) END IF WORK( 1 ) = MAXWRK + * + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) + $ INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELSS', -INFO ) RETURN diff -cNr octave-2.9.15/libcruft/lapack/zgeqpf.f octave-2.9.16/libcruft/lapack/zgeqpf.f *** octave-2.9.15/libcruft/lapack/zgeqpf.f Wed Nov 3 14:54:37 1999 --- octave-2.9.16/libcruft/lapack/zgeqpf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * ! * -- LAPACK deprecated driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N *************** *** 78,83 **** --- 77,88 ---- * jpvt(j) = i * then the jth column of P is the ith canonical unit vector. * + * Partial column norm updating strategy modified by + * Z. Drmac and Z. Bujanovic, Dept. of Mathematics, + * University of Zagreb, Croatia. + * June 2006. + * For more details see LAPACK Working Note 176. + * * ===================================================================== * * .. Parameters .. *************** *** 86,92 **** * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT ! DOUBLE PRECISION TEMP, TEMP2 COMPLEX*16 AII * .. * .. External Subroutines .. --- 91,97 ---- * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MA, MN, PVT ! DOUBLE PRECISION TEMP, TEMP2, TOL3Z COMPLEX*16 AII * .. * .. External Subroutines .. *************** *** 97,104 **** * .. * .. External Functions .. INTEGER IDAMAX ! DOUBLE PRECISION DZNRM2 ! EXTERNAL IDAMAX, DZNRM2 * .. * .. Executable Statements .. * --- 102,109 ---- * .. * .. External Functions .. INTEGER IDAMAX ! DOUBLE PRECISION DLAMCH, DZNRM2 ! EXTERNAL IDAMAX, DLAMCH, DZNRM2 * .. * .. Executable Statements .. * *************** *** 118,123 **** --- 123,129 ---- END IF * MN = MIN( M, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) * * Move initial columns up front * *************** *** 198,208 **** * DO 30 J = I + 1, N IF( RWORK( J ).NE.ZERO ) THEN ! TEMP = ONE - ( ABS( A( I, J ) ) / RWORK( J ) )**2 ! TEMP = MAX( TEMP, ZERO ) ! TEMP2 = ONE + 0.05D0*TEMP* ! $ ( RWORK( J ) / RWORK( N+J ) )**2 ! IF( TEMP2.EQ.ONE ) THEN IF( M-I.GT.0 ) THEN RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) --- 204,217 ---- * DO 30 J = I + 1, N IF( RWORK( J ).NE.ZERO ) THEN ! * ! * NOTE: The following 4 lines follow from the analysis in ! * Lapack Working Note 176. ! * ! TEMP = ABS( A( I, J ) ) / RWORK( J ) ! TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) ! TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 ! IF( TEMP2 .LE. TOL3Z ) THEN IF( M-I.GT.0 ) THEN RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) RWORK( N+J ) = RWORK( J ) diff -cNr octave-2.9.15/libcruft/lapack/zgeqr2.f octave-2.9.16/libcruft/lapack/zgeqr2.f *** octave-2.9.15/libcruft/lapack/zgeqr2.f Wed Nov 3 14:54:38 1999 --- octave-2.9.16/libcruft/lapack/zgeqr2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/zgeqrf.f octave-2.9.16/libcruft/lapack/zgeqrf.f *** octave-2.9.15/libcruft/lapack/zgeqrf.f Wed Nov 3 14:54:38 1999 --- octave-2.9.16/libcruft/lapack/zgeqrf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N *************** *** 43,49 **** * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 42,48 ---- * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zgesv.f octave-2.9.16/libcruft/lapack/zgesv.f *** octave-2.9.15/libcruft/lapack/zgesv.f Wed Nov 3 14:54:38 1999 --- octave-2.9.16/libcruft/lapack/zgesv.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS --- 1,8 ---- SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/zgesvd.f octave-2.9.16/libcruft/lapack/zgesvd.f *** octave-2.9.15/libcruft/lapack/zgesvd.f Thu Feb 10 04:26:50 2000 --- octave-2.9.16/libcruft/lapack/zgesvd.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT --- 1,9 ---- SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT *************** *** 106,117 **** * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER ! * The dimension of the array WORK. LWORK >= 1. ! * LWORK >= 2*MIN(M,N)+MAX(M,N). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine --- 105,116 ---- * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER ! * The dimension of the array WORK. ! * LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine *************** *** 176,182 **** * INFO = 0 MINMN = MIN( M, N ) - MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) WNTUA = LSAME( JOBU, 'A' ) WNTUS = LSAME( JOBU, 'S' ) WNTUAS = WNTUA .OR. WNTUS --- 175,180 ---- *************** *** 187,193 **** WNTVAS = WNTVA .OR. WNTVS WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) - MINWRK = 1 LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN --- 185,190 ---- *************** *** 216,227 **** * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * ! IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. ! $ N.GT.0 ) THEN ! IF( M.GE.N ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*N * IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN * --- 213,226 ---- * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * ! IF( INFO.EQ.0 ) THEN ! MINWRK = 1 ! MAXWRK = 1 ! IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*N * + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN * *************** *** 235,241 **** $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MINWRK = 3*N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') --- 234,239 ---- *************** *** 249,255 **** $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or --- 247,252 ---- *************** *** 266,272 **** $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') --- 263,268 ---- *************** *** 280,286 **** $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') --- 276,281 ---- *************** *** 296,302 **** $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = 2*N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or --- 291,296 ---- *************** *** 313,319 **** $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') --- 307,312 ---- *************** *** 327,333 **** $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') --- 320,325 ---- *************** *** 343,349 **** $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = 2*N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or --- 335,340 ---- *************** *** 360,366 **** $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) END IF ELSE * --- 351,356 ---- *************** *** 378,389 **** $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MINWRK = 2*N + M - MAXWRK = MAX( MINWRK, MAXWRK ) END IF ! ELSE * * Space needed for ZBDSQR is BDSPAC = 5*M * IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * --- 368,379 ---- $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MINWRK = 2*N + M END IF ! ELSE IF( MINMN.GT.0 ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*M * + MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * *************** *** 397,403 **** $ MAXWRK = MAX( MAXWRK, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MINWRK = 3*M - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') --- 387,392 ---- *************** *** 411,417 **** $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', --- 400,405 ---- *************** *** 428,434 **** $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') --- 416,421 ---- *************** *** 442,448 **** $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') --- 429,434 ---- *************** *** 458,464 **** $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = 2*M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', --- 444,449 ---- *************** *** 475,481 **** $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') --- 460,465 ---- *************** *** 489,495 **** $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') --- 473,478 ---- *************** *** 505,511 **** $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = 2*M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', --- 488,493 ---- *************** *** 522,528 **** $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) END IF ELSE * --- 504,509 ---- *************** *** 540,554 **** $ MAXWRK = MAX( MAXWRK, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MINWRK = 2*M + N - MAXWRK = MAX( MINWRK, MAXWRK ) END IF END IF WORK( 1 ) = MAXWRK - END IF * ! IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN ! INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVD', -INFO ) RETURN --- 521,536 ---- $ MAXWRK = MAX( MAXWRK, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MINWRK = 2*M + N END IF END IF + MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK * ! IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN ! INFO = -13 ! END IF END IF + * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVD', -INFO ) RETURN *************** *** 559,566 **** * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN - IF( LWORK.GE.1 ) - $ WORK( 1 ) = ONE RETURN END IF * --- 541,546 ---- *************** *** 823,830 **** * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), ! $ LDVT ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) --- 803,811 ---- * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, ! $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) *************** *** 904,911 **** * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), ! $ LDVT ) * * Generate Q in A * (CWorkspace: need 2*N, prefer N+N*NB) --- 885,893 ---- * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, ! $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (CWorkspace: need 2*N, prefer N+N*NB) *************** *** 1407,1414 **** * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, ! $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N --- 1389,1397 ---- * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, ! $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N *************** *** 1921,1928 **** * Copy R from A to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, ! $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N --- 1904,1912 ---- * Copy R from A to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) ! IF( N.GT.1 ) ! $ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, ! $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N diff -cNr octave-2.9.15/libcruft/lapack/zgetf2.f octave-2.9.16/libcruft/lapack/zgetf2.f *** octave-2.9.15/libcruft/lapack/zgetf2.f Wed Nov 3 14:54:39 1999 --- octave-2.9.16/libcruft/lapack/zgetf2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N *************** *** 64,74 **** $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. ! INTEGER J, JP * .. * .. External Functions .. INTEGER IZAMAX ! EXTERNAL IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP --- 63,75 ---- $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. ! DOUBLE PRECISION SFMIN ! INTEGER I, J, JP * .. * .. External Functions .. + DOUBLE PRECISION DLAMCH INTEGER IZAMAX ! EXTERNAL DLAMCH, IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP *************** *** 98,103 **** --- 99,108 ---- IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * + * Compute machine safe minimum + * + SFMIN = DLAMCH('S') + * DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. *************** *** 113,120 **** * * Compute elements J+1:M of J-th column. * ! IF( J.LT.M ) ! $ CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) * ELSE IF( INFO.EQ.0 ) THEN * --- 118,132 ---- * * Compute elements J+1:M of J-th column. * ! IF( J.LT.M ) THEN ! IF( ABS(A( J, J )) .GE. SFMIN ) THEN ! CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) ! ELSE ! DO 20 I = 1, M-J ! A( J+I, J ) = A( J+I, J ) / A( J, J ) ! 20 CONTINUE ! END IF ! END IF * ELSE IF( INFO.EQ.0 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/zgetrf.f octave-2.9.16/libcruft/lapack/zgetrf.f *** octave-2.9.15/libcruft/lapack/zgetrf.f Wed Nov 3 14:54:39 1999 --- octave-2.9.16/libcruft/lapack/zgetrf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N --- 1,8 ---- SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/zgetri.f octave-2.9.16/libcruft/lapack/zgetri.f *** octave-2.9.15/libcruft/lapack/zgetri.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/zgetri.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N --- 1,8 ---- SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N *************** *** 40,46 **** * The pivot indices from ZGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO=0, then WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 39,45 ---- * The pivot indices from ZGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO=0, then WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zgetrs.f octave-2.9.16/libcruft/lapack/zgetrs.f *** octave-2.9.15/libcruft/lapack/zgetrs.f Wed Nov 3 14:54:39 1999 --- octave-2.9.16/libcruft/lapack/zgetrs.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER TRANS --- 1,8 ---- SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS diff -cNr octave-2.9.15/libcruft/lapack/zggbal.f octave-2.9.16/libcruft/lapack/zggbal.f *** octave-2.9.15/libcruft/lapack/zggbal.f Wed Nov 3 14:54:39 1999 --- octave-2.9.16/libcruft/lapack/zggbal.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB --- 1,9 ---- SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOB *************** *** 88,94 **** * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * ! * WORK (workspace) DOUBLE PRECISION array, dimension (6*N) * * INFO (output) INTEGER * = 0: successful exit --- 87,95 ---- * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * ! * WORK (workspace) REAL array, dimension (lwork) ! * lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and ! * at least 1 when JOB = 'N' or 'P'. * * INFO (output) INTEGER * = 0: successful exit *************** *** 150,188 **** ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN ! INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAL', -INFO ) RETURN END IF * - K = 1 - L = N - * * Quick return if possible * ! IF( N.EQ.0 ) ! $ RETURN ! * ! IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N - DO 10 I = 1, N - LSCALE( I ) = ONE - RSCALE( I ) = ONE - 10 CONTINUE RETURN END IF * ! IF( K.EQ.L ) THEN ILO = 1 ! IHI = 1 LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * --- 151,191 ---- ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN ! INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAL', -INFO ) RETURN END IF * * Quick return if possible * ! IF( N.EQ.0 ) THEN ILO = 1 IHI = N RETURN END IF * ! IF( N.EQ.1 ) THEN ILO = 1 ! IHI = N LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * + IF( LSAME( JOB, 'N' ) ) THEN + ILO = 1 + IHI = N + DO 10 I = 1, N + LSCALE( I ) = ONE + RSCALE( I ) = ONE + 10 CONTINUE + RETURN + END IF + * + K = 1 + L = N IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * *************** *** 278,287 **** ILO = K IHI = L * ! IF( ILO.EQ.IHI ) ! $ RETURN * ! IF( LSAME( JOB, 'P' ) ) $ RETURN * * Balance the submatrix in rows ILO to IHI. --- 281,295 ---- ILO = K IHI = L * ! IF( LSAME( JOB, 'P' ) ) THEN ! DO 195 I = ILO, IHI ! LSCALE( I ) = ONE ! RSCALE( I ) = ONE ! 195 CONTINUE ! RETURN ! END IF * ! IF( ILO.EQ.IHI ) $ RETURN * * Balance the submatrix in rows ILO to IHI. *************** *** 437,443 **** DO 360 I = ILO, IHI IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) ! IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDA ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) --- 445,451 ---- DO 360 I = ILO, IHI IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) ! IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) diff -cNr octave-2.9.15/libcruft/lapack/zgtsv.f octave-2.9.16/libcruft/lapack/zgtsv.f *** octave-2.9.15/libcruft/lapack/zgtsv.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zgtsv.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS --- 1,8 ---- SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/zgttrf.f octave-2.9.16/libcruft/lapack/zgttrf.f *** octave-2.9.15/libcruft/lapack/zgttrf.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zgttrf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * ! * -- LAPACK routine (version 2.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, N --- 1,8 ---- SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N *************** *** 29,56 **** * ========= * * N (input) INTEGER ! * The order of the matrix A. N >= 0. * * DL (input/output) COMPLEX*16 array, dimension (N-1) ! * On entry, DL must contain the (n-1) subdiagonal elements of * A. * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) COMPLEX*16 array, dimension (N) * On entry, D must contain the diagonal elements of A. * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) COMPLEX*16 array, dimension (N-1) ! * On entry, DU must contain the (n-1) superdiagonal elements * of A. * On exit, DU is overwritten by the (n-1) elements of the first ! * superdiagonal of U. * * DU2 (output) COMPLEX*16 array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the ! * second superdiagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was --- 28,58 ---- * ========= * * N (input) INTEGER ! * The order of the matrix A. * * DL (input/output) COMPLEX*16 array, dimension (N-1) ! * On entry, DL must contain the (n-1) sub-diagonal elements of * A. + * * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) COMPLEX*16 array, dimension (N) * On entry, D must contain the diagonal elements of A. + * * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) COMPLEX*16 array, dimension (N-1) ! * On entry, DU must contain the (n-1) super-diagonal elements * of A. + * * On exit, DU is overwritten by the (n-1) elements of the first ! * super-diagonal of U. * * DU2 (output) COMPLEX*16 array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the ! * second super-diagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was *************** *** 60,86 **** * * INFO (output) INTEGER * = 0: successful exit ! * < 0: if INFO = -i, the i-th argument had an illegal value ! * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Local Scalars .. INTEGER I COMPLEX*16 FACT, TEMP, ZDUM * .. - * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG - * .. * .. External Subroutines .. EXTERNAL XERBLA * .. ! * .. Parameters .. ! COMPLEX*16 CZERO ! PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 --- 62,88 ---- * * INFO (output) INTEGER * = 0: successful exit ! * < 0: if INFO = -k, the k-th argument had an illegal value ! * > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * + * .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + * .. * .. Local Scalars .. INTEGER I COMPLEX*16 FACT, TEMP, ZDUM * .. * .. External Subroutines .. EXTERNAL XERBLA * .. ! * .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE, DIMAG * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 *************** *** 102,131 **** IF( N.EQ.0 ) $ RETURN * ! * Initialize IPIV(i) = i * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE * ! DO 20 I = 1, N - 1 ! IF( DL( I ).EQ.CZERO ) THEN ! * ! * Subdiagonal is zero, no elimination is required. ! * ! IF( D( I ).EQ.CZERO .AND. INFO.EQ.0 ) ! $ INFO = I ! IF( I.LT.N-1 ) ! $ DU2( I ) = CZERO ! ELSE IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * ! FACT = DL( I ) / D( I ) ! DL( I ) = FACT ! D( I+1 ) = D( I+1 ) - FACT*DU( I ) ! IF( I.LT.N-1 ) ! $ DU2( I ) = CZERO ELSE * * Interchange rows I and I+1, eliminate DL(I) --- 104,128 ---- IF( N.EQ.0 ) $ RETURN * ! * Initialize IPIV(i) = i and DU2(i) = 0 * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE + DO 20 I = 1, N - 2 + DU2( I ) = ZERO + 20 CONTINUE * ! DO 30 I = 1, N - 2 ! IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * ! IF( CABS1( D( I ) ).NE.ZERO ) THEN ! FACT = DL( I ) / D( I ) ! DL( I ) = FACT ! D( I+1 ) = D( I+1 ) - FACT*DU( I ) ! END IF ELSE * * Interchange rows I and I+1, eliminate DL(I) *************** *** 136,153 **** TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) ! IF( I.LT.N-1 ) THEN ! DU2( I ) = DU( I+1 ) ! DU( I+1 ) = -FACT*DU( I+1 ) END IF ! IPIV( I ) = IPIV( I ) + 1 END IF - 20 CONTINUE - IF( D( N ).EQ.CZERO .AND. INFO.EQ.0 ) THEN - INFO = N - RETURN END IF * RETURN * * End of ZGTTRF --- 133,172 ---- TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) ! DU2( I ) = DU( I+1 ) ! DU( I+1 ) = -FACT*DU( I+1 ) ! IPIV( I ) = I + 1 ! END IF ! 30 CONTINUE ! IF( N.GT.1 ) THEN ! I = N - 1 ! IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN ! IF( CABS1( D( I ) ).NE.ZERO ) THEN ! FACT = DL( I ) / D( I ) ! DL( I ) = FACT ! D( I+1 ) = D( I+1 ) - FACT*DU( I ) END IF ! ELSE ! FACT = D( I ) / DL( I ) ! D( I ) = DL( I ) ! DL( I ) = FACT ! TEMP = DU( I ) ! DU( I ) = D( I+1 ) ! D( I+1 ) = TEMP - FACT*D( I+1 ) ! IPIV( I ) = I + 1 END IF END IF * + * Check for a zero on the diagonal of U. + * + DO 40 I = 1, N + IF( CABS1( D( I ) ).EQ.ZERO ) THEN + INFO = I + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE + * RETURN * * End of ZGTTRF diff -cNr octave-2.9.15/libcruft/lapack/zgttrs.f octave-2.9.16/libcruft/lapack/zgttrs.f *** octave-2.9.15/libcruft/lapack/zgttrs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zgttrs.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 2.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER TRANS --- 1,9 ---- SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANS *************** *** 26,39 **** * Arguments * ========= * ! * TRANS (input) CHARACTER ! * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose) * * N (input) INTEGER ! * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns --- 25,38 ---- * Arguments * ========= * ! * TRANS (input) CHARACTER*1 ! * Specifies the form of the system of equations. * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose) * * N (input) INTEGER ! * The order of the matrix A. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns *************** *** 48,57 **** * the LU factorization of A. * * DU (input) COMPLEX*16 array, dimension (N-1) ! * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) COMPLEX*16 array, dimension (N-2) ! * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was --- 47,56 ---- * the LU factorization of A. * * DU (input) COMPLEX*16 array, dimension (N-1) ! * The (n-1) elements of the first super-diagonal of U. * * DU2 (input) COMPLEX*16 array, dimension (N-2) ! * The (n-2) elements of the second super-diagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was *************** *** 60,98 **** * required. * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) ! * On entry, the right hand side matrix B. ! * On exit, B is overwritten by the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit ! * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN ! INTEGER I, J ! COMPLEX*16 TEMP * .. * .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME * .. * .. External Subroutines .. ! EXTERNAL XERBLA * .. * .. Intrinsic Functions .. ! INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * INFO = 0 ! NOTRAN = LSAME( TRANS, 'N' ) ! IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. ! $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 --- 59,96 ---- * required. * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) ! * On entry, the matrix of right hand side vectors B. ! * On exit, B is overwritten by the solution vectors X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit ! * < 0: if INFO = -k, the k-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN ! INTEGER ITRANS, J, JB, NB * .. * .. External Functions .. ! INTEGER ILAENV ! EXTERNAL ILAENV * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZGTTS2 * .. * .. Intrinsic Functions .. ! INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 ! NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' ) ! IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. ! $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 *************** *** 111,204 **** IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * ! IF( NOTRAN ) THEN ! * ! * Solve A*X = B using the LU factorization of A, ! * overwriting each right hand side vector with its solution. ! * ! DO 30 J = 1, NRHS * ! * Solve L*x = b. ! * ! DO 10 I = 1, N - 1 ! IF( IPIV( I ).EQ.I ) THEN ! B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) ! ELSE ! TEMP = B( I, J ) ! B( I, J ) = B( I+1, J ) ! B( I+1, J ) = TEMP - DL( I )*B( I, J ) ! END IF ! 10 CONTINUE ! * ! * Solve U*x = b. ! * ! B( N, J ) = B( N, J ) / D( N ) ! IF( N.GT.1 ) ! $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / ! $ D( N-1 ) ! DO 20 I = N - 2, 1, -1 ! B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* ! $ B( I+2, J ) ) / D( I ) ! 20 CONTINUE ! 30 CONTINUE ! ELSE IF( LSAME( TRANS, 'T' ) ) THEN ! * ! * Solve A**T * X = B. ! * ! DO 60 J = 1, NRHS ! * ! * Solve U**T * x = b. ! * ! B( 1, J ) = B( 1, J ) / D( 1 ) ! IF( N.GT.1 ) ! $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) ! DO 40 I = 3, N ! B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* ! $ B( I-2, J ) ) / D( I ) ! 40 CONTINUE ! * ! * Solve L**T * x = b. ! * ! DO 50 I = N - 1, 1, -1 ! IF( IPIV( I ).EQ.I ) THEN ! B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) ! ELSE ! TEMP = B( I+1, J ) ! B( I+1, J ) = B( I, J ) - DL( I )*TEMP ! B( I, J ) = TEMP ! END IF ! 50 CONTINUE ! 60 CONTINUE ELSE * ! * Solve A**H * X = B. ! * ! DO 90 J = 1, NRHS * ! * Solve U**H * x = b. * ! B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) ) ! IF( N.GT.1 ) ! $ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) / ! $ DCONJG( D( 2 ) ) ! DO 70 I = 3, N ! B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*B( I-1, J )- ! $ DCONJG( DU2( I-2 ) )*B( I-2, J ) ) / ! $ DCONJG( D( I ) ) ! 70 CONTINUE ! * ! * Solve L**H * x = b. ! * ! DO 80 I = N - 1, 1, -1 ! IF( IPIV( I ).EQ.I ) THEN ! B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*B( I+1, J ) ! ELSE ! TEMP = B( I+1, J ) ! B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP ! B( I, J ) = TEMP ! END IF ! 80 CONTINUE ! 90 CONTINUE END IF * * End of ZGTTRS --- 109,140 ---- IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * ! * Decode TRANS * ! IF( NOTRAN ) THEN ! ITRANS = 0 ! ELSE IF( TRANS.EQ.'T' .OR. TRANS.EQ.'t' ) THEN ! ITRANS = 1 ELSE + ITRANS = 2 + END IF * ! * Determine the number of right-hand sides to solve at a time. * ! IF( NRHS.EQ.1 ) THEN ! NB = 1 ! ELSE ! NB = MAX( 1, ILAENV( 1, 'ZGTTRS', TRANS, N, NRHS, -1, -1 ) ) ! END IF * ! IF( NB.GE.NRHS ) THEN ! CALL ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) ! ELSE ! DO 10 J = 1, NRHS, NB ! JB = MIN( NRHS-J+1, NB ) ! CALL ZGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), ! $ LDB ) ! 10 CONTINUE END IF * * End of ZGTTRS diff -cNr octave-2.9.15/libcruft/lapack/zgtts2.f octave-2.9.16/libcruft/lapack/zgtts2.f *** octave-2.9.15/libcruft/lapack/zgtts2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zgtts2.f Tue Oct 23 19:17:36 2007 *************** *** 0 **** --- 1,271 ---- + SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER ITRANS, LDB, N, NRHS + * .. + * .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) + * .. + * + * Purpose + * ======= + * + * ZGTTS2 solves one of the systems of equations + * A * X = B, A**T * X = B, or A**H * X = B, + * with a tridiagonal matrix A using the LU factorization computed + * by ZGTTRF. + * + * Arguments + * ========= + * + * ITRANS (input) INTEGER + * Specifies the form of the system of equations. + * = 0: A * X = B (No transpose) + * = 1: A**T * X = B (Transpose) + * = 2: A**H * X = B (Conjugate transpose) + * + * N (input) INTEGER + * The order of the matrix A. + * + * NRHS (input) INTEGER + * The number of right hand sides, i.e., the number of columns + * of the matrix B. NRHS >= 0. + * + * DL (input) COMPLEX*16 array, dimension (N-1) + * The (n-1) multipliers that define the matrix L from the + * LU factorization of A. + * + * D (input) COMPLEX*16 array, dimension (N) + * The n diagonal elements of the upper triangular matrix U from + * the LU factorization of A. + * + * DU (input) COMPLEX*16 array, dimension (N-1) + * The (n-1) elements of the first super-diagonal of U. + * + * DU2 (input) COMPLEX*16 array, dimension (N-2) + * The (n-2) elements of the second super-diagonal of U. + * + * IPIV (input) INTEGER array, dimension (N) + * The pivot indices; for 1 <= i <= n, row i of the matrix was + * interchanged with row IPIV(i). IPIV(i) will always be either + * i or i+1; IPIV(i) = i indicates a row interchange was not + * required. + * + * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) + * On entry, the matrix of right hand side vectors B. + * On exit, B is overwritten by the solution vectors X. + * + * LDB (input) INTEGER + * The leading dimension of the array B. LDB >= max(1,N). + * + * ===================================================================== + * + * .. Local Scalars .. + INTEGER I, J + COMPLEX*16 TEMP + * .. + * .. Intrinsic Functions .. + INTRINSIC DCONJG + * .. + * .. Executable Statements .. + * + * Quick return if possible + * + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN + * + IF( ITRANS.EQ.0 ) THEN + * + * Solve A*X = B using the LU factorization of A, + * overwriting each right hand side vector with its solution. + * + IF( NRHS.LE.1 ) THEN + J = 1 + 10 CONTINUE + * + * Solve L*x = b. + * + DO 20 I = 1, N - 1 + IF( IPIV( I ).EQ.I ) THEN + B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) + ELSE + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - DL( I )*B( I, J ) + END IF + 20 CONTINUE + * + * Solve U*x = b. + * + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 30 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* + $ B( I+2, J ) ) / D( I ) + 30 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 10 + END IF + ELSE + DO 60 J = 1, NRHS + * + * Solve L*x = b. + * + DO 40 I = 1, N - 1 + IF( IPIV( I ).EQ.I ) THEN + B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) + ELSE + TEMP = B( I, J ) + B( I, J ) = B( I+1, J ) + B( I+1, J ) = TEMP - DL( I )*B( I, J ) + END IF + 40 CONTINUE + * + * Solve U*x = b. + * + B( N, J ) = B( N, J ) / D( N ) + IF( N.GT.1 ) + $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / + $ D( N-1 ) + DO 50 I = N - 2, 1, -1 + B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* + $ B( I+2, J ) ) / D( I ) + 50 CONTINUE + 60 CONTINUE + END IF + ELSE IF( ITRANS.EQ.1 ) THEN + * + * Solve A**T * X = B. + * + IF( NRHS.LE.1 ) THEN + J = 1 + 70 CONTINUE + * + * Solve U**T * x = b. + * + B( 1, J ) = B( 1, J ) / D( 1 ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) + DO 80 I = 3, N + B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* + $ B( I-2, J ) ) / D( I ) + 80 CONTINUE + * + * Solve L**T * x = b. + * + DO 90 I = N - 1, 1, -1 + IF( IPIV( I ).EQ.I ) THEN + B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) + ELSE + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - DL( I )*TEMP + B( I, J ) = TEMP + END IF + 90 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 70 + END IF + ELSE + DO 120 J = 1, NRHS + * + * Solve U**T * x = b. + * + B( 1, J ) = B( 1, J ) / D( 1 ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) + DO 100 I = 3, N + B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- + $ DU2( I-2 )*B( I-2, J ) ) / D( I ) + 100 CONTINUE + * + * Solve L**T * x = b. + * + DO 110 I = N - 1, 1, -1 + IF( IPIV( I ).EQ.I ) THEN + B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) + ELSE + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - DL( I )*TEMP + B( I, J ) = TEMP + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + * + * Solve A**H * X = B. + * + IF( NRHS.LE.1 ) THEN + J = 1 + 130 CONTINUE + * + * Solve U**H * x = b. + * + B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) / + $ DCONJG( D( 2 ) ) + DO 140 I = 3, N + B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*B( I-1, J )- + $ DCONJG( DU2( I-2 ) )*B( I-2, J ) ) / + $ DCONJG( D( I ) ) + 140 CONTINUE + * + * Solve L**H * x = b. + * + DO 150 I = N - 1, 1, -1 + IF( IPIV( I ).EQ.I ) THEN + B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*B( I+1, J ) + ELSE + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP + B( I, J ) = TEMP + END IF + 150 CONTINUE + IF( J.LT.NRHS ) THEN + J = J + 1 + GO TO 130 + END IF + ELSE + DO 180 J = 1, NRHS + * + * Solve U**H * x = b. + * + B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) ) + IF( N.GT.1 ) + $ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) + $ / DCONJG( D( 2 ) ) + DO 160 I = 3, N + B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )* + $ B( I-1, J )-DCONJG( DU2( I-2 ) )* + $ B( I-2, J ) ) / DCONJG( D( I ) ) + 160 CONTINUE + * + * Solve L**H * x = b. + * + DO 170 I = N - 1, 1, -1 + IF( IPIV( I ).EQ.I ) THEN + B( I, J ) = B( I, J ) - DCONJG( DL( I ) )* + $ B( I+1, J ) + ELSE + TEMP = B( I+1, J ) + B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP + B( I, J ) = TEMP + END IF + 170 CONTINUE + 180 CONTINUE + END IF + END IF + * + * End of ZGTTS2 + * + END diff -cNr octave-2.9.15/libcruft/lapack/zheev.f octave-2.9.16/libcruft/lapack/zheev.f *** octave-2.9.15/libcruft/lapack/zheev.f Wed Nov 3 14:54:39 1999 --- octave-2.9.16/libcruft/lapack/zheev.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * ! * -- LAPACK driver routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO --- 1,9 ---- SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO *************** *** 53,59 **** * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 52,58 ---- * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 86,92 **** * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, ! $ LLWORK, LOPT, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. --- 85,91 ---- * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, ! $ LLWORK, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. *************** *** 120,133 **** INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+1 )*N ) WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN --- 119,133 ---- INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+1 )*N ) WORK( 1 ) = LWKOPT + * + IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 END IF * IF( INFO.NE.0 ) THEN *************** *** 140,152 **** * Quick return if possible * IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) ! WORK( 1 ) = 3 IF( WANTZ ) $ A( 1, 1 ) = CONE RETURN --- 140,151 ---- * Quick return if possible * IF( N.EQ.0 ) THEN RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) ! WORK( 1 ) = 1 IF( WANTZ ) $ A( 1, 1 ) = CONE RETURN *************** *** 183,189 **** LLWORK = LWORK - INDWRK + 1 CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) - LOPT = N + WORK( INDWRK ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * ZUNGTR to generate the unitary matrix, then call ZSTEQR. --- 182,187 ---- diff -cNr octave-2.9.15/libcruft/lapack/zhetd2.f octave-2.9.16/libcruft/lapack/zhetd2.f *** octave-2.9.15/libcruft/lapack/zhetd2.f Thu Feb 10 04:26:51 2000 --- octave-2.9.16/libcruft/lapack/zhetd2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zhetrd.f octave-2.9.16/libcruft/lapack/zhetrd.f *** octave-2.9.15/libcruft/lapack/zhetrd.f Wed Nov 3 14:54:40 1999 --- octave-2.9.16/libcruft/lapack/zhetrd.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 65,71 **** * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 64,70 ---- * The scalar factors of the elementary reflectors (see Further * Details). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zhseqr.f octave-2.9.16/libcruft/lapack/zhseqr.f *** octave-2.9.15/libcruft/lapack/zhseqr.f Wed Nov 3 14:54:40 1999 --- octave-2.9.16/libcruft/lapack/zhseqr.f Tue Oct 16 14:54:22 2007 *************** *** 1,159 **** SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. - CHARACTER COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * ! * Purpose ! * ======= ! * ! * ZHSEQR computes the eigenvalues of a complex upper Hessenberg ! * matrix H, and, optionally, the matrices T and Z from the Schur ! * decomposition H = Z T Z**H, where T is an upper triangular matrix ! * (the Schur form), and Z is the unitary matrix of Schur vectors. ! * ! * Optionally Z may be postmultiplied into an input unitary matrix Q, ! * so that this routine can give the Schur factorization of a matrix A ! * which has been reduced to the Hessenberg form H by the unitary ! * matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. ! * ! * Arguments ! * ========= ! * ! * JOB (input) CHARACTER*1 ! * = 'E': compute eigenvalues only; ! * = 'S': compute eigenvalues and the Schur form T. ! * ! * COMPZ (input) CHARACTER*1 ! * = 'N': no Schur vectors are computed; ! * = 'I': Z is initialized to the unit matrix and the matrix Z ! * of Schur vectors of H is returned; ! * = 'V': Z must contain an unitary matrix Q on entry, and ! * the product Q*Z is returned. ! * ! * N (input) INTEGER ! * The order of the matrix H. N >= 0. ! * ! * ILO (input) INTEGER ! * IHI (input) INTEGER ! * It is assumed that H is already upper triangular in rows ! * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally ! * set by a previous call to ZGEBAL, and then passed to CGEHRD ! * when the matrix output by ZGEBAL is reduced to Hessenberg ! * form. Otherwise ILO and IHI should be set to 1 and N ! * respectively. ! * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! * ! * H (input/output) COMPLEX*16 array, dimension (LDH,N) ! * On entry, the upper Hessenberg matrix H. ! * On exit, if JOB = 'S', H contains the upper triangular matrix ! * T from the Schur decomposition (the Schur form). If ! * JOB = 'E', the contents of H are unspecified on exit. ! * ! * LDH (input) INTEGER ! * The leading dimension of the array H. LDH >= max(1,N). ! * ! * W (output) COMPLEX*16 array, dimension (N) ! * The computed eigenvalues. If JOB = 'S', the eigenvalues are ! * stored in the same order as on the diagonal of the Schur form ! * returned in H, with W(i) = H(i,i). ! * ! * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) ! * If COMPZ = 'N': Z is not referenced. ! * If COMPZ = 'I': on entry, Z need not be set, and on exit, Z ! * contains the unitary matrix Z of the Schur vectors of H. ! * If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, ! * which is assumed to be equal to the unit matrix except for ! * the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. ! * Normally Q is the unitary matrix generated by ZUNGHR after ! * the call to ZGEHRD which formed the Hessenberg matrix H. ! * ! * LDZ (input) INTEGER ! * The leading dimension of the array Z. ! * LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. ! * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) ! * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! * ! * LWORK (input) INTEGER ! * The dimension of the array WORK. LWORK >= max(1,N). ! * ! * If LWORK = -1, then a workspace query is assumed; the routine ! * only calculates the optimal size of the WORK array, returns ! * this value as the first entry of the WORK array, and no error ! * message related to LWORK is issued by XERBLA. ! * ! * INFO (output) INTEGER ! * = 0: successful exit ! * < 0: if INFO = -i, the i-th argument had an illegal value ! * > 0: if INFO = i, ZHSEQR failed to compute all the ! * eigenvalues in a total of 30*(IHI-ILO+1) iterations; ! * elements 1:ilo-1 and i+1:n of W contain those ! * eigenvalues which have been successfully computed. ! * ! * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE ! PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), ! $ ONE = ( 1.0D+0, 0.0D+0 ) ) ! DOUBLE PRECISION RZERO, RONE, CONST ! PARAMETER ( RZERO = 0.0D+0, RONE = 1.0D+0, ! $ CONST = 1.5D+0 ) ! INTEGER NSMAX, LDS ! PARAMETER ( NSMAX = 15, LDS = NSMAX ) * .. * .. Local Scalars .. LOGICAL INITZ, LQUERY, WANTT, WANTZ - INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L, - $ MAXB, NH, NR, NS, NV - DOUBLE PRECISION OVFL, RTEMP, SMLNUM, TST1, ULP, UNFL - COMPLEX*16 CDUM, TAU, TEMP - * .. - * .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) - COMPLEX*16 S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 ) * .. * .. External Functions .. LOGICAL LSAME ! INTEGER ILAENV, IZAMAX ! DOUBLE PRECISION DLAMCH, DLAPY2, ZLANHS ! EXTERNAL LSAME, ILAENV, IZAMAX, DLAMCH, DLAPY2, ZLANHS * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLACPY, ZLAHQR, ! $ ZLARFG, ZLARFX, ZLASET, ZSCAL * .. * .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN ! * .. ! * .. Statement Functions .. ! DOUBLE PRECISION CABS1 ! * .. ! * .. Statement Function definitions .. ! CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * ! * Decode and test the input parameters * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) * INFO = 0 - WORK( 1 ) = MAX( 1, N ) - LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN --- 1,267 ---- SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * ! * -- LAPACK driver routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. + * Purpose + * ======= * ! * ZHSEQR computes the eigenvalues of a Hessenberg matrix H ! * and, optionally, the matrices T and Z from the Schur decomposition ! * H = Z T Z**H, where T is an upper triangular matrix (the ! * Schur form), and Z is the unitary matrix of Schur vectors. ! * ! * Optionally Z may be postmultiplied into an input unitary ! * matrix Q so that this routine can give the Schur factorization ! * of a matrix A which has been reduced to the Hessenberg form H ! * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. ! * ! * Arguments ! * ========= ! * ! * JOB (input) CHARACTER*1 ! * = 'E': compute eigenvalues only; ! * = 'S': compute eigenvalues and the Schur form T. ! * ! * COMPZ (input) CHARACTER*1 ! * = 'N': no Schur vectors are computed; ! * = 'I': Z is initialized to the unit matrix and the matrix Z ! * of Schur vectors of H is returned; ! * = 'V': Z must contain an unitary matrix Q on entry, and ! * the product Q*Z is returned. ! * ! * N (input) INTEGER ! * The order of the matrix H. N .GE. 0. ! * ! * ILO (input) INTEGER ! * IHI (input) INTEGER ! * It is assumed that H is already upper triangular in rows ! * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally ! * set by a previous call to ZGEBAL, and then passed to ZGEHRD ! * when the matrix output by ZGEBAL is reduced to Hessenberg ! * form. Otherwise ILO and IHI should be set to 1 and N ! * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. ! * If N = 0, then ILO = 1 and IHI = 0. ! * ! * H (input/output) COMPLEX*16 array, dimension (LDH,N) ! * On entry, the upper Hessenberg matrix H. ! * On exit, if INFO = 0 and JOB = 'S', H contains the upper ! * triangular matrix T from the Schur decomposition (the ! * Schur form). If INFO = 0 and JOB = 'E', the contents of ! * H are unspecified on exit. (The output value of H when ! * INFO.GT.0 is given under the description of INFO below.) ! * ! * Unlike earlier versions of ZHSEQR, this subroutine may ! * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 ! * or j = IHI+1, IHI+2, ... N. ! * ! * LDH (input) INTEGER ! * The leading dimension of the array H. LDH .GE. max(1,N). ! * ! * W (output) COMPLEX*16 array, dimension (N) ! * The computed eigenvalues. If JOB = 'S', the eigenvalues are ! * stored in the same order as on the diagonal of the Schur ! * form returned in H, with W(i) = H(i,i). ! * ! * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) ! * If COMPZ = 'N', Z is not referenced. ! * If COMPZ = 'I', on entry Z need not be set and on exit, ! * if INFO = 0, Z contains the unitary matrix Z of the Schur ! * vectors of H. If COMPZ = 'V', on entry Z must contain an ! * N-by-N matrix Q, which is assumed to be equal to the unit ! * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, ! * if INFO = 0, Z contains Q*Z. ! * Normally Q is the unitary matrix generated by ZUNGHR ! * after the call to ZGEHRD which formed the Hessenberg matrix ! * H. (The output value of Z when INFO.GT.0 is given under ! * the description of INFO below.) ! * ! * LDZ (input) INTEGER ! * The leading dimension of the array Z. if COMPZ = 'I' or ! * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. ! * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) ! * On exit, if INFO = 0, WORK(1) returns an estimate of ! * the optimal value for LWORK. ! * ! * LWORK (input) INTEGER ! * The dimension of the array WORK. LWORK .GE. max(1,N) ! * is sufficient, but LWORK typically as large as 6*N may ! * be required for optimal performance. A workspace query ! * to determine the optimal workspace size is recommended. ! * ! * If LWORK = -1, then ZHSEQR does a workspace query. ! * In this case, ZHSEQR checks the input parameters and ! * estimates the optimal workspace size for the given ! * values of N, ILO and IHI. The estimate is returned ! * in WORK(1). No error message related to LWORK is ! * issued by XERBLA. Neither H nor Z are accessed. ! * ! * ! * INFO (output) INTEGER ! * = 0: successful exit ! * .LT. 0: if INFO = -i, the i-th argument had an illegal ! * value ! * .GT. 0: if INFO = i, ZHSEQR failed to compute all of ! * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR ! * and WI contain those eigenvalues which have been ! * successfully computed. (Failures are rare.) ! * ! * If INFO .GT. 0 and JOB = 'E', then on exit, the ! * remaining unconverged eigenvalues are the eigen- ! * values of the upper Hessenberg matrix rows and ! * columns ILO through INFO of the final, output ! * value of H. ! * ! * If INFO .GT. 0 and JOB = 'S', then on exit ! * ! * (*) (initial value of H)*U = U*(final value of H) ! * ! * where U is a unitary matrix. The final ! * value of H is upper Hessenberg and triangular in ! * rows and columns INFO+1 through IHI. ! * ! * If INFO .GT. 0 and COMPZ = 'V', then on exit ! * ! * (final value of Z) = (initial value of Z)*U ! * ! * where U is the unitary matrix in (*) (regard- ! * less of the value of JOB.) ! * ! * If INFO .GT. 0 and COMPZ = 'I', then on exit ! * (final value of Z) = U ! * where U is the unitary matrix in (*) (regard- ! * less of the value of JOB.) ! * ! * If INFO .GT. 0 and COMPZ = 'N', then Z is not ! * accessed. ! * ! * ================================================================ ! * Default values supplied by ! * ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). ! * It is suggested that these defaults be adjusted in order ! * to attain best performance in each particular ! * computational environment. ! * ! * ISPEC=1: The ZLAHQR vs ZLAQR0 crossover point. ! * Default: 75. (Must be at least 11.) ! * ! * ISPEC=2: Recommended deflation window size. ! * This depends on ILO, IHI and NS. NS is the ! * number of simultaneous shifts returned ! * by ILAENV(ISPEC=4). (See ISPEC=4 below.) ! * The default for (IHI-ILO+1).LE.500 is NS. ! * The default for (IHI-ILO+1).GT.500 is 3*NS/2. ! * ! * ISPEC=3: Nibble crossover point. (See ILAENV for ! * details.) Default: 14% of deflation window ! * size. ! * ! * ISPEC=4: Number of simultaneous shifts, NS, in ! * a multi-shift QR iteration. ! * ! * If IHI-ILO+1 is ... ! * ! * greater than ...but less ... the ! * or equal to ... than default is ! * ! * 1 30 NS - 2(+) ! * 30 60 NS - 4(+) ! * 60 150 NS = 10(+) ! * 150 590 NS = ** ! * 590 3000 NS = 64 ! * 3000 6000 NS = 128 ! * 6000 infinity NS = 256 ! * ! * (+) By default some or all matrices of this order ! * are passed to the implicit double shift routine ! * ZLAHQR and NS is ignored. See ISPEC=1 above ! * and comments in IPARM for details. ! * ! * The asterisks (**) indicate an ad-hoc ! * function of N increasing from 10 to 64. ! * ! * ISPEC=5: Select structured matrix multiply. ! * (See ILAENV for details.) Default: 3. ! * ! * ================================================================ ! * Based on contributions by ! * Karen Braman and Ralph Byers, Department of Mathematics, ! * University of Kansas, USA ! * ! * ================================================================ ! * References: ! * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR ! * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 ! * Performance, SIAM Journal of Matrix Analysis, volume 23, pages ! * 929--947, 2002. ! * ! * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR ! * Algorithm Part II: Aggressive Early Deflation, SIAM Journal ! * of Matrix Analysis, volume 23, pages 948--973, 2002. * + * ================================================================ * .. Parameters .. + * + * ==== Matrices of order NTINY or smaller must be processed by + * . ZLAHQR because of insufficient subdiagonal scratch space. + * . (This is a hard limit.) ==== + * + * ==== NL allocates some local workspace to help small matrices + * . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is + * . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- + * . mended. (The default value of NMIN is 75.) Using NL = 49 + * . allows up to six simultaneous shifts and a 16-by-16 + * . deflation window. ==== + * + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER NL + PARAMETER ( NL = 49 ) COMPLEX*16 ZERO, ONE ! PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), ! $ ONE = ( 1.0d0, 0.0d0 ) ) ! DOUBLE PRECISION RZERO ! PARAMETER ( RZERO = 0.0d0 ) ! * .. ! * .. Local Arrays .. ! COMPLEX*16 HL( NL, NL ), WORKL( NL ) * .. * .. Local Scalars .. + INTEGER KBOT, NMIN LOGICAL INITZ, LQUERY, WANTT, WANTZ * .. * .. External Functions .. + INTEGER ILAENV LOGICAL LSAME ! EXTERNAL ILAENV, LSAME * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET * .. * .. Intrinsic Functions .. ! INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Executable Statements .. * ! * ==== Decode and check the input parameters. ==== * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) + LQUERY = LWORK.EQ.-1 * INFO = 0 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN *************** *** 166,474 **** INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ! ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHSEQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF - * - * Initialize Z, if necessary * ! IF( INITZ ) ! $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * ! * Store the eigenvalues isolated by ZGEBAL. * ! DO 10 I = 1, ILO - 1 ! W( I ) = H( I, I ) ! 10 CONTINUE ! DO 20 I = IHI + 1, N ! W( I ) = H( I, I ) ! 20 CONTINUE ! * ! * Quick return if possible. ! * ! IF( N.EQ.0 ) ! $ RETURN ! IF( ILO.EQ.IHI ) THEN ! W( ILO ) = H( ILO, ILO ) RETURN - END IF - * - * Set rows and columns ILO to IHI to zero below the first - * subdiagonal. - * - DO 40 J = ILO, IHI - 2 - DO 30 I = J + 2, N - H( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - NH = IHI - ILO + 1 - * - * I1 and I2 are the indices of the first row and last column of H - * to which transformations must be applied. If eigenvalues only are - * being computed, I1 and I2 are re-set inside the main loop. - * - IF( WANTT ) THEN - I1 = 1 - I2 = N - ELSE - I1 = ILO - I2 = IHI - END IF * ! * Ensure that the subdiagonal elements are real. * ! DO 50 I = ILO + 1, IHI ! TEMP = H( I, I-1 ) ! IF( DIMAG( TEMP ).NE.RZERO ) THEN ! RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) ) ! H( I, I-1 ) = RTEMP ! TEMP = TEMP / RTEMP ! IF( I2.GT.I ) ! $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) ! CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) ! IF( I.LT.IHI ) ! $ H( I+1, I ) = TEMP*H( I+1, I ) ! IF( WANTZ ) ! $ CALL ZSCAL( NH, TEMP, Z( ILO, I ), 1 ) ! END IF ! 50 CONTINUE * ! * Determine the order of the multi-shift QR algorithm to be used. * ! NS = ILAENV( 4, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) ! MAXB = ILAENV( 8, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) ! IF( NS.LE.1 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN * ! * Use the standard double-shift algorithm * ! CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, ! $ LDZ, INFO ) RETURN - END IF - MAXB = MAX( 2, MAXB ) - NS = MIN( NS, MAXB, NSMAX ) - * - * Now 1 < NS <= MAXB < NH. * ! * Set machine-dependent constants for the stopping criterion. ! * If norm(H) <= sqrt(OVFL), overflow should not occur. * ! UNFL = DLAMCH( 'Safe minimum' ) ! OVFL = RONE / UNFL ! CALL DLABAD( UNFL, OVFL ) ! ULP = DLAMCH( 'Precision' ) ! SMLNUM = UNFL*( NH / ULP ) ! * ! * ITN is the total number of multiple-shift QR iterations allowed. ! * ! ITN = 30*NH ! * ! * The main loop begins here. I is the loop index and decreases from ! * IHI to ILO in steps of at most MAXB. Each iteration of the loop ! * works with the active submatrix in rows and columns L to I. ! * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or ! * H(L,L-1) is negligible so that the matrix splits. ! * ! I = IHI ! 60 CONTINUE ! IF( I.LT.ILO ) ! $ GO TO 180 ! * ! * Perform multiple-shift QR iterations on rows and columns ILO to I ! * until a submatrix of order at most MAXB splits off at the bottom ! * because a subdiagonal element has become negligible. ! * ! L = ILO ! DO 160 ITS = 0, ITN ! * ! * Look for a single small subdiagonal element. ! * ! DO 70 K = I, L + 1, -1 ! TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) ! IF( TST1.EQ.RZERO ) ! $ TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK ) ! IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) ) ! $ GO TO 80 ! 70 CONTINUE ! 80 CONTINUE ! L = K ! IF( L.GT.ILO ) THEN * ! * H(L,L-1) is negligible. * ! H( L, L-1 ) = ZERO ! END IF * ! * Exit from loop if a submatrix of order <= MAXB has split off. * ! IF( L.GE.I-MAXB+1 ) ! $ GO TO 170 * ! * Now the active submatrix is in rows and columns L to I. If ! * eigenvalues only are being computed, only the active submatrix ! * need be transformed. ! * ! IF( .NOT.WANTT ) THEN ! I1 = L ! I2 = I END IF * ! IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN ! * ! * Exceptional shifts. ! * ! DO 90 II = I - NS + 1, I ! W( II ) = CONST*( ABS( DBLE( H( II, II-1 ) ) )+ ! $ ABS( DBLE( H( II, II ) ) ) ) ! 90 CONTINUE ! ELSE ! * ! * Use eigenvalues of trailing submatrix of order NS as shifts. * ! CALL ZLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S, ! $ LDS ) ! CALL ZLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS, ! $ W( I-NS+1 ), 1, NS, Z, LDZ, IERR ) ! IF( IERR.GT.0 ) THEN ! * ! * If ZLAHQR failed to compute all NS eigenvalues, use the ! * unconverged diagonal elements as the remaining shifts. ! * ! DO 100 II = 1, IERR ! W( I-NS+II ) = S( II, II ) ! 100 CONTINUE ! END IF ! END IF * ! * Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) ! * where G is the Hessenberg submatrix H(L:I,L:I) and w is ! * the vector of shifts (stored in W). The result is ! * stored in the local array V. ! * ! V( 1 ) = ONE ! DO 110 II = 2, NS + 1 ! V( II ) = ZERO ! 110 CONTINUE ! NV = 1 ! DO 130 J = I - NS + 1, I ! CALL ZCOPY( NV+1, V, 1, VV, 1 ) ! CALL ZGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), LDH, ! $ VV, 1, -W( J ), V, 1 ) ! NV = NV + 1 ! * ! * Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, ! * reset it to the unit vector. ! * ! ITEMP = IZAMAX( NV, V, 1 ) ! RTEMP = CABS1( V( ITEMP ) ) ! IF( RTEMP.EQ.RZERO ) THEN ! V( 1 ) = ONE ! DO 120 II = 2, NV ! V( II ) = ZERO ! 120 CONTINUE ! ELSE ! RTEMP = MAX( RTEMP, SMLNUM ) ! CALL ZDSCAL( NV, RONE / RTEMP, V, 1 ) ! END IF ! 130 CONTINUE * ! * Multiple-shift QR step * ! DO 150 K = L, I - 1 * ! * The first iteration of this loop determines a reflection G ! * from the vector V and applies it from left and right to H, ! * thus creating a nonzero bulge below the subdiagonal. ! * ! * Each subsequent iteration determines a reflection G to ! * restore the Hessenberg form in the (K-1)th column, and thus ! * chases the bulge one step toward the bottom of the active ! * submatrix. NR is the order of G. ! * ! NR = MIN( NS+1, I-K+1 ) ! IF( K.GT.L ) ! $ CALL ZCOPY( NR, H( K, K-1 ), 1, V, 1 ) ! CALL ZLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) ! IF( K.GT.L ) THEN ! H( K, K-1 ) = V( 1 ) ! DO 140 II = K + 1, I ! H( II, K-1 ) = ZERO ! 140 CONTINUE ! END IF ! V( 1 ) = ONE * ! * Apply G' from the left to transform the rows of the matrix ! * in columns K to I2. * ! CALL ZLARFX( 'Left', NR, I2-K+1, V, DCONJG( TAU ), ! $ H( K, K ), LDH, WORK ) * ! * Apply G from the right to transform the columns of the ! * matrix in rows I1 to min(K+NR,I). * ! CALL ZLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU, ! $ H( I1, K ), LDH, WORK ) * ! IF( WANTZ ) THEN * ! * Accumulate transformations in the matrix Z * ! CALL ZLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ, ! $ WORK ) ! END IF ! 150 CONTINUE * ! * Ensure that H(I,I-1) is real. * ! TEMP = H( I, I-1 ) ! IF( DIMAG( TEMP ).NE.RZERO ) THEN ! RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( TEMP ) ) ! H( I, I-1 ) = RTEMP ! TEMP = TEMP / RTEMP ! IF( I2.GT.I ) ! $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) ! CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) ! IF( WANTZ ) THEN ! CALL ZSCAL( NH, TEMP, Z( ILO, I ), 1 ) END IF END IF * ! 160 CONTINUE * ! * Failure to converge in remaining number of iterations * ! INFO = I ! RETURN * ! 170 CONTINUE ! * ! * A submatrix of order <= MAXB in rows and columns L to I has split ! * off. Use the double-shift QR algorithm to handle it. ! * ! CALL ZLAHQR( WANTT, WANTZ, N, L, I, H, LDH, W, ILO, IHI, Z, LDZ, ! $ INFO ) ! IF( INFO.GT.0 ) ! $ RETURN ! * ! * Decrement number of remaining iterations, and return to start of ! * the main loop with a new value of I. ! * ! ITN = ITN - ITS ! I = L - 1 ! GO TO 60 ! * ! 180 CONTINUE ! WORK( 1 ) = MAX( 1, N ) ! RETURN * ! * End of ZHSEQR * END --- 274,395 ---- INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ! ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * ! IF( INFO.NE.0 ) THEN * ! * ==== Quick return in case of invalid argument. ==== * ! CALL XERBLA( 'ZHSEQR', -INFO ) RETURN * ! ELSE IF( N.EQ.0 ) THEN * ! * ==== Quick return in case N = 0; nothing to do. ==== * ! RETURN * ! ELSE IF( LQUERY ) THEN * ! * ==== Quick return in case of a workspace query ==== * ! CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, ! $ LDZ, WORK, LWORK, INFO ) ! * ==== Ensure reported workspace size is backward-compatible with ! * . previous LAPACK versions. ==== ! WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, ! $ N ) ) ), RZERO ) RETURN * ! ELSE * ! * ==== copy eigenvalues isolated by ZGEBAL ==== * ! IF( ILO.GT.1 ) ! $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) ! IF( IHI.LT.N ) ! $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) * ! * ==== Initialize Z, if requested ==== * ! IF( INITZ ) ! $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) * ! * ==== Quick return if possible ==== * ! IF( ILO.EQ.IHI ) THEN ! W( ILO ) = H( ILO, ILO ) ! RETURN END IF * ! * ==== ZLAHQR/ZLAQR0 crossover point ==== * ! NMIN = ILAENV( 1, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO, ! $ IHI, LWORK ) ! NMIN = MAX( NTINY, NMIN ) * ! * ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== * ! IF( N.GT.NMIN ) THEN ! CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, ! $ Z, LDZ, WORK, LWORK, INFO ) ! ELSE * ! * ==== Small matrix ==== * ! CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, ! $ Z, LDZ, INFO ) * ! IF( INFO.GT.0 ) THEN * ! * ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds ! * . when ZLAHQR fails. ==== * ! KBOT = INFO * ! IF( N.GE.NL ) THEN * ! * ==== Larger matrices have enough subdiagonal scratch ! * . space to call ZLAQR0 directly. ==== * ! CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, ! $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) * ! ELSE * ! * ==== Tiny matrices don't have enough subdiagonal ! * . scratch space to benefit from ZLAQR0. Hence, ! * . tiny matrices must be copied into a larger ! * . array before calling ZLAQR0. ==== * ! CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) ! HL( N+1, N ) = ZERO ! CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), ! $ NL ) ! CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, ! $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) ! IF( WANTT .OR. INFO.NE.0 ) ! $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) ! END IF END IF END IF * ! * ==== Clear out the trash, if necessary. ==== * ! IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) ! $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) * ! * ==== Ensure reported workspace size is backward-compatible with ! * . previous LAPACK versions. ==== * ! WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), ! $ DBLE( WORK( 1 ) ) ), RZERO ) ! END IF * ! * ==== End of ZHSEQR ==== * END diff -cNr octave-2.9.15/libcruft/lapack/zlabrd.f octave-2.9.16/libcruft/lapack/zlabrd.f *** octave-2.9.15/libcruft/lapack/zlabrd.f Wed Nov 3 14:54:40 1999 --- octave-2.9.16/libcruft/lapack/zlabrd.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB --- 1,9 ---- SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB *************** *** 88,94 **** * The n-by-nb matrix Y required to update the unreduced part * of A. * ! * LDY (output) INTEGER * The leading dimension of the array Y. LDY >= max(1,N). * * Further Details --- 87,93 ---- * The n-by-nb matrix Y required to update the unreduced part * of A. * ! * LDY (input) INTEGER * The leading dimension of the array Y. LDY >= max(1,N). * * Further Details diff -cNr octave-2.9.15/libcruft/lapack/zlacgv.f octave-2.9.16/libcruft/lapack/zlacgv.f *** octave-2.9.15/libcruft/lapack/zlacgv.f Wed Nov 3 14:54:40 1999 --- octave-2.9.16/libcruft/lapack/zlacgv.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLACGV( N, X, INCX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- SUBROUTINE ZLACGV( N, X, INCX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/zlacn2.f octave-2.9.16/libcruft/lapack/zlacn2.f *** octave-2.9.15/libcruft/lapack/zlacn2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlacn2.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,221 ---- + SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER KASE, N + DOUBLE PRECISION EST + * .. + * .. Array Arguments .. + INTEGER ISAVE( 3 ) + COMPLEX*16 V( * ), X( * ) + * .. + * + * Purpose + * ======= + * + * ZLACN2 estimates the 1-norm of a square, complex matrix A. + * Reverse communication is used for evaluating matrix-vector products. + * + * Arguments + * ========= + * + * N (input) INTEGER + * The order of the matrix. N >= 1. + * + * V (workspace) COMPLEX*16 array, dimension (N) + * On the final return, V = A*W, where EST = norm(V)/norm(W) + * (W is not returned). + * + * X (input/output) COMPLEX*16 array, dimension (N) + * On an intermediate return, X should be overwritten by + * A * X, if KASE=1, + * A' * X, if KASE=2, + * where A' is the conjugate transpose of A, and ZLACN2 must be + * re-called with all the other parameters unchanged. + * + * EST (input/output) DOUBLE PRECISION + * On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be + * unchanged from the previous call to ZLACN2. + * On exit, EST is an estimate (a lower bound) for norm(A). + * + * KASE (input/output) INTEGER + * On the initial call to ZLACN2, KASE should be 0. + * On an intermediate return, KASE will be 1 or 2, indicating + * whether X should be overwritten by A * X or A' * X. + * On the final return from ZLACN2, KASE will again be 0. + * + * ISAVE (input/output) INTEGER array, dimension (3) + * ISAVE is used to save variables between calls to ZLACN2 + * + * Further Details + * ======= ======= + * + * Contributed by Nick Higham, University of Manchester. + * Originally named CONEST, dated March 16, 1988. + * + * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of + * a real or complex matrix, with applications to condition estimation", + * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. + * + * Last modified: April, 1999 + * + * This is a thread safe version of ZLACON, which uses the array ISAVE + * in place of a SAVE statement, as follows: + * + * ZLACON ZLACN2 + * JUMP ISAVE(1) + * J ISAVE(2) + * ITER ISAVE(3) + * + * ===================================================================== + * + * .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 5 ) + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) + * .. + * .. Local Scalars .. + INTEGER I, JLAST + DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP + * .. + * .. External Functions .. + INTEGER IZMAX1 + DOUBLE PRECISION DLAMCH, DZSUM1 + EXTERNAL IZMAX1, DLAMCH, DZSUM1 + * .. + * .. External Subroutines .. + EXTERNAL ZCOPY + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG + * .. + * .. Executable Statements .. + * + SAFMIN = DLAMCH( 'Safe minimum' ) + IF( KASE.EQ.0 ) THEN + DO 10 I = 1, N + X( I ) = DCMPLX( ONE / DBLE( N ) ) + 10 CONTINUE + KASE = 1 + ISAVE( 1 ) = 1 + RETURN + END IF + * + GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) + * + * ................ ENTRY (ISAVE( 1 ) = 1) + * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. + * + 20 CONTINUE + IF( N.EQ.1 ) THEN + V( 1 ) = X( 1 ) + EST = ABS( V( 1 ) ) + * ... QUIT + GO TO 130 + END IF + EST = DZSUM1( N, X, 1 ) + * + DO 30 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 30 CONTINUE + KASE = 2 + ISAVE( 1 ) = 2 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 2) + * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. + * + 40 CONTINUE + ISAVE( 2 ) = IZMAX1( N, X, 1 ) + ISAVE( 3 ) = 2 + * + * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. + * + 50 CONTINUE + DO 60 I = 1, N + X( I ) = CZERO + 60 CONTINUE + X( ISAVE( 2 ) ) = CONE + KASE = 1 + ISAVE( 1 ) = 3 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 3) + * X HAS BEEN OVERWRITTEN BY A*X. + * + 70 CONTINUE + CALL ZCOPY( N, X, 1, V, 1 ) + ESTOLD = EST + EST = DZSUM1( N, V, 1 ) + * + * TEST FOR CYCLING. + IF( EST.LE.ESTOLD ) + $ GO TO 100 + * + DO 80 I = 1, N + ABSXI = ABS( X( I ) ) + IF( ABSXI.GT.SAFMIN ) THEN + X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, + $ DIMAG( X( I ) ) / ABSXI ) + ELSE + X( I ) = CONE + END IF + 80 CONTINUE + KASE = 2 + ISAVE( 1 ) = 4 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 4) + * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. + * + 90 CONTINUE + JLAST = ISAVE( 2 ) + ISAVE( 2 ) = IZMAX1( N, X, 1 ) + IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. + $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN + ISAVE( 3 ) = ISAVE( 3 ) + 1 + GO TO 50 + END IF + * + * ITERATION COMPLETE. FINAL STAGE. + * + 100 CONTINUE + ALTSGN = ONE + DO 110 I = 1, N + X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) + ALTSGN = -ALTSGN + 110 CONTINUE + KASE = 1 + ISAVE( 1 ) = 5 + RETURN + * + * ................ ENTRY (ISAVE( 1 ) = 5) + * X HAS BEEN OVERWRITTEN BY A*X. + * + 120 CONTINUE + TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) + IF( TEMP.GT.EST ) THEN + CALL ZCOPY( N, X, 1, V, 1 ) + EST = TEMP + END IF + * + 130 CONTINUE + KASE = 0 + RETURN + * + * End of ZLACN2 + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlacon.f octave-2.9.16/libcruft/lapack/zlacon.f *** octave-2.9.15/libcruft/lapack/zlacon.f Wed Nov 3 14:54:40 1999 --- octave-2.9.16/libcruft/lapack/zlacon.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLACON( N, V, X, EST, KASE ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER KASE, N --- 1,8 ---- SUBROUTINE ZLACON( N, V, X, EST, KASE ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER KASE, N *************** *** 36,43 **** * where A' is the conjugate transpose of A, and ZLACON must be * re-called with all the other parameters unchanged. * ! * EST (output) DOUBLE PRECISION ! * An estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to ZLACON, KASE should be 0. --- 35,44 ---- * where A' is the conjugate transpose of A, and ZLACON must be * re-called with all the other parameters unchanged. * ! * EST (input/output) DOUBLE PRECISION ! * On entry with KASE = 1 or 2 and JUMP = 3, EST should be ! * unchanged from the previous call to ZLACON. ! * On exit, EST is an estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to ZLACON, KASE should be 0. *************** *** 126,132 **** RETURN * * ................ ENTRY (JUMP = 2) ! * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. * 40 CONTINUE J = IZMAX1( N, X, 1 ) --- 127,133 ---- RETURN * * ................ ENTRY (JUMP = 2) ! * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE J = IZMAX1( N, X, 1 ) *************** *** 169,175 **** RETURN * * ................ ENTRY (JUMP = 4) ! * X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. * 90 CONTINUE JLAST = J --- 170,176 ---- RETURN * * ................ ENTRY (JUMP = 4) ! * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = J diff -cNr octave-2.9.15/libcruft/lapack/zlacpy.f octave-2.9.16/libcruft/lapack/zlacpy.f *** octave-2.9.15/libcruft/lapack/zlacpy.f Wed Nov 3 14:54:41 1999 --- octave-2.9.16/libcruft/lapack/zlacpy.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zladiv.f octave-2.9.16/libcruft/lapack/zladiv.f *** octave-2.9.15/libcruft/lapack/zladiv.f Wed Nov 3 14:54:41 1999 --- octave-2.9.16/libcruft/lapack/zladiv.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** ! DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. COMPLEX*16 X, Y --- 1,8 ---- ! COMPLEX*16 FUNCTION ZLADIV( X, Y ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. COMPLEX*16 X, Y diff -cNr octave-2.9.15/libcruft/lapack/zlahqr.f octave-2.9.16/libcruft/lapack/zlahqr.f *** octave-2.9.15/libcruft/lapack/zlahqr.f Wed Nov 3 14:54:41 1999 --- octave-2.9.16/libcruft/lapack/zlahqr.f Tue Oct 16 14:54:22 2007 *************** *** 1,42 **** SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. - LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. * ! * Purpose ! * ======= * ! * ZLAHQR is an auxiliary routine called by ZHSEQR to update the ! * eigenvalues and Schur decomposition already computed by ZHSEQR, by ! * dealing with the Hessenberg submatrix in rows and columns ILO to IHI. * ! * Arguments ! * ========= * ! * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * ! * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * ! * N (input) INTEGER * The order of the matrix H. N >= 0. * ! * ILO (input) INTEGER ! * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows and * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). * ZLAHQR works primarily with the Hessenberg submatrix in rows --- 1,42 ---- SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. * ! * Purpose ! * ======= * ! * ZLAHQR is an auxiliary routine called by CHSEQR to update the ! * eigenvalues and Schur decomposition already computed by CHSEQR, by ! * dealing with the Hessenberg submatrix in rows and columns ILO to ! * IHI. * ! * Arguments ! * ========= * ! * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * ! * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * ! * N (input) INTEGER * The order of the matrix H. N >= 0. * ! * ILO (input) INTEGER ! * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows and * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). * ZLAHQR works primarily with the Hessenberg submatrix in rows *************** *** 44,123 **** * H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * ! * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. ! * On exit, if WANTT is .TRUE., H is upper triangular in rows ! * and columns ILO:IHI, with any 2-by-2 diagonal blocks in ! * standard form. If WANTT is .FALSE., the contents of H are ! * unspecified on exit. * ! * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * ! * W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues ILO to IHI are stored in the * corresponding elements of W. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with W(i) = H(i,i). * ! * ILOZ (input) INTEGER ! * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * ! * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current ! * matrix Z of transformations accumulated by ZHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * ! * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * ! * INFO (output) INTEGER ! * = 0: successful exit ! * > 0: if INFO = i, ZLAHQR failed to compute all the ! * eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1) ! * iterations; elements i+1:ihi of W contain those ! * eigenvalues which have been successfully computed. * ! * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE ! PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), ! $ ONE = ( 1.0D+0, 0.0D+0 ) ) ! DOUBLE PRECISION RZERO, HALF ! PARAMETER ( RZERO = 0.0D+0, HALF = 0.5D+0 ) DOUBLE PRECISION DAT1 ! PARAMETER ( DAT1 = 0.75D+0 ) * .. * .. Local Scalars .. ! INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ ! DOUBLE PRECISION H10, H21, RTEMP, S, SMLNUM, T2, TST1, ULP ! COMPLEX*16 CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2, ! $ X, Y * .. * .. Local Arrays .. - DOUBLE PRECISION RWORK( 1 ) COMPLEX*16 V( 2 ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, ZLANHS COMPLEX*16 ZLADIV ! EXTERNAL DLAMCH, ZLANHS, ZLADIV * .. * .. External Subroutines .. ! EXTERNAL ZCOPY, ZLARFG, ZSCAL ! * .. ! * .. Intrinsic Functions .. ! INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. --- 44,158 ---- * H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * ! * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. ! * On exit, if INFO is zero and if WANTT is .TRUE., then H ! * is upper triangular in rows and columns ILO:IHI. If INFO ! * is zero and if WANTT is .FALSE., then the contents of H ! * are unspecified on exit. The output state of H in case ! * INF is positive is below under the description of INFO. * ! * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * ! * W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues ILO to IHI are stored in the * corresponding elements of W. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with W(i) = H(i,i). * ! * ILOZ (input) INTEGER ! * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * ! * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current ! * matrix Z of transformations accumulated by CHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * ! * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * ! * INFO (output) INTEGER ! * = 0: successful exit ! * .GT. 0: if INFO = i, ZLAHQR failed to compute all the ! * eigenvalues ILO to IHI in a total of 30 iterations ! * per eigenvalue; elements i+1:ihi of W contain ! * those eigenvalues which have been successfully ! * computed. ! * ! * If INFO .GT. 0 and WANTT is .FALSE., then on exit, ! * the remaining unconverged eigenvalues are the ! * eigenvalues of the upper Hessenberg matrix ! * rows and columns ILO thorugh INFO of the final, ! * output value of H. ! * ! * If INFO .GT. 0 and WANTT is .TRUE., then on exit ! * (*) (initial value of H)*U = U*(final value of H) ! * where U is an orthognal matrix. The final ! * value of H is upper Hessenberg and triangular in ! * rows and columns INFO+1 through IHI. ! * ! * If INFO .GT. 0 and WANTZ is .TRUE., then on exit ! * (final value of Z) = (initial value of Z)*U ! * where U is the orthogonal matrix in (*) ! * (regardless of the value of WANTT.) ! * ! * Further Details ! * =============== ! * ! * 02-96 Based on modifications by ! * David Day, Sandia National Laboratory, USA ! * ! * 12-04 Further modifications by ! * Ralph Byers, University of Kansas, USA ! * ! * This is a modified version of ZLAHQR from LAPACK version 3.0. ! * It is (1) more robust against overflow and underflow and ! * (2) adopts the more conservative Ahues & Tisseur stopping ! * criterion (LAWN 122, 1997). * ! * ========================================================= * * .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 30 ) COMPLEX*16 ZERO, ONE ! PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), ! $ ONE = ( 1.0d0, 0.0d0 ) ) ! DOUBLE PRECISION RZERO, RONE, HALF ! PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) DOUBLE PRECISION DAT1 ! PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) * .. * .. Local Scalars .. ! COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, ! $ V2, X, Y ! DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, ! $ SAFMIN, SMLNUM, SX, T2, TST, ULP ! INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ * .. * .. Local Arrays .. COMPLEX*16 V( 2 ) * .. * .. External Functions .. COMPLEX*16 ZLADIV ! DOUBLE PRECISION DLAMCH ! EXTERNAL ZLADIV, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT + * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. *************** *** 134,147 **** RETURN END IF * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. - * If norm(H) <= sqrt(OVFL), overflow should not occur. * ! ULP = DLAMCH( 'Precision' ) ! SMLNUM = DLAMCH( 'Safe minimum' ) / ULP * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are --- 169,215 ---- RETURN END IF * + * ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO + * ==== ensure that subdiagonal entries are real ==== + DO 20 I = ILO + 1, IHI + IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN + * ==== The following redundant normalization + * . avoids problems with both gradual and + * . sudden underflow in ABS(H(I,I-1)) ==== + SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) + SC = DCONJG( SC ) / ABS( SC ) + H( I, I-1 ) = ABS( H( I, I-1 ) ) + IF( WANTT ) THEN + JLO = 1 + JHI = N + ELSE + JLO = ILO + JHI = IHI + END IF + CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) + CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), + $ H( JLO, I ), 1 ) + IF( WANTZ ) + $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) + END IF + 20 CONTINUE + * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * ! SAFMIN = DLAMCH( 'SAFE MINIMUM' ) ! SAFMAX = RONE / SAFMIN ! CALL DLABAD( SAFMIN, SAFMAX ) ! ULP = DLAMCH( 'PRECISION' ) ! SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are *************** *** 152,161 **** I2 = N END IF * - * ITN is the total number of QR iterations allowed. - * - ITN = 30*NH - * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1. Each iteration of the loop works * with the active submatrix in rows and columns L to I. --- 220,225 ---- *************** *** 163,189 **** * H(L,L-1) is negligible so that the matrix splits. * I = IHI ! 10 CONTINUE IF( I.LT.ILO ) ! $ GO TO 130 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO ! DO 110 ITS = 0, ITN * * Look for a single small subdiagonal element. * ! DO 20 K = I, L + 1, -1 ! TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) ! IF( TST1.EQ.RZERO ) ! $ TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK ) ! IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) ) ! $ GO TO 30 ! 20 CONTINUE ! 30 CONTINUE L = K IF( L.GT.ILO ) THEN * --- 227,272 ---- * H(L,L-1) is negligible so that the matrix splits. * I = IHI ! 30 CONTINUE IF( I.LT.ILO ) ! $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO ! DO 130 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * ! DO 40 K = I, L + 1, -1 ! IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) ! $ GO TO 50 ! TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) ! IF( TST.EQ.ZERO ) THEN ! IF( K-2.GE.ILO ) ! $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) ! IF( K+1.LE.IHI ) ! $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) ! END IF ! * ==== The following is a conservative small subdiagonal ! * . deflation criterion due to Ahues & Tisseur (LAWN 122, ! * . 1997). It has better mathematical foundation and ! * . improves accuracy in some examples. ==== ! IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN ! AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) ! BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) ! AA = MAX( CABS1( H( K, K ) ), ! $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) ! BB = MIN( CABS1( H( K, K ) ), ! $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) ! S = AA + AB ! IF( BA*( AB / S ).LE.MAX( SMLNUM, ! $ ULP*( BB*( AA / S ) ) ) )GO TO 50 ! END IF ! 40 CONTINUE ! 50 CONTINUE L = K IF( L.GT.ILO ) THEN * *************** *** 195,201 **** * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) ! $ GO TO 120 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix --- 278,284 ---- * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) ! $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix *************** *** 217,235 **** * Wilkinson's shift. * T = H( I, I ) ! U = H( I-1, I )*DBLE( H( I, I-1 ) ) ! IF( U.NE.ZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) ! Y = SQRT( X*X+U ) ! IF( DBLE( X )*DBLE( Y )+DIMAG( X )*DIMAG( Y ).LT.RZERO ) ! $ Y = -Y ! T = T - ZLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * ! DO 40 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) --- 300,323 ---- * Wilkinson's shift. * T = H( I, I ) ! U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) ! S = CABS1( U ) ! IF( S.NE.RZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) ! SX = CABS1( X ) ! S = MAX( S, CABS1( X ) ) ! Y = S*SQRT( ( X / S )**2+( U / S )**2 ) ! IF( SX.GT.RZERO ) THEN ! IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* ! $ DIMAG( Y ).LT.RZERO )Y = -Y ! END IF ! T = T - U*ZLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * ! DO 60 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) *************** *** 245,254 **** V( 1 ) = H11S V( 2 ) = H21 H10 = H( M, M-1 ) ! TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ! IF( ABS( H10*H21 ).LE.ULP*TST1 ) ! $ GO TO 50 ! 40 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T --- 333,342 ---- V( 1 ) = H11S V( 2 ) = H21 H10 = H( M, M-1 ) ! IF( ABS( H10 )*ABS( H21 ).LE.ULP* ! $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) ! $ GO TO 70 ! 60 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T *************** *** 258,268 **** H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 ! 50 CONTINUE * * Single-shift QR step * ! DO 100 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, --- 346,356 ---- H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 ! 70 CONTINUE * * Single-shift QR step * ! DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, *************** *** 289,318 **** * Apply G from the left to transform the rows of the matrix * in columns K to I2. * ! DO 60 J = K, I2 SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 ! 60 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * ! DO 70 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) ! 70 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * ! DO 80 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) ! 80 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN --- 377,406 ---- * Apply G from the left to transform the rows of the matrix * in columns K to I2. * ! DO 80 J = K, I2 SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 ! 80 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * ! DO 90 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) ! 90 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * ! DO 100 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) ! 100 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN *************** *** 327,333 **** H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP ! DO 90 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) --- 415,421 ---- H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP ! DO 110 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) *************** *** 337,345 **** $ 1 ) END IF END IF ! 90 CONTINUE END IF ! 100 CONTINUE * * Ensure that H(I,I-1) is real. * --- 425,433 ---- $ 1 ) END IF END IF ! 110 CONTINUE END IF ! 120 CONTINUE * * Ensure that H(I,I-1) is real. * *************** *** 356,382 **** END IF END IF * ! 110 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * ! 120 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * ! * Decrement number of remaining iterations, and return to start of ! * the main loop with new value of I. * - ITN = ITN - ITS I = L - 1 ! GO TO 10 * ! 130 CONTINUE RETURN * * End of ZLAHQR --- 444,468 ---- END IF END IF * ! 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * ! 140 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * ! * return to start of the main loop with new value of I. * I = L - 1 ! GO TO 30 * ! 150 CONTINUE RETURN * * End of ZLAHQR diff -cNr octave-2.9.15/libcruft/lapack/zlahr2.f octave-2.9.16/libcruft/lapack/zlahr2.f *** octave-2.9.15/libcruft/lapack/zlahr2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlahr2.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,240 ---- + SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB + * .. + * .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) + * .. + * + * Purpose + * ======= + * + * ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) + * matrix A so that elements below the k-th subdiagonal are zero. The + * reduction is performed by an unitary similarity transformation + * Q' * A * Q. The routine returns the matrices V and T which determine + * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. + * + * This is an auxiliary routine called by ZGEHRD. + * + * Arguments + * ========= + * + * N (input) INTEGER + * The order of the matrix A. + * + * K (input) INTEGER + * The offset for the reduction. Elements below the k-th + * subdiagonal in the first NB columns are reduced to zero. + * K < N. + * + * NB (input) INTEGER + * The number of columns to be reduced. + * + * A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) + * On entry, the n-by-(n-k+1) general matrix A. + * On exit, the elements on and above the k-th subdiagonal in + * the first NB columns are overwritten with the corresponding + * elements of the reduced matrix; the elements below the k-th + * subdiagonal, with the array TAU, represent the matrix Q as a + * product of elementary reflectors. The other columns of A are + * unchanged. See Further Details. + * + * LDA (input) INTEGER + * The leading dimension of the array A. LDA >= max(1,N). + * + * TAU (output) COMPLEX*16 array, dimension (NB) + * The scalar factors of the elementary reflectors. See Further + * Details. + * + * T (output) COMPLEX*16 array, dimension (LDT,NB) + * The upper triangular matrix T. + * + * LDT (input) INTEGER + * The leading dimension of the array T. LDT >= NB. + * + * Y (output) COMPLEX*16 array, dimension (LDY,NB) + * The n-by-nb matrix Y. + * + * LDY (input) INTEGER + * The leading dimension of the array Y. LDY >= N. + * + * Further Details + * =============== + * + * The matrix Q is represented as a product of nb elementary reflectors + * + * Q = H(1) H(2) . . . H(nb). + * + * Each H(i) has the form + * + * H(i) = I - tau * v * v' + * + * where tau is a complex scalar, and v is a complex vector with + * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in + * A(i+k+1:n,i), and tau in TAU(i). + * + * The elements of the vectors v together form the (n-k+1)-by-nb matrix + * V which is needed, with T and Y, to apply the transformation to the + * unreduced part of the matrix, using an update of the form: + * A := (I - V*T*V') * (A - Y*V'). + * + * The contents of A on exit are illustrated by the following example + * with n = 7, k = 3 and nb = 2: + * + * ( a a a a a ) + * ( a a a a a ) + * ( a a a a a ) + * ( h h a a a ) + * ( v1 h a a a ) + * ( v1 v2 a a a ) + * ( v1 v2 a a a ) + * + * where a denotes an element of the original matrix A, h denotes a + * modified element of the upper Hessenberg matrix H, and vi denotes an + * element of the vector defining H(i). + * + * This file is a slight modification of LAPACK-3.0's ZLAHRD + * incorporating improvements proposed by Quintana-Orti and Van de + * Gejin. Note that the entries of A(1:K,2:NB) differ from those + * returned by the original LAPACK routine. This function is + * not backward compatible with LAPACK3.0. + * + * ===================================================================== + * + * .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) + * .. + * .. Local Scalars .. + INTEGER I + COMPLEX*16 EI + * .. + * .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, + $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV + * .. + * .. Intrinsic Functions .. + INTRINSIC MIN + * .. + * .. Executable Statements .. + * + * Quick return if possible + * + IF( N.LE.1 ) + $ RETURN + * + DO 10 I = 1, NB + IF( I.GT.1 ) THEN + * + * Update A(K+1:N,I) + * + * Update I-th column of A - Y * V' + * + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + * + * Apply I - V * T' * V' to this column (call it b) from the + * left, using the last column of T as workspace + * + * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) + * ( V2 ) ( b2 ) + * + * where V1 is unit lower triangular + * + * w := V1' * b1 + * + CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) + * + * w := w + V2'*b2 + * + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) + * + * w := T'*w + * + CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) + * + * b2 := b2 - V2*w + * + CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) + * + * b1 := b1 - V1*w + * + CALL ZTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) + * + A( K+I-1, I-1 ) = EI + END IF + * + * Generate the elementary reflector H(I) to annihilate + * A(K+I+1:N,I) + * + CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE + * + * Compute Y(K+1:N,I) + * + CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) + * + * Compute T(1:I,I) + * + CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + * + 10 CONTINUE + A( K+NB, NB ) = EI + * + * Compute Y(1:K,1:NB) + * + CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) + * + RETURN + * + * End of ZLAHR2 + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlahrd.f octave-2.9.16/libcruft/lapack/zlahrd.f *** octave-2.9.15/libcruft/lapack/zlahrd.f Wed Nov 3 14:54:41 1999 --- octave-2.9.16/libcruft/lapack/zlahrd.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB --- 1,8 ---- SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB *************** *** 22,28 **** * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * ! * This is an auxiliary routine called by ZGEHRD. * * Arguments * ========= --- 21,29 ---- * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * ! * This is an OBSOLETE auxiliary routine. ! * This routine will be 'deprecated' in a future release. ! * Please use the new routine ZLAHR2 instead. * * Arguments * ========= diff -cNr octave-2.9.15/libcruft/lapack/zlals0.f octave-2.9.16/libcruft/lapack/zlals0.f *** octave-2.9.15/libcruft/lapack/zlals0.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlals0.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,433 ---- + SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, + $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, + $ POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, + $ LDGNUM, NL, NR, NRHS, SQRE + DOUBLE PRECISION C, S + * .. + * .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), PERM( * ) + DOUBLE PRECISION DIFL( * ), DIFR( LDGNUM, * ), + $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), + $ RWORK( * ), Z( * ) + COMPLEX*16 B( LDB, * ), BX( LDBX, * ) + * .. + * + * Purpose + * ======= + * + * ZLALS0 applies back the multiplying factors of either the left or the + * right singular vector matrix of a diagonal matrix appended by a row + * to the right hand side matrix B in solving the least squares problem + * using the divide-and-conquer SVD approach. + * + * For the left singular vector matrix, three types of orthogonal + * matrices are involved: + * + * (1L) Givens rotations: the number of such rotations is GIVPTR; the + * pairs of columns/rows they were applied to are stored in GIVCOL; + * and the C- and S-values of these rotations are stored in GIVNUM. + * + * (2L) Permutation. The (NL+1)-st row of B is to be moved to the first + * row, and for J=2:N, PERM(J)-th row of B is to be moved to the + * J-th row. + * + * (3L) The left singular vector matrix of the remaining matrix. + * + * For the right singular vector matrix, four types of orthogonal + * matrices are involved: + * + * (1R) The right singular vector matrix of the remaining matrix. + * + * (2R) If SQRE = 1, one extra Givens rotation to generate the right + * null space. + * + * (3R) The inverse transformation of (2L). + * + * (4R) The inverse transformation of (1L). + * + * Arguments + * ========= + * + * ICOMPQ (input) INTEGER + * Specifies whether singular vectors are to be computed in + * factored form: + * = 0: Left singular vector matrix. + * = 1: Right singular vector matrix. + * + * NL (input) INTEGER + * The row dimension of the upper block. NL >= 1. + * + * NR (input) INTEGER + * The row dimension of the lower block. NR >= 1. + * + * SQRE (input) INTEGER + * = 0: the lower block is an NR-by-NR square matrix. + * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. + * + * The bidiagonal matrix has row dimension N = NL + NR + 1, + * and column dimension M = N + SQRE. + * + * NRHS (input) INTEGER + * The number of columns of B and BX. NRHS must be at least 1. + * + * B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS ) + * On input, B contains the right hand sides of the least + * squares problem in rows 1 through M. On output, B contains + * the solution X in rows 1 through N. + * + * LDB (input) INTEGER + * The leading dimension of B. LDB must be at least + * max(1,MAX( M, N ) ). + * + * BX (workspace) COMPLEX*16 array, dimension ( LDBX, NRHS ) + * + * LDBX (input) INTEGER + * The leading dimension of BX. + * + * PERM (input) INTEGER array, dimension ( N ) + * The permutations (from deflation and sorting) applied + * to the two blocks. + * + * GIVPTR (input) INTEGER + * The number of Givens rotations which took place in this + * subproblem. + * + * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) + * Each pair of numbers indicates a pair of rows/columns + * involved in a Givens rotation. + * + * LDGCOL (input) INTEGER + * The leading dimension of GIVCOL, must be at least N. + * + * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + * Each number indicates the C or S value used in the + * corresponding Givens rotation. + * + * LDGNUM (input) INTEGER + * The leading dimension of arrays DIFR, POLES and + * GIVNUM, must be at least K. + * + * POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) + * On entry, POLES(1:K, 1) contains the new singular + * values obtained from solving the secular equation, and + * POLES(1:K, 2) is an array containing the poles in the secular + * equation. + * + * DIFL (input) DOUBLE PRECISION array, dimension ( K ). + * On entry, DIFL(I) is the distance between I-th updated + * (undeflated) singular value and the I-th (undeflated) old + * singular value. + * + * DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). + * On entry, DIFR(I, 1) contains the distances between I-th + * updated (undeflated) singular value and the I+1-th + * (undeflated) old singular value. And DIFR(I, 2) is the + * normalizing factor for the I-th right singular vector. + * + * Z (input) DOUBLE PRECISION array, dimension ( K ) + * Contain the components of the deflation-adjusted updating row + * vector. + * + * K (input) INTEGER + * Contains the dimension of the non-deflated matrix, + * This is the order of the related secular equation. 1 <= K <=N. + * + * C (input) DOUBLE PRECISION + * C contains garbage if SQRE =0 and the C-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * S (input) DOUBLE PRECISION + * S contains garbage if SQRE =0 and the S-value of a Givens + * rotation related to the right null space if SQRE = 1. + * + * RWORK (workspace) DOUBLE PRECISION array, dimension + * ( K*(1+NRHS) + 2*NRHS ) + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ONE, ZERO, NEGONE + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 ) + * .. + * .. Local Scalars .. + INTEGER I, J, JCOL, JROW, M, N, NLP1 + DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP + * .. + * .. External Subroutines .. + EXTERNAL DGEMV, XERBLA, ZCOPY, ZDROT, ZDSCAL, ZLACPY, + $ ZLASCL + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMC3, DNRM2 + EXTERNAL DLAMC3, DNRM2 + * .. + * .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG, MAX + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( NL.LT.1 ) THEN + INFO = -2 + ELSE IF( NR.LT.1 ) THEN + INFO = -3 + ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN + INFO = -4 + END IF + * + N = NL + NR + 1 + * + IF( NRHS.LT.1 ) THEN + INFO = -5 + ELSE IF( LDB.LT.N ) THEN + INFO = -7 + ELSE IF( LDBX.LT.N ) THEN + INFO = -9 + ELSE IF( GIVPTR.LT.0 ) THEN + INFO = -11 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -13 + ELSE IF( LDGNUM.LT.N ) THEN + INFO = -15 + ELSE IF( K.LT.1 ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLALS0', -INFO ) + RETURN + END IF + * + M = N + SQRE + NLP1 = NL + 1 + * + IF( ICOMPQ.EQ.0 ) THEN + * + * Apply back orthogonal transformations from the left. + * + * Step (1L): apply back the Givens rotations performed. + * + DO 10 I = 1, GIVPTR + CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ GIVNUM( I, 1 ) ) + 10 CONTINUE + * + * Step (2L): permute rows of B. + * + CALL ZCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX ) + DO 20 I = 2, N + CALL ZCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX ) + 20 CONTINUE + * + * Step (3L): apply the inverse of the left singular vector + * matrix to BX. + * + IF( K.EQ.1 ) THEN + CALL ZCOPY( NRHS, BX, LDBX, B, LDB ) + IF( Z( 1 ).LT.ZERO ) THEN + CALL ZDSCAL( NRHS, NEGONE, B, LDB ) + END IF + ELSE + DO 100 J = 1, K + DIFLJ = DIFL( J ) + DJ = POLES( J, 1 ) + DSIGJ = -POLES( J, 2 ) + IF( J.LT.K ) THEN + DIFRJ = -DIFR( J, 1 ) + DSIGJP = -POLES( J+1, 2 ) + END IF + IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) ) + $ THEN + RWORK( J ) = ZERO + ELSE + RWORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ / + $ ( POLES( J, 2 )+DJ ) + END IF + DO 30 I = 1, J - 1 + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + RWORK( I ) = ZERO + ELSE + RWORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJ )- + $ DIFLJ ) / ( POLES( I, 2 )+DJ ) + END IF + 30 CONTINUE + DO 40 I = J + 1, K + IF( ( Z( I ).EQ.ZERO ) .OR. + $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN + RWORK( I ) = ZERO + ELSE + RWORK( I ) = POLES( I, 2 )*Z( I ) / + $ ( DLAMC3( POLES( I, 2 ), DSIGJP )+ + $ DIFRJ ) / ( POLES( I, 2 )+DJ ) + END IF + 40 CONTINUE + RWORK( 1 ) = NEGONE + TEMP = DNRM2( K, RWORK, 1 ) + * + * Since B and BX are complex, the following call to DGEMV + * is performed in two steps (real and imaginary parts). + * + * CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, + * $ B( J, 1 ), LDB ) + * + I = K + NRHS*2 + DO 60 JCOL = 1, NRHS + DO 50 JROW = 1, K + I = I + 1 + RWORK( I ) = DBLE( BX( JROW, JCOL ) ) + 50 CONTINUE + 60 CONTINUE + CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K, + $ RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 ) + I = K + NRHS*2 + DO 80 JCOL = 1, NRHS + DO 70 JROW = 1, K + I = I + 1 + RWORK( I ) = DIMAG( BX( JROW, JCOL ) ) + 70 CONTINUE + 80 CONTINUE + CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K, + $ RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 ) + DO 90 JCOL = 1, NRHS + B( J, JCOL ) = DCMPLX( RWORK( JCOL+K ), + $ RWORK( JCOL+K+NRHS ) ) + 90 CONTINUE + CALL ZLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ), + $ LDB, INFO ) + 100 CONTINUE + END IF + * + * Move the deflated rows of BX to B also. + * + IF( K.LT.MAX( M, N ) ) + $ CALL ZLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX, + $ B( K+1, 1 ), LDB ) + ELSE + * + * Apply back the right orthogonal transformations. + * + * Step (1R): apply back the new right singular vector matrix + * to B. + * + IF( K.EQ.1 ) THEN + CALL ZCOPY( NRHS, B, LDB, BX, LDBX ) + ELSE + DO 180 J = 1, K + DSIGJ = POLES( J, 2 ) + IF( Z( J ).EQ.ZERO ) THEN + RWORK( J ) = ZERO + ELSE + RWORK( J ) = -Z( J ) / DIFL( J ) / + $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 ) + END IF + DO 110 I = 1, J - 1 + IF( Z( J ).EQ.ZERO ) THEN + RWORK( I ) = ZERO + ELSE + RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1, + $ 2 ) )-DIFR( I, 1 ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 110 CONTINUE + DO 120 I = J + 1, K + IF( Z( J ).EQ.ZERO ) THEN + RWORK( I ) = ZERO + ELSE + RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I, + $ 2 ) )-DIFL( I ) ) / + $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 ) + END IF + 120 CONTINUE + * + * Since B and BX are complex, the following call to DGEMV + * is performed in two steps (real and imaginary parts). + * + * CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, + * $ BX( J, 1 ), LDBX ) + * + I = K + NRHS*2 + DO 140 JCOL = 1, NRHS + DO 130 JROW = 1, K + I = I + 1 + RWORK( I ) = DBLE( B( JROW, JCOL ) ) + 130 CONTINUE + 140 CONTINUE + CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K, + $ RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 ) + I = K + NRHS*2 + DO 160 JCOL = 1, NRHS + DO 150 JROW = 1, K + I = I + 1 + RWORK( I ) = DIMAG( B( JROW, JCOL ) ) + 150 CONTINUE + 160 CONTINUE + CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K, + $ RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 ) + DO 170 JCOL = 1, NRHS + BX( J, JCOL ) = DCMPLX( RWORK( JCOL+K ), + $ RWORK( JCOL+K+NRHS ) ) + 170 CONTINUE + 180 CONTINUE + END IF + * + * Step (2R): if SQRE = 1, apply back the rotation that is + * related to the right null space of the subproblem. + * + IF( SQRE.EQ.1 ) THEN + CALL ZCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX ) + CALL ZDROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S ) + END IF + IF( K.LT.MAX( M, N ) ) + $ CALL ZLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ), + $ LDBX ) + * + * Step (3R): permute rows of B. + * + CALL ZCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB ) + IF( SQRE.EQ.1 ) THEN + CALL ZCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB ) + END IF + DO 190 I = 2, N + CALL ZCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB ) + 190 CONTINUE + * + * Step (4R): apply back the Givens rotations performed. + * + DO 200 I = GIVPTR, 1, -1 + CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, + $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), + $ -GIVNUM( I, 1 ) ) + 200 CONTINUE + END IF + * + RETURN + * + * End of ZLALS0 + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlalsa.f octave-2.9.16/libcruft/lapack/zlalsa.f *** octave-2.9.15/libcruft/lapack/zlalsa.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlalsa.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,503 ---- + SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, + $ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, + $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, + $ IWORK, INFO ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, + $ SMLSIZ + * .. + * .. Array Arguments .. + INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), + $ K( * ), PERM( LDGCOL, * ) + DOUBLE PRECISION C( * ), DIFL( LDU, * ), DIFR( LDU, * ), + $ GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ), + $ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * ) + COMPLEX*16 B( LDB, * ), BX( LDBX, * ) + * .. + * + * Purpose + * ======= + * + * ZLALSA is an itermediate step in solving the least squares problem + * by computing the SVD of the coefficient matrix in compact form (The + * singular vectors are computed as products of simple orthorgonal + * matrices.). + * + * If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector + * matrix of an upper bidiagonal matrix to the right hand side; and if + * ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the + * right hand side. The singular vector matrices were generated in + * compact form by ZLALSA. + * + * Arguments + * ========= + * + * ICOMPQ (input) INTEGER + * Specifies whether the left or the right singular vector + * matrix is involved. + * = 0: Left singular vector matrix + * = 1: Right singular vector matrix + * + * SMLSIZ (input) INTEGER + * The maximum size of the subproblems at the bottom of the + * computation tree. + * + * N (input) INTEGER + * The row and column dimensions of the upper bidiagonal matrix. + * + * NRHS (input) INTEGER + * The number of columns of B and BX. NRHS must be at least 1. + * + * B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS ) + * On input, B contains the right hand sides of the least + * squares problem in rows 1 through M. + * On output, B contains the solution X in rows 1 through N. + * + * LDB (input) INTEGER + * The leading dimension of B in the calling subprogram. + * LDB must be at least max(1,MAX( M, N ) ). + * + * BX (output) COMPLEX*16 array, dimension ( LDBX, NRHS ) + * On exit, the result of applying the left or right singular + * vector matrix to B. + * + * LDBX (input) INTEGER + * The leading dimension of BX. + * + * U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). + * On entry, U contains the left singular vector matrices of all + * subproblems at the bottom level. + * + * LDU (input) INTEGER, LDU = > N. + * The leading dimension of arrays U, VT, DIFL, DIFR, + * POLES, GIVNUM, and Z. + * + * VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). + * On entry, VT' contains the right singular vector matrices of + * all subproblems at the bottom level. + * + * K (input) INTEGER array, dimension ( N ). + * + * DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). + * where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. + * + * DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). + * On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record + * distances between singular values on the I-th level and + * singular values on the (I -1)-th level, and DIFR(*, 2 * I) + * record the normalizing factors of the right singular vectors + * matrices of subproblems on I-th level. + * + * Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). + * On entry, Z(1, I) contains the components of the deflation- + * adjusted updating row vector for subproblems on the I-th + * level. + * + * POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). + * On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old + * singular values involved in the secular equations on the I-th + * level. + * + * GIVPTR (input) INTEGER array, dimension ( N ). + * On entry, GIVPTR( I ) records the number of Givens + * rotations performed on the I-th problem on the computation + * tree. + * + * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). + * On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the + * locations of Givens rotations performed on the I-th level on + * the computation tree. + * + * LDGCOL (input) INTEGER, LDGCOL = > N. + * The leading dimension of arrays GIVCOL and PERM. + * + * PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). + * On entry, PERM(*, I) records permutations done on the I-th + * level of the computation tree. + * + * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). + * On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- + * values of Givens rotations performed on the I-th level on the + * computation tree. + * + * C (input) DOUBLE PRECISION array, dimension ( N ). + * On entry, if the I-th subproblem is not square, + * C( I ) contains the C-value of a Givens rotation related to + * the right null space of the I-th subproblem. + * + * S (input) DOUBLE PRECISION array, dimension ( N ). + * On entry, if the I-th subproblem is not square, + * S( I ) contains the S-value of a Givens rotation related to + * the right null space of the I-th subproblem. + * + * RWORK (workspace) DOUBLE PRECISION array, dimension at least + * max ( N, (SMLSZ+1)*NRHS*3 ). + * + * IWORK (workspace) INTEGER array. + * The dimension must be at least 3 * N + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + * .. + * .. Local Scalars .. + INTEGER I, I1, IC, IM1, INODE, J, JCOL, JIMAG, JREAL, + $ JROW, LF, LL, LVL, LVL2, ND, NDB1, NDIML, + $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQRE + * .. + * .. External Subroutines .. + EXTERNAL DGEMM, DLASDT, XERBLA, ZCOPY, ZLALS0 + * .. + * .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN + INFO = -1 + ELSE IF( SMLSIZ.LT.3 ) THEN + INFO = -2 + ELSE IF( N.LT.SMLSIZ ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( LDB.LT.N ) THEN + INFO = -6 + ELSE IF( LDBX.LT.N ) THEN + INFO = -8 + ELSE IF( LDU.LT.N ) THEN + INFO = -10 + ELSE IF( LDGCOL.LT.N ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLALSA', -INFO ) + RETURN + END IF + * + * Book-keeping and setting up the computation tree. + * + INODE = 1 + NDIML = INODE + N + NDIMR = NDIML + N + * + CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), + $ IWORK( NDIMR ), SMLSIZ ) + * + * The following code applies back the left singular vector factors. + * For applying back the right singular vector factors, go to 170. + * + IF( ICOMPQ.EQ.1 ) THEN + GO TO 170 + END IF + * + * The nodes on the bottom level of the tree were solved + * by DLASDQ. The corresponding left and right singular vector + * matrices are in explicit form. First apply back the left + * singular vector matrices. + * + NDB1 = ( ND+1 ) / 2 + DO 130 I = NDB1, ND + * + * IC : center row of each node + * NL : number of rows of left subproblem + * NR : number of rows of right subproblem + * NLF: starting row of the left subproblem + * NRF: starting row of the right subproblem + * + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLF = IC - NL + NRF = IC + 1 + * + * Since B and BX are complex, the following call to DGEMM + * is performed in two steps (real and imaginary parts). + * + * CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, + * $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + * + J = NL*NRHS*2 + DO 20 JCOL = 1, NRHS + DO 10 JROW = NLF, NLF + NL - 1 + J = J + 1 + RWORK( J ) = DBLE( B( JROW, JCOL ) ) + 10 CONTINUE + 20 CONTINUE + CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, + $ RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1 ), NL ) + J = NL*NRHS*2 + DO 40 JCOL = 1, NRHS + DO 30 JROW = NLF, NLF + NL - 1 + J = J + 1 + RWORK( J ) = DIMAG( B( JROW, JCOL ) ) + 30 CONTINUE + 40 CONTINUE + CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, + $ RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1+NL*NRHS ), + $ NL ) + JREAL = 0 + JIMAG = NL*NRHS + DO 60 JCOL = 1, NRHS + DO 50 JROW = NLF, NLF + NL - 1 + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 50 CONTINUE + 60 CONTINUE + * + * Since B and BX are complex, the following call to DGEMM + * is performed in two steps (real and imaginary parts). + * + * CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, + * $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + * + J = NR*NRHS*2 + DO 80 JCOL = 1, NRHS + DO 70 JROW = NRF, NRF + NR - 1 + J = J + 1 + RWORK( J ) = DBLE( B( JROW, JCOL ) ) + 70 CONTINUE + 80 CONTINUE + CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, + $ RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1 ), NR ) + J = NR*NRHS*2 + DO 100 JCOL = 1, NRHS + DO 90 JROW = NRF, NRF + NR - 1 + J = J + 1 + RWORK( J ) = DIMAG( B( JROW, JCOL ) ) + 90 CONTINUE + 100 CONTINUE + CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, + $ RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1+NR*NRHS ), + $ NR ) + JREAL = 0 + JIMAG = NR*NRHS + DO 120 JCOL = 1, NRHS + DO 110 JROW = NRF, NRF + NR - 1 + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 110 CONTINUE + 120 CONTINUE + * + 130 CONTINUE + * + * Next copy the rows of B that correspond to unchanged rows + * in the bidiagonal matrix to BX. + * + DO 140 I = 1, ND + IC = IWORK( INODE+I-1 ) + CALL ZCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX ) + 140 CONTINUE + * + * Finally go through the left singular vector matrices of all + * the other subproblems bottom-up on the tree. + * + J = 2**NLVL + SQRE = 0 + * + DO 160 LVL = NLVL, 1, -1 + LVL2 = 2*LVL - 1 + * + * find the first node LF and last node LL on + * the current level LVL + * + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 150 I = LF, LL + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + J = J - 1 + CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX, + $ B( NLF, 1 ), LDB, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK, + $ INFO ) + 150 CONTINUE + 160 CONTINUE + GO TO 330 + * + * ICOMPQ = 1: applying back the right singular vector factors. + * + 170 CONTINUE + * + * First now go through the right singular vector matrices of all + * the tree nodes top-down. + * + J = 0 + DO 190 LVL = 1, NLVL + LVL2 = 2*LVL - 1 + * + * Find the first node LF and last node LL on + * the current level LVL. + * + IF( LVL.EQ.1 ) THEN + LF = 1 + LL = 1 + ELSE + LF = 2**( LVL-1 ) + LL = 2*LF - 1 + END IF + DO 180 I = LL, LF, -1 + IM1 = I - 1 + IC = IWORK( INODE+IM1 ) + NL = IWORK( NDIML+IM1 ) + NR = IWORK( NDIMR+IM1 ) + NLF = IC - NL + NRF = IC + 1 + IF( I.EQ.LL ) THEN + SQRE = 0 + ELSE + SQRE = 1 + END IF + J = J + 1 + CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB, + $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ), + $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, + $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), + $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), + $ Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK, + $ INFO ) + 180 CONTINUE + 190 CONTINUE + * + * The nodes on the bottom level of the tree were solved + * by DLASDQ. The corresponding right singular vector + * matrices are in explicit form. Apply them back. + * + NDB1 = ( ND+1 ) / 2 + DO 320 I = NDB1, ND + I1 = I - 1 + IC = IWORK( INODE+I1 ) + NL = IWORK( NDIML+I1 ) + NR = IWORK( NDIMR+I1 ) + NLP1 = NL + 1 + IF( I.EQ.ND ) THEN + NRP1 = NR + ELSE + NRP1 = NR + 1 + END IF + NLF = IC - NL + NRF = IC + 1 + * + * Since B and BX are complex, the following call to DGEMM is + * performed in two steps (real and imaginary parts). + * + * CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, + * $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) + * + J = NLP1*NRHS*2 + DO 210 JCOL = 1, NRHS + DO 200 JROW = NLF, NLF + NLP1 - 1 + J = J + 1 + RWORK( J ) = DBLE( B( JROW, JCOL ) ) + 200 CONTINUE + 210 CONTINUE + CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, + $ RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO, RWORK( 1 ), + $ NLP1 ) + J = NLP1*NRHS*2 + DO 230 JCOL = 1, NRHS + DO 220 JROW = NLF, NLF + NLP1 - 1 + J = J + 1 + RWORK( J ) = DIMAG( B( JROW, JCOL ) ) + 220 CONTINUE + 230 CONTINUE + CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, + $ RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO, + $ RWORK( 1+NLP1*NRHS ), NLP1 ) + JREAL = 0 + JIMAG = NLP1*NRHS + DO 250 JCOL = 1, NRHS + DO 240 JROW = NLF, NLF + NLP1 - 1 + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 240 CONTINUE + 250 CONTINUE + * + * Since B and BX are complex, the following call to DGEMM is + * performed in two steps (real and imaginary parts). + * + * CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, + * $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) + * + J = NRP1*NRHS*2 + DO 270 JCOL = 1, NRHS + DO 260 JROW = NRF, NRF + NRP1 - 1 + J = J + 1 + RWORK( J ) = DBLE( B( JROW, JCOL ) ) + 260 CONTINUE + 270 CONTINUE + CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, + $ RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO, RWORK( 1 ), + $ NRP1 ) + J = NRP1*NRHS*2 + DO 290 JCOL = 1, NRHS + DO 280 JROW = NRF, NRF + NRP1 - 1 + J = J + 1 + RWORK( J ) = DIMAG( B( JROW, JCOL ) ) + 280 CONTINUE + 290 CONTINUE + CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, + $ RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO, + $ RWORK( 1+NRP1*NRHS ), NRP1 ) + JREAL = 0 + JIMAG = NRP1*NRHS + DO 310 JCOL = 1, NRHS + DO 300 JROW = NRF, NRF + NRP1 - 1 + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 300 CONTINUE + 310 CONTINUE + * + 320 CONTINUE + * + 330 CONTINUE + * + RETURN + * + * End of ZLALSA + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlalsd.f octave-2.9.16/libcruft/lapack/zlalsd.f *** octave-2.9.15/libcruft/lapack/zlalsd.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlalsd.f Fri Oct 26 11:52:58 2007 *************** *** 0 **** --- 1,600 ---- + SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, + $ RANK, WORK, RWORK, IWORK, INFO ) + * + * -- LAPACK routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ + DOUBLE PRECISION RCOND + * .. + * .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), RWORK( * ) + COMPLEX*16 B( LDB, * ), WORK( * ) + * .. + * + * Purpose + * ======= + * + * ZLALSD uses the singular value decomposition of A to solve the least + * squares problem of finding X to minimize the Euclidean norm of each + * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B + * are N-by-NRHS. The solution X overwrites B. + * + * The singular values of A smaller than RCOND times the largest + * singular value are treated as zero in solving the least squares + * problem; in this case a minimum norm solution is returned. + * The actual singular values are returned in D in ascending order. + * + * This code makes very mild assumptions about floating point + * arithmetic. It will work on machines with a guard digit in + * add/subtract, or on those binary machines without guard digits + * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. + * It could conceivably fail on hexadecimal or decimal machines + * without guard digits, but we know of none. + * + * Arguments + * ========= + * + * UPLO (input) CHARACTER*1 + * = 'U': D and E define an upper bidiagonal matrix. + * = 'L': D and E define a lower bidiagonal matrix. + * + * SMLSIZ (input) INTEGER + * The maximum size of the subproblems at the bottom of the + * computation tree. + * + * N (input) INTEGER + * The dimension of the bidiagonal matrix. N >= 0. + * + * NRHS (input) INTEGER + * The number of columns of B. NRHS must be at least 1. + * + * D (input/output) DOUBLE PRECISION array, dimension (N) + * On entry D contains the main diagonal of the bidiagonal + * matrix. On exit, if INFO = 0, D contains its singular values. + * + * E (input/output) DOUBLE PRECISION array, dimension (N-1) + * Contains the super-diagonal entries of the bidiagonal matrix. + * On exit, E has been destroyed. + * + * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) + * On input, B contains the right hand sides of the least + * squares problem. On output, B contains the solution X. + * + * LDB (input) INTEGER + * The leading dimension of B in the calling subprogram. + * LDB must be at least max(1,N). + * + * RCOND (input) DOUBLE PRECISION + * The singular values of A less than or equal to RCOND times + * the largest singular value are treated as zero in solving + * the least squares problem. If RCOND is negative, + * machine precision is used instead. + * For example, if diag(S)*X=B were the least squares problem, + * where diag(S) is a diagonal matrix of singular values, the + * solution would be X(i) = B(i) / S(i) if S(i) is greater than + * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to + * RCOND*max(S). + * + * RANK (output) INTEGER + * The number of singular values of A greater than RCOND times + * the largest singular value. + * + * WORK (workspace) COMPLEX*16 array, dimension at least + * (N * NRHS). + * + * RWORK (workspace) DOUBLE PRECISION array, dimension at least + * (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2), + * where + * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) + * + * IWORK (workspace) INTEGER array, dimension at least + * (3*N*NLVL + 11*N). + * + * INFO (output) INTEGER + * = 0: successful exit. + * < 0: if INFO = -i, the i-th argument had an illegal value. + * > 0: The algorithm failed to compute an singular value while + * working on the submatrix lying in rows and columns + * INFO/(N+1) through MOD(INFO,N+1). + * + * Further Details + * =============== + * + * Based on contributions by + * Ming Gu and Ren-Cang Li, Computer Science Division, University of + * California at Berkeley, USA + * Osni Marques, LBNL/NERSC, USA + * + * ===================================================================== + * + * .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) + * .. + * .. Local Scalars .. + INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM, + $ GIVPTR, I, ICMPQ1, ICMPQ2, IRWB, IRWIB, IRWRB, + $ IRWU, IRWVT, IRWWRK, IWK, J, JCOL, JIMAG, + $ JREAL, JROW, K, NLVL, NM1, NRWORK, NSIZE, NSUB, + $ PERM, POLES, S, SIZEI, SMLSZP, SQRE, ST, ST1, + $ U, VT, Z + DOUBLE PRECISION CS, EPS, ORGNRM, RCND, R, SN, TOL + * .. + * .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL IDAMAX, DLAMCH, DLANST + * .. + * .. External Subroutines .. + EXTERNAL DGEMM, DLARTG, DLASCL, DLASDA, DLASDQ, DLASET, + $ DLASRT, XERBLA, ZCOPY, ZDROT, ZLACPY, ZLALSA, + $ ZLASCL, ZLASET + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, LOG, SIGN + * .. + * .. Executable Statements .. + * + * Test the input parameters. + * + INFO = 0 + * + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.1 ) THEN + INFO = -4 + ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLALSD', -INFO ) + RETURN + END IF + * + EPS = DLAMCH( 'Epsilon' ) + * + * Set up the tolerance. + * + IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN + RCND = EPS + ELSE + RCND = RCOND + END IF + * + RANK = 0 + * + * Quick return if possible. + * + IF( N.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN + IF( D( 1 ).EQ.ZERO ) THEN + CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B, LDB ) + ELSE + RANK = 1 + CALL ZLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO ) + D( 1 ) = ABS( D( 1 ) ) + END IF + RETURN + END IF + * + * Rotate the matrix if it is lower bidiagonal. + * + IF( UPLO.EQ.'L' ) THEN + DO 10 I = 1, N - 1 + CALL DLARTG( D( I ), E( I ), CS, SN, R ) + D( I ) = R + E( I ) = SN*D( I+1 ) + D( I+1 ) = CS*D( I+1 ) + IF( NRHS.EQ.1 ) THEN + CALL ZDROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN ) + ELSE + RWORK( I*2-1 ) = CS + RWORK( I*2 ) = SN + END IF + 10 CONTINUE + IF( NRHS.GT.1 ) THEN + DO 30 I = 1, NRHS + DO 20 J = 1, N - 1 + CS = RWORK( J*2-1 ) + SN = RWORK( J*2 ) + CALL ZDROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN ) + 20 CONTINUE + 30 CONTINUE + END IF + END IF + * + * Scale. + * + NM1 = N - 1 + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.EQ.ZERO ) THEN + CALL ZLASET( 'A', N, NRHS, CZERO, CZERO, B, LDB ) + RETURN + END IF + * + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO ) + * + * If N is smaller than the minimum divide size SMLSIZ, then solve + * the problem with another solver. + * + IF( N.LE.SMLSIZ ) THEN + IRWU = 1 + IRWVT = IRWU + N*N + IRWWRK = IRWVT + N*N + IRWRB = IRWWRK + IRWIB = IRWRB + N*NRHS + IRWB = IRWIB + N*NRHS + CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWU ), N ) + CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWVT ), N ) + CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, RWORK( IRWVT ), N, + $ RWORK( IRWU ), N, RWORK( IRWWRK ), 1, + $ RWORK( IRWWRK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + * + * In the real version, B is passed to DLASDQ and multiplied + * internally by Q'. Here B is complex and that product is + * computed below in two steps (real and imaginary parts). + * + J = IRWB - 1 + DO 50 JCOL = 1, NRHS + DO 40 JROW = 1, N + J = J + 1 + RWORK( J ) = DBLE( B( JROW, JCOL ) ) + 40 CONTINUE + 50 CONTINUE + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N, + $ RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N ) + J = IRWB - 1 + DO 70 JCOL = 1, NRHS + DO 60 JROW = 1, N + J = J + 1 + RWORK( J ) = DIMAG( B( JROW, JCOL ) ) + 60 CONTINUE + 70 CONTINUE + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N, + $ RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N ) + JREAL = IRWRB - 1 + JIMAG = IRWIB - 1 + DO 90 JCOL = 1, NRHS + DO 80 JROW = 1, N + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 80 CONTINUE + 90 CONTINUE + * + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) + DO 100 I = 1, N + IF( D( I ).LE.TOL ) THEN + CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB ) + ELSE + CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ), + $ LDB, INFO ) + RANK = RANK + 1 + END IF + 100 CONTINUE + * + * Since B is complex, the following call to DGEMM is performed + * in two steps (real and imaginary parts). That is for V * B + * (in the real version of the code V' is stored in WORK). + * + * CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, + * $ WORK( NWORK ), N ) + * + J = IRWB - 1 + DO 120 JCOL = 1, NRHS + DO 110 JROW = 1, N + J = J + 1 + RWORK( J ) = DBLE( B( JROW, JCOL ) ) + 110 CONTINUE + 120 CONTINUE + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N, + $ RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N ) + J = IRWB - 1 + DO 140 JCOL = 1, NRHS + DO 130 JROW = 1, N + J = J + 1 + RWORK( J ) = DIMAG( B( JROW, JCOL ) ) + 130 CONTINUE + 140 CONTINUE + CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N, + $ RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N ) + JREAL = IRWRB - 1 + JIMAG = IRWIB - 1 + DO 160 JCOL = 1, NRHS + DO 150 JROW = 1, N + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 150 CONTINUE + 160 CONTINUE + * + * Unscale. + * + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) + * + RETURN + END IF + * + * Book-keeping and setting up some constants. + * + NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1 + * + SMLSZP = SMLSIZ + 1 + * + U = 1 + VT = 1 + SMLSIZ*N + DIFL = VT + SMLSZP*N + DIFR = DIFL + NLVL*N + Z = DIFR + NLVL*N*2 + C = Z + NLVL*N + S = C + N + POLES = S + N + GIVNUM = POLES + 2*NLVL*N + NRWORK = GIVNUM + 2*NLVL*N + BX = 1 + * + IRWRB = NRWORK + IRWIB = IRWRB + SMLSIZ*NRHS + IRWB = IRWIB + SMLSIZ*NRHS + * + SIZEI = 1 + N + K = SIZEI + N + GIVPTR = K + N + PERM = GIVPTR + N + GIVCOL = PERM + NLVL*N + IWK = GIVCOL + NLVL*N*2 + * + ST = 1 + SQRE = 0 + ICMPQ1 = 1 + ICMPQ2 = 0 + NSUB = 0 + * + DO 170 I = 1, N + IF( ABS( D( I ) ).LT.EPS ) THEN + D( I ) = SIGN( EPS, D( I ) ) + END IF + 170 CONTINUE + * + DO 240 I = 1, NM1 + IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN + NSUB = NSUB + 1 + IWORK( NSUB ) = ST + * + * Subproblem found. First determine its size and then + * apply divide and conquer on it. + * + IF( I.LT.NM1 ) THEN + * + * A subproblem with E(I) small for I < NM1. + * + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE IF( ABS( E( I ) ).GE.EPS ) THEN + * + * A subproblem with E(NM1) not too small but I = NM1. + * + NSIZE = N - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + ELSE + * + * A subproblem with E(NM1) small. This implies an + * 1-by-1 subproblem at D(N), which is not solved + * explicitly. + * + NSIZE = I - ST + 1 + IWORK( SIZEI+NSUB-1 ) = NSIZE + NSUB = NSUB + 1 + IWORK( NSUB ) = N + IWORK( SIZEI+NSUB-1 ) = 1 + CALL ZCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N ) + END IF + ST1 = ST - 1 + IF( NSIZE.EQ.1 ) THEN + * + * This is a 1-by-1 subproblem and is not solved + * explicitly. + * + CALL ZCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN + * + * This is a small subproblem and is solved by DLASDQ. + * + CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, + $ RWORK( VT+ST1 ), N ) + CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, + $ RWORK( U+ST1 ), N ) + CALL DLASDQ( 'U', 0, NSIZE, NSIZE, NSIZE, 0, D( ST ), + $ E( ST ), RWORK( VT+ST1 ), N, RWORK( U+ST1 ), + $ N, RWORK( NRWORK ), 1, RWORK( NRWORK ), + $ INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + * + * In the real version, B is passed to DLASDQ and multiplied + * internally by Q'. Here B is complex and that product is + * computed below in two steps (real and imaginary parts). + * + J = IRWB - 1 + DO 190 JCOL = 1, NRHS + DO 180 JROW = ST, ST + NSIZE - 1 + J = J + 1 + RWORK( J ) = DBLE( B( JROW, JCOL ) ) + 180 CONTINUE + 190 CONTINUE + CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + $ RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE, + $ ZERO, RWORK( IRWRB ), NSIZE ) + J = IRWB - 1 + DO 210 JCOL = 1, NRHS + DO 200 JROW = ST, ST + NSIZE - 1 + J = J + 1 + RWORK( J ) = DIMAG( B( JROW, JCOL ) ) + 200 CONTINUE + 210 CONTINUE + CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + $ RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE, + $ ZERO, RWORK( IRWIB ), NSIZE ) + JREAL = IRWRB - 1 + JIMAG = IRWIB - 1 + DO 230 JCOL = 1, NRHS + DO 220 JROW = ST, ST + NSIZE - 1 + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 220 CONTINUE + 230 CONTINUE + * + CALL ZLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB, + $ WORK( BX+ST1 ), N ) + ELSE + * + * A large problem. Solve it using divide and conquer. + * + CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ), + $ E( ST ), RWORK( U+ST1 ), N, RWORK( VT+ST1 ), + $ IWORK( K+ST1 ), RWORK( DIFL+ST1 ), + $ RWORK( DIFR+ST1 ), RWORK( Z+ST1 ), + $ RWORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ), + $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ), + $ RWORK( GIVNUM+ST1 ), RWORK( C+ST1 ), + $ RWORK( S+ST1 ), RWORK( NRWORK ), + $ IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + BXST = BX + ST1 + CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ), + $ LDB, WORK( BXST ), N, RWORK( U+ST1 ), N, + $ RWORK( VT+ST1 ), IWORK( K+ST1 ), + $ RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ), + $ RWORK( Z+ST1 ), RWORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ), + $ RWORK( C+ST1 ), RWORK( S+ST1 ), + $ RWORK( NRWORK ), IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + ST = I + 1 + END IF + 240 CONTINUE + * + * Apply the singular values and treat the tiny ones as zero. + * + TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) ) + * + DO 250 I = 1, N + * + * Some of the elements in D can be negative because 1-by-1 + * subproblems were not solved explicitly. + * + IF( ABS( D( I ) ).LE.TOL ) THEN + CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, WORK( BX+I-1 ), N ) + ELSE + RANK = RANK + 1 + CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, + $ WORK( BX+I-1 ), N, INFO ) + END IF + D( I ) = ABS( D( I ) ) + 250 CONTINUE + * + * Now apply back the right singular vectors. + * + ICMPQ2 = 1 + DO 320 I = 1, NSUB + ST = IWORK( I ) + ST1 = ST - 1 + NSIZE = IWORK( SIZEI+I-1 ) + BXST = BX + ST1 + IF( NSIZE.EQ.1 ) THEN + CALL ZCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB ) + ELSE IF( NSIZE.LE.SMLSIZ ) THEN + * + * Since B and BX are complex, the following call to DGEMM + * is performed in two steps (real and imaginary parts). + * + * CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + * $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO, + * $ B( ST, 1 ), LDB ) + * + J = BXST - N - 1 + JREAL = IRWB - 1 + DO 270 JCOL = 1, NRHS + J = J + N + DO 260 JROW = 1, NSIZE + JREAL = JREAL + 1 + RWORK( JREAL ) = DBLE( WORK( J+JROW ) ) + 260 CONTINUE + 270 CONTINUE + CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + $ RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO, + $ RWORK( IRWRB ), NSIZE ) + J = BXST - N - 1 + JIMAG = IRWB - 1 + DO 290 JCOL = 1, NRHS + J = J + N + DO 280 JROW = 1, NSIZE + JIMAG = JIMAG + 1 + RWORK( JIMAG ) = DIMAG( WORK( J+JROW ) ) + 280 CONTINUE + 290 CONTINUE + CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, + $ RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO, + $ RWORK( IRWIB ), NSIZE ) + JREAL = IRWRB - 1 + JIMAG = IRWIB - 1 + DO 310 JCOL = 1, NRHS + DO 300 JROW = ST, ST + NSIZE - 1 + JREAL = JREAL + 1 + JIMAG = JIMAG + 1 + B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ), + $ RWORK( JIMAG ) ) + 300 CONTINUE + 310 CONTINUE + ELSE + CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N, + $ B( ST, 1 ), LDB, RWORK( U+ST1 ), N, + $ RWORK( VT+ST1 ), IWORK( K+ST1 ), + $ RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ), + $ RWORK( Z+ST1 ), RWORK( POLES+ST1 ), + $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, + $ IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ), + $ RWORK( C+ST1 ), RWORK( S+ST1 ), + $ RWORK( NRWORK ), IWORK( IWK ), INFO ) + IF( INFO.NE.0 ) THEN + RETURN + END IF + END IF + 320 CONTINUE + * + * Unscale and sort the singular values. + * + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) + CALL DLASRT( 'D', N, D, INFO ) + CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO ) + * + RETURN + * + * End of ZLALSD + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlange.f octave-2.9.16/libcruft/lapack/zlange.f *** octave-2.9.15/libcruft/lapack/zlange.f Wed Nov 3 14:54:41 1999 --- octave-2.9.16/libcruft/lapack/zlange.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM --- 1,8 ---- DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER NORM *************** *** 37,43 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 36,42 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 60,66 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * --- 59,65 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * diff -cNr octave-2.9.15/libcruft/lapack/zlanhe.f octave-2.9.16/libcruft/lapack/zlanhe.f *** octave-2.9.15/libcruft/lapack/zlanhe.f Wed Nov 3 14:54:42 1999 --- octave-2.9.16/libcruft/lapack/zlanhe.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM, UPLO --- 1,8 ---- DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER NORM, UPLO *************** *** 37,43 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 36,42 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 69,75 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * --- 68,74 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * diff -cNr octave-2.9.15/libcruft/lapack/zlanhs.f octave-2.9.16/libcruft/lapack/zlanhs.f *** octave-2.9.15/libcruft/lapack/zlanhs.f Wed Nov 3 14:54:42 1999 --- octave-2.9.16/libcruft/lapack/zlanhs.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM --- 1,8 ---- DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER NORM *************** *** 37,43 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 36,42 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 57,63 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * --- 56,62 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * diff -cNr octave-2.9.15/libcruft/lapack/zlantr.f octave-2.9.16/libcruft/lapack/zlantr.f *** octave-2.9.15/libcruft/lapack/zlantr.f Mon May 22 01:45:46 2006 --- octave-2.9.16/libcruft/lapack/zlantr.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO --- 1,9 ---- DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO *************** *** 38,44 **** * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= --- 37,43 ---- * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of ! * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. * * Arguments * ========= *************** *** 80,86 **** * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * --- 79,85 ---- * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * ! * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * diff -cNr octave-2.9.15/libcruft/lapack/zlaqr0.f octave-2.9.16/libcruft/lapack/zlaqr0.f *** octave-2.9.15/libcruft/lapack/zlaqr0.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlaqr0.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,601 ---- + SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) + * .. + * + * Purpose + * ======= + * + * ZLAQR0 computes the eigenvalues of a Hessenberg matrix H + * and, optionally, the matrices T and Z from the Schur decomposition + * H = Z T Z**H, where T is an upper triangular matrix (the + * Schur form), and Z is the unitary matrix of Schur vectors. + * + * Optionally Z may be postmultiplied into an input unitary + * matrix Q so that this routine can give the Schur factorization + * of a matrix A which has been reduced to the Hessenberg form H + * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. + * + * Arguments + * ========= + * + * WANTT (input) LOGICAL + * = .TRUE. : the full Schur form T is required; + * = .FALSE.: only eigenvalues are required. + * + * WANTZ (input) LOGICAL + * = .TRUE. : the matrix of Schur vectors Z is required; + * = .FALSE.: Schur vectors are not required. + * + * N (input) INTEGER + * The order of the matrix H. N .GE. 0. + * + * ILO (input) INTEGER + * IHI (input) INTEGER + * It is assumed that H is already upper triangular in rows + * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, + * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a + * previous call to ZGEBAL, and then passed to ZGEHRD when the + * matrix output by ZGEBAL is reduced to Hessenberg form. + * Otherwise, ILO and IHI should be set to 1 and N, + * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. + * If N = 0, then ILO = 1 and IHI = 0. + * + * H (input/output) COMPLEX*16 array, dimension (LDH,N) + * On entry, the upper Hessenberg matrix H. + * On exit, if INFO = 0 and WANTT is .TRUE., then H + * contains the upper triangular matrix T from the Schur + * decomposition (the Schur form). If INFO = 0 and WANT is + * .FALSE., then the contents of H are unspecified on exit. + * (The output value of H when INFO.GT.0 is given under the + * description of INFO below.) + * + * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and + * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. + * + * LDH (input) INTEGER + * The leading dimension of the array H. LDH .GE. max(1,N). + * + * W (output) COMPLEX*16 array, dimension (N) + * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored + * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are + * stored in the same order as on the diagonal of the Schur + * form returned in H, with W(i) = H(i,i). + * + * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) + * If WANTZ is .FALSE., then Z is not referenced. + * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is + * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the + * orthogonal Schur factor of H(ILO:IHI,ILO:IHI). + * (The output value of Z when INFO.GT.0 is given under + * the description of INFO below.) + * + * LDZ (input) INTEGER + * The leading dimension of the array Z. if WANTZ is .TRUE. + * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. + * + * WORK (workspace/output) COMPLEX*16 array, dimension LWORK + * On exit, if LWORK = -1, WORK(1) returns an estimate of + * the optimal value for LWORK. + * + * LWORK (input) INTEGER + * The dimension of the array WORK. LWORK .GE. max(1,N) + * is sufficient, but LWORK typically as large as 6*N may + * be required for optimal performance. A workspace query + * to determine the optimal workspace size is recommended. + * + * If LWORK = -1, then ZLAQR0 does a workspace query. + * In this case, ZLAQR0 checks the input parameters and + * estimates the optimal workspace size for the given + * values of N, ILO and IHI. The estimate is returned + * in WORK(1). No error message related to LWORK is + * issued by XERBLA. Neither H nor Z are accessed. + * + * + * INFO (output) INTEGER + * = 0: successful exit + * .GT. 0: if INFO = i, ZLAQR0 failed to compute all of + * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR + * and WI contain those eigenvalues which have been + * successfully computed. (Failures are rare.) + * + * If INFO .GT. 0 and WANT is .FALSE., then on exit, + * the remaining unconverged eigenvalues are the eigen- + * values of the upper Hessenberg matrix rows and + * columns ILO through INFO of the final, output + * value of H. + * + * If INFO .GT. 0 and WANTT is .TRUE., then on exit + * + * (*) (initial value of H)*U = U*(final value of H) + * + * where U is a unitary matrix. The final + * value of H is upper Hessenberg and triangular in + * rows and columns INFO+1 through IHI. + * + * If INFO .GT. 0 and WANTZ is .TRUE., then on exit + * + * (final value of Z(ILO:IHI,ILOZ:IHIZ) + * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U + * + * where U is the unitary matrix in (*) (regard- + * less of the value of WANTT.) + * + * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not + * accessed. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================ + * References: + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + * Performance, SIAM Journal of Matrix Analysis, volume 23, pages + * 929--947, 2002. + * + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part II: Aggressive Early Deflation, SIAM Journal + * of Matrix Analysis, volume 23, pages 948--973, 2002. + * + * ================================================================ + * .. Parameters .. + * + * ==== Matrices of order NTINY or smaller must be processed by + * . ZLAHQR because of insufficient subdiagonal scratch space. + * . (This is a hard limit.) ==== + * + * ==== Exceptional deflation windows: try to cure rare + * . slow convergence by increasing the size of the + * . deflation window after KEXNW iterations. ===== + * + * ==== Exceptional shifts: try to cure rare slow convergence + * . with ad-hoc exceptional shifts every KEXSH iterations. + * . The constants WILK1 and WILK2 are used to form the + * . exceptional shifts. ==== + * + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) + * .. + * .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 + * .. + * .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV + * .. + * .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) + * .. + * .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT + * .. + * .. Statement Functions .. + DOUBLE PRECISION CABS1 + * .. + * .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) + * .. + * .. Executable Statements .. + INFO = 0 + * + * ==== Quick return for N = 0: nothing to do. ==== + * + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF + * + * ==== Set up job flags for ILAENV. ==== + * + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF + * + * ==== Tiny matrices must use ZLAHQR. ==== + * + IF( N.LE.NTINY ) THEN + * + * ==== Estimate optimal workspace. ==== + * + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE + * + * ==== Use small bulge multi-shift QR with aggressive early + * . deflation on larger-than-tiny matrices. ==== + * + * ==== Hope for the best. ==== + * + INFO = 0 + * + * ==== NWR = recommended deflation window size. At this + * . point, N .GT. NTINY = 11, so there is enough + * . subdiagonal workspace for NWR.GE.2 as required. + * . (In fact, there is enough subdiagonal space for + * . NWR.GE.3.) ==== + * + NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR + * + * ==== NSR = recommended number of simultaneous shifts. + * . At this point N .GT. NTINY = 11, so there is at + * . enough subdiagonal workspace for NSR to be even + * . and greater than or equal to two as required. ==== + * + NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) + * + * ==== Estimate optimal workspace ==== + * + * ==== Workspace query call to ZLAQR3 ==== + * + CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) + * + * ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== + * + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF + * + * ==== ZLAHQR/ZLAQR0 crossover point ==== + * + NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) + * + * ==== Nibble crossover point ==== + * + NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) + * + * ==== Accumulate reflections during ttswp? Use block + * . 2-by-2 structure during matrix-matrix multiply? ==== + * + KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) + * + * ==== NWMAX = the largest possible deflation window for + * . which there is sufficient workspace. ==== + * + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + * + * ==== NSMAX = the Largest number of simultaneous shifts + * . for which there is sufficient workspace. ==== + * + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) + * + * ==== NDFL: an iteration count restarted at deflation. ==== + * + NDFL = 1 + * + * ==== ITMAX = iteration limit ==== + * + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) + * + * ==== Last row and column in the active block ==== + * + KBOT = IHI + * + * ==== Main Loop ==== + * + DO 70 IT = 1, ITMAX + * + * ==== Done when KBOT falls below ILO ==== + * + IF( KBOT.LT.ILO ) + $ GO TO 80 + * + * ==== Locate active block ==== + * + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K + * + * ==== Select deflation window size ==== + * + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN + * + * ==== Typical deflation window. If possible and + * . advisable, nibble the entire active block. + * . If not, use size NWR or NWR+1 depending upon + * . which has the smaller corresponding subdiagonal + * . entry (a heuristic). ==== + * + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE + * + * ==== Exceptional deflation window. If there have + * . been no deflations in KEXNW or more iterations, + * . then vary the deflation window size. At first, + * . because, larger windows are, in general, more + * . powerful than smaller ones, rapidly increase the + * . window up to the maximum reasonable and possible. + * . Then maybe try a slightly smaller window. ==== + * + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF + * + * ==== Aggressive early deflation: + * . split workspace under the subdiagonal into + * . - an nw-by-nw work array V in the lower + * . left-hand-corner, + * . - an NW-by-at-least-NW-but-more-is-better + * . (NW-by-NHO) horizontal work array along + * . the bottom edge, + * . - an at-least-NW-but-more-is-better (NHV-by-NW) + * . vertical work array along the left-hand-edge. + * . ==== + * + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 + * + * ==== Aggressive early deflation ==== + * + CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) + * + * ==== Adjust KBOT accounting for new deflations. ==== + * + KBOT = KBOT - LD + * + * ==== KS points to the shifts. ==== + * + KS = KBOT - LS + 1 + * + * ==== Skip an expensive QR sweep if there is a (partly + * . heuristic) reason to expect that many eigenvalues + * . will deflate without it. Here, the QR sweep is + * . skipped if many eigenvalues have just been deflated + * . or if the remaining active block is small. + * + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN + * + * ==== NS = nominal number of simultaneous shifts. + * . This may be lowered (slightly) if ZLAQR3 + * . did not provide that many shifts. ==== + * + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) + * + * ==== If there have been no deflations + * . in a multiple of KEXSH iterations, + * . then try exceptional shifts. + * . Otherwise use shifts provided by + * . ZLAQR3 above or from the eigenvalues + * . of a trailing principal submatrix. ==== + * + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE + * + * ==== Got NS/2 or fewer shifts? Use ZLAQR4 or + * . ZLAHQR on a trailing principal submatrix to + * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, + * . there is enough space below the subdiagonal + * . to fit an NS-by-NS scratch array.) ==== + * + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL ZLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, WORK, LWORK, INF ) + ELSE + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, INF ) + END IF + KS = KS + INF + * + * ==== In case of a rare QR failure use + * . eigenvalues of the trailing 2-by-2 + * . principal submatrix. Scale to avoid + * . overflows, underflows and subnormals. + * . (The scale factor S can not be zero, + * . because H(KBOT,KBOT-1) is nonzero.) ==== + * + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S + * + KS = KBOT - 1 + END IF + END IF + * + IF( KBOT-KS+1.GT.NS ) THEN + * + * ==== Sort the shifts (Helps a little) ==== + * + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF + * + * ==== If there are only two shifts, then use + * . only one. ==== + * + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF + * + * ==== Use up to NS of the the smallest magnatiude + * . shifts. If there aren't NS shifts available, + * . then use them all, possibly dropping one to + * . make the number of shifts even. ==== + * + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 + * + * ==== Small-bulge multi-shift QR sweep: + * . split workspace under the subdiagonal into + * . - a KDU-by-KDU work array U in the lower + * . left-hand-corner, + * . - a KDU-by-at-least-KDU-but-more-is-better + * . (KDU-by-NHo) horizontal work array WH along + * . the bottom edge, + * . - and an at-least-KDU-but-more-is-better-by-KDU + * . (NVE-by-KDU) vertical work WV arrow along + * . the left-hand-edge. ==== + * + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 + * + * ==== Small-bulge multi-shift QR sweep ==== + * + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF + * + * ==== Note progress (or the lack of it). ==== + * + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF + * + * ==== End of main loop ==== + 70 CONTINUE + * + * ==== Iteration limit exceeded. Set INFO to show where + * . the problem occurred and exit. ==== + * + INFO = KBOT + 80 CONTINUE + END IF + * + * ==== Return the optimal value of LWORK. ==== + * + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + * + * ==== End of ZLAQR0 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlaqr1.f octave-2.9.16/libcruft/lapack/zlaqr1.f *** octave-2.9.15/libcruft/lapack/zlaqr1.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlaqr1.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,97 ---- + SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + COMPLEX*16 S1, S2 + INTEGER LDH, N + * .. + * .. Array Arguments .. + COMPLEX*16 H( LDH, * ), V( * ) + * .. + * + * Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a + * scalar multiple of the first column of the product + * + * (*) K = (H - s1*I)*(H - s2*I) + * + * scaling to avoid overflows and most underflows. + * + * This is useful for starting double implicit shift bulges + * in the QR algorithm. + * + * + * N (input) integer + * Order of the matrix H. N must be either 2 or 3. + * + * H (input) COMPLEX*16 array of dimension (LDH,N) + * The 2-by-2 or 3-by-3 matrix H in (*). + * + * LDH (input) integer + * The leading dimension of H as declared in + * the calling procedure. LDH.GE.N + * + * S1 (input) COMPLEX*16 + * S2 S1 and S2 are the shifts defining K in (*) above. + * + * V (output) COMPLEX*16 array of dimension N + * A scalar multiple of the first column of the + * matrix K in (*). + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================ + * + * .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) + * .. + * .. Local Scalars .. + COMPLEX*16 CDUM + DOUBLE PRECISION H21S, H31S, S + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG + * .. + * .. Statement Functions .. + DOUBLE PRECISION CABS1 + * .. + * .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) + * .. + * .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + IF( S.EQ.RZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* + $ ( ( H( 1, 1 )-S2 ) / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + END IF + ELSE + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + + $ CABS1( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) + END IF + END IF + END diff -cNr octave-2.9.15/libcruft/lapack/zlaqr2.f octave-2.9.16/libcruft/lapack/zlaqr2.f *** octave-2.9.15/libcruft/lapack/zlaqr2.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlaqr2.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,437 ---- + SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) + * .. + * + * This subroutine is identical to ZLAQR3 except that it avoids + * recursion by calling ZLAHQR instead of ZLAQR4. + * + * + * ****************************************************************** + * Aggressive early deflation: + * + * This subroutine accepts as input an upper Hessenberg matrix + * H and performs an unitary similarity transformation + * designed to detect and deflate fully converged eigenvalues from + * a trailing principal submatrix. On output H has been over- + * written by a new Hessenberg matrix that is a perturbation of + * an unitary similarity transformation of H. It is to be + * hoped that the final version of H has many zero subdiagonal + * entries. + * + * ****************************************************************** + * WANTT (input) LOGICAL + * If .TRUE., then the Hessenberg matrix H is fully updated + * so that the triangular Schur factor may be + * computed (in cooperation with the calling subroutine). + * If .FALSE., then only enough of H is updated to preserve + * the eigenvalues. + * + * WANTZ (input) LOGICAL + * If .TRUE., then the unitary matrix Z is updated so + * so that the unitary Schur factor may be computed + * (in cooperation with the calling subroutine). + * If .FALSE., then Z is not referenced. + * + * N (input) INTEGER + * The order of the matrix H and (if WANTZ is .TRUE.) the + * order of the unitary matrix Z. + * + * KTOP (input) INTEGER + * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. + * KBOT and KTOP together determine an isolated block + * along the diagonal of the Hessenberg matrix. + * + * KBOT (input) INTEGER + * It is assumed without a check that either + * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together + * determine an isolated block along the diagonal of the + * Hessenberg matrix. + * + * NW (input) INTEGER + * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). + * + * H (input/output) COMPLEX*16 array, dimension (LDH,N) + * On input the initial N-by-N section of H stores the + * Hessenberg matrix undergoing aggressive early deflation. + * On output H has been transformed by a unitary + * similarity transformation, perturbed, and the returned + * to Hessenberg form that (it is to be hoped) has some + * zero subdiagonal entries. + * + * LDH (input) integer + * Leading dimension of H just as declared in the calling + * subroutine. N .LE. LDH + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. + * + * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) + * IF WANTZ is .TRUE., then on output, the unitary + * similarity transformation mentioned above has been + * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. + * If WANTZ is .FALSE., then Z is unreferenced. + * + * LDZ (input) integer + * The leading dimension of Z just as declared in the + * calling subroutine. 1 .LE. LDZ. + * + * NS (output) integer + * The number of unconverged (ie approximate) eigenvalues + * returned in SR and SI that may be used as shifts by the + * calling subroutine. + * + * ND (output) integer + * The number of converged eigenvalues uncovered by this + * subroutine. + * + * SH (output) COMPLEX*16 array, dimension KBOT + * On output, approximate eigenvalues that may + * be used for shifts are stored in SH(KBOT-ND-NS+1) + * through SR(KBOT-ND). Converged eigenvalues are + * stored in SH(KBOT-ND+1) through SH(KBOT). + * + * V (workspace) COMPLEX*16 array, dimension (LDV,NW) + * An NW-by-NW work array. + * + * LDV (input) integer scalar + * The leading dimension of V just as declared in the + * calling subroutine. NW .LE. LDV + * + * NH (input) integer scalar + * The number of columns of T. NH.GE.NW. + * + * T (workspace) COMPLEX*16 array, dimension (LDT,NW) + * + * LDT (input) integer + * The leading dimension of T just as declared in the + * calling subroutine. NW .LE. LDT + * + * NV (input) integer + * The number of rows of work array WV available for + * workspace. NV.GE.NW. + * + * WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) + * + * LDWV (input) integer + * The leading dimension of W just as declared in the + * calling subroutine. NW .LE. LDV + * + * WORK (workspace) COMPLEX*16 array, dimension LWORK. + * On exit, WORK(1) is set to an estimate of the optimal value + * of LWORK for the given values of N, NW, KTOP and KBOT. + * + * LWORK (input) integer + * The dimension of the work array WORK. LWORK = 2*NW + * suffices, but greater efficiency may result from larger + * values of LWORK. + * + * If LWORK = -1, then a workspace query is assumed; ZLAQR2 + * only estimates the optimal workspace size for the given + * values of N, NW, KTOP and KBOT. The estimate is returned + * in WORK(1). No error message related to LWORK is issued + * by XERBLA. Neither H nor Z are accessed. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================== + * .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) + * .. + * .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + * .. + * .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN + * .. + * .. Statement Functions .. + DOUBLE PRECISION CABS1 + * .. + * .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) + * .. + * .. Executable Statements .. + * + * ==== Estimate optimal workspace. ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE + * + * ==== Workspace query call to ZGEHRD ==== + * + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) + * + * ==== Workspace query call to ZUNGHR ==== + * + CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) + * + * ==== Optimal workspace ==== + * + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF + * + * ==== Nothing to do ... + * ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN + * ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN + * + * ==== Machine constants ==== + * + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) + * + * ==== Setup deflation window ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF + * + IF( KBOT.EQ.KWTOP ) THEN + * + * ==== 1-by-1 deflation window: not much to do ==== + * + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF + * + * ==== Convert to spike-triangular form. (In case of a + * . rare QR failure, this routine continues to do + * . aggressive early deflation using that part of + * . the deflation window that converged using INFQR + * . here and there to keep track.) ==== + * + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + * + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) + * + * ==== Deflation detection loop ==== + * + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW + * + * ==== Small spike tip deflation test ==== + * + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN + * + * ==== One more converged eigenvalue ==== + * + NS = NS - 1 + ELSE + * + * ==== One undflatable eigenvalue. Move it up out of the + * . way. (ZTREXC can not fail in this case.) ==== + * + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE + * + * ==== Return to Hessenberg form ==== + * + IF( NS.EQ.0 ) + $ S = ZERO + * + IF( NS.LT.JW ) THEN + * + * ==== sorting the diagonal of T improves accuracy for + * . graded matrices. ==== + * + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF + * + * ==== Restore shift/eigenvalue array from T ==== + * + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE + * + * + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + * + * ==== Reflect spike back into lower triangle ==== + * + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE + * + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + * + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) + * + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF + * + * ==== Copy updated reduced window into place ==== + * + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) + * + * ==== Accumulate orthogonal matrix in order update + * . H and Z, if requested. (A modified version + * . of ZUNGHR that accumulates block Householder + * . transformations into V directly might be + * . marginally more efficient than the following.) ==== + * + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF + * + * ==== Update vertical slab in H ==== + * + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE + * + * ==== Update horizontal slab in H ==== + * + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF + * + * ==== Update vertical slab in Z ==== + * + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF + * + * ==== Return the number of deflations ... ==== + * + ND = JW - NS + * + * ==== ... and the number of shifts. (Subtracting + * . INFQR from the spike length takes care + * . of the case of a rare QR failure while + * . calculating eigenvalues of the deflation + * . window.) ==== + * + NS = NS - INFQR + * + * ==== Return optimal workspace. ==== + * + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + * + * ==== End of ZLAQR2 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlaqr3.f octave-2.9.16/libcruft/lapack/zlaqr3.f *** octave-2.9.15/libcruft/lapack/zlaqr3.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlaqr3.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,448 ---- + SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) + * .. + * + * ****************************************************************** + * Aggressive early deflation: + * + * This subroutine accepts as input an upper Hessenberg matrix + * H and performs an unitary similarity transformation + * designed to detect and deflate fully converged eigenvalues from + * a trailing principal submatrix. On output H has been over- + * written by a new Hessenberg matrix that is a perturbation of + * an unitary similarity transformation of H. It is to be + * hoped that the final version of H has many zero subdiagonal + * entries. + * + * ****************************************************************** + * WANTT (input) LOGICAL + * If .TRUE., then the Hessenberg matrix H is fully updated + * so that the triangular Schur factor may be + * computed (in cooperation with the calling subroutine). + * If .FALSE., then only enough of H is updated to preserve + * the eigenvalues. + * + * WANTZ (input) LOGICAL + * If .TRUE., then the unitary matrix Z is updated so + * so that the unitary Schur factor may be computed + * (in cooperation with the calling subroutine). + * If .FALSE., then Z is not referenced. + * + * N (input) INTEGER + * The order of the matrix H and (if WANTZ is .TRUE.) the + * order of the unitary matrix Z. + * + * KTOP (input) INTEGER + * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. + * KBOT and KTOP together determine an isolated block + * along the diagonal of the Hessenberg matrix. + * + * KBOT (input) INTEGER + * It is assumed without a check that either + * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together + * determine an isolated block along the diagonal of the + * Hessenberg matrix. + * + * NW (input) INTEGER + * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). + * + * H (input/output) COMPLEX*16 array, dimension (LDH,N) + * On input the initial N-by-N section of H stores the + * Hessenberg matrix undergoing aggressive early deflation. + * On output H has been transformed by a unitary + * similarity transformation, perturbed, and the returned + * to Hessenberg form that (it is to be hoped) has some + * zero subdiagonal entries. + * + * LDH (input) integer + * Leading dimension of H just as declared in the calling + * subroutine. N .LE. LDH + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. + * + * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) + * IF WANTZ is .TRUE., then on output, the unitary + * similarity transformation mentioned above has been + * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. + * If WANTZ is .FALSE., then Z is unreferenced. + * + * LDZ (input) integer + * The leading dimension of Z just as declared in the + * calling subroutine. 1 .LE. LDZ. + * + * NS (output) integer + * The number of unconverged (ie approximate) eigenvalues + * returned in SR and SI that may be used as shifts by the + * calling subroutine. + * + * ND (output) integer + * The number of converged eigenvalues uncovered by this + * subroutine. + * + * SH (output) COMPLEX*16 array, dimension KBOT + * On output, approximate eigenvalues that may + * be used for shifts are stored in SH(KBOT-ND-NS+1) + * through SR(KBOT-ND). Converged eigenvalues are + * stored in SH(KBOT-ND+1) through SH(KBOT). + * + * V (workspace) COMPLEX*16 array, dimension (LDV,NW) + * An NW-by-NW work array. + * + * LDV (input) integer scalar + * The leading dimension of V just as declared in the + * calling subroutine. NW .LE. LDV + * + * NH (input) integer scalar + * The number of columns of T. NH.GE.NW. + * + * T (workspace) COMPLEX*16 array, dimension (LDT,NW) + * + * LDT (input) integer + * The leading dimension of T just as declared in the + * calling subroutine. NW .LE. LDT + * + * NV (input) integer + * The number of rows of work array WV available for + * workspace. NV.GE.NW. + * + * WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) + * + * LDWV (input) integer + * The leading dimension of W just as declared in the + * calling subroutine. NW .LE. LDV + * + * WORK (workspace) COMPLEX*16 array, dimension LWORK. + * On exit, WORK(1) is set to an estimate of the optimal value + * of LWORK for the given values of N, NW, KTOP and KBOT. + * + * LWORK (input) integer + * The dimension of the work array WORK. LWORK = 2*NW + * suffices, but greater efficiency may result from larger + * values of LWORK. + * + * If LWORK = -1, then a workspace query is assumed; ZLAQR3 + * only estimates the optimal workspace size for the given + * values of N, NW, KTOP and KBOT. The estimate is returned + * in WORK(1). No error message related to LWORK is issued + * by XERBLA. Neither H nor Z are accessed. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================== + * .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) + * .. + * .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV + * .. + * .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN + * .. + * .. Statement Functions .. + DOUBLE PRECISION CABS1 + * .. + * .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) + * .. + * .. Executable Statements .. + * + * ==== Estimate optimal workspace. ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE + * + * ==== Workspace query call to ZGEHRD ==== + * + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) + * + * ==== Workspace query call to ZUNGHR ==== + * + CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) + * + * ==== Workspace query call to ZLAQR4 ==== + * + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, + $ LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) + * + * ==== Optimal workspace ==== + * + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF + * + * ==== Nothing to do ... + * ... for an empty active block ... ==== + NS = 0 + ND = 0 + IF( KTOP.GT.KBOT ) + $ RETURN + * ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN + * + * ==== Machine constants ==== + * + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) + * + * ==== Setup deflation window ==== + * + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF + * + IF( KBOT.EQ.KWTOP ) THEN + * + * ==== 1-by-1 deflation window: not much to do ==== + * + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + RETURN + END IF + * + * ==== Convert to spike-triangular form. (In case of a + * . rare QR failure, this routine continues to do + * . aggressive early deflation using that part of + * . the deflation window that converged using INFQR + * . here and there to keep track.) ==== + * + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + * + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) + END IF + * + * ==== Deflation detection loop ==== + * + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW + * + * ==== Small spike tip deflation test ==== + * + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN + * + * ==== One more converged eigenvalue ==== + * + NS = NS - 1 + ELSE + * + * ==== One undflatable eigenvalue. Move it up out of the + * . way. (ZTREXC can not fail in this case.) ==== + * + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE + * + * ==== Return to Hessenberg form ==== + * + IF( NS.EQ.0 ) + $ S = ZERO + * + IF( NS.LT.JW ) THEN + * + * ==== sorting the diagonal of T improves accuracy for + * . graded matrices. ==== + * + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF + * + * ==== Restore shift/eigenvalue array from T ==== + * + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE + * + * + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + * + * ==== Reflect spike back into lower triangle ==== + * + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE + * + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + * + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) + * + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF + * + * ==== Copy updated reduced window into place ==== + * + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) + * + * ==== Accumulate orthogonal matrix in order update + * . H and Z, if requested. (A modified version + * . of ZUNGHR that accumulates block Householder + * . transformations into V directly might be + * . marginally more efficient than the following.) ==== + * + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN + CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, + $ WV, LDWV ) + CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) + END IF + * + * ==== Update vertical slab in H ==== + * + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE + * + * ==== Update horizontal slab in H ==== + * + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF + * + * ==== Update vertical slab in Z ==== + * + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF + * + * ==== Return the number of deflations ... ==== + * + ND = JW - NS + * + * ==== ... and the number of shifts. (Subtracting + * . INFQR from the spike length takes care + * . of the case of a rare QR failure while + * . calculating eigenvalues of the deflation + * . window.) ==== + * + NS = NS - INFQR + * + * ==== Return optimal workspace. ==== + * + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + * + * ==== End of ZLAQR3 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlaqr4.f octave-2.9.16/libcruft/lapack/zlaqr4.f *** octave-2.9.15/libcruft/lapack/zlaqr4.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlaqr4.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,602 ---- + SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) + * .. + * + * This subroutine implements one level of recursion for ZLAQR0. + * It is a complete implementation of the small bulge multi-shift + * QR algorithm. It may be called by ZLAQR0 and, for large enough + * deflation window size, it may be called by ZLAQR3. This + * subroutine is identical to ZLAQR0 except that it calls ZLAQR2 + * instead of ZLAQR3. + * + * Purpose + * ======= + * + * ZLAQR4 computes the eigenvalues of a Hessenberg matrix H + * and, optionally, the matrices T and Z from the Schur decomposition + * H = Z T Z**H, where T is an upper triangular matrix (the + * Schur form), and Z is the unitary matrix of Schur vectors. + * + * Optionally Z may be postmultiplied into an input unitary + * matrix Q so that this routine can give the Schur factorization + * of a matrix A which has been reduced to the Hessenberg form H + * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. + * + * Arguments + * ========= + * + * WANTT (input) LOGICAL + * = .TRUE. : the full Schur form T is required; + * = .FALSE.: only eigenvalues are required. + * + * WANTZ (input) LOGICAL + * = .TRUE. : the matrix of Schur vectors Z is required; + * = .FALSE.: Schur vectors are not required. + * + * N (input) INTEGER + * The order of the matrix H. N .GE. 0. + * + * ILO (input) INTEGER + * IHI (input) INTEGER + * It is assumed that H is already upper triangular in rows + * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, + * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a + * previous call to ZGEBAL, and then passed to ZGEHRD when the + * matrix output by ZGEBAL is reduced to Hessenberg form. + * Otherwise, ILO and IHI should be set to 1 and N, + * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. + * If N = 0, then ILO = 1 and IHI = 0. + * + * H (input/output) COMPLEX*16 array, dimension (LDH,N) + * On entry, the upper Hessenberg matrix H. + * On exit, if INFO = 0 and WANTT is .TRUE., then H + * contains the upper triangular matrix T from the Schur + * decomposition (the Schur form). If INFO = 0 and WANT is + * .FALSE., then the contents of H are unspecified on exit. + * (The output value of H when INFO.GT.0 is given under the + * description of INFO below.) + * + * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and + * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. + * + * LDH (input) INTEGER + * The leading dimension of the array H. LDH .GE. max(1,N). + * + * W (output) COMPLEX*16 array, dimension (N) + * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored + * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are + * stored in the same order as on the diagonal of the Schur + * form returned in H, with W(i) = H(i,i). + * + * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) + * If WANTZ is .FALSE., then Z is not referenced. + * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is + * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the + * orthogonal Schur factor of H(ILO:IHI,ILO:IHI). + * (The output value of Z when INFO.GT.0 is given under + * the description of INFO below.) + * + * LDZ (input) INTEGER + * The leading dimension of the array Z. if WANTZ is .TRUE. + * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. + * + * WORK (workspace/output) COMPLEX*16 array, dimension LWORK + * On exit, if LWORK = -1, WORK(1) returns an estimate of + * the optimal value for LWORK. + * + * LWORK (input) INTEGER + * The dimension of the array WORK. LWORK .GE. max(1,N) + * is sufficient, but LWORK typically as large as 6*N may + * be required for optimal performance. A workspace query + * to determine the optimal workspace size is recommended. + * + * If LWORK = -1, then ZLAQR4 does a workspace query. + * In this case, ZLAQR4 checks the input parameters and + * estimates the optimal workspace size for the given + * values of N, ILO and IHI. The estimate is returned + * in WORK(1). No error message related to LWORK is + * issued by XERBLA. Neither H nor Z are accessed. + * + * + * INFO (output) INTEGER + * = 0: successful exit + * .GT. 0: if INFO = i, ZLAQR4 failed to compute all of + * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR + * and WI contain those eigenvalues which have been + * successfully computed. (Failures are rare.) + * + * If INFO .GT. 0 and WANT is .FALSE., then on exit, + * the remaining unconverged eigenvalues are the eigen- + * values of the upper Hessenberg matrix rows and + * columns ILO through INFO of the final, output + * value of H. + * + * If INFO .GT. 0 and WANTT is .TRUE., then on exit + * + * (*) (initial value of H)*U = U*(final value of H) + * + * where U is a unitary matrix. The final + * value of H is upper Hessenberg and triangular in + * rows and columns INFO+1 through IHI. + * + * If INFO .GT. 0 and WANTZ is .TRUE., then on exit + * + * (final value of Z(ILO:IHI,ILOZ:IHIZ) + * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U + * + * where U is the unitary matrix in (*) (regard- + * less of the value of WANTT.) + * + * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not + * accessed. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ================================================================ + * References: + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + * Performance, SIAM Journal of Matrix Analysis, volume 23, pages + * 929--947, 2002. + * + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part II: Aggressive Early Deflation, SIAM Journal + * of Matrix Analysis, volume 23, pages 948--973, 2002. + * + * ================================================================ + * .. Parameters .. + * + * ==== Matrices of order NTINY or smaller must be processed by + * . ZLAHQR because of insufficient subdiagonal scratch space. + * . (This is a hard limit.) ==== + * + * ==== Exceptional deflation windows: try to cure rare + * . slow convergence by increasing the size of the + * . deflation window after KEXNW iterations. ===== + * + * ==== Exceptional shifts: try to cure rare slow convergence + * . with ad-hoc exceptional shifts every KEXSH iterations. + * . The constants WILK1 and WILK2 are used to form the + * . exceptional shifts. ==== + * + INTEGER NTINY + PARAMETER ( NTINY = 11 ) + INTEGER KEXNW, KEXSH + PARAMETER ( KEXNW = 5, KEXSH = 6 ) + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) + * .. + * .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, + $ NSR, NVE, NW, NWMAX, NWR + LOGICAL NWINC, SORTED + CHARACTER JBCMPZ*2 + * .. + * .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV + * .. + * .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) + * .. + * .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 + * .. + * .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT + * .. + * .. Statement Functions .. + DOUBLE PRECISION CABS1 + * .. + * .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) + * .. + * .. Executable Statements .. + INFO = 0 + * + * ==== Quick return for N = 0: nothing to do. ==== + * + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF + * + * ==== Set up job flags for ILAENV. ==== + * + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF + * + * ==== Tiny matrices must use ZLAHQR. ==== + * + IF( N.LE.NTINY ) THEN + * + * ==== Estimate optimal workspace. ==== + * + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE + * + * ==== Use small bulge multi-shift QR with aggressive early + * . deflation on larger-than-tiny matrices. ==== + * + * ==== Hope for the best. ==== + * + INFO = 0 + * + * ==== NWR = recommended deflation window size. At this + * . point, N .GT. NTINY = 11, so there is enough + * . subdiagonal workspace for NWR.GE.2 as required. + * . (In fact, there is enough subdiagonal space for + * . NWR.GE.3.) ==== + * + NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) + NW = NWR + * + * ==== NSR = recommended number of simultaneous shifts. + * . At this point N .GT. NTINY = 11, so there is at + * . enough subdiagonal workspace for NSR to be even + * . and greater than or equal to two as required. ==== + * + NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) + * + * ==== Estimate optimal workspace ==== + * + * ==== Workspace query call to ZLAQR2 ==== + * + CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) + * + * ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== + * + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) + * + * ==== Quick return in case of workspace query. ==== + * + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF + * + * ==== ZLAHQR/ZLAQR0 crossover point ==== + * + NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) + * + * ==== Nibble crossover point ==== + * + NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) + * + * ==== Accumulate reflections during ttswp? Use block + * . 2-by-2 structure during matrix-matrix multiply? ==== + * + KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) + * + * ==== NWMAX = the largest possible deflation window for + * . which there is sufficient workspace. ==== + * + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + * + * ==== NSMAX = the Largest number of simultaneous shifts + * . for which there is sufficient workspace. ==== + * + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) + * + * ==== NDFL: an iteration count restarted at deflation. ==== + * + NDFL = 1 + * + * ==== ITMAX = iteration limit ==== + * + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) + * + * ==== Last row and column in the active block ==== + * + KBOT = IHI + * + * ==== Main Loop ==== + * + DO 70 IT = 1, ITMAX + * + * ==== Done when KBOT falls below ILO ==== + * + IF( KBOT.LT.ILO ) + $ GO TO 80 + * + * ==== Locate active block ==== + * + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K + * + * ==== Select deflation window size ==== + * + NH = KBOT - KTOP + 1 + IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN + * + * ==== Typical deflation window. If possible and + * . advisable, nibble the entire active block. + * . If not, use size NWR or NWR+1 depending upon + * . which has the smaller corresponding subdiagonal + * . entry (a heuristic). ==== + * + NWINC = .TRUE. + IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN + NW = NH + ELSE + NW = MIN( NWR, NH, NWMAX ) + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + END IF + ELSE + * + * ==== Exceptional deflation window. If there have + * . been no deflations in KEXNW or more iterations, + * . then vary the deflation window size. At first, + * . because, larger windows are, in general, more + * . powerful than smaller ones, rapidly increase the + * . window up to the maximum reasonable and possible. + * . Then maybe try a slightly smaller window. ==== + * + IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN + NW = MIN( NWMAX, NH, 2*NW ) + ELSE + NWINC = .FALSE. + IF( NW.EQ.NH .AND. NH.GT.2 ) + $ NW = NH - 1 + END IF + END IF + * + * ==== Aggressive early deflation: + * . split workspace under the subdiagonal into + * . - an nw-by-nw work array V in the lower + * . left-hand-corner, + * . - an NW-by-at-least-NW-but-more-is-better + * . (NW-by-NHO) horizontal work array along + * . the bottom edge, + * . - an at-least-NW-but-more-is-better (NHV-by-NW) + * . vertical work array along the left-hand-edge. + * . ==== + * + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 + * + * ==== Aggressive early deflation ==== + * + CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) + * + * ==== Adjust KBOT accounting for new deflations. ==== + * + KBOT = KBOT - LD + * + * ==== KS points to the shifts. ==== + * + KS = KBOT - LS + 1 + * + * ==== Skip an expensive QR sweep if there is a (partly + * . heuristic) reason to expect that many eigenvalues + * . will deflate without it. Here, the QR sweep is + * . skipped if many eigenvalues have just been deflated + * . or if the remaining active block is small. + * + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN + * + * ==== NS = nominal number of simultaneous shifts. + * . This may be lowered (slightly) if ZLAQR2 + * . did not provide that many shifts. ==== + * + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) + * + * ==== If there have been no deflations + * . in a multiple of KEXSH iterations, + * . then try exceptional shifts. + * . Otherwise use shifts provided by + * . ZLAQR2 above or from the eigenvalues + * . of a trailing principal submatrix. ==== + * + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE + * + * ==== Got NS/2 or fewer shifts? Use ZLAHQR + * . on a trailing principal submatrix to + * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, + * . there is enough space below the subdiagonal + * . to fit an NS-by-NS scratch array.) ==== + * + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, + $ 1, INF ) + KS = KS + INF + * + * ==== In case of a rare QR failure use + * . eigenvalues of the trailing 2-by-2 + * . principal submatrix. Scale to avoid + * . overflows, underflows and subnormals. + * . (The scale factor S can not be zero, + * . because H(KBOT,KBOT-1) is nonzero.) ==== + * + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S + * + KS = KBOT - 1 + END IF + END IF + * + IF( KBOT-KS+1.GT.NS ) THEN + * + * ==== Sort the shifts (Helps a little) ==== + * + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF + * + * ==== If there are only two shifts, then use + * . only one. ==== + * + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF + * + * ==== Use up to NS of the the smallest magnatiude + * . shifts. If there aren't NS shifts available, + * . then use them all, possibly dropping one to + * . make the number of shifts even. ==== + * + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 + * + * ==== Small-bulge multi-shift QR sweep: + * . split workspace under the subdiagonal into + * . - a KDU-by-KDU work array U in the lower + * . left-hand-corner, + * . - a KDU-by-at-least-KDU-but-more-is-better + * . (KDU-by-NHo) horizontal work array WH along + * . the bottom edge, + * . - and an at-least-KDU-but-more-is-better-by-KDU + * . (NVE-by-KDU) vertical work WV arrow along + * . the left-hand-edge. ==== + * + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 + * + * ==== Small-bulge multi-shift QR sweep ==== + * + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF + * + * ==== Note progress (or the lack of it). ==== + * + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF + * + * ==== End of main loop ==== + 70 CONTINUE + * + * ==== Iteration limit exceeded. Set INFO to show where + * . the problem occurred and exit. ==== + * + INFO = KBOT + 80 CONTINUE + END IF + * + * ==== Return the optimal value of LWORK. ==== + * + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + * + * ==== End of ZLAQR4 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlaqr5.f octave-2.9.16/libcruft/lapack/zlaqr5.f *** octave-2.9.15/libcruft/lapack/zlaqr5.f Wed Dec 31 19:00:00 1969 --- octave-2.9.16/libcruft/lapack/zlaqr5.f Tue Oct 16 14:54:22 2007 *************** *** 0 **** --- 1,809 ---- + SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, + $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, + $ WV, LDWV, NH, WH, LDWH ) + * + * -- LAPACK auxiliary routine (version 3.1) -- + * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. + * November 2006 + * + * .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ + * .. + * .. Array Arguments .. + COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), + $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) + * .. + * + * This auxiliary subroutine called by ZLAQR0 performs a + * single small-bulge multi-shift QR sweep. + * + * WANTT (input) logical scalar + * WANTT = .true. if the triangular Schur factor + * is being computed. WANTT is set to .false. otherwise. + * + * WANTZ (input) logical scalar + * WANTZ = .true. if the unitary Schur factor is being + * computed. WANTZ is set to .false. otherwise. + * + * KACC22 (input) integer with value 0, 1, or 2. + * Specifies the computation mode of far-from-diagonal + * orthogonal updates. + * = 0: ZLAQR5 does not accumulate reflections and does not + * use matrix-matrix multiply to update far-from-diagonal + * matrix entries. + * = 1: ZLAQR5 accumulates reflections and uses matrix-matrix + * multiply to update the far-from-diagonal matrix entries. + * = 2: ZLAQR5 accumulates reflections, uses matrix-matrix + * multiply to update the far-from-diagonal matrix entries, + * and takes advantage of 2-by-2 block structure during + * matrix multiplies. + * + * N (input) integer scalar + * N is the order of the Hessenberg matrix H upon which this + * subroutine operates. + * + * KTOP (input) integer scalar + * KBOT (input) integer scalar + * These are the first and last rows and columns of an + * isolated diagonal block upon which the QR sweep is to be + * applied. It is assumed without a check that + * either KTOP = 1 or H(KTOP,KTOP-1) = 0 + * and + * either KBOT = N or H(KBOT+1,KBOT) = 0. + * + * NSHFTS (input) integer scalar + * NSHFTS gives the number of simultaneous shifts. NSHFTS + * must be positive and even. + * + * S (input) COMPLEX*16 array of size (NSHFTS) + * S contains the shifts of origin that define the multi- + * shift QR sweep. + * + * H (input/output) COMPLEX*16 array of size (LDH,N) + * On input H contains a Hessenberg matrix. On output a + * multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied + * to the isolated diagonal block in rows and columns KTOP + * through KBOT. + * + * LDH (input) integer scalar + * LDH is the leading dimension of H just as declared in the + * calling procedure. LDH.GE.MAX(1,N). + * + * ILOZ (input) INTEGER + * IHIZ (input) INTEGER + * Specify the rows of Z to which transformations must be + * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N + * + * Z (input/output) COMPLEX*16 array of size (LDZ,IHI) + * If WANTZ = .TRUE., then the QR Sweep unitary + * similarity transformation is accumulated into + * Z(ILOZ:IHIZ,ILO:IHI) from the right. + * If WANTZ = .FALSE., then Z is unreferenced. + * + * LDZ (input) integer scalar + * LDA is the leading dimension of Z just as declared in + * the calling procedure. LDZ.GE.N. + * + * V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) + * + * LDV (input) integer scalar + * LDV is the leading dimension of V as declared in the + * calling procedure. LDV.GE.3. + * + * U (workspace) COMPLEX*16 array of size + * (LDU,3*NSHFTS-3) + * + * LDU (input) integer scalar + * LDU is the leading dimension of U just as declared in the + * in the calling subroutine. LDU.GE.3*NSHFTS-3. + * + * NH (input) integer scalar + * NH is the number of columns in array WH available for + * workspace. NH.GE.1. + * + * WH (workspace) COMPLEX*16 array of size (LDWH,NH) + * + * LDWH (input) integer scalar + * Leading dimension of WH just as declared in the + * calling procedure. LDWH.GE.3*NSHFTS-3. + * + * NV (input) integer scalar + * NV is the number of rows in WV agailable for workspace. + * NV.GE.1. + * + * WV (workspace) COMPLEX*16 array of size + * (LDWV,3*NSHFTS-3) + * + * LDWV (input) integer scalar + * LDWV is the leading dimension of WV as declared in the + * in the calling subroutine. LDWV.GE.NV. + * + * ================================================================ + * Based on contributions by + * Karen Braman and Ralph Byers, Department of Mathematics, + * University of Kansas, USA + * + * ============================================================ + * Reference: + * + * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + * Algorithm Part I: Maintaining Well Focused Shifts, and + * Level 3 Performance, SIAM Journal of Matrix Analysis, + * volume 23, pages 929--947, 2002. + * + * ============================================================ + * .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) + * .. + * .. Local Scalars .. + COMPLEX*16 ALPHA, BETA, CDUM, REFSUM + DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, + $ SMLNUM, TST1, TST2, ULP + INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, + $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, + $ NS, NU + LOGICAL ACCUM, BLK22, BMP22 + * .. + * .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + * .. + * .. Intrinsic Functions .. + * + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD + * .. + * .. Local Arrays .. + COMPLEX*16 VT( 3 ) + * .. + * .. External Subroutines .. + EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, + $ ZTRMM + * .. + * .. Statement Functions .. + DOUBLE PRECISION CABS1 + * .. + * .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) + * .. + * .. Executable Statements .. + * + * ==== If there are no shifts, then there is nothing to do. ==== + * + IF( NSHFTS.LT.2 ) + $ RETURN + * + * ==== If the active block is empty or 1-by-1, then there + * . is nothing to do. ==== + * + IF( KTOP.GE.KBOT ) + $ RETURN + * + * ==== NSHFTS is supposed to be even, but if is odd, + * . then simply reduce it by one. ==== + * + NS = NSHFTS - MOD( NSHFTS, 2 ) + * + * ==== Machine constants for deflation ==== + * + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) + * + * ==== Use accumulated reflections to update far-from-diagonal + * . entries ? ==== + * + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) + * + * ==== If so, exploit the 2-by-2 block structure? ==== + * + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) + * + * ==== clear trash ==== + * + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO + * + * ==== NBMPS = number of 2-shift bulges in the chain ==== + * + NBMPS = NS / 2 + * + * ==== KDU = width of slab ==== + * + KDU = 6*NBMPS - 3 + * + * ==== Create and chase chains of NBMPS bulges ==== + * + DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) + * + * ==== Near-the-diagonal bulge chase. The following loop + * . performs the near-the-diagonal part of a small bulge + * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal + * . chunk extends from column INCOL to column NDCOL + * . (including both column INCOL and column NDCOL). The + * . following loop chases a 3*NBMPS column long chain of + * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL + * . may be less than KTOP and and NDCOL may be greater than + * . KBOT indicating phantom columns from which to chase + * . bulges before they are actually introduced or to which + * . to chase bulges beyond column KBOT.) ==== + * + DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) + * + * ==== Bulges number MTOP to MBOT are active double implicit + * . shift bulges. There may or may not also be small + * . 2-by-2 bulge, if there is room. The inactive bulges + * . (if any) must wait until the active bulges have moved + * . down the diagonal to make room. The phantom matrix + * . paradigm described above helps keep track. ==== + * + MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) + MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) + M22 = MBOT + 1 + BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. + $ ( KBOT-2 ) + * + * ==== Generate reflections to chase the chain right + * . one column. (The minimum value of K is KTOP-1.) ==== + * + DO 10 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), + $ S( 2*M ), V( 1, M ) ) + ALPHA = V( 1, M ) + CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M ) = H( K+2, K ) + V( 3, M ) = H( K+3, K ) + CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) + * + * ==== A Bulge may collapse because of vigilant + * . deflation or destructive underflow. (The + * . initial bulge is always collapsed.) Use + * . the two-small-subdiagonals trick to try + * . to get it started again. If V(2,M).NE.0 and + * . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then + * . this bulge is collapsing into a zero + * . subdiagonal. It will be restarted next + * . trip through the loop.) + * + IF( V( 1, M ).NE.ZERO .AND. + $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, + $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) + $ THEN + * + * ==== Typical case: not collapsed (yet). ==== + * + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE + * + * ==== Atypical case: collapsed. Attempt to + * . reintroduce ignoring H(K+1,K). If the + * . fill resulting from the new reflector + * . is too large, then abandon it. + * . Otherwise, use the new one. ==== + * + CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), + $ S( 2*M ), VT ) + SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + + $ CABS1( VT( 3 ) ) + IF( SCL.NE.RZERO ) THEN + VT( 1 ) = VT( 1 ) / SCL + VT( 2 ) = VT( 2 ) / SCL + VT( 3 ) = VT( 3 ) / SCL + END IF + * + * ==== The following is the traditional and + * . conservative two-small-subdiagonals + * . test. ==== + * . + IF( CABS1( H( K+1, K ) )* + $ ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* + $ CABS1( VT( 1 ) )*( CABS1( H( K, + $ K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, + $ K+2 ) ) ) ) THEN + * + * ==== Starting a new bulge here would + * . create non-negligible fill. If + * . the old reflector is diagonal (only + * . possible with underflows), then + * . change it to I. Otherwise, use + * . it with trepidation. ==== + * + IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) + $ THEN + V( 1, M ) = ZERO + ELSE + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + END IF + ELSE + * + * ==== Stating a new bulge here would + * . create only negligible fill. + * . Replace the old reflector with + * . the new one. ==== + * + ALPHA = VT( 1 ) + CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = H( K+1, K ) + + $ H( K+2, K )*DCONJG( VT( 2 ) ) + + $ H( K+3, K )*DCONJG( VT( 3 ) ) + H( K+1, K ) = H( K+1, K ) - + $ DCONJG( VT( 1 ) )*REFSUM + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + V( 1, M ) = VT( 1 ) + V( 2, M ) = VT( 2 ) + V( 3, M ) = VT( 3 ) + END IF + END IF + END IF + 10 CONTINUE + * + * ==== Generate a 2-by-2 reflection, if needed. ==== + * + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), + $ S( 2*M22 ), V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + ELSE + * + * ==== Initialize V(1,M22) here to avoid possible undefined + * . variable problems later. ==== + * + V( 1, M22 ) = ZERO + END IF + * + * ==== Multiply H by reflections from the left ==== + * + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 30 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 20 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = DCONJG( V( 1, M ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M ) )* + $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) + H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) + 20 CONTINUE + 30 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 40 J = MAX( K+1, KTOP ), JBOT + REFSUM = DCONJG( V( 1, M22 ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* + $ H( K+2, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) + 40 CONTINUE + END IF + * + * ==== Multiply H by reflections from the right. + * . Delay filling in the last row until the + * . vigilant deflation check is complete. ==== + * + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 80 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 50 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* + $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + H( J, K+3 ) = H( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 50 CONTINUE + * + IF( ACCUM ) THEN + * + * ==== Accumulate U. (If necessary, update Z later + * . with with an efficient matrix-matrix + * . multiply.) ==== + * + KMS = K - INCOL + DO 60 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* + $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + U( J, KMS+3 ) = U( J, KMS+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 60 CONTINUE + ELSE IF( WANTZ ) THEN + * + * ==== U is not accumulated, so update Z + * . now by multiplying by reflections + * . from the right. ==== + * + DO 70 J = ILOZ, IHIZ + REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* + $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + Z( J, K+3 ) = Z( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 70 CONTINUE + END IF + END IF + 80 CONTINUE + * + * ==== Special case: 2-by-2 reflection (if needed) ==== + * + K = KRCOL + 3*( M22-1 ) + IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN + DO 90 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* + $ H( J, K+2 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 90 CONTINUE + * + IF( ACCUM ) THEN + KMS = K - INCOL + DO 100 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )* + $ U( J, KMS+2 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 100 CONTINUE + ELSE IF( WANTZ ) THEN + DO 110 J = ILOZ, IHIZ + REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* + $ Z( J, K+2 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 110 CONTINUE + END IF + END IF + * + * ==== Vigilant deflation check ==== + * + MSTART = MTOP + IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) + $ MSTART = MSTART + 1 + MEND = MBOT + IF( BMP22 ) + $ MEND = MEND + 1 + IF( KRCOL.EQ.KBOT-2 ) + $ MEND = MEND + 1 + DO 120 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) + * + * ==== The following convergence test requires that + * . the tradition small-compared-to-nearby-diagonals + * . criterion and the Ahues & Tisseur (LAWN 122, 1997) + * . criteria both be satisfied. The latter improves + * . accuracy in some examples. Falling back on an + * . alternate convergence criterion when TST1 or TST2 + * . is zero (as done here) is traditional but probably + * . unnecessary. ==== + * + IF( H( K+1, K ).NE.ZERO ) THEN + TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) + IF( TST1.EQ.RZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + CABS1( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + CABS1( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + CABS1( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) + END IF + IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H21 = MIN( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H11 = MAX( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) + * + IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 120 CONTINUE + * + * ==== Fill in the last row of each bulge. ==== + * + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 130 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) + H( K+4, K+1 ) = -REFSUM + H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) + H( K+4, K+3 ) = H( K+4, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 130 CONTINUE + * + * ==== End of near-the-diagonal bulge chase. ==== + * + 140 CONTINUE + * + * ==== Use U (if accumulated) to update far-from-diagonal + * . entries in H. If required, use U to update Z as + * . well. ==== + * + IF( ACCUM ) THEN + IF( WANTT ) THEN + JTOP = 1 + JBOT = N + ELSE + JTOP = KTOP + JBOT = KBOT + END IF + IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. + $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN + * + * ==== Updates not exploiting the 2-by-2 block + * . structure of U. K1 and NU keep track of + * . the location and size of U in the special + * . cases of introducing bulges and chasing + * . bulges off the bottom. In these special + * . cases and in case the number of shifts + * . is NS = 2, there is no 2-by-2 block + * . structure to exploit. ==== + * + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 + * + * ==== Horizontal Multiply ==== + * + DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 150 CONTINUE + * + * ==== Vertical multiply ==== + * + DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 160 CONTINUE + * + * ==== Z multiply (also vertical) ==== + * + IF( WANTZ ) THEN + DO 170 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 170 CONTINUE + END IF + ELSE + * + * ==== Updates exploiting U's 2-by-2 block structure. + * . (I2, I4, J2, J4 are the last rows and columns + * . of the blocks.) ==== + * + I2 = ( KDU+1 ) / 2 + I4 = KDU + J2 = I4 - I2 + J4 = KDU + * + * ==== KZS and KNZ deal with the band of zeros + * . along the diagonal of one of the triangular + * . blocks. ==== + * + KZS = ( J4-J2 ) - ( NS+1 ) + KNZ = NS + 1 + * + * ==== Horizontal multiply ==== + * + DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + * + * ==== Copy bottom of H to top+KZS of scratch ==== + * (The first KZS rows get multiplied by zero.) ==== + * + CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) + * + * ==== Multiply by U21' ==== + * + CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) + * + * ==== Multiply top of H by U11' ==== + * + CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) + * + * ==== Copy top of H bottom of WH ==== + * + CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) + * + * ==== Multiply by U21' ==== + * + CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) + * + * ==== Multiply by U22 ==== + * + CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, + $ U( J2+1, I2+1 ), LDU, + $ H( INCOL+1+J2, JCOL ), LDH, ONE, + $ WH( I2+1, 1 ), LDWH ) + * + * ==== Copy it back ==== + * + CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 180 CONTINUE + * + * ==== Vertical multiply ==== + * + DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) + * + * ==== Copy right of H to scratch (the first KZS + * . columns get multiplied by zero) ==== + * + CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) + * + * ==== Multiply by U21 ==== + * + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) + * + * ==== Multiply by U11 ==== + * + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) + * + * ==== Copy left of H to right of scratch ==== + * + CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) + * + * ==== Multiply by U21 ==== + * + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) + * + * ==== Multiply by U22 ==== + * + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ H( JROW, INCOL+1+J2 ), LDH, + $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), + $ LDWV ) + * + * ==== Copy it back ==== + * + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 190 CONTINUE + * + * ==== Multiply Z (also vertical) ==== + * + IF( WANTZ ) THEN + DO 200 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + * + * ==== Copy right of Z to left of scratch (first + * . KZS columns get multiplied by zero) ==== + * + CALL ZLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) + * + * ==== Multiply by U12 ==== + * + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) + * + * ==== Multiply by U11 ==== + * + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) + * + * ==== Copy left of Z to right of scratch ==== + * + CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) + * + * ==== Multiply by U21 ==== + * + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) + * + * ==== Multiply by U22 ==== + * + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ U( J2+1, I2+1 ), LDU, ONE, + $ WV( 1, 1+I2 ), LDWV ) + * + * ==== Copy the result back to Z ==== + * + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 200 CONTINUE + END IF + END IF + END IF + 210 CONTINUE + * + * ==== End of ZLAQR5 ==== + * + END diff -cNr octave-2.9.15/libcruft/lapack/zlarf.f octave-2.9.16/libcruft/lapack/zlarf.f *** octave-2.9.15/libcruft/lapack/zlarf.f Wed Nov 3 14:54:42 1999 --- octave-2.9.16/libcruft/lapack/zlarf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE --- 1,8 ---- SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE diff -cNr octave-2.9.15/libcruft/lapack/zlarfb.f octave-2.9.16/libcruft/lapack/zlarfb.f *** octave-2.9.15/libcruft/lapack/zlarfb.f Wed Nov 3 14:54:42 1999 --- octave-2.9.16/libcruft/lapack/zlarfb.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS --- 1,9 ---- SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS diff -cNr octave-2.9.15/libcruft/lapack/zlarfg.f octave-2.9.16/libcruft/lapack/zlarfg.f *** octave-2.9.15/libcruft/lapack/zlarfg.f Wed Nov 3 14:54:42 1999 --- octave-2.9.16/libcruft/lapack/zlarfg.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/zlarft.f octave-2.9.16/libcruft/lapack/zlarft.f *** octave-2.9.15/libcruft/lapack/zlarft.f Wed Nov 3 14:54:43 1999 --- octave-2.9.16/libcruft/lapack/zlarft.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV --- 1,8 ---- SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV diff -cNr octave-2.9.15/libcruft/lapack/zlarfx.f octave-2.9.16/libcruft/lapack/zlarfx.f *** octave-2.9.15/libcruft/lapack/zlarfx.f Wed Nov 3 14:54:43 1999 --- octave-2.9.16/libcruft/lapack/zlarfx.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE --- 1,8 ---- SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE diff -cNr octave-2.9.15/libcruft/lapack/zlartg.f octave-2.9.16/libcruft/lapack/zlartg.f *** octave-2.9.15/libcruft/lapack/zlartg.f Wed Nov 3 14:54:43 1999 --- octave-2.9.16/libcruft/lapack/zlartg.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLARTG( F, G, CS, SN, R ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. DOUBLE PRECISION CS --- 1,8 ---- SUBROUTINE ZLARTG( F, G, CS, SN, R ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. DOUBLE PRECISION CS *************** *** 48,53 **** --- 47,55 ---- * * 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel * + * This version has a few statements commented out for thread safety + * (machine parameters are computed on each entry). 10 feb 03, SJH. + * * ===================================================================== * * .. Parameters .. *************** *** 57,63 **** PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. ! LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, $ SAFMN2, SAFMX2, SCALE --- 59,65 ---- PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. ! * LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, $ SAFMN2, SAFMX2, SCALE *************** *** 75,84 **** DOUBLE PRECISION ABS1, ABSSQ * .. * .. Save statement .. ! SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. ! DATA FIRST / .TRUE. / * .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) --- 77,86 ---- DOUBLE PRECISION ABS1, ABSSQ * .. * .. Save statement .. ! * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. ! * DATA FIRST / .TRUE. / * .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) *************** *** 86,99 **** * .. * .. Executable Statements .. * ! IF( FIRST ) THEN ! FIRST = .FALSE. SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 ! END IF SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G --- 88,101 ---- * .. * .. Executable Statements .. * ! * IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 ! * FIRST = .FALSE. ! * END IF SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G diff -cNr octave-2.9.15/libcruft/lapack/zlascl.f octave-2.9.16/libcruft/lapack/zlascl.f *** octave-2.9.15/libcruft/lapack/zlascl.f Wed Nov 3 14:54:43 1999 --- octave-2.9.16/libcruft/lapack/zlascl.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE --- 1,8 ---- SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TYPE *************** *** 62,68 **** * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * ! * A (input/output) COMPLEX*16 array, dimension (LDA,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * --- 61,67 ---- * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * ! * A (input/output) COMPLEX*16 array, dimension (LDA,N) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * diff -cNr octave-2.9.15/libcruft/lapack/zlaset.f octave-2.9.16/libcruft/lapack/zlaset.f *** octave-2.9.15/libcruft/lapack/zlaset.f Wed Nov 3 14:54:43 1999 --- octave-2.9.16/libcruft/lapack/zlaset.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zlasr.f octave-2.9.16/libcruft/lapack/zlasr.f *** octave-2.9.15/libcruft/lapack/zlasr.f Wed Nov 3 14:54:44 1999 --- octave-2.9.16/libcruft/lapack/zlasr.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE --- 1,8 ---- SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE *************** *** 17,58 **** * Purpose * ======= * ! * ZLASR performs the transformation * ! * A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) * ! * A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) * ! * where A is an m by n complex matrix and P is an orthogonal matrix, ! * consisting of a sequence of plane rotations determined by the ! * parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' ! * and z = n when SIDE = 'R' or 'r' ): * ! * When DIRECT = 'F' or 'f' ( Forward sequence ) then ! * ! * P = P( z - 1 )*...*P( 2 )*P( 1 ), ! * ! * and when DIRECT = 'B' or 'b' ( Backward sequence ) then ! * ! * P = P( 1 )*P( 2 )*...*P( z - 1 ), ! * ! * where P( k ) is a plane rotation matrix for the following planes: ! * ! * when PIVOT = 'V' or 'v' ( Variable pivot ), ! * the plane ( k, k + 1 ) ! * ! * when PIVOT = 'T' or 't' ( Top pivot ), ! * the plane ( 1, k + 1 ) ! * ! * when PIVOT = 'B' or 'b' ( Bottom pivot ), ! * the plane ( k, z ) ! * ! * c( k ) and s( k ) must contain the cosine and sine that define the ! * matrix P( k ). The two by two plane rotation part of the matrix ! * P( k ), R( k ), is assumed to be of the form ! * ! * R( k ) = ( c( k ) s( k ) ). ! * ( -s( k ) c( k ) ) * * Arguments * ========= --- 16,92 ---- * Purpose * ======= * ! * ZLASR applies a sequence of real plane rotations to a complex matrix ! * A, from either the left or the right. * ! * When SIDE = 'L', the transformation takes the form * ! * A := P*A * ! * and when SIDE = 'R', the transformation takes the form * ! * A := A*P**T ! * ! * where P is an orthogonal matrix consisting of a sequence of z plane ! * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', ! * and P**T is the transpose of P. ! * ! * When DIRECT = 'F' (Forward sequence), then ! * ! * P = P(z-1) * ... * P(2) * P(1) ! * ! * and when DIRECT = 'B' (Backward sequence), then ! * ! * P = P(1) * P(2) * ... * P(z-1) ! * ! * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation ! * ! * R(k) = ( c(k) s(k) ) ! * = ( -s(k) c(k) ). ! * ! * When PIVOT = 'V' (Variable pivot), the rotation is performed ! * for the plane (k,k+1), i.e., P(k) has the form ! * ! * P(k) = ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( c(k) s(k) ) ! * ( -s(k) c(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ! * where R(k) appears as a rank-2 modification to the identity matrix in ! * rows and columns k and k+1. ! * ! * When PIVOT = 'T' (Top pivot), the rotation is performed for the ! * plane (1,k+1), so P(k) has the form ! * ! * P(k) = ( c(k) s(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( -s(k) c(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ! * where R(k) appears in rows and columns 1 and k+1. ! * ! * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is ! * performed for the plane (k,z), giving P(k) the form ! * ! * P(k) = ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( c(k) s(k) ) ! * ( 1 ) ! * ( ... ) ! * ( 1 ) ! * ( -s(k) c(k) ) ! * ! * where R(k) appears in rows and columns k and z. The rotations are ! * performed without ever forming P(k) explicitly. * * Arguments * ========= *************** *** 61,73 **** * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A ! * = 'R': Right, compute A:= A*P' ! * ! * DIRECT (input) CHARACTER*1 ! * Specifies whether P is a forward or backward sequence of ! * plane rotations. ! * = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) ! * = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation --- 95,101 ---- * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A ! * = 'R': Right, compute A:= A*P**T * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation *************** *** 76,81 **** --- 104,115 ---- * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * + * DIRECT (input) CHARACTER*1 + * Specifies whether P is a forward or backward sequence of + * plane rotations. + * = 'F': Forward, P = P(z-1)*...*P(2)*P(1) + * = 'B': Backward, P = P(1)*P(2)*...*P(z-1) + * * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. *************** *** 84,101 **** * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * ! * C, S (input) DOUBLE PRECISION arrays, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' ! * c(k) and s(k) contain the cosine and sine that define the ! * matrix P(k). The two by two plane rotation part of the ! * matrix P(k), R(k), is assumed to be of the form ! * R( k ) = ( c( k ) s( k ) ). ! * ( -s( k ) c( k ) ) * * A (input/output) COMPLEX*16 array, dimension (LDA,N) ! * The m by n matrix A. On exit, A is overwritten by P*A if ! * SIDE = 'R' or by A*P' if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). --- 118,139 ---- * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * ! * C (input) DOUBLE PRECISION array, dimension ! * (M-1) if SIDE = 'L' ! * (N-1) if SIDE = 'R' ! * The cosines c(k) of the plane rotations. ! * ! * S (input) DOUBLE PRECISION array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' ! * The sines s(k) of the plane rotations. The 2-by-2 plane ! * rotation part of the matrix P(k), R(k), has the form ! * R(k) = ( c(k) s(k) ) ! * ( -s(k) c(k) ). * * A (input/output) COMPLEX*16 array, dimension (LDA,N) ! * The M-by-N matrix A. On exit, A is overwritten by P*A if ! * SIDE = 'R' or by A*P**T if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). diff -cNr octave-2.9.15/libcruft/lapack/zlassq.f octave-2.9.16/libcruft/lapack/zlassq.f *** octave-2.9.15/libcruft/lapack/zlassq.f Wed Nov 3 14:54:44 1999 --- octave-2.9.16/libcruft/lapack/zlassq.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N --- 1,8 ---- SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, N diff -cNr octave-2.9.15/libcruft/lapack/zlaswp.f octave-2.9.16/libcruft/lapack/zlaswp.f *** octave-2.9.15/libcruft/lapack/zlaswp.f Wed Nov 3 14:54:44 1999 --- octave-2.9.16/libcruft/lapack/zlaswp.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N --- 1,8 ---- SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N *************** *** 41,47 **** * The last element of IPIV for which a row interchange will * be done. * ! * IPIV (input) INTEGER array, dimension (M*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. --- 40,46 ---- * The last element of IPIV for which a row interchange will * be done. * ! * IPIV (input) INTEGER array, dimension (K2*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. diff -cNr octave-2.9.15/libcruft/lapack/zlatbs.f octave-2.9.16/libcruft/lapack/zlatbs.f *** octave-2.9.15/libcruft/lapack/zlatbs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zlatbs.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO --- 1,9 ---- SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff -cNr octave-2.9.15/libcruft/lapack/zlatrd.f octave-2.9.16/libcruft/lapack/zlatrd.f *** octave-2.9.15/libcruft/lapack/zlatrd.f Wed Nov 3 14:54:44 1999 --- octave-2.9.16/libcruft/lapack/zlatrd.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 32,38 **** * Arguments * ========= * ! * UPLO (input) CHARACTER * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored: * = 'U': Upper triangular --- 31,37 ---- * Arguments * ========= * ! * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored: * = 'U': Upper triangular diff -cNr octave-2.9.15/libcruft/lapack/zlatrs.f octave-2.9.16/libcruft/lapack/zlatrs.f *** octave-2.9.15/libcruft/lapack/zlatrs.f Wed Nov 3 14:54:44 1999 --- octave-2.9.16/libcruft/lapack/zlatrs.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO --- 1,9 ---- SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO diff -cNr octave-2.9.15/libcruft/lapack/zlauu2.f octave-2.9.16/libcruft/lapack/zlauu2.f *** octave-2.9.15/libcruft/lapack/zlauu2.f Fri May 6 12:26:58 2005 --- octave-2.9.16/libcruft/lapack/zlauu2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zlauum.f octave-2.9.16/libcruft/lapack/zlauum.f *** octave-2.9.15/libcruft/lapack/zlauum.f Fri May 6 12:26:58 2005 --- octave-2.9.16/libcruft/lapack/zlauum.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zpbcon.f octave-2.9.16/libcruft/lapack/zpbcon.f *** octave-2.9.15/libcruft/lapack/zpbcon.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zpbcon.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ RWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,11 ---- SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ RWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 81,86 **** --- 82,90 ---- DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM COMPLEX*16 ZDUM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX *************** *** 88,94 **** EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATBS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG --- 92,98 ---- EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATBS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG *************** *** 138,144 **** KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * --- 142,148 ---- KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/zpbtf2.f octave-2.9.16/libcruft/lapack/zpbtf2.f *** octave-2.9.15/libcruft/lapack/zpbtf2.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zpbtf2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zpbtrf.f octave-2.9.16/libcruft/lapack/zpbtrf.f *** octave-2.9.15/libcruft/lapack/zpbtrf.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zpbtrf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zpbtrs.f octave-2.9.16/libcruft/lapack/zpbtrs.f *** octave-2.9.15/libcruft/lapack/zpbtrs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zpbtrs.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zpocon.f octave-2.9.16/libcruft/lapack/zpocon.f *** octave-2.9.15/libcruft/lapack/zpocon.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/zpocon.f Tue Oct 16 14:54:22 2007 *************** *** 1,10 **** SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,11 ---- SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 72,77 **** --- 73,81 ---- DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM COMPLEX*16 ZDUM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX *************** *** 79,85 **** EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX --- 83,89 ---- EXTERNAL LSAME, IZAMAX, DLAMCH * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX *************** *** 127,133 **** KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * --- 131,137 ---- KASE = 0 NORMIN = 'N' 10 CONTINUE ! CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/zpotf2.f octave-2.9.16/libcruft/lapack/zpotf2.f *** octave-2.9.15/libcruft/lapack/zpotf2.f Wed Nov 3 14:54:44 1999 --- octave-2.9.16/libcruft/lapack/zpotf2.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zpotrf.f octave-2.9.16/libcruft/lapack/zpotrf.f *** octave-2.9.15/libcruft/lapack/zpotrf.f Wed Nov 3 14:54:45 1999 --- octave-2.9.16/libcruft/lapack/zpotrf.f Tue Oct 16 14:54:22 2007 *************** *** 1,9 **** SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zpotri.f octave-2.9.16/libcruft/lapack/zpotri.f *** octave-2.9.15/libcruft/lapack/zpotri.f Fri May 6 12:26:58 2005 --- octave-2.9.16/libcruft/lapack/zpotri.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zpotrs.f octave-2.9.16/libcruft/lapack/zpotrs.f *** octave-2.9.15/libcruft/lapack/zpotrs.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/zpotrs.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zptsv.f octave-2.9.16/libcruft/lapack/zptsv.f *** octave-2.9.15/libcruft/lapack/zptsv.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zptsv.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * February 25, 1997 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS --- 1,8 ---- SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/zpttrf.f octave-2.9.16/libcruft/lapack/zpttrf.f *** octave-2.9.15/libcruft/lapack/zpttrf.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zpttrf.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZPTTRF( N, D, E, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, N --- 1,8 ---- SUBROUTINE ZPTTRF( N, D, E, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, N *************** *** 44,50 **** * > 0: if INFO = k, the leading minor of order k is not * positive definite; if k < N, the factorization could not * be completed, while if k = N, the factorization was ! * completed, but D(N) = 0. * * ===================================================================== * --- 43,49 ---- * > 0: if INFO = k, the leading minor of order k is not * positive definite; if k < N, the factorization could not * be completed, while if k = N, the factorization was ! * completed, but D(N) <= 0. * * ===================================================================== * diff -cNr octave-2.9.15/libcruft/lapack/zpttrs.f octave-2.9.16/libcruft/lapack/zpttrs.f *** octave-2.9.15/libcruft/lapack/zpttrs.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zpttrs.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO diff -cNr octave-2.9.15/libcruft/lapack/zptts2.f octave-2.9.16/libcruft/lapack/zptts2.f *** octave-2.9.15/libcruft/lapack/zptts2.f Fri Feb 25 14:55:24 2005 --- octave-2.9.16/libcruft/lapack/zptts2.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER IUPLO, LDB, N, NRHS --- 1,8 ---- SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IUPLO, LDB, N, NRHS diff -cNr octave-2.9.15/libcruft/lapack/zrot.f octave-2.9.16/libcruft/lapack/zrot.f *** octave-2.9.15/libcruft/lapack/zrot.f Wed Nov 3 14:54:45 1999 --- octave-2.9.16/libcruft/lapack/zrot.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * ! * -- LAPACK auxiliary routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, INCY, N --- 1,8 ---- SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * ! * -- LAPACK auxiliary routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INCX, INCY, N diff -cNr octave-2.9.15/libcruft/lapack/zsteqr.f octave-2.9.16/libcruft/lapack/zsteqr.f *** octave-2.9.15/libcruft/lapack/zsteqr.f Wed Nov 3 14:54:45 1999 --- octave-2.9.16/libcruft/lapack/zsteqr.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPZ --- 1,8 ---- SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER COMPZ diff -cNr octave-2.9.15/libcruft/lapack/ztrcon.f octave-2.9.16/libcruft/lapack/ztrcon.f *** octave-2.9.15/libcruft/lapack/ztrcon.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/ztrcon.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO --- 1,11 ---- SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO *************** *** 85,90 **** --- 86,94 ---- DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM COMPLEX*16 ZDUM * .. + * .. Local Arrays .. + INTEGER ISAVE( 3 ) + * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX *************** *** 92,98 **** EXTERNAL LSAME, IZAMAX, DLAMCH, ZLANTR * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX --- 96,102 ---- EXTERNAL LSAME, IZAMAX, DLAMCH, ZLANTR * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX *************** *** 157,163 **** END IF KASE = 0 10 CONTINUE ! CALL ZLACON( N, WORK( N+1 ), WORK, AINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * --- 161,167 ---- END IF KASE = 0 10 CONTINUE ! CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/ztrevc.f octave-2.9.16/libcruft/lapack/ztrevc.f *** octave-2.9.15/libcruft/lapack/ztrevc.f Wed Nov 3 14:54:45 1999 --- octave-2.9.16/libcruft/lapack/ztrevc.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE --- 1,9 ---- SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE *************** *** 22,41 **** * * ZTREVC computes some or all of the right and/or left eigenvectors of * a complex upper triangular matrix T. ! * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: ! * ! * T*x = w*x, y'*T = w*y' ! * ! * where y' denotes the conjugate transpose of the vector y. ! * ! * If all eigenvectors are requested, the routine may either return the ! * matrices X and/or Y of right or left eigenvectors of T, or the ! * products Q*X and/or Q*Y, where Q is an input unitary ! * matrix. If T was obtained from the Schur factorization of an ! * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of ! * right or left eigenvectors of A. * * Arguments * ========= --- 21,43 ---- * * ZTREVC computes some or all of the right and/or left eigenvectors of * a complex upper triangular matrix T. ! * Matrices of this type are produced by the Schur factorization of ! * a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. ! * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: ! * ! * T*x = w*x, (y**H)*T = w*(y**H) ! * ! * where y**H denotes the conjugate transpose of the vector y. ! * The eigenvalues are not input to this routine, but are read directly ! * from the diagonal of T. ! * ! * This routine returns the matrices X and/or Y of right and left ! * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an ! * input matrix. If Q is the unitary factor that reduces a matrix A to ! * Schur form T, then Q*X and Q*Y are the matrices of right and left ! * eigenvectors of A. * * Arguments * ========= *************** *** 48,64 **** * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, ! * and backtransform them using the input matrices ! * supplied in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, ! * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. ! * If HOWMNY = 'A' or 'B', SELECT is not referenced. ! * To select the eigenvector corresponding to the j-th ! * eigenvalue, SELECT(j) must be set to .TRUE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. --- 50,66 ---- * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, ! * backtransformed using the matrices supplied in ! * VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, ! * as indicated by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. ! * The eigenvector corresponding to the j-th eigenvalue is ! * computed if SELECT(j) = .TRUE.. ! * Not referenced if HOWMNY = 'A' or 'B'. * * N (input) INTEGER * The order of the matrix T. N >= 0. *************** *** 76,94 **** * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; - * VL is lower triangular. The i-th column - * VL(i) of VL is the eigenvector corresponding - * to T(i,i). * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. ! * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER ! * The leading dimension of the array VL. LDVL >= max(1,N) if ! * SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must --- 78,93 ---- * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. ! * Not referenced if SIDE = 'R'. * * LDVL (input) INTEGER ! * The leading dimension of the array VL. LDVL >= 1, and if ! * SIDE = 'L' or 'B', LDVL >= N. * * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must *************** *** 96,114 **** * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; - * VR is upper triangular. The i-th column - * VR(i) of VR is the eigenvector corresponding - * to T(i,i). * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. ! * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER ! * The leading dimension of the array VR. LDVR >= max(1,N) if ! * SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. --- 95,110 ---- * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. ! * Not referenced if SIDE = 'L'. * * LDVR (input) INTEGER ! * The leading dimension of the array VR. LDVR >= 1, and if ! * SIDE = 'R' or 'B'; LDVR >= N. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. diff -cNr octave-2.9.15/libcruft/lapack/ztrexc.f octave-2.9.16/libcruft/lapack/ztrexc.f *** octave-2.9.15/libcruft/lapack/ztrexc.f Wed Nov 3 14:54:45 1999 --- octave-2.9.16/libcruft/lapack/ztrexc.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ --- 1,8 ---- SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER COMPQ diff -cNr octave-2.9.15/libcruft/lapack/ztrsen.f octave-2.9.16/libcruft/lapack/ztrsen.f *** octave-2.9.15/libcruft/lapack/ztrsen.f Wed Nov 3 14:54:46 1999 --- octave-2.9.16/libcruft/lapack/ztrsen.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB --- 1,11 ---- SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 ! * ! * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. CHARACTER COMPQ, JOB *************** *** 92,106 **** * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) ! * If JOB = 'N', WORK is not referenced. Otherwise, ! * on exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= 1; ! * if JOB = 'E', LWORK = M*(N-M); ! * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns --- 93,106 ---- * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) ! * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= 1; ! * if JOB = 'E', LWORK = max(1,M*(N-M)); ! * if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns *************** *** 194,199 **** --- 194,200 ---- DOUBLE PRECISION EST, RNORM, SCALE * .. * .. Local Arrays .. + INTEGER ISAVE( 3 ) DOUBLE PRECISION RWORK( 1 ) * .. * .. External Functions .. *************** *** 202,208 **** EXTERNAL LSAME, ZLANGE * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZLACON, ZLACPY, ZTREXC, ZTRSYL * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT --- 203,209 ---- EXTERNAL LSAME, ZLANGE * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT *************** *** 318,324 **** EST = ZERO KASE = 0 30 CONTINUE ! CALL ZLACON( NN, WORK( NN+1 ), WORK, EST, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * --- 319,325 ---- EST = ZERO KASE = 0 30 CONTINUE ! CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * diff -cNr octave-2.9.15/libcruft/lapack/ztrsyl.f octave-2.9.16/libcruft/lapack/ztrsyl.f *** octave-2.9.15/libcruft/lapack/ztrsyl.f Wed Nov 3 14:54:46 1999 --- octave-2.9.16/libcruft/lapack/ztrsyl.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB --- 1,9 ---- SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB *************** *** 106,112 **** EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV * .. * .. External Subroutines .. ! EXTERNAL XERBLA, ZDSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN --- 105,111 ---- EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV * .. * .. External Subroutines .. ! EXTERNAL DLABAD, XERBLA, ZDSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN *************** *** 119,129 **** NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 ! IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. ! $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ! ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. ! $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 --- 118,126 ---- NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 ! IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 ! ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 diff -cNr octave-2.9.15/libcruft/lapack/ztrti2.f octave-2.9.16/libcruft/lapack/ztrti2.f *** octave-2.9.15/libcruft/lapack/ztrti2.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/ztrti2.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO --- 1,8 ---- SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff -cNr octave-2.9.15/libcruft/lapack/ztrtri.f octave-2.9.16/libcruft/lapack/ztrtri.f *** octave-2.9.15/libcruft/lapack/ztrtri.f Tue Feb 18 15:00:48 2003 --- octave-2.9.16/libcruft/lapack/ztrtri.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO --- 1,8 ---- SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO diff -cNr octave-2.9.15/libcruft/lapack/ztrtrs.f octave-2.9.16/libcruft/lapack/ztrtrs.f *** octave-2.9.15/libcruft/lapack/ztrtrs.f Wed May 3 15:32:46 2006 --- octave-2.9.16/libcruft/lapack/ztrtrs.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO --- 1,9 ---- SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff -cNr octave-2.9.15/libcruft/lapack/zung2l.f octave-2.9.16/libcruft/lapack/zung2l.f *** octave-2.9.15/libcruft/lapack/zung2l.f Wed Nov 3 14:54:46 1999 --- octave-2.9.16/libcruft/lapack/zung2l.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N --- 1,8 ---- SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/zung2r.f octave-2.9.16/libcruft/lapack/zung2r.f *** octave-2.9.15/libcruft/lapack/zung2r.f Wed Nov 3 14:54:46 1999 --- octave-2.9.16/libcruft/lapack/zung2r.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N --- 1,8 ---- SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/zungbr.f octave-2.9.16/libcruft/lapack/zungbr.f *** octave-2.9.15/libcruft/lapack/zungbr.f Wed Nov 3 14:54:46 1999 --- octave-2.9.16/libcruft/lapack/zungbr.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER VECT --- 1,8 ---- SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER VECT *************** *** 76,82 **** * reflector H(i) or G(i), which determines Q or P**H, as * returned by ZGEBRD in its array argument TAUQ or TAUP. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 75,81 ---- * reflector H(i) or G(i), which determines Q or P**H, as * returned by ZGEBRD in its array argument TAUQ or TAUP. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zunghr.f octave-2.9.16/libcruft/lapack/zunghr.f *** octave-2.9.15/libcruft/lapack/zunghr.f Wed Nov 3 14:54:47 1999 --- octave-2.9.16/libcruft/lapack/zunghr.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N --- 1,8 ---- SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N *************** *** 46,52 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEHRD. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 45,51 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEHRD. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zungl2.f octave-2.9.16/libcruft/lapack/zungl2.f *** octave-2.9.15/libcruft/lapack/zungl2.f Wed Nov 3 14:54:47 1999 --- octave-2.9.16/libcruft/lapack/zungl2.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N --- 1,8 ---- SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N diff -cNr octave-2.9.15/libcruft/lapack/zunglq.f octave-2.9.16/libcruft/lapack/zunglq.f *** octave-2.9.15/libcruft/lapack/zunglq.f Wed Nov 3 14:54:47 1999 --- octave-2.9.16/libcruft/lapack/zunglq.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N *************** *** 49,55 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 48,54 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zungql.f octave-2.9.16/libcruft/lapack/zungql.f *** octave-2.9.15/libcruft/lapack/zungql.f Wed Nov 3 14:54:47 1999 --- octave-2.9.16/libcruft/lapack/zungql.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N *************** *** 50,56 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 49,55 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER *************** *** 93,101 **** * Test the input arguments * INFO = 0 - NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 --- 92,97 ---- *************** *** 105,113 **** INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQL', -INFO ) RETURN --- 101,122 ---- INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF + * + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT + * + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF + * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQL', -INFO ) RETURN *************** *** 118,124 **** * Quick return if possible * IF( N.LE.0 ) THEN - WORK( 1 ) = 1 RETURN END IF * --- 127,132 ---- diff -cNr octave-2.9.15/libcruft/lapack/zungqr.f octave-2.9.16/libcruft/lapack/zungqr.f *** octave-2.9.15/libcruft/lapack/zungqr.f Wed Nov 3 14:54:47 1999 --- octave-2.9.16/libcruft/lapack/zungqr.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N --- 1,8 ---- SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N *************** *** 50,56 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 49,55 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zungtr.f octave-2.9.16/libcruft/lapack/zungtr.f *** octave-2.9.15/libcruft/lapack/zungtr.f Wed Nov 3 14:54:48 1999 --- octave-2.9.16/libcruft/lapack/zungtr.f Tue Oct 16 14:54:23 2007 *************** *** 1,9 **** SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO --- 1,8 ---- SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER UPLO *************** *** 48,54 **** * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZHETRD. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 47,53 ---- * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZHETRD. * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zunm2r.f octave-2.9.16/libcruft/lapack/zunm2r.f *** octave-2.9.15/libcruft/lapack/zunm2r.f Wed Nov 3 14:54:48 1999 --- octave-2.9.16/libcruft/lapack/zunm2r.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff -cNr octave-2.9.15/libcruft/lapack/zunmbr.f octave-2.9.16/libcruft/lapack/zunmbr.f *** octave-2.9.15/libcruft/lapack/zunmbr.f Wed Nov 3 14:54:48 1999 --- octave-2.9.16/libcruft/lapack/zunmbr.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT --- 1,9 ---- SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT *************** *** 98,113 **** * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); ! * if SIDE = 'R', LWORK >= max(1,M). ! * For optimum performance LWORK >= N*NB if SIDE = 'L', and ! * LWORK >= M*NB if SIDE = 'R', where NB is the optimal ! * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns --- 97,113 ---- * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); ! * if SIDE = 'R', LWORK >= max(1,M); ! * if N = 0 or M = 0, LWORK >= 1. ! * For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L', ! * and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the ! * optimal blocksize. (NB = 0 if M = 0 or N = 0.) * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns *************** *** 155,160 **** --- 155,163 ---- NQ = N NW = M END IF + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + NW = 0 + END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN *************** *** 178,201 **** END IF * IF( INFO.EQ.0 ) THEN ! IF( APPLYQ ) THEN ! IF( LEFT ) THEN ! NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, ! $ -1 ) ELSE ! NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, ! $ -1 ) END IF ELSE ! IF( LEFT ) THEN ! NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, ! $ -1 ) ! ELSE ! NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, ! $ -1 ) ! END IF END IF - LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * --- 181,208 ---- END IF * IF( INFO.EQ.0 ) THEN ! IF( NW.GT.0 ) THEN ! IF( APPLYQ ) THEN ! IF( LEFT ) THEN ! NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, ! $ -1 ) ! ELSE ! NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, ! $ -1 ) ! END IF ELSE ! IF( LEFT ) THEN ! NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, ! $ -1 ) ! ELSE ! NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, ! $ -1 ) ! END IF END IF + LWKOPT = MAX( 1, NW*NB ) ELSE ! LWKOPT = 1 END IF WORK( 1 ) = LWKOPT END IF * *************** *** 203,213 **** CALL XERBLA( 'ZUNMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN END IF * * Quick return if possible * - WORK( 1 ) = 1 IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * --- 210,220 ---- CALL XERBLA( 'ZUNMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN + RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * diff -cNr octave-2.9.15/libcruft/lapack/zunml2.f octave-2.9.16/libcruft/lapack/zunml2.f *** octave-2.9.15/libcruft/lapack/zunml2.f Wed Nov 3 14:54:48 1999 --- octave-2.9.16/libcruft/lapack/zunml2.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS diff -cNr octave-2.9.15/libcruft/lapack/zunmlq.f octave-2.9.16/libcruft/lapack/zunmlq.f *** octave-2.9.15/libcruft/lapack/zunmlq.f Wed Nov 3 14:54:48 1999 --- octave-2.9.16/libcruft/lapack/zunmlq.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS *************** *** 76,82 **** * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 75,81 ---- * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/libcruft/lapack/zunmqr.f octave-2.9.16/libcruft/lapack/zunmqr.f *** octave-2.9.15/libcruft/lapack/zunmqr.f Wed Nov 3 14:54:49 1999 --- octave-2.9.16/libcruft/lapack/zunmqr.f Tue Oct 16 14:54:23 2007 *************** *** 1,10 **** SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.0) -- ! * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! * Courant Institute, Argonne National Lab, and Rice University ! * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS --- 1,9 ---- SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * ! * -- LAPACK routine (version 3.1) -- ! * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! * November 2006 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS *************** *** 76,82 **** * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER --- 75,81 ---- * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * ! * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER diff -cNr octave-2.9.15/liboctave/CMatrix.cc octave-2.9.16/liboctave/CMatrix.cc *** octave-2.9.15/liboctave/CMatrix.cc Fri Oct 12 17:27:13 2007 --- octave-2.9.16/liboctave/CMatrix.cc Tue Oct 30 15:26:32 2007 *************** *** 126,131 **** --- 126,138 ---- Complex*, const octave_idx_type&, double*, octave_idx_type&); F77_RET_T + F77_FUNC (zgelsd, ZGELSD) (const octave_idx_type&, const octave_idx_type&, const octave_idx_type&, + Complex*, const octave_idx_type&, Complex*, + const octave_idx_type&, double*, double&, octave_idx_type&, + Complex*, const octave_idx_type&, double*, + octave_idx_type*, octave_idx_type&); + + F77_RET_T F77_FUNC (zpotrf, ZPOTRF) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&, Complex*, const octave_idx_type&, octave_idx_type& F77_CHAR_ARG_LEN_DECL); *************** *** 1202,1208 **** if (!mattype.is_hermitian ()) ret = finverse(mattype, info, rcond, force, calc_cond); ! if (rcond == 0.) ret = ComplexMatrix (rows (), columns (), Complex (octave_Inf, 0.)); } --- 1209,1215 ---- if (!mattype.is_hermitian ()) ret = finverse(mattype, info, rcond, force, calc_cond); ! if ((mattype.is_hermitian () || calc_cond) && rcond == 0.) ret = ComplexMatrix (rows (), columns (), Complex (octave_Inf, 0.)); } *************** *** 2194,2200 **** if (singular_fallback && mattype.type () == MatrixType::Rectangular) { octave_idx_type rank; ! retval = lssolve (b, info, rank); } return retval; --- 2201,2207 ---- if (singular_fallback && mattype.type () == MatrixType::Rectangular) { octave_idx_type rank; ! retval = lssolve (b, info, rank, rcond); } return retval; *************** *** 2388,2407 **** { octave_idx_type info; octave_idx_type rank; ! return lssolve (ComplexMatrix (b), info, rank); } ComplexMatrix ComplexMatrix::lssolve (const Matrix& b, octave_idx_type& info) const { octave_idx_type rank; ! return lssolve (ComplexMatrix (b), info, rank); } ComplexMatrix ! ComplexMatrix::lssolve (const Matrix& b, octave_idx_type& info, octave_idx_type& rank) const { ! return lssolve (ComplexMatrix (b), info, rank); } ComplexMatrix --- 2395,2425 ---- { octave_idx_type info; octave_idx_type rank; ! double rcond; ! return lssolve (ComplexMatrix (b), info, rank, rcond); } ComplexMatrix ComplexMatrix::lssolve (const Matrix& b, octave_idx_type& info) const { octave_idx_type rank; ! double rcond; ! return lssolve (ComplexMatrix (b), info, rank, rcond); ! } ! ! ComplexMatrix ! ComplexMatrix::lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank) const ! { ! double rcond; ! return lssolve (ComplexMatrix (b), info, rank, rcond); } ComplexMatrix ! ComplexMatrix::lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank, double& rcond) const { ! return lssolve (ComplexMatrix (b), info, rank, rcond); } ComplexMatrix *************** *** 2409,2426 **** { octave_idx_type info; octave_idx_type rank; ! return lssolve (b, info, rank); } ComplexMatrix ComplexMatrix::lssolve (const ComplexMatrix& b, octave_idx_type& info) const { octave_idx_type rank; ! return lssolve (b, info, rank); } ComplexMatrix ! ComplexMatrix::lssolve (const ComplexMatrix& b, octave_idx_type& info, octave_idx_type& rank) const { ComplexMatrix retval; --- 2427,2455 ---- { octave_idx_type info; octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); } ComplexMatrix ComplexMatrix::lssolve (const ComplexMatrix& b, octave_idx_type& info) const { octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); ! } ! ! ComplexMatrix ! ComplexMatrix::lssolve (const ComplexMatrix& b, octave_idx_type& info, ! octave_idx_type& rank) const ! { ! double rcond; ! return lssolve (b, info, rank, rcond); } ComplexMatrix ! ComplexMatrix::lssolve (const ComplexMatrix& b, octave_idx_type& info, ! octave_idx_type& rank, double& rcond) const { ComplexMatrix retval; *************** *** 2436,2493 **** retval = ComplexMatrix (n, b.cols (), Complex (0.0, 0.0)); else { ! ComplexMatrix atmp = *this; ! Complex *tmp_data = atmp.fortran_vec (); ! octave_idx_type nrr = m > n ? m : n; ! ComplexMatrix result (nrr, nrhs); ! ! for (octave_idx_type j = 0; j < nrhs; j++) ! for (octave_idx_type i = 0; i < m; i++) ! result.elem (i, j) = b.elem (i, j); ! ! Complex *presult = result.fortran_vec (); ! ! Array jpvt (n); ! octave_idx_type *pjpvt = jpvt.fortran_vec (); ! double rcond = -1.0; ! Array rwork (2 * n); ! double *prwork = rwork.fortran_vec (); ! // Ask ZGELSY what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! F77_XFCN (zgelsy, ZGELSY, (m, n, nrhs, tmp_data, m, presult, ! nrr, pjpvt, rcond, rank, ! work.fortran_vec (), lwork, prwork, ! info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ("unrecoverable error in zgelsy"); else { lwork = static_cast (std::real (work(0))); work.resize (lwork); ! F77_XFCN (zgelsy, ZGELSY, (m, n, nrhs, tmp_data, m, presult, ! nrr, pjpvt, rcond, rank, ! work.fortran_vec (), lwork, ! prwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in zgelsy"); else { retval.resize (n, nrhs); - for (octave_idx_type j = 0; j < nrhs; j++) - for (octave_idx_type i = 0; i < n; i++) - retval.elem (i, j) = result.elem (i, j); } } } --- 2465,2558 ---- retval = ComplexMatrix (n, b.cols (), Complex (0.0, 0.0)); else { ! volatile octave_idx_type minmn = (m < n ? m : n); ! octave_idx_type maxmn = m > n ? m : n; ! rcond = -1.0; ! if (m != n) ! { ! retval = ComplexMatrix (maxmn, nrhs); ! for (octave_idx_type j = 0; j < nrhs; j++) ! for (octave_idx_type i = 0; i < m; i++) ! retval.elem (i, j) = b.elem (i, j); ! } ! else ! retval = b; ! ComplexMatrix atmp = *this; ! Complex *tmp_data = atmp.fortran_vec (); ! Complex *pretval = retval.fortran_vec (); ! Array s (minmn); ! double *ps = s.fortran_vec (); + // Ask ZGELSD what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! // FIXME: Can SMLSIZ be other than 25? ! octave_idx_type smlsiz = 25; ! ! // We compute the size of rwork and iwork because ZGELSD in ! // older versions of LAPACK does not return them on a query ! // call. ! #if defined (HAVE_LOG2) ! double tmp = log2 (minmn) / static_cast (smlsiz+1) + 1; ! #else ! double tmp = log (minmn) / static_cast (smlsiz+1) / log (2) + 1; ! #endif ! octave_idx_type nlvl = static_cast (tmp); ! if (nlvl < 0) ! nlvl = 0; ! ! octave_idx_type lrwork = minmn*(10 + 2*smlsiz + 8*nlvl) ! + 3*smlsiz*nrhs + (smlsiz+1)*(smlsiz+1); ! if (lrwork < 1) ! lrwork = 1; ! Array rwork (lrwork); ! double *prwork = rwork.fortran_vec (); ! ! octave_idx_type liwork = 3 * minmn * nlvl + 11 * minmn; ! if (liwork < 1) ! liwork = 1; ! Array iwork (liwork); ! octave_idx_type* piwork = iwork.fortran_vec (); ! ! F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, tmp_data, m, pretval, maxmn, ! ps, rcond, rank, work.fortran_vec (), ! lwork, prwork, piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in zgelsd"); else { lwork = static_cast (std::real (work(0))); work.resize (lwork); ! F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, tmp_data, m, pretval, ! maxmn, ps, rcond, rank, ! work.fortran_vec (), lwork, ! prwork, piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in zgelsd"); else { + if (rank < minmn) + (*current_liboctave_warning_handler) + ("zgelsd: rank deficient %dx%d matrix, rank = %d, tol = %e", + m, n, rank, rcond); + + if (s.elem (0) == 0.0) + rcond = 0.0; + else + rcond = s.elem (minmn - 1) / s.elem (0); + retval.resize (n, nrhs); } } } *************** *** 2500,2519 **** { octave_idx_type info; octave_idx_type rank; ! return lssolve (ComplexColumnVector (b), info, rank); } ComplexColumnVector ComplexMatrix::lssolve (const ColumnVector& b, octave_idx_type& info) const { octave_idx_type rank; ! return lssolve (ComplexColumnVector (b), info, rank); } ComplexColumnVector ! ComplexMatrix::lssolve (const ColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const { ! return lssolve (ComplexColumnVector (b), info, rank); } ComplexColumnVector --- 2565,2595 ---- { octave_idx_type info; octave_idx_type rank; ! double rcond; ! return lssolve (ComplexColumnVector (b), info, rank, rcond); } ComplexColumnVector ComplexMatrix::lssolve (const ColumnVector& b, octave_idx_type& info) const { octave_idx_type rank; ! double rcond; ! return lssolve (ComplexColumnVector (b), info, rank, rcond); ! } ! ! ComplexColumnVector ! ComplexMatrix::lssolve (const ColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank) const ! { ! double rcond; ! return lssolve (ComplexColumnVector (b), info, rank, rcond); } ComplexColumnVector ! ComplexMatrix::lssolve (const ColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank, double& rcond) const { ! return lssolve (ComplexColumnVector (b), info, rank, rcond); } ComplexColumnVector *************** *** 2521,2540 **** { octave_idx_type info; octave_idx_type rank; ! return lssolve (b, info, rank); } ComplexColumnVector ComplexMatrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info) const { octave_idx_type rank; ! return lssolve (b, info, rank); } ComplexColumnVector ComplexMatrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const { ComplexColumnVector retval; octave_idx_type nrhs = 1; --- 2597,2627 ---- { octave_idx_type info; octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); } ComplexColumnVector ComplexMatrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info) const { octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); } ComplexColumnVector ComplexMatrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const { + double rcond; + return lssolve (b, info, rank, rcond); + + } + + ComplexColumnVector + ComplexMatrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info, + octave_idx_type& rank, double& rcond) const + { ComplexColumnVector retval; octave_idx_type nrhs = 1; *************** *** 2549,2604 **** retval = ComplexColumnVector (n, Complex (0.0, 0.0)); else { ! ComplexMatrix atmp = *this; ! Complex *tmp_data = atmp.fortran_vec (); ! ! octave_idx_type nrr = m > n ? m : n; ! ComplexColumnVector result (nrr); ! ! for (octave_idx_type i = 0; i < m; i++) ! result.elem (i) = b.elem (i); ! Complex *presult = result.fortran_vec (); ! ! Array jpvt (n); ! octave_idx_type *pjpvt = jpvt.fortran_vec (); ! double rcond = -1.0; ! Array rwork (2 * n); ! double *prwork = rwork.fortran_vec (); ! // Ask ZGELSY what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! F77_XFCN (zgelsy, ZGELSY, (m, n, nrhs, tmp_data, m, presult, ! nrr, pjpvt, rcond, rank, ! work.fortran_vec (), lwork, prwork, ! info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ("unrecoverable error in zgelsy"); else { ! lwork = static_cast (std::real (work(0))); work.resize (lwork); ! F77_XFCN (zgelsy, ZGELSY, (m, n, nrhs, tmp_data, m, presult, ! nrr, pjpvt, rcond, rank, ! work.fortran_vec (), lwork, ! prwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in zgelsy"); ! else { ! retval.resize (n); ! for (octave_idx_type i = 0; i < n; i++) ! retval.elem (i) = result.elem (i); } } } --- 2636,2730 ---- retval = ComplexColumnVector (n, Complex (0.0, 0.0)); else { ! volatile octave_idx_type minmn = (m < n ? m : n); ! octave_idx_type maxmn = m > n ? m : n; ! rcond = -1.0; ! if (m != n) ! { ! retval = ComplexColumnVector (maxmn); ! for (octave_idx_type i = 0; i < m; i++) ! retval.elem (i) = b.elem (i); ! } ! else ! retval = b; ! ComplexMatrix atmp = *this; ! Complex *tmp_data = atmp.fortran_vec (); ! Complex *pretval = retval.fortran_vec (); ! Array s (minmn); ! double *ps = s.fortran_vec (); + // Ask ZGELSD what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! // FIXME: Can SMLSIZ be other than 25? ! octave_idx_type smlsiz = 25; ! ! // We compute the size of rwork and iwork because ZGELSD in ! // older versions of LAPACK does not return them on a query ! // call. ! #if defined (HAVE_LOG2) ! double tmp = log2 (minmn) / static_cast (smlsiz+1) + 1; ! #else ! double tmp = log (minmn) / static_cast (smlsiz+1) / log (2) + 1; ! #endif ! octave_idx_type nlvl = static_cast (tmp); ! if (nlvl < 0) ! nlvl = 0; ! ! octave_idx_type lrwork = minmn*(10 + 2*smlsiz + 8*nlvl) ! + 3*smlsiz*nrhs + (smlsiz+1)*(smlsiz+1); ! if (lrwork < 1) ! lrwork = 1; ! Array rwork (lrwork); ! double *prwork = rwork.fortran_vec (); ! ! octave_idx_type liwork = 3 * minmn * nlvl + 11 * minmn; ! if (liwork < 1) ! liwork = 1; ! Array iwork (liwork); ! octave_idx_type* piwork = iwork.fortran_vec (); ! ! F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, tmp_data, m, pretval, maxmn, ! ps, rcond, rank, work.fortran_vec (), ! lwork, prwork, piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in zgelsd"); else { ! lwork = static_cast (std::real (work(0))); work.resize (lwork); + rwork.resize (static_cast (rwork(0))); + iwork.resize (iwork(0)); ! F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, tmp_data, m, pretval, ! maxmn, ps, rcond, rank, ! work.fortran_vec (), lwork, ! prwork, piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in zgelsd"); ! else if (rank < minmn) { ! if (rank < minmn) ! (*current_liboctave_warning_handler) ! ("zgelsd: rank deficient %dx%d matrix, rank = %d, tol = %e", ! m, n, rank, rcond); ! ! if (s.elem (0) == 0.0) ! rcond = 0.0; ! else ! rcond = s.elem (minmn - 1) / s.elem (0); ! ! retval.resize (n, nrhs); } } } diff -cNr octave-2.9.15/liboctave/CMatrix.h octave-2.9.16/liboctave/CMatrix.h *** octave-2.9.15/liboctave/CMatrix.h Fri Oct 12 17:27:13 2007 --- octave-2.9.16/liboctave/CMatrix.h Mon Oct 29 14:09:57 2007 *************** *** 260,281 **** ComplexMatrix lssolve (const Matrix& b) const; ComplexMatrix lssolve (const Matrix& b, octave_idx_type& info) const; ! ComplexMatrix lssolve (const Matrix& b, octave_idx_type& info, octave_idx_type& rank) const; ComplexMatrix lssolve (const ComplexMatrix& b) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info, octave_idx_type& rank) const; ComplexColumnVector lssolve (const ColumnVector& b) const; ! ComplexColumnVector lssolve (const ColumnVector& b, octave_idx_type& info) const; ComplexColumnVector lssolve (const ColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const; ComplexColumnVector lssolve (const ComplexColumnVector& b) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, octave_idx_type& info) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const; ComplexMatrix expm (void) const; --- 260,294 ---- ComplexMatrix lssolve (const Matrix& b) const; ComplexMatrix lssolve (const Matrix& b, octave_idx_type& info) const; ! ComplexMatrix lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank) const; ! ComplexMatrix lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank, double& rcond) const; ComplexMatrix lssolve (const ComplexMatrix& b) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info, octave_idx_type& rank) const; + ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info, + octave_idx_type& rank, double& rcond) const; ComplexColumnVector lssolve (const ColumnVector& b) const; ! ComplexColumnVector lssolve (const ColumnVector& b, ! octave_idx_type& info) const; ComplexColumnVector lssolve (const ColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const; + ComplexColumnVector lssolve (const ColumnVector& b, octave_idx_type& info, + octave_idx_type& rank, double& rcond) const; ComplexColumnVector lssolve (const ComplexColumnVector& b) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, ! octave_idx_type& info) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, ! octave_idx_type& info, octave_idx_type& rank) const; + ComplexColumnVector lssolve (const ComplexColumnVector& b, + octave_idx_type& info, + octave_idx_type& rank, double& rcond) const; ComplexMatrix expm (void) const; diff -cNr octave-2.9.15/liboctave/CRowVector.cc octave-2.9.16/liboctave/CRowVector.cc *** octave-2.9.15/liboctave/CRowVector.cc Fri Oct 12 17:27:13 2007 --- octave-2.9.16/liboctave/CRowVector.cc Tue Oct 23 13:46:48 2007 *************** *** 502,509 **** gripe_nonconformant ("operator *", len, a_len); else if (len != 0) F77_FUNC (xzdotu, XZDOTU) (len, v.data (), 1, a.data (), 1, retval); - for (octave_idx_type i = 0; i < len; i++) - retval += v.elem (i) * a.elem (i); return retval; } --- 502,507 ---- diff -cNr octave-2.9.15/liboctave/CSparse.cc octave-2.9.16/liboctave/CSparse.cc *** octave-2.9.15/liboctave/CSparse.cc Fri Oct 12 17:27:13 2007 --- octave-2.9.16/liboctave/CSparse.cc Wed Oct 17 15:02:10 2007 *************** *** 5770,5792 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate if - // it runs out of memory. Use CHOLMOD's memory guard for - // METIS, which allocates a huge block of memory (and then - // immediately frees it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free. - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. - cm->metis_memory = 0.0; - #endif - #endif - #endif cm->final_ll = true; cholmod_sparse Astore; --- 5770,5775 ---- *************** *** 6030,6055 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate MATLAB if - // it runs out of memory. Use CHOLMOD's memory guard for METIS, - // which mxMalloc's a huge block of memory (and then immediately - // mxFree's it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. It is not needed, because mxMalloc - // will safely terminate the mexFunction and free any workspace - // without killing all of octave. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_ll = true; cholmod_sparse Astore; --- 6013,6018 ---- *************** *** 6341,6366 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate MATLAB if - // it runs out of memory. Use CHOLMOD's memory guard for METIS, - // which mxMalloc's a huge block of memory (and then immediately - // mxFree's it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. It is not needed, because mxMalloc - // will safely terminate the mexFunction and free any workspace - // without killing all of octave. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_ll = true; cholmod_sparse Astore; --- 6304,6309 ---- *************** *** 6583,6608 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate MATLAB if - // it runs out of memory. Use CHOLMOD's memory guard for METIS, - // which mxMalloc's a huge block of memory (and then immediately - // mxFree's it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. It is not needed, because mxMalloc - // will safely terminate the mexFunction and free any workspace - // without killing all of octave. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_ll = true; cholmod_sparse Astore; --- 6526,6531 ---- diff -cNr octave-2.9.15/liboctave/ChangeLog octave-2.9.16/liboctave/ChangeLog *** octave-2.9.15/liboctave/ChangeLog Fri Oct 12 02:40:58 2007 --- octave-2.9.16/liboctave/ChangeLog Tue Oct 30 21:08:15 2007 *************** *** 1,3 **** --- 1,95 ---- + 2007-10-30 David Bateman + + * DASRT-opts.in, LSODE-opts.in: Doc fixes for small book format. + + 2007-10-30 John W. Eaton + + * CMatrix.cc (lssolve): Compute size of rwork and iwork arrays. + * dMatrix.cc (lssolve): Compute size of iwork array. + + 2007-10-29 David Bateman + + * CMatrix.h (lssolve (const Matrix&, octave_idx_type&, + octave_idx_type&, double&) const, lssolve (const ComplexMatrix&, + octave_idx_type&, octave_idx_type&, double&) const, lssolve + (const ColumnVector&, octave_idx_type&, octave_idx_type&, + double& rcond) const, lssolve (const ComplexColumnVector&, + octave_idx_type&, octave_idx_type&, double& rcond) const): New + declarations. + * CMatrix.cc (lssolve (const Matrix&, octave_idx_type&, + octave_idx_type&, double&) const, lssolve (const ComplexMatrix&, + octave_idx_type&, octave_idx_type&, double&) const, lssolve + (const ColumnVector&, octave_idx_type&, octave_idx_type&, + double& rcond) const, lssolve (const ComplexColumnVector&, + octave_idx_type&, octave_idx_type&, double& rcond) const): New + methods. + (lssolve (const Matrix&, octave_idx_type&, octave_idx_type&, + double&) const, lssolve (const ComplexMatrix&, octave_idx_type&, + octave_idx_type&, double&) const): Also return rcond from the + singular values returned by XGELSD. + * dMatrix.h (lssolve (const Matrix&, octave_idx_type&, + octave_idx_type&, double&) const, lssolve (const ComplexMatrix&, + octave_idx_type&, octave_idx_type&, double&) const, lssolve + (const ColumnVector&, octave_idx_type&, octave_idx_type&, + double& rcond) const, lssolve (const ComplexColumnVector&, + octave_idx_type&, octave_idx_type&, double& rcond) const): New + declarations. + * dMatrix.cc (lssolve (const Matrix&, octave_idx_type&, + octave_idx_type&, double&) const, lssolve (const ComplexMatrix&, + octave_idx_type&, octave_idx_type&, double&) const, lssolve + (const ColumnVector&, octave_idx_type&, octave_idx_type&, + double& rcond) const, lssolve (const ComplexColumnVector&, + octave_idx_type&, octave_idx_type&, double& rcond) const): New + methods. + (lssolve (const Matrix&, octave_idx_type&, octave_idx_type&, + double&) const, lssolve (const ComplexMatrix&, octave_idx_type&, + octave_idx_type&, double&) const): Also return rcond from the + singular values returned by XGELSD. + + 2007-10-26 David Bateman + + * dMatrix.cc (Matrix::lssolve): Use xGELSD for rank deficient + matrices to avoid reliability issues with xGELSY. + * CMatrix.cc (ComplexMatrix::lssolve): Likewise. + + 2007-10-25 John W. Eaton + + * oct-time.cc (octave_gmtime::init, octave_localtime::init): + Call unix_time on arg instead of relying on conversion operator. + + * oct-time.h (octave_time::double_value): New function. + (octave_time::operator double () const): Delete. + (octave_time::operator time_t () const): Delete. + + 2007-10-24 John W. Eaton + + * strptime.c: Also compile if OCTAVE_HAVE_BROKEN_STRPTIME is defined. + + 2007-10-23 John W. Eaton + + * CRowVector.cc (operator * const ComplexRowVector&, const + ComplexColumnVector&)): Delete spurious code left from patch. + + 2007-10-22 Kim Hansen + + * chMatrix.cc, lo-utils.cc, oct-env.cc, oct-uname.cc, + sparse-sort.cc: Include . + + 2007-10-17 John W. Eaton + + * oct-sparse.h: Don't include metis.h. + + * dSparse.cc (SparseMatrix::fsolve): Delete special code for METIS. + * CSparse.cc (SparseComplexMatrix::fsolve): Likewise. + * sparse-base-chol.cc (sparse_base_chol::sparse_base_chol_rep::init): Likewise. + + 2007-10-16 John W. Eaton + + * dMatrix.cc (Matrix::inverse): Only check rcond == 0 if the + matrix is hermitian or calc_cond is true. + * CMatrix.cc (ComplexMatrix::inverse): Likewise. + 2007-10-12 John W. Eaton * Change copyright notices in all files that are part of Octave to diff -cNr octave-2.9.15/liboctave/DASRT-opts.in octave-2.9.16/liboctave/DASRT-opts.in *** octave-2.9.15/liboctave/DASRT-opts.in Fri Oct 12 17:27:14 2007 --- octave-2.9.16/liboctave/DASRT-opts.in Tue Oct 30 21:08:15 2007 *************** *** 55,61 **** The local error test applied at each integration step is @example ! abs (local error in x(i)) <= rtol(i) * abs (Y(i)) + atol(i) @end example END_DOC_ITEM TYPE = "Array" --- 55,62 ---- The local error test applied at each integration step is @example ! abs (local error in x(i)) <= ... ! rtol(i) * abs (Y(i)) + atol(i) @end example END_DOC_ITEM TYPE = "Array" diff -cNr octave-2.9.15/liboctave/LSODE-opts.in octave-2.9.16/liboctave/LSODE-opts.in *** octave-2.9.15/liboctave/LSODE-opts.in Fri Oct 12 17:27:14 2007 --- octave-2.9.16/liboctave/LSODE-opts.in Tue Oct 30 21:08:15 2007 *************** *** 54,60 **** The local error test applied at each integration step is @example ! abs (local error in x(i)) <= rtol * abs (y(i)) + atol(i) @end example END_DOC_ITEM TYPE = "double" --- 54,61 ---- The local error test applied at each integration step is @example ! abs (local error in x(i)) <= ... ! rtol * abs (y(i)) + atol(i) @end example END_DOC_ITEM TYPE = "double" diff -cNr octave-2.9.15/liboctave/chMatrix.cc octave-2.9.16/liboctave/chMatrix.cc *** octave-2.9.15/liboctave/chMatrix.cc Fri Oct 12 17:27:15 2007 --- octave-2.9.16/liboctave/chMatrix.cc Mon Oct 22 12:55:41 2007 *************** *** 26,31 **** --- 26,33 ---- #include #endif + #include + #include #include diff -cNr octave-2.9.15/liboctave/dMatrix.cc octave-2.9.16/liboctave/dMatrix.cc *** octave-2.9.15/liboctave/dMatrix.cc Fri Oct 12 17:27:15 2007 --- octave-2.9.16/liboctave/dMatrix.cc Tue Oct 30 15:26:33 2007 *************** *** 123,128 **** --- 123,135 ---- double*, const octave_idx_type&, octave_idx_type&); F77_RET_T + F77_FUNC (dgelsd, DGELSD) (const octave_idx_type&, const octave_idx_type&, const octave_idx_type&, + double*, const octave_idx_type&, double*, + const octave_idx_type&, double*, double&, octave_idx_type&, + double*, const octave_idx_type&, octave_idx_type*, + octave_idx_type&); + + F77_RET_T F77_FUNC (dpotrf, DPOTRF) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&, double *, const octave_idx_type&, octave_idx_type& F77_CHAR_ARG_LEN_DECL); *************** *** 871,877 **** if (!mattype.is_hermitian ()) ret = finverse(mattype, info, rcond, force, calc_cond); ! if (rcond == 0.) ret = Matrix (rows (), columns (), octave_Inf); } --- 878,884 ---- if (!mattype.is_hermitian ()) ret = finverse(mattype, info, rcond, force, calc_cond); ! if ((mattype.is_hermitian () || calc_cond) && rcond == 0.) ret = Matrix (rows (), columns (), octave_Inf); } *************** *** 1812,1818 **** if (singular_fallback && mattype.type () == MatrixType::Rectangular) { octave_idx_type rank; ! retval = lssolve (b, info, rank); } return retval; --- 1819,1825 ---- if (singular_fallback && mattype.type () == MatrixType::Rectangular) { octave_idx_type rank; ! retval = lssolve (b, info, rank, rcond); } return retval; *************** *** 2032,2049 **** { octave_idx_type info; octave_idx_type rank; ! return lssolve (b, info, rank); } Matrix Matrix::lssolve (const Matrix& b, octave_idx_type& info) const { octave_idx_type rank; ! return lssolve (b, info, rank); } Matrix ! Matrix::lssolve (const Matrix& b, octave_idx_type& info, octave_idx_type& rank) const { Matrix retval; --- 2039,2067 ---- { octave_idx_type info; octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); } Matrix Matrix::lssolve (const Matrix& b, octave_idx_type& info) const { octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); ! } ! ! Matrix ! Matrix::lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank) const ! { ! double rcond; ! return lssolve (b, info, rank, rcond); } Matrix ! Matrix::lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank, double &rcond) const { Matrix retval; *************** *** 2052,2058 **** octave_idx_type m = rows (); octave_idx_type n = cols (); - if (m != b.rows ()) (*current_liboctave_error_handler) ("matrix dimension mismatch solution of linear equations"); --- 2070,2075 ---- *************** *** 2060,2112 **** retval = Matrix (n, b.cols (), 0.0); else { ! Matrix atmp = *this; ! double *tmp_data = atmp.fortran_vec (); ! ! octave_idx_type nrr = m > n ? m : n; ! Matrix result (nrr, nrhs, 0.0); ! ! for (octave_idx_type j = 0; j < nrhs; j++) ! for (octave_idx_type i = 0; i < m; i++) ! result.elem (i, j) = b.elem (i, j); ! ! double *presult = result.fortran_vec (); ! Array jpvt (n); ! octave_idx_type *pjpvt = jpvt.fortran_vec (); ! double rcond = -1.0; ! // Ask DGELSY what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! F77_XFCN (dgelsy, DGELSY, (m, n, nrhs, tmp_data, m, presult, nrr, pjpvt, ! rcond, rank, work.fortran_vec (), ! lwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ("unrecoverable error in dgelsy"); else { lwork = static_cast (work(0)); work.resize (lwork); ! F77_XFCN (dgelsy, DGELSY, (m, n, nrhs, tmp_data, m, presult, ! nrr, pjpvt, rcond, rank, ! work.fortran_vec (), lwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in dgelsy"); ! else { retval.resize (n, nrhs); - for (octave_idx_type j = 0; j < nrhs; j++) - for (octave_idx_type i = 0; i < n; i++) - retval.elem (i, j) = result.elem (i, j); } } } --- 2077,2159 ---- retval = Matrix (n, b.cols (), 0.0); else { ! volatile octave_idx_type minmn = (m < n ? m : n); ! octave_idx_type maxmn = m > n ? m : n; ! rcond = -1.0; ! if (m != n) ! { ! retval = Matrix (maxmn, nrhs, 0.0); ! for (octave_idx_type j = 0; j < nrhs; j++) ! for (octave_idx_type i = 0; i < m; i++) ! retval.elem (i, j) = b.elem (i, j); ! } ! else ! retval = b; ! Matrix atmp = *this; ! double *tmp_data = atmp.fortran_vec (); ! double *pretval = retval.fortran_vec (); ! Array s (minmn); ! double *ps = s.fortran_vec (); + // Ask DGELSD what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! // FIXME: Can SMLSIZ be other than 25? ! octave_idx_type smlsiz = 25; ! ! // We compute the size of iwork because DGELSD in older versions ! // of LAPACK does not return it on a query call. ! #if defined (HAVE_LOG2) ! double tmp = log2 (minmn) / static_cast (smlsiz+1) + 1; ! #else ! double tmp = log (minmn) / static_cast (smlsiz+1) / log (2) + 1; ! #endif ! octave_idx_type nlvl = static_cast (tmp); ! if (nlvl < 0) ! nlvl = 0; ! ! octave_idx_type liwork = 3 * minmn * nlvl + 11 * minmn; ! if (liwork < 1) ! liwork = 1; ! Array iwork (liwork); ! octave_idx_type* piwork = iwork.fortran_vec (); ! ! F77_XFCN (dgelsd, DGELSD, (m, n, nrhs, tmp_data, m, pretval, maxmn, ! ps, rcond, rank, work.fortran_vec (), ! lwork, piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in dgelsd"); else { lwork = static_cast (work(0)); work.resize (lwork); ! F77_XFCN (dgelsd, DGELSD, (m, n, nrhs, tmp_data, m, pretval, ! maxmn, ps, rcond, rank, ! work.fortran_vec (), lwork, ! piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in dgelsd"); ! else { + if (rank < minmn) + (*current_liboctave_warning_handler) + ("dgelsd: rank deficient %dx%d matrix, rank = %d", m, n, rank); + if (s.elem (0) == 0.0) + rcond = 0.0; + else + rcond = s.elem (minmn - 1) / s.elem (0); + retval.resize (n, nrhs); } } } *************** *** 2120,2126 **** ComplexMatrix tmp (*this); octave_idx_type info; octave_idx_type rank; ! return tmp.lssolve (b, info, rank); } ComplexMatrix --- 2167,2174 ---- ComplexMatrix tmp (*this); octave_idx_type info; octave_idx_type rank; ! double rcond; ! return tmp.lssolve (b, info, rank, rcond); } ComplexMatrix *************** *** 2128,2141 **** { ComplexMatrix tmp (*this); octave_idx_type rank; ! return tmp.lssolve (b, info, rank); } ComplexMatrix ! Matrix::lssolve (const ComplexMatrix& b, octave_idx_type& info, octave_idx_type& rank) const { ComplexMatrix tmp (*this); ! return tmp.lssolve (b, info, rank); } ColumnVector --- 2176,2200 ---- { ComplexMatrix tmp (*this); octave_idx_type rank; ! double rcond; ! return tmp.lssolve (b, info, rank, rcond); ! } ! ! ComplexMatrix ! Matrix::lssolve (const ComplexMatrix& b, octave_idx_type& info, ! octave_idx_type& rank) const ! { ! ComplexMatrix tmp (*this); ! double rcond; ! return tmp.lssolve (b, info, rank, rcond); } ComplexMatrix ! Matrix::lssolve (const ComplexMatrix& b, octave_idx_type& info, ! octave_idx_type& rank, double& rcond) const { ComplexMatrix tmp (*this); ! return tmp.lssolve (b, info, rank, rcond); } ColumnVector *************** *** 2143,2160 **** { octave_idx_type info; octave_idx_type rank; ! return lssolve (b, info, rank); } ColumnVector Matrix::lssolve (const ColumnVector& b, octave_idx_type& info) const { octave_idx_type rank; ! return lssolve (b, info, rank); } ColumnVector ! Matrix::lssolve (const ColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const { ColumnVector retval; --- 2202,2230 ---- { octave_idx_type info; octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); } ColumnVector Matrix::lssolve (const ColumnVector& b, octave_idx_type& info) const { octave_idx_type rank; ! double rcond; ! return lssolve (b, info, rank, rcond); } ColumnVector ! Matrix::lssolve (const ColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank) const ! { ! double rcond; ! return lssolve (b, info, rank, rcond); ! } ! ! ColumnVector ! Matrix::lssolve (const ColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank, double &rcond) const { ColumnVector retval; *************** *** 2170,2221 **** retval = ColumnVector (n, 0.0); else { ! Matrix atmp = *this; ! double *tmp_data = atmp.fortran_vec (); ! ! octave_idx_type nrr = m > n ? m : n; ! ColumnVector result (nrr); ! ! for (octave_idx_type i = 0; i < m; i++) ! result.elem (i) = b.elem (i); ! ! double *presult = result.fortran_vec (); ! Array jpvt (n); ! octave_idx_type *pjpvt = jpvt.fortran_vec (); ! double rcond = -1.0; ! // Ask DGELSY what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! F77_XFCN (dgelsy, DGELSY, (m, n, nrhs, tmp_data, m, presult, nrr, pjpvt, ! rcond, rank, work.fortran_vec (), ! lwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ("unrecoverable error in dgelsy"); else { lwork = static_cast (work(0)); work.resize (lwork); ! F77_XFCN (dgelsy, DGELSY, (m, n, nrhs, tmp_data, m, presult, ! nrr, pjpvt, rcond, rank, ! work.fortran_vec (), lwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in dgelsy"); ! else { ! retval.resize (n); ! for (octave_idx_type i = 0; i < n; i++) ! retval.elem (i) = result.elem (i); } } } --- 2240,2323 ---- retval = ColumnVector (n, 0.0); else { ! volatile octave_idx_type minmn = (m < n ? m : n); ! octave_idx_type maxmn = m > n ? m : n; ! rcond = -1.0; ! ! if (m != n) ! { ! retval = ColumnVector (maxmn, 0.0); ! for (octave_idx_type i = 0; i < m; i++) ! retval.elem (i) = b.elem (i); ! } ! else ! retval = b; ! Matrix atmp = *this; ! double *tmp_data = atmp.fortran_vec (); ! double *pretval = retval.fortran_vec (); ! Array s (minmn); ! double *ps = s.fortran_vec (); + // Ask DGELSD what the dimension of WORK should be. octave_idx_type lwork = -1; Array work (1); ! // FIXME: Can SMLSIZ be other than 25? ! octave_idx_type smlsiz = 25; ! ! // We compute the size of iwork because DGELSD in older versions ! // of LAPACK does not return it on a query call. ! #if defined (HAVE_LOG2) ! double tmp = log2 (minmn) / static_cast (smlsiz+1) + 1; ! #else ! double tmp = log (minmn) / static_cast (smlsiz+1) / log (2) + 1; ! #endif ! octave_idx_type nlvl = static_cast (tmp); ! if (nlvl < 0) ! nlvl = 0; ! ! octave_idx_type liwork = 3 * minmn * nlvl + 11 * minmn; ! if (liwork < 1) ! liwork = 1; ! Array iwork (liwork); ! octave_idx_type* piwork = iwork.fortran_vec (); ! ! F77_XFCN (dgelsd, DGELSD, (m, n, nrhs, tmp_data, m, pretval, maxmn, ! ps, rcond, rank, work.fortran_vec (), ! lwork, piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in dgelsd"); else { lwork = static_cast (work(0)); work.resize (lwork); ! F77_XFCN (dgelsd, DGELSD, (m, n, nrhs, tmp_data, m, pretval, ! maxmn, ps, rcond, rank, ! work.fortran_vec (), lwork, ! piwork, info)); if (f77_exception_encountered) ! (*current_liboctave_error_handler) ! ("unrecoverable error in dgelsd"); ! else if (rank < minmn) { ! if (rank < minmn) ! (*current_liboctave_warning_handler) ! ("dgelsd: rank deficient %dx%d matrix, rank = %d", m, n, rank); ! if (s.elem (0) == 0.0) ! rcond = 0.0; ! else ! rcond = s.elem (minmn - 1) / s.elem (0); } + + retval.resize (n, nrhs); } } *************** *** 2226,2246 **** Matrix::lssolve (const ComplexColumnVector& b) const { ComplexMatrix tmp (*this); ! return tmp.lssolve (b); } ComplexColumnVector Matrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info) const { ComplexMatrix tmp (*this); ! return tmp.lssolve (b, info); } ComplexColumnVector ! Matrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const { ComplexMatrix tmp (*this); ! return tmp.lssolve (b, info, rank); } // Constants for matrix exponential calculation. --- 2328,2363 ---- Matrix::lssolve (const ComplexColumnVector& b) const { ComplexMatrix tmp (*this); ! octave_idx_type info; ! octave_idx_type rank; ! double rcond; ! return tmp.lssolve (b, info, rank, rcond); } ComplexColumnVector Matrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info) const { ComplexMatrix tmp (*this); ! octave_idx_type rank; ! double rcond; ! return tmp.lssolve (b, info, rank, rcond); ! } ! ! ComplexColumnVector ! Matrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank) const ! { ! ComplexMatrix tmp (*this); ! double rcond; ! return tmp.lssolve (b, info, rank, rcond); } ComplexColumnVector ! Matrix::lssolve (const ComplexColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank, double &rcond) const { ComplexMatrix tmp (*this); ! return tmp.lssolve (b, info, rank, rcond); } // Constants for matrix exponential calculation. diff -cNr octave-2.9.15/liboctave/dMatrix.h octave-2.9.16/liboctave/dMatrix.h *** octave-2.9.15/liboctave/dMatrix.h Fri Oct 12 17:27:15 2007 --- octave-2.9.16/liboctave/dMatrix.h Mon Oct 29 14:09:57 2007 *************** *** 226,246 **** // Singular solvers Matrix lssolve (const Matrix& b) const; Matrix lssolve (const Matrix& b, octave_idx_type& info) const; ! Matrix lssolve (const Matrix& b, octave_idx_type& info, octave_idx_type& rank) const; ComplexMatrix lssolve (const ComplexMatrix& b) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info, octave_idx_type& rank) const; ColumnVector lssolve (const ColumnVector& b) const; ColumnVector lssolve (const ColumnVector& b, octave_idx_type& info) const; ! ColumnVector lssolve (const ColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const; ComplexColumnVector lssolve (const ComplexColumnVector& b) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, octave_idx_type& info) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, octave_idx_type& info, octave_idx_type& rank) const; Matrix expm (void) const; --- 226,259 ---- // Singular solvers Matrix lssolve (const Matrix& b) const; Matrix lssolve (const Matrix& b, octave_idx_type& info) const; ! Matrix lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank) const; ! Matrix lssolve (const Matrix& b, octave_idx_type& info, ! octave_idx_type& rank, double& rcond) const; ComplexMatrix lssolve (const ComplexMatrix& b) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info) const; ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info, octave_idx_type& rank) const; + ComplexMatrix lssolve (const ComplexMatrix& b, octave_idx_type& info, + octave_idx_type& rank, double &rcond) const; ColumnVector lssolve (const ColumnVector& b) const; ColumnVector lssolve (const ColumnVector& b, octave_idx_type& info) const; ! ColumnVector lssolve (const ColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank) const; ! ColumnVector lssolve (const ColumnVector& b, octave_idx_type& info, ! octave_idx_type& rank, double& rcond) const; ComplexColumnVector lssolve (const ComplexColumnVector& b) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, ! octave_idx_type& info) const; ! ComplexColumnVector lssolve (const ComplexColumnVector& b, ! octave_idx_type& info, octave_idx_type& rank) const; + ComplexColumnVector lssolve (const ComplexColumnVector& b, + octave_idx_type& info, + octave_idx_type& rank, double& rcond) const; Matrix expm (void) const; diff -cNr octave-2.9.15/liboctave/dSparse.cc octave-2.9.16/liboctave/dSparse.cc *** octave-2.9.15/liboctave/dSparse.cc Fri Oct 12 17:27:15 2007 --- octave-2.9.16/liboctave/dSparse.cc Wed Oct 17 15:02:11 2007 *************** *** 5986,6009 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate if - // it runs out of memory. Use CHOLMOD's memory guard for - // METIS, which allocates a huge block of memory (and then - // immediately frees it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free. - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_ll = true; cholmod_sparse Astore; --- 5986,5991 ---- *************** *** 6220,6245 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate MATLAB if - // it runs out of memory. Use CHOLMOD's memory guard for METIS, - // which mxMalloc's a huge block of memory (and then immediately - // mxFree's it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. It is not needed, because mxMalloc - // will safely terminate the mexFunction and free any workspace - // without killing all of octave. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_ll = true; cholmod_sparse Astore; --- 6202,6207 ---- *************** *** 6502,6527 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate MATLAB if - // it runs out of memory. Use CHOLMOD's memory guard for METIS, - // which mxMalloc's a huge block of memory (and then immediately - // mxFree's it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. It is not needed, because mxMalloc - // will safely terminate the mexFunction and free any workspace - // without killing all of octave. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_ll = true; cholmod_sparse Astore; --- 6464,6469 ---- *************** *** 6756,6781 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate MATLAB if - // it runs out of memory. Use CHOLMOD's memory guard for METIS, - // which mxMalloc's a huge block of memory (and then immediately - // mxFree's it) before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. It is not needed, because mxMalloc - // will safely terminate the mexFunction and free any workspace - // without killing all of octave. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_ll = true; cholmod_sparse Astore; --- 6698,6703 ---- diff -cNr octave-2.9.15/liboctave/lo-utils.cc octave-2.9.16/liboctave/lo-utils.cc *** octave-2.9.15/liboctave/lo-utils.cc Fri Oct 12 17:27:16 2007 --- octave-2.9.16/liboctave/lo-utils.cc Mon Oct 22 12:55:41 2007 *************** *** 29,34 **** --- 29,35 ---- #include #include #include + #include #include #include diff -cNr octave-2.9.15/liboctave/oct-env.cc octave-2.9.16/liboctave/oct-env.cc *** octave-2.9.15/liboctave/oct-env.cc Fri Oct 12 17:27:16 2007 --- octave-2.9.16/liboctave/oct-env.cc Mon Oct 22 12:55:41 2007 *************** *** 43,48 **** --- 43,49 ---- #include #include + #include #include diff -cNr octave-2.9.15/liboctave/oct-sparse.h octave-2.9.16/liboctave/oct-sparse.h *** octave-2.9.15/liboctave/oct-sparse.h Fri Oct 12 17:27:17 2007 --- octave-2.9.16/liboctave/oct-sparse.h Wed Oct 17 15:02:11 2007 *************** *** 57,72 **** #include #endif - #if defined (HAVE_SUITESPARSE_METIS_H) - #include - #elif defined (HAVE_UFSPARSE_METIS_H) - #include - #elif defined (HAVE_METIS_METIS_H) - #include - #elif defined (HAVE_METIS_H) - #include - #endif - #if defined (HAVE_SUITESPARSE_CHOLMOD_H) #include #elif defined (HAVE_UFSPARSE_CHOLMOD_H) --- 57,62 ---- diff -cNr octave-2.9.15/liboctave/oct-time.cc octave-2.9.16/liboctave/oct-time.cc *** octave-2.9.15/liboctave/oct-time.cc Fri Oct 12 17:27:17 2007 --- octave-2.9.16/liboctave/oct-time.cc Thu Oct 25 01:50:55 2007 *************** *** 316,322 **** { tm_usec = ot.usec (); ! time_t t = ot; octave_base_tm::init (localtime (&t)); } --- 316,322 ---- { tm_usec = ot.usec (); ! time_t t = ot.unix_time (); octave_base_tm::init (localtime (&t)); } *************** *** 326,332 **** { tm_usec = ot.usec (); ! time_t t = ot; octave_base_tm::init (gmtime (&t)); } --- 326,332 ---- { tm_usec = ot.usec (); ! time_t t = ot.unix_time (); octave_base_tm::init (gmtime (&t)); } *************** *** 379,385 **** octave_base_tm::init (&t); #if defined (HAVE_STRUCT_TM_TM_ZONE) ! delete ps; #endif } --- 379,385 ---- octave_base_tm::init (&t); #if defined (HAVE_STRUCT_TM_TM_ZONE) ! delete [] ps; #endif } diff -cNr octave-2.9.15/liboctave/oct-time.h octave-2.9.16/liboctave/oct-time.h *** octave-2.9.15/liboctave/oct-time.h Fri Oct 12 17:27:17 2007 --- octave-2.9.16/liboctave/oct-time.h Thu Oct 25 01:50:55 2007 *************** *** 70,78 **** void stamp (void); ! operator double () const { return ot_unix_time + ot_usec / 1e6; } ! ! operator time_t () const { return ot_unix_time; } time_t unix_time (void) const { return ot_unix_time; } --- 70,76 ---- void stamp (void); ! double double_value (void) const { return ot_unix_time + ot_usec / 1e6; } time_t unix_time (void) const { return ot_unix_time; } diff -cNr octave-2.9.15/liboctave/oct-uname.cc octave-2.9.16/liboctave/oct-uname.cc *** octave-2.9.15/liboctave/oct-uname.cc Fri Oct 12 17:27:17 2007 --- octave-2.9.16/liboctave/oct-uname.cc Mon Oct 22 12:55:41 2007 *************** *** 25,30 **** --- 25,31 ---- #endif #include + #include #ifdef HAVE_SYS_UTSNAME_H #include diff -cNr octave-2.9.15/liboctave/sparse-base-chol.cc octave-2.9.16/liboctave/sparse-base-chol.cc *** octave-2.9.15/liboctave/sparse-base-chol.cc Fri Oct 12 17:27:17 2007 --- octave-2.9.16/liboctave/sparse-base-chol.cc Wed Oct 17 15:02:11 2007 *************** *** 116,139 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate if it runs - // out of memory. Use CHOLMOD's memory guard for METIS, which - // allocates a huge block of memory (and then immediately frees it) - // before calling METIS - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free. - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. - cm->metis_memory = 0.0; - #endif - #endif - #endif - cm->final_asis = false; cm->final_super = false; cm->final_ll = true; --- 116,121 ---- diff -cNr octave-2.9.15/liboctave/sparse-sort.cc octave-2.9.16/liboctave/sparse-sort.cc *** octave-2.9.15/liboctave/sparse-sort.cc Fri Oct 12 17:27:17 2007 --- octave-2.9.16/liboctave/sparse-sort.cc Mon Oct 22 12:55:41 2007 *************** *** 26,31 **** --- 26,32 ---- #endif #include + #include #include "oct-sort.cc" #include "quit.h" diff -cNr octave-2.9.15/liboctave/strptime.c octave-2.9.16/liboctave/strptime.c *** octave-2.9.15/liboctave/strptime.c Wed Dec 6 14:31:28 2006 --- octave-2.9.16/liboctave/strptime.c Wed Oct 24 02:15:40 2007 *************** *** 27,33 **** # include #endif ! #ifndef HAVE_STRPTIME #include #ifdef _LIBC --- 27,33 ---- # include #endif ! #if ! defined (HAVE_STRPTIME) || defined (OCTAVE_HAVE_BROKEN_STRPTIME) #include #ifdef _LIBC diff -cNr octave-2.9.15/octMakefile.in octave-2.9.16/octMakefile.in *** octave-2.9.15/octMakefile.in Fri Oct 12 17:27:12 2007 --- octave-2.9.16/octMakefile.in Wed Oct 31 16:35:10 2007 *************** *** 42,51 **** BUILT_DISTFILES = $(BUILT_CONF_DISTFILES) BUGS INSTALL.OCTAVE DISTFILES = $(CONF_DISTFILES) \ ! COPYING FLEX.patch INSTALL NEWS \ NEWS.[0-9] PROJECTS README README.Linux README.Windows \ ! README.Cygwin README.MSVC \ ! README.MachTen README.kpathsea ROADMAP SENDING-PATCHES \ THANKS move-if-change octave-sh octave-bug.in \ octave-config.in mk-opts.pl mkinstalldirs \ mkoctfile.in run-octave.in ChangeLog ChangeLog.[0-9] --- 42,50 ---- BUILT_DISTFILES = $(BUILT_CONF_DISTFILES) BUGS INSTALL.OCTAVE DISTFILES = $(CONF_DISTFILES) \ ! COPYING INSTALL NEWS \ NEWS.[0-9] PROJECTS README README.Linux README.Windows \ ! README.Cygwin README.MSVC README.kpathsea ROADMAP SENDING-PATCHES \ THANKS move-if-change octave-sh octave-bug.in \ octave-config.in mk-opts.pl mkinstalldirs \ mkoctfile.in run-octave.in ChangeLog ChangeLog.[0-9] *************** *** 162,168 **** .PHONY: clean mostlyclean distclean maintainer-clean maintainer-clean distclean:: ! rm -f octMakefile Makefile Makeconf Makefrag.f77 Makerules.f77 rm -f config.cache config.h config.log config.status rm -rf autom4te.cache rm -f $(SHELL_SCRIPTS) --- 161,167 ---- .PHONY: clean mostlyclean distclean maintainer-clean maintainer-clean distclean:: ! rm -f octMakefile Makefile Makeconf rm -f config.cache config.h config.log config.status rm -rf autom4te.cache rm -f $(SHELL_SCRIPTS) diff -cNr octave-2.9.15/scripts/ChangeLog octave-2.9.16/scripts/ChangeLog *** octave-2.9.15/scripts/ChangeLog Sat Oct 13 01:13:28 2007 --- octave-2.9.16/scripts/ChangeLog Wed Oct 31 13:11:49 2007 *************** *** 1,3 **** --- 1,99 ---- + 2007-10-31 Michael goffioul + + * plot/subplot.m: Ignore legend objects when parsing existing axes + objects and legend objects are implemented with a separate axes + object. + + 2007-10-30 David Bateman + + * control/base/DEMOcontrol.m: Doc fixes for small book format. + + * plot/__go_draw_axes__.m (do_linestyle_command): + Use point type 0 for ".". + + 2007-10-26 John W. Eaton + + * image/imshow.m: Improve compatibility. + * image/image.m: Return handle if nargou > 0. + + * pkg/pkg.m: Delete PKG_ADD directive for autoloading packes. + + 2007-10-25 John W. Eaton + + * miscellaneous/compare_versions.m: Style fixes. + + 2007-10-24 John W. Eaton + + * image/saveimage.m: Use functional form of save instead of eval. + Use -text instead of -ascii. + + * plot/__go_draw_axes__.m: Handle visible = "off" for axes objects. + + 2007-10-23 Peter A. Gustafson + + * plot/legend.m: Also extract location string from varargin (lost + when 2007-10-08 patch was applied). + + 2007-10-23 David Bateman + + * plot/xlim.m, plot/ylim.m, plot/zlim.m, plot/__axes_limits__.m, + miscellaneous/what.m: New functions + * plot/Makefile.in, miscellaneous/Makefile.in (SOURCES): Add new + functions. + + 2007-10-22 David Bateman + + * miscellaneous/cputime.m, time/tic.m, time/toc.m: Delete. + * miscellaneous/Makefile.in (SOURCES): remove cputim.m + * time/Makefile.in (SOURCES): Remov tic.m and toc.m + + 2007-10-19 Kai Habel + + * plot/contourf.m: New function. + * plot/Makefile.in (SOURCES): Add it to the list. + + 2007-10-19 John W. Eaton + + * plot/subplot.m: Doc fix. + + 2007-10-19 David Bateman + + * plot/__bar__.m, plot/fill.m: Call newplot as needed. + + 2007-10-17 Carlo de Falco + + * plot/print.m: Handle -textspecial and -textnormal flags for fig + output. + + 2007-10-15 Søren Hauberg + + * general/rat.m, sparse/pcg.m, sparse/pcr.m, optimization/sqp.m, + statistics/models/logistic_regression.m, polynomial/polygcd.m, + control/system/ss.m, signal/arch_rnd.m, control/system/ss2sys.m, + control/system/syssetsignals.m, control/base/lqg.m, + strings/str2double.m, control/system/sysscale.m, + control/hinf/hinfdemo.m, general/cplxpair.m: + Make help text fit on pages when using smallbook. + + 2007-10-15 David Bateman + + * plot/print.m: Call drawnow before printing to ensure the plot is + on the screen. + + * testfun/test.m: In error/warning blocks test for an error before + a warning to avoid unexpected failures. + + 2007-10-15 Kim Hansen i + + * testfun/assert.m: Correct documentation of absolution versus + relative error tolerance and add tests. + + 2007-10-14 David Bateman + + * pkg/pkg.m (pkg:configure_make): Treat case of no files to install in + src directory. + * plot/Makefile.in (SOURCES): Add fill.m. + 2007-10-13 David Bateman * plot/__patch__.m: Allow multiple patches to be defined and diff -cNr octave-2.9.15/scripts/DOCSTRINGS octave-2.9.16/scripts/DOCSTRINGS *** octave-2.9.15/scripts/DOCSTRINGS Sat Oct 13 11:10:13 2007 --- octave-2.9.16/scripts/DOCSTRINGS Wed Oct 31 18:08:45 2007 *************** *** 110,116 **** @example @group octave:1> DEMOcontrol - O C T A V E C O N T R O L S Y S T E M S T O O L B O X Octave Controls System Toolbox Demo [ 1] System representation --- 110,115 ---- *************** *** 960,967 **** @end example or @example ! x(k+1) = A x(k) + B u(k) + G w(k) [w]=N(0,[Sigw 0 ]) ! y(k) = C x(k) + v(k) [v] ( 0 Sigv ]) @end example @strong{Inputs} --- 959,966 ---- @end example or @example ! x(k+1) = A x(k) + B u(k) + G w(k) [w]=N(0,[Sigw 0 ]) ! y(k) = C x(k) + v(k) [v] ( 0 Sigv ]) @end example @strong{Inputs} *************** *** 1778,1784 **** @end example @end ifinfo ! @example @group +----+ --- 1777,1783 ---- @end example @end ifinfo ! @smallexample @group +----+ *************** *** 1794,1800 **** -----| K |<------- +---+ @end group ! @end example @iftex @tex --- 1793,1799 ---- -----| K |<------- +---+ @end group ! @end smallexample @iftex @tex *************** *** 1823,1829 **** @end ifinfo norm of the augmented plant @var{P} (mixed-sensitivity problem): ! @example @group w 1 -----------+ --- 1822,1828 ---- @end ifinfo norm of the augmented plant @var{P} (mixed-sensitivity problem): ! @smallexample @group w 1 -----------+ *************** *** 1840,1846 **** u y (to K) (from controller K) @end group ! @end example @iftex @tex --- 1839,1845 ---- u y (to K) (from controller K) @end group ! @end smallexample @iftex @tex *************** *** 1853,1859 **** @end tex @end iftex @ifinfo ! @example @group + + + + | z | | w | --- 1852,1858 ---- @end tex @end iftex @ifinfo ! @smallexample @group + + + + | z | | w | *************** *** 1863,1869 **** | y | | u | + + + + @end group ! @end example @end ifinfo @item Discrete system: --- 1862,1868 ---- | y | | u | + + + + @end group ! @end smallexample @end ifinfo @item Discrete system: *************** *** 1908,1914 **** @end example @end ifinfo ! @example @group +----+ --- 1907,1913 ---- @end example @end ifinfo ! @smallexample @group +----+ *************** *** 1924,1930 **** -----| K |<------- +---+ @end group ! @end example @iftex @tex $$ { \rm min } \Vert T_{vz} \Vert _\infty $$ --- 1923,1929 ---- -----| K |<------- +---+ @end group ! @end smallexample @iftex @tex $$ { \rm min } \Vert T_{vz} \Vert _\infty $$ *************** *** 3330,3336 **** octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 --- 3329,3336 ---- octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, ... ! > @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 *************** *** 3371,3377 **** @end deftypefn ss2sys -*- texinfo -*- ! @deftypefn {Function File} {} ss (@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}, @var{n}, @var{nz}, @var{stname}, @var{inname}, @var{outname}, @var{outlist}) Create system structure from state-space data. May be continuous, discrete, or mixed (sampled data) --- 3371,3377 ---- @end deftypefn ss2sys -*- texinfo -*- ! @deftypefn {Function File} {} ss2sys (@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}, @var{n}, @var{nz}, @var{stname}, @var{inname}, @var{outname}, @var{outlist}) Create system structure from state-space data. May be continuous, discrete, or mixed (sampled data) *************** *** 3494,3500 **** octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 --- 3494,3501 ---- octave:1> a = [1 2 3; 4 5 6; 7 8 10]; octave:2> b = [0 0 ; 0 1 ; 1 0]; octave:3> c = eye (3); ! octave:4> sys = ss (a, b, c, [], 0, 3, 0, ! > @{"volts", "amps", "joules"@}); octave:5> sysout(sys); Input(s) 1: u_1 *************** *** 4324,4334 **** @table @var @item retsys resulting open loop system: ! @example ----------- ------- ----------- u --->| inscale |--->| sys |--->| outscale |---> y ----------- ------- ----------- ! @end example @end table If the input names and output names (each a list of strings) are not given and the scaling matrices --- 4325,4335 ---- @table @var @item retsys resulting open loop system: ! @smallexample ----------- ------- ----------- u --->| inscale |--->| sys |--->| outscale |---> y ----------- ------- ----------- ! @end smallexample @end table If the input names and output names (each a list of strings) are not given and the scaling matrices *************** *** 4388,4395 **** @strong{Example} @example ! octave:1> sys=ss([1 2; 3 4],[5;6],[7 8]); ! octave:2> sys = syssetsignals(sys,"st",str2mat("Posx","Velx")); octave:3> sysout(sys) Input(s) 1: u_1 --- 4389,4397 ---- @strong{Example} @example ! octave:1> sys=ss ([1 2; 3 4],[5;6],[7 8]); ! octave:2> sys = syssetsignals (sys, "st", ! > str2mat("Posx","Velx")); octave:3> sysout(sys) Input(s) 1: u_1 *************** *** 6131,6139 **** error. Note that there are no guarantees on the order of the returned pairs with identical real parts but differing imaginary parts. ! @example cplxpair (exp(2i*pi*[0:4]'/5)) == exp(2i*pi*[3; 2; 4; 1; 0]/5) ! @end example @end deftypefn cumtrapz -*- texinfo -*- --- 6133,6142 ---- error. Note that there are no guarantees on the order of the returned pairs with identical real parts but differing imaginary parts. ! @c Using 'smallexample' to make text fit in page when using 'smallbook' ! @smallexample cplxpair (exp(2i*pi*[0:4]'/5)) == exp(2i*pi*[3; 2; 4; 1; 0]/5) ! @end smallexample @end deftypefn cumtrapz -*- texinfo -*- *************** *** 6918,6925 **** by @var{tol} using a continued fraction expansion. E.g, @example ! rat(pi) = 3 + 1/(7 + 1/16) = 355/113 ! rat(e) = 3 + 1/(-4 + 1/(2 + 1/(5 + 1/(-2 + 1/(-7))))) = 1457/536 @end example Called with two arguments returns the numerator and denominator separately --- 6921,6929 ---- by @var{tol} using a continued fraction expansion. E.g, @example ! rat(pi) = 3 + 1/(7 + 1/16) = 355/113 ! rat(e) = 3 + 1/(-4 + 1/(2 + 1/(5 + 1/(-2 + 1/(-7))))) ! = 1457/536 @end example Called with two arguments returns the numerator and denominator separately *************** *** 7638,7650 **** @deftypefn {Function File} {} imshow (@var{im}) @deftypefnx {Function File} {} imshow (@var{im}, @var{limits}) @deftypefnx {Function File} {} imshow (@var{im}, @var{map}) ! @deftypefnx {Function File} {} imshow (@var{R}, @var{G}, @var{B}, @dots{}) @deftypefnx {Function File} {} imshow (@var{filename}) @deftypefnx {Function File} {} imshow (@dots{}, @var{string_param1}, @var{value1}, @dots{}) Display the image @var{im}, where @var{im} can be a 2-dimensional ! (gray-scale image) or a 3-dimensional (RGB image) matrix. If three matrices ! of the same size are given as arguments, they will be concatenated into ! 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 --- 7642,7652 ---- @deftypefn {Function File} {} imshow (@var{im}) @deftypefnx {Function File} {} imshow (@var{im}, @var{limits}) @deftypefnx {Function File} {} imshow (@var{im}, @var{map}) ! @deftypefnx {Function File} {} imshow (@var{rgb}, @dots{}) @deftypefnx {Function File} {} imshow (@var{filename}) @deftypefnx {Function File} {} imshow (@dots{}, @var{string_param1}, @var{value1}, @dots{}) Display the image @var{im}, where @var{im} can be a 2-dimensional ! (gray-scale 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 *************** *** 8293,8311 **** message identifier.\n\ @seealso{glob, movefile} @end deftypefn - cputime - -*- texinfo -*- - @deftypefn {Function File} {[@var{total}, @var{user}, @var{system}] =} cputime (); - Return the CPU time used by your Octave session. The first output is - the total time spent executing your process and is equal to the sum of - second and third outputs, which are the number of CPU seconds spent - executing in user mode and the number of CPU seconds spent executing in - system mode, respectively. If your system does not have a way to report - CPU time usage, @code{cputime} returns 0 for each of its output values. - Note that because Octave used some CPU time to start, it is reasonable - to check to see if @code{cputime} works by checking to see if the total - CPU time used is nonzero. - @end deftypefn delete -*- texinfo -*- @deftypefn {Function File} {} delete (@var{file}) --- 8295,8300 ---- *************** *** 9147,9152 **** --- 9136,9152 ---- expression. By default, the @code{Octave:variable-switch-label} warning is disabled. @end table + what + -*- texinfo -*- + @deftypefn {Command} {} what + @deftypefnx {Command} {} what @var{dir} + @deftypefnx {Function File} {w =} what (@var{dir}) + List the Octave specific files in a directory. If the variable @var{dir} + is given then check that directory rather than the current directory. If + a return argument is requested, the files found are returned in the + structure @var{w}. + @seealso{which} + @end deftypefn xor -*- texinfo -*- @deftypefn {Mapping Function} {} xor (@var{x}, @var{y}) *************** *** 9716,9722 **** If supplied, the gradient function must be of the form @example ! g = gradient (x) @end example @noindent --- 9716,9722 ---- If supplied, the gradient function must be of the form @example ! g = gradient (x) @end example @noindent *************** *** 9725,9731 **** If supplied, the hessian function must be of the form @example ! h = hessian (x) @end example @noindent --- 9725,9731 ---- If supplied, the hessian function must be of the form @example ! h = hessian (x) @end example @noindent *************** *** 9742,9748 **** of the form @example ! r = f (x) @end example @noindent --- 9742,9748 ---- of the form @example ! r = f (x) @end example @noindent *************** *** 9773,9807 **** Here is an example of calling @code{sqp}: @example ! function r = g (x) ! r = [ sumsq(x)-10; x(2)*x(3)-5*x(4)*x(5); x(1)^3+x(2)^3+1]; ! endfunction ! ! function obj = phi (x) ! obj = exp(prod(x)) - 0.5*(x(1)^3+x(2)^3+1)^2; ! endfunction ! x0 = [-1.8; 1.7; 1.9; -0.8; -0.8]; ! [x, obj, info, iter, nf, lambda] = sqp (x0, @@phi, @@g, []) ! x = ! ! -1.71714 ! 1.59571 ! 1.82725 ! -0.76364 ! -0.76364 ! ! obj = 0.053950 ! info = 101 ! iter = 8 ! nf = 10 ! lambda = ! -0.0401627 ! 0.0379578 ! -0.0052227 @end example The value returned in @var{info} may be one of the following: --- 9773,9809 ---- Here is an example of calling @code{sqp}: @example ! function r = g (x) ! r = [ sumsq(x)-10; ! x(2)*x(3)-5*x(4)*x(5); ! x(1)^3+x(2)^3+1 ]; ! endfunction ! ! function obj = phi (x) ! obj = exp(prod(x)) - 0.5*(x(1)^3+x(2)^3+1)^2; ! endfunction ! x0 = [-1.8; 1.7; 1.9; -0.8; -0.8]; ! [x, obj, info, iter, nf, lambda] = sqp (x0, @@phi, @@g, []) ! x = ! ! -1.71714 ! 1.59571 ! 1.82725 ! -0.76364 ! -0.76364 ! obj = 0.053950 ! info = 101 ! iter = 8 ! nf = 10 ! lambda = ! ! -0.0401627 ! 0.0379578 ! -0.0052227 @end example The value returned in @var{info} may be one of the following: *************** *** 9983,9988 **** --- 9985,9992 ---- the other options are ignored. @end table @end deftypefn + __axes_limits__ + Undocumented internal function. __axis_label__ Undocumented internal function. __bar__ *************** *** 10152,10158 **** @end deftypefn bar -*- texinfo -*- ! @deftypefn {Function File} {@var{h} =} bar (@var{x}, @var{y}, @var{style}) @deftypefnx {Function File} {[@var{xb}, @var{yb}] =} bar (@dots{}) Given two vectors of x-y data, @code{bar} produce a bar graph. --- 10156,10162 ---- @end deftypefn bar -*- texinfo -*- ! @deftypefn {Function File} {@var{h} =} bar (@var{x}, @var{y}, @var{p1}, @var{v1}, @dots{}) @deftypefnx {Function File} {[@var{xb}, @var{yb}] =} bar (@dots{}) Given two vectors of x-y data, @code{bar} produce a bar graph. *************** *** 10162,10168 **** If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values 'group' (the default), or 'stack'. If two output arguments are specified, the data are generated but not plotted. For example, --- 10166,10173 ---- If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values @code{"grouped"} (the default), ! or @code{"stacked"}. If two output arguments are specified, the data are generated but not plotted. For example, *************** *** 10195,10201 **** If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values 'group' (the default), or 'stack'. If two output arguments are specified, the data are generated but not plotted. For example, --- 10200,10207 ---- If @var{y} is a matrix, then each column of @var{y} is taken to be a separate bar graph plotted on the same graph. By default the columns are plotted side-by-side. This behavior can be changed by the @var{style} ! argument, which can take the values @code{"grouped"} (the default), ! or @code{"stacked"}. If two output arguments are specified, the data are generated but not plotted. For example, *************** *** 10310,10315 **** --- 10316,10358 ---- @end example @seealso{contour} @end deftypefn + contourf + -*- texinfo -*- + @deftypefn {Function File} {[@var{c}, @var{h}] =} contourf (@var{x}, @var{y}, @var{z}, @var{lvl}) + @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{x}, @var{y}, @var{z}, @var{n}) + @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{x}, @var{y}, @var{z}) + @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{z}, @var{n}) + @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{z}, @var{lvl}) + @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{z}) + @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{ax}, @dots{}) + @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@dots{}, @var{"property"}, @var{val}) + Compute and plot filled contours of the matrix @var{z}. + Parameters @var{x}, @var{y} and @var{n} or @var{lvl} are optional. + + The return value @var{c} is a 2xn matrix containing the contour lines + as described in the help to the contourc function. + + The return value @var{h} is handle-vector to the patch objects creating + the filled contours. + + If @var{x} and @var{y} are ommited they are taken as the row/column + index of @var{z}. @var{n} is a scalar denoting the number of lines + to compute. Alternatively @var{lvl} is a vector containing the + contour levels. If only one value (e.g. lvl0) is wanted, set + @var{lvl} to [lvl0, lvl0]. If both @var{n} or @var{lvl} are omitted + a default value of 10 contour level is assumed. + + If provided, the filled contours are added to the axes object + @var{ax} instead of the current axis. + + The following example plots filled contours of the @code{peaks} + function. + @example + [x, y, z] = peaks (50); + contourf (x, y, z, -7:9) + @end example + @seealso{contour, contourc, patch} + @end deftypefn drawnow -*- texinfo -*- @deftypefn {Function File} {} drawnow () *************** *** 11098,11104 **** @item emf Microsoft Enhanced Metafile @item fig ! XFig @item hpgl HP plotter language @item mf --- 11141,11150 ---- @item emf Microsoft Enhanced Metafile @item fig ! XFig. If this format is selected the additional options ! @code{-textspecial} or @code{-textnormal} can be used to control ! whether the special flag should be set for the text in the figure ! (default is @code{-textnormal}). @item hpgl HP plotter language @item mf *************** *** 11335,11342 **** \vskip 10pt \hfil\vbox{\offinterlineskip\hrule \halign{\vrule#&&\qquad\hfil#\hfil\qquad\vrule\cr ! height13pt&1&2&3&4\cr height12pt&&&&\cr\noalign{\hrule} ! height13pt&5&6&7&8\cr height12pt&&&&\cr\noalign{\hrule}}} \hfil \vskip 10pt @end tex --- 11381,11388 ---- \vskip 10pt \hfil\vbox{\offinterlineskip\hrule \halign{\vrule#&&\qquad\hfil#\hfil\qquad\vrule\cr ! height13pt&1&2&3\cr height12pt&&&&\cr\noalign{\hrule} ! height13pt&4&5&6\cr height12pt&&&&\cr\noalign{\hrule}}} \hfil \vskip 10pt @end tex *************** *** 11346,11356 **** @group @example ! +-----+-----+-----+-----+ ! | 1 | 2 | 3 | 4 | ! +-----+-----+-----+-----+ ! | 5 | 6 | 7 | 8 | ! +-----+-----+-----+-----+ @end example @end group @end display --- 11392,11402 ---- @group @example ! +-----+-----+-----+ ! | 1 | 2 | 3 | ! +-----+-----+-----+ ! | 4 | 5 | 6 | ! +-----+-----+-----+ @end example @end group @end display *************** *** 11388,11403 **** --- 11434,11512 ---- @seealso{plot, semilogx, semilogy, loglog, polar, mesh, contour, bar, stairs, ylabel, title} @end deftypefn + xlim + -*- texinfo -*- + @deftypefn {Function File} {@var{xl} =} xlim () + @deftypefnx {Function File} {} xlim (@var{xl}) + @deftypefnx {Function File} {@var{m} =} xlim ('mode') + @deftypefnx {Function File} {} xlim (@var{m}) + @deftypefnx {Function File} {} xlim (@var{h}, @dots{}) + Get or set the limits of the x axis of the current plot. Called without + argumenst @code{xlim] returns the x axis limits of the current plot. + If passed a two element vector @var{xl}, the limits of the x axis are set + to this value. + + The current mode for calculation of the x axis can be returned with a + call @code{xlim ('mode')}, and can be either 'auto' or 'manual'. The + current plotting mode can be set by passing either 'auto' or 'manual' + as the argument. + + If passed an handle as the first argument, then operate on this handle + rather than the current axes handle. + @seealso{ylim, zlim, set, get, gca} + @end deftypefn ylabel -*- texinfo -*- @deftypefn {Function File} {} ylabel (@var{string}) See xlabel. @end deftypefn + ylim + -*- texinfo -*- + @deftypefn {Function File} {@var{xl} =} ylim () + @deftypefnx {Function File} {} ylim (@var{xl}) + @deftypefnx {Function File} {@var{m} =} ylim ('mode') + @deftypefnx {Function File} {} ylim (@var{m}) + @deftypefnx {Function File} {} ylim (@var{h}, @dots{}) + Get or set the limits of the y axis of the current plot. Called without + argumenst @code{ylim] returns the y axis limits of the current plot. + If passed a two element vector @var{xl}, the limits of the y axis are set + to this value. + + The current mode for calculation of the y axis can be returned with a + call @code{ylim ('mode')}, and can be either 'auto' or 'manual'. The + current plotting mode can be set by passing either 'auto' or 'manual' + as the argument. + + If passed an handle as the first argument, then operate on this handle + rather than the current axes handle. + @seealso{xlim, zlim, set, get, gca} + @end deftypefn zlabel -*- texinfo -*- @deftypefn {Function File} {} zlabel (@var{string}) See xlabel. @end deftypefn + zlim + -*- texinfo -*- + @deftypefn {Function File} {@var{xl} =} zlim () + @deftypefnx {Function File} {} zlim (@var{xl}) + @deftypefnx {Function File} {@var{m} =} zlim ('mode') + @deftypefnx {Function File} {} zlim (@var{m}) + @deftypefnx {Function File} {} zlim (@var{h}, @dots{}) + Get or set the limits of the z axis of the current plot. Called without + argumenst @code{zlim] returns the z axis limits of the current plot. + If passed a two element vector @var{xl}, the limits of the z axis are set + to this value. + + The current mode for calculation of the z axis can be returned with a + call @code{zlim ('mode')}, and can be either 'auto' or 'manual'. The + current plotting mode can be set by passing either 'auto' or 'manual' + as the argument. + + If passed an handle as the first argument, then operate on this handle + rather than the current axes handle. + @seealso{xlim, ylim, set, get, gca} + @end deftypefn compan -*- texinfo -*- @deftypefn {Function File} {} compan (@var{c}) *************** *** 11656,11662 **** @example polygcd (poly(1:8), poly(3:12)) - poly(3:8) @result{} [ 0, 0, 0, 0, 0, 0, 0 ] ! deconv (poly(1:8), polygcd (poly(1:8), poly(3:12))) - poly(1:2) @result{} [ 0, 0, 0 ] @end example @seealso{poly, polyinteg, polyderiv, polyreduce, roots, conv, deconv, --- 11765,11772 ---- @example polygcd (poly(1:8), poly(3:12)) - poly(3:8) @result{} [ 0, 0, 0, 0, 0, 0, 0 ] ! deconv (poly(1:8), polygcd (poly(1:8), poly(3:12))) ... ! - poly(1:2) @result{} [ 0, 0, 0 ] @end example @seealso{poly, polyinteg, polyderiv, polyreduce, roots, conv, deconv, *************** *** 12286,12302 **** coefficients @var{b} and CH coefficients @var{a}. I.e., the result @math{y(t)} follows the model ! @example y(t) = b(1) + b(2) * y(t-1) + @dots{} + b(lb) * y(t-lb+1) + e(t), ! @end example @noindent where @math{e(t)}, given @var{y} up to time @math{t-1}, is @math{N(0, h(t))}, with ! @example h(t) = a(1) + a(2) * e(t-1)^2 + @dots{} + a(la) * e(t-la+1)^2 ! @end example @end deftypefn arch_test -*- texinfo -*- --- 12396,12412 ---- coefficients @var{b} and CH coefficients @var{a}. I.e., the result @math{y(t)} follows the model ! @smallexample y(t) = b(1) + b(2) * y(t-1) + @dots{} + b(lb) * y(t-lb+1) + e(t), ! @end smallexample @noindent where @math{e(t)}, given @var{y} up to time @math{t-1}, is @math{N(0, h(t))}, with ! @smallexample h(t) = a(1) + a(2) * e(t-1)^2 + @dots{} + a(la) * e(t-la+1)^2 ! @end smallexample @end deftypefn arch_test -*- texinfo -*- *************** *** 12981,12987 **** y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec, eigest] = pcg (A, b, [], [], "applyM"); semilogy (1:iter+1, resvec); @end group @end example --- 13091,13098 ---- y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec, eigest] = ... ! pcg (A, b, [], [], "applyM"); semilogy (1:iter+1, resvec); @end group @end example *************** *** 13136,13142 **** y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = pcr(A,b,[],[],'applyM') semilogy([1:iter+1], resvec); @end group @end example --- 13247,13254 ---- y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = ... ! pcr(A, b, [], [], 'applyM') semilogy([1:iter+1], resvec); @end group @end example *************** *** 13151,13157 **** y = x; y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = pcr(A,b,[],[],'applyM',[],3) @end group @end example --- 13263,13270 ---- y = x; y(1:K) = x(1:K)./[1:K]'; endfunction ! [x, flag, relres, iter, resvec] = ... ! pcr(A, b, [], [], 'applyM', [], 3) @end group @end example *************** *** 15400,15406 **** fits the model @example ! logit (gamma_i (x)) = theta_i - beta' * x, i = 1, ..., k-1 @end example The number of ordinal categories, @var{k}, is taken to be the number --- 15513,15519 ---- fits the model @example ! logit (gamma_i (x)) = theta_i - beta' * x, i = 1...k-1 @end example The number of ordinal categories, @var{k}, is taken to be the number *************** *** 16291,16302 **** 3.1400 4.4440 0.7000 -10.0000 NaN NaN ! line = "200,300,400,NaN,-inf,cd,yes,no,999,maybe,NaN"; [x, status] = str2double (line) ! x = ! 200 300 400 NaN -Inf NaN NaN NaN 999 NaN NaN ! status = ! 0 0 0 0 0 -1 -1 -1 0 -1 0 @end example @end deftypefn str2mat --- 16404,16415 ---- 3.1400 4.4440 0.7000 -10.0000 NaN NaN ! line = "200, 300, NaN, -inf, yes, no, 999, maybe, NaN"; [x, status] = str2double (line) ! @result{} x = ! 200 300 NaN -Inf NaN NaN 999 NaN NaN ! @result{} status = ! 0 0 0 0 -1 -1 0 -1 0 @end example @end deftypefn str2mat *************** *** 16486,16495 **** lists or structures. @item assert(@var{observed}, @var{expected}, @var{tol}) ! Produce an error if relative error is less than tolerance. That is, ! @code{abs(@var{observed} - @var{expected}) > @var{tol} * @var{expected}}. ! Absolute error @code{abs(@var{observed} - @var{expected}) > abs(@var{tol})} ! will be used when tolerance is negative or when the expected value is zero. @end table @seealso{test} @end deftypefn --- 16599,16610 ---- lists or structures. @item assert(@var{observed}, @var{expected}, @var{tol}) ! Accept a tolerance when comparing numbers. ! If @var{tol} is possitive use it as an absolute tolerance, will produce an error if ! @code{abs(@var{observed} - @var{expected}) > abs(@var{tol})}. ! If @var{tol} is negative use it as a relative tolerance, will produce an error if ! @code{abs(@var{observed} - @var{expected}) > abs(@var{tol} * @var{expected})}. ! If @var{expected} is zero @var{tol} will always be used as an absolute tolerance. @end table @seealso{test} @end deftypefn *************** *** 17046,17107 **** (see @code{datenum}). @seealso{clock, date, datenum} @end deftypefn - tic - -*- texinfo -*- - @deftypefn {Function File} {} tic () - @deftypefnx {Function File} {} toc () - Set or check a wall-clock timer. Calling @code{tic} without an - output argument sets the timer. Subsequent calls to @code{toc} - return the number of seconds since the timer was set. For example, - - @example - tic (); - many computations later... - elapsed_time = toc (); - @end example - - @noindent - will set the variable @code{elapsed_time} to the number of seconds since - the most recent call to the function @code{tic}. - - If called with one output argument then this function returns a scalar - of type @code{uint64} and the wall-clock timer is not started. - - @example - @group - t = tic; sleep (5); (double (tic ()) - double (t)) * 1e-6 - @result{} 5 - @end group - @end example - - Nested timing with @code{tic} and @code{toc} is not supported. - Therefore @code{toc} will always return the elapsed time from the most - recent call to @code{tic}. - - If you are more interested in the CPU time that your process used, you - should use the @code{cputime} function instead. The @code{tic} and - @code{toc} functions report the actual wall clock time that elapsed - between the calls. This may include time spent processing other jobs or - doing nothing at all. For example, - - @example - @group - tic (); sleep (5); toc () - @result{} 5 - t = cputime (); sleep (5); cputime () - t - @result{} 0 - @end group - @end example - - @noindent - (This example also illustrates that the CPU timer may have a fairly - coarse resolution.) - @end deftypefn - toc - -*- texinfo -*- - @deftypefn {Function File} {} toc () - See tic. - @end deftypefn weekday -*- texinfo -*- @deftypefn {Function File} {[@var{n}, @var{s}] =} weekday (@var{d}, [@var{form}]) --- 17161,17166 ---- diff -cNr octave-2.9.15/scripts/control/base/DEMOcontrol.m octave-2.9.16/scripts/control/base/DEMOcontrol.m *** octave-2.9.15/scripts/control/base/DEMOcontrol.m Fri Oct 12 17:27:17 2007 --- octave-2.9.16/scripts/control/base/DEMOcontrol.m Tue Oct 30 21:09:28 2007 *************** *** 24,30 **** ## @example ## @group ## octave:1> DEMOcontrol - ## O C T A V E C O N T R O L S Y S T E M S T O O L B O X ## Octave Controls System Toolbox Demo ## ## [ 1] System representation --- 24,29 ---- *************** *** 47,54 **** function DEMOcontrol () - puts ("O C T A V E C O N T R O L S Y S T E M S T O O L B O X"); - while (1) clc (); --- 46,51 ---- diff -cNr octave-2.9.15/scripts/control/base/lqg.m octave-2.9.16/scripts/control/base/lqg.m *** octave-2.9.15/scripts/control/base/lqg.m Fri Oct 12 17:27:18 2007 --- octave-2.9.16/scripts/control/base/lqg.m Mon Oct 15 11:30:04 2007 *************** *** 26,33 **** ## @end example ## or ## @example ! ## x(k+1) = A x(k) + B u(k) + G w(k) [w]=N(0,[Sigw 0 ]) ! ## y(k) = C x(k) + v(k) [v] ( 0 Sigv ]) ## @end example ## ## @strong{Inputs} --- 26,33 ---- ## @end example ## or ## @example ! ## x(k+1) = A x(k) + B u(k) + G w(k) [w]=N(0,[Sigw 0 ]) ! ## y(k) = C x(k) + v(k) [v] ( 0 Sigv ]) ## @end example ## ## @strong{Inputs} diff -cNr octave-2.9.15/scripts/control/hinf/hinfdemo.m octave-2.9.16/scripts/control/hinf/hinfdemo.m *** octave-2.9.15/scripts/control/hinf/hinfdemo.m Fri Oct 12 17:27:18 2007 --- octave-2.9.16/scripts/control/hinf/hinfdemo.m Mon Oct 15 11:30:04 2007 *************** *** 62,68 **** ## @end example ## @end ifinfo ## ! ## @example ## @group ## ## +----+ --- 62,68 ---- ## @end example ## @end ifinfo ## ! ## @smallexample ## @group ## ## +----+ *************** *** 78,84 **** ## -----| K |<------- ## +---+ ## @end group ! ## @end example ## ## @iftex ## @tex --- 78,84 ---- ## -----| K |<------- ## +---+ ## @end group ! ## @end smallexample ## ## @iftex ## @tex *************** *** 107,113 **** ## @end ifinfo ## norm of the ## augmented plant @var{P} (mixed-sensitivity problem): ! ## @example ## @group ## w ## 1 -----------+ --- 107,113 ---- ## @end ifinfo ## norm of the ## augmented plant @var{P} (mixed-sensitivity problem): ! ## @smallexample ## @group ## w ## 1 -----------+ *************** *** 124,130 **** ## u y (to K) ## (from controller K) ## @end group ! ## @end example ## ## @iftex ## @tex --- 124,130 ---- ## u y (to K) ## (from controller K) ## @end group ! ## @end smallexample ## ## @iftex ## @tex *************** *** 137,143 **** ## @end tex ## @end iftex ## @ifinfo ! ## @example ## @group ## + + + + ## | z | | w | --- 137,143 ---- ## @end tex ## @end iftex ## @ifinfo ! ## @smallexample ## @group ## + + + + ## | z | | w | *************** *** 147,153 **** ## | y | | u | ## + + + + ## @end group ! ## @end example ## @end ifinfo ## ## @item Discrete system: --- 147,153 ---- ## | y | | u | ## + + + + ## @end group ! ## @end smallexample ## @end ifinfo ## ## @item Discrete system: *************** *** 192,198 **** ## @end example ## @end ifinfo ## ! ## @example ## @group ## ## +----+ --- 192,198 ---- ## @end example ## @end ifinfo ## ! ## @smallexample ## @group ## ## +----+ *************** *** 208,214 **** ## -----| K |<------- ## +---+ ## @end group ! ## @end example ## @iftex ## @tex ## $$ { \rm min } \Vert T_{vz} \Vert _\infty $$ --- 208,214 ---- ## -----| K |<------- ## +---+ ## @end group ! ## @end smallexample ## @iftex ## @tex ## $$ { \rm min } \Vert T_{vz} \Vert _\infty $$ diff -cNr octave-2.9.15/scripts/control/system/ss.m octave-2.9.16/scripts/control/system/ss.m *** octave-2.9.15/scripts/control/system/ss.m Fri Oct 12 17:27:18 2007 --- octave-2.9.16/scripts/control/system/ss.m Mon Oct 15 11:30:04 2007 *************** *** 144,150 **** ## octave:1> a = [1 2 3; 4 5 6; 7 8 10]; ## octave:2> b = [0 0 ; 0 1 ; 1 0]; ## octave:3> c = eye (3); ! ## octave:4> sys = ss (a, b, c, [], 0, 3, 0, @{"volts", "amps", "joules"@}); ## octave:5> sysout(sys); ## Input(s) ## 1: u_1 --- 144,151 ---- ## octave:1> a = [1 2 3; 4 5 6; 7 8 10]; ## octave:2> b = [0 0 ; 0 1 ; 1 0]; ## octave:3> c = eye (3); ! ## octave:4> sys = ss (a, b, c, [], 0, 3, 0, ... ! ## > @{"volts", "amps", "joules"@}); ## octave:5> sysout(sys); ## Input(s) ## 1: u_1 diff -cNr octave-2.9.15/scripts/control/system/ss2sys.m octave-2.9.16/scripts/control/system/ss2sys.m *** octave-2.9.15/scripts/control/system/ss2sys.m Fri Oct 12 17:27:18 2007 --- octave-2.9.16/scripts/control/system/ss2sys.m Mon Oct 15 11:30:04 2007 *************** *** 18,24 **** ## . ## -*- texinfo -*- ! ## @deftypefn {Function File} {} ss (@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}, @var{n}, @var{nz}, @var{stname}, @var{inname}, @var{outname}, @var{outlist}) ## Create system structure from state-space data. May be continuous, ## discrete, or mixed (sampled data) ## --- 18,24 ---- ## . ## -*- texinfo -*- ! ## @deftypefn {Function File} {} ss2sys (@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}, @var{n}, @var{nz}, @var{stname}, @var{inname}, @var{outname}, @var{outlist}) ## Create system structure from state-space data. May be continuous, ## discrete, or mixed (sampled data) ## *************** *** 141,147 **** ## octave:1> a = [1 2 3; 4 5 6; 7 8 10]; ## octave:2> b = [0 0 ; 0 1 ; 1 0]; ## octave:3> c = eye (3); ! ## octave:4> sys = ss (a, b, c, [], 0, 3, 0, @{"volts", "amps", "joules"@}); ## octave:5> sysout(sys); ## Input(s) ## 1: u_1 --- 141,148 ---- ## octave:1> a = [1 2 3; 4 5 6; 7 8 10]; ## octave:2> b = [0 0 ; 0 1 ; 1 0]; ## octave:3> c = eye (3); ! ## octave:4> sys = ss (a, b, c, [], 0, 3, 0, ! ## > @{"volts", "amps", "joules"@}); ## octave:5> sysout(sys); ## Input(s) ## 1: u_1 diff -cNr octave-2.9.15/scripts/control/system/sysscale.m octave-2.9.16/scripts/control/system/sysscale.m *** octave-2.9.15/scripts/control/system/sysscale.m Fri Oct 12 17:27:19 2007 --- octave-2.9.16/scripts/control/system/sysscale.m Mon Oct 15 11:30:04 2007 *************** *** 37,47 **** ## @table @var ## @item retsys ## resulting open loop system: ! ## @example ## ----------- ------- ----------- ## u --->| inscale |--->| sys |--->| outscale |---> y ## ----------- ------- ----------- ! ## @end example ## @end table ## If the input names and output names (each a list of strings) ## are not given and the scaling matrices --- 37,47 ---- ## @table @var ## @item retsys ## resulting open loop system: ! ## @smallexample ## ----------- ------- ----------- ## u --->| inscale |--->| sys |--->| outscale |---> y ## ----------- ------- ----------- ! ## @end smallexample ## @end table ## If the input names and output names (each a list of strings) ## are not given and the scaling matrices diff -cNr octave-2.9.15/scripts/control/system/syssetsignals.m octave-2.9.16/scripts/control/system/syssetsignals.m *** octave-2.9.15/scripts/control/system/syssetsignals.m Fri Oct 12 17:27:19 2007 --- octave-2.9.16/scripts/control/system/syssetsignals.m Mon Oct 15 11:30:04 2007 *************** *** 65,72 **** ## ## @strong{Example} ## @example ! ## octave:1> sys=ss([1 2; 3 4],[5;6],[7 8]); ! ## octave:2> sys = syssetsignals(sys,"st",str2mat("Posx","Velx")); ## octave:3> sysout(sys) ## Input(s) ## 1: u_1 --- 65,73 ---- ## ## @strong{Example} ## @example ! ## octave:1> sys=ss ([1 2; 3 4],[5;6],[7 8]); ! ## octave:2> sys = syssetsignals (sys, "st", ! ## > str2mat("Posx","Velx")); ## octave:3> sysout(sys) ## Input(s) ## 1: u_1 diff -cNr octave-2.9.15/scripts/general/cplxpair.m octave-2.9.16/scripts/general/cplxpair.m *** octave-2.9.15/scripts/general/cplxpair.m Fri Oct 12 17:27:21 2007 --- octave-2.9.16/scripts/general/cplxpair.m Mon Oct 15 11:30:04 2007 *************** *** 35,43 **** ## error. Note that there are no guarantees on the order of the returned ## pairs with identical real parts but differing imaginary parts. ## ! ## @example ## cplxpair (exp(2i*pi*[0:4]'/5)) == exp(2i*pi*[3; 2; 4; 1; 0]/5) ! ## @end example ## @end deftypefn ## TODO: subsort returned pairs by imaginary magnitude --- 35,44 ---- ## error. Note that there are no guarantees on the order of the returned ## pairs with identical real parts but differing imaginary parts. ## ! ## @c Using 'smallexample' to make text fit in page when using 'smallbook' ! ## @smallexample ## cplxpair (exp(2i*pi*[0:4]'/5)) == exp(2i*pi*[3; 2; 4; 1; 0]/5) ! ## @end smallexample ## @end deftypefn ## TODO: subsort returned pairs by imaginary magnitude diff -cNr octave-2.9.15/scripts/general/rat.m octave-2.9.16/scripts/general/rat.m *** octave-2.9.15/scripts/general/rat.m Fri Oct 12 17:27:21 2007 --- octave-2.9.16/scripts/general/rat.m Mon Oct 15 11:30:04 2007 *************** *** 24,31 **** ## by @var{tol} using a continued fraction expansion. E.g, ## ## @example ! ## rat(pi) = 3 + 1/(7 + 1/16) = 355/113 ! ## rat(e) = 3 + 1/(-4 + 1/(2 + 1/(5 + 1/(-2 + 1/(-7))))) = 1457/536 ## @end example ## ## Called with two arguments returns the numerator and denominator separately --- 24,32 ---- ## by @var{tol} using a continued fraction expansion. E.g, ## ## @example ! ## rat(pi) = 3 + 1/(7 + 1/16) = 355/113 ! ## rat(e) = 3 + 1/(-4 + 1/(2 + 1/(5 + 1/(-2 + 1/(-7))))) ! ## = 1457/536 ## @end example ## ## Called with two arguments returns the numerator and denominator separately diff -cNr octave-2.9.15/scripts/image/image.m octave-2.9.16/scripts/image/image.m *** octave-2.9.15/scripts/image/image.m Fri Oct 12 17:27:22 2007 --- octave-2.9.16/scripts/image/image.m Fri Oct 26 13:57:34 2007 *************** *** 39,45 **** ## Created: July 1994 ## Adapted-By: jwe ! function image (x, y, img) ## Deprecated zoom. Remove this hunk of code if old zoom argument ## is outmoded. --- 39,45 ---- ## Created: July 1994 ## Adapted-By: jwe ! function h = image (x, y, img) ## Deprecated zoom. Remove this hunk of code if old zoom argument ## is outmoded. diff -cNr octave-2.9.15/scripts/image/imshow.m octave-2.9.16/scripts/image/imshow.m *** octave-2.9.15/scripts/image/imshow.m Fri Oct 12 17:27:22 2007 --- octave-2.9.16/scripts/image/imshow.m Fri Oct 26 13:57:34 2007 *************** *** 1,5 **** ## Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2004, 2005, ! ## 2006, 2007 Soren Hauberg ## ## This file is part of Octave. ## --- 1,5 ---- ## Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2004, 2005, ! ## 2006, 2007 John W. Eaton ## ## This file is part of Octave. ## *************** *** 21,33 **** ## @deftypefn {Function File} {} imshow (@var{im}) ## @deftypefnx {Function File} {} imshow (@var{im}, @var{limits}) ## @deftypefnx {Function File} {} imshow (@var{im}, @var{map}) ! ## @deftypefnx {Function File} {} imshow (@var{R}, @var{G}, @var{B}, @dots{}) ## @deftypefnx {Function File} {} imshow (@var{filename}) ## @deftypefnx {Function File} {} imshow (@dots{}, @var{string_param1}, @var{value1}, @dots{}) ## Display the image @var{im}, where @var{im} can be a 2-dimensional ! ## (gray-scale image) or a 3-dimensional (RGB image) matrix. If three matrices ! ## of the same size are given as arguments, they will be concatenated into ! ## 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 --- 21,31 ---- ## @deftypefn {Function File} {} imshow (@var{im}) ## @deftypefnx {Function File} {} imshow (@var{im}, @var{limits}) ## @deftypefnx {Function File} {} imshow (@var{im}, @var{map}) ! ## @deftypefnx {Function File} {} imshow (@var{rgb}, @dots{}) ## @deftypefnx {Function File} {} imshow (@var{filename}) ## @deftypefnx {Function File} {} imshow (@dots{}, @var{string_param1}, @var{value1}, @dots{}) ## Display the image @var{im}, where @var{im} can be a 2-dimensional ! ## (gray-scale 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 *************** *** 50,125 **** ## @seealso{image, imagesc, colormap, gray2ind, rgb2ind} ## @end deftypefn ## Author: Soren Hauberg ## Adapted-By: jwe ! function imshow (im, varargin) if (nargin == 0) print_usage (); endif ## Get the image. if (ischar (im)) ! im = loadimage (im); # It would be better to use imread from octave-forge ! elseif (! ismatrix (im)) error ("imshow: first argument must be an image or the filename of an image"); endif ! ! ## Is the function called with 3 matrices (i.e., imshow (R, G, B))? ! if (nargin >= 3 ! && ndims (im) == 2 ! && ndims (varargin{1}) == 2 ! && ndims (varargin{2}) == 2 ! && size_equal (im, varargin{1}) ! && size_equal (im, varargin{2})) ! im(:,:,3) = varargin{2}; ! im(:,:,2) = varargin{1}; ! varargin(1:2) = []; endif - ## Set default display range. - switch class (im) - case {"uint8"} - display_range = [0, 255]; - case {"uint16"} - display_range = [0, 65535]; - case {"double", "single", "logical"} - display_range = [0, 1]; - otherwise - error ("imshow: currently only images whos class is uint8, uint16, logical, or double are supported"); - endswitch - - ## Set other default parameters. - isindexed = false; - initial_magnification = 100; - color_map = colormap (); - - ## Handle the rest of the arguments. narg = 1; ! while (narg <= length (varargin)) ! arg = varargin{narg}; ! if (ismatrix (arg) && size (arg, 2) == 3) ! color_map = arg; ! isindexed = true; ! elseif (ismatrix (arg) && numel (arg) == 2) ! display_range = arg; ! elseif (isempty (arg)) ! display_range = [min(im(:)), max(im(:))]; ! elseif (ischar (arg) && strcmpi (arg, "displayrange")) ! narg++; ! display_range = varargin{narg}; ! elseif (ischar (arg) && ! (strcmpi (arg, "truesize") || ! strcmpi (arg, "initialmagnification"))) ! narg++; ! warning ("image: zoom argument ignored -- use GUI features"); else ! warning ("imshow: input argument number %d is unsupported", narg) endif - narg++; endwhile ## Check for complex images. if (iscomplex (im)) warning ("imshow: only showing real part of complex image"); --- 48,135 ---- ## @seealso{image, imagesc, colormap, gray2ind, rgb2ind} ## @end deftypefn + ## Author: Stefan van der Walt ## Author: Soren Hauberg ## Adapted-By: jwe ! function h = imshow (im, varargin) if (nargin == 0) print_usage (); endif + display_range = []; + true_color = false; + indexed = false; + ## Get the image. if (ischar (im)) ! ## Eventually, this should be imread. ! [im, map] = loadimage (im); ! indexed = true; ! colormap (map); ! endif ! ! if (! (isnumeric (im) && (ndims (im) == 2 || ndims (im) == 3))) error ("imshow: first argument must be an image or the filename of an image"); endif ! ! if (ndims (im) == 2) ! if (! indexed) ! colormap (gray ()); ! endif ! elseif (size (im, 3) == 3) ! if (ismember (class (im), {"uint8", "uint16", "double", "single"})) ! true_color = true; ! else ! error ("imshow: color image must be uint8, uint16, double, or single"); ! endif ! else ! error ("imshow: expecting MxN or MxNx3 matrix for image"); endif narg = 1; ! while (narg <= numel (varargin)) ! arg = varargin{narg++}; ! if (isnumeric (arg)) ! if (numel (arg) == 2) ! display_range = arg; ! elseif (columns (arg) == 3) ! indexed = true; ! colormap (arg); ! elseif (! isempty (arg)) ! error ("imshow: argument number %d is invalid", narg+1); ! endif ! elseif (ischar (arg)) ! switch (arg) ! case "displayrange"; ! displayrange = varargin{narg++}; ! case {"truesize", "initialmagnification"} ! warning ("image: zoom argument ignored -- use GUI features"); ! otherwise ! warning ("imshow: unrecognized property %s", arg); ! narg++; ! endswitch else ! error ("imshow: argument number %d is invalid", narg+1); endif endwhile + ## Set default display range. + if (true_color || isempty (display_range)) + display_range = [min(im(:)), max(im(:))]; + else + t = class (im); + switch (t) + case {"double", "single", "logical"} + display_range = [0, 1]; + case {"int8", "int16", "int32", "uint8", "uint16", "uint32"} + display_range = [intmin(t), intmax(t)]; + otherwise + error ("imshow: invalid data type for image"); + endswitch + endif + ## Check for complex images. if (iscomplex (im)) warning ("imshow: only showing real part of complex image"); *************** *** 129,170 **** nans = isnan (im(:)); if (any (nans)) warning ("Octave:imshow-NaN", ! "imshow: pixel with NaN or NA values are set to zero"); im(nans) = display_range(1); endif ## Scale the image to the interval [0, 1] according to display_range. ! if (! isindexed) low = display_range(1); high = display_range(2); ! im = (double (im) - low)/(high-low); im(im < 0) = 0; im(im > 1) = 1; endif ! dim = ndims (im); ! if (dim == 2) ! im = round ((size (color_map, 1) - 1) * im); ! image (im); ! colormap (color_map); ! elseif (dim == 3 && size (im, 3) == 3) ! __img__ ([] , [], im); ! ## FIXME -- needed anymore for a special case? ! ## Convert to indexed image. ! ## [im, color_map] = rgb2ind (im); else ! error ("imshow: input image must be a 2D or 3D matrix"); endif ! endfunction %!error imshow () # no arguments %!error imshow ({"cell"}) # No image or filename given - %!error imshow (int8(1)) # Unsupported image class %!error imshow (ones(4,4,4)) # Too many dimensions in image %!demo ! %! imshow (loadimage ("default.img")); %!demo %! [I, M] = loadimage ("default.img"); --- 139,184 ---- nans = isnan (im(:)); if (any (nans)) warning ("Octave:imshow-NaN", ! "imshow: pixels with NaN or NA values are set to minimum pixel value"); im(nans) = display_range(1); endif + ## This is for compatibility. + if (ismember (class (im), {"int8", "int16", "uint32", "int32", "single"})) + im = double (im); + endif + ## Scale the image to the interval [0, 1] according to display_range. ! if (! indexed || islogical (im)) low = display_range(1); high = display_range(2); ! im = (im-low)/(high-low); im(im < 0) = 0; im(im > 1) = 1; endif ! if (true_color) ! tmp = __img__ ([] , [], im); else ! tmp = image (round ((rows (colormap ()) - 1) * im)); endif ! ! if (nargout > 0) ! h = tmp; ! endif ! endfunction %!error imshow () # no arguments %!error imshow ({"cell"}) # No image or filename given %!error imshow (ones(4,4,4)) # Too many dimensions in image %!demo ! %! imshow ("default.img"); ! ! %!demo ! %! imshow ("default.img"); ! %! colormap ("autumn"); %!demo %! [I, M] = loadimage ("default.img"); *************** *** 175,179 **** %! imshow (cat(3, I, I*0.5, I*0.8)); %!demo ! %! I = loadimage("default.img"); ! %! imshow(I, I, I); --- 189,202 ---- %! imshow (cat(3, I, I*0.5, I*0.8)); %!demo ! %! imshow (rand (100, 100)); ! ! %!demo ! %! imshow (rand (100, 100, 3)); ! ! %!demo ! %! imshow (100*rand (100, 100, 3)); ! ! %!demo ! %! imshow (rand (100, 100)); ! %! colormap (jet); diff -cNr octave-2.9.15/scripts/image/saveimage.m octave-2.9.16/scripts/image/saveimage.m *** octave-2.9.15/scripts/image/saveimage.m Fri Oct 12 17:27:22 2007 --- octave-2.9.16/scripts/image/saveimage.m Wed Oct 24 15:00:12 2007 *************** *** 115,121 **** ## If we just want Octave image format, save and return. if (strcmp (img_form, "img")) ! eval (strcat ("save -ascii ", filename, " map img")); return; endif --- 115,121 ---- ## If we just want Octave image format, save and return. if (strcmp (img_form, "img")) ! save ("-text", filename, "map", "img"); return; endif diff -cNr octave-2.9.15/scripts/miscellaneous/Makefile.in octave-2.9.16/scripts/miscellaneous/Makefile.in *** octave-2.9.15/scripts/miscellaneous/Makefile.in Fri Oct 12 17:27:23 2007 --- octave-2.9.16/scripts/miscellaneous/Makefile.in Tue Oct 23 04:19:49 2007 *************** *** 34,40 **** INSTALL_DATA = @INSTALL_DATA@ SOURCES = ans.m bincoeff.m bug_report.m bunzip2.m cast.m comma.m \ ! compare_versions.m computer.m copyfile.m cputime.m \ delete.m dir.m doc.m dos.m dump_prefs.m \ fileattrib.m fileparts.m flops.m fullfile.m getfield.m gunzip.m \ gzip.m inputname.m ismac.m ispc.m isunix.m license.m list_primes.m ls.m \ --- 34,40 ---- INSTALL_DATA = @INSTALL_DATA@ SOURCES = ans.m bincoeff.m bug_report.m bunzip2.m cast.m comma.m \ ! compare_versions.m computer.m copyfile.m \ delete.m dir.m doc.m dos.m dump_prefs.m \ fileattrib.m fileparts.m flops.m fullfile.m getfield.m gunzip.m \ gzip.m inputname.m ismac.m ispc.m isunix.m license.m list_primes.m ls.m \ *************** *** 42,48 **** news.m orderfields.m pack.m paren.m parseparams.m \ run.m semicolon.m setfield.m single.m substruct.m swapbytes.m tar.m \ tempdir.m tempname.m texas_lotto.m unix.m unpack.m untar.m \ ! unzip.m ver.m version.m warning_ids.m xor.m zip.m DISTFILES = $(addprefix $(srcdir)/, Makefile.in $(SOURCES)) --- 42,48 ---- news.m orderfields.m pack.m paren.m parseparams.m \ run.m semicolon.m setfield.m single.m substruct.m swapbytes.m tar.m \ tempdir.m tempname.m texas_lotto.m unix.m unpack.m untar.m \ ! unzip.m ver.m version.m warning_ids.m what.m xor.m zip.m DISTFILES = $(addprefix $(srcdir)/, Makefile.in $(SOURCES)) diff -cNr octave-2.9.15/scripts/miscellaneous/compare_versions.m octave-2.9.16/scripts/miscellaneous/compare_versions.m *** octave-2.9.15/scripts/miscellaneous/compare_versions.m Fri Oct 12 17:27:23 2007 --- octave-2.9.16/scripts/miscellaneous/compare_versions.m Thu Oct 25 03:16:07 2007 *************** *** 68,102 **** ## TODO?: This allows a single equal sign "=" to indicate equality, do ## we want to require a double equal since that is the boolean operator? ! function out = compare_versions(v1, v2, operator) ! ## make sure that the version numbers are valid ! if ~ (ischar (v1) && ischar (v2)) ! error ("Both version numbers must be strings"); ! elseif (size (v1, 1) ~= 1) || (size (v2, 1) ~= 1) ! error ("Version numbers must be a single row") endif ## check and make sure that the operator is valid ! if (~ ischar (operator)) ! error("Operator must be a character string"); elseif (numel (operator) > 2) ! error("Operator cannot be more than 2 characters long"); endif ## trim off any character data that is not part of a normal version ## number numbers = "0123456789."; ! v1firstchar = find(~ ismember(v1, numbers), 1); ! v2firstchar = find(~ ismember(v2, numbers), 1); ! if ~ isempty (v1firstchar) v1c = v1(v1firstchar:length(v1)); v1nochar = v1(1:v1firstchar-1); else v1c = ""; v1nochar = v1; endif ! if ~ isempty (v2firstchar) v2c = v2(v2firstchar:length(v2)); v2nochar = v2(1:v2firstchar-1); else --- 68,103 ---- ## TODO?: This allows a single equal sign "=" to indicate equality, do ## we want to require a double equal since that is the boolean operator? ! function out = compare_versions (v1, v2, operator) ! ## Make sure that the version numbers are valid. ! if (! (ischar (v1) && ischar (v2))) ! error ("compare_versions: both version numbers must be strings"); ! elseif (size (v1, 1) != 1 || size (v2, 1) != 1) ! error ("compare_versions: version numbers must be a single row") endif ## check and make sure that the operator is valid ! if (! ischar (operator)) ! error ("compare_versions: operator must be a character string"); elseif (numel (operator) > 2) ! error("compare_versions: operator cannot be more than 2 characters long"); endif ## trim off any character data that is not part of a normal version ## number numbers = "0123456789."; ! ! v1firstchar = find (! ismember (v1, numbers), 1); ! v2firstchar = find (! ismember (v2, numbers), 1); ! if (! isempty (v1firstchar)) v1c = v1(v1firstchar:length(v1)); v1nochar = v1(1:v1firstchar-1); else v1c = ""; v1nochar = v1; endif ! if (! isempty (v2firstchar)) v2c = v2(v2firstchar:length(v2)); v2nochar = v2(1:v2firstchar-1); else *************** *** 104,117 **** v2nochar = v2; endif ! v1n = str2num (split (v1nochar, '.')); ! v2n = str2num (split (v2nochar, '.')); if ((isempty (v1n) && isempty (v1c)) || (isempty (v2n) && isempty(v2c))) ! error ("Given version strings are not valid: %s %s", v1, v2); endif ! ## assume that any additional elements would be 0 if one is longer ! ## than the other maxnumlen = max ([length(v1n) length(v2n)]); if (length (v1n) < maxnumlen) v1n(length(v1n)+1:maxnumlen) = 0; --- 105,119 ---- v2nochar = v2; endif ! v1n = str2num (split (v1nochar, ".")); ! v2n = str2num (split (v2nochar, ".")); if ((isempty (v1n) && isempty (v1c)) || (isempty (v2n) && isempty(v2c))) ! error ("compare_versions: given version strings are not valid: %s %s", ! v1, v2); endif ! ## Assume that any additional elements would be 0 if one is longer ! ## than the other. maxnumlen = max ([length(v1n) length(v2n)]); if (length (v1n) < maxnumlen) v1n(length(v1n)+1:maxnumlen) = 0; *************** *** 120,128 **** v2n(length(v2n)+1:maxnumlen) = 0; endif ! ## assume that any additional character elements would be 0 if one is ! ## longer than the other ! maxcharlen = max ([length(v1c) length(v2c)]); if (length (v1c) < maxcharlen) v1c(length(v1c)+1:maxcharlen) = "\0"; endif --- 122,130 ---- v2n(length(v2n)+1:maxnumlen) = 0; endif ! ## Assume that any additional character elements would be 0 if one is ! ## longer than the other. ! maxcharlen = max ([length(v1c), length(v2c)]); if (length (v1c) < maxcharlen) v1c(length(v1c)+1:maxcharlen) = "\0"; endif *************** *** 130,136 **** v2c(length(v2c)+1:maxcharlen) = "\0"; endif ! ## determine the operator if any (ismember (operator, "=")) equal_op = true; else --- 132,138 ---- v2c(length(v2c)+1:maxcharlen) = "\0"; endif ! ## Determine the operator. if any (ismember (operator, "=")) equal_op = true; else *************** *** 152,185 **** gt_op = false; endif ! ## make sure that we don't have conflicting operators if (gt_op && lt_op) ! error("Operator cannot contain both greater and less than symbols"); elseif ((gt_op || lt_op) && not_op) ! error("Operator cannot contain not and greater than or less than symbols"); endif ! ## compare the versions (making sure that they're the same shape) vcmp = v1n(:) - v2n(:); vcmp = [vcmp; (v1c - v2c)(:)]; if (lt_op) ## so that we only need to check for the output being greater than 1 vcmp = -vcmp; endif ! firstdiff = find(vcmp != 0, 1); ! if isempty (firstdiff) ! ## they're equal out = equal_op; elseif (lt_op || gt_op) ! ## they're correctly less than or greater than out = (vcmp(firstdiff) > 0); else ! ## they're not correctly less than or greater than, and they're not equal out = false; endif ! ## reverse the output if not is given out = xor (not_op, out); endfunction --- 154,188 ---- gt_op = false; endif ! ## Make sure that we don't have conflicting operators. if (gt_op && lt_op) ! error ("compare_versions: operator cannot contain both greater and less than symbols"); elseif ((gt_op || lt_op) && not_op) ! error ("compare_versions: operator cannot contain not and greater than or less than symbols"); endif ! ## Compare the versions (making sure that they're the same shape) vcmp = v1n(:) - v2n(:); vcmp = [vcmp; (v1c - v2c)(:)]; if (lt_op) ## so that we only need to check for the output being greater than 1 vcmp = -vcmp; endif ! firstdiff = find (vcmp != 0, 1); ! if (isempty (firstdiff)) ! ## They're equal. out = equal_op; elseif (lt_op || gt_op) ! ## They're correctly less than or greater than. out = (vcmp(firstdiff) > 0); else ! ## They're not correctly less than or greater than, and they're not ! ## equal. out = false; endif ! ## Reverse the output if not is given. out = xor (not_op, out); endfunction diff -cNr octave-2.9.15/scripts/miscellaneous/cputime.m octave-2.9.16/scripts/miscellaneous/cputime.m *** octave-2.9.15/scripts/miscellaneous/cputime.m Fri Oct 12 17:27:23 2007 --- octave-2.9.16/scripts/miscellaneous/cputime.m Wed Dec 31 19:00:00 1969 *************** *** 1,49 **** - ## Copyright (C) 1995, 1996, 1997, 1999, 2005, 2007 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 - ## . - - ## -*- texinfo -*- - ## @deftypefn {Function File} {[@var{total}, @var{user}, @var{system}] =} cputime (); - ## Return the CPU time used by your Octave session. The first output is - ## the total time spent executing your process and is equal to the sum of - ## second and third outputs, which are the number of CPU seconds spent - ## executing in user mode and the number of CPU seconds spent executing in - ## system mode, respectively. If your system does not have a way to report - ## CPU time usage, @code{cputime} returns 0 for each of its output values. - ## Note that because Octave used some CPU time to start, it is reasonable - ## to check to see if @code{cputime} works by checking to see if the total - ## CPU time used is nonzero. - ## @end deftypefn - - ## Author: jwe - - function [total, user, system] = cputime () - - if (nargin != 0) - warning ("cputime: ignoring extra arguments"); - endif - - resource_stats = getrusage (); - - usr = resource_stats.utime; - sys = resource_stats.stime; - - user = usr.sec + usr.usec / 1e6; - system = sys.sec + sys.usec / 1e6; - total = user + system; - - endfunction --- 0 ---- diff -cNr octave-2.9.15/scripts/miscellaneous/what.m octave-2.9.16/scripts/miscellaneous/what.m *** octave-2.9.15/scripts/miscellaneous/what.m Wed Dec 31 19:00:00 1969 --- octave-2.9.16/scripts/miscellaneous/what.m Tue Oct 23 08:02:17 2007 *************** *** 0 **** --- 1,116 ---- + ## Copyright (C) 2007 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 + ## . + + ## -*- texinfo -*- + ## @deftypefn {Command} {} what + ## @deftypefnx {Command} {} what @var{dir} + ## @deftypefnx {Function File} {w =} what (@var{dir}) + ## List the Octave specific files in a directory. If the variable @var{dir} + ## is given then check that directory rather than the current directory. If + ## a return argument is requested, the files found are returned in the + ## structure @var{w}. + ## @seealso{which} + ## @end deftypefn + + ## PKG_ADD: mark_as_command what + + function ret = what (d) + + if (nargin == 0) + d = pwd (); + elseif (isempty (strfind (d, filesep ()))) + ## Find the appropriate directory on the path + p = split (path (), pathsep()); + p = cellfun (@(x) deblank (x), mat2cell (p, ones (1, size (p, 1)), ... + size (p, 2)), "UniformOutput", false); + d = p{find (cellfun (@(x) ! isempty (strfind (x, d)), p))(end)}; + else + [status, msg, msgid] = fileattrib (d); + if (status != 1) + error ("could not find the file or path %s", d); + else + d = msg.Name; + endif + endif + + files = dir (d); + w.path = d; + w.m = cell (0, 1); + w.mex = cell (0, 1); + w.oct = cell (0, 1); + w.mat = cell (0, 1); + w.mdl = cell (0, 1); + w.p = cell (0, 1); + w.classes = cell (0, 1); + + for i = 1 : length (files) + n = files(i).name; + ## Ignore . and .. + if (strcmp (n, ".") || strcmp (n, "..")) + continue; + else + ## Ignore mdl and p files + [dummy, f, e] = fileparts (n); + if (strcmp (e, ".m")) + w.m {end+1} = n; + elseif (strcmp (e, mexext ())) + w.mex {end + 1} = n; + elseif (strcmp (e, ".oct")) + w.oct {end + 1} = n; + elseif (strcmp (e, ".mat")) + w.mat {end + 1} = n; + elseif(strcmp (n(1), "@")) + w.classes {end + 1} = n; + endif + endif + endfor + + if (nargout == 0) + __display_filenames__ ("M-files in directory", w.path, w.m); + __display_filenames__ ("\nMEX-files in directory", w.path, w.mex); + __display_filenames__ ("\nOCT-files in directory", w.path, w.oct); + __display_filenames__ ("\nMAT-files in directory", w.path, w.mat); + __display_filenames__ ("\nClasses in directory", w.path, w.classes); + else + ret = w; + endif + endfunction + + function __display_filenames__ (msg, p, f) + if (length (f) > 0) + printf ("%s %s:\n\n", msg, p) + + maxlen = max (cellfun (@(x) length (x), f)); + ncols = max (1, floor (terminal_size()(2) / (maxlen + 3))); + fmt = ""; + for i = 1: ncols + fmt = sprintf ("%s %%-%ds", fmt, maxlen); + endfor + fmt = [fmt, "\n"]; + + nrows = ceil (length (f) / ncols); + for i = 1 : nrows + args = f(i:nrows:end); + if (length (args) < ncols) + n = ncols - length (args); + args{end : end + n} = ""; + endif + printf (fmt, args{:}); + endfor + endif + endfunction diff -cNr octave-2.9.15/scripts/optimization/sqp.m octave-2.9.16/scripts/optimization/sqp.m *** octave-2.9.15/scripts/optimization/sqp.m Fri Oct 12 17:27:23 2007 --- octave-2.9.16/scripts/optimization/sqp.m Mon Oct 15 11:30:04 2007 *************** *** 77,83 **** ## If supplied, the gradient function must be of the form ## ## @example ! ## g = gradient (x) ## @end example ## ## @noindent --- 77,83 ---- ## If supplied, the gradient function must be of the form ## ## @example ! ## g = gradient (x) ## @end example ## ## @noindent *************** *** 86,92 **** ## If supplied, the hessian function must be of the form ## ## @example ! ## h = hessian (x) ## @end example ## ## @noindent --- 86,92 ---- ## If supplied, the hessian function must be of the form ## ## @example ! ## h = hessian (x) ## @end example ## ## @noindent *************** *** 103,109 **** ## of the form ## ## @example ! ## r = f (x) ## @end example ## ## @noindent --- 103,109 ---- ## of the form ## ## @example ! ## r = f (x) ## @end example ## ## @noindent *************** *** 134,168 **** ## Here is an example of calling @code{sqp}: ## ## @example ! ## function r = g (x) ! ## r = [ sumsq(x)-10; x(2)*x(3)-5*x(4)*x(5); x(1)^3+x(2)^3+1]; ! ## endfunction ! ## ! ## function obj = phi (x) ! ## obj = exp(prod(x)) - 0.5*(x(1)^3+x(2)^3+1)^2; ! ## endfunction ! ## ! ## x0 = [-1.8; 1.7; 1.9; -0.8; -0.8]; ! ## ! ## [x, obj, info, iter, nf, lambda] = sqp (x0, @@phi, @@g, []) ! ## ! ## x = ! ## ! ## -1.71714 ! ## 1.59571 ! ## 1.82725 ! ## -0.76364 ! ## -0.76364 ! ## ! ## obj = 0.053950 ! ## info = 101 ! ## iter = 8 ! ## nf = 10 ! ## lambda = ## ! ## -0.0401627 ! ## 0.0379578 ! ## -0.0052227 ## @end example ## ## The value returned in @var{info} may be one of the following: --- 134,170 ---- ## Here is an example of calling @code{sqp}: ## ## @example ! ## function r = g (x) ! ## r = [ sumsq(x)-10; ! ## x(2)*x(3)-5*x(4)*x(5); ! ## x(1)^3+x(2)^3+1 ]; ! ## endfunction ! ## ! ## function obj = phi (x) ! ## obj = exp(prod(x)) - 0.5*(x(1)^3+x(2)^3+1)^2; ! ## endfunction ! ## ! ## x0 = [-1.8; 1.7; 1.9; -0.8; -0.8]; ! ## ! ## [x, obj, info, iter, nf, lambda] = sqp (x0, @@phi, @@g, []) ! ## ! ## x = ! ## ! ## -1.71714 ! ## 1.59571 ! ## 1.82725 ! ## -0.76364 ! ## -0.76364 ## ! ## obj = 0.053950 ! ## info = 101 ! ## iter = 8 ! ## nf = 10 ! ## lambda = ! ## ! ## -0.0401627 ! ## 0.0379578 ! ## -0.0052227 ## @end example ## ## The value returned in @var{info} may be one of the following: diff -cNr octave-2.9.15/scripts/pkg/pkg.m octave-2.9.16/scripts/pkg/pkg.m *** octave-2.9.15/scripts/pkg/pkg.m Fri Oct 12 17:27:23 2007 --- octave-2.9.16/scripts/pkg/pkg.m Fri Oct 26 12:09:12 2007 *************** *** 173,179 **** ## @end deftypefn ## PKG_ADD: mark_as_command pkg - ## PKG_ADD: pkg ("load", "auto"); function [local_packages, global_packages] = pkg (varargin) ## Installation prefix (XXX: what should these be on windows?) --- 173,178 ---- *************** *** 1095,1101 **** endif ## Split into architecture dependent and independent files ! idx = cellfun (@(x) is_architecture_dependent (x), filenames); archdependent = filenames (idx); archindependent = filenames (!idx); --- 1094,1104 ---- endif ## Split into architecture dependent and independent files ! if (isempty (filenames)) ! idx = []; ! else ! idx = cellfun (@(x) is_architecture_dependent (x), filenames); ! endif archdependent = filenames (idx); archindependent = filenames (!idx); diff -cNr octave-2.9.15/scripts/plot/Makefile.in octave-2.9.16/scripts/plot/Makefile.in *** octave-2.9.15/scripts/plot/Makefile.in Fri Oct 12 17:27:24 2007 --- octave-2.9.16/scripts/plot/Makefile.in Tue Oct 23 04:19:49 2007 *************** *** 34,39 **** --- 34,40 ---- INSTALL_DATA = @INSTALL_DATA@ SOURCES = \ + __axes_limits__.m \ __axis_label__.m \ __bar__.m \ __default_plot_options__.m \ *************** *** 70,78 **** --- 71,81 ---- closereq.m \ contour.m \ contourc.m \ + contourf.m \ drawnow.m \ errorbar.m \ figure.m \ + fill.m \ findobj.m \ fplot.m \ gca.m \ *************** *** 112,119 **** title.m \ view.m \ xlabel.m \ ylabel.m \ ! zlabel.m DISTFILES = $(addprefix $(srcdir)/, Makefile.in $(SOURCES)) --- 115,125 ---- title.m \ view.m \ xlabel.m \ + xlim.m \ ylabel.m \ ! ylim.m \ ! zlabel.m \ ! zlim.m DISTFILES = $(addprefix $(srcdir)/, Makefile.in $(SOURCES)) diff -cNr octave-2.9.15/scripts/plot/__axes_limits__.m octave-2.9.16/scripts/plot/__axes_limits__.m *** octave-2.9.15/scripts/plot/__axes_limits__.m Wed Dec 31 19:00:00 1969 --- octave-2.9.16/scripts/plot/__axes_limits__.m Tue Oct 23 08:02:17 2007 *************** *** 0 **** --- 1,57 ---- + ## Copyright (C) 2007 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 + ## . + + ## Undocumented internal function. + + function retval = __axes_limits__ (fcn, varargin) + retval = []; + fcnmode = sprintf("%smode", fcn); + + if (nargin > 1 && isscalar (varargin{1}) && ishandle (varargin{1})) + h = varargin {1}; + off = 1; + if (! strcmp (get (h, "type"), "axes")) + error ("%s: expecting first argument to be an axes object", fcn); + endif + else + off = 0; + h = gca (); + endif + + if (nargin == off + 1) + retval = get (h, fcn); + else + arg = varargin {off + 1}; + + if (ischar (arg)) + arg = tolower (arg); + if (strcmp ("mode", arg)) + + retval = get (h, fcnmode); + elseif (strcmp ("auto", arg) || strcmp ("manual", arg)) + set (h, fcnmode, arg); + endif + else + if (!isnumeric (arg) && any (size(arg(:)) != [2, 1])) + error ("%s: argument must be a 2 element vector", fcn); + else + set (h, fcn, arg (:)); + endif + endif + endif + endfunction diff -cNr octave-2.9.15/scripts/plot/__bar__.m octave-2.9.16/scripts/plot/__bar__.m *** octave-2.9.15/scripts/plot/__bar__.m Fri Oct 12 17:27:24 2007 --- octave-2.9.16/scripts/plot/__bar__.m Fri Oct 19 12:12:05 2007 *************** *** 144,151 **** --- 144,153 ---- if (vertical) if (nargout < 1) + newplot (); patch (xb, yb, newargs {:}); elseif (nargout < 2) + newplot (); varargout{1} = patch (xb, yb, newargs {:}); else varargout{1} = xb; *************** *** 153,160 **** --- 155,164 ---- endif else if (nargout < 1) + newplot (); patch (yb, xb, newargs{:}); elseif (nargout < 2) + newplot (); varargout{1} = patch (yb, xb, newargs{:}); else varargout{1} = yb; diff -cNr octave-2.9.15/scripts/plot/__go_draw_axes__.m octave-2.9.16/scripts/plot/__go_draw_axes__.m *** octave-2.9.15/scripts/plot/__go_draw_axes__.m Sat Oct 13 01:13:29 2007 --- octave-2.9.16/scripts/plot/__go_draw_axes__.m Wed Oct 31 12:23:25 2007 *************** *** 143,149 **** if (strcmpi (axis_obj.zgrid, "on")) fputs (plot_stream, "set grid ztics;\n"); else ! fputs (plot_stream, "set grid ztics;\n"); endif if (strcmpi (axis_obj.xminorgrid, "on")) --- 143,149 ---- if (strcmpi (axis_obj.zgrid, "on")) fputs (plot_stream, "set grid ztics;\n"); else ! fputs (plot_stream, "set grid noztics;\n"); endif if (strcmpi (axis_obj.xminorgrid, "on")) *************** *** 788,793 **** --- 788,797 ---- endif endif + if (strcmpi (axis_obj.visible, "off")) + fputs (plot_stream, "unset border; unset tics\n"); + endif + if (strcmpi (axis_obj.key, "on")) if (strcmpi (axis_obj.keybox, "on")) box = "box"; *************** *** 1052,1058 **** case "*" pt = "3"; case "." ! pt = "7"; case "x" pt = "2"; case {"square", "s"} --- 1056,1062 ---- case "*" pt = "3"; case "." ! pt = "0"; case "x" pt = "2"; case {"square", "s"} diff -cNr octave-2.9.15/scripts/plot/bar.m octave-2.9.16/scripts/plot/bar.m *** octave-2.9.15/scripts/plot/bar.m Fri Oct 12 17:27:24 2007 --- octave-2.9.16/scripts/plot/bar.m Wed Oct 31 13:16:16 2007 *************** *** 18,24 **** ## . ## -*- texinfo -*- ! ## @deftypefn {Function File} {@var{h} =} bar (@var{x}, @var{y}, @var{style}) ## @deftypefnx {Function File} {[@var{xb}, @var{yb}] =} bar (@dots{}) ## Given two vectors of x-y data, @code{bar} produce a bar graph. ## --- 18,24 ---- ## . ## -*- texinfo -*- ! ## @deftypefn {Function File} {@var{h} =} bar (@var{x}, @var{y}, @var{p1}, @var{v1}, @dots{}) ## @deftypefnx {Function File} {[@var{xb}, @var{yb}] =} bar (@dots{}) ## Given two vectors of x-y data, @code{bar} produce a bar graph. ## *************** *** 28,34 **** ## If @var{y} is a matrix, then each column of @var{y} is taken to be a ## separate bar graph plotted on the same graph. By default the columns ## are plotted side-by-side. This behavior can be changed by the @var{style} ! ## argument, which can take the values 'group' (the default), or 'stack'. ## ## If two output arguments are specified, the data are generated but ## not plotted. For example, --- 28,35 ---- ## If @var{y} is a matrix, then each column of @var{y} is taken to be a ## separate bar graph plotted on the same graph. By default the columns ## are plotted side-by-side. This behavior can be changed by the @var{style} ! ## argument, which can take the values @code{"grouped"} (the default), ! ## or @code{"stacked"}. ## ## If two output arguments are specified, the data are generated but ## not plotted. For example, diff -cNr octave-2.9.15/scripts/plot/barh.m octave-2.9.16/scripts/plot/barh.m *** octave-2.9.15/scripts/plot/barh.m Fri Oct 12 17:27:24 2007 --- octave-2.9.16/scripts/plot/barh.m Wed Oct 31 13:16:16 2007 *************** *** 27,33 **** ## If @var{y} is a matrix, then each column of @var{y} is taken to be a ## separate bar graph plotted on the same graph. By default the columns ## are plotted side-by-side. This behavior can be changed by the @var{style} ! ## argument, which can take the values 'group' (the default), or 'stack'. ## ## If two output arguments are specified, the data are generated but ## not plotted. For example, --- 27,34 ---- ## If @var{y} is a matrix, then each column of @var{y} is taken to be a ## separate bar graph plotted on the same graph. By default the columns ## are plotted side-by-side. This behavior can be changed by the @var{style} ! ## argument, which can take the values @code{"grouped"} (the default), ! ## or @code{"stacked"}. ## ## If two output arguments are specified, the data are generated but ## not plotted. For example, diff -cNr octave-2.9.15/scripts/plot/contourf.m octave-2.9.16/scripts/plot/contourf.m *** octave-2.9.15/scripts/plot/contourf.m Wed Dec 31 19:00:00 1969 --- octave-2.9.16/scripts/plot/contourf.m Fri Oct 19 16:43:32 2007 *************** *** 0 **** --- 1,259 ---- + ## Copyright (C) 2007 Kai Habel + ## Copyright (C) 2003 Shai Ayal + ## + ## This program is free software; you can redistribute it and/or modify it + ## under the terms of the GNU General Public License as published by + ## the Free Software Foundation; either version 2, or (at your option) + ## any later version. + ## + ## OctPlot 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 OctPlot; see the file COPYING. If not, write to the Free + ## Software Foundation, 59 Temple Place - Suite 330, Boston, MA + ## 02111-1307, USA. + + ## -*- texinfo -*- + ## @deftypefn {Function File} {[@var{c}, @var{h}] =} contourf (@var{x}, @var{y}, @var{z}, @var{lvl}) + ## @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{x}, @var{y}, @var{z}, @var{n}) + ## @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{x}, @var{y}, @var{z}) + ## @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{z}, @var{n}) + ## @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{z}, @var{lvl}) + ## @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{z}) + ## @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@var{ax}, @dots{}) + ## @deftypefnx {Function File} {[@var{c}, @var{h}] =} contourf (@dots{}, @var{"property"}, @var{val}) + ## Compute and plot filled contours of the matrix @var{z}. + ## Parameters @var{x}, @var{y} and @var{n} or @var{lvl} are optional. + ## + ## The return value @var{c} is a 2xn matrix containing the contour lines + ## as described in the help to the contourc function. + ## + ## The return value @var{h} is handle-vector to the patch objects creating + ## the filled contours. + ## + ## If @var{x} and @var{y} are ommited they are taken as the row/column + ## index of @var{z}. @var{n} is a scalar denoting the number of lines + ## to compute. Alternatively @var{lvl} is a vector containing the + ## contour levels. If only one value (e.g. lvl0) is wanted, set + ## @var{lvl} to [lvl0, lvl0]. If both @var{n} or @var{lvl} are omitted + ## a default value of 10 contour level is assumed. + ## + ## If provided, the filled contours are added to the axes object + ## @var{ax} instead of the current axis. + ## + ## The following example plots filled contours of the @code{peaks} + ## function. + ## @example + ## [x, y, z] = peaks (50); + ## contourf (x, y, z, -7:9) + ## @end example + ## @seealso{contour, contourc, patch} + ## @end deftypefn + + ## Author: Kai Habel + ## Author: shaia + + function varargout = contourf (varargin) + + [X, Y, Z, lvl, ax, patch_props] = parse_args (varargin); + [nr, nc] = size (Z); + [minx, maxx] = deal (min (X(:)), max (X(:))); + [miny, maxy] = deal (min (Y(:)), max (Y(:))); + + if (diff (lvl) < 10*eps) + lvl_eps = 1e-6; + else + lvl_eps = min (diff (lvl)) / 1000.0; + endif + + X0 = prepad(X, nc+1, 2 * X(1, 1) - X(1, 2), 2); + X0 = postpad(X0, nc+2, 2 * X(1, nc) - X(1, nc - 1), 2); + X0 = [X0(1, :); X0; X0(1, :)]; + Y0 = prepad(Y, nr+1, 2 * Y(1, 1) - Y(2, 1), 1); + Y0 = postpad(Y0, nr+2, 2 * Y(nr, 1) - Y(nr - 1, 1)); + Y0 = [Y0(:, 1), Y0, Y0(:, 1)]; + + Z0 = -Inf(nr+2, nc+2); + Z0(2:nr+1, 2:nc+1) = Z; + [c, lev] = contourc (X0, Y0, Z0, lvl); + cmap = colormap (); + + levx = linspace (min (lev), max (lev), size (cmap, 1)); + + newplot (); + + ## Decode contourc output format. + i1 = 1; + ncont = 0; + while (i1 < columns (c)) + ncont++; + cont_lev(ncont) = c(1, i1); + cont_len(ncont) = c(2, i1); + cont_idx(ncont) = i1+1; + + ii = i1+1:i1+cont_len(ncont); + cur_cont = c(:, ii); + c(:, ii); + startidx = ii(1); + stopidx = ii(end); + cont_area(ncont) = polyarea (c(1, ii), c(2, ii)); + i1 += c(2, i1) + 1; + endwhile + + ## Handle for each level the case where we have (a) hole(s) in a patch. + ## Those are to be filled with the color of level below or with the + ## background colour. + for k = 1:numel (lev) + lvl_idx = find (abs (cont_lev - lev(k)) < lvl_eps); + len = numel (lvl_idx); + if (len > 1) + ## mark = logical(zeros(size(lvl_idx))); + mark = false (size (lvl_idx)); + a = 1; + while (a < len) + # take 1st patch + b = a + 1; + pa_idx = lvl_idx(a); + # get pointer to contour start, and contour length + curr_ct_idx = cont_idx(pa_idx); + curr_ct_len = cont_len(pa_idx); + # get contour + curr_ct = c(:, curr_ct_idx:curr_ct_idx+curr_ct_len-1); + b_vec = (a+1):len; + next_ct_pt_vec = c(:, cont_idx(lvl_idx(b_vec))); + in = inpolygon (next_ct_pt_vec(1,:), next_ct_pt_vec(2,:), + curr_ct(1, :), curr_ct(2, :)); + mark(b_vec(in)) = !mark(b_vec(in)); + a++; + endwhile + if (numel (mark) > 0) + ## All marked contours describe a hole in a larger contour of + ## the same level and must be filled with colour of level below. + ma_idx = lvl_idx(mark); + if (k > 1) + ## Find color of level below. + tmp = find(abs(cont_lev - lev(k - 1)) < lvl_eps); + lvl_bel_idx = tmp(1); + ## Set color of patches found. + cont_lev(ma_idx) = cont_lev(lvl_bel_idx); + else + ## Set lowest level contour to NaN. + cont_lev(ma_idx) = NaN; + endif + endif + endif + endfor + + ## The algorithm can create patches with the size of the plotting + ## area, we would like to draw only the patch with the highest level. + del_idx = []; + max_idx = find (cont_area == max (cont_area)); + if (numel (max_idx) > 1) + # delete double entries + del_idx = max_idx(1:end-1); + cont_area(del_idx) = cont_lev(del_idx) = []; + cont_len(del_idx) = cont_idx(del_idx) = []; + endif + + ## Now we have everything together and can start plotting the patches + ## beginning with largest area. + [tmp, svec] = sort (cont_area); + len = ncont - numel (del_idx); + h = zeros (1, len); + for n = len:-1:1 + idx = svec(n); + ii = cont_idx(idx):cont_idx(idx) + cont_len(idx) - 2; + h(n) = patch (c(1, ii), c(2, ii), cont_lev(idx), patch_props{:}); + endfor + + if (min (lev) == max (lev)) + set (gca (), "clim", [min(lev)-1, max(lev)+1]); + else + set (gca(), "clim", [min(lev), max(lev)]); + endif + + if (nargout > 0) + varargout{2} = h; + varargout{1} = c; + endif + + endfunction + + function [X, Y, Z, lvl, ax, patch_props] = parse_args (arg) + + patch_props = {}; + nolvl = false; + + if (isinteger (arg{1}) && ishandle (arg{1}) + && strncmpi (get (arg{1}, "type"), "axis", 4)) + ax = arg{1}; + arg{1} = []; + else + ax = gca (); + endif + + for n = 1:numel (arg) + if (ischar (arg{n})) + patch_props = arg(n:end); + arg(n:end) = []; + break; + endif + endfor + + if (mod (numel (patch_props), 2) != 0) + error ("patch: property value is missing"); + endif + + if (numel (arg) < 3) + Z = arg{1}; + [X, Y] = meshgrid (1:columns (Z), 1:rows (Z)); + endif + + if (numel (arg) == 1) + nolvl = true; + arg(1) = []; + elseif (numel (arg) == 2) + lvl = arg{2}; + arg(1:2) = []; + elseif (numel (arg) == 3) + arg{1:3}; + [X, Y, Z] = deal (arg{1:3}); + arg(1:3) = []; + nolvl = true; + elseif (numel (arg) == 4) + [X, Y, Z, lvl] = deal (arg{1:4}); + arg(1:4) = []; + endif + + if (any (size (X) != size (Y))) + error ("patch: X and Y must be of same size") + endif + + if (isvector (X) || isvector (Y)) + [X, Y] = meshgrid (X, Y); + endif + + Z_no_inf = Z(!isinf (Z)); + [minz, maxz] = deal (min (Z_no_inf(:)), max (Z_no_inf(:))); + Z(isnan (Z)) = -Inf; + + if (nolvl) + lvl = linspace (minz, maxz, 12); + endif + + if (isscalar (lvl)) + lvl = linspace (minz, maxz, lvl + 2)(1:end-1); + else + idx1 = find(lvl < minz); + idx2 = find(lvl > maxz); + lvl(idx1(1:end-1)) = []; + lvl(idx2) = []; + if (isempty (lvl)) + lvl = [minz, minz]; + endif + endif + + endfunction diff -cNr octave-2.9.15/scripts/plot/fill.m octave-2.9.16/scripts/plot/fill.m *** octave-2.9.15/scripts/plot/fill.m Wed Dec 31 19:00:00 1969 --- octave-2.9.16/scripts/plot/fill.m Fri Oct 19 15:05:21 2007 *************** *** 0 **** --- 1,135 ---- + ## Copyright (C) 2007 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 + ## . + + ## -*- texinfo -*- + ## @deftypefn {Function File} {} fill (@var{x}, @var{y}, @var{c}) + ## @deftypefnx {Function File} {} fill (@var{x1}, @var{y1}, @var{c1}, @var{x2}, @var{y2}, @var{c2}) + ## @deftypefnx {Function File} {} fill (@dots{}, @var{prop}, @var{val}) + ## @deftypefnx {Function File} {} fill (@var{h}, @dots{}) + ## @deftypefnx {Function File} {@var{h} = } fill (@dots{}) + ## Create one or more filled patch objects, returning a patch object for each. + ## @end deftypefn + + function h = fill (varargin) + + htmp = []; + + if (isscalar (varargin{1}) && ishandle (varargin{1})) + h = varargin {1}; + if (! strcmp (get (h, "type"), "axes")) + error ("fill: expecting first argument to be an axes object"); + endif + + iargs = __find_patches__ (varargin{:}) + 1; + oldh = gca (); + unwind_protect + axes (h); + + for i = 1 : length (iargs) + if (i == length (iargs)) + args = varargin (iargs(i):end); + else + args = varargin (iargs(i):iargs(i+1)-1); + endif + newplot (); + [tmp, fail] = __patch__ (h, args{:}); + if (fail) + print_usage(); + endif + htmp (end + 1) = tmp; + endfor + unwind_protect_cleanup + axes (oldh); + end_unwind_protect + else + iargs = __find_patches__ (varargin{:}); + for i = 1 : length (iargs) + if (i == length (iargs)) + args = varargin (iargs(i):end); + else + args = varargin (iargs(i):iargs(i+1)-1); + endif + newplot (); + [tmp, fail] = __patch__ (gca (), args{:}); + if (fail) + print_usage(); + endif + htmp (end + 1) = tmp; + endfor + endif + if (nargout > 0) + h = htmp; + endif + endfunction + + function iargs = __find_patches__ (varargin) + iargs = []; + i = 1; + while (i < nargin) + iargs (end + 1) = i; + if (ischar (varargin {i}) && (strcmp (tolower (varargin{i}), "faces") || + strcmp (tolower (varargin{i}), "vertices"))) + i += 4; + elseif (isnumeric (varargin {i})) + i += 2; + endif + + if (i <= nargin) + while (true); + if (ischar (varargin {i}) && + (strcmp (tolower (varargin{i}), "faces") || + strcmp (tolower (varargin{i}), "vertices"))) + break; + elseif (isnumeric (varargin {i})) + ## Assume its the colorspec + i++; + break; + elseif (ischar (varargin {i})) + colspec = tolower (varargin {i}); + collen = length (colspec); + + if (strncmp (colspec, "blue", collen) || + strncmp (colspec, "black", collen) || + strncmp (colspec, "k", collen) || + strncmp (colspec, "black", collen) || + strncmp (colspec, "red", collen) || + strncmp (colspec, "green", collen) || + strncmp (colspec, "yellow", collen) || + strncmp (colspec, "magenta", collen) || + strncmp (colspec, "cyan", collen) || + strncmp (colspec, "white", collen)) + i++; + break; + endif + else + i += 2; + endif + endwhile + endif + endwhile + endfunction + + %!demo + %! close all; + %! t1 = (1/16:1/8:1)'*2*pi; + %! t2 = ((1/16:1/8:1)' + 1/32)*2*pi; + %! x1 = sin(t1) - 0.8; + %! y1 = cos(t1); + %! x2 = sin(t2) + 0.8; + %! y2 = cos(t2); + %! h = fill(x1,y1,'r',x2,y2,'g') diff -cNr octave-2.9.15/scripts/plot/legend.m octave-2.9.16/scripts/plot/legend.m *** octave-2.9.15/scripts/plot/legend.m Fri Oct 12 17:27:24 2007 --- octave-2.9.16/scripts/plot/legend.m Tue Oct 23 19:22:17 2007 *************** *** 98,103 **** --- 98,104 ---- if (nargs > 1) pos = varargin{nargs-1}; + str = varargin{nargs}; if (strcmpi (pos, "location") && ischar (str)) set (ca, "keypos", str); nargs -= 2; diff -cNr octave-2.9.15/scripts/plot/print.m octave-2.9.16/scripts/plot/print.m *** octave-2.9.15/scripts/plot/print.m Fri Oct 12 17:27:24 2007 --- octave-2.9.16/scripts/plot/print.m Fri Oct 19 14:24:19 2007 *************** *** 72,78 **** ## @item emf ## Microsoft Enhanced Metafile ## @item fig ! ## XFig ## @item hpgl ## HP plotter language ## @item mf --- 72,81 ---- ## @item emf ## Microsoft Enhanced Metafile ## @item fig ! ## XFig. If this format is selected the additional options ! ## @code{-textspecial} or @code{-textnormal} can be used to control ! ## whether the special flag should be set for the text in the figure ! ## (default is @code{-textnormal}). ## @item hpgl ## HP plotter language ## @item mf *************** *** 127,132 **** --- 130,140 ---- printer = ""; debug = false; debug_file = "octave-print-commands.log"; + special_flag = "textnormal"; + + ## Ensure the last figure is on the screen for single line commands like + ## plot(...); print(...); + drawnow (); for i = 1:nargin arg = varargin{i}; *************** *** 143,148 **** --- 151,158 ---- orientation = "portrait"; elseif (strcmp (arg, "-landscape")) orientation = "landscape"; + elseif (strcmp (arg, "-textspecial")) + special_flag = "textspecial"; elseif (strncmp (arg, "-debug", 6)) debug = true; if (length (arg) > 7) *************** *** 298,309 **** --- 308,321 ---- else options = " mono"; endif + options = strcat (options, " ", special_flag); if (! isempty (fontsize)) options = strcat (options, " fontsize ", fontsize); endif new_terminal = strcat ("fig ", options); + elseif (strcmp (dev, "emf")) ## Enhanced Metafile format options = " "; diff -cNr octave-2.9.15/scripts/plot/subplot.m octave-2.9.16/scripts/plot/subplot.m *** octave-2.9.15/scripts/plot/subplot.m Fri Oct 12 17:27:24 2007 --- octave-2.9.16/scripts/plot/subplot.m Wed Oct 31 13:12:39 2007 *************** *** 37,44 **** ## \vskip 10pt ## \hfil\vbox{\offinterlineskip\hrule ## \halign{\vrule#&&\qquad\hfil#\hfil\qquad\vrule\cr ! ## height13pt&1&2&3&4\cr height12pt&&&&\cr\noalign{\hrule} ! ## height13pt&5&6&7&8\cr height12pt&&&&\cr\noalign{\hrule}}} ## \hfil ## \vskip 10pt ## @end tex --- 37,44 ---- ## \vskip 10pt ## \hfil\vbox{\offinterlineskip\hrule ## \halign{\vrule#&&\qquad\hfil#\hfil\qquad\vrule\cr ! ## height13pt&1&2&3\cr height12pt&&&&\cr\noalign{\hrule} ! ## height13pt&4&5&6\cr height12pt&&&&\cr\noalign{\hrule}}} ## \hfil ## \vskip 10pt ## @end tex *************** *** 48,58 **** ## @group ## @example ## ! ## +-----+-----+-----+-----+ ! ## | 1 | 2 | 3 | 4 | ! ## +-----+-----+-----+-----+ ! ## | 5 | 6 | 7 | 8 | ! ## +-----+-----+-----+-----+ ## @end example ## @end group ## @end display --- 48,58 ---- ## @group ## @example ## ! ## +-----+-----+-----+ ! ## | 1 | 2 | 3 | ! ## +-----+-----+-----+ ! ## | 4 | 5 | 6 | ! ## +-----+-----+-----+ ## @end example ## @end group ## @end display *************** *** 118,131 **** found = false; for child = get (cf, "children") ! ## Check if this child is still valid; this might not be the case ! ## anymore due to the deletion of previous children (due to DeleteFcn ! ## callback or for legends/colorbars that get deleted with their ! ## corresponding axes) if (! ishandle (child)) continue; endif if (strcmp (get (child, "type"), "axes")) objpos = get (child, "outerposition"); if (objpos == pos) ## If the new axes are in exactly the same position as an --- 118,135 ---- found = false; for child = get (cf, "children") ! ## Check whether this child is still valid; this might not be the ! ## case anymore due to the deletion of previous children (due to ! ## "deletefcn" callback or for legends/colorbars that are deleted ! ## with their corresponding axes). if (! ishandle (child)) continue; endif if (strcmp (get (child, "type"), "axes")) + ## Skip legend objects. + if (strcmp (get (child, "tag"), "legend")) + continue; + endif objpos = get (child, "outerposition"); if (objpos == pos) ## If the new axes are in exactly the same position as an diff -cNr octave-2.9.15/scripts/plot/xlim.m octave-2.9.16/scripts/plot/xlim.m *** octave-2.9.15/scripts/plot/xlim.m Wed Dec 31 19:00:00 1969 --- octave-2.9.16/scripts/plot/xlim.m Tue Oct 23 08:02:17 2007 *************** *** 0 **** --- 1,46 ---- + ## Copyright (C) 2007 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 + ## . + + ## -*- texinfo -*- + ## @deftypefn {Function File} {@var{xl} =} xlim () + ## @deftypefnx {Function File} {} xlim (@var{xl}) + ## @deftypefnx {Function File} {@var{m} =} xlim ('mode') + ## @deftypefnx {Function File} {} xlim (@var{m}) + ## @deftypefnx {Function File} {} xlim (@var{h}, @dots{}) + ## Get or set the limits of the x axis of the current plot. Called without + ## argumenst @code{xlim] returns the x axis limits of the current plot. + ## If passed a two element vector @var{xl}, the limits of the x axis are set + ## to this value. + ## + ## The current mode for calculation of the x axis can be returned with a + ## call @code{xlim ('mode')}, and can be either 'auto' or 'manual'. The + ## current plotting mode can be set by passing either 'auto' or 'manual' + ## as the argument. + ## + ## If passed an handle as the first argument, then operate on this handle + ## rather than the current axes handle. + ## @seealso{ylim, zlim, set, get, gca} + ## @end deftypefn + + function retval = xlim (varargin) + ret = __axes_limits__ ("xlim", varargin {:}); + + if (! isempty (ret)) + retval = ret; + endif + endfunction diff -cNr octave-2.9.15/scripts/plot/ylim.m octave-2.9.16/scripts/plot/ylim.m *** octave-2.9.15/scripts/plot/ylim.m Wed Dec 31 19:00:00 1969 --- octave-2.9.16/scripts/plot/ylim.m Tue Oct 23 08:02:18 2007 *************** *** 0 **** --- 1,46 ---- + ## Copyright (C) 2007 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 + ## . + + ## -*- texinfo -*- + ## @deftypefn {Function File} {@var{xl} =} ylim () + ## @deftypefnx {Function File} {} ylim (@var{xl}) + ## @deftypefnx {Function File} {@var{m} =} ylim ('mode') + ## @deftypefnx {Function File} {} ylim (@var{m}) + ## @deftypefnx {Function File} {} ylim (@var{h}, @dots{}) + ## Get or set the limits of the y axis of the current plot. Called without + ## argumenst @code{ylim] returns the y axis limits of the current plot. + ## If passed a two element vector @var{xl}, the limits of the y axis are set + ## to this value. + ## + ## The current mode for calculation of the y axis can be returned with a + ## call @code{ylim ('mode')}, and can be either 'auto' or 'manual'. The + ## current plotting mode can be set by passing either 'auto' or 'manual' + ## as the argument. + ## + ## If passed an handle as the first argument, then operate on this handle + ## rather than the current axes handle. + ## @seealso{xlim, zlim, set, get, gca} + ## @end deftypefn + + function retval = ylim (varargin) + ret = __axes_limits__ ("ylim", varargin {:}); + + if (! isempty (ret)) + retval = ret; + endif + endfunction diff -cNr octave-2.9.15/scripts/plot/zlim.m octave-2.9.16/scripts/plot/zlim.m *** octave-2.9.15/scripts/plot/zlim.m Wed Dec 31 19:00:00 1969 --- octave-2.9.16/scripts/plot/zlim.m Tue Oct 23 08:02:18 2007 *************** *** 0 **** --- 1,46 ---- + ## Copyright (C) 2007 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 + ## . + + ## -*- texinfo -*- + ## @deftypefn {Function File} {@var{xl} =} zlim () + ## @deftypefnx {Function File} {} zlim (@var{xl}) + ## @deftypefnx {Function File} {@var{m} =} zlim ('mode') + ## @deftypefnx {Function File} {} zlim (@var{m}) + ## @deftypefnx {Function File} {} zlim (@var{h}, @dots{}) + ## Get or set the limits of the z axis of the current plot. Called without + ## argumenst @code{zlim] returns the z axis limits of the current plot. + ## If passed a two element vector @var{xl}, the limits of the z axis are set + ## to this value. + ## + ## The current mode for calculation of the z axis can be returned with a + ## call @code{zlim ('mode')}, and can be either 'auto' or 'manual'. The + ## current plotting mode can be set by passing either 'auto' or 'manual' + ## as the argument. + ## + ## If passed an handle as the first argument, then operate on this handle + ## rather than the current axes handle. + ## @seealso{xlim, ylim, set, get, gca} + ## @end deftypefn + + function retval = zlim (varargin) + ret = __axes_limits__ ("zlim", varargin {:}); + + if (! isempty (ret)) + retval = ret; + endif + endfunction diff -cNr octave-2.9.15/scripts/polynomial/polygcd.m octave-2.9.16/scripts/polynomial/polygcd.m *** octave-2.9.15/scripts/polynomial/polygcd.m Fri Oct 12 17:27:25 2007 --- octave-2.9.16/scripts/polynomial/polygcd.m Mon Oct 15 11:30:04 2007 *************** *** 33,39 **** ## @example ## polygcd (poly(1:8), poly(3:12)) - poly(3:8) ## @result{} [ 0, 0, 0, 0, 0, 0, 0 ] ! ## deconv (poly(1:8), polygcd (poly(1:8), poly(3:12))) - poly(1:2) ## @result{} [ 0, 0, 0 ] ## @end example ## @seealso{poly, polyinteg, polyderiv, polyreduce, roots, conv, deconv, --- 33,40 ---- ## @example ## polygcd (poly(1:8), poly(3:12)) - poly(3:8) ## @result{} [ 0, 0, 0, 0, 0, 0, 0 ] ! ## deconv (poly(1:8), polygcd (poly(1:8), poly(3:12))) ... ! ## - poly(1:2) ## @result{} [ 0, 0, 0 ] ## @end example ## @seealso{poly, polyinteg, polyderiv, polyreduce, roots, conv, deconv, diff -cNr octave-2.9.15/scripts/set/ismember.m octave-2.9.16/scripts/set/ismember.m *** octave-2.9.15/scripts/set/ismember.m Fri Oct 12 17:27:25 2007 --- octave-2.9.16/scripts/set/ismember.m Mon Oct 29 15:12:28 2007 *************** *** 119,130 **** --- 119,134 ---- %!assert (ismember ({''}, {'abc', 'def'}), false); %!assert (ismember ('abc', {'abc', 'def'}), true); %!assert (isempty (ismember ([], [1, 2])), true); + %!assert (isempty (ismember ({}, {'a', 'b'})), true); %!xtest assert (ismember ('', {'abc', 'def'}), false); %!xtest fail ('ismember ([], {1, 2})', 'error:.*'); %!fail ('ismember ({[]}, {1, 2})', 'error:.*'); + %!xtest fail ('ismember ({}, {1, 2})', 'error:.*'); %!assert (ismember ({'foo', 'bar'}, {'foobar'}), logical ([0, 0])) %!assert (ismember ({'foo'}, {'foobar'}), false) %!assert (ismember ({'bar'}, {'foobar'}), false) %!assert (ismember ({'bar'}, {'foobar', 'bar'}), true) %!assert (ismember ({'foo', 'bar'}, {'foobar', 'bar'}), logical ([0, 1])) %!assert (ismember ({'xfb', 'f', 'b'}, {'fb', 'b'}), logical ([0, 0, 1])) + %!assert (ismember ("1", "0123456789."), true) + %!assert (ismember ("1.1", "0123456789."), logical ([1, 1, 1])) diff -cNr octave-2.9.15/scripts/signal/arch_rnd.m octave-2.9.16/scripts/signal/arch_rnd.m *** octave-2.9.15/scripts/signal/arch_rnd.m Fri Oct 12 17:27:25 2007 --- octave-2.9.16/scripts/signal/arch_rnd.m Mon Oct 15 11:30:04 2007 *************** *** 23,39 **** ## coefficients @var{b} and CH coefficients @var{a}. I.e., the result ## @math{y(t)} follows the model ## ! ## @example ## y(t) = b(1) + b(2) * y(t-1) + @dots{} + b(lb) * y(t-lb+1) + e(t), ! ## @end example ## ## @noindent ## where @math{e(t)}, given @var{y} up to time @math{t-1}, is ## @math{N(0, h(t))}, with ## ! ## @example ## h(t) = a(1) + a(2) * e(t-1)^2 + @dots{} + a(la) * e(t-la+1)^2 ! ## @end example ## @end deftypefn ## Author: KH --- 23,39 ---- ## coefficients @var{b} and CH coefficients @var{a}. I.e., the result ## @math{y(t)} follows the model ## ! ## @smallexample ## y(t) = b(1) + b(2) * y(t-1) + @dots{} + b(lb) * y(t-lb+1) + e(t), ! ## @end smallexample ## ## @noindent ## where @math{e(t)}, given @var{y} up to time @math{t-1}, is ## @math{N(0, h(t))}, with ## ! ## @smallexample ## h(t) = a(1) + a(2) * e(t-1)^2 + @dots{} + a(la) * e(t-la+1)^2 ! ## @end smallexample ## @end deftypefn ## Author: KH diff -cNr octave-2.9.15/scripts/sparse/pcg.m octave-2.9.16/scripts/sparse/pcg.m *** octave-2.9.15/scripts/sparse/pcg.m Fri Oct 12 17:27:26 2007 --- octave-2.9.16/scripts/sparse/pcg.m Mon Oct 15 11:30:04 2007 *************** *** 174,180 **** ## y(1:K) = x(1:K)./[1:K]'; ## endfunction ## ! ## [x, flag, relres, iter, resvec, eigest] = pcg (A, b, [], [], "applyM"); ## semilogy (1:iter+1, resvec); ## @end group ## @end example --- 174,181 ---- ## y(1:K) = x(1:K)./[1:K]'; ## endfunction ## ! ## [x, flag, relres, iter, resvec, eigest] = ... ! ## pcg (A, b, [], [], "applyM"); ## semilogy (1:iter+1, resvec); ## @end group ## @end example diff -cNr octave-2.9.15/scripts/sparse/pcr.m octave-2.9.16/scripts/sparse/pcr.m *** octave-2.9.15/scripts/sparse/pcr.m Fri Oct 12 17:27:26 2007 --- octave-2.9.16/scripts/sparse/pcr.m Mon Oct 15 11:30:04 2007 *************** *** 137,143 **** ## y(1:K) = x(1:K)./[1:K]'; ## endfunction ## ! ## [x, flag, relres, iter, resvec] = pcr(A,b,[],[],'applyM') ## semilogy([1:iter+1], resvec); ## @end group ## @end example --- 137,144 ---- ## y(1:K) = x(1:K)./[1:K]'; ## endfunction ## ! ## [x, flag, relres, iter, resvec] = ... ! ## pcr(A, b, [], [], 'applyM') ## semilogy([1:iter+1], resvec); ## @end group ## @end example *************** *** 152,158 **** ## y = x; y(1:K) = x(1:K)./[1:K]'; ## endfunction ## ! ## [x, flag, relres, iter, resvec] = pcr(A,b,[],[],'applyM',[],3) ## @end group ## @end example ## --- 153,160 ---- ## y = x; y(1:K) = x(1:K)./[1:K]'; ## endfunction ## ! ## [x, flag, relres, iter, resvec] = ... ! ## pcr(A, b, [], [], 'applyM', [], 3) ## @end group ## @end example ## diff -cNr octave-2.9.15/scripts/startup/main-rcfile octave-2.9.16/scripts/startup/main-rcfile *** octave-2.9.15/scripts/startup/main-rcfile Tue Nov 7 15:52:18 2006 --- octave-2.9.16/scripts/startup/main-rcfile Fri Oct 26 12:09:12 2007 *************** *** 13,15 **** --- 13,20 ---- if (strcmp (PAGER (), "less") && isempty (getenv ("LESS"))) PAGER_FLAGS ('-e -X -P"-- less ?pB(%pB\\%):--. (f)orward, (b)ack, (q)uit$"'); endif + + ## This appears here instead of in the pkg/PKG_ADD file so that --norc + ## will also skip automatic loading of packages. + + pkg ("load", "auto"); diff -cNr octave-2.9.15/scripts/statistics/distributions/frnd.m octave-2.9.16/scripts/statistics/distributions/frnd.m *** octave-2.9.15/scripts/statistics/distributions/frnd.m Fri Oct 12 17:27:27 2007 --- octave-2.9.16/scripts/statistics/distributions/frnd.m Mon Oct 15 12:31:55 2007 *************** *** 78,93 **** if (isscalar (m) && isscalar (n)) ! if ((m > 0) && (m < Inf) && (n > 0) && (n < Inf)) ! rnd = n ./ m .* randg(m/2,sz) ./ randg(n/2,sz); else rnd = NaN * ones (sz); endif else rnd = zeros (sz); ! k = find (!(m > 0) | !(m < Inf) | ! !(n > 0) | !(n < Inf)); if (any (k)) rnd(k) = NaN; endif --- 78,110 ---- if (isscalar (m) && isscalar (n)) ! if (isinf (m) || isinf (n)) ! if (isinf (m)) ! rnd = ones (sz); ! else ! rnd = 2 ./ m .* randg(m / 2, sz); ! endif ! if (! isinf (n)) ! rnd = 0.5 .* n .* rnd ./ randg (n / 2, sz); ! endif ! elseif ((m > 0) && (m < Inf) && (n > 0) && (n < Inf)) ! rnd = n ./ m .* randg (m / 2, sz) ./ randg (n / 2, sz); else rnd = NaN * ones (sz); endif else rnd = zeros (sz); ! k = find (isinf(m) | isinf(n)); ! if (any (k)) ! rnd (k) = 1; ! k2 = find (!isinf(m) & isinf(n)); ! rnd (k2) = 2 ./ m(k2) .* randg (m(k2) ./ 2, size(k2)); ! k2 = find (isinf(m) & !isinf(n)); ! rnd (k2) = 0.5 .* n(k2) .* rnd(k2) ./ randg (n(k2) ./ 2, size(k2)); ! endif ! ! k = find (!(m > 0) | !(n > 0)); if (any (k)) rnd(k) = NaN; endif diff -cNr octave-2.9.15/scripts/statistics/models/logistic_regression.m octave-2.9.16/scripts/statistics/models/logistic_regression.m *** octave-2.9.15/scripts/statistics/models/logistic_regression.m Fri Oct 12 17:27:28 2007 --- octave-2.9.16/scripts/statistics/models/logistic_regression.m Mon Oct 15 11:30:04 2007 *************** *** 34,40 **** ## fits the model ## ## @example ! ## logit (gamma_i (x)) = theta_i - beta' * x, i = 1, ..., k-1 ## @end example ## ## The number of ordinal categories, @var{k}, is taken to be the number --- 34,40 ---- ## fits the model ## ## @example ! ## logit (gamma_i (x)) = theta_i - beta' * x, i = 1...k-1 ## @end example ## ## The number of ordinal categories, @var{k}, is taken to be the number diff -cNr octave-2.9.15/scripts/strings/str2double.m octave-2.9.16/scripts/strings/str2double.m *** octave-2.9.15/scripts/strings/str2double.m Fri Oct 12 17:27:28 2007 --- octave-2.9.16/scripts/strings/str2double.m Mon Oct 15 11:30:04 2007 *************** *** 67,78 **** ## 3.1400 4.4440 0.7000 ## -10.0000 NaN NaN ## ! ## line = "200,300,400,NaN,-inf,cd,yes,no,999,maybe,NaN"; ## [x, status] = str2double (line) ! ## x = ! ## 200 300 400 NaN -Inf NaN NaN NaN 999 NaN NaN ! ## status = ! ## 0 0 0 0 0 -1 -1 -1 0 -1 0 ## @end example ## @end deftypefn --- 67,78 ---- ## 3.1400 4.4440 0.7000 ## -10.0000 NaN NaN ## ! ## line = "200, 300, NaN, -inf, yes, no, 999, maybe, NaN"; ## [x, status] = str2double (line) ! ## @result{} x = ! ## 200 300 NaN -Inf NaN NaN 999 NaN NaN ! ## @result{} status = ! ## 0 0 0 0 -1 -1 0 -1 0 ## @end example ## @end deftypefn diff -cNr octave-2.9.15/scripts/testfun/assert.m octave-2.9.16/scripts/testfun/assert.m *** octave-2.9.15/scripts/testfun/assert.m Fri Oct 12 17:27:29 2007 --- octave-2.9.16/scripts/testfun/assert.m Mon Oct 15 04:22:54 2007 *************** *** 35,44 **** ## lists or structures. ## ## @item assert(@var{observed}, @var{expected}, @var{tol}) ! ## Produce an error if relative error is less than tolerance. That is, ! ## @code{abs(@var{observed} - @var{expected}) > @var{tol} * @var{expected}}. ! ## Absolute error @code{abs(@var{observed} - @var{expected}) > abs(@var{tol})} ! ## will be used when tolerance is negative or when the expected value is zero. ## @end table ## @seealso{test} ## @end deftypefn --- 35,46 ---- ## lists or structures. ## ## @item assert(@var{observed}, @var{expected}, @var{tol}) ! ## Accept a tolerance when comparing numbers. ! ## If @var{tol} is possitive use it as an absolute tolerance, will produce an error if ! ## @code{abs(@var{observed} - @var{expected}) > abs(@var{tol})}. ! ## If @var{tol} is negative use it as a relative tolerance, will produce an error if ! ## @code{abs(@var{observed} - @var{expected}) > abs(@var{tol} * @var{expected})}. ! ## If @var{expected} is zero @var{tol} will always be used as an absolute tolerance. ## @end table ## @seealso{test} ## @end deftypefn *************** *** 249,255 **** %!error assert(3+2*eps, 3, eps); %!error assert(3, 3+2*eps, eps); ! %## must give a little space for floating point errors on relative %!assert(100+100*eps, 100, -2*eps); %!assert(100, 100+100*eps, -2*eps); %!error assert(100+300*eps, 100, -2*eps); --- 251,257 ---- %!error assert(3+2*eps, 3, eps); %!error assert(3, 3+2*eps, eps); ! ## must give a little space for floating point errors on relative %!assert(100+100*eps, 100, -2*eps); %!assert(100, 100+100*eps, -2*eps); %!error assert(100+300*eps, 100, -2*eps); *************** *** 257,262 **** --- 259,270 ---- %!error assert(3, [3,3]); %!error assert(3,4); + ## test relative vs. absolute tolerances + %!test assert (0.1+eps, 0.1, 2*eps); # accept absolute + %!error assert (0.1+eps, 0.1, -2*eps); # fail relative + %!test assert (100+100*eps, 100, -2*eps); # accept relative + %!error assert (100+100*eps, 100, 2*eps); # fail absolute + ## structures %!shared x,y %! x.a = 1; x.b=[2, 2]; diff -cNr octave-2.9.15/scripts/testfun/test.m octave-2.9.16/scripts/testfun/test.m *** octave-2.9.15/scripts/testfun/test.m Fri Oct 12 17:27:29 2007 --- octave-2.9.16/scripts/testfun/test.m Mon Oct 15 05:00:02 2007 *************** *** 381,401 **** warning ("on", "quiet"); try eval (sprintf ("__test__(%s);", __shared)); - __err = trimerr (lastwarn, "warning"); - warning (__warnstate.state, "quiet"); - if (! __warning) __msg = sprintf ("%sexpected <%s> but got no error\n", __signal_fail, __pattern); ! elseif (isempty (__err)) ! __msg = sprintf ("%sexpected <%s> but got no warning\n", __signal_fail, __pattern); ! elseif (isempty (regexp (__err, __pattern, "once"))) ! __msg = sprintf ("%sexpected <%s> but got %s\n", ! __signal_fail, __pattern, __err); ! else ! __success = 1; ! endif catch __err = trimerr (lasterr, "error"); --- 381,402 ---- warning ("on", "quiet"); try eval (sprintf ("__test__(%s);", __shared)); if (! __warning) __msg = sprintf ("%sexpected <%s> but got no error\n", __signal_fail, __pattern); ! else ! __err = trimerr (lastwarn, "warning"); ! warning (__warnstate.state, "quiet"); ! if (isempty (__err)) ! __msg = sprintf ("%sexpected <%s> but got no warning\n", __signal_fail, __pattern); ! elseif (isempty (regexp (__err, __pattern, "once"))) ! __msg = sprintf ("%sexpected <%s> but got %s\n", ! __signal_fail, __pattern, __err); ! else ! __success = 1; ! endif ! endif catch __err = trimerr (lasterr, "error"); diff -cNr octave-2.9.15/scripts/time/Makefile.in octave-2.9.16/scripts/time/Makefile.in *** octave-2.9.15/scripts/time/Makefile.in Fri Oct 12 17:27:29 2007 --- octave-2.9.16/scripts/time/Makefile.in Mon Oct 22 07:52:39 2007 *************** *** 34,40 **** SOURCES = asctime.m calendar.m clock.m ctime.m date.m datenum.m \ datestr.m datevec.m eomday.m etime.m is_leap_year.m now.m \ ! tic.m toc.m weekday.m DISTFILES = $(addprefix $(srcdir)/, Makefile.in $(SOURCES)) --- 34,40 ---- SOURCES = asctime.m calendar.m clock.m ctime.m date.m datenum.m \ datestr.m datevec.m eomday.m etime.m is_leap_year.m now.m \ ! weekday.m DISTFILES = $(addprefix $(srcdir)/, Makefile.in $(SOURCES)) diff -cNr octave-2.9.15/scripts/time/tic.m octave-2.9.16/scripts/time/tic.m *** octave-2.9.15/scripts/time/tic.m Fri Oct 12 17:27:29 2007 --- octave-2.9.16/scripts/time/tic.m Wed Dec 31 19:00:00 1969 *************** *** 1,85 **** - ## Copyright (C) 1996, 1997, 2006, 2007 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 - ## . - - ## -*- texinfo -*- - ## @deftypefn {Function File} {} tic () - ## @deftypefnx {Function File} {} toc () - ## Set or check a wall-clock timer. Calling @code{tic} without an - ## output argument sets the timer. Subsequent calls to @code{toc} - ## return the number of seconds since the timer was set. For example, - ## - ## @example - ## tic (); - ## # many computations later... - ## elapsed_time = toc (); - ## @end example - ## - ## @noindent - ## will set the variable @code{elapsed_time} to the number of seconds since - ## the most recent call to the function @code{tic}. - ## - ## If called with one output argument then this function returns a scalar - ## of type @code{uint64} and the wall-clock timer is not started. - ## - ## @example - ## @group - ## t = tic; sleep (5); (double (tic ()) - double (t)) * 1e-6 - ## @result{} 5 - ## @end group - ## @end example - ## - ## Nested timing with @code{tic} and @code{toc} is not supported. - ## Therefore @code{toc} will always return the elapsed time from the most - ## recent call to @code{tic}. - ## - ## If you are more interested in the CPU time that your process used, you - ## should use the @code{cputime} function instead. The @code{tic} and - ## @code{toc} functions report the actual wall clock time that elapsed - ## between the calls. This may include time spent processing other jobs or - ## doing nothing at all. For example, - ## - ## @example - ## @group - ## tic (); sleep (5); toc () - ## @result{} 5 - ## t = cputime (); sleep (5); cputime () - t - ## @result{} 0 - ## @end group - ## @end example - ## - ## @noindent - ## (This example also illustrates that the CPU timer may have a fairly - ## coarse resolution.) - ## @end deftypefn - - ## Author: jwe - - function ret = tic () - - if (nargin != 0) - warning ("tic: ignoring extra arguments"); - endif - - if (nargout == 1) - ret = uint64 (time () * 1e6); - else - global __tic_toc_timestamp__; - __tic_toc_timestamp__ = clock (); - endif - - endfunction --- 0 ---- diff -cNr octave-2.9.15/scripts/time/toc.m octave-2.9.16/scripts/time/toc.m *** octave-2.9.15/scripts/time/toc.m Fri Oct 12 17:27:29 2007 --- octave-2.9.16/scripts/time/toc.m Wed Dec 31 19:00:00 1969 *************** *** 1,46 **** - ## Copyright (C) 1996, 1997, 2006, 2007 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 - ## . - - ## -*- texinfo -*- - ## @deftypefn {Function File} {} toc () - ## See tic. - ## @end deftypefn - - ## Author: jwe - - function secs = toc () - - if (nargin != 0) - warning ("toc: ignoring extra arguments"); - endif - - global __tic_toc_timestamp__ = -1; - - if (__tic_toc_timestamp__ < 0) - warning ("toc called before timer set"); - secs0 = []; - else - secs0 = etime (clock (), __tic_toc_timestamp__); - if (nargout != 0) - secs = secs0; - else - printf ("Elapsed time is %f seconds.\n", secs0); - endif - endif - - endfunction --- 0 ---- diff -cNr octave-2.9.15/src/ChangeLog octave-2.9.16/src/ChangeLog *** octave-2.9.15/src/ChangeLog Sat Oct 13 10:34:06 2007 --- octave-2.9.16/src/ChangeLog Wed Oct 31 17:29:24 2007 *************** *** 1,4 **** ! 2007-09-17 John W. Eaton * version.h (OCTAVE_VERSION): Now 2.9.15. (OCTAVE_API_VERSION): Now api-v27. --- 1,201 ---- ! 2007-10-31 John W. Eaton ! ! * version.h (OCTAVE_VERSION): Now 2.9.16. ! (OCTAVE_API_VERSION): Now api-v28. ! (OCTAVE_RELEASE_DATE): Now 2007-10-31. ! ! 2007-10-31 Muthiah Annamalai ! ! * pt-assign.h (tree_simple_assignment::op_type, ! tree_multi_assignment::op_type): New functions. ! * pt-unop.h (tree_unary_expression::op_type): New function. ! ! 2007-10-31 John W. Eaton ! ! * graphics.cc (line::properties::get): Fix property name ! (markerface -> markerfacecolor). ! ! * Makefile.in (INCLUDES): Add debug.h to the list. ! ! 2007-10-30 John Swensen ! ! * debug.h: New file. ! * debug.cc (parse_dbfunction_params, do_find_bkpt_list, ! intmap_to_ov): New functions. ! (Fdbstop, Fdbclear): Use parse_dbfunction_params. ! Improve compatibility. ! (Fdbstatus): Improve compatibility. ! ! * help.cc (do_which): No longer static. ! * help.h: Provide decl. ! ! 2007-10-30 David Bateman ! ! * symtab.cc: Doc fixes for small book format. ! ! 2007-10-30 John W. Eaton ! ! * file-io.cc (fopen_mode_to_ios_mode): Handle 'W' as 'w' and 'R' ! as 'r', but warn about them. ! ! 2007-10-29 Thomas Treichl ! ! * data.cc: Include sytime.h, sys/types.h, and sys/resource.h. ! ! 2007-10-25 John W. Eaton ! ! * graphics.cc (figure::properties::set_currentaxes): ! Allow currentfigure to be NaN. ! ! 2007-10-25 Michael Goffioul ! ! * DLD-FUNCTIONS/__contourc__.cc: Use unsigned int instead of uint. ! (drawcn): Use 1 << k instead of pow (2, k). ! ! 2007-10-25 John W. Eaton ! ! * symtab.h (symbol_record::TYPE): Delete trailing comma in enum decl. ! ! * ov-base.h (DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA): Use ! OCTAVE_EMPTY_CPP_ARG to avoid annoying Sun compiler warning. ! ! * Makefile.in (graphics.h): Use $(AWK) instead of awk. ! ! * DLD-FUNCTIONS/time.cc (Ftime, Fmktime): Avoid unnecessary cast. ! ! * data.cc (Ftic, Ftoc): Call double_value on octave_time objects ! instead of relying on conversion operator. ! * ov.cc (octave_value::octave_value (octave_time)): Likewise. ! ! * variables.cc (symbol_out_of_date): Use explicit conversion to ! time_t instead of relying on conversion operator. ! * ov-fcn-handle.cc (octave_fcn_handle::subsref): Likewise. ! ! * data.cc (tic_toc_timestamp): Rename from __tic_toc_timestamp__. ! Change all uses. ! ! 2007-10-24 David Bateman ! ! * ov-intx.h (OCTAVE_VALUE_INT_MATRIX_T::OCTAVE_VALUE_INT_MATRIX_T ! (const ArrayN&)): New constructor. ! * ov.cc (octave_value::octave_value(const ArrayN) with T being ! octave_int8, octave_uint8, octave_int16, octave_uint16, ! octave_int32, octave_uint32, octave_int64, octave_uint64): New ! constructors. ! * ov.h (octave_value::octave_value(const ArrayN) with T being ! octave_int8, octave_uint8, octave_int16, octave_uint16, ! octave_int32, octave_uint32, octave_int64, octave_uint64): ! Declare them. ! * DLD-FUNCTIONS/sort.cc (template class octave_sort, ! template class vec_index, template class ! octave_sort *>, with T being ! octave_int8, octave_uint8, octave_int16, octave_uint16, ! octave_int32, octave_uint32, octave_int64, octave_uint64): New ! instantiations of sort template classes. ! (Fsort): Use them. ! ! 2007-10-24 John W. Eaton ! ! * graphics.cc (root_figure::properties::set_currentfigure): ! Allow currentfigure to be NaN. ! ! * pt-idx.cc (tree_index_expression::lvalue): Correctly compute ! number of elements in lvalue expression when last indexing ! element is ".". ! ! 2007-10-23 John W. Eaton ! ! * graphics.cc (is_handle (const graphics_handle&)): New function. ! (gh_manager::do_free, reparent, base_properties::set_parent, ! properties::get_title, properties::get_xlabel, ! properties::get_ylabel, properties::get_zlabel, ! properties::remove_child, make_graphics_object, F__go_figure__, ! F__go_delete__, __go_axes_init__): Call OK on graphics handle ! object instead of relying on implicit conversion operator. ! * graphics.h.in (graphics_handle::operator double ()): Delete. ! (graphics_handle::operator bool ()): Delete. ! (gh_manager::do_handle_list, gh_manager::do_figure_handle_list, ! base_properties::adopt): Call VALUE on graphics handle object ! instead of relying on implicit conversion operator. ! ! * ov-base.h (DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA): Call ! DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA2 with "( )" as arg list ! instead of "()". ! ! * mxarray.h.in (mxClassID): Delete trailing comma in enum decl. ! ! * symtab.h (symbol_table::symbol_table): Reduce default table size ! to 64. ! ! 2007-10-22 Kim Hansen ! ! * unwind-prot.cc: Include . ! ! 2007-10-22 David Bateman ! ! * data.cc (Ftic, Ftoc, Fcputime): New builtin versions of the ! benchmarking functions for speed. ! * oct-map.cc (Octave_map::squeeze, Octave_map::permute): New methods. ! (Octave_map::index (const octave_value_list&, bool)): Add resize_ok ! argument, define as const and use const_iterator internally. ! (Octave_map::index (idx_vector&, ...), Octave_map::index (Array ! &, ...)): New forms of the index function. ! * oct-map.h (squeeze, permute, indx (const octave_value_list&, bool), ! index (idx_vector&, ...), index (Array &, ...)): Add ! or update declaration. ! * ov-struct.cc (octave_struct::do_index_op (const octave_value_list&, ! bool)): New method. ! * ov-struct.h (do_index_op (const octave_value_list&, bool)): Declare ! it. ! (squeeze (void), permute (const Arra&, bool): New methods. ! ! 2007-10-19 Kai Habel ! ! * DLD-FUNCTIONS/__contourc__.cc (add_point): Rename from ! cl_add_point. Change all uses. ! (end_contour): Rename from cl_end_contour. Change all uses. ! (start_contour): Rename from cl_start_contour. Change all uses. ! (drawcn): Rename from cl_drawcn. New algorithm for locating contours. ! (mark_facets): New function. ! (cntr): Rename from cl_cntr. Change all uses. New algorithm for ! locating contours. ! ! 2007-10-19 John W. Eaton ! ! * ov-cell.cc (octave_cell::subsasgn): If RHS is cs-list, don't ! fail if shape of LHS is different. ! * ov-struct.cc (octave_struct::subsasgn): Likewise. ! ! 2007-10-19 Olli Saarela ! ! * help.cc (Flookfor): Call print_usage instead of usage. ! * DLD-FUNCTIONS/cellfun.cc (Fmat2cell): Likewise. ! ! 2007-10-17 John W. Eaton ! ! * DLD-FUNCTIONS/spchol.cc (Fsymbfact): Delete special code for METIS. ! ! 2007-10-17 Gabriele Pannocchia ! ! * DLD-FUNCTIONS/__qp__.cc (qp): Fix check for Wact(j). ! ! 2007-10-15 Søren Hauberg ! ! * error.cc (Ferror): Make text fit on pages when using smallbook. ! * load-save.cc (Fsave_header_format_string): Ditto. ! * ov-struct.cc (Fcell2struct): Ditto. ! * DLD-FUNCTIONS/besselj.cc (Fairy): Ditto. ! * DLD-FUNCTIONS/urlwrite.cc (Furlwrite, Furlread): Ditto. ! ! 2007-10-15 David Bateman ! ! * graphics.cc (axes::properties::get): Fix typo. ! ! 2007-10-13 John W. Eaton ! ! * version.h (OCTAVE_VERSION): Now 2.9.15+. ! ! 2007-10-13 John W. Eaton * version.h (OCTAVE_VERSION): Now 2.9.15. (OCTAVE_API_VERSION): Now api-v27. diff -cNr octave-2.9.15/src/DASRT-opts.cc octave-2.9.16/src/DASRT-opts.cc *** octave-2.9.15/src/DASRT-opts.cc Sat Oct 13 10:49:37 2007 --- octave-2.9.16/src/DASRT-opts.cc Wed Oct 31 17:44:19 2007 *************** *** 318,324 **** \n\ The local error test applied at each integration step is\n\ @example\n\ ! abs (local error in x(i)) <= rtol(i) * abs (Y(i)) + atol(i)\n\ @end example\n\ @item \"initial step size\"\n\ Differential-algebraic problems may occasionally suffer from severe\n\ --- 318,325 ---- \n\ The local error test applied at each integration step is\n\ @example\n\ ! abs (local error in x(i)) <= ...\n\ ! rtol(i) * abs (Y(i)) + atol(i)\n\ @end example\n\ @item \"initial step size\"\n\ Differential-algebraic problems may occasionally suffer from severe\n\ diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/__contourc__.cc octave-2.9.16/src/DLD-FUNCTIONS/__contourc__.cc *** octave-2.9.15/src/DLD-FUNCTIONS/__contourc__.cc Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/__contourc__.cc Thu Oct 25 16:41:17 2007 *************** *** 1,5 **** --- 1,6 ---- /* Contour lines for function evaluated on a grid. + Copyright (C) 2007 Kai Habel Copyright (C) 2004, 2007 Shai Ayal Adapted to an oct file from the stand alone contourl by Victro Munoz *************** *** 35,40 **** --- 36,43 ---- #include #endif + #include + #include "quit.h" #include "defun-dld.h" *************** *** 45,59 **** static Matrix contourc; static int elem; ! // this is the quanta in which we increase this_contour #define CONTOUR_QUANT 50 ! // cl_add_point(x,y); ! // ! // Add a coordinate point (x,y) to this_contour static void ! cl_add_point (double x, double y) { if (elem % CONTOUR_QUANT == 0) this_contour = this_contour.append (Matrix (2, CONTOUR_QUANT, 0)); --- 48,60 ---- 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)); *************** *** 63,299 **** elem++; } ! // cl_end_contour(); ! // ! // Adds contents of current contour to contourc. // this_contour.cols () - 1; static void ! cl_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; } ! // cl_start_contour(flev,x,y); ! // ! // Start a new contour, and adds contents of current one to contourc static void ! cl_start_contour (double flev, double x, double y) { ! cl_end_contour (); this_contour.resize (2, 0); ! cl_add_point (flev, flev); ! cl_add_point (x, y); } static void ! cl_drawcn (RowVector & X, RowVector & Y, Matrix & Z, double flev, ! int krow, int kcol, double lastx, double lasty, int startedge, ! Matrix & ipts) { ! int kx = 0, lx = Z.cols () - 1, ky = 0, ly = Z.rows () - 1; ! ! double f[4]; ! double px[4], py[4], locx[4], locy[4]; ! int iedge[4]; ! int num, first, inext, kcolnext, krownext; ! ! px[0] = X (krow + 1); ! px[1] = X (krow); ! px[2] = X (krow); ! px[3] = X (krow + 1); ! py[0] = Y (kcol); ! py[1] = Y (kcol); ! py[2] = Y (kcol + 1); ! py[3] = Y (kcol + 1); ! ! f[0] = Z (krow + 1, kcol) - flev; ! f[1] = Z (krow, kcol) - flev; ! f[2] = Z (krow, kcol + 1) - flev; ! f[3] = Z (krow + 1, kcol + 1) - flev; ! for (int i = 0, j = 1; i < 4; i++, j = (j + 1) % 4) { ! iedge[i] = (f[i] * f[j] > 0.0) ? -1 : ((f[i] * f[j] < 0.0) ? 1 : 0); } ! // Mark this square as done ! ipts(krow,kcol) = 1; ! ! // Check if no contour has been crossed i.e. iedge[i] = -1 ! if (iedge[0] == -1 && iedge[1] == -1 && iedge[2] == -1 && iedge[3] == -1) return; ! // Check if this is a completely flat square - in which case ignore it ! if (f[0] == 0.0 && f[1] == 0.0 && f[2] == 0.0 && f[3] == 0.0) ! return; ! // Calculate intersection points ! num = 0; ! if (startedge < 0) { ! first = 1; } ! else { ! locx[num] = lastx; ! locy[num] = lasty; ! num++; ! first = 0; } ! for (int k = 0, i = (startedge < 0 ? 0 : startedge); k < 4; ! k++, i = (i + 1) % 4) { ! if (i == startedge) ! continue; ! // If the contour is an edge check it hasn't already been done ! if (f[i] == 0.0 && f[(i + 1) % 4] == 0.0) ! { ! kcolnext = kcol; ! krownext = krow; ! if (i == 0) ! kcolnext--; ! if (i == 1) ! krownext--; ! if (i == 2) ! kcolnext++; ! if (i == 3) ! krownext++; ! if (kcolnext < kx || kcolnext >= lx || krownext < ky ! || krownext >= ly || ipts(krownext,kcolnext) == 1) ! continue; ! } ! if (iedge[i] == 1 || f[i] == 0.0) ! { ! int j = (i + 1) % 4; ! if (f[i] != 0.0) ! { ! locx[num] = ! (px[i] * fabs (f[j]) + px[j] * fabs (f[i])) / fabs (f[j] - ! f[i]); ! locy[num] = ! (py[i] * fabs (f[j]) + py[j] * fabs (f[i])) / fabs (f[j] - ! f[i]); ! } ! else ! { ! locx[num] = px[i]; ! locy[num] = py[i]; ! } ! // If this is the start of the contour then move to the point ! if (first == 1) ! { ! cl_start_contour (flev, locx[num], locy[num]); ! first = 0; ! } ! else ! { ! // Link to the next point on the contour ! cl_add_point (locx[num], locy[num]); ! // Need to follow contour into next grid box ! // Easy case where contour does not pass through corner ! if (f[i] != 0.0) ! { ! kcolnext = kcol; ! krownext = krow; ! inext = (i + 2) % 4; ! if (i == 0) ! kcolnext--; ! if (i == 1) ! krownext--; ! if (i == 2) ! kcolnext++; ! if (i == 3) ! krownext++; ! if (kcolnext >= kx && kcolnext < lx ! && krownext >= ky && krownext < ly ! && ipts(krownext,kcolnext) == 0) ! { ! cl_drawcn (X, Y, Z, flev, krownext, kcolnext, ! locx[num], locy[num], inext, ipts); ! } ! } ! // Hard case where contour passes through corner. This ! // is still not perfect - it may lose the contour which ! // won't upset the contour itself (we can find it again ! // later) but might upset the labelling (which is only ! // relevant for the PLPlot implementation, since we ! // don't worry about labels---for now!) ! else ! { ! kcolnext = kcol; ! krownext = krow; ! inext = (i + 2) % 4; ! if (i == 0) ! { ! kcolnext--; ! krownext++; ! } ! if (i == 1) ! { ! krownext--; ! kcolnext--; ! } ! if (i == 2) ! { ! kcolnext++; ! krownext--; ! } ! if (i == 3) ! { ! krownext++; ! kcolnext++; ! } ! if (kcolnext >= kx && kcolnext < lx ! && krownext >= ky && krownext < ly ! && ipts(krownext,kcolnext) == 0) ! { ! cl_drawcn (X, Y, Z, flev, krownext, kcolnext, ! locx[num], locy[num], inext, ipts); ! } ! ! } ! if (first == 1) ! { ! // Move back to first point ! cl_start_contour (flev, locx[num], locy[num]); ! first = 0; ! } ! else ! { ! first = 1; ! } ! num++; ! } ! } } } static void ! cl_cntr (RowVector & X, RowVector & Y, Matrix & Z, double flev) { ! Matrix ipts (Z.rows (), Z.cols (), 0); ! for (int krow = 0; krow < Z.rows () - 1; krow++) { ! for (int kcol = 0; kcol < Z.cols () - 1; kcol++) ! { ! if (ipts(krow,kcol) == 0) ! { ! cl_drawcn (X, Y, Z, flev, krow, kcol, 0.0, 0.0, -2, ipts); ! } ! } } } DEFUN_DLD (__contourc__, args, , --- 64,301 ---- 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 (mark(r, c)); ! // Check startedge s. ! if (start_edge == 255) { ! // Find start edge. ! for (unsigned int k = 0; k < 4; k++) ! if (static_cast (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 (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: control flow --> while. ! 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 (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 (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, , *************** *** 308,314 **** { RowVector X = args (0).row_vector_value (); RowVector Y = args (1).row_vector_value (); ! Matrix Z = args (2).matrix_value ().transpose (); RowVector L = args (3).row_vector_value (); if (! error_state) --- 310,316 ---- { 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) *************** *** 316,324 **** contourc.resize (2, 0); for (int i = 0; i < L.length (); i++) ! cl_cntr (X, Y, Z, L (i)); ! cl_end_contour (); retval = contourc; } --- 318,326 ---- contourc.resize (2, 0); for (int i = 0; i < L.length (); i++) ! cntr (X, Y, Z, L (i)); ! end_contour (); retval = contourc; } diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/__qp__.cc octave-2.9.16/src/DLD-FUNCTIONS/__qp__.cc *** octave-2.9.15/src/DLD-FUNCTIONS/__qp__.cc Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/__qp__.cc Wed Oct 17 11:38:54 2007 *************** *** 379,385 **** for (octave_idx_type j = 0; j < n_act-n_eq; j++) { ! if (Wact(j) == i - n_eq) { found = true; break; --- 379,385 ---- for (octave_idx_type j = 0; j < n_act-n_eq; j++) { ! if (Wact(j) == i) { found = true; break; *************** *** 452,458 **** { for (octave_idx_type j = 0; j < n_act-n_eq; j++) { ! if (Wact(j) == i) { lambda(i) = lambda_tmp(n_eq+j); break; --- 452,458 ---- { 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; diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/besselj.cc octave-2.9.16/src/DLD-FUNCTIONS/besselj.cc *** octave-2.9.15/src/DLD-FUNCTIONS/besselj.cc Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/besselj.cc Mon Oct 15 11:30:05 2007 *************** *** 415,426 **** derivatives.\n\ \n\ @example\n\ ! K Function Scale factor (if a third argument 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 example\n\ \n\ The function call @code{airy (@var{z})} is equivalent to\n\ --- 415,426 ---- derivatives.\n\ \n\ @example\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 example\n\ \n\ The function call @code{airy (@var{z})} is equivalent to\n\ diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/cellfun.cc octave-2.9.16/src/DLD-FUNCTIONS/cellfun.cc *** octave-2.9.15/src/DLD-FUNCTIONS/cellfun.cc Fri Oct 12 17:27:35 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/cellfun.cc Fri Oct 19 12:05:49 2007 *************** *** 676,682 **** octave_value retval; if (nargin < 2) ! usage ("mat2cell"); else { dim_vector dv = args(0).dims(); --- 676,682 ---- octave_value retval; if (nargin < 2) ! print_usage (); else { dim_vector dv = args(0).dims(); diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/rand.cc octave-2.9.16/src/DLD-FUNCTIONS/rand.cc *** octave-2.9.15/src/DLD-FUNCTIONS/rand.cc Fri Oct 12 17:27:35 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/rand.cc Mon Oct 15 07:48:45 2007 *************** *** 649,656 **** @end example\n\ @item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2}\n\ @example\n\ ! r1 = 2 * randg (n1 / 2) / n1 or 1 if n1 is infinite\n\ ! r2 = 2 * randg (n2 / 2) / n2 or 1 if n2 is infinite\n\ r = r1 / r2\n\n\ @end example\n\ @item negative @code{binomial (n, p)} for @code{n > 0}, @code{0 < p <= 1}\n\ --- 649,656 ---- @end example\n\ @item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2}\n\ @example\n\ ! r1 = 2 * randg (n1 / 2) / n1 ## r1 equals 1 if n1 is infinite\n\ ! r2 = 2 * randg (n2 / 2) / n2 ## r2 equals 1 if n2 is infinite\n\ r = r1 / r2\n\n\ @end example\n\ @item negative @code{binomial (n, p)} for @code{n > 0}, @code{0 < p <= 1}\n\ diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/sort.cc octave-2.9.16/src/DLD-FUNCTIONS/sort.cc *** octave-2.9.15/src/DLD-FUNCTIONS/sort.cc Fri Oct 12 17:27:35 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/sort.cc Thu Oct 25 01:50:56 2007 *************** *** 890,895 **** --- 890,1087 ---- mx_sort_indexed (ArrayN &m, int dim, sortmode mode); #endif + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_int8 a, octave_int8 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_int8 a, octave_int8 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_uint8 a, octave_uint8 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_uint8 a, octave_uint8 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_int16 a, octave_int16 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_int16 a, octave_int16 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_uint16 a, octave_uint16 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_uint16 a, octave_uint16 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_int32 a, octave_int32 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_int32 a, octave_int32 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_uint32 a, octave_uint32 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_uint32 a, octave_uint32 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_int64 a, octave_int64 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_int64 a, octave_int64 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + + template class octave_sort; + template class vec_index; + template class octave_sort *>; + + #if !defined (CXX_NEW_FRIEND_TEMPLATE_DECL) + bool + ascending_compare (octave_uint64 a, octave_uint64 b); + + bool + ascending_compare (vec_index *a, vec_index *b); + + bool + descending_compare (octave_uint64 a, octave_uint64 b); + + bool + descending_compare (vec_index *a, vec_index *b); + + static octave_value_list + mx_sort (ArrayN &m, int dim, sortmode mode); + + static octave_value_list + mx_sort_indexed (ArrayN &m, int dim, sortmode mode); + #endif + template <> bool ascending_compare (vec_index *a, vec_index *b) *************** *** 1048,1053 **** --- 1240,1251 ---- } } + // FIXME -- Perhaps sort should be made a method of the octave_value + // classes and then the mess of if statements below might be + // replaced with + // + // retval = arg.sort (dim, smode, return_idx); + if (arg.is_real_type ()) { if (arg.is_sparse_type ()) *************** *** 1062,1067 **** --- 1260,1353 ---- retval = mx_sort_sparse (m, dim, smode); } } + else if (arg.is_int8_type ()) + { + int8NDArray m = arg.int8_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } + else if (arg.is_uint8_type ()) + { + uint8NDArray m = arg.uint8_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } + else if (arg.is_int16_type ()) + { + int16NDArray m = arg.int16_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } + else if (arg.is_uint16_type ()) + { + uint16NDArray m = arg.uint16_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } + else if (arg.is_int32_type ()) + { + int32NDArray m = arg.int32_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } + else if (arg.is_uint32_type ()) + { + uint32NDArray m = arg.uint32_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } + else if (arg.is_int64_type ()) + { + int64NDArray m = arg.int64_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } + else if (arg.is_uint64_type ()) + { + uint64NDArray m = arg.uint64_array_value (); + if (! error_state) + { + if (return_idx) + retval = mx_sort_indexed (m, dim, smode); + else + retval = mx_sort (m, dim, smode); + } + } else { NDArray m = arg.array_value (); diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/spchol.cc octave-2.9.16/src/DLD-FUNCTIONS/spchol.cc *** octave-2.9.15/src/DLD-FUNCTIONS/spchol.cc Fri Oct 12 17:27:35 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/spchol.cc Wed Oct 17 15:02:11 2007 *************** *** 415,438 **** cm->complex_divide = CHOLMOD_NAME(divcomplex); cm->hypotenuse = CHOLMOD_NAME(hypot); - #ifdef HAVE_METIS - // METIS 4.0.1 uses malloc and free, and will terminate if it runs - // out of memory. Use CHOLMOD's memory guard for METIS, which - // allocates a huge block of memory (and then immediately frees it) - // before calling METIS. - cm->metis_memory = 2.0; - - #if defined(METIS_VERSION) - #if (METIS_VERSION >= METIS_VER(4,0,2)) - // METIS 4.0.2 uses function pointers for malloc and free. - METIS_malloc = cm->malloc_memory; - METIS_free = cm->free_memory; - // Turn off METIS memory guard. - cm->metis_memory = 0.0; - #endif - #endif - #endif - double dummy; cholmod_sparse Astore; cholmod_sparse *A = &Astore; --- 415,420 ---- diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/time.cc octave-2.9.16/src/DLD-FUNCTIONS/time.cc *** octave-2.9.15/src/DLD-FUNCTIONS/time.cc Fri Oct 12 17:27:35 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/time.cc Thu Oct 25 01:50:56 2007 *************** *** 89,95 **** octave_value retval; if (args.length () == 0) ! retval = static_cast (octave_time ()); else print_usage (); --- 89,95 ---- octave_value retval; if (args.length () == 0) ! retval = octave_time (); else print_usage (); *************** *** 206,212 **** octave_base_tm tm = extract_tm (map); if (! error_state) ! retval = static_cast (octave_time (tm)); else error ("mktime: invalid TMSTRUCT argument"); } --- 206,212 ---- octave_base_tm tm = extract_tm (map); if (! error_state) ! retval = octave_time (tm); else error ("mktime: invalid TMSTRUCT argument"); } diff -cNr octave-2.9.15/src/DLD-FUNCTIONS/urlwrite.cc octave-2.9.16/src/DLD-FUNCTIONS/urlwrite.cc *** octave-2.9.15/src/DLD-FUNCTIONS/urlwrite.cc Fri Oct 12 17:27:35 2007 --- octave-2.9.16/src/DLD-FUNCTIONS/urlwrite.cc Mon Oct 15 11:30:05 2007 *************** *** 195,201 **** @var{localfile}. For example,\n\ \n\ @example\n\ ! urlwrite (\"ftp://ftp.octave.org/pub/octave/README\", \"README.txt\");\n\ @end example\n\ \n\ The full path of the downloaded file is returned in @var{f}. The\n\ --- 195,202 ---- @var{localfile}. For example,\n\ \n\ @example\n\ ! urlwrite (\"ftp://ftp.octave.org/pub/octave/README\", \n\ ! \"README.txt\");\n\ @end example\n\ \n\ The full path of the downloaded file is returned in @var{f}. The\n\ *************** *** 342,348 **** URL. For example,\n\ \n\ @example\n\ ! s = urlread (\"http://username:password@@example.com/file.txt\");\n\ @end example\n\ \n\ GET and POST requests can be specified by @var{method} and @var{param}.\n\ --- 343,349 ---- URL. For example,\n\ \n\ @example\n\ ! s = urlread (\"http://user:password@@example.com/file.txt\");\n\ @end example\n\ \n\ GET and POST requests can be specified by @var{method} and @var{param}.\n\ diff -cNr octave-2.9.15/src/DOCSTRINGS octave-2.9.16/src/DOCSTRINGS *** octave-2.9.15/src/DOCSTRINGS Sat Oct 13 11:10:07 2007 --- octave-2.9.16/src/DOCSTRINGS Wed Oct 31 18:08:40 2007 *************** *** 283,294 **** derivatives. @example ! K Function Scale factor (if a third argument is supplied) ! --- -------- ---------------------------------------------- ! 0 Ai (Z) exp ((2/3) * Z * sqrt (Z)) ! 1 dAi(Z)/dZ exp ((2/3) * Z * sqrt (Z)) ! 2 Bi (Z) exp (-abs (real ((2/3) * Z *sqrt (Z)))) ! 3 dBi(Z)/dZ exp (-abs (real ((2/3) * Z *sqrt (Z)))) @end example The function call @code{airy (@var{z})} is equivalent to --- 283,294 ---- derivatives. @example ! K Function Scale factor (if 'opt' is supplied) ! --- -------- --------------------------------------- ! 0 Ai (Z) exp ((2/3) * Z * sqrt (Z)) ! 1 dAi(Z)/dZ exp ((2/3) * Z * sqrt (Z)) ! 2 Bi (Z) exp (-abs (real ((2/3) * Z *sqrt (Z)))) ! 3 dBi(Z)/dZ exp (-abs (real ((2/3) * Z *sqrt (Z)))) @end example The function call @code{airy (@var{z})} is equivalent to *************** *** 1236,1242 **** The local error test applied at each integration step is @example ! abs (local error in x(i)) <= rtol(i) * abs (Y(i)) + atol(i) @end example @item "initial step size" Differential-algebraic problems may occasionally suffer from severe --- 1236,1243 ---- The local error test applied at each integration step is @example ! abs (local error in x(i)) <= ... ! rtol(i) * abs (Y(i)) + atol(i) @end example @item "initial step size" Differential-algebraic problems may occasionally suffer from severe *************** *** 2354,2362 **** @deftypefn {Built-in Function} {} or (@var{x}, @var{y}) This function is equivalent to @code{x | y}. @end deftypefn dbstop -*- texinfo -*- ! @deftypefn {Loadable Function} {rline =} dbstop (func, line, @dots{}) Set a breakpoint in a function @table @code @item func --- 2355,2432 ---- @deftypefn {Built-in Function} {} or (@var{x}, @var{y}) This function is equivalent to @code{x | y}. @end deftypefn + tic + -*- texinfo -*- + @deftypefn {Built-in Function} {} tic () + @deftypefnx {Built-in Function} {} toc () + Set or check a wall-clock timer. Calling @code{tic} without an + output argument sets the timer. Subsequent calls to @code{toc} + return the number of seconds since the timer was set. For example, + + @example + tic (); + # many computations later... + elapsed_time = toc (); + @end example + + @noindent + will set the variable @code{elapsed_time} to the number of seconds since + the most recent call to the function @code{tic}. + + If called with one output argument then this function returns a scalar + of type @code{uint64} and the wall-clock timer is not started. + + @example + @group + t = tic; sleep (5); (double (tic ()) - double (t)) * 1e-6 + @result{} 5 + @end group + @end example + + Nested timing with @code{tic} and @code{toc} is not supported. + Therefore @code{toc} will always return the elapsed time from the most + recent call to @code{tic}. + + If you are more interested in the CPU time that your process used, you + should use the @code{cputime} function instead. The @code{tic} and + @code{toc} functions report the actual wall clock time that elapsed + between the calls. This may include time spent processing other jobs or + doing nothing at all. For example, + + @example + @group + tic (); sleep (5); toc () + @result{} 5 + t = cputime (); sleep (5); cputime () - t + @result{} 0 + @end group + @end example + + @noindent + (This example also illustrates that the CPU timer may have a fairly + coarse resolution.) + @end deftypefn + toc + -*- texinfo -*- + @deftypefn {Built-in Function} {} toc () + See tic. + @end deftypefn + cputime + -*- texinfo -*- + @deftypefn {Built-in Function} {[@var{total}, @var{user}, @var{system}] =} cputime (); + Return the CPU time used by your Octave session. The first output is + the total time spent executing your process and is equal to the sum of + second and third outputs, which are the number of CPU seconds spent + executing in user mode and the number of CPU seconds spent executing in + system mode, respectively. If your system does not have a way to report + CPU time usage, @code{cputime} returns 0 for each of its output values. + Note that because Octave used some CPU time to start, it is reasonable + to check to see if @code{cputime} works by checking to see if the total + CPU time used is nonzero. + @end deftypefn dbstop -*- texinfo -*- ! @deftypefn {Loadable Function} {rline =} dbstop (@var{func}, @var{line}, @dots{}) Set a breakpoint in a function @table @code @item func *************** *** 2372,2378 **** @end deftypefn dbclear -*- texinfo -*- ! @deftypefn {Loadable Function} {} dbclear (func, line, @dots{}) Delete a breakpoint in a function @table @code @item func --- 2442,2448 ---- @end deftypefn dbclear -*- texinfo -*- ! @deftypefn {Loadable Function} {} dbclear (@var{func}, @var{line}, @dots{}) Delete a breakpoint in a function @table @code @item func *************** *** 2388,2394 **** @end deftypefn dbstatus -*- texinfo -*- ! @deftypefn {Loadable Function} {lst =} dbstatus ([func]) Return a vector containing the lines on which a function has breakpoints set. @table @code --- 2458,2464 ---- @end deftypefn dbstatus -*- texinfo -*- ! @deftypefn {Loadable Function} {lst =} dbstatus (@var{func}) Return a vector containing the lines on which a function has breakpoints set. @table @code *************** *** 2695,2701 **** calling the function @code{f} will result in a list of messages that can help you to quickly locate the exact location of the error: ! @example @group f () error: nargin != 1 --- 2765,2771 ---- calling the function @code{f} will result in a list of messages that can help you to quickly locate the exact location of the error: ! @smallexample @group f () error: nargin != 1 *************** *** 2705,2711 **** error: called from `g' error: called from `f' @end group ! @end example If the error message ends in a new line character, Octave will print the message but will not display any traceback messages as it returns --- 2775,2781 ---- error: called from `g' error: called from `f' @end group ! @end smallexample If the error message ends in a new line character, Octave will print the message but will not display any traceback messages as it returns *************** *** 4950,4958 **** the header comment is omitted from text-format data files. The default value is ! @example "# Created by Octave VERSION, %a %b %d %H:%M:%S %Y %Z " ! @end example @seealso{strftime} @end deftypefn save_precision --- 5020,5028 ---- the header comment is omitted from text-format data files. The default value is ! @smallexample "# Created by Octave VERSION, %a %b %d %H:%M:%S %Y %Z " ! @end smallexample @seealso{strftime} @end deftypefn save_precision *************** *** 4984,4990 **** The local error test applied at each integration step is @example ! abs (local error in x(i)) <= rtol * abs (y(i)) + atol(i) @end example @item "integration method" A string specifying the method of integration to use to solve the ODE --- 5054,5061 ---- The local error test applied at each integration step is @example ! abs (local error in x(i)) <= ... ! rtol * abs (y(i)) + atol(i) @end example @item "integration method" A string specifying the method of integration to use to solve the ODE *************** *** 6195,6201 **** @example @group ! A = cell2struct (@{'Peter', 'Hannah', 'Robert'; 185, 170, 168@}, @{'Name','Height'@}, 1); A(1) @result{} ans = --- 6266,6273 ---- @example @group ! A = cell2struct (@{'Peter', 'Hannah', 'Robert'; ! 185, 170, 168@}, @{'Name','Height'@}, 1); A(1) @result{} ans = *************** *** 7257,7264 **** @end example @item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2} @example ! r1 = 2 * randg (n1 / 2) / n1 or 1 if n1 is infinite ! r2 = 2 * randg (n2 / 2) / n2 or 1 if n2 is infinite r = r1 / r2 @end example --- 7329,7336 ---- @end example @item @code{F (n1, n2)} for @code{0 < n1}, @code{0 < n2} @example ! r1 = 2 * randg (n1 / 2) / n1 ## r1 equals 1 if n1 is infinite ! r2 = 2 * randg (n2 / 2) / n2 ## r2 equals 1 if n2 is infinite r = r1 / r2 @end example *************** *** 8637,8643 **** @end table A command is composed like this: ! %[modifier][:size_of_parameter[:center-specific[:print_dims[:balance]]]]; Command and modifier is already explained. Size_of_parameter tells how many columns the parameter will need for printing. --- 8709,8719 ---- @end table A command is composed like this: ! ! @example ! %[modifier][:size_of_parameter[:center-specific[ ! :print_dims[:balance]]]]; ! @end example Command and modifier is already explained. Size_of_parameter tells how many columns the parameter will need for printing. *************** *** 9791,9797 **** @var{localfile}. For example, @example ! urlwrite ("ftp://ftp.octave.org/pub/octave/README", "README.txt"); @end example The full path of the downloaded file is returned in @var{f}. The --- 9867,9874 ---- @var{localfile}. For example, @example ! urlwrite ("ftp://ftp.octave.org/pub/octave/README", ! "README.txt"); @end example The full path of the downloaded file is returned in @var{f}. The *************** *** 9843,9849 **** URL. For example, @example ! s = urlread ("http://username:password@@example.com/file.txt"); @end example GET and POST requests can be specified by @var{method} and @var{param}. --- 9920,9926 ---- URL. For example, @example ! s = urlread ("http://user:password@@example.com/file.txt"); @end example GET and POST requests can be specified by @var{method} and @var{param}. diff -cNr octave-2.9.15/src/LSODE-opts.cc octave-2.9.16/src/LSODE-opts.cc *** octave-2.9.15/src/LSODE-opts.cc Sat Oct 13 10:49:37 2007 --- octave-2.9.16/src/LSODE-opts.cc Wed Oct 31 17:44:19 2007 *************** *** 358,364 **** The local error test applied at each integration step is\n\ \n\ @example\n\ ! abs (local error in x(i)) <= rtol * abs (y(i)) + atol(i)\n\ @end example\n\ @item \"integration method\"\n\ A string specifying the method of integration to use to solve the ODE\n\ --- 358,365 ---- The local error test applied at each integration step is\n\ \n\ @example\n\ ! abs (local error in x(i)) <= ...\n\ ! rtol * abs (y(i)) + atol(i)\n\ @end example\n\ @item \"integration method\"\n\ A string specifying the method of integration to use to solve the ODE\n\ diff -cNr octave-2.9.15/src/Makefile.in octave-2.9.16/src/Makefile.in *** octave-2.9.15/src/Makefile.in Fri Oct 12 17:27:29 2007 --- octave-2.9.16/src/Makefile.in Wed Oct 31 10:53:15 2007 *************** *** 113,119 **** pt-pr-code.h pt-select.h pt-stmt.h pt-unop.h pt-walk.h \ INCLUDES := Cell.h base-list.h c-file-ptr-stream.h comment-list.h \ ! defun-dld.h defun-int.h defun.h dirfns.h dynamic-ld.h \ error.h file-io.h gripes.h help.h input.h \ lex.h load-path.h load-save.h ls-hdf5.h ls-mat-ascii.h ls-mat4.h \ ls-mat5.h ls-oct-ascii.h ls-oct-binary.h ls-utils.h \ --- 113,119 ---- pt-pr-code.h pt-select.h pt-stmt.h pt-unop.h pt-walk.h \ INCLUDES := Cell.h base-list.h c-file-ptr-stream.h comment-list.h \ ! debug.h defun-dld.h defun-int.h defun.h dirfns.h dynamic-ld.h \ error.h file-io.h gripes.h help.h input.h \ lex.h load-path.h load-save.h ls-hdf5.h ls-mat-ascii.h ls-mat4.h \ ls-mat5.h ls-oct-ascii.h ls-oct-binary.h ls-utils.h \ *************** *** 369,375 **** graphics.h: graphics.h.in genprops.awk @echo making $@ ! @awk -f $(srcdir)/genprops.awk $< > $@-t @$(simple-move-if-change-rule) PKG_ADD: $(DLD_DEF_FILES) --- 369,375 ---- graphics.h: graphics.h.in genprops.awk @echo making $@ ! @$(AWK) -f $(srcdir)/genprops.awk $< > $@-t @$(simple-move-if-change-rule) PKG_ADD: $(DLD_DEF_FILES) diff -cNr octave-2.9.15/src/data.cc octave-2.9.16/src/data.cc *** octave-2.9.15/src/data.cc Fri Oct 12 17:27:29 2007 --- octave-2.9.16/src/data.cc Tue Oct 30 10:05:00 2007 *************** *** 25,30 **** --- 25,40 ---- #include #endif + #include "systime.h" + + #ifdef HAVE_SYS_TYPES_H + #include + #endif + + #ifdef HAVE_SYS_RESOURCE_H + #include + #endif + #include #include *************** *** 47,52 **** --- 57,63 ---- #include "pt-mat.h" #include "utils.h" #include "variables.h" + #include "pager.h" #define ANY_ALL(FCN) \ \ *************** *** 2609,2615 **** %!shared m %! m = magic (4); %!assert(norm(m,1), 34); ! %!assert(norm(m,2), 34); %!assert(norm(m,Inf), 34); %!assert(norm(m,"inf"), 34); */ --- 2620,2626 ---- %!shared m %! m = magic (4); %!assert(norm(m,1), 34); ! %!assert(norm(m,2), 34, -eps); %!assert(norm(m,Inf), 34); %!assert(norm(m,"inf"), 34); */ *************** *** 2963,2968 **** --- 2974,3164 ---- BINARY_OP_DEFUN_BODY (op_el_or); } + static double tic_toc_timestamp = -1.0; + + DEFUN (tic, args, nargout, + "-*- texinfo -*-\n\ + @deftypefn {Built-in Function} {} tic ()\n\ + @deftypefnx {Built-in Function} {} toc ()\n\ + Set or check a wall-clock timer. Calling @code{tic} without an\n\ + output argument sets the timer. Subsequent calls to @code{toc}\n\ + return the number of seconds since the timer was set. For example,\n\ + \n\ + @example\n\ + tic ();\n\ + # many computations later...\n\ + elapsed_time = toc ();\n\ + @end example\n\ + \n\ + @noindent\n\ + will set the variable @code{elapsed_time} to the number of seconds since\n\ + the most recent call to the function @code{tic}.\n\ + \n\ + If called with one output argument then this function returns a scalar\n\ + of type @code{uint64} and the wall-clock timer is not started.\n\ + \n\ + @example\n\ + @group\n\ + t = tic; sleep (5); (double (tic ()) - double (t)) * 1e-6\n\ + @result{} 5\n\ + @end group\n\ + @end example\n\ + \n\ + Nested timing with @code{tic} and @code{toc} is not supported.\n\ + Therefore @code{toc} will always return the elapsed time from the most\n\ + recent call to @code{tic}.\n\ + \n\ + If you are more interested in the CPU time that your process used, you\n\ + should use the @code{cputime} function instead. The @code{tic} and\n\ + @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. For example,\n\ + \n\ + @example\n\ + @group\n\ + tic (); sleep (5); toc ()\n\ + @result{} 5\n\ + t = cputime (); sleep (5); cputime () - t\n\ + @result{} 0\n\ + @end group\n\ + @end example\n\ + \n\ + @noindent\n\ + (This example also illustrates that the CPU timer may have a fairly\n\ + coarse resolution.)\n\ + @end deftypefn") + { + octave_value retval; + + int nargin = args.length (); + + if (nargin != 0) + warning ("tic: ignoring extra arguments"); + + octave_time now; + + double tmp = now.double_value (); + + if (nargout > 0) + retval = static_cast (1e6 * tmp); + else + tic_toc_timestamp = tmp; + + return retval; + } + + DEFUN (toc, args, nargout, + "-*- texinfo -*-\n\ + @deftypefn {Built-in Function} {} toc ()\n\ + See tic.\n\ + @end deftypefn") + { + octave_value retval; + + int nargin = args.length (); + + if (nargin != 0) + warning ("tic: ignoring extra arguments"); + + if (tic_toc_timestamp < 0) + { + warning ("toc called before timer set"); + if (nargout > 0) + retval = Matrix (); + } + else + { + octave_time now; + + double tmp = now.double_value () - tic_toc_timestamp; + + if (nargout > 0) + retval = tmp; + else + octave_stdout << "Elapsed time is " << tmp << " seconds.\n"; + } + + return retval; + } + + DEFUN (cputime, args, , + "-*- texinfo -*-\n\ + @deftypefn {Built-in Function} {[@var{total}, @var{user}, @var{system}] =} cputime ();\n\ + Return the CPU time used by your Octave session. The first output is\n\ + the total time spent executing your process and is equal to the sum of\n\ + second and third outputs, which are the number of CPU seconds spent\n\ + executing in user mode and the number of CPU seconds spent executing in\n\ + system mode, respectively. If your system does not have a way to report\n\ + CPU time usage, @code{cputime} returns 0 for each of its output values.\n\ + 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\ + @end deftypefn") + { + octave_value_list retval; + int nargin = args.length (); + double usr = 0.0; + double sys = 0.0; + + if (nargin != 0) + warning ("tic: ignoring extra arguments"); + + #if defined (HAVE_GETRUSAGE) + + struct rusage ru; + + getrusage (RUSAGE_SELF, &ru); + + usr = static_cast (ru.ru_utime.tv_sec) + + static_cast (ru.ru_utime.tv_usec) * 1e-6; + + sys = static_cast (ru.ru_stime.tv_sec) + + static_cast (ru.ru_stime.tv_usec) * 1e-6; + + #elif defined (HAVE_TIMES) && defined (HAVE_SYS_TIMES_H) + + 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; + + usr = static_cast (seconds) + static_cast(fraction) / + static_cast(HZ); + + ticks = t.tms_stime + t.tms_cstime; + fraction = ticks % HZ; + seconds = ticks / HZ; + + sys = static_cast (seconds) + static_cast(fraction) / + static_cast(HZ); + + #elif defined (__WIN32__) + HANDLE hProcess = GetCurrentProcess (); + FILETIME ftCreation, ftExit, ftUser, ftKernel; + GetProcessTimes (hProcess, &ftCreation, &ftExit, &ftKernel, &ftUser); + + int64_t itmp = *(reinterpret_cast (&ftUser)); + usr = static_cast (itmp) * 1e-1; + + itmp = *(reinterpret_cast (&ftKernel)); + sys = static_cast (itmp) * 1e-1; + + #endif + + retval (2) = sys; + retval (1) = usr; + retval (0) = sys + usr; + + return retval; + } + /* ;;; Local Variables: *** ;;; mode: C++ *** diff -cNr octave-2.9.15/src/debug.cc octave-2.9.16/src/debug.cc *** octave-2.9.15/src/debug.cc Fri Oct 12 17:27:29 2007 --- octave-2.9.16/src/debug.cc Tue Oct 30 22:12:16 2007 *************** *** 19,25 **** . */ - #ifdef HAVE_CONFIG_H #include #endif --- 19,24 ---- *************** *** 27,35 **** --- 26,37 ---- #include #include #include + #include + #include "defun.h" #include "error.h" + #include "help.h" #include "input.h" #include "pager.h" #include "oct-obj.h" *************** *** 40,45 **** --- 42,49 ---- #include "ov.h" #include "ov-usr-fcn.h" #include "ov-fcn.h" + #include "ov-list.h" + #include "ov-struct.h" #include "pt-pr-code.h" #include "pt.h" #include "pt-bp.h" *************** *** 48,63 **** #include "unwind-prot.h" #include "variables.h" // Return a pointer to the user-defined function FNAME. If FNAME is // empty, search backward for the first user-defined function in the // current call stack. static octave_user_function * ! get_user_function (std::string fname = "") { octave_user_function *dbg_fcn = 0; ! if (fname == "") dbg_fcn = octave_call_stack::caller_user_function (); else { --- 52,72 ---- #include "unwind-prot.h" #include "variables.h" + #include "debug.h" + + // Initialize the singleton object + bp_table *bp_table::instance = 0; + // Return a pointer to the user-defined function FNAME. If FNAME is // empty, search backward for the first user-defined function in the // current call stack. static octave_user_function * ! get_user_function (const std::string& fname = std::string ()) { octave_user_function *dbg_fcn = 0; ! if (fname.empty ()) dbg_fcn = octave_call_stack::caller_user_function (); else { *************** *** 71,77 **** else { ptr = lookup_by_name (fname, false); ! if (ptr && ptr->is_user_function ()) { octave_value tmp = ptr->def (); --- 80,86 ---- else { ptr = lookup_by_name (fname, false); ! if (ptr && ptr->is_user_function ()) { octave_value tmp = ptr->def (); *************** *** 83,187 **** return dbg_fcn; } ! ! DEFCMD (dbstop, args, , ! "-*- texinfo -*-\n\ ! @deftypefn {Loadable Function} {rline =} dbstop (func, line, @dots{})\n\ ! Set a breakpoint in a function\n\ ! @table @code\n\ ! @item func\n\ ! String representing the function name. When already in debug\n\ ! mode this should be left out and only the line should be given.\n\ ! @item line\n\ ! Line you would like the breakpoint to be set on. Multiple\n\ ! lines might be given as separate arguments or as a vector.\n\ ! @end table\n\ ! \n\ ! The rline returned is the real line that the breakpoint was set at.\n\ ! @seealso{dbclear, dbstatus, dbnext}\n\ ! @end deftypefn") { ! octave_value retval; int nargin = args.length (); int idx = 0; ! std::string symbol_name = ""; ! if (nargin != 1 && args(0).is_string()) { ! symbol_name = args(0).string_value (); idx = 1; } ! octave_user_function *dbg_fcn = get_user_function (symbol_name); if (dbg_fcn) { - octave_idx_type nsize = 10; - RowVector results (nsize); - octave_idx_type nr = 0; - tree_statement_list *cmds = dbg_fcn->body (); ! for (int i = idx; i < nargin; i++) { ! if (args(i).is_string ()) ! { ! int line = atoi (args(i).string_value ().c_str ()); ! if (error_state) ! break; ! if (nr == nsize) ! { ! nsize *= 2; ! results.resize (nsize); ! } ! results(nr++) = cmds->set_breakpoint (line); } ! else ! { ! const NDArray arg = args(i).array_value (); ! if (error_state) ! break; - for (octave_idx_type j = 0; j < arg.nelem(); j++) - { - int line = static_cast (arg.elem (j)); ! if (error_state) ! break; ! if (nr == nsize) ! { ! nsize *= 2; ! results.resize (nsize); ! } ! results(nr++) = cmds->set_breakpoint (line); ! } ! if (error_state) ! break; } } ! if (! error_state) { ! results.resize (nr); ! retval = results; } } else ! error ("dbstop: unable to find the function requested\n"); return retval; } DEFCMD (dbclear, args, , "-*- texinfo -*-\n\ ! @deftypefn {Loadable Function} {} dbclear (func, line, @dots{})\n\ Delete a breakpoint in a function\n\ @table @code\n\ @item func\n\ --- 92,374 ---- return dbg_fcn; } ! static void ! parse_dbfunction_params (const octave_value_list& args, ! std::string& symbol_name, ! bp_table::intmap& lines) { ! octave_idx_type len = 0; int nargin = args.length (); int idx = 0; ! int list_idx = 0; ! symbol_name = std::string (); ! // If we are already in a debugging function. ! if (octave_call_stack::caller_user_function ()) ! idx = 0; ! else { ! symbol_name = args (0).string_value (); ! if (error_state) ! return; idx = 1; } ! for (int i = idx; i < nargin; i++ ) ! { ! if (args (i).is_string ()) ! len++; ! else ! len += args (i).numel (); ! } ! ! lines = bp_table::intmap (); ! for (int i = idx; i < nargin; i++ ) ! { ! if (args (i).is_string ()) ! { ! int line = atoi (args(i).string_value().c_str ()); ! if (error_state) ! break; ! lines[list_idx++] = line; ! } ! else ! { ! const NDArray arg = args(i).array_value (); ! ! if (error_state) ! break; ! ! for (octave_idx_type j = 0; j < arg.nelem (); j++) ! { ! int line = static_cast (arg.elem (j)); ! if (error_state) ! break; ! lines[list_idx++] = line; ! } ! ! if (error_state) ! break; ! } ! } ! } ! ! bp_table::intmap ! bp_table::do_add_breakpoint (const std::string& fname, ! const bp_table::intmap& line) ! { ! intmap retval; ! ! octave_idx_type len = line.size (); ! ! octave_user_function *dbg_fcn = get_user_function (fname); if (dbg_fcn) { tree_statement_list *cmds = dbg_fcn->body (); ! for (int i = 0; i < len; i++) { ! const_intmap_iterator p = line.find (i); ! if (p != line.end ()) ! { ! int lineno = p->second; ! retval[i] = cmds->set_breakpoint (lineno); ! if (retval[i] != 0) ! bp_map[fname] = dbg_fcn; } ! } ! } ! else ! error ("add_breakpoint: unable to find the function requested\n"); ! return retval; ! } ! int ! bp_table::do_remove_breakpoint (const std::string& fname, ! const bp_table::intmap& line) ! { ! int retval = 0; ! octave_idx_type len = line.size (); ! if (len == 0) ! { ! intmap results = remove_all_breakpoints_in_file (fname); ! retval = results.size (); ! } ! else ! { ! octave_user_function *dbg_fcn = get_user_function (fname); ! if (dbg_fcn) ! { ! tree_statement_list *cmds = dbg_fcn->body (); ! for (int i = 0; i < len; i++) ! { ! const_intmap_iterator p = line.find (i); ! if (p != line.end ()) ! cmds->delete_breakpoint (p->second); } + + octave_value_list results = cmds->list_breakpoints (); + + if (results.length () == 0) + bp_map.erase (bp_map.find (fname)); + + retval = results.length (); } + else + error ("remove_breakpoint: unable to find the function requested\n"); + } + return retval; + } + + + bp_table::intmap + bp_table::do_remove_all_breakpoints_in_file (const std::string& fname) + { + intmap retval; + + octave_user_function *dbg_fcn = get_user_function (fname); + + if (dbg_fcn) + { + tree_statement_list *cmds = dbg_fcn->body (); ! octave_value_list bkpts = cmds->list_breakpoints (); ! ! for (int i = 0; i < bkpts.length (); i++) { ! int lineno = static_cast (bkpts(i).int_value ()); ! cmds->delete_breakpoint (lineno); ! retval[i] = lineno; } + + bp_map.erase (bp_map.find (fname)); } else ! error ("remove_all_breakpoint_in_file: " ! "unable to find the function requested\n"); ! ! return retval; ! } ! ! void ! bp_table::do_remove_all_breakpoints (void) ! { ! for (const_breakpoint_map_iterator it = bp_map.begin (); ! it != bp_map.end (); it++) ! remove_all_breakpoints_in_file (it->first); ! } ! ! std::string ! do_find_bkpt_list (octave_value_list slist, ! std::string match) ! { ! std::string retval; ! ! for (int i = 0; i < slist.length (); i++) ! { ! if (slist (i).string_value () == match) ! { ! retval = slist(i).string_value (); ! break; ! } ! } ! return retval; ! } ! ! ! bp_table::fname_line_map ! bp_table::do_get_breakpoint_list (const octave_value_list& fname_list) ! { ! fname_line_map retval; ! ! // Iterate through each of the files in the map and get the ! // name and list of breakpoints. ! ! for (breakpoint_map_iterator it = bp_map.begin (); it != bp_map.end (); it++) ! { ! if (fname_list.length () == 0 ! || do_find_bkpt_list (fname_list, it->first) != "") ! { ! octave_value_list bkpts = it->second->body ()->list_breakpoints (); ! ! octave_idx_type len = bkpts.length (); ! ! bp_table::intmap bkpts_vec; ! ! for (int i = 0; i < len; i++) ! bkpts_vec[i] = bkpts (i).double_value (); ! ! retval[it->first] = bkpts_vec; ! } ! } ! ! return retval; ! } ! ! static octave_value ! intmap_to_ov (const bp_table::intmap& line) ! { ! int idx = 0; ! ! NDArray retval (dim_vector (1, line.size ())); ! ! for (size_t i = 0; i < line.size (); i++) ! { ! bp_table::const_intmap_iterator p = line.find (i); ! ! if (p != line.end ()) ! { ! int lineno = p->second; ! retval(idx++) = lineno; ! } ! } ! ! retval.resize (dim_vector (1, idx)); return retval; } + DEFCMD (dbstop, args, , + "-*- texinfo -*-\n\ + @deftypefn {Loadable Function} {rline =} dbstop (@var{func}, @var{line}, @dots{})\n\ + Set a breakpoint in a function\n\ + @table @code\n\ + @item func\n\ + String representing the function name. When already in debug\n\ + mode this should be left out and only the line should be given.\n\ + @item line\n\ + Line you would like the breakpoint to be set on. Multiple\n\ + lines might be given as separate arguments or as a vector.\n\ + @end table\n\ + \n\ + The rline returned is the real line that the breakpoint was set at.\n\ + @seealso{dbclear, dbstatus, dbnext}\n\ + @end deftypefn") + { + bp_table::intmap retval; + std::string symbol_name; + bp_table::intmap lines; + + parse_dbfunction_params (args, symbol_name, lines); + + if (! error_state) + retval = bp_table::add_breakpoint (symbol_name, lines); + + return intmap_to_ov (retval); + } + DEFCMD (dbclear, args, , "-*- texinfo -*-\n\ ! @deftypefn {Loadable Function} {} dbclear (@var{func}, @var{line}, @dots{})\n\ Delete a breakpoint in a function\n\ @table @code\n\ @item func\n\ *************** *** 197,260 **** @end deftypefn") { octave_value retval; - int nargin = args.length (); - int idx = 0; std::string symbol_name = ""; ! if (nargin != 1 && args(0).is_string()) ! { ! symbol_name = args(0).string_value (); ! idx = 1; ! } ! ! octave_user_function *dbg_fcn = get_user_function (symbol_name); ! ! if (dbg_fcn) ! { ! tree_statement_list *cmds = dbg_fcn->body (); ! ! for (int i = idx; i < nargin; i++) ! { ! if (args(i).is_string ()) ! { ! int line = atoi (args(i).string_value ().c_str ()); ! ! if (error_state) ! break; ! ! cmds->delete_breakpoint (line); ! } ! else ! { ! const NDArray arg = args(i).array_value (); ! ! if (error_state) ! break; ! ! for (octave_idx_type j = 0; j < arg.nelem (); j++) ! { ! int line = static_cast (arg.elem (j)); ! ! if (error_state) ! break; ! ! cmds->delete_breakpoint (line); ! } ! ! if (error_state) ! break; ! } ! } ! } ! else ! error ("dbclear: unable to find the function requested\n"); return retval; } ! DEFCMD (dbstatus, args, , "-*- texinfo -*-\n\ ! @deftypefn {Loadable Function} {lst =} dbstatus ([func])\n\ Return a vector containing the lines on which a function has \n\ breakpoints set.\n\ @table @code\n\ --- 384,403 ---- @end deftypefn") { octave_value retval; std::string symbol_name = ""; + bp_table::intmap lines; ! parse_dbfunction_params (args, symbol_name, lines); ! ! if (! error_state) ! bp_table::remove_breakpoint (symbol_name, lines); return retval; } ! DEFCMD (dbstatus, args, nargout, "-*- texinfo -*-\n\ ! @deftypefn {Loadable Function} {lst =} dbstatus (@var{func})\n\ Return a vector containing the lines on which a function has \n\ breakpoints set.\n\ @table @code\n\ *************** *** 265,314 **** @seealso{dbclear, dbwhere}\n\ @end deftypefn") { ! octave_value retval; ! int nargin = args.length (); if (nargin != 0 && nargin != 1) { error ("dbstatus: only zero or one arguements accepted\n"); ! return retval; } - std::string symbol_name = ""; - if (nargin == 1) { if (args(0).is_string ()) ! symbol_name = args(0).string_value (); else gripe_wrong_type_arg ("dbstatus", args(0)); } ! octave_user_function *dbg_fcn = get_user_function (symbol_name); ! if (dbg_fcn) { ! tree_statement_list *cmds = dbg_fcn->body (); ! octave_value_list lst = cmds->list_breakpoints (); ! RowVector vec (lst.length (), 0.0); ! for (int i = 0; i < lst.length (); i++) ! { ! vec(i) = lst(i).double_value (); ! if (error_state) ! panic_impossible (); ! } ! retval = octave_value (vec); } else ! error ("dbstatus: unable to find the function you requested\n"); ! return retval; } DEFCMD (dbwhere, , , --- 408,493 ---- @seealso{dbclear, dbwhere}\n\ @end deftypefn") { ! Octave_map retval; int nargin = args.length (); + octave_value_list fcn_list; + bp_table::fname_line_map bp_list; + std::string symbol_name; if (nargin != 0 && nargin != 1) { error ("dbstatus: only zero or one arguements accepted\n"); ! return octave_value (); } if (nargin == 1) { if (args(0).is_string ()) ! { ! symbol_name = args(0).string_value (); ! fcn_list(0) = symbol_name; ! bp_list = bp_table::get_breakpoint_list (fcn_list); ! } else gripe_wrong_type_arg ("dbstatus", args(0)); } + else + { + octave_user_function *dbg_fcn = get_user_function (); + if (dbg_fcn) + { + symbol_name = dbg_fcn->name (); + fcn_list(0) = symbol_name; + } ! bp_list = bp_table::get_breakpoint_list (fcn_list); ! } ! if (nargout == 0) { ! // Print out the breakpoint information. ! for (bp_table::fname_line_map_iterator it = bp_list.begin (); ! it != bp_list.end (); it++) ! { ! octave_stdout << "Breakpoint in " << it->first << " at line(s) "; ! bp_table::intmap m = it->second; ! size_t nel = m.size (); ! for (size_t j = 0; j < nel; j++) ! octave_stdout << m[j] << ((j < nel - 1) ? ", " : "."); ! if (nel > 0) ! octave_stdout << std::endl; ! } ! return octave_value (); } else ! { ! // Fill in an array for return. ! int i = 0; ! Cell names (dim_vector (bp_list.size (), 1)); ! Cell file (dim_vector (bp_list.size (), 1)); ! Cell line (dim_vector (bp_list.size (), 1)); ! ! for (bp_table::const_fname_line_map_iterator it = bp_list.begin (); ! it != bp_list.end (); it++) ! { ! names(i) = it->first; ! line(i) = intmap_to_ov (it->second); ! file(i) = do_which (it->first); ! i++; ! } ! ! retval.assign ("name", names); ! retval.assign ("file", file); ! retval.assign ("line", line); ! ! return octave_value (retval); ! } } DEFCMD (dbwhere, , , *************** *** 332,342 **** if (dbg_stmt) { ! octave_stdout << "line " << dbg_stmt->line () << ", "; octave_stdout << "column " << dbg_stmt->column () << std::endl; } else ! octave_stdout << "-1\n"; } else error ("dbwhere: must be inside of a user function to use dbwhere\n"); --- 511,521 ---- if (dbg_stmt) { ! octave_stdout << " line " << dbg_stmt->line () << ", "; octave_stdout << "column " << dbg_stmt->column () << std::endl; } else ! octave_stdout << " (unknown line)\n"; } else error ("dbwhere: must be inside of a user function to use dbwhere\n"); *************** *** 420,426 **** do_dbtype (octave_stdout, dbg_fcn->name (), 0, INT_MAX); else { ! dbg_fcn = get_user_function (""); if (dbg_fcn) { --- 599,605 ---- do_dbtype (octave_stdout, dbg_fcn->name (), 0, INT_MAX); else { ! dbg_fcn = get_user_function (); if (dbg_fcn) { diff -cNr octave-2.9.15/src/debug.h octave-2.9.16/src/debug.h *** octave-2.9.15/src/debug.h Wed Dec 31 19:00:00 1969 --- octave-2.9.16/src/debug.h Wed Oct 31 10:52:08 2007 *************** *** 0 **** --- 1,141 ---- + /* + + Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007 Ben Sapp + + 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 + . + + */ + + #if !defined (octave_debug_h) + #define octave_debug_h 1 + + #include + #include "ov.h" + #include "dRowVector.h" + + class octave_value_list; + class octave_user_function; + + // Interface to breakpoints,. + + class bp_table + { + private: + + bp_table (void) { } + + ~bp_table (void) { } + + public: + + typedef std::map intmap; + + typedef intmap::const_iterator const_intmap_iterator; + typedef intmap::iterator intmap_iterator; + + typedef std::map fname_line_map; + + typedef fname_line_map::const_iterator const_fname_line_map_iterator; + typedef fname_line_map::iterator fname_line_map_iterator; + + static bool instance_ok (void) + { + bool retval = true; + + if (! instance) + instance = new bp_table (); + + if (! instance) + { + ::error ("unable to create breakpoint table!"); + retval = false; + } + + return retval; + } + + // Add a breakpoint at the nearest executable line. + static intmap add_breakpoint (const std::string& fname = "", + const intmap& lines = intmap ()) + { + return instance_ok () + ? instance->do_add_breakpoint (fname, lines) : intmap (); + } + + // Remove a breakpoint from a line in file. + static int remove_breakpoint (const std::string& fname = "", + const intmap& lines = intmap ()) + { + return instance_ok () + ? instance->do_remove_breakpoint (fname, lines) : 0; + } + + // Remove all the breakpoints in a specified file. + static intmap remove_all_breakpoints_in_file (const std::string& fname) + { + return instance_ok () + ? instance->do_remove_all_breakpoints_in_file (fname) : intmap (); + } + + // Remove all the breakpoints registered with octave. + static void remove_all_breakpoints (void) + { + if (instance_ok ()) + instance->do_remove_all_breakpoints (); + } + + // Return all breakpoints. Each element of the map is a vector + // containing the breakpoints corresponding to a given function name. + static fname_line_map + get_breakpoint_list (const octave_value_list& fname_list) + { + return instance_ok () + ? instance->do_get_breakpoint_list (fname_list) : fname_line_map (); + } + + private: + + // Map from function names to function objects for functions + // containing at least one breakpoint. + typedef std::map breakpoint_map; + + typedef breakpoint_map::const_iterator const_breakpoint_map_iterator; + typedef breakpoint_map::iterator breakpoint_map_iterator; + + breakpoint_map bp_map; + + static bp_table *instance; + + intmap do_add_breakpoint (const std::string& fname, const intmap& lines); + + int do_remove_breakpoint (const std::string&, const intmap& lines); + + intmap do_remove_all_breakpoints_in_file (const std::string& fname); + + void do_remove_all_breakpoints (void); + + fname_line_map do_get_breakpoint_list (const octave_value_list& fname_list); + + }; + + #endif + + /* + ;;; Local Variables: *** + ;;; mode: C++ *** + ;;; End: *** + */ diff -cNr octave-2.9.15/src/error.cc octave-2.9.16/src/error.cc *** octave-2.9.15/src/error.cc Fri Oct 12 17:27:29 2007 --- octave-2.9.16/src/error.cc Mon Oct 15 11:30:05 2007 *************** *** 984,990 **** calling the function @code{f} will result in a list of messages that\n\ can help you to quickly locate the exact location of the error:\n\ \n\ ! @example\n\ @group\n\ f ()\n\ error: nargin != 1\n\ --- 984,990 ---- calling the function @code{f} will result in a list of messages that\n\ can help you to quickly locate the exact location of the error:\n\ \n\ ! @smallexample\n\ @group\n\ f ()\n\ error: nargin != 1\n\ *************** *** 994,1000 **** error: called from `g'\n\ error: called from `f'\n\ @end group\n\ ! @end example\n\ \n\ If the error message ends in a new line character, Octave will print the\n\ message but will not display any traceback messages as it returns\n\ --- 994,1000 ---- error: called from `g'\n\ error: called from `f'\n\ @end group\n\ ! @end smallexample\n\ \n\ If the error message ends in a new line character, Octave will print the\n\ message but will not display any traceback messages as it returns\n\ diff -cNr octave-2.9.15/src/file-io.cc octave-2.9.16/src/file-io.cc *** octave-2.9.15/src/file-io.cc Fri Oct 12 17:27:29 2007 --- octave-2.9.16/src/file-io.cc Tue Oct 30 10:05:00 2007 *************** *** 144,150 **** std::string mode = mode_arg; ! size_t pos = mode.find ('z'); if (pos != NPOS) { --- 144,170 ---- std::string mode = mode_arg; ! // 'W' and 'R' are accepted as 'w' and 'r', but we warn about ! // them because Matlab says they perform "automatic flushing" ! // but we don't know precisely what action that implies. ! ! size_t pos = mode.find ('W'); ! ! if (pos != NPOS) ! { ! warning ("fopen: treating mode \"W\" as equivalent to \"w\""); ! mode[pos] = 'w'; ! } ! ! pos = mode.find ('R'); ! ! if (pos != NPOS) ! { ! warning ("fopen: treating mode \"R\" as equivalent to \"r\""); ! mode[pos] = 'r'; ! } ! ! pos = mode.find ('z'); if (pos != NPOS) { diff -cNr octave-2.9.15/src/graphics.cc octave-2.9.16/src/graphics.cc *** octave-2.9.15/src/graphics.cc Sat Oct 13 01:13:29 2007 --- octave-2.9.16/src/graphics.cc Wed Oct 31 13:11:49 2007 *************** *** 461,467 **** void gh_manager::do_free (const graphics_handle& h) { ! if (h) { if (h.value () != 0) { --- 461,467 ---- void gh_manager::do_free (const graphics_handle& h) { ! if (h.ok ()) { if (h.value () != 0) { *************** *** 523,529 **** { h = gh_manager::lookup (val); ! if (h) { graphics_object obj = gh_manager::get_object (h); --- 523,529 ---- { h = gh_manager::lookup (val); ! if (h.ok ()) { graphics_object obj = gh_manager::get_object (h); *************** *** 576,581 **** --- 576,587 ---- } static bool + is_handle (const graphics_handle& h) + { + return h.ok (); + } + + static bool is_handle (double val) { graphics_handle h = gh_manager::lookup (val); *************** *** 709,715 **** { new_parent = gh_manager::lookup (tmp); ! if (new_parent) { graphics_object parent_obj = gh_manager::get_object (parent); --- 715,721 ---- { new_parent = gh_manager::lookup (tmp); ! if (new_parent.ok ()) { graphics_object parent_obj = gh_manager::get_object (parent); *************** *** 756,762 **** if (error_state) return; ! if (is_handle (val)) { currentfigure = val; --- 762,768 ---- if (error_state) return; ! if (xisnan (val.value ()) || is_handle (val)) { currentfigure = val; *************** *** 836,842 **** if (error_state) return; ! if (is_handle (val)) currentaxes = val; else gripe_set_invalid ("currentaxes"); --- 842,848 ---- if (error_state) return; ! if (xisnan (val.value ()) || is_handle (val)) currentaxes = val; else gripe_set_invalid ("currentaxes"); *************** *** 1233,1239 **** else if (name.compare ("xtick")) set_xtick (val); else if (name.compare ("ytick")) ! set_xtick (val); else if (name.compare ("ztick")) set_ztick (val); else if (name.compare ("xtickmode")) --- 1239,1245 ---- else if (name.compare ("xtick")) set_xtick (val); else if (name.compare ("ytick")) ! set_ytick (val); else if (name.compare ("ztick")) set_ztick (val); else if (name.compare ("xtickmode")) *************** *** 1374,1380 **** graphics_handle axes::properties::get_title (void) const { ! if (! title) title = gh_manager::make_graphics_handle ("text", __myhandle__); return title; --- 1380,1386 ---- graphics_handle axes::properties::get_title (void) const { ! if (! title.ok ()) title = gh_manager::make_graphics_handle ("text", __myhandle__); return title; *************** *** 1383,1389 **** graphics_handle axes::properties::get_xlabel (void) const { ! if (! xlabel) xlabel = gh_manager::make_graphics_handle ("text", __myhandle__); return xlabel; --- 1389,1395 ---- graphics_handle axes::properties::get_xlabel (void) const { ! if (! xlabel.ok ()) xlabel = gh_manager::make_graphics_handle ("text", __myhandle__); return xlabel; *************** *** 1392,1398 **** graphics_handle axes::properties::get_ylabel (void) const { ! if (! ylabel) ylabel = gh_manager::make_graphics_handle ("text", __myhandle__); return ylabel; --- 1398,1404 ---- graphics_handle axes::properties::get_ylabel (void) const { ! if (! ylabel.ok ()) ylabel = gh_manager::make_graphics_handle ("text", __myhandle__); return ylabel; *************** *** 1401,1407 **** graphics_handle axes::properties::get_zlabel (void) const { ! if (! zlabel) zlabel = gh_manager::make_graphics_handle ("text", __myhandle__); return zlabel; --- 1407,1413 ---- graphics_handle axes::properties::get_zlabel (void) const { ! if (! zlabel.ok ()) zlabel = gh_manager::make_graphics_handle ("text", __myhandle__); return zlabel; *************** *** 1592,1604 **** void axes::properties::remove_child (const graphics_handle& h) { ! if (title && h == title) title = gh_manager::make_graphics_handle ("text", __myhandle__); ! else if (xlabel && h == xlabel) xlabel = gh_manager::make_graphics_handle ("text", __myhandle__); ! else if (ylabel && h == ylabel) ylabel = gh_manager::make_graphics_handle ("text", __myhandle__); ! else if (zlabel && h == zlabel) zlabel = gh_manager::make_graphics_handle ("text", __myhandle__); else base_properties::remove_child (h); --- 1598,1610 ---- void axes::properties::remove_child (const graphics_handle& h) { ! if (title.ok () && h == title) title = gh_manager::make_graphics_handle ("text", __myhandle__); ! else if (xlabel.ok () && h == xlabel) xlabel = gh_manager::make_graphics_handle ("text", __myhandle__); ! else if (ylabel.ok () && h == ylabel) ylabel = gh_manager::make_graphics_handle ("text", __myhandle__); ! else if (zlabel.ok () && h == zlabel) zlabel = gh_manager::make_graphics_handle ("text", __myhandle__); else base_properties::remove_child (h); *************** *** 1819,1825 **** m.assign ("linewidth", linewidth); m.assign ("marker", marker); m.assign ("markeredgecolor", markeredgecolor); ! m.assign ("markerface", markerfacecolor); m.assign ("markersize", markersize); m.assign ("keylabel", keylabel); --- 1825,1831 ---- m.assign ("linewidth", linewidth); m.assign ("marker", marker); m.assign ("markeredgecolor", markeredgecolor); ! m.assign ("markerfacecolor", markerfacecolor); m.assign ("markersize", markersize); m.assign ("keylabel", keylabel); *************** *** 2651,2657 **** { graphics_handle parent = gh_manager::lookup (val); ! if (parent) { graphics_handle h = gh_manager::make_graphics_handle (go_name, parent); --- 2657,2663 ---- { graphics_handle parent = gh_manager::lookup (val); ! if (parent.ok ()) { graphics_handle h = gh_manager::make_graphics_handle (go_name, parent); *************** *** 2710,2716 **** else error ("__go_figure__: invalid figure number"); ! if (! error_state && h) { adopt (0, h); --- 2716,2722 ---- else error ("__go_figure__: invalid figure number"); ! if (! error_state && h.ok ()) { adopt (0, h); *************** *** 2813,2819 **** { h = gh_manager::lookup (val); ! if (h) { graphics_object obj = gh_manager::get_object (h); --- 2819,2825 ---- { h = gh_manager::lookup (val); ! if (h.ok ()) { graphics_object obj = gh_manager::get_object (h); *************** *** 2867,2873 **** { h = gh_manager::lookup (val); ! if (h) { graphics_object obj = gh_manager::get_object (h); --- 2873,2879 ---- { h = gh_manager::lookup (val); ! if (h.ok ()) { graphics_object obj = gh_manager::get_object (h); diff -cNr octave-2.9.15/src/graphics.h octave-2.9.16/src/graphics.h *** octave-2.9.15/src/graphics.h Sat Oct 13 10:49:37 2007 --- octave-2.9.16/src/graphics.h Wed Oct 31 17:44:18 2007 *************** *** 466,473 **** ~graphics_handle (void) { } - operator double (void) const { return val; } - double value (void) const { return val; } octave_value as_octave_value (void) const --- 466,471 ---- *************** *** 503,510 **** bool ok (void) const { return ! xisnan (val); } - operator bool () const { return ok (); } - private: double val; }; --- 501,506 ---- *************** *** 581,587 **** { octave_idx_type n = children.numel (); children.resize (1, n+1); ! children(n) = h; } void set_parent (const octave_value& val); --- 577,583 ---- { octave_idx_type n = children.numel (); children.resize (1, n+1); ! children(n) = h.value (); } void set_parent (const octave_value& val); *************** *** 2966,2972 **** Matrix retval (1, handle_map.size ()); octave_idx_type i = 0; for (const_iterator p = handle_map.begin (); p != handle_map.end (); p++) ! retval(i++) = p->first; return retval; } --- 2962,2971 ---- Matrix retval (1, handle_map.size ()); octave_idx_type i = 0; for (const_iterator p = handle_map.begin (); p != handle_map.end (); p++) ! { ! graphics_handle h = p->first; ! retval(i++) = h.value (); ! } return retval; } *************** *** 2977,2983 **** for (const_figure_list_iterator p = figure_list.begin (); p != figure_list.end (); p++) ! retval(i++) = *p; return retval; } --- 2976,2985 ---- for (const_figure_list_iterator p = figure_list.begin (); p != figure_list.end (); p++) ! { ! graphics_handle h = *p; ! retval(i++) = h.value (); ! } return retval; } diff -cNr octave-2.9.15/src/graphics.h.in octave-2.9.16/src/graphics.h.in *** octave-2.9.15/src/graphics.h.in Sat Oct 13 01:13:29 2007 --- octave-2.9.16/src/graphics.h.in Tue Oct 23 20:32:44 2007 *************** *** 464,471 **** ~graphics_handle (void) { } - operator double (void) const { return val; } - double value (void) const { return val; } octave_value as_octave_value (void) const --- 464,469 ---- *************** *** 501,508 **** bool ok (void) const { return ! xisnan (val); } - operator bool () const { return ok (); } - private: double val; }; --- 499,504 ---- *************** *** 579,585 **** { octave_idx_type n = children.numel (); children.resize (1, n+1); ! children(n) = h; } void set_parent (const octave_value& val); --- 575,581 ---- { octave_idx_type n = children.numel (); children.resize (1, n+1); ! children(n) = h.value (); } void set_parent (const octave_value& val); *************** *** 1913,1919 **** Matrix retval (1, handle_map.size ()); octave_idx_type i = 0; for (const_iterator p = handle_map.begin (); p != handle_map.end (); p++) ! retval(i++) = p->first; return retval; } --- 1909,1918 ---- Matrix retval (1, handle_map.size ()); octave_idx_type i = 0; for (const_iterator p = handle_map.begin (); p != handle_map.end (); p++) ! { ! graphics_handle h = p->first; ! retval(i++) = h.value (); ! } return retval; } *************** *** 1924,1930 **** for (const_figure_list_iterator p = figure_list.begin (); p != figure_list.end (); p++) ! retval(i++) = *p; return retval; } --- 1923,1932 ---- for (const_figure_list_iterator p = figure_list.begin (); p != figure_list.end (); p++) ! { ! graphics_handle h = *p; ! retval(i++) = h.value (); ! } return retval; } diff -cNr octave-2.9.15/src/help.cc octave-2.9.16/src/help.cc *** octave-2.9.15/src/help.cc Fri Oct 12 17:27:30 2007 --- octave-2.9.16/src/help.cc Tue Oct 30 21:24:12 2007 *************** *** 1295,1301 **** return retval; } ! static std::string do_which (const std::string& name) { std::string retval; --- 1295,1301 ---- return retval; } ! std::string do_which (const std::string& name) { std::string retval; *************** *** 1769,1775 **** if (nargin != 1 && nargin != 2) { ! usage ("lookfor"); return retval; } --- 1769,1775 ---- if (nargin != 1 && nargin != 2) { ! print_usage (); return retval; } diff -cNr octave-2.9.15/src/help.h octave-2.9.16/src/help.h *** octave-2.9.15/src/help.h Fri Oct 12 17:27:30 2007 --- octave-2.9.16/src/help.h Tue Oct 30 21:24:12 2007 *************** *** 49,54 **** --- 49,56 ---- // (--info-program program) extern std::string Vinfo_program; + extern std::string do_which (const std::string& name); + #endif /* diff -cNr octave-2.9.15/src/load-save.cc octave-2.9.16/src/load-save.cc *** octave-2.9.15/src/load-save.cc Fri Oct 12 17:27:30 2007 --- octave-2.9.16/src/load-save.cc Mon Oct 15 11:30:05 2007 *************** *** 1853,1861 **** the header comment is omitted from text-format data files. The\n\ default value is\n\ \n\ ! @example\n\ \"# Created by Octave VERSION, %a %b %d %H:%M:%S %Y %Z \"\n\ ! @end example\n\ @seealso{strftime}\n\ @end deftypefn") { --- 1853,1861 ---- the header comment is omitted from text-format data files. The\n\ default value is\n\ \n\ ! @smallexample\n\ \"# Created by Octave VERSION, %a %b %d %H:%M:%S %Y %Z \"\n\ ! @end smallexample\n\ @seealso{strftime}\n\ @end deftypefn") { diff -cNr octave-2.9.15/src/mxarray.h octave-2.9.16/src/mxarray.h *** octave-2.9.15/src/mxarray.h Sat Oct 13 10:37:46 2007 --- octave-2.9.16/src/mxarray.h Wed Oct 31 17:31:20 2007 *************** *** 71,77 **** mxUINT32_CLASS, mxINT64_CLASS, mxUINT64_CLASS, ! mxFUNCTION_CLASS, } mxClassID; --- 71,77 ---- mxUINT32_CLASS, mxINT64_CLASS, mxUINT64_CLASS, ! mxFUNCTION_CLASS } mxClassID; diff -cNr octave-2.9.15/src/mxarray.h.in octave-2.9.16/src/mxarray.h.in *** octave-2.9.15/src/mxarray.h.in Fri Oct 12 17:27:30 2007 --- octave-2.9.16/src/mxarray.h.in Tue Oct 23 20:32:44 2007 *************** *** 71,77 **** mxUINT32_CLASS, mxINT64_CLASS, mxUINT64_CLASS, ! mxFUNCTION_CLASS, } mxClassID; --- 71,77 ---- mxUINT32_CLASS, mxINT64_CLASS, mxUINT64_CLASS, ! mxFUNCTION_CLASS } mxClassID; diff -cNr octave-2.9.15/src/oct-map.cc octave-2.9.16/src/oct-map.cc *** octave-2.9.15/src/oct-map.cc Fri Oct 12 17:27:30 2007 --- octave-2.9.16/src/oct-map.cc Mon Oct 22 08:12:20 2007 *************** *** 49,54 **** --- 49,90 ---- error ("Octave_map: expecting keys to be cellstr"); } + Octave_map + Octave_map::squeeze (void) const + { + Octave_map retval (dims ().squeeze ()); + + for (const_iterator pa = begin (); pa != end (); pa++) + { + Cell tmp = contents (pa).squeeze (); + + if (error_state) + break; + + retval.assign (key (pa), tmp); + } + + return retval; + } + + Octave_map + Octave_map::permute (const Array& vec, bool inv) const + { + Octave_map retval (dims ()); + + for (const_iterator pa = begin (); pa != end (); pa++) + { + Cell tmp = contents (pa).permute (vec, inv); + + if (error_state) + break; + + retval.assign (key (pa), tmp); + } + + return retval; + } + Cell& Octave_map::contents (const std::string& k) { *************** *** 422,436 **** } Octave_map ! Octave_map::index (const octave_value_list& idx) { Octave_map retval; if (idx.length () > 0) { ! for (iterator p = begin (); p != end (); p++) { ! Cell tmp = contents(p).index (idx); if (error_state) break; --- 458,472 ---- } Octave_map ! Octave_map::index (const octave_value_list& idx, bool resize_ok) const { Octave_map retval; if (idx.length () > 0) { ! for (const_iterator p = begin (); p != end (); p++) { ! Cell tmp = contents(p).index (idx, resize_ok); if (error_state) break; *************** *** 444,449 **** --- 480,541 ---- return retval; } + Octave_map + Octave_map::index (idx_vector& i, int resize_ok, const octave_value& rfv) const + { + Octave_map retval (dims ()); + + for (const_iterator p = begin (); p != end (); p++) + { + Cell tmp = contents (p).index (i, resize_ok, rfv); + + if (error_state) + break; + + retval.assign (key (p), tmp); + } + + return retval; + } + + Octave_map + Octave_map::index (idx_vector& i, idx_vector& j, int resize_ok, + const octave_value& rfv) const + { + Octave_map retval (dims ()); + + for (const_iterator p = begin (); p != end (); p++) + { + Cell tmp = contents (p).index (i, j, resize_ok, rfv); + + if (error_state) + break; + + retval.assign (key (p), tmp); + } + + return retval; + } + + Octave_map + Octave_map::index (Array& ra_idx, int resize_ok, + const octave_value& rfv) const + { + Octave_map retval (dims ()); + + for (const_iterator p = begin (); p != end (); p++) + { + Cell tmp = contents (p).index (ra_idx, resize_ok, rfv); + + if (error_state) + break; + + retval.assign (key (p), tmp); + } + + return retval; + } + /* ;;; Local Variables: *** ;;; mode: C++ *** diff -cNr octave-2.9.15/src/oct-map.h octave-2.9.16/src/oct-map.h *** octave-2.9.15/src/oct-map.h Fri Oct 12 17:27:31 2007 --- octave-2.9.16/src/oct-map.h Mon Oct 22 08:12:20 2007 *************** *** 87,92 **** --- 87,96 ---- ~Octave_map (void) { } + Octave_map squeeze (void) const; + + Octave_map permute (const Array& vec, bool inv = false) const; + // This is the number of keys. octave_idx_type nfields (void) const { return map.size (); } *************** *** 172,178 **** Octave_map& assign (const std::string& k, const Cell& rhs); ! Octave_map index (const octave_value_list& idx); private: --- 176,192 ---- Octave_map& assign (const std::string& k, const Cell& rhs); ! Octave_map index (const octave_value_list& idx, ! bool resize_ok = false) const; ! ! Octave_map index (idx_vector& i, int resize_ok = 0, ! const octave_value& rfv = Cell::resize_fill_value ()) const; ! ! Octave_map index (idx_vector& i, idx_vector& j, int resize_ok = 0, ! const octave_value& rfv = Cell::resize_fill_value ()) const; ! ! Octave_map index (Array& ra_idx, int resize_ok = 0, ! const octave_value& rfv = Cell::resize_fill_value ()) const; private: diff -cNr octave-2.9.15/src/ov-base.h octave-2.9.16/src/ov-base.h *** octave-2.9.15/src/ov-base.h Fri Oct 12 17:27:31 2007 --- octave-2.9.16/src/ov-base.h Thu Oct 25 02:57:17 2007 *************** *** 60,67 **** // T_ID is the type id of struct objects, set by register_type(). // T_NAME is the type name of struct objects. #define DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA \ ! DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA2() #define DECLARE_OV_BASE_TYPEID_FUNCTIONS_AND_DATA \ DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA2(virtual) --- 60,68 ---- // T_ID is the type id of struct objects, set by register_type(). // T_NAME is the type name of struct objects. + #define DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA \ ! DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA2 (OCTAVE_EMPTY_CPP_ARG) #define DECLARE_OV_BASE_TYPEID_FUNCTIONS_AND_DATA \ DECLARE_OV_TYPEID_FUNCTIONS_AND_DATA2(virtual) diff -cNr octave-2.9.15/src/ov-cell.cc octave-2.9.16/src/ov-cell.cc *** octave-2.9.15/src/ov-cell.cc Fri Oct 12 17:27:31 2007 --- octave-2.9.16/src/ov-cell.cc Fri Oct 19 14:24:19 2007 *************** *** 252,260 **** { Cell tmp_cell = Cell (t_rhs.list_value ()); ! // FIXME -- shouldn't care if the dimensions of the ! // RHS don't match the dimensions of the subscripted ! // LHS. octave_base_matrix::assign (i, tmp_cell); } --- 252,263 ---- { Cell tmp_cell = Cell (t_rhs.list_value ()); ! // The shape of the RHS is irrelevant, we just want ! // the number of elements to agree and to preserve the ! // shape of the left hand side of the assignment. ! ! if (numel () == tmp_cell.numel ()) ! tmp_cell = tmp_cell.reshape (dims ()); octave_base_matrix::assign (i, tmp_cell); } diff -cNr octave-2.9.15/src/ov-fcn-handle.cc octave-2.9.16/src/ov-fcn-handle.cc *** octave-2.9.15/src/ov-fcn-handle.cc Fri Oct 12 17:27:31 2007 --- octave-2.9.16/src/ov-fcn-handle.cc Thu Oct 25 01:50:55 2007 *************** *** 92,98 **** { std::string ff_nm = f->fcn_file_name (); ! time_t tp = f->time_parsed (); if (ff_nm.empty ()) { --- 92,99 ---- { std::string ff_nm = f->fcn_file_name (); ! octave_time ottp = f->time_parsed (); ! time_t tp = ottp.unix_time (); if (ff_nm.empty ()) { diff -cNr octave-2.9.15/src/ov-intx.h octave-2.9.16/src/ov-intx.h *** octave-2.9.15/src/ov-intx.h Fri Oct 12 17:27:32 2007 --- octave-2.9.16/src/ov-intx.h Wed Oct 24 17:09:44 2007 *************** *** 50,55 **** --- 50,58 ---- OCTAVE_VALUE_INT_MATRIX_T (const OCTAVE_INT_NDARRAY_T& nda) : octave_base_int_matrix (nda) { } + OCTAVE_VALUE_INT_MATRIX_T (const ArrayN& nda) + : octave_base_int_matrix (OCTAVE_INT_NDARRAY_T (nda)) { } + ~OCTAVE_VALUE_INT_MATRIX_T (void) { } octave_base_value *clone (void) const diff -cNr octave-2.9.15/src/ov-struct.cc octave-2.9.16/src/ov-struct.cc *** octave-2.9.15/src/ov-struct.cc Fri Oct 12 17:27:32 2007 --- octave-2.9.16/src/ov-struct.cc Mon Oct 22 08:12:20 2007 *************** *** 367,375 **** { Cell tmp_cell = Cell (t_rhs.list_value ()); ! // FIXME -- shouldn't care if the dimensions of the ! // RHS don't match the dimensions of the subscriped ! // LHS. map.assign (key, tmp_cell); } --- 367,378 ---- { Cell tmp_cell = Cell (t_rhs.list_value ()); ! // The shape of the RHS is irrelevant, we just want ! // the number of elements to agree and to preserve the ! // shape of the left hand side of the assignment. ! ! if (numel () == tmp_cell.numel ()) ! tmp_cell = tmp_cell.reshape (dims ()); map.assign (key, tmp_cell); } *************** *** 400,405 **** --- 403,470 ---- return retval; } + octave_value + octave_struct::do_index_op (const octave_value_list& idx, bool resize_ok) + { + octave_value retval; + + octave_idx_type n_idx = idx.length (); + + int nd = map.ndims (); + + switch (n_idx) + { + case 0: + retval = map; + break; + + case 1: + { + idx_vector i = idx (0).index_vector (); + + if (! error_state) + retval = map.index (i, resize_ok, Cell::resize_fill_value ()); + } + break; + + default: + { + if (n_idx == 2 && nd == 2) + { + idx_vector i = idx (0).index_vector (); + + if (! error_state) + { + idx_vector j = idx (1).index_vector (); + + if (! error_state) + retval = map.index (i, j, resize_ok, + Cell::resize_fill_value ()); + } + } + else + { + Array idx_vec (n_idx); + + for (octave_idx_type i = 0; i < n_idx; i++) + { + idx_vec(i) = idx(i).index_vector (); + + if (error_state) + break; + } + + if (! error_state) + retval = map.index (idx_vec, resize_ok, + Cell::resize_fill_value ()); + } + } + break; + } + + return retval; + } + size_t octave_struct::byte_size (void) const { *************** *** 829,835 **** \n\ @example\n\ @group\n\ ! A = cell2struct (@{'Peter', 'Hannah', 'Robert'; 185, 170, 168@},\n\ @{'Name','Height'@}, 1);\n\ A(1)\n\ @result{} ans =\n\ --- 894,901 ---- \n\ @example\n\ @group\n\ ! A = cell2struct (@{'Peter', 'Hannah', 'Robert';\n\ ! 185, 170, 168@},\n\ @{'Name','Height'@}, 1);\n\ A(1)\n\ @result{} ans =\n\ diff -cNr octave-2.9.15/src/ov-struct.h octave-2.9.16/src/ov-struct.h *** octave-2.9.15/src/ov-struct.h Fri Oct 12 17:27:32 2007 --- octave-2.9.16/src/ov-struct.h Mon Oct 22 08:12:20 2007 *************** *** 83,88 **** --- 83,96 ---- const std::list& idx, const octave_value& rhs); + octave_value squeeze (void) const { return map.squeeze (); } + + octave_value permute (const Array& vec, bool inv = false) const + { return map.permute (vec, inv); } + + octave_value do_index_op (const octave_value_list& idx, + bool resize_ok = false); + dim_vector dims (void) const { return map.dims (); } size_t byte_size (void) const; diff -cNr octave-2.9.15/src/ov.cc octave-2.9.16/src/ov.cc *** octave-2.9.15/src/ov.cc Fri Oct 12 17:27:32 2007 --- octave-2.9.16/src/ov.cc Thu Oct 25 01:50:55 2007 *************** *** 348,354 **** #endif octave_value::octave_value (octave_time t) ! : rep (new octave_scalar (t)) { } --- 348,354 ---- #endif octave_value::octave_value (octave_time t) ! : rep (new octave_scalar (t.double_value ())) { } *************** *** 612,659 **** --- 612,707 ---- maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_int8_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (const uint8NDArray& inda) : rep (new octave_uint8_matrix (inda)) { maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_uint8_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (const int16NDArray& inda) : rep (new octave_int16_matrix (inda)) { maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_int16_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (const uint16NDArray& inda) : rep (new octave_uint16_matrix (inda)) { maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_uint16_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (const int32NDArray& inda) : rep (new octave_int32_matrix (inda)) { maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_int32_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (const uint32NDArray& inda) : rep (new octave_uint32_matrix (inda)) { maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_uint32_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (const int64NDArray& inda) : rep (new octave_int64_matrix (inda)) { maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_int64_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (const uint64NDArray& inda) : rep (new octave_uint64_matrix (inda)) { maybe_mutate (); } + octave_value::octave_value (const ArrayN& inda) + : rep (new octave_uint64_matrix (inda)) + { + maybe_mutate (); + } + octave_value::octave_value (double base, double limit, double inc) : rep (new octave_range (base, limit, inc)) { diff -cNr octave-2.9.15/src/ov.h octave-2.9.16/src/ov.h *** octave-2.9.15/src/ov.h Fri Oct 12 17:27:32 2007 --- octave-2.9.16/src/ov.h Wed Oct 24 17:09:44 2007 *************** *** 207,219 **** --- 207,227 ---- octave_value (const octave_uint32& i); octave_value (const octave_uint64& i); octave_value (const int8NDArray& inda); + octave_value (const ArrayN& inda); octave_value (const int16NDArray& inda); + octave_value (const ArrayN& inda); octave_value (const int32NDArray& inda); + octave_value (const ArrayN& inda); octave_value (const int64NDArray& inda); + octave_value (const ArrayN& inda); octave_value (const uint8NDArray& inda); + octave_value (const ArrayN& inda); octave_value (const uint16NDArray& inda); + octave_value (const ArrayN& inda); octave_value (const uint32NDArray& inda); + octave_value (const ArrayN& inda); octave_value (const uint64NDArray& inda); + octave_value (const ArrayN& inda); octave_value (double base, double limit, double inc); octave_value (const Range& r); octave_value (const Octave_map& m); diff -cNr octave-2.9.15/src/pt-assign.h octave-2.9.16/src/pt-assign.h *** octave-2.9.15/src/pt-assign.h Fri Oct 12 17:27:33 2007 --- octave-2.9.16/src/pt-assign.h Wed Oct 31 15:08:18 2007 *************** *** 76,81 **** --- 76,83 ---- void accept (tree_walker& tw); + octave_value::assign_op op_type (void) const { return etype; } + private: void do_assign (octave_lvalue& ult, const octave_value_list& args, *************** *** 143,148 **** --- 145,152 ---- tree_expression *dup (symbol_table *sym_tab); void accept (tree_walker& tw); + + octave_value::assign_op op_type (void) const { return etype; } private: diff -cNr octave-2.9.15/src/pt-idx.cc octave-2.9.16/src/pt-idx.cc *** octave-2.9.15/src/pt-idx.cc Fri Oct 12 17:27:33 2007 --- octave-2.9.16/src/pt-idx.cc Wed Oct 24 00:39:57 2007 *************** *** 480,495 **** if (! error_state) { - idx.push_back (tidx); - if (i == n-1) { // Last indexing element. Will this result in a // comma-separated list? if (first_retval_object.is_map ()) ! retval.numel (first_retval_object.numel ()); } } else eval_error (); --- 480,532 ---- if (! error_state) { if (i == n-1) { // Last indexing element. Will this result in a // comma-separated list? if (first_retval_object.is_map ()) ! { ! if (i > 0) ! { ! octave_value_list xidx = idx.back (); ! ! if (xidx.has_magic_colon ()) ! { ! std::string ttype = type.substr (0, i); ! ! octave_value_list tmp_list ! = first_retval_object.subsref (ttype, idx, 1); ! ! if (! error_state) ! { ! octave_value val = tmp_list(0); ! ! retval.numel (val.numel ()); ! } ! } ! else ! { ! octave_idx_type nel = 1; ! ! octave_idx_type nidx = xidx.length (); ! ! for (octave_idx_type j = 0; j < nidx; j++) ! { ! octave_value val = xidx(j); ! ! nel *= val.numel (); ! } ! ! retval.numel (nel); ! } ! } ! else ! retval.numel (first_retval_object.numel ()); ! } } + + idx.push_back (octave_value (tidx)); } else eval_error (); diff -cNr octave-2.9.15/src/pt-unop.h octave-2.9.16/src/pt-unop.h *** octave-2.9.15/src/pt-unop.h Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/pt-unop.h Wed Oct 31 15:08:18 2007 *************** *** 58,63 **** --- 58,65 ---- tree_expression *operand (void) { return op; } std::string oper (void) const; + + octave_value::unary_op op_type (void) const { return etype; } protected: diff -cNr octave-2.9.15/src/symtab.cc octave-2.9.16/src/symtab.cc *** octave-2.9.15/src/symtab.cc Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/symtab.cc Tue Oct 30 21:08:16 2007 *************** *** 1967,1973 **** @end table\n\ \n\ A command is composed like this:\n\ ! %[modifier][:size_of_parameter[:center-specific[:print_dims[:balance]]]];\n\ \n\ Command and modifier is already explained. Size_of_parameter\n\ tells how many columns the parameter will need for printing.\n\ --- 1967,1977 ---- @end table\n\ \n\ A command is composed like this:\n\ ! \n\ ! @example\n\ ! %[modifier][:size_of_parameter[:center-specific[\n\ ! :print_dims[:balance]]]];\n\ ! @end example\n\ \n\ Command and modifier is already explained. Size_of_parameter\n\ tells how many columns the parameter will need for printing.\n\ diff -cNr octave-2.9.15/src/symtab.h octave-2.9.16/src/symtab.h *** octave-2.9.15/src/symtab.h Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/symtab.h Thu Oct 25 02:57:17 2007 *************** *** 76,82 **** COMMAND = 16, RAWCOMMAND = 32, MAPPER_FUNCTION = 64, ! MEX_FUNCTION = 128, }; private: --- 76,82 ---- COMMAND = 16, RAWCOMMAND = 32, MAPPER_FUNCTION = 64, ! MEX_FUNCTION = 128 }; private: *************** *** 499,505 **** { public: ! symbol_table (unsigned int tab_size = 128, const std::string& nm = std::string ()) : table_size (tab_size), table (new symbol_record [table_size]), table_name (nm) --- 499,505 ---- { public: ! symbol_table (unsigned int tab_size = 64, const std::string& nm = std::string ()) : table_size (tab_size), table (new symbol_record [table_size]), table_name (nm) diff -cNr octave-2.9.15/src/unwind-prot.cc octave-2.9.16/src/unwind-prot.cc *** octave-2.9.15/src/unwind-prot.cc Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/unwind-prot.cc Mon Oct 22 12:55:41 2007 *************** *** 26,31 **** --- 26,32 ---- #endif #include + #include #include "CMatrix.h" diff -cNr octave-2.9.15/src/variables.cc octave-2.9.16/src/variables.cc *** octave-2.9.15/src/variables.cc Fri Oct 12 17:27:34 2007 --- octave-2.9.16/src/variables.cc Thu Oct 25 01:50:55 2007 *************** *** 1008,1014 **** if (tc < Vlast_prompt_time || (relative && tc < Vlast_chdir_time)) { ! time_t tp = fcn->time_parsed (); std::string nm = fcn->is_nested_function () ? fcn->parent_fcn_name () : fcn->name (); --- 1008,1015 ---- if (tc < Vlast_prompt_time || (relative && tc < Vlast_chdir_time)) { ! octave_time ottp = fcn->time_parsed (); ! time_t tp = ottp.unix_time (); std::string nm = fcn->is_nested_function () ? fcn->parent_fcn_name () : fcn->name (); diff -cNr octave-2.9.15/src/version.h octave-2.9.16/src/version.h *** octave-2.9.15/src/version.h Sat Oct 13 10:34:07 2007 --- octave-2.9.16/src/version.h Wed Oct 31 17:29:24 2007 *************** *** 24,34 **** #if !defined (octave_version_h) #define octave_version_h 1 ! #define OCTAVE_VERSION "2.9.15" ! #define OCTAVE_API_VERSION "api-v27" ! #define OCTAVE_RELEASE_DATE "2007-10-13" #define OCTAVE_COPYRIGHT "Copyright (C) 2007 John W. Eaton and others." --- 24,34 ---- #if !defined (octave_version_h) #define octave_version_h 1 ! #define OCTAVE_VERSION "2.9.16" ! #define OCTAVE_API_VERSION "api-v28" ! #define OCTAVE_RELEASE_DATE "2007-10-31" #define OCTAVE_COPYRIGHT "Copyright (C) 2007 John W. Eaton and others." diff -cNr octave-2.9.15/test/ChangeLog octave-2.9.16/test/ChangeLog *** octave-2.9.15/test/ChangeLog Fri Oct 12 02:41:25 2007 --- octave-2.9.16/test/ChangeLog Tue Oct 30 15:52:50 2007 *************** *** 1,3 **** --- 1,12 ---- + 2007-10-30 Kim Hansen + + * build_sparse_tests.sh: Fix typo. + + 2007-10-23 John W. Eaton + + * build_sparse_tests.sh (gen_sparsesparse_elementop_tests): + Use xtest for "assert(as./bs,sparse(af./bf,true),100*eps);" test. + 2007-10-12 John W. Eaton * Change copyright notices in all files that are part of Octave to diff -cNr octave-2.9.15/test/build_sparse_tests.sh octave-2.9.16/test/build_sparse_tests.sh *** octave-2.9.15/test/build_sparse_tests.sh Fri Oct 12 21:42:21 2007 --- octave-2.9.16/test/build_sparse_tests.sh Tue Oct 30 15:52:50 2007 *************** *** 334,340 **** %!assert(as+bs,sparse(af+bf,true)) %!assert(as-bs,sparse(af-bf,true)) %!assert(as.*bs,sparse(af.*bf,true)) ! %!assert(as./bs,sparse(af./bf,true),100*eps); %!test %! sv = as.^bs; %! fv = af.^bf; --- 334,340 ---- %!assert(as+bs,sparse(af+bf,true)) %!assert(as-bs,sparse(af-bf,true)) %!assert(as.*bs,sparse(af.*bf,true)) ! %!xtest assert(as./bs,sparse(af./bf,true),100*eps); %!test %! sv = as.^bs; %! fv = af.^bf; *************** *** 908,914 **** %! bcf = bf + bf'; bcs = sparse(bcf); %! tcf = tf + tf'; tcs = sparse(tcf); %! xf = diag(1:n) + fliplr(diag(1:n)).*beta; xs = sparse(xf); ! %!assert(ds\xf,df\xf),1e-10; %!assert(ds\xs,sparse(df\xf,1),1e-10); %!assert(pds\xf,pdf\xf,1e-10); %!assert(pds\xs,sparse(pdf\xf,1),1e-10); --- 908,914 ---- %! bcf = bf + bf'; bcs = sparse(bcf); %! tcf = tf + tf'; tcs = sparse(tcf); %! xf = diag(1:n) + fliplr(diag(1:n)).*beta; xs = sparse(xf); ! %!assert(ds\xf,df\xf,1e-10); %!assert(ds\xs,sparse(df\xf,1),1e-10); %!assert(pds\xf,pdf\xf,1e-10); %!assert(pds\xs,sparse(pdf\xf,1),1e-10); PATCH_EOF