hmatrix 0.14.1.0 → 0.20.2
raw patch · 102 files changed
Files
- CHANGELOG +290/−0
- CHANGES.md +0/−161
- Config.hs +0/−155
- INSTALL.md +0/−111
- LICENSE +26/−2
- Setup.lhs +1/−14
- THANKS.md +122/−3
- examples/bool.hs +0/−54
- examples/data.txt +0/−10
- examples/deriv.hs +0/−8
- examples/devel/ej1/functions.c +0/−35
- examples/devel/ej1/wrappers.hs +0/−44
- examples/devel/ej2/functions.c +0/−24
- examples/devel/ej2/wrappers.hs +0/−32
- examples/error.hs +0/−21
- examples/fitting.hs +0/−24
- examples/inplace.hs +0/−152
- examples/integrate.hs +0/−17
- examples/kalman.hs +0/−51
- examples/lie.hs +0/−65
- examples/minimize.hs +0/−50
- examples/monadic.hs +0/−118
- examples/multiply.hs +0/−100
- examples/ode.hs +0/−50
- examples/parallel.hs +0/−28
- examples/pca1.hs +0/−46
- examples/pca2.hs +0/−65
- examples/pinv.hs +0/−20
- examples/plot.hs +0/−20
- examples/root.hs +0/−31
- examples/vector.hs +0/−31
- hmatrix.cabal +118/−156
- lib/Data/Packed.hs +0/−28
- lib/Data/Packed/Development.hs +0/−30
- lib/Data/Packed/Internal.hs +0/−26
- lib/Data/Packed/Internal/Common.hs +0/−167
- lib/Data/Packed/Internal/Matrix.hs +0/−461
- lib/Data/Packed/Internal/Signatures.hs +0/−72
- lib/Data/Packed/Internal/Vector.hs +0/−582
- lib/Data/Packed/Matrix.hs +0/−406
- lib/Data/Packed/Random.hs +0/−66
- lib/Data/Packed/ST.hs +0/−178
- lib/Data/Packed/Vector.hs +0/−90
- lib/Graphics/Plot.hs +0/−183
- lib/Numeric/Chain.hs +0/−140
- lib/Numeric/Container.hs +0/−134
- lib/Numeric/ContainerBoot.hs +0/−603
- lib/Numeric/Conversion.hs +0/−91
- lib/Numeric/GSL.hs +0/−43
- lib/Numeric/GSL/Differentiation.hs +0/−87
- lib/Numeric/GSL/Fitting.hs +0/−177
- lib/Numeric/GSL/Fourier.hs +0/−47
- lib/Numeric/GSL/Integration.hs +0/−198
- lib/Numeric/GSL/Internal.hs +0/−73
- lib/Numeric/GSL/Minimization.hs +0/−194
- lib/Numeric/GSL/ODE.hs +0/−136
- lib/Numeric/GSL/Polynomials.hs +0/−58
- lib/Numeric/GSL/Root.hs +0/−146
- lib/Numeric/GSL/Vector.hs +0/−327
- lib/Numeric/GSL/gsl-aux.c +0/−1336
- lib/Numeric/GSL/gsl-ode.c +0/−182
- lib/Numeric/IO.hs +0/−160
- lib/Numeric/LinearAlgebra.hs +0/−28
- lib/Numeric/LinearAlgebra/Algorithms.hs +0/−731
- lib/Numeric/LinearAlgebra/LAPACK.hs +0/−535
- lib/Numeric/LinearAlgebra/LAPACK/clapack.h +0/−5079
- lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c +0/−1344
- lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h +0/−131
- lib/Numeric/LinearAlgebra/Util.hs +0/−156
- lib/Numeric/LinearAlgebra/Util/Convolution.hs +0/−114
- lib/Numeric/Matrix.hs +0/−71
- lib/Numeric/Vector.hs +0/−185
- src/Internal/Algorithms.hs +1164/−0
- src/Internal/C/lapack-aux.c +2014/−0
- src/Internal/C/lapack-aux.h +111/−0
- src/Internal/C/vector-aux.c +1599/−0
- src/Internal/CG.hs +188/−0
- src/Internal/Chain.hs +150/−0
- src/Internal/Container.hs +302/−0
- src/Internal/Conversion.hs +93/−0
- src/Internal/Convolution.hs +161/−0
- src/Internal/Devel.hs +108/−0
- src/Internal/Element.hs +617/−0
- src/Internal/IO.hs +183/−0
- src/Internal/LAPACK.hs +758/−0
- src/Internal/Matrix.hs +721/−0
- src/Internal/Modular.hs +476/−0
- src/Internal/Numeric.hs +945/−0
- src/Internal/Random.hs +81/−0
- src/Internal/ST.hs +257/−0
- src/Internal/Sparse.hs +277/−0
- src/Internal/Static.hs +588/−0
- src/Internal/Util.hs +914/−0
- src/Internal/Vector.hs +468/−0
- src/Internal/Vectorized.hs +557/−0
- src/Numeric/LinearAlgebra.hs +269/−0
- src/Numeric/LinearAlgebra/Data.hs +121/−0
- src/Numeric/LinearAlgebra/Devel.hs +68/−0
- src/Numeric/LinearAlgebra/HMatrix.hs +36/−0
- src/Numeric/LinearAlgebra/Static.hs +912/−0
- src/Numeric/Matrix.hs +119/−0
- src/Numeric/Vector.hs +185/−0
+ CHANGELOG view
@@ -0,0 +1,290 @@+0.18.0.0+--------++ * Many new functions and instances in the Static module++ * meanCov and gaussianSample use Herm type++ * thinQR, thinRQ++ * compactSVDTol++ * unitary changed to normalize, also admits Vector (Complex Double)++0.17.0.0+--------++ * eigSH, chol, and other functions that work with Hermitian or symmetric matrices+ now take a special "Herm" argument that can be created by means of "sym"+ or "mTm". The unchecked versions of those functions have been removed and we+ use "trustSym" to create the Herm type when the matrix is known to be Hermitian/symmetric.++ * Improved matrix extraction (??) and rectangular matrix slices without data copy++ * Basic support of Int32 and Int64 elements++ * remap, more general cond, sortIndex++ * Experimental support of type safe modular arithmetic, including linear+ system solver and LU factorization++ * Elementary row operations and inplace matrix slice products in the ST monad++ * Improved development tools.++ * Old compatibility modules removed, simpler organization of internal modules++ * unitary, pairwiseD2, tr'++ * ldlPacked, ldlSolve for indefinite symmetric systems (apparently not faster+ than the general solver based on the LU)++ * LU, LDL, and QR types for these compact decompositions.++0.16.1.0+--------++ * Added (|||) and (===) for "besides" and "above"++ * rowOuters++0.16.0.0+--------++ * The modules Numeric.GSL.* have been moved to the new package hmatrix-gsl.++ * The package "hmatrix" now depends only on BLAS and LAPACK and the+ license has been changed to BSD3.++ * Added more organized reexport modules:+ Numeric.LinearAlgebra.HMatrix+ Numeric.LinearAlgebra.Data+ Numeric.LinearAlgebra.Devel++ For normal usage we only need to import Numeric.LinearAlgebra.HMatrix.++ (The documentation is now hidden for Data.Packed.*, Numeric.Container, and+ the other Numeric.LinearAlgebra.* modules, but they continue to be exposed+ for backwards compatibility.)++ * Added support for empty arrays, extending automatic conformability+ (very useful for construction of block matrices).++ * Added experimental support for sparse linear systems.++ * Added experimental support for static dimension checking and inference+ using type-level literals.++ * Added a different operator for the matrix-vector product.+ (available from the new reexport module).++ * "join" deprecated (use "vjoin").++ * "dot" now conjugates the first input vector.++ * Added "udot" (unconjugated dot product).++ * Added to/from ByteString++ * Added "sortVector", "roundVector"++ * Added Monoid instance for Matrix using matrix product.++ * Added several pretty print functions++ * Improved "build", "konst", "linspace", "LSDiv", loadMatrix', and other small changes.++ * In hmatrix-glpk: (:=>:) change to (:>=:). Added L_1 linear system solvers.++ * Improved error messages.++ * Added many usage examples in the documentation.+++0.15.2.0+--------++ * general pinvTol and improved pinv++0.15.1.0+--------++ * One-dimensional minimization++ * Doubly-adaptive quadrature for difficult integrands++0.15.0.0+--------++ * Data.Packed.Foreign (additional FFI helpers)++ * NFData instance of Matrix++ * Unidimensional root finding++ * In Numeric.LinearAlgebra.Util:+ pairwise2D, rowOuters, null1, null1sym, size, unitary, mt, (¦), (?), (¿)++ * diagBlock++ * meanCov moved to Container++0.14.1.0+--------++ * In Numeric.LinearAlgebra.Util:+ convolution: corr, conv, corr2, conv2, separable, corrMin+ kronecker: vec, vech, dup, vtrans++0.14.0.0+--------++ * integration over infinite intervals++ * msadams and msbdf methods for ode++ * Numeric.LinearAlgebra.Util++ * (<\>) extended to multiple right-hand sides++ * orth++0.13.0.0+--------++ * tests moved to new package hmatrix-tests++0.11.2.0+--------++ * geigSH' (symmetric generalized eigensystem)++ * mapVectorWithIndex++0.11.1.0+--------++ * exported Mul++ * mapMatrixWithIndex{,M,M_}++0.11.0.0+--------++ * flag -fvector default = True++ * invlndet (inverse and log of determinant)++ * step, cond++ * find++ * assoc, accum++0.10.0.0+--------++ * Module reorganization++ * Support for Float and Complex Float elements (excluding LAPACK computations)++ * Binary instances for Vector and Matrix++ * optimiseMult++ * mapVectorM, mapVectorWithIndexM, unzipVectorWith, and related functions.++ * diagRect admits diagonal vectors of any length without producing an error,+ and takes an additional argument for the off-diagonal elements.++ * different signatures in some functions++0.9.3.0+--------++ * flag -fvector to optionally use Data.Vector.Storable.Vector+ without any conversion.++ * Simpler module structure.++ * toBlocks, toBlocksEvery++ * cholSolve, mbCholSH++ * GSL Nonlinear Least-Squares fitting using Levenberg-Marquardt.++ * GSL special functions moved to separate package hmatrix-special.++ * Added offset of Vector, allowing fast, noncopy subVector (slice).+ Vector is now identical to Roman Leshchinskiy's Data.Vector.Storable.Vector,+ so we can convert from/to them in O(1).++ * Removed Data.Packed.Convert, see examples/vector.hs++0.8.3.0+--------++ * odeSolve++ * Matrix arithmetic automatically replicates matrix with single row/column++ * latexFormat, dispcf++0.8.2.0+--------++ * fromRows/fromColumns now automatically expand vectors of dim 1+ to match the common dimension.+ fromBlocks also replicates single row/column matrices.+ Previously all dimensions had to be exactly the same.++ * display utilities: dispf, disps, vecdisp++ * scalar++ * minimizeV, minimizeVD, using Vector instead of lists.++0.8.1.0+--------++ * runBenchmarks++0.8.0.0+--------++ * singularValues, fullSVD, thinSVD, compactSVD, leftSV, rightSV+ and complete interface to [d|z]gesdd.+ Algorithms based on the SVD of large matrices can now be+ significantly faster.++ * eigenvalues, eigenvaluesSH++ * linearSolveLS, rq++0.7.2.0+--------++ * ranksv++0.7.1.0+--------++ * buildVector/buildMatrix++ * removed NFData instances++0.6.0.0+--------++ * added randomVector, gaussianSample, uniformSample, meanCov++ * added rankSVD, nullspaceSVD++ * rank, nullspacePrec, and economy svd defined in terms of ranksvd.++ * economy svd now admits zero rank matrices and return a "degenerate+ rank 1" decomposition with zero singular value.++ * added NFData instances for Matrix and Vector.++ * liftVector, liftVector2 replaced by mapVector, zipVector.
− CHANGES.md
@@ -1,161 +0,0 @@-0.14.1.0------------ In Numeric.LinearAlgebra.Util:- convolution: corr, conv, corr2, conv2, separable, corrMin- kronecker: vec, vech, dup, vtrans--0.14.0.0------------ integration over infinite intervals--- msadams and msbdf methods for ode--- Numeric.LinearAlgebra.Util--- (<\>) extended to multiple right-hand sides--- orth--0.13.0.0------------ tests moved to new package hmatrix-tests--0.11.2.0------------ geigSH' (symmetric generalized eigensystem)--- mapVectorWithIndex---0.11.1.0------------ exported Mul--- mapMatrixWithIndex{,M,M_}--0.11.0.0------------ flag -fvector default = True--- invlndet (inverse and log of determinant)--- step, cond--- find--- assoc, accum--0.10.0.0------------ Module reorganization--- Support for Float and Complex Float elements (excluding LAPACK computations)--- Binary instances for Vector and Matrix--- optimiseMult--- mapVectorM, mapVectorWithIndexM, unzipVectorWith, and related functions.--- diagRect admits diagonal vectors of any length without producing an error,- and takes an additional argument for the off-diagonal elements.--- different signatures in some functions--0.9.3.0------------ flag -fvector to optionally use Data.Vector.Storable.Vector- without any conversion.--- Simpler module structure.--- toBlocks, toBlocksEvery--- cholSolve, mbCholSH--- GSL Nonlinear Least-Squares fitting using Levenberg-Marquardt.--- GSL special functions moved to separate package hmatrix-special.--- Added offset of Vector, allowing fast, noncopy subVector (slice).- Vector is now identical to Roman Leshchinskiy's Data.Vector.Storable.Vector,- so we can convert from/to them in O(1).--- Removed Data.Packed.Convert, see examples/vector.hs--0.8.3.0------------ odeSolve--- Matrix arithmetic automatically replicates matrix with single row/column--- latexFormat, dispcf--0.8.2.0------------ fromRows/fromColumns now automatically expand vectors of dim 1- to match the common dimension.- fromBlocks also replicates single row/column matrices.- Previously all dimensions had to be exactly the same.--- display utilities: dispf, disps, vecdisp--- scalar--- minimizeV, minimizeVD, using Vector instead of lists.--0.8.1.0------------ runBenchmarks--0.8.0.0------------ singularValues, fullSVD, thinSVD, compactSVD, leftSV, rightSV- and complete interface to [d|z]gesdd.- Algorithms based on the SVD of large matrices can now be- significantly faster.--- eigenvalues, eigenvaluesSH--- linearSolveLS, rq--0.7.2.0------------ ranksv--0.7.1.0------------ buildVector/buildMatrix--- removed NFData instances--0.6.0.0------------ added randomVector, gaussianSample, uniformSample, meanCov--- added rankSVD, nullspaceSVD--- rank, nullspacePrec, and economy svd defined in terms of ranksvd.--- economy svd now admits zero rank matrices and return a "degenerate- rank 1" decomposition with zero singular value.--- added NFData instances for Matrix and Vector.--- liftVector, liftVector2 replaced by mapVector, zipVector.-
− Config.hs
@@ -1,155 +0,0 @@-{-- GSL and LAPACK may require auxiliary libraries which depend on OS,- distribution, and implementation. This script tries to to find out- the correct link command for your system.- Suggestions and contributions are welcome.-- By default we try to link -lgsl -llapack. This works in ubuntu/debian,- both with and without ATLAS.- If this fails we try different sets of additional libraries which are- known to work in some systems.-- The desired libraries can also be explicitly given by the user using cabal- flags (e.g., -fmkl, -faccelerate) or --configure-option=link:lib1,lib2,lib3,...---}--module Config(config) where--import System.Process-import System.Exit-import System.Environment-import System.Directory(createDirectoryIfMissing)-import Data.List(isPrefixOf, intercalate)-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Configure-import Distribution.PackageDescription---- possible additional dependencies for the desired libs (by default gsl lapack)--opts = [ "" -- Ubuntu/Debian- , "blas"- , "blas cblas"- , "cblas"- , "gslcblas"- , "blas gslcblas"- , "f77blas"- , "f77blas cblas atlas gcc_s" -- Arch Linux (older version of atlas-lapack)- , "blas gslcblas gfortran" -- Arch Linux with normal blas and lapack- ]---- compile a simple program with symbols from GSL and LAPACK with the given libs-testprog bInfo buildInfo libs fmks =- "echo \"#include <gsl/gsl_sf_gamma.h>\nint main(){dgemm_(); zgesvd_(); gsl_sf_gamma(5);}\""- ++" > " ++ (buildDir bInfo) ++ "/dummy.c; gcc "- ++ (join $ ccOptions buildInfo) ++ " "- ++ (join $ cppOptions buildInfo) ++ " "- ++ (join $ map ("-I"++) $ includeDirs buildInfo) ++ " " - ++ (buildDir bInfo) ++ "/dummy.c -o "- ++ (buildDir bInfo) ++ "/dummy "- ++ (join $ map ("-L"++) $ extraLibDirs buildInfo) ++ " "- ++ (prepend "-l" $ libs) ++ " "- ++ (prepend "-framework " fmks) ++ " > /dev/null 2> /dev/null"--join = intercalate " "-prepend x = unwords . map (x++) . words--check bInfo buildInfo libs fmks = (ExitSuccess ==) `fmap` system (testprog bInfo buildInfo libs fmks)---- simple test for GSL-gsl bInfo buildInfo = "echo \"#include <gsl/gsl_sf_gamma.h>\nint main(){gsl_sf_gamma(5);}\""- ++" > " ++ (buildDir bInfo) ++ "/dummy.c; gcc "- ++ (join $ ccOptions buildInfo) ++ " "- ++ (join $ cppOptions buildInfo) ++ " "- ++ (join $ map ("-I"++) $ includeDirs buildInfo) ++ " " - ++ (buildDir bInfo) ++ "/dummy.c -o "- ++ (buildDir bInfo) ++ "/dummy "- ++ (join $ map ("-L"++) $ extraLibDirs buildInfo) ++ " -lgsl -lgslcblas"- ++ " > /dev/null 2> /dev/null"---- test for gsl >= 1.12-gsl112 bInfo buildInfo =- "echo \"#include <gsl/gsl_sf_exp.h>\nint main(){gsl_sf_exprel_n_CF_e(1,1,0);}\""- ++" > " ++ (buildDir bInfo) ++ "/dummy.c; gcc " - ++ (buildDir bInfo) ++ "/dummy.c "- ++ (join $ ccOptions buildInfo) ++ " "- ++ (join $ cppOptions buildInfo) ++ " "- ++ (join $ map ("-I"++) $ includeDirs buildInfo)- ++" -o " ++ (buildDir bInfo) ++ "/dummy "- ++ (join $ map ("-L"++) $ extraLibDirs buildInfo) ++ " -lgsl -lgslcblas"- ++ " > /dev/null 2> /dev/null"---- test for odeiv2-gslodeiv2 bInfo buildInfo =- "echo \"#include <gsl/gsl_odeiv2.h>\nint main(){return 0;}\""- ++" > " ++ (buildDir bInfo) ++ "/dummy.c; gcc " - ++ (buildDir bInfo) ++ "/dummy.c "- ++ (join $ ccOptions buildInfo) ++ " "- ++ (join $ cppOptions buildInfo) ++ " "- ++ (join $ map ("-I"++) $ includeDirs buildInfo)- ++" -o " ++ (buildDir bInfo) ++ "/dummy "- ++ (join $ map ("-L"++) $ extraLibDirs buildInfo) ++ " -lgsl -lgslcblas"- ++ " > /dev/null 2> /dev/null"---checkCommand c = (ExitSuccess ==) `fmap` system c---- test different configurations until the first one works-try _ _ _ _ [] = return Nothing-try l i b f (opt:rest) = do- ok <- check l i (b ++ " " ++ opt) f- if ok then return (Just opt)- else try l i b f rest---- read --configure-option=link:lib1,lib2,lib3,etc-linkop = "--configure-option=link:"-getUserLink = concatMap (g . drop (length linkop)) . filter (isPrefixOf linkop)- where g = map cs- cs ',' = ' '- cs x = x--config :: LocalBuildInfo -> IO HookedBuildInfo- -config bInfo = do- putStr "Checking foreign libraries..."- args <- getArgs-- let Just lib = library . localPkgDescr $ bInfo- buildInfo = libBuildInfo lib- base = unwords . extraLibs $ buildInfo- fwks = unwords . frameworks $ buildInfo- auxpref = getUserLink args-- -- We extract the desired libs from hmatrix.cabal (using a cabal flags)- -- and from a posible --configure-option=link:lib1,lib2,lib3- -- by default the desired libs are gsl lapack.-- let pref = if null (words (base ++ " " ++ auxpref)) then "gsl lapack" else auxpref- fullOpts = map ((pref++" ")++) opts-- -- create the build directory (used for tmp files) if necessary- createDirectoryIfMissing True $ buildDir bInfo- - r <- try bInfo buildInfo base fwks fullOpts-- case r of- Nothing -> do- putStrLn " FAIL"- g <- checkCommand $ gsl bInfo buildInfo- if g- then putStrLn " *** Sorry, I can't link LAPACK."- else putStrLn " *** Sorry, I can't link GSL."- putStrLn " *** Please make sure that the appropriate -dev packages are installed."- putStrLn " *** You can also specify the required libraries using"- putStrLn " *** cabal install hmatrix --configure-option=link:lib1,lib2,lib3,etc." - return (Just emptyBuildInfo { buildable = False }, [])- Just ops -> do- putStrLn $ " OK " ++ ops- g1 <- checkCommand $ gsl112 bInfo buildInfo- let op1 = if g1 then "" else "-DGSL110"- g2 <- checkCommand $ gslodeiv2 bInfo buildInfo- let op2 = if g2 then "" else "-DGSLODE1"- opts = filter (not.null) [op1,op2]- let hbi = emptyBuildInfo { extraLibs = words ops, ccOptions = opts }- return (Just hbi, [])-
− INSTALL.md
@@ -1,111 +0,0 @@--# [hmatrix][hmatrix2] installation--This package requires the [Glasgow Haskell Compiler](http://www.haskell.org/ghc/index.html) ghc >= 6.10, and [cabal-install](http://www.haskell.org/haskellwiki/Cabal-Install), conveniently available in the [Haskell Platform](http://hackage.haskell.org/platform), and the development packages for [GSL](http://www.gnu.org/software/gsl) and BLAS/[LAPACK](http://www.netlib.org/lapack). (The graphical functions also require **gnuplot** and **imagemagick**.)--[hmatrix]: http://code.haskell.org/hmatrix-[hmatrix2]: http://perception.inf.um.es/hmatrix---## Linux ##################################################---Ubuntu/Debian:-- $ sudo apt-get install libgsl0-dev liblapack-dev- $ cabal install hmatrix--Arch Linux: If the automatic installation from Hackage fails, install atlas-lapack and gsl, unpack the source, change the build-type to Simple in hmatrix.cabal (line 28) and add extra-libraries: gsl lapack (line 194). --Other distributions may require additional libraries. They can be given in a **--configure-option**.--## Mac OS/X ###############################################---GSL must be installed via MacPorts:-- $ sudo port install gsl-devel +universal- $ cabal install hmatrix--(Contributed by Heinrich Apfelmus and Torsten Kemps-Benedix).--## Windows ###############################################--We use this [GSL binary](http://www.miscdebris.net/blog/2009/04/20/mingw-345-binaries-of-gnu-scientific-library-112-for-use-with-mingw-and-visual-c/), and blas/lapack dlls built with g77 (contributed by Gilberto Camara). All required files are in [gsl-lapack-windows.zip][winpack].--(Due to [issue 21](https://github.com/albertoruiz/hmatrix/issues/21) we need hmatrix-0.13.1.0.)--1) Install the Haskell Platform (tested on 2011.2.0.1)-- > cabal update--2) Download and unzip the following file into a stable folder %GSL%-- http://perception.inf.um.es/hmatrix/gsl-lapack-windows.zip--3.a) In a msys shell the installation should be fully automatic:-- $ cabal install hmatrix-0.13.1.0 --extra-lib-dir=${GSL} --extra-include-dir=${GSL}--3.b) Alternatively, in a normal windows cmd:-- > cabal unpack hmatrix-0.13.1.0-- Edit hmatrix.cabal, in line 28 change build-type to "Simple", and then-- > cabal install --extra-lib-dir=%GSL% --extra-include-dir=%GSL%-- It may be necessary to put the dlls in the search path.---NOTE: The examples using graphics do not yet work in windows.--[install]: http://code.haskell.org/hmatrix/INSTALL-[install2]: http://patch-tag.com/r/aruiz/hmatrix/snapshot/current/content/pretty/INSTALL-[winpack2]: http://perception.inf.um.es/hmatrix/gsl-lapack-windows.zip-[winpack]: https://github.com/downloads/AlbertoRuiz/hmatrix/gsl-lapack-windows.zip--## Tests ###############################################--After installation we must verify that the library works as expected:-- $ cabal install hmatrix-tests --enable-tests- $ ghci- > Numeric.LinearAlgebra.Tests.runTests 20- OK, passed 100 tests. - OK, passed 100 tests.- ... etc...--If you get any failure please run lapack's own tests to confirm that your version is not broken. For instance, in ubuntu 9.04, **libatlas-sse2** does not work (see this [bug report](https://bugs.launchpad.net/ubuntu/+source/atlas/+bug/368478)). If your lapack library is ok but hmatrix's tests fail please send a bug report!---## Optimized BLAS/LAPACK ##########################################--I have successfully tested ATLAS and MKL on Linux.--### [ATLAS](http://math-atlas.sourceforge.net/) ####################--In Ubuntu >= 9.04 we need:-- $ sudo apt-get install libatlas-base-dev--In older Ubuntu/Debian versions we needed:-- $ sudo apt-get install refblas3-dev lapack3-dev atlas3-base-dev--We may use a version (sse2, 3dnow, etc.) optimized for the machine.--### Intel's MKL ###############################################--There is a free noncommercial download available from Intel's website. To use it I have added the following lines in my .bashrc configuration file:-- export LD_LIBRARY_PATH=/path/to/mkl/lib/arch- export LIBRARY_PATH=/path/to/mkl/lib/arch--where arch = 32 or em64t.--The library must be installed with the -fmkl flag:-- $ cabal install hmatrix -fmkl--
LICENSE view
@@ -1,2 +1,26 @@-Copyright Alberto Ruiz 2006-2007-GPL license+Copyright (c) 2006-2014 Alberto Ruiz and other contributors++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of Alberto Ruiz nor the names of other contributors may+ be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
Setup.lhs view
@@ -1,18 +1,5 @@ #! /usr/bin/env runhaskell > import Distribution.Simple-> import Distribution.Simple.Setup-> import Distribution.PackageDescription-> import Distribution.Simple.LocalBuildInfo--> import System.Process(system)-> import Config(config)--> main = defaultMainWithHooks simpleUserHooks { confHook = c }--> c x y = do-> binfo <- confHook simpleUserHooks x y-> pbi <- config binfo-> let pkg_descr = localPkgDescr binfo-> return $ binfo { localPkgDescr = updatePackageDescription pbi pkg_descr }+> main = defaultMain
THANKS.md view
@@ -92,7 +92,7 @@ - Carter Schonwald helped with the configuration for Homebrew OS X and found a tolerance problem in test "1E5 rots". He also discovered- a bug in the signature of cmap.+ a bug in the signature of cmap and fixed the cabal file. - Duncan Coutts reported a problem with configure.hs and contributed a solution and a simplified Setup.lhs.@@ -103,15 +103,134 @@ deprecation warnings, used more explicit imports, and updated to ghc-7.4. - Tom Nielsen discovered a problem in Config.hs, exposed by link problems- in Ubuntu 11.10 beta.+ in Ubuntu 11.10 beta, and fixed the link options on freebsd. - Daniel Fischer reported some Haddock markup errors. -- Danny Chan added support for integration over infinite intervals.+- Danny Chan added support for integration over infinite intervals, and fixed+ Configure.hs using platform independent functions. - Clark Gaebel removed superfluous thread safety. - Jeffrey Burdges reported a glpk link problem on OS/X - Jian Zhang reported the Windows installation problem due to new ODE interface.++- Mihaly Barasz and Ben Gamari fixed mapMatrix* and mapMatrixWithIndex++- Takano Akio fixed off-by-one errors in gsl-aux.c producing segfaults.++- Alex Lang implemented uniRoot and uniRootJ for one-dimensional root-finding, and+ fixed asRow and asColumn for empty vectors.++- Mike Ledger contributed alternative FFI helpers for matrix interoperation with C++- Stephen J. Barr suggested flipping argument order in the double integral example++- Greg Horn fixed the bus error on ghci 64-bit.++- Kristof Bastiaensen added bindings for one-dimensional minimization.++- Matthew Peddie added bindings for gsl_integrate_cquad doubly-adaptive quadrature+ for difficult integrands.++- Ben Gamari exposed matrixFromVector for Development.++- greg94301 reported tolerance issues in the tests.++- Clemens Lang updated the MacPort installation instructions.++- Henning Thielemann reported the pinv inefficient implementation and the need of+ pkgconfig-depends.++- bdoering reported the problem of zero absolute tolerance in the integration functions.++- Alexei Uimanov replaced fromList by Vector.fromList.++- Adam Vogt updated the code for ghc-7.7++- Mike Meyer (mwm) added freeBSD library configuration information.++- tfgit updated the OSX installation instructions via Homebrew++- "yokto" and "ttylec" reported the problem with the dot product of complex vectors.++- Samium Gromoff reported a build failure caused by a size_t - int mismatch.++- Denis Laxalde separated the gsl tests from the base ones.++- Dominic Steinitz (idontgetoutmuch) reported a bug in the static diagonal creation functions and+ added Cholesky to Static. He also added support for tridiagonal matrix solver and fixed several bugs.++- Dylan Thurston reported an error in the glpk documentation and ambiguity in+ the description of linearSolve.++- Adrian Victor Crisciu developed an installation method for platforms which+ don't provide shared lapack libraries.++- Ian Ross reported the max/minIndex bug.++- Niklas Hambüchen improved the documentation and fixed compilation with GHC-8.2+ adding type signatures. Added disable-default-paths flag.++- "erdeszt" optimized "conv" using a direct vector reverse.++- John Shahbazian added support for openBLAS.++- "yongqli" reported the bug in randomVector (rand() is not thread-safe and drand48_r() is not portable).++- Kiwamu Ishikura improved randomVector for OSX++- C.J. East fixed the examples for simplex.++- Ben Gamari contributed fixes for ghc 7.10++- Piotr Mardziel added general sparse constraints to simplex and the interface to glp_exact++- Maxim Baz fixed an instance declaration for ghc 7.11++- Thomas M. DuBuisson fixed a C include file.++- Matt Peddie wrote the interfaces to the interpolation and simulated annealing modules.++- "maxc01" solved uninstallability in FreeBSD, improved urandom, and fixed a Windows+ link error using rand_s.++- "ntfrgl" added {take,drop}Last{Rows,Columns} and odeSolveVWith with generalized step control function+ and fixed link errors related to mod/mod_l.++- "cruegge" discovered a bug in the conjugate gradient solver for sparse symmetric systems.++- Ilan Godik and Douglas McClean helped with Windows support.++- Vassil Keremidchiev fixed the cabal options for OpenBlas, fixed several installation+ issues, and added support for stack-based build. He also added support for LTS 8.15+ under Windows.++- Greg Nwosu fixed arm compilation++- Patrik Jansson changed meanCov and gaussianSample to use Herm type. Fixed stack.yaml.++- Justin Le added NFData instances for Static types, added mapping and outer product+ methods to Domain, and many other functions to the Static module.++- Sidharth Kapur added Normed and numeric instances for several Static types,+fixed the CPP issue in cabal files, and made many other contributions.++- Matt Renaud improved the documentation.++- Joshua Moerman fixed cabal/stack flags for windows.++- Francesco Mazzoli, Niklas Hambüchen, Patrick Chilton, and Andras Slemmer+ discovered a serious and subtle bug in the wrapper helpers causing memory corruption.+ Andras Slemmer fixed the bug. Thank you all.++- Kevin Slagle implemented thinQR and thinRQ, much faster than the original qr,+ and added compactSVDTol. He also added an optimized reorderVector for hTensor.++- "fedeinthemix" suggested a better name and a more general type for unitary.++- Huw Campbell fixed a bug in equal.++- Hiromi Ishii fixed compilation problems for ghc-8.4
− examples/bool.hs
@@ -1,54 +0,0 @@--- vectorized boolean operations defined in terms of step or cond--import Numeric.LinearAlgebra--infix 4 .==., ./=., .<., .<=., .>=., .>.-infixr 3 .&&.-infixr 2 .||.--a .<. b = step (b-a)-a .<=. b = cond a b 1 1 0-a .==. b = cond a b 0 1 0-a ./=. b = cond a b 1 0 1-a .>=. b = cond a b 0 1 1-a .>. b = step (a-b)--a .&&. b = step (a*b)-a .||. b = step (a+b)-no a = 1-a-xor a b = a ./=. b-equiv a b = a .==. b-imp a b = no a .||. b--taut x = minElement x == 1--minEvery a b = cond a b a a b-maxEvery a b = cond a b b b a---- examples--clip a b x = cond y b y y b where y = cond x a a x x--disp = putStr . dispf 3--eye n = ident n :: Matrix Double-row = asRow . fromList :: [Double] -> Matrix Double-col = asColumn . fromList :: [Double] -> Matrix Double--m = (3><4) [1..] :: Matrix Double--p = row [0,0,1,1]-q = row [0,1,0,1]--main = do- print $ find (>6) m- disp $ assoc (6,8) 7 $ zip (find (/=0) (eye 5)) [10..]- disp $ accum (eye 5) (+) [((0,2),3), ((3,1),7), ((1,1),1)]- disp $ m .>=. 10 .||. m .<. 4- (disp . fromColumns . map flatten) [p, q, p.&&.q, p .||.q, p `xor` q, p `equiv` q, p `imp` q]- print $ taut $ (p `imp` q ) `equiv` (no q `imp` no p)- print $ taut $ (xor p q) `equiv` (p .&&. no q .||. no p .&&. q)- disp $ clip 3 8 m- disp $ col [1..7] .<=. row [1..5]- disp $ cond (col [1..3]) (row [1..4]) m 50 (3*m)-
− examples/data.txt
@@ -1,10 +0,0 @@- 0.9 1.1- 2.1 3.9- 3.1 9.2- 4.0 51.8- 4.9 25.3- 6.1 35.7- 7.0 49.4- 7.9 3.6- 9.1 81.5-10.2 99.5
− examples/deriv.hs
@@ -1,8 +0,0 @@--- Numerical differentiation--import Numeric.GSL--d :: (Double -> Double) -> (Double -> Double)-d f x = fst $ derivCentral 0.01 f x--main = print $ d (\x-> x * d (\y-> x+y) 1) 1
− examples/devel/ej1/functions.c
@@ -1,35 +0,0 @@-/* assuming row order */--typedef struct { double r, i; } doublecomplex;--#define DVEC(A) int A##n, double*A##p-#define CVEC(A) int A##n, doublecomplex*A##p-#define DMAT(A) int A##r, int A##c, double*A##p-#define CMAT(A) int A##r, int A##c, doublecomplex*A##p--#define AT(M,row,col) (M##p[(row)*M##c + (col)])--/*-----------------------------------------------------*/--int c_scale_vector(double s, DVEC(x), DVEC(y)) {- int k;- for (k=0; k<=yn; k++) {- yp[k] = s*xp[k];- }- return 0;-}--/*-----------------------------------------------------*/--int c_diag(DMAT(m),DVEC(y),DMAT(z)) {- int i,j;- for (j=0; j<yn; j++) {- yp[j] = AT(m,j,j);- }- for (i=0; i<mr; i++) {- for (j=0; j<mc; j++) {- AT(z,i,j) = i==j?yp[i]:0;- }- }- return 0;-}
− examples/devel/ej1/wrappers.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}---- $ ghc -O2 --make wrappers.hs functions.c--import Numeric.LinearAlgebra-import Data.Packed.Development-import Foreign(Ptr,unsafePerformIO)-import Foreign.C.Types(CInt)---------------------------------------------------------main = do- print $ myScale 3.0 (fromList [1..10])- print $ myDiag $ (3><5) [1..]---------------------------------------------------------foreign import ccall unsafe "c_scale_vector"- cScaleVector :: Double -- scale- -> CInt -> Ptr Double -- argument- -> CInt -> Ptr Double -- result- -> IO CInt -- exit code--myScale s x = unsafePerformIO $ do- y <- createVector (dim x)- app2 (cScaleVector s) vec x vec y "cScaleVector"- return y---------------------------------------------------------- forcing row order--foreign import ccall unsafe "c_diag"- cDiag :: CInt -> CInt -> Ptr Double -- argument- -> CInt -> Ptr Double -- result1- -> CInt -> CInt -> Ptr Double -- result2- -> IO CInt -- exit code--myDiag m = unsafePerformIO $ do- y <- createVector (min r c)- z <- createMatrix RowMajor r c- app3 cDiag mat (cmat m) vec y mat z "cDiag"- return (y,z)- where r = rows m- c = cols m
− examples/devel/ej2/functions.c
@@ -1,24 +0,0 @@-/* general element order */--typedef struct { double r, i; } doublecomplex;--#define DVEC(A) int A##n, double*A##p-#define CVEC(A) int A##n, doublecomplex*A##p-#define DMAT(A) int A##r, int A##c, double*A##p-#define CMAT(A) int A##r, int A##c, doublecomplex*A##p--#define AT(M,r,c) (M##p[(r)*sr+(c)*sc])--int c_diag(int ro, DMAT(m),DVEC(y),DMAT(z)) {- int i,j,sr,sc;- if (ro==1) { sr = mc; sc = 1;} else { sr = 1; sc = mr;}- for (j=0; j<yn; j++) {- yp[j] = AT(m,j,j);- }- for (i=0; i<mr; i++) {- for (j=0; j<mc; j++) {- AT(z,i,j) = i==j?yp[i]:0;- }- }- return 0;-}
− examples/devel/ej2/wrappers.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}---- $ ghc -O2 --make wrappers.hs functions.c--import Numeric.LinearAlgebra-import Data.Packed.Development-import Foreign(Ptr,unsafePerformIO)-import Foreign.C.Types(CInt)---------------------------------------------------------main = do- print $ myDiag $ (3><5) [1..]---------------------------------------------------------- arbitrary data order--foreign import ccall unsafe "c_diag"- cDiag :: CInt -- matrix order- -> CInt -> CInt -> Ptr Double -- argument- -> CInt -> Ptr Double -- result1- -> CInt -> CInt -> Ptr Double -- result2- -> IO CInt -- exit code--myDiag m = unsafePerformIO $ do- y <- createVector (min r c)- z <- createMatrix (orderOf m) r c- app3 (cDiag o) mat m vec y mat z "cDiag"- return (y,z)- where r = rows m- c = cols m- o = if orderOf m == RowMajor then 1 else 0
− examples/error.hs
@@ -1,21 +0,0 @@-import Numeric.GSL-import Numeric.GSL.Special-import Numeric.LinearAlgebra-import Prelude hiding (catch)-import Control.Exception--test x = catch- (print x)- (\e -> putStrLn $ "captured ["++ show (e :: SomeException) ++"]")--main = do- setErrorHandlerOff-- test $ log_e (-1)- test $ 5 + (fst.exp_e) 1000- test $ bessel_zero_Jnu_e (-0.3) 2-- test $ (linearSolve 0 4 :: Matrix Double)- test $ (linearSolve 5 (sqrt (-1)) :: Matrix Double)-- putStrLn "Bye"
− examples/fitting.hs
@@ -1,24 +0,0 @@--- nonlinear least-squares fitting--import Numeric.GSL.Fitting-import Numeric.LinearAlgebra--xs = map return [0 .. 39]-sigma = 0.1-ys = map return $ toList $ fromList (map (head . expModel [5,0.1,1]) xs)- + scalar sigma * (randomVector 0 Gaussian 40)--dat :: [([Double],([Double],Double))]--dat = zip xs (zip ys (repeat sigma))--expModel [a,lambda,b] [t] = [a * exp (-lambda * t) + b]--expModelDer [a,lambda,b] [t] = [[exp (-lambda * t), -t * a * exp(-lambda*t) , 1]]--(sol,path) = fitModelScaled 1E-4 1E-4 20 (expModel, expModelDer) dat [1,0,0]--main = do- print dat- print path- print sol
− examples/inplace.hs
@@ -1,152 +0,0 @@--- some tests of the interface for pure--- computations with inplace updates--import Numeric.LinearAlgebra-import Data.Packed.ST-import Data.Packed.Convert--import Data.Array.Unboxed-import Data.Array.ST-import Control.Monad.ST-import Control.Monad--main = sequence_[- print test1,- print test2,- print test3,- print test4,- test5,- test6,- print test7,- test8,- test0]---- helper functions-vector l = fromList l :: Vector Double-norm v = pnorm PNorm2 v---- hmatrix vector and matrix-v = vector [1..10]-m = (5><10) [1..50::Double]---------------------------------------------------------------------------- vector creation by in-place updates on a copy of the argument-test1 = fun v--fun :: Element t => Vector t -> Vector t-fun x = runSTVector $ do- a <- thawVector x- mapM_ (flip (modifyVector a) (+57)) [0 .. dim x `div` 2 - 1]- return a---- another example: creation of an antidiagonal matrix from a list-test2 = antiDiag 5 8 [1..] :: Matrix Double--antiDiag :: (Element b) => Int -> Int -> [b] -> Matrix b-antiDiag r c l = runSTMatrix $ do- m <- newMatrix 0 r c- let d = min r c - 1- sequence_ $ zipWith (\i v -> writeMatrix m i (c-1-i) v) [0..d] l- return m---- using vector or matrix functions on mutable objects requires freezing:-test3 = g1 v--g1 x = runST $ do- a <- thawVector x- writeVector a (dim x -1) 0- b <- freezeVector a- return (norm b)---- another possibility:-test4 = g2 v--g2 x = runST $ do- a <- thawVector x- writeVector a (dim x -1) 0- t <- liftSTVector norm a- return t-------------------------------------------------------------------- haskell arrays-hv = listArray (0,9) [1..10::Double]-hm = listArray ((0,0),(4,9)) [1..50::Double]------ conversion from standard Haskell arrays-test5 = do- print $ norm (vectorFromArray hv)- print $ norm v- print $ rcond (matrixFromArray hm)- print $ rcond m----- conversion to mutable ST arrays-test6 = do- let y = clearColumn m 1- print y- print (matrixFromArray y)--clearColumn x c = runSTUArray $ do- a <- mArrayFromMatrix x- forM_ [0..rows x-1] $ \i->- writeArray a (i,c) (0::Double)- return a---- hmatrix functions applied to mutable ST arrays-test7 = unitary (listArray (1,4) [3,5,7,2] :: UArray Int Double)--unitary v = runSTUArray $ do- a <- thaw v- n <- norm `fmap` vectorFromMArray a- b <- mapArray (/n) a- return b------------------------------------------------------- (just to check that they are not affected)-test0 = do- print v- print m- --print hv- --print hm-----------------------------------------------------histogram n ds = runSTVector $ do- h <- newVector (0::Double) n -- number of bins- let inc k = modifyVector h k (+1)- mapM_ inc ds- return h---- check that newVector is really called with a fresh new array-histoCheck ds = runSTVector $ do- h <- newVector (0::Double) 15 -- > constant for this test- let inc k = modifyVector h k (+1)- mapM_ inc ds- return h--hc = fromList [1 .. 15::Double]---- check that thawVector creates a new array-histoCheck2 ds = runSTVector $ do- h <- thawVector hc- let inc k = modifyVector h k (+1)- mapM_ inc ds- return h--test8 = do- let ds = [0..14]- print $ histogram 15 ds- print $ histogram 15 ds- print $ histogram 15 ds- print $ histoCheck ds- print $ histoCheck ds- print $ histoCheck ds- print $ histoCheck2 ds- print $ histoCheck2 ds- print $ histoCheck2 ds- putStrLn "----------------------"
− examples/integrate.hs
@@ -1,17 +0,0 @@--- Numerical integration-import Numeric.GSL--quad f a b = fst $ integrateQAGS 1E-9 100 f a b ---- A multiple integral can be easily defined using partial application-quad2 f a b g1 g2 = quad h a b- where h x = quad (f x) (g1 x) (g2 x)--volSphere r = 8 * quad2 (\x y -> sqrt (r*r-x*x-y*y)) - 0 r (const 0) (\x->sqrt (r*r-x*x))--main = do- print $ quad (\x -> 4/(x^2+1)) 0 1- print pi- print $ volSphere 2.5- print $ 4/3*pi*2.5**3
− examples/kalman.hs
@@ -1,51 +0,0 @@-import Numeric.LinearAlgebra-import Graphics.Plot--vector l = fromList l :: Vector Double-matrix ls = fromLists ls :: Matrix Double-diagl = diag . vector--f = matrix [[1,0,0,0],- [1,1,0,0],- [0,0,1,0],- [0,0,0,1]]--h = matrix [[0,-1,1,0],- [0,-1,0,1]]--q = diagl [1,1,0,0]--r = diagl [2,2]--s0 = State (vector [0, 0, 10, -10]) (diagl [10,0, 100, 100])--data System = System {kF, kH, kQ, kR :: Matrix Double}-data State = State {sX :: Vector Double , sP :: Matrix Double}-type Measurement = Vector Double--kalman :: System -> State -> Measurement -> State-kalman (System f h q r) (State x p) z = State x' p' where- px = f <> x -- prediction- pq = f <> p <> trans f + q -- its covariance- y = z - h <> px -- residue- cy = h <> pq <> trans h + r -- its covariance- k = pq <> trans h <> inv cy -- kalman gain- x' = px + k <> y -- new state- p' = (ident (dim x) - k <> h) <> pq -- its covariance--sys = System f h q r--zs = [vector [15-k,-20-k] | k <- [0..]]--xs = s0 : zipWith (kalman sys) xs zs--des = map (sqrt.takeDiag.sP) xs--evolution n (xs,des) =- vector [1.. fromIntegral n]:(toColumns $ fromRows $ take n (zipWith (-) (map sX xs) des)) ++- (toColumns $ fromRows $ take n (zipWith (+) (map sX xs) des))--main = do- print $ fromRows $ take 10 (map sX xs)- mapM_ (print . sP) $ take 10 xs- mplot (evolution 20 (xs,des))
− examples/lie.hs
@@ -1,65 +0,0 @@--- The magic of Lie Algebra--import Numeric.LinearAlgebra--disp = putStrLn . dispf 5--rot1 :: Double -> Matrix Double-rot1 a = (3><3)- [ 1, 0, 0- , 0, c, s- , 0,-s, c ]- where c = cos a- s = sin a--g1,g2,g3 :: Matrix Double--g1 = (3><3) [0, 0,0- ,0, 0,1- ,0,-1,0]--rot2 :: Double -> Matrix Double-rot2 a = (3><3)- [ c, 0, s- , 0, 1, 0- ,-s, 0, c ]- where c = cos a- s = sin a--g2 = (3><3) [ 0,0,1- , 0,0,0- ,-1,0,0]--rot3 :: Double -> Matrix Double-rot3 a = (3><3)- [ c, s, 0- ,-s, c, 0- , 0, 0, 1 ]- where c = cos a- s = sin a--g3 = (3><3) [ 0,1,0- ,-1,0,0- , 0,0,0]--deg=pi/180---- commutator-infix 8 &-a & b = a <> b - b <> a--infixl 6 |+|-a |+| b = a + b + a&b /2 + (a-b)&(a & b) /12--main = do- let a = 45*deg- b = 50*deg- c = -30*deg- exact = rot3 a <> rot1 b <> rot2 c- lie = scalar a * g3 |+| scalar b * g1 |+| scalar c * g2- putStrLn "position in the tangent space:"- disp lie- putStrLn "exponential map back to the group (2 terms):"- disp (expm lie)- putStrLn "exact position:"- disp exact
− examples/minimize.hs
@@ -1,50 +0,0 @@--- the multidimensional minimization example in the GSL manual-import Numeric.GSL-import Numeric.LinearAlgebra-import Graphics.Plot-import Text.Printf(printf)---- the function to be minimized-f [x,y] = 10*(x-1)^2 + 20*(y-2)^2 + 30---- exact gradient-df [x,y] = [20*(x-1), 40*(y-2)]---- a minimization algorithm which does not require the gradient-minimizeS f xi = minimize NMSimplex2 1E-2 100 (replicate (length xi) 1) f xi---- Numerical estimation of the gradient-gradient f v = [partialDerivative k f v | k <- [0 .. length v -1]]--partialDerivative n f v = fst (derivCentral 0.01 g (v!!n)) where- g x = f (concat [a,x:b])- (a,_:b) = splitAt n v--disp = putStrLn . format " " (printf "%.3f")--allMethods :: (Enum a, Bounded a) => [a]-allMethods = [minBound .. maxBound]--test method = do- print method- let (s,p) = minimize method 1E-2 30 [1,1] f [5,7]- print s- disp p--testD method = do- print method- let (s,p) = minimizeD method 1E-3 30 1E-2 1E-4 f df [5,7]- print s- disp p--testD' method = do- putStrLn $ show method ++ " with estimated gradient"- let (s,p) = minimizeD method 1E-3 30 1E-2 1E-4 f (gradient f) [5,7]- print s- disp p--main = do- mapM_ test [NMSimplex, NMSimplex2]- mapM_ testD allMethods- testD' ConjugateFR- mplot $ drop 3 . toColumns . snd $ minimizeS f [5,7]
− examples/monadic.hs
@@ -1,118 +0,0 @@--- monadic computations--- (contributed by Vivian McPhail)--import Numeric.LinearAlgebra-import Control.Monad.State.Strict-import Control.Monad.Maybe-import Foreign.Storable(Storable)-import System.Random(randomIO)------------------------------------------------- an instance of MonadIO, a monad transformer-type VectorMonadT = StateT Int IO--test1 :: Vector Int -> IO (Vector Int)-test1 = mapVectorM $ \x -> do- putStr $ (show x) ++ " "- return (x + 1)---- we can have an arbitrary monad AND do IO-addInitialM :: Vector Int -> VectorMonadT ()-addInitialM = mapVectorM_ $ \x -> do- i <- get- liftIO $ putStr $ (show $ x + i) ++ " "- put $ x + i---- sum the values of the even indiced elements-sumEvens :: Vector Int -> Int-sumEvens = foldVectorWithIndex (\x a b -> if x `mod` 2 == 0 then a + b else b) 0---- sum and print running total of evens-sumEvensAndPrint :: Vector Int -> VectorMonadT ()-sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do- when (i `mod` 2 == 0) $ do- v <- get- put $ v + x- v' <- get- liftIO $ putStr $ (show v') ++ " "---indexPlusSum :: Vector Int -> VectorMonadT ()-indexPlusSum v' = do- let f i x = do- s <- get- let inc = x+s- liftIO $ putStr $ show (i,inc) ++ " "- put inc- return inc- v <- mapVectorWithIndexM f v'- liftIO $ do- putStrLn ""- putStrLn $ show v------------------------------------------------- short circuit-monoStep :: Double -> MaybeT (State Double) ()-monoStep d = do- dp <- get- when (d < dp) (fail "negative difference")- put d-{-# INLINE monoStep #-}--isMonotoneIncreasing :: Vector Double -> Bool-isMonotoneIncreasing v =- let res = evalState (runMaybeT $ (mapVectorM_ monoStep v)) (v @> 0)- in case res of- Nothing -> False- Just _ -> True-------------------------------------------------- | apply a test to successive elements of a vector, evaluates to true iff test passes for all pairs-successive_ :: Storable a => (a -> a -> Bool) -> Vector a -> Bool-successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (dim v - 1) v))) (v @> 0)- where step e = do- ep <- lift $ get- if t e ep- then lift $ put e- else (fail "successive_ test failed")---- | operate on successive elements of a vector and return the resulting vector, whose length 1 less than that of the input-successive :: (Storable a, Storable b) => (a -> a -> b) -> Vector a -> Vector b-successive f v = evalState (mapVectorM step (subVector 1 (dim v - 1) v)) (v @> 0)- where step e = do- ep <- get- put e- return $ f ep e-----------------------------------------------v :: Vector Int-v = 10 |> [0..]--w = fromList ([1..10]++[10,9..1]) :: Vector Double---main = do- v' <- test1 v- putStrLn ""- putStrLn $ show v'- evalStateT (addInitialM v) 0- putStrLn ""- putStrLn $ show (sumEvens v)- evalStateT (sumEvensAndPrint v) 0- putStrLn ""- evalStateT (indexPlusSum v) 0- putStrLn "-----------------------"- mapVectorM_ print v- print =<< (mapVectorM (const randomIO) v :: IO (Vector Double))- print =<< (mapVectorM (\a -> fmap (+a) randomIO) (5|>[0,100..1000]) :: IO (Vector Double))- putStrLn "-----------------------"- print $ isMonotoneIncreasing w- print $ isMonotoneIncreasing (subVector 0 7 w)- print $ successive_ (>) v- print $ successive_ (>) w- print $ successive (+) v
− examples/multiply.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE UnicodeSyntax- , MultiParamTypeClasses- , FunctionalDependencies- , FlexibleInstances- , FlexibleContexts--- , OverlappingInstances- , UndecidableInstances #-}--import Numeric.LinearAlgebra--class Scaling a b c | a b -> c where- -- ^ 0x22C5 8901 DOT OPERATOR, scaling- infixl 7 ⋅- (⋅) :: a -> b -> c--class Contraction a b c | a b -> c where- -- ^ 0x00D7 215 MULTIPLICATION SIGN ×, contraction- infixl 7 ×- (×) :: a -> b -> c--class Outer a b c | a b -> c where- -- ^ 0x2297 8855 CIRCLED TIMES ⊗, outer product (not associative)- infixl 7 ⊗- (⊗) :: a -> b -> c------------instance (Num t) => Scaling t t t where- (⋅) = (*)--instance Container Vector t => Scaling t (Vector t) (Vector t) where- (⋅) = scale--instance Container Vector t => Scaling (Vector t) t (Vector t) where- (⋅) = flip scale--instance Container Vector t => Scaling t (Matrix t) (Matrix t) where- (⋅) = scale--instance Container Vector t => Scaling (Matrix t) t (Matrix t) where- (⋅) = flip scale---instance Product t => Contraction (Vector t) (Vector t) t where- (×) = dot--instance Product t => Contraction (Matrix t) (Vector t) (Vector t) where- (×) = mXv--instance Product t => Contraction (Vector t) (Matrix t) (Vector t) where- (×) = vXm--instance Product t => Contraction (Matrix t) (Matrix t) (Matrix t) where- (×) = mXm-----instance Scaling a b c => Contraction a b c where--- (×) = (⋅)---------instance Product t => Outer (Vector t) (Vector t) (Matrix t) where- (⊗) = outer--instance Product t => Outer (Vector t) (Matrix t) (Matrix t) where- v ⊗ m = kronecker (asColumn v) m--instance Product t => Outer (Matrix t) (Vector t) (Matrix t) where- m ⊗ v = kronecker m (asRow v)--instance Product t => Outer (Matrix t) (Matrix t) (Matrix t) where- (⊗) = kronecker----------v = 3 |> [1..] :: Vector Double--m = (3 >< 3) [1..] :: Matrix Double--s = 3 :: Double--a = s ⋅ v × m × m × v ⋅ s--b = (v ⊗ m) ⊗ (v ⊗ m)--c = v ⊗ m ⊗ v ⊗ m--d = s ⋅ (3 |> [10,20..] :: Vector Double)--main = do- print $ scale s v <> m <.> v - print $ scale s v <.> (m <> v)- print $ s * (v <> m <.> v)- print $ s ⋅ v × m × v- print a- print (b == c)- print d-
− examples/ode.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-import Numeric.GSL.ODE-import Numeric.LinearAlgebra-import Graphics.Plot-import Debug.Trace(trace)-debug x = trace (show x) x--vanderpol mu = do- let xdot mu t [x,v] = [v, -x + mu * v * (1-x^2)]- ts = linspace 1000 (0,50)- sol = toColumns $ odeSolve (xdot mu) [1,0] ts- mplot (ts : sol)- mplot sol---harmonic w d = do- let xdot w d t [x,v] = [v, a*x + b*v] where a = -w^2; b = -2*d*w- ts = linspace 100 (0,20)- sol = odeSolve (xdot w d) [1,0] ts- mplot (ts : toColumns sol)---kepler v a = mplot (take 2 $ toColumns sol) where- xdot t [x,y,vx,vy] = [vx,vy,x*k,y*k]- where g=1- k=(-g)*(x*x+y*y)**(-1.5)- ts = linspace 100 (0,30)- sol = odeSolve xdot [4, 0, v * cos (a*degree), v * sin (a*degree)] ts- degree = pi/180---main = do- vanderpol 2- harmonic 1 0- harmonic 1 0.1- kepler 0.3 60- kepler 0.4 70- vanderpol' 2---- example of odeSolveV with jacobian-vanderpol' mu = do- let xdot mu t (toList->[x,v]) = fromList [v, -x + mu * v * (1-x^2)]- jac t (toList->[x,v]) = (2><2) [ 0 , 1- , -1-2*x*v*mu, mu*(1-x**2) ]- ts = linspace 1000 (0,50)- hi = (ts@>1 - ts@>0)/100- sol = toColumns $ odeSolveV (MSBDF jac) hi 1E-8 1E-8 (xdot mu) (fromList [1,0]) ts- mplot sol--
− examples/parallel.hs
@@ -1,28 +0,0 @@--- $ ghc --make -O -rtsopts -threaded parallel.hs--- $ ./parallel 3000 +RTS -N4 -s -A200M--import System.Environment(getArgs)-import Numeric.LinearAlgebra-import Control.Parallel.Strategies-import System.Time--inParallel = parMap rwhnf id---- matrix product decomposed into p parallel subtasks-parMul p x y = fromBlocks [ inParallel ( map (x <>) ys ) ]- where [ys] = toBlocksEvery (rows y) (cols y `div` p) y--main = do- n <- (read . head) `fmap` getArgs- let m = ident n :: Matrix Double- time $ print $ maxElement $ takeDiag $ m <> m- time $ print $ maxElement $ takeDiag $ parMul 2 m m- time $ print $ maxElement $ takeDiag $ parMul 4 m m- time $ print $ maxElement $ takeDiag $ parMul 8 m m--time act = do- t0 <- getClockTime- act- t1 <- getClockTime- print $ tdSec $ normalizeTimeDiff $ diffClockTimes t1 t0-
− examples/pca1.hs
@@ -1,46 +0,0 @@--- Principal component analysis--import Numeric.LinearAlgebra-import System.Directory(doesFileExist)-import System.Process(system)-import Control.Monad(when)--type Vec = Vector Double-type Mat = Matrix Double----- Vector with the mean value of the columns of a matrix-mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a---- covariance matrix of a list of observations stored as rows-cov x = (trans xc <> xc) / fromIntegral (rows x - 1)- where xc = x - asRow (mean x)----- creates the compression and decompression functions from the desired number of components-pca :: Int -> Mat -> (Vec -> Vec , Vec -> Vec)-pca n dataSet = (encode,decode)- where- encode x = vp <> (x - m)- decode x = x <> vp + m- m = mean dataSet- c = cov dataSet- (_,v) = eigSH' c- vp = takeRows n (trans v)--norm = pnorm PNorm2--main = do- ok <- doesFileExist ("mnist.txt")- when (not ok) $ do- putStrLn "\nTrying to download test datafile..."- system("wget -nv http://dis.um.es/~alberto/material/sp/mnist.txt.gz")- system("gunzip mnist.txt.gz")- return ()- m <- loadMatrix "mnist.txt" -- fromFile "mnist.txt" (5000,785)- let xs = takeColumns (cols m -1) m -- the last column is the digit type (class label)- let x = toRows xs !! 4 -- an arbitrary test Vec- let (pe,pd) = pca 10 xs- let y = pe x- print y -- compressed version- print $ norm (x - pd y) / norm x --reconstruction quality
− examples/pca2.hs
@@ -1,65 +0,0 @@--- Improved PCA, including illustrative graphics--import Numeric.LinearAlgebra-import Graphics.Plot-import System.Directory(doesFileExist)-import System.Process(system)-import Control.Monad(when)--type Vec = Vector Double-type Mat = Matrix Double---- Vector with the mean value of the columns of a matrix-mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a---- covariance matrix of a list of observations stored as rows-cov x = (trans xc <> xc) / fromIntegral (rows x - 1)- where xc = x - asRow (mean x)---type Stat = (Vec, [Double], Mat)--- 1st and 2nd order statistics of a dataset (mean, eigenvalues and eigenvectors of cov)-stat :: Mat -> Stat-stat x = (m, toList s, trans v) where- m = mean x- (s,v) = eigSH' (cov x)---- creates the compression and decompression functions from the desired reconstruction--- quality and the statistics of a data set-pca :: Double -> Stat -> (Vec -> Vec , Vec -> Vec)-pca prec (m,s,v) = (encode,decode) - where - encode x = vp <> (x - m)- decode x = x <> vp + m- vp = takeRows n v- n = 1 + (length $ fst $ span (< (prec'*sum s)) $ cumSum s)- cumSum = tail . scanl (+) 0.0- prec' = if prec <=0.0 || prec >= 1.0- then error "the precision in pca must be 0<prec<1"- else prec--shdigit :: Vec -> IO ()-shdigit v = imshow (reshape 28 (-v))---- shows the effect of a given reconstruction quality on a test vector-test :: Stat -> Double -> Vec -> IO ()-test st prec x = do- let (pe,pd) = pca prec st- let y = pe x- print $ dim y- shdigit (pd y)--main = do- ok <- doesFileExist ("mnist.txt")- when (not ok) $ do- putStrLn "\nTrying to download test datafile..."- system("wget -nv http://dis.um.es/~alberto/material/sp/mnist.txt.gz")- system("gunzip mnist.txt.gz")- return ()- m <- loadMatrix "mnist.txt"- let xs = takeColumns (cols m -1) m- let x = toRows xs !! 4 -- an arbitrary test vector- shdigit x- let st = stat xs- test st 0.90 x- test st 0.50 x
− examples/pinv.hs
@@ -1,20 +0,0 @@-import Numeric.LinearAlgebra-import Graphics.Plot-import Text.Printf(printf)--expand :: Int -> Vector Double -> Matrix Double-expand n x = fromColumns $ map (x^) [0 .. n]--polynomialModel :: Vector Double -> Vector Double -> Int- -> (Vector Double -> Vector Double)-polynomialModel x y n = f where- f z = expand n z <> ws- ws = expand n x <\> y--main = do- [x,y] <- (toColumns . readMatrix) `fmap` readFile "data.txt"- let pol = polynomialModel x y- let view = [x, y, pol 1 x, pol 2 x, pol 3 x]- putStrLn $ " x y p 1 p 2 p 3"- putStrLn $ format " " (printf "%.2f") $ fromColumns view- mplot view
− examples/plot.hs
@@ -1,20 +0,0 @@-import Numeric.LinearAlgebra-import Graphics.Plot-import Numeric.GSL.Special(erf_Z, erf)--sombrero n = f x y where - (x,y) = meshdom range range- range = linspace n (-2,2)- f x y = exp (-r2) * cos (2*r2) where - r2 = x*x+y*y--f x = sin x + 0.5 * sin (5*x)--gaussianPDF = erf_Z-cumdist x = 0.5 * (1+ erf (x/sqrt 2))--main = do- let x = linspace 1000 (-4,4)- mplot [f x]- mplot [x, mapVector cumdist x, mapVector gaussianPDF x]- mesh (sombrero 40)
− examples/root.hs
@@ -1,31 +0,0 @@--- root finding examples-import Numeric.GSL-import Numeric.LinearAlgebra-import Text.Printf(printf)--rosenbrock a b [x,y] = [ a*(1-x), b*(y-x^2) ]--test method = do- print method- let (s,p) = root method 1E-7 30 (rosenbrock 1 10) [-10,-5]- print s -- solution- disp p -- evolution of the algorithm--jacobian a b [x,y] = [ [-a , 0]- , [-2*b*x, b] ]--testJ method = do- print method- let (s,p) = rootJ method 1E-7 30 (rosenbrock 1 10) (jacobian 1 10) [-10,-5]- print s- disp p--disp = putStrLn . format " " (printf "%.3f")--main = do- test Hybrids- test Hybrid- test DNewton- test Broyden-- mapM_ testJ [HybridsJ .. GNewton]
− examples/vector.hs
@@ -1,31 +0,0 @@--- conversion to/from Data.Vector.Storable--- from Roman Leshchinskiy "vector" package------ In the future Data.Packed.Vector will be replaced by Data.Vector.Storable-----------------------------------------------import Numeric.LinearAlgebra as H-import Data.Packed.Development(unsafeFromForeignPtr, unsafeToForeignPtr)-import Foreign.Storable-import qualified Data.Vector.Storable as V--fromVector :: Storable t => V.Vector t -> H.Vector t-fromVector v = unsafeFromForeignPtr p i n where- (p,i,n) = V.unsafeToForeignPtr v--toVector :: Storable t => H.Vector t -> V.Vector t-toVector v = V.unsafeFromForeignPtr p i n where- (p,i,n) = unsafeToForeignPtr v-----------------------------------------------v = V.slice 5 10 (V.fromList [1 .. 10::Double] V.++ V.replicate 10 7)--w = subVector 2 3 (linspace 5 (0,1)) :: Vector Double--main = do- print v- print $ fromVector v- print w- print $ toVector w
hmatrix.cabal view
@@ -1,202 +1,164 @@ Name: hmatrix-Version: 0.14.1.0-License: GPL+Version: 0.20.2+License: BSD3 License-file: LICENSE Author: Alberto Ruiz-Maintainer: Alberto Ruiz <aruiz@um.es>+Maintainer: Dominic Steinitz Stability: provisional-Homepage: https://github.com/albertoruiz/hmatrix-Synopsis: Linear algebra and numerical computation-Description: Purely functional interface to basic linear algebra- and other numerical computations, internally implemented using- GSL, BLAS and LAPACK.- .- The Linear Algebra API is organized as follows:- .- - "Data.Packed": structure manipulation+Homepage: https://github.com/haskell-numerics/hmatrix+Synopsis: Numeric Linear Algebra+Description: Linear systems, matrix decompositions, and other numerical computations based on BLAS and LAPACK. .- - "Numeric.Container": simple numeric functions+ Standard interface: "Numeric.LinearAlgebra". .- - "Numeric.LinearAlgebra.Algorithms": matrix computations+ Safer interface with statically checked dimensions: "Numeric.LinearAlgebra.Static". .- - "Numeric.LinearAlgebra": everything + instances of standard Haskell numeric classes-Category: Math-tested-with: GHC ==7.4--cabal-version: >=1.8--build-type: Custom--extra-source-files: Config.hs THANKS.md INSTALL.md CHANGES.md+ Code examples: <http://dis.um.es/~alberto/hmatrix/hmatrix.html> -extra-source-files: examples/deriv.hs- examples/integrate.hs- examples/minimize.hs- examples/root.hs- examples/ode.hs- examples/pca1.hs- examples/pca2.hs- examples/pinv.hs- examples/data.txt- examples/lie.hs- examples/kalman.hs- examples/parallel.hs- examples/plot.hs- examples/inplace.hs- examples/error.hs- examples/fitting.hs- examples/devel/ej1/wrappers.hs- examples/devel/ej1/functions.c- examples/devel/ej2/wrappers.hs- examples/devel/ej2/functions.c- examples/vector.hs- examples/monadic.hs- examples/bool.hs- examples/multiply.hs+Category: Math+tested-with: GHC==8.10 -extra-source-files: lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h,- lib/Numeric/LinearAlgebra/LAPACK/clapack.h- lib/Numeric/GSL/gsl-ode.c+cabal-version: >=1.18 -flag dd- description: svd = zgesdd- default: True+build-type: Simple -flag mkl- description: Link with Intel's MKL optimized libraries.- default: False+extra-source-files: THANKS.md CHANGELOG -flag unsafe- description: Compile the library with bound checking disabled.- default: False+extra-source-files: src/Internal/C/lapack-aux.h -flag finit- description: Force FPU initialization in foreing calls+flag openblas+ description: Link with OpenBLAS (https://github.com/xianyi/OpenBLAS) optimized libraries. default: False+ manual: True -flag debugfpu- description: Check FPU stack+flag disable-default-paths+ description: When enabled, don't add default hardcoded include/link dirs by default. Needed for hermetic builds like in nix. default: False+ manual: True -flag debugnan- description: Check NaN+flag no-random_r+ description: When enabled, don't depend on the random_r() C function. default: False+ manual: True library - Build-Depends: base >= 4 && < 5,+ default-language: Haskell2010++ Build-Depends: base >= 4.8 && < 5,+ binary, array,+ deepseq,+ random,+ split,+ bytestring,+ primitive, storable-complex,- process, random,- vector >= 0.8,- binary+ semigroups,+ vector >= 0.11 - Extensions: ForeignFunctionInterface,- CPP+ hs-source-dirs: src - hs-source-dirs: lib- Exposed-modules: Data.Packed,- Data.Packed.Vector,- Data.Packed.Matrix,- Numeric.GSL.Differentiation,- Numeric.GSL.Integration,- Numeric.GSL.Fourier,- Numeric.GSL.Polynomials,- Numeric.GSL.Minimization,- Numeric.GSL.Root,- Numeric.GSL.Fitting,- Numeric.GSL.ODE,- Numeric.GSL,- Numeric.Container,- Numeric.LinearAlgebra,- Numeric.LinearAlgebra.LAPACK,- Numeric.LinearAlgebra.Algorithms,- Numeric.LinearAlgebra.Util,- Graphics.Plot,- Data.Packed.ST,- Data.Packed.Development- other-modules: Data.Packed.Internal,- Data.Packed.Internal.Common,- Data.Packed.Internal.Signatures,- Data.Packed.Internal.Vector,- Data.Packed.Internal.Matrix,- Data.Packed.Random,- Numeric.GSL.Internal,- Numeric.GSL.Vector,- Numeric.Conversion,- Numeric.ContainerBoot,- Numeric.IO,- Numeric.Chain,- Numeric.Vector,- Numeric.Matrix,- Numeric.LinearAlgebra.Util.Convolution+ exposed-modules: Numeric.LinearAlgebra+ Numeric.LinearAlgebra.Devel+ Numeric.LinearAlgebra.Data+ Numeric.LinearAlgebra.HMatrix+ Numeric.LinearAlgebra.Static - C-sources: lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c,- lib/Numeric/GSL/gsl-aux.c+ other-modules: Internal.Vector+ Internal.Devel+ Internal.Vectorized+ Internal.Matrix+ Internal.ST+ Internal.IO+ Internal.Element+ Internal.Conversion+ Internal.LAPACK+ Internal.Numeric+ Internal.Algorithms+ Internal.Random+ Internal.Container+ Internal.Sparse+ Internal.Convolution+ Internal.Chain+ Numeric.Vector+ Internal.CG+ Numeric.Matrix+ Internal.Util+ Internal.Modular+ Internal.Static - cpp-options: -DVECTOR -DBINARY+ C-sources: src/Internal/C/lapack-aux.c+ src/Internal/C/vector-aux.c - -- ghc-prof-options: -auto - ghc-options: -Wall -fno-warn-missing-signatures+ other-extensions: ForeignFunctionInterface++ ghc-options: -Wall+ -fno-warn-missing-signatures -fno-warn-orphans- -fno-warn-unused-binds+ -fno-prof-auto - if flag(unsafe)- cpp-options: -DUNSAFE+ cc-options: -O4 -Wall - if !flag(dd)- cpp-options: -DNOZGESDD+ if arch(x86_64)+ cc-options: -msse2+ if arch(i386)+ cc-options: -msse2 - if impl(ghc < 6.10.2)- cpp-options: -DFINIT - if impl(ghc == 7.0.1)- cpp-options: -DFINIT-- if impl(ghc == 7.0.2)- cpp-options: -DFINIT-- if flag(finit)- cpp-options: -DFINIT-- if flag(debugfpu)- cc-options: -DFPUDEBUG-- if flag(debugnan)- cc-options: -DNANDEBUG-- if impl(ghc == 7.0.1)- cpp-options: -DNONORMVTEST-- if flag(mkl)- if arch(x86_64)- extra-libraries: gsl mkl_lapack mkl_intel_lp64 mkl_sequential mkl_core- else- extra-libraries: gsl mkl_lapack mkl_intel mkl_sequential mkl_core+ if flag(no-random_r)+ cc-options: -DNO_RANDOM_R if os(OSX)- extra-lib-dirs: /opt/local/lib/- include-dirs: /opt/local/include/- extra-lib-dirs: /usr/local/lib/- include-dirs: /usr/local/include/- extra-libraries: gsl+ if flag(openblas)+ if !flag(disable-default-paths)+ extra-lib-dirs: /opt/local/lib/openblas/lib+ extra-libraries: openblas+ else+ extra-libraries: blas lapack++ if !flag(disable-default-paths)+ extra-lib-dirs: /opt/local/lib/+ include-dirs: /opt/local/include/+ extra-lib-dirs: /usr/local/lib/+ include-dirs: /usr/local/include/ if arch(i386) cc-options: -arch i386 frameworks: Accelerate + if os(freebsd)+ if flag(openblas)+ if !flag(disable-default-paths)+ extra-lib-dirs: /usr/local/lib/openblas/lib+ extra-libraries: openblas+ else+ extra-libraries: blas lapack++ if !flag(disable-default-paths)+ extra-lib-dirs: /usr/local/lib+ include-dirs: /usr/local/include+ extra-libraries: gfortran+ extra-lib-dirs: /usr/local/lib/gcc9 /usr/local/lib/gcc8 /usr/local/lib/gcc7+ if os(windows)- extra-libraries: gsl-0 blas lapack+ if flag(openblas)+ extra-libraries: openblas+ else+ extra-libraries: blas lapack --- The extra-libraries required for GSL and LAPACK--- should now be automatically detected by configure(.hs)+ if os(linux)+ if flag(openblas)+ if !flag(disable-default-paths)+ extra-lib-dirs: /usr/lib/openblas/lib+ extra-libraries: openblas+ else+ extra-libraries: blas lapack - extra-libraries:- extra-lib-dirs:+ if arch(x86_64)+ cc-options: -fPIC + source-repository head type: git- location: https://github.com/albertoruiz/hmatrix---- The tests are in package hmatrix-tests-+ location: https://github.com/haskell-numerics/hmatrix
− lib/Data/Packed.hs
@@ -1,28 +0,0 @@-------------------------------------------------------------------------------{- |-Module : Data.Packed-Copyright : (c) Alberto Ruiz 2006-2010-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Types for dense 'Vector' and 'Matrix' of 'Storable' elements.---}--------------------------------------------------------------------------------module Data.Packed (- module Data.Packed.Vector,- module Data.Packed.Matrix,--- module Numeric.Conversion,--- module Data.Packed.Random,--- module Data.Complex-) where--import Data.Packed.Vector-import Data.Packed.Matrix---import Data.Packed.Random---import Data.Complex---import Numeric.Conversion
− lib/Data/Packed/Development.hs
@@ -1,30 +0,0 @@---------------------------------------------------------------------------------- |--- Module : Data.Packed.Development--- Copyright : (c) Alberto Ruiz 2009--- License : GPL------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ The library can be easily extended with additional foreign functions--- using the tools in this module. Illustrative usage examples can be found--- in the @examples\/devel@ folder included in the package.-----------------------------------------------------------------------------------module Data.Packed.Development (- createVector, createMatrix,- vec, mat,- app1, app2, app3, app4,- app5, app6, app7, app8, app9, app10,- MatrixOrder(..), orderOf, cmat, fmat,- unsafeFromForeignPtr,- unsafeToForeignPtr,- check, (//),- at', atM'-) where--import Data.Packed.Internal
− lib/Data/Packed/Internal.hs
@@ -1,26 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Packed.Internal--- Copyright : (c) Alberto Ruiz 2007--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ Reexports all internal modules------------------------------------------------------------------------------------ #hide--module Data.Packed.Internal (- module Data.Packed.Internal.Common,- module Data.Packed.Internal.Signatures,- module Data.Packed.Internal.Vector,- module Data.Packed.Internal.Matrix,-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Data.Packed.Internal.Vector-import Data.Packed.Internal.Matrix
− lib/Data/Packed/Internal/Common.hs
@@ -1,167 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module : Data.Packed.Internal.Common--- Copyright : (c) Alberto Ruiz 2007--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable (uses FFI)------ Development utilities.------------------------------------------------------------------------------------ #hide--module Data.Packed.Internal.Common(- Adapt,- app1, app2, app3, app4,- app5, app6, app7, app8, app9, app10,- (//), check, mbCatch,- splitEvery, common, compatdim,- fi,- table-) where--import Foreign-import Control.Monad(when)-import Foreign.C.String(peekCString)-import Foreign.C.Types-import Foreign.Storable.Complex()-import Data.List(transpose,intersperse)-import Control.Exception as E---- | @splitEvery 3 [1..9] == [[1,2,3],[4,5,6],[7,8,9]]@-splitEvery :: Int -> [a] -> [[a]]-splitEvery _ [] = []-splitEvery k l = take k l : splitEvery k (drop k l)---- | obtains the common value of a property of a list-common :: (Eq a) => (b->a) -> [b] -> Maybe a-common f = commonval . map f where- commonval :: (Eq a) => [a] -> Maybe a- commonval [] = Nothing- commonval [a] = Just a- commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing---- | common value with \"adaptable\" 1-compatdim :: [Int] -> Maybe Int-compatdim [] = Nothing-compatdim [a] = Just a-compatdim (a:b:xs) = if a==b || a==1 || b==1 then compatdim (max a b:xs) else Nothing---- | Formatting tool-table :: String -> [[String]] -> String-table sep as = unlines . map unwords' $ transpose mtp where - mt = transpose as- longs = map (maximum . map length) mt- mtp = zipWith (\a b -> map (pad a) b) longs mt- pad n str = replicate (n - length str) ' ' ++ str- unwords' = concat . intersperse sep---- | postfix function application (@flip ($)@)-(//) :: x -> (x -> y) -> y-infixl 0 //-(//) = flip ($)---- | specialized fromIntegral-fi :: Int -> CInt-fi = fromIntegral---- hmm..-ww2 w1 o1 w2 o2 f = w1 o1 $ w2 o2 . f-ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ ww2 w2 o2 w3 o3 . f-ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ ww3 w2 o2 w3 o3 w4 o4 . f-ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 f = w1 o1 $ ww4 w2 o2 w3 o3 w4 o4 w5 o5 . f-ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 f = w1 o1 $ ww5 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 . f-ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 f = w1 o1 $ ww6 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 . f-ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 f = w1 o1 $ ww7 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 . f-ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 f = w1 o1 $ ww8 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 . f-ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 f = w1 o1 $ ww9 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 . f--type Adapt f t r = t -> ((f -> r) -> IO()) -> IO()--type Adapt1 f t1 = Adapt f t1 (IO CInt) -> t1 -> String -> IO()-type Adapt2 f t1 r1 t2 = Adapt f t1 r1 -> t1 -> Adapt1 r1 t2-type Adapt3 f t1 r1 t2 r2 t3 = Adapt f t1 r1 -> t1 -> Adapt2 r1 t2 r2 t3-type Adapt4 f t1 r1 t2 r2 t3 r3 t4 = Adapt f t1 r1 -> t1 -> Adapt3 r1 t2 r2 t3 r3 t4-type Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 = Adapt f t1 r1 -> t1 -> Adapt4 r1 t2 r2 t3 r3 t4 r4 t5-type Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 = Adapt f t1 r1 -> t1 -> Adapt5 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6-type Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 = Adapt f t1 r1 -> t1 -> Adapt6 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7-type Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 = Adapt f t1 r1 -> t1 -> Adapt7 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8-type Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 = Adapt f t1 r1 -> t1 -> Adapt8 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9-type Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 = Adapt f t1 r1 -> t1 -> Adapt9 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10--app1 :: f -> Adapt1 f t1-app2 :: f -> Adapt2 f t1 r1 t2-app3 :: f -> Adapt3 f t1 r1 t2 r2 t3-app4 :: f -> Adapt4 f t1 r1 t2 r2 t3 r3 t4-app5 :: f -> Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5-app6 :: f -> Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6-app7 :: f -> Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7-app8 :: f -> Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8-app9 :: f -> Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9-app10 :: f -> Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10--app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s-app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s-app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $- \a1 a2 a3 -> f // a1 // a2 // a3 // check s-app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $- \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s-app5 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 s = ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 $- \a1 a2 a3 a4 a5 -> f // a1 // a2 // a3 // a4 // a5 // check s-app6 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 s = ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 $- \a1 a2 a3 a4 a5 a6 -> f // a1 // a2 // a3 // a4 // a5 // a6 // check s-app7 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 s = ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 $- \a1 a2 a3 a4 a5 a6 a7 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // check s-app8 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 s = ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 $- \a1 a2 a3 a4 a5 a6 a7 a8 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // check s-app9 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 s = ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 $- \a1 a2 a3 a4 a5 a6 a7 a8 a9 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // check s-app10 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 s = ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 $- \a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // a10 // check s------ GSL error codes are <= 1024--- | error codes for the auxiliary functions required by the wrappers-errorCode :: CInt -> String-errorCode 2000 = "bad size"-errorCode 2001 = "bad function code"-errorCode 2002 = "memory problem"-errorCode 2003 = "bad file"-errorCode 2004 = "singular"-errorCode 2005 = "didn't converge"-errorCode 2006 = "the input matrix is not positive definite"-errorCode 2007 = "not yet supported in this OS"-errorCode n = "code "++show n----- | clear the fpu-foreign import ccall unsafe "asm_finit" finit :: IO ()---- | check the error code-check :: String -> IO CInt -> IO ()-check msg f = do-#if FINIT- finit-#endif- err <- f- when (err/=0) $ if err > 1024- then (error (msg++": "++errorCode err)) -- our errors- else do -- GSL errors- ps <- gsl_strerror err- s <- peekCString ps- error (msg++": "++s)- return ()---- | description of GSL error codes-foreign import ccall unsafe "gsl_strerror" gsl_strerror :: CInt -> IO (Ptr CChar)---- | Error capture and conversion to Maybe-mbCatch :: IO x -> IO (Maybe x)-mbCatch act = E.catch (Just `fmap` act) f- where f :: SomeException -> IO (Maybe x)- f _ = return Nothing
− lib/Data/Packed/Internal/Matrix.hs
@@ -1,461 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}--------------------------------------------------------------------------------- |--- Module : Data.Packed.Internal.Matrix--- Copyright : (c) Alberto Ruiz 2007--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable (uses FFI)------ Internal matrix representation------------------------------------------------------------------------------------ #hide--module Data.Packed.Internal.Matrix(- Matrix(..), rows, cols, cdat, fdat,- MatrixOrder(..), orderOf,- createMatrix, mat,- cmat, fmat,- toLists, flatten, reshape,- Element(..),- trans,- fromRows, toRows, fromColumns, toColumns,- matrixFromVector,- subMatrix,- liftMatrix, liftMatrix2,- (@@>), atM',- saveMatrix,- singleton,- size, shSize, conformVs, conformMs, conformVTo, conformMTo-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Data.Packed.Internal.Vector--import Foreign.Marshal.Alloc(alloca, free)-import Foreign.Marshal.Array(newArray)-import Foreign.Ptr(Ptr, castPtr)-import Foreign.Storable(Storable, peekElemOff, pokeElemOff, poke, sizeOf)-import Data.Complex(Complex)-import Foreign.C.Types-import Foreign.C.String(newCString)-import System.IO.Unsafe(unsafePerformIO)---------------------------------------------------------------------{- Design considerations for the Matrix Type- -------------------------------------------- we must easily handle both row major and column major order,- for bindings to LAPACK and GSL/C--- we'd like to simplify redundant matrix transposes:- - Some of them arise from the order requirements of some functions- - some functions (matrix product) admit transposed arguments--- maybe we don't really need this kind of simplification:- - more complex code- - some computational overhead- - only appreciable gain in code with a lot of redundant transpositions- and cheap matrix computations--- we could carry both the matrix and its (lazily computed) transpose.- This may save some transpositions, but it is necessary to keep track of the- data which is actually computed to be used by functions like the matrix product- which admit both orders.--- but if we need the transposed data and it is not in the structure, we must make- sure that we touch the same foreignptr that is used in the computation.--- a reasonable solution is using two constructors for a matrix. Transposition just- "flips" the constructor. Actual data transposition is not done if followed by a- matrix product or another transpose.---}--data MatrixOrder = RowMajor | ColumnMajor deriving (Show,Eq)--transOrder RowMajor = ColumnMajor-transOrder ColumnMajor = RowMajor-{- | Matrix representation suitable for GSL and LAPACK computations.--The elements are stored in a continuous memory array.---}--data Matrix t = Matrix { irows :: {-# UNPACK #-} !Int- , icols :: {-# UNPACK #-} !Int- , xdat :: {-# UNPACK #-} !(Vector t)- , order :: !MatrixOrder }--- RowMajor: preferred by C, fdat may require a transposition--- ColumnMajor: preferred by LAPACK, cdat may require a transposition--cdat = xdat-fdat = xdat--rows :: Matrix t -> Int-rows = irows--cols :: Matrix t -> Int-cols = icols--orderOf :: Matrix t -> MatrixOrder-orderOf = order----- | Matrix transpose.-trans :: Matrix t -> Matrix t-trans Matrix {irows = r, icols = c, xdat = d, order = o } = Matrix { irows = c, icols = r, xdat = d, order = transOrder o}--cmat :: (Element t) => Matrix t -> Matrix t-cmat m@Matrix{order = RowMajor} = m-cmat Matrix {irows = r, icols = c, xdat = d, order = ColumnMajor } = Matrix { irows = r, icols = c, xdat = transdata r d c, order = RowMajor}--fmat :: (Element t) => Matrix t -> Matrix t-fmat m@Matrix{order = ColumnMajor} = m-fmat Matrix {irows = r, icols = c, xdat = d, order = RowMajor } = Matrix { irows = r, icols = c, xdat = transdata c d r, order = ColumnMajor}---- C-Haskell matrix adapter--- mat :: Adapt (CInt -> CInt -> Ptr t -> r) (Matrix t) r--mat :: (Storable t) => Matrix t -> (((CInt -> CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b-mat a f =- unsafeWith (xdat a) $ \p -> do- let m g = do- g (fi (rows a)) (fi (cols a)) p- f m--{- | Creates a vector by concatenation of rows--@\> flatten ('ident' 3)-9 |> [1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0]@--}-flatten :: Element t => Matrix t -> Vector t-flatten = xdat . cmat--type Mt t s = Int -> Int -> Ptr t -> s--- not yet admitted by my haddock version--- infixr 6 ::>--- type t ::> s = Mt t s---- | the inverse of 'Data.Packed.Matrix.fromLists'-toLists :: (Element t) => Matrix t -> [[t]]-toLists m = splitEvery (cols m) . toList . flatten $ m---- | Create a matrix from a list of vectors.--- All vectors must have the same dimension,--- or dimension 1, which is are automatically expanded.-fromRows :: Element t => [Vector t] -> Matrix t-fromRows vs = case compatdim (map dim vs) of- Nothing -> error "fromRows applied to [] or to vectors with different sizes"- Just c -> reshape c . join . map (adapt c) $ vs- where- adapt c v | dim v == c = v- | otherwise = constantD (v@>0) c---- | extracts the rows of a matrix as a list of vectors-toRows :: Element t => Matrix t -> [Vector t]-toRows m = toRows' 0 where- v = flatten m- r = rows m- c = cols m- toRows' k | k == r*c = []- | otherwise = subVector k c v : toRows' (k+c)---- | Creates a matrix from a list of vectors, as columns-fromColumns :: Element t => [Vector t] -> Matrix t-fromColumns m = trans . fromRows $ m---- | Creates a list of vectors from the columns of a matrix-toColumns :: Element t => Matrix t -> [Vector t]-toColumns m = toRows . trans $ m---- | Reads a matrix position.-(@@>) :: Storable t => Matrix t -> (Int,Int) -> t-infixl 9 @@>-m@Matrix {irows = r, icols = c} @@> (i,j)- | safe = if i<0 || i>=r || j<0 || j>=c- then error "matrix indexing out of range"- else atM' m i j- | otherwise = atM' m i j-{-# INLINE (@@>) #-}---- Unsafe matrix access without range checking-atM' Matrix {icols = c, xdat = v, order = RowMajor} i j = v `at'` (i*c+j)-atM' Matrix {irows = r, xdat = v, order = ColumnMajor} i j = v `at'` (j*r+i)-{-# INLINE atM' #-}----------------------------------------------------------------------matrixFromVector o c v = Matrix { irows = r, icols = c, xdat = v, order = o }- where (d,m) = dim v `quotRem` c- r | m==0 = d- | otherwise = error "matrixFromVector"---- allocates memory for a new matrix-createMatrix :: (Storable a) => MatrixOrder -> Int -> Int -> IO (Matrix a)-createMatrix ord r c = do- p <- createVector (r*c)- return (matrixFromVector ord c p)--{- | Creates a matrix from a vector by grouping the elements in rows with the desired number of columns. (GNU-Octave groups by columns. To do it you can define @reshapeF r = trans . reshape r@-where r is the desired number of rows.)--@\> reshape 4 ('fromList' [1..12])-(3><4)- [ 1.0, 2.0, 3.0, 4.0- , 5.0, 6.0, 7.0, 8.0- , 9.0, 10.0, 11.0, 12.0 ]@---}-reshape :: Storable t => Int -> Vector t -> Matrix t-reshape c v = matrixFromVector RowMajor c v--singleton x = reshape 1 (fromList [x])---- | application of a vector function on the flattened matrix elements-liftMatrix :: (Storable a, Storable b) => (Vector a -> Vector b) -> Matrix a -> Matrix b-liftMatrix f Matrix { icols = c, xdat = d, order = o } = matrixFromVector o c (f d)---- | application of a vector function on the flattened matrices elements-liftMatrix2 :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t-liftMatrix2 f m1 m2- | not (compat m1 m2) = error "nonconformant matrices in liftMatrix2"- | otherwise = case orderOf m1 of- RowMajor -> matrixFromVector RowMajor (cols m1) (f (xdat m1) (flatten m2))- ColumnMajor -> matrixFromVector ColumnMajor (cols m1) (f (xdat m1) ((xdat.fmat) m2))---compat :: Matrix a -> Matrix b -> Bool-compat m1 m2 = rows m1 == rows m2 && cols m1 == cols m2----------------------------------------------------------------------{- | Supported matrix elements.-- This class provides optimized internal- operations for selected element types.- It provides unoptimised defaults for any 'Storable' type,- so you can create instances simply as:- @instance Element Foo@.--}-class (Storable a) => Element a where- subMatrixD :: (Int,Int) -- ^ (r0,c0) starting position - -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix- -> Matrix a -> Matrix a- subMatrixD = subMatrix'- transdata :: Int -> Vector a -> Int -> Vector a- transdata = transdataP -- transdata'- constantD :: a -> Int -> Vector a- constantD = constantP -- constant'---instance Element Float where- transdata = transdataAux ctransF- constantD = constantAux cconstantF--instance Element Double where- transdata = transdataAux ctransR- constantD = constantAux cconstantR--instance Element (Complex Float) where- transdata = transdataAux ctransQ- constantD = constantAux cconstantQ--instance Element (Complex Double) where- transdata = transdataAux ctransC- constantD = constantAux cconstantC-----------------------------------------------------------------------transdata' :: Storable a => Int -> Vector a -> Int -> Vector a-transdata' c1 v c2 =- if noneed- then v- else unsafePerformIO $ do- w <- createVector (r2*c2)- unsafeWith v $ \p ->- unsafeWith w $ \q -> do- let go (-1) _ = return ()- go !i (-1) = go (i-1) (c1-1)- go !i !j = do x <- peekElemOff p (i*c1+j)- pokeElemOff q (j*c2+i) x- go i (j-1)- go (r1-1) (c1-1)- return w- where r1 = dim v `div` c1- r2 = dim v `div` c2- noneed = r1 == 1 || c1 == 1---- {-# SPECIALIZE transdata' :: Int -> Vector Double -> Int -> Vector Double #-}--- {-# SPECIALIZE transdata' :: Int -> Vector (Complex Double) -> Int -> Vector (Complex Double) #-}---- I don't know how to specialize...--- The above pragmas only seem to work on top level defs--- Fortunately everything seems to work using the above class---- C versions, still a little faster:--transdataAux fun c1 d c2 =- if noneed- then d- else unsafePerformIO $ do- v <- createVector (dim d)- unsafeWith d $ \pd ->- unsafeWith v $ \pv ->- fun (fi r1) (fi c1) pd (fi r2) (fi c2) pv // check "transdataAux"- return v- where r1 = dim d `div` c1- r2 = dim d `div` c2- noneed = r1 == 1 || c1 == 1--transdataP :: Storable a => Int -> Vector a -> Int -> Vector a-transdataP c1 d c2 =- if noneed- then d- else unsafePerformIO $ do- v <- createVector (dim d)- unsafeWith d $ \pd ->- unsafeWith v $ \pv ->- ctransP (fi r1) (fi c1) (castPtr pd) (fi sz) (fi r2) (fi c2) (castPtr pv) (fi sz) // check "transdataP"- return v- where r1 = dim d `div` c1- r2 = dim d `div` c2- sz = sizeOf (d @> 0)- noneed = r1 == 1 || c1 == 1--foreign import ccall unsafe "transF" ctransF :: TFMFM-foreign import ccall unsafe "transR" ctransR :: TMM-foreign import ccall unsafe "transQ" ctransQ :: TQMQM-foreign import ccall unsafe "transC" ctransC :: TCMCM-foreign import ccall unsafe "transP" ctransP :: CInt -> CInt -> Ptr () -> CInt -> CInt -> CInt -> Ptr () -> CInt -> IO CInt--------------------------------------------------------------------------constant' v n = unsafePerformIO $ do- w <- createVector n- unsafeWith w $ \p -> do- let go (-1) = return ()- go !k = pokeElemOff p k v >> go (k-1)- go (n-1)- return w---- C versions--constantAux fun x n = unsafePerformIO $ do- v <- createVector n- px <- newArray [x]- app1 (fun px) vec v "constantAux"- free px- return v--constantF :: Float -> Int -> Vector Float-constantF = constantAux cconstantF-foreign import ccall unsafe "constantF" cconstantF :: Ptr Float -> TF--constantR :: Double -> Int -> Vector Double-constantR = constantAux cconstantR-foreign import ccall unsafe "constantR" cconstantR :: Ptr Double -> TV--constantQ :: Complex Float -> Int -> Vector (Complex Float)-constantQ = constantAux cconstantQ-foreign import ccall unsafe "constantQ" cconstantQ :: Ptr (Complex Float) -> TQV--constantC :: Complex Double -> Int -> Vector (Complex Double)-constantC = constantAux cconstantC-foreign import ccall unsafe "constantC" cconstantC :: Ptr (Complex Double) -> TCV--constantP :: Storable a => a -> Int -> Vector a-constantP a n = unsafePerformIO $ do- let sz = sizeOf a- v <- createVector n- unsafeWith v $ \p -> do- alloca $ \k -> do- poke k a- cconstantP (castPtr k) (fi n) (castPtr p) (fi sz) // check "constantP"- return v-foreign import ccall unsafe "constantP" cconstantP :: Ptr () -> CInt -> Ptr () -> CInt -> IO CInt---------------------------------------------------------------------------- | Extracts a submatrix from a matrix.-subMatrix :: Element a- => (Int,Int) -- ^ (r0,c0) starting position - -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix- -> Matrix a -- ^ input matrix- -> Matrix a -- ^ result-subMatrix (r0,c0) (rt,ct) m- | 0 <= r0 && 0 < rt && r0+rt <= (rows m) &&- 0 <= c0 && 0 < ct && c0+ct <= (cols m) = subMatrixD (r0,c0) (rt,ct) m- | otherwise = error $ "wrong subMatrix "++- show ((r0,c0),(rt,ct))++" of "++show(rows m)++"x"++ show (cols m)--subMatrix'' (r0,c0) (rt,ct) c v = unsafePerformIO $ do- w <- createVector (rt*ct)- unsafeWith v $ \p ->- unsafeWith w $ \q -> do- let go (-1) _ = return ()- go !i (-1) = go (i-1) (ct-1)- go !i !j = do x <- peekElemOff p ((i+r0)*c+j+c0)- pokeElemOff q (i*ct+j) x- go i (j-1)- go (rt-1) (ct-1)- return w--subMatrix' (r0,c0) (rt,ct) (Matrix { icols = c, xdat = v, order = RowMajor}) = Matrix rt ct (subMatrix'' (r0,c0) (rt,ct) c v) RowMajor-subMatrix' (r0,c0) (rt,ct) m = trans $ subMatrix' (c0,r0) (ct,rt) (trans m)-------------------------------------------------------------------------------- | Saves a matrix as 2D ASCII table.-saveMatrix :: FilePath- -> String -- ^ format (%f, %g, %e)- -> Matrix Double- -> IO ()-saveMatrix filename fmt m = do- charname <- newCString filename- charfmt <- newCString fmt- let o = if orderOf m == RowMajor then 1 else 0- app1 (matrix_fprintf charname charfmt o) mat m "matrix_fprintf"- free charname- free charfmt--foreign import ccall unsafe "matrix_fprintf" matrix_fprintf :: Ptr CChar -> Ptr CChar -> CInt -> TM--------------------------------------------------------------------------conformMs ms = map (conformMTo (r,c)) ms- where- r = maximum (map rows ms)- c = maximum (map cols ms)--conformVs vs = map (conformVTo n) vs- where- n = maximum (map dim vs)--conformMTo (r,c) m- | size m == (r,c) = m- | size m == (1,1) = reshape c (constantD (m@@>(0,0)) (r*c))- | size m == (r,1) = repCols c m- | size m == (1,c) = repRows r m- | otherwise = error $ "matrix " ++ shSize m ++ " cannot be expanded to (" ++ show r ++ "><"++ show c ++")"--conformVTo n v- | dim v == n = v- | dim v == 1 = constantD (v@>0) n- | otherwise = error $ "vector of dim=" ++ show (dim v) ++ " cannot be expanded to dim=" ++ show n--repRows n x = fromRows (replicate n (flatten x))-repCols n x = fromColumns (replicate n (flatten x))--size m = (rows m, cols m)--shSize m = "(" ++ show (rows m) ++"><"++ show (cols m)++")"-
− lib/Data/Packed/Internal/Signatures.hs
@@ -1,72 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Packed.Internal.Signatures--- Copyright : (c) Alberto Ruiz 2009--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable (uses FFI)------ Signatures of the C functions.-----------------------------------------------------------------------------------module Data.Packed.Internal.Signatures where--import Foreign.Ptr(Ptr)-import Data.Complex(Complex)-import Foreign.C.Types(CInt)--type PF = Ptr Float ---type PD = Ptr Double ---type PQ = Ptr (Complex Float) ---type PC = Ptr (Complex Double) ---type TF = CInt -> PF -> IO CInt ---type TFF = CInt -> PF -> TF ---type TFV = CInt -> PF -> TV ---type TVF = CInt -> PD -> TF ---type TFFF = CInt -> PF -> TFF ---type TV = CInt -> PD -> IO CInt ---type TVV = CInt -> PD -> TV ---type TVVV = CInt -> PD -> TVV ---type TFM = CInt -> CInt -> PF -> IO CInt ---type TFMFM = CInt -> CInt -> PF -> TFM ---type TFMFMFM = CInt -> CInt -> PF -> TFMFM ---type TM = CInt -> CInt -> PD -> IO CInt ---type TMM = CInt -> CInt -> PD -> TM ---type TVMM = CInt -> PD -> TMM ---type TMVMM = CInt -> CInt -> PD -> TVMM ---type TMMM = CInt -> CInt -> PD -> TMM ---type TVM = CInt -> PD -> TM ---type TVVM = CInt -> PD -> TVM ---type TMV = CInt -> CInt -> PD -> TV ---type TMMV = CInt -> CInt -> PD -> TMV ---type TMVM = CInt -> CInt -> PD -> TVM ---type TMMVM = CInt -> CInt -> PD -> TMVM ---type TCM = CInt -> CInt -> PC -> IO CInt ---type TCVCM = CInt -> PC -> TCM ---type TCMCVCM = CInt -> CInt -> PC -> TCVCM ---type TMCMCVCM = CInt -> CInt -> PD -> TCMCVCM ---type TCMCMCVCM = CInt -> CInt -> PC -> TCMCVCM ---type TCMCM = CInt -> CInt -> PC -> TCM ---type TVCM = CInt -> PD -> TCM ---type TCMVCM = CInt -> CInt -> PC -> TVCM ---type TCMCMVCM = CInt -> CInt -> PC -> TCMVCM ---type TCMCMCM = CInt -> CInt -> PC -> TCMCM ---type TCV = CInt -> PC -> IO CInt ---type TCVCV = CInt -> PC -> TCV ---type TCVCVCV = CInt -> PC -> TCVCV ---type TCVV = CInt -> PC -> TV ---type TQV = CInt -> PQ -> IO CInt ---type TQVQV = CInt -> PQ -> TQV ---type TQVQVQV = CInt -> PQ -> TQVQV ---type TQVF = CInt -> PQ -> TF ---type TQM = CInt -> CInt -> PQ -> IO CInt ---type TQMQM = CInt -> CInt -> PQ -> TQM ---type TQMQMQM = CInt -> CInt -> PQ -> TQMQM ---type TCMCV = CInt -> CInt -> PC -> TCV ---type TVCV = CInt -> PD -> TCV ---type TCVM = CInt -> PC -> TM ---type TMCVM = CInt -> CInt -> PD -> TCVM ---type TMMCVM = CInt -> CInt -> PD -> TMCVM --
− lib/Data/Packed/Internal/Vector.hs
@@ -1,582 +0,0 @@-{-# LANGUAGE MagicHash, CPP, UnboxedTuples, BangPatterns, FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module : Data.Packed.Internal.Vector--- Copyright : (c) Alberto Ruiz 2007--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable (uses FFI)------ Vector implementation-----------------------------------------------------------------------------------module Data.Packed.Internal.Vector (- Vector, dim,- fromList, toList, (|>),- join, (@>), safe, at, at', subVector, takesV,- mapVector, mapVectorWithIndex, zipVectorWith, unzipVectorWith,- mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_,- foldVector, foldVectorG, foldLoop, foldVectorWithIndex,- createVector, vec,- asComplex, asReal, float2DoubleV, double2FloatV,- stepF, stepD, condF, condD,- conjugateQ, conjugateC,- fwriteVector, freadVector, fprintfVector, fscanfVector,- cloneVector,- unsafeToForeignPtr,- unsafeFromForeignPtr,- unsafeWith-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Foreign.Marshal.Alloc(free)-import Foreign.Marshal.Array(peekArray, pokeArray, copyArray, advancePtr)-import Foreign.ForeignPtr(ForeignPtr, castForeignPtr)-import Foreign.Ptr(Ptr)-import Foreign.Storable(Storable, peekElemOff, pokeElemOff, sizeOf)-import Foreign.C.String-import Foreign.C.Types-import Data.Complex-import Control.Monad(when)-import System.IO.Unsafe(unsafePerformIO)--#if __GLASGOW_HASKELL__ >= 605-import GHC.ForeignPtr (mallocPlainForeignPtrBytes)-#else-import Foreign.ForeignPtr (mallocForeignPtrBytes)-#endif--import GHC.Base-#if __GLASGOW_HASKELL__ < 612-import GHC.IOBase hiding (liftIO)-#endif--#ifdef VECTOR-import qualified Data.Vector.Storable as Vector-import Data.Vector.Storable(Vector,- unsafeToForeignPtr,- unsafeFromForeignPtr,- unsafeWith)-#else-import Foreign.ForeignPtr(withForeignPtr)-#endif--#ifdef VECTOR---- | Number of elements-dim :: (Storable t) => Vector t -> Int-dim = Vector.length--#else---- | One-dimensional array of objects stored in a contiguous memory block.-data Vector t =- V { ioff :: {-# UNPACK #-} !Int -- ^ offset of first element- , idim :: {-# UNPACK #-} !Int -- ^ number of elements- , fptr :: {-# UNPACK #-} !(ForeignPtr t) -- ^ foreign pointer to the memory block- }--unsafeToForeignPtr :: Storable a => Vector a -> (ForeignPtr a, Int, Int)-unsafeToForeignPtr v = (fptr v, ioff v, idim v)---- | Same convention as in Roman Leshchinskiy's vector package.-unsafeFromForeignPtr :: Storable a => ForeignPtr a -> Int -> Int -> Vector a-unsafeFromForeignPtr fp i n | n > 0 = V {ioff = i, idim = n, fptr = fp}- | otherwise = error "unsafeFromForeignPtr with dim < 1"--unsafeWith (V i _ fp) m = withForeignPtr fp $ \p -> m (p `advancePtr` i)-{-# INLINE unsafeWith #-}---- | Number of elements-dim :: (Storable t) => Vector t -> Int-dim = idim--#endif----- C-Haskell vector adapter--- vec :: Adapt (CInt -> Ptr t -> r) (Vector t) r-vec :: (Storable t) => Vector t -> (((CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b-vec x f = unsafeWith x $ \p -> do- let v g = do- g (fi $ dim x) p- f v-{-# INLINE vec #-}----- allocates memory for a new vector-createVector :: Storable a => Int -> IO (Vector a)-createVector n = do- when (n <= 0) $ error ("trying to createVector of dim "++show n)- fp <- doMalloc undefined- return $ unsafeFromForeignPtr fp 0 n- where- --- -- Use the much cheaper Haskell heap allocated storage- -- for foreign pointer space we control- --- doMalloc :: Storable b => b -> IO (ForeignPtr b)- doMalloc dummy = do-#if __GLASGOW_HASKELL__ >= 605- mallocPlainForeignPtrBytes (n * sizeOf dummy)-#else- mallocForeignPtrBytes (n * sizeOf dummy)-#endif--{- | creates a Vector from a list:--@> fromList [2,3,5,7]-4 |> [2.0,3.0,5.0,7.0]@---}-fromList :: Storable a => [a] -> Vector a-fromList l = unsafePerformIO $ do- v <- createVector (length l)- unsafeWith v $ \ p -> pokeArray p l- return v--safeRead v = inlinePerformIO . unsafeWith v-{-# INLINE safeRead #-}--inlinePerformIO :: IO a -> a-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-{-# INLINE inlinePerformIO #-}--{- | extracts the Vector elements to a list--@> toList (linspace 5 (1,10))-[1.0,3.25,5.5,7.75,10.0]@---}-toList :: Storable a => Vector a -> [a]-toList v = safeRead v $ peekArray (dim v)--{- | An alternative to 'fromList' with explicit dimension. The input- list is explicitly truncated if it is too long, so it may safely- be used, for instance, with infinite lists.-- This is the format used in the instances for Show (Vector a).--}-(|>) :: (Storable a) => Int -> [a] -> Vector a-infixl 9 |>-n |> l = if length l' == n- then fromList l'- else error "list too short for |>"- where l' = take n l----- | access to Vector elements without range checking-at' :: Storable a => Vector a -> Int -> a-at' v n = safeRead v $ flip peekElemOff n-{-# INLINE at' #-}------- turn off bounds checking with -funsafe at configure time.--- ghc will optimise away the salways true case at compile time.----#if defined(UNSAFE)-safe :: Bool-safe = False-#else-safe = True-#endif---- | access to Vector elements with range checking.-at :: Storable a => Vector a -> Int -> a-at v n- | safe = if n >= 0 && n < dim v- then at' v n- else error "vector index out of range"- | otherwise = at' v n-{-# INLINE at #-}--{- | takes a number of consecutive elements from a Vector--@> subVector 2 3 (fromList [1..10])-3 |> [3.0,4.0,5.0]@---}-subVector :: Storable t => Int -- ^ index of the starting element- -> Int -- ^ number of elements to extract- -> Vector t -- ^ source- -> Vector t -- ^ result--#ifdef VECTOR--subVector = Vector.slice--{--subVector k l v- | k<0 || k >= n || k+l > n || l < 0 = error "subVector out of range"- | otherwise = unsafeFromForeignPtr fp (i+k) l- where- (fp, i, n) = unsafeToForeignPtr v--}--#else--subVector k l v@V{idim = n, ioff = i}- | k<0 || k >= n || k+l > n || l < 0 = error "subVector out of range"- | otherwise = v {idim = l, ioff = i+k}--{--subVectorCopy k l (v@V {idim=n})- | k<0 || k >= n || k+l > n || l < 0 = error "subVector out of range"- | otherwise = unsafePerformIO $ do- r <- createVector l- let f _ s _ d = copyArray d (advancePtr s k) l >> return 0- app2 f vec v vec r "subVector"- return r--}--#endif--{- | Reads a vector position:--@> fromList [0..9] \@\> 7-7.0@---}-(@>) :: Storable t => Vector t -> Int -> t-infixl 9 @>-(@>) = at---{- | creates a new Vector by joining a list of Vectors--@> join [fromList [1..5], constant 1 3]-8 |> [1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0]@---}-join :: Storable t => [Vector t] -> Vector t-join [] = error "joining zero vectors"-join [v] = v-join as = unsafePerformIO $ do- let tot = sum (map dim as)- r <- createVector tot- unsafeWith r $ \ptr ->- joiner as tot ptr- return r- where joiner [] _ _ = return ()- joiner (v:cs) _ p = do- let n = dim v- unsafeWith v $ \pb -> copyArray p pb n- joiner cs 0 (advancePtr p n)---{- | Extract consecutive subvectors of the given sizes.--@> takesV [3,4] (linspace 10 (1,10))-[3 |> [1.0,2.0,3.0],4 |> [4.0,5.0,6.0,7.0]]@---}-takesV :: Storable t => [Int] -> Vector t -> [Vector t]-takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w)- | otherwise = go ms w- where go [] _ = []- go (n:ns) v = subVector 0 n v- : go ns (subVector n (dim v - n) v)--------------------------------------------------------------------- | transforms a complex vector into a real vector with alternating real and imaginary parts -asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a-asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n)- where (fp,i,n) = unsafeToForeignPtr v---- | transforms a real vector into a complex vector with alternating real and imaginary parts-asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a)-asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2)- where (fp,i,n) = unsafeToForeignPtr v-------------------------------------------------------------------float2DoubleV :: Vector Float -> Vector Double-float2DoubleV v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_float2double vec v vec r "float2double"- return r--double2FloatV :: Vector Double -> Vector Float-double2FloatV v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_double2float vec v vec r "double2float2"- return r---foreign import ccall unsafe "float2double" c_float2double:: TFV-foreign import ccall unsafe "double2float" c_double2float:: TVF-------------------------------------------------------------------stepF :: Vector Float -> Vector Float-stepF v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_stepF vec v vec r "stepF"- return r--stepD :: Vector Double -> Vector Double-stepD v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_stepD vec v vec r "stepD"- return r--foreign import ccall unsafe "stepF" c_stepF :: TFF-foreign import ccall unsafe "stepD" c_stepD :: TVV-------------------------------------------------------------------condF :: Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float-condF x y l e g = unsafePerformIO $ do- r <- createVector (dim x)- app6 c_condF vec x vec y vec l vec e vec g vec r "condF"- return r--condD :: Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double-condD x y l e g = unsafePerformIO $ do- r <- createVector (dim x)- app6 c_condD vec x vec y vec l vec e vec g vec r "condD"- return r--foreign import ccall unsafe "condF" c_condF :: CInt -> PF -> CInt -> PF -> CInt -> PF -> TFFF-foreign import ccall unsafe "condD" c_condD :: CInt -> PD -> CInt -> PD -> CInt -> PD -> TVVV------------------------------------------------------------------------------------conjugateAux fun x = unsafePerformIO $ do- v <- createVector (dim x)- app2 fun vec x vec v "conjugateAux"- return v--conjugateQ :: Vector (Complex Float) -> Vector (Complex Float)-conjugateQ = conjugateAux c_conjugateQ-foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TQVQV--conjugateC :: Vector (Complex Double) -> Vector (Complex Double)-conjugateC = conjugateAux c_conjugateC-foreign import ccall unsafe "conjugateC" c_conjugateC :: TCVCV------------------------------------------------------------------------------------cloneVector :: Storable t => Vector t -> IO (Vector t)-cloneVector v = do- let n = dim v- r <- createVector n- let f _ s _ d = copyArray d s n >> return 0- app2 f vec v vec r "cloneVector"- return r------------------------------------------------------------------------ | map on Vectors-mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b-mapVector f v = unsafePerformIO $ do- w <- createVector (dim v)- unsafeWith v $ \p ->- unsafeWith w $ \q -> do- let go (-1) = return ()- go !k = do x <- peekElemOff p k- pokeElemOff q k (f x)- go (k-1)- go (dim v -1)- return w-{-# INLINE mapVector #-}---- | zipWith for Vectors-zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c-zipVectorWith f u v = unsafePerformIO $ do- let n = min (dim u) (dim v)- w <- createVector n- unsafeWith u $ \pu ->- unsafeWith v $ \pv ->- unsafeWith w $ \pw -> do- let go (-1) = return ()- go !k = do x <- peekElemOff pu k- y <- peekElemOff pv k- pokeElemOff pw k (f x y)- go (k-1)- go (n -1)- return w-{-# INLINE zipVectorWith #-}---- | unzipWith for Vectors-unzipVectorWith :: (Storable (a,b), Storable c, Storable d) - => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d)-unzipVectorWith f u = unsafePerformIO $ do- let n = dim u- v <- createVector n- w <- createVector n- unsafeWith u $ \pu ->- unsafeWith v $ \pv ->- unsafeWith w $ \pw -> do- let go (-1) = return ()- go !k = do z <- peekElemOff pu k- let (x,y) = f z - pokeElemOff pv k x- pokeElemOff pw k y- go (k-1)- go (n-1)- return (v,w)-{-# INLINE unzipVectorWith #-}--foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b-foldVector f x v = unsafePerformIO $- unsafeWith v $ \p -> do- let go (-1) s = return s- go !k !s = do y <- peekElemOff p k- go (k-1::Int) (f y s)- go (dim v -1) x-{-# INLINE foldVector #-}---- the zero-indexed index is passed to the folding function-foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b-foldVectorWithIndex f x v = unsafePerformIO $- unsafeWith v $ \p -> do- let go (-1) s = return s- go !k !s = do y <- peekElemOff p k- go (k-1::Int) (f k y s)- go (dim v -1) x-{-# INLINE foldVectorWithIndex #-}--foldLoop f s0 d = go (d - 1) s0- where- go 0 s = f (0::Int) s- go !j !s = go (j - 1) (f j s)--foldVectorG f s0 v = foldLoop g s0 (dim v)- where g !k !s = f k (at' v) s- {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479)-{-# INLINE foldVectorG #-}------------------------------------------------------------------------- | monadic map over Vectors--- the monad @m@ must be strict-mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b)-mapVectorM f v = do- w <- return $! unsafePerformIO $! createVector (dim v)- mapVectorM' w 0 (dim v -1)- return w- where mapVectorM' w' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f x- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f x- _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- mapVectorM' w' (k+1) t-{-# INLINE mapVectorM #-}---- | monadic map over Vectors-mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m ()-mapVectorM_ f v = do- mapVectorM' 0 (dim v -1)- where mapVectorM' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k- f x- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - _ <- f x- mapVectorM' (k+1) t-{-# INLINE mapVectorM_ #-}---- | monadic map over Vectors with the zero-indexed index passed to the mapping function--- the monad @m@ must be strict-mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b)-mapVectorWithIndexM f v = do- w <- return $! unsafePerformIO $! createVector (dim v)- mapVectorM' w 0 (dim v -1)- return w- where mapVectorM' w' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f k x- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f k x- _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- mapVectorM' w' (k+1) t-{-# INLINE mapVectorWithIndexM #-}---- | monadic map over Vectors with the zero-indexed index passed to the mapping function-mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m ()-mapVectorWithIndexM_ f v = do- mapVectorM' 0 (dim v -1)- where mapVectorM' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k- f k x- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - _ <- f k x- mapVectorM' (k+1) t-{-# INLINE mapVectorWithIndexM_ #-}---mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b---mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b])-mapVectorWithIndex f v = unsafePerformIO $ do- w <- createVector (dim v)- unsafeWith v $ \p ->- unsafeWith w $ \q -> do- let go (-1) = return ()- go !k = do x <- peekElemOff p k- pokeElemOff q k (f k x)- go (k-1)- go (dim v -1)- return w-{-# INLINE mapVectorWithIndex #-}-------------------------------------------------------------------------- | Loads a vector from an ASCII file (the number of elements must be known in advance).-fscanfVector :: FilePath -> Int -> IO (Vector Double)-fscanfVector filename n = do- charname <- newCString filename- res <- createVector n- app1 (gsl_vector_fscanf charname) vec res "gsl_vector_fscanf"- free charname- return res--foreign import ccall unsafe "vector_fscanf" gsl_vector_fscanf:: Ptr CChar -> TV---- | Saves the elements of a vector, with a given format (%f, %e, %g), to an ASCII file.-fprintfVector :: FilePath -> String -> Vector Double -> IO ()-fprintfVector filename fmt v = do- charname <- newCString filename- charfmt <- newCString fmt- app1 (gsl_vector_fprintf charname charfmt) vec v "gsl_vector_fprintf"- free charname- free charfmt--foreign import ccall unsafe "vector_fprintf" gsl_vector_fprintf :: Ptr CChar -> Ptr CChar -> TV---- | Loads a vector from a binary file (the number of elements must be known in advance).-freadVector :: FilePath -> Int -> IO (Vector Double)-freadVector filename n = do- charname <- newCString filename- res <- createVector n- app1 (gsl_vector_fread charname) vec res "gsl_vector_fread"- free charname- return res--foreign import ccall unsafe "vector_fread" gsl_vector_fread:: Ptr CChar -> TV---- | Saves the elements of a vector to a binary file.-fwriteVector :: FilePath -> Vector Double -> IO ()-fwriteVector filename v = do- charname <- newCString filename- app1 (gsl_vector_fwrite charname) vec v "gsl_vector_fwrite"- free charname--foreign import ccall unsafe "vector_fwrite" gsl_vector_fwrite :: Ptr CChar -> TV-
− lib/Data/Packed/Matrix.hs
@@ -1,406 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module : Data.Packed.Matrix--- Copyright : (c) Alberto Ruiz 2007-10--- License : GPL------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional------ A Matrix representation suitable for numerical computations using LAPACK and GSL.------ This module provides basic functions for manipulation of structure.---------------------------------------------------------------------------------module Data.Packed.Matrix (- Matrix,- Element,- rows,cols,- (><),- trans,- reshape, flatten,- fromLists, toLists, buildMatrix,- (@@>),- asRow, asColumn,- fromRows, toRows, fromColumns, toColumns,- fromBlocks, toBlocks, toBlocksEvery,- repmat,- flipud, fliprl,- subMatrix, takeRows, dropRows, takeColumns, dropColumns,- extractRows,- diagRect, takeDiag,- mapMatrix, mapMatrixWithIndex, mapMatrixWithIndexM, mapMatrixWithIndexM_,- liftMatrix, liftMatrix2, liftMatrix2Auto,fromArray2D-) where--import Data.Packed.Internal-import qualified Data.Packed.ST as ST-import Data.Array--import Data.List(transpose,intersperse)-import Foreign.Storable(Storable)-import Control.Arrow((***))-----------------------------------------------------------------------#ifdef BINARY--import Data.Binary-import Control.Monad(replicateM)--instance (Binary a, Element a, Storable a) => Binary (Matrix a) where- put m = do- let r = rows m- let c = cols m- put r- put c- mapM_ (\i -> mapM_ (\j -> put $ m @@> (i,j)) [0..(c-1)]) [0..(r-1)]- get = do- r <- get- c <- get- xs <- replicateM r $ replicateM c get- return $ fromLists xs--#endif-----------------------------------------------------------------------instance (Show a, Element a) => (Show (Matrix a)) where- show m = (sizes++) . dsp . map (map show) . toLists $ m- where sizes = "("++show (rows m)++"><"++show (cols m)++")\n"--dsp as = (++" ]") . (" ["++) . init . drop 2 . unlines . map (" , "++) . map unwords' $ transpose mtp- where- mt = transpose as- longs = map (maximum . map length) mt- mtp = zipWith (\a b -> map (pad a) b) longs mt- pad n str = replicate (n - length str) ' ' ++ str- unwords' = concat . intersperse ", "----------------------------------------------------------------------instance (Element a, Read a) => Read (Matrix a) where- readsPrec _ s = [((rs><cs) . read $ listnums, rest)]- where (thing,rest) = breakAt ']' s- (dims,listnums) = breakAt ')' thing- cs = read . init . fst. breakAt ')' . snd . breakAt '<' $ dims- rs = read . snd . breakAt '(' .init . fst . breakAt '>' $ dims---breakAt c l = (a++[c],tail b) where- (a,b) = break (==c) l------------------------------------------------------------------------ | creates a matrix from a vertical list of matrices-joinVert :: Element t => [Matrix t] -> Matrix t-joinVert ms = case common cols ms of- Nothing -> error "(impossible) joinVert on matrices with different number of columns"- Just c -> reshape c $ join (map flatten ms)---- | creates a matrix from a horizontal list of matrices-joinHoriz :: Element t => [Matrix t] -> Matrix t-joinHoriz ms = trans. joinVert . map trans $ ms--{- | Creates a matrix from blocks given as a list of lists of matrices.--Single row/column components are automatically expanded to match the-corresponding common row and column:--@\> let disp = putStr . dispf 2-\> let vector xs = fromList xs :: Vector Double-\> let diagl = diag . vector-\> let rowm = asRow . vector--\> disp $ fromBlocks [[ident 5, 7, rowm[10,20]], [3, diagl[1,2,3], 0]]--8x10-1 0 0 0 0 7 7 7 10 20-0 1 0 0 0 7 7 7 10 20-0 0 1 0 0 7 7 7 10 20-0 0 0 1 0 7 7 7 10 20-0 0 0 0 1 7 7 7 10 20-3 3 3 3 3 1 0 0 0 0-3 3 3 3 3 0 2 0 0 0-3 3 3 3 3 0 0 3 0 0@--}-fromBlocks :: Element t => [[Matrix t]] -> Matrix t-fromBlocks = fromBlocksRaw . adaptBlocks--fromBlocksRaw mms = joinVert . map joinHoriz $ mms--adaptBlocks ms = ms' where- bc = case common length ms of- Just c -> c- Nothing -> error "fromBlocks requires rectangular [[Matrix]]"- rs = map (compatdim . map rows) ms- cs = map (compatdim . map cols) (transpose ms)- szs = sequence [rs,cs]- ms' = splitEvery bc $ zipWith g szs (concat ms)-- g [Just nr,Just nc] m- | nr == r && nc == c = m- | r == 1 && c == 1 = reshape nc (constantD x (nr*nc))- | r == 1 = fromRows (replicate nr (flatten m))- | otherwise = fromColumns (replicate nc (flatten m))- where- r = rows m- c = cols m- x = m@@>(0,0)- g _ _ = error "inconsistent dimensions in fromBlocks"----------------------------------------------------------------- | Reverse rows -flipud :: Element t => Matrix t -> Matrix t-flipud m = fromRows . reverse . toRows $ m---- | Reverse columns-fliprl :: Element t => Matrix t -> Matrix t-fliprl m = fromColumns . reverse . toColumns $ m----------------------------------------------------------------{- | creates a rectangular diagonal matrix:--@> diagRect 7 (fromList [10,20,30]) 4 5 :: Matrix Double-(4><5)- [ 10.0, 7.0, 7.0, 7.0, 7.0- , 7.0, 20.0, 7.0, 7.0, 7.0- , 7.0, 7.0, 30.0, 7.0, 7.0- , 7.0, 7.0, 7.0, 7.0, 7.0 ]@--}-diagRect :: (Storable t) => t -> Vector t -> Int -> Int -> Matrix t-diagRect z v r c = ST.runSTMatrix $ do- m <- ST.newMatrix z r c- let d = min r c `min` (dim v)- mapM_ (\k -> ST.writeMatrix m k k (v@>k)) [0..d-1]- return m---- | extracts the diagonal from a rectangular matrix-takeDiag :: (Element t) => Matrix t -> Vector t-takeDiag m = fromList [flatten m `at` (k*cols m+k) | k <- [0 .. min (rows m) (cols m) -1]]----------------------------------------------------------------{- | An easy way to create a matrix:--@\> (2><3)[1..6]-(2><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0 ]@--This is the format produced by the instances of Show (Matrix a), which-can also be used for input.--The input list is explicitly truncated, so that it can-safely be used with lists that are too long (like infinite lists).--Example:--@\> (2><3)[1..]-(2><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0 ]@---}-(><) :: (Storable a) => Int -> Int -> [a] -> Matrix a-r >< c = f where- f l | dim v == r*c = matrixFromVector RowMajor c v- | otherwise = error $ "inconsistent list size = "- ++show (dim v) ++" in ("++show r++"><"++show c++")"- where v = fromList $ take (r*c) l---------------------------------------------------------------------- | Creates a matrix with the first n rows of another matrix-takeRows :: Element t => Int -> Matrix t -> Matrix t-takeRows n mt = subMatrix (0,0) (n, cols mt) mt--- | Creates a copy of a matrix without the first n rows-dropRows :: Element t => Int -> Matrix t -> Matrix t-dropRows n mt = subMatrix (n,0) (rows mt - n, cols mt) mt--- |Creates a matrix with the first n columns of another matrix-takeColumns :: Element t => Int -> Matrix t -> Matrix t-takeColumns n mt = subMatrix (0,0) (rows mt, n) mt--- | Creates a copy of a matrix without the first n columns-dropColumns :: Element t => Int -> Matrix t -> Matrix t-dropColumns n mt = subMatrix (0,n) (rows mt, cols mt - n) mt--------------------------------------------------------------------{- | Creates a 'Matrix' from a list of lists (considered as rows).--@\> fromLists [[1,2],[3,4],[5,6]]-(3><2)- [ 1.0, 2.0- , 3.0, 4.0- , 5.0, 6.0 ]@--}-fromLists :: Element t => [[t]] -> Matrix t-fromLists = fromRows . map fromList---- | creates a 1-row matrix from a vector-asRow :: Storable a => Vector a -> Matrix a-asRow v = reshape (dim v) v---- | creates a 1-column matrix from a vector-asColumn :: Storable a => Vector a -> Matrix a-asColumn v = reshape 1 v----{- | creates a Matrix of the specified size using the supplied function to- to map the row\/column position to the value at that row\/column position.--@> buildMatrix 3 4 (\\(r,c) -> fromIntegral r * fromIntegral c)-(3><4)- [ 0.0, 0.0, 0.0, 0.0, 0.0- , 0.0, 1.0, 2.0, 3.0, 4.0- , 0.0, 2.0, 4.0, 6.0, 8.0]@--Hilbert matrix of order N:--@hilb n = buildMatrix n n (\\(i,j)->1/(fromIntegral i + fromIntegral j +1))@---}-buildMatrix :: Element a => Int -> Int -> ((Int, Int) -> a) -> Matrix a-buildMatrix rc cc f =- fromLists $ map (map f)- $ map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)]---------------------------------------------------------fromArray2D :: (Storable e) => Array (Int, Int) e -> Matrix e-fromArray2D m = (r><c) (elems m)- where ((r0,c0),(r1,c1)) = bounds m- r = r1-r0+1- c = c1-c0+1----- | rearranges the rows of a matrix according to the order given in a list of integers. -extractRows :: Element t => [Int] -> Matrix t -> Matrix t-extractRows l m = fromRows $ extract (toRows m) l- where extract l' is = [l'!!i |i<-is]--{- | creates matrix by repetition of a matrix a given number of rows and columns--@> repmat (ident 2) 2 3 :: Matrix Double-(4><6)- [ 1.0, 0.0, 1.0, 0.0, 1.0, 0.0- , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0- , 1.0, 0.0, 1.0, 0.0, 1.0, 0.0- , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 ]@---}-repmat :: (Element t) => Matrix t -> Int -> Int -> Matrix t-repmat m r c = fromBlocks $ splitEvery c $ replicate (r*c) m---- | A version of 'liftMatrix2' which automatically adapt matrices with a single row or column to match the dimensions of the other matrix.-liftMatrix2Auto :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t-liftMatrix2Auto f m1 m2- | compat' m1 m2 = lM f m1 m2- | ok = lM f m1' m2'- | otherwise = error $ "nonconformable matrices in liftMatrix2Auto: " ++ shSize m1 ++ ", " ++ shSize m2- where- (r1,c1) = size m1- (r2,c2) = size m2- r = max r1 r2- c = max c1 c2- r0 = min r1 r2- c0 = min c1 c2- ok = r0 == 1 || r1 == r2 && c0 == 1 || c1 == c2- m1' = conformMTo (r,c) m1- m2' = conformMTo (r,c) m2--lM f m1 m2 = reshape (max (cols m1) (cols m2)) (f (flatten m1) (flatten m2))--compat' :: Matrix a -> Matrix b -> Bool-compat' m1 m2 = s1 == (1,1) || s2 == (1,1) || s1 == s2- where- s1 = size m1- s2 = size m2----------------------------------------------------------------toBlockRows [r] m | r == rows m = [m]-toBlockRows rs m = map (reshape (cols m)) (takesV szs (flatten m))- where szs = map (* cols m) rs--toBlockCols [c] m | c == cols m = [m]-toBlockCols cs m = map trans . toBlockRows cs . trans $ m---- | Partition a matrix into blocks with the given numbers of rows and columns.--- The remaining rows and columns are discarded.-toBlocks :: (Element t) => [Int] -> [Int] -> Matrix t -> [[Matrix t]]-toBlocks rs cs m = map (toBlockCols cs) . toBlockRows rs $ m---- | Fully partition a matrix into blocks of the same size. If the dimensions are not--- a multiple of the given size the last blocks will be smaller.-toBlocksEvery :: (Element t) => Int -> Int -> Matrix t -> [[Matrix t]]-toBlocksEvery r c m = toBlocks rs cs m where- (qr,rr) = rows m `divMod` r- (qc,rc) = cols m `divMod` c- rs = replicate qr r ++ if rr > 0 then [rr] else []- cs = replicate qc c ++ if rc > 0 then [rc] else []-----------------------------------------------------------------------mk c g = \k v -> g ((fromIntegral *** fromIntegral) (divMod k c)) v --{- | --@ghci> mapMatrixWithIndexM_ (\\(i,j) v -> printf \"m[%.0f,%.0f] = %.f\\n\" i j v :: IO()) ((2><3)[1 :: Double ..])-m[0,0] = 1-m[0,1] = 2-m[0,2] = 3-m[1,0] = 4-m[1,1] = 5-m[1,2] = 6@--}-mapMatrixWithIndexM_- :: (Element a, Num a,- Functor f, Monad f) =>- ((a, a) -> a -> f ()) -> Matrix a -> f ()-mapMatrixWithIndexM_ g m = mapVectorWithIndexM_ (mk c g) . flatten $ m - where- c = cols m--{- |--@ghci> mapMatrixWithIndexM (\\(i,j) v -> Just $ 100*v + 10*i + j) (ident 3:: Matrix Double)-Just (3><3)- [ 100.0, 1.0, 2.0- , 10.0, 111.0, 12.0- , 20.0, 21.0, 122.0 ]@--}-mapMatrixWithIndexM- :: (Foreign.Storable.Storable t, - Element a, Num a,- Functor f, Monad f) =>- ((a, a) -> a -> f t) -> Matrix a -> f (Matrix t)-mapMatrixWithIndexM g m = fmap (reshape c) . mapVectorWithIndexM (mk c g) . flatten $ m - where- c = cols m--{- |-@ghci> mapMatrixWithIndex (\\(i,j) v -> 100*v + 10*i + j) (ident 3:: Matrix Double)-(3><3)- [ 100.0, 1.0, 2.0- , 10.0, 111.0, 12.0- , 20.0, 21.0, 122.0 ]@- -}-mapMatrixWithIndex :: (Foreign.Storable.Storable t, - Element a, Num a) =>- ((a, a) -> a -> t) -> Matrix a -> Matrix t-mapMatrixWithIndex g = head . mapMatrixWithIndexM (\a b -> [g a b])--mapMatrix :: (Storable a, Storable b) => (a -> b) -> Matrix a -> Matrix b-mapMatrix f = liftMatrix (mapVector f)-
− lib/Data/Packed/Random.hs
@@ -1,66 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Packed.Vector--- Copyright : (c) Alberto Ruiz 2009--- License : GPL------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional------ Random vectors and matrices.-----------------------------------------------------------------------------------module Data.Packed.Random (- RandDist(..),- randomVector,- gaussianSample,- uniformSample,- meanCov,-) where--import Numeric.GSL.Vector-import Data.Packed-import Numeric.ContainerBoot-import Numeric.LinearAlgebra.Algorithms----- | Obtains a matrix whose rows are pseudorandom samples from a multivariate--- Gaussian distribution.-gaussianSample :: Int -- ^ seed- -> Int -- ^ number of rows- -> Vector Double -- ^ mean vector- -> Matrix Double -- ^ covariance matrix- -> Matrix Double -- ^ result-gaussianSample seed n med cov = m where- c = dim med- meds = konst 1 n `outer` med- rs = reshape c $ randomVector seed Gaussian (c * n)- m = rs `mXm` cholSH cov `add` meds---- | Obtains a matrix whose rows are pseudorandom samples from a multivariate--- uniform distribution.-uniformSample :: Int -- ^ seed- -> Int -- ^ number of rows- -> [(Double,Double)] -- ^ ranges for each column- -> Matrix Double -- ^ result-uniformSample seed n rgs = m where- (as,bs) = unzip rgs- a = fromList as- cs = zipWith subtract as bs- d = dim a- dat = toRows $ reshape n $ randomVector seed Uniform (n*d)- am = konst 1 n `outer` a- m = fromColumns (zipWith scale cs dat) `add` am-------------- utilities ----------------------------------- | Compute mean vector and covariance matrix of the rows of a matrix.-meanCov :: Matrix Double -> (Vector Double, Matrix Double)-meanCov x = (med,cov) where- r = rows x- k = 1 / fromIntegral r- med = konst k r `vXm` x- meds = konst 1 r `outer` med- xc = x `sub` meds- cov = scale (recip (fromIntegral (r-1))) (trans xc `mXm` xc)
− lib/Data/Packed/ST.hs
@@ -1,178 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE BangPatterns #-}--------------------------------------------------------------------------------- |--- Module : Data.Packed.ST--- Copyright : (c) Alberto Ruiz 2008--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ In-place manipulation inside the ST monad.--- See examples/inplace.hs in the distribution.-----------------------------------------------------------------------------------module Data.Packed.ST (- -- * Mutable Vectors- STVector, newVector, thawVector, freezeVector, runSTVector,- readVector, writeVector, modifyVector, liftSTVector,- -- * Mutable Matrices- STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix,- readMatrix, writeMatrix, modifyMatrix, liftSTMatrix,- -- * Unsafe functions- newUndefinedVector,- unsafeReadVector, unsafeWriteVector,- unsafeThawVector, unsafeFreezeVector,- newUndefinedMatrix,- unsafeReadMatrix, unsafeWriteMatrix,- unsafeThawMatrix, unsafeFreezeMatrix-) where--import Data.Packed.Internal--import Control.Monad.ST(ST, runST)-import Foreign.Storable(Storable, peekElemOff, pokeElemOff)--#if MIN_VERSION_base(4,4,0)-import Control.Monad.ST.Unsafe(unsafeIOToST)-#else-import Control.Monad.ST(unsafeIOToST)-#endif--{-# INLINE ioReadV #-}-ioReadV :: Storable t => Vector t -> Int -> IO t-ioReadV v k = unsafeWith v $ \s -> peekElemOff s k--{-# INLINE ioWriteV #-}-ioWriteV :: Storable t => Vector t -> Int -> t -> IO ()-ioWriteV v k x = unsafeWith v $ \s -> pokeElemOff s k x--newtype STVector s t = STVector (Vector t)--thawVector :: Storable t => Vector t -> ST s (STVector s t)-thawVector = unsafeIOToST . fmap STVector . cloneVector--unsafeThawVector :: Storable t => Vector t -> ST s (STVector s t)-unsafeThawVector = unsafeIOToST . return . STVector--runSTVector :: Storable t => (forall s . ST s (STVector s t)) -> Vector t-runSTVector st = runST (st >>= unsafeFreezeVector)--{-# INLINE unsafeReadVector #-}-unsafeReadVector :: Storable t => STVector s t -> Int -> ST s t-unsafeReadVector (STVector x) = unsafeIOToST . ioReadV x--{-# INLINE unsafeWriteVector #-}-unsafeWriteVector :: Storable t => STVector s t -> Int -> t -> ST s ()-unsafeWriteVector (STVector x) k = unsafeIOToST . ioWriteV x k--{-# INLINE modifyVector #-}-modifyVector :: (Storable t) => STVector s t -> Int -> (t -> t) -> ST s ()-modifyVector x k f = readVector x k >>= return . f >>= unsafeWriteVector x k--liftSTVector :: (Storable t) => (Vector t -> a) -> STVector s1 t -> ST s2 a-liftSTVector f (STVector x) = unsafeIOToST . fmap f . cloneVector $ x--freezeVector :: (Storable t) => STVector s1 t -> ST s2 (Vector t)-freezeVector v = liftSTVector id v--unsafeFreezeVector :: (Storable t) => STVector s1 t -> ST s2 (Vector t)-unsafeFreezeVector (STVector x) = unsafeIOToST . return $ x--{-# INLINE safeIndexV #-}-safeIndexV f (STVector v) k- | k < 0 || k>= dim v = error $ "out of range error in vector (dim="- ++show (dim v)++", pos="++show k++")"- | otherwise = f (STVector v) k--{-# INLINE readVector #-}-readVector :: Storable t => STVector s t -> Int -> ST s t-readVector = safeIndexV unsafeReadVector--{-# INLINE writeVector #-}-writeVector :: Storable t => STVector s t -> Int -> t -> ST s ()-writeVector = safeIndexV unsafeWriteVector--newUndefinedVector :: Storable t => Int -> ST s (STVector s t)-newUndefinedVector = unsafeIOToST . fmap STVector . createVector--{-# INLINE newVector #-}-newVector :: Storable t => t -> Int -> ST s (STVector s t)-newVector x n = do- v <- newUndefinedVector n- let go (-1) = return v- go !k = unsafeWriteVector v k x >> go (k-1 :: Int)- go (n-1)-----------------------------------------------------------------------------{-# INLINE ioReadM #-}-ioReadM :: Storable t => Matrix t -> Int -> Int -> IO t-ioReadM (Matrix _ nc cv RowMajor) r c = ioReadV cv (r*nc+c)-ioReadM (Matrix nr _ fv ColumnMajor) r c = ioReadV fv (c*nr+r)--{-# INLINE ioWriteM #-}-ioWriteM :: Storable t => Matrix t -> Int -> Int -> t -> IO ()-ioWriteM (Matrix _ nc cv RowMajor) r c val = ioWriteV cv (r*nc+c) val-ioWriteM (Matrix nr _ fv ColumnMajor) r c val = ioWriteV fv (c*nr+r) val--newtype STMatrix s t = STMatrix (Matrix t)--thawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t)-thawMatrix = unsafeIOToST . fmap STMatrix . cloneMatrix--unsafeThawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t)-unsafeThawMatrix = unsafeIOToST . return . STMatrix--runSTMatrix :: Storable t => (forall s . ST s (STMatrix s t)) -> Matrix t-runSTMatrix st = runST (st >>= unsafeFreezeMatrix)--{-# INLINE unsafeReadMatrix #-}-unsafeReadMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t-unsafeReadMatrix (STMatrix x) r = unsafeIOToST . ioReadM x r--{-# INLINE unsafeWriteMatrix #-}-unsafeWriteMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()-unsafeWriteMatrix (STMatrix x) r c = unsafeIOToST . ioWriteM x r c--{-# INLINE modifyMatrix #-}-modifyMatrix :: (Storable t) => STMatrix s t -> Int -> Int -> (t -> t) -> ST s ()-modifyMatrix x r c f = readMatrix x r c >>= return . f >>= unsafeWriteMatrix x r c--liftSTMatrix :: (Storable t) => (Matrix t -> a) -> STMatrix s1 t -> ST s2 a-liftSTMatrix f (STMatrix x) = unsafeIOToST . fmap f . cloneMatrix $ x--unsafeFreezeMatrix :: (Storable t) => STMatrix s1 t -> ST s2 (Matrix t)-unsafeFreezeMatrix (STMatrix x) = unsafeIOToST . return $ x--freezeMatrix :: (Storable t) => STMatrix s1 t -> ST s2 (Matrix t)-freezeMatrix m = liftSTMatrix id m--cloneMatrix (Matrix r c d o) = cloneVector d >>= return . (\d' -> Matrix r c d' o)--{-# INLINE safeIndexM #-}-safeIndexM f (STMatrix m) r c- | r<0 || r>=rows m ||- c<0 || c>=cols m = error $ "out of range error in matrix (size="- ++show (rows m,cols m)++", pos="++show (r,c)++")"- | otherwise = f (STMatrix m) r c--{-# INLINE readMatrix #-}-readMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t-readMatrix = safeIndexM unsafeReadMatrix--{-# INLINE writeMatrix #-}-writeMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()-writeMatrix = safeIndexM unsafeWriteMatrix--newUndefinedMatrix :: Storable t => MatrixOrder -> Int -> Int -> ST s (STMatrix s t)-newUndefinedMatrix ord r c = unsafeIOToST $ fmap STMatrix $ createMatrix ord r c--{-# NOINLINE newMatrix #-}-newMatrix :: Storable t => t -> Int -> Int -> ST s (STMatrix s t)-newMatrix v r c = unsafeThawMatrix $ reshape c $ runSTVector $ newVector v (r*c)
− lib/Data/Packed/Vector.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module : Data.Packed.Vector--- Copyright : (c) Alberto Ruiz 2007-10--- License : GPL------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional------ 1D arrays suitable for numeric computations using external libraries.------ This module provides basic functions for manipulation of structure.-----------------------------------------------------------------------------------module Data.Packed.Vector (- Vector,- fromList, (|>), toList, buildVector,- dim, (@>),- subVector, takesV, join,- mapVector, mapVectorWithIndex, zipVector, zipVectorWith, unzipVector, unzipVectorWith,- mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_,- foldLoop, foldVector, foldVectorG, foldVectorWithIndex-) where--import Data.Packed.Internal.Vector-import Foreign.Storable-----------------------------------------------------------------------#ifdef BINARY--import Data.Binary-import Control.Monad(replicateM)---- a 64K cache, with a Double taking 13 bytes in Bytestring,--- implies a chunk size of 5041-chunk :: Int-chunk = 5000--chunks :: Int -> [Int]-chunks d = let c = d `div` chunk- m = d `mod` chunk- in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk) --putVector v = do- let d = dim v- mapM_ (\i -> put $ v @> i) [0..(d-1)]--getVector d = do- xs <- replicateM d get- return $! fromList xs--instance (Binary a, Storable a) => Binary (Vector a) where- put v = do- let d = dim v- put d- mapM_ putVector $! takesV (chunks d) v- get = do- d <- get- vs <- mapM getVector $ chunks d- return $! join vs--#endif-----------------------------------------------------------------------{- | creates a Vector of the specified length using the supplied function to- to map the index to the value at that index.--@> buildVector 4 fromIntegral-4 |> [0.0,1.0,2.0,3.0]@---}-buildVector :: Storable a => Int -> (Int -> a) -> Vector a-buildVector len f =- fromList $ map f [0 .. (len - 1)]----- | zip for Vectors-zipVector :: (Storable a, Storable b, Storable (a,b)) => Vector a -> Vector b -> Vector (a,b)-zipVector = zipVectorWith (,)---- | unzip for Vectors-unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vector a,Vector b)-unzipVector = unzipVectorWith id---------------------------------------------------------------------
− lib/Graphics/Plot.hs
@@ -1,183 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Graphics.Plot--- Copyright : (c) Alberto Ruiz 2005-8--- License : GPL-style------ Maintainer : Alberto Ruiz (aruiz at um dot es)--- Stability : provisional--- Portability : uses gnuplot and ImageMagick------ This module is deprecated. It can be replaced by improved drawing tools--- available in the plot\\plot-gtk packages by Vivian McPhail or Gnuplot by Henning Thielemann.--------------------------------------------------------------------------------module Graphics.Plot(-- mplot,-- plot, parametricPlot, -- splot, mesh, meshdom,-- matrixToPGM, imshow,-- gnuplotX, gnuplotpdf, gnuplotWin--) where--import Numeric.Container-import Data.List(intersperse)-import System.Process (system)---- | From vectors x and y, it generates a pair of matrices to be used as x and y arguments for matrix functions.-meshdom :: Vector Double -> Vector Double -> (Matrix Double , Matrix Double)-meshdom r1 r2 = (outer r1 (constant 1 (dim r2)), outer (constant 1 (dim r1)) r2)---{- | Draws a 3D surface representation of a real matrix.--> > mesh $ build (10,10) (\\i j -> i + (j-5)^2)--In certain versions you can interactively rotate the graphic using the mouse.---}-mesh :: Matrix Double -> IO ()-mesh m = gnuplotX (command++dat) where- command = "splot "++datafollows++" matrix with lines\n"- dat = prep $ toLists m--{- | Draws the surface represented by the function f in the desired ranges and number of points, internally using 'mesh'.--> > let f x y = cos (x + y) -> > splot f (0,pi) (0,2*pi) 50 ---}-splot :: (Matrix Double->Matrix Double->Matrix Double) -> (Double,Double) -> (Double,Double) -> Int -> IO () -splot f rx ry n = mesh z where- (x,y) = meshdom (linspace n rx) (linspace n ry)- z = f x y--{- | plots several vectors against the first one --> > let t = linspace 100 (-3,3) in mplot [t, sin t, exp (-t^2)]---}-mplot :: [Vector Double] -> IO ()-mplot m = gnuplotX (commands++dats) where- commands = if length m == 1 then command1 else commandmore- command1 = "plot "++datafollows++" with lines\n" ++ dat- commandmore = "plot " ++ plots ++ "\n"- plots = concat $ intersperse ", " (map cmd [2 .. length m])- cmd k = datafollows++" using 1:"++show k++" with lines"- dat = prep $ toLists $ fromColumns m- dats = concat (replicate (length m-1) dat)---{- | Draws a list of functions over a desired range and with a desired number of points --> > plot [sin, cos, sin.(3*)] (0,2*pi) 1000---}-plot :: [Vector Double->Vector Double] -> (Double,Double) -> Int -> IO ()-plot fs rx n = mplot (x: mapf fs x)- where x = linspace n rx- mapf gs y = map ($ y) gs--{- | Draws a parametric curve. For instance, to draw a spiral we can do something like:--> > parametricPlot (\t->(t * sin t, t * cos t)) (0,10*pi) 1000---}-parametricPlot :: (Vector Double->(Vector Double,Vector Double)) -> (Double, Double) -> Int -> IO ()-parametricPlot f rt n = mplot [fx, fy]- where t = linspace n rt- (fx,fy) = f t----- | writes a matrix to pgm image file-matrixToPGM :: Matrix Double -> String-matrixToPGM m = header ++ unlines (map unwords ll) where- c = cols m- r = rows m- header = "P2 "++show c++" "++show r++" "++show (round maxgray :: Int)++"\n"- maxgray = 255.0- maxval = maxElement m- minval = minElement m- scale' = if maxval == minval- then 0.0- else maxgray / (maxval - minval)- f x = show ( round ( scale' *(x - minval) ) :: Int )- ll = map (map f) (toLists m)---- | imshow shows a representation of a matrix as a gray level image using ImageMagick's display.-imshow :: Matrix Double -> IO ()-imshow m = do- _ <- system $ "echo \""++ matrixToPGM m ++"\"| display -antialias -resize 300 - &"- return ()--------------------------------------------------------gnuplotX :: String -> IO ()-gnuplotX command = do { _ <- system cmdstr; return()} where- cmdstr = "echo \""++command++"\" | gnuplot -persist"--datafollows = "\\\"-\\\""--prep = (++"e\n\n") . unlines . map (unwords . map show)---gnuplotpdf :: String -> String -> [([[Double]], String)] -> IO ()-gnuplotpdf title command ds = gnuplot (prelude ++ command ++" "++ draw) >> postproc where- prelude = "set terminal epslatex color; set output '"++title++".tex';"- (dats,defs) = unzip ds- draw = concat (intersperse ", " (map ("\"-\" "++) defs)) ++ "\n" ++- concatMap pr dats- postproc = do- _ <- system $ "epstopdf "++title++".eps"- mklatex- _ <- system $ "pdflatex "++title++"aux.tex > /dev/null"- _ <- system $ "pdfcrop "++title++"aux.pdf > /dev/null"- _ <- system $ "mv "++title++"aux-crop.pdf "++title++".pdf"- _ <- system $ "rm "++title++"aux.* "++title++".eps "++title++".tex"- return ()-- mklatex = writeFile (title++"aux.tex") $- "\\documentclass{article}\n"++- "\\usepackage{graphics}\n"++- "\\usepackage{nopageno}\n"++- "\\usepackage{txfonts}\n"++- "\\renewcommand{\\familydefault}{phv}\n"++- "\\usepackage[usenames]{color}\n"++-- "\\begin{document}\n"++-- "\\begin{center}\n"++- " \\input{./"++title++".tex}\n"++- "\\end{center}\n"++-- "\\end{document}"-- pr = (++"e\n") . unlines . map (unwords . map show)-- gnuplot cmd = do- writeFile "gnuplotcommand" cmd- _ <- system "gnuplot gnuplotcommand"- _ <- system "rm gnuplotcommand"- return ()--gnuplotWin :: String -> String -> [([[Double]], String)] -> IO ()-gnuplotWin title command ds = gnuplot (prelude ++ command ++" "++ draw) where- (dats,defs) = unzip ds- draw = concat (intersperse ", " (map ("\"-\" "++) defs)) ++ "\n" ++- concatMap pr dats-- pr = (++"e\n") . unlines . map (unwords . map show)-- prelude = "set title \""++title++"\";"-- gnuplot cmd = do- writeFile "gnuplotcommand" cmd- _ <- system "gnuplot -persist gnuplotcommand"- _ <- system "rm gnuplotcommand"- return ()
− lib/Numeric/Chain.hs
@@ -1,140 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.Chain--- Copyright : (c) Vivian McPhail 2010--- License : GPL-style------ Maintainer : Vivian McPhail <haskell.vivian.mcphail <at> gmail.com>--- Stability : provisional--- Portability : portable------ optimisation of association order for chains of matrix multiplication-----------------------------------------------------------------------------------module Numeric.Chain (- optimiseMult,- ) where--import Data.Maybe--import Data.Packed.Matrix-import Numeric.ContainerBoot--import qualified Data.Array.IArray as A--------------------------------------------------------------------------------{- | - Provide optimal association order for a chain of matrix multiplications - and apply the multiplications.-- The algorithm is the well-known O(n\^3) dynamic programming algorithm- that builds a pyramid of optimal associations.--> m1, m2, m3, m4 :: Matrix Double-> m1 = (10><15) [1..]-> m2 = (15><20) [1..]-> m3 = (20><5) [1..]-> m4 = (5><10) [1..]--> >>> optimiseMult [m1,m2,m3,m4]--will perform @((m1 `multiply` (m2 `multiply` m3)) `multiply` m4)@--The naive left-to-right multiplication would take @4500@ scalar multiplications-whereas the optimised version performs @2750@ scalar multiplications. The complexity-in this case is 32 (= 4^3/2) * (2 comparisons, 3 scalar multiplications, 3 scalar additions,-5 lookups, 2 updates) + a constant (= three table allocations)--}-optimiseMult :: Product t => [Matrix t] -> Matrix t-optimiseMult = chain---------------------------------------------------------------------------------type Matrices a = A.Array Int (Matrix a)-type Sizes = A.Array Int (Int,Int)-type Cost = A.Array Int (A.Array Int (Maybe Int))-type Indexes = A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))--update :: A.Array Int (A.Array Int a) -> (Int,Int) -> a -> A.Array Int (A.Array Int a)-update a (r,c) e = a A.// [(r,(a A.! r) A.// [(c,e)])]--newWorkSpaceCost :: Int -> A.Array Int (A.Array Int (Maybe Int))-newWorkSpaceCost n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]- where subArray i = A.listArray (1,i) (repeat Nothing)--newWorkSpaceIndexes :: Int -> A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))-newWorkSpaceIndexes n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]- where subArray i = A.listArray (1,i) (repeat Nothing)--matricesToSizes :: [Matrix a] -> Sizes-matricesToSizes ms = A.listArray (1,length ms) $ map (\m -> (rows m,cols m)) ms--chain :: Product a => [Matrix a] -> Matrix a-chain [] = error "chain: zero matrices to multiply"-chain [m] = m-chain [ml,mr] = ml `multiply` mr-chain ms = let ln = length ms- ma = A.listArray (1,ln) ms- mz = matricesToSizes ms- i = chain_cost mz- in chain_paren (ln,ln) i ma--chain_cost :: Sizes -> Indexes-chain_cost mz = let (_,u) = A.bounds mz- cost = newWorkSpaceCost u- ixes = newWorkSpaceIndexes u- (_,_,i) = foldl chain_cost' (mz,cost,ixes) (order u)- in i--chain_cost' :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)-chain_cost' sci@(mz,cost,ixes) (r,c) - | c == 1 = let cost' = update cost (r,c) (Just 0)- ixes' = update ixes (r,c) (Just ((r,c),(r,c)))- in (mz,cost',ixes')- | otherwise = minimum_cost sci (r,c)--minimum_cost :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)-minimum_cost sci fu = foldl (smaller_cost fu) sci (fulcrum_order fu)--smaller_cost :: (Int,Int) -> (Sizes,Cost,Indexes) -> ((Int,Int),(Int,Int)) -> (Sizes,Cost,Indexes)-smaller_cost (r,c) (mz,cost,ixes) ix@((lr,lc),(rr,rc)) = let op_cost = fromJust ((cost A.! lr) A.! lc)- + fromJust ((cost A.! rr) A.! rc)- + fst (mz A.! (lr-lc+1))- * snd (mz A.! lc)- * snd (mz A.! rr)- cost' = (cost A.! r) A.! c- in case cost' of- Nothing -> let cost'' = update cost (r,c) (Just op_cost)- ixes'' = update ixes (r,c) (Just ix)- in (mz,cost'',ixes'')- Just ct -> if op_cost < ct then- let cost'' = update cost (r,c) (Just op_cost)- ixes'' = update ixes (r,c) (Just ix)- in (mz,cost'',ixes'')- else (mz,cost,ixes)- --fulcrum_order (r,c) = let fs' = zip (repeat r) [1..(c-1)]- in map (partner (r,c)) fs'--partner (r,c) (a,b) = ((r-b, c-b), (a,b))--order 0 = []-order n = order (n-1) ++ zip (repeat n) [1..n]--chain_paren :: Product a => (Int,Int) -> Indexes -> Matrices a -> Matrix a-chain_paren (r,c) ixes ma = let ((lr,lc),(rr,rc)) = fromJust $ (ixes A.! r) A.! c- in if lr == rr && lc == rc then (ma A.! lr)- else (chain_paren (lr,lc) ixes ma) `multiply` (chain_paren (rr,rc) ixes ma) ------------------------------------------------------------------------------{- TESTS -}---- optimal association is ((m1*(m2*m3))*m4)-m1, m2, m3, m4 :: Matrix Double-m1 = (10><15) [1..]-m2 = (15><20) [1..]-m3 = (20><5) [1..]-m4 = (5><10) [1..]
− lib/Numeric/Container.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Numeric.Container--- Copyright : (c) Alberto Ruiz 2010--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ Basic numeric operations on 'Vector' and 'Matrix', including conversion routines.------ The 'Container' class is used to define optimized generic functions which work--- on 'Vector' and 'Matrix' with real or complex elements.------ Some of these functions are also available in the instances of the standard--- numeric Haskell classes provided by "Numeric.LinearAlgebra".-----------------------------------------------------------------------------------module Numeric.Container (- -- * Basic functions- module Data.Packed,- constant, linspace,- diag, ident,- ctrans,- -- * Generic operations- Container(..),- -- * Matrix product- Product(..),- optimiseMult,- mXm,mXv,vXm,(<.>),Mul(..),LSDiv(..),- outer, kronecker,- -- * Random numbers- RandDist(..),- randomVector,- gaussianSample,- uniformSample,- meanCov,- -- * Element conversion- Convert(..),- Complexable(),- RealElement(),-- RealOf, ComplexOf, SingleOf, DoubleOf,-- IndexOf,- module Data.Complex,- -- * Input / Output- dispf, disps, dispcf, vecdisp, latexFormat, format,- loadMatrix, saveMatrix, fromFile, fileDimensions,- readMatrix,- fscanfVector, fprintfVector, freadVector, fwriteVector,- -- * Experimental- build', konst'-) where--import Data.Packed-import Data.Packed.Internal(constantD)-import Numeric.ContainerBoot-import Numeric.Chain-import Numeric.IO-import Data.Complex-import Numeric.LinearAlgebra.Algorithms(Field,linearSolveSVD)-import Data.Packed.Random----------------------------------------------------------------------{- | creates a vector with a given number of equal components:--@> constant 2 7-7 |> [2.0,2.0,2.0,2.0,2.0,2.0,2.0]@--}-constant :: Element a => a -> Int -> Vector a--- constant x n = runSTVector (newVector x n)-constant = constantD-- about 2x faster--{- | Creates a real vector containing a range of values:--@\> linspace 5 (-3,7)-5 |> [-3.0,-0.5,2.0,4.5,7.0]@--Logarithmic spacing can be defined as follows:--@logspace n (a,b) = 10 ** linspace n (a,b)@--}-linspace :: (Enum e, Container Vector e) => Int -> (e, e) -> Vector e-linspace n (a,b) = addConstant a $ scale s $ fromList [0 .. fromIntegral n-1]- where s = (b-a)/fromIntegral (n-1)---- | Dot product: @u \<.\> v = dot u v@-(<.>) :: Product t => Vector t -> Vector t -> t-infixl 7 <.>-(<.>) = dot--------------------------------------------------------------class Mul a b c | a b -> c where- infixl 7 <>- -- | Matrix-matrix, matrix-vector, and vector-matrix products.- (<>) :: Product t => a t -> b t -> c t--instance Mul Matrix Matrix Matrix where- (<>) = mXm--instance Mul Matrix Vector Vector where- (<>) m v = flatten $ m <> asColumn v--instance Mul Vector Matrix Vector where- (<>) v m = flatten $ asRow v <> m------------------------------------------------------------class LSDiv b c | b -> c, c->b where- infixl 7 <\>- -- | least squares solution of a linear system, similar to the \\ operator of Matlab\/Octave (based on linearSolveSVD)- (<\>) :: Field t => Matrix t -> b t -> c t--instance LSDiv Vector Vector where- m <\> v = flatten (linearSolveSVD m (reshape 1 v))--instance LSDiv Matrix Matrix where- (<\>) = linearSolveSVD----------------------------------------------------------
− lib/Numeric/ContainerBoot.hs
@@ -1,603 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Numeric.ContainerBoot--- Copyright : (c) Alberto Ruiz 2010--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ Module to avoid cyclyc dependencies.-----------------------------------------------------------------------------------module Numeric.ContainerBoot (- -- * Basic functions- ident, diag, ctrans,- -- * Generic operations- Container(..),- -- * Matrix product and related functions- Product(..),- mXm,mXv,vXm,- outer, kronecker,- -- * Element conversion- Convert(..),- Complexable(),- RealElement(),-- RealOf, ComplexOf, SingleOf, DoubleOf,-- IndexOf,- module Data.Complex,- -- * Experimental- build', konst'-) where--import Data.Packed-import Data.Packed.ST as ST-import Numeric.Conversion-import Data.Packed.Internal-import Numeric.GSL.Vector-import Data.Complex-import Control.Monad(ap)--import Numeric.LinearAlgebra.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ)-----------------------------------------------------------------------type family IndexOf (c :: * -> *)--type instance IndexOf Vector = Int-type instance IndexOf Matrix = (Int,Int)--type family ArgOf (c :: * -> *) a--type instance ArgOf Vector a = a -> a-type instance ArgOf Matrix a = a -> a -> a------------------------------------------------------------------------- | Basic element-by-element functions for numeric containers-class (Complexable c, Fractional e, Element e) => Container c e where- -- | create a structure with a single element- scalar :: e -> c e- -- | complex conjugate- conj :: c e -> c e- scale :: e -> c e -> c e- -- | scale the element by element reciprocal of the object:- --- -- @scaleRecip 2 (fromList [5,i]) == 2 |> [0.4 :+ 0.0,0.0 :+ (-2.0)]@- scaleRecip :: e -> c e -> c e- addConstant :: e -> c e -> c e- add :: c e -> c e -> c e- sub :: c e -> c e -> c e- -- | element by element multiplication- mul :: c e -> c e -> c e- -- | element by element division- divide :: c e -> c e -> c e- equal :: c e -> c e -> Bool- --- -- element by element inverse tangent- arctan2 :: c e -> c e -> c e- --- -- | cannot implement instance Functor because of Element class constraint- cmap :: (Element b) => (e -> b) -> c e -> c b- -- | constant structure of given size- konst :: e -> IndexOf c -> c e- -- | create a structure using a function- --- -- Hilbert matrix of order N:- --- -- @hilb n = build (n,n) (\\i j -> 1/(i+j+1))@- build :: IndexOf c -> (ArgOf c e) -> c e- --build :: BoundsOf f -> f -> (ContainerOf f) e- --- -- | indexing function- atIndex :: c e -> IndexOf c -> e- -- | index of min element- minIndex :: c e -> IndexOf c- -- | index of max element- maxIndex :: c e -> IndexOf c- -- | value of min element- minElement :: c e -> e- -- | value of max element- maxElement :: c e -> e- -- the C functions sumX/prodX are twice as fast as using foldVector- -- | the sum of elements (faster than using @fold@)- sumElements :: c e -> e- -- | the product of elements (faster than using @fold@)- prodElements :: c e -> e-- -- | A more efficient implementation of @cmap (\\x -> if x>0 then 1 else 0)@- --- -- @> step $ linspace 5 (-1,1::Double)- -- 5 |> [0.0,0.0,0.0,1.0,1.0]@- - step :: RealElement e => c e -> c e-- -- | Element by element version of @case compare a b of {LT -> l; EQ -> e; GT -> g}@.- --- -- Arguments with any dimension = 1 are automatically expanded: - --- -- @> cond ((1>\<4)[1..]) ((3>\<1)[1..]) 0 100 ((3>\<4)[1..]) :: Matrix Double- -- (3><4)- -- [ 100.0, 2.0, 3.0, 4.0- -- , 0.0, 100.0, 7.0, 8.0- -- , 0.0, 0.0, 100.0, 12.0 ]@- - cond :: RealElement e - => c e -- ^ a- -> c e -- ^ b- -> c e -- ^ l - -> c e -- ^ e- -> c e -- ^ g- -> c e -- ^ result-- -- | Find index of elements which satisfy a predicate- --- -- @> find (>0) (ident 3 :: Matrix Double)- -- [(0,0),(1,1),(2,2)]@-- find :: (e -> Bool) -> c e -> [IndexOf c]-- -- | Create a structure from an association list- --- -- @> assoc 5 0 [(2,7),(1,3)] :: Vector Double- -- 5 |> [0.0,3.0,7.0,0.0,0.0]@- - assoc :: IndexOf c -- ^ size- -> e -- ^ default value- -> [(IndexOf c, e)] -- ^ association list- -> c e -- ^ result-- -- | Modify a structure using an update function- --- -- @> accum (ident 5) (+) [((1,1),5),((0,3),3)] :: Matrix Double- -- (5><5)- -- [ 1.0, 0.0, 0.0, 3.0, 0.0- -- , 0.0, 6.0, 0.0, 0.0, 0.0- -- , 0.0, 0.0, 1.0, 0.0, 0.0- -- , 0.0, 0.0, 0.0, 1.0, 0.0- -- , 0.0, 0.0, 0.0, 0.0, 1.0 ]@- - accum :: c e -- ^ initial structure- -> (e -> e -> e) -- ^ update function- -> [(IndexOf c, e)] -- ^ association list- -> c e -- ^ result------------------------------------------------------------------------------instance Container Vector Float where- scale = vectorMapValF Scale- scaleRecip = vectorMapValF Recip- addConstant = vectorMapValF AddConstant- add = vectorZipF Add- sub = vectorZipF Sub- mul = vectorZipF Mul- divide = vectorZipF Div- equal u v = dim u == dim v && maxElement (vectorMapF Abs (sub u v)) == 0.0- arctan2 = vectorZipF ATan2- scalar x = fromList [x]- konst = constantD- build = buildV- conj = id- cmap = mapVector- atIndex = (@>)- minIndex = round . toScalarF MinIdx- maxIndex = round . toScalarF MaxIdx- minElement = toScalarF Min- maxElement = toScalarF Max- sumElements = sumF- prodElements = prodF- step = stepF- find = findV- assoc = assocV- accum = accumV- cond = condV condF--instance Container Vector Double where- scale = vectorMapValR Scale- scaleRecip = vectorMapValR Recip- addConstant = vectorMapValR AddConstant- add = vectorZipR Add- sub = vectorZipR Sub- mul = vectorZipR Mul- divide = vectorZipR Div- equal u v = dim u == dim v && maxElement (vectorMapR Abs (sub u v)) == 0.0- arctan2 = vectorZipR ATan2- scalar x = fromList [x]- konst = constantD- build = buildV- conj = id- cmap = mapVector- atIndex = (@>)- minIndex = round . toScalarR MinIdx- maxIndex = round . toScalarR MaxIdx- minElement = toScalarR Min- maxElement = toScalarR Max- sumElements = sumR- prodElements = prodR- step = stepD- find = findV- assoc = assocV- accum = accumV- cond = condV condD--instance Container Vector (Complex Double) where- scale = vectorMapValC Scale- scaleRecip = vectorMapValC Recip- addConstant = vectorMapValC AddConstant- add = vectorZipC Add- sub = vectorZipC Sub- mul = vectorZipC Mul- divide = vectorZipC Div- equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0- arctan2 = vectorZipC ATan2- scalar x = fromList [x]- konst = constantD- build = buildV- conj = conjugateC- cmap = mapVector- atIndex = (@>)- minIndex = minIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate)- maxIndex = maxIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate)- minElement = ap (@>) minIndex- maxElement = ap (@>) maxIndex- sumElements = sumC- prodElements = prodC- step = undefined -- cannot match- find = findV- assoc = assocV- accum = accumV- cond = undefined -- cannot match--instance Container Vector (Complex Float) where- scale = vectorMapValQ Scale- scaleRecip = vectorMapValQ Recip- addConstant = vectorMapValQ AddConstant- add = vectorZipQ Add- sub = vectorZipQ Sub- mul = vectorZipQ Mul- divide = vectorZipQ Div- equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0- arctan2 = vectorZipQ ATan2- scalar x = fromList [x]- konst = constantD- build = buildV- conj = conjugateQ- cmap = mapVector- atIndex = (@>)- minIndex = minIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate)- maxIndex = maxIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate)- minElement = ap (@>) minIndex- maxElement = ap (@>) maxIndex- sumElements = sumQ- prodElements = prodQ- step = undefined -- cannot match- find = findV- assoc = assocV- accum = accumV- cond = undefined -- cannot match-------------------------------------------------------------------instance (Container Vector a) => Container Matrix a where- scale x = liftMatrix (scale x)- scaleRecip x = liftMatrix (scaleRecip x)- addConstant x = liftMatrix (addConstant x)- add = liftMatrix2 add- sub = liftMatrix2 sub- mul = liftMatrix2 mul- divide = liftMatrix2 divide- equal a b = cols a == cols b && flatten a `equal` flatten b- arctan2 = liftMatrix2 arctan2- scalar x = (1><1) [x]- konst v (r,c) = reshape c (konst v (r*c))- build = buildM- conj = liftMatrix conj- cmap f = liftMatrix (mapVector f)- atIndex = (@@>)- minIndex m = let (r,c) = (rows m,cols m)- i = (minIndex $ flatten m)- in (i `div` c,i `mod` c)- maxIndex m = let (r,c) = (rows m,cols m)- i = (maxIndex $ flatten m)- in (i `div` c,i `mod` c)- minElement = ap (@@>) minIndex- maxElement = ap (@@>) maxIndex- sumElements = sumElements . flatten- prodElements = prodElements . flatten- step = liftMatrix step- find = findM- assoc = assocM- accum = accumM- cond = condM---------------------------------------------------------- | Matrix product and related functions-class Element e => Product e where- -- | matrix product- multiply :: Matrix e -> Matrix e -> Matrix e- -- | dot (inner) product- dot :: Vector e -> Vector e -> e- -- | sum of absolute value of elements (differs in complex case from @norm1@)- absSum :: Vector e -> RealOf e- -- | sum of absolute value of elements- norm1 :: Vector e -> RealOf e- -- | euclidean norm- norm2 :: Vector e -> RealOf e- -- | element of maximum magnitude- normInf :: Vector e -> RealOf e--instance Product Float where- norm2 = toScalarF Norm2- absSum = toScalarF AbsSum- dot = dotF- norm1 = toScalarF AbsSum- normInf = maxElement . vectorMapF Abs- multiply = multiplyF--instance Product Double where- norm2 = toScalarR Norm2- absSum = toScalarR AbsSum- dot = dotR- norm1 = toScalarR AbsSum- normInf = maxElement . vectorMapR Abs- multiply = multiplyR--instance Product (Complex Float) where- norm2 = toScalarQ Norm2- absSum = toScalarQ AbsSum- dot = dotQ- norm1 = sumElements . fst . fromComplex . vectorMapQ Abs- normInf = maxElement . fst . fromComplex . vectorMapQ Abs- multiply = multiplyQ--instance Product (Complex Double) where- norm2 = toScalarC Norm2- absSum = toScalarC AbsSum- dot = dotC- norm1 = sumElements . fst . fromComplex . vectorMapC Abs- normInf = maxElement . fst . fromComplex . vectorMapC Abs- multiply = multiplyC---------------------------------------------------------------- synonym for matrix product-mXm :: Product t => Matrix t -> Matrix t -> Matrix t-mXm = multiply---- matrix - vector product-mXv :: Product t => Matrix t -> Vector t -> Vector t-mXv m v = flatten $ m `mXm` (asColumn v)---- vector - matrix product-vXm :: Product t => Vector t -> Matrix t -> Vector t-vXm v m = flatten $ (asRow v) `mXm` m--{- | Outer product of two vectors.--@\> 'fromList' [1,2,3] \`outer\` 'fromList' [5,2,3]-(3><3)- [ 5.0, 2.0, 3.0- , 10.0, 4.0, 6.0- , 15.0, 6.0, 9.0 ]@--}-outer :: (Product t) => Vector t -> Vector t -> Matrix t-outer u v = asColumn u `multiply` asRow v--{- | Kronecker product of two matrices.--@m1=(2><3)- [ 1.0, 2.0, 0.0- , 0.0, -1.0, 3.0 ]-m2=(4><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0- , 7.0, 8.0, 9.0- , 10.0, 11.0, 12.0 ]@--@\> kronecker m1 m2-(8><9)- [ 1.0, 2.0, 3.0, 2.0, 4.0, 6.0, 0.0, 0.0, 0.0- , 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.0, 0.0, 0.0- , 7.0, 8.0, 9.0, 14.0, 16.0, 18.0, 0.0, 0.0, 0.0- , 10.0, 11.0, 12.0, 20.0, 22.0, 24.0, 0.0, 0.0, 0.0- , 0.0, 0.0, 0.0, -1.0, -2.0, -3.0, 3.0, 6.0, 9.0- , 0.0, 0.0, 0.0, -4.0, -5.0, -6.0, 12.0, 15.0, 18.0- , 0.0, 0.0, 0.0, -7.0, -8.0, -9.0, 21.0, 24.0, 27.0- , 0.0, 0.0, 0.0, -10.0, -11.0, -12.0, 30.0, 33.0, 36.0 ]@--}-kronecker :: (Product t) => Matrix t -> Matrix t -> Matrix t-kronecker a b = fromBlocks- . splitEvery (cols a)- . map (reshape (cols b))- . toRows- $ flatten a `outer` flatten b------------------------------------------------------------------------class Convert t where- real :: Container c t => c (RealOf t) -> c t- complex :: Container c t => c t -> c (ComplexOf t)- single :: Container c t => c t -> c (SingleOf t)- double :: Container c t => c t -> c (DoubleOf t)- toComplex :: (Container c t, RealElement t) => (c t, c t) -> c (Complex t)- fromComplex :: (Container c t, RealElement t) => c (Complex t) -> (c t, c t)---instance Convert Double where- real = id- complex = comp'- single = single'- double = id- toComplex = toComplex'- fromComplex = fromComplex'--instance Convert Float where- real = id- complex = comp'- single = id- double = double'- toComplex = toComplex'- fromComplex = fromComplex'--instance Convert (Complex Double) where- real = comp'- complex = id- single = single'- double = id- toComplex = toComplex'- fromComplex = fromComplex'--instance Convert (Complex Float) where- real = comp'- complex = id- single = id- double = double'- toComplex = toComplex'- fromComplex = fromComplex'-----------------------------------------------------------------------type family RealOf x--type instance RealOf Double = Double-type instance RealOf (Complex Double) = Double--type instance RealOf Float = Float-type instance RealOf (Complex Float) = Float--type family ComplexOf x--type instance ComplexOf Double = Complex Double-type instance ComplexOf (Complex Double) = Complex Double--type instance ComplexOf Float = Complex Float-type instance ComplexOf (Complex Float) = Complex Float--type family SingleOf x--type instance SingleOf Double = Float-type instance SingleOf Float = Float--type instance SingleOf (Complex a) = Complex (SingleOf a)--type family DoubleOf x--type instance DoubleOf Double = Double-type instance DoubleOf Float = Double--type instance DoubleOf (Complex a) = Complex (DoubleOf a)--type family ElementOf c--type instance ElementOf (Vector a) = a-type instance ElementOf (Matrix a) = a----------------------------------------------------------------class Build f where- build' :: BoundsOf f -> f -> ContainerOf f--type family BoundsOf x--type instance BoundsOf (a->a) = Int-type instance BoundsOf (a->a->a) = (Int,Int)--type family ContainerOf x--type instance ContainerOf (a->a) = Vector a-type instance ContainerOf (a->a->a) = Matrix a--instance (Element a, Num a) => Build (a->a) where- build' = buildV--instance (Element a, Num a) => Build (a->a->a) where- build' = buildM--buildM (rc,cc) f = fromLists [ [f r c | c <- cs] | r <- rs ]- where rs = map fromIntegral [0 .. (rc-1)]- cs = map fromIntegral [0 .. (cc-1)]--buildV n f = fromList [f k | k <- ks]- where ks = map fromIntegral [0 .. (n-1)]--------------------------------------------------------- experimental--class Konst s where- konst' :: Element e => e -> s -> ContainerOf' s e--type family ContainerOf' x y--type instance ContainerOf' Int a = Vector a-type instance ContainerOf' (Int,Int) a = Matrix a--instance Konst Int where- konst' = constantD--instance Konst (Int,Int) where- konst' k (r,c) = reshape c $ konst' k (r*c)------------------------------------------------------------- | conjugate transpose-ctrans :: (Container Vector e, Element e) => Matrix e -> Matrix e-ctrans = liftMatrix conj . trans---- | Creates a square matrix with a given diagonal.-diag :: (Num a, Element a) => Vector a -> Matrix a-diag v = diagRect 0 v n n where n = dim v---- | creates the identity matrix of given dimension-ident :: (Num a, Element a) => Int -> Matrix a-ident n = diag (constantD 1 n)------------------------------------------------------------findV p x = foldVectorWithIndex g [] x where- g k z l = if p z then k:l else l--findM p x = map ((`divMod` cols x)) $ findV p (flatten x)--assocV n z xs = ST.runSTVector $ do- v <- ST.newVector z n- mapM_ (\(k,x) -> ST.writeVector v k x) xs- return v--assocM (r,c) z xs = ST.runSTMatrix $ do- m <- ST.newMatrix z r c- mapM_ (\((i,j),x) -> ST.writeMatrix m i j x) xs- return m--accumV v0 f xs = ST.runSTVector $ do- v <- ST.thawVector v0- mapM_ (\(k,x) -> ST.modifyVector v k (f x)) xs- return v--accumM m0 f xs = ST.runSTMatrix $ do- m <- ST.thawMatrix m0- mapM_ (\((i,j),x) -> ST.modifyMatrix m i j (f x)) xs- return m--------------------------------------------------------------------------condM a b l e t = reshape (cols a'') $ cond a' b' l' e' t'- where- args@(a'':_) = conformMs [a,b,l,e,t]- [a', b', l', e', t'] = map flatten args--condV f a b l e t = f a' b' l' e' t'- where- [a', b', l', e', t'] = conformVs [a,b,l,e,t]-
− lib/Numeric/Conversion.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Numeric.Conversion--- Copyright : (c) Alberto Ruiz 2010--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ Conversion routines-----------------------------------------------------------------------------------module Numeric.Conversion (- Complexable(..), RealElement,- module Data.Complex-) where--import Data.Packed.Internal.Vector-import Data.Packed.Internal.Matrix-import Data.Complex-import Control.Arrow((***))------------------------------------------------------------------------- | Supported single-double precision type pairs-class (Element s, Element d) => Precision s d | s -> d, d -> s where- double2FloatG :: Vector d -> Vector s- float2DoubleG :: Vector s -> Vector d--instance Precision Float Double where- double2FloatG = double2FloatV- float2DoubleG = float2DoubleV--instance Precision (Complex Float) (Complex Double) where- double2FloatG = asComplex . double2FloatV . asReal- float2DoubleG = asComplex . float2DoubleV . asReal---- | Supported real types-class (Element t, Element (Complex t), RealFloat t--- , RealOf t ~ t, RealOf (Complex t) ~ t- )- => RealElement t--instance RealElement Double-instance RealElement Float----- | Structures that may contain complex numbers-class Complexable c where- toComplex' :: (RealElement e) => (c e, c e) -> c (Complex e)- fromComplex' :: (RealElement e) => c (Complex e) -> (c e, c e)- comp' :: (RealElement e) => c e -> c (Complex e)- single' :: Precision a b => c b -> c a- double' :: Precision a b => c a -> c b---instance Complexable Vector where- toComplex' = toComplexV- fromComplex' = fromComplexV- comp' v = toComplex' (v,constantD 0 (dim v))- single' = double2FloatG- double' = float2DoubleG----- | creates a complex vector from vectors with real and imaginary parts-toComplexV :: (RealElement a) => (Vector a, Vector a) -> Vector (Complex a)-toComplexV (r,i) = asComplex $ flatten $ fromColumns [r,i]---- | the inverse of 'toComplex'-fromComplexV :: (RealElement a) => Vector (Complex a) -> (Vector a, Vector a)-fromComplexV z = (r,i) where- [r,i] = toColumns $ reshape 2 $ asReal z---instance Complexable Matrix where- toComplex' = uncurry $ liftMatrix2 $ curry toComplex'- fromComplex' z = (reshape c *** reshape c) . fromComplex' . flatten $ z- where c = cols z- comp' = liftMatrix comp'- single' = liftMatrix single'- double' = liftMatrix double'-
− lib/Numeric/GSL.hs
@@ -1,43 +0,0 @@-{- |--Module : Numeric.GSL-Copyright : (c) Alberto Ruiz 2006-7-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses -fffi and -fglasgow-exts--This module reexports all available GSL functions.--The GSL special functions are in the separate package hmatrix-special.---}--module Numeric.GSL (- module Numeric.GSL.Integration-, module Numeric.GSL.Differentiation-, module Numeric.GSL.Fourier-, module Numeric.GSL.Polynomials-, module Numeric.GSL.Minimization-, module Numeric.GSL.Root-, module Numeric.GSL.ODE-, module Numeric.GSL.Fitting-, module Data.Complex-, setErrorHandlerOff-) where--import Numeric.GSL.Integration-import Numeric.GSL.Differentiation-import Numeric.GSL.Fourier-import Numeric.GSL.Polynomials-import Numeric.GSL.Minimization-import Numeric.GSL.Root-import Numeric.GSL.ODE-import Numeric.GSL.Fitting-import Data.Complex----- | This action removes the GSL default error handler (which aborts the program), so that--- GSL errors can be handled by Haskell (using Control.Exception) and ghci doesn't abort.-foreign import ccall unsafe "GSL/gsl-aux.h no_abort_on_error" setErrorHandlerOff :: IO ()
− lib/Numeric/GSL/Differentiation.hs
@@ -1,87 +0,0 @@-{-# OPTIONS #-}-------------------------------------------------------------------------------{- |-Module : Numeric.GSL.Differentiation-Copyright : (c) Alberto Ruiz 2006-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Numerical differentiation.--<http://www.gnu.org/software/gsl/manual/html_node/Numerical-Differentiation.html#Numerical-Differentiation>--From the GSL manual: \"The functions described in this chapter compute numerical derivatives by finite differencing. An adaptive algorithm is used to find the best choice of finite difference and to estimate the error in the derivative.\"--}-------------------------------------------------------------------------------module Numeric.GSL.Differentiation (- derivCentral,- derivForward,- derivBackward-) where--import Foreign.C.Types-import Foreign.Marshal.Alloc(malloc, free)-import Foreign.Ptr(Ptr, FunPtr, freeHaskellFunPtr)-import Foreign.Storable(peek)-import Data.Packed.Internal(check,(//))-import System.IO.Unsafe(unsafePerformIO)--derivGen ::- CInt -- ^ type: 0 central, 1 forward, 2 backward- -> Double -- ^ initial step size- -> (Double -> Double) -- ^ function- -> Double -- ^ point where the derivative is taken- -> (Double, Double) -- ^ result and error-derivGen c h f x = unsafePerformIO $ do- r <- malloc- e <- malloc- fp <- mkfun (\y _ -> f y) - c_deriv c fp x h r e // check "deriv"- vr <- peek r- ve <- peek e- let result = (vr,ve)- free r- free e- freeHaskellFunPtr fp- return result--foreign import ccall safe "gsl-aux.h deriv" - c_deriv :: CInt -> FunPtr (Double -> Ptr () -> Double) -> Double -> Double - -> Ptr Double -> Ptr Double -> IO CInt---{- | Adaptive central difference algorithm, /gsl_deriv_central/. For example:--> > let deriv = derivCentral 0.01 -> > deriv sin (pi/4)->(0.7071067812000676,1.0600063101654055e-10)-> > cos (pi/4)->0.7071067811865476 ---}-derivCentral :: Double -- ^ initial step size- -> (Double -> Double) -- ^ function - -> Double -- ^ point where the derivative is taken- -> (Double, Double) -- ^ result and absolute error-derivCentral = derivGen 0---- | Adaptive forward difference algorithm, /gsl_deriv_forward/. The function is evaluated only at points greater than x, and never at x itself. The derivative is returned in result and an estimate of its absolute error is returned in abserr. This function should be used if f(x) has a discontinuity at x, or is undefined for values less than x. A backward derivative can be obtained using a negative step.-derivForward :: Double -- ^ initial step size- -> (Double -> Double) -- ^ function - -> Double -- ^ point where the derivative is taken- -> (Double, Double) -- ^ result and absolute error-derivForward = derivGen 1---- | Adaptive backward difference algorithm, /gsl_deriv_backward/. -derivBackward ::Double -- ^ initial step size- -> (Double -> Double) -- ^ function - -> Double -- ^ point where the derivative is taken- -> (Double, Double) -- ^ result and absolute error-derivBackward = derivGen 2--{- | conversion of Haskell functions into function pointers that can be used in the C side--}-foreign import ccall safe "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double))
− lib/Numeric/GSL/Fitting.hs
@@ -1,177 +0,0 @@-{- |-Module : Numeric.GSL.Fitting-Copyright : (c) Alberto Ruiz 2010-License : GPL--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Nonlinear Least-Squares Fitting--<http://www.gnu.org/software/gsl/manual/html_node/Nonlinear-Least_002dSquares-Fitting.html>--The example program in the GSL manual (see examples/fitting.hs):--@dat = [- ([0.0],([6.0133918608118675],0.1)),- ([1.0],([5.5153769909966535],0.1)),- ([2.0],([5.261094606015287],0.1)),- ...- ([39.0],([1.0619821710802808],0.1))]--expModel [a,lambda,b] [t] = [a * exp (-lambda * t) + b]--expModelDer [a,lambda,b] [t] = [[exp (-lambda * t), -t * a * exp(-lambda*t) , 1]]--(sol,path) = fitModelScaled 1E-4 1E-4 20 (expModel, expModelDer) dat [1,0,0]--\> path-(6><5)- [ 1.0, 76.45780563978782, 1.6465931240727802, 1.8147715267618197e-2, 0.6465931240727797- , 2.0, 37.683816318260355, 2.858760367632973, 8.092094813253975e-2, 1.4479636296208662- , 3.0, 9.5807893736187, 4.948995119561291, 0.11942927999921617, 1.0945766509238248- , 4.0, 5.630494933603935, 5.021755718065913, 0.10287787128056883, 1.0338835440862608- , 5.0, 5.443976278682909, 5.045204331329302, 0.10405523433131504, 1.019416067207375- , 6.0, 5.4439736648994685, 5.045357818922331, 0.10404905846029407, 1.0192487112786812 ]-\> sol-[(5.045357818922331,6.027976702418132e-2),-(0.10404905846029407,3.157045047172834e-3),-(1.0192487112786812,3.782067731353722e-2)]@---}--------------------------------------------------------------------------------module Numeric.GSL.Fitting (- -- * Levenberg-Marquardt- nlFitting, FittingMethod(..),- -- * Utilities- fitModelScaled, fitModel-) where--import Data.Packed.Internal-import Numeric.LinearAlgebra-import Numeric.GSL.Internal--import Foreign.Ptr(FunPtr, freeHaskellFunPtr)-import Foreign.C.Types-import System.IO.Unsafe(unsafePerformIO)-----------------------------------------------------------------------------data FittingMethod = LevenbergMarquardtScaled -- ^ Interface to gsl_multifit_fdfsolver_lmsder. This is a robust and efficient version of the Levenberg-Marquardt algorithm as implemented in the scaled lmder routine in minpack. Minpack was written by Jorge J. More, Burton S. Garbow and Kenneth E. Hillstrom.- | LevenbergMarquardt -- ^ This is an unscaled version of the lmder algorithm. The elements of the diagonal scaling matrix D are set to 1. This algorithm may be useful in circumstances where the scaled version of lmder converges too slowly, or the function is already scaled appropriately.- deriving (Enum,Eq,Show,Bounded)----- | Nonlinear multidimensional least-squares fitting.-nlFitting :: FittingMethod- -> Double -- ^ absolute tolerance- -> Double -- ^ relative tolerance- -> Int -- ^ maximum number of iterations allowed- -> (Vector Double -> Vector Double) -- ^ function to be minimized- -> (Vector Double -> Matrix Double) -- ^ Jacobian- -> Vector Double -- ^ starting point- -> (Vector Double, Matrix Double) -- ^ solution vector and optimization path--nlFitting method epsabs epsrel maxit fun jac xinit = nlFitGen (fi (fromEnum method)) fun jac xinit epsabs epsrel maxit--nlFitGen m f jac xiv epsabs epsrel maxit = unsafePerformIO $ do- let p = dim xiv- n = dim (f xiv)- fp <- mkVecVecfun (aux_vTov (checkdim1 n p . f))- jp <- mkVecMatfun (aux_vTom (checkdim2 n p . jac))- rawpath <- createMatrix RowMajor maxit (2+p)- app2 (c_nlfit m fp jp epsabs epsrel (fi maxit) (fi n)) vec xiv mat rawpath "c_nlfit"- let it = round (rawpath @@> (maxit-1,0))- path = takeRows it rawpath- [sol] = toRows $ dropRows (it-1) path- freeHaskellFunPtr fp- freeHaskellFunPtr jp- return (subVector 2 p sol, path)--foreign import ccall safe "nlfit"- c_nlfit:: CInt -> FunPtr TVV -> FunPtr TVM -> Double -> Double -> CInt -> CInt -> TVM-----------------------------------------------------------checkdim1 n _p v- | dim v == n = v- | otherwise = error $ "Error: "++ show n- ++ " components expected in the result of the function supplied to nlFitting"--checkdim2 n p m- | rows m == n && cols m == p = m- | otherwise = error $ "Error: "++ show n ++ "x" ++ show p- ++ " Jacobian expected in nlFitting"----------------------------------------------------------------err (model,deriv) dat vsol = zip sol errs where- sol = toList vsol- c = max 1 (chi/sqrt (fromIntegral dof))- dof = length dat - (rows cov)- chi = norm2 (fromList $ cost (resMs model) dat sol)- js = fromLists $ jacobian (resDs deriv) dat sol- cov = inv $ trans js <> js- errs = toList $ scalar c * sqrt (takeDiag cov)------ | Higher level interface to 'nlFitting' 'LevenbergMarquardtScaled'. The optimization function and--- Jacobian are automatically built from a model f vs x = y and its derivatives, and a list of--- instances (x, (y,sigma)) to be fitted.--fitModelScaled- :: Double -- ^ absolute tolerance- -> Double -- ^ relative tolerance- -> Int -- ^ maximum number of iterations allowed- -> ([Double] -> x -> [Double], [Double] -> x -> [[Double]]) -- ^ (model, derivatives)- -> [(x, ([Double], Double))] -- ^ instances- -> [Double] -- ^ starting point- -> ([(Double, Double)], Matrix Double) -- ^ (solution, error) and optimization path-fitModelScaled epsabs epsrel maxit (model,deriv) dt xin = (err (model,deriv) dt sol, path) where- (sol,path) = nlFitting LevenbergMarquardtScaled epsabs epsrel maxit- (fromList . cost (resMs model) dt . toList)- (fromLists . jacobian (resDs deriv) dt . toList)- (fromList xin)------ | Higher level interface to 'nlFitting' 'LevenbergMarquardt'. The optimization function and--- Jacobian are automatically built from a model f vs x = y and its derivatives, and a list of--- instances (x,y) to be fitted.--fitModel :: Double -- ^ absolute tolerance- -> Double -- ^ relative tolerance- -> Int -- ^ maximum number of iterations allowed- -> ([Double] -> x -> [Double], [Double] -> x -> [[Double]]) -- ^ (model, derivatives)- -> [(x, [Double])] -- ^ instances- -> [Double] -- ^ starting point- -> ([Double], Matrix Double) -- ^ solution and optimization path-fitModel epsabs epsrel maxit (model,deriv) dt xin = (toList sol, path) where- (sol,path) = nlFitting LevenbergMarquardt epsabs epsrel maxit- (fromList . cost (resM model) dt . toList)- (fromLists . jacobian (resD deriv) dt . toList)- (fromList xin)--cost model ds vs = concatMap (model vs) ds--jacobian modelDer ds vs = concatMap (modelDer vs) ds---- | Model-to-residual for association pairs with sigma, to be used with 'fitModel'.-resMs :: ([Double] -> x -> [Double]) -> [Double] -> (x, ([Double], Double)) -> [Double]-resMs m v = \(x,(ys,s)) -> zipWith (g s) (m v x) ys where g s a b = (a-b)/s---- | Associated derivative for 'resMs'.-resDs :: ([Double] -> x -> [[Double]]) -> [Double] -> (x, ([Double], Double)) -> [[Double]]-resDs m v = \(x,(_,s)) -> map (map (/s)) (m v x)---- | Model-to-residual for association pairs, to be used with 'fitModel'. It is equivalent--- to 'resMs' with all sigmas = 1.-resM :: ([Double] -> x -> [Double]) -> [Double] -> (x, [Double]) -> [Double]-resM m v = \(x,ys) -> zipWith g (m v x) ys where g a b = a-b---- | Associated derivative for 'resM'.-resD :: ([Double] -> x -> [[Double]]) -> [Double] -> (x, [Double]) -> [[Double]]-resD m v = \(x,_) -> m v x
− lib/Numeric/GSL/Fourier.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-------------------------------------------------------------------------------{- |-Module : Numeric.GSL.Fourier-Copyright : (c) Alberto Ruiz 2006-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Fourier Transform.--<http://www.gnu.org/software/gsl/manual/html_node/Fast-Fourier-Transforms.html#Fast-Fourier-Transforms>---}-------------------------------------------------------------------------------module Numeric.GSL.Fourier (- fft,- ifft-) where--import Data.Packed.Internal-import Data.Complex-import Foreign.C.Types-import System.IO.Unsafe (unsafePerformIO)--genfft code v = unsafePerformIO $ do- r <- createVector (dim v)- app2 (c_fft code) vec v vec r "fft"- return r--foreign import ccall unsafe "gsl-aux.h fft" c_fft :: CInt -> TCVCV---{- | Fast 1D Fourier transform of a 'Vector' @(@'Complex' 'Double'@)@ using /gsl_fft_complex_forward/. It uses the same scaling conventions as GNU Octave.--@> fft ('fromList' [1,2,3,4])-vector (4) [10.0 :+ 0.0,(-2.0) :+ 2.0,(-2.0) :+ 0.0,(-2.0) :+ (-2.0)]@---}-fft :: Vector (Complex Double) -> Vector (Complex Double)-fft = genfft 0---- | The inverse of 'fft', using /gsl_fft_complex_inverse/.-ifft :: Vector (Complex Double) -> Vector (Complex Double)-ifft = genfft 1
− lib/Numeric/GSL/Integration.hs
@@ -1,198 +0,0 @@-{-# OPTIONS #-}-------------------------------------------------------------------------------{- |-Module : Numeric.GSL.Integration-Copyright : (c) Alberto Ruiz 2006-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Numerical integration routines.--<http://www.gnu.org/software/gsl/manual/html_node/Numerical-Integration.html#Numerical-Integration>--}--------------------------------------------------------------------------------module Numeric.GSL.Integration (- integrateQNG,- integrateQAGS,- integrateQAGI,- integrateQAGIU,- integrateQAGIL-) where--import Foreign.C.Types-import Foreign.Marshal.Alloc(malloc, free)-import Foreign.Ptr(Ptr, FunPtr, freeHaskellFunPtr)-import Foreign.Storable(peek)-import Data.Packed.Internal(check,(//))-import System.IO.Unsafe(unsafePerformIO)--{- | conversion of Haskell functions into function pointers that can be used in the C side--}-foreign import ccall safe "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double)) -----------------------------------------------------------------------{- | Numerical integration using /gsl_integration_qags/ (adaptive integration with singularities). For example:--@\> let quad = integrateQAGS 1E-9 1000 -\> let f a x = x**(-0.5) * log (a*x)-\> quad (f 1) 0 1-(-3.999999999999974,4.871658632055187e-13)@- --}--integrateQAGS :: Double -- ^ precision (e.g. 1E-9)- -> Int -- ^ size of auxiliary workspace (e.g. 1000)- -> (Double -> Double) -- ^ function to be integrated on the interval (a,b)- -> Double -- ^ a- -> Double -- ^ b- -> (Double, Double) -- ^ result of the integration and error-integrateQAGS prec n f a b = unsafePerformIO $ do- r <- malloc- e <- malloc- fp <- mkfun (\x _ -> f x) - c_integrate_qags fp a b prec (fromIntegral n) r e // check "integrate_qags"- vr <- peek r- ve <- peek e- let result = (vr,ve)- free r- free e- freeHaskellFunPtr fp- return result--foreign import ccall safe "gsl-aux.h integrate_qags" - c_integrate_qags :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> Double -> CInt- -> Ptr Double -> Ptr Double -> IO CInt--------------------------------------------------------------------{- | Numerical integration using /gsl_integration_qng/ (useful for fast integration of smooth functions). For example:--@\> let quad = integrateQNG 1E-6 -\> quad (\\x -> 4\/(1+x*x)) 0 1 -(3.141592653589793,3.487868498008632e-14)@- --}--integrateQNG :: Double -- ^ precision (e.g. 1E-9)- -> (Double -> Double) -- ^ function to be integrated on the interval (a,b)- -> Double -- ^ a- -> Double -- ^ b- -> (Double, Double) -- ^ result of the integration and error-integrateQNG prec f a b = unsafePerformIO $ do- r <- malloc- e <- malloc- fp <- mkfun (\x _ -> f x) - c_integrate_qng fp a b prec r e // check "integrate_qng"- vr <- peek r- ve <- peek e- let result = (vr,ve)- free r- free e- freeHaskellFunPtr fp- return result--foreign import ccall safe "gsl-aux.h integrate_qng" - c_integrate_qng :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> Double - -> Ptr Double -> Ptr Double -> IO CInt-----------------------------------------------------------------------{- | Numerical integration using /gsl_integration_qagi/ (integration over the infinite integral -Inf..Inf using QAGS). -For example:--@\> let quad = integrateQAGI 1E-9 1000 -\> let f a x = exp(-a * x^2)-\> quad (f 0.5) -(2.5066282746310002,6.229215880648858e-11)@- --}--integrateQAGI :: Double -- ^ precision (e.g. 1E-9)- -> Int -- ^ size of auxiliary workspace (e.g. 1000)- -> (Double -> Double) -- ^ function to be integrated on the interval (-Inf,Inf)- -> (Double, Double) -- ^ result of the integration and error-integrateQAGI prec n f = unsafePerformIO $ do- r <- malloc- e <- malloc- fp <- mkfun (\x _ -> f x) - c_integrate_qagi fp prec (fromIntegral n) r e // check "integrate_qagi"- vr <- peek r- ve <- peek e- let result = (vr,ve)- free r- free e- freeHaskellFunPtr fp- return result--foreign import ccall safe "gsl-aux.h integrate_qagi" - c_integrate_qagi :: FunPtr (Double-> Ptr() -> Double) -> Double -> CInt- -> Ptr Double -> Ptr Double -> IO CInt-----------------------------------------------------------------------{- | Numerical integration using /gsl_integration_qagiu/ (integration over the semi-infinite integral a..Inf). -For example:--@\> let quad = integrateQAGIU 1E-9 1000 -\> let f a x = exp(-a * x^2)-\> quad (f 0.5) 0-(1.2533141373155001,3.114607940324429e-11)@- --}--integrateQAGIU :: Double -- ^ precision (e.g. 1E-9)- -> Int -- ^ size of auxiliary workspace (e.g. 1000)- -> (Double -> Double) -- ^ function to be integrated on the interval (a,Inf)- -> Double -- ^ a- -> (Double, Double) -- ^ result of the integration and error-integrateQAGIU prec n f a = unsafePerformIO $ do- r <- malloc- e <- malloc- fp <- mkfun (\x _ -> f x) - c_integrate_qagiu fp a prec (fromIntegral n) r e // check "integrate_qagiu"- vr <- peek r- ve <- peek e- let result = (vr,ve)- free r- free e- freeHaskellFunPtr fp- return result--foreign import ccall safe "gsl-aux.h integrate_qagiu" - c_integrate_qagiu :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> CInt- -> Ptr Double -> Ptr Double -> IO CInt-----------------------------------------------------------------------{- | Numerical integration using /gsl_integration_qagil/ (integration over the semi-infinite integral -Inf..b). -For example:--@\> let quad = integrateQAGIL 1E-9 1000 -\> let f a x = exp(-a * x^2)-\> quad (f 0.5) 0 -(1.2533141373155001,3.114607940324429e-11)@- --}--integrateQAGIL :: Double -- ^ precision (e.g. 1E-9)- -> Int -- ^ size of auxiliary workspace (e.g. 1000)- -> (Double -> Double) -- ^ function to be integrated on the interval (a,Inf)- -> Double -- ^ b- -> (Double, Double) -- ^ result of the integration and error-integrateQAGIL prec n f b = unsafePerformIO $ do- r <- malloc- e <- malloc- fp <- mkfun (\x _ -> f x) - c_integrate_qagil fp b prec (fromIntegral n) r e // check "integrate_qagil"- vr <- peek r- ve <- peek e- let result = (vr,ve)- free r- free e- freeHaskellFunPtr fp- return result--foreign import ccall safe "gsl-aux.h integrate_qagil" - c_integrate_qagil :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> CInt- -> Ptr Double -> Ptr Double -> IO CInt-
− lib/Numeric/GSL/Internal.hs
@@ -1,73 +0,0 @@--- Module : Numeric.GSL.Internal--- Copyright : (c) Alberto Ruiz 2009--- License : GPL------ Maintainer : Alberto Ruiz (aruiz at um dot es)--- Stability : provisional--- Portability : uses ffi------ Auxiliary functions.------ #hide--module Numeric.GSL.Internal where--import Data.Packed.Internal--import Foreign.Marshal.Array(copyArray)-import Foreign.Ptr(Ptr, FunPtr)-import Foreign.C.Types-import System.IO.Unsafe(unsafePerformIO)--iv :: (Vector Double -> Double) -> (CInt -> Ptr Double -> Double)-iv f n p = f (createV (fromIntegral n) copy "iv") where- copy n' q = do- copyArray q p (fromIntegral n')- return 0---- | conversion of Haskell functions into function pointers that can be used in the C side-foreign import ccall safe "wrapper"- mkVecfun :: (CInt -> Ptr Double -> Double)- -> IO( FunPtr (CInt -> Ptr Double -> Double))--foreign import ccall safe "wrapper"- mkVecVecfun :: TVV -> IO (FunPtr TVV)--foreign import ccall safe "wrapper"- mkDoubleVecVecfun :: (Double -> TVV) -> IO (FunPtr (Double -> TVV))--aux_vTov :: (Vector Double -> Vector Double) -> TVV-aux_vTov f n p nr r = g where- v = f x- x = createV (fromIntegral n) copy "aux_vTov"- copy n' q = do- copyArray q p (fromIntegral n')- return 0- g = do unsafeWith v $ \p' -> copyArray r p' (fromIntegral nr)- return 0--foreign import ccall safe "wrapper"- mkVecMatfun :: TVM -> IO (FunPtr TVM)--foreign import ccall safe "wrapper"- mkDoubleVecMatfun :: (Double -> TVM) -> IO (FunPtr (Double -> TVM))--aux_vTom :: (Vector Double -> Matrix Double) -> TVM-aux_vTom f n p rr cr r = g where- v = flatten $ f x- x = createV (fromIntegral n) copy "aux_vTov"- copy n' q = do- copyArray q p (fromIntegral n')- return 0- g = do unsafeWith v $ \p' -> copyArray r p' (fromIntegral $ rr*cr)- return 0--createV n fun msg = unsafePerformIO $ do- r <- createVector n- app1 fun vec r msg- return r--createMIO r c fun msg = do- res <- createMatrix RowMajor r c- app1 fun mat res msg- return res
− lib/Numeric/GSL/Minimization.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-------------------------------------------------------------------------------{- |-Module : Numeric.GSL.Minimization-Copyright : (c) Alberto Ruiz 2006-9-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Minimization of a multidimensional function using some of the algorithms described in:--<http://www.gnu.org/software/gsl/manual/html_node/Multidimensional-Minimization.html>--The example in the GSL manual:--@--f [x,y] = 10*(x-1)^2 + 20*(y-2)^2 + 30--main = do- let (s,p) = minimize NMSimplex2 1E-2 30 [1,1] f [5,7]- print s- print p--\> main-[0.9920430849306288,1.9969168063253182]- 0.000 512.500 1.130 6.500 5.000- 1.000 290.625 1.409 5.250 4.000- 2.000 290.625 1.409 5.250 4.000- 3.000 252.500 1.409 5.500 1.000- ...-22.000 30.001 0.013 0.992 1.997-23.000 30.001 0.008 0.992 1.997-@--The path to the solution can be graphically shown by means of:--@'Graphics.Plot.mplot' $ drop 3 ('toColumns' p)@--Taken from the GSL manual:--The vector Broyden-Fletcher-Goldfarb-Shanno (BFGS) algorithm is a quasi-Newton method which builds up an approximation to the second derivatives of the function f using the difference between successive gradient vectors. By combining the first and second derivatives the algorithm is able to take Newton-type steps towards the function minimum, assuming quadratic behavior in that region.--The bfgs2 version of this minimizer is the most efficient version available, and is a faithful implementation of the line minimization scheme described in Fletcher's Practical Methods of Optimization, Algorithms 2.6.2 and 2.6.4. It supercedes the original bfgs routine and requires substantially fewer function and gradient evaluations. The user-supplied tolerance tol corresponds to the parameter \sigma used by Fletcher. A value of 0.1 is recommended for typical use (larger values correspond to less accurate line searches).--The nmsimplex2 version is a new O(N) implementation of the earlier O(N^2) nmsimplex minimiser. It calculates the size of simplex as the rms distance of each vertex from the center rather than the mean distance, which has the advantage of allowing a linear update.---}--------------------------------------------------------------------------------module Numeric.GSL.Minimization (- minimize, minimizeV, MinimizeMethod(..),- minimizeD, minimizeVD, MinimizeMethodD(..),-- minimizeNMSimplex,- minimizeConjugateGradient,- minimizeVectorBFGS2-) where---import Data.Packed.Internal-import Data.Packed.Matrix-import Numeric.GSL.Internal--import Foreign.Ptr(Ptr, FunPtr, freeHaskellFunPtr)-import Foreign.C.Types-import System.IO.Unsafe(unsafePerformIO)----------------------------------------------------------------------------{-# DEPRECATED minimizeNMSimplex "use minimize NMSimplex2 eps maxit sizes f xi" #-}-minimizeNMSimplex f xi szs eps maxit = minimize NMSimplex eps maxit szs f xi--{-# DEPRECATED minimizeConjugateGradient "use minimizeD ConjugateFR eps maxit step tol f g xi" #-}-minimizeConjugateGradient step tol eps maxit f g xi = minimizeD ConjugateFR eps maxit step tol f g xi--{-# DEPRECATED minimizeVectorBFGS2 "use minimizeD VectorBFGS2 eps maxit step tol f g xi" #-}-minimizeVectorBFGS2 step tol eps maxit f g xi = minimizeD VectorBFGS2 eps maxit step tol f g xi-----------------------------------------------------------------------------data MinimizeMethod = NMSimplex- | NMSimplex2- deriving (Enum,Eq,Show,Bounded)---- | Minimization without derivatives-minimize :: MinimizeMethod- -> Double -- ^ desired precision of the solution (size test)- -> Int -- ^ maximum number of iterations allowed- -> [Double] -- ^ sizes of the initial search box- -> ([Double] -> Double) -- ^ function to minimize- -> [Double] -- ^ starting point- -> ([Double], Matrix Double) -- ^ solution vector and optimization path---- | Minimization without derivatives (vector version)-minimizeV :: MinimizeMethod- -> Double -- ^ desired precision of the solution (size test)- -> Int -- ^ maximum number of iterations allowed- -> Vector Double -- ^ sizes of the initial search box- -> (Vector Double -> Double) -- ^ function to minimize- -> Vector Double -- ^ starting point- -> (Vector Double, Matrix Double) -- ^ solution vector and optimization path--minimize method eps maxit sz f xi = v2l $ minimizeV method eps maxit (fromList sz) (f.toList) (fromList xi)- where v2l (v,m) = (toList v, m)--ww2 w1 o1 w2 o2 f = w1 o1 $ \a1 -> w2 o2 $ \a2 -> f a1 a2--minimizeV method eps maxit szv f xiv = unsafePerformIO $ do- let n = dim xiv- fp <- mkVecfun (iv f)- rawpath <- ww2 vec xiv vec szv $ \xiv' szv' ->- createMIO maxit (n+3)- (c_minimize (fi (fromEnum method)) fp eps (fi maxit) // xiv' // szv')- "minimize"- let it = round (rawpath @@> (maxit-1,0))- path = takeRows it rawpath- sol = cdat $ dropColumns 3 $ dropRows (it-1) path- freeHaskellFunPtr fp- return (sol, path)---foreign import ccall safe "gsl-aux.h minimize"- c_minimize:: CInt -> FunPtr (CInt -> Ptr Double -> Double) -> Double -> CInt -> TVVM---------------------------------------------------------------------------------------data MinimizeMethodD = ConjugateFR- | ConjugatePR- | VectorBFGS- | VectorBFGS2- | SteepestDescent- deriving (Enum,Eq,Show,Bounded)---- | Minimization with derivatives.-minimizeD :: MinimizeMethodD- -> Double -- ^ desired precision of the solution (gradient test)- -> Int -- ^ maximum number of iterations allowed- -> Double -- ^ size of the first trial step- -> Double -- ^ tol (precise meaning depends on method)- -> ([Double] -> Double) -- ^ function to minimize- -> ([Double] -> [Double]) -- ^ gradient- -> [Double] -- ^ starting point- -> ([Double], Matrix Double) -- ^ solution vector and optimization path---- | Minimization with derivatives (vector version)-minimizeVD :: MinimizeMethodD- -> Double -- ^ desired precision of the solution (gradient test)- -> Int -- ^ maximum number of iterations allowed- -> Double -- ^ size of the first trial step- -> Double -- ^ tol (precise meaning depends on method)- -> (Vector Double -> Double) -- ^ function to minimize- -> (Vector Double -> Vector Double) -- ^ gradient- -> Vector Double -- ^ starting point- -> (Vector Double, Matrix Double) -- ^ solution vector and optimization path--minimizeD method eps maxit istep tol f df xi = v2l $ minimizeVD- method eps maxit istep tol (f.toList) (fromList.df.toList) (fromList xi)- where v2l (v,m) = (toList v, m)---minimizeVD method eps maxit istep tol f df xiv = unsafePerformIO $ do- let n = dim xiv- f' = f- df' = (checkdim1 n . df)- fp <- mkVecfun (iv f')- dfp <- mkVecVecfun (aux_vTov df')- rawpath <- vec xiv $ \xiv' ->- createMIO maxit (n+2)- (c_minimizeD (fi (fromEnum method)) fp dfp istep tol eps (fi maxit) // xiv')- "minimizeD"- let it = round (rawpath @@> (maxit-1,0))- path = takeRows it rawpath- sol = cdat $ dropColumns 2 $ dropRows (it-1) path- freeHaskellFunPtr fp- freeHaskellFunPtr dfp- return (sol,path)--foreign import ccall safe "gsl-aux.h minimizeD"- c_minimizeD :: CInt- -> FunPtr (CInt -> Ptr Double -> Double)- -> FunPtr TVV- -> Double -> Double -> Double -> CInt- -> TVM-------------------------------------------------------------------------checkdim1 n v- | dim v == n = v- | otherwise = error $ "Error: "++ show n- ++ " components expected in the result of the gradient supplied to minimizeD"
− lib/Numeric/GSL/ODE.hs
@@ -1,136 +0,0 @@-{- |-Module : Numeric.GSL.ODE-Copyright : (c) Alberto Ruiz 2010-License : GPL--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Solution of ordinary differential equation (ODE) initial value problems.--<http://www.gnu.org/software/gsl/manual/html_node/Ordinary-Differential-Equations.html>--A simple example:--@import Numeric.GSL-import Numeric.LinearAlgebra-import Graphics.Plot--xdot t [x,v] = [v, -0.95*x - 0.1*v]--ts = linspace 100 (0,20 :: Double)--sol = odeSolve xdot [10,0] ts--main = mplot (ts : toColumns sol)@---}--------------------------------------------------------------------------------module Numeric.GSL.ODE (- odeSolve, odeSolveV, ODEMethod(..), Jacobian-) where--import Data.Packed.Internal-import Numeric.GSL.Internal--import Foreign.Ptr(FunPtr, nullFunPtr, freeHaskellFunPtr)-import Foreign.C.Types-import System.IO.Unsafe(unsafePerformIO)-----------------------------------------------------------------------------type Jacobian = Double -> Vector Double -> Matrix Double---- | Stepping functions-data ODEMethod = RK2 -- ^ Embedded Runge-Kutta (2, 3) method.- | RK4 -- ^ 4th order (classical) Runge-Kutta. The error estimate is obtained by halving the step-size. For more efficient estimate of the error, use the embedded methods.- | RKf45 -- ^ Embedded Runge-Kutta-Fehlberg (4, 5) method. This method is a good general-purpose integrator.- | RKck -- ^ Embedded Runge-Kutta Cash-Karp (4, 5) method.- | RK8pd -- ^ Embedded Runge-Kutta Prince-Dormand (8,9) method.- | RK2imp Jacobian -- ^ Implicit 2nd order Runge-Kutta at Gaussian points.- | RK4imp Jacobian -- ^ Implicit 4th order Runge-Kutta at Gaussian points.- | BSimp Jacobian -- ^ Implicit Bulirsch-Stoer method of Bader and Deuflhard. The method is generally suitable for stiff problems.- | RK1imp Jacobian -- ^ Implicit Gaussian first order Runge-Kutta. Also known as implicit Euler or backward Euler method. Error estimation is carried out by the step doubling method.- | MSAdams -- ^ A variable-coefficient linear multistep Adams method in Nordsieck form. This stepper uses explicit Adams-Bashforth (predictor) and implicit Adams-Moulton (corrector) methods in P(EC)^m functional iteration mode. Method order varies dynamically between 1 and 12. - | MSBDF Jacobian -- ^ A variable-coefficient linear multistep backward differentiation formula (BDF) method in Nordsieck form. This stepper uses the explicit BDF formula as predictor and implicit BDF formula as corrector. A modified Newton iteration method is used to solve the system of non-linear equations. Method order varies dynamically between 1 and 5. The method is generally suitable for stiff problems.----- | A version of 'odeSolveV' with reasonable default parameters and system of equations defined using lists.-odeSolve- :: (Double -> [Double] -> [Double]) -- ^ xdot(t,x)- -> [Double] -- ^ initial conditions- -> Vector Double -- ^ desired solution times- -> Matrix Double -- ^ solution-odeSolve xdot xi ts = odeSolveV RKf45 hi epsAbs epsRel (l2v xdot) (fromList xi) ts- where hi = (ts@>1 - ts@>0)/100- epsAbs = 1.49012e-08- epsRel = 1.49012e-08- l2v f = \t -> fromList . f t . toList---- | Evolution of the system with adaptive step-size control.-odeSolveV- :: ODEMethod- -> Double -- ^ initial step size- -> Double -- ^ absolute tolerance for the state vector- -> Double -- ^ relative tolerance for the state vector- -> (Double -> Vector Double -> Vector Double) -- ^ xdot(t,x)- -> Vector Double -- ^ initial conditions- -> Vector Double -- ^ desired solution times- -> Matrix Double -- ^ solution-odeSolveV RK2 = odeSolveV' 0 Nothing-odeSolveV RK4 = odeSolveV' 1 Nothing-odeSolveV RKf45 = odeSolveV' 2 Nothing-odeSolveV RKck = odeSolveV' 3 Nothing-odeSolveV RK8pd = odeSolveV' 4 Nothing-odeSolveV (RK2imp jac) = odeSolveV' 5 (Just jac)-odeSolveV (RK4imp jac) = odeSolveV' 6 (Just jac)-odeSolveV (BSimp jac) = odeSolveV' 7 (Just jac)-odeSolveV (RK1imp jac) = odeSolveV' 8 (Just jac)-odeSolveV MSAdams = odeSolveV' 9 Nothing-odeSolveV (MSBDF jac) = odeSolveV' 10 (Just jac)---odeSolveV'- :: CInt- -> Maybe (Double -> Vector Double -> Matrix Double) -- ^ optional jacobian- -> Double -- ^ initial step size- -> Double -- ^ absolute tolerance for the state vector- -> Double -- ^ relative tolerance for the state vector- -> (Double -> Vector Double -> Vector Double) -- ^ xdot(t,x)- -> Vector Double -- ^ initial conditions- -> Vector Double -- ^ desired solution times- -> Matrix Double -- ^ solution-odeSolveV' method mbjac h epsAbs epsRel f xiv ts = unsafePerformIO $ do- let n = dim xiv- fp <- mkDoubleVecVecfun (\t -> aux_vTov (checkdim1 n . f t))- jp <- case mbjac of- Just jac -> mkDoubleVecMatfun (\t -> aux_vTom (checkdim2 n . jac t))- Nothing -> return nullFunPtr- sol <- vec xiv $ \xiv' ->- vec (checkTimes ts) $ \ts' ->- createMIO (dim ts) n- (ode_c (method) h epsAbs epsRel fp jp // xiv' // ts' )- "ode"- freeHaskellFunPtr fp- return sol--foreign import ccall safe "ode"- ode_c :: CInt -> Double -> Double -> Double -> FunPtr (Double -> TVV) -> FunPtr (Double -> TVM) -> TVVM-----------------------------------------------------------checkdim1 n v- | dim v == n = v- | otherwise = error $ "Error: "++ show n- ++ " components expected in the result of the function supplied to odeSolve"--checkdim2 n m- | rows m == n && cols m == n = m- | otherwise = error $ "Error: "++ show n ++ "x" ++ show n- ++ " Jacobian expected in odeSolve"--checkTimes ts | dim ts > 1 && all (>0) (zipWith subtract ts' (tail ts')) = ts- | otherwise = error "odeSolve requires increasing times"- where ts' = toList ts
− lib/Numeric/GSL/Polynomials.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-------------------------------------------------------------------------------{- |-Module : Numeric.GSL.Polynomials-Copyright : (c) Alberto Ruiz 2006-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Polynomials.--<http://www.gnu.org/software/gsl/manual/html_node/General-Polynomial-Equations.html#General-Polynomial-Equations>---}-------------------------------------------------------------------------------module Numeric.GSL.Polynomials (- polySolve-) where--import Data.Packed.Internal-import Data.Complex-import System.IO.Unsafe (unsafePerformIO)--#if __GLASGOW_HASKELL__ >= 704-import Foreign.C.Types (CInt(..))-#endif--{- | Solution of general polynomial equations, using /gsl_poly_complex_solve/. For example,- the three solutions of x^3 + 8 = 0--@\> polySolve [8,0,0,1]-[(-1.9999999999999998) :+ 0.0,- 1.0 :+ 1.732050807568877,- 1.0 :+ (-1.732050807568877)]@--The example in the GSL manual: To find the roots of x^5 -1 = 0:--@\> polySolve [-1, 0, 0, 0, 0, 1]-[(-0.8090169943749475) :+ 0.5877852522924731,-(-0.8090169943749475) :+ (-0.5877852522924731),-0.30901699437494734 :+ 0.9510565162951536,-0.30901699437494734 :+ (-0.9510565162951536),-1.0 :+ 0.0]@---} -polySolve :: [Double] -> [Complex Double]-polySolve = toList . polySolve' . fromList--polySolve' :: Vector Double -> Vector (Complex Double)-polySolve' v | dim v > 1 = unsafePerformIO $ do- r <- createVector (dim v-1)- app2 c_polySolve vec v vec r "polySolve"- return r- | otherwise = error "polySolve on a polynomial of degree zero"--foreign import ccall unsafe "gsl-aux.h polySolve" c_polySolve:: TVCV
− lib/Numeric/GSL/Root.hs
@@ -1,146 +0,0 @@-{- |-Module : Numeric.GSL.Root-Copyright : (c) Alberto Ruiz 2009-License : GPL--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--Multidimensional root finding.--<http://www.gnu.org/software/gsl/manual/html_node/Multidimensional-Root_002dFinding.html>--The example in the GSL manual:--@import Numeric.GSL-import Numeric.LinearAlgebra(format)-import Text.Printf(printf)--rosenbrock a b [x,y] = [ a*(1-x), b*(y-x^2) ]--disp = putStrLn . format \" \" (printf \"%.3f\")--main = do- let (sol,path) = root Hybrids 1E-7 30 (rosenbrock 1 10) [-10,-5]- print sol- disp path--\> main-[1.0,1.0]- 0.000 -10.000 -5.000 11.000 -1050.000- 1.000 -3.976 24.827 4.976 90.203- 2.000 -3.976 24.827 4.976 90.203- 3.000 -3.976 24.827 4.976 90.203- 4.000 -1.274 -5.680 2.274 -73.018- 5.000 -1.274 -5.680 2.274 -73.018- 6.000 0.249 0.298 0.751 2.359- 7.000 0.249 0.298 0.751 2.359- 8.000 1.000 0.878 -0.000 -1.218- 9.000 1.000 0.989 -0.000 -0.108-10.000 1.000 1.000 0.000 0.000-@---}--------------------------------------------------------------------------------module Numeric.GSL.Root (- root, RootMethod(..),- rootJ, RootMethodJ(..),-) where--import Data.Packed.Internal-import Data.Packed.Matrix-import Numeric.GSL.Internal-import Foreign.Ptr(FunPtr, freeHaskellFunPtr)-import Foreign.C.Types-import System.IO.Unsafe(unsafePerformIO)-----------------------------------------------------------------------------data RootMethod = Hybrids- | Hybrid- | DNewton- | Broyden- deriving (Enum,Eq,Show,Bounded)---- | Nonlinear multidimensional root finding using algorithms that do not require --- any derivative information to be supplied by the user.--- Any derivatives needed are approximated by finite differences.-root :: RootMethod- -> Double -- ^ maximum residual- -> Int -- ^ maximum number of iterations allowed- -> ([Double] -> [Double]) -- ^ function to minimize- -> [Double] -- ^ starting point- -> ([Double], Matrix Double) -- ^ solution vector and optimization path--root method epsabs maxit fun xinit = rootGen (fi (fromEnum method)) fun xinit epsabs maxit--rootGen m f xi epsabs maxit = unsafePerformIO $ do- let xiv = fromList xi- n = dim xiv- fp <- mkVecVecfun (aux_vTov (checkdim1 n . fromList . f . toList))- rawpath <- vec xiv $ \xiv' ->- createMIO maxit (2*n+1)- (c_root m fp epsabs (fi maxit) // xiv')- "root"- let it = round (rawpath @@> (maxit-1,0))- path = takeRows it rawpath- [sol] = toLists $ dropRows (it-1) path- freeHaskellFunPtr fp- return (take n $ drop 1 sol, path)---foreign import ccall safe "root"- c_root:: CInt -> FunPtr TVV -> Double -> CInt -> TVM-----------------------------------------------------------------------------data RootMethodJ = HybridsJ- | HybridJ- | Newton- | GNewton- deriving (Enum,Eq,Show,Bounded)---- | Nonlinear multidimensional root finding using both the function and its derivatives.-rootJ :: RootMethodJ- -> Double -- ^ maximum residual- -> Int -- ^ maximum number of iterations allowed- -> ([Double] -> [Double]) -- ^ function to minimize- -> ([Double] -> [[Double]]) -- ^ Jacobian- -> [Double] -- ^ starting point- -> ([Double], Matrix Double) -- ^ solution vector and optimization path--rootJ method epsabs maxit fun jac xinit = rootJGen (fi (fromEnum method)) fun jac xinit epsabs maxit--rootJGen m f jac xi epsabs maxit = unsafePerformIO $ do- let xiv = fromList xi- n = dim xiv- fp <- mkVecVecfun (aux_vTov (checkdim1 n . fromList . f . toList))- jp <- mkVecMatfun (aux_vTom (checkdim2 n . fromLists . jac . toList))- rawpath <- vec xiv $ \xiv' ->- createMIO maxit (2*n+1)- (c_rootj m fp jp epsabs (fi maxit) // xiv')- "root"- let it = round (rawpath @@> (maxit-1,0))- path = takeRows it rawpath- [sol] = toLists $ dropRows (it-1) path- freeHaskellFunPtr fp- freeHaskellFunPtr jp- return (take n $ drop 1 sol, path)---foreign import ccall safe "rootj"- c_rootj:: CInt -> FunPtr TVV -> FunPtr TVM -> Double -> CInt -> TVM-----------------------------------------------------------checkdim1 n v- | dim v == n = v- | otherwise = error $ "Error: "++ show n- ++ " components expected in the result of the function supplied to root"--checkdim2 n m- | rows m == n && cols m == n = m- | otherwise = error $ "Error: "++ show n ++ "x" ++ show n- ++ " Jacobian expected in rootJ"
− lib/Numeric/GSL/Vector.hs
@@ -1,327 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.GSL.Vector--- Copyright : (c) Alberto Ruiz 2007--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable (uses FFI)------ Low level interface to vector operations.-----------------------------------------------------------------------------------module Numeric.GSL.Vector (- sumF, sumR, sumQ, sumC,- prodF, prodR, prodQ, prodC,- dotF, dotR, dotQ, dotC,- FunCodeS(..), toScalarR, toScalarF, toScalarC, toScalarQ,- FunCodeV(..), vectorMapR, vectorMapC, vectorMapF, vectorMapQ,- FunCodeSV(..), vectorMapValR, vectorMapValC, vectorMapValF, vectorMapValQ,- FunCodeVV(..), vectorZipR, vectorZipC, vectorZipF, vectorZipQ,- RandDist(..), randomVector-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Data.Packed.Internal.Vector--import Data.Complex-import Foreign.Marshal.Alloc(free)-import Foreign.Marshal.Array(newArray)-import Foreign.Ptr(Ptr)-import Foreign.C.Types-import System.IO.Unsafe(unsafePerformIO)--fromei x = fromIntegral (fromEnum x) :: CInt--data FunCodeV = Sin- | Cos- | Tan- | Abs- | ASin- | ACos- | ATan- | Sinh- | Cosh- | Tanh- | ASinh- | ACosh- | ATanh- | Exp- | Log- | Sign- | Sqrt- deriving Enum--data FunCodeSV = Scale- | Recip- | AddConstant- | Negate- | PowSV- | PowVS- deriving Enum--data FunCodeVV = Add- | Sub- | Mul- | Div- | Pow- | ATan2- deriving Enum--data FunCodeS = Norm2- | AbsSum- | MaxIdx- | Max- | MinIdx- | Min- deriving Enum------------------------------------------------------------------------ | sum of elements-sumF :: Vector Float -> Float-sumF x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumF vec x vec r "sumF"- return $ r @> 0---- | sum of elements-sumR :: Vector Double -> Double-sumR x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumR vec x vec r "sumR"- return $ r @> 0---- | sum of elements-sumQ :: Vector (Complex Float) -> Complex Float-sumQ x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumQ vec x vec r "sumQ"- return $ r @> 0---- | sum of elements-sumC :: Vector (Complex Double) -> Complex Double-sumC x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumC vec x vec r "sumC"- return $ r @> 0--foreign import ccall unsafe "gsl-aux.h sumF" c_sumF :: TFF-foreign import ccall unsafe "gsl-aux.h sumR" c_sumR :: TVV-foreign import ccall unsafe "gsl-aux.h sumQ" c_sumQ :: TQVQV-foreign import ccall unsafe "gsl-aux.h sumC" c_sumC :: TCVCV---- | product of elements-prodF :: Vector Float -> Float-prodF x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodF vec x vec r "prodF"- return $ r @> 0---- | product of elements-prodR :: Vector Double -> Double-prodR x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodR vec x vec r "prodR"- return $ r @> 0---- | product of elements-prodQ :: Vector (Complex Float) -> Complex Float-prodQ x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodQ vec x vec r "prodQ"- return $ r @> 0---- | product of elements-prodC :: Vector (Complex Double) -> Complex Double-prodC x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodC vec x vec r "prodC"- return $ r @> 0--foreign import ccall unsafe "gsl-aux.h prodF" c_prodF :: TFF-foreign import ccall unsafe "gsl-aux.h prodR" c_prodR :: TVV-foreign import ccall unsafe "gsl-aux.h prodQ" c_prodQ :: TQVQV-foreign import ccall unsafe "gsl-aux.h prodC" c_prodC :: TCVCV---- | dot product-dotF :: Vector Float -> Vector Float -> Float-dotF x y = unsafePerformIO $ do- r <- createVector 1- app3 c_dotF vec x vec y vec r "dotF"- return $ r @> 0---- | dot product-dotR :: Vector Double -> Vector Double -> Double-dotR x y = unsafePerformIO $ do- r <- createVector 1- app3 c_dotR vec x vec y vec r "dotR"- return $ r @> 0---- | dot product-dotQ :: Vector (Complex Float) -> Vector (Complex Float) -> Complex Float-dotQ x y = unsafePerformIO $ do- r <- createVector 1- app3 c_dotQ vec x vec y vec r "dotQ"- return $ r @> 0---- | dot product-dotC :: Vector (Complex Double) -> Vector (Complex Double) -> Complex Double-dotC x y = unsafePerformIO $ do- r <- createVector 1- app3 c_dotC vec x vec y vec r "dotC"- return $ r @> 0--foreign import ccall unsafe "gsl-aux.h dotF" c_dotF :: TFFF-foreign import ccall unsafe "gsl-aux.h dotR" c_dotR :: TVVV-foreign import ccall unsafe "gsl-aux.h dotQ" c_dotQ :: TQVQVQV-foreign import ccall unsafe "gsl-aux.h dotC" c_dotC :: TCVCVCV----------------------------------------------------------------------toScalarAux fun code v = unsafePerformIO $ do- r <- createVector 1- app2 (fun (fromei code)) vec v vec r "toScalarAux"- return (r `at` 0)--vectorMapAux fun code v = unsafePerformIO $ do- r <- createVector (dim v)- app2 (fun (fromei code)) vec v vec r "vectorMapAux"- return r--vectorMapValAux fun code val v = unsafePerformIO $ do- r <- createVector (dim v)- pval <- newArray [val]- app2 (fun (fromei code) pval) vec v vec r "vectorMapValAux"- free pval- return r--vectorZipAux fun code u v = unsafePerformIO $ do- r <- createVector (dim u)- app3 (fun (fromei code)) vec u vec v vec r "vectorZipAux"- return r--------------------------------------------------------------------------- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.-toScalarR :: FunCodeS -> Vector Double -> Double-toScalarR oper = toScalarAux c_toScalarR (fromei oper)--foreign import ccall unsafe "gsl-aux.h toScalarR" c_toScalarR :: CInt -> TVV---- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.-toScalarF :: FunCodeS -> Vector Float -> Float-toScalarF oper = toScalarAux c_toScalarF (fromei oper)--foreign import ccall unsafe "gsl-aux.h toScalarF" c_toScalarF :: CInt -> TFF---- | obtains different functions of a vector: only norm1, norm2-toScalarC :: FunCodeS -> Vector (Complex Double) -> Double-toScalarC oper = toScalarAux c_toScalarC (fromei oper)--foreign import ccall unsafe "gsl-aux.h toScalarC" c_toScalarC :: CInt -> TCVV---- | obtains different functions of a vector: only norm1, norm2-toScalarQ :: FunCodeS -> Vector (Complex Float) -> Float-toScalarQ oper = toScalarAux c_toScalarQ (fromei oper)--foreign import ccall unsafe "gsl-aux.h toScalarQ" c_toScalarQ :: CInt -> TQVF------------------------------------------------------------------------ | map of real vectors with given function-vectorMapR :: FunCodeV -> Vector Double -> Vector Double-vectorMapR = vectorMapAux c_vectorMapR--foreign import ccall unsafe "gsl-aux.h mapR" c_vectorMapR :: CInt -> TVV---- | map of complex vectors with given function-vectorMapC :: FunCodeV -> Vector (Complex Double) -> Vector (Complex Double)-vectorMapC oper = vectorMapAux c_vectorMapC (fromei oper)--foreign import ccall unsafe "gsl-aux.h mapC" c_vectorMapC :: CInt -> TCVCV---- | map of real vectors with given function-vectorMapF :: FunCodeV -> Vector Float -> Vector Float-vectorMapF = vectorMapAux c_vectorMapF--foreign import ccall unsafe "gsl-aux.h mapF" c_vectorMapF :: CInt -> TFF---- | map of real vectors with given function-vectorMapQ :: FunCodeV -> Vector (Complex Float) -> Vector (Complex Float)-vectorMapQ = vectorMapAux c_vectorMapQ--foreign import ccall unsafe "gsl-aux.h mapQ" c_vectorMapQ :: CInt -> TQVQV------------------------------------------------------------------------- | map of real vectors with given function-vectorMapValR :: FunCodeSV -> Double -> Vector Double -> Vector Double-vectorMapValR oper = vectorMapValAux c_vectorMapValR (fromei oper)--foreign import ccall unsafe "gsl-aux.h mapValR" c_vectorMapValR :: CInt -> Ptr Double -> TVV---- | map of complex vectors with given function-vectorMapValC :: FunCodeSV -> Complex Double -> Vector (Complex Double) -> Vector (Complex Double)-vectorMapValC = vectorMapValAux c_vectorMapValC--foreign import ccall unsafe "gsl-aux.h mapValC" c_vectorMapValC :: CInt -> Ptr (Complex Double) -> TCVCV---- | map of real vectors with given function-vectorMapValF :: FunCodeSV -> Float -> Vector Float -> Vector Float-vectorMapValF oper = vectorMapValAux c_vectorMapValF (fromei oper)--foreign import ccall unsafe "gsl-aux.h mapValF" c_vectorMapValF :: CInt -> Ptr Float -> TFF---- | map of complex vectors with given function-vectorMapValQ :: FunCodeSV -> Complex Float -> Vector (Complex Float) -> Vector (Complex Float)-vectorMapValQ oper = vectorMapValAux c_vectorMapValQ (fromei oper)--foreign import ccall unsafe "gsl-aux.h mapValQ" c_vectorMapValQ :: CInt -> Ptr (Complex Float) -> TQVQV------------------------------------------------------------------------- | elementwise operation on real vectors-vectorZipR :: FunCodeVV -> Vector Double -> Vector Double -> Vector Double-vectorZipR = vectorZipAux c_vectorZipR--foreign import ccall unsafe "gsl-aux.h zipR" c_vectorZipR :: CInt -> TVVV---- | elementwise operation on complex vectors-vectorZipC :: FunCodeVV -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double)-vectorZipC = vectorZipAux c_vectorZipC--foreign import ccall unsafe "gsl-aux.h zipC" c_vectorZipC :: CInt -> TCVCVCV---- | elementwise operation on real vectors-vectorZipF :: FunCodeVV -> Vector Float -> Vector Float -> Vector Float-vectorZipF = vectorZipAux c_vectorZipF--foreign import ccall unsafe "gsl-aux.h zipF" c_vectorZipF :: CInt -> TFFF---- | elementwise operation on complex vectors-vectorZipQ :: FunCodeVV -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float)-vectorZipQ = vectorZipAux c_vectorZipQ--foreign import ccall unsafe "gsl-aux.h zipQ" c_vectorZipQ :: CInt -> TQVQVQV---------------------------------------------------------------------------data RandDist = Uniform -- ^ uniform distribution in [0,1)- | Gaussian -- ^ normal distribution with mean zero and standard deviation one- deriving Enum---- | Obtains a vector of pseudorandom elements from the the mt19937 generator in GSL, with a given seed. Use randomIO to get a random seed.-randomVector :: Int -- ^ seed- -> RandDist -- ^ distribution- -> Int -- ^ vector size- -> Vector Double-randomVector seed dist n = unsafePerformIO $ do- r <- createVector n- app1 (c_random_vector (fi seed) ((fi.fromEnum) dist)) vec r "randomVector"- return r--foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> TV
− lib/Numeric/GSL/gsl-aux.c
@@ -1,1336 +0,0 @@-#include <gsl/gsl_complex.h>--#define RVEC(A) int A##n, double*A##p-#define RMAT(A) int A##r, int A##c, double* A##p-#define KRVEC(A) int A##n, const double*A##p-#define KRMAT(A) int A##r, int A##c, const double* A##p--#define CVEC(A) int A##n, gsl_complex*A##p-#define CMAT(A) int A##r, int A##c, gsl_complex* A##p-#define KCVEC(A) int A##n, const gsl_complex*A##p-#define KCMAT(A) int A##r, int A##c, const gsl_complex* A##p--#define FVEC(A) int A##n, float*A##p-#define FMAT(A) int A##r, int A##c, float* A##p-#define KFVEC(A) int A##n, const float*A##p-#define KFMAT(A) int A##r, int A##c, const float* A##p--#define QVEC(A) int A##n, gsl_complex_float*A##p-#define QMAT(A) int A##r, int A##c, gsl_complex_float* A##p-#define KQVEC(A) int A##n, const gsl_complex_float*A##p-#define KQMAT(A) int A##r, int A##c, const gsl_complex_float* A##p--#include <gsl/gsl_blas.h>-#include <gsl/gsl_math.h>-#include <gsl/gsl_errno.h>-#include <gsl/gsl_fft_complex.h>-#include <gsl/gsl_integration.h>-#include <gsl/gsl_deriv.h>-#include <gsl/gsl_poly.h>-#include <gsl/gsl_multimin.h>-#include <gsl/gsl_multiroots.h>-#include <gsl/gsl_complex_math.h>-#include <gsl/gsl_rng.h>-#include <gsl/gsl_randist.h>-#include <gsl/gsl_multifit_nlin.h>-#include <string.h>-#include <stdio.h>--#define MACRO(B) do {B} while (0)-#define ERROR(CODE) MACRO(return CODE;)-#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})-#define OK return 0;--#define MIN(A,B) ((A)<(B)?(A):(B))-#define MAX(A,B) ((A)>(B)?(A):(B))--#ifdef DBG-#define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M);-#else-#define DEBUGMSG(M)-#endif--#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)--#ifdef DBG-#define DEBUGMAT(MSG,X) printf(MSG" = \n"); gsl_matrix_fprintf(stdout,X,"%f"); printf("\n");-#else-#define DEBUGMAT(MSG,X)-#endif--#ifdef DBG-#define DEBUGVEC(MSG,X) printf(MSG" = \n"); gsl_vector_fprintf(stdout,X,"%f"); printf("\n");-#else-#define DEBUGVEC(MSG,X)-#endif--#define DVVIEW(A) gsl_vector_view A = gsl_vector_view_array(A##p,A##n)-#define DMVIEW(A) gsl_matrix_view A = gsl_matrix_view_array(A##p,A##r,A##c)-#define CVVIEW(A) gsl_vector_complex_view A = gsl_vector_complex_view_array((double*)A##p,A##n)-#define CMVIEW(A) gsl_matrix_complex_view A = gsl_matrix_complex_view_array((double*)A##p,A##r,A##c)-#define KDVVIEW(A) gsl_vector_const_view A = gsl_vector_const_view_array(A##p,A##n)-#define KDMVIEW(A) gsl_matrix_const_view A = gsl_matrix_const_view_array(A##p,A##r,A##c)-#define KCVVIEW(A) gsl_vector_complex_const_view A = gsl_vector_complex_const_view_array((double*)A##p,A##n)-#define KCMVIEW(A) gsl_matrix_complex_const_view A = gsl_matrix_complex_const_view_array((double*)A##p,A##r,A##c)--#define FVVIEW(A) gsl_vector_float_view A = gsl_vector_float_view_array(A##p,A##n)-#define FMVIEW(A) gsl_matrix_float_view A = gsl_matrix_float_view_array(A##p,A##r,A##c)-#define QVVIEW(A) gsl_vector_complex_float_view A = gsl_vector_float_complex_view_array((float*)A##p,A##n)-#define QMVIEW(A) gsl_matrix_complex_float_view A = gsl_matrix_float_complex_view_array((float*)A##p,A##r,A##c)-#define KFVVIEW(A) gsl_vector_float_const_view A = gsl_vector_float_const_view_array(A##p,A##n)-#define KFMVIEW(A) gsl_matrix_float_const_view A = gsl_matrix_float_const_view_array(A##p,A##r,A##c)-#define KQVVIEW(A) gsl_vector_complex_float_const_view A = gsl_vector_complex_float_const_view_array((float*)A##p,A##n)-#define KQMVIEW(A) gsl_matrix_complex_float_const_view A = gsl_matrix_complex_float_const_view_array((float*)A##p,A##r,A##c)--#define V(a) (&a.vector)-#define M(a) (&a.matrix)--#define GCVEC(A) int A##n, gsl_complex*A##p-#define KGCVEC(A) int A##n, const gsl_complex*A##p--#define GQVEC(A) int A##n, gsl_complex_float*A##p-#define KGQVEC(A) int A##n, const gsl_complex_float*A##p--#define BAD_SIZE 2000-#define BAD_CODE 2001-#define MEM 2002-#define BAD_FILE 2003---void no_abort_on_error() {- gsl_set_error_handler_off();-}---int sumF(KFVEC(x),FVEC(r)) {- DEBUGMSG("sumF");- REQUIRES(rn==1,BAD_SIZE);- int i;- float res = 0;- for (i = 0; i < xn; i++) res += xp[i];- rp[0] = res;- OK-}- -int sumR(KRVEC(x),RVEC(r)) {- DEBUGMSG("sumR");- REQUIRES(rn==1,BAD_SIZE);- int i;- double res = 0;- for (i = 0; i < xn; i++) res += xp[i];- rp[0] = res;- OK-}- -int sumQ(KQVEC(x),QVEC(r)) {- DEBUGMSG("sumQ");- REQUIRES(rn==1,BAD_SIZE);- int i;- gsl_complex_float res;- res.dat[0] = 0;- res.dat[1] = 0;- for (i = 0; i < xn; i++) {- res.dat[0] += xp[i].dat[0];- res.dat[1] += xp[i].dat[1];- }- rp[0] = res;- OK-}- -int sumC(KCVEC(x),CVEC(r)) {- DEBUGMSG("sumC");- REQUIRES(rn==1,BAD_SIZE);- int i;- gsl_complex res;- res.dat[0] = 0;- res.dat[1] = 0;- for (i = 0; i < xn; i++) {- res.dat[0] += xp[i].dat[0];- res.dat[1] += xp[i].dat[1];- }- rp[0] = res;- OK-}--int prodF(KFVEC(x),FVEC(r)) {- DEBUGMSG("prodF");- REQUIRES(rn==1,BAD_SIZE);- int i;- float res = 1;- for (i = 0; i < xn; i++) res *= xp[i];- rp[0] = res;- OK-}- -int prodR(KRVEC(x),RVEC(r)) {- DEBUGMSG("prodR");- REQUIRES(rn==1,BAD_SIZE);- int i;- double res = 1;- for (i = 0; i < xn; i++) res *= xp[i];- rp[0] = res;- OK-}- -int prodQ(KQVEC(x),QVEC(r)) {- DEBUGMSG("prodQ");- REQUIRES(rn==1,BAD_SIZE);- int i;- gsl_complex_float res;- float temp;- res.dat[0] = 1;- res.dat[1] = 0;- for (i = 0; i < xn; i++) {- temp = res.dat[0] * xp[i].dat[0] - res.dat[1] * xp[i].dat[1];- res.dat[1] = res.dat[0] * xp[i].dat[1] + res.dat[1] * xp[i].dat[0];- res.dat[0] = temp;- }- rp[0] = res;- OK-}- -int prodC(KCVEC(x),CVEC(r)) {- DEBUGMSG("prodC");- REQUIRES(rn==1,BAD_SIZE);- int i;- gsl_complex res;- double temp;- res.dat[0] = 1;- res.dat[1] = 0;- for (i = 0; i < xn; i++) {- temp = res.dat[0] * xp[i].dat[0] - res.dat[1] * xp[i].dat[1];- res.dat[1] = res.dat[0] * xp[i].dat[1] + res.dat[1] * xp[i].dat[0];- res.dat[0] = temp;- }- rp[0] = res;- OK-}--int dotF(KFVEC(x), KFVEC(y), FVEC(r)) {- DEBUGMSG("dotF");- REQUIRES(xn==yn,BAD_SIZE); - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("dotF");- KFVVIEW(x);- KFVVIEW(y);- gsl_blas_sdot(V(x),V(y),rp);- OK-}- -int dotR(KRVEC(x), KRVEC(y), RVEC(r)) {- DEBUGMSG("dotR");- REQUIRES(xn==yn,BAD_SIZE); - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("dotR");- KDVVIEW(x);- KDVVIEW(y);- gsl_blas_ddot(V(x),V(y),rp);- OK-}- -int dotQ(KQVEC(x), KQVEC(y), QVEC(r)) {- DEBUGMSG("dotQ");- REQUIRES(xn==yn,BAD_SIZE); - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("dotQ");- KQVVIEW(x);- KQVVIEW(y);- gsl_blas_cdotu(V(x),V(y),rp);- OK-}- -int dotC(KCVEC(x), KCVEC(y), CVEC(r)) {- DEBUGMSG("dotC");- REQUIRES(xn==yn,BAD_SIZE); - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("dotC");- KCVVIEW(x);- KCVVIEW(y);- gsl_blas_zdotu(V(x),V(y),rp);- OK-}- -int toScalarR(int code, KRVEC(x), RVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarR");- KDVVIEW(x);- double res;- switch(code) {- case 0: { res = gsl_blas_dnrm2(V(x)); break; } - case 1: { res = gsl_blas_dasum(V(x)); break; }- case 2: { res = gsl_vector_max_index(V(x)); break; }- case 3: { res = gsl_vector_max(V(x)); break; }- case 4: { res = gsl_vector_min_index(V(x)); break; }- case 5: { res = gsl_vector_min(V(x)); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}--int toScalarF(int code, KFVEC(x), FVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarF");- KFVVIEW(x);- float res;- switch(code) {- case 0: { res = gsl_blas_snrm2(V(x)); break; } - case 1: { res = gsl_blas_sasum(V(x)); break; }- case 2: { res = gsl_vector_float_max_index(V(x)); break; }- case 3: { res = gsl_vector_float_max(V(x)); break; }- case 4: { res = gsl_vector_float_min_index(V(x)); break; }- case 5: { res = gsl_vector_float_min(V(x)); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}---int toScalarC(int code, KCVEC(x), RVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarC");- KCVVIEW(x);- double res;- switch(code) {- case 0: { res = gsl_blas_dznrm2(V(x)); break; } - case 1: { res = gsl_blas_dzasum(V(x)); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}--int toScalarQ(int code, KQVEC(x), FVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarQ");- KQVVIEW(x);- float res;- switch(code) {- case 0: { res = gsl_blas_scnrm2(V(x)); break; } - case 1: { res = gsl_blas_scasum(V(x)); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}---inline double sign(double x) {- if(x>0) {- return +1.0;- } else if (x<0) {- return -1.0;- } else {- return 0.0;- }-}--inline float float_sign(float x) {- if(x>0) {- return +1.0;- } else if (x<0) {- return -1.0;- } else {- return 0.0;- }-}--inline gsl_complex complex_abs(gsl_complex z) {- gsl_complex r;- r.dat[0] = gsl_complex_abs(z);- r.dat[1] = 0;- return r;-}--inline gsl_complex complex_signum(gsl_complex z) {- gsl_complex r;- double mag;- if (z.dat[0] == 0 && z.dat[1] == 0) {- r.dat[0] = 0;- r.dat[1] = 0;- } else {- mag = gsl_complex_abs(z);- r.dat[0] = z.dat[0]/mag;- r.dat[1] = z.dat[1]/mag;- }- return r;-}--#define OP(C,F) case C: { for(k=0;k<xn;k++) rp[k] = F(xp[k]); OK }-#define OPV(C,E) case C: { for(k=0;k<xn;k++) rp[k] = E; OK }-int mapR(int code, KRVEC(x), RVEC(r)) {- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapR");- switch (code) {- OP(0,sin)- OP(1,cos)- OP(2,tan)- OP(3,fabs)- OP(4,asin)- OP(5,acos)- OP(6,atan) /* atan2 mediante vectorZip */- OP(7,sinh)- OP(8,cosh)- OP(9,tanh)- OP(10,gsl_asinh)- OP(11,gsl_acosh)- OP(12,gsl_atanh)- OP(13,exp)- OP(14,log)- OP(15,sign)- OP(16,sqrt)- default: ERROR(BAD_CODE);- }-}--int mapF(int code, KFVEC(x), FVEC(r)) {- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapF");- switch (code) {- OP(0,sin)- OP(1,cos)- OP(2,tan)- OP(3,fabs)- OP(4,asin)- OP(5,acos)- OP(6,atan) /* atan2 mediante vectorZip */- OP(7,sinh)- OP(8,cosh)- OP(9,tanh)- OP(10,gsl_asinh)- OP(11,gsl_acosh)- OP(12,gsl_atanh)- OP(13,exp)- OP(14,log)- OP(15,sign)- OP(16,sqrt)- default: ERROR(BAD_CODE);- }-}---int mapCAux(int code, KGCVEC(x), GCVEC(r)) {- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapC");- switch (code) {- OP(0,gsl_complex_sin)- OP(1,gsl_complex_cos)- OP(2,gsl_complex_tan)- OP(3,complex_abs)- OP(4,gsl_complex_arcsin)- OP(5,gsl_complex_arccos)- OP(6,gsl_complex_arctan)- OP(7,gsl_complex_sinh)- OP(8,gsl_complex_cosh)- OP(9,gsl_complex_tanh)- OP(10,gsl_complex_arcsinh)- OP(11,gsl_complex_arccosh)- OP(12,gsl_complex_arctanh)- OP(13,gsl_complex_exp)- OP(14,gsl_complex_log)- OP(15,complex_signum)- OP(16,gsl_complex_sqrt)-- // gsl_complex_arg- // gsl_complex_abs- default: ERROR(BAD_CODE);- }-}--int mapC(int code, KCVEC(x), CVEC(r)) {- return mapCAux(code, xn, (gsl_complex*)xp, rn, (gsl_complex*)rp);-}---gsl_complex_float complex_float_math_fun(gsl_complex (*cf)(gsl_complex), gsl_complex_float a)-{- gsl_complex c;- gsl_complex r;-- gsl_complex_float float_r;-- c.dat[0] = a.dat[0];- c.dat[1] = a.dat[1];-- r = (*cf)(c);-- float_r.dat[0] = r.dat[0];- float_r.dat[1] = r.dat[1];-- return float_r;-}--gsl_complex_float complex_float_math_op(gsl_complex (*cf)(gsl_complex,gsl_complex), - gsl_complex_float a,gsl_complex_float b)-{- gsl_complex c1;- gsl_complex c2;- gsl_complex r;-- gsl_complex_float float_r;-- c1.dat[0] = a.dat[0];- c1.dat[1] = a.dat[1];-- c2.dat[0] = b.dat[0];- c2.dat[1] = b.dat[1];-- r = (*cf)(c1,c2);-- float_r.dat[0] = r.dat[0];- float_r.dat[1] = r.dat[1];-- return float_r;-}--#define OPC(C,F) case C: { for(k=0;k<xn;k++) rp[k] = complex_float_math_fun(&F,xp[k]); OK }-#define OPCA(C,F,A,B) case C: { for(k=0;k<xn;k++) rp[k] = complex_float_math_op(&F,A,B); OK }-int mapQAux(int code, KGQVEC(x), GQVEC(r)) {- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapQ");- switch (code) {- OPC(0,gsl_complex_sin)- OPC(1,gsl_complex_cos)- OPC(2,gsl_complex_tan)- OPC(3,complex_abs)- OPC(4,gsl_complex_arcsin)- OPC(5,gsl_complex_arccos)- OPC(6,gsl_complex_arctan)- OPC(7,gsl_complex_sinh)- OPC(8,gsl_complex_cosh)- OPC(9,gsl_complex_tanh)- OPC(10,gsl_complex_arcsinh)- OPC(11,gsl_complex_arccosh)- OPC(12,gsl_complex_arctanh)- OPC(13,gsl_complex_exp)- OPC(14,gsl_complex_log)- OPC(15,complex_signum)- OPC(16,gsl_complex_sqrt)-- // gsl_complex_arg- // gsl_complex_abs- default: ERROR(BAD_CODE);- }-}--int mapQ(int code, KQVEC(x), QVEC(r)) {- return mapQAux(code, xn, (gsl_complex_float*)xp, rn, (gsl_complex_float*)rp);-}---int mapValR(int code, double* pval, KRVEC(x), RVEC(r)) {- int k;- double val = *pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValR");- switch (code) {- OPV(0,val*xp[k])- OPV(1,val/xp[k])- OPV(2,val+xp[k])- OPV(3,val-xp[k])- OPV(4,pow(val,xp[k]))- OPV(5,pow(xp[k],val))- default: ERROR(BAD_CODE);- }-}--int mapValF(int code, float* pval, KFVEC(x), FVEC(r)) {- int k;- float val = *pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValF");- switch (code) {- OPV(0,val*xp[k])- OPV(1,val/xp[k])- OPV(2,val+xp[k])- OPV(3,val-xp[k])- OPV(4,pow(val,xp[k]))- OPV(5,pow(xp[k],val))- default: ERROR(BAD_CODE);- }-}--int mapValCAux(int code, gsl_complex* pval, KGCVEC(x), GCVEC(r)) {- int k;- gsl_complex val = *pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValC");- switch (code) {- OPV(0,gsl_complex_mul(val,xp[k]))- OPV(1,gsl_complex_div(val,xp[k]))- OPV(2,gsl_complex_add(val,xp[k]))- OPV(3,gsl_complex_sub(val,xp[k]))- OPV(4,gsl_complex_pow(val,xp[k]))- OPV(5,gsl_complex_pow(xp[k],val))- default: ERROR(BAD_CODE);- }-}--int mapValC(int code, gsl_complex* val, KCVEC(x), CVEC(r)) {- return mapValCAux(code, val, xn, (gsl_complex*)xp, rn, (gsl_complex*)rp);-}---int mapValQAux(int code, gsl_complex_float* pval, KQVEC(x), GQVEC(r)) {- int k;- gsl_complex_float val = *pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValQ");- switch (code) {- OPCA(0,gsl_complex_mul,val,xp[k])- OPCA(1,gsl_complex_div,val,xp[k])- OPCA(2,gsl_complex_add,val,xp[k])- OPCA(3,gsl_complex_sub,val,xp[k])- OPCA(4,gsl_complex_pow,val,xp[k])- OPCA(5,gsl_complex_pow,xp[k],val)- default: ERROR(BAD_CODE);- }-}--int mapValQ(int code, gsl_complex_float* val, KQVEC(x), QVEC(r)) {- return mapValQAux(code, val, xn, (gsl_complex_float*)xp, rn, (gsl_complex_float*)rp);-}---#define OPZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = E(ap[k],bp[k]); OK }-#define OPZV(C,msg,E) case C: {DEBUGMSG(msg) res = E(V(r),V(b)); CHECK(res,res); OK }-int zipR(int code, KRVEC(a), KRVEC(b), RVEC(r)) {- REQUIRES(an == bn && an == rn, BAD_SIZE);- int k;- switch(code) {- OPZE(4,"zipR Pow",pow)- OPZE(5,"zipR ATan2",atan2)- }- KDVVIEW(a);- KDVVIEW(b);- DVVIEW(r);- gsl_vector_memcpy(V(r),V(a));- int res;- switch(code) {- OPZV(0,"zipR Add",gsl_vector_add)- OPZV(1,"zipR Sub",gsl_vector_sub)- OPZV(2,"zipR Mul",gsl_vector_mul)- OPZV(3,"zipR Div",gsl_vector_div)- default: ERROR(BAD_CODE);- }-}---int zipF(int code, KFVEC(a), KFVEC(b), FVEC(r)) {- REQUIRES(an == bn && an == rn, BAD_SIZE);- int k;- switch(code) {- OPZE(4,"zipF Pow",pow)- OPZE(5,"zipF ATan2",atan2)- }- KFVVIEW(a);- KFVVIEW(b);- FVVIEW(r);- gsl_vector_float_memcpy(V(r),V(a));- int res;- switch(code) {- OPZV(0,"zipF Add",gsl_vector_float_add)- OPZV(1,"zipF Sub",gsl_vector_float_sub)- OPZV(2,"zipF Mul",gsl_vector_float_mul)- OPZV(3,"zipF Div",gsl_vector_float_div)- default: ERROR(BAD_CODE);- }-}---int zipCAux(int code, KGCVEC(a), KGCVEC(b), GCVEC(r)) {- REQUIRES(an == bn && an == rn, BAD_SIZE);- int k;- switch(code) {- OPZE(0,"zipC Add",gsl_complex_add)- OPZE(1,"zipC Sub",gsl_complex_sub)- OPZE(2,"zipC Mul",gsl_complex_mul)- OPZE(3,"zipC Div",gsl_complex_div)- OPZE(4,"zipC Pow",gsl_complex_pow)- //OPZE(5,"zipR ATan2",atan2)- }- //KCVVIEW(a);- //KCVVIEW(b);- //CVVIEW(r);- //gsl_vector_memcpy(V(r),V(a));- //int res;- switch(code) {- default: ERROR(BAD_CODE);- }-}---int zipC(int code, KCVEC(a), KCVEC(b), CVEC(r)) {- return zipCAux(code, an, (gsl_complex*)ap, bn, (gsl_complex*)bp, rn, (gsl_complex*)rp);-}---#define OPCZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = complex_float_math_op(&E,ap[k],bp[k]); OK }-int zipQAux(int code, KGQVEC(a), KGQVEC(b), GQVEC(r)) {- REQUIRES(an == bn && an == rn, BAD_SIZE);- int k;- switch(code) {- OPCZE(0,"zipQ Add",gsl_complex_add)- OPCZE(1,"zipQ Sub",gsl_complex_sub)- OPCZE(2,"zipQ Mul",gsl_complex_mul)- OPCZE(3,"zipQ Div",gsl_complex_div)- OPCZE(4,"zipQ Pow",gsl_complex_pow)- //OPZE(5,"zipR ATan2",atan2)- }- //KCVVIEW(a);- //KCVVIEW(b);- //CVVIEW(r);- //gsl_vector_memcpy(V(r),V(a));- //int res;- switch(code) {- default: ERROR(BAD_CODE);- }-}---int zipQ(int code, KQVEC(a), KQVEC(b), QVEC(r)) {- return zipQAux(code, an, (gsl_complex_float*)ap, bn, (gsl_complex_float*)bp, rn, (gsl_complex_float*)rp);-}----int fft(int code, KCVEC(X), CVEC(R)) {- REQUIRES(Xn == Rn,BAD_SIZE);- DEBUGMSG("fft");- int s = Xn;- gsl_fft_complex_wavetable * wavetable = gsl_fft_complex_wavetable_alloc (s);- gsl_fft_complex_workspace * workspace = gsl_fft_complex_workspace_alloc (s);- gsl_vector_const_view X = gsl_vector_const_view_array((double*)Xp, 2*Xn);- gsl_vector_view R = gsl_vector_view_array((double*)Rp, 2*Rn);- gsl_blas_dcopy(&X.vector,&R.vector);- if(code==0) {- gsl_fft_complex_forward ((double*)Rp, 1, s, wavetable, workspace);- } else {- gsl_fft_complex_inverse ((double*)Rp, 1, s, wavetable, workspace);- }- gsl_fft_complex_wavetable_free (wavetable);- gsl_fft_complex_workspace_free (workspace);- OK-}---int deriv(int code, double f(double, void*), double x, double h, double * result, double * abserr)-{- gsl_function F;- F.function = f;- F.params = 0;-- if(code==0) return gsl_deriv_central (&F, x, h, result, abserr);-- if(code==1) return gsl_deriv_forward (&F, x, h, result, abserr);-- if(code==2) return gsl_deriv_backward (&F, x, h, result, abserr);-- return 0;-}---int integrate_qng(double f(double, void*), double a, double b, double prec,- double *result, double*error) {- DEBUGMSG("integrate_qng");- gsl_function F;- F.function = f;- F.params = NULL;- size_t neval;- int res = gsl_integration_qng (&F, a,b, 0, prec, result, error, &neval); - CHECK(res,res);- OK-}--int integrate_qags(double f(double,void*), double a, double b, double prec, int w, - double *result, double* error) {- DEBUGMSG("integrate_qags");- gsl_integration_workspace * wk = gsl_integration_workspace_alloc (w);- gsl_function F;- F.function = f;- F.params = NULL;- int res = gsl_integration_qags (&F, a,b, 0, prec, w,wk, result, error); - CHECK(res,res);- gsl_integration_workspace_free (wk); - OK-}--int integrate_qagi(double f(double,void*), double prec, int w, - double *result, double* error) {- DEBUGMSG("integrate_qagi");- gsl_integration_workspace * wk = gsl_integration_workspace_alloc (w);- gsl_function F;- F.function = f;- F.params = NULL;- int res = gsl_integration_qagi (&F, 0, prec, w,wk, result, error); - CHECK(res,res);- gsl_integration_workspace_free (wk); - OK-}---int integrate_qagiu(double f(double,void*), double a, double prec, int w, - double *result, double* error) {- DEBUGMSG("integrate_qagiu");- gsl_integration_workspace * wk = gsl_integration_workspace_alloc (w);- gsl_function F;- F.function = f;- F.params = NULL;- int res = gsl_integration_qagiu (&F, a, 0, prec, w,wk, result, error); - CHECK(res,res);- gsl_integration_workspace_free (wk); - OK-}---int integrate_qagil(double f(double,void*), double b, double prec, int w, - double *result, double* error) {- DEBUGMSG("integrate_qagil");- gsl_integration_workspace * wk = gsl_integration_workspace_alloc (w);- gsl_function F;- F.function = f;- F.params = NULL;- int res = gsl_integration_qagil (&F, b, 0, prec, w,wk, result, error); - CHECK(res,res);- gsl_integration_workspace_free (wk); - OK-}---int polySolve(KRVEC(a), CVEC(z)) {- DEBUGMSG("polySolve");- REQUIRES(an>1,BAD_SIZE);- gsl_poly_complex_workspace * w = gsl_poly_complex_workspace_alloc (an);- int res = gsl_poly_complex_solve ((double*)ap, an, w, (double*)zp);- CHECK(res,res);- gsl_poly_complex_workspace_free (w);- OK;-}--int vector_fscanf(char*filename, RVEC(a)) {- DEBUGMSG("gsl_vector_fscanf");- DVVIEW(a);- FILE * f = fopen(filename,"r");- CHECK(!f,BAD_FILE);- int res = gsl_vector_fscanf(f,V(a));- CHECK(res,res);- fclose (f);- OK-}--int vector_fprintf(char*filename, char*fmt, RVEC(a)) {- DEBUGMSG("gsl_vector_fprintf");- DVVIEW(a);- FILE * f = fopen(filename,"w");- CHECK(!f,BAD_FILE);- int res = gsl_vector_fprintf(f,V(a),fmt);- CHECK(res,res);- fclose (f);- OK-}--int vector_fread(char*filename, RVEC(a)) {- DEBUGMSG("gsl_vector_fread");- DVVIEW(a);- FILE * f = fopen(filename,"r");- CHECK(!f,BAD_FILE);- int res = gsl_vector_fread(f,V(a));- CHECK(res,res);- fclose (f);- OK-}--int vector_fwrite(char*filename, RVEC(a)) {- DEBUGMSG("gsl_vector_fwrite");- DVVIEW(a);- FILE * f = fopen(filename,"w");- CHECK(!f,BAD_FILE);- int res = gsl_vector_fwrite(f,V(a));- CHECK(res,res);- fclose (f);- OK-}--int matrix_fprintf(char*filename, char*fmt, int ro, RMAT(m)) {- DEBUGMSG("matrix_fprintf");- FILE * f = fopen(filename,"w");- CHECK(!f,BAD_FILE);- int i,j,sr,sc;- if (ro==1) { sr = mc; sc = 1;} else { sr = 1; sc = mr;}- #define AT(M,r,c) (M##p[(r)*sr+(c)*sc])- for (i=0; i<mr; i++) {- for (j=0; j<mc-1; j++) {- fprintf(f,fmt,AT(m,i,j));- fprintf(f," ");- }- fprintf(f,fmt,AT(m,i,j));- fprintf(f,"\n");- }- fclose (f);- OK-}--//-----------------------------------------------------------------typedef double Trawfun(int, double*);--double only_f_aux_min(const gsl_vector*x, void *pars) {- Trawfun * f = (Trawfun*) pars; - double* p = (double*)calloc(x->size,sizeof(double));- int k;- for(k=0;k<x->size;k++) {- p[k] = gsl_vector_get(x,k);- } - double res = f(x->size,p);- free(p);- return res;-}--// this version returns info about intermediate steps-int minimize(int method, double f(int, double*), double tolsize, int maxit, - KRVEC(xi), KRVEC(sz), RMAT(sol)) {- REQUIRES(xin==szn && solr == maxit && solc == 3+xin,BAD_SIZE);- DEBUGMSG("minimizeList (nmsimplex)");- gsl_multimin_function my_func;- // extract function from pars- my_func.f = only_f_aux_min;- my_func.n = xin; - my_func.params = f;- size_t iter = 0;- int status;- double size;- const gsl_multimin_fminimizer_type *T;- gsl_multimin_fminimizer *s = NULL;- // Initial vertex size vector - KDVVIEW(sz);- // Starting point- KDVVIEW(xi);- // Minimizer nmsimplex, without derivatives- switch(method) {- case 0 : {T = gsl_multimin_fminimizer_nmsimplex; break; }-#ifdef GSL110- case 1 : {T = gsl_multimin_fminimizer_nmsimplex; break; }-#else- case 1 : {T = gsl_multimin_fminimizer_nmsimplex2; break; }-#endif- default: ERROR(BAD_CODE);- }- s = gsl_multimin_fminimizer_alloc (T, my_func.n);- gsl_multimin_fminimizer_set (s, &my_func, V(xi), V(sz));- do {- status = gsl_multimin_fminimizer_iterate (s);- size = gsl_multimin_fminimizer_size (s);-- solp[iter*solc+0] = iter+1;- solp[iter*solc+1] = s->fval;- solp[iter*solc+2] = size;-- int k;- for(k=0;k<xin;k++) {- solp[iter*solc+k+3] = gsl_vector_get(s->x,k);- }- iter++;- if (status) break;- status = gsl_multimin_test_size (size, tolsize);- } while (status == GSL_CONTINUE && iter <= maxit);- int i,j;- for (i=iter; i<solr; i++) {- solp[i*solc+0] = iter;- for(j=1;j<solc;j++) {- solp[i*solc+j]=0.;- }- }- gsl_multimin_fminimizer_free(s);- OK-}--// working with the gradient--typedef struct {double (*f)(int, double*); int (*df)(int, double*, int, double*);} Tfdf;--double f_aux_min(const gsl_vector*x, void *pars) {- Tfdf * fdf = ((Tfdf*) pars);- double* p = (double*)calloc(x->size,sizeof(double));- int k;- for(k=0;k<x->size;k++) {- p[k] = gsl_vector_get(x,k);- }- double res = fdf->f(x->size,p);- free(p);- return res;-}---void df_aux_min(const gsl_vector * x, void * pars, gsl_vector * g) {- Tfdf * fdf = ((Tfdf*) pars);- double* p = (double*)calloc(x->size,sizeof(double));- double* q = (double*)calloc(g->size,sizeof(double));- int k;- for(k=0;k<x->size;k++) {- p[k] = gsl_vector_get(x,k);- }-- fdf->df(x->size,p,g->size,q);-- for(k=0;k<x->size;k++) {- gsl_vector_set(g,k,q[k]);- }- free(p);- free(q);-}--void fdf_aux_min(const gsl_vector * x, void * pars, double * f, gsl_vector * g) {- *f = f_aux_min(x,pars);- df_aux_min(x,pars,g);-}---int minimizeD(int method, double f(int, double*), int df(int, double*, int, double*),- double initstep, double minimpar, double tolgrad, int maxit, - KRVEC(xi), RMAT(sol)) {- REQUIRES(solr == maxit && solc == 2+xin,BAD_SIZE);- DEBUGMSG("minimizeWithDeriv (conjugate_fr)");- gsl_multimin_function_fdf my_func;- // extract function from pars- my_func.f = f_aux_min;- my_func.df = df_aux_min;- my_func.fdf = fdf_aux_min;- my_func.n = xin; - Tfdf stfdf;- stfdf.f = f;- stfdf.df = df;- my_func.params = &stfdf;- size_t iter = 0;- int status;- const gsl_multimin_fdfminimizer_type *T;- gsl_multimin_fdfminimizer *s = NULL;- // Starting point- KDVVIEW(xi);- // conjugate gradient fr- switch(method) {- case 0 : {T = gsl_multimin_fdfminimizer_conjugate_fr; break; }- case 1 : {T = gsl_multimin_fdfminimizer_conjugate_pr; break; }- case 2 : {T = gsl_multimin_fdfminimizer_vector_bfgs; break; }- case 3 : {T = gsl_multimin_fdfminimizer_vector_bfgs2; break; }- case 4 : {T = gsl_multimin_fdfminimizer_steepest_descent; break; }- default: ERROR(BAD_CODE);- }- s = gsl_multimin_fdfminimizer_alloc (T, my_func.n);- gsl_multimin_fdfminimizer_set (s, &my_func, V(xi), initstep, minimpar);- do {- status = gsl_multimin_fdfminimizer_iterate (s);- solp[iter*solc+0] = iter+1;- solp[iter*solc+1] = s->f;- int k;- for(k=0;k<xin;k++) {- solp[iter*solc+k+2] = gsl_vector_get(s->x,k);- }- iter++;- if (status) break;- status = gsl_multimin_test_gradient (s->gradient, tolgrad);- } while (status == GSL_CONTINUE && iter <= maxit);- int i,j;- for (i=iter; i<solr; i++) {- solp[i*solc+0] = iter;- for(j=1;j<solc;j++) {- solp[i*solc+j]=0.;- }- }- gsl_multimin_fdfminimizer_free(s);- OK-}--//-----------------------------------------------------------------typedef void TrawfunV(int, double*, int, double*);--int only_f_aux_root(const gsl_vector*x, void *pars, gsl_vector*y) {- TrawfunV * f = (TrawfunV*) pars;- double* p = (double*)calloc(x->size,sizeof(double));- double* q = (double*)calloc(y->size,sizeof(double));- int k;- for(k=0;k<x->size;k++) {- p[k] = gsl_vector_get(x,k);- }- f(x->size,p,y->size,q);- for(k=0;k<y->size;k++) {- gsl_vector_set(y,k,q[k]);- }- free(p);- free(q);- return 0; //hmmm-}--int root(int method, void f(int, double*, int, double*),- double epsabs, int maxit,- KRVEC(xi), RMAT(sol)) {- REQUIRES(solr == maxit && solc == 1+2*xin,BAD_SIZE);- DEBUGMSG("root_only_f");- gsl_multiroot_function my_func;- // extract function from pars- my_func.f = only_f_aux_root;- my_func.n = xin;- my_func.params = f;- size_t iter = 0;- int status;- const gsl_multiroot_fsolver_type *T;- gsl_multiroot_fsolver *s;- // Starting point- KDVVIEW(xi);- switch(method) {- case 0 : {T = gsl_multiroot_fsolver_hybrids;; break; }- case 1 : {T = gsl_multiroot_fsolver_hybrid; break; }- case 2 : {T = gsl_multiroot_fsolver_dnewton; break; }- case 3 : {T = gsl_multiroot_fsolver_broyden; break; }- default: ERROR(BAD_CODE);- }- s = gsl_multiroot_fsolver_alloc (T, my_func.n);- gsl_multiroot_fsolver_set (s, &my_func, V(xi));-- do {- status = gsl_multiroot_fsolver_iterate (s);-- solp[iter*solc+0] = iter+1;-- int k;- for(k=0;k<xin;k++) {- solp[iter*solc+k+1] = gsl_vector_get(s->x,k);- }- for(k=xin;k<2*xin;k++) {- solp[iter*solc+k+1] = gsl_vector_get(s->f,k-xin);- }-- iter++;- if (status) /* check if solver is stuck */- break;-- status =- gsl_multiroot_test_residual (s->f, epsabs);- }- while (status == GSL_CONTINUE && iter <= maxit);-- int i,j;- for (i=iter; i<solr; i++) {- solp[i*solc+0] = iter;- for(j=1;j<solc;j++) {- solp[i*solc+j]=0.;- }- }- gsl_multiroot_fsolver_free(s);- OK-}--// working with the jacobian--typedef struct {int (*f)(int, double*, int, double *);- int (*jf)(int, double*, int, int, double*);} Tfjf;--int f_aux(const gsl_vector*x, void *pars, gsl_vector*y) {- Tfjf * fjf = ((Tfjf*) pars);- double* p = (double*)calloc(x->size,sizeof(double));- double* q = (double*)calloc(y->size,sizeof(double));- int k;- for(k=0;k<x->size;k++) {- p[k] = gsl_vector_get(x,k);- }- (fjf->f)(x->size,p,y->size,q);- for(k=0;k<y->size;k++) {- gsl_vector_set(y,k,q[k]);- }- free(p);- free(q);- return 0;-}--int jf_aux(const gsl_vector * x, void * pars, gsl_matrix * jac) {- Tfjf * fjf = ((Tfjf*) pars);- double* p = (double*)calloc(x->size,sizeof(double));- double* q = (double*)calloc((jac->size1)*(jac->size2),sizeof(double));- int i,j,k;- for(k=0;k<x->size;k++) {- p[k] = gsl_vector_get(x,k);- }-- (fjf->jf)(x->size,p,jac->size1,jac->size2,q);-- k=0;- for(i=0;i<jac->size1;i++) {- for(j=0;j<jac->size2;j++){- gsl_matrix_set(jac,i,j,q[k++]);- }- }- free(p);- free(q);- return 0;-}--int fjf_aux(const gsl_vector * x, void * pars, gsl_vector * f, gsl_matrix * g) {- f_aux(x,pars,f);- jf_aux(x,pars,g);- return 0;-}--int rootj(int method, int f(int, double*, int, double*),- int jac(int, double*, int, int, double*),- double epsabs, int maxit,- KRVEC(xi), RMAT(sol)) {- REQUIRES(solr == maxit && solc == 1+2*xin,BAD_SIZE);- DEBUGMSG("root_fjf");- gsl_multiroot_function_fdf my_func;- // extract function from pars- my_func.f = f_aux;- my_func.df = jf_aux;- my_func.fdf = fjf_aux;- my_func.n = xin;- Tfjf stfjf;- stfjf.f = f;- stfjf.jf = jac;- my_func.params = &stfjf;- size_t iter = 0;- int status;- const gsl_multiroot_fdfsolver_type *T;- gsl_multiroot_fdfsolver *s;- // Starting point- KDVVIEW(xi);- switch(method) {- case 0 : {T = gsl_multiroot_fdfsolver_hybridsj;; break; }- case 1 : {T = gsl_multiroot_fdfsolver_hybridj; break; }- case 2 : {T = gsl_multiroot_fdfsolver_newton; break; }- case 3 : {T = gsl_multiroot_fdfsolver_gnewton; break; }- default: ERROR(BAD_CODE);- }- s = gsl_multiroot_fdfsolver_alloc (T, my_func.n);-- gsl_multiroot_fdfsolver_set (s, &my_func, V(xi));-- do {- status = gsl_multiroot_fdfsolver_iterate (s);-- solp[iter*solc+0] = iter+1;-- int k;- for(k=0;k<xin;k++) {- solp[iter*solc+k+1] = gsl_vector_get(s->x,k);- }- for(k=xin;k<2*xin;k++) {- solp[iter*solc+k+1] = gsl_vector_get(s->f,k-xin);- }-- iter++;- if (status) /* check if solver is stuck */- break;-- status =- gsl_multiroot_test_residual (s->f, epsabs);- }- while (status == GSL_CONTINUE && iter <= maxit);-- int i,j;- for (i=iter; i<solr; i++) {- solp[i*solc+0] = iter;- for(j=1;j<solc;j++) {- solp[i*solc+j]=0.;- }- }- gsl_multiroot_fdfsolver_free(s);- OK-}--//-------------- non linear least squares fitting ---------------------int nlfit(int method, int f(int, double*, int, double*),- int jac(int, double*, int, int, double*),- double epsabs, double epsrel, int maxit, int p,- KRVEC(xi), RMAT(sol)) {- REQUIRES(solr == maxit && solc == 2+xin,BAD_SIZE);- DEBUGMSG("nlfit");- const gsl_multifit_fdfsolver_type *T;- gsl_multifit_fdfsolver *s;- gsl_multifit_function_fdf my_f;- // extract function from pars- my_f.f = f_aux;- my_f.df = jf_aux;- my_f.fdf = fjf_aux;- my_f.n = p;- my_f.p = xin; // !!!!- Tfjf stfjf;- stfjf.f = f;- stfjf.jf = jac;- my_f.params = &stfjf;- size_t iter = 0;- int status;-- KDVVIEW(xi);- //DMVIEW(cov);-- switch(method) {- case 0 : { T = gsl_multifit_fdfsolver_lmsder; break; }- case 1 : { T = gsl_multifit_fdfsolver_lmder; break; }- default: ERROR(BAD_CODE);- }-- s = gsl_multifit_fdfsolver_alloc (T, my_f.n, my_f.p);- gsl_multifit_fdfsolver_set (s, &my_f, V(xi));-- do { status = gsl_multifit_fdfsolver_iterate (s);-- solp[iter*solc+0] = iter+1;- solp[iter*solc+1] = gsl_blas_dnrm2 (s->f);-- int k;- for(k=0;k<xin;k++) {- solp[iter*solc+k+2] = gsl_vector_get(s->x,k);- }-- iter++;- if (status) /* check if solver is stuck */- break;-- status = gsl_multifit_test_delta (s->dx, s->x, epsabs, epsrel);- }- while (status == GSL_CONTINUE && iter <= maxit);-- int i,j;- for (i=iter; i<solr; i++) {- solp[i*solc+0] = iter;- for(j=1;j<solc;j++) {- solp[i*solc+j]=0.;- }- }-- //gsl_multifit_covar (s->J, 0.0, M(cov));-- gsl_multifit_fdfsolver_free (s);- OK-}---//////////////////////////////////////////////////////---#define RAN(C,F) case C: { for(k=0;k<rn;k++) { rp[k]= F(gen); }; OK }--int random_vector(int seed, int code, RVEC(r)) {- DEBUGMSG("random_vector")- static gsl_rng * gen = NULL;- if (!gen) { gen = gsl_rng_alloc (gsl_rng_mt19937);}- gsl_rng_set (gen, seed);- int k;- switch (code) {- RAN(0,gsl_rng_uniform)- RAN(1,gsl_ran_ugaussian)- default: ERROR(BAD_CODE);- }-}-#undef RAN--//////////////////////////////////////////////////////--#include "gsl-ode.c"--//////////////////////////////////////////////////////
− lib/Numeric/GSL/gsl-ode.c
@@ -1,182 +0,0 @@--#ifdef GSLODE1--////////////////////////////// ODE V1 //////////////////////////////////////////--#include <gsl/gsl_odeiv.h>--typedef struct {int n; int (*f)(double,int, const double*, int, double *); int (*j)(double,int, const double*, int, int, double*);} Tode;--int odefunc (double t, const double y[], double f[], void *params) { - Tode * P = (Tode*) params;- (P->f)(t,P->n,y,P->n,f);- return GSL_SUCCESS;-}--int odejac (double t, const double y[], double *dfdy, double dfdt[], void *params) {- Tode * P = ((Tode*) params);- (P->j)(t,P->n,y,P->n,P->n,dfdy);- int j;- for (j=0; j< P->n; j++)- dfdt[j] = 0.0;- return GSL_SUCCESS;-}---int ode(int method, double h, double eps_abs, double eps_rel,- int f(double, int, const double*, int, double*),- int jac(double, int, const double*, int, int, double*),- KRVEC(xi), KRVEC(ts), RMAT(sol)) {-- const gsl_odeiv_step_type * T;-- switch(method) {- case 0 : {T = gsl_odeiv_step_rk2; break; }- case 1 : {T = gsl_odeiv_step_rk4; break; }- case 2 : {T = gsl_odeiv_step_rkf45; break; }- case 3 : {T = gsl_odeiv_step_rkck; break; }- case 4 : {T = gsl_odeiv_step_rk8pd; break; }- case 5 : {T = gsl_odeiv_step_rk2imp; break; }- case 6 : {T = gsl_odeiv_step_rk4imp; break; }- case 7 : {T = gsl_odeiv_step_bsimp; break; }- case 8 : { printf("Sorry: ODE rk1imp not available in this GSL version\n"); exit(0); }- case 9 : { printf("Sorry: ODE msadams not available in this GSL version\n"); exit(0); }- case 10: { printf("Sorry: ODE msbdf not available in this GSL version\n"); exit(0); }- default: ERROR(BAD_CODE);- }-- gsl_odeiv_step * s = gsl_odeiv_step_alloc (T, xin);- gsl_odeiv_control * c = gsl_odeiv_control_y_new (eps_abs, eps_rel);- gsl_odeiv_evolve * e = gsl_odeiv_evolve_alloc (xin);-- Tode P;- P.f = f;- P.j = jac;- P.n = xin;-- gsl_odeiv_system sys = {odefunc, odejac, xin, &P};-- double t = tsp[0];-- double* y = (double*)calloc(xin,sizeof(double));- int i,j;- for(i=0; i< xin; i++) {- y[i] = xip[i];- solp[i] = xip[i];- }-- for (i = 1; i < tsn ; i++)- {- double ti = tsp[i];- while (t < ti)- {- gsl_odeiv_evolve_apply (e, c, s,- &sys,- &t, ti, &h,- y);- // if (h < hmin) h = hmin;- }- for(j=0; j<xin; j++) {- solp[i*xin + j] = y[j];- }- }-- free(y);- gsl_odeiv_evolve_free (e);- gsl_odeiv_control_free (c);- gsl_odeiv_step_free (s);- return 0;-}--#else--///////////////////// ODE V2 ///////////////////////////////////////////////////- -#include <gsl/gsl_odeiv2.h>--typedef struct {int n; int (*f)(double,int, const double*, int, double *); int (*j)(double,int, const double*, int, int, double*);} Tode;--int odefunc (double t, const double y[], double f[], void *params) { - Tode * P = (Tode*) params;- (P->f)(t,P->n,y,P->n,f);- return GSL_SUCCESS;-}--int odejac (double t, const double y[], double *dfdy, double dfdt[], void *params) {- Tode * P = ((Tode*) params);- (P->j)(t,P->n,y,P->n,P->n,dfdy);- int j;- for (j=0; j< P->n; j++)- dfdt[j] = 0.0;- return GSL_SUCCESS;-}---int ode(int method, double h, double eps_abs, double eps_rel,- int f(double, int, const double*, int, double*),- int jac(double, int, const double*, int, int, double*),- KRVEC(xi), KRVEC(ts), RMAT(sol)) {-- const gsl_odeiv2_step_type * T;-- switch(method) {- case 0 : {T = gsl_odeiv2_step_rk2; break; }- case 1 : {T = gsl_odeiv2_step_rk4; break; }- case 2 : {T = gsl_odeiv2_step_rkf45; break; }- case 3 : {T = gsl_odeiv2_step_rkck; break; }- case 4 : {T = gsl_odeiv2_step_rk8pd; break; }- case 5 : {T = gsl_odeiv2_step_rk2imp; break; }- case 6 : {T = gsl_odeiv2_step_rk4imp; break; }- case 7 : {T = gsl_odeiv2_step_bsimp; break; }- case 8 : {T = gsl_odeiv2_step_rk1imp; break; }- case 9 : {T = gsl_odeiv2_step_msadams; break; }- case 10: {T = gsl_odeiv2_step_msbdf; break; }- default: ERROR(BAD_CODE);- }-- Tode P;- P.f = f;- P.j = jac;- P.n = xin;-- gsl_odeiv2_system sys = {odefunc, odejac, xin, &P};-- gsl_odeiv2_driver * d =- gsl_odeiv2_driver_alloc_y_new (&sys, T, h, eps_abs, eps_rel);-- double t = tsp[0];-- double* y = (double*)calloc(xin,sizeof(double));- int i,j;- int status;- for(i=0; i< xin; i++) {- y[i] = xip[i];- solp[i] = xip[i];- }-- for (i = 1; i < tsn ; i++)- {- double ti = tsp[i];- - status = gsl_odeiv2_driver_apply (d, &t, ti, y);- - if (status != GSL_SUCCESS) {- printf ("error in ode, return value=%d\n", status);- break;- }--// printf ("%.5e %.5e %.5e\n", t, y[0], y[1]);- - for(j=0; j<xin; j++) {- solp[i*xin + j] = y[j];- }- }-- free(y);- gsl_odeiv2_driver_free (d);- - return status;-}--#endif-
− lib/Numeric/IO.hs
@@ -1,160 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.IO--- Copyright : (c) Alberto Ruiz 2010--- License : GPL------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ Display, formatting and IO functions for numeric 'Vector' and 'Matrix'-----------------------------------------------------------------------------------module Numeric.IO (- dispf, disps, dispcf, vecdisp, latexFormat, format,- loadMatrix, saveMatrix, fromFile, fileDimensions,- readMatrix, fromArray2D,- fscanfVector, fprintfVector, freadVector, fwriteVector-) where--import Data.Packed-import Data.Packed.Internal-import System.Process(readProcess)-import Text.Printf(printf)-import Data.List(intersperse)-import Data.Complex--{- | Creates a string from a matrix given a separator and a function to show each entry. Using-this function the user can easily define any desired display function:--@import Text.Printf(printf)@--@disp = putStr . format \" \" (printf \"%.2f\")@---}-format :: (Element t) => String -> (t -> String) -> Matrix t -> String-format sep f m = table sep . map (map f) . toLists $ m--{- | Show a matrix with \"autoscaling\" and a given number of decimal places.--@disp = putStr . disps 2--\> disp $ 120 * (3><4) [1..]-3x4 E3- 0.12 0.24 0.36 0.48- 0.60 0.72 0.84 0.96- 1.08 1.20 1.32 1.44-@--}-disps :: Int -> Matrix Double -> String-disps d x = sdims x ++ " " ++ formatScaled d x--{- | Show a matrix with a given number of decimal places.--@disp = putStr . dispf 3--\> disp (1/3 + ident 4)-4x4-1.333 0.333 0.333 0.333-0.333 1.333 0.333 0.333-0.333 0.333 1.333 0.333-0.333 0.333 0.333 1.333-@--}-dispf :: Int -> Matrix Double -> String-dispf d x = sdims x ++ "\n" ++ formatFixed (if isInt x then 0 else d) x--sdims x = show (rows x) ++ "x" ++ show (cols x)--formatFixed d x = format " " (printf ("%."++show d++"f")) $ x--isInt = all lookslikeInt . toList . flatten--formatScaled dec t = "E"++show o++"\n" ++ ss- where ss = format " " (printf fmt. g) t- g x | o >= 0 = x/10^(o::Int)- | otherwise = x*10^(-o)- o = floor $ maximum $ map (logBase 10 . abs) $ toList $ flatten t- fmt = '%':show (dec+3) ++ '.':show dec ++"f"--{- | Show a vector using a function for showing matrices.--@disp = putStr . vecdisp ('dispf' 2)--\> disp ('linspace' 10 (0,1))-10 |> 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00-@--}-vecdisp :: (Element t) => (Matrix t -> String) -> Vector t -> String-vecdisp f v- = ((show (dim v) ++ " |> ") ++) . (++"\n")- . unwords . lines . tail . dropWhile (not . (`elem` " \n"))- . f . trans . reshape 1- $ v---- | Tool to display matrices with latex syntax.-latexFormat :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc.- -> String -- ^ Formatted matrix, with elements separated by spaces and newlines- -> String-latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}"- where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines---- | Pretty print a complex number with at most n decimal digits.-showComplex :: Int -> Complex Double -> String-showComplex d (a:+b)- | isZero a && isZero b = "0"- | isZero b = sa- | isZero a && isOne b = s2++"i"- | isZero a = sb++"i"- | isOne b = sa++s3++"i"- | otherwise = sa++s1++sb++"i"- where- sa = shcr d a- sb = shcr d b- s1 = if b<0 then "" else "+"- s2 = if b<0 then "-" else ""- s3 = if b<0 then "-" else "+"--shcr d a | lookslikeInt a = printf "%.0f" a- | otherwise = printf ("%."++show d++"f") a---lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx- where shx = show x--isZero x = show x `elem` ["0.0","-0.0"]-isOne x = show x `elem` ["1.0","-1.0"]---- | Pretty print a complex matrix with at most n decimal digits.-dispcf :: Int -> Matrix (Complex Double) -> String-dispcf d m = sdims m ++ "\n" ++ format " " (showComplex d) m-------------------------------------------------------------------------- | reads a matrix from a string containing a table of numbers.-readMatrix :: String -> Matrix Double-readMatrix = fromLists . map (map read). map words . filter (not.null) . lines--{- | obtains the number of rows and columns in an ASCII data file- (provisionally using unix's wc).--}-fileDimensions :: FilePath -> IO (Int,Int)-fileDimensions fname = do- wcres <- readProcess "wc" ["-w",fname] ""- contents <- readFile fname- let tot = read . head . words $ wcres- c = length . head . dropWhile null . map words . lines $ contents- if tot > 0- then return (tot `div` c, c)- else return (0,0)---- | Loads a matrix from an ASCII file formatted as a 2D table.-loadMatrix :: FilePath -> IO (Matrix Double)-loadMatrix file = fromFile file =<< fileDimensions file---- | Loads a matrix from an ASCII file (the number of rows and columns must be known in advance).-fromFile :: FilePath -> (Int,Int) -> IO (Matrix Double)-fromFile filename (r,c) = reshape c `fmap` fscanfVector filename (r*c)-
− lib/Numeric/LinearAlgebra.hs
@@ -1,28 +0,0 @@-------------------------------------------------------------------------------{- |-Module : Numeric.LinearAlgebra-Copyright : (c) Alberto Ruiz 2006-10-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--This module reexports all normally required functions for Linear Algebra applications.--It also provides instances of standard classes 'Show', 'Read', 'Eq',-'Num', 'Fractional', and 'Floating' for 'Vector' and 'Matrix'.-In arithmetic operations one-component vectors and matrices automatically-expand to match the dimensions of the other operand.---}-------------------------------------------------------------------------------module Numeric.LinearAlgebra (- module Numeric.Container,- module Numeric.LinearAlgebra.Algorithms-) where--import Numeric.Container-import Numeric.LinearAlgebra.Algorithms-import Numeric.Matrix()-import Numeric.Vector()
− lib/Numeric/LinearAlgebra/Algorithms.hs
@@ -1,731 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------{- |-Module : Numeric.LinearAlgebra.Algorithms-Copyright : (c) Alberto Ruiz 2006-9-License : GPL-style--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional-Portability : uses ffi--High level generic interface to common matrix computations.--Specific functions for particular base types can also be explicitly-imported from "Numeric.LinearAlgebra.LAPACK".---}--------------------------------------------------------------------------------module Numeric.LinearAlgebra.Algorithms (--- * Supported types- Field(),--- * Linear Systems- linearSolve,- luSolve,- cholSolve,- linearSolveLS,- linearSolveSVD,- inv, pinv,- det, invlndet,- rank, rcond,--- * Matrix factorizations--- ** Singular value decomposition- svd,- fullSVD,- thinSVD,- compactSVD,- singularValues,- leftSV, rightSV,--- ** Eigensystems- eig, eigSH, eigSH',- eigenvalues, eigenvaluesSH, eigenvaluesSH',- geigSH',--- ** QR- qr, rq,--- ** Cholesky- chol, cholSH, mbCholSH,--- ** Hessenberg- hess,--- ** Schur- schur,--- ** LU- lu, luPacked,--- * Matrix functions- expm,- sqrtm,- matFunc,--- * Nullspace- nullspacePrec,- nullVector,- nullspaceSVD,- orth,--- * Norms- Normed(..), NormType(..),- relativeError,--- * Misc- eps, peps, i,--- * Util- haussholder,- unpackQR, unpackHess,- pinvTol,- ranksv-) where---import Data.Packed.Internal hiding ((//))-import Data.Packed.Matrix-import Numeric.LinearAlgebra.LAPACK as LAPACK-import Data.List(foldl1')-import Data.Array-import Numeric.ContainerBoot---{- | Class used to define generic linear algebra computations for both real and complex matrices. Only double precision is supported in this version (we can-transform single precision objects using 'single' and 'double').---}-class (Product t,- Convert t,- Container Vector t,- Container Matrix t,- Normed Matrix t,- Normed Vector t) => Field t where- svd' :: Matrix t -> (Matrix t, Vector Double, Matrix t)- thinSVD' :: Matrix t -> (Matrix t, Vector Double, Matrix t)- sv' :: Matrix t -> Vector Double- luPacked' :: Matrix t -> (Matrix t, [Int])- luSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t- linearSolve' :: Matrix t -> Matrix t -> Matrix t- cholSolve' :: Matrix t -> Matrix t -> Matrix t- linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t- linearSolveLS' :: Matrix t -> Matrix t -> Matrix t- eig' :: Matrix t -> (Vector (Complex Double), Matrix (Complex Double))- eigSH'' :: Matrix t -> (Vector Double, Matrix t)- eigOnly :: Matrix t -> Vector (Complex Double)- eigOnlySH :: Matrix t -> Vector Double- cholSH' :: Matrix t -> Matrix t- mbCholSH' :: Matrix t -> Maybe (Matrix t)- qr' :: Matrix t -> (Matrix t, Matrix t)- hess' :: Matrix t -> (Matrix t, Matrix t)- schur' :: Matrix t -> (Matrix t, Matrix t)---instance Field Double where- svd' = svdRd- thinSVD' = thinSVDRd- sv' = svR- luPacked' = luR- luSolve' (l_u,perm) = lusR l_u perm- linearSolve' = linearSolveR -- (luSolve . luPacked) ??- cholSolve' = cholSolveR- linearSolveLS' = linearSolveLSR- linearSolveSVD' = linearSolveSVDR Nothing- eig' = eigR- eigSH'' = eigS- eigOnly = eigOnlyR- eigOnlySH = eigOnlyS- cholSH' = cholS- mbCholSH' = mbCholS- qr' = unpackQR . qrR- hess' = unpackHess hessR- schur' = schurR--instance Field (Complex Double) where-#ifdef NOZGESDD- svd' = svdC- thinSVD' = thinSVDC-#else- svd' = svdCd- thinSVD' = thinSVDCd-#endif- sv' = svC- luPacked' = luC- luSolve' (l_u,perm) = lusC l_u perm- linearSolve' = linearSolveC- cholSolve' = cholSolveC- linearSolveLS' = linearSolveLSC- linearSolveSVD' = linearSolveSVDC Nothing- eig' = eigC- eigOnly = eigOnlyC- eigSH'' = eigH- eigOnlySH = eigOnlyH- cholSH' = cholH- mbCholSH' = mbCholH- qr' = unpackQR . qrC- hess' = unpackHess hessC- schur' = schurC------------------------------------------------------------------square m = rows m == cols m--vertical m = rows m >= cols m--exactHermitian m = m `equal` ctrans m-------------------------------------------------------------------- | Full singular value decomposition.-svd :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)-svd = {-# SCC "svd" #-} svd'---- | A version of 'svd' which returns only the @min (rows m) (cols m)@ singular vectors of @m@.------ If @(u,s,v) = thinSVD m@ then @m == u \<> diag s \<> trans v@.-thinSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)-thinSVD = {-# SCC "thinSVD" #-} thinSVD'---- | Singular values only.-singularValues :: Field t => Matrix t -> Vector Double-singularValues = {-# SCC "singularValues" #-} sv'---- | A version of 'svd' which returns an appropriate diagonal matrix with the singular values.------ If @(u,d,v) = fullSVD m@ then @m == u \<> d \<> trans v@.-fullSVD :: Field t => Matrix t -> (Matrix t, Matrix Double, Matrix t)-fullSVD m = (u,d,v) where- (u,s,v) = svd m- d = diagRect 0 s r c- r = rows m- c = cols m---- | Similar to 'thinSVD', returning only the nonzero singular values and the corresponding singular vectors.-compactSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)-compactSVD m = (u', subVector 0 d s, v') where- (u,s,v) = thinSVD m- d = rankSVD (1*eps) m s `max` 1- u' = takeColumns d u- v' = takeColumns d v----- | Singular values and all right singular vectors.-rightSV :: Field t => Matrix t -> (Vector Double, Matrix t)-rightSV m | vertical m = let (_,s,v) = thinSVD m in (s,v)- | otherwise = let (_,s,v) = svd m in (s,v)---- | Singular values and all left singular vectors.-leftSV :: Field t => Matrix t -> (Matrix t, Vector Double)-leftSV m | vertical m = let (u,s,_) = svd m in (u,s)- | otherwise = let (u,s,_) = thinSVD m in (u,s)--------------------------------------------------------------------- | Obtains the LU decomposition of a matrix in a compact data structure suitable for 'luSolve'.-luPacked :: Field t => Matrix t -> (Matrix t, [Int])-luPacked = {-# SCC "luPacked" #-} luPacked'---- | Solution of a linear system (for several right hand sides) from the precomputed LU factorization obtained by 'luPacked'.-luSolve :: Field t => (Matrix t, [Int]) -> Matrix t -> Matrix t-luSolve = {-# SCC "luSolve" #-} luSolve'---- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.--- It is similar to 'luSolve' . 'luPacked', but @linearSolve@ raises an error if called on a singular system.-linearSolve :: Field t => Matrix t -> Matrix t -> Matrix t-linearSolve = {-# SCC "linearSolve" #-} linearSolve'---- | Solve a symmetric or Hermitian positive definite linear system using a precomputed Cholesky decomposition obtained by 'chol'.-cholSolve :: Field t => Matrix t -> Matrix t -> Matrix t-cholSolve = {-# SCC "cholSolve" #-} cholSolve'---- | Minimum norm solution of a general linear least squares problem Ax=B using the SVD. Admits rank-deficient systems but it is slower than 'linearSolveLS'. The effective rank of A is determined by treating as zero those singular valures which are less than 'eps' times the largest singular value.-linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t-linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD'----- | Least squared error solution of an overconstrained linear system, or the minimum norm solution of an underconstrained system. For rank-deficient systems use 'linearSolveSVD'.-linearSolveLS :: Field t => Matrix t -> Matrix t -> Matrix t-linearSolveLS = {-# SCC "linearSolveLS" #-} linearSolveLS'-------------------------------------------------------------------- | Eigenvalues and eigenvectors of a general square matrix.------ If @(s,v) = eig m@ then @m \<> v == v \<> diag s@-eig :: Field t => Matrix t -> (Vector (Complex Double), Matrix (Complex Double))-eig = {-# SCC "eig" #-} eig'---- | Eigenvalues of a general square matrix.-eigenvalues :: Field t => Matrix t -> Vector (Complex Double)-eigenvalues = {-# SCC "eigenvalues" #-} eigOnly---- | Similar to 'eigSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.-eigSH' :: Field t => Matrix t -> (Vector Double, Matrix t)-eigSH' = {-# SCC "eigSH'" #-} eigSH''---- | Similar to 'eigenvaluesSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.-eigenvaluesSH' :: Field t => Matrix t -> Vector Double-eigenvaluesSH' = {-# SCC "eigenvaluesSH'" #-} eigOnlySH---- | Eigenvalues and Eigenvectors of a complex hermitian or real symmetric matrix.------ If @(s,v) = eigSH m@ then @m == v \<> diag s \<> ctrans v@-eigSH :: Field t => Matrix t -> (Vector Double, Matrix t)-eigSH m | exactHermitian m = eigSH' m- | otherwise = error "eigSH requires complex hermitian or real symmetric matrix"---- | Eigenvalues of a complex hermitian or real symmetric matrix.-eigenvaluesSH :: Field t => Matrix t -> Vector Double-eigenvaluesSH m | exactHermitian m = eigenvaluesSH' m- | otherwise = error "eigenvaluesSH requires complex hermitian or real symmetric matrix"-------------------------------------------------------------------- | QR factorization.------ If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular.-qr :: Field t => Matrix t -> (Matrix t, Matrix t)-qr = {-# SCC "qr" #-} qr'---- | RQ factorization.------ If @(r,q) = rq m@ then @m == r \<> q@, where q is unitary and r is upper triangular.-rq :: Field t => Matrix t -> (Matrix t, Matrix t)-rq m = {-# SCC "rq" #-} (r,q) where- (q',r') = qr $ trans $ rev1 m- r = rev2 (trans r')- q = rev2 (trans q')- rev1 = flipud . fliprl- rev2 = fliprl . flipud---- | Hessenberg factorization.------ If @(p,h) = hess m@ then @m == p \<> h \<> ctrans p@, where p is unitary--- and h is in upper Hessenberg form (it has zero entries below the first subdiagonal).-hess :: Field t => Matrix t -> (Matrix t, Matrix t)-hess = hess'---- | Schur factorization.------ If @(u,s) = schur m@ then @m == u \<> s \<> ctrans u@, where u is unitary--- and s is a Shur matrix. A complex Schur matrix is upper triangular. A real Schur matrix is--- upper triangular in 2x2 blocks.------ \"Anything that the Jordan decomposition can do, the Schur decomposition--- can do better!\" (Van Loan)-schur :: Field t => Matrix t -> (Matrix t, Matrix t)-schur = schur'----- | Similar to 'cholSH', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'.-mbCholSH :: Field t => Matrix t -> Maybe (Matrix t)-mbCholSH = {-# SCC "mbCholSH" #-} mbCholSH'---- | Similar to 'chol', without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.-cholSH :: Field t => Matrix t -> Matrix t-cholSH = {-# SCC "cholSH" #-} cholSH'---- | Cholesky factorization of a positive definite hermitian or symmetric matrix.------ If @c = chol m@ then @c@ is upper triangular and @m == ctrans c \<> c@.-chol :: Field t => Matrix t -> Matrix t-chol m | exactHermitian m = cholSH m- | otherwise = error "chol requires positive definite complex hermitian or real symmetric matrix"----- | Joint computation of inverse and logarithm of determinant of a square matrix.-invlndet :: (Floating t, Field t)- => Matrix t- -> (Matrix t, (t, t)) -- ^ (inverse, (log abs det, sign or phase of det)) -invlndet m | square m = (im,(ladm,sdm))- | otherwise = error $ "invlndet of nonsquare "++ shSize m ++ " matrix"- where- lp@(lup,perm) = luPacked m- s = signlp (rows m) perm- dg = toList $ takeDiag $ lup- ladm = sum $ map (log.abs) dg- sdm = s* product (map signum dg)- im = luSolve lp (ident (rows m))----- | Determinant of a square matrix. To avoid possible overflow or underflow use 'invlndet'.-det :: Field t => Matrix t -> t-det m | square m = {-# SCC "det" #-} s * (product $ toList $ takeDiag $ lup)- | otherwise = error $ "det of nonsquare "++ shSize m ++ " matrix"- where (lup,perm) = luPacked m- s = signlp (rows m) perm---- | Explicit LU factorization of a general matrix.------ If @(l,u,p,s) = lu m@ then @m == p \<> l \<> u@, where l is lower triangular,--- u is upper triangular, p is a permutation matrix and s is the signature of the permutation.-lu :: Field t => Matrix t -> (Matrix t, Matrix t, Matrix t, t)-lu = luFact . luPacked---- | Inverse of a square matrix. See also 'invlndet'.-inv :: Field t => Matrix t -> Matrix t-inv m | square m = m `linearSolve` ident (rows m)- | otherwise = error $ "inv of nonsquare "++ shSize m ++ " matrix"---- | Pseudoinverse of a general matrix.-pinv :: Field t => Matrix t -> Matrix t-pinv m = linearSolveSVD m (ident (rows m))---- | Numeric rank of a matrix from the SVD decomposition.-rankSVD :: Element t- => Double -- ^ numeric zero (e.g. 1*'eps')- -> Matrix t -- ^ input matrix m- -> Vector Double -- ^ 'sv' of m- -> Int -- ^ rank of m-rankSVD teps m s = ranksv teps (max (rows m) (cols m)) (toList s)---- | Numeric rank of a matrix from its singular values.-ranksv :: Double -- ^ numeric zero (e.g. 1*'eps')- -> Int -- ^ maximum dimension of the matrix- -> [Double] -- ^ singular values- -> Int -- ^ rank of m-ranksv teps maxdim s = k where- g = maximum s- tol = fromIntegral maxdim * g * teps- s' = filter (>tol) s- k = if g > teps then length s' else 0---- | The machine precision of a Double: @eps = 2.22044604925031e-16@ (the value used by GNU-Octave).-eps :: Double-eps = 2.22044604925031e-16----- | 1 + 0.5*peps == 1, 1 + 0.6*peps /= 1-peps :: RealFloat x => x-peps = x where x = 2.0 ** fromIntegral (1 - floatDigits x)----- | The imaginary unit: @i = 0.0 :+ 1.0@-i :: Complex Double-i = 0:+1----------------------------------------------------------------------------- | The nullspace of a matrix from its SVD decomposition.-nullspaceSVD :: Field t- => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'),- -- or Right \"theoretical\" matrix rank.- -> Matrix t -- ^ input matrix m- -> (Vector Double, Matrix t) -- ^ 'rightSV' of m- -> [Vector t] -- ^ list of unitary vectors spanning the nullspace-nullspaceSVD hint a (s,v) = vs where- tol = case hint of- Left t -> t- _ -> eps- k = case hint of- Right t -> t- _ -> rankSVD tol a s- vs = drop k $ toRows $ ctrans v----- | The nullspace of a matrix. See also 'nullspaceSVD'.-nullspacePrec :: Field t- => Double -- ^ relative tolerance in 'eps' units (e.g., use 3 to get 3*'eps')- -> Matrix t -- ^ input matrix- -> [Vector t] -- ^ list of unitary vectors spanning the nullspace-nullspacePrec t m = nullspaceSVD (Left (t*eps)) m (rightSV m)---- | The nullspace of a matrix, assumed to be one-dimensional, with machine precision.-nullVector :: Field t => Matrix t -> Vector t-nullVector = last . nullspacePrec 1--orth :: Field t => Matrix t -> [Vector t]--- ^ Return an orthonormal basis of the range space of a matrix-orth m = take r $ toColumns u- where- (u,s,_) = compactSVD m- r = ranksv eps (max (rows m) (cols m)) (toList s)----------------------------------------------------------------------------{- Pseudoinverse of a real matrix with the desired tolerance, expressed as a-multiplicative factor of the default tolerance used by GNU-Octave (see 'pinv').--@\> let m = 'fromLists' [[1,0, 0]- ,[0,1, 0]- ,[0,0,1e-10]]-\ ---\> 'pinv' m -1. 0. 0.-0. 1. 0.-0. 0. 10000000000.-\ ---\> pinvTol 1E8 m-1. 0. 0.-0. 1. 0.-0. 0. 1.@---}---pinvTol :: Double -> Matrix Double -> Matrix Double-pinvTol t m = v' `mXm` diag s' `mXm` trans u' where- (u,s,v) = thinSVDRd m- sl@(g:_) = toList s- s' = fromList . map rec $ sl- rec x = if x < g*tol then 1 else 1/x- tol = (fromIntegral (max r c) * g * t * eps)- r = rows m- c = cols m- d = dim s- u' = takeColumns d u- v' = takeColumns d v--------------------------------------------------------------------------- many thanks, quickcheck!--haussholder :: (Field a) => a -> Vector a -> Matrix a-haussholder tau v = ident (dim v) `sub` (tau `scale` (w `mXm` ctrans w))- where w = asColumn v---zh k v = fromList $ replicate (k-1) 0 ++ (1:drop k xs)- where xs = toList v--zt 0 v = v-zt k v = join [subVector 0 (dim v - k) v, konst 0 k]---unpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t)-unpackQR (pq, tau) = {-# SCC "unpackQR" #-} (q,r)- where cs = toColumns pq- m = rows pq- n = cols pq- mn = min m n- r = fromColumns $ zipWith zt ([m-1, m-2 .. 1] ++ repeat 0) cs- vs = zipWith zh [1..mn] cs- hs = zipWith haussholder (toList tau) vs- q = foldl1' mXm hs--unpackHess :: (Field t) => (Matrix t -> (Matrix t,Vector t)) -> Matrix t -> (Matrix t, Matrix t)-unpackHess hf m- | rows m == 1 = ((1><1)[1],m)- | otherwise = (uH . hf) m--uH (pq, tau) = (p,h)- where cs = toColumns pq- m = rows pq- n = cols pq- mn = min m n- h = fromColumns $ zipWith zt ([m-2, m-3 .. 1] ++ repeat 0) cs- vs = zipWith zh [2..mn] cs- hs = zipWith haussholder (toList tau) vs- p = foldl1' mXm hs-------------------------------------------------------------------------------- | Reciprocal of the 2-norm condition number of a matrix, computed from the singular values.-rcond :: Field t => Matrix t -> Double-rcond m = last s / head s- where s = toList (singularValues m)---- | Number of linearly independent rows or columns.-rank :: Field t => Matrix t -> Int-rank m = rankSVD eps m (singularValues m)--{--expm' m = case diagonalize (complex m) of- Just (l,v) -> v `mXm` diag (exp l) `mXm` inv v- Nothing -> error "Sorry, expm not yet implemented for non-diagonalizable matrices"- where exp = vectorMapC Exp--}--diagonalize m = if rank v == n- then Just (l,v)- else Nothing- where n = rows m- (l,v) = if exactHermitian m- then let (l',v') = eigSH m in (real l', v')- else eig m---- | Generic matrix functions for diagonalizable matrices. For instance:------ @logm = matFunc log@----matFunc :: (Complex Double -> Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-matFunc f m = case diagonalize m of- Just (l,v) -> v `mXm` diag (mapVector f l) `mXm` inv v- Nothing -> error "Sorry, matFunc requires a diagonalizable matrix" ------------------------------------------------------------------golubeps :: Integer -> Integer -> Double-golubeps p q = a * fromIntegral b / fromIntegral c where- a = 2^^(3-p-q)- b = fact p * fact q- c = fact (p+q) * fact (p+q+1)- fact n = product [1..n]--epslist = [ (fromIntegral k, golubeps k k) | k <- [1..]]--geps delta = head [ k | (k,g) <- epslist, g<delta]---{- | Matrix exponential. It uses a direct translation of Algorithm 11.3.1 in Golub & Van Loan,- based on a scaled Pade approximation.--}-expm :: Field t => Matrix t -> Matrix t-expm = expGolub--expGolub :: ( Fractional t, Element t, Field t- , Normed Matrix t- , RealFrac (RealOf t)- , Floating (RealOf t)- ) => Matrix t -> Matrix t-expGolub m = iterate msq f !! j- where j = max 0 $ floor $ logBase 2 $ pnorm Infinity m- a = m */ fromIntegral ((2::Int)^j)- q = geps eps -- 7 steps- eye = ident (rows m)- work (k,c,x,n,d) = (k',c',x',n',d')- where k' = k+1- c' = c * fromIntegral (q-k+1) / fromIntegral ((2*q-k+1)*k)- x' = a <> x- n' = n |+| (c' .* x')- d' = d |+| (((-1)^k * c') .* x')- (_,_,_,nf,df) = iterate work (1,1,eye,eye,eye) !! q- f = linearSolve df nf- msq x = x <> x-- (<>) = multiply- v */ x = scale (recip x) v- (.*) = scale- (|+|) = add------------------------------------------------------------------{- | Matrix square root. Currently it uses a simple iterative algorithm described in Wikipedia.-It only works with invertible matrices that have a real solution. For diagonalizable matrices you can try @matFunc sqrt@.--@m = (2><2) [4,9- ,0,4] :: Matrix Double@--@\>sqrtm m-(2><2)- [ 2.0, 2.25- , 0.0, 2.0 ]@--}-sqrtm :: Field t => Matrix t -> Matrix t-sqrtm = sqrtmInv--sqrtmInv x = fst $ fixedPoint $ iterate f (x, ident (rows x))- where fixedPoint (a:b:rest) | pnorm PNorm1 (fst a |-| fst b) < peps = a- | otherwise = fixedPoint (b:rest)- fixedPoint _ = error "fixedpoint with impossible inputs"- f (y,z) = (0.5 .* (y |+| inv z),- 0.5 .* (inv y |+| z))- (.*) = scale- (|+|) = add- (|-|) = sub----------------------------------------------------------------------signlp r vals = foldl f 1 (zip [0..r-1] vals)- where f s (a,b) | a /= b = -s- | otherwise = s--swap (arr,s) (a,b) | a /= b = (arr // [(a, arr!b),(b,arr!a)],-s)- | otherwise = (arr,s)--fixPerm r vals = (fromColumns $ elems res, sign)- where v = [0..r-1]- s = toColumns (ident r)- (res,sign) = foldl swap (listArray (0,r-1) s, 1) (zip v vals)--triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]]- where el p q = if q-p>=h then v else 1 - v--luFact (l_u,perm) | r <= c = (l ,u ,p, s)- | otherwise = (l',u',p, s)- where- r = rows l_u- c = cols l_u- tu = triang r c 0 1- tl = triang r c 0 0- l = takeColumns r (l_u |*| tl) |+| diagRect 0 (konst 1 r) r r- u = l_u |*| tu- (p,s) = fixPerm r perm- l' = (l_u |*| tl) |+| diagRect 0 (konst 1 c) r c- u' = takeRows c (l_u |*| tu)- (|+|) = add- (|*|) = mul-------------------------------------------------------------------------------data NormType = Infinity | PNorm1 | PNorm2 | Frobenius--class (RealFloat (RealOf t)) => Normed c t where- pnorm :: NormType -> c t -> RealOf t--instance Normed Vector Double where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = norm2--instance Normed Vector (Complex Double) where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = pnorm PNorm2--instance Normed Vector Float where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = pnorm PNorm2--instance Normed Vector (Complex Float) where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = pnorm PNorm2---instance Normed Matrix Double where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = (@>0) . singularValues- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten--instance Normed Matrix (Complex Double) where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = (@>0) . singularValues- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten--instance Normed Matrix Float where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = realToFrac . (@>0) . singularValues . double- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten--instance Normed Matrix (Complex Float) where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = realToFrac . (@>0) . singularValues . double- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten---- | Approximate number of common digits in the maximum element.-relativeError :: (Normed c t, Container c t) => c t -> c t -> Int-relativeError x y = dig (norm (x `sub` y) / norm x)- where norm = pnorm Infinity- dig r = round $ -logBase 10 (realToFrac r :: Double)---------------------------------------------------------------------------- | Generalized symmetric positive definite eigensystem Av = lBv,--- for A and B symmetric, B positive definite (conditions not checked).-geigSH' :: Field t- => Matrix t -- ^ A- -> Matrix t -- ^ B- -> (Vector Double, Matrix t)-geigSH' a b = (l,v')- where- u = cholSH b- iu = inv u- c = ctrans iu <> a <> iu- (l,v) = eigSH' c- v' = iu <> v- (<>) = mXm-
− lib/Numeric/LinearAlgebra/LAPACK.hs
@@ -1,535 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.LinearAlgebra.LAPACK--- Copyright : (c) Alberto Ruiz 2006-7--- License : GPL-style--- --- Maintainer : Alberto Ruiz (aruiz at um dot es)--- Stability : provisional--- Portability : portable (uses FFI)------ Functional interface to selected LAPACK functions (<http://www.netlib.org/lapack>).-----------------------------------------------------------------------------------module Numeric.LinearAlgebra.LAPACK (- -- * Matrix product- multiplyR, multiplyC, multiplyF, multiplyQ,- -- * Linear systems- linearSolveR, linearSolveC,- lusR, lusC,- cholSolveR, cholSolveC,- linearSolveLSR, linearSolveLSC,- linearSolveSVDR, linearSolveSVDC,- -- * SVD- svR, svRd, svC, svCd,- svdR, svdRd, svdC, svdCd,- thinSVDR, thinSVDRd, thinSVDC, thinSVDCd,- rightSVR, rightSVC, leftSVR, leftSVC,- -- * Eigensystems- eigR, eigC, eigS, eigS', eigH, eigH',- eigOnlyR, eigOnlyC, eigOnlyS, eigOnlyH,- -- * LU- luR, luC,- -- * Cholesky- cholS, cholH, mbCholS, mbCholH,- -- * QR- qrR, qrC,- -- * Hessenberg- hessR, hessC,- -- * Schur- schurR, schurC-) where--import Data.Packed.Internal-import Data.Packed.Matrix-import Numeric.Conversion-import Numeric.GSL.Vector(vectorMapValR, FunCodeSV(Scale))--import Foreign.Ptr(nullPtr)-import Foreign.C.Types-import Control.Monad(when)-import System.IO.Unsafe(unsafePerformIO)---------------------------------------------------------------------------------------foreign import ccall unsafe "multiplyR" dgemmc :: CInt -> CInt -> TMMM-foreign import ccall unsafe "multiplyC" zgemmc :: CInt -> CInt -> TCMCMCM-foreign import ccall unsafe "multiplyF" sgemmc :: CInt -> CInt -> TFMFMFM-foreign import ccall unsafe "multiplyQ" cgemmc :: CInt -> CInt -> TQMQMQM--isT Matrix{order = ColumnMajor} = 0-isT Matrix{order = RowMajor} = 1--tt x@Matrix{order = ColumnMajor} = x-tt x@Matrix{order = RowMajor} = trans x--multiplyAux f st a b = unsafePerformIO $ do- when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++- show (rows a,cols a) ++ " x " ++ show (rows b, cols b)- s <- createMatrix ColumnMajor (rows a) (cols b)- app3 (f (isT a) (isT b)) mat (tt a) mat (tt b) mat s st- return s---- | Matrix product based on BLAS's /dgemm/.-multiplyR :: Matrix Double -> Matrix Double -> Matrix Double-multiplyR a b = {-# SCC "multiplyR" #-} multiplyAux dgemmc "dgemmc" a b---- | Matrix product based on BLAS's /zgemm/.-multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-multiplyC a b = multiplyAux zgemmc "zgemmc" a b---- | Matrix product based on BLAS's /sgemm/.-multiplyF :: Matrix Float -> Matrix Float -> Matrix Float-multiplyF a b = multiplyAux sgemmc "sgemmc" a b---- | Matrix product based on BLAS's /cgemm/.-multiplyQ :: Matrix (Complex Float) -> Matrix (Complex Float) -> Matrix (Complex Float)-multiplyQ a b = multiplyAux cgemmc "cgemmc" a b--------------------------------------------------------------------------------foreign import ccall unsafe "svd_l_R" dgesvd :: TMMVM-foreign import ccall unsafe "svd_l_C" zgesvd :: TCMCMVCM-foreign import ccall unsafe "svd_l_Rdd" dgesdd :: TMMVM-foreign import ccall unsafe "svd_l_Cdd" zgesdd :: TCMCMVCM---- | Full SVD of a real matrix using LAPACK's /dgesvd/.-svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-svdR = svdAux dgesvd "svdR" . fmat---- | Full SVD of a real matrix using LAPACK's /dgesdd/.-svdRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-svdRd = svdAux dgesdd "svdRdd" . fmat---- | Full SVD of a complex matrix using LAPACK's /zgesvd/.-svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-svdC = svdAux zgesvd "svdC" . fmat---- | Full SVD of a complex matrix using LAPACK's /zgesdd/.-svdCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-svdCd = svdAux zgesdd "svdCdd" . fmat--svdAux f st x = unsafePerformIO $ do- u <- createMatrix ColumnMajor r r- s <- createVector (min r c)- v <- createMatrix ColumnMajor c c- app4 f mat x mat u vec s mat v st- return (u,s,trans v)- where r = rows x- c = cols x----- | Thin SVD of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'S\'.-thinSVDR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-thinSVDR = thinSVDAux dgesvd "thinSVDR" . fmat---- | Thin SVD of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'S\'.-thinSVDC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-thinSVDC = thinSVDAux zgesvd "thinSVDC" . fmat---- | Thin SVD of a real matrix, using LAPACK's /dgesdd/ with jobz == \'S\'.-thinSVDRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-thinSVDRd = thinSVDAux dgesdd "thinSVDRdd" . fmat---- | Thin SVD of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'S\'.-thinSVDCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-thinSVDCd = thinSVDAux zgesdd "thinSVDCdd" . fmat--thinSVDAux f st x = unsafePerformIO $ do- u <- createMatrix ColumnMajor r q- s <- createVector q- v <- createMatrix ColumnMajor q c- app4 f mat x mat u vec s mat v st- return (u,s,trans v)- where r = rows x- c = cols x- q = min r c----- | Singular values of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'N\'.-svR :: Matrix Double -> Vector Double-svR = svAux dgesvd "svR" . fmat---- | Singular values of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'N\'.-svC :: Matrix (Complex Double) -> Vector Double-svC = svAux zgesvd "svC" . fmat---- | Singular values of a real matrix, using LAPACK's /dgesdd/ with jobz == \'N\'.-svRd :: Matrix Double -> Vector Double-svRd = svAux dgesdd "svRd" . fmat---- | Singular values of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'N\'.-svCd :: Matrix (Complex Double) -> Vector Double-svCd = svAux zgesdd "svCd" . fmat--svAux f st x = unsafePerformIO $ do- s <- createVector q- app2 g mat x vec s st- return s- where r = rows x- c = cols x- q = min r c- g ra ca pa nb pb = f ra ca pa 0 0 nullPtr nb pb 0 0 nullPtr----- | Singular values and all right singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'N\' and jobvt == \'A\'.-rightSVR :: Matrix Double -> (Vector Double, Matrix Double)-rightSVR = rightSVAux dgesvd "rightSVR" . fmat---- | Singular values and all right singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'N\' and jobvt == \'A\'.-rightSVC :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))-rightSVC = rightSVAux zgesvd "rightSVC" . fmat--rightSVAux f st x = unsafePerformIO $ do- s <- createVector q- v <- createMatrix ColumnMajor c c- app3 g mat x vec s mat v st- return (s,trans v)- where r = rows x- c = cols x- q = min r c- g ra ca pa = f ra ca pa 0 0 nullPtr----- | Singular values and all left singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'A\' and jobvt == \'N\'.-leftSVR :: Matrix Double -> (Matrix Double, Vector Double)-leftSVR = leftSVAux dgesvd "leftSVR" . fmat---- | Singular values and all left singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'A\' and jobvt == \'N\'.-leftSVC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double)-leftSVC = leftSVAux zgesvd "leftSVC" . fmat--leftSVAux f st x = unsafePerformIO $ do- u <- createMatrix ColumnMajor r r- s <- createVector q- app3 g mat x mat u vec s st- return (u,s)- where r = rows x- c = cols x- q = min r c- g ra ca pa ru cu pu nb pb = f ra ca pa ru cu pu nb pb 0 0 nullPtr---------------------------------------------------------------------------------foreign import ccall unsafe "LAPACK/lapack-aux.h eig_l_R" dgeev :: TMMCVM-foreign import ccall unsafe "LAPACK/lapack-aux.h eig_l_C" zgeev :: TCMCMCVCM-foreign import ccall unsafe "LAPACK/lapack-aux.h eig_l_S" dsyev :: CInt -> TMVM-foreign import ccall unsafe "LAPACK/lapack-aux.h eig_l_H" zheev :: CInt -> TCMVCM--eigAux f st m = unsafePerformIO $ do- l <- createVector r- v <- createMatrix ColumnMajor r r- app3 g mat m vec l mat v st- return (l,v)- where r = rows m- g ra ca pa = f ra ca pa 0 0 nullPtr----- | Eigenvalues and right eigenvectors of a general complex matrix, using LAPACK's /zgeev/.--- The eigenvectors are the columns of v. The eigenvalues are not sorted.-eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double))-eigC = eigAux zgeev "eigC" . fmat--eigOnlyAux f st m = unsafePerformIO $ do- l <- createVector r- app2 g mat m vec l st- return l- where r = rows m- g ra ca pa nl pl = f ra ca pa 0 0 nullPtr nl pl 0 0 nullPtr---- | Eigenvalues of a general complex matrix, using LAPACK's /zgeev/ with jobz == \'N\'.--- The eigenvalues are not sorted.-eigOnlyC :: Matrix (Complex Double) -> Vector (Complex Double)-eigOnlyC = eigOnlyAux zgeev "eigOnlyC" . fmat---- | Eigenvalues and right eigenvectors of a general real matrix, using LAPACK's /dgeev/.--- The eigenvectors are the columns of v. The eigenvalues are not sorted.-eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double))-eigR m = (s', v'')- where (s,v) = eigRaux (fmat m)- s' = fixeig1 s- v' = toRows $ trans v- v'' = fromColumns $ fixeig (toList s') v'--eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double)-eigRaux m = unsafePerformIO $ do- l <- createVector r- v <- createMatrix ColumnMajor r r- app3 g mat m vec l mat v "eigR"- return (l,v)- where r = rows m- g ra ca pa = dgeev ra ca pa 0 0 nullPtr--fixeig1 s = toComplex' (subVector 0 r (asReal s), subVector r r (asReal s))- where r = dim s--fixeig [] _ = []-fixeig [_] [v] = [comp' v]-fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs)- | r1 == r2 && i1 == (-i2) = toComplex' (v1,v2) : toComplex' (v1,scale (-1) v2) : fixeig r vs- | otherwise = comp' v1 : fixeig ((r2:+i2):r) (v2:vs)- where scale = vectorMapValR Scale-fixeig _ _ = error "fixeig with impossible inputs"----- | Eigenvalues of a general real matrix, using LAPACK's /dgeev/ with jobz == \'N\'.--- The eigenvalues are not sorted.-eigOnlyR :: Matrix Double -> Vector (Complex Double)-eigOnlyR = fixeig1 . eigOnlyAux dgeev "eigOnlyR" . fmat----------------------------------------------------------------------------------eigSHAux f st m = unsafePerformIO $ do- l <- createVector r- v <- createMatrix ColumnMajor r r- app3 f mat m vec l mat v st- return (l,v)- where r = rows m---- | Eigenvalues and right eigenvectors of a symmetric real matrix, using LAPACK's /dsyev/.--- The eigenvectors are the columns of v.--- The eigenvalues are sorted in descending order (use 'eigS'' for ascending order).-eigS :: Matrix Double -> (Vector Double, Matrix Double)-eigS m = (s', fliprl v)- where (s,v) = eigS' (fmat m)- s' = fromList . reverse . toList $ s---- | 'eigS' in ascending order-eigS' :: Matrix Double -> (Vector Double, Matrix Double)-eigS' = eigSHAux (dsyev 1) "eigS'" . fmat---- | Eigenvalues and right eigenvectors of a hermitian complex matrix, using LAPACK's /zheev/.--- The eigenvectors are the columns of v.--- The eigenvalues are sorted in descending order (use 'eigH'' for ascending order).-eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))-eigH m = (s', fliprl v)- where (s,v) = eigH' (fmat m)- s' = fromList . reverse . toList $ s---- | 'eigH' in ascending order-eigH' :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))-eigH' = eigSHAux (zheev 1) "eigH'" . fmat----- | Eigenvalues of a symmetric real matrix, using LAPACK's /dsyev/ with jobz == \'N\'.--- The eigenvalues are sorted in descending order.-eigOnlyS :: Matrix Double -> Vector Double-eigOnlyS = vrev . fst. eigSHAux (dsyev 0) "eigS'" . fmat---- | Eigenvalues of a hermitian complex matrix, using LAPACK's /zheev/ with jobz == \'N\'.--- The eigenvalues are sorted in descending order.-eigOnlyH :: Matrix (Complex Double) -> Vector Double-eigOnlyH = vrev . fst. eigSHAux (zheev 1) "eigH'" . fmat--vrev = flatten . flipud . reshape 1--------------------------------------------------------------------------------foreign import ccall unsafe "linearSolveR_l" dgesv :: TMMM-foreign import ccall unsafe "linearSolveC_l" zgesv :: TCMCMCM-foreign import ccall unsafe "cholSolveR_l" dpotrs :: TMMM-foreign import ccall unsafe "cholSolveC_l" zpotrs :: TCMCMCM--linearSolveSQAux f st a b- | n1==n2 && n1==r = unsafePerformIO $ do- s <- createMatrix ColumnMajor r c- app3 f mat a mat b mat s st- return s- | otherwise = error $ st ++ " of nonsquare matrix"- where n1 = rows a- n2 = cols a- r = rows b- c = cols b---- | Solve a real linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /dgesv/. For underconstrained or overconstrained systems use 'linearSolveLSR' or 'linearSolveSVDR'. See also 'lusR'.-linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double-linearSolveR a b = linearSolveSQAux dgesv "linearSolveR" (fmat a) (fmat b)---- | Solve a complex linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /zgesv/. For underconstrained or overconstrained systems use 'linearSolveLSC' or 'linearSolveSVDC'. See also 'lusC'.-linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-linearSolveC a b = linearSolveSQAux zgesv "linearSolveC" (fmat a) (fmat b)----- | Solves a symmetric positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholS'.-cholSolveR :: Matrix Double -> Matrix Double -> Matrix Double-cholSolveR a b = linearSolveSQAux dpotrs "cholSolveR" (fmat a) (fmat b)---- | Solves a Hermitian positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholH'.-cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-cholSolveC a b = linearSolveSQAux zpotrs "cholSolveC" (fmat a) (fmat b)--------------------------------------------------------------------------------------foreign import ccall unsafe "LAPACK/lapack-aux.h linearSolveLSR_l" dgels :: TMMM-foreign import ccall unsafe "LAPACK/lapack-aux.h linearSolveLSC_l" zgels :: TCMCMCM-foreign import ccall unsafe "LAPACK/lapack-aux.h linearSolveSVDR_l" dgelss :: Double -> TMMM-foreign import ccall unsafe "LAPACK/lapack-aux.h linearSolveSVDC_l" zgelss :: Double -> TCMCMCM--linearSolveAux f st a b = unsafePerformIO $ do- r <- createMatrix ColumnMajor (max m n) nrhs- app3 f mat a mat b mat r st- return r- where m = rows a- n = cols a- nrhs = cols b---- | Least squared error solution of an overconstrained real linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /dgels/. For rank-deficient systems use 'linearSolveSVDR'.-linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double-linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux dgels "linearSolverLSR" (fmat a) (fmat b)---- | Least squared error solution of an overconstrained complex linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /zgels/. For rank-deficient systems use 'linearSolveSVDC'.-linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux zgels "linearSolveLSC" (fmat a) (fmat b)---- | Minimum norm solution of a general real linear least squares problem Ax=B using the SVD, based on LAPACK's /dgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSR'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.-linearSolveSVDR :: Maybe Double -- ^ rcond- -> Matrix Double -- ^ coefficient matrix- -> Matrix Double -- ^ right hand sides (as columns)- -> Matrix Double -- ^ solution vectors (as columns)-linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux (dgelss rcond) "linearSolveSVDR" (fmat a) (fmat b)-linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) (fmat a) (fmat b)---- | Minimum norm solution of a general complex linear least squares problem Ax=B using the SVD, based on LAPACK's /zgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSC'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.-linearSolveSVDC :: Maybe Double -- ^ rcond- -> Matrix (Complex Double) -- ^ coefficient matrix- -> Matrix (Complex Double) -- ^ right hand sides (as columns)- -> Matrix (Complex Double) -- ^ solution vectors (as columns)-linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux (zgelss rcond) "linearSolveSVDC" (fmat a) (fmat b)-linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) (fmat a) (fmat b)--------------------------------------------------------------------------------------foreign import ccall unsafe "LAPACK/lapack-aux.h chol_l_H" zpotrf :: TCMCM-foreign import ccall unsafe "LAPACK/lapack-aux.h chol_l_S" dpotrf :: TMM--cholAux f st a = do- r <- createMatrix ColumnMajor n n- app2 f mat a mat r st- return r- where n = rows a---- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/.-cholH :: Matrix (Complex Double) -> Matrix (Complex Double)-cholH = unsafePerformIO . cholAux zpotrf "cholH" . fmat---- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/.-cholS :: Matrix Double -> Matrix Double-cholS = unsafePerformIO . cholAux dpotrf "cholS" . fmat---- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/ ('Maybe' version).-mbCholH :: Matrix (Complex Double) -> Maybe (Matrix (Complex Double))-mbCholH = unsafePerformIO . mbCatch . cholAux zpotrf "cholH" . fmat---- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/ ('Maybe' version).-mbCholS :: Matrix Double -> Maybe (Matrix Double)-mbCholS = unsafePerformIO . mbCatch . cholAux dpotrf "cholS" . fmat--------------------------------------------------------------------------------------foreign import ccall unsafe "LAPACK/lapack-aux.h qr_l_R" dgeqr2 :: TMVM-foreign import ccall unsafe "LAPACK/lapack-aux.h qr_l_C" zgeqr2 :: TCMCVCM---- | QR factorization of a real matrix, using LAPACK's /dgeqr2/.-qrR :: Matrix Double -> (Matrix Double, Vector Double)-qrR = qrAux dgeqr2 "qrR" . fmat---- | QR factorization of a complex matrix, using LAPACK's /zgeqr2/.-qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))-qrC = qrAux zgeqr2 "qrC" . fmat--qrAux f st a = unsafePerformIO $ do- r <- createMatrix ColumnMajor m n- tau <- createVector mn- app3 f mat a vec tau mat r st- return (r,tau)- where m = rows a- n = cols a- mn = min m n--------------------------------------------------------------------------------------foreign import ccall unsafe "LAPACK/lapack-aux.h hess_l_R" dgehrd :: TMVM-foreign import ccall unsafe "LAPACK/lapack-aux.h hess_l_C" zgehrd :: TCMCVCM---- | Hessenberg factorization of a square real matrix, using LAPACK's /dgehrd/.-hessR :: Matrix Double -> (Matrix Double, Vector Double)-hessR = hessAux dgehrd "hessR" . fmat---- | Hessenberg factorization of a square complex matrix, using LAPACK's /zgehrd/.-hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))-hessC = hessAux zgehrd "hessC" . fmat--hessAux f st a = unsafePerformIO $ do- r <- createMatrix ColumnMajor m n- tau <- createVector (mn-1)- app3 f mat a vec tau mat r st- return (r,tau)- where m = rows a- n = cols a- mn = min m n--------------------------------------------------------------------------------------foreign import ccall unsafe "LAPACK/lapack-aux.h schur_l_R" dgees :: TMMM-foreign import ccall unsafe "LAPACK/lapack-aux.h schur_l_C" zgees :: TCMCMCM---- | Schur factorization of a square real matrix, using LAPACK's /dgees/.-schurR :: Matrix Double -> (Matrix Double, Matrix Double)-schurR = schurAux dgees "schurR" . fmat---- | Schur factorization of a square complex matrix, using LAPACK's /zgees/.-schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double))-schurC = schurAux zgees "schurC" . fmat--schurAux f st a = unsafePerformIO $ do- u <- createMatrix ColumnMajor n n- s <- createMatrix ColumnMajor n n- app3 f mat a mat u mat s st- return (u,s)- where n = rows a--------------------------------------------------------------------------------------foreign import ccall unsafe "LAPACK/lapack-aux.h lu_l_R" dgetrf :: TMVM-foreign import ccall unsafe "LAPACK/lapack-aux.h lu_l_C" zgetrf :: TCMVCM---- | LU factorization of a general real matrix, using LAPACK's /dgetrf/.-luR :: Matrix Double -> (Matrix Double, [Int])-luR = luAux dgetrf "luR" . fmat---- | LU factorization of a general complex matrix, using LAPACK's /zgetrf/.-luC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int])-luC = luAux zgetrf "luC" . fmat--luAux f st a = unsafePerformIO $ do- lu <- createMatrix ColumnMajor n m- piv <- createVector (min n m)- app3 f mat a vec piv mat lu st- return (lu, map (pred.round) (toList piv))- where n = rows a- m = cols a--------------------------------------------------------------------------------------type TW a = CInt -> PD -> a-type TQ a = CInt -> CInt -> PC -> a--foreign import ccall unsafe "LAPACK/lapack-aux.h luS_l_R" dgetrs :: TMVMM-foreign import ccall unsafe "LAPACK/lapack-aux.h luS_l_C" zgetrs :: TQ (TW (TQ (TQ (IO CInt))))---- | Solve a real linear system from a precomputed LU decomposition ('luR'), using LAPACK's /dgetrs/.-lusR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double-lusR a piv b = lusAux dgetrs "lusR" (fmat a) piv (fmat b)---- | Solve a real linear system from a precomputed LU decomposition ('luC'), using LAPACK's /zgetrs/.-lusC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double)-lusC a piv b = lusAux zgetrs "lusC" (fmat a) piv (fmat b)--lusAux f st a piv b- | n1==n2 && n2==n =unsafePerformIO $ do- x <- createMatrix ColumnMajor n m- app4 f mat a vec piv' mat b mat x st- return x- | otherwise = error $ st ++ " on LU factorization of nonsquare matrix"- where n1 = rows a- n2 = cols a- n = rows b- m = cols b- piv' = fromList (map (fromIntegral.succ) piv) :: Vector Double
− lib/Numeric/LinearAlgebra/LAPACK/clapack.h
@@ -1,5079 +0,0 @@-#ifndef __CLAPACK_H-#define __CLAPACK_H- -/* Subroutine */ int cbdsqr_(char *uplo, integer *n, integer *ncvt, integer *- nru, integer *ncc, real *d__, real *e, complex *vt, integer *ldvt, - complex *u, integer *ldu, complex *c__, integer *ldc, real *rwork, - integer *info);- -/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,- integer *kl, integer *ku, complex *ab, integer *ldab, real *d__, - real *e, complex *q, integer *ldq, complex *pt, integer *ldpt, - complex *c__, integer *ldc, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgbcon_(char *norm, integer *n, integer *kl, integer *ku,- complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgbequ_(integer *m, integer *n, integer *kl, integer *ku,- complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real - *colcnd, real *amax, integer *info);- -/* Subroutine */ int cgbrfs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *- ldafb, integer *ipiv, complex *b, integer *ldb, complex *x, integer *- ldx, real *ferr, real *berr, complex *work, real *rwork, integer *- info);- -/* Subroutine */ int cgbsv_(integer *n, integer *kl, integer *ku, integer *- nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer *- ldb, integer *info);- -/* Subroutine */ int cgbsvx_(char *fact, char *trans, integer *n, integer *kl,- integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb,- integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, - complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real - *ferr, real *berr, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgbtf2_(integer *m, integer *n, integer *kl, integer *ku,- complex *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int cgbtrf_(integer *m, integer *n, integer *kl, integer *ku,- complex *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int cgbtrs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex - *b, integer *ldb, integer *info);- -/* Subroutine */ int cgebak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, real *scale, integer *m, complex *v, integer *ldv, - integer *info);- -/* Subroutine */ int cgebal_(char *job, integer *n, complex *a, integer *lda, - integer *ilo, integer *ihi, real *scale, integer *info);- -/* Subroutine */ int cgebd2_(integer *m, integer *n, complex *a, integer *lda,- real *d__, real *e, complex *tauq, complex *taup, complex *work, - integer *info);- -/* Subroutine */ int cgebrd_(integer *m, integer *n, complex *a, integer *lda,- real *d__, real *e, complex *tauq, complex *taup, complex *work, - integer *lwork, integer *info);- -/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda,- real *anorm, real *rcond, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgeequ_(integer *m, integer *n, complex *a, integer *lda,- real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, - integer *info);- -/* Subroutine */ int cgees_(char *jobvs, char *sort, L_fp select, integer *n, - complex *a, integer *lda, integer *sdim, complex *w, complex *vs, - integer *ldvs, complex *work, integer *lwork, real *rwork, logical *- bwork, integer *info);- -/* Subroutine */ int cgeesx_(char *jobvs, char *sort, L_fp select, char *- sense, integer *n, complex *a, integer *lda, integer *sdim, complex *- w, complex *vs, integer *ldvs, real *rconde, real *rcondv, complex *- work, integer *lwork, real *rwork, logical *bwork, integer *info);- -/* Subroutine */ int cgeev_(char *jobvl, char *jobvr, integer *n, complex *a, - integer *lda, complex *w, complex *vl, integer *ldvl, complex *vr, - integer *ldvr, complex *work, integer *lwork, real *rwork, integer *- info);- -/* Subroutine */ int cgeevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, complex *a, integer *lda, complex *w, complex *vl, - integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi,- real *scale, real *abnrm, real *rconde, real *rcondv, complex *work, - integer *lwork, real *rwork, integer *info);- -/* Subroutine */ int cgegs_(char *jobvsl, char *jobvsr, integer *n, complex *- a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *- beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr, - complex *work, integer *lwork, real *rwork, integer *info);- -/* Subroutine */ int cgegv_(char *jobvl, char *jobvr, integer *n, complex *a, - integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,- complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *- work, integer *lwork, real *rwork, integer *info);- -/* Subroutine */ int cgehd2_(integer *n, integer *ilo, integer *ihi, complex *- a, integer *lda, complex *tau, complex *work, integer *info);- -/* Subroutine */ int cgehrd_(integer *n, integer *ilo, integer *ihi, complex *- a, integer *lda, complex *tau, complex *work, integer *lwork, integer - *info);- -/* Subroutine */ int cgelq2_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *info);- -/* Subroutine */ int cgelqf_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cgels_(char *trans, integer *m, integer *n, integer *- nrhs, complex *a, integer *lda, complex *b, integer *ldb, complex *- work, integer *lwork, integer *info);- -/* Subroutine */ int cgelsx_(integer *m, integer *n, integer *nrhs, complex *- a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,- integer *rank, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgelsy_(integer *m, integer *n, integer *nrhs, complex *- a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,- integer *rank, complex *work, integer *lwork, real *rwork, integer *- info);- -/* Subroutine */ int cgeql2_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *info);- -/* Subroutine */ int cgeqlf_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cgeqp3_(integer *m, integer *n, complex *a, integer *lda,- integer *jpvt, complex *tau, complex *work, integer *lwork, real *- rwork, integer *info);- -/* Subroutine */ int cgeqpf_(integer *m, integer *n, complex *a, integer *lda,- integer *jpvt, complex *tau, complex *work, real *rwork, integer *- info);- -/* Subroutine */ int cgeqr2_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *info);- -/* Subroutine */ int cgeqrf_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cgerfs_(char *trans, integer *n, integer *nrhs, complex *- a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *- b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgerq2_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *info);- -/* Subroutine */ int cgerqf_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cgesc2_(integer *n, complex *a, integer *lda, complex *- rhs, integer *ipiv, integer *jpiv, real *scale);- -/* Subroutine */ int cgesv_(integer *n, integer *nrhs, complex *a, integer *- lda, integer *ipiv, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cgesvx_(char *fact, char *trans, integer *n, integer *- nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *- ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb, - complex *x, integer *ldx, real *rcond, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgetc2_(integer *n, complex *a, integer *lda, integer *- ipiv, integer *jpiv, integer *info);- -/* Subroutine */ int cgetf2_(integer *m, integer *n, complex *a, integer *lda,- integer *ipiv, integer *info);- -/* Subroutine */ int cgetrf_(integer *m, integer *n, complex *a, integer *lda,- integer *ipiv, integer *info);- -/* Subroutine */ int cgetri_(integer *n, complex *a, integer *lda, integer *- ipiv, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cgetrs_(char *trans, integer *n, integer *nrhs, complex *- a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *- info);- -/* Subroutine */ int cggbak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, real *lscale, real *rscale, integer *m, complex *v, - integer *ldv, integer *info);- -/* Subroutine */ int cggbal_(char *job, integer *n, complex *a, integer *lda, - complex *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, - real *rscale, real *work, integer *info);- -/* Subroutine */ int cgges_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, integer *n, complex *a, integer *lda, complex *b, integer *- ldb, integer *sdim, complex *alpha, complex *beta, complex *vsl, - integer *ldvsl, complex *vsr, integer *ldvsr, complex *work, integer *- lwork, real *rwork, logical *bwork, integer *info);- -/* Subroutine */ int cggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, char *sense, integer *n, complex *a, integer *lda, complex *b,- integer *ldb, integer *sdim, complex *alpha, complex *beta, complex *- vsl, integer *ldvsl, complex *vsr, integer *ldvsr, real *rconde, real - *rcondv, complex *work, integer *lwork, real *rwork, integer *iwork, - integer *liwork, logical *bwork, integer *info);- -/* Subroutine */ int cggev_(char *jobvl, char *jobvr, integer *n, complex *a, - integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,- complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *- work, integer *lwork, real *rwork, integer *info);- -/* Subroutine */ int cggevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, complex *a, integer *lda, complex *b, integer *ldb,- complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *- vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *- rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, complex - *work, integer *lwork, real *rwork, integer *iwork, logical *bwork, - integer *info);- -/* Subroutine */ int cggglm_(integer *n, integer *m, integer *p, complex *a, - integer *lda, complex *b, integer *ldb, complex *d__, complex *x, - complex *y, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cgghrd_(char *compq, char *compz, integer *n, integer *- ilo, integer *ihi, complex *a, integer *lda, complex *b, integer *ldb,- complex *q, integer *ldq, complex *z__, integer *ldz, integer *info);- -/* Subroutine */ int cgglse_(integer *m, integer *n, integer *p, complex *a, - integer *lda, complex *b, integer *ldb, complex *c__, complex *d__, - complex *x, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cggqrf_(integer *n, integer *m, integer *p, complex *a, - integer *lda, complex *taua, complex *b, integer *ldb, complex *taub, - complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cggrqf_(integer *m, integer *p, integer *n, complex *a, - integer *lda, complex *taua, complex *b, integer *ldb, complex *taub, - complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cggsvd_(char *jobu, char *jobv, char *jobq, integer *m, - integer *n, integer *p, integer *k, integer *l, complex *a, integer *- lda, complex *b, integer *ldb, real *alpha, real *beta, complex *u, - integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, - complex *work, real *rwork, integer *iwork, integer *info);- -/* Subroutine */ int cggsvp_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, complex *a, integer *lda, complex *b, integer - *ldb, real *tola, real *tolb, integer *k, integer *l, complex *u, - integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, - integer *iwork, real *rwork, complex *tau, complex *work, integer *- info);- -/* Subroutine */ int cgtcon_(char *norm, integer *n, complex *dl, complex *- d__, complex *du, complex *du2, integer *ipiv, real *anorm, real *- rcond, complex *work, integer *info);- -/* Subroutine */ int cgtrfs_(char *trans, integer *n, integer *nrhs, complex *- dl, complex *d__, complex *du, complex *dlf, complex *df, complex *- duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *- x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int cgtsv_(integer *n, integer *nrhs, complex *dl, complex *- d__, complex *du, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cgtsvx_(char *fact, char *trans, integer *n, integer *- nrhs, complex *dl, complex *d__, complex *du, complex *dlf, complex *- df, complex *duf, complex *du2, integer *ipiv, complex *b, integer *- ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int cgttrf_(integer *n, complex *dl, complex *d__, complex *- du, complex *du2, integer *ipiv, integer *info);- -/* Subroutine */ int cgttrs_(char *trans, integer *n, integer *nrhs, complex *- dl, complex *d__, complex *du, complex *du2, integer *ipiv, complex *- b, integer *ldb, integer *info);- -/* Subroutine */ int cgtts2_(integer *itrans, integer *n, integer *nrhs, - complex *dl, complex *d__, complex *du, complex *du2, integer *ipiv, - complex *b, integer *ldb);- -/* Subroutine */ int chbev_(char *jobz, char *uplo, integer *n, integer *kd, - complex *ab, integer *ldab, real *w, complex *z__, integer *ldz, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int chbevd_(char *jobz, char *uplo, integer *n, integer *kd, - complex *ab, integer *ldab, real *w, complex *z__, integer *ldz, - complex *work, integer *lwork, real *rwork, integer *lrwork, integer *- iwork, integer *liwork, integer *info);- -/* Subroutine */ int chbevx_(char *jobz, char *range, char *uplo, integer *n, - integer *kd, complex *ab, integer *ldab, complex *q, integer *ldq, - real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *- m, real *w, complex *z__, integer *ldz, complex *work, real *rwork, - integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int chbgst_(char *vect, char *uplo, integer *n, integer *ka, - integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, - complex *x, integer *ldx, complex *work, real *rwork, integer *info);- -/* Subroutine */ int chbgv_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, - real *w, complex *z__, integer *ldz, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int chbgvx_(char *jobz, char *range, char *uplo, integer *n, - integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, - integer *ldbb, complex *q, integer *ldq, real *vl, real *vu, integer *- il, integer *iu, real *abstol, integer *m, real *w, complex *z__, - integer *ldz, complex *work, real *rwork, integer *iwork, integer *- ifail, integer *info);- -/* Subroutine */ int chbtrd_(char *vect, char *uplo, integer *n, integer *kd, - complex *ab, integer *ldab, real *d__, real *e, complex *q, integer *- ldq, complex *work, integer *info);- -/* Subroutine */ int checon_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, real *anorm, real *rcond, complex *work, integer *- info);- -/* Subroutine */ int cheev_(char *jobz, char *uplo, integer *n, complex *a, - integer *lda, real *w, complex *work, integer *lwork, real *rwork, - integer *info);- -/* Subroutine */ int cheevd_(char *jobz, char *uplo, integer *n, complex *a, - integer *lda, real *w, complex *work, integer *lwork, real *rwork, - integer *lrwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int cheevr_(char *jobz, char *range, char *uplo, integer *n, - complex *a, integer *lda, real *vl, real *vu, integer *il, integer *- iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz, - integer *isuppz, complex *work, integer *lwork, real *rwork, integer *- lrwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int cheevx_(char *jobz, char *range, char *uplo, integer *n, - complex *a, integer *lda, real *vl, real *vu, integer *il, integer *- iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz, - complex *work, integer *lwork, real *rwork, integer *iwork, integer *- ifail, integer *info);- -/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *- a, integer *lda, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int chegst_(integer *itype, char *uplo, integer *n, complex *- a, integer *lda, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int chegv_(integer *itype, char *jobz, char *uplo, integer *- n, complex *a, integer *lda, complex *b, integer *ldb, real *w, - complex *work, integer *lwork, real *rwork, integer *info);- -/* Subroutine */ int chegvd_(integer *itype, char *jobz, char *uplo, integer *- n, complex *a, integer *lda, complex *b, integer *ldb, real *w, - complex *work, integer *lwork, real *rwork, integer *lrwork, integer *- iwork, integer *liwork, integer *info);- -/* Subroutine */ int chegvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb, - real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *- m, real *w, complex *z__, integer *ldz, complex *work, integer *lwork,- real *rwork, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int cherfs_(char *uplo, integer *n, integer *nrhs, complex *- a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *- b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int chesv_(char *uplo, integer *n, integer *nrhs, complex *a,- integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work,- integer *lwork, integer *info);- -/* Subroutine */ int chesvx_(char *fact, char *uplo, integer *n, integer *- nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *- ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,- real *ferr, real *berr, complex *work, integer *lwork, real *rwork, - integer *info);- -/* Subroutine */ int chetf2_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, integer *info);- -/* Subroutine */ int chetrd_(char *uplo, integer *n, complex *a, integer *lda,- real *d__, real *e, complex *tau, complex *work, integer *lwork, - integer *info);- -/* Subroutine */ int chetrf_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int chetri_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, complex *work, integer *info);- -/* Subroutine */ int chetrs_(char *uplo, integer *n, integer *nrhs, complex *- a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *- info);- -/* Subroutine */ int chgeqz_(char *job, char *compq, char *compz, integer *n, - integer *ilo, integer *ihi, complex *a, integer *lda, complex *b, - integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq,- complex *z__, integer *ldz, complex *work, integer *lwork, real *- rwork, integer *info);- -/* Subroutine */ int chpcon_(char *uplo, integer *n, complex *ap, integer *- ipiv, real *anorm, real *rcond, complex *work, integer *info);- -/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap, - real *w, complex *z__, integer *ldz, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int chpevd_(char *jobz, char *uplo, integer *n, complex *ap, - real *w, complex *z__, integer *ldz, complex *work, integer *lwork, - real *rwork, integer *lrwork, integer *iwork, integer *liwork, - integer *info);- -/* Subroutine */ int chpevx_(char *jobz, char *range, char *uplo, integer *n, - complex *ap, real *vl, real *vu, integer *il, integer *iu, real *- abstol, integer *m, real *w, complex *z__, integer *ldz, complex *- work, real *rwork, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex *- ap, complex *bp, integer *info);- -/* Subroutine */ int chpgv_(integer *itype, char *jobz, char *uplo, integer *- n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int chpgvd_(integer *itype, char *jobz, char *uplo, integer *- n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz, - complex *work, integer *lwork, real *rwork, integer *lrwork, integer *- iwork, integer *liwork, integer *info);- -/* Subroutine */ int chpgvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, complex *ap, complex *bp, real *vl, real *vu, - integer *il, integer *iu, real *abstol, integer *m, real *w, complex *- z__, integer *ldz, complex *work, real *rwork, integer *iwork, - integer *ifail, integer *info);- -/* Subroutine */ int chprfs_(char *uplo, integer *n, integer *nrhs, complex *- ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,- integer *ldx, real *ferr, real *berr, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int chpsv_(char *uplo, integer *n, integer *nrhs, complex *- ap, integer *ipiv, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int chpsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *- ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int chptrd_(char *uplo, integer *n, complex *ap, real *d__, - real *e, complex *tau, integer *info);- -/* Subroutine */ int chptrf_(char *uplo, integer *n, complex *ap, integer *- ipiv, integer *info);- -/* Subroutine */ int chptri_(char *uplo, integer *n, complex *ap, integer *- ipiv, complex *work, integer *info);- -/* Subroutine */ int chptrs_(char *uplo, integer *n, integer *nrhs, complex *- ap, integer *ipiv, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int chsein_(char *side, char *eigsrc, char *initv, logical *- select, integer *n, complex *h__, integer *ldh, complex *w, complex *- vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *- m, complex *work, real *rwork, integer *ifaill, integer *ifailr, - integer *info);- -/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,- integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__, - integer *ldz, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int clabrd_(integer *m, integer *n, integer *nb, complex *a, - integer *lda, real *d__, real *e, complex *tauq, complex *taup, - complex *x, integer *ldx, complex *y, integer *ldy);- -/* Subroutine */ int clacgv_(integer *n, complex *x, integer *incx);- -/* Subroutine */ int clacon_(integer *n, complex *v, complex *x, real *est, - integer *kase);- -/* Subroutine */ int clacp2_(char *uplo, integer *m, integer *n, real *a, - integer *lda, complex *b, integer *ldb);- -/* Subroutine */ int clacpy_(char *uplo, integer *m, integer *n, complex *a, - integer *lda, complex *b, integer *ldb);- -/* Subroutine */ int clacrm_(integer *m, integer *n, complex *a, integer *lda,- real *b, integer *ldb, complex *c__, integer *ldc, real *rwork);- -/* Subroutine */ int clacrt_(integer *n, complex *cx, integer *incx, complex *- cy, integer *incy, complex *c__, complex *s);- -/* Subroutine */ int claed0_(integer *qsiz, integer *n, real *d__, real *e, - complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork,- integer *iwork, integer *info);- -/* Subroutine */ int claed7_(integer *n, integer *cutpnt, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, real *d__, complex *- q, integer *ldq, real *rho, integer *indxq, real *qstore, integer *- qptr, integer *prmptr, integer *perm, integer *givptr, integer *- givcol, real *givnum, complex *work, real *rwork, integer *iwork, - integer *info);- -/* Subroutine */ int claed8_(integer *k, integer *n, integer *qsiz, complex *- q, integer *ldq, real *d__, real *rho, integer *cutpnt, real *z__, - real *dlamda, complex *q2, integer *ldq2, real *w, integer *indxp, - integer *indx, integer *indxq, integer *perm, integer *givptr, - integer *givcol, real *givnum, integer *info);- -/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n, - complex *h__, integer *ldh, complex *w, complex *v, complex *b, - integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info);- -/* Subroutine */ int claesy_(complex *a, complex *b, complex *c__, complex *- rt1, complex *rt2, complex *evscal, complex *cs1, complex *sn1);- -/* Subroutine */ int claev2_(complex *a, complex *b, complex *c__, real *rt1, - real *rt2, real *cs1, complex *sn1);- -/* Subroutine */ int clags2_(logical *upper, real *a1, complex *a2, real *a3, - real *b1, complex *b2, real *b3, real *csu, complex *snu, real *csv, - complex *snv, real *csq, complex *snq);- -/* Subroutine */ int clagtm_(char *trans, integer *n, integer *nrhs, real *- alpha, complex *dl, complex *d__, complex *du, complex *x, integer *- ldx, real *beta, complex *b, integer *ldb);- -/* Subroutine */ int clahef_(char *uplo, integer *n, integer *nb, integer *kb,- complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw, - integer *info);- -/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w, - integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *- info);- -/* Subroutine */ int clahrd_(integer *n, integer *k, integer *nb, complex *a, - integer *lda, complex *tau, complex *t, integer *ldt, complex *y, - integer *ldy);- -/* Subroutine */ int claic1_(integer *job, integer *j, complex *x, real *sest,- complex *w, complex *gamma, real *sestpr, complex *s, complex *c__);- -/* Subroutine */ int clals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, complex *b, integer *ldb, complex *bx, - integer *ldbx, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *- difl, real *difr, real *z__, integer *k, real *c__, real *s, real *- rwork, integer *info);- -/* Subroutine */ int clalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, complex *b, integer *ldb, complex *bx, integer *ldbx, - real *u, integer *ldu, real *vt, integer *k, real *difl, real *difr, - real *z__, real *poles, integer *givptr, integer *givcol, integer *- ldgcol, integer *perm, real *givnum, real *c__, real *s, real *rwork, - integer *iwork, integer *info);- -/* Subroutine */ int clapll_(integer *n, complex *x, integer *incx, complex *- y, integer *incy, real *ssmin);- -/* Subroutine */ int clapmt_(logical *forwrd, integer *m, integer *n, complex - *x, integer *ldx, integer *k);- -/* Subroutine */ int claqgb_(integer *m, integer *n, integer *kl, integer *ku,- complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real - *colcnd, real *amax, char *equed);- -/* Subroutine */ int claqge_(integer *m, integer *n, complex *a, integer *lda,- real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char *- equed);- -/* Subroutine */ int claqhb_(char *uplo, integer *n, integer *kd, complex *ab,- integer *ldab, real *s, real *scond, real *amax, char *equed);- -/* Subroutine */ int claqhe_(char *uplo, integer *n, complex *a, integer *lda,- real *s, real *scond, real *amax, char *equed);- -/* Subroutine */ int claqhp_(char *uplo, integer *n, complex *ap, real *s, - real *scond, real *amax, char *equed);- -/* Subroutine */ int claqp2_(integer *m, integer *n, integer *offset, complex - *a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2, - complex *work);- -/* Subroutine */ int claqps_(integer *m, integer *n, integer *offset, integer - *nb, integer *kb, complex *a, integer *lda, integer *jpvt, complex *- tau, real *vn1, real *vn2, complex *auxv, complex *f, integer *ldf);- -/* Subroutine */ int claqsb_(char *uplo, integer *n, integer *kd, complex *ab,- integer *ldab, real *s, real *scond, real *amax, char *equed);- -/* Subroutine */ int claqsp_(char *uplo, integer *n, complex *ap, real *s, - real *scond, real *amax, char *equed);- -/* Subroutine */ int claqsy_(char *uplo, integer *n, complex *a, integer *lda,- real *s, real *scond, real *amax, char *equed);- -/* Subroutine */ int clar1v_(integer *n, integer *b1, integer *bn, real *- sigma, real *d__, real *l, real *ld, real *lld, real *gersch, complex - *z__, real *ztz, real *mingma, integer *r__, integer *isuppz, real *- work);- -/* Subroutine */ int clar2v_(integer *n, complex *x, complex *y, complex *z__,- integer *incx, real *c__, complex *s, integer *incc);- -/* Subroutine */ int clarcm_(integer *m, integer *n, real *a, integer *lda, - complex *b, integer *ldb, complex *c__, integer *ldc, real *rwork);- -/* Subroutine */ int clarf_(char *side, integer *m, integer *n, complex *v, - integer *incv, complex *tau, complex *c__, integer *ldc, complex *- work);- -/* Subroutine */ int clarfb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, complex *v, integer *ldv, - complex *t, integer *ldt, complex *c__, integer *ldc, complex *work, - integer *ldwork);- -/* Subroutine */ int clarfg_(integer *n, complex *alpha, complex *x, integer *- incx, complex *tau);- -/* Subroutine */ int clarft_(char *direct, char *storev, integer *n, integer *- k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt);- -/* Subroutine */ int clarfx_(char *side, integer *m, integer *n, complex *v, - complex *tau, complex *c__, integer *ldc, complex *work);- -/* Subroutine */ int clargv_(integer *n, complex *x, integer *incx, complex *- y, integer *incy, real *c__, integer *incc);- -/* Subroutine */ int clarnv_(integer *idist, integer *iseed, integer *n, - complex *x);- -/* Subroutine */ int clarrv_(integer *n, real *d__, real *l, integer *isplit, - integer *m, real *w, integer *iblock, real *gersch, real *tol, - complex *z__, integer *ldz, integer *isuppz, real *work, integer *- iwork, integer *info);- -/* Subroutine */ int clartg_(complex *f, complex *g, real *cs, complex *sn, - complex *r__);- -/* Subroutine */ int clartv_(integer *n, complex *x, integer *incx, complex *- y, integer *incy, real *c__, complex *s, integer *incc);- -/* Subroutine */ int clarz_(char *side, integer *m, integer *n, integer *l, - complex *v, integer *incv, complex *tau, complex *c__, integer *ldc, - complex *work);- -/* Subroutine */ int clarzb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, integer *l, complex *v, - integer *ldv, complex *t, integer *ldt, complex *c__, integer *ldc, - complex *work, integer *ldwork);- -/* Subroutine */ int clarzt_(char *direct, char *storev, integer *n, integer *- k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt);- -/* Subroutine */ int clascl_(char *type__, integer *kl, integer *ku, real *- cfrom, real *cto, integer *m, integer *n, complex *a, integer *lda, - integer *info);- -/* Subroutine */ int claset_(char *uplo, integer *m, integer *n, complex *- alpha, complex *beta, complex *a, integer *lda);- -/* Subroutine */ int clasr_(char *side, char *pivot, char *direct, integer *m,- integer *n, real *c__, real *s, complex *a, integer *lda);- -/* Subroutine */ int classq_(integer *n, complex *x, integer *incx, real *- scale, real *sumsq);- -/* Subroutine */ int claswp_(integer *n, complex *a, integer *lda, integer *- k1, integer *k2, integer *ipiv, integer *incx);- -/* Subroutine */ int clasyf_(char *uplo, integer *n, integer *nb, integer *kb,- complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw, - integer *info);- -/* Subroutine */ int clatbs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, integer *kd, complex *ab, integer *ldab, complex *- x, real *scale, real *cnorm, integer *info);- -/* Subroutine */ int clatdf_(integer *ijob, integer *n, complex *z__, integer - *ldz, complex *rhs, real *rdsum, real *rdscal, integer *ipiv, integer - *jpiv);- -/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char *- normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm,- integer *info);- -/* Subroutine */ int clatrd_(char *uplo, integer *n, integer *nb, complex *a, - integer *lda, real *e, complex *tau, complex *w, integer *ldw);- -/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, complex *a, integer *lda, complex *x, real *scale,- real *cnorm, integer *info);- -/* Subroutine */ int clatrz_(integer *m, integer *n, integer *l, complex *a, - integer *lda, complex *tau, complex *work);- -/* Subroutine */ int clatzm_(char *side, integer *m, integer *n, complex *v, - integer *incv, complex *tau, complex *c1, complex *c2, integer *ldc, - complex *work);- -/* Subroutine */ int clauu2_(char *uplo, integer *n, complex *a, integer *lda,- integer *info);- -/* Subroutine */ int clauum_(char *uplo, integer *n, complex *a, integer *lda,- integer *info);- -/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab,- integer *ldab, real *anorm, real *rcond, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int cpbequ_(char *uplo, integer *n, integer *kd, complex *ab,- integer *ldab, real *s, real *scond, real *amax, integer *info);- -/* Subroutine */ int cpbrfs_(char *uplo, integer *n, integer *kd, integer *- nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, - complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *- berr, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cpbstf_(char *uplo, integer *n, integer *kd, complex *ab,- integer *ldab, integer *info);- -/* Subroutine */ int cpbsv_(char *uplo, integer *n, integer *kd, integer *- nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *- info);- -/* Subroutine */ int cpbsvx_(char *fact, char *uplo, integer *n, integer *kd, - integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *- ldafb, char *equed, real *s, complex *b, integer *ldb, complex *x, - integer *ldx, real *rcond, real *ferr, real *berr, complex *work, - real *rwork, integer *info);- -/* Subroutine */ int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab,- integer *ldab, integer *info);- -/* Subroutine */ int cpbtrf_(char *uplo, integer *n, integer *kd, complex *ab,- integer *ldab, integer *info);- -/* Subroutine */ int cpbtrs_(char *uplo, integer *n, integer *kd, integer *- nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *- info);- -/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda,- real *anorm, real *rcond, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cpoequ_(integer *n, complex *a, integer *lda, real *s, - real *scond, real *amax, integer *info);- -/* Subroutine */ int cporfs_(char *uplo, integer *n, integer *nrhs, complex *- a, integer *lda, complex *af, integer *ldaf, complex *b, integer *ldb,- complex *x, integer *ldx, real *ferr, real *berr, complex *work, - real *rwork, integer *info);- -/* Subroutine */ int cposv_(char *uplo, integer *n, integer *nrhs, complex *a,- integer *lda, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cposvx_(char *fact, char *uplo, integer *n, integer *- nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *- equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, - real *rcond, real *ferr, real *berr, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int cpotf2_(char *uplo, integer *n, complex *a, integer *lda,- integer *info);- -/* Subroutine */ int cpotrf_(char *uplo, integer *n, complex *a, integer *lda,- integer *info);- -/* Subroutine */ int cpotri_(char *uplo, integer *n, complex *a, integer *lda,- integer *info);- -/* Subroutine */ int cpotrs_(char *uplo, integer *n, integer *nrhs, complex *- a, integer *lda, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cppcon_(char *uplo, integer *n, complex *ap, real *anorm,- real *rcond, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cppequ_(char *uplo, integer *n, complex *ap, real *s, - real *scond, real *amax, integer *info);- -/* Subroutine */ int cpprfs_(char *uplo, integer *n, integer *nrhs, complex *- ap, complex *afp, complex *b, integer *ldb, complex *x, integer *ldx, - real *ferr, real *berr, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cppsv_(char *uplo, integer *n, integer *nrhs, complex *- ap, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cppsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b, - integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real - *berr, complex *work, real *rwork, integer *info);- -/* Subroutine */ int cpptrf_(char *uplo, integer *n, complex *ap, integer *- info);- -/* Subroutine */ int cpptri_(char *uplo, integer *n, complex *ap, integer *- info);- -/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex *- ap, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cptcon_(integer *n, real *d__, complex *e, real *anorm, - real *rcond, real *rwork, integer *info);- -/* Subroutine */ int cptrfs_(char *uplo, integer *n, integer *nrhs, real *d__,- complex *e, real *df, complex *ef, complex *b, integer *ldb, complex - *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int cptsv_(integer *n, integer *nrhs, real *d__, complex *e, - complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cptsvx_(char *fact, integer *n, integer *nrhs, real *d__,- complex *e, real *df, complex *ef, complex *b, integer *ldb, complex - *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, - real *rwork, integer *info);- -/* Subroutine */ int cpttrf_(integer *n, real *d__, complex *e, integer *info);- -/* Subroutine */ int cpttrs_(char *uplo, integer *n, integer *nrhs, real *d__,- complex *e, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cptts2_(integer *iuplo, integer *n, integer *nrhs, real *- d__, complex *e, complex *b, integer *ldb);- -/* Subroutine */ int crot_(integer *n, complex *cx, integer *incx, complex *- cy, integer *incy, real *c__, complex *s);- -/* Subroutine */ int cspcon_(char *uplo, integer *n, complex *ap, integer *- ipiv, real *anorm, real *rcond, complex *work, integer *info);- -/* Subroutine */ int cspmv_(char *uplo, integer *n, complex *alpha, complex *- ap, complex *x, integer *incx, complex *beta, complex *y, integer *- incy);- -/* Subroutine */ int cspr_(char *uplo, integer *n, complex *alpha, complex *x,- integer *incx, complex *ap);- -/* Subroutine */ int csprfs_(char *uplo, integer *n, integer *nrhs, complex *- ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,- integer *ldx, real *ferr, real *berr, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int cspsv_(char *uplo, integer *n, integer *nrhs, complex *- ap, integer *ipiv, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int cspsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *- ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int csptrf_(char *uplo, integer *n, complex *ap, integer *- ipiv, integer *info);- -/* Subroutine */ int csptri_(char *uplo, integer *n, complex *ap, integer *- ipiv, complex *work, integer *info);- -/* Subroutine */ int csptrs_(char *uplo, integer *n, integer *nrhs, complex *- ap, integer *ipiv, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int csrot_(integer *n, complex *cx, integer *incx, complex *- cy, integer *incy, real *c__, real *s);- -/* Subroutine */ int csrscl_(integer *n, real *sa, complex *sx, integer *incx);- -/* Subroutine */ int cstedc_(char *compz, integer *n, real *d__, real *e, - complex *z__, integer *ldz, complex *work, integer *lwork, real *- rwork, integer *lrwork, integer *iwork, integer *liwork, integer *- info);- -/* Subroutine */ int cstein_(integer *n, real *d__, real *e, integer *m, real - *w, integer *iblock, integer *isplit, complex *z__, integer *ldz, - real *work, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int csteqr_(char *compz, integer *n, real *d__, real *e, - complex *z__, integer *ldz, real *work, integer *info);- -/* Subroutine */ int csycon_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, real *anorm, real *rcond, complex *work, integer *- info);- -/* Subroutine */ int csymv_(char *uplo, integer *n, complex *alpha, complex *- a, integer *lda, complex *x, integer *incx, complex *beta, complex *y,- integer *incy);- -/* Subroutine */ int csyr_(char *uplo, integer *n, complex *alpha, complex *x,- integer *incx, complex *a, integer *lda);- -/* Subroutine */ int csyrfs_(char *uplo, integer *n, integer *nrhs, complex *- a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *- b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int csysv_(char *uplo, integer *n, integer *nrhs, complex *a,- integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work,- integer *lwork, integer *info);- -/* Subroutine */ int csysvx_(char *fact, char *uplo, integer *n, integer *- nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *- ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,- real *ferr, real *berr, complex *work, integer *lwork, real *rwork, - integer *info);- -/* Subroutine */ int csytf2_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, integer *info);- -/* Subroutine */ int csytrf_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int csytri_(char *uplo, integer *n, complex *a, integer *lda,- integer *ipiv, complex *work, integer *info);- -/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex *- a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *- info);- -/* Subroutine */ int ctbcon_(char *norm, char *uplo, char *diag, integer *n, - integer *kd, complex *ab, integer *ldab, real *rcond, complex *work, - real *rwork, integer *info);- -/* Subroutine */ int ctbrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b, - integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, - complex *work, real *rwork, integer *info);- -/* Subroutine */ int ctbtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b, - integer *ldb, integer *info);- -/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select, - integer *n, complex *a, integer *lda, complex *b, integer *ldb, - complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, - integer *m, complex *work, real *rwork, integer *info);- -/* Subroutine */ int ctgex2_(logical *wantq, logical *wantz, integer *n, - complex *a, integer *lda, complex *b, integer *ldb, complex *q, - integer *ldq, complex *z__, integer *ldz, integer *j1, integer *info);- -/* Subroutine */ int ctgexc_(logical *wantq, logical *wantz, integer *n, - complex *a, integer *lda, complex *b, integer *ldb, complex *q, - integer *ldq, complex *z__, integer *ldz, integer *ifst, integer *- ilst, integer *info);- -/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz, - logical *select, integer *n, complex *a, integer *lda, complex *b, - integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq,- complex *z__, integer *ldz, integer *m, real *pl, real *pr, real *- dif, complex *work, integer *lwork, integer *iwork, integer *liwork, - integer *info);- -/* Subroutine */ int ctgsja_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, integer *k, integer *l, complex *a, integer *- lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha, - real *beta, complex *u, integer *ldu, complex *v, integer *ldv, - complex *q, integer *ldq, complex *work, integer *ncycle, integer *- info);- -/* Subroutine */ int ctgsna_(char *job, char *howmny, logical *select, - integer *n, complex *a, integer *lda, complex *b, integer *ldb, - complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real - *dif, integer *mm, integer *m, complex *work, integer *lwork, integer - *iwork, integer *info);- -/* Subroutine */ int ctgsy2_(char *trans, integer *ijob, integer *m, integer *- n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, - integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde, - complex *f, integer *ldf, real *scale, real *rdsum, real *rdscal, - integer *info);- -/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer *- n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, - integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde, - complex *f, integer *ldf, real *scale, real *dif, complex *work, - integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int ctpcon_(char *norm, char *uplo, char *diag, integer *n, - complex *ap, real *rcond, complex *work, real *rwork, integer *info);- -/* Subroutine */ int ctprfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x, - integer *ldx, real *ferr, real *berr, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int ctptri_(char *uplo, char *diag, integer *n, complex *ap, - integer *info);- -/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info);- -/* Subroutine */ int ctrcon_(char *norm, char *uplo, char *diag, integer *n, - complex *a, integer *lda, real *rcond, complex *work, real *rwork, - integer *info);- -/* Subroutine */ int ctrevc_(char *side, char *howmny, logical *select, - integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, - complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, - real *rwork, integer *info);- -/* Subroutine */ int ctrexc_(char *compq, integer *n, complex *t, integer *- ldt, complex *q, integer *ldq, integer *ifst, integer *ilst, integer *- info);- -/* Subroutine */ int ctrrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, - complex *x, integer *ldx, real *ferr, real *berr, complex *work, real - *rwork, integer *info);- -/* Subroutine */ int ctrsen_(char *job, char *compq, logical *select, integer - *n, complex *t, integer *ldt, complex *q, integer *ldq, complex *w, - integer *m, real *s, real *sep, complex *work, integer *lwork, - integer *info);- -/* Subroutine */ int ctrsna_(char *job, char *howmny, logical *select, - integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, - complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer *- m, complex *work, integer *ldwork, real *rwork, integer *info);- -/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer - *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, - complex *c__, integer *ldc, real *scale, integer *info);- -/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a, - integer *lda, integer *info);- -/* Subroutine */ int ctrtri_(char *uplo, char *diag, integer *n, complex *a, - integer *lda, integer *info);- -/* Subroutine */ int ctrtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, - integer *info);- -/* Subroutine */ int ctzrqf_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, integer *info);- -/* Subroutine */ int ctzrzf_(integer *m, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cung2l_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *info);- -/* Subroutine */ int cung2r_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *info);- -/* Subroutine */ int cungbr_(char *vect, integer *m, integer *n, integer *k, - complex *a, integer *lda, complex *tau, complex *work, integer *lwork,- integer *info);- -/* Subroutine */ int cunghr_(integer *n, integer *ilo, integer *ihi, complex *- a, integer *lda, complex *tau, complex *work, integer *lwork, integer - *info);- -/* Subroutine */ int cungl2_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *info);- -/* Subroutine */ int cunglq_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *lwork, integer *- info);- -/* Subroutine */ int cungql_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *lwork, integer *- info);- -/* Subroutine */ int cungqr_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *lwork, integer *- info);- -/* Subroutine */ int cungr2_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *info);- -/* Subroutine */ int cungrq_(integer *m, integer *n, integer *k, complex *a, - integer *lda, complex *tau, complex *work, integer *lwork, integer *- info);- -/* Subroutine */ int cungtr_(char *uplo, integer *n, complex *a, integer *lda,- complex *tau, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cunm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *info);- -/* Subroutine */ int cunm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *info);- -/* Subroutine */ int cunmbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, complex *a, integer *lda, complex *tau, - complex *c__, integer *ldc, complex *work, integer *lwork, integer *- info);- -/* Subroutine */ int cunmhr_(char *side, char *trans, integer *m, integer *n, - integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau, - complex *c__, integer *ldc, complex *work, integer *lwork, integer *- info);- -/* Subroutine */ int cunml2_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *info);- -/* Subroutine */ int cunmlq_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cunmql_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cunmqr_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cunmr2_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *info);- -/* Subroutine */ int cunmr3_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, complex *a, integer *lda, complex *tau, - complex *c__, integer *ldc, complex *work, integer *info);- -/* Subroutine */ int cunmrq_(char *side, char *trans, integer *m, integer *n, - integer *k, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cunmrz_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, complex *a, integer *lda, complex *tau, - complex *c__, integer *ldc, complex *work, integer *lwork, integer *- info);- -/* Subroutine */ int cunmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, complex *a, integer *lda, complex *tau, complex *c__, - integer *ldc, complex *work, integer *lwork, integer *info);- -/* Subroutine */ int cupgtr_(char *uplo, integer *n, complex *ap, complex *- tau, complex *q, integer *ldq, complex *work, integer *info);- -/* Subroutine */ int cupmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, complex *ap, complex *tau, complex *c__, integer *ldc, - complex *work, integer *info);- -/* Subroutine */ int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *- d__, doublereal *e, doublereal *u, integer *ldu, doublereal *vt, - integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *- nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt, - integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *- ldc, doublereal *work, integer *info);- -/* Subroutine */ int ddisna_(char *job, integer *m, integer *n, doublereal *- d__, doublereal *sep, integer *info);- -/* Subroutine */ int dgbbrd_(char *vect, integer *m, integer *n, integer *ncc,- integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *- d__, doublereal *e, doublereal *q, integer *ldq, doublereal *pt, - integer *ldpt, doublereal *c__, integer *ldc, doublereal *work, - integer *info);- -/* Subroutine */ int dgbcon_(char *norm, integer *n, integer *kl, integer *ku,- doublereal *ab, integer *ldab, integer *ipiv, doublereal *anorm, - doublereal *rcond, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dgbequ_(integer *m, integer *n, integer *kl, integer *ku,- doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *- info);- -/* Subroutine */ int dgbrfs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, - integer *ldafb, integer *ipiv, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dgbsv_(integer *n, integer *kl, integer *ku, integer *- nrhs, doublereal *ab, integer *ldab, integer *ipiv, doublereal *b, - integer *ldb, integer *info);- -/* Subroutine */ int dgbsvx_(char *fact, char *trans, integer *n, integer *kl,- integer *ku, integer *nrhs, doublereal *ab, integer *ldab, - doublereal *afb, integer *ldafb, integer *ipiv, char *equed, - doublereal *r__, doublereal *c__, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, - doublereal *berr, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku,- doublereal *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku,- doublereal *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int dgbtrs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv, - doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dgebak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, doublereal *scale, integer *m, doublereal *v, integer *- ldv, integer *info);- -/* Subroutine */ int dgebal_(char *job, integer *n, doublereal *a, integer *- lda, integer *ilo, integer *ihi, doublereal *scale, integer *info);- -/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *- taup, doublereal *work, integer *info);- -/* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *- taup, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer *- lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dgeequ_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal - *colcnd, doublereal *amax, integer *info);- -/* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n, - doublereal *a, integer *lda, integer *sdim, doublereal *wr, - doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, - integer *lwork, logical *bwork, integer *info);- -/* Subroutine */ int dgeesx_(char *jobvs, char *sort, L_fp select, char *- sense, integer *n, doublereal *a, integer *lda, integer *sdim, - doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, - doublereal *rconde, doublereal *rcondv, doublereal *work, integer *- lwork, integer *iwork, integer *liwork, logical *bwork, integer *info);- -/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *- a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl, - integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work, - integer *lwork, integer *info);- -/* Subroutine */ int dgeevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, doublereal *a, integer *lda, doublereal *wr, - doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, - integer *ldvr, integer *ilo, integer *ihi, doublereal *scale, - doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal - *work, integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *- alphar, doublereal *alphai, doublereal *beta, doublereal *vsl, - integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work, - integer *lwork, integer *info);- -/* Subroutine */ int dgegv_(char *jobvl, char *jobvr, integer *n, doublereal *- a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, - doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, - doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *info);- -/* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info);- -/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *- nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *- s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,- integer *iwork, integer *info);- -/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *- s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,- integer *info);- -/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *- jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *- info);- -/* Subroutine */ int dgelsy_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *- jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *- lwork, integer *info);- -/* Subroutine */ int dgeql2_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dgeqlf_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dgeqp3_(integer *m, integer *n, doublereal *a, integer *- lda, integer *jpvt, doublereal *tau, doublereal *work, integer *lwork,- integer *info);- -/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer *- lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dgerfs_(char *trans, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *- ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dgerq2_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dgerqf_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dgesc2_(integer *n, doublereal *a, integer *lda, - doublereal *rhs, integer *ipiv, integer *jpiv, doublereal *scale);- -/* Subroutine */ int dgesdd_(char *jobz, integer *m, integer *n, doublereal *- a, integer *lda, doublereal *s, doublereal *u, integer *ldu, - doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, - integer *iwork, integer *info);- -/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer - *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n, - doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *- ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dgesvx_(char *fact, char *trans, integer *n, integer *- nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, char *equed, doublereal *r__, doublereal *c__, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *- rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dgetc2_(integer *n, doublereal *a, integer *lda, integer - *ipiv, integer *jpiv, integer *info);- -/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *- lda, integer *ipiv, integer *info);- -/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *- lda, integer *ipiv, integer *info);- -/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer - *ipiv, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs, - doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *- ldb, integer *info);- -/* Subroutine */ int dggbak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, doublereal *lscale, doublereal *rscale, integer *m, - doublereal *v, integer *ldv, integer *info);- -/* Subroutine */ int dggbal_(char *job, integer *n, doublereal *a, integer *- lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi, - doublereal *lscale, doublereal *rscale, doublereal *work, integer *- info);- -/* Subroutine */ int dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp - delctg, integer *n, doublereal *a, integer *lda, doublereal *b, - integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai, - doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr, - integer *ldvsr, doublereal *work, integer *lwork, logical *bwork, - integer *info);- -/* Subroutine */ int dggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp - delctg, char *sense, integer *n, doublereal *a, integer *lda, - doublereal *b, integer *ldb, integer *sdim, doublereal *alphar, - doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl,- doublereal *vsr, integer *ldvsr, doublereal *rconde, doublereal *- rcondv, doublereal *work, integer *lwork, integer *iwork, integer *- liwork, logical *bwork, integer *info);- -/* Subroutine */ int dggev_(char *jobvl, char *jobvr, integer *n, doublereal *- a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, - doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, - doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *- beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, - integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, - doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *- rcondv, doublereal *work, integer *lwork, integer *iwork, logical *- bwork, integer *info);- -/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, doublereal *- a, integer *lda, doublereal *b, integer *ldb, doublereal *d__, - doublereal *x, doublereal *y, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dgghrd_(char *compq, char *compz, integer *n, integer *- ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *q, integer *ldq, doublereal *z__, integer *- ldz, integer *info);- -/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal *- a, integer *lda, doublereal *b, integer *ldb, doublereal *c__, - doublereal *d__, doublereal *x, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dggqrf_(integer *n, integer *m, integer *p, doublereal *- a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, - doublereal *taub, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, doublereal *- a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, - doublereal *taub, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dggsvd_(char *jobu, char *jobv, char *jobq, integer *m, - integer *n, integer *p, integer *k, integer *l, doublereal *a, - integer *lda, doublereal *b, integer *ldb, doublereal *alpha, - doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer - *ldv, doublereal *q, integer *ldq, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dggsvp_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer - *l, doublereal *u, integer *ldu, doublereal *v, integer *ldv, - doublereal *q, integer *ldq, integer *iwork, doublereal *tau, - doublereal *work, integer *info);- -/* Subroutine */ int dgtcon_(char *norm, integer *n, doublereal *dl, - doublereal *d__, doublereal *du, doublereal *du2, integer *ipiv, - doublereal *anorm, doublereal *rcond, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dgtrfs_(char *trans, integer *n, integer *nrhs, - doublereal *dl, doublereal *d__, doublereal *du, doublereal *dlf, - doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *- ferr, doublereal *berr, doublereal *work, integer *iwork, integer *- info);- -/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, doublereal *dl, - doublereal *d__, doublereal *du, doublereal *b, integer *ldb, integer - *info);- -/* Subroutine */ int dgtsvx_(char *fact, char *trans, integer *n, integer *- nrhs, doublereal *dl, doublereal *d__, doublereal *du, doublereal *- dlf, doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *- rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dgttrf_(integer *n, doublereal *dl, doublereal *d__, - doublereal *du, doublereal *du2, integer *ipiv, integer *info);- -/* Subroutine */ int dgttrs_(char *trans, integer *n, integer *nrhs, - doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2, - integer *ipiv, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dgtts2_(integer *itrans, integer *n, integer *nrhs, - doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2, - integer *ipiv, doublereal *b, integer *ldb);- -/* Subroutine */ int dhgeqz_(char *job, char *compq, char *compz, integer *n, - integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *- b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *- beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz, - doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dhsein_(char *side, char *eigsrc, char *initv, logical *- select, integer *n, doublereal *h__, integer *ldh, doublereal *wr, - doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, - integer *ldvr, integer *mm, integer *m, doublereal *work, integer *- ifaill, integer *ifailr, integer *info);- -/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo,- integer *ihi, doublereal *h__, integer *ldh, doublereal *wr, - doublereal *wi, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *info);- -/* Subroutine */ int dlabad_(doublereal *smalll, doublereal *large); /* !? */- -/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal *- a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq, - doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer - *ldy);- -/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x, - integer *isgn, doublereal *est, integer *kase);- -/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal *- a, integer *lda, doublereal *b, integer *ldb);- -/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *d__, doublereal *p, doublereal *q);- -/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *rt1, doublereal *rt2);- -/* Subroutine */ int dlaebz_(integer *ijob, integer *nitmax, integer *n, - integer *mmax, integer *minp, integer *nbmin, doublereal *abstol, - doublereal *reltol, doublereal *pivmin, doublereal *d__, doublereal *- e, doublereal *e2, integer *nval, doublereal *ab, doublereal *c__, - integer *mout, integer *nab, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n, - doublereal *d__, doublereal *e, doublereal *q, integer *ldq, - doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q, - integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal *- d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, - doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2, - integer *indx, integer *indxc, integer *indxp, integer *coltyp, - integer *info);- -/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal *- d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda,- doublereal *q2, integer *indx, integer *ctot, doublereal *w, - doublereal *s, integer *info);- -/* Subroutine */ int dlaed4_(integer *n, integer *i__, doublereal *d__, - doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam,- integer *info);- -/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__, - doublereal *delta, doublereal *rho, doublereal *dlam);- -/* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal *- rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal *- tau, integer *info);- -/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, - doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer - *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer *- perm, integer *givptr, integer *givcol, doublereal *givnum, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer - *qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq, - doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda,- doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer - *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer - *indx, integer *info);- -/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, - integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal *- rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, - integer *info);- -/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, - integer *curpbm, integer *prmptr, integer *perm, integer *givptr, - integer *givcol, doublereal *givnum, doublereal *q, integer *qptr, - doublereal *z__, doublereal *ztemp, integer *info);- -/* Subroutine */ int dlaein_(logical *rightv, logical *noinit, integer *n, - doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, - doublereal *vr, doublereal *vi, doublereal *b, integer *ldb, - doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal *- bignum, integer *info);- -/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1);- -/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t, - integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1, - integer *n2, doublereal *work, integer *info);- -/* Subroutine */ int dlag2_(doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *safmin, doublereal *scale1, doublereal *- scale2, doublereal *wr1, doublereal *wr2, doublereal *wi);- -/* Subroutine */ int dlags2_(logical *upper, doublereal *a1, doublereal *a2, - doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3, - doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv, - doublereal *csq, doublereal *snq);- -/* Subroutine */ int dlagtf_(integer *n, doublereal *a, doublereal *lambda, - doublereal *b, doublereal *c__, doublereal *tol, doublereal *d__, - integer *in, integer *info);- -/* Subroutine */ int dlagtm_(char *trans, integer *n, integer *nrhs, - doublereal *alpha, doublereal *dl, doublereal *d__, doublereal *du, - doublereal *x, integer *ldx, doublereal *beta, doublereal *b, integer - *ldb);- -/* Subroutine */ int dlagts_(integer *job, integer *n, doublereal *a, - doublereal *b, doublereal *c__, doublereal *d__, integer *in, - doublereal *y, doublereal *tol, integer *info);- -/* Subroutine */ int dlagv2_(doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *- beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal *- snr);- -/* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal - *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__, - integer *ldz, integer *info);- -/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal *- a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, - doublereal *y, integer *ldy);- -/* Subroutine */ int dlaic1_(integer *job, integer *j, doublereal *x, - doublereal *sest, doublereal *w, doublereal *gamma, doublereal *- sestpr, doublereal *s, doublereal *c__);- -/* Subroutine */ int dlaln2_(logical *ltrans, integer *na, integer *nw, - doublereal *smin, doublereal *ca, doublereal *a, integer *lda, - doublereal *d1, doublereal *d2, doublereal *b, integer *ldb, - doublereal *wr, doublereal *wi, doublereal *x, integer *ldx, - doublereal *scale, doublereal *xnorm, integer *info);- -/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal - *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *- poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *- k, doublereal *c__, doublereal *s, doublereal *work, integer *info);- -/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *- ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, - doublereal *difl, doublereal *difr, doublereal *z__, doublereal *- poles, integer *givptr, integer *givcol, integer *ldgcol, integer *- perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *- work, integer *iwork, integer *info);- -/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer - *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, - doublereal *rcond, integer *rank, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1);- -/* Subroutine */ int dlamc2_(integer *beta, integer *t, logical *rnd, - doublereal *eps, integer *emin, doublereal *rmin, integer *emax, - doublereal *rmax);- -/* Subroutine */ int dlamc4_(integer *emin, doublereal *start, integer *base);- -/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin, - logical *ieee, integer *emax, doublereal *rmax);- -/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer - *dtrd1, integer *dtrd2, integer *index);- -/* Subroutine */ int dlanv2_(doublereal *a, doublereal *b, doublereal *c__, - doublereal *d__, doublereal *rt1r, doublereal *rt1i, doublereal *rt2r,- doublereal *rt2i, doublereal *cs, doublereal *sn);- -/* Subroutine */ int dlapll_(integer *n, doublereal *x, integer *incx, - doublereal *y, integer *incy, doublereal *ssmin);- -/* Subroutine */ int dlapmt_(logical *forwrd, integer *m, integer *n, - doublereal *x, integer *ldx, integer *k);- -/* Subroutine */ int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku,- doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);- -/* Subroutine */ int dlaqge_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal - *colcnd, doublereal *amax, char *equed);- -/* Subroutine */ int dlaqp2_(integer *m, integer *n, integer *offset, - doublereal *a, integer *lda, integer *jpvt, doublereal *tau, - doublereal *vn1, doublereal *vn2, doublereal *work);- -/* Subroutine */ int dlaqps_(integer *m, integer *n, integer *offset, integer - *nb, integer *kb, doublereal *a, integer *lda, integer *jpvt, - doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *auxv, - doublereal *f, integer *ldf);- -/* Subroutine */ int dlaqsb_(char *uplo, integer *n, integer *kd, doublereal *- ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax,- char *equed);- -/* Subroutine */ int dlaqsp_(char *uplo, integer *n, doublereal *ap, - doublereal *s, doublereal *scond, doublereal *amax, char *equed);- -/* Subroutine */ int dlaqsy_(char *uplo, integer *n, doublereal *a, integer *- lda, doublereal *s, doublereal *scond, doublereal *amax, char *equed);- -/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n, - doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal - *scale, doublereal *x, doublereal *work, integer *info);- -/* Subroutine */ int dlar1v_(integer *n, integer *b1, integer *bn, doublereal - *sigma, doublereal *d__, doublereal *l, doublereal *ld, doublereal *- lld, doublereal *gersch, doublereal *z__, doublereal *ztz, doublereal - *mingma, integer *r__, integer *isuppz, doublereal *work);- -/* Subroutine */ int dlar2v_(integer *n, doublereal *x, doublereal *y, - doublereal *z__, integer *incx, doublereal *c__, doublereal *s, - integer *incc);- -/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,- integer *incv, doublereal *tau, doublereal *c__, integer *ldc, - doublereal *work);- -/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, doublereal *v, integer *- ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, - doublereal *work, integer *ldwork);- -/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, - integer *incx, doublereal *tau);- -/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *- k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, - integer *ldt);- -/* Subroutine */ int dlarfx_(char *side, integer *m, integer *n, doublereal *- v, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work);- -/* Subroutine */ int dlargv_(integer *n, doublereal *x, integer *incx, - doublereal *y, integer *incy, doublereal *c__, integer *incc);- -/* Subroutine */ int dlarnv_(integer *idist, integer *iseed, integer *n, - doublereal *x);- -/* Subroutine */ int dlarrb_(integer *n, doublereal *d__, doublereal *l, - doublereal *ld, doublereal *lld, integer *ifirst, integer *ilast, - doublereal *sigma, doublereal *reltol, doublereal *w, doublereal *- wgap, doublereal *werr, doublereal *work, integer *iwork, integer *- info);- -/* Subroutine */ int dlarre_(integer *n, doublereal *d__, doublereal *e, - doublereal *tol, integer *nsplit, integer *isplit, integer *m, - doublereal *w, doublereal *woff, doublereal *gersch, doublereal *work,- integer *info);- -/* Subroutine */ int dlarrf_(integer *n, doublereal *d__, doublereal *l, - doublereal *ld, doublereal *lld, integer *ifirst, integer *ilast, - doublereal *w, doublereal *dplus, doublereal *lplus, doublereal *work,- integer *iwork, integer *info);- -/* Subroutine */ int dlarrv_(integer *n, doublereal *d__, doublereal *l, - integer *isplit, integer *m, doublereal *w, integer *iblock, - doublereal *gersch, doublereal *tol, doublereal *z__, integer *ldz, - integer *isuppz, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs, - doublereal *sn, doublereal *r__);- -/* Subroutine */ int dlartv_(integer *n, doublereal *x, integer *incx, - doublereal *y, integer *incy, doublereal *c__, doublereal *s, integer - *incc);- -/* Subroutine */ int dlaruv_(integer *iseed, integer *n, doublereal *x);- -/* Subroutine */ int dlarz_(char *side, integer *m, integer *n, integer *l, - doublereal *v, integer *incv, doublereal *tau, doublereal *c__, - integer *ldc, doublereal *work);- -/* Subroutine */ int dlarzb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, integer *l, doublereal *v,- integer *ldv, doublereal *t, integer *ldt, doublereal *c__, integer *- ldc, doublereal *work, integer *ldwork);- -/* Subroutine */ int dlarzt_(char *direct, char *storev, integer *n, integer *- k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, - integer *ldt);- -/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax);- -/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku, - doublereal *cfrom, doublereal *cto, integer *m, integer *n, - doublereal *a, integer *lda, integer *info);- -/* Subroutine */ int dlasd0_(integer *n, integer *sqre, doublereal *d__, - doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *- ldvt, integer *smlsiz, integer *iwork, doublereal *work, integer *- info);- -/* Subroutine */ int dlasd1_(integer *nl, integer *nr, integer *sqre, - doublereal *d__, doublereal *alpha, doublereal *beta, doublereal *u, - integer *ldu, doublereal *vt, integer *ldvt, integer *idxq, integer *- iwork, doublereal *work, integer *info);- -/* Subroutine */ int dlasd2_(integer *nl, integer *nr, integer *sqre, integer - *k, doublereal *d__, doublereal *z__, doublereal *alpha, doublereal *- beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, - doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2, - integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *- idxq, integer *coltyp, integer *info);- -/* Subroutine */ int dlasd3_(integer *nl, integer *nr, integer *sqre, integer - *k, doublereal *d__, doublereal *q, integer *ldq, doublereal *dsigma, - doublereal *u, integer *ldu, doublereal *u2, integer *ldu2, - doublereal *vt, integer *ldvt, doublereal *vt2, integer *ldvt2, - integer *idxc, integer *ctot, doublereal *z__, integer *info);- -/* Subroutine */ int dlasd4_(integer *n, integer *i__, doublereal *d__, - doublereal *z__, doublereal *delta, doublereal *rho, doublereal *- sigma, doublereal *work, integer *info);- -/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__, - doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal *- work);- -/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr, - integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl, - doublereal *alpha, doublereal *beta, integer *idxq, integer *perm, - integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,- integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *- difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *k, doublereal *d__, doublereal *z__, - doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl, - doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *- dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, - integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,- integer *ldgnum, doublereal *c__, doublereal *s, integer *info);- -/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__, - doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl, - doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *- work, integer *info);- -/* Subroutine */ int dlasd9_(integer *icompq, integer *ldu, integer *k, - doublereal *d__, doublereal *z__, doublereal *vf, doublereal *vl, - doublereal *difl, doublereal *difr, doublereal *dsigma, doublereal *- work, integer *info);- -/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n, - integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer - *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr, - doublereal *z__, doublereal *poles, integer *givptr, integer *givcol, - integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__, - doublereal *s, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer *- ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e, - doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, - doublereal *c__, integer *ldc, doublereal *work, integer *info);- -/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer *- inode, integer *ndiml, integer *ndimr, integer *msub);- -/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal *- alpha, doublereal *beta, doublereal *a, integer *lda);- -/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e, - doublereal *work, integer *info);- -/* Subroutine */ int dlasq2_(integer *n, doublereal *z__, integer *info);- -/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig,- doublereal *qmax, integer *nfail, integer *iter, integer *ndiv, - logical *ieee);- -/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__, - integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1, - doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2, - doublereal *tau, integer *ttype);- -/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *tau, doublereal *dmin__, doublereal *dmin1, - doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2,- logical *ieee);- -/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,- doublereal *dn, doublereal *dnm1, doublereal *dnm2);- -/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m,- integer *n, doublereal *c__, doublereal *s, doublereal *a, integer *- lda);- -/* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer *- info);- -/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx, - doublereal *scale, doublereal *sumsq);- -/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *- csr, doublereal *snl, doublereal *csl);- -/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer - *k1, integer *k2, integer *ipiv, integer *incx);- -/* Subroutine */ int dlasy2_(logical *ltranl, logical *ltranr, integer *isgn, - integer *n1, integer *n2, doublereal *tl, integer *ldtl, doublereal *- tr, integer *ldtr, doublereal *b, integer *ldb, doublereal *scale, - doublereal *x, integer *ldx, doublereal *xnorm, integer *info);- -/* Subroutine */ int dlasyf_(char *uplo, integer *n, integer *nb, integer *kb,- doublereal *a, integer *lda, integer *ipiv, doublereal *w, integer *- ldw, integer *info);- -/* Subroutine */ int dlatbs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, integer *kd, doublereal *ab, integer *ldab, - doublereal *x, doublereal *scale, doublereal *cnorm, integer *info);- -/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__, - integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal, - integer *ipiv, integer *jpiv);- -/* Subroutine */ int dlatps_(char *uplo, char *trans, char *diag, char *- normin, integer *n, doublereal *ap, doublereal *x, doublereal *scale, - doublereal *cnorm, integer *info);- -/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *- a, integer *lda, doublereal *e, doublereal *tau, doublereal *w, - integer *ldw);- -/* Subroutine */ int dlatrs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, doublereal *a, integer *lda, doublereal *x, - doublereal *scale, doublereal *cnorm, integer *info);- -/* Subroutine */ int dlatrz_(integer *m, integer *n, integer *l, doublereal *- a, integer *lda, doublereal *tau, doublereal *work);- -/* Subroutine */ int dlatzm_(char *side, integer *m, integer *n, doublereal *- v, integer *incv, doublereal *tau, doublereal *c1, doublereal *c2, - integer *ldc, doublereal *work);- -/* Subroutine */ int dlauu2_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *info);- -/* Subroutine */ int dlauum_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *info);- -/* Subroutine */ int dopgtr_(char *uplo, integer *n, doublereal *ap, - doublereal *tau, doublereal *q, integer *ldq, doublereal *work, - integer *info);- -/* Subroutine */ int dopmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublereal *ap, doublereal *tau, doublereal *c__, integer - *ldc, doublereal *work, integer *info);- -/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info);- -/* Subroutine */ int dorghr_(integer *n, integer *ilo, integer *ihi, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info);- -/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dorgr2_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *info);- -/* Subroutine */ int dorgrq_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *info);- -/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *info);- -/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dormhr_(char *side, char *trans, integer *m, integer *n, - integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *- tau, doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *info);- -/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dormr2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *info);- -/* Subroutine */ int dormr3_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *info);- -/* Subroutine */ int dormrq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dormrz_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *- c__, integer *ldc, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dpbcon_(char *uplo, integer *n, integer *kd, doublereal *- ab, integer *ldab, doublereal *anorm, doublereal *rcond, doublereal *- work, integer *iwork, integer *info);- -/* Subroutine */ int dpbequ_(char *uplo, integer *n, integer *kd, doublereal *- ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax,- integer *info);- -/* Subroutine */ int dpbrfs_(char *uplo, integer *n, integer *kd, integer *- nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *- ferr, doublereal *berr, doublereal *work, integer *iwork, integer *- info);- -/* Subroutine */ int dpbstf_(char *uplo, integer *n, integer *kd, doublereal *- ab, integer *ldab, integer *info);- -/* Subroutine */ int dpbsv_(char *uplo, integer *n, integer *kd, integer *- nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, - integer *info);- -/* Subroutine */ int dpbsvx_(char *fact, char *uplo, integer *n, integer *kd, - integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, - integer *ldafb, char *equed, doublereal *s, doublereal *b, integer *- ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr,- doublereal *berr, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dpbtf2_(char *uplo, integer *n, integer *kd, doublereal *- ab, integer *ldab, integer *info);- -/* Subroutine */ int dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *- ab, integer *ldab, integer *info);- -/* Subroutine */ int dpbtrs_(char *uplo, integer *n, integer *kd, integer *- nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, - integer *info);- -/* Subroutine */ int dpocon_(char *uplo, integer *n, doublereal *a, integer *- lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dpoequ_(integer *n, doublereal *a, integer *lda, - doublereal *s, doublereal *scond, doublereal *amax, integer *info);- -/* Subroutine */ int dporfs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *af, integer *ldaf, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *- ferr, doublereal *berr, doublereal *work, integer *iwork, integer *- info);- -/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal - *a, integer *lda, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dposvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *- x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *- berr, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *info);- -/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *info);- -/* Subroutine */ int dpotri_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *info);- -/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *- info);- -/* Subroutine */ int dppcon_(char *uplo, integer *n, doublereal *ap, - doublereal *anorm, doublereal *rcond, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dppequ_(char *uplo, integer *n, doublereal *ap, - doublereal *s, doublereal *scond, doublereal *amax, integer *info);- -/* Subroutine */ int dpprfs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, doublereal *afp, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dppsv_(char *uplo, integer *n, integer *nrhs, doublereal - *ap, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dppsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *- rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *- iwork, integer *info);- -/* Subroutine */ int dpptrf_(char *uplo, integer *n, doublereal *ap, integer *- info);- -/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer *- info);- -/* Subroutine */ int dpptrs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dptcon_(integer *n, doublereal *d__, doublereal *e, - doublereal *anorm, doublereal *rcond, doublereal *work, integer *info);- -/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info);- -/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer - *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,- doublereal *work, integer *info);- -/* Subroutine */ int dptsv_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dptsvx_(char *fact, integer *n, integer *nrhs, - doublereal *d__, doublereal *e, doublereal *df, doublereal *ef, - doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *- rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *- info);- -/* Subroutine */ int dpttrf_(integer *n, doublereal *d__, doublereal *e, - integer *info);- -/* Subroutine */ int dpttrs_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dptts2_(integer *n, integer *nrhs, doublereal *d__, - doublereal *e, doublereal *b, integer *ldb);- -/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx, - integer *incx);- -/* Subroutine */ int dsbev_(char *jobz, char *uplo, integer *n, integer *kd, - doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *info);- -/* Subroutine */ int dsbevd_(char *jobz, char *uplo, integer *n, integer *kd, - doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n, - integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *- ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu, - doublereal *abstol, integer *m, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *iwork, integer *ifail, - integer *info);- -/* Subroutine */ int dsbgst_(char *vect, char *uplo, integer *n, integer *ka, - integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *- ldbb, doublereal *x, integer *ldx, doublereal *work, integer *info);- -/* Subroutine */ int dsbgv_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *- ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *info);- -/* Subroutine */ int dsbgvd_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *- ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n, - integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *- bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl, - doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer - *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int dsbtrd_(char *vect, char *uplo, integer *n, integer *kd, - doublereal *ab, integer *ldab, doublereal *d__, doublereal *e, - doublereal *q, integer *ldq, doublereal *work, integer *info);- -/* Subroutine */ int dspcon_(char *uplo, integer *n, doublereal *ap, integer *- ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer - *iwork, integer *info);- -/* Subroutine */ int dspev_(char *jobz, char *uplo, integer *n, doublereal *- ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *info);- -/* Subroutine */ int dspevd_(char *jobz, char *uplo, integer *n, doublereal *- ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dspevx_(char *jobz, char *range, char *uplo, integer *n, - doublereal *ap, doublereal *vl, doublereal *vu, integer *il, integer *- iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *iwork, integer *ifail, - integer *info);- -/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n, - doublereal *ap, doublereal *bp, integer *info);- -/* Subroutine */ int dspgv_(integer *itype, char *jobz, char *uplo, integer *- n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *info);- -/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer *- n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int dspgvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *vl, - doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer - *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, - integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, - integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, - doublereal *berr, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dspsv_(char *uplo, integer *n, integer *nrhs, doublereal - *ap, integer *ipiv, doublereal *b, integer *ldb, integer *info);- -/* Subroutine */ int dspsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, - integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, - doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dsptrd_(char *uplo, integer *n, doublereal *ap, - doublereal *d__, doublereal *e, doublereal *tau, integer *info);- -/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer *- ipiv, integer *info);- -/* Subroutine */ int dsptri_(char *uplo, integer *n, doublereal *ap, integer *- ipiv, doublereal *work, integer *info);- -/* Subroutine */ int dsptrs_(char *uplo, integer *n, integer *nrhs, - doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer *- info);- -/* Subroutine */ int dstebz_(char *range, char *order, integer *n, doublereal - *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, - doublereal *d__, doublereal *e, integer *m, integer *nsplit, - doublereal *w, integer *iblock, integer *isplit, doublereal *work, - integer *iwork, integer *info);- -/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dstegr_(char *jobz, char *range, integer *n, doublereal *- d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dstein_(integer *n, doublereal *d__, doublereal *e, - integer *m, doublereal *w, integer *iblock, integer *isplit, - doublereal *z__, integer *ldz, doublereal *work, integer *iwork, - integer *ifail, integer *info);- -/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info);- -/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e, - integer *info);- -/* Subroutine */ int dstev_(char *jobz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *info);- -/* Subroutine */ int dstevd_(char *jobz, integer *n, doublereal *d__, - doublereal *e, doublereal *z__, integer *ldz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dstevr_(char *jobz, char *range, integer *n, doublereal *- d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dstevx_(char *jobz, char *range, integer *n, doublereal *- d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, - integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, doublereal *work, integer *iwork, - integer *ifail, integer *info);- -/* Subroutine */ int dsycon_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal *- work, integer *iwork, integer *info);- -/* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,- integer *lda, doublereal *w, doublereal *work, integer *lwork, - integer *info);- -/* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal *- a, integer *lda, doublereal *w, doublereal *work, integer *lwork, - integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *- il, integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, integer *isuppz, doublereal *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int dsyevx_(char *jobz, char *range, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *- il, integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublereal *z__, integer *ldz, doublereal *work, integer *lwork, - integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *- info);- -/* Subroutine */ int dsygst_(integer *itype, char *uplo, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *- info);- -/* Subroutine */ int dsygv_(integer *itype, char *jobz, char *uplo, integer *- n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *w, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dsygvd_(integer *itype, char *jobz, char *uplo, integer *- n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *w, doublereal *work, integer *lwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int dsygvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer - *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu, - doublereal *abstol, integer *m, doublereal *w, doublereal *z__, - integer *ldz, doublereal *work, integer *lwork, integer *iwork, - integer *ifail, integer *info);- -/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *- ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dsysv_(char *uplo, integer *n, integer *nrhs, doublereal - *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, - doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dsysvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, - integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *- ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, - doublereal *work, integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer *- lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info);- -/* Subroutine */ int dsytf2_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *ipiv, integer *info);- -/* Subroutine */ int dsytrd_(char *uplo, integer *n, doublereal *a, integer *- lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal *- work, integer *lwork, integer *info);- -/* Subroutine */ int dsytrf_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *ipiv, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *ipiv, doublereal *work, integer *info);- -/* Subroutine */ int dsytrs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *- ldb, integer *info);- -/* Subroutine */ int dtbcon_(char *norm, char *uplo, char *diag, integer *n, - integer *kd, doublereal *ab, integer *ldab, doublereal *rcond, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dtbrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal - *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, - doublereal *berr, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dtbtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal - *b, integer *ldb, integer *info);- -/* Subroutine */ int dtgevc_(char *side, char *howmny, logical *select, - integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer - *mm, integer *m, doublereal *work, integer *info);- -/* Subroutine */ int dtgex2_(logical *wantq, logical *wantz, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *- q, integer *ldq, doublereal *z__, integer *ldz, integer *j1, integer *- n1, integer *n2, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dtgexc_(logical *wantq, logical *wantz, integer *n, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *- q, integer *ldq, doublereal *z__, integer *ldz, integer *ifst, - integer *ilst, doublereal *work, integer *lwork, integer *info);- -/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz, - logical *select, integer *n, doublereal *a, integer *lda, doublereal *- b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *- beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz, - integer *m, doublereal *pl, doublereal *pr, doublereal *dif, - doublereal *work, integer *lwork, integer *iwork, integer *liwork, - integer *info);- -/* Subroutine */ int dtgsja_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, integer *k, integer *l, doublereal *a, - integer *lda, doublereal *b, integer *ldb, doublereal *tola, - doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u, - integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer *- ldq, doublereal *work, integer *ncycle, integer *info);- -/* Subroutine */ int dtgsna_(char *job, char *howmny, logical *select, - integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, - doublereal *s, doublereal *dif, integer *mm, integer *m, doublereal *- work, integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int dtgsy2_(char *trans, integer *ijob, integer *m, integer *- n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *c__, integer *ldc, doublereal *d__, integer *ldd, - doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *- scale, doublereal *rdsum, doublereal *rdscal, integer *iwork, integer - *pq, integer *info);- -/* Subroutine */ int dtgsyl_(char *trans, integer *ijob, integer *m, integer *- n, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *c__, integer *ldc, doublereal *d__, integer *ldd, - doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *- scale, doublereal *dif, doublereal *work, integer *lwork, integer *- iwork, integer *info);- -/* Subroutine */ int dtpcon_(char *norm, char *uplo, char *diag, integer *n, - doublereal *ap, doublereal *rcond, doublereal *work, integer *iwork, - integer *info);- -/* Subroutine */ int dtprfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dtptri_(char *uplo, char *diag, integer *n, doublereal *- ap, integer *info);- -/* Subroutine */ int dtptrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer *- info);- -/* Subroutine */ int dtrcon_(char *norm, char *uplo, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *rcond, doublereal *work, - integer *iwork, integer *info);- -/* Subroutine */ int dtrevc_(char *side, char *howmny, logical *select, - integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *- ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m, - doublereal *work, integer *info);- -/* Subroutine */ int dtrexc_(char *compq, integer *n, doublereal *t, integer *- ldt, doublereal *q, integer *ldq, integer *ifst, integer *ilst, - doublereal *work, integer *info);- -/* Subroutine */ int dtrrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *- ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int dtrsen_(char *job, char *compq, logical *select, integer - *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, - doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal - *sep, doublereal *work, integer *lwork, integer *iwork, integer *- liwork, integer *info);- -/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select, - integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *- ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep, - integer *mm, integer *m, doublereal *work, integer *ldwork, integer *- iwork, integer *info);- -/* Subroutine */ int dtrsyl_(char *trana, char *tranb, integer *isgn, integer - *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *- ldb, doublereal *c__, integer *ldc, doublereal *scale, integer *info);- -/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal *- a, integer *lda, integer *info);- -/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal *- a, integer *lda, integer *info);- -/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *- ldb, integer *info);- -/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, integer *info);- -/* Subroutine */ int dtzrzf_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);- -integer icmax1_(integer *n, complex *cx, integer *incx);- -integer ieeeck_(integer *ispec, real *zero, real *one);- -integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, - integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen - opts_len);- -integer izmax1_(integer *n, doublecomplex *cx, integer *incx);- -/* Subroutine */ int sbdsdc_(char *uplo, char *compq, integer *n, real *d__, - real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q, - integer *iq, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sbdsqr_(char *uplo, integer *n, integer *ncvt, integer *- nru, integer *ncc, real *d__, real *e, real *vt, integer *ldvt, real *- u, integer *ldu, real *c__, integer *ldc, real *work, integer *info);- -/* Subroutine */ int sdisna_(char *job, integer *m, integer *n, real *d__, - real *sep, integer *info);- -/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc,- integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real *- e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer - *ldc, real *work, integer *info);- -/* Subroutine */ int sgbcon_(char *norm, integer *n, integer *kl, integer *ku,- real *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, - real *work, integer *iwork, integer *info);- -/* Subroutine */ int sgbequ_(integer *m, integer *n, integer *kl, integer *ku,- real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real *- colcnd, real *amax, integer *info);- -/* Subroutine */ int sgbrfs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb,- integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *- ferr, real *berr, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sgbsv_(integer *n, integer *kl, integer *ku, integer *- nrhs, real *ab, integer *ldab, integer *ipiv, real *b, integer *ldb, - integer *info);- -/* Subroutine */ int sgbsvx_(char *fact, char *trans, integer *n, integer *kl,- integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, - integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, - real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr,- real *berr, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sgbtf2_(integer *m, integer *n, integer *kl, integer *ku,- real *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int sgbtrf_(integer *m, integer *n, integer *kl, integer *ku,- real *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int sgbtrs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, real *ab, integer *ldab, integer *ipiv, real *b, - integer *ldb, integer *info);- -/* Subroutine */ int sgebak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, real *scale, integer *m, real *v, integer *ldv, integer - *info);- -/* Subroutine */ int sgebal_(char *job, integer *n, real *a, integer *lda, - integer *ilo, integer *ihi, real *scale, integer *info);- -/* Subroutine */ int sgebd2_(integer *m, integer *n, real *a, integer *lda, - real *d__, real *e, real *tauq, real *taup, real *work, integer *info);- -/* Subroutine */ int sgebrd_(integer *m, integer *n, real *a, integer *lda, - real *d__, real *e, real *tauq, real *taup, real *work, integer *- lwork, integer *info);- -/* Subroutine */ int sgecon_(char *norm, integer *n, real *a, integer *lda, - real *anorm, real *rcond, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sgeequ_(integer *m, integer *n, real *a, integer *lda, - real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer - *info);- -/* Subroutine */ int sgees_(char *jobvs, char *sort, L_fp select, integer *n, - real *a, integer *lda, integer *sdim, real *wr, real *wi, real *vs, - integer *ldvs, real *work, integer *lwork, logical *bwork, integer *- info);- -/* Subroutine */ int sgeesx_(char *jobvs, char *sort, L_fp select, char *- sense, integer *n, real *a, integer *lda, integer *sdim, real *wr, - real *wi, real *vs, integer *ldvs, real *rconde, real *rcondv, real *- work, integer *lwork, integer *iwork, integer *liwork, logical *bwork,- integer *info);- -/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a, - integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr, - integer *ldvr, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *- vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *- ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,- integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int sgegs_(char *jobvsl, char *jobvsr, integer *n, real *a, - integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real - *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *- work, integer *lwork, integer *info);- -/* Subroutine */ int sgegv_(char *jobvl, char *jobvr, integer *n, real *a, - integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real - *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, - integer *lwork, integer *info);- -/* Subroutine */ int sgehd2_(integer *n, integer *ilo, integer *ihi, real *a, - integer *lda, real *tau, real *work, integer *info);- -/* Subroutine */ int sgehrd_(integer *n, integer *ilo, integer *ihi, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgelq2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info);- -/* Subroutine */ int sgelqf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgels_(char *trans, integer *m, integer *n, integer *- nrhs, real *a, integer *lda, real *b, integer *ldb, real *work, - integer *lwork, integer *info);- -/* Subroutine */ int sgelsd_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *- rank, real *work, integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int sgelss_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *- rank, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgelsx_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, - integer *rank, real *work, integer *info);- -/* Subroutine */ int sgelsy_(integer *m, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, - integer *rank, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgeql2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info);- -/* Subroutine */ int sgeqlf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgeqp3_(integer *m, integer *n, real *a, integer *lda, - integer *jpvt, real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda, - integer *jpvt, real *tau, real *work, integer *info);- -/* Subroutine */ int sgeqr2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info);- -/* Subroutine */ int sgeqrf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgerfs_(char *trans, integer *n, integer *nrhs, real *a, - integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, - integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *- work, integer *iwork, integer *info);- -/* Subroutine */ int sgerq2_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *info);- -/* Subroutine */ int sgerqf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgesc2_(integer *n, real *a, integer *lda, real *rhs, - integer *ipiv, integer *jpiv, real *scale);- -/* Subroutine */ int sgesdd_(char *jobz, integer *m, integer *n, real *a, - integer *lda, real *s, real *u, integer *ldu, real *vt, integer *ldvt,- real *work, integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int sgesv_(integer *n, integer *nrhs, real *a, integer *lda, - integer *ipiv, real *b, integer *ldb, integer *info);- -/* Subroutine */ int sgesvd_(char *jobu, char *jobvt, integer *m, integer *n, - real *a, integer *lda, real *s, real *u, integer *ldu, real *vt, - integer *ldvt, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgesvx_(char *fact, char *trans, integer *n, integer *- nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - char *equed, real *r__, real *c__, real *b, integer *ldb, real *x, - integer *ldx, real *rcond, real *ferr, real *berr, real *work, - integer *iwork, integer *info);- -/* Subroutine */ int sgetc2_(integer *n, real *a, integer *lda, integer *ipiv,- integer *jpiv, integer *info);- -/* Subroutine */ int sgetf2_(integer *m, integer *n, real *a, integer *lda, - integer *ipiv, integer *info);- -/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda, - integer *ipiv, integer *info);- -/* Subroutine */ int sgetri_(integer *n, real *a, integer *lda, integer *ipiv,- real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgetrs_(char *trans, integer *n, integer *nrhs, real *a, - integer *lda, integer *ipiv, real *b, integer *ldb, integer *info);- -/* Subroutine */ int sggbak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, real *lscale, real *rscale, integer *m, real *v, - integer *ldv, integer *info);- -/* Subroutine */ int sggbal_(char *job, integer *n, real *a, integer *lda, - real *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, real - *rscale, real *work, integer *info);- -/* Subroutine */ int sgges_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, integer *n, real *a, integer *lda, real *b, integer *ldb, - integer *sdim, real *alphar, real *alphai, real *beta, real *vsl, - integer *ldvsl, real *vsr, integer *ldvsr, real *work, integer *lwork,- logical *bwork, integer *info);- -/* Subroutine */ int sggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp - selctg, char *sense, integer *n, real *a, integer *lda, real *b, - integer *ldb, integer *sdim, real *alphar, real *alphai, real *beta, - real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *rconde, - real *rcondv, real *work, integer *lwork, integer *iwork, integer *- liwork, logical *bwork, integer *info);- -/* Subroutine */ int sggev_(char *jobvl, char *jobvr, integer *n, real *a, - integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real - *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, - integer *lwork, integer *info);- -/* Subroutine */ int sggevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, real *a, integer *lda, real *b, integer *ldb, real - *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr, - integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *rscale,- real *abnrm, real *bbnrm, real *rconde, real *rcondv, real *work, - integer *lwork, integer *iwork, logical *bwork, integer *info);- -/* Subroutine */ int sggglm_(integer *n, integer *m, integer *p, real *a, - integer *lda, real *b, integer *ldb, real *d__, real *x, real *y, - real *work, integer *lwork, integer *info);- -/* Subroutine */ int sgghrd_(char *compq, char *compz, integer *n, integer *- ilo, integer *ihi, real *a, integer *lda, real *b, integer *ldb, real - *q, integer *ldq, real *z__, integer *ldz, integer *info);- -/* Subroutine */ int sgglse_(integer *m, integer *n, integer *p, real *a, - integer *lda, real *b, integer *ldb, real *c__, real *d__, real *x, - real *work, integer *lwork, integer *info);- -/* Subroutine */ int sggqrf_(integer *n, integer *m, integer *p, real *a, - integer *lda, real *taua, real *b, integer *ldb, real *taub, real *- work, integer *lwork, integer *info);- -/* Subroutine */ int sggrqf_(integer *m, integer *p, integer *n, real *a, - integer *lda, real *taua, real *b, integer *ldb, real *taub, real *- work, integer *lwork, integer *info);- -/* Subroutine */ int sggsvd_(char *jobu, char *jobv, char *jobq, integer *m, - integer *n, integer *p, integer *k, integer *l, real *a, integer *lda,- real *b, integer *ldb, real *alpha, real *beta, real *u, integer *- ldu, real *v, integer *ldv, real *q, integer *ldq, real *work, - integer *iwork, integer *info);- -/* Subroutine */ int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb, - real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu,- real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real *- tau, real *work, integer *info);- -/* Subroutine */ int sgtcon_(char *norm, integer *n, real *dl, real *d__, - real *du, real *du2, integer *ipiv, real *anorm, real *rcond, real *- work, integer *iwork, integer *info);- -/* Subroutine */ int sgtrfs_(char *trans, integer *n, integer *nrhs, real *dl,- real *d__, real *du, real *dlf, real *df, real *duf, real *du2, - integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *- ferr, real *berr, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sgtsv_(integer *n, integer *nrhs, real *dl, real *d__, - real *du, real *b, integer *ldb, integer *info);- -/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer *- nrhs, real *dl, real *d__, real *du, real *dlf, real *df, real *duf, - real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer *- ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int sgttrf_(integer *n, real *dl, real *d__, real *du, real *- du2, integer *ipiv, integer *info);- -/* Subroutine */ int sgttrs_(char *trans, integer *n, integer *nrhs, real *dl,- real *d__, real *du, real *du2, integer *ipiv, real *b, integer *ldb,- integer *info);- -/* Subroutine */ int sgtts2_(integer *itrans, integer *n, integer *nrhs, real - *dl, real *d__, real *du, real *du2, integer *ipiv, real *b, integer *- ldb);- -/* Subroutine */ int shgeqz_(char *job, char *compq, char *compz, integer *n, - integer *ilo, integer *ihi, real *a, integer *lda, real *b, integer *- ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq, - real *z__, integer *ldz, real *work, integer *lwork, integer *info);- -/* Subroutine */ int shsein_(char *side, char *eigsrc, char *initv, logical *- select, integer *n, real *h__, integer *ldh, real *wr, real *wi, real - *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, - real *work, integer *ifaill, integer *ifailr, integer *info);- -/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo,- integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,- integer *ldz, real *work, integer *lwork, integer *info);- -/* Subroutine */ int slabad_(real *smalll, real *large); /* !? */- -/* Subroutine */ int slabrd_(integer *m, integer *n, integer *nb, real *a, - integer *lda, real *d__, real *e, real *tauq, real *taup, real *x, - integer *ldx, real *y, integer *ldy);- -/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn, - real *est, integer *kase);- -/* Subroutine */ int slacpy_(char *uplo, integer *m, integer *n, real *a, - integer *lda, real *b, integer *ldb);- -/* Subroutine */ int sladiv_(real *a, real *b, real *c__, real *d__, real *p, - real *q);- -/* Subroutine */ int slae2_(real *a, real *b, real *c__, real *rt1, real *rt2);- -/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n, - integer *mmax, integer *minp, integer *nbmin, real *abstol, real *- reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval, - real *ab, real *c__, integer *mout, integer *nab, real *work, integer - *iwork, integer *info);- -/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real - *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, - real *work, integer *iwork, integer *info);- -/* Subroutine */ int slaed1_(integer *n, real *d__, real *q, integer *ldq, - integer *indxq, real *rho, integer *cutpnt, real *work, integer *- iwork, integer *info);- -/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__, - real *q, integer *ldq, integer *indxq, real *rho, real *z__, real *- dlamda, real *w, real *q2, integer *indx, integer *indxc, integer *- indxp, integer *coltyp, integer *info);- -/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__, - real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *- indx, integer *ctot, real *w, real *s, integer *info);- -/* Subroutine */ int slaed4_(integer *n, integer *i__, real *d__, real *z__, - real *delta, real *rho, real *dlam, integer *info);- -/* Subroutine */ int slaed5_(integer *i__, real *d__, real *z__, real *delta, - real *rho, real *dlam);- -/* Subroutine */ int slaed6_(integer *kniter, logical *orgati, real *rho, - real *d__, real *z__, real *finit, real *tau, integer *info);- -/* Subroutine */ int slaed7_(integer *icompq, integer *n, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, real *d__, real *q, - integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *- qstore, integer *qptr, integer *prmptr, integer *perm, integer *- givptr, integer *givcol, real *givnum, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int slaed8_(integer *icompq, integer *k, integer *n, integer - *qsiz, real *d__, real *q, integer *ldq, integer *indxq, real *rho, - integer *cutpnt, real *z__, real *dlamda, real *q2, integer *ldq2, - real *w, integer *perm, integer *givptr, integer *givcol, real *- givnum, integer *indxp, integer *indx, integer *info);- -/* Subroutine */ int slaed9_(integer *k, integer *kstart, integer *kstop, - integer *n, real *d__, real *q, integer *ldq, real *rho, real *dlamda,- real *w, real *s, integer *lds, integer *info);- -/* Subroutine */ int slaeda_(integer *n, integer *tlvls, integer *curlvl, - integer *curpbm, integer *prmptr, integer *perm, integer *givptr, - integer *givcol, real *givnum, real *q, integer *qptr, real *z__, - real *ztemp, integer *info);- -/* Subroutine */ int slaein_(logical *rightv, logical *noinit, integer *n, - real *h__, integer *ldh, real *wr, real *wi, real *vr, real *vi, real - *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum, - integer *info);- -/* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real *- rt2, real *cs1, real *sn1);- -/* Subroutine */ int slaexc_(logical *wantq, integer *n, real *t, integer *- ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2, - real *work, integer *info);- -/* Subroutine */ int slag2_(real *a, integer *lda, real *b, integer *ldb, - real *safmin, real *scale1, real *scale2, real *wr1, real *wr2, real *- wi);- -/* Subroutine */ int slags2_(logical *upper, real *a1, real *a2, real *a3, - real *b1, real *b2, real *b3, real *csu, real *snu, real *csv, real *- snv, real *csq, real *snq);- -/* Subroutine */ int slagtf_(integer *n, real *a, real *lambda, real *b, real - *c__, real *tol, real *d__, integer *in, integer *info);- -/* Subroutine */ int slagtm_(char *trans, integer *n, integer *nrhs, real *- alpha, real *dl, real *d__, real *du, real *x, integer *ldx, real *- beta, real *b, integer *ldb);- -/* Subroutine */ int slagts_(integer *job, integer *n, real *a, real *b, real - *c__, real *d__, integer *in, real *y, real *tol, integer *info);- -/* Subroutine */ int slagv2_(real *a, integer *lda, real *b, integer *ldb, - real *alphar, real *alphai, real *beta, real *csl, real *snl, real *- csr, real *snr);- -/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *- wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *- info);- -/* Subroutine */ int slahrd_(integer *n, integer *k, integer *nb, real *a, - integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy);- -/* Subroutine */ int slaic1_(integer *job, integer *j, real *x, real *sest, - real *w, real *gamma, real *sestpr, real *s, real *c__);- -/* Subroutine */ int slaln2_(logical *ltrans, integer *na, integer *nw, real *- smin, real *ca, real *a, integer *lda, real *d1, real *d2, real *b, - integer *ldb, real *wr, real *wi, real *x, integer *ldx, real *scale, - real *xnorm, integer *info);- -/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx, - integer *ldbx, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *- difl, real *difr, real *z__, integer *k, real *c__, real *s, real *- work, integer *info);- -/* Subroutine */ int slalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, real *- u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real *- z__, real *poles, integer *givptr, integer *givcol, integer *ldgcol, - integer *perm, real *givnum, real *c__, real *s, real *work, integer *- iwork, integer *info);- -/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer - *nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond, - integer *rank, real *work, integer *iwork, integer *info);- -/* Subroutine */ int slamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1);- -/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *- eps, integer *emin, real *rmin, integer *emax, real *rmax);- -/* Subroutine */ int slamc4_(integer *emin, real *start, integer *base);- -/* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin, - logical *ieee, integer *emax, real *rmax);- -/* Subroutine */ int slamrg_(integer *n1, integer *n2, real *a, integer *- strd1, integer *strd2, integer *index);- -/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real *- rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn);- -/* Subroutine */ int slapll_(integer *n, real *x, integer *incx, real *y, - integer *incy, real *ssmin);- -/* Subroutine */ int slapmt_(logical *forwrd, integer *m, integer *n, real *x,- integer *ldx, integer *k);- -/* Subroutine */ int slaqgb_(integer *m, integer *n, integer *kl, integer *ku,- real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real *- colcnd, real *amax, char *equed);- -/* Subroutine */ int slaqge_(integer *m, integer *n, real *a, integer *lda, - real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char *- equed);- -/* Subroutine */ int slaqp2_(integer *m, integer *n, integer *offset, real *a,- integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real *- work);- -/* Subroutine */ int slaqps_(integer *m, integer *n, integer *offset, integer - *nb, integer *kb, real *a, integer *lda, integer *jpvt, real *tau, - real *vn1, real *vn2, real *auxv, real *f, integer *ldf);- -/* Subroutine */ int slaqsb_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, real *s, real *scond, real *amax, char *equed);- -/* Subroutine */ int slaqsp_(char *uplo, integer *n, real *ap, real *s, real *- scond, real *amax, char *equed);- -/* Subroutine */ int slaqsy_(char *uplo, integer *n, real *a, integer *lda, - real *s, real *scond, real *amax, char *equed);- -/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real - *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work, - integer *info);- -/* Subroutine */ int slar1v_(integer *n, integer *b1, integer *bn, real *- sigma, real *d__, real *l, real *ld, real *lld, real *gersch, real *- z__, real *ztz, real *mingma, integer *r__, integer *isuppz, real *- work);- -/* Subroutine */ int slar2v_(integer *n, real *x, real *y, real *z__, integer - *incx, real *c__, real *s, integer *incc);- -/* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v, - integer *incv, real *tau, real *c__, integer *ldc, real *work);- -/* Subroutine */ int slarfb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, real *v, integer *ldv, - real *t, integer *ldt, real *c__, integer *ldc, real *work, integer *- ldwork);- -/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx, - real *tau);- -/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer *- k, real *v, integer *ldv, real *tau, real *t, integer *ldt);- -/* Subroutine */ int slarfx_(char *side, integer *m, integer *n, real *v, - real *tau, real *c__, integer *ldc, real *work);- -/* Subroutine */ int slargv_(integer *n, real *x, integer *incx, real *y, - integer *incy, real *c__, integer *incc);- -/* Subroutine */ int slarnv_(integer *idist, integer *iseed, integer *n, real - *x);- -/* Subroutine */ int slarrb_(integer *n, real *d__, real *l, real *ld, real *- lld, integer *ifirst, integer *ilast, real *sigma, real *reltol, real - *w, real *wgap, real *werr, real *work, integer *iwork, integer *info);- -/* Subroutine */ int slarre_(integer *n, real *d__, real *e, real *tol, - integer *nsplit, integer *isplit, integer *m, real *w, real *woff, - real *gersch, real *work, integer *info);- -/* Subroutine */ int slarrf_(integer *n, real *d__, real *l, real *ld, real *- lld, integer *ifirst, integer *ilast, real *w, real *dplus, real *- lplus, real *work, integer *iwork, integer *info);- -/* Subroutine */ int slarrv_(integer *n, real *d__, real *l, integer *isplit, - integer *m, real *w, integer *iblock, real *gersch, real *tol, real *- z__, integer *ldz, integer *isuppz, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r__);- -/* Subroutine */ int slartv_(integer *n, real *x, integer *incx, real *y, - integer *incy, real *c__, real *s, integer *incc);- -/* Subroutine */ int slaruv_(integer *iseed, integer *n, real *x);- -/* Subroutine */ int slarz_(char *side, integer *m, integer *n, integer *l, - real *v, integer *incv, real *tau, real *c__, integer *ldc, real *- work);- -/* Subroutine */ int slarzb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, integer *l, real *v, - integer *ldv, real *t, integer *ldt, real *c__, integer *ldc, real *- work, integer *ldwork);- -/* Subroutine */ int slarzt_(char *direct, char *storev, integer *n, integer *- k, real *v, integer *ldv, real *tau, real *t, integer *ldt);- -/* Subroutine */ int slas2_(real *f, real *g, real *h__, real *ssmin, real *- ssmax);- -/* Subroutine */ int slascl_(char *type__, integer *kl, integer *ku, real *- cfrom, real *cto, integer *m, integer *n, real *a, integer *lda, - integer *info);- -/* Subroutine */ int slasd0_(integer *n, integer *sqre, real *d__, real *e, - real *u, integer *ldu, real *vt, integer *ldvt, integer *smlsiz, - integer *iwork, real *work, integer *info);- -/* Subroutine */ int slasd1_(integer *nl, integer *nr, integer *sqre, real *- d__, real *alpha, real *beta, real *u, integer *ldu, real *vt, - integer *ldvt, integer *idxq, integer *iwork, real *work, integer *- info);- -/* Subroutine */ int slasd2_(integer *nl, integer *nr, integer *sqre, integer - *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer *- ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2, - real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc,- integer *idxq, integer *coltyp, integer *info);- -/* Subroutine */ int slasd3_(integer *nl, integer *nr, integer *sqre, integer - *k, real *d__, real *q, integer *ldq, real *dsigma, real *u, integer *- ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2, - integer *ldvt2, integer *idxc, integer *ctot, real *z__, integer *- info);- -/* Subroutine */ int slasd4_(integer *n, integer *i__, real *d__, real *z__, - real *delta, real *rho, real *sigma, real *work, integer *info);- -/* Subroutine */ int slasd5_(integer *i__, real *d__, real *z__, real *delta, - real *rho, real *dsigma, real *work);- -/* Subroutine */ int slasd6_(integer *icompq, integer *nl, integer *nr, - integer *sqre, real *d__, real *vf, real *vl, real *alpha, real *beta,- integer *idxq, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *- difl, real *difr, real *z__, integer *k, real *c__, real *s, real *- work, integer *iwork, integer *info);- -/* Subroutine */ int slasd7_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *k, real *d__, real *z__, real *zw, real *vf, - real *vfw, real *vl, real *vlw, real *alpha, real *beta, real *dsigma,- integer *idx, integer *idxp, integer *idxq, integer *perm, integer *- givptr, integer *givcol, integer *ldgcol, real *givnum, integer *- ldgnum, real *c__, real *s, integer *info);- -/* Subroutine */ int slasd8_(integer *icompq, integer *k, real *d__, real *- z__, real *vf, real *vl, real *difl, real *difr, integer *lddifr, - real *dsigma, real *work, integer *info);- -/* Subroutine */ int slasd9_(integer *icompq, integer *ldu, integer *k, real *- d__, real *z__, real *vf, real *vl, real *difl, real *difr, real *- dsigma, real *work, integer *info);- -/* Subroutine */ int slasda_(integer *icompq, integer *smlsiz, integer *n, - integer *sqre, real *d__, real *e, real *u, integer *ldu, real *vt, - integer *k, real *difl, real *difr, real *z__, real *poles, integer *- givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum,- real *c__, real *s, real *work, integer *iwork, integer *info);- -/* Subroutine */ int slasdq_(char *uplo, integer *sqre, integer *n, integer *- ncvt, integer *nru, integer *ncc, real *d__, real *e, real *vt, - integer *ldvt, real *u, integer *ldu, real *c__, integer *ldc, real *- work, integer *info);- -/* Subroutine */ int slasdt_(integer *n, integer *lvl, integer *nd, integer *- inode, integer *ndiml, integer *ndimr, integer *msub);- -/* Subroutine */ int slaset_(char *uplo, integer *m, integer *n, real *alpha, - real *beta, real *a, integer *lda);- -/* Subroutine */ int slasq1_(integer *n, real *d__, real *e, real *work, - integer *info);- -/* Subroutine */ int slasq2_(integer *n, real *z__, integer *info);- -/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp,- real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail, - integer *iter, integer *ndiv, logical *ieee);- -/* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp,- integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn, - real *dn1, real *dn2, real *tau, integer *ttype);- -/* Subroutine */ int slasq5_(integer *i0, integer *n0, real *z__, integer *pp,- real *tau, real *dmin__, real *dmin1, real *dmin2, real *dn, real *- dnm1, real *dnm2, logical *ieee);- -/* Subroutine */ int slasq6_(integer *i0, integer *n0, real *z__, integer *pp,- real *dmin__, real *dmin1, real *dmin2, real *dn, real *dnm1, real *- dnm2);- -/* Subroutine */ int slasr_(char *side, char *pivot, char *direct, integer *m,- integer *n, real *c__, real *s, real *a, integer *lda);- -/* Subroutine */ int slasrt_(char *id, integer *n, real *d__, integer *info);- -/* Subroutine */ int slassq_(integer *n, real *x, integer *incx, real *scale, - real *sumsq);- -/* Subroutine */ int slasv2_(real *f, real *g, real *h__, real *ssmin, real *- ssmax, real *snr, real *csr, real *snl, real *csl);- -/* Subroutine */ int slaswp_(integer *n, real *a, integer *lda, integer *k1, - integer *k2, integer *ipiv, integer *incx);- -/* Subroutine */ int slasy2_(logical *ltranl, logical *ltranr, integer *isgn, - integer *n1, integer *n2, real *tl, integer *ldtl, real *tr, integer *- ldtr, real *b, integer *ldb, real *scale, real *x, integer *ldx, real - *xnorm, integer *info);- -/* Subroutine */ int slasyf_(char *uplo, integer *n, integer *nb, integer *kb,- real *a, integer *lda, integer *ipiv, real *w, integer *ldw, integer - *info);- -/* Subroutine */ int slatbs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, integer *kd, real *ab, integer *ldab, real *x, - real *scale, real *cnorm, integer *info);- -/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer *- ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer *- jpiv);- -/* Subroutine */ int slatps_(char *uplo, char *trans, char *diag, char *- normin, integer *n, real *ap, real *x, real *scale, real *cnorm, - integer *info);- -/* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a, - integer *lda, real *e, real *tau, real *w, integer *ldw);- -/* Subroutine */ int slatrs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, real *a, integer *lda, real *x, real *scale, real - *cnorm, integer *info);- -/* Subroutine */ int slatrz_(integer *m, integer *n, integer *l, real *a, - integer *lda, real *tau, real *work);- -/* Subroutine */ int slatzm_(char *side, integer *m, integer *n, real *v, - integer *incv, real *tau, real *c1, real *c2, integer *ldc, real *- work);- -/* Subroutine */ int slauu2_(char *uplo, integer *n, real *a, integer *lda, - integer *info);- -/* Subroutine */ int slauum_(char *uplo, integer *n, real *a, integer *lda, - integer *info);- -/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau, - real *q, integer *ldq, real *work, integer *info);- -/* Subroutine */ int sopmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, real *ap, real *tau, real *c__, integer *ldc, real *work, - integer *info);- -/* Subroutine */ int sorg2l_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info);- -/* Subroutine */ int sorg2r_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info);- -/* Subroutine */ int sorgbr_(char *vect, integer *m, integer *n, integer *k, - real *a, integer *lda, real *tau, real *work, integer *lwork, integer - *info);- -/* Subroutine */ int sorghr_(integer *n, integer *ilo, integer *ihi, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sorgl2_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info);- -/* Subroutine */ int sorglq_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sorgql_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sorgqr_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sorgr2_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *info);- -/* Subroutine */ int sorgrq_(integer *m, integer *n, integer *k, real *a, - integer *lda, real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sorgtr_(char *uplo, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sorm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *info);- -/* Subroutine */ int sorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *info);- -/* Subroutine */ int sormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, real *a, integer *lda, real *tau, real *c__, - integer *ldc, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sormhr_(char *side, char *trans, integer *m, integer *n, - integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *- c__, integer *ldc, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *info);- -/* Subroutine */ int sormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *lwork, integer *info);- -/* Subroutine */ int sormql_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *lwork, integer *info);- -/* Subroutine */ int sormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *lwork, integer *info);- -/* Subroutine */ int sormr2_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *info);- -/* Subroutine */ int sormr3_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, real *a, integer *lda, real *tau, real *c__, - integer *ldc, real *work, integer *info);- -/* Subroutine */ int sormrq_(char *side, char *trans, integer *m, integer *n, - integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *lwork, integer *info);- -/* Subroutine */ int sormrz_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, real *a, integer *lda, real *tau, real *c__, - integer *ldc, real *work, integer *lwork, integer *info);- -/* Subroutine */ int sormtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc,- real *work, integer *lwork, integer *info);- -/* Subroutine */ int spbcon_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, real *anorm, real *rcond, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int spbequ_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, real *s, real *scond, real *amax, integer *info);- -/* Subroutine */ int spbrfs_(char *uplo, integer *n, integer *kd, integer *- nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, real *b, - integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *- work, integer *iwork, integer *info);- -/* Subroutine */ int spbstf_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, integer *info);- -/* Subroutine */ int spbsv_(char *uplo, integer *n, integer *kd, integer *- nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info);- -/* Subroutine */ int spbsvx_(char *fact, char *uplo, integer *n, integer *kd, - integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, - char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, - real *rcond, real *ferr, real *berr, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int spbtf2_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, integer *info);- -/* Subroutine */ int spbtrf_(char *uplo, integer *n, integer *kd, real *ab, - integer *ldab, integer *info);- -/* Subroutine */ int spbtrs_(char *uplo, integer *n, integer *kd, integer *- nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info);- -/* Subroutine */ int spocon_(char *uplo, integer *n, real *a, integer *lda, - real *anorm, real *rcond, real *work, integer *iwork, integer *info);- -/* Subroutine */ int spoequ_(integer *n, real *a, integer *lda, real *s, real - *scond, real *amax, integer *info);- -/* Subroutine */ int sporfs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *af, integer *ldaf, real *b, integer *ldb, real *x,- integer *ldx, real *ferr, real *berr, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int sposv_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *info);- -/* Subroutine */ int sposvx_(char *fact, char *uplo, integer *n, integer *- nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed, - real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, - real *ferr, real *berr, real *work, integer *iwork, integer *info);- -/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda, - integer *info);- -/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda, - integer *info);- -/* Subroutine */ int spotri_(char *uplo, integer *n, real *a, integer *lda, - integer *info);- -/* Subroutine */ int spotrs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *b, integer *ldb, integer *info);- -/* Subroutine */ int sppcon_(char *uplo, integer *n, real *ap, real *anorm, - real *rcond, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sppequ_(char *uplo, integer *n, real *ap, real *s, real *- scond, real *amax, integer *info);- -/* Subroutine */ int spprfs_(char *uplo, integer *n, integer *nrhs, real *ap, - real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr, - real *berr, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sppsv_(char *uplo, integer *n, integer *nrhs, real *ap, - real *b, integer *ldb, integer *info);- -/* Subroutine */ int sppsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, real *ap, real *afp, char *equed, real *s, real *b, integer *- ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real - *work, integer *iwork, integer *info);- -/* Subroutine */ int spptrf_(char *uplo, integer *n, real *ap, integer *info);- -/* Subroutine */ int spptri_(char *uplo, integer *n, real *ap, integer *info);- -/* Subroutine */ int spptrs_(char *uplo, integer *n, integer *nrhs, real *ap, - real *b, integer *ldb, integer *info);- -/* Subroutine */ int sptcon_(integer *n, real *d__, real *e, real *anorm, - real *rcond, real *work, integer *info);- -/* Subroutine */ int spteqr_(char *compz, integer *n, real *d__, real *e, - real *z__, integer *ldz, real *work, integer *info);- -/* Subroutine */ int sptrfs_(integer *n, integer *nrhs, real *d__, real *e, - real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx, - real *ferr, real *berr, real *work, integer *info);- -/* Subroutine */ int sptsv_(integer *n, integer *nrhs, real *d__, real *e, - real *b, integer *ldb, integer *info);- -/* Subroutine */ int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__,- real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer - *ldx, real *rcond, real *ferr, real *berr, real *work, integer *info);- -/* Subroutine */ int spttrf_(integer *n, real *d__, real *e, integer *info);- -/* Subroutine */ int spttrs_(integer *n, integer *nrhs, real *d__, real *e, - real *b, integer *ldb, integer *info);- -/* Subroutine */ int sptts2_(integer *n, integer *nrhs, real *d__, real *e, - real *b, integer *ldb);- -/* Subroutine */ int srscl_(integer *n, real *sa, real *sx, integer *incx);- -/* Subroutine */ int ssbev_(char *jobz, char *uplo, integer *n, integer *kd, - real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work,- integer *info);- -/* Subroutine */ int ssbevd_(char *jobz, char *uplo, integer *n, integer *kd, - real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work,- integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int ssbevx_(char *jobz, char *range, char *uplo, integer *n, - integer *kd, real *ab, integer *ldab, real *q, integer *ldq, real *vl,- real *vu, integer *il, integer *iu, real *abstol, integer *m, real *- w, real *z__, integer *ldz, real *work, integer *iwork, integer *- ifail, integer *info);- -/* Subroutine */ int ssbgst_(char *vect, char *uplo, integer *n, integer *ka, - integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *- x, integer *ldx, real *work, integer *info);- -/* Subroutine */ int ssbgv_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *- w, real *z__, integer *ldz, real *work, integer *info);- -/* Subroutine */ int ssbgvd_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *- w, real *z__, integer *ldz, real *work, integer *lwork, integer *- iwork, integer *liwork, integer *info);- -/* Subroutine */ int ssbgvx_(char *jobz, char *range, char *uplo, integer *n, - integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer *- ldbb, real *q, integer *ldq, real *vl, real *vu, integer *il, integer - *iu, real *abstol, integer *m, real *w, real *z__, integer *ldz, real - *work, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int ssbtrd_(char *vect, char *uplo, integer *n, integer *kd, - real *ab, integer *ldab, real *d__, real *e, real *q, integer *ldq, - real *work, integer *info);- -/* Subroutine */ int sspcon_(char *uplo, integer *n, real *ap, integer *ipiv, - real *anorm, real *rcond, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sspev_(char *jobz, char *uplo, integer *n, real *ap, - real *w, real *z__, integer *ldz, real *work, integer *info);- -/* Subroutine */ int sspevd_(char *jobz, char *uplo, integer *n, real *ap, - real *w, real *z__, integer *ldz, real *work, integer *lwork, integer - *iwork, integer *liwork, integer *info);- -/* Subroutine */ int sspevx_(char *jobz, char *range, char *uplo, integer *n, - real *ap, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, real *work, integer *- iwork, integer *ifail, integer *info);- -/* Subroutine */ int sspgst_(integer *itype, char *uplo, integer *n, real *ap,- real *bp, integer *info);- -/* Subroutine */ int sspgv_(integer *itype, char *jobz, char *uplo, integer *- n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work, - integer *info);- -/* Subroutine */ int sspgvd_(integer *itype, char *jobz, char *uplo, integer *- n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int sspgvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, real *ap, real *bp, real *vl, real *vu, integer *il,- integer *iu, real *abstol, integer *m, real *w, real *z__, integer *- ldz, real *work, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int ssprfs_(char *uplo, integer *n, integer *nrhs, real *ap, - real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer *- ldx, real *ferr, real *berr, real *work, integer *iwork, integer *- info);- -/* Subroutine */ int sspsv_(char *uplo, integer *n, integer *nrhs, real *ap, - integer *ipiv, real *b, integer *ldb, integer *info);- -/* Subroutine */ int sspsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, real *ap, real *afp, integer *ipiv, real *b, integer *ldb, real - *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, - integer *iwork, integer *info);- -/* Subroutine */ int ssptrd_(char *uplo, integer *n, real *ap, real *d__, - real *e, real *tau, integer *info);- -/* Subroutine */ int ssptrf_(char *uplo, integer *n, real *ap, integer *ipiv, - integer *info);- -/* Subroutine */ int ssptri_(char *uplo, integer *n, real *ap, integer *ipiv, - real *work, integer *info);- -/* Subroutine */ int ssptrs_(char *uplo, integer *n, integer *nrhs, real *ap, - integer *ipiv, real *b, integer *ldb, integer *info);- -/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl, - real *vu, integer *il, integer *iu, real *abstol, real *d__, real *e, - integer *m, integer *nsplit, real *w, integer *iblock, integer *- isplit, real *work, integer *iwork, integer *info);- -/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e, - real *z__, integer *ldz, real *work, integer *lwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int sstegr_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real *- work, integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int sstein_(integer *n, real *d__, real *e, integer *m, real - *w, integer *iblock, integer *isplit, real *z__, integer *ldz, real *- work, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e, - real *z__, integer *ldz, real *work, integer *info);- -/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info);- -/* Subroutine */ int sstev_(char *jobz, integer *n, real *d__, real *e, real *- z__, integer *ldz, real *work, integer *info);- -/* Subroutine */ int sstevd_(char *jobz, integer *n, real *d__, real *e, real - *z__, integer *ldz, real *work, integer *lwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int sstevr_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real *- work, integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int sstevx_(char *jobz, char *range, integer *n, real *d__, - real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, - integer *m, real *w, real *z__, integer *ldz, real *work, integer *- iwork, integer *ifail, integer *info);- -/* Subroutine */ int ssycon_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int ssyev_(char *jobz, char *uplo, integer *n, real *a, - integer *lda, real *w, real *work, integer *lwork, integer *info);- -/* Subroutine */ int ssyevd_(char *jobz, char *uplo, integer *n, real *a, - integer *lda, real *w, real *work, integer *lwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int ssyevr_(char *jobz, char *range, char *uplo, integer *n, - real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, - real *abstol, integer *m, real *w, real *z__, integer *ldz, integer *- isuppz, real *work, integer *lwork, integer *iwork, integer *liwork, - integer *info);- -/* Subroutine */ int ssyevx_(char *jobz, char *range, char *uplo, integer *n, - real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, - real *abstol, integer *m, real *w, real *z__, integer *ldz, real *- work, integer *lwork, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int ssygs2_(integer *itype, char *uplo, integer *n, real *a, - integer *lda, real *b, integer *ldb, integer *info);- -/* Subroutine */ int ssygst_(integer *itype, char *uplo, integer *n, real *a, - integer *lda, real *b, integer *ldb, integer *info);- -/* Subroutine */ int ssygv_(integer *itype, char *jobz, char *uplo, integer *- n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, - integer *lwork, integer *info);- -/* Subroutine */ int ssygvd_(integer *itype, char *jobz, char *uplo, integer *- n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, - integer *lwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int ssygvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real *- vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, - real *w, real *z__, integer *ldz, real *work, integer *lwork, integer - *iwork, integer *ifail, integer *info);- -/* Subroutine */ int ssyrfs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, - integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *- work, integer *iwork, integer *info);- -/* Subroutine */ int ssysv_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, integer *ipiv, real *b, integer *ldb, real *work, - integer *lwork, integer *info);- -/* Subroutine */ int ssysvx_(char *fact, char *uplo, integer *n, integer *- nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, - real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr,- real *berr, real *work, integer *lwork, integer *iwork, integer *- info);- -/* Subroutine */ int ssytd2_(char *uplo, integer *n, real *a, integer *lda, - real *d__, real *e, real *tau, integer *info);- -/* Subroutine */ int ssytf2_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, integer *info);- -/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda, - real *d__, real *e, real *tau, real *work, integer *lwork, integer *- info);- -/* Subroutine */ int ssytrf_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, real *work, integer *lwork, integer *info);- -/* Subroutine */ int ssytri_(char *uplo, integer *n, real *a, integer *lda, - integer *ipiv, real *work, integer *info);- -/* Subroutine */ int ssytrs_(char *uplo, integer *n, integer *nrhs, real *a, - integer *lda, integer *ipiv, real *b, integer *ldb, integer *info);- -/* Subroutine */ int stbcon_(char *norm, char *uplo, char *diag, integer *n, - integer *kd, real *ab, integer *ldab, real *rcond, real *work, - integer *iwork, integer *info);- -/* Subroutine */ int stbrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer - *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, - integer *iwork, integer *info);- -/* Subroutine */ int stbtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer - *ldb, integer *info);- -/* Subroutine */ int stgevc_(char *side, char *howmny, logical *select, - integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl, - integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real - *work, integer *info);- -/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real - *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *- z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work, - integer *lwork, integer *info);- -/* Subroutine */ int stgexc_(logical *wantq, logical *wantz, integer *n, real - *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *- z__, integer *ldz, integer *ifst, integer *ilst, real *work, integer *- lwork, integer *info);- -/* Subroutine */ int stgsen_(integer *ijob, logical *wantq, logical *wantz, - logical *select, integer *n, real *a, integer *lda, real *b, integer *- ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq, - real *z__, integer *ldz, integer *m, real *pl, real *pr, real *dif, - real *work, integer *lwork, integer *iwork, integer *liwork, integer *- info);- -/* Subroutine */ int stgsja_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, integer *k, integer *l, real *a, integer *lda,- real *b, integer *ldb, real *tola, real *tolb, real *alpha, real *- beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *- ldq, real *work, integer *ncycle, integer *info);- -/* Subroutine */ int stgsna_(char *job, char *howmny, logical *select, - integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl, - integer *ldvl, real *vr, integer *ldvr, real *s, real *dif, integer *- mm, integer *m, real *work, integer *lwork, integer *iwork, integer *- info);- -/* Subroutine */ int stgsy2_(char *trans, integer *ijob, integer *m, integer *- n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer *- ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer - *ldf, real *scale, real *rdsum, real *rdscal, integer *iwork, integer - *pq, integer *info);- -/* Subroutine */ int stgsyl_(char *trans, integer *ijob, integer *m, integer *- n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer *- ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer - *ldf, real *scale, real *dif, real *work, integer *lwork, integer *- iwork, integer *info);- -/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n, - real *ap, real *rcond, real *work, integer *iwork, integer *info);- -/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx,- real *ferr, real *berr, real *work, integer *iwork, integer *info);- -/* Subroutine */ int stptri_(char *uplo, char *diag, integer *n, real *ap, - integer *info);- -/* Subroutine */ int stptrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *ap, real *b, integer *ldb, integer *info);- -/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n, - real *a, integer *lda, real *rcond, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int strevc_(char *side, char *howmny, logical *select, - integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, - integer *ldvr, integer *mm, integer *m, real *work, integer *info);- -/* Subroutine */ int strexc_(char *compq, integer *n, real *t, integer *ldt, - real *q, integer *ldq, integer *ifst, integer *ilst, real *work, - integer *info);- -/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x, - integer *ldx, real *ferr, real *berr, real *work, integer *iwork, - integer *info);- -/* Subroutine */ int strsen_(char *job, char *compq, logical *select, integer - *n, real *t, integer *ldt, real *q, integer *ldq, real *wr, real *wi, - integer *m, real *s, real *sep, real *work, integer *lwork, integer *- iwork, integer *liwork, integer *info);- -/* Subroutine */ int strsna_(char *job, char *howmny, logical *select, - integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, - integer *ldvr, real *s, real *sep, integer *mm, integer *m, real *- work, integer *ldwork, integer *iwork, integer *info);- -/* Subroutine */ int strsyl_(char *trana, char *tranb, integer *isgn, integer - *m, integer *n, real *a, integer *lda, real *b, integer *ldb, real *- c__, integer *ldc, real *scale, integer *info);- -/* Subroutine */ int strti2_(char *uplo, char *diag, integer *n, real *a, - integer *lda, integer *info);- -/* Subroutine */ int strtri_(char *uplo, char *diag, integer *n, real *a, - integer *lda, integer *info);- -/* Subroutine */ int strtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *- info);- -/* Subroutine */ int stzrqf_(integer *m, integer *n, real *a, integer *lda, - real *tau, integer *info);- -/* Subroutine */ int stzrzf_(integer *m, integer *n, real *a, integer *lda, - real *tau, real *work, integer *lwork, integer *info);- -/* Subroutine */ int xerbla_(char *srname, integer *info);- -/* Subroutine */ int zbdsqr_(char *uplo, integer *n, integer *ncvt, integer *- nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt, - integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__, - integer *ldc, doublereal *rwork, integer *info);- -/* Subroutine */ int zdrot_(integer *n, doublecomplex *cx, integer *incx, - doublecomplex *cy, integer *incy, doublereal *c__, doublereal *s);- -/* Subroutine */ int zdrscl_(integer *n, doublereal *sa, doublecomplex *sx, - integer *incx);- -/* Subroutine */ int zgbbrd_(char *vect, integer *m, integer *n, integer *ncc,- integer *kl, integer *ku, doublecomplex *ab, integer *ldab, - doublereal *d__, doublereal *e, doublecomplex *q, integer *ldq, - doublecomplex *pt, integer *ldpt, doublecomplex *c__, integer *ldc, - doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int zgbcon_(char *norm, integer *n, integer *kl, integer *ku,- doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm, - doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int zgbequ_(integer *m, integer *n, integer *kl, integer *ku,- doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *- info);- -/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *- afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb, - doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int zgbsv_(integer *n, integer *kl, integer *ku, integer *- nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, doublecomplex *- b, integer *ldb, integer *info);- -/* Subroutine */ int zgbsvx_(char *fact, char *trans, integer *n, integer *kl,- integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, - doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed, - doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb, - doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, - doublereal *berr, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int zgbtf2_(integer *m, integer *n, integer *kl, integer *ku,- doublecomplex *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int zgbtrf_(integer *m, integer *n, integer *kl, integer *ku,- doublecomplex *ab, integer *ldab, integer *ipiv, integer *info);- -/* Subroutine */ int zgbtrs_(char *trans, integer *n, integer *kl, integer *- ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, - doublecomplex *b, integer *ldb, integer *info);- -/* Subroutine */ int zgebak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, doublereal *scale, integer *m, doublecomplex *v, - integer *ldv, integer *info);- -/* Subroutine */ int zgebal_(char *job, integer *n, doublecomplex *a, integer - *lda, integer *ilo, integer *ihi, doublereal *scale, integer *info);- -/* Subroutine */ int zgebd2_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq, - doublecomplex *taup, doublecomplex *work, integer *info);- -/* Subroutine */ int zgebrd_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq, - doublecomplex *taup, doublecomplex *work, integer *lwork, integer *- info);- -/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a, - integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zgeequ_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, - doublereal *colcnd, doublereal *amax, integer *info);- -/* Subroutine */ int zgees_(char *jobvs, char *sort, L_fp select, integer *n, - doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, - doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,- doublereal *rwork, logical *bwork, integer *info);- -/* Subroutine */ int zgeesx_(char *jobvs, char *sort, L_fp select, char *- sense, integer *n, doublecomplex *a, integer *lda, integer *sdim, - doublecomplex *w, doublecomplex *vs, integer *ldvs, doublereal *- rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, - doublereal *rwork, logical *bwork, integer *info);- -/* Subroutine */ int zgeev_(char *jobvl, char *jobvr, integer *n, - doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl, - integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, - integer *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zgeevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w, - doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, - integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm, - doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *- lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zgegs_(char *jobvsl, char *jobvsr, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl, - integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex *- work, integer *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zgegv_(char *jobvl, char *jobvr, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer - *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer - *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *info);- -/* Subroutine */ int zgehrd_(integer *n, integer *ilo, integer *ihi, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zgelq2_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);- -/* Subroutine */ int zgelqf_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer *- nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *work, integer *lwork, integer *info);- -/* Subroutine */ int zgelsx_(integer *m, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, - doublereal *rwork, integer *info);- -/* Subroutine */ int zgelsy_(integer *m, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, - integer *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zgeql2_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);- -/* Subroutine */ int zgeqlf_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zgeqp3_(integer *m, integer *n, doublecomplex *a, - integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, - integer *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a, - integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, - doublereal *rwork, integer *info);- -/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);- -/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zgerfs_(char *trans, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, - integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, - integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,- doublereal *rwork, integer *info);- -/* Subroutine */ int zgerq2_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);- -/* Subroutine */ int zgerqf_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zgesc2_(integer *n, doublecomplex *a, integer *lda, - doublecomplex *rhs, integer *ipiv, integer *jpiv, doublereal *scale);- -/* Subroutine */ int zgesv_(integer *n, integer *nrhs, doublecomplex *a, - integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *- info);- -/* Subroutine */ int zgesvx_(char *fact, char *trans, integer *n, integer *- nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *- ldaf, integer *ipiv, char *equed, doublereal *r__, doublereal *c__, - doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zgetc2_(integer *n, doublecomplex *a, integer *lda, - integer *ipiv, integer *jpiv, integer *info);- -/* Subroutine */ int zgetf2_(integer *m, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, integer *info);- -/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, integer *info);- -/* Subroutine */ int zgetri_(integer *n, doublecomplex *a, integer *lda, - integer *ipiv, doublecomplex *work, integer *lwork, integer *info);- -/* Subroutine */ int zgetrs_(char *trans, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, - integer *ldb, integer *info);- -/* Subroutine */ int zggbak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, doublereal *lscale, doublereal *rscale, integer *m, - doublecomplex *v, integer *ldv, integer *info);- -/* Subroutine */ int zggbal_(char *job, integer *n, doublecomplex *a, integer - *lda, doublecomplex *b, integer *ldb, integer *ilo, integer *ihi, - doublereal *lscale, doublereal *rscale, doublereal *work, integer *- info);- -/* Subroutine */ int zgges_(char *jobvsl, char *jobvsr, char *sort, L_fp - delctg, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, - integer *ldb, integer *sdim, doublecomplex *alpha, doublecomplex *- beta, doublecomplex *vsl, integer *ldvsl, doublecomplex *vsr, integer - *ldvsr, doublecomplex *work, integer *lwork, doublereal *rwork, - logical *bwork, integer *info);- -/* Subroutine */ int zggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp - delctg, char *sense, integer *n, doublecomplex *a, integer *lda, - doublecomplex *b, integer *ldb, integer *sdim, doublecomplex *alpha, - doublecomplex *beta, doublecomplex *vsl, integer *ldvsl, - doublecomplex *vsr, integer *ldvsr, doublereal *rconde, doublereal *- rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, - integer *iwork, integer *liwork, logical *bwork, integer *info);- -/* Subroutine */ int zggev_(char *jobvl, char *jobvr, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer - *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer - *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zggevx_(char *balanc, char *jobvl, char *jobvr, char *- sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, - integer *ldb, doublecomplex *alpha, doublecomplex *beta, - doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, - integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, - doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *- rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, - integer *iwork, logical *bwork, integer *info);- -/* Subroutine */ int zggglm_(integer *n, integer *m, integer *p, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *d__, doublecomplex *x, doublecomplex *y, doublecomplex - *work, integer *lwork, integer *info);- -/* Subroutine */ int zgghrd_(char *compq, char *compz, integer *n, integer *- ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *b, - integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z__, - integer *ldz, integer *info);- -/* Subroutine */ int zgglse_(integer *m, integer *n, integer *p, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *c__, doublecomplex *d__, doublecomplex *x, - doublecomplex *work, integer *lwork, integer *info);- -/* Subroutine */ int zggqrf_(integer *n, integer *m, integer *p, - doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b,- integer *ldb, doublecomplex *taub, doublecomplex *work, integer *- lwork, integer *info);- -/* Subroutine */ int zggrqf_(integer *m, integer *p, integer *n, - doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b,- integer *ldb, doublecomplex *taub, doublecomplex *work, integer *- lwork, integer *info);- -/* Subroutine */ int zggsvd_(char *jobu, char *jobv, char *jobq, integer *m, - integer *n, integer *p, integer *k, integer *l, doublecomplex *a, - integer *lda, doublecomplex *b, integer *ldb, doublereal *alpha, - doublereal *beta, doublecomplex *u, integer *ldu, doublecomplex *v, - integer *ldv, doublecomplex *q, integer *ldq, doublecomplex *work, - doublereal *rwork, integer *iwork, integer *info);- -/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex - *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k, - integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer - *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal *- rwork, doublecomplex *tau, doublecomplex *work, integer *info);- -/* Subroutine */ int zgtcon_(char *norm, integer *n, doublecomplex *dl, - doublecomplex *d__, doublecomplex *du, doublecomplex *du2, integer *- ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work, - integer *info);- -/* Subroutine */ int zgtrfs_(char *trans, integer *n, integer *nrhs, - doublecomplex *dl, doublecomplex *d__, doublecomplex *du, - doublecomplex *dlf, doublecomplex *df, doublecomplex *duf, - doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, - doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int zgtsv_(integer *n, integer *nrhs, doublecomplex *dl, - doublecomplex *d__, doublecomplex *du, doublecomplex *b, integer *ldb,- integer *info);- -/* Subroutine */ int zgtsvx_(char *fact, char *trans, integer *n, integer *- nrhs, doublecomplex *dl, doublecomplex *d__, doublecomplex *du, - doublecomplex *dlf, doublecomplex *df, doublecomplex *duf, - doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, - doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, - doublereal *berr, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int zgttrf_(integer *n, doublecomplex *dl, doublecomplex *- d__, doublecomplex *du, doublecomplex *du2, integer *ipiv, integer *- info);- -/* Subroutine */ int zgttrs_(char *trans, integer *n, integer *nrhs, - doublecomplex *dl, doublecomplex *d__, doublecomplex *du, - doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zgtts2_(integer *itrans, integer *n, integer *nrhs, - doublecomplex *dl, doublecomplex *d__, doublecomplex *du, - doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb);- -/* Subroutine */ int zhbev_(char *jobz, char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z__, - integer *ldz, doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int zhbevd_(char *jobz, char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z__, - integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, - integer *lrwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int zhbevx_(char *jobz, char *range, char *uplo, integer *n, - integer *kd, doublecomplex *ab, integer *ldab, doublecomplex *q, - integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer *- iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z__,- integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork,- integer *ifail, integer *info);- -/* Subroutine */ int zhbgst_(char *vect, char *uplo, integer *n, integer *ka, - integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb, - integer *ldbb, doublecomplex *x, integer *ldx, doublecomplex *work, - doublereal *rwork, integer *info);- -/* Subroutine */ int zhbgv_(char *jobz, char *uplo, integer *n, integer *ka, - integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb, - integer *ldbb, doublereal *w, doublecomplex *z__, integer *ldz, - doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int zhbgvx_(char *jobz, char *range, char *uplo, integer *n, - integer *ka, integer *kb, doublecomplex *ab, integer *ldab, - doublecomplex *bb, integer *ldbb, doublecomplex *q, integer *ldq, - doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *- abstol, integer *m, doublereal *w, doublecomplex *z__, integer *ldz, - doublecomplex *work, doublereal *rwork, integer *iwork, integer *- ifail, integer *info);- -/* Subroutine */ int zhbtrd_(char *vect, char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, doublereal *d__, doublereal *e, - doublecomplex *q, integer *ldq, doublecomplex *work, integer *info);- -/* Subroutine */ int zhecon_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond, - doublecomplex *work, integer *info);- -/* Subroutine */ int zheev_(char *jobz, char *uplo, integer *n, doublecomplex - *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork, - doublereal *rwork, integer *info);- -/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n, - doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work, - integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int zheevr_(char *jobz, char *range, char *uplo, integer *n, - doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, - integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *- w, doublecomplex *z__, integer *ldz, integer *isuppz, doublecomplex *- work, integer *lwork, doublereal *rwork, integer *lrwork, integer *- iwork, integer *liwork, integer *info);- -/* Subroutine */ int zheevx_(char *jobz, char *range, char *uplo, integer *n, - doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, - integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *- w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer *- lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *- info);- -/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zhegst_(integer *itype, char *uplo, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zhegv_(integer *itype, char *jobz, char *uplo, integer *- n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,- integer *info);- -/* Subroutine */ int zhegvd_(integer *itype, char *jobz, char *uplo, integer *- n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,- integer *lrwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int zhegvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, - integer *ldb, doublereal *vl, doublereal *vu, integer *il, integer *- iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z__,- integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork,- integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int zherfs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, - integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, - integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,- doublereal *rwork, integer *info);- -/* Subroutine */ int zhesv_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, - integer *ldb, doublecomplex *work, integer *lwork, integer *info);- -/* Subroutine */ int zhesvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *- ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,- integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, - doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zhetf2_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, integer *info);- -/* Subroutine */ int zhetrd_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau, - doublecomplex *work, integer *lwork, integer *info);- -/* Subroutine */ int zhetrf_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, - integer *info);- -/* Subroutine */ int zhetri_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, doublecomplex *work, integer *info);- -/* Subroutine */ int zhetrs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, - integer *ldb, integer *info);- -/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n, - integer *ilo, integer *ihi, doublecomplex *a, integer *lda, - doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *- beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *- ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *- info);- -/* Subroutine */ int zhpcon_(char *uplo, integer *n, doublecomplex *ap, - integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *- work, integer *info);- -/* Subroutine */ int zhpev_(char *jobz, char *uplo, integer *n, doublecomplex - *ap, doublereal *w, doublecomplex *z__, integer *ldz, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zhpevd_(char *jobz, char *uplo, integer *n, - doublecomplex *ap, doublereal *w, doublecomplex *z__, integer *ldz, - doublecomplex *work, integer *lwork, doublereal *rwork, integer *- lrwork, integer *iwork, integer *liwork, integer *info);- -/* Subroutine */ int zhpevx_(char *jobz, char *range, char *uplo, integer *n, - doublecomplex *ap, doublereal *vl, doublereal *vu, integer *il, - integer *iu, doublereal *abstol, integer *m, doublereal *w, - doublecomplex *z__, integer *ldz, doublecomplex *work, doublereal *- rwork, integer *iwork, integer *ifail, integer *info);- -/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n, - doublecomplex *ap, doublecomplex *bp, integer *info);- -/* Subroutine */ int zhpgv_(integer *itype, char *jobz, char *uplo, integer *- n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex - *z__, integer *ldz, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int zhpgvd_(integer *itype, char *jobz, char *uplo, integer *- n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex - *z__, integer *ldz, doublecomplex *work, integer *lwork, doublereal *- rwork, integer *lrwork, integer *iwork, integer *liwork, integer *- info);- -/* Subroutine */ int zhpgvx_(integer *itype, char *jobz, char *range, char *- uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal *- vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, - integer *m, doublereal *w, doublecomplex *z__, integer *ldz, - doublecomplex *work, doublereal *rwork, integer *iwork, integer *- ifail, integer *info);- -/* Subroutine */ int zhprfs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *- b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, - doublereal *berr, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int zhpsv_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zhpsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv, - doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap, - doublereal *d__, doublereal *e, doublecomplex *tau, integer *info);- -/* Subroutine */ int zhptrf_(char *uplo, integer *n, doublecomplex *ap, - integer *ipiv, integer *info);- -/* Subroutine */ int zhptri_(char *uplo, integer *n, doublecomplex *ap, - integer *ipiv, doublecomplex *work, integer *info);- -/* Subroutine */ int zhptrs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zhsein_(char *side, char *eigsrc, char *initv, logical *- select, integer *n, doublecomplex *h__, integer *ldh, doublecomplex *- w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,- integer *mm, integer *m, doublecomplex *work, doublereal *rwork, - integer *ifaill, integer *ifailr, integer *info);- -/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,- integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w, - doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zlabrd_(integer *m, integer *n, integer *nb, - doublecomplex *a, integer *lda, doublereal *d__, doublereal *e, - doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, integer *- ldx, doublecomplex *y, integer *ldy);- -/* Subroutine */ int zlacgv_(integer *n, doublecomplex *x, integer *incx);- -/* Subroutine */ int zlacon_(integer *n, doublecomplex *v, doublecomplex *x, - doublereal *est, integer *kase);- -/* Subroutine */ int zlacp2_(char *uplo, integer *m, integer *n, doublereal *- a, integer *lda, doublecomplex *b, integer *ldb);- -/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb);- -/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublereal *b, integer *ldb, doublecomplex *c__, - integer *ldc, doublereal *rwork);- -/* Subroutine */ int zlacrt_(integer *n, doublecomplex *cx, integer *incx, - doublecomplex *cy, integer *incy, doublecomplex *c__, doublecomplex *- s);- -/* Subroutine */ int zlaed0_(integer *qsiz, integer *n, doublereal *d__, - doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *qstore, - integer *ldqs, doublereal *rwork, integer *iwork, integer *info);- -/* Subroutine */ int zlaed7_(integer *n, integer *cutpnt, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, - doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq, - doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, - integer *givptr, integer *givcol, doublereal *givnum, doublecomplex *- work, doublereal *rwork, integer *iwork, integer *info);- -/* Subroutine */ int zlaed8_(integer *k, integer *n, integer *qsiz, - doublecomplex *q, integer *ldq, doublereal *d__, doublereal *rho, - integer *cutpnt, doublereal *z__, doublereal *dlamda, doublecomplex *- q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx, - integer *indxq, integer *perm, integer *givptr, integer *givcol, - doublereal *givnum, integer *info);- -/* Subroutine */ int zlaein_(logical *rightv, logical *noinit, integer *n, - doublecomplex *h__, integer *ldh, doublecomplex *w, doublecomplex *v, - doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *eps3, - doublereal *smlnum, integer *info);- -/* Subroutine */ int zlaesy_(doublecomplex *a, doublecomplex *b, - doublecomplex *c__, doublecomplex *rt1, doublecomplex *rt2, - doublecomplex *evscal, doublecomplex *cs1, doublecomplex *sn1);- -/* Subroutine */ int zlaev2_(doublecomplex *a, doublecomplex *b, - doublecomplex *c__, doublereal *rt1, doublereal *rt2, doublereal *cs1,- doublecomplex *sn1);- -/* Subroutine */ int zlags2_(logical *upper, doublereal *a1, doublecomplex *- a2, doublereal *a3, doublereal *b1, doublecomplex *b2, doublereal *b3,- doublereal *csu, doublecomplex *snu, doublereal *csv, doublecomplex *- snv, doublereal *csq, doublecomplex *snq);- -/* Subroutine */ int zlagtm_(char *trans, integer *n, integer *nrhs, - doublereal *alpha, doublecomplex *dl, doublecomplex *d__, - doublecomplex *du, doublecomplex *x, integer *ldx, doublereal *beta, - doublecomplex *b, integer *ldb);- -/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb,- doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w, - integer *ldw, integer *info);- -/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n, - integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh, - doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__, - integer *ldz, integer *info);- -/* Subroutine */ int zlahrd_(integer *n, integer *k, integer *nb, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t, - integer *ldt, doublecomplex *y, integer *ldy);- -/* Subroutine */ int zlaic1_(integer *job, integer *j, doublecomplex *x, - doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *- sestpr, doublecomplex *s, doublecomplex *c__);- -/* Subroutine */ int zlals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, doublecomplex *b, integer *ldb, - doublecomplex *bx, integer *ldbx, integer *perm, integer *givptr, - integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum,- doublereal *poles, doublereal *difl, doublereal *difr, doublereal *- z__, integer *k, doublereal *c__, doublereal *s, doublereal *rwork, - integer *info);- -/* Subroutine */ int zlalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, doublecomplex *b, integer *ldb, doublecomplex *bx, - integer *ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *- k, doublereal *difl, doublereal *difr, doublereal *z__, doublereal *- poles, integer *givptr, integer *givcol, integer *ldgcol, integer *- perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *- rwork, integer *iwork, integer *info);- -/* Subroutine */ int zlapll_(integer *n, doublecomplex *x, integer *incx, - doublecomplex *y, integer *incy, doublereal *ssmin);- -/* Subroutine */ int zlapmt_(logical *forwrd, integer *m, integer *n, - doublecomplex *x, integer *ldx, integer *k);- -/* Subroutine */ int zlaqgb_(integer *m, integer *n, integer *kl, integer *ku,- doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);- -/* Subroutine */ int zlaqge_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, - doublereal *colcnd, doublereal *amax, char *equed);- -/* Subroutine */ int zlaqhb_(char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, - doublereal *amax, char *equed);- -/* Subroutine */ int zlaqhe_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublereal *s, doublereal *scond, doublereal *amax, - char *equed);- -/* Subroutine */ int zlaqhp_(char *uplo, integer *n, doublecomplex *ap, - doublereal *s, doublereal *scond, doublereal *amax, char *equed);- -/* Subroutine */ int zlaqp2_(integer *m, integer *n, integer *offset, - doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau, - doublereal *vn1, doublereal *vn2, doublecomplex *work);- -/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer - *nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt, - doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *- auxv, doublecomplex *f, integer *ldf);- -/* Subroutine */ int zlaqsb_(char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, - doublereal *amax, char *equed);- -/* Subroutine */ int zlaqsp_(char *uplo, integer *n, doublecomplex *ap, - doublereal *s, doublereal *scond, doublereal *amax, char *equed);- -/* Subroutine */ int zlaqsy_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublereal *s, doublereal *scond, doublereal *amax, - char *equed);- -/* Subroutine */ int zlar1v_(integer *n, integer *b1, integer *bn, doublereal - *sigma, doublereal *d__, doublereal *l, doublereal *ld, doublereal *- lld, doublereal *gersch, doublecomplex *z__, doublereal *ztz, - doublereal *mingma, integer *r__, integer *isuppz, doublereal *work);- -/* Subroutine */ int zlar2v_(integer *n, doublecomplex *x, doublecomplex *y, - doublecomplex *z__, integer *incx, doublereal *c__, doublecomplex *s, - integer *incc);- -/* Subroutine */ int zlarcm_(integer *m, integer *n, doublereal *a, integer *- lda, doublecomplex *b, integer *ldb, doublecomplex *c__, integer *ldc,- doublereal *rwork);- -/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex - *v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer *- ldc, doublecomplex *work);- -/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, doublecomplex *v, integer - *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *- ldc, doublecomplex *work, integer *ldwork);- -/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *- x, integer *incx, doublecomplex *tau);- -/* Subroutine */ int zlarft_(char *direct, char *storev, integer *n, integer *- k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *- t, integer *ldt);- -/* Subroutine */ int zlarfx_(char *side, integer *m, integer *n, - doublecomplex *v, doublecomplex *tau, doublecomplex *c__, integer *- ldc, doublecomplex *work);- -/* Subroutine */ int zlargv_(integer *n, doublecomplex *x, integer *incx, - doublecomplex *y, integer *incy, doublereal *c__, integer *incc);- -/* Subroutine */ int zlarnv_(integer *idist, integer *iseed, integer *n, - doublecomplex *x);- -/* Subroutine */ int zlarrv_(integer *n, doublereal *d__, doublereal *l, - integer *isplit, integer *m, doublereal *w, integer *iblock, - doublereal *gersch, doublereal *tol, doublecomplex *z__, integer *ldz,- integer *isuppz, doublereal *work, integer *iwork, integer *info);- -/* Subroutine */ int zlartg_(doublecomplex *f, doublecomplex *g, doublereal *- cs, doublecomplex *sn, doublecomplex *r__);- -/* Subroutine */ int zlartv_(integer *n, doublecomplex *x, integer *incx, - doublecomplex *y, integer *incy, doublereal *c__, doublecomplex *s, - integer *incc);- -/* Subroutine */ int zlarz_(char *side, integer *m, integer *n, integer *l, - doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *- c__, integer *ldc, doublecomplex *work);- -/* Subroutine */ int zlarzb_(char *side, char *trans, char *direct, char *- storev, integer *m, integer *n, integer *k, integer *l, doublecomplex - *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, - integer *ldc, doublecomplex *work, integer *ldwork);- -/* Subroutine */ int zlarzt_(char *direct, char *storev, integer *n, integer *- k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *- t, integer *ldt);- -/* Subroutine */ int zlascl_(char *type__, integer *kl, integer *ku, - doublereal *cfrom, doublereal *cto, integer *m, integer *n, - doublecomplex *a, integer *lda, integer *info);- -/* Subroutine */ int zlaset_(char *uplo, integer *m, integer *n, - doublecomplex *alpha, doublecomplex *beta, doublecomplex *a, integer *- lda);- -/* Subroutine */ int zlasr_(char *side, char *pivot, char *direct, integer *m,- integer *n, doublereal *c__, doublereal *s, doublecomplex *a, - integer *lda);- -/* Subroutine */ int zlassq_(integer *n, doublecomplex *x, integer *incx, - doublereal *scale, doublereal *sumsq);- -/* Subroutine */ int zlaswp_(integer *n, doublecomplex *a, integer *lda, - integer *k1, integer *k2, integer *ipiv, integer *incx);- -/* Subroutine */ int zlasyf_(char *uplo, integer *n, integer *nb, integer *kb,- doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w, - integer *ldw, integer *info);- -/* Subroutine */ int zlatbs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, integer *kd, doublecomplex *ab, integer *ldab, - doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info);- -/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__, - integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *- rdscal, integer *ipiv, integer *jpiv);- -/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char *- normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *- scale, doublereal *cnorm, integer *info);- -/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb, - doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau, - doublecomplex *w, integer *ldw);- -/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *- normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x, - doublereal *scale, doublereal *cnorm, integer *info);- -/* Subroutine */ int zlatrz_(integer *m, integer *n, integer *l, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work);- -/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n, - doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *- c1, doublecomplex *c2, integer *ldc, doublecomplex *work);- -/* Subroutine */ int zlauu2_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *info);- -/* Subroutine */ int zlauum_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *info);- -/* Subroutine */ int zpbcon_(char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, doublereal *anorm, doublereal *- rcond, doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int zpbequ_(char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, - doublereal *amax, integer *info);- -/* Subroutine */ int zpbrfs_(char *uplo, integer *n, integer *kd, integer *- nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *- ldafb, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,- doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *- rwork, integer *info);- -/* Subroutine */ int zpbstf_(char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, integer *info);- -/* Subroutine */ int zpbsv_(char *uplo, integer *n, integer *kd, integer *- nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *- ldb, integer *info);- -/* Subroutine */ int zpbsvx_(char *fact, char *uplo, integer *n, integer *kd, - integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, - integer *ldafb, char *equed, doublereal *s, doublecomplex *b, integer - *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *- ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, - integer *info);- -/* Subroutine */ int zpbtf2_(char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, integer *info);- -/* Subroutine */ int zpbtrf_(char *uplo, integer *n, integer *kd, - doublecomplex *ab, integer *ldab, integer *info);- -/* Subroutine */ int zpbtrs_(char *uplo, integer *n, integer *kd, integer *- nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *- ldb, integer *info);- -/* Subroutine */ int zpocon_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zpoequ_(integer *n, doublecomplex *a, integer *lda, - doublereal *s, doublereal *scond, doublereal *amax, integer *info);- -/* Subroutine */ int zporfs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, - doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *- rwork, integer *info);- -/* Subroutine */ int zposv_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zposvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *- ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb, - doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, - doublereal *berr, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int zpotf2_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *info);- -/* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *info);- -/* Subroutine */ int zpotri_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *info);- -/* Subroutine */ int zpotrs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zppcon_(char *uplo, integer *n, doublecomplex *ap, - doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal - *rwork, integer *info);- -/* Subroutine */ int zppequ_(char *uplo, integer *n, doublecomplex *ap, - doublereal *s, doublereal *scond, doublereal *amax, integer *info);- -/* Subroutine */ int zpprfs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, doublecomplex *afp, doublecomplex *b, integer *ldb,- doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int zppsv_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info);- -/* Subroutine */ int zppsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublecomplex *ap, doublecomplex *afp, char *equed, doublereal *- s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zpptrf_(char *uplo, integer *n, doublecomplex *ap, - integer *info);- -/* Subroutine */ int zpptri_(char *uplo, integer *n, doublecomplex *ap, - integer *info);- -/* Subroutine */ int zpptrs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info);- -/* Subroutine */ int zptcon_(integer *n, doublereal *d__, doublecomplex *e, - doublereal *anorm, doublereal *rcond, doublereal *rwork, integer *- info);- -/* Subroutine */ int zptrfs_(char *uplo, integer *n, integer *nrhs, - doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef, - doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *- rwork, integer *info);- -/* Subroutine */ int zptsv_(integer *n, integer *nrhs, doublereal *d__, - doublecomplex *e, doublecomplex *b, integer *ldb, integer *info);- -/* Subroutine */ int zptsvx_(char *fact, integer *n, integer *nrhs, - doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef, - doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zpttrf_(integer *n, doublereal *d__, doublecomplex *e, - integer *info);- -/* Subroutine */ int zpttrs_(char *uplo, integer *n, integer *nrhs, - doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zptts2_(integer *iuplo, integer *n, integer *nrhs, - doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb);- -/* Subroutine */ int zrot_(integer *n, doublecomplex *cx, integer *incx, - doublecomplex *cy, integer *incy, doublereal *c__, doublecomplex *s);- -/* Subroutine */ int zspcon_(char *uplo, integer *n, doublecomplex *ap, - integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *- work, integer *info);- -/* Subroutine */ int zspmv_(char *uplo, integer *n, doublecomplex *alpha, - doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex *- beta, doublecomplex *y, integer *incy);- -/* Subroutine */ int zspr_(char *uplo, integer *n, doublecomplex *alpha, - doublecomplex *x, integer *incx, doublecomplex *ap);- -/* Subroutine */ int zsprfs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *- b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, - doublereal *berr, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int zspsv_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zspsvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv, - doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int zsptrf_(char *uplo, integer *n, doublecomplex *ap, - integer *ipiv, integer *info);- -/* Subroutine */ int zsptri_(char *uplo, integer *n, doublecomplex *ap, - integer *ipiv, doublecomplex *work, integer *info);- -/* Subroutine */ int zsptrs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int zstedc_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublecomplex *z__, integer *ldz, doublecomplex *work, - integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, - integer *liwork, integer *info);- -/* Subroutine */ int zstein_(integer *n, doublereal *d__, doublereal *e, - integer *m, doublereal *w, integer *iblock, integer *isplit, - doublecomplex *z__, integer *ldz, doublereal *work, integer *iwork, - integer *ifail, integer *info);- -/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__, - doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work, - integer *info);- -/* Subroutine */ int zsycon_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond, - doublecomplex *work, integer *info);- -/* Subroutine */ int zsymv_(char *uplo, integer *n, doublecomplex *alpha, - doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, - doublecomplex *beta, doublecomplex *y, integer *incy);- -/* Subroutine */ int zsyr_(char *uplo, integer *n, doublecomplex *alpha, - doublecomplex *x, integer *incx, doublecomplex *a, integer *lda);- -/* Subroutine */ int zsyrfs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, - integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, - integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,- doublereal *rwork, integer *info);- -/* Subroutine */ int zsysv_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, - integer *ldb, doublecomplex *work, integer *lwork, integer *info);- -/* Subroutine */ int zsysvx_(char *fact, char *uplo, integer *n, integer *- nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *- ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,- integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, - doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);- -/* Subroutine */ int zsytf2_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, integer *info);- -/* Subroutine */ int zsytrf_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, - integer *info);- -/* Subroutine */ int zsytri_(char *uplo, integer *n, doublecomplex *a, - integer *lda, integer *ipiv, doublecomplex *work, integer *info);- -/* Subroutine */ int zsytrs_(char *uplo, integer *n, integer *nrhs, - doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, - integer *ldb, integer *info);- -/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n, - integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond, - doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int ztbrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, - doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *- rwork, integer *info);- -/* Subroutine */ int ztbtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, - doublecomplex *b, integer *ldb, integer *info);- -/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select, - integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer - *ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *- ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,- integer *info);- -/* Subroutine */ int ztgex2_(logical *wantq, logical *wantz, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz, - integer *j1, integer *info);- -/* Subroutine */ int ztgexc_(logical *wantq, logical *wantz, integer *n, - doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz, - integer *ifst, integer *ilst, integer *info);- -/* Subroutine */ int ztgsen_(integer *ijob, logical *wantq, logical *wantz, - logical *select, integer *n, doublecomplex *a, integer *lda, - doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *- beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *- ldz, integer *m, doublereal *pl, doublereal *pr, doublereal *dif, - doublecomplex *work, integer *lwork, integer *iwork, integer *liwork, - integer *info);- -/* Subroutine */ int ztgsja_(char *jobu, char *jobv, char *jobq, integer *m, - integer *p, integer *n, integer *k, integer *l, doublecomplex *a, - integer *lda, doublecomplex *b, integer *ldb, doublereal *tola, - doublereal *tolb, doublereal *alpha, doublereal *beta, doublecomplex *- u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q, - integer *ldq, doublecomplex *work, integer *ncycle, integer *info);- -/* Subroutine */ int ztgsna_(char *job, char *howmny, logical *select, - integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer - *ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *- ldvr, doublereal *s, doublereal *dif, integer *mm, integer *m, - doublecomplex *work, integer *lwork, integer *iwork, integer *info);- -/* Subroutine */ int ztgsy2_(char *trans, integer *ijob, integer *m, integer *- n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd, - doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf, - doublereal *scale, doublereal *rdsum, doublereal *rdscal, integer *- info);- -/* Subroutine */ int ztgsyl_(char *trans, integer *ijob, integer *m, integer *- n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, - doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd, - doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf, - doublereal *scale, doublereal *dif, doublecomplex *work, integer *- lwork, integer *iwork, integer *info);- -/* Subroutine */ int ztpcon_(char *norm, char *uplo, char *diag, integer *n, - doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal - *rwork, integer *info);- -/* Subroutine */ int ztprfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb, - doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n, - doublecomplex *ap, integer *info);- -/* Subroutine */ int ztptrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb, - integer *info);- -/* Subroutine */ int ztrcon_(char *norm, char *uplo, char *diag, integer *n, - doublecomplex *a, integer *lda, doublereal *rcond, doublecomplex *- work, doublereal *rwork, integer *info);- -/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select, - integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, - integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer - *m, doublecomplex *work, doublereal *rwork, integer *info);- -/* Subroutine */ int ztrexc_(char *compq, integer *n, doublecomplex *t, - integer *ldt, doublecomplex *q, integer *ldq, integer *ifst, integer *- ilst, integer *info);- -/* Subroutine */ int ztrrfs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, - integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, - doublereal *berr, doublecomplex *work, doublereal *rwork, integer *- info);- -/* Subroutine */ int ztrsen_(char *job, char *compq, logical *select, integer - *n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq, - doublecomplex *w, integer *m, doublereal *s, doublereal *sep, - doublecomplex *work, integer *lwork, integer *info);- -/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select, - integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, - integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, - doublereal *sep, integer *mm, integer *m, doublecomplex *work, - integer *ldwork, doublereal *rwork, integer *info);- -/* Subroutine */ int ztrsyl_(char *trana, char *tranb, integer *isgn, integer - *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, - integer *ldb, doublecomplex *c__, integer *ldc, doublereal *scale, - integer *info);- -/* Subroutine */ int ztrti2_(char *uplo, char *diag, integer *n, - doublecomplex *a, integer *lda, integer *info);- -/* Subroutine */ int ztrtri_(char *uplo, char *diag, integer *n, - doublecomplex *a, integer *lda, integer *info);- -/* Subroutine */ int ztrtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, - integer *ldb, integer *info);- -/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, integer *info);- -/* Subroutine */ int ztzrzf_(integer *m, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zung2l_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *info);- -/* Subroutine */ int zung2r_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *info);- -/* Subroutine */ int zungbr_(char *vect, integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zunghr_(integer *n, integer *ilo, integer *ihi, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zungl2_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *info);- -/* Subroutine */ int zunglq_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zungql_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zungr2_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *info);- -/* Subroutine */ int zungrq_(integer *m, integer *n, integer *k, - doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zungtr_(char *uplo, integer *n, doublecomplex *a, - integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zunm2l_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);- -/* Subroutine */ int zunm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);- -/* Subroutine */ int zunmbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex - *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *- lwork, integer *info);- -/* Subroutine */ int zunmhr_(char *side, char *trans, integer *m, integer *n, - integer *ilo, integer *ihi, doublecomplex *a, integer *lda, - doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *- work, integer *lwork, integer *info);- -/* Subroutine */ int zunml2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);- -/* Subroutine */ int zunmlq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zunmql_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zunmqr_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zunmr2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);- -/* Subroutine */ int zunmr3_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex - *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *- info);- -/* Subroutine */ int zunmrq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zunmrz_(char *side, char *trans, integer *m, integer *n, - integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex - *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *- lwork, integer *info);- -/* Subroutine */ int zunmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, - doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,- integer *info);- -/* Subroutine */ int zupgtr_(char *uplo, integer *n, doublecomplex *ap, - doublecomplex *tau, doublecomplex *q, integer *ldq, doublecomplex *- work, integer *info);- -/* Subroutine */ int zupmtr_(char *side, char *uplo, char *trans, integer *m, - integer *n, doublecomplex *ap, doublecomplex *tau, doublecomplex *c__,- integer *ldc, doublecomplex *work, integer *info);--#endif /* __CLAPACK_H */
− lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c
@@ -1,1344 +0,0 @@-#include <stdio.h>-#include <stdlib.h>-#include <string.h>-#include <math.h>-#include <time.h>-#include "lapack-aux.h"--#define MACRO(B) do {B} while (0)-#define ERROR(CODE) MACRO(return CODE;)-#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})--#define MIN(A,B) ((A)<(B)?(A):(B))-#define MAX(A,B) ((A)>(B)?(A):(B))--// #define DBGL--#ifdef DBGL-#define DEBUGMSG(M) printf("\nLAPACK "M"\n");-#else-#define DEBUGMSG(M)-#endif--#define OK return 0;--// #ifdef DBGL-// #define DEBUGMSG(M) printf("LAPACK Wrapper "M"\n: "); size_t t0 = time(NULL);-// #define OK MACRO(printf("%ld s\n",time(0)-t0); return 0;);-// #else-// #define DEBUGMSG(M)-// #define OK return 0;-// #endif--#define TRACEMAT(M) {int q; printf(" %d x %d: ",M##r,M##c); \- for(q=0;q<M##r*M##c;q++) printf("%.1f ",M##p[q]); printf("\n");}--#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)--#define BAD_SIZE 2000-#define BAD_CODE 2001-#define MEM 2002-#define BAD_FILE 2003-#define SINGULAR 2004-#define NOCONVER 2005-#define NODEFPOS 2006-#define NOSPRTD 2007--//----------------------------------------void asm_finit() {-#ifdef i386--// asm("finit");-- static unsigned char buf[108];- asm("FSAVE %0":"=m" (buf));-- #if FPUDEBUG- if(buf[8]!=255 || buf[9]!=255) { // print warning in red- printf("%c[;31mWarning: FPU TAG = %x %x\%c[0m\n",0x1B,buf[8],buf[9],0x1B);- }- #endif-- #if NANDEBUG- asm("FRSTOR %0":"=m" (buf));- #endif--#endif-}--//-----------------------------------------#if NANDEBUG--#define CHECKNANR(M,msg) \-{ int k; \-for(k=0; k<(M##r * M##c); k++) { \- if(M##p[k] != M##p[k]) { \- printf(msg); \- TRACEMAT(M) \- /*exit(1);*/ \- } \-} \-}--#define CHECKNANC(M,msg) \-{ int k; \-for(k=0; k<(M##r * M##c); k++) { \- if( M##p[k].r != M##p[k].r \- || M##p[k].i != M##p[k].i) { \- printf(msg); \- /*exit(1);*/ \- } \-} \-}--#else-#define CHECKNANC(M,msg)-#define CHECKNANR(M,msg)-#endif--//-----------------------------------------//////////////////// real svd ////////////////////////////////////--int svd_l_R(KDMAT(a),DMAT(u), DVEC(s),DMAT(v)) {- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES(up==NULL || ur==m && (uc==m || uc==q),BAD_SIZE);- char* jobu = "A";- if (up==NULL) {- jobu = "N";- } else {- if (uc==q) {- jobu = "S";- }- }- REQUIRES(vp==NULL || vc==n && (vr==n || vr==q),BAD_SIZE);- char* jobvt = "A";- integer ldvt = n;- if (vp==NULL) {- jobvt = "N";- } else {- if (vr==q) {- jobvt = "S";- ldvt = q;- }- }- DEBUGMSG("svd_l_R");- double *B = (double*)malloc(m*n*sizeof(double));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(double));- integer lwork = -1;- integer res;- // ask for optimal lwork- double ans;- dgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- &ans, &lwork,- &res);- lwork = ceil(ans);- double * work = (double*)malloc(lwork*sizeof(double));- CHECK(!work,MEM);- dgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- work, &lwork,- &res);- CHECK(res,res);- free(work);- free(B);- OK-}--// (alternative version)--int svd_l_Rdd(KDMAT(a),DMAT(u), DVEC(s),DMAT(v)) {- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES(up == NULL && vp == NULL- || ur==m && vc==n- && (uc == q && vr == q- || uc == m && vc==n),BAD_SIZE);- char* jobz = "A";- integer ldvt = n;- if (up==NULL) {- jobz = "N";- } else {- if (uc==q && vr == q) {- jobz = "S";- ldvt = q;- }- }- DEBUGMSG("svd_l_Rdd");- double *B = (double*)malloc(m*n*sizeof(double));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(double));- integer* iwk = (integer*) malloc(8*q*sizeof(integer));- CHECK(!iwk,MEM);- integer lwk = -1;- integer res;- // ask for optimal lwk- double ans;- dgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,iwk,&res);- lwk = ans;- double * workv = (double*)malloc(lwk*sizeof(double));- CHECK(!workv,MEM);- dgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,workv,&lwk,iwk,&res);- CHECK(res,res);- free(iwk);- free(workv);- free(B);- OK-}--//////////////////// complex svd ////////////////////////////////////--// not in clapack.h--int zgesvd_(char *jobu, char *jobvt, integer *m, integer *n,- doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,- integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,- integer *lwork, doublereal *rwork, integer *info);--int svd_l_C(KCMAT(a),CMAT(u), DVEC(s),CMAT(v)) {- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES(up==NULL || ur==m && (uc==m || uc==q),BAD_SIZE);- char* jobu = "A";- if (up==NULL) {- jobu = "N";- } else {- if (uc==q) {- jobu = "S";- }- }- REQUIRES(vp==NULL || vc==n && (vr==n || vr==q),BAD_SIZE);- char* jobvt = "A";- integer ldvt = n;- if (vp==NULL) {- jobvt = "N";- } else {- if (vr==q) {- jobvt = "S";- ldvt = q;- }- }DEBUGMSG("svd_l_C");- doublecomplex *B = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(doublecomplex));-- double *rwork = (double*) malloc(5*q*sizeof(double));- CHECK(!rwork,MEM);- integer lwork = -1;- integer res;- // ask for optimal lwork- doublecomplex ans;- zgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- &ans, &lwork,- rwork,- &res);- lwork = ceil(ans.r);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!work,MEM);- zgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- work, &lwork,- rwork,- &res);- CHECK(res,res);- free(work);- free(rwork);- free(B);- OK-}--int zgesdd_ (char *jobz, integer *m, integer *n,- doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,- integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,- integer *lwork, doublereal *rwork, integer* iwork, integer *info);--int svd_l_Cdd(KCMAT(a),CMAT(u), DVEC(s),CMAT(v)) {- //printf("entro\n");- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES(up == NULL && vp == NULL- || ur==m && vc==n- && (uc == q && vr == q- || uc == m && vc==n),BAD_SIZE);- char* jobz = "A";- integer ldvt = n;- if (up==NULL) {- jobz = "N";- } else {- if (uc==q && vr == q) {- jobz = "S";- ldvt = q;- }- }- DEBUGMSG("svd_l_Cdd");- doublecomplex *B = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(doublecomplex));- integer* iwk = (integer*) malloc(8*q*sizeof(integer));- CHECK(!iwk,MEM);- int lrwk;- if (0 && *jobz == 'N') {- lrwk = 5*q; // does not work, crash at free below- } else {- lrwk = 5*q*q + 7*q;- }- double *rwk = (double*)malloc(lrwk*sizeof(double));;- CHECK(!rwk,MEM);- //printf("%s %ld %d\n",jobz,q,lrwk);- integer lwk = -1;- integer res;- // ask for optimal lwk- doublecomplex ans;- zgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,rwk,iwk,&res);- lwk = ans.r;- //printf("lwk = %ld\n",lwk);- doublecomplex * workv = (doublecomplex*)malloc(lwk*sizeof(doublecomplex));- CHECK(!workv,MEM);- zgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,workv,&lwk,rwk,iwk,&res);- //printf("res = %ld\n",res);- CHECK(res,res);- free(workv); // printf("freed workv\n");- free(rwk); // printf("freed rwk\n");- free(iwk); // printf("freed iwk\n");- free(B); // printf("freed B, salgo\n");- OK-}--//////////////////// general complex eigensystem ////////////--int eig_l_C(KCMAT(a), CMAT(u), CVEC(s),CMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(up==NULL || ur==n && uc==n, BAD_SIZE);- char jobvl = up==NULL?'N':'V';- REQUIRES(vp==NULL || vr==n && vc==n, BAD_SIZE);- char jobvr = vp==NULL?'N':'V';- DEBUGMSG("eig_l_C");- doublecomplex *B = (doublecomplex*)malloc(n*n*sizeof(doublecomplex));- CHECK(!B,MEM);- memcpy(B,ap,n*n*sizeof(doublecomplex));- double *rwork = (double*) malloc(2*n*sizeof(double));- CHECK(!rwork,MEM);- integer lwork = -1;- integer res;- // ask for optimal lwork- doublecomplex ans;- //printf("ask zgeev\n");- zgeev_ (&jobvl,&jobvr,- &n,B,&n,- sp,- up,&n,- vp,&n,- &ans, &lwork,- rwork,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!work,MEM);- //printf("zgeev\n");- zgeev_ (&jobvl,&jobvr,- &n,B,&n,- sp,- up,&n,- vp,&n,- work, &lwork,- rwork,- &res);- CHECK(res,res);- free(work);- free(rwork);- free(B);- OK-}----//////////////////// general real eigensystem ////////////--int eig_l_R(KDMAT(a),DMAT(u), CVEC(s),DMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(up==NULL || ur==n && uc==n, BAD_SIZE);- char jobvl = up==NULL?'N':'V';- REQUIRES(vp==NULL || vr==n && vc==n, BAD_SIZE);- char jobvr = vp==NULL?'N':'V';- DEBUGMSG("eig_l_R");- double *B = (double*)malloc(n*n*sizeof(double));- CHECK(!B,MEM);- memcpy(B,ap,n*n*sizeof(double));- integer lwork = -1;- integer res;- // ask for optimal lwork- double ans;- //printf("ask dgeev\n");- dgeev_ (&jobvl,&jobvr,- &n,B,&n,- (double*)sp, (double*)sp+n,- up,&n,- vp,&n,- &ans, &lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- CHECK(!work,MEM);- //printf("dgeev\n");- dgeev_ (&jobvl,&jobvr,- &n,B,&n,- (double*)sp, (double*)sp+n,- up,&n,- vp,&n,- work, &lwork,- &res);- CHECK(res,res);- free(work);- free(B);- OK-}---//////////////////// symmetric real eigensystem ////////////---int eig_l_S(int wantV,KDMAT(a),DVEC(s),DMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(vr==n && vc==n, BAD_SIZE);- char jobz = wantV?'V':'N';- DEBUGMSG("eig_l_S");- memcpy(vp,ap,n*n*sizeof(double));- integer lwork = -1;- char uplo = 'U';- integer res;- // ask for optimal lwork- double ans;- //printf("ask dsyev\n");- dsyev_ (&jobz,&uplo,- &n,vp,&n,- sp,- &ans, &lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- CHECK(!work,MEM);- dsyev_ (&jobz,&uplo,- &n,vp,&n,- sp,- work, &lwork,- &res);- CHECK(res,res);- free(work);- OK-}--//////////////////// hermitian complex eigensystem ////////////--int eig_l_H(int wantV,KCMAT(a),DVEC(s),CMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(vr==n && vc==n, BAD_SIZE);- char jobz = wantV?'V':'N';- DEBUGMSG("eig_l_H");- memcpy(vp,ap,2*n*n*sizeof(double));- double *rwork = (double*) malloc((3*n-2)*sizeof(double));- CHECK(!rwork,MEM);- integer lwork = -1;- char uplo = 'U';- integer res;- // ask for optimal lwork- doublecomplex ans;- //printf("ask zheev\n");- zheev_ (&jobz,&uplo,- &n,vp,&n,- sp,- &ans, &lwork,- rwork,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!work,MEM);- zheev_ (&jobz,&uplo,- &n,vp,&n,- sp,- work, &lwork,- rwork,- &res);- CHECK(res,res);- free(work);- free(rwork);- OK-}--//////////////////// general real linear system ////////////--int linearSolveR_l(KDMAT(a),KDMAT(b),DMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("linearSolveR_l");- double*AC = (double*)malloc(n*n*sizeof(double));- memcpy(AC,ap,n*n*sizeof(double));- memcpy(xp,bp,n*nhrs*sizeof(double));- integer * ipiv = (integer*)malloc(n*sizeof(integer));- integer res;- dgesv_ (&n,&nhrs,- AC, &n,- ipiv,- xp, &n,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(ipiv);- free(AC);- OK-}--//////////////////// general complex linear system ////////////--int linearSolveC_l(KCMAT(a),KCMAT(b),CMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("linearSolveC_l");- doublecomplex*AC = (doublecomplex*)malloc(n*n*sizeof(doublecomplex));- memcpy(AC,ap,n*n*sizeof(doublecomplex));- memcpy(xp,bp,n*nhrs*sizeof(doublecomplex));- integer * ipiv = (integer*)malloc(n*sizeof(integer));- integer res;- zgesv_ (&n,&nhrs,- AC, &n,- ipiv,- xp, &n,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(ipiv);- free(AC);- OK-}--//////// symmetric positive definite real linear system using Cholesky ////////////--int cholSolveR_l(KDMAT(a),KDMAT(b),DMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("cholSolveR_l");- memcpy(xp,bp,n*nhrs*sizeof(double));- integer res;- dpotrs_ ("U",- &n,&nhrs,- (double*)ap, &n,- xp, &n,- &res);- CHECK(res,res);- OK-}--//////// Hermitian positive definite real linear system using Cholesky ////////////--int cholSolveC_l(KCMAT(a),KCMAT(b),CMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("cholSolveC_l");- memcpy(xp,bp,n*nhrs*sizeof(doublecomplex));- integer res;- zpotrs_ ("U",- &n,&nhrs,- (doublecomplex*)ap, &n,- xp, &n,- &res);- CHECK(res,res);- OK-}--//////////////////// least squares real linear system ////////////--int linearSolveLSR_l(KDMAT(a),KDMAT(b),DMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveLSR_l");- double*AC = (double*)malloc(m*n*sizeof(double));- memcpy(AC,ap,m*n*sizeof(double));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(double));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(double));- }- }- integer res;- integer lwork = -1;- double ans;- dgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- &ans,&lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- dgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- work,&lwork,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(work);- free(AC);- OK-}--//////////////////// least squares complex linear system ////////////--int linearSolveLSC_l(KCMAT(a),KCMAT(b),CMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveLSC_l");- doublecomplex*AC = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- memcpy(AC,ap,m*n*sizeof(doublecomplex));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(doublecomplex));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(doublecomplex));- }- }- integer res;- integer lwork = -1;- doublecomplex ans;- zgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- &ans,&lwork,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- zgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- work,&lwork,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(work);- free(AC);- OK-}--//////////////////// least squares real linear system using SVD ////////////--int linearSolveSVDR_l(double rcond,KDMAT(a),KDMAT(b),DMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveSVDR_l");- double*AC = (double*)malloc(m*n*sizeof(double));- double*S = (double*)malloc(MIN(m,n)*sizeof(double));- memcpy(AC,ap,m*n*sizeof(double));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(double));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(double));- }- }- integer res;- integer lwork = -1;- integer rank;- double ans;- dgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- &ans,&lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- dgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- work,&lwork,- &res);- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(work);- free(S);- free(AC);- OK-}--//////////////////// least squares complex linear system using SVD ////////////--// not in clapack.h--int zgelss_(integer *m, integer *n, integer *nhrs,- doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s,- doublereal *rcond, integer* rank,- doublecomplex *work, integer* lwork, doublereal* rwork,- integer *info);--int linearSolveSVDC_l(double rcond, KCMAT(a),KCMAT(b),CMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveSVDC_l");- doublecomplex*AC = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- double*S = (double*)malloc(MIN(m,n)*sizeof(double));- double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double));- memcpy(AC,ap,m*n*sizeof(doublecomplex));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(doublecomplex));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(doublecomplex));- }- }- integer res;- integer lwork = -1;- integer rank;- doublecomplex ans;- zgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- &ans,&lwork,- RWORK,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- zgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- work,&lwork,- RWORK,- &res);- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(work);- free(RWORK);- free(S);- free(AC);- OK-}--//////////////////// Cholesky factorization /////////////////////////--int chol_l_H(KCMAT(a),CMAT(l)) {- integer n = ar;- REQUIRES(n>=1 && ac == n && lr==n && lc==n,BAD_SIZE);- DEBUGMSG("chol_l_H");- memcpy(lp,ap,n*n*sizeof(doublecomplex));- char uplo = 'U';- integer res;- zpotrf_ (&uplo,&n,lp,&n,&res);- CHECK(res>0,NODEFPOS);- CHECK(res,res);- doublecomplex zero = {0.,0.};- int r,c;- for (r=0; r<lr-1; r++) {- for(c=r+1; c<lc; c++) {- lp[r*lc+c] = zero;- }- }- OK-}--int chol_l_S(KDMAT(a),DMAT(l)) {- integer n = ar;- REQUIRES(n>=1 && ac == n && lr==n && lc==n,BAD_SIZE);- DEBUGMSG("chol_l_S");- memcpy(lp,ap,n*n*sizeof(double));- char uplo = 'U';- integer res;- dpotrf_ (&uplo,&n,lp,&n,&res);- CHECK(res>0,NODEFPOS);- CHECK(res,res);- int r,c;- for (r=0; r<lr-1; r++) {- for(c=r+1; c<lc; c++) {- lp[r*lc+c] = 0.;- }- }- OK-}--//////////////////// QR factorization /////////////////////////--int qr_l_R(KDMAT(a), DVEC(tau), DMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && rr== m && rc == n && taun == mn, BAD_SIZE);- DEBUGMSG("qr_l_R");- double *WORK = (double*)malloc(n*sizeof(double));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(double));- integer res;- dgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);- CHECK(res,res);- free(WORK);- OK-}--int qr_l_C(KCMAT(a), CVEC(tau), CMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && rr== m && rc == n && taun == mn, BAD_SIZE);- DEBUGMSG("qr_l_C");- doublecomplex *WORK = (doublecomplex*)malloc(n*sizeof(doublecomplex));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(doublecomplex));- integer res;- zgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);- CHECK(res,res);- free(WORK);- OK-}--//////////////////// Hessenberg factorization /////////////////////////--int hess_l_R(KDMAT(a), DVEC(tau), DMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n == m && rr== m && rc == n && taun == mn-1, BAD_SIZE);- DEBUGMSG("hess_l_R");- integer lwork = 5*n; // fixme- double *WORK = (double*)malloc(lwork*sizeof(double));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(double));- integer res;- integer one = 1;- dgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);- CHECK(res,res);- free(WORK);- OK-}--int hess_l_C(KCMAT(a), CVEC(tau), CMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n == m && rr== m && rc == n && taun == mn-1, BAD_SIZE);- DEBUGMSG("hess_l_C");- integer lwork = 5*n; // fixme- doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(doublecomplex));- integer res;- integer one = 1;- zgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);- CHECK(res,res);- free(WORK);- OK-}--//////////////////// Schur factorization /////////////////////////--int schur_l_R(KDMAT(a), DMAT(u), DMAT(s)) {- integer m = ar;- integer n = ac;- REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE);- DEBUGMSG("schur_l_R");- int k;- //printf("---------------------------\n");- //printf("%p: ",ap); for(k=0;k<n*n;k++) printf("%f ",ap[k]); printf("\n");- //printf("%p: ",up); for(k=0;k<n*n;k++) printf("%f ",up[k]); printf("\n");- //printf("%p: ",sp); for(k=0;k<n*n;k++) printf("%f ",sp[k]); printf("\n");- memcpy(sp,ap,n*n*sizeof(double));- integer lwork = 6*n; // fixme- double *WORK = (double*)malloc(lwork*sizeof(double));- double *WR = (double*)malloc(n*sizeof(double));- double *WI = (double*)malloc(n*sizeof(double));- // WR and WI not really required in this call- logical *BWORK = (logical*)malloc(n*sizeof(logical));- integer res;- integer sdim;- dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res);- //printf("%p: ",ap); for(k=0;k<n*n;k++) printf("%f ",ap[k]); printf("\n");- //printf("%p: ",up); for(k=0;k<n*n;k++) printf("%f ",up[k]); printf("\n");- //printf("%p: ",sp); for(k=0;k<n*n;k++) printf("%f ",sp[k]); printf("\n");- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(WR);- free(WI);- free(BWORK);- free(WORK);- OK-}--int schur_l_C(KCMAT(a), CMAT(u), CMAT(s)) {- integer m = ar;- integer n = ac;- REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE);- DEBUGMSG("schur_l_C");- memcpy(sp,ap,n*n*sizeof(doublecomplex));- integer lwork = 6*n; // fixme- doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- doublecomplex *W = (doublecomplex*)malloc(n*sizeof(doublecomplex));- // W not really required in this call- logical *BWORK = (logical*)malloc(n*sizeof(logical));- double *RWORK = (double*)malloc(n*sizeof(double));- integer res;- integer sdim;- zgees_ ("V","N",NULL,&n,sp,&n,&sdim,W,- up,&n,- WORK,&lwork,RWORK,BWORK,&res);- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(W);- free(BWORK);- free(WORK);- OK-}--//////////////////// LU factorization /////////////////////////--int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);- DEBUGMSG("lu_l_R");- integer* auxipiv = (integer*)malloc(mn*sizeof(integer));- memcpy(rp,ap,m*n*sizeof(double));- integer res;- dgetrf_ (&m,&n,rp,&m,auxipiv,&res);- if(res>0) {- res = 0; // fixme- }- CHECK(res,res);- int k;- for (k=0; k<mn; k++) {- ipivp[k] = auxipiv[k];- }- free(auxipiv);- OK-}--int lu_l_C(KCMAT(a), DVEC(ipiv), CMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);- DEBUGMSG("lu_l_C");- integer* auxipiv = (integer*)malloc(mn*sizeof(integer));- memcpy(rp,ap,m*n*sizeof(doublecomplex));- integer res;- zgetrf_ (&m,&n,rp,&m,auxipiv,&res);- if(res>0) {- res = 0; // fixme- }- CHECK(res,res);- int k;- for (k=0; k<mn; k++) {- ipivp[k] = auxipiv[k];- }- free(auxipiv);- OK-}---//////////////////// LU substitution /////////////////////////--int luS_l_R(KDMAT(a), KDVEC(ipiv), KDMAT(b), DMAT(x)) {- integer m = ar;- integer n = ac;- integer mrhs = br;- integer nrhs = bc;-- REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);- integer* auxipiv = (integer*)malloc(n*sizeof(integer));- int k;- for (k=0; k<n; k++) {- auxipiv[k] = (integer)ipivp[k];- }- integer res;- memcpy(xp,bp,mrhs*nrhs*sizeof(double));- dgetrs_ ("N",&n,&nrhs,(/*no const (!?)*/ double*)ap,&m,auxipiv,xp,&mrhs,&res);- CHECK(res,res);- free(auxipiv);- OK-}--int luS_l_C(KCMAT(a), KDVEC(ipiv), KCMAT(b), CMAT(x)) {- integer m = ar;- integer n = ac;- integer mrhs = br;- integer nrhs = bc;-- REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);- integer* auxipiv = (integer*)malloc(n*sizeof(integer));- int k;- for (k=0; k<n; k++) {- auxipiv[k] = (integer)ipivp[k];- }- integer res;- memcpy(xp,bp,mrhs*nrhs*sizeof(doublecomplex));- zgetrs_ ("N",&n,&nrhs,(doublecomplex*)ap,&m,auxipiv,xp,&mrhs,&res);- CHECK(res,res);- free(auxipiv);- OK-}--//////////////////// Matrix Product /////////////////////////--void dgemm_(char *, char *, integer *, integer *, integer *,- double *, const double *, integer *, const double *,- integer *, double *, double *, integer *);--int multiplyR(int ta, int tb, KDMAT(a),KDMAT(b),DMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("dgemm_");- CHECKNANR(a,"NaN multR Input\n")- CHECKNANR(b,"NaN multR Input\n")- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- double alpha = 1;- double beta = 0;- dgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);- CHECKNANR(r,"NaN multR Output\n")- OK-}--void zgemm_(char *, char *, integer *, integer *, integer *,- doublecomplex *, const doublecomplex *, integer *, const doublecomplex *,- integer *, doublecomplex *, doublecomplex *, integer *);--int multiplyC(int ta, int tb, KCMAT(a),KCMAT(b),CMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("zgemm_");- CHECKNANC(a,"NaN multC Input\n")- CHECKNANC(b,"NaN multC Input\n")- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- doublecomplex alpha = {1,0};- doublecomplex beta = {0,0};- zgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,- ap,&lda,- bp,&ldb,&beta,- rp,&ldc);- CHECKNANC(r,"NaN multC Output\n")- OK-}--void sgemm_(char *, char *, integer *, integer *, integer *,- float *, const float *, integer *, const float *,- integer *, float *, float *, integer *);--int multiplyF(int ta, int tb, KFMAT(a),KFMAT(b),FMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("sgemm_");- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- float alpha = 1;- float beta = 0;- sgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);- OK-}--void cgemm_(char *, char *, integer *, integer *, integer *,- complex *, const complex *, integer *, const complex *,- integer *, complex *, complex *, integer *);--int multiplyQ(int ta, int tb, KQMAT(a),KQMAT(b),QMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("cgemm_");- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- complex alpha = {1,0};- complex beta = {0,0};- cgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,- ap,&lda,- bp,&ldb,&beta,- rp,&ldc);- OK-}--//////////////////// transpose /////////////////////////--int transF(KFMAT(x),FMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transF");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transR(KDMAT(x),DMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transR");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transQ(KQMAT(x),QMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transQ");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transC(KCMAT(x),CMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transC");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transP(KPMAT(x), PMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- REQUIRES(xs==ts,NOCONVER);- DEBUGMSG("transP");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- memcpy(tp+(i*tc+j)*xs,xp +(j*xc+i)*xs,xs);- }- }- OK-}--//////////////////// constant /////////////////////////--int constantF(float * pval, FVEC(r)) {- DEBUGMSG("constantF")- int k;- double val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantR(double * pval, DVEC(r)) {- DEBUGMSG("constantR")- int k;- double val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantQ(complex* pval, QVEC(r)) {- DEBUGMSG("constantQ")- int k;- complex val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantC(doublecomplex* pval, CVEC(r)) {- DEBUGMSG("constantC")- int k;- doublecomplex val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantP(void* pval, PVEC(r)) {- DEBUGMSG("constantP")- int k;- for(k=0;k<rn;k++) {- memcpy(rp+k*rs,pval,rs);- }- OK-}--//////////////////// float-double conversion /////////////////////////--int float2double(FVEC(x),DVEC(y)) {- DEBUGMSG("float2double")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k];- }- OK-}--int double2float(DVEC(x),FVEC(y)) {- DEBUGMSG("double2float")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k];- }- OK-}--//////////////////// conjugate /////////////////////////--int conjugateQ(KQVEC(x),QVEC(t)) {- REQUIRES(xn==tn,BAD_SIZE);- DEBUGMSG("conjugateQ");- int k;- for(k=0;k<xn;k++) {- tp[k].r = xp[k].r;- tp[k].i = -xp[k].i;- }- OK-}--int conjugateC(KCVEC(x),CVEC(t)) {- REQUIRES(xn==tn,BAD_SIZE);- DEBUGMSG("conjugateC");- int k;- for(k=0;k<xn;k++) {- tp[k].r = xp[k].r;- tp[k].i = -xp[k].i;- }- OK-}--//////////////////// step /////////////////////////--int stepF(FVEC(x),FVEC(y)) {- DEBUGMSG("stepF")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k]>0;- }- OK-}--int stepD(DVEC(x),DVEC(y)) {- DEBUGMSG("stepD")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k]>0;- }- OK-}--//////////////////// cond /////////////////////////--int condF(FVEC(x),FVEC(y),FVEC(lt),FVEC(eq),FVEC(gt),FVEC(r)) {- REQUIRES(xn==yn && xn==ltn && xn==eqn && xn==gtn && xn==rn ,BAD_SIZE);- DEBUGMSG("condF")- int k;- for(k=0;k<xn;k++) {- rp[k] = xp[k]<yp[k]?ltp[k]:(xp[k]>yp[k]?gtp[k]:eqp[k]);- }- OK-}--int condD(DVEC(x),DVEC(y),DVEC(lt),DVEC(eq),DVEC(gt),DVEC(r)) {- REQUIRES(xn==yn && xn==ltn && xn==eqn && xn==gtn && xn==rn ,BAD_SIZE);- DEBUGMSG("condD")- int k;- for(k=0;k<xn;k++) {- rp[k] = xp[k]<yp[k]?ltp[k]:(xp[k]>yp[k]?gtp[k]:eqp[k]);- }- OK-}-
− lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h
@@ -1,131 +0,0 @@-/*- * We have copied the definitions in f2c.h required- * to compile clapack.h, modified to support both- * 32 and 64 bit-- http://opengrok.creo.hu/dragonfly/xref/src/contrib/gcc-3.4/libf2c/readme.netlib- http://www.ibm.com/developerworks/library/l-port64.html- */--#ifdef _LP64-typedef int integer;-typedef unsigned int uinteger;-typedef int logical;-typedef long longint; /* system-dependent */-typedef unsigned long ulongint; /* system-dependent */-#else-typedef long int integer;-typedef unsigned long int uinteger;-typedef long int logical;-typedef long long longint; /* system-dependent */-typedef unsigned long long ulongint; /* system-dependent */-#endif--typedef char *address;-typedef short int shortint;-typedef float real;-typedef double doublereal;-typedef struct { real r, i; } complex;-typedef struct { doublereal r, i; } doublecomplex;-typedef short int shortlogical;-typedef char logical1;-typedef char integer1;--typedef logical (*L_fp)();-typedef short ftnlen;--/********************************************************/--#include "clapack.h"--/********************************************************/--#define FVEC(A) int A##n, float*A##p-#define DVEC(A) int A##n, double*A##p-#define QVEC(A) int A##n, complex*A##p-#define CVEC(A) int A##n, doublecomplex*A##p-#define PVEC(A) int A##n, void* A##p, int A##s-#define FMAT(A) int A##r, int A##c, float* A##p-#define DMAT(A) int A##r, int A##c, double* A##p-#define QMAT(A) int A##r, int A##c, complex* A##p-#define CMAT(A) int A##r, int A##c, doublecomplex* A##p-#define PMAT(A) int A##r, int A##c, void* A##p, int A##s--#define KFVEC(A) int A##n, const float*A##p-#define KDVEC(A) int A##n, const double*A##p-#define KQVEC(A) int A##n, const complex*A##p-#define KCVEC(A) int A##n, const doublecomplex*A##p-#define KPVEC(A) int A##n, const void* A##p, int A##s-#define KFMAT(A) int A##r, int A##c, const float* A##p-#define KDMAT(A) int A##r, int A##c, const double* A##p-#define KQMAT(A) int A##r, int A##c, const complex* A##p-#define KCMAT(A) int A##r, int A##c, const doublecomplex* A##p-#define KPMAT(A) int A##r, int A##c, const void* A##p, int A##s--/********************************************************/--int multiplyF(int ta, int tb, KFMAT(a),KFMAT(b),FMAT(r));-int multiplyR(int ta, int tb, KDMAT(a),KDMAT(b),DMAT(r));-int multiplyC(int ta, int tb, KCMAT(a),KCMAT(b),CMAT(r));-int multiplyQ(int ta, int tb, KQMAT(a),KQMAT(b),QMAT(r));--int transF(KFMAT(x),FMAT(t));-int transR(KDMAT(x),DMAT(t));-int transQ(KQMAT(x),QMAT(t));-int transC(KCMAT(x),CMAT(t));-int transP(KPMAT(x),PMAT(t));--int constantF(float * pval, FVEC(r));-int constantR(double * pval, DVEC(r));-int constantQ(complex* pval, QVEC(r));-int constantC(doublecomplex* pval, CVEC(r));-int constantP(void* pval, PVEC(r));--int float2double(FVEC(x),DVEC(y));-int double2float(DVEC(x),FVEC(y));--int conjugateQ(KQVEC(x),QVEC(t));-int conjugateC(KCVEC(x),CVEC(t));--int stepF(FVEC(x),FVEC(y));-int stepD(DVEC(x),DVEC(y));--int condF(FVEC(x),FVEC(y),FVEC(lt),FVEC(eq),FVEC(gt),FVEC(r));-int condD(DVEC(x),DVEC(y),DVEC(lt),DVEC(eq),DVEC(gt),DVEC(r));--int svd_l_R(KDMAT(x),DMAT(u),DVEC(s),DMAT(v));-int svd_l_Rdd(KDMAT(x),DMAT(u),DVEC(s),DMAT(v));-int svd_l_C(KCMAT(a),CMAT(u),DVEC(s),CMAT(v));--int eig_l_C(KCMAT(a),CMAT(u),CVEC(s),CMAT(v));-int eig_l_R(KDMAT(a),DMAT(u),CVEC(s),DMAT(v));--int eig_l_S(int,KDMAT(a),DVEC(s),DMAT(v));-int eig_l_H(int,KCMAT(a),DVEC(s),CMAT(v));--int linearSolveR_l(KDMAT(a),KDMAT(b),DMAT(x));-int linearSolveC_l(KCMAT(a),KCMAT(b),CMAT(x));--int linearSolveLSR_l(KDMAT(a),KDMAT(b),DMAT(x));-int linearSolveLSC_l(KCMAT(a),KCMAT(b),CMAT(x));--int linearSolveSVDR_l(double,KDMAT(a),KDMAT(b),DMAT(x));-int linearSolveSVDC_l(double,KCMAT(a),KCMAT(b),CMAT(x));--int chol_l_H(KCMAT(a),CMAT(r));-int chol_l_S(KDMAT(a),DMAT(r));--int qr_l_R(KDMAT(a), DVEC(tau), DMAT(r));-int qr_l_C(KCMAT(a), CVEC(tau), CMAT(r));--int hess_l_R(KDMAT(a), DVEC(tau), DMAT(r));-int hess_l_C(KCMAT(a), CVEC(tau), CMAT(r));--int schur_l_R(KDMAT(a), DMAT(u), DMAT(s));-int schur_l_C(KCMAT(a), CMAT(u), CMAT(s));--int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r));-int lu_l_C(KCMAT(a), DVEC(ipiv), CMAT(r));--int luS_l_R(KDMAT(a), KDVEC(ipiv), KDMAT(b), DMAT(x));-int luS_l_C(KCMAT(a), KDVEC(ipiv), KCMAT(b), CMAT(x));
− lib/Numeric/LinearAlgebra/Util.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-------------------------------------------------------------------------------{- |-Module : Numeric.LinearAlgebra.Util-Copyright : (c) Alberto Ruiz 2012-License : GPL--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional---}--------------------------------------------------------------------------------module Numeric.LinearAlgebra.Util(- -- * Convenience functions for real elements- disp,- zeros, ones,- diagl,- row,- col,- (&),(!), (#),- rand, randn,- cross,- norm,- -- * Convolution- -- ** 1D- corr, conv, corrMin,- -- ** 2D- corr2, conv2, separable,- -- * Tools for the Kronecker product- --- -- | (see A. Fusiello, A matter of notation: Several uses of the Kronecker product in- -- 3d computer vision, Pattern Recognition Letters 28 (15) (2007) 2127-2132)-- --- -- | @`vec` (a \<> x \<> b) == ('trans' b ` 'kronecker' ` a) \<> 'vec' x@- vec,- vech,- dup,- vtrans-) where--import Numeric.LinearAlgebra hiding (i)-import System.Random(randomIO)-import Numeric.LinearAlgebra.Util.Convolution---disp :: Int -> Matrix Double -> IO ()--- ^ show a matrix with given number of digits after the decimal point-disp n = putStrLn . dispf n---- | pseudorandom matrix with uniform elements between 0 and 1-randm :: RandDist- -> Int -- ^ rows- -> Int -- ^ columns- -> IO (Matrix Double)-randm d r c = do- seed <- randomIO- return (reshape c $ randomVector seed d (r*c))---- | pseudorandom matrix with uniform elements between 0 and 1-rand :: Int -> Int -> IO (Matrix Double)-rand = randm Uniform---- | pseudorandom matrix with normal elements-randn :: Int -> Int -> IO (Matrix Double)-randn = randm Gaussian---- | create a real diagonal matrix from a list-diagl :: [Double] -> Matrix Double-diagl = diag . fromList---- | a real matrix of zeros-zeros :: Int -- ^ rows- -> Int -- ^ columns- -> Matrix Double-zeros r c = konst 0 (r,c)---- | a real matrix of ones-ones :: Int -- ^ rows- -> Int -- ^ columns- -> Matrix Double-ones r c = konst 1 (r,c)---- | concatenation of real vectors-infixl 3 &-(&) :: Vector Double -> Vector Double -> Vector Double-a & b = join [a,b]---- | horizontal concatenation of real matrices-infixl 3 !-(!) :: Matrix Double -> Matrix Double -> Matrix Double-a ! b = fromBlocks [[a,b]]---- | vertical concatenation of real matrices-(#) :: Matrix Double -> Matrix Double -> Matrix Double-infixl 2 #-a # b = fromBlocks [[a],[b]]---- | create a single row real matrix from a list-row :: [Double] -> Matrix Double-row = asRow . fromList---- | create a single column real matrix from a list-col :: [Double] -> Matrix Double-col = asColumn . fromList--cross :: Vector Double -> Vector Double -> Vector Double--- ^ cross product (for three-element real vectors)-cross x y | dim x == 3 && dim y == 3 = fromList [z1,z2,z3]- | otherwise = error $ "cross ("++show x++") ("++show y++")"- where- [x1,x2,x3] = toList x- [y1,y2,y3] = toList y- z1 = x2*y3-x3*y2- z2 = x3*y1-x1*y3- z3 = x1*y2-x2*y1--norm :: Vector Double -> Double--- ^ 2-norm of real vector-norm = pnorm PNorm2------------------------------------------------------------------------------------vec :: Element t => Matrix t -> Vector t--- ^ stacking of columns-vec = flatten . trans---vech :: Element t => Matrix t -> Vector t--- ^ half-vectorization (of the lower triangular part)-vech m = join . zipWith f [0..] . toColumns $ m- where- f k v = subVector k (dim v - k) v---dup :: (Num t, Num (Vector t), Element t) => Int -> Matrix t--- ^ duplication matrix (@'dup' k \<> 'vech' m == 'vec' m@, for symmetric m of 'dim' k)-dup k = trans $ fromRows $ map f es- where- rs = zip [0..] (toRows (ident (k^(2::Int))))- es = [(i,j) | j <- [0..k-1], i <- [0..k-1], i>=j ]- f (i,j) | i == j = g (k*j + i)- | otherwise = g (k*j + i) + g (k*i + j)- g j = v- where- Just v = lookup j rs---vtrans :: Element t => Int -> Matrix t -> Matrix t--- ^ generalized \"vector\" transposition: @'vtrans' 1 == 'trans'@, and @'vtrans' ('rows' m) m == 'asColumn' ('vec' m)@-vtrans p m | r == 0 = fromBlocks . map (map asColumn . takesV (replicate q p)) . toColumns $ m- | otherwise = error $ "vtrans " ++ show p ++ " of matrix with " ++ show (rows m) ++ " rows"- where- (q,r) = divMod (rows m) p-
− lib/Numeric/LinearAlgebra/Util/Convolution.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-------------------------------------------------------------------------------{- |-Module : Numeric.LinearAlgebra.Util.Convolution-Copyright : (c) Alberto Ruiz 2012-License : GPL--Maintainer : Alberto Ruiz (aruiz at um dot es)-Stability : provisional---}--------------------------------------------------------------------------------module Numeric.LinearAlgebra.Util.Convolution(- corr, conv, corrMin,- corr2, conv2, separable-) where--import Numeric.LinearAlgebra---vectSS :: Element t => Int -> Vector t -> Matrix t-vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ]---corr :: Product t => Vector t -- ^ kernel- -> Vector t -- ^ source- -> Vector t-{- ^ correlation-->>> corr (fromList[1,2,3]) (fromList [1..10])-fromList [14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0]---}-corr ker v | dim ker <= dim v = vectSS (dim ker) v <> ker- | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")"---conv :: (Product t, Num t) => Vector t -> Vector t -> Vector t-{- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product)-->>> conv (fromList[1,1]) (fromList [-1,1])-fromList [-1.0,0.0,1.0]---}-conv ker v = corr ker' v'- where- ker' = (flatten.fliprl.asRow) ker- v' | dim ker > 1 = join [z,v,z]- | otherwise = v- z = constant 0 (dim ker -1)--corrMin :: (Container Vector t, RealElement t, Product t)- => Vector t- -> Vector t- -> Vector t--- ^ similar to 'corr', using 'min' instead of (*)-corrMin ker v = minEvery ss (asRow ker) <> ones- where- minEvery a b = cond a b a a b- ss = vectSS (dim ker) v- ones = konst' 1 (dim ker)----matSS :: Element t => Int -> Matrix t -> [Matrix t]-matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ]- where- v = flatten m- c = cols m- r = rows m- n = dr*c---corr2 :: Product a => Matrix a -> Matrix a -> Matrix a--- ^ 2D correlation-corr2 ker mat = dims- . concatMap (map ((<.> ker') . flatten) . matSS c . trans)- . matSS r $ mat- where- r = rows ker- c = cols ker- ker' = flatten (trans ker)- rr = rows mat - r + 1- rc = cols mat - c + 1- dims | rr > 0 && rc > 0 = (rr >< rc)- | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")"- sz m = show (rows m)++"x"++show (cols m)--conv2 :: (Num a, Product a) => Matrix a -> Matrix a -> Matrix a--- ^ 2D convolution-conv2 k m = corr2 (fliprl . flipud $ k) pm- where- pm | r == 0 && c == 0 = m- | r == 0 = fromBlocks [[z3,m,z3]]- | c == 0 = fromBlocks [[z2],[m],[z2]]- | otherwise = fromBlocks [[z1,z2,z1]- ,[z3, m,z3]- ,[z1,z2,z1]]- r = rows k - 1- c = cols k - 1- h = rows m- w = cols m- z1 = konst' 0 (r,c)- z2 = konst' 0 (r,w)- z3 = konst' 0 (h,c)---- TODO: could be simplified using future empty arrays---separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t--- ^ matrix computation implemented as separated vector operations by rows and columns.-separable f = fromColumns . map f . toColumns . fromRows . map f . toRows-
− lib/Numeric/Matrix.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}---------------------------------------------------------------------------------- |--- Module : Numeric.Matrix--- Copyright : (c) Alberto Ruiz 2010--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ Provides instances of standard classes 'Show', 'Read', 'Eq',--- 'Num', 'Fractional', and 'Floating' for 'Matrix'.------ In arithmetic operations one-component--- vectors and matrices automatically expand to match the dimensions of the other operand.---------------------------------------------------------------------------------module Numeric.Matrix (- ) where-----------------------------------------------------------------------import Numeric.Container-----------------------------------------------------------------------instance Container Matrix a => Eq (Matrix a) where- (==) = equal--instance (Container Matrix a, Num (Vector a)) => Num (Matrix a) where- (+) = liftMatrix2Auto (+)- (-) = liftMatrix2Auto (-)- negate = liftMatrix negate- (*) = liftMatrix2Auto (*)- signum = liftMatrix signum- abs = liftMatrix abs- fromInteger = (1><1) . return . fromInteger-------------------------------------------------------instance (Container Vector a, Fractional (Vector a), Num (Matrix a)) => Fractional (Matrix a) where- fromRational n = (1><1) [fromRational n]- (/) = liftMatrix2Auto (/)-------------------------------------------------------------instance (Floating a, Container Vector a, Floating (Vector a), Fractional (Matrix a)) => Floating (Matrix a) where- sin = liftMatrix sin- cos = liftMatrix cos- tan = liftMatrix tan- asin = liftMatrix asin- acos = liftMatrix acos- atan = liftMatrix atan- sinh = liftMatrix sinh- cosh = liftMatrix cosh- tanh = liftMatrix tanh- asinh = liftMatrix asinh- acosh = liftMatrix acosh- atanh = liftMatrix atanh- exp = liftMatrix exp- log = liftMatrix log- (**) = liftMatrix2Auto (**)- sqrt = liftMatrix sqrt- pi = (1><1) [pi]
− lib/Numeric/Vector.hs
@@ -1,185 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module : Numeric.Vector--- Copyright : (c) Alberto Ruiz 2011--- License : GPL-style------ Maintainer : Alberto Ruiz <aruiz@um.es>--- Stability : provisional--- Portability : portable------ Provides instances of standard classes 'Show', 'Read', 'Eq',--- 'Num', 'Fractional', and 'Floating' for 'Vector'.--- --------------------------------------------------------------------------------module Numeric.Vector () where--import Numeric.GSL.Vector-import Numeric.Container-----------------------------------------------------------------------#ifndef VECTOR-import Foreign(Storable)-#endif----------------------------------------------------------------------#ifndef VECTOR--instance (Show a, Storable a) => (Show (Vector a)) where- show v = (show (dim v))++" |> " ++ show (toList v)--instance Container Vector a => Eq (Vector a) where- (==) = equal--instance (Element a, Read a) => Read (Vector a) where- readsPrec _ s = [((d |>) . read $ listnums, rest)]- where (thing,rest) = breakAt ']' s- (dims,listnums) = breakAt '>' thing- d = read . init . fst . breakAt '|' $ dims- breakAt c l = (a++[c],tail b) where- (a,b) = break (==c) l--#endif-----------------------------------------------------------------------adaptScalar f1 f2 f3 x y- | dim x == 1 = f1 (x@>0) y- | dim y == 1 = f3 x (y@>0)- | otherwise = f2 x y----------------------------------------------------------------------instance Num (Vector Float) where- (+) = adaptScalar addConstant add (flip addConstant)- negate = scale (-1)- (*) = adaptScalar scale mul (flip scale)- signum = vectorMapF Sign- abs = vectorMapF Abs- fromInteger = fromList . return . fromInteger--instance Num (Vector Double) where- (+) = adaptScalar addConstant add (flip addConstant)- negate = scale (-1)- (*) = adaptScalar scale mul (flip scale)- signum = vectorMapR Sign- abs = vectorMapR Abs- fromInteger = fromList . return . fromInteger--instance Num (Vector (Complex Double)) where- (+) = adaptScalar addConstant add (flip addConstant)- negate = scale (-1)- (*) = adaptScalar scale mul (flip scale)- signum = vectorMapC Sign- abs = vectorMapC Abs- fromInteger = fromList . return . fromInteger--instance Num (Vector (Complex Float)) where- (+) = adaptScalar addConstant add (flip addConstant)- negate = scale (-1)- (*) = adaptScalar scale mul (flip scale)- signum = vectorMapQ Sign- abs = vectorMapQ Abs- fromInteger = fromList . return . fromInteger-------------------------------------------------------instance (Container Vector a, Num (Vector a)) => Fractional (Vector a) where- fromRational n = fromList [fromRational n]- (/) = adaptScalar f divide g where- r `f` v = scaleRecip r v- v `g` r = scale (recip r) v-----------------------------------------------------------instance Floating (Vector Float) where- sin = vectorMapF Sin- cos = vectorMapF Cos- tan = vectorMapF Tan- asin = vectorMapF ASin- acos = vectorMapF ACos- atan = vectorMapF ATan- sinh = vectorMapF Sinh- cosh = vectorMapF Cosh- tanh = vectorMapF Tanh- asinh = vectorMapF ASinh- acosh = vectorMapF ACosh- atanh = vectorMapF ATanh- exp = vectorMapF Exp- log = vectorMapF Log- sqrt = vectorMapF Sqrt- (**) = adaptScalar (vectorMapValF PowSV) (vectorZipF Pow) (flip (vectorMapValF PowVS))- pi = fromList [pi]-----------------------------------------------------------------instance Floating (Vector Double) where- sin = vectorMapR Sin- cos = vectorMapR Cos- tan = vectorMapR Tan- asin = vectorMapR ASin- acos = vectorMapR ACos- atan = vectorMapR ATan- sinh = vectorMapR Sinh- cosh = vectorMapR Cosh- tanh = vectorMapR Tanh- asinh = vectorMapR ASinh- acosh = vectorMapR ACosh- atanh = vectorMapR ATanh- exp = vectorMapR Exp- log = vectorMapR Log- sqrt = vectorMapR Sqrt- (**) = adaptScalar (vectorMapValR PowSV) (vectorZipR Pow) (flip (vectorMapValR PowVS))- pi = fromList [pi]-----------------------------------------------------------------instance Floating (Vector (Complex Double)) where- sin = vectorMapC Sin- cos = vectorMapC Cos- tan = vectorMapC Tan- asin = vectorMapC ASin- acos = vectorMapC ACos- atan = vectorMapC ATan- sinh = vectorMapC Sinh- cosh = vectorMapC Cosh- tanh = vectorMapC Tanh- asinh = vectorMapC ASinh- acosh = vectorMapC ACosh- atanh = vectorMapC ATanh- exp = vectorMapC Exp- log = vectorMapC Log- sqrt = vectorMapC Sqrt- (**) = adaptScalar (vectorMapValC PowSV) (vectorZipC Pow) (flip (vectorMapValC PowVS))- pi = fromList [pi]---------------------------------------------------------------instance Floating (Vector (Complex Float)) where- sin = vectorMapQ Sin- cos = vectorMapQ Cos- tan = vectorMapQ Tan- asin = vectorMapQ ASin- acos = vectorMapQ ACos- atan = vectorMapQ ATan- sinh = vectorMapQ Sinh- cosh = vectorMapQ Cosh- tanh = vectorMapQ Tanh- asinh = vectorMapQ ASinh- acosh = vectorMapQ ACosh- atanh = vectorMapQ ATanh- exp = vectorMapQ Exp- log = vectorMapQ Log- sqrt = vectorMapQ Sqrt- (**) = adaptScalar (vectorMapValQ PowSV) (vectorZipQ Pow) (flip (vectorMapValQ PowVS))- pi = fromList [pi]-
+ src/Internal/Algorithms.hs view
@@ -0,0 +1,1164 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+{- |+Module : Internal.Algorithms+Copyright : (c) Alberto Ruiz 2006-14+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++High level generic interface to common matrix computations.++Specific functions for particular base types can also be explicitly+imported from "Numeric.LinearAlgebra.LAPACK".++-}+-----------------------------------------------------------------------------++module Internal.Algorithms (+ module Internal.Algorithms,+ UpLo(..)+) where++#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Conversion+import Internal.LAPACK+import Internal.Numeric+import Data.List(foldl1')+import qualified Data.Array as A+import qualified Data.Vector.Storable as Vector+import Internal.ST+import Internal.Vectorized(range)+import Control.DeepSeq++{- | Generic linear algebra functions for double precision real and complex matrices.++(Single precision data can be converted using 'single' and 'double').++-}+class (Numeric t,+ Convert t,+ Normed Matrix t,+ Normed Vector t,+ Floating t,+ Linear t Vector,+ Linear t Matrix,+ Additive (Vector t),+ Additive (Matrix t),+ RealOf t ~ Double) => Field t where+ svd' :: Matrix t -> (Matrix t, Vector Double, Matrix t)+ thinSVD' :: Matrix t -> (Matrix t, Vector Double, Matrix t)+ sv' :: Matrix t -> Vector Double+ luPacked' :: Matrix t -> (Matrix t, [Int])+ luSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t+ mbLinearSolve' :: Matrix t -> Matrix t -> Maybe (Matrix t)+ linearSolve' :: Matrix t -> Matrix t -> Matrix t+ cholSolve' :: Matrix t -> Matrix t -> Matrix t+ triSolve' :: UpLo -> Matrix t -> Matrix t -> Matrix t+ triDiagSolve' :: Vector t -> Vector t -> Vector t -> Matrix t -> Matrix t+ ldlPacked' :: Matrix t -> (Matrix t, [Int])+ ldlSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t+ linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t+ linearSolveLS' :: Matrix t -> Matrix t -> Matrix t+ eig' :: Matrix t -> (Vector (Complex Double), Matrix (Complex Double))+ geig' :: Matrix t -> Matrix t -> (Vector (Complex Double), Vector t, Matrix (Complex Double))+ eigSH'' :: Matrix t -> (Vector Double, Matrix t)+ eigOnly :: Matrix t -> Vector (Complex Double)+ geigOnly :: Matrix t -> Matrix t -> (Vector (Complex Double), Vector t)+ eigOnlySH :: Matrix t -> Vector Double+ cholSH' :: Matrix t -> Matrix t+ mbCholSH' :: Matrix t -> Maybe (Matrix t)+ qr' :: Matrix t -> (Matrix t, Vector t)+ qrgr' :: Int -> (Matrix t, Vector t) -> Matrix t+ hess' :: Matrix t -> (Matrix t, Matrix t)+ schur' :: Matrix t -> (Matrix t, Matrix t)+++instance Field Double where+ svd' = svdRd+ thinSVD' = thinSVDRd+ sv' = svR+ luPacked' = luR+ luSolve' (l_u,perm) = lusR l_u perm+ linearSolve' = linearSolveR -- (luSolve . luPacked) ??+ mbLinearSolve' = mbLinearSolveR+ cholSolve' = cholSolveR+ triSolve' = triSolveR+ triDiagSolve' = triDiagSolveR+ linearSolveLS' = linearSolveLSR+ linearSolveSVD' = linearSolveSVDR Nothing+ eig' = eigR+ eigSH'' = eigS+ geig' = eigG+ eigOnly = eigOnlyR+ geigOnly = eigOnlyG+ eigOnlySH = eigOnlyS+ cholSH' = cholS+ mbCholSH' = mbCholS+ qr' = qrR+ qrgr' = qrgrR+ hess' = unpackHess hessR+ schur' = schurR+ ldlPacked' = ldlR+ ldlSolve'= uncurry ldlsR++instance Field (Complex Double) where+#ifdef NOZGESDD+ svd' = svdC+ thinSVD' = thinSVDC+#else+ svd' = svdCd+ thinSVD' = thinSVDCd+#endif+ sv' = svC+ luPacked' = luC+ luSolve' (l_u,perm) = lusC l_u perm+ linearSolve' = linearSolveC+ mbLinearSolve' = mbLinearSolveC+ cholSolve' = cholSolveC+ triSolve' = triSolveC+ triDiagSolve' = triDiagSolveC+ linearSolveLS' = linearSolveLSC+ linearSolveSVD' = linearSolveSVDC Nothing+ eig' = eigC+ geig' = eigGC+ eigOnly = eigOnlyC+ geigOnly = eigOnlyGC+ eigSH'' = eigH+ eigOnlySH = eigOnlyH+ cholSH' = cholH+ mbCholSH' = mbCholH+ qr' = qrC+ qrgr' = qrgrC+ hess' = unpackHess hessC+ schur' = schurC+ ldlPacked' = ldlC+ ldlSolve' = uncurry ldlsC++--------------------------------------------------------------++square m = rows m == cols m++vertical m = rows m >= cols m++exactHermitian m = m `equal` ctrans m++--------------------------------------------------------------++{- | Full singular value decomposition.++@+a = (5><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0+ , 13.0, 14.0, 15.0 ] :: Matrix Double+@++>>> let (u,s,v) = svd a++>>> disp 3 u+5x5+-0.101 0.768 0.614 0.028 -0.149+-0.249 0.488 -0.503 0.172 0.646+-0.396 0.208 -0.405 -0.660 -0.449+-0.543 -0.072 -0.140 0.693 -0.447+-0.690 -0.352 0.433 -0.233 0.398++>>> s+[35.18264833189422,1.4769076999800903,1.089145439970417e-15]+it :: Vector Double++>>> disp 3 v+3x3+-0.519 -0.751 0.408+-0.576 -0.046 -0.816+-0.632 0.659 0.408++>>> let d = diagRect 0 s 5 3+>>> disp 3 d+5x3+35.183 0.000 0.000+ 0.000 1.477 0.000+ 0.000 0.000 0.000+ 0.000 0.000 0.000++>>> disp 3 $ u <> d <> tr v+5x3+ 1.000 2.000 3.000+ 4.000 5.000 6.000+ 7.000 8.000 9.000+10.000 11.000 12.000+13.000 14.000 15.000++-}+svd :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)+svd = {-# SCC "svd" #-} g . svd'+ where+ g (u,s,v) = (u,s,tr v)++{- | A version of 'svd' which returns only the @min (rows m) (cols m)@ singular vectors of @m@.++If @(u,s,v) = thinSVD m@ then @m == u \<> diag s \<> tr v@.++@+a = (5><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0+ , 13.0, 14.0, 15.0 ] :: Matrix Double+@++>>> let (u,s,v) = thinSVD a++>>> disp 3 u+5x3+-0.101 0.768 0.614+-0.249 0.488 -0.503+-0.396 0.208 -0.405+-0.543 -0.072 -0.140+-0.690 -0.352 0.433++>>> s+[35.18264833189422,1.4769076999800903,1.089145439970417e-15]+it :: Vector Double++>>> disp 3 v+3x3+-0.519 -0.751 0.408+-0.576 -0.046 -0.816+-0.632 0.659 0.408++>>> disp 3 $ u <> diag s <> tr v+5x3+ 1.000 2.000 3.000+ 4.000 5.000 6.000+ 7.000 8.000 9.000+10.000 11.000 12.000+13.000 14.000 15.000++-}+thinSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)+thinSVD = {-# SCC "thinSVD" #-} g . thinSVD'+ where+ g (u,s,v) = (u,s,tr v)+++-- | Singular values only.+singularValues :: Field t => Matrix t -> Vector Double+singularValues = {-# SCC "singularValues" #-} sv'++-- | A version of 'svd' which returns an appropriate diagonal matrix with the singular values.+--+-- If @(u,d,v) = fullSVD m@ then @m == u \<> d \<> tr v@.+fullSVD :: Field t => Matrix t -> (Matrix t, Matrix Double, Matrix t)+fullSVD m = (u,d,v) where+ (u,s,v) = svd m+ d = diagRect 0 s r c+ r = rows m+ c = cols m++{- | Similar to 'thinSVD', returning only the nonzero singular values and the corresponding singular vectors.++@+a = (5><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0+ , 13.0, 14.0, 15.0 ] :: Matrix Double+@++>>> let (u,s,v) = compactSVD a++>>> disp 3 u+5x2+-0.101 0.768+-0.249 0.488+-0.396 0.208+-0.543 -0.072+-0.690 -0.352++>>> s+[35.18264833189422,1.476907699980091]+it :: Vector Double++>>> disp 3 u+5x2+-0.101 0.768+-0.249 0.488+-0.396 0.208+-0.543 -0.072+-0.690 -0.352++>>> disp 3 $ u <> diag s <> tr v+5x3+ 1.000 2.000 3.000+ 4.000 5.000 6.000+ 7.000 8.000 9.000+10.000 11.000 12.000+13.000 14.000 15.000++-}+compactSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)+compactSVD = compactSVDTol 1++-- | @compactSVDTol r@ is similar to 'compactSVD' (for which @r=1@), but uses tolerance @tol=r*g*eps*(max rows cols)@ to distinguish nonzero singular values, where @g@ is the greatest singular value. If @g<r*eps@, then only one singular value is returned.+compactSVDTol :: Field t => Double -> Matrix t -> (Matrix t, Vector Double, Matrix t)+compactSVDTol r m = (u', subVector 0 d s, v') where+ (u,s,v) = thinSVD m+ d = rankSVD (r*eps) m s `max` 1+ u' = takeColumns d u+ v' = takeColumns d v+++-- | Singular values and all right singular vectors (as columns).+rightSV :: Field t => Matrix t -> (Vector Double, Matrix t)+rightSV m | vertical m = let (_,s,v) = thinSVD m in (s,v)+ | otherwise = let (_,s,v) = svd m in (s,v)++-- | Singular values and all left singular vectors (as columns).+leftSV :: Field t => Matrix t -> (Matrix t, Vector Double)+leftSV m | vertical m = let (u,s,_) = svd m in (u,s)+ | otherwise = let (u,s,_) = thinSVD m in (u,s)+++--------------------------------------------------------------++-- | LU decomposition of a matrix in a compact format.+data LU t = LU (Matrix t) [Int] deriving Show++instance (NFData t, Numeric t) => NFData (LU t)+ where+ rnf (LU m _) = rnf m++-- | Obtains the LU decomposition of a matrix in a compact data structure suitable for 'luSolve'.+luPacked :: Field t => Matrix t -> LU t+luPacked x = {-# SCC "luPacked" #-} LU m p+ where+ (m,p) = luPacked' x++-- | Solution of a linear system (for several right hand sides) from the precomputed LU factorization obtained by 'luPacked'.+luSolve :: Field t => LU t -> Matrix t -> Matrix t+luSolve (LU m p) = {-# SCC "luSolve" #-} luSolve' (m,p)++-- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.+-- It is similar to 'luSolve' . 'luPacked', but @linearSolve@ raises an error if called on a singular system.+linearSolve :: Field t => Matrix t -> Matrix t -> Matrix t+linearSolve = {-# SCC "linearSolve" #-} linearSolve'++-- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.+mbLinearSolve :: Field t => Matrix t -> Matrix t -> Maybe (Matrix t)+mbLinearSolve = {-# SCC "linearSolve" #-} mbLinearSolve'++-- | Solve a symmetric or Hermitian positive definite linear system using a precomputed Cholesky decomposition obtained by 'chol'.+cholSolve+ :: Field t+ => Matrix t -- ^ Cholesky decomposition of the coefficient matrix+ -> Matrix t -- ^ right hand sides+ -> Matrix t -- ^ solution+cholSolve = {-# SCC "cholSolve" #-} cholSolve'++-- | Solve a triangular linear system. If `Upper` is specified then+-- all elements below the diagonal are ignored; if `Lower` is+-- specified then all elements above the diagonal are ignored.+triSolve+ :: Field t+ => UpLo -- ^ `Lower` or `Upper`+ -> Matrix t -- ^ coefficient matrix+ -> Matrix t -- ^ right hand sides+ -> Matrix t -- ^ solution+triSolve = {-# SCC "triSolve" #-} triSolve'++-- | Solve a tridiagonal linear system. Suppose you wish to solve \(Ax = b\) where+--+-- \[+-- A =+-- \begin{bmatrix}+-- 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0+-- \end{bmatrix}+-- \quad+-- b =+-- \begin{bmatrix}+-- 1.0 & 1.0 & 1.0+-- \\ 1.0 & -1.0 & 2.0+-- \\ 1.0 & 1.0 & 3.0+-- \\ 1.0 & -1.0 & 4.0+-- \\ 1.0 & 1.0 & 5.0+-- \\ 1.0 & -1.0 & 6.0+-- \\ 1.0 & 1.0 & 7.0+-- \\ 1.0 & -1.0 & 8.0+-- \\ 1.0 & 1.0 & 9.0+-- \end{bmatrix}+-- \]+--+-- then+--+-- @+-- dL = fromList [3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0]+-- d = fromList [1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0]+-- dU = fromList [4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0]+--+-- b = (9><3)+-- [+-- 1.0, 1.0, 1.0,+-- 1.0, -1.0, 2.0,+-- 1.0, 1.0, 3.0,+-- 1.0, -1.0, 4.0,+-- 1.0, 1.0, 5.0,+-- 1.0, -1.0, 6.0,+-- 1.0, 1.0, 7.0,+-- 1.0, -1.0, 8.0,+-- 1.0, 1.0, 9.0+-- ]+--+-- x = triDiagSolve dL d dU b+-- @+--+triDiagSolve+ :: Field t+ => Vector t -- ^ lower diagonal: \(n - 1\) elements+ -> Vector t -- ^ diagonal: \(n\) elements+ -> Vector t -- ^ upper diagonal: \(n - 1\) elements+ -> Matrix t -- ^ right hand sides+ -> Matrix t -- ^ solution+triDiagSolve = {-# SCC "triDiagSolve" #-} triDiagSolve'++-- | Minimum norm solution of a general linear least squares problem Ax=B using the SVD. Admits rank-deficient systems but it is slower than 'linearSolveLS'. The effective rank of A is determined by treating as zero those singular valures which are less than 'eps' times the largest singular value.+linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t+linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD'+++-- | Least squared error solution of an overconstrained linear system, or the minimum norm solution of an underconstrained system. For rank-deficient systems use 'linearSolveSVD'.+linearSolveLS :: Field t => Matrix t -> Matrix t -> Matrix t+linearSolveLS = {-# SCC "linearSolveLS" #-} linearSolveLS'++--------------------------------------------------------------------------------++-- | LDL decomposition of a complex Hermitian or real symmetric matrix in a compact format.+data LDL t = LDL (Matrix t) [Int] deriving Show++instance (NFData t, Numeric t) => NFData (LDL t)+ where+ rnf (LDL m _) = rnf m++-- | Similar to 'ldlPacked', without checking that the input matrix is hermitian or symmetric. It works with the lower triangular part.+ldlPackedSH :: Field t => Matrix t -> LDL t+ldlPackedSH x = {-# SCC "ldlPacked" #-} LDL m p+ where+ (m,p) = ldlPacked' x++-- | Obtains the LDL decomposition of a matrix in a compact data structure suitable for 'ldlSolve'.+ldlPacked :: Field t => Herm t -> LDL t+ldlPacked (Herm m) = ldlPackedSH m++-- | Solution of a linear system (for several right hand sides) from a precomputed LDL factorization obtained by 'ldlPacked'.+--+-- Note: this can be slower than the general solver based on the LU decomposition.+ldlSolve :: Field t => LDL t -> Matrix t -> Matrix t+ldlSolve (LDL m p) = {-# SCC "ldlSolve" #-} ldlSolve' (m,p)++--------------------------------------------------------------++{- | Eigenvalues (not ordered) and eigenvectors (as columns) of a general square matrix.++If @(s,v) = eig m@ then @m \<> v == v \<> diag s@++@+a = (3><3)+ [ 3, 0, -2+ , 4, 5, -1+ , 3, 1, 0 ] :: Matrix Double+@++>>> let (l, v) = eig a++>>> putStr . dispcf 3 . asRow $ l+1x3+1.925+1.523i 1.925-1.523i 4.151++>>> putStr . dispcf 3 $ v+3x3+-0.455+0.365i -0.455-0.365i 0.181+ 0.603 0.603 -0.978+ 0.033+0.543i 0.033-0.543i -0.104++>>> putStr . dispcf 3 $ complex a <> v+3x3+-1.432+0.010i -1.432-0.010i 0.753+ 1.160+0.918i 1.160-0.918i -4.059+-0.763+1.096i -0.763-1.096i -0.433++>>> putStr . dispcf 3 $ v <> diag l+3x3+-1.432+0.010i -1.432-0.010i 0.753+ 1.160+0.918i 1.160-0.918i -4.059+-0.763+1.096i -0.763-1.096i -0.433++-}+eig :: Field t => Matrix t -> (Vector (Complex Double), Matrix (Complex Double))+eig = {-# SCC "eig" #-} eig'++-- | Generalized eigenvalues (not ordered) and eigenvectors (as columns) of a pair of nonsymmetric matrices.+-- Eigenvalues are represented as pairs of alpha, beta, where eigenvalue = alpha / beta. Alpha is always+-- complex, but betas has the same type as the input matrix.+--+-- If @(alphas, betas, v) = geig a b@, then @a \<> v == b \<> v \<> diag (alphas / betas)@+--+-- Note that beta can be 0 and that has reasonable interpretation.+geig :: Field t => Matrix t -> Matrix t -> (Vector (Complex Double), Vector t, Matrix (Complex Double))+geig = {-# SCC "geig" #-} geig'++-- | Eigenvalues (not ordered) of a general square matrix.+eigenvalues :: Field t => Matrix t -> Vector (Complex Double)+eigenvalues = {-# SCC "eigenvalues" #-} eigOnly++-- | Generalized eigenvalues of a pair of matrices. Represented as pairs of alpha, beta,+-- where eigenvalue is alpha / beta as in 'geig'.+geigenvalues :: Field t => Matrix t -> Matrix t -> (Vector (Complex Double), Vector t)+geigenvalues = {-# SCC "geigenvalues" #-} geigOnly++-- | Similar to 'eigSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.+eigSH' :: Field t => Matrix t -> (Vector Double, Matrix t)+eigSH' = {-# SCC "eigSH'" #-} eigSH''++-- | Similar to 'eigenvaluesSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.+eigenvaluesSH' :: Field t => Matrix t -> Vector Double+eigenvaluesSH' = {-# SCC "eigenvaluesSH'" #-} eigOnlySH++{- | Eigenvalues and eigenvectors (as columns) of a complex hermitian or real symmetric matrix, in descending order.++If @(s,v) = eigSH m@ then @m == v \<> diag s \<> tr v@++@+a = (3><3)+ [ 1.0, 2.0, 3.0+ , 2.0, 4.0, 5.0+ , 3.0, 5.0, 6.0 ]+@++>>> let (l, v) = eigSH a++>>> l+[11.344814282762075,0.17091518882717918,-0.5157294715892575]++>>> disp 3 $ v <> diag l <> tr v+3x3+1.000 2.000 3.000+2.000 4.000 5.000+3.000 5.000 6.000++-}+eigSH :: Field t => Herm t -> (Vector Double, Matrix t)+eigSH (Herm m) = eigSH' m++-- | Eigenvalues (in descending order) of a complex hermitian or real symmetric matrix.+eigenvaluesSH :: Field t => Herm t -> Vector Double+eigenvaluesSH (Herm m) = eigenvaluesSH' m++--------------------------------------------------------------++-- | QR decomposition of a matrix in compact form. (The orthogonal matrix is not explicitly formed.)+data QR t = QR (Matrix t) (Vector t)++instance (NFData t, Numeric t) => NFData (QR t)+ where+ rnf (QR m _) = rnf m+++-- | QR factorization.+--+-- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular.+-- Note: the current implementation is very slow for large matrices. 'thinQR' is much faster.+qr :: Field t => Matrix t -> (Matrix t, Matrix t)+qr = {-# SCC "qr" #-} unpackQR . qr'++-- | A version of 'qr' which returns only the @min (rows m) (cols m)@ columns of @q@ and rows of @r@.+thinQR :: Field t => Matrix t -> (Matrix t, Matrix t)+thinQR = {-# SCC "thinQR" #-} thinUnpackQR . qr'++-- | Compute the QR decomposition of a matrix in compact form.+qrRaw :: Field t => Matrix t -> QR t+qrRaw m = QR x v+ where+ (x,v) = qr' m++-- | generate a matrix with k orthogonal columns from the compact QR decomposition obtained by 'qrRaw'.+--+qrgr :: Field t => Int -> QR t -> Matrix t+qrgr n (QR a t)+ | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)"+ | otherwise = qrgr' n (a,t)++-- | RQ factorization.+--+-- If @(r,q) = rq m@ then @m == r \<> q@, where q is unitary and r is upper triangular.+-- Note: the current implementation is very slow for large matrices. 'thinRQ' is much faster.+rq :: Field t => Matrix t -> (Matrix t, Matrix t)+rq = {-# SCC "rq" #-} rqFromQR qr++-- | A version of 'rq' which returns only the @min (rows m) (cols m)@ columns of @r@ and rows of @q@.+thinRQ :: Field t => Matrix t -> (Matrix t, Matrix t)+thinRQ = {-# SCC "thinQR" #-} rqFromQR thinQR++rqFromQR :: Field t => (Matrix t -> (Matrix t, Matrix t)) -> Matrix t -> (Matrix t, Matrix t)+rqFromQR qr0 m = (r,q) where+ (q',r') = qr0 $ trans $ rev1 m+ r = rev2 (trans r')+ q = rev2 (trans q')+ rev1 = flipud . fliprl+ rev2 = fliprl . flipud++-- | Hessenberg factorization.+--+-- If @(p,h) = hess m@ then @m == p \<> h \<> tr p@, where p is unitary+-- and h is in upper Hessenberg form (it has zero entries below the first subdiagonal).+hess :: Field t => Matrix t -> (Matrix t, Matrix t)+hess = hess'++-- | Schur factorization.+--+-- If @(u,s) = schur m@ then @m == u \<> s \<> tr u@, where u is unitary+-- and s is a Shur matrix. A complex Schur matrix is upper triangular. A real Schur matrix is+-- upper triangular in 2x2 blocks.+--+-- \"Anything that the Jordan decomposition can do, the Schur decomposition+-- can do better!\" (Van Loan)+schur :: Field t => Matrix t -> (Matrix t, Matrix t)+schur = schur'+++-- | Similar to 'cholSH', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'.+mbCholSH :: Field t => Matrix t -> Maybe (Matrix t)+mbCholSH = {-# SCC "mbCholSH" #-} mbCholSH'++-- | Similar to 'chol', without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.+cholSH :: Field t => Matrix t -> Matrix t+cholSH = cholSH'++-- | Cholesky factorization of a positive definite hermitian or symmetric matrix.+--+-- If @c = chol m@ then @c@ is upper triangular and @m == tr c \<> c@.+chol :: Field t => Herm t -> Matrix t+chol (Herm m) = {-# SCC "chol" #-} cholSH' m++-- | Similar to 'chol', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'.+mbChol :: Field t => Herm t -> Maybe (Matrix t)+mbChol (Herm m) = {-# SCC "mbChol" #-} mbCholSH' m++++-- | Joint computation of inverse and logarithm of determinant of a square matrix.+invlndet :: Field t+ => Matrix t+ -> (Matrix t, (t, t)) -- ^ (inverse, (log abs det, sign or phase of det))+invlndet m | square m = (im,(ladm,sdm))+ | otherwise = error $ "invlndet of nonsquare "++ shSize m ++ " matrix"+ where+ lp@(LU lup perm) = luPacked m+ s = signlp (rows m) perm+ dg = toList $ takeDiag $ lup+ ladm = sum $ map (log.abs) dg+ sdm = s* product (map signum dg)+ im = luSolve lp (ident (rows m))+++-- | Determinant of a square matrix. To avoid possible overflow or underflow use 'invlndet'.+det :: Field t => Matrix t -> t+det m | square m = {-# SCC "det" #-} s * (product $ toList $ takeDiag $ lup)+ | otherwise = error $ "det of nonsquare "++ shSize m ++ " matrix"+ where+ LU lup perm = luPacked m+ s = signlp (rows m) perm++-- | Explicit LU factorization of a general matrix.+--+-- If @(l,u,p,s) = lu m@ then @m == p \<> l \<> u@, where l is lower triangular,+-- u is upper triangular, p is a permutation matrix and s is the signature of the permutation.+lu :: Field t => Matrix t -> (Matrix t, Matrix t, Matrix t, t)+lu = luFact . luPacked++-- | Inverse of a square matrix. See also 'invlndet'.+inv :: Field t => Matrix t -> Matrix t+inv m | square m = m `linearSolve` ident (rows m)+ | otherwise = error $ "inv of nonsquare "++ shSize m ++ " matrix"+++-- | Pseudoinverse of a general matrix with default tolerance ('pinvTol' 1, similar to GNU-Octave).+pinv :: Field t => Matrix t -> Matrix t+pinv = pinvTol 1++{- | @pinvTol r@ computes the pseudoinverse of a matrix with tolerance @tol=r*g*eps*(max rows cols)@, where g is the greatest singular value.++@+m = (3><3) [ 1, 0, 0+ , 0, 1, 0+ , 0, 0, 1e-10] :: Matrix Double+@++>>> pinv m+1. 0. 0.+0. 1. 0.+0. 0. 10000000000.++>>> pinvTol 1E8 m+1. 0. 0.+0. 1. 0.+0. 0. 1.++-}++pinvTol :: Field t => Double -> Matrix t -> Matrix t+pinvTol t m = v' `mXm` diag s' `mXm` ctrans u' where+ (u,s,v) = thinSVD m+ sl@(g:_) = toList s+ s' = real . fromList . map rec $ sl+ rec x = if x <= g*tol then x else 1/x+ tol = (fromIntegral (max r c) * g * t * eps)+ r = rows m+ c = cols m+ d = dim s+ u' = takeColumns d u+ v' = takeColumns d v+++-- | Numeric rank of a matrix from the SVD decomposition.+rankSVD :: Element t+ => Double -- ^ numeric zero (e.g. 1*'eps')+ -> Matrix t -- ^ input matrix m+ -> Vector Double -- ^ 'sv' of m+ -> Int -- ^ rank of m+rankSVD teps m s = ranksv teps (max (rows m) (cols m)) (toList s)++-- | Numeric rank of a matrix from its singular values.+ranksv :: Double -- ^ numeric zero (e.g. 1*'eps')+ -> Int -- ^ maximum dimension of the matrix+ -> [Double] -- ^ singular values+ -> Int -- ^ rank of m+ranksv teps maxdim s = k where+ g = maximum s+ tol = fromIntegral maxdim * g * teps+ s' = filter (>tol) s+ k = if g > teps then length s' else 0++-- | The machine precision of a Double: @eps = 2.22044604925031e-16@ (the value used by GNU-Octave).+eps :: Double+eps = 2.22044604925031e-16+++-- | 1 + 0.5*peps == 1, 1 + 0.6*peps /= 1+peps :: RealFloat x => x+peps = x where x = 2.0 ** fromIntegral (1 - floatDigits x)++-----------------------------------------------------------------------++-- | The nullspace of a matrix from its precomputed SVD decomposition.+nullspaceSVD :: Field t+ => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'),+ -- or Right \"theoretical\" matrix rank.+ -> Matrix t -- ^ input matrix m+ -> (Vector Double, Matrix t) -- ^ 'rightSV' of m+ -> Matrix t -- ^ nullspace+nullspaceSVD hint a (s,v) = vs where+ tol = case hint of+ Left t -> t+ _ -> eps+ k = case hint of+ Right t -> t+ _ -> rankSVD tol a s+ vs = dropColumns k v+++-- | The nullspace of a matrix. See also 'nullspaceSVD'.+nullspacePrec :: Field t+ => Double -- ^ relative tolerance in 'eps' units (e.g., use 3 to get 3*'eps')+ -> Matrix t -- ^ input matrix+ -> [Vector t] -- ^ list of unitary vectors spanning the nullspace+nullspacePrec t m = toColumns $ nullspaceSVD (Left (t*eps)) m (rightSV m)++-- | The nullspace of a matrix, assumed to be one-dimensional, with machine precision.+nullVector :: Field t => Matrix t -> Vector t+nullVector = last . nullspacePrec 1++-- | The range space a matrix from its precomputed SVD decomposition.+orthSVD :: Field t+ => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'),+ -- or Right \"theoretical\" matrix rank.+ -> Matrix t -- ^ input matrix m+ -> (Matrix t, Vector Double) -- ^ 'leftSV' of m+ -> Matrix t -- ^ orth+orthSVD hint a (v,s) = vs where+ tol = case hint of+ Left t -> t+ _ -> eps+ k = case hint of+ Right t -> t+ _ -> rankSVD tol a s+ vs = takeColumns k v+++orth :: Field t => Matrix t -> [Vector t]+-- ^ Return an orthonormal basis of the range space of a matrix+orth m = take r $ toColumns u+ where+ (u,s,_) = compactSVD m+ r = ranksv eps (max (rows m) (cols m)) (toList s)++------------------------------------------------------------------------++-- many thanks, quickcheck!++haussholder :: (Field a) => a -> Vector a -> Matrix a+haussholder tau v = ident (dim v) `sub` (tau `scale` (w `mXm` ctrans w))+ where w = asColumn v+++zh k v = fromList $ replicate (k-1) 0 ++ (1:drop k xs)+ where xs = toList v++zt 0 v = v+zt k v = vjoin [subVector 0 (dim v - k) v, konst' 0 k]+++unpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t)+unpackQR (pq, tau) = {-# SCC "unpackQR" #-} (q,r)+ where cs = toColumns pq+ m = rows pq+ n = cols pq+ mn = min m n+ r = fromColumns $ zipWith zt ([m-1, m-2 .. 1] ++ repeat 0) cs+ vs = zipWith zh [1..mn] cs+ hs = zipWith haussholder (toList tau) vs+ q = foldl1' mXm hs++thinUnpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t)+thinUnpackQR (pq, tau) = (q, r)+ where mn = uncurry min $ size pq+ q = qrgr mn $ QR pq tau+ r = fromRows $ zipWith (\i v -> Vector.replicate i 0 Vector.++ Vector.drop i v) [0..mn-1] (toRows pq)++unpackHess :: (Field t) => (Matrix t -> (Matrix t,Vector t)) -> Matrix t -> (Matrix t, Matrix t)+unpackHess hf m+ | rows m == 1 = ((1><1)[1],m)+ | otherwise = (uH . hf) m++uH (pq, tau) = (p,h)+ where cs = toColumns pq+ m = rows pq+ n = cols pq+ mn = min m n+ h = fromColumns $ zipWith zt ([m-2, m-3 .. 1] ++ repeat 0) cs+ vs = zipWith zh [2..mn] cs+ hs = zipWith haussholder (toList tau) vs+ p = foldl1' mXm hs++--------------------------------------------------------------------------++-- | Reciprocal of the 2-norm condition number of a matrix, computed from the singular values.+rcond :: Field t => Matrix t -> Double+rcond m = last s / head s+ where s = toList (singularValues m)++-- | Number of linearly independent rows or columns. See also 'ranksv'+rank :: Field t => Matrix t -> Int+rank m = rankSVD eps m (singularValues m)++{-+expm' m = case diagonalize (complex m) of+ Just (l,v) -> v `mXm` diag (exp l) `mXm` inv v+ Nothing -> error "Sorry, expm not yet implemented for non-diagonalizable matrices"+ where exp = vectorMapC Exp+-}++diagonalize m = if rank v == n+ then Just (l,v)+ else Nothing+ where n = rows m+ (l,v) = if exactHermitian m+ then let (l',v') = eigSH (trustSym m) in (real l', v')+ else eig m++-- | Generic matrix functions for diagonalizable matrices. For instance:+--+-- @logm = matFunc log@+--+matFunc :: (Complex Double -> Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+matFunc f m = case diagonalize m of+ Just (l,v) -> v `mXm` diag (mapVector f l) `mXm` inv v+ Nothing -> error "Sorry, matFunc requires a diagonalizable matrix"++--------------------------------------------------------------++golubeps :: Integer -> Integer -> Double+golubeps p q = a * fromIntegral b / fromIntegral c where+ a = 2^^(3-p-q)+ b = fact p * fact q+ c = fact (p+q) * fact (p+q+1)+ fact n = product [1..n]++epslist :: [(Int,Double)]+epslist = [ (fromIntegral k, golubeps k k) | k <- [1..]]++geps delta = head [ k | (k,g) <- epslist, g<delta]+++{- | Matrix exponential. It uses a direct translation of Algorithm 11.3.1 in Golub & Van Loan,+ based on a scaled Pade approximation.+-}+expm :: Field t => Matrix t -> Matrix t+expm = expGolub++expGolub :: Field t => Matrix t -> Matrix t+expGolub m = iterate msq f !! j+ where j = max 0 $ floor $ logBase 2 $ pnorm Infinity m+ a = m */ fromIntegral ((2::Int)^j)+ q = geps eps -- 7 steps+ eye = ident (rows m)+ work (k,c,x,n,d) = (k',c',x',n',d')+ where k' = k+1+ c' = c * fromIntegral (q-k+1) / fromIntegral ((2*q-k+1)*k)+ x' = a <> x+ n' = n |+| (c' .* x')+ d' = d |+| (((-1)^k * c') .* x')+ (_,_,_,nf,df) = iterate work (1,1,eye,eye,eye) !! q+ f = linearSolve df nf+ msq x = x <> x++ (<>) = multiply+ v */ x = scale (recip x) v+ (.*) = scale+ (|+|) = add++--------------------------------------------------------------++{- | Matrix square root. Currently it uses a simple iterative algorithm described in Wikipedia.+It only works with invertible matrices that have a real solution.++@m = (2><2) [4,9+ ,0,4] :: Matrix Double@++>>> sqrtm m+(2><2)+ [ 2.0, 2.25+ , 0.0, 2.0 ]++For diagonalizable matrices you can try 'matFunc' @sqrt@:++>>> matFunc sqrt ((2><2) [1,0,0,-1])+(2><2)+ [ 1.0 :+ 0.0, 0.0 :+ 0.0+ , 0.0 :+ 0.0, 0.0 :+ 1.0 ]++-}+sqrtm :: Field t => Matrix t -> Matrix t+sqrtm = sqrtmInv++sqrtmInv x = fst $ fixedPoint $ iterate f (x, ident (rows x))+ where fixedPoint (a:b:rest) | pnorm PNorm1 (fst a |-| fst b) < peps = a+ | otherwise = fixedPoint (b:rest)+ fixedPoint _ = error "fixedpoint with impossible inputs"+ f (y,z) = (0.5 .* (y |+| inv z),+ 0.5 .* (inv y |+| z))+ (.*) = scale+ (|+|) = add+ (|-|) = sub++------------------------------------------------------------------++signlp r vals = foldl f 1 (zip [0..r-1] vals)+ where f s (a,b) | a /= b = -s+ | otherwise = s++fixPerm r vals = (fromColumns $ A.elems res, sign)+ where+ v = [0..r-1]+ t = toColumns (ident r)+ (res,sign) = foldl swap (A.listArray (0,r-1) t, 1) (zip v vals)+ swap (arr,s) (a,b)+ | a /= b = (arr A.// [(a, arr A.! b),(b,arr A.! a)],-s)+ | otherwise = (arr,s)++fixPerm' :: [Int] -> Vector I+fixPerm' s = res $ mutable f s0+ where+ s0 = reshape 1 (range (length s))+ res = flatten . fst+ swap m i j = rowOper (SWAP i j AllCols) m+ f :: (Num t, Element t) => (Int, Int) -> STMatrix s t -> ST s () -- needed because of TypeFamilies+ f _ p = sequence_ $ zipWith (swap p) [0..] s++triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]]+ where el p q = if q-p>=h then v else 1 - v++-- | Compute the explicit LU decomposition from the compact one obtained by 'luPacked'.+luFact :: Numeric t => LU t -> (Matrix t, Matrix t, Matrix t, t)+luFact (LU l_u perm)+ | r <= c = (l ,u ,p, s)+ | otherwise = (l',u',p, s)+ where+ r = rows l_u+ c = cols l_u+ tu = triang r c 0 1+ tl = triang r c 0 0+ l = takeColumns r (l_u |*| tl) |+| diagRect 0 (konst' 1 r) r r+ u = l_u |*| tu+ (p,s) = fixPerm r perm+ l' = (l_u |*| tl) |+| diagRect 0 (konst' 1 c) r c+ u' = takeRows c (l_u |*| tu)+ (|+|) = add+ (|*|) = mul++---------------------------------------------------------------------------++data NormType = Infinity | PNorm1 | PNorm2 | Frobenius++class (RealFloat (RealOf t)) => Normed c t where+ pnorm :: NormType -> c t -> RealOf t++instance Normed Vector Double where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = norm2++instance Normed Vector (Complex Double) where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = pnorm PNorm2++instance Normed Vector Float where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = pnorm PNorm2++instance Normed Vector (Complex Float) where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = pnorm PNorm2+++instance Normed Matrix Double where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = (@>0) . singularValues+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++instance Normed Matrix (Complex Double) where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = (@>0) . singularValues+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++instance Normed Matrix Float where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = realToFrac . (@>0) . singularValues . double+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++instance Normed Matrix (Complex Float) where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = realToFrac . (@>0) . singularValues . double+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++-- | Approximate number of common digits in the maximum element.+relativeError' :: (Normed c t, Container c t) => c t -> c t -> Int+relativeError' x y = dig (norm (x `sub` y) / norm x)+ where norm = pnorm Infinity+ dig r = round $ -logBase 10 (realToFrac r :: Double)+++relativeError :: Num a => (a -> Double) -> a -> a -> Double+relativeError norm a b = r+ where+ na = norm a+ nb = norm b+ nab = norm (a-b)+ mx = max na nb+ mn = min na nb+ r = if mn < peps+ then mx+ else nab/mx+++----------------------------------------------------------------------++-- | Generalized symmetric positive definite eigensystem Av = lBv,+-- for A and B symmetric, B positive definite.+geigSH :: Field t+ => Herm t -- ^ A+ -> Herm t -- ^ B+ -> (Vector Double, Matrix t)+geigSH (Herm a) (Herm b) = geigSH' a b++geigSH' :: Field t+ => Matrix t -- ^ A+ -> Matrix t -- ^ B+ -> (Vector Double, Matrix t)+geigSH' a b = (l,v')+ where+ u = cholSH b+ iu = inv u+ c = ctrans iu <> a <> iu+ (l,v) = eigSH' c+ v' = iu <> v+ (<>) = mXm++--------------------------------------------------------------------------------++-- | A matrix that, by construction, it is known to be complex Hermitian or real symmetric.+--+-- It can be created using 'sym', 'mTm', or 'trustSym', and the matrix can be extracted using 'unSym'.+newtype Herm t = Herm (Matrix t) deriving Show++instance (NFData t, Numeric t) => NFData (Herm t)+ where+ rnf (Herm m) = rnf m++-- | Extract the general matrix from a 'Herm' structure, forgetting its symmetric or Hermitian property.+unSym :: Herm t -> Matrix t+unSym (Herm x) = x++-- | Compute the complex Hermitian or real symmetric part of a square matrix (@(x + tr x)/2@).+sym :: Field t => Matrix t -> Herm t+sym x = Herm (scale 0.5 (tr x `add` x))++-- | Compute the contraction @tr x <> x@ of a general matrix.+mTm :: Numeric t => Matrix t -> Herm t+mTm x = Herm (tr x `mXm` x)++instance Field t => Linear t Herm where+ scale x (Herm m) = Herm (scale x m)++instance Field t => Additive (Herm t) where+ add (Herm a) (Herm b) = Herm (a `add` b)++-- | At your own risk, declare that a matrix is complex Hermitian or real symmetric+-- for usage in 'chol', 'eigSH', etc. Only a triangular part of the matrix will be used.+trustSym :: Matrix t -> Herm t+trustSym x = (Herm x)
+ src/Internal/C/lapack-aux.c view
@@ -0,0 +1,2014 @@+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+#include <math.h>+#include <time.h>+#include <inttypes.h>+#include <complex.h>++typedef double complex TCD;+typedef float complex TCF;++#undef complex++#include "lapack-aux.h"++#define MACRO(B) do {B} while (0)+#define ERROR(CODE) MACRO(return CODE;)+#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})++#define MIN(A,B) ((A)<(B)?(A):(B))+#define MAX(A,B) ((A)>(B)?(A):(B))++// #define DBGL++#ifdef DBGL+#define DEBUGMSG(M) printf("\nLAPACK "M"\n");+#else+#define DEBUGMSG(M)+#endif++#define OK return 0;++// #ifdef DBGL+// #define DEBUGMSG(M) printf("LAPACK Wrapper "M"\n: "); size_t t0 = time(NULL);+// #define OK MACRO(printf("%ld s\n",time(0)-t0); return 0;);+// #else+// #define DEBUGMSG(M)+// #define OK return 0;+// #endif+++#define INFOMAT(M) printf("%dx%d %d:%d\n",M##r,M##c,M##Xr,M##Xc);++#define TRACEMAT(M) {int q; printf(" %d x %d: ",M##r,M##c); \+ for(q=0;q<M##r*M##c;q++) printf("%.1f ",M##p[q]); printf("\n");}++#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)+#define MARK(RES,CODE) MACRO(if(RES) { ret = CODE; })+#define CONVERGED(RES,CODE) MACRO(if(RES > 0) { ret = CODE; } else if(RES < 0) { ret = RES; })+#define UNWIND(RES,CODE,LABEL) MACRO(if(RES) { ret = CODE; goto LABEL; })++#define BAD_SIZE 2000+#define BAD_CODE 2001+#define MEM 2002+#define BAD_FILE 2003+#define SINGULAR 2004+#define NOCONVER 2005+#define NODEFPOS 2006+#define NOSPRTD 2007++////////////////////////////////////////////////////////////////////////////////+void asm_finit() {+#ifdef i386++// asm("finit");++ static unsigned char buf[108];+ asm("FSAVE %0":"=m" (buf));++ #if FPUDEBUG+ if(buf[8]!=255 || buf[9]!=255) { // print warning in red+ printf("%c[;31mWarning: FPU TAG = %x %x\%c[0m\n",0x1B,buf[8],buf[9],0x1B);+ }+ #endif++ #if NANDEBUG+ asm("FRSTOR %0":"=m" (buf));+ #endif++#endif+}++#if NANDEBUG++#define CHECKNANR(M,msg) \+{ int k; \+for(k=0; k<(M##r * M##c); k++) { \+ if(M##p[k] != M##p[k]) { \+ printf(msg); \+ TRACEMAT(M) \+ /*exit(1);*/ \+ } \+} \+}++#define CHECKNANC(M,msg) \+{ int k; \+for(k=0; k<(M##r * M##c); k++) { \+ if( M##p[k].r != M##p[k].r \+ || M##p[k].i != M##p[k].i) { \+ printf(msg); \+ /*exit(1);*/ \+ } \+} \+}++#else+#define CHECKNANC(M,msg)+#define CHECKNANR(M,msg)+#endif+++////////////////////////////////////////////////////////////////////////////////+//////////////////// real svd ///////////////////////////////////////////////////++int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n,+ doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *+ ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,+ integer *info);++int svd_l_R(ODMAT(a),ODMAT(u), DVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer q = MIN(m,n);+ REQUIRES(sn==q,BAD_SIZE);+ REQUIRES(up==NULL || (ur==m && (uc==m || uc==q)),BAD_SIZE);+ char* jobu = "A";+ if (up==NULL) {+ jobu = "N";+ } else {+ if (uc==q) {+ jobu = "S";+ }+ }+ REQUIRES(vp==NULL || (vc==n && (vr==n || vr==q)),BAD_SIZE);+ char* jobvt = "A";+ integer ldvt = n;+ if (vp==NULL) {+ jobvt = "N";+ } else {+ if (vr==q) {+ jobvt = "S";+ ldvt = q;+ }+ }+ DEBUGMSG("svd_l_R");+ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ double ans;+ dgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ work, &lwork,+ &res);++ MARK(res, res);+ free(work);+ return ret;+}++// (alternative version)++int dgesdd_(char *jobz, integer *m, integer *n, doublereal *+ a, integer *lda, doublereal *s, doublereal *u, integer *ldu,+ doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,+ integer *iwork, integer *info);++int svd_l_Rdd(ODMAT(a),ODMAT(u), DVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer q = MIN(m,n);+ REQUIRES(sn==q,BAD_SIZE);+ REQUIRES((up == NULL && vp == NULL)+ || (ur==m && vc==n+ && ((uc == q && vr == q)+ || (uc == m && vc==n))),BAD_SIZE);+ char* jobz = "A";+ integer ldvt = n;+ if (up==NULL) {+ jobz = "N";+ } else {+ if (uc==q && vr == q) {+ jobz = "S";+ ldvt = q;+ }+ }+ DEBUGMSG("svd_l_Rdd");+ integer* iwk = (integer*) malloc(8*q*sizeof(integer));+ UNWIND(!iwk,MEM,cleanup0);+ integer lwk = -1;+ integer res;+ // ask for optimal lwk+ double ans;+ dgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,iwk,&res);+ UNWIND(res,res,cleanup1);++ lwk = ans;+ double * workv = (double*)malloc(lwk*sizeof(double));+ UNWIND(!workv,MEM,cleanup1);++ dgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,workv,&lwk,iwk,&res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(workv);+cleanup1:+ free(iwk);+cleanup0:+ return ret;+}++//////////////////// complex svd ////////////////////////////////////++int zgesvd_(char *jobu, char *jobvt, integer *m, integer *n,+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,+ integer *lwork, doublereal *rwork, integer *info);++int svd_l_C(OCMAT(a),OCMAT(u), DVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer q = MIN(m,n);+ REQUIRES(sn==q,BAD_SIZE);+ REQUIRES(up==NULL || (ur==m && (uc==m || uc==q)),BAD_SIZE);+ REQUIRES(vp==NULL || (vc==n && (vr==n || vr==q)),BAD_SIZE);++ char* jobu = "A";+ if (up==NULL) {+ jobu = "N";+ } else {+ if (uc==q) {+ jobu = "S";+ }+ }+ char* jobvt = "A";+ integer ldvt = n;+ if (vp==NULL) {+ jobvt = "N";+ } else {+ if (vr==q) {+ jobvt = "S";+ ldvt = q;+ }+ }DEBUGMSG("svd_l_C");++ double *rwork = (double*) malloc(5*q*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ &ans, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ work, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++int zgesdd_ (char *jobz, integer *m, integer *n,+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,+ integer *lwork, doublereal *rwork, integer* iwork, integer *info);++int svd_l_Cdd(OCMAT(a),OCMAT(u), DVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer mx = MAX(m,n);+ integer mn = MIN(m,n);+ REQUIRES(sn==mn,BAD_SIZE);+ REQUIRES((up == NULL && vp == NULL)+ || (ur==m && vc==n+ && ((uc == mn && vr == mn)+ || (uc == m && vc==n))),BAD_SIZE);+ char* jobz = "A";+ integer ldvt = n;+ if (up==NULL) {+ jobz = "N";+ } else {+ if (uc==mn && vr == mn) {+ jobz = "S";+ ldvt = mn;+ }+ }+ DEBUGMSG("svd_l_Cdd");+ integer* iwk = (integer*) malloc(8*mn*sizeof(integer));+ UNWIND(!iwk,MEM,cleanup0);++ // Docs: http://www.netlib.org/lapack/explore-html/d8/d54/zgesdd_8f_source.html+ // RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))+ // Let mx = max(M,N) and mn = min(M,N).+ // If JOBZ = 'N', LRWORK >= 5*mn (LAPACK <= 3.6 needs 7*mn);+ // else if mx >> mn, LRWORK >= 5*mn*mn + 5*mn;+ // else LRWORK >= max( 5*mn*mn + 5*mn,+ // 2*mx*mn + 2*mn*mn + mn ).+ int lrwk;+ if (*jobz == 'N') {+ lrwk = 7*mn;+ } else {+ lrwk = MAX(5*mn*mn + 7*mn, 2*mx*mn + 2*mn*mn + mn);+ }+ double *rwk = (double*)malloc(MAX(1, lrwk)*sizeof(double));;+ UNWIND(!rwk,MEM,cleanup1);++ integer lwk = -1;+ integer res;+ // ask for optimal lwk+ doublecomplex ans;+ zgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,rwk,iwk,&res);+ UNWIND(res,res,cleanup2);++ lwk = ans.r;+ doublecomplex * workv = (doublecomplex*)malloc(lwk*sizeof(doublecomplex));+ UNWIND(!workv,MEM,cleanup2);++ zgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,workv,&lwk,rwk,iwk,&res);+ UNWIND(res,res,cleanup3);++cleanup3:+ free(workv);+cleanup2:+ free(rwk);+cleanup1:+ free(iwk);+cleanup0:+ return ret;+}++//////////////////// general complex eigensystem ////////////++int zgeev_(char *jobvl, char *jobvr, integer *n,+ doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl,+ integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work,+ integer *lwork, doublereal *rwork, integer *info);++int eig_l_C(OCMAT(a), OCMAT(u), CVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac==n && sn==n, BAD_SIZE);+ REQUIRES(up==NULL || (ur==n && uc==n), BAD_SIZE);+ char jobvl = up==NULL?'N':'V';+ REQUIRES(vp==NULL || (vr==n && vc==n), BAD_SIZE);+ char jobvr = vp==NULL?'N':'V';+ DEBUGMSG("eig_l_C");++ double *rwork = (double*) malloc(2*n*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ sp,+ up,&n,+ vp,&n,+ &ans, &lwork,+ rwork,+ &res);++ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ sp,+ up,&n,+ vp,&n,+ work, &lwork,+ rwork,+ &res);++ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++++//////////////////// general real eigensystem ////////////++int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *+ a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl,+ integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work,+ integer *lwork, integer *info);++int eig_l_R(ODMAT(a),ODMAT(u), CVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac==n && sn==n, BAD_SIZE);+ REQUIRES(up==NULL || (ur==n && uc==n), BAD_SIZE);+ char jobvl = up==NULL?'N':'V';+ REQUIRES(vp==NULL || (vr==n && vc==n), BAD_SIZE);+ char jobvr = vp==NULL?'N':'V';+ DEBUGMSG("eig_l_R");+ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ double ans;+ dgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ (double*)sp, (double*)sp+n,+ up,&n,+ vp,&n,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);+ dgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ (double*)sp, (double*)sp+n,+ up,&n,+ vp,&n,+ work, &lwork,+ &res);+ MARK(res,res);++ free(work);+ return ret;+}++//////////////////// generalized real eigensystem ////////////++int dggev_(char *jobvl, char *jobvr, integer *n,+ doublereal *a, integer *lda, doublereal *b, integer *ldb,+ doublereal *alphar, doublereal *alphai, doublereal *beta,+ doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,+ doublereal *work,+ integer *lwork, integer *info);++int eig_l_G(ODMAT(a), ODMAT(b), CVEC(alpha), DVEC(beta), ODMAT(vl), ODMAT(vr)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac == n && br == n && bc == n && alphan == n && betan == n, BAD_SIZE);+ REQUIRES(vlp==NULL || (vlr==n && vlc==n), BAD_SIZE);+ char jobvl = vlp==NULL?'N':'V';+ REQUIRES(vrp==NULL || (vrr==n && vrc==n), BAD_SIZE);+ char jobvr = vrp==NULL?'N':'V';+ DEBUGMSG("eig_l_G");+ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ double ans;+ dggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ (double*)alphap, (double*)alphap+n, betap,+ vlp, &n, vrp, &n,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ (double*)alphap, (double*)alphap+n, betap,+ vlp, &n, vrp, &n,+ work, &lwork,+ &res);+ MARK(res,res);++ free(work);+ return ret;+}++//////////////////// generalized complex eigensystem ////////////++int zggev_(char *jobvl, char *jobvr, integer *n,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ doublecomplex *alphar, doublecomplex *beta,+ doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,+ doublecomplex *work, integer *lwork,+ doublereal *rwork, integer *info);++int eig_l_GC(OCMAT(a), OCMAT(b), CVEC(alpha), CVEC(beta), OCMAT(vl), OCMAT(vr)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac == n && br == n && bc == n && alphan == n && betan == n, BAD_SIZE);+ REQUIRES(vlp==NULL || (vlr==n && vlc==n), BAD_SIZE);+ char jobvl = vlp==NULL?'N':'V';+ REQUIRES(vrp==NULL || (vrr==n && vrc==n), BAD_SIZE);+ char jobvr = vrp==NULL?'N':'V';+ DEBUGMSG("eig_l_GC");+ double *rwork = (double*) malloc(8*n*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ alphap, betap,+ vlp, &n, vrp, &n,+ &ans, &lwork,+ rwork, &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ alphap, betap,+ vlp, &n, vrp, &n,+ work, &lwork,+ rwork, &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++//////////////////// symmetric real eigensystem ////////////++int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,+ integer *lda, doublereal *w, doublereal *work, integer *lwork,+ integer *info);++int eig_l_S(int wantV,DVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer n = sn;+ REQUIRES(vr==n && vc==n, BAD_SIZE);+ char jobz = wantV?'V':'N';+ DEBUGMSG("eig_l_S");+ integer lwork = -1;+ char uplo = 'U';+ integer res;+ // ask for optimal lwork+ double ans;+ dsyev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dsyev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ work, &lwork,+ &res);+ MARK(res,res);++ free(work);+ return ret;+}++//////////////////// hermitian complex eigensystem ////////////++int zheev_(char *jobz, char *uplo, integer *n, doublecomplex+ *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork,+ doublereal *rwork, integer *info);++int eig_l_H(int wantV,DVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer n = sn;++ REQUIRES(vr==n && vc==n, BAD_SIZE);+ char jobz = wantV?'V':'N';+ DEBUGMSG("eig_l_H");+ double *rwork = (double*) malloc((3*n-2)*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ char uplo = 'U';+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zheev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ &ans, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zheev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ work, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++//////////////////// general real linear system ////////////++int dgesv_(integer *n, integer *nrhs, doublereal *a, integer+ *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);++int linearSolveR_l(ODMAT(a),ODMAT(b)) {+ integer ret = 0;+ integer n = ar;+ integer nhrs = bc;++ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("linearSolveR_l");+ integer * ipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!ipiv,MEM);++ integer res;+ dgesv_ (&n,&nhrs,+ ap, &n,+ ipiv,+ bp, &n,+ &res);+ CONVERGED(res,SINGULAR);++ free(ipiv);+ return ret;+}++//////////////////// general complex linear system ////////////++int zgesv_(integer *n, integer *nrhs, doublecomplex *a,+ integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *+ info);++int linearSolveC_l(OCMAT(a),OCMAT(b)) {+ integer ret = 0;+ integer n = ar;+ integer nhrs = bc;++ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("linearSolveC_l");+ integer * ipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!ipiv,MEM);++ integer res;+ zgesv_ (&n,&nhrs,+ ap, &n,+ ipiv,+ bp, &n,+ &res);+ CONVERGED(res,SINGULAR);++ free(ipiv);+ return ret;+}++//////// symmetric positive definite real linear system using Cholesky ////////////++int dpotrs_(char *uplo, integer *n, integer *nrhs,+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *+ info);++int cholSolveR_l(KODMAT(a),ODMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("cholSolveR_l");+ integer res;+ dpotrs_ ("U",+ &n,&nhrs,+ (double*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// Hermitian positive definite real linear system using Cholesky ////////////++int zpotrs_(char *uplo, integer *n, integer *nrhs,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ integer *info);++int cholSolveC_l(KOCMAT(a),OCMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("cholSolveC_l");+ integer res;+ zpotrs_ ("U",+ &n,&nhrs,+ (doublecomplex*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// triangular real linear system ////////////++int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs,+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *+ info);++int triSolveR_l_u(KODMAT(a),ODMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveR_l_u");+ integer res;+ dtrtrs_ ("U",+ "N",+ "N",+ &n,&nhrs,+ (double*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++int triSolveR_l_l(KODMAT(a),ODMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveR_l_l");+ integer res;+ dtrtrs_ ("L",+ "N",+ "N",+ &n,&nhrs,+ (double*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// triangular complex linear system ////////////++int ztrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ integer *info);++int triSolveC_l_u(KOCMAT(a),OCMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveC_l_u");+ integer res;+ ztrtrs_ ("U",+ "N",+ "N",+ &n,&nhrs,+ (doublecomplex*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++int triSolveC_l_l(KOCMAT(a),OCMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveC_l_u");+ integer res;+ ztrtrs_ ("L",+ "N",+ "N",+ &n,&nhrs,+ (doublecomplex*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// tridiagonal real linear system ////////////++int dgttrf_(integer *n,+ doublereal *dl, doublereal *d, doublereal *du, doublereal *du2,+ integer *ipiv,+ integer *info);++int dgttrs_(char *trans, integer *n, integer *nrhs,+ doublereal *dl, doublereal *d, doublereal *du, doublereal *du2,+ integer *ipiv, doublereal *b, integer *ldb,+ integer *info);++int triDiagSolveR_l(DVEC(dl), DVEC(d), DVEC(du), ODMAT(b)) {+ integer ret = 0;+ integer n = dn;+ integer nhrs = bc;+ REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE);+ DEBUGMSG("triDiagSolveR_l");+ integer res;+ integer* ipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!ipiv,MEM,cleanup0);++ double* du2 = (double*)malloc((n - 2)*sizeof(double));+ UNWIND(!du2,MEM,cleanup1);++ dgttrf_ (&n,+ dlp, dp, dup, du2,+ ipiv,+ &res);+ UNWIND(res,res,cleanup2);++ dgttrs_ ("N",+ &n,&nhrs,+ dlp, dp, dup, du2,+ ipiv, bp, &n,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(du2);+cleanup1:+ free(ipiv);+cleanup0:+ return ret;+}++//////// tridiagonal complex linear system ////////////++int zgttrf_(integer *n,+ doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2,+ integer *ipiv,+ integer *info);++int zgttrs_(char *trans, integer *n, integer *nrhs,+ doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2,+ integer *ipiv, doublecomplex *b, integer *ldb,+ integer *info);++int triDiagSolveC_l(CVEC(dl), CVEC(d), CVEC(du), OCMAT(b)) {+ integer ret = 0;+ integer n = dn;+ integer nhrs = bc;+ REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE);+ DEBUGMSG("triDiagSolveC_l");+ integer res;+ integer* ipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!ipiv,MEM,cleanup0);++ doublecomplex* du2 = (doublecomplex*)malloc((n - 2)*sizeof(doublecomplex));+ UNWIND(!du2,MEM,cleanup1);++ zgttrf_ (&n,+ dlp, dp, dup, du2,+ ipiv,+ &res);+ UNWIND(res,res,cleanup2);++ zgttrs_ ("N",+ &n,&nhrs,+ dlp, dp, dup, du2,+ ipiv, bp, &n,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(du2);+cleanup1:+ free(ipiv);+cleanup0:+ return ret;+}++//////////////////// least squares real linear system ////////////++int dgels_(char *trans, integer *m, integer *n, integer *+ nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb,+ doublereal *work, integer *lwork, integer *info);++int linearSolveLSR_l(ODMAT(a),ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveLSR_l");+ integer res;+ integer lwork = -1;+ double ans;+ dgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ &ans,&lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ work,&lwork,+ &res);+ CONVERGED(res,SINGULAR);++ free(work);+ return ret;+}++//////////////////// least squares complex linear system ////////////++int zgels_(char *trans, integer *m, integer *n, integer *+ nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ doublecomplex *work, integer *lwork, integer *info);++int linearSolveLSC_l(OCMAT(a),OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveLSC_l");+ integer res;+ integer lwork = -1;+ doublecomplex ans;+ zgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ &ans,&lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ CHECK(!work,MEM);++ zgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ work,&lwork,+ &res);+ CONVERGED(res,SINGULAR);++ free(work);+ return ret;+}++//////////////////// least squares real linear system using SVD ////////////++int dgelss_(integer *m, integer *n, integer *nrhs,+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *+ s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,+ integer *info);++int linearSolveSVDR_l(double rcond,ODMAT(a),ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveSVDR_l");++ double * S = (double*)malloc(MIN(m,n)*sizeof(double));+ UNWIND(!S,MEM,cleanup0);++ integer res;+ integer lwork = -1;+ integer rank;+ double ans;+ dgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ &ans,&lwork,+ &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ UNWIND(!work,MEM,cleanup1);++ dgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ work,&lwork,+ &res);++ CONVERGED(res,NOCONVER);++ free(work);+cleanup1:+ free(S);+cleanup0:+ return ret;++}++//////////////////// least squares complex linear system using SVD ////////////++int zgelss_(integer *m, integer *n, integer *nhrs,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s,+ doublereal *rcond, integer* rank,+ doublecomplex *work, integer* lwork, doublereal* rwork,+ integer *info);++int linearSolveSVDC_l(double rcond, OCMAT(a),OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveSVDC_l");++ double*S = (double*)malloc(MIN(m,n)*sizeof(double));+ UNWIND(!S,MEM,cleanup0);++ double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double));+ UNWIND(!S,MEM,cleanup1);++ integer res;+ integer lwork = -1;+ integer rank;+ doublecomplex ans;+ zgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ &ans,&lwork,+ RWORK,+ &res);+ UNWIND(res,res,cleanup2);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup2);++ zgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ work,&lwork,+ RWORK,+ &res);+ CONVERGED(res,NOCONVER);++ free(work);+cleanup2:+ free(RWORK);+cleanup1:+ free(S);+cleanup0:+ return ret;++}++//////////////////// Cholesky factorization /////////////////////////++int zpotrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info);++int chol_l_H(OCMAT(l)) {+ integer n = lr;+ REQUIRES(n>=1 && lc == n,BAD_SIZE);+ DEBUGMSG("chol_l_H");+ char uplo = 'U';+ integer res;+ zpotrf_ (&uplo,&n,lp,&n,&res);+ CHECK(res>0,NODEFPOS);+ CHECK(res,res);+ doublecomplex zero = {0.,0.};+ int r,c;+ for (r=0; r<lr; r++) {+ for(c=0; c<r; c++) {+ AT(l,r,c) = zero;+ }+ }+ OK+}+++int dpotrf_(char *uplo, integer *n, doublereal *a, integer * lda, integer *info);++int chol_l_S(ODMAT(l)) {+ integer n = lr;+ REQUIRES(n>=1 && lc == n,BAD_SIZE);+ DEBUGMSG("chol_l_S");+ char uplo = 'U';+ integer res;+ dpotrf_ (&uplo,&n,lp,&n,&res);+ CHECK(res>0,NODEFPOS);+ CHECK(res,res);+ int r,c;+ for (r=0; r<lr; r++) {+ for(c=0; c<r; c++) {+ AT(l,r,c) = 0.;+ }+ }+ OK+}++//////////////////// QR factorization /////////////////////////++int dgeqr2_(integer *m, integer *n, doublereal *a, integer *+ lda, doublereal *tau, doublereal *work, integer *info);++int qr_l_R(DVEC(tau), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n >=1 && taun == mn, BAD_SIZE);+ DEBUGMSG("qr_l_R");+ double *WORK = (double*)malloc(n*sizeof(double));+ CHECK(!WORK,MEM);++ integer res;+ dgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++int zgeqr2_(integer *m, integer *n, doublecomplex *a,+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);++int qr_l_C(CVEC(tau), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n >=1 && taun == mn, BAD_SIZE);+ DEBUGMSG("qr_l_C");++ doublecomplex *WORK = (doublecomplex*)malloc(n*sizeof(doublecomplex));+ CHECK(!WORK,MEM);++ integer res;+ zgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++int dorgqr_(integer *m, integer *n, integer *k, doublereal *+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,+ integer *info);++int c_dorgqr(KDVEC(tau), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = MIN(rc,rr);+ integer k = taun;+ DEBUGMSG("c_dorgqr");+ integer lwork = 8*n; // FIXME+ double *WORK = (double*)malloc(lwork*sizeof(double));+ CHECK(!WORK,MEM);++ integer res;+ dorgqr_ (&m,&n,&k,rp,&m,(double*)taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++int zungqr_(integer *m, integer *n, integer *k,+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *+ work, integer *lwork, integer *info);++int c_zungqr(KCVEC(tau), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = MIN(rc,rr);+ integer k = taun;+ DEBUGMSG("z_ungqr");+ integer lwork = 8*n; // FIXME+ doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ CHECK(!WORK,MEM);++ integer res;+ zungqr_ (&m,&n,&k,rp,&m,(doublecomplex*)taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}+++//////////////////// Hessenberg factorization /////////////////////////++int dgehrd_(integer *n, integer *ilo, integer *ihi,+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,+ integer *lwork, integer *info);++int hess_l_R(DVEC(tau), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE);+ DEBUGMSG("hess_l_R");+ integer lwork = 5*n; // FIXME+ double *WORK = (double*)malloc(lwork*sizeof(double));+ CHECK(!WORK,MEM);++ integer res;+ integer one = 1;+ dgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}+++int zgehrd_(integer *n, integer *ilo, integer *ihi,+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *+ work, integer *lwork, integer *info);++int hess_l_C(CVEC(tau), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE);+ DEBUGMSG("hess_l_C");+ integer lwork = 5*n; // FIXME+ doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ CHECK(!WORK,MEM);++ integer res;+ integer one = 1;+ zgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++//////////////////// Schur factorization /////////////////////////++int dgees_(char *jobvs, char *sort, L_fp select, integer *n,+ doublereal *a, integer *lda, integer *sdim, doublereal *wr,+ doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,+ integer *lwork, logical *bwork, integer *info);++int schur_l_R(ODMAT(u), ODMAT(s)) {+ integer ret = 0;+ integer m = sr;+ integer n = sc;+ REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE);+ DEBUGMSG("schur_l_R");+ integer lwork = 6*n; // FIXME+ double *WORK = (double*)malloc(lwork*sizeof(double));+ UNWIND(!WORK,MEM,cleanup0);+ double *WR = (double*)malloc(n*sizeof(double));+ UNWIND(!WORK,MEM,cleanup1);+ double *WI = (double*)malloc(n*sizeof(double));+ UNWIND(!WORK,MEM,cleanup2);+ // WR and WI not really required in this call+ logical *BWORK = (logical*)malloc(n*sizeof(logical));+ UNWIND(!BWORK,MEM,cleanup3);+ integer res;+ integer sdim;+ dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res);+ CONVERGED(res,NOCONVER);++ free(BWORK);+cleanup3:+ free(WI);+cleanup2:+ free(WR);+cleanup1:+ free(WORK);+cleanup0:+ return ret;+}+++int zgees_(char *jobvs, char *sort, L_fp select, integer *n,+ doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w,+ doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,+ doublereal *rwork, logical *bwork, integer *info);++int schur_l_C(OCMAT(u), OCMAT(s)) {+ integer ret = 0;+ integer m = sr;+ integer n = sc;+ REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE);+ DEBUGMSG("schur_l_C");+ integer lwork = 6*n; // FIXME+ doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!WORK,MEM,cleanup0);++ doublecomplex *W = (doublecomplex*)malloc(n*sizeof(doublecomplex));+ UNWIND(!W,MEM,cleanup1);++ // W not really required in this call+ logical *BWORK = (logical*)malloc(n*sizeof(logical));+ UNWIND(!BWORK,MEM,cleanup2);++ double *RWORK = (double*)malloc(n*sizeof(double));+ UNWIND(!RWORK,MEM,cleanup3);+ integer res;+ integer sdim;+ zgees_ ("V","N",NULL,&n,sp,&n,&sdim,W,+ up,&n,+ WORK,&lwork,RWORK,BWORK,&res);+ CONVERGED(res,NOCONVER);++ free(RWORK);+cleanup3:+ free(BWORK);+cleanup2:+ free(W);+cleanup1:+ free(WORK);+cleanup0:+ return ret;+}++//////////////////// LU factorization /////////////////////////++int dgetrf_(integer *m, integer *n, doublereal *a, integer *+ lda, integer *ipiv, integer *info);++int lu_l_R(DVEC(ipiv), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);+ DEBUGMSG("lu_l_R");+ integer* auxipiv = (integer*)malloc(mn*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ dgetrf_ (&m,&n,rp,&m,auxipiv,&res);+ if(res>0) {+ res = 0; // FIXME+ }+ UNWIND(res,res,cleanup1);++ for (int k=0; k<mn; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup1:+ free(auxipiv);+cleanup0:+ return ret;+}+++int zgetrf_(integer *m, integer *n, doublecomplex *a,+ integer *lda, integer *ipiv, integer *info);++int lu_l_C(DVEC(ipiv), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);++ REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);+ DEBUGMSG("lu_l_C");+ integer* auxipiv = (integer*)malloc(mn*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ zgetrf_ (&m,&n,rp,&m,auxipiv,&res);+ if(res>0) {+ res = 0; // FIXME+ }+ UNWIND(res,res,cleanup1);++ for (int k=0; k<mn; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup1:+ free(auxipiv);+cleanup0:+ return ret;+}+++//////////////////// LU substitution /////////////////////////++int dgetrs_(char *trans, integer *n, integer *nrhs,+ doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *+ ldb, integer *info);++int luS_l_R(KODMAT(a), KDVEC(ipiv), ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ dgetrs_ ("N",&n,&nrhs,(/*no const (!?)*/ double*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++int zgetrs_(char *trans, integer *n, integer *nrhs,+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,+ integer *ldb, integer *info);++int luS_l_C(KOCMAT(a), KDVEC(ipiv), OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ zgetrs_ ("N",&n,&nrhs,(doublecomplex*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++//////////////////// LDL factorization /////////////////////////++int dsytrf_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv,+ doublereal *work, integer *lwork, integer *info);++int ldl_R(DVEC(ipiv), ODMAT(r)) {+ integer ret = 0;+ integer n = rr;++ REQUIRES(n>=1 && rc==n && ipivn == n, BAD_SIZE);+ DEBUGMSG("ldl_R");++ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ integer lda = rXc;+ integer lwork = -1;+ doublereal ans;+ dsytrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res);+ lwork = ceil(ans);+ doublereal* work = (doublereal*)malloc(lwork*sizeof(doublereal));+ UNWIND(!work,MEM,cleanup1);++ dsytrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res);+ UNWIND(res,res,cleanup2);++ int k;+ for (k=0; k<n; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup2:+ free(work);+cleanup1:+ free(auxipiv);+cleanup0:+ return ret;+}+++int zhetrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv,+ doublecomplex *work, integer *lwork, integer *info);++int ldl_C(DVEC(ipiv), OCMAT(r)) {+ integer ret = 0;+ integer n = rr;++ REQUIRES(n>=1 && rc==n && ipivn == n, BAD_SIZE);+ DEBUGMSG("ldl_R");+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ integer lda = rXc;+ integer lwork = -1;+ doublecomplex ans;+ zhetrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res);+ lwork = ceil(ans.r);+ doublecomplex* work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zhetrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res);+ UNWIND(res,res,cleanup2);+ int k;+ for (k=0; k<n; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup2:+ free(work);+cleanup1:+ free(auxipiv);+cleanup0:+ return ret;++}++//////////////////// LDL solve /////////////////////////++int dsytrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda,+ integer *ipiv, doublereal *b, integer *ldb, integer *info);++int ldl_S_R(KODMAT(a), KDVEC(ipiv), ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ dsytrs_ ("L",&n,&nrhs,(/*no const (!?)*/ double*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++int zhetrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda,+ integer *ipiv, doublecomplex *b, integer *ldb, integer *info);++int ldl_S_C(KOCMAT(a), KDVEC(ipiv), OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ zhetrs_ ("L",&n,&nrhs,(doublecomplex*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++//////////////////// Matrix Product /////////////////////////++void dgemm_(char *, char *, integer *, integer *, integer *,+ double *, const double *, integer *, const double *,+ integer *, double *, double *, integer *);++int multiplyR(int ta, int tb, KODMAT(a),KODMAT(b),ODMAT(r)) {+ DEBUGMSG("dgemm_");+ CHECKNANR(a,"NaN multR Input\n")+ CHECKNANR(b,"NaN multR Input\n")+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ double alpha = 1;+ double beta = 0;+ dgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);+ CHECKNANR(r,"NaN multR Output\n")+ OK+}++void zgemm_(char *, char *, integer *, integer *, integer *,+ doublecomplex *, const doublecomplex *, integer *, const doublecomplex *,+ integer *, doublecomplex *, doublecomplex *, integer *);++int multiplyC(int ta, int tb, KOCMAT(a),KOCMAT(b),OCMAT(r)) {+ DEBUGMSG("zgemm_");+ CHECKNANC(a,"NaN multC Input\n")+ CHECKNANC(b,"NaN multC Input\n")+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ doublecomplex alpha = {1,0};+ doublecomplex beta = {0,0};+ zgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,+ ap,&lda,+ bp,&ldb,&beta,+ rp,&ldc);+ CHECKNANC(r,"NaN multC Output\n")+ OK+}++void sgemm_(char *, char *, integer *, integer *, integer *,+ float *, const float *, integer *, const float *,+ integer *, float *, float *, integer *);++int multiplyF(int ta, int tb, KOFMAT(a),KOFMAT(b),OFMAT(r)) {+ DEBUGMSG("sgemm_");+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ float alpha = 1;+ float beta = 0;+ sgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);+ OK+}++void cgemm_(char *, char *, integer *, integer *, integer *,+ complex *, const complex *, integer *, const complex *,+ integer *, complex *, complex *, integer *);++int multiplyQ(int ta, int tb, KOQMAT(a),KOQMAT(b),OQMAT(r)) {+ DEBUGMSG("cgemm_");+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ complex alpha = {1,0};+ complex beta = {0,0};+ cgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,+ ap,&lda,+ bp,&ldb,&beta,+ rp,&ldc);+ OK+}+++#define MULT_IMP_VER(OP) \+ { TRAV(r,i,j) { \+ int k; \+ AT(r,i,j) = 0; \+ for (k=0;k<ac;k++) { \+ OP \+ } \+ } \+ }++#define MULT_IMP(M) { \+ if (m==1) { \+ MULT_IMP_VER( AT(r,i,j) += AT(a,i,k) * AT(b,k,j); ) \+ } else { \+ MULT_IMP_VER( AT(r,i,j) = M(AT(r,i,j) + M(AT(a,i,k) * AT(b,k,j), m) , m) ; ) \+ } OK }++int multiplyI(int m, KOIMAT(a), KOIMAT(b), OIMAT(r)) MULT_IMP(mod)+int multiplyL(int64_t m, KOLMAT(a), KOLMAT(b), OLMAT(r)) MULT_IMP(mod_l)++/////////////////////////////// inplace row ops ////////////////////////////////++#define AXPY_IMP { \+ int j; \+ for(j=j1; j<=j2; j++) { \+ AT(r,i2,j) += a*AT(r,i1,j); \+ } OK }++#define AXPY_MOD_IMP(M) { \+ int j; \+ for(j=j1; j<=j2; j++) { \+ AT(r,i2,j) = M(AT(r,i2,j) + M(a*AT(r,i1,j), m) , m); \+ } OK }+++#define SCAL_IMP { \+ int i,j; \+ for(i=i1; i<=i2; i++) { \+ for(j=j1; j<=j2; j++) { \+ AT(r,i,j) = a*AT(r,i,j); \+ } \+ } OK }++#define SCAL_MOD_IMP(M) { \+ int i,j; \+ for(i=i1; i<=i2; i++) { \+ for(j=j1; j<=j2; j++) { \+ AT(r,i,j) = M(a*AT(r,i,j) , m); \+ } \+ } OK }+++#define SWAP_IMP(T) { \+ T aux; \+ int k; \+ if (i1 != i2) { \+ for (k=j1; k<=j2; k++) { \+ aux = AT(r,i1,k); \+ AT(r,i1,k) = AT(r,i2,k); \+ AT(r,i2,k) = aux; \+ } \+ } OK }+++#define ROWOP_IMP(T) { \+ T a = *pa; \+ switch(code) { \+ case 0: AXPY_IMP \+ case 1: SCAL_IMP \+ case 2: SWAP_IMP(T) \+ default: ERROR(BAD_CODE); \+ } \+}++#define ROWOP_MOD_IMP(T,M) { \+ T a = *pa; \+ switch(code) { \+ case 0: AXPY_MOD_IMP(M) \+ case 1: SCAL_MOD_IMP(M) \+ case 2: SWAP_IMP(T) \+ default: ERROR(BAD_CODE); \+ } \+}+++#define ROWOP(T) int rowop_##T(int code, T* pa, int i1, int i2, int j1, int j2, MATG(T,r)) ROWOP_IMP(T)++#define ROWOP_MOD(T,M) int rowop_mod_##T(T m, int code, T* pa, int i1, int i2, int j1, int j2, MATG(T,r)) ROWOP_MOD_IMP(T,M)++ROWOP(double)+ROWOP(float)+ROWOP(TCD)+ROWOP(TCF)+ROWOP(int32_t)+ROWOP(int64_t)+ROWOP_MOD(int32_t,mod)+ROWOP_MOD(int64_t,mod_l)++/////////////////////////////// inplace GEMM ////////////////////////////////++#define GEMM(T) int gemm_##T(VECG(T,c),MATG(T,a),MATG(T,b),MATG(T,r)) { \+ T a = cp[0], b = cp[1]; \+ T t; \+ int k; \+ { TRAV(r,i,j) { \+ t = 0; \+ for(k=0; k<ac; k++) { \+ t += AT(a,i,k) * AT(b,k,j); \+ } \+ AT(r,i,j) = b*AT(r,i,j) + a*t; \+ } \+ } OK }+++GEMM(double)+GEMM(float)+GEMM(TCD)+GEMM(TCF)+GEMM(int32_t)+GEMM(int64_t)++#define GEMM_MOD(T,M) int gemm_mod_##T(T m, VECG(T,c),MATG(T,a),MATG(T,b),MATG(T,r)) { \+ T a = cp[0], b = cp[1]; \+ int k; \+ T t; \+ { TRAV(r,i,j) { \+ t = 0; \+ for(k=0; k<ac; k++) { \+ t = M(t+M(AT(a,i,k) * AT(b,k,j))); \+ } \+ AT(r,i,j) = M(M(b*AT(r,i,j)) + M(a*t)); \+ } \+ } OK }+++#define MOD32(X) mod(X,m)+#define MOD64(X) mod_l(X,m)++GEMM_MOD(int32_t,MOD32)+GEMM_MOD(int64_t,MOD64)++////////////////// sparse matrix-product ///////////////////////////////////////+++int smXv(KDVEC(vals),KIVEC(cols),KIVEC(rows),KDVEC(x),DVEC(r)) {+ int r, c;+ for (r = 0; r < rowsn - 1; r++) {+ rp[r] = 0;+ for (c = rowsp[r]; c < rowsp[r+1]; c++) {+ rp[r] += valsp[c-1] * xp[colsp[c-1]-1];+ }+ }+ OK+}++int smTXv(KDVEC(vals),KIVEC(cols),KIVEC(rows),KDVEC(x),DVEC(r)) {+ int r,c;+ for (c = 0; c < rn; c++) {+ rp[c] = 0;+ }+ for (r = 0; r < rowsn - 1; r++) {+ for (c = rowsp[r]; c < rowsp[r+1]; c++) {+ rp[colsp[c-1]-1] += valsp[c-1] * xp[r];+ }+ }+ OK+}+++//////////////////////// extract /////////////////////////////////++#define EXTRACT_IMP { \+ int i,j,si,sj,ni,nj; \+ ni = modei ? in : ip[1]-ip[0]+1; \+ nj = modej ? jn : jp[1]-jp[0]+1; \+ \+ for (i=0; i<ni; i++) { \+ si = modei ? ip[i] : i+ip[0]; \+ \+ for (j=0; j<nj; j++) { \+ sj = modej ? jp[j] : j+jp[0]; \+ \+ AT(r,i,j) = AT(m,si,sj); \+ } \+ } OK }++#define EXTRACT(T) int extract##T(int modei, int modej, KIVEC(i), KIVEC(j), KO##T##MAT(m), O##T##MAT(r)) EXTRACT_IMP++EXTRACT(D)+EXTRACT(F)+EXTRACT(C)+EXTRACT(Q)+EXTRACT(I)+EXTRACT(L)++//////////////////////// setRect /////////////////////////////////++#define SETRECT(T) \+int setRect##T(int i, int j, KO##T##MAT(m), O##T##MAT(r)) { \+ { TRAV(m,a,b) { \+ int x = a+i, y = b+j; \+ if(x>=0 && x<rr && y>=0 && y<rc) { \+ AT(r,x,y) = AT(m,a,b); \+ } \+ } \+ } OK }++SETRECT(D)+SETRECT(F)+SETRECT(C)+SETRECT(Q)+SETRECT(I)+SETRECT(L)++//////////////////////// remap /////////////////////////////////++#define REMAP_IMP \+ REQUIRES(ir==jr && ic==jc && ir==rr && ic==rc ,BAD_SIZE); \+ { TRAV(r,a,b) { AT(r,a,b) = AT(m,AT(i,a,b),AT(j,a,b)); } \+ } \+ OK++int remapD(KOIMAT(i), KOIMAT(j), KODMAT(m), ODMAT(r)) {+ REMAP_IMP+}++int remapF(KOIMAT(i), KOIMAT(j), KOFMAT(m), OFMAT(r)) {+ REMAP_IMP+}++int remapI(KOIMAT(i), KOIMAT(j), KOIMAT(m), OIMAT(r)) {+ REMAP_IMP+}++int remapL(KOIMAT(i), KOIMAT(j), KOLMAT(m), OLMAT(r)) {+ REMAP_IMP+}++int remapC(KOIMAT(i), KOIMAT(j), KOCMAT(m), OCMAT(r)) {+ REMAP_IMP+}++int remapQ(KOIMAT(i), KOIMAT(j), KOQMAT(m), OQMAT(r)) {+ REMAP_IMP+}++////////////////////////////////////////////////////////////////////////////////++int saveMatrix(char * file, char * format, KODMAT(a)){+ FILE * fp;+ fp = fopen (file, "w");+ int r, c;+ for (r=0;r<ar; r++) {+ for (c=0; c<ac; c++) {+ fprintf(fp,format,AT(a,r,c));+ if (c<ac-1) {+ fprintf(fp," ");+ } else {+ fprintf(fp,"\n");+ }+ }+ }+ fclose(fp);+ OK+}+
+ src/Internal/C/lapack-aux.h view
@@ -0,0 +1,111 @@+/*+ * We have copied the definitions in f2c.h required+ * to compile clapack.h, modified to support both+ * 32 and 64 bit++ http://opengrok.creo.hu/dragonfly/xref/src/contrib/gcc-3.4/libf2c/readme.netlib+ http://www.ibm.com/developerworks/library/l-port64.html+ */++#ifdef _LP64+typedef int integer;+typedef unsigned int uinteger;+typedef int logical;+typedef long longint; /* system-dependent */+typedef unsigned long ulongint; /* system-dependent */+#else+typedef long int integer;+typedef unsigned long int uinteger;+typedef long int logical;+typedef long long longint; /* system-dependent */+typedef unsigned long long ulongint; /* system-dependent */+#endif++typedef char *address;+typedef short int shortint;+typedef float real;+typedef double doublereal;+typedef struct { real r, i; } complex;+typedef struct { doublereal r, i; } doublecomplex;+typedef short int shortlogical;+typedef char logical1;+typedef char integer1;++typedef logical (*L_fp)();+typedef short ftnlen;++/********************************************************/++#define IVEC(A) int A##n, int*A##p+#define LVEC(A) int A##n, int64_t*A##p+#define FVEC(A) int A##n, float*A##p+#define DVEC(A) int A##n, double*A##p+#define QVEC(A) int A##n, complex*A##p+#define CVEC(A) int A##n, doublecomplex*A##p+#define PVEC(A) int A##n, void* A##p, int A##s++#define IMAT(A) int A##r, int A##c, int* A##p+#define LMAT(A) int A##r, int A##c, int64_t* A##p+#define FMAT(A) int A##r, int A##c, float* A##p+#define DMAT(A) int A##r, int A##c, double* A##p+#define QMAT(A) int A##r, int A##c, complex* A##p+#define CMAT(A) int A##r, int A##c, doublecomplex* A##p+#define PMAT(A) int A##r, int A##c, void* A##p, int A##s++#define KIVEC(A) int A##n, const int*A##p+#define KLVEC(A) int A##n, const int64_t*A##p+#define KFVEC(A) int A##n, const float*A##p+#define KDVEC(A) int A##n, const double*A##p+#define KQVEC(A) int A##n, const complex*A##p+#define KCVEC(A) int A##n, const doublecomplex*A##p+#define KPVEC(A) int A##n, const void* A##p, int A##s++#define KIMAT(A) int A##r, int A##c, const int* A##p+#define KLMAT(A) int A##r, int A##c, const int64_t* A##p+#define KFMAT(A) int A##r, int A##c, const float* A##p+#define KDMAT(A) int A##r, int A##c, const double* A##p+#define KQMAT(A) int A##r, int A##c, const complex* A##p+#define KCMAT(A) int A##r, int A##c, const doublecomplex* A##p+#define KPMAT(A) int A##r, int A##c, const void* A##p, int A##s++#define VECG(T,A) int A##n, T* A##p+#define MATG(T,A) int A##r, int A##c, int A##Xr, int A##Xc, T* A##p++#define OIMAT(A) MATG(int,A)+#define OLMAT(A) MATG(int64_t,A)+#define OFMAT(A) MATG(float,A)+#define ODMAT(A) MATG(double,A)+#define OQMAT(A) MATG(complex,A)+#define OCMAT(A) MATG(doublecomplex,A)++#define KOIMAT(A) MATG(const int,A)+#define KOLMAT(A) MATG(const int64_t,A)+#define KOFMAT(A) MATG(const float,A)+#define KODMAT(A) MATG(const double,A)+#define KOQMAT(A) MATG(const complex,A)+#define KOCMAT(A) MATG(const doublecomplex,A)++#define AT(m,i,j) (m##p[(i)*m##Xr + (j)*m##Xc])+#define TRAV(m,i,j) int i,j; for (i=0;i<m##r;i++) for (j=0;j<m##c;j++)++/********************************************************/++static inline+int mod (int a, int b) {+ int m = a % b;+ if (b>0) {+ return m >=0 ? m : m+b;+ } else {+ return m <=0 ? m : m+b;+ }+}++static inline+int64_t mod_l (int64_t a, int64_t b) {+ int64_t m = a % b;+ if (b>0) {+ return m >=0 ? m : m+b;+ } else {+ return m <=0 ? m : m+b;+ }+}
+ src/Internal/C/vector-aux.c view
@@ -0,0 +1,1599 @@+#include <complex.h>+#include <inttypes.h>++typedef double complex TCD;+typedef float complex TCF;++#undef complex++#include "lapack-aux.h"++#define V(x) x##n,x##p++#include <string.h>+#include <math.h>+#include <stdio.h>+#include <stdlib.h>+#include <stdint.h>++#define MACRO(B) do {B} while (0)+#define ERROR(CODE) MACRO(return CODE;)+#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})+#define OK return 0;++#define MIN(A,B) ((A)<(B)?(A):(B))+#define MAX(A,B) ((A)>(B)?(A):(B))++#ifdef DBG+#define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M);+#else+#define DEBUGMSG(M)+#endif++#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)++#define BAD_SIZE 2000+#define BAD_CODE 2001+#define MEM 2002+#define BAD_FILE 2003+++int sumF(KFVEC(x),FVEC(r)) {+ DEBUGMSG("sumF");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ float res = 0;+ for (i = 0; i < xn; i++) res += xp[i];+ rp[0] = res;+ OK+}++int sumR(KDVEC(x),DVEC(r)) {+ DEBUGMSG("sumR");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ double res = 0;+ for (i = 0; i < xn; i++) res += xp[i];+ rp[0] = res;+ OK+}++int sumI(int m, KIVEC(x),IVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 0;+ if (m==1) {+ for (i = 0; i < xn; i++) res += xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res + xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int sumL(int64_t m, KLVEC(x),LVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 0;+ if (m==1) {+ for (i = 0; i < xn; i++) res += xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res + xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int sumQ(KQVEC(x),QVEC(r)) {+ DEBUGMSG("sumQ");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ complex res;+ res.r = 0;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ res.r += xp[i].r;+ res.i += xp[i].i;+ }+ rp[0] = res;+ OK+}++int sumC(KCVEC(x),CVEC(r)) {+ DEBUGMSG("sumC");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ doublecomplex res;+ res.r = 0;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ res.r += xp[i].r;+ res.i += xp[i].i;+ }+ rp[0] = res;+ OK+}+++int prodF(KFVEC(x),FVEC(r)) {+ DEBUGMSG("prodF");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ float res = 1;+ for (i = 0; i < xn; i++) res *= xp[i];+ rp[0] = res;+ OK+}++int prodR(KDVEC(x),DVEC(r)) {+ DEBUGMSG("prodR");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ double res = 1;+ for (i = 0; i < xn; i++) res *= xp[i];+ rp[0] = res;+ OK+}++int prodI(int m, KIVEC(x),IVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 1;+ if (m==1) {+ for (i = 0; i < xn; i++) res *= xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res * xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int prodL(int64_t m, KLVEC(x),LVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 1;+ if (m==1) {+ for (i = 0; i < xn; i++) res *= xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res * xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int prodQ(KQVEC(x),QVEC(r)) {+ DEBUGMSG("prodQ");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ complex res;+ float temp;+ res.r = 1;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ temp = res.r * xp[i].r - res.i * xp[i].i;+ res.i = res.r * xp[i].i + res.i * xp[i].r;+ res.r = temp;+ }+ rp[0] = res;+ OK+}++int prodC(KCVEC(x),CVEC(r)) {+ DEBUGMSG("prodC");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ doublecomplex res;+ double temp;+ res.r = 1;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ temp = res.r * xp[i].r - res.i * xp[i].i;+ res.i = res.r * xp[i].i + res.i * xp[i].r;+ res.r = temp;+ }+ rp[0] = res;+ OK+}+++double dnrm2_(integer*, const double*, integer*);+double dasum_(integer*, const double*, integer*);++double vector_max(KDVEC(x)) {+ double r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++double vector_min(KDVEC(x)) {+ double r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index(KDVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index(KDVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}++int toScalarR(int code, KDVEC(x), DVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarR");+ double res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = dnrm2_(&n,xp,&one); break; }+ case 1: { res = dasum_(&n,xp,&one); break; }+ case 2: { res = vector_max_index(V(x)); break; }+ case 3: { res = vector_max(V(x)); break; }+ case 4: { res = vector_min_index(V(x)); break; }+ case 5: { res = vector_min(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++float snrm2_(integer*, const float*, integer*);+float sasum_(integer*, const float*, integer*);++float vector_max_f(KFVEC(x)) {+ float r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++float vector_min_f(KFVEC(x)) {+ float r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index_f(KFVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index_f(KFVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}+++int toScalarF(int code, KFVEC(x), FVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarF");+ float res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = snrm2_(&n,xp,&one); break; }+ case 1: { res = sasum_(&n,xp,&one); break; }+ case 2: { res = vector_max_index_f(V(x)); break; }+ case 3: { res = vector_max_f(V(x)); break; }+ case 4: { res = vector_min_index_f(V(x)); break; }+ case 5: { res = vector_min_f(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}++int vector_max_i(KIVEC(x)) {+ int r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_min_i(KIVEC(x)) {+ int r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index_i(KIVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index_i(KIVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}+++int toScalarI(int code, KIVEC(x), IVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int res;+ switch(code) {+ case 2: { res = vector_max_index_i(V(x)); break; }+ case 3: { res = vector_max_i(V(x)); break; }+ case 4: { res = vector_min_index_i(V(x)); break; }+ case 5: { res = vector_min_i(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++int64_t vector_max_l(KLVEC(x)) {+ int64_t r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++int64_t vector_min_l(KLVEC(x)) {+ int64_t r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index_l(KLVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index_l(KLVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}+++int toScalarL(int code, KLVEC(x), LVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int64_t res;+ switch(code) {+ case 2: { res = vector_max_index_l(V(x)); break; }+ case 3: { res = vector_max_l(V(x)); break; }+ case 4: { res = vector_min_index_l(V(x)); break; }+ case 5: { res = vector_min_l(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++double dznrm2_(integer*, const doublecomplex*, integer*);+double dzasum_(integer*, const doublecomplex*, integer*);++int toScalarC(int code, KCVEC(x), DVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarC");+ double res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = dznrm2_(&n,xp,&one); break; }+ case 1: { res = dzasum_(&n,xp,&one); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++double scnrm2_(integer*, const complex*, integer*);+double scasum_(integer*, const complex*, integer*);++int toScalarQ(int code, KQVEC(x), FVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarQ");+ float res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = scnrm2_(&n,xp,&one); break; }+ case 1: { res = scasum_(&n,xp,&one); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++inline double sign(double x) {+ if(x>0) {+ return +1.0;+ } else if (x<0) {+ return -1.0;+ } else {+ return 0.0;+ }+}++inline float float_sign(float x) {+ if(x>0) {+ return +1.0;+ } else if (x<0) {+ return -1.0;+ } else {+ return 0.0;+ }+}+++#define OP(C,F) case C: { for(k=0;k<xn;k++) rp[k] = F(xp[k]); OK }+#define OPV(C,E) case C: { for(k=0;k<xn;k++) rp[k] = E; OK }+int mapR(int code, KDVEC(x), DVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapR");+ switch (code) {+ OP(0,sin)+ OP(1,cos)+ OP(2,tan)+ OP(3,fabs)+ OP(4,asin)+ OP(5,acos)+ OP(6,atan)+ OP(7,sinh)+ OP(8,cosh)+ OP(9,tanh)+ OP(10,asinh)+ OP(11,acosh)+ OP(12,atanh)+ OP(13,exp)+ OP(14,log)+ OP(15,sign)+ OP(16,sqrt)+ default: ERROR(BAD_CODE);+ }+}++int mapF(int code, KFVEC(x), FVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapF");+ switch (code) {+ OP(0,sin)+ OP(1,cos)+ OP(2,tan)+ OP(3,fabs)+ OP(4,asin)+ OP(5,acos)+ OP(6,atan)+ OP(7,sinh)+ OP(8,cosh)+ OP(9,tanh)+ OP(10,asinh)+ OP(11,acosh)+ OP(12,atanh)+ OP(13,exp)+ OP(14,log)+ OP(15,sign)+ OP(16,sqrt)+ default: ERROR(BAD_CODE);+ }+}+++int mapI(int code, KIVEC(x), IVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ switch (code) {+ OP(3,abs)+ OP(15,sign)+ default: ERROR(BAD_CODE);+ }+}+++int mapL(int code, KLVEC(x), LVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ switch (code) {+ OP(3,abs)+ OP(15,sign)+ default: ERROR(BAD_CODE);+ }+}++++inline double abs_complex(doublecomplex z) {+ return sqrt(z.r*z.r + z.i*z.i);+}++inline doublecomplex complex_abs_complex(doublecomplex z) {+ doublecomplex r;+ r.r = abs_complex(z);+ r.i = 0;+ return r;+}++inline doublecomplex complex_signum_complex(doublecomplex z) {+ doublecomplex r;+ double mag;+ if (z.r == 0 && z.i == 0) {+ r.r = 0;+ r.i = 0;+ } else {+ mag = abs_complex(z);+ r.r = z.r/mag;+ r.i = z.i/mag;+ }+ return r;+}++#define OPb(C,F) case C: { for(k=0;k<xn;k++) r2p[k] = F(x2p[k]); OK }+int mapC(int code, KCVEC(x), CVEC(r)) {+ TCD* x2p = (TCD*)xp;+ TCD* r2p = (TCD*)rp;+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapC");+ switch (code) {+ OPb(0,csin)+ OPb(1,ccos)+ OPb(2,ctan)+ OP(3,complex_abs_complex)+ OPb(4,casin)+ OPb(5,cacos)+ OPb(6,catan)+ OPb(7,csinh)+ OPb(8,ccosh)+ OPb(9,ctanh)+ OPb(10,casinh)+ OPb(11,cacosh)+ OPb(12,catanh)+ OPb(13,cexp)+ OPb(14,clog)+ OP(15,complex_signum_complex)+ OPb(16,csqrt)+ default: ERROR(BAD_CODE);+ }+}++++inline complex complex_f_math_fun(doublecomplex (*cf)(doublecomplex), complex a)+{+ doublecomplex c;+ doublecomplex r;++ complex float_r;++ c.r = a.r;+ c.i = a.i;++ r = (*cf)(c);++ float_r.r = r.r;+ float_r.i = r.i;++ return float_r;+}+++#define OPC(C,F) case C: { for(k=0;k<xn;k++) rp[k] = complex_f_math_fun(&F,xp[k]); OK }+int mapQ(int code, KQVEC(x), QVEC(r)) {+ TCF* x2p = (TCF*)xp;+ TCF* r2p = (TCF*)rp;+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapQ");+ switch (code) {+ OPb(0,csinf)+ OPb(1,ccosf)+ OPb(2,ctanf)+ OPC(3,complex_abs_complex)+ OPb(4,casinf)+ OPb(5,cacosf)+ OPb(6,catanf)+ OPb(7,csinhf)+ OPb(8,ccoshf)+ OPb(9,ctanhf)+ OPb(10,casinhf)+ OPb(11,cacoshf)+ OPb(12,catanhf)+ OPb(13,cexpf)+ OPb(14,clogf)+ OPC(15,complex_signum_complex)+ OPb(16,csqrtf)+ default: ERROR(BAD_CODE);+ }+}+++int mapValR(int code, double* pval, KDVEC(x), DVEC(r)) {+ int k;+ double val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValR");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(4,pow(val,xp[k]))+ OPV(5,pow(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++int mapValF(int code, float* pval, KFVEC(x), FVEC(r)) {+ int k;+ float val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValF");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(4,pow(val,xp[k]))+ OPV(5,pow(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++int mapValI(int code, int* pval, KIVEC(x), IVEC(r)) {+ int k;+ int val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValI");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(6,mod(val,xp[k]))+ OPV(7,mod(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++int mapValL(int code, int64_t* pval, KLVEC(x), LVEC(r)) {+ int k;+ int64_t val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValL");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(6,mod_l(val,xp[k]))+ OPV(7,mod_l(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++++inline doublecomplex complex_add(doublecomplex a, doublecomplex b) {+ doublecomplex r;+ r.r = a.r+b.r;+ r.i = a.i+b.i;+ return r;+}++#define OPVb(C,E) case C: { for(k=0;k<xn;k++) r2p[k] = E; OK }+int mapValC(int code, doublecomplex* pval, KCVEC(x), CVEC(r)) {+ TCD* x2p = (TCD*)xp;+ TCD* r2p = (TCD*)rp;+ int k;+ TCD val = * (TCD*)pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValC");+ switch (code) {+ OPVb(0,val*x2p[k])+ OPVb(1,val/x2p[k])+ OPVb(2,val+x2p[k])+ OPVb(3,val-x2p[k])+ OPVb(4,cpow(val,x2p[k]))+ OPVb(5,cpow(x2p[k],val))+ default: ERROR(BAD_CODE);+ }+}+++int mapValQ(int code, complex* pval, KQVEC(x), QVEC(r)) {+ TCF* x2p = (TCF*)xp;+ TCF* r2p = (TCF*)rp;+ int k;+ TCF val = *(TCF*)pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValQ");+ switch (code) {+ OPVb(0,val*x2p[k])+ OPVb(1,val/x2p[k])+ OPVb(2,val+x2p[k])+ OPVb(3,val-x2p[k])+ OPVb(4,cpow(val,x2p[k]))+ OPVb(5,cpow(x2p[k],val))+ default: ERROR(BAD_CODE);+ }+}++++#define OPZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = E(ap[k],bp[k]); OK }+#define OPZV(C,msg,E) case C: {DEBUGMSG(msg) res = E(V(r),V(b)); CHECK(res,res); OK }+#define OPZO(C,msg,O) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = ap[k] O bp[k]; OK }++int zipR(int code, KDVEC(a), KDVEC(b), DVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipR Add",+)+ OPZO(1,"zipR Sub",-)+ OPZO(2,"zipR Mul",*)+ OPZO(3,"zipR Div",/)+ OPZE(4,"zipR Pow", pow)+ OPZE(5,"zipR ATan2",atan2)+ default: ERROR(BAD_CODE);+ }+}++int zipF(int code, KFVEC(a), KFVEC(b), FVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipR Add",+)+ OPZO(1,"zipR Sub",-)+ OPZO(2,"zipR Mul",*)+ OPZO(3,"zipR Div",/)+ OPZE(4,"zipR Pow", pow)+ OPZE(5,"zipR ATan2",atan2)+ default: ERROR(BAD_CODE);+ }+}+++int zipI(int code, KIVEC(a), KIVEC(b), IVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipI Add",+)+ OPZO(1,"zipI Sub",-)+ OPZO(2,"zipI Mul",*)+ OPZO(3,"zipI Div",/)+ OPZO(6,"zipI Mod",%)+ default: ERROR(BAD_CODE);+ }+}+++int zipL(int code, KLVEC(a), KLVEC(b), LVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipI Add",+)+ OPZO(1,"zipI Sub",-)+ OPZO(2,"zipI Mul",*)+ OPZO(3,"zipI Div",/)+ OPZO(6,"zipI Mod",%)+ default: ERROR(BAD_CODE);+ }+}+++#define OPZOb(C,msg,O) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) r2p[k] = a2p[k] O b2p[k]; OK }+#define OPZEb(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) r2p[k] = E(a2p[k],b2p[k]); OK }+int zipC(int code, KCVEC(a), KCVEC(b), CVEC(r)) {+ REQUIRES(an == bn && an == rn, BAD_SIZE);+ TCD* a2p = (TCD*)ap;+ TCD* b2p = (TCD*)bp;+ TCD* r2p = (TCD*)rp;+ int k;+ switch(code) {+ OPZOb(0,"zipC Add",+)+ OPZOb(1,"zipC Sub",-)+ OPZOb(2,"zipC Mul",*)+ OPZOb(3,"zipC Div",/)+ OPZEb(4,"zipC Pow",cpow)+ default: ERROR(BAD_CODE);+ }+}++++++#define OPCZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = complex_f_math_op(&E,ap[k],bp[k]); OK }++int zipQ(int code, KQVEC(a), KQVEC(b), QVEC(r)) {+ REQUIRES(an == bn && an == rn, BAD_SIZE);+ TCF* a2p = (TCF*)ap;+ TCF* b2p = (TCF*)bp;+ TCF* r2p = (TCF*)rp;++ int k;+ switch(code) {+ OPZOb(0,"zipC Add",+)+ OPZOb(1,"zipC Sub",-)+ OPZOb(2,"zipC Mul",*)+ OPZOb(3,"zipC Div",/)+ OPZEb(4,"zipC Pow",cpowf)+ default: ERROR(BAD_CODE);+ }+}++////////////////////////////////////////////////////////////////////////////////++int vectorScan(char * file, int* n, double**pp){+ FILE * fp;+ fp = fopen (file, "r");+ if(!fp) {+ ERROR(BAD_FILE);+ }+ int nbuf = 100*100;+ double * p = (double*)malloc(nbuf*sizeof(double));+ int k=0;+ double d;+ int ok;+ for (;;) {+ ok = fscanf(fp,"%lf",&d);+ if (ok<1) {+ break;+ }+ if (k==nbuf) {+ nbuf = nbuf * 2;+ p = (double*)realloc(p,nbuf*sizeof(double));+ // printf("R\n");+ }+ p[k++] = d;+ }+ *n = k;+ *pp = p;+ fclose(fp);+ OK+}++////////////////////////////////////////////////////////////////////////////////++#if defined (__APPLE__) || (__FreeBSD__) || defined(NO_RANDOM_R) || defined(_WIN32) || defined(WIN32)+/* Windows use thread-safe random+ See: http://stackoverflow.com/questions/143108/is-windows-rand-s-thread-safe+*/+#if defined (__APPLE__) || (__FreeBSD__) || defined(NO_RANDOM_R)++/* For FreeBSD, Mac OS X, and other libcs (like `musl`) that do not provide+ random_r(), or if the use of random_r() is explicitly disabled, thread safety+ cannot be guaranteed.+ As per current understanding, this should at worst lead to less "random"+ numbers being generated, in particular+ * if another thread somebody calls lcong48() at the same time as nrand48()+ is called+ * in addition to that, for glibc with NO_RANDOM_R enabled when ndrand48()+ is called for the first time by multiple threads in parallel due to the+ initialisation function placed within it+ See: http://www.evanjones.ca/random-thread-safe.html++ For FreeBSD and Mac OS X, nrand48() is much better than random().+ See: http://www.evanjones.ca/random-thread-safe.html++ TODO: As mentioned in the linked article, this could be fixed:+ "the best solution for truly portable applications is to include+ your own random number generator implementation,+ and not rely on the system's C library".+*/+#pragma message "randomVector is not thread-safe in OSX and FreeBSD or with NO_RANDOM_R; this likely leads to less random numbers at worst; see http://www.evanjones.ca/random-thread-safe.html"++inline double urandom() {+ /* the probalility of matching will be theoretically p^3(in fact, it is not)+ p is matching probalility of random().+ using the test there, only 3 matches, using random(), 13783 matches+ */+ unsigned short state[3];+ state[0] = random();+ state[1] = random();+ state[2] = random();++ const long max_random = 2147483647; // 2**31 - 1+ return (double)nrand48(state) / (double)max_random;+}++#else++#define _CRT_RAND_S+inline double urandom() {+ unsigned int number;+ errno_t err;+ err = rand_s(&number);+ if (err!=0) {+ printf("something wrong\n");+ return -1;+ }+ return (double)number / (double)UINT_MAX;+}++#endif++double gaussrand(int *phase, double *pV1, double *pV2, double *pS)+{+ double V1=*pV1, V2=*pV2, S=*pS;+ double X;++ if(*phase == 0) {+ do {+ double U1 = urandom();+ double U2 = urandom();++ V1 = 2 * U1 - 1;+ V2 = 2 * U2 - 1;+ S = V1 * V1 + V2 * V2;+ } while(S >= 1 || S == 0);++ X = V1 * sqrt(-2 * log(S) / S);+ } else+ X = V2 * sqrt(-2 * log(S) / S);++ *phase = 1 - *phase;+ *pV1=V1; *pV2=V2; *pS=S;++ return X;++}++#if defined(_WIN32) || defined(WIN32)++int random_vector(unsigned int seed, int code, DVEC(r)) {+ int phase = 0;+ double V1,V2,S;++ srand(seed);++ int k;+ switch (code) {+ case 0: { // uniform+ for (k=0; k<rn; k++) {+ rp[k] = urandom();+ }+ OK+ }+ case 1: { // gaussian+ for (k=0; k<rn; k++) {+ rp[k] = gaussrand(&phase,&V1,&V2,&S);+ }+ OK+ }++ default: ERROR(BAD_CODE);+ }+}++#else++int random_vector(unsigned int seed, int code, DVEC(r)) {+ int phase = 0;+ double V1,V2,S;++ srandom(seed);++ int k;+ switch (code) {+ case 0: { // uniform+ for (k=0; k<rn; k++) {+ rp[k] = urandom();+ }+ OK+ }+ case 1: { // gaussian+ for (k=0; k<rn; k++) {+ rp[k] = gaussrand(&phase,&V1,&V2,&S);+ }+ OK+ }++ default: ERROR(BAD_CODE);+ }+}++#endif++#else++inline double urandom(struct random_data * buffer) {+ int32_t res;+ random_r(buffer,&res);+ return (double)res/RAND_MAX;+}+++// http://c-faq.com/lib/gaussian.html+double gaussrand(struct random_data *buffer,+ int *phase, double *pV1, double *pV2, double *pS)+{+ double V1=*pV1, V2=*pV2, S=*pS;+ double X;++ if(*phase == 0) {+ do {+ double U1 = urandom(buffer);+ double U2 = urandom(buffer);++ V1 = 2 * U1 - 1;+ V2 = 2 * U2 - 1;+ S = V1 * V1 + V2 * V2;+ } while(S >= 1 || S == 0);++ X = V1 * sqrt(-2 * log(S) / S);+ } else+ X = V2 * sqrt(-2 * log(S) / S);++ *phase = 1 - *phase;+ *pV1=V1; *pV2=V2; *pS=S;++ return X;++}++int random_vector(unsigned int seed, int code, DVEC(r)) {+ struct random_data buffer;+ char random_state[128];+ memset(&buffer, 0, sizeof(struct random_data));+ memset(random_state, 0, sizeof(random_state));++ initstate_r(seed,random_state,sizeof(random_state),&buffer);+ // setstate_r(random_state,&buffer);+ // srandom_r(seed,&buffer);++ int phase = 0;+ double V1,V2,S;++ int k;+ switch (code) {+ case 0: { // uniform+ for (k=0; k<rn; k++) {+ rp[k] = urandom(&buffer);+ }+ OK+ }+ case 1: { // gaussian+ for (k=0; k<rn; k++) {+ rp[k] = gaussrand(&buffer,&phase,&V1,&V2,&S);+ }+ OK+ }++ default: ERROR(BAD_CODE);+ }+}++#endif++////////////////////////////////////////////////////////////////////////////////++int+compare_doubles (const void *a, const void *b) {+ return *(double*)a > *(double*)b;+}++int sort_valuesD(KDVEC(v),DVEC(r)) {+ memcpy(rp,vp,vn*sizeof(double));+ qsort(rp,rn,sizeof(double),compare_doubles);+ OK+}++int+compare_floats (const void *a, const void *b) {+ return *(float*)a > *(float*)b;+}++int sort_valuesF(KFVEC(v),FVEC(r)) {+ memcpy(rp,vp,vn*sizeof(float));+ qsort(rp,rn,sizeof(float),compare_floats);+ OK+}++int+compare_ints(const void *a, const void *b) {+ return *(int*)a > *(int*)b;+}++int sort_valuesI(KIVEC(v),IVEC(r)) {+ memcpy(rp,vp,vn*sizeof(int));+ qsort(rp,rn,sizeof(int),compare_ints);+ OK+}++int+compare_longs(const void *a, const void *b) {+ return *(int64_t*)a > *(int64_t*)b;+}++int sort_valuesL(KLVEC(v),LVEC(r)) {+ memcpy(rp,vp,vn*sizeof(int64_t));+ qsort(rp,rn,sizeof(int64_t),compare_ints);+ OK+}+++////////////////////////////////////////+++#define SORTIDX_IMP(T,C) \+ T* x = (T*)malloc(sizeof(T)*vn); \+ int k; \+ for (k=0;k<vn;k++) { \+ x[k].pos = k; \+ x[k].val = vp[k]; \+ } \+ \+ qsort(x,vn,sizeof(T),C); \+ \+ for (k=0;k<vn;k++) { \+ rp[k] = x[k].pos; \+ } \+ free(x); \+ OK+++typedef struct DI { int pos; double val;} DI;++int compare_doubles_i (const void *a, const void *b) {+ return ((DI*)a)->val > ((DI*)b)->val;+}++int sort_indexD(KDVEC(v),IVEC(r)) {+ SORTIDX_IMP(DI,compare_doubles_i)+}+++typedef struct FI { int pos; float val;} FI;++int compare_floats_i (const void *a, const void *b) {+ return ((FI*)a)->val > ((FI*)b)->val;+}++int sort_indexF(KFVEC(v),IVEC(r)) {+ SORTIDX_IMP(FI,compare_floats_i)+}+++typedef struct II { int pos; int val;} II;++int compare_ints_i (const void *a, const void *b) {+ return ((II*)a)->val > ((II*)b)->val;+}++int sort_indexI(KIVEC(v),IVEC(r)) {+ SORTIDX_IMP(II,compare_ints_i)+}+++typedef struct LI { int pos; int64_t val;} LI;++int compare_longs_i (const void *a, const void *b) {+ return ((II*)a)->val > ((II*)b)->val;+}++int sort_indexL(KLVEC(v),LVEC(r)) {+ SORTIDX_IMP(II,compare_longs_i)+}+++////////////////////////////////////////////////////////////////////////////////++int round_vector(KDVEC(v),DVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = round(vp[k]);+ }+ OK+}++////////////////////////////////////////////////////////////////////////////////++int round_vector_i(KDVEC(v),IVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = round(vp[k]);+ }+ OK+}+++int mod_vector(int m, KIVEC(v), IVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = mod(vp[k],m);+ }+ OK+}++int div_vector(int m, KIVEC(v), IVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = vp[k] / m;+ }+ OK+}++int range_vector(IVEC(r)) {+ int k;+ for(k=0; k<rn; k++) {+ rp[k] = k;+ }+ OK+}++///////////////////////////+++int round_vector_l(KDVEC(v),LVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = round(vp[k]);+ }+ OK+}+++int mod_vector_l(int64_t m, KLVEC(v), LVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = mod_l(vp[k],m);+ }+ OK+}++int div_vector_l(int64_t m, KLVEC(v), LVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = vp[k] / m;+ }+ OK+}++int range_vector_l(LVEC(r)) {+ int k;+ for(k=0; k<rn; k++) {+ rp[k] = k;+ }+ OK+}++++//////////////////// constant /////////////////////////++int constantF(float * pval, FVEC(r)) {+ DEBUGMSG("constantF")+ int k;+ double val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++int constantR(double * pval, DVEC(r)) {+ DEBUGMSG("constantR")+ int k;+ double val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++int constantQ(complex* pval, QVEC(r)) {+ DEBUGMSG("constantQ")+ int k;+ complex val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++int constantC(doublecomplex* pval, CVEC(r)) {+ DEBUGMSG("constantC")+ int k;+ doublecomplex val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++++int constantI(int * pval, IVEC(r)) {+ DEBUGMSG("constantI")+ int k;+ int val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++++int constantL(int64_t * pval, LVEC(r)) {+ DEBUGMSG("constantL")+ int k;+ int64_t val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}+++//////////////////// type conversions /////////////////////////++#define CONVERT_IMP { \+ int k; \+ for(k=0;k<xn;k++) { \+ yp[k]=xp[k]; \+ } \+ OK }++int float2double(FVEC(x),DVEC(y)) CONVERT_IMP++int float2int(KFVEC(x),IVEC(y)) CONVERT_IMP++int double2float(DVEC(x),FVEC(y)) CONVERT_IMP++int double2int(KDVEC(x),IVEC(y)) CONVERT_IMP++int double2long(KDVEC(x),LVEC(y)) CONVERT_IMP++int int2float(KIVEC(x),FVEC(y)) CONVERT_IMP++int int2double(KIVEC(x),DVEC(y)) CONVERT_IMP++int int2long(KIVEC(x),LVEC(y)) CONVERT_IMP++int long2int(KLVEC(x),IVEC(y)) CONVERT_IMP++int long2double(KLVEC(x),DVEC(y)) CONVERT_IMP+++//////////////////// conjugate /////////////////////////++int conjugateQ(KQVEC(x),QVEC(t)) {+ REQUIRES(xn==tn,BAD_SIZE);+ DEBUGMSG("conjugateQ");+ int k;+ for(k=0;k<xn;k++) {+ tp[k].r = xp[k].r;+ tp[k].i = -xp[k].i;+ }+ OK+}++int conjugateC(KCVEC(x),CVEC(t)) {+ REQUIRES(xn==tn,BAD_SIZE);+ DEBUGMSG("conjugateC");+ int k;+ for(k=0;k<xn;k++) {+ tp[k].r = xp[k].r;+ tp[k].i = -xp[k].i;+ }+ OK+}++//////////////////// step /////////////////////////++#define STEP_IMP \+ int k; \+ for(k=0;k<xn;k++) { \+ yp[k]=xp[k]>0; \+ } \+ OK++int stepF(KFVEC(x),FVEC(y)) {+ STEP_IMP+}++int stepD(KDVEC(x),DVEC(y)) {+ STEP_IMP+}++int stepI(KIVEC(x),IVEC(y)) {+ STEP_IMP+}++int stepL(KLVEC(x),LVEC(y)) {+ STEP_IMP+}+++//////////////////// cond /////////////////////////++#define COMPARE_IMP \+ REQUIRES(xn==yn && xn==rn ,BAD_SIZE); \+ int k; \+ for(k=0;k<xn;k++) { \+ rp[k] = xp[k]<yp[k]?-1:(xp[k]>yp[k]?1:0); \+ } \+ OK+++int compareF(KFVEC(x),KFVEC(y),IVEC(r)) {+ COMPARE_IMP+}++int compareD(KDVEC(x),KDVEC(y),IVEC(r)) {+ COMPARE_IMP+}++int compareI(KIVEC(x),KIVEC(y),IVEC(r)) {+ COMPARE_IMP+}++int compareL(KLVEC(x),KLVEC(y),IVEC(r)) {+ COMPARE_IMP+}++++#define CHOOSE_IMP \+ REQUIRES(condn==ltn && ltn==eqn && ltn==gtn && ltn==rn ,BAD_SIZE); \+ int k; \+ for(k=0;k<condn;k++) { \+ rp[k] = condp[k]<0?ltp[k]:(condp[k]>0?gtp[k]:eqp[k]); \+ } \+ OK++int chooseF(KIVEC(cond),KFVEC(lt),KFVEC(eq),KFVEC(gt),FVEC(r)) {+ CHOOSE_IMP+}++int chooseD(KIVEC(cond),KDVEC(lt),KDVEC(eq),KDVEC(gt),DVEC(r)) {+ CHOOSE_IMP+}++int chooseI(KIVEC(cond),KIVEC(lt),KIVEC(eq),KIVEC(gt),IVEC(r)) {+ CHOOSE_IMP+}++int chooseL(KIVEC(cond),KLVEC(lt),KLVEC(eq),KLVEC(gt),LVEC(r)) {+ CHOOSE_IMP+}+++int chooseC(KIVEC(cond),KCVEC(lt),KCVEC(eq),KCVEC(gt),CVEC(r)) {+ CHOOSE_IMP+}++int chooseQ(KIVEC(cond),KQVEC(lt),KQVEC(eq),KQVEC(gt),QVEC(r)) {+ CHOOSE_IMP+}++//////////////////// reorder /////////////////////////++#define REORDER_IMP \+ REQUIRES(kn == stridesn && stridesn == dimsn ,BAD_SIZE); \+ int i,j,l; \+ for (i=1,j=0,l=0;l<kn;++l) { \+ kp[l] = 0; \+ i *= dimsp[l]; \+ j += (dimsp[l]-1) * stridesp[l]; \+ } \+ REQUIRES(i <= vn && j < rn ,BAD_SIZE); \+ for (i=0,j=0;;i++) { \+ rp[i] = vp[j]; \+ for(l=kn-1;;l--) { \+ ++kp[l]; \+ if (kp[l] < dimsp[l]) { \+ j += stridesp[l]; \+ break; \+ } else { \+ if (l == 0) { \+ return 0; \+ } \+ kp[l] = 0; \+ j -= (dimsp[l]-1) * stridesp[l]; \+ } \+ } \+ }++int reorderF(IVEC(k), KIVEC(strides),KIVEC(dims),KFVEC(v),FVEC(r)) {+ REORDER_IMP+}++int reorderD(IVEC(k), KIVEC(strides),KIVEC(dims),KDVEC(v),DVEC(r)) {+ REORDER_IMP+}++int reorderI(IVEC(k), KIVEC(strides),KIVEC(dims),KIVEC(v),IVEC(r)) {+ REORDER_IMP+}++int reorderL(IVEC(k), KIVEC(strides),KIVEC(dims),KLVEC(v),LVEC(r)) {+ REORDER_IMP+}++int reorderC(IVEC(k), KIVEC(strides),KIVEC(dims),KCVEC(v),CVEC(r)) {+ REORDER_IMP+}++int reorderQ(IVEC(k), KIVEC(strides),KIVEC(dims),KQVEC(v),QVEC(r)) {+ REORDER_IMP+}
+ src/Internal/CG.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Internal.CG(+ cgSolve, cgSolve',+ CGState(..), R, V+) where++import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import Internal.Element+import Internal.IO+import Internal.Container+import Internal.Sparse+import Numeric.Vector()+import Internal.Algorithms(linearSolveLS, linearSolve, relativeError, pnorm, NormType(..))+import Control.Arrow((***))++{-+import Util.Misc(debug, debugMat)++(//) :: Show a => a -> String -> a+infix 0 // -- , ///+a // b = debug b id a++(///) :: V -> String -> V+infix 0 ///+v /// b = debugMat b 2 asRow v+-}++type V = Vector R++data CGState = CGState+ { cgp :: Vector R -- ^ conjugate gradient+ , cgr :: Vector R -- ^ residual+ , cgr2 :: R -- ^ squared norm of residual+ , cgx :: Vector R -- ^ current solution+ , cgdx :: R -- ^ normalized size of correction+ }++cg :: Bool -> (V -> V) -> (V -> V) -> CGState -> CGState+cg sym at a (CGState p r r2 x _) = CGState p' r' r'2 x' rdx+ where+ ap1 = a p+ ap | sym = ap1+ | otherwise = at ap1+ pap | sym = p <.> ap1+ | otherwise = norm2 ap1 ** 2+ alpha = r2 / pap+ dx = scale alpha p+ x' = x + dx+ r' = r - scale alpha ap+ r'2 = r' <.> r'+ beta = r'2 / r2+ p' = r' + scale beta p++ rdx = norm2 dx / max 1 (norm2 x)++conjugrad+ :: Bool -> GMatrix -> V -> V -> R -> R -> [CGState]+conjugrad sym a b = solveG sym (tr a !#>) (a !#>) (cg sym) b++solveG+ :: Bool+ -> (V -> V) -> (V -> V)+ -> ((V -> V) -> (V -> V) -> CGState -> CGState)+ -> V+ -> V+ -> R -> R+ -> [CGState]+solveG sym mat ma meth rawb x0' ϵb ϵx+ = takeUntil ok . iterate (meth mat ma) $ CGState p0 r0 r20 x0 1+ where+ a = if sym then ma else mat . ma+ b = if sym then rawb else mat rawb+ x0 = if x0' == 0 then konst 0 (dim b) else x0'+ r0 = b - a x0+ r20 = r0 <.> r0+ p0 = r0+ nb2 = b <.> b+ ok CGState {..}+ = cgr2 <nb2*ϵb**2+ || cgdx < ϵx+++takeUntil :: (a -> Bool) -> [a] -> [a]+takeUntil q xs = a++ take 1 b+ where+ (a,b) = break q xs++-- | Solve a sparse linear system using the conjugate gradient method with default parameters.+cgSolve+ :: Bool -- ^ is symmetric+ -> GMatrix -- ^ coefficient matrix+ -> Vector R -- ^ right-hand side+ -> Vector R -- ^ solution+cgSolve sym a b = cgx $ last $ cgSolve' sym 1E-4 1E-3 n a b 0+ where+ n = max 10 (round $ sqrt (fromIntegral (dim b) :: Double))++-- | Solve a sparse linear system using the conjugate gradient method with default parameters.+cgSolve'+ :: Bool -- ^ symmetric+ -> R -- ^ relative tolerance for the residual (e.g. 1E-4)+ -> R -- ^ relative tolerance for δx (e.g. 1E-3)+ -> Int -- ^ maximum number of iterations+ -> GMatrix -- ^ coefficient matrix+ -> Vector R -- ^ initial solution+ -> Vector R -- ^ right-hand side+ -> [CGState] -- ^ solution+cgSolve' sym er es n a b x = take n $ conjugrad sym a b x er es+++--------------------------------------------------------------------------------++instance Testable GMatrix+ where+ checkT _ = (ok,info)+ where+ sma = convo2 20 3+ x1 = vect [1..20]+ x2 = vect [1..40]+ sm = mkSparse sma+ dm = toDense sma++ s1 = sm !#> x1+ d1 = dm #> x1++ s2 = tr sm !#> x2+ d2 = tr dm #> x2++ sdia = mkDiagR 40 20 (vect [1..10])+ s3 = sdia !#> x1+ s4 = tr sdia !#> x2+ ddia = diagRect 0 (vect [1..10]) 40 20+ d3 = ddia #> x1+ d4 = tr ddia #> x2++ v = testb 40+ s5 = cgSolve False sm v+ d5 = denseSolve dm v++ symassoc = [((0,0),1.0),((1,1),2.0),((0,1),0.5),((1,0),0.5)]+ b = vect [3,4]+ d6 = flatten $ linearSolve (toDense symassoc) (asColumn b)+ s6 = cgSolve True (mkSparse symassoc) b++ info = do+ print sm+ disp (toDense sma)+ print s1; print d1+ print s2; print d2+ print s3; print d3+ print s4; print d4+ print s5; print d5+ print $ relativeError (pnorm Infinity) s5 d5+ print s6; print d6+ print $ relativeError (pnorm Infinity) s6 d6++ ok = s1==d1+ && s2==d2+ && s3==d3+ && s4==d4+ && relativeError (pnorm Infinity) s5 d5 < 1E-10+ && relativeError (pnorm Infinity) s6 d6 < 1E-10++ disp = putStr . dispf 2++ vect = fromList :: [Double] -> Vector Double++ convomat :: Int -> Int -> AssocMatrix+ convomat n k = [ ((i,j `mod` n),1) | i<-[0..n-1], j <- [i..i+k-1]]++ convo2 :: Int -> Int -> AssocMatrix+ convo2 n k = m1 ++ m2+ where+ m1 = convomat n k+ m2 = map (((+n) *** id) *** id) m1++ testb n = vect $ take n $ cycle ([0..10]++[9,8..1])++ denseSolve a = flatten . linearSolveLS a . asColumn++ -- mkDiag v = mkDiagR (dim v) (dim v) v+
+ src/Internal/Chain.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Internal.Chain+-- Copyright : (c) Vivian McPhail 2010+-- License : BSD3+--+-- Maintainer : Vivian McPhail <haskell.vivian.mcphail <at> gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- optimisation of association order for chains of matrix multiplication+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}++module Internal.Chain (+ optimiseMult,+ ) where++import Data.Maybe++import Internal.Matrix+import Internal.Numeric++import qualified Data.Array.IArray as A++-----------------------------------------------------------------------------+{- | + Provide optimal association order for a chain of matrix multiplications + and apply the multiplications.++ The algorithm is the well-known O(n\^3) dynamic programming algorithm+ that builds a pyramid of optimal associations.++> m1, m2, m3, m4 :: Matrix Double+> m1 = (10><15) [1..]+> m2 = (15><20) [1..]+> m3 = (20><5) [1..]+> m4 = (5><10) [1..]++> >>> optimiseMult [m1,m2,m3,m4]++will perform @((m1 `multiply` (m2 `multiply` m3)) `multiply` m4)@++The naive left-to-right multiplication would take @4500@ scalar multiplications+whereas the optimised version performs @2750@ scalar multiplications. The complexity+in this case is 32 (= 4^3/2) * (2 comparisons, 3 scalar multiplications, 3 scalar additions,+5 lookups, 2 updates) + a constant (= three table allocations)+-}+optimiseMult :: Product t => [Matrix t] -> Matrix t+optimiseMult = chain++-----------------------------------------------------------------------------++type Matrices a = A.Array Int (Matrix a)+type Sizes = A.Array Int (Int,Int)+type Cost = A.Array Int (A.Array Int (Maybe Int))+type Indexes = A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))++update :: A.Array Int (A.Array Int a) -> (Int,Int) -> a -> A.Array Int (A.Array Int a)+update a (r,c) e = a A.// [(r,(a A.! r) A.// [(c,e)])]++newWorkSpaceCost :: Int -> A.Array Int (A.Array Int (Maybe Int))+newWorkSpaceCost n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]+ where subArray i = A.listArray (1,i) (repeat Nothing)++newWorkSpaceIndexes :: Int -> A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))+newWorkSpaceIndexes n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]+ where subArray i = A.listArray (1,i) (repeat Nothing)++matricesToSizes :: [Matrix a] -> Sizes+matricesToSizes ms = A.listArray (1,length ms) $ map (\m -> (rows m,cols m)) ms++chain :: Product a => [Matrix a] -> Matrix a+chain [] = error "chain: zero matrices to multiply"+chain [m] = m+chain [ml,mr] = ml `multiply` mr+chain ms = let ln = length ms+ ma = A.listArray (1,ln) ms+ mz = matricesToSizes ms+ i = chain_cost mz+ in chain_paren (ln,ln) i ma++chain_cost :: Sizes -> Indexes+chain_cost mz = let (_,u) = A.bounds mz+ cost = newWorkSpaceCost u+ ixes = newWorkSpaceIndexes u+ (_,_,i) = foldl chain_cost' (mz,cost,ixes) (order u)+ in i++chain_cost' :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)+chain_cost' sci@(mz,cost,ixes) (r,c) + | c == 1 = let cost' = update cost (r,c) (Just 0)+ ixes' = update ixes (r,c) (Just ((r,c),(r,c)))+ in (mz,cost',ixes')+ | otherwise = minimum_cost sci (r,c)++minimum_cost :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)+minimum_cost sci fu = foldl (smaller_cost fu) sci (fulcrum_order fu)++smaller_cost :: (Int,Int) -> (Sizes,Cost,Indexes) -> ((Int,Int),(Int,Int)) -> (Sizes,Cost,Indexes)+smaller_cost (r,c) (mz,cost,ixes) ix@((lr,lc),(rr,rc)) =+ let op_cost = fromJust ((cost A.! lr) A.! lc)+ + fromJust ((cost A.! rr) A.! rc)+ + fst (mz A.! (lr-lc+1))+ * snd (mz A.! lc)+ * snd (mz A.! rr)+ cost' = (cost A.! r) A.! c+ in case cost' of+ Nothing -> let cost'' = update cost (r,c) (Just op_cost)+ ixes'' = update ixes (r,c) (Just ix)+ in (mz,cost'',ixes'')+ Just ct -> if op_cost < ct then+ let cost'' = update cost (r,c) (Just op_cost)+ ixes'' = update ixes (r,c) (Just ix)+ in (mz,cost'',ixes'')+ else (mz,cost,ixes)+ ++fulcrum_order (r,c) = let fs' = zip (repeat r) [1..(c-1)]+ in map (partner (r,c)) fs'++partner (r,c) (a,b) = ((r-b, c-b), (a,b))++order 0 = []+order n = order (n-1) ++ zip (repeat n) [1..n]++chain_paren :: Product a => (Int,Int) -> Indexes -> Matrices a -> Matrix a+chain_paren (r,c) ixes ma = let ((lr,lc),(rr,rc)) = fromJust $ (ixes A.! r) A.! c+ in if lr == rr && lc == rc then (ma A.! lr)+ else (chain_paren (lr,lc) ixes ma) `multiply` (chain_paren (rr,rc) ixes ma) ++--------------------------------------------------------------------------++{- TESTS++-- optimal association is ((m1*(m2*m3))*m4)+m1, m2, m3, m4 :: Matrix Double+m1 = (10><15) [1..]+m2 = (15><20) [1..]+m3 = (20><5) [1..]+m4 = (5><10) [1..]++-}+
+ src/Internal/Container.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Internal.Container+-- Copyright : (c) Alberto Ruiz 2010-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Basic numeric operations on 'Vector' and 'Matrix', including conversion routines.+--+-- The 'Container' class is used to define optimized generic functions which work+-- on 'Vector' and 'Matrix' with real or complex elements.+--+-- Some of these functions are also available in the instances of the standard+-- numeric Haskell classes provided by "Numeric.LinearAlgebra".+--+-----------------------------------------------------------------------------++module Internal.Container where++import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Numeric+import Internal.Algorithms(Field,linearSolveSVD,Herm,mTm)+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+------------------------------------------------------------------++{- | Creates a real vector containing a range of values:++>>> linspace 5 (-3,7::Double)+[-3.0,-0.5,2.0,4.5,7.0]+it :: Vector Double++>>> linspace 5 (8,3:+2) :: Vector (Complex Double)+[8.0 :+ 0.0,6.75 :+ 0.5,5.5 :+ 1.0,4.25 :+ 1.5,3.0 :+ 2.0]+it :: Vector (Complex Double)++Logarithmic spacing can be defined as follows:++@logspace n (a,b) = 10 ** linspace n (a,b)@+-}+linspace :: (Fractional e, Container Vector e) => Int -> (e, e) -> Vector e+linspace 0 _ = fromList[]+linspace 1 (a,b) = fromList[(a+b)/2]+linspace n (a,b) = addConstant a $ scale s $ fromList $ map fromIntegral [0 .. n-1]+ where s = (b-a)/fromIntegral (n-1)++--------------------------------------------------------------------------------++infixr 8 <.>+{- | An infix synonym for 'dot'++>>> vector [1,2,3,4] <.> vector [-2,0,1,1]+5.0++>>> let 𝑖 = 0:+1 :: C+>>> fromList [1+𝑖,1] <.> fromList [1,1+𝑖]+2.0 :+ 0.0++-}++(<.>) :: Numeric t => Vector t -> Vector t -> t+(<.>) = dot++++++{- | dense matrix-vector product++>>> let m = (2><3) [1..]+>>> m+(2><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0 ]++>>> let v = vector [10,20,30]++>>> m #> v+[140.0,320.0]+it :: Vector Numeric.LinearAlgebra.Data.R++-}+infixr 8 #>+(#>) :: Numeric t => Matrix t -> Vector t -> Vector t+(#>) = mXv++-- | dense matrix-vector product+app :: Numeric t => Matrix t -> Vector t -> Vector t+app = (#>)++infixl 8 <#+-- | dense vector-matrix product+(<#) :: Numeric t => Vector t -> Matrix t -> Vector t+(<#) = vXm++--------------------------------------------------------------------------------++class Mul a b c | a b -> c where+ infixl 7 <>+ -- | Matrix-matrix, matrix-vector, and vector-matrix products.+ (<>) :: Product t => a t -> b t -> c t++instance Mul Matrix Matrix Matrix where+ (<>) = mXm++instance Mul Matrix Vector Vector where+ (<>) m v = flatten $ m <> asColumn v++instance Mul Vector Matrix Vector where+ (<>) v m = flatten $ asRow v <> m++--------------------------------------------------------------------------------++{- | Least squares solution of a linear system, similar to the \\ operator of Matlab\/Octave (based on linearSolveSVD)++@+a = (3><2)+ [ 1.0, 2.0+ , 2.0, 4.0+ , 2.0, -1.0 ]+@++@+v = vector [13.0,27.0,1.0]+@++>>> let x = a <\> v+>>> x+[3.0799999999999996,5.159999999999999]+it :: Vector Numeric.LinearAlgebra.Data.R++>>> a #> x+[13.399999999999999,26.799999999999997,0.9999999999999991]+it :: Vector Numeric.LinearAlgebra.Data.R++It also admits multiple right-hand sides stored as columns in a matrix.++-}+infixl 7 <\>+(<\>) :: (LSDiv c, Field t) => Matrix t -> c t -> c t+(<\>) = linSolve++class LSDiv c+ where+ linSolve :: Field t => Matrix t -> c t -> c t++instance LSDiv Vector+ where+ linSolve m v = flatten (linearSolveSVD m (reshape 1 v))++instance LSDiv Matrix+ where+ linSolve = linearSolveSVD++--------------------------------------------------------------------------------+++class Build d f c e | d -> c, c -> d, f -> e, f -> d, f -> c, c e -> f, d e -> f+ where+ -- |+ -- >>> build 5 (**2) :: Vector Double+ -- [0.0,1.0,4.0,9.0,16.0]+ -- it :: Vector Double+ --+ -- Hilbert matrix of order N:+ --+ -- >>> let hilb n = build (n,n) (\i j -> 1/(i+j+1)) :: Matrix Double+ -- >>> putStr . dispf 2 $ hilb 3+ -- 3x3+ -- 1.00 0.50 0.33+ -- 0.50 0.33 0.25+ -- 0.33 0.25 0.20+ --+ build :: d -> f -> c e++instance Container Vector e => Build Int (e -> e) Vector e+ where+ build = build'++instance (Num e, Container Vector e) => Build (Int,Int) (e -> e -> e) Matrix e+ where+ build = build'++--------------------------------------------------------------------------------++-- @dot u v = 'udot' ('conj' u) v@+dot :: (Numeric t) => Vector t -> Vector t -> t+dot u v = udot (conj u) v++--------------------------------------------------------------------------------++optimiseMult :: Monoid (Matrix t) => [Matrix t] -> Matrix t+optimiseMult = mconcat++--------------------------------------------------------------------------------+++{- | Compute mean vector and covariance matrix of the rows of a matrix.++>>> meanCov $ gaussianSample 666 1000 (fromList[4,5]) (trustSym $ diagl [2,3])+([3.9933155655086696,5.061409102770331],Herm (2><2)+ [ 1.9963242906624408, -4.227815571404954e-2+ , -4.227815571404954e-2, 3.2003833097832857 ])+it :: (Vector Double, Herm Double)+-}+meanCov :: Matrix Double -> (Vector Double, Herm Double)+meanCov x = (med,cov) where+ r = rows x+ k = 1 / fromIntegral r+ med = konst k r `vXm` x+ meds = konst 1 r `outer` med+ xc = x `sub` meds+ cov = scale (recip (fromIntegral (r-1))) (mTm xc)++--------------------------------------------------------------------------------++sortVector :: (Ord t, Element t) => Vector t -> Vector t+sortVector = sortV++{- |++>>> m <- randn 4 10+>>> disp 2 m+4x10+-0.31 0.41 0.43 -0.19 -0.17 -0.23 -0.17 -1.04 -0.07 -1.24+ 0.26 0.19 0.14 0.83 -1.54 -0.09 0.37 -0.63 0.71 -0.50+-0.11 -0.10 -1.29 -1.40 -1.04 -0.89 -0.68 0.35 -1.46 1.86+ 1.04 -0.29 0.19 -0.75 -2.20 -0.01 1.06 0.11 -2.09 -1.58++>>> disp 2 $ m ?? (All, Pos $ sortIndex (m!1))+4x10+-0.17 -1.04 -1.24 -0.23 0.43 0.41 -0.31 -0.17 -0.07 -0.19+-1.54 -0.63 -0.50 -0.09 0.14 0.19 0.26 0.37 0.71 0.83+-1.04 0.35 1.86 -0.89 -1.29 -0.10 -0.11 -0.68 -1.46 -1.40+-2.20 0.11 -1.58 -0.01 0.19 -0.29 1.04 1.06 -2.09 -0.75++-}+sortIndex :: (Ord t, Element t) => Vector t -> Vector I+sortIndex = sortI++ccompare :: (Ord t, Container c t) => c t -> c t -> c I+ccompare = ccompare'++cselect :: (Container c t) => c I -> c t -> c t -> c t -> c t+cselect = cselect'++{- | Extract elements from positions given in matrices of rows and columns.++>>> r+(3><3)+ [ 1, 1, 1+ , 1, 2, 2+ , 1, 2, 3 ]+>>> c+(3><3)+ [ 0, 1, 5+ , 2, 2, 1+ , 4, 4, 1 ]+>>> m+(4><6)+ [ 0, 1, 2, 3, 4, 5+ , 6, 7, 8, 9, 10, 11+ , 12, 13, 14, 15, 16, 17+ , 18, 19, 20, 21, 22, 23 ]++>>> remap r c m+(3><3)+ [ 6, 7, 11+ , 8, 14, 13+ , 10, 16, 19 ]++The indexes are autoconformable.++>>> c'+(3><1)+ [ 1+ , 2+ , 4 ]+>>> remap r c' m+(3><3)+ [ 7, 7, 7+ , 8, 14, 14+ , 10, 16, 22 ]++-}+remap :: Element t => Matrix I -> Matrix I -> Matrix t -> Matrix t+remap i j m+ | minElement i >= 0 && maxElement i < fromIntegral (rows m) &&+ minElement j >= 0 && maxElement j < fromIntegral (cols m) = remapM i' j' m+ | otherwise = error $ "out of range index in remap"+ where+ [i',j'] = conformMs [i,j]
+ src/Internal/Conversion.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.Conversion+-- Copyright : (c) Alberto Ruiz 2010+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Conversion routines+--+-----------------------------------------------------------------------------+++module Internal.Conversion (+ Complexable(..), RealElement,+ module Data.Complex+) where++import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import Data.Complex+import Control.Arrow((***))++-------------------------------------------------------------------++-- | Supported single-double precision type pairs+class (Element s, Element d) => Precision s d | s -> d, d -> s where+ double2FloatG :: Vector d -> Vector s+ float2DoubleG :: Vector s -> Vector d++instance Precision Float Double where+ double2FloatG = double2FloatV+ float2DoubleG = float2DoubleV++instance Precision (Complex Float) (Complex Double) where+ double2FloatG = asComplex . double2FloatV . asReal+ float2DoubleG = asComplex . float2DoubleV . asReal++instance Precision I Z where+ double2FloatG = long2intV+ float2DoubleG = int2longV+++-- | Supported real types+class (Element t, Element (Complex t), RealFloat t)+ => RealElement t++instance RealElement Double+instance RealElement Float+++-- | Structures that may contain complex numbers+class Complexable c where+ toComplex' :: (RealElement e) => (c e, c e) -> c (Complex e)+ fromComplex' :: (RealElement e) => c (Complex e) -> (c e, c e)+ comp' :: (RealElement e) => c e -> c (Complex e)+ single' :: Precision a b => c b -> c a+ double' :: Precision a b => c a -> c b+++instance Complexable Vector where+ toComplex' = toComplexV+ fromComplex' = fromComplexV+ comp' v = toComplex' (v,constantD 0 (dim v))+ single' = double2FloatG+ double' = float2DoubleG+++-- | creates a complex vector from vectors with real and imaginary parts+toComplexV :: (RealElement a) => (Vector a, Vector a) -> Vector (Complex a)+toComplexV (r,i) = asComplex $ flatten $ fromColumns [r,i]++-- | the inverse of 'toComplex'+fromComplexV :: (RealElement a) => Vector (Complex a) -> (Vector a, Vector a)+fromComplexV z = (r,i) where+ [r,i] = toColumns $ reshape 2 $ asReal z+++instance Complexable Matrix where+ toComplex' = uncurry $ liftMatrix2 $ curry toComplex'+ fromComplex' z = (reshape c *** reshape c) . fromComplex' . flatten $ z+ where c = cols z+ comp' = liftMatrix comp'+ single' = liftMatrix single'+ double' = liftMatrix double'+
+ src/Internal/Convolution.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+{- |+Module : Internal.Convolution+Copyright : (c) Alberto Ruiz 2012+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++-}+-----------------------------------------------------------------------------+{-# OPTIONS_HADDOCK hide #-}++module Internal.Convolution(+ corr, conv, corrMin,+ corr2, conv2, separable+) where++import qualified Data.Vector.Storable as SV+import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import Internal.Element+import Internal.Conversion+import Internal.Container+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+++vectSS :: Element t => Int -> Vector t -> Matrix t+vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ]+++corr+ :: (Container Vector t, Product t)+ => Vector t -- ^ kernel+ -> Vector t -- ^ source+ -> Vector t+{- ^ correlation++>>> corr (fromList[1,2,3]) (fromList [1..10])+[14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0]+it :: (Enum t, Product t, Container Vector t) => Vector t++-}+corr ker v+ | dim ker == 0 = konst 0 (dim v)+ | dim ker <= dim v = vectSS (dim ker) v <> ker+ | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")"+++conv :: (Container Vector t, Product t, Num t) => Vector t -> Vector t -> Vector t+{- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product)++>>> conv (fromList[1,1]) (fromList [-1,1])+[-1.0,0.0,1.0]+it :: (Product t, Container Vector t) => Vector t++-}+conv ker v+ | dim ker == 0 = konst 0 (dim v)+ | otherwise = corr ker' v'+ where+ ker' = SV.reverse ker+ v' = vjoin [z,v,z]+ z = konst 0 (dim ker -1)++corrMin :: (Container Vector t, RealElement t, Product t)+ => Vector t+ -> Vector t+ -> Vector t+-- ^ similar to 'corr', using 'min' instead of (*)+corrMin ker v+ | dim ker == 0 = error "corrMin: empty kernel"+ | otherwise = minEvery ss (asRow ker) <> ones+ where+ minEvery a b = cond a b a a b+ ss = vectSS (dim ker) v+ ones = konst 1 (dim ker)++++matSS :: Element t => Int -> Matrix t -> [Matrix t]+matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ]+ where+ v = flatten m+ c = cols m+ r = rows m+ n = dr*c+++{- | 2D correlation (without padding)++>>> disp 5 $ corr2 (konst 1 (3,3)) (ident 10 :: Matrix Double)+8x8+3 2 1 0 0 0 0 0+2 3 2 1 0 0 0 0+1 2 3 2 1 0 0 0+0 1 2 3 2 1 0 0+0 0 1 2 3 2 1 0+0 0 0 1 2 3 2 1+0 0 0 0 1 2 3 2+0 0 0 0 0 1 2 3++-}+corr2 :: Product a => Matrix a -> Matrix a -> Matrix a+corr2 ker mat = dims+ . concatMap (map (udot ker' . flatten) . matSS c . trans)+ . matSS r $ mat+ where+ r = rows ker+ c = cols ker+ ker' = flatten (trans ker)+ rr = rows mat - r + 1+ rc = cols mat - c + 1+ dims | rr > 0 && rc > 0 = (rr >< rc)+ | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")"+ sz m = show (rows m)++"x"++show (cols m)+-- TODO check empty kernel++{- | 2D convolution++>>> disp 5 $ conv2 (konst 1 (3,3)) (ident 10 :: Matrix Double)+12x12+1 1 1 0 0 0 0 0 0 0 0 0+1 2 2 1 0 0 0 0 0 0 0 0+1 2 3 2 1 0 0 0 0 0 0 0+0 1 2 3 2 1 0 0 0 0 0 0+0 0 1 2 3 2 1 0 0 0 0 0+0 0 0 1 2 3 2 1 0 0 0 0+0 0 0 0 1 2 3 2 1 0 0 0+0 0 0 0 0 1 2 3 2 1 0 0+0 0 0 0 0 0 1 2 3 2 1 0+0 0 0 0 0 0 0 1 2 3 2 1+0 0 0 0 0 0 0 0 1 2 2 1+0 0 0 0 0 0 0 0 0 1 1 1++-}+conv2+ :: (Num (Matrix a), Product a, Container Vector a)+ => Matrix a -- ^ kernel+ -> Matrix a -> Matrix a+conv2 k m+ | empty = konst 0 (rows m + r -1, cols m + c -1)+ | otherwise = corr2 (fliprl . flipud $ k) padded+ where+ padded = fromBlocks [[z,0,0]+ ,[0,m,0]+ ,[0,0,z]]+ r = rows k+ c = cols k+ z = konst 0 (r-1,c-1)+ empty = r == 0 || c == 0+++separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t+-- ^ matrix computation implemented as separated vector operations by rows and columns.+separable f = fromColumns . map f . toColumns . fromRows . map f . toRows+
+ src/Internal/Devel.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Internal.Devel+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--++module Internal.Devel where+++import Control.Monad ( when )+import Foreign.C.Types ( CInt )+--import Foreign.Storable.Complex ()+import Foreign.Ptr(Ptr)+import Control.Exception (SomeException, SomeAsyncException (..))+import qualified Control.Exception as Exception+import Internal.Vector(Vector,avec)+import Foreign.Storable(Storable)++-- | postfix function application (@flip ($)@)+(//) :: x -> (x -> y) -> y+infixl 0 //+(//) = flip ($)+++-- GSL error codes are <= 1024+-- | error codes for the auxiliary functions required by the wrappers+errorCode :: CInt -> String+errorCode 2000 = "bad size"+errorCode 2001 = "bad function code"+errorCode 2002 = "memory problem"+errorCode 2003 = "bad file"+errorCode 2004 = "singular"+errorCode 2005 = "didn't converge"+errorCode 2006 = "the input matrix is not positive definite"+errorCode 2007 = "not yet supported in this OS"+errorCode n = "code "++show n+++-- | clear the fpu+foreign import ccall unsafe "asm_finit" finit :: IO ()++-- | check the error code+check :: String -> IO CInt -> IO ()+check msg f = do+-- finit+ err <- f+ when (err/=0) $ error (msg++": "++errorCode err)+ return ()+++-- | postfix error code check+infixl 0 #|+(#|) :: IO CInt -> String -> IO ()+(#|) = flip check++-- | Error capture and conversion to Maybe+mbCatch :: IO x -> IO (Maybe x)+mbCatch act =+ hush <$>+ Exception.tryJust+ (\e -> if isSyncException e then Just e else Nothing)+ act++ where+ hush :: Either a b -> Maybe b+ hush = either (const Nothing) Just++ isSyncException :: SomeException -> Bool+ isSyncException e =+ case Exception.fromException e of+ Just (SomeAsyncException _) -> False+ Nothing -> True++--------------------------------------------------------------------------------++type CM b r = CInt -> CInt -> Ptr b -> r+type CV b r = CInt -> Ptr b -> r+type OM b r = CInt -> CInt -> CInt -> CInt -> Ptr b -> r++type CIdxs r = CV CInt r+type Ok = IO CInt++infixr 5 :>, ::>, ..>+type (:>) t r = CV t r+type (::>) t r = OM t r+type (..>) t r = CM t r++class TransArray c+ where+ type Trans c b+ type TransRaw c b+ apply :: c -> (b -> IO r) -> (Trans c b) -> IO r+ applyRaw :: c -> (b -> IO r) -> (TransRaw c b) -> IO r+ infixl 1 `apply`, `applyRaw`++instance Storable t => TransArray (Vector t)+ where+ type Trans (Vector t) b = CInt -> Ptr t -> b+ type TransRaw (Vector t) b = CInt -> Ptr t -> b+ apply = avec+ {-# INLINE apply #-}+ applyRaw = avec+ {-# INLINE applyRaw #-}
+ src/Internal/Element.hs view
@@ -0,0 +1,617 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Packed.Matrix+-- Copyright : (c) Alberto Ruiz 2007-10+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- A Matrix representation suitable for numerical computations using LAPACK and GSL.+--+-- This module provides basic functions for manipulation of structure.++-----------------------------------------------------------------------------++module Internal.Element where++import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import qualified Internal.ST as ST+import Data.Array+import Text.Printf+import Data.List(transpose,intersperse)+import Data.List.Split(chunksOf)+import Foreign.Storable(Storable)+import System.IO.Unsafe(unsafePerformIO)+import Control.Monad(liftM)+import Foreign.C.Types(CInt)++-------------------------------------------------------------------+++import Data.Binary++instance (Binary a, Element a) => Binary (Matrix a) where+ put m = do+ put (cols m)+ put (flatten m)+ get = do+ c <- get+ v <- get+ return (reshape c v)+++-------------------------------------------------------------------++instance (Show a, Element a) => (Show (Matrix a)) where+ show m | rows m == 0 || cols m == 0 = sizes m ++" []"+ show m = (sizes m++) . dsp . map (map show) . toLists $ m++sizes :: Matrix t -> [Char]+sizes m = "("++show (rows m)++"><"++show (cols m)++")\n"++dsp :: [[[Char]]] -> [Char]+dsp as = (++" ]") . (" ["++) . init . drop 2 . unlines . map (" , "++) . map unwords' $ transpose mtp+ where+ mt = transpose as+ longs = map (maximum . map length) mt+ mtp = zipWith (\a b -> map (pad a) b) longs mt+ pad n str = replicate (n - length str) ' ' ++ str+ unwords' = concat . intersperse ", "++------------------------------------------------------------------++instance (Element a, Read a) => Read (Matrix a) where+ readsPrec _ s = [((rs><cs) . read $ listnums, rest)]+ where (thing,rest) = breakAt ']' s+ (dims,listnums) = breakAt ')' thing+ cs = read . init . fst. breakAt ')' . snd . breakAt '<' $ dims+ rs = read . snd . breakAt '(' .init . fst . breakAt '>' $ dims+++breakAt :: Eq a => a -> [a] -> ([a], [a])+breakAt c l = (a++[c],tail b) where+ (a,b) = break (==c) l++--------------------------------------------------------------------------------+-- | Specification of indexes for the operator '??'.+data Extractor+ = All+ | Range Int Int Int+ | Pos (Vector I)+ | PosCyc (Vector I)+ | Take Int+ | TakeLast Int+ | Drop Int+ | DropLast Int+ deriving Show++ppext :: Extractor -> [Char]+ppext All = ":"+ppext (Range a 1 c) = printf "%d:%d" a c+ppext (Range a b c) = printf "%d:%d:%d" a b c+ppext (Pos v) = show (toList v)+ppext (PosCyc v) = "Cyclic"++show (toList v)+ppext (Take n) = printf "Take %d" n+ppext (Drop n) = printf "Drop %d" n+ppext (TakeLast n) = printf "TakeLast %d" n+ppext (DropLast n) = printf "DropLast %d" n++{- | General matrix slicing.++>>> m+(4><5)+ [ 0, 1, 2, 3, 4+ , 5, 6, 7, 8, 9+ , 10, 11, 12, 13, 14+ , 15, 16, 17, 18, 19 ]++>>> m ?? (Take 3, DropLast 2)+(3><3)+ [ 0, 1, 2+ , 5, 6, 7+ , 10, 11, 12 ]++>>> m ?? (Pos (idxs[2,1]), All)+(2><5)+ [ 10, 11, 12, 13, 14+ , 5, 6, 7, 8, 9 ]++>>> m ?? (PosCyc (idxs[-7,80]), Range 4 (-2) 0)+(2><3)+ [ 9, 7, 5+ , 4, 2, 0 ]++-}+infixl 9 ??+(??) :: Element t => Matrix t -> (Extractor,Extractor) -> Matrix t++minEl :: Vector CInt -> CInt+minEl = toScalarI Min+maxEl :: Vector CInt -> CInt+maxEl = toScalarI Max+cmodi :: Foreign.C.Types.CInt -> Vector Foreign.C.Types.CInt -> Vector Foreign.C.Types.CInt+cmodi = vectorMapValI ModVS++extractError :: Matrix t1 -> (Extractor, Extractor) -> t+extractError m (e1,e2)= error $ printf "can't extract (%s,%s) from matrix %dx%d" (ppext e1::String) (ppext e2::String) (rows m) (cols m)++m ?? (Range a s b,e) | s /= 1 = m ?? (Pos (idxs [a,a+s .. b]), e)+m ?? (e,Range a s b) | s /= 1 = m ?? (e, Pos (idxs [a,a+s .. b]))++m ?? e@(Range a _ b,_) | a < 0 || b >= rows m = extractError m e+m ?? e@(_,Range a _ b) | a < 0 || b >= cols m = extractError m e++m ?? e@(Pos vs,_) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (rows m)) = extractError m e+m ?? e@(_,Pos vs) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (cols m)) = extractError m e++m ?? (All,All) = m++m ?? (Range a _ b,e) | a > b = m ?? (Take 0,e)+m ?? (e,Range a _ b) | a > b = m ?? (e,Take 0)++m ?? (Take n,e)+ | n <= 0 = (0><cols m) [] ?? (All,e)+ | n >= rows m = m ?? (All,e)++m ?? (e,Take n)+ | n <= 0 = (rows m><0) [] ?? (e,All)+ | n >= cols m = m ?? (e,All)++m ?? (Drop n,e)+ | n <= 0 = m ?? (All,e)+ | n >= rows m = (0><cols m) [] ?? (All,e)++m ?? (e,Drop n)+ | n <= 0 = m ?? (e,All)+ | n >= cols m = (rows m><0) [] ?? (e,All)++m ?? (TakeLast n, e) = m ?? (Drop (rows m - n), e)+m ?? (e, TakeLast n) = m ?? (e, Drop (cols m - n))++m ?? (DropLast n, e) = m ?? (Take (rows m - n), e)+m ?? (e, DropLast n) = m ?? (e, Take (cols m - n))++m ?? (er,ec) = unsafePerformIO $ extractR (orderOf m) m moder rs modec cs+ where+ (moder,rs) = mkExt (rows m) er+ (modec,cs) = mkExt (cols m) ec+ ran a b = (0, idxs [a,b])+ pos ks = (1, ks)+ mkExt _ (Pos ks) = pos ks+ mkExt n (PosCyc ks)+ | n == 0 = mkExt n (Take 0)+ | otherwise = pos (cmodi (fi n) ks)+ mkExt _ (Range mn _ mx) = ran mn mx+ mkExt _ (Take k) = ran 0 (k-1)+ mkExt n (Drop k) = ran k (n-1)+ mkExt n _ = ran 0 (n-1) -- All++--------------------------------------------------------------------------------++-- | obtains the common value of a property of a list+common :: (Eq a) => (b->a) -> [b] -> Maybe a+common f = commonval . map f+ where+ commonval :: (Eq a) => [a] -> Maybe a+ commonval [] = Nothing+ commonval [a] = Just a+ commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing+++-- | creates a matrix from a vertical list of matrices+joinVert :: Element t => [Matrix t] -> Matrix t+joinVert [] = emptyM 0 0+joinVert ms = case common cols ms of+ Nothing -> error "(impossible) joinVert on matrices with different number of columns"+ Just c -> matrixFromVector RowMajor (sum (map rows ms)) c $ vjoin (map flatten ms)++-- | creates a matrix from a horizontal list of matrices+joinHoriz :: Element t => [Matrix t] -> Matrix t+joinHoriz ms = trans. joinVert . map trans $ ms++{- | Create a matrix from blocks given as a list of lists of matrices.++Single row-column components are automatically expanded to match the+corresponding common row and column:++@+disp = putStr . dispf 2+@++>>> disp $ fromBlocks [[ident 5, 7, row[10,20]], [3, diagl[1,2,3], 0]]+8x10+1 0 0 0 0 7 7 7 10 20+0 1 0 0 0 7 7 7 10 20+0 0 1 0 0 7 7 7 10 20+0 0 0 1 0 7 7 7 10 20+0 0 0 0 1 7 7 7 10 20+3 3 3 3 3 1 0 0 0 0+3 3 3 3 3 0 2 0 0 0+3 3 3 3 3 0 0 3 0 0++-}+fromBlocks :: Element t => [[Matrix t]] -> Matrix t+fromBlocks = fromBlocksRaw . adaptBlocks++fromBlocksRaw :: Element t => [[Matrix t]] -> Matrix t+fromBlocksRaw mms = joinVert . map joinHoriz $ mms++adaptBlocks :: Element t => [[Matrix t]] -> [[Matrix t]]+adaptBlocks ms = ms' where+ bc = case common length ms of+ Just c -> c+ Nothing -> error "fromBlocks requires rectangular [[Matrix]]"+ rs = map (compatdim . map rows) ms+ cs = map (compatdim . map cols) (transpose ms)+ szs = sequence [rs,cs]+ ms' = chunksOf bc $ zipWith g szs (concat ms)++ g [Just nr,Just nc] m+ | nr == r && nc == c = m+ | r == 1 && c == 1 = matrixFromVector RowMajor nr nc (constantD x (nr*nc))+ | r == 1 = fromRows (replicate nr (flatten m))+ | otherwise = fromColumns (replicate nc (flatten m))+ where+ r = rows m+ c = cols m+ x = m@@>(0,0)+ g _ _ = error "inconsistent dimensions in fromBlocks"+++--------------------------------------------------------------------------------++{- | create a block diagonal matrix++>>> disp 2 $ diagBlock [konst 1 (2,2), konst 2 (3,5), col [5,7]]+7x8+1 1 0 0 0 0 0 0+1 1 0 0 0 0 0 0+0 0 2 2 2 2 2 0+0 0 2 2 2 2 2 0+0 0 2 2 2 2 2 0+0 0 0 0 0 0 0 5+0 0 0 0 0 0 0 7++>>> diagBlock [(0><4)[], konst 2 (2,3)] :: Matrix Double+(2><7)+ [ 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0+ , 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0 ]++-}+diagBlock :: (Element t, Num t) => [Matrix t] -> Matrix t+diagBlock ms = fromBlocks $ zipWith f ms [0..]+ where+ f m k = take n $ replicate k z ++ m : repeat z+ n = length ms+ z = (1><1) [0]++--------------------------------------------------------------------------------+++-- | Reverse rows+flipud :: Element t => Matrix t -> Matrix t+flipud m = extractRows [r-1,r-2 .. 0] $ m+ where+ r = rows m++-- | Reverse columns+fliprl :: Element t => Matrix t -> Matrix t+fliprl m = extractColumns [c-1,c-2 .. 0] $ m+ where+ c = cols m++------------------------------------------------------------++{- | creates a rectangular diagonal matrix:++>>> diagRect 7 (fromList [10,20,30]) 4 5 :: Matrix Double+(4><5)+ [ 10.0, 7.0, 7.0, 7.0, 7.0+ , 7.0, 20.0, 7.0, 7.0, 7.0+ , 7.0, 7.0, 30.0, 7.0, 7.0+ , 7.0, 7.0, 7.0, 7.0, 7.0 ]++-}+diagRect :: (Storable t) => t -> Vector t -> Int -> Int -> Matrix t+diagRect z v r c = ST.runSTMatrix $ do+ m <- ST.newMatrix z r c+ let d = min r c `min` (dim v)+ mapM_ (\k -> ST.writeMatrix m k k (v@>k)) [0..d-1]+ return m++-- | extracts the diagonal from a rectangular matrix+takeDiag :: (Element t) => Matrix t -> Vector t+takeDiag m = fromList [flatten m @> (k*cols m+k) | k <- [0 .. min (rows m) (cols m) -1]]++------------------------------------------------------------++{- | Create a matrix from a list of elements++>>> (2><3) [2, 4, 7+2*iC, -3, 11, 0]+(2><3)+ [ 2.0 :+ 0.0, 4.0 :+ 0.0, 7.0 :+ 2.0+ , (-3.0) :+ (-0.0), 11.0 :+ 0.0, 0.0 :+ 0.0 ]++The input list is explicitly truncated, so that it can+safely be used with lists that are too long (like infinite lists).++>>> (2><3)[1..]+(2><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0 ]++This is the format produced by the instances of Show (Matrix a), which+can also be used for input.++-}+(><) :: (Storable a) => Int -> Int -> [a] -> Matrix a+r >< c = f where+ f l | dim v == r*c = matrixFromVector RowMajor r c v+ | otherwise = error $ "inconsistent list size = "+ ++show (dim v) ++" in ("++show r++"><"++show c++")"+ where v = fromList $ take (r*c) l++----------------------------------------------------------------++takeRows :: Element t => Int -> Matrix t -> Matrix t+takeRows n mt = subMatrix (0,0) (n, cols mt) mt++-- | Creates a matrix with the last n rows of another matrix+takeLastRows :: Element t => Int -> Matrix t -> Matrix t+takeLastRows n mt = subMatrix (rows mt - n, 0) (n, cols mt) mt++dropRows :: Element t => Int -> Matrix t -> Matrix t+dropRows n mt = subMatrix (n,0) (rows mt - n, cols mt) mt++-- | Creates a copy of a matrix without the last n rows+dropLastRows :: Element t => Int -> Matrix t -> Matrix t+dropLastRows n mt = subMatrix (0,0) (rows mt - n, cols mt) mt++takeColumns :: Element t => Int -> Matrix t -> Matrix t+takeColumns n mt = subMatrix (0,0) (rows mt, n) mt++-- |Creates a matrix with the last n columns of another matrix+takeLastColumns :: Element t => Int -> Matrix t -> Matrix t+takeLastColumns n mt = subMatrix (0, cols mt - n) (rows mt, n) mt++dropColumns :: Element t => Int -> Matrix t -> Matrix t+dropColumns n mt = subMatrix (0,n) (rows mt, cols mt - n) mt++-- | Creates a copy of a matrix without the last n columns+dropLastColumns :: Element t => Int -> Matrix t -> Matrix t+dropLastColumns n mt = subMatrix (0,0) (rows mt, cols mt - n) mt++----------------------------------------------------------------++{- | Creates a 'Matrix' from a list of lists (considered as rows).++>>> fromLists [[1,2],[3,4],[5,6]]+(3><2)+ [ 1.0, 2.0+ , 3.0, 4.0+ , 5.0, 6.0 ]++-}+fromLists :: Element t => [[t]] -> Matrix t+fromLists = fromRows . map fromList++-- | creates a 1-row matrix from a vector+--+-- >>> asRow (fromList [1..5])+-- (1><5)+-- [ 1.0, 2.0, 3.0, 4.0, 5.0 ]+--+asRow :: Storable a => Vector a -> Matrix a+asRow = trans . asColumn++-- | creates a 1-column matrix from a vector+--+-- >>> asColumn (fromList [1..5])+-- (5><1)+-- [ 1.0+-- , 2.0+-- , 3.0+-- , 4.0+-- , 5.0 ]+--+asColumn :: Storable a => Vector a -> Matrix a+asColumn v = reshape 1 v++++{- | creates a Matrix of the specified size using the supplied function to+ to map the row\/column position to the value at that row\/column position.++@> buildMatrix 3 4 (\\(r,c) -> fromIntegral r * fromIntegral c)+(3><4)+ [ 0.0, 0.0, 0.0, 0.0, 0.0+ , 0.0, 1.0, 2.0, 3.0, 4.0+ , 0.0, 2.0, 4.0, 6.0, 8.0]@++Hilbert matrix of order N:++@hilb n = buildMatrix n n (\\(i,j)->1/(fromIntegral i + fromIntegral j +1))@++-}+buildMatrix :: Element a => Int -> Int -> ((Int, Int) -> a) -> Matrix a+buildMatrix rc cc f =+ fromLists $ map (map f)+ $ map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)]++-----------------------------------------------------++fromArray2D :: (Storable e) => Array (Int, Int) e -> Matrix e+fromArray2D m = (r><c) (elems m)+ where ((r0,c0),(r1,c1)) = bounds m+ r = r1-r0+1+ c = c1-c0+1+++-- | rearranges the rows of a matrix according to the order given in a list of integers.+extractRows :: Element t => [Int] -> Matrix t -> Matrix t+extractRows l m = m ?? (Pos (idxs l), All)++-- | rearranges the rows of a matrix according to the order given in a list of integers.+extractColumns :: Element t => [Int] -> Matrix t -> Matrix t+extractColumns l m = m ?? (All, Pos (idxs l))+++{- | creates matrix by repetition of a matrix a given number of rows and columns++>>> repmat (ident 2) 2 3+(4><6)+ [ 1.0, 0.0, 1.0, 0.0, 1.0, 0.0+ , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0+ , 1.0, 0.0, 1.0, 0.0, 1.0, 0.0+ , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 ]++-}+repmat :: (Element t) => Matrix t -> Int -> Int -> Matrix t+repmat m r c+ | r == 0 || c == 0 = emptyM (r*rows m) (c*cols m)+ | otherwise = fromBlocks $ replicate r $ replicate c $ m++-- | A version of 'liftMatrix2' which automatically adapt matrices with a single row or column to match the dimensions of the other matrix.+liftMatrix2Auto :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t+liftMatrix2Auto f m1 m2+ | compat' m1 m2 = lM f m1 m2+ | ok = lM f m1' m2'+ | otherwise = error $ "nonconformable matrices in liftMatrix2Auto: " ++ shSize m1 ++ ", " ++ shSize m2+ where+ (r1,c1) = size m1+ (r2,c2) = size m2+ r = max r1 r2+ c = max c1 c2+ r0 = min r1 r2+ c0 = min c1 c2+ ok = r0 == 1 || r1 == r2 && c0 == 1 || c1 == c2+ m1' = conformMTo (r,c) m1+ m2' = conformMTo (r,c) m2++-- FIXME do not flatten if equal order+lM :: (Storable t, Element t1, Element t2)+ => (Vector t1 -> Vector t2 -> Vector t)+ -> Matrix t1 -> Matrix t2 -> Matrix t+lM f m1 m2 = matrixFromVector+ RowMajor+ (max' (rows m1) (rows m2))+ (max' (cols m1) (cols m2))+ (f (flatten m1) (flatten m2))+ where+ max' 1 b = b+ max' a 1 = a+ max' a b = max a b++compat' :: Matrix a -> Matrix b -> Bool+compat' m1 m2 = s1 == (1,1) || s2 == (1,1) || s1 == s2+ where+ s1 = size m1+ s2 = size m2++------------------------------------------------------------++toBlockRows :: Element t => [Int] -> Matrix t -> [Matrix t]+toBlockRows [r] m+ | r == rows m = [m]+toBlockRows rs m+ | cols m > 0 = map (reshape (cols m)) (takesV szs (flatten m))+ | otherwise = map g rs+ where+ szs = map (* cols m) rs+ g k = (k><0)[]++toBlockCols :: Element t => [Int] -> Matrix t -> [Matrix t]+toBlockCols [c] m | c == cols m = [m]+toBlockCols cs m = map trans . toBlockRows cs . trans $ m++-- | Partition a matrix into blocks with the given numbers of rows and columns.+-- The remaining rows and columns are discarded.+toBlocks :: (Element t) => [Int] -> [Int] -> Matrix t -> [[Matrix t]]+toBlocks rs cs m+ | ok = map (toBlockCols cs) . toBlockRows rs $ m+ | otherwise = error $ "toBlocks: bad partition: "++show rs++" "++show cs+ ++ " "++shSize m+ where+ ok = sum rs <= rows m && sum cs <= cols m && all (>=0) rs && all (>=0) cs++-- | Fully partition a matrix into blocks of the same size. If the dimensions are not+-- a multiple of the given size the last blocks will be smaller.+toBlocksEvery :: (Element t) => Int -> Int -> Matrix t -> [[Matrix t]]+toBlocksEvery r c m+ | r < 1 || c < 1 = error $ "toBlocksEvery expects block sizes > 0, given "++show r++" and "++ show c+ | otherwise = toBlocks rs cs m+ where+ (qr,rr) = rows m `divMod` r+ (qc,rc) = cols m `divMod` c+ rs = replicate qr r ++ if rr > 0 then [rr] else []+ cs = replicate qc c ++ if rc > 0 then [rc] else []++-------------------------------------------------------------------++-- Given a column number and a function taking matrix indexes, returns+-- a function which takes vector indexes (that can be used on the+-- flattened matrix).+mk :: Int -> ((Int, Int) -> t) -> (Int -> t)+mk c g = \k -> g (divMod k c)++{- |++>>> mapMatrixWithIndexM_ (\(i,j) v -> printf "m[%d,%d] = %.f\n" i j v :: IO()) ((2><3)[1 :: Double ..])+m[0,0] = 1+m[0,1] = 2+m[0,2] = 3+m[1,0] = 4+m[1,1] = 5+m[1,2] = 6++-}+mapMatrixWithIndexM_+ :: (Element a, Num a, Monad m) =>+ ((Int, Int) -> a -> m ()) -> Matrix a -> m ()+mapMatrixWithIndexM_ g m = mapVectorWithIndexM_ (mk c g) . flatten $ m+ where+ c = cols m++{- |++>>> mapMatrixWithIndexM (\(i,j) v -> Just $ 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double)+Just (3><3)+ [ 100.0, 1.0, 2.0+ , 10.0, 111.0, 12.0+ , 20.0, 21.0, 122.0 ]++-}+mapMatrixWithIndexM+ :: (Element a, Storable b, Monad m) =>+ ((Int, Int) -> a -> m b) -> Matrix a -> m (Matrix b)+mapMatrixWithIndexM g m = liftM (reshape c) . mapVectorWithIndexM (mk c g) . flatten $ m+ where+ c = cols m++{- |++>>> mapMatrixWithIndex (\(i,j) v -> 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double)+(3><3)+ [ 100.0, 1.0, 2.0+ , 10.0, 111.0, 12.0+ , 20.0, 21.0, 122.0 ]++ -}+mapMatrixWithIndex+ :: (Element a, Storable b) =>+ ((Int, Int) -> a -> b) -> Matrix a -> Matrix b+mapMatrixWithIndex g m = reshape c . mapVectorWithIndex (mk c g) . flatten $ m+ where+ c = cols m++mapMatrix :: (Element a, Element b) => (a -> b) -> Matrix a -> Matrix b+mapMatrix f = liftMatrix (mapVector f)
+ src/Internal/IO.hs view
@@ -0,0 +1,183 @@+-----------------------------------------------------------------------------+-- |+-- Module : Internal.IO+-- Copyright : (c) Alberto Ruiz 2010+-- License : BSD3+--+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Display, formatting and IO functions for numeric 'Vector' and 'Matrix'+--+-----------------------------------------------------------------------------++module Internal.IO (+ dispf, disps, dispcf, vecdisp, latexFormat, format,+ loadMatrix, loadMatrix', saveMatrix+) where++import Internal.Devel+import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import Text.Printf(printf, PrintfArg, PrintfType)+import Data.List(intersperse,transpose)+import Data.Complex+++-- | Formatting tool+table :: String -> [[String]] -> String+table sep as = unlines . map unwords' $ transpose mtp+ where+ mt = transpose as+ longs = map (maximum . map length) mt+ mtp = zipWith (\a b -> map (pad a) b) longs mt+ pad n str = replicate (n - length str) ' ' ++ str+ unwords' = concat . intersperse sep++++{- | Creates a string from a matrix given a separator and a function to show each entry. Using+this function the user can easily define any desired display function:++@import Text.Printf(printf)@++@disp = putStr . format \" \" (printf \"%.2f\")@++-}+format :: (Element t) => String -> (t -> String) -> Matrix t -> String+format sep f m = table sep . map (map f) . toLists $ m++{- | Show a matrix with \"autoscaling\" and a given number of decimal places.++>>> putStr . disps 2 $ 120 * (3><4) [1..]+3x4 E3+ 0.12 0.24 0.36 0.48+ 0.60 0.72 0.84 0.96+ 1.08 1.20 1.32 1.44++-}+disps :: Int -> Matrix Double -> String+disps d x = sdims x ++ " " ++ formatScaled d x++{- | Show a matrix with a given number of decimal places.++>>> dispf 2 (1/3 + ident 3)+"3x3\n1.33 0.33 0.33\n0.33 1.33 0.33\n0.33 0.33 1.33\n"++>>> putStr . dispf 2 $ (3><4)[1,1.5..]+3x4+1.00 1.50 2.00 2.50+3.00 3.50 4.00 4.50+5.00 5.50 6.00 6.50++>>> putStr . unlines . tail . lines . dispf 2 . asRow $ linspace 10 (0,1)+0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00++-}+dispf :: Int -> Matrix Double -> String+dispf d x = sdims x ++ "\n" ++ formatFixed (if isInt x then 0 else d) x++sdims :: Matrix t -> [Char]+sdims x = show (rows x) ++ "x" ++ show (cols x)++formatFixed :: (Show a, Text.Printf.PrintfArg t, Element t)+ => a -> Matrix t -> String+formatFixed d x = format " " (printf ("%."++show d++"f")) $ x++isInt :: Matrix Double -> Bool+isInt = all lookslikeInt . toList . flatten++formatScaled :: (Text.Printf.PrintfArg b, RealFrac b, Floating b, Num t, Element b, Show t)+ => t -> Matrix b -> [Char]+formatScaled dec t = "E"++show o++"\n" ++ ss+ where ss = format " " (printf fmt. g) t+ g x | o >= 0 = x/10^(o::Int)+ | otherwise = x*10^(-o)+ o | rows t == 0 || cols t == 0 = 0+ | otherwise = floor $ maximum $ map (logBase 10 . abs) $ toList $ flatten t+ fmt = '%':show (dec+3) ++ '.':show dec ++"f"++{- | Show a vector using a function for showing matrices.++>>> putStr . vecdisp (dispf 2) $ linspace 10 (0,1)+10 |> 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00++-}+vecdisp :: (Element t) => (Matrix t -> String) -> Vector t -> String+vecdisp f v+ = ((show (dim v) ++ " |> ") ++) . (++"\n")+ . unwords . lines . tail . dropWhile (not . (`elem` " \n"))+ . f . trans . reshape 1+ $ v++{- | Tool to display matrices with latex syntax.++>>> latexFormat "bmatrix" (dispf 2 $ ident 2)+"\\begin{bmatrix}\n1 & 0\n\\\\\n0 & 1\n\\end{bmatrix}"++-}+latexFormat :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc.+ -> String -- ^ Formatted matrix, with elements separated by spaces and newlines+ -> String+latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}"+ where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines++-- | Pretty print a complex number with at most n decimal digits.+showComplex :: Int -> Complex Double -> String+showComplex d (a:+b)+ | isZero a && isZero b = "0"+ | isZero b = sa+ | isZero a && isOne b = s2++"i"+ | isZero a = sb++"i"+ | isOne b = sa++s3++"i"+ | otherwise = sa++s1++sb++"i"+ where+ sa = shcr d a+ sb = shcr d b+ s1 = if b<0 then "" else "+"+ s2 = if b<0 then "-" else ""+ s3 = if b<0 then "-" else "+"++shcr :: (Show a, Show t1, Text.Printf.PrintfType t, Text.Printf.PrintfArg t1, RealFrac t1)+ => a -> t1 -> t+shcr d a | lookslikeInt a = printf "%.0f" a+ | otherwise = printf ("%."++show d++"f") a++lookslikeInt :: (Show a, RealFrac a) => a -> Bool+lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx+ where shx = show x++isZero :: Show a => a -> Bool+isZero x = show x `elem` ["0.0","-0.0"]+isOne :: Show a => a -> Bool+isOne x = show x `elem` ["1.0","-1.0"]++-- | Pretty print a complex matrix with at most n decimal digits.+dispcf :: Int -> Matrix (Complex Double) -> String+dispcf d m = sdims m ++ "\n" ++ format " " (showComplex d) m++--------------------------------------------------------------------++apparentCols :: FilePath -> IO Int+apparentCols s = f . dropWhile null . map words . lines <$> readFile s+ where+ f [] = 0+ f (x:_) = length x+++-- | load a matrix from an ASCII file formatted as a 2D table.+loadMatrix :: FilePath -> IO (Matrix Double)+loadMatrix f = do+ v <- vectorScan f+ c <- apparentCols f+ if (dim v `mod` c /= 0)+ then+ error $ printf "loadMatrix: %d elements and %d columns in file %s"+ (dim v) c f+ else+ return (reshape c v)++loadMatrix' :: FilePath -> IO (Maybe (Matrix Double))+loadMatrix' name = mbCatch (loadMatrix name)+
+ src/Internal/LAPACK.hs view
@@ -0,0 +1,758 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.LinearAlgebra.LAPACK+-- Copyright : (c) Alberto Ruiz 2006-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Functional interface to selected LAPACK functions (<http://www.netlib.org/lapack>).+--+-----------------------------------------------------------------------------+++module Internal.LAPACK where++import Data.Bifunctor (first)++import Internal.Devel+import Internal.Vector+import Internal.Matrix hiding ((#), (#!))+import Internal.Conversion+import Internal.Element+import Foreign.Ptr(nullPtr)+import Foreign.C.Types+import Control.Monad(when)+import System.IO.Unsafe(unsafePerformIO)++-----------------------------------------------------------------------------------++infixr 1 #+a # b = apply a b+{-# INLINE (#) #-}++a #! b = a # b # id+{-# INLINE (#!) #-}++-----------------------------------------------------------------------------------++type TMMM t = t ::> t ::> t ::> Ok++type F = Float+type Q = Complex Float++foreign import ccall unsafe "multiplyR" dgemmc :: CInt -> CInt -> TMMM R+foreign import ccall unsafe "multiplyC" zgemmc :: CInt -> CInt -> TMMM C+foreign import ccall unsafe "multiplyF" sgemmc :: CInt -> CInt -> TMMM F+foreign import ccall unsafe "multiplyQ" cgemmc :: CInt -> CInt -> TMMM Q+foreign import ccall unsafe "multiplyI" c_multiplyI :: I -> TMMM I+foreign import ccall unsafe "multiplyL" c_multiplyL :: Z -> TMMM Z++isT (rowOrder -> False) = 0+isT _ = 1++tt x@(rowOrder -> False) = x+tt x = trans x++multiplyAux f st a b = unsafePerformIO $ do+ when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "+++ show (rows a,cols a) ++ " x " ++ show (rows b, cols b)+ s <- createMatrix ColumnMajor (rows a) (cols b)+ ((tt a) # (tt b) #! s) (f (isT a) (isT b)) #| st+ return s++-- | Matrix product based on BLAS's /dgemm/.+multiplyR :: Matrix Double -> Matrix Double -> Matrix Double+multiplyR a b = {-# SCC "multiplyR" #-} multiplyAux dgemmc "dgemmc" a b++-- | Matrix product based on BLAS's /zgemm/.+multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+multiplyC a b = multiplyAux zgemmc "zgemmc" a b++-- | Matrix product based on BLAS's /sgemm/.+multiplyF :: Matrix Float -> Matrix Float -> Matrix Float+multiplyF a b = multiplyAux sgemmc "sgemmc" a b++-- | Matrix product based on BLAS's /cgemm/.+multiplyQ :: Matrix (Complex Float) -> Matrix (Complex Float) -> Matrix (Complex Float)+multiplyQ a b = multiplyAux cgemmc "cgemmc" a b++multiplyI :: I -> Matrix CInt -> Matrix CInt -> Matrix CInt+multiplyI m a b = unsafePerformIO $ do+ when (cols a /= rows b) $ error $+ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b+ s <- createMatrix ColumnMajor (rows a) (cols b)+ (a # b #! s) (c_multiplyI m) #|"c_multiplyI"+ return s++multiplyL :: Z -> Matrix Z -> Matrix Z -> Matrix Z+multiplyL m a b = unsafePerformIO $ do+ when (cols a /= rows b) $ error $+ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b+ s <- createMatrix ColumnMajor (rows a) (cols b)+ (a # b #! s) (c_multiplyL m) #|"c_multiplyL"+ return s++-----------------------------------------------------------------------------++type TSVD t = t ::> t ::> R :> t ::> Ok++foreign import ccall unsafe "svd_l_R" dgesvd :: TSVD R+foreign import ccall unsafe "svd_l_C" zgesvd :: TSVD C+foreign import ccall unsafe "svd_l_Rdd" dgesdd :: TSVD R+foreign import ccall unsafe "svd_l_Cdd" zgesdd :: TSVD C++-- | Full SVD of a real matrix using LAPACK's /dgesvd/.+svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+svdR = svdAux dgesvd "svdR"++-- | Full SVD of a real matrix using LAPACK's /dgesdd/.+svdRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+svdRd = svdAux dgesdd "svdRdd"++-- | Full SVD of a complex matrix using LAPACK's /zgesvd/.+svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+svdC = svdAux zgesvd "svdC"++-- | Full SVD of a complex matrix using LAPACK's /zgesdd/.+svdCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+svdCd = svdAux zgesdd "svdCdd"++svdAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ u <- createMatrix ColumnMajor r r+ s <- createVector (min r c)+ v <- createMatrix ColumnMajor c c+ (a # u # s #! v) f #| st+ return (u,s,v)+ where+ r = rows x+ c = cols x+++-- | Thin SVD of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'S\'.+thinSVDR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+thinSVDR = thinSVDAux dgesvd "thinSVDR"++-- | Thin SVD of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'S\'.+thinSVDC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+thinSVDC = thinSVDAux zgesvd "thinSVDC"++-- | Thin SVD of a real matrix, using LAPACK's /dgesdd/ with jobz == \'S\'.+thinSVDRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+thinSVDRd = thinSVDAux dgesdd "thinSVDRdd"++-- | Thin SVD of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'S\'.+thinSVDCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+thinSVDCd = thinSVDAux zgesdd "thinSVDCdd"++thinSVDAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ u <- createMatrix ColumnMajor r q+ s <- createVector q+ v <- createMatrix ColumnMajor q c+ (a # u # s #! v) f #| st+ return (u,s,v)+ where+ r = rows x+ c = cols x+ q = min r c+++-- | Singular values of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'N\'.+svR :: Matrix Double -> Vector Double+svR = svAux dgesvd "svR"++-- | Singular values of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'N\'.+svC :: Matrix (Complex Double) -> Vector Double+svC = svAux zgesvd "svC"++-- | Singular values of a real matrix, using LAPACK's /dgesdd/ with jobz == \'N\'.+svRd :: Matrix Double -> Vector Double+svRd = svAux dgesdd "svRd"++-- | Singular values of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'N\'.+svCd :: Matrix (Complex Double) -> Vector Double+svCd = svAux zgesdd "svCd"++svAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ s <- createVector q+ (a #! s) g #| st+ return s+ where+ r = rows x+ c = cols x+ q = min r c+ g ra ca xra xca pa nb pb = f ra ca xra xca pa 0 0 0 0 nullPtr nb pb 0 0 0 0 nullPtr+++-- | Singular values and all right singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'N\' and jobvt == \'A\'.+rightSVR :: Matrix Double -> (Vector Double, Matrix Double)+rightSVR = rightSVAux dgesvd "rightSVR"++-- | Singular values and all right singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'N\' and jobvt == \'A\'.+rightSVC :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))+rightSVC = rightSVAux zgesvd "rightSVC"++rightSVAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ s <- createVector q+ v <- createMatrix ColumnMajor c c+ (a # s #! v) g #| st+ return (s,v)+ where+ r = rows x+ c = cols x+ q = min r c+ g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr+++-- | Singular values and all left singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'A\' and jobvt == \'N\'.+leftSVR :: Matrix Double -> (Matrix Double, Vector Double)+leftSVR = leftSVAux dgesvd "leftSVR"++-- | Singular values and all left singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'A\' and jobvt == \'N\'.+leftSVC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double)+leftSVC = leftSVAux zgesvd "leftSVC"++leftSVAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ u <- createMatrix ColumnMajor r r+ s <- createVector q+ (a # u #! s) g #| st+ return (u,s)+ where+ r = rows x+ c = cols x+ q = min r c+ g ra ca xra xca pa ru cu xru xcu pu nb pb = f ra ca xra xca pa ru cu xru xcu pu nb pb 0 0 0 0 nullPtr++-----------------------------------------------------------------------------++foreign import ccall unsafe "eig_l_R" dgeev :: R ::> R ::> C :> R ::> Ok+foreign import ccall unsafe "eig_l_G" dggev :: R ::> R ::> C :> R :> R ::> R ::> Ok+foreign import ccall unsafe "eig_l_C" zgeev :: C ::> C ::> C :> C ::> Ok+foreign import ccall unsafe "eig_l_GC" zggev :: C ::> C ::> C :> C :> C ::> C ::> Ok+foreign import ccall unsafe "eig_l_S" dsyev :: CInt -> R :> R ::> Ok+foreign import ccall unsafe "eig_l_H" zheev :: CInt -> R :> C ::> Ok++eigAux f st m = unsafePerformIO $ do+ a <- copy ColumnMajor m+ l <- createVector r+ v <- createMatrix ColumnMajor r r+ (a # l #! v) g #| st+ return (l,v)+ where+ r = rows m+ g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr+++-- | Eigenvalues and right eigenvectors of a general complex matrix, using LAPACK's /zgeev/.+-- The eigenvectors are the columns of v. The eigenvalues are not sorted.+eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double))+eigC = eigAux zgeev "eigC"++eigOnlyAux f st m = unsafePerformIO $ do+ a <- copy ColumnMajor m+ l <- createVector r+ (a #! l) g #| st+ return l+ where+ r = rows m+ g ra ca xra xca pa nl pl = f ra ca xra xca pa 0 0 0 0 nullPtr nl pl 0 0 0 0 nullPtr++-- | Eigenvalues of a general complex matrix, using LAPACK's /zgeev/ with jobz == \'N\'.+-- The eigenvalues are not sorted.+eigOnlyC :: Matrix (Complex Double) -> Vector (Complex Double)+eigOnlyC = eigOnlyAux zgeev "eigOnlyC"++-- | Eigenvalues and right eigenvectors of a general real matrix, using LAPACK's /dgeev/.+-- The eigenvectors are the columns of v. The eigenvalues are not sorted.+eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double))+eigR m = (s', v'')+ where (s,v) = eigRaux m+ s' = fixeig1 s+ v' = toRows $ trans v+ v'' = fromColumns $ fixeig (toList s') v'++eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double)+eigRaux m = unsafePerformIO $ do+ a <- copy ColumnMajor m+ l <- createVector r+ v <- createMatrix ColumnMajor r r+ (a # l #! v) g #| "eigR"+ return (l,v)+ where+ r = rows m+ g ra ca xra xca pa = dgeev ra ca xra xca pa 0 0 0 0 nullPtr++fixeig1 s = toComplex' (subVector 0 r (asReal s), subVector r r (asReal s))+ where r = dim s++fixeig [] _ = []+fixeig [_] [v] = [comp' v]+fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs)+ | r1 == r2 && i1 == (-i2) = toComplex' (v1,v2) : toComplex' (v1, mapVector negate v2) : fixeig r vs+ | otherwise = comp' v1 : fixeig ((r2:+i2):r) (v2:vs)+fixeig _ _ = error "fixeig with impossible inputs"++-- For dggev alpha(i) / beta(i), alpha(i+1) / beta(i+1) form a complex conjugate pair when Im alpha(i) != 0.+-- However, this does not lead to Re alpha(i) == Re alpha(i+1), since beta(i) and beta(i+1)+-- can be different. Therefore old 'fixeig' would fail for 'eigG'.+fixeigG [] _ = []+fixeigG [_] [v] = [comp' v]+fixeigG ((_:+ai1) : an : as) (v1:v2:vs)+ | abs ai1 > 1e-13 = toComplex' (v1, v2) : toComplex' (v1, mapVector negate v2) : fixeigG as vs+ | otherwise = comp' v1 : fixeigG (an:as) (v2:vs)+fixeigG _ _ = error "fixeigG with impossible inputs"++-- | Eigenvalues of a general real matrix, using LAPACK's /dgeev/ with jobz == \'N\'.+-- The eigenvalues are not sorted.+eigOnlyR :: Matrix Double -> Vector (Complex Double)+eigOnlyR = fixeig1 . eigOnlyAux dgeev "eigOnlyR"++-- | Generalized eigenvalues and right eigenvectors of a pair of real matrices, using LAPACK's /dggev/.+-- The eigenvectors are the columns of v. The eigenvalues are represented as alphas / betas and not sorted.+eigG :: Matrix Double -> Matrix Double -> (Vector (Complex Double), Vector Double, Matrix (Complex Double))+eigG a b = (alpha', beta, v'')+ where+ (alpha, beta, v) = eigGaux dggev a b "eigG"+ alpha' = fixeig1 alpha+ v' = toRows $ trans v+ v'' = fromColumns $ fixeigG (toList alpha') v'++eigGaux f ma mb st = unsafePerformIO $ do+ a <- copy ColumnMajor ma+ b <- copy ColumnMajor mb+ alpha <- createVector r+ beta <- createVector r+ vr <- createMatrix ColumnMajor r r++ (a # b # alpha # beta #! vr) g #| st++ return (alpha, beta, vr)+ where+ r = rows ma+ g ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta = f ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta 0 0 0 0 nullPtr ++eigGOnlyAux f ma mb st = unsafePerformIO $ do+ a <- copy ColumnMajor ma+ b <- copy ColumnMajor mb+ alpha <- createVector r+ beta <- createVector r++ (a # b # alpha #! beta) g #| st++ return (alpha, beta)+ where+ r = rows ma+ g ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta = f ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta 0 0 0 0 nullPtr 0 0 0 0 nullPtr++-- | Generalized eigenvalues and right eigenvectors of a pair of complex matrices, using LAPACK's /zggev/.+-- The eigenvectors are the columns of v. The eigenvalues are represented as alphas / betas and not sorted.+eigGC :: Matrix (Complex Double) -> Matrix (Complex Double) -> (Vector (Complex Double), Vector (Complex Double), Matrix (Complex Double))+eigGC a b = eigGaux zggev a b "eigGC"++eigOnlyG :: Matrix Double -> Matrix Double -> (Vector (Complex Double), Vector Double)+eigOnlyG a b = first fixeig1 $ eigGOnlyAux dggev a b "eigOnlyG"++eigOnlyGC :: Matrix (Complex Double) -> Matrix (Complex Double) -> (Vector (Complex Double), Vector (Complex Double))+eigOnlyGC a b = eigGOnlyAux zggev a b "eigOnlyGC"++-----------------------------------------------------------------------------++eigSHAux f st m = unsafePerformIO $ do+ l <- createVector r+ v <- copy ColumnMajor m+ (l #! v) f #| st+ return (l,v)+ where+ r = rows m++-- | Eigenvalues and right eigenvectors of a symmetric real matrix, using LAPACK's /dsyev/.+-- The eigenvectors are the columns of v.+-- The eigenvalues are sorted in descending order (use 'eigS'' for ascending order).+eigS :: Matrix Double -> (Vector Double, Matrix Double)+eigS m = (s', fliprl v)+ where (s,v) = eigS' m+ s' = fromList . reverse . toList $ s++-- | 'eigS' in ascending order+eigS' :: Matrix Double -> (Vector Double, Matrix Double)+eigS' = eigSHAux (dsyev 1) "eigS'"++-- | Eigenvalues and right eigenvectors of a hermitian complex matrix, using LAPACK's /zheev/.+-- The eigenvectors are the columns of v.+-- The eigenvalues are sorted in descending order (use 'eigH'' for ascending order).+eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))+eigH m = (s', fliprl v)+ where+ (s,v) = eigH' m+ s' = fromList . reverse . toList $ s++-- | 'eigH' in ascending order+eigH' :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))+eigH' = eigSHAux (zheev 1) "eigH'"+++-- | Eigenvalues of a symmetric real matrix, using LAPACK's /dsyev/ with jobz == \'N\'.+-- The eigenvalues are sorted in descending order.+eigOnlyS :: Matrix Double -> Vector Double+eigOnlyS = vrev . fst. eigSHAux (dsyev 0) "eigS'"++-- | Eigenvalues of a hermitian complex matrix, using LAPACK's /zheev/ with jobz == \'N\'.+-- The eigenvalues are sorted in descending order.+eigOnlyH :: Matrix (Complex Double) -> Vector Double+eigOnlyH = vrev . fst. eigSHAux (zheev 0) "eigH'"++vrev = flatten . flipud . reshape 1++-----------------------------------------------------------------------------+foreign import ccall unsafe "linearSolveR_l" dgesv :: R ::> R ::> Ok+foreign import ccall unsafe "linearSolveC_l" zgesv :: C ::> C ::> Ok++linearSolveSQAux g f st a b+ | n1==n2 && n1==r = unsafePerformIO . g $ do+ a' <- copy ColumnMajor a+ s <- copy ColumnMajor b+ (a' #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ n1 = rows a+ n2 = cols a+ r = rows b++-- | Solve a real linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /dgesv/. For underconstrained or overconstrained systems use 'linearSolveLSR' or 'linearSolveSVDR'. See also 'lusR'.+linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double+linearSolveR a b = linearSolveSQAux id dgesv "linearSolveR" a b++mbLinearSolveR :: Matrix Double -> Matrix Double -> Maybe (Matrix Double)+mbLinearSolveR a b = linearSolveSQAux mbCatch dgesv "linearSolveR" a b+++-- | Solve a complex linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /zgesv/. For underconstrained or overconstrained systems use 'linearSolveLSC' or 'linearSolveSVDC'. See also 'lusC'.+linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+linearSolveC a b = linearSolveSQAux id zgesv "linearSolveC" a b++mbLinearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Maybe (Matrix (Complex Double))+mbLinearSolveC a b = linearSolveSQAux mbCatch zgesv "linearSolveC" a b++--------------------------------------------------------------------------------+foreign import ccall unsafe "cholSolveR_l" dpotrs :: R ::> R ::> Ok+foreign import ccall unsafe "cholSolveC_l" zpotrs :: C ::> C ::> Ok+++linearSolveSQAux2 g f st a b+ | n1==n2 && n1==r = unsafePerformIO . g $ do+ s <- copy ColumnMajor b+ (a #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ n1 = rows a+ n2 = cols a+ r = rows b++-- | Solves a symmetric positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholS'.+cholSolveR :: Matrix Double -> Matrix Double -> Matrix Double+cholSolveR a b = linearSolveSQAux2 id dpotrs "cholSolveR" (fmat a) b++-- | Solves a Hermitian positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholH'.+cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+cholSolveC a b = linearSolveSQAux2 id zpotrs "cholSolveC" (fmat a) b++--------------------------------------------------------------------------------+foreign import ccall unsafe "triSolveR_l_u" dtrtrs_u :: R ::> R ::> Ok+foreign import ccall unsafe "triSolveC_l_u" ztrtrs_u :: C ::> C ::> Ok+foreign import ccall unsafe "triSolveR_l_l" dtrtrs_l :: R ::> R ::> Ok+foreign import ccall unsafe "triSolveC_l_l" ztrtrs_l :: C ::> C ::> Ok+++linearSolveTRAux2 g f st a b+ | n1==n2 && n1==r = unsafePerformIO . g $ do+ s <- copy ColumnMajor b+ (a #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ n1 = rows a+ n2 = cols a+ r = rows b++data UpLo = Lower | Upper++-- | Solves a triangular system of linear equations.+triSolveR :: UpLo -> Matrix Double -> Matrix Double -> Matrix Double+triSolveR Lower a b = linearSolveTRAux2 id dtrtrs_l "triSolveR" (fmat a) b+triSolveR Upper a b = linearSolveTRAux2 id dtrtrs_u "triSolveR" (fmat a) b++-- | Solves a triangular system of linear equations.+triSolveC :: UpLo -> Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+triSolveC Lower a b = linearSolveTRAux2 id ztrtrs_l "triSolveC" (fmat a) b+triSolveC Upper a b = linearSolveTRAux2 id ztrtrs_u "triSolveC" (fmat a) b++--------------------------------------------------------------------------------+foreign import ccall unsafe "triDiagSolveR_l" dgttrs :: R :> R :> R :> R ::> Ok+foreign import ccall unsafe "triDiagSolveC_l" zgttrs :: C :> C :> C :> C ::> Ok++linearSolveGTAux2 g f st dl d du b+ | ndl == nd - 1 &&+ ndu == nd - 1 &&+ nd == r = unsafePerformIO . g $ do+ dl' <- head . toRows <$> copy ColumnMajor (fromRows [dl])+ du' <- head . toRows <$> copy ColumnMajor (fromRows [du])+ s <- copy ColumnMajor b+ (dl' # d # du' #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ ndl = dim dl+ nd = dim d+ ndu = dim du+ r = rows b++-- | Solves a tridiagonal system of linear equations.+triDiagSolveR dl d du b = linearSolveGTAux2 id dgttrs "triDiagSolveR" dl d du b+triDiagSolveC dl d du b = linearSolveGTAux2 id zgttrs "triDiagSolveC" dl d du b++-----------------------------------------------------------------------------------++foreign import ccall unsafe "linearSolveLSR_l" dgels :: R ::> R ::> Ok+foreign import ccall unsafe "linearSolveLSC_l" zgels :: C ::> C ::> Ok+foreign import ccall unsafe "linearSolveSVDR_l" dgelss :: Double -> R ::> R ::> Ok+foreign import ccall unsafe "linearSolveSVDC_l" zgelss :: Double -> C ::> C ::> Ok++linearSolveAux f st a b+ | m == rows b = unsafePerformIO $ do+ a' <- copy ColumnMajor a+ r <- createMatrix ColumnMajor (max m n) nrhs+ setRect 0 0 b r+ (a' #! r) f #| st+ return r+ | otherwise = error $ "different number of rows in linearSolve ("++st++")"+ where+ m = rows a+ n = cols a+ nrhs = cols b++-- | Least squared error solution of an overconstrained real linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /dgels/. For rank-deficient systems use 'linearSolveSVDR'.+linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double+linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux dgels "linearSolverLSR" a b++-- | Least squared error solution of an overconstrained complex linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /zgels/. For rank-deficient systems use 'linearSolveSVDC'.+linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux zgels "linearSolveLSC" a b++-- | Minimum norm solution of a general real linear least squares problem Ax=B using the SVD, based on LAPACK's /dgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSR'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.+linearSolveSVDR :: Maybe Double -- ^ rcond+ -> Matrix Double -- ^ coefficient matrix+ -> Matrix Double -- ^ right hand sides (as columns)+ -> Matrix Double -- ^ solution vectors (as columns)+linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux (dgelss rcond) "linearSolveSVDR" a b+linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) a b++-- | Minimum norm solution of a general complex linear least squares problem Ax=B using the SVD, based on LAPACK's /zgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSC'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.+linearSolveSVDC :: Maybe Double -- ^ rcond+ -> Matrix (Complex Double) -- ^ coefficient matrix+ -> Matrix (Complex Double) -- ^ right hand sides (as columns)+ -> Matrix (Complex Double) -- ^ solution vectors (as columns)+linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux (zgelss rcond) "linearSolveSVDC" a b+linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) a b++-----------------------------------------------------------------------------------++foreign import ccall unsafe "chol_l_H" zpotrf :: C ::> Ok+foreign import ccall unsafe "chol_l_S" dpotrf :: R ::> Ok++cholAux f st a = do+ r <- copy ColumnMajor a+ (r # id) f #| st+ return r++-- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/.+cholH :: Matrix (Complex Double) -> Matrix (Complex Double)+cholH = unsafePerformIO . cholAux zpotrf "cholH"++-- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/.+cholS :: Matrix Double -> Matrix Double+cholS = unsafePerformIO . cholAux dpotrf "cholS"++-- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/ ('Maybe' version).+mbCholH :: Matrix (Complex Double) -> Maybe (Matrix (Complex Double))+mbCholH = unsafePerformIO . mbCatch . cholAux zpotrf "cholH"++-- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/ ('Maybe' version).+mbCholS :: Matrix Double -> Maybe (Matrix Double)+mbCholS = unsafePerformIO . mbCatch . cholAux dpotrf "cholS"++-----------------------------------------------------------------------------------++type TMVM t = t ::> t :> t ::> Ok++foreign import ccall unsafe "qr_l_R" dgeqr2 :: R :> R ::> Ok+foreign import ccall unsafe "qr_l_C" zgeqr2 :: C :> C ::> Ok++-- | QR factorization of a real matrix, using LAPACK's /dgeqr2/.+qrR :: Matrix Double -> (Matrix Double, Vector Double)+qrR = qrAux dgeqr2 "qrR"++-- | QR factorization of a complex matrix, using LAPACK's /zgeqr2/.+qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))+qrC = qrAux zgeqr2 "qrC"++qrAux f st a = unsafePerformIO $ do+ r <- copy ColumnMajor a+ tau <- createVector mn+ (tau #! r) f #| st+ return (r,tau)+ where+ m = rows a+ n = cols a+ mn = min m n++foreign import ccall unsafe "c_dorgqr" dorgqr :: R :> R ::> Ok+foreign import ccall unsafe "c_zungqr" zungqr :: C :> C ::> Ok++-- | build rotation from reflectors+qrgrR :: Int -> (Matrix Double, Vector Double) -> Matrix Double+qrgrR = qrgrAux dorgqr "qrgrR"+-- | build rotation from reflectors+qrgrC :: Int -> (Matrix (Complex Double), Vector (Complex Double)) -> Matrix (Complex Double)+qrgrC = qrgrAux zungqr "qrgrC"++qrgrAux f st n (a, tau) = unsafePerformIO $ do+ res <- copy ColumnMajor (subMatrix (0,0) (rows a,n) a)+ ((subVector 0 n tau') #! res) f #| st+ return res+ where+ tau' = vjoin [tau, constantD 0 n]++-----------------------------------------------------------------------------------+foreign import ccall unsafe "hess_l_R" dgehrd :: R :> R ::> Ok+foreign import ccall unsafe "hess_l_C" zgehrd :: C :> C ::> Ok++-- | Hessenberg factorization of a square real matrix, using LAPACK's /dgehrd/.+hessR :: Matrix Double -> (Matrix Double, Vector Double)+hessR = hessAux dgehrd "hessR"++-- | Hessenberg factorization of a square complex matrix, using LAPACK's /zgehrd/.+hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))+hessC = hessAux zgehrd "hessC"++hessAux f st a = unsafePerformIO $ do+ r <- copy ColumnMajor a+ tau <- createVector (mn-1)+ (tau #! r) f #| st+ return (r,tau)+ where+ m = rows a+ n = cols a+ mn = min m n++-----------------------------------------------------------------------------------+foreign import ccall unsafe "schur_l_R" dgees :: R ::> R ::> Ok+foreign import ccall unsafe "schur_l_C" zgees :: C ::> C ::> Ok++-- | Schur factorization of a square real matrix, using LAPACK's /dgees/.+schurR :: Matrix Double -> (Matrix Double, Matrix Double)+schurR = schurAux dgees "schurR"++-- | Schur factorization of a square complex matrix, using LAPACK's /zgees/.+schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double))+schurC = schurAux zgees "schurC"++schurAux f st a = unsafePerformIO $ do+ u <- createMatrix ColumnMajor n n+ s <- copy ColumnMajor a+ (u #! s) f #| st+ return (u,s)+ where+ n = rows a++-----------------------------------------------------------------------------------+foreign import ccall unsafe "lu_l_R" dgetrf :: R :> R ::> Ok+foreign import ccall unsafe "lu_l_C" zgetrf :: R :> C ::> Ok++-- | LU factorization of a general real matrix, using LAPACK's /dgetrf/.+luR :: Matrix Double -> (Matrix Double, [Int])+luR = luAux dgetrf "luR"++-- | LU factorization of a general complex matrix, using LAPACK's /zgetrf/.+luC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int])+luC = luAux zgetrf "luC"++luAux f st a = unsafePerformIO $ do+ lu <- copy ColumnMajor a+ piv <- createVector (min n m)+ (piv #! lu) f #| st+ return (lu, map (pred.round) (toList piv))+ where+ n = rows a+ m = cols a++-----------------------------------------------------------------------------------++foreign import ccall unsafe "luS_l_R" dgetrs :: R ::> R :> R ::> Ok+foreign import ccall unsafe "luS_l_C" zgetrs :: C ::> R :> C ::> Ok++-- | Solve a real linear system from a precomputed LU decomposition ('luR'), using LAPACK's /dgetrs/.+lusR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double+lusR a piv b = lusAux dgetrs "lusR" (fmat a) piv b++-- | Solve a complex linear system from a precomputed LU decomposition ('luC'), using LAPACK's /zgetrs/.+lusC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double)+lusC a piv b = lusAux zgetrs "lusC" (fmat a) piv b++lusAux f st a piv b+ | n1==n2 && n2==n =unsafePerformIO $ do+ x <- copy ColumnMajor b+ (a # piv' #! x) f #| st+ return x+ | otherwise = error st+ where+ n1 = rows a+ n2 = cols a+ n = rows b+ piv' = fromList (map (fromIntegral.succ) piv) :: Vector Double++-----------------------------------------------------------------------------------+foreign import ccall unsafe "ldl_R" dsytrf :: R :> R ::> Ok+foreign import ccall unsafe "ldl_C" zhetrf :: R :> C ::> Ok++-- | LDL factorization of a symmetric real matrix, using LAPACK's /dsytrf/.+ldlR :: Matrix Double -> (Matrix Double, [Int])+ldlR = ldlAux dsytrf "ldlR"++-- | LDL factorization of a hermitian complex matrix, using LAPACK's /zhetrf/.+ldlC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int])+ldlC = ldlAux zhetrf "ldlC"++ldlAux f st a = unsafePerformIO $ do+ ldl <- copy ColumnMajor a+ piv <- createVector (rows a)+ (piv #! ldl) f #| st+ return (ldl, map (pred.round) (toList piv))++-----------------------------------------------------------------------------------++foreign import ccall unsafe "ldl_S_R" dsytrs :: R ::> R :> R ::> Ok+foreign import ccall unsafe "ldl_S_C" zsytrs :: C ::> R :> C ::> Ok++-- | Solve a real linear system from a precomputed LDL decomposition ('ldlR'), using LAPACK's /dsytrs/.+ldlsR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double+ldlsR a piv b = lusAux dsytrs "ldlsR" (fmat a) piv b++-- | Solve a complex linear system from a precomputed LDL decomposition ('ldlC'), using LAPACK's /zsytrs/.+ldlsC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double)+ldlsC a piv b = lusAux zsytrs "ldlsC" (fmat a) piv b
+ src/Internal/Matrix.hs view
@@ -0,0 +1,721 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ConstrainedClassMethods #-}++-- |+-- Module : Internal.Matrix+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Internal matrix representation+--++module Internal.Matrix where++import Internal.Vector+import Internal.Devel+import Internal.Vectorized hiding ((#), (#!))+import Foreign.Marshal.Alloc ( free )+import Foreign.Marshal.Array(newArray)+import Foreign.Ptr ( Ptr )+import Foreign.Storable ( Storable )+import Data.Complex ( Complex )+import Foreign.C.Types ( CInt(..) )+import Foreign.C.String ( CString, newCString )+import System.IO.Unsafe ( unsafePerformIO )+import Control.DeepSeq ( NFData(..) )+import Text.Printf++-----------------------------------------------------------------++data MatrixOrder = RowMajor | ColumnMajor deriving (Show,Eq)++-- | Matrix representation suitable for BLAS\/LAPACK computations.++data Matrix t = Matrix+ { irows :: {-# UNPACK #-} !Int+ , icols :: {-# UNPACK #-} !Int+ , xRow :: {-# UNPACK #-} !Int+ , xCol :: {-# UNPACK #-} !Int+ , xdat :: {-# UNPACK #-} !(Vector t)+ }+++rows :: Matrix t -> Int+rows = irows+{-# INLINE rows #-}++cols :: Matrix t -> Int+cols = icols+{-# INLINE cols #-}++size :: Matrix t -> (Int, Int)+size m = (irows m, icols m)+{-# INLINE size #-}++rowOrder :: Matrix t -> Bool+rowOrder m = xCol m == 1 || cols m == 1+{-# INLINE rowOrder #-}++colOrder :: Matrix t -> Bool+colOrder m = xRow m == 1 || rows m == 1+{-# INLINE colOrder #-}++is1d :: Matrix t -> Bool+is1d (size->(r,c)) = r==1 || c==1+{-# INLINE is1d #-}++-- data is not contiguous+isSlice :: Storable t => Matrix t -> Bool+isSlice m@(size->(r,c)) = r*c < dim (xdat m)+{-# INLINE isSlice #-}++orderOf :: Matrix t -> MatrixOrder+orderOf m = if rowOrder m then RowMajor else ColumnMajor+++showInternal :: Storable t => Matrix t -> IO ()+showInternal m = printf "%dx%d %s %s %d:%d (%d)\n" r c slc ord xr xc dv+ where+ r = rows m+ c = cols m+ xr = xRow m+ xc = xCol m+ slc = if isSlice m then "slice" else "full"+ ord = if is1d m then "1d" else if rowOrder m then "rows" else "cols"+ dv = dim (xdat m)++--------------------------------------------------------------------------------++-- | Matrix transpose.+trans :: Matrix t -> Matrix t+trans m@Matrix { irows = r, icols = c, xRow = xr, xCol = xc } =+ m { irows = c, icols = r, xRow = xc, xCol = xr }+++cmat :: (Element t) => Matrix t -> Matrix t+cmat m+ | rowOrder m = m+ | otherwise = extractAll RowMajor m+++fmat :: (Element t) => Matrix t -> Matrix t+fmat m+ | colOrder m = m+ | otherwise = extractAll ColumnMajor m+++-- C-Haskell matrix adapters+{-# INLINE amatr #-}+amatr :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> Ptr a -> f) -> IO r+amatr x f g = unsafeWith (xdat x) (f . g r c)+ where+ r = fi (rows x)+ c = fi (cols x)++{-# INLINE amat #-}+amat :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r+amat x f g = unsafeWith (xdat x) (f . g r c sr sc)+ where+ r = fi (rows x)+ c = fi (cols x)+ sr = fi (xRow x)+ sc = fi (xCol x)+++instance Storable t => TransArray (Matrix t)+ where+ type TransRaw (Matrix t) b = CInt -> CInt -> Ptr t -> b+ type Trans (Matrix t) b = CInt -> CInt -> CInt -> CInt -> Ptr t -> b+ apply = amat+ {-# INLINE apply #-}+ applyRaw = amatr+ {-# INLINE applyRaw #-}++infixr 1 #+(#) :: TransArray c => c -> (b -> IO r) -> Trans c b -> IO r+a # b = apply a b+{-# INLINE (#) #-}++(#!) :: (TransArray c, TransArray c1) => c1 -> c -> Trans c1 (Trans c (IO r)) -> IO r+a #! b = a # b # id+{-# INLINE (#!) #-}++--------------------------------------------------------------------------------++copy :: Element t => MatrixOrder -> Matrix t -> IO (Matrix t)+copy ord m = extractR ord m 0 (idxs[0,rows m-1]) 0 (idxs[0,cols m-1])++extractAll :: Element t => MatrixOrder -> Matrix t -> Matrix t+extractAll ord m = unsafePerformIO (copy ord m)++{- | Creates a vector by concatenation of rows. If the matrix is ColumnMajor, this operation requires a transpose.++>>> flatten (ident 3)+[1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0]+it :: (Num t, Element t) => Vector t++-}+flatten :: Element t => Matrix t -> Vector t+flatten m+ | isSlice m || not (rowOrder m) = xdat (extractAll RowMajor m)+ | otherwise = xdat m+++-- | the inverse of 'Data.Packed.Matrix.fromLists'+toLists :: (Element t) => Matrix t -> [[t]]+toLists = map toList . toRows++++-- | common value with \"adaptable\" 1+compatdim :: [Int] -> Maybe Int+compatdim [] = Nothing+compatdim [a] = Just a+compatdim (a:b:xs)+ | a==b = compatdim (b:xs)+ | a==1 = compatdim (b:xs)+ | b==1 = compatdim (a:xs)+ | otherwise = Nothing+++++-- | Create a matrix from a list of vectors.+-- All vectors must have the same dimension,+-- or dimension 1, which is are automatically expanded.+fromRows :: Element t => [Vector t] -> Matrix t+fromRows [] = emptyM 0 0+fromRows vs = case compatdim (map dim vs) of+ Nothing -> error $ "fromRows expects vectors with equal sizes (or singletons), given: " ++ show (map dim vs)+ Just 0 -> emptyM r 0+ Just c -> matrixFromVector RowMajor r c . vjoin . map (adapt c) $ vs+ where+ r = length vs+ adapt c v+ | c == 0 = fromList[]+ | dim v == c = v+ | otherwise = constantD (v@>0) c++-- | extracts the rows of a matrix as a list of vectors+toRows :: Element t => Matrix t -> [Vector t]+toRows m+ | rowOrder m = map sub rowRange+ | otherwise = map ext rowRange+ where+ rowRange = [0..rows m-1]+ sub k = subVector (k*xRow m) (cols m) (xdat m)+ ext k = xdat $ unsafePerformIO $ extractR RowMajor m 1 (idxs[k]) 0 (idxs[0,cols m-1])+++-- | Creates a matrix from a list of vectors, as columns+fromColumns :: Element t => [Vector t] -> Matrix t+fromColumns m = trans . fromRows $ m++-- | Creates a list of vectors from the columns of a matrix+toColumns :: Element t => Matrix t -> [Vector t]+toColumns m = toRows . trans $ m++-- | Reads a matrix position.+(@@>) :: Storable t => Matrix t -> (Int,Int) -> t+infixl 9 @@>+m@Matrix {irows = r, icols = c} @@> (i,j)+ | i<0 || i>=r || j<0 || j>=c = error "matrix indexing out of range"+ | otherwise = atM' m i j+{-# INLINE (@@>) #-}++-- Unsafe matrix access without range checking+atM' :: Storable t => Matrix t -> Int -> Int -> t+atM' m i j = xdat m `at'` (i * (xRow m) + j * (xCol m))+{-# INLINE atM' #-}++------------------------------------------------------------------++matrixFromVector :: Storable t => MatrixOrder -> Int -> Int -> Vector t -> Matrix t+matrixFromVector _ 1 _ v@(dim->d) = Matrix { irows = 1, icols = d, xdat = v, xRow = d, xCol = 1 }+matrixFromVector _ _ 1 v@(dim->d) = Matrix { irows = d, icols = 1, xdat = v, xRow = 1, xCol = d }+matrixFromVector o r c v+ | r * c == dim v = m+ | otherwise = error $ "can't reshape vector dim = "++ show (dim v)++" to matrix " ++ shSize m+ where+ m | o == RowMajor = Matrix { irows = r, icols = c, xdat = v, xRow = c, xCol = 1 }+ | otherwise = Matrix { irows = r, icols = c, xdat = v, xRow = 1, xCol = r }++-- allocates memory for a new matrix+createMatrix :: (Storable a) => MatrixOrder -> Int -> Int -> IO (Matrix a)+createMatrix ord r c = do+ p <- createVector (r*c)+ return (matrixFromVector ord r c p)++{- | Creates a matrix from a vector by grouping the elements in rows with the desired number of columns. (GNU-Octave groups by columns. To do it you can define @reshapeF r = tr' . reshape r@+where r is the desired number of rows.)++>>> reshape 4 (fromList [1..12])+(3><4)+ [ 1.0, 2.0, 3.0, 4.0+ , 5.0, 6.0, 7.0, 8.0+ , 9.0, 10.0, 11.0, 12.0 ]++-}+reshape :: Storable t => Int -> Vector t -> Matrix t+reshape 0 v = matrixFromVector RowMajor 0 0 v+reshape c v = matrixFromVector RowMajor (dim v `div` c) c v+++-- | application of a vector function on the flattened matrix elements+liftMatrix :: (Element a, Element b) => (Vector a -> Vector b) -> Matrix a -> Matrix b+liftMatrix f m@Matrix { irows = r, icols = c, xdat = d}+ | isSlice m = matrixFromVector RowMajor r c (f (flatten m))+ | otherwise = matrixFromVector (orderOf m) r c (f d)++-- | application of a vector function on the flattened matrices elements+liftMatrix2 :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t+liftMatrix2 f m1@(size->(r,c)) m2+ | (r,c)/=size m2 = error "nonconformant matrices in liftMatrix2"+ | rowOrder m1 = matrixFromVector RowMajor r c (f (flatten m1) (flatten m2))+ | otherwise = matrixFromVector ColumnMajor r c (f (flatten (trans m1)) (flatten (trans m2)))++------------------------------------------------------------------++-- | Supported matrix elements.+class (Storable a) => Element a where+ constantD :: a -> Int -> Vector a+ extractR :: MatrixOrder -> Matrix a -> CInt -> Vector CInt -> CInt -> Vector CInt -> IO (Matrix a)+ setRect :: Int -> Int -> Matrix a -> Matrix a -> IO ()+ sortI :: Ord a => Vector a -> Vector CInt+ sortV :: Ord a => Vector a -> Vector a+ compareV :: Ord a => Vector a -> Vector a -> Vector CInt+ selectV :: Vector CInt -> Vector a -> Vector a -> Vector a -> Vector a+ remapM :: Matrix CInt -> Matrix CInt -> Matrix a -> Matrix a+ rowOp :: Int -> a -> Int -> Int -> Int -> Int -> Matrix a -> IO ()+ gemm :: Vector a -> Matrix a -> Matrix a -> Matrix a -> IO ()+ reorderV :: Vector CInt-> Vector CInt-> Vector a -> Vector a -- see reorderVector for documentation+++instance Element Float where+ constantD = constantAux cconstantF+ extractR = extractAux c_extractF+ setRect = setRectAux c_setRectF+ sortI = sortIdxF+ sortV = sortValF+ compareV = compareF+ selectV = selectF+ remapM = remapF+ rowOp = rowOpAux c_rowOpF+ gemm = gemmg c_gemmF+ reorderV = reorderAux c_reorderF++instance Element Double where+ constantD = constantAux cconstantR+ extractR = extractAux c_extractD+ setRect = setRectAux c_setRectD+ sortI = sortIdxD+ sortV = sortValD+ compareV = compareD+ selectV = selectD+ remapM = remapD+ rowOp = rowOpAux c_rowOpD+ gemm = gemmg c_gemmD+ reorderV = reorderAux c_reorderD++instance Element (Complex Float) where+ constantD = constantAux cconstantQ+ extractR = extractAux c_extractQ+ setRect = setRectAux c_setRectQ+ sortI = undefined+ sortV = undefined+ compareV = undefined+ selectV = selectQ+ remapM = remapQ+ rowOp = rowOpAux c_rowOpQ+ gemm = gemmg c_gemmQ+ reorderV = reorderAux c_reorderQ++instance Element (Complex Double) where+ constantD = constantAux cconstantC+ extractR = extractAux c_extractC+ setRect = setRectAux c_setRectC+ sortI = undefined+ sortV = undefined+ compareV = undefined+ selectV = selectC+ remapM = remapC+ rowOp = rowOpAux c_rowOpC+ gemm = gemmg c_gemmC+ reorderV = reorderAux c_reorderC++instance Element (CInt) where+ constantD = constantAux cconstantI+ extractR = extractAux c_extractI+ setRect = setRectAux c_setRectI+ sortI = sortIdxI+ sortV = sortValI+ compareV = compareI+ selectV = selectI+ remapM = remapI+ rowOp = rowOpAux c_rowOpI+ gemm = gemmg c_gemmI+ reorderV = reorderAux c_reorderI++instance Element Z where+ constantD = constantAux cconstantL+ extractR = extractAux c_extractL+ setRect = setRectAux c_setRectL+ sortI = sortIdxL+ sortV = sortValL+ compareV = compareL+ selectV = selectL+ remapM = remapL+ rowOp = rowOpAux c_rowOpL+ gemm = gemmg c_gemmL+ reorderV = reorderAux c_reorderL++-------------------------------------------------------------------++-- | reference to a rectangular slice of a matrix (no data copy)+subMatrix :: Element a+ => (Int,Int) -- ^ (r0,c0) starting position+ -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix+ -> Matrix a -- ^ input matrix+ -> Matrix a -- ^ result+subMatrix (r0,c0) (rt,ct) m+ | rt <= 0 || ct <= 0 = matrixFromVector RowMajor (max 0 rt) (max 0 ct) (fromList [])+ | 0 <= r0 && 0 <= rt && r0+rt <= rows m &&+ 0 <= c0 && 0 <= ct && c0+ct <= cols m = res+ | otherwise = error $ "wrong subMatrix "++show ((r0,c0),(rt,ct))++" of "++shSize m+ where+ p = r0 * xRow m + c0 * xCol m+ tot | rowOrder m = ct + (rt-1) * xRow m+ | otherwise = rt + (ct-1) * xCol m+ res = m { irows = rt, icols = ct, xdat = subVector p tot (xdat m) }++--------------------------------------------------------------------------++maxZ :: (Num t1, Ord t1, Foldable t) => t t1 -> t1+maxZ xs = if minimum xs == 0 then 0 else maximum xs++conformMs :: Element t => [Matrix t] -> [Matrix t]+conformMs ms = map (conformMTo (r,c)) ms+ where+ r = maxZ (map rows ms)+ c = maxZ (map cols ms)++conformVs :: Element t => [Vector t] -> [Vector t]+conformVs vs = map (conformVTo n) vs+ where+ n = maxZ (map dim vs)++conformMTo :: Element t => (Int, Int) -> Matrix t -> Matrix t+conformMTo (r,c) m+ | size m == (r,c) = m+ | size m == (1,1) = matrixFromVector RowMajor r c (constantD (m@@>(0,0)) (r*c))+ | size m == (r,1) = repCols c m+ | size m == (1,c) = repRows r m+ | otherwise = error $ "matrix " ++ shSize m ++ " cannot be expanded to " ++ shDim (r,c)++conformVTo :: Element t => Int -> Vector t -> Vector t+conformVTo n v+ | dim v == n = v+ | dim v == 1 = constantD (v@>0) n+ | otherwise = error $ "vector of dim=" ++ show (dim v) ++ " cannot be expanded to dim=" ++ show n++repRows :: Element t => Int -> Matrix t -> Matrix t+repRows n x = fromRows (replicate n (flatten x))+repCols :: Element t => Int -> Matrix t -> Matrix t+repCols n x = fromColumns (replicate n (flatten x))++shSize :: Matrix t -> [Char]+shSize = shDim . size++shDim :: (Show a, Show a1) => (a1, a) -> [Char]+shDim (r,c) = "(" ++ show r ++"x"++ show c ++")"++emptyM :: Storable t => Int -> Int -> Matrix t+emptyM r c = matrixFromVector RowMajor r c (fromList[])++----------------------------------------------------------------------++instance (Storable t, NFData t) => NFData (Matrix t)+ where+ rnf m | d > 0 = rnf (v @> 0)+ | otherwise = ()+ where+ d = dim v+ v = xdat m++---------------------------------------------------------------++extractAux :: (Eq t3, Eq t2, TransArray c, Storable a, Storable t1,+ Storable t, Num t3, Num t2, Integral t1, Integral t)+ => (t3 -> t2 -> CInt -> Ptr t1 -> CInt -> Ptr t+ -> Trans c (CInt -> CInt -> CInt -> CInt -> Ptr a -> IO CInt))+ -> MatrixOrder -> c -> t3 -> Vector t1 -> t2 -> Vector t -> IO (Matrix a)+extractAux f ord m moder vr modec vc = do+ let nr = if moder == 0 then fromIntegral $ vr@>1 - vr@>0 + 1 else dim vr+ nc = if modec == 0 then fromIntegral $ vc@>1 - vc@>0 + 1 else dim vc+ r <- createMatrix ord nr nc+ (vr # vc # m #! r) (f moder modec) #|"extract"++ return r++type Extr x = CInt -> CInt -> CIdxs (CIdxs (OM x (OM x (IO CInt))))++foreign import ccall unsafe "extractD" c_extractD :: Extr Double+foreign import ccall unsafe "extractF" c_extractF :: Extr Float+foreign import ccall unsafe "extractC" c_extractC :: Extr (Complex Double)+foreign import ccall unsafe "extractQ" c_extractQ :: Extr (Complex Float)+foreign import ccall unsafe "extractI" c_extractI :: Extr CInt+foreign import ccall unsafe "extractL" c_extractL :: Extr Z++---------------------------------------------------------------++setRectAux :: (TransArray c1, TransArray c)+ => (CInt -> CInt -> Trans c1 (Trans c (IO CInt)))+ -> Int -> Int -> c1 -> c -> IO ()+setRectAux f i j m r = (m #! r) (f (fi i) (fi j)) #|"setRect"++type SetRect x = I -> I -> x ::> x::> Ok++foreign import ccall unsafe "setRectD" c_setRectD :: SetRect Double+foreign import ccall unsafe "setRectF" c_setRectF :: SetRect Float+foreign import ccall unsafe "setRectC" c_setRectC :: SetRect (Complex Double)+foreign import ccall unsafe "setRectQ" c_setRectQ :: SetRect (Complex Float)+foreign import ccall unsafe "setRectI" c_setRectI :: SetRect I+foreign import ccall unsafe "setRectL" c_setRectL :: SetRect Z++--------------------------------------------------------------------------------++sortG :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+sortG f v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) f #|"sortG"+ return r++sortIdxD :: Vector Double -> Vector CInt+sortIdxD = sortG c_sort_indexD+sortIdxF :: Vector Float -> Vector CInt+sortIdxF = sortG c_sort_indexF+sortIdxI :: Vector CInt -> Vector CInt+sortIdxI = sortG c_sort_indexI+sortIdxL :: Vector Z -> Vector I+sortIdxL = sortG c_sort_indexL++sortValD :: Vector Double -> Vector Double+sortValD = sortG c_sort_valD+sortValF :: Vector Float -> Vector Float+sortValF = sortG c_sort_valF+sortValI :: Vector CInt -> Vector CInt+sortValI = sortG c_sort_valI+sortValL :: Vector Z -> Vector Z+sortValL = sortG c_sort_valL++foreign import ccall unsafe "sort_indexD" c_sort_indexD :: CV Double (CV CInt (IO CInt))+foreign import ccall unsafe "sort_indexF" c_sort_indexF :: CV Float (CV CInt (IO CInt))+foreign import ccall unsafe "sort_indexI" c_sort_indexI :: CV CInt (CV CInt (IO CInt))+foreign import ccall unsafe "sort_indexL" c_sort_indexL :: Z :> I :> Ok++foreign import ccall unsafe "sort_valuesD" c_sort_valD :: CV Double (CV Double (IO CInt))+foreign import ccall unsafe "sort_valuesF" c_sort_valF :: CV Float (CV Float (IO CInt))+foreign import ccall unsafe "sort_valuesI" c_sort_valI :: CV CInt (CV CInt (IO CInt))+foreign import ccall unsafe "sort_valuesL" c_sort_valL :: Z :> Z :> Ok++--------------------------------------------------------------------------------++compareG :: (TransArray c, Storable t, Storable a)+ => Trans c (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt)+ -> c -> Vector t -> Vector a+compareG f u v = unsafePerformIO $ do+ r <- createVector (dim v)+ (u # v #! r) f #|"compareG"+ return r++compareD :: Vector Double -> Vector Double -> Vector CInt+compareD = compareG c_compareD+compareF :: Vector Float -> Vector Float -> Vector CInt+compareF = compareG c_compareF+compareI :: Vector CInt -> Vector CInt -> Vector CInt+compareI = compareG c_compareI+compareL :: Vector Z -> Vector Z -> Vector CInt+compareL = compareG c_compareL++foreign import ccall unsafe "compareD" c_compareD :: CV Double (CV Double (CV CInt (IO CInt)))+foreign import ccall unsafe "compareF" c_compareF :: CV Float (CV Float (CV CInt (IO CInt)))+foreign import ccall unsafe "compareI" c_compareI :: CV CInt (CV CInt (CV CInt (IO CInt)))+foreign import ccall unsafe "compareL" c_compareL :: Z :> Z :> I :> Ok++--------------------------------------------------------------------------------++selectG :: (TransArray c, TransArray c1, TransArray c2, Storable t, Storable a)+ => Trans c2 (Trans c1 (CInt -> Ptr t -> Trans c (CInt -> Ptr a -> IO CInt)))+ -> c2 -> c1 -> Vector t -> c -> Vector a+selectG f c u v w = unsafePerformIO $ do+ r <- createVector (dim v)+ (c # u # v # w #! r) f #|"selectG"+ return r++selectD :: Vector CInt -> Vector Double -> Vector Double -> Vector Double -> Vector Double+selectD = selectG c_selectD+selectF :: Vector CInt -> Vector Float -> Vector Float -> Vector Float -> Vector Float+selectF = selectG c_selectF+selectI :: Vector CInt -> Vector CInt -> Vector CInt -> Vector CInt -> Vector CInt+selectI = selectG c_selectI+selectL :: Vector CInt -> Vector Z -> Vector Z -> Vector Z -> Vector Z+selectL = selectG c_selectL+selectC :: Vector CInt+ -> Vector (Complex Double)+ -> Vector (Complex Double)+ -> Vector (Complex Double)+ -> Vector (Complex Double)+selectC = selectG c_selectC+selectQ :: Vector CInt+ -> Vector (Complex Float)+ -> Vector (Complex Float)+ -> Vector (Complex Float)+ -> Vector (Complex Float)+selectQ = selectG c_selectQ++type Sel x = CV CInt (CV x (CV x (CV x (CV x (IO CInt)))))++foreign import ccall unsafe "chooseD" c_selectD :: Sel Double+foreign import ccall unsafe "chooseF" c_selectF :: Sel Float+foreign import ccall unsafe "chooseI" c_selectI :: Sel CInt+foreign import ccall unsafe "chooseC" c_selectC :: Sel (Complex Double)+foreign import ccall unsafe "chooseQ" c_selectQ :: Sel (Complex Float)+foreign import ccall unsafe "chooseL" c_selectL :: Sel Z++---------------------------------------------------------------------------++remapG :: (TransArray c, TransArray c1, Storable t, Storable a)+ => (CInt -> CInt -> CInt -> CInt -> Ptr t+ -> Trans c1 (Trans c (CInt -> CInt -> CInt -> CInt -> Ptr a -> IO CInt)))+ -> Matrix t -> c1 -> c -> Matrix a+remapG f i j m = unsafePerformIO $ do+ r <- createMatrix RowMajor (rows i) (cols i)+ (i # j # m #! r) f #|"remapG"+ return r++remapD :: Matrix CInt -> Matrix CInt -> Matrix Double -> Matrix Double+remapD = remapG c_remapD+remapF :: Matrix CInt -> Matrix CInt -> Matrix Float -> Matrix Float+remapF = remapG c_remapF+remapI :: Matrix CInt -> Matrix CInt -> Matrix CInt -> Matrix CInt+remapI = remapG c_remapI+remapL :: Matrix CInt -> Matrix CInt -> Matrix Z -> Matrix Z+remapL = remapG c_remapL+remapC :: Matrix CInt+ -> Matrix CInt+ -> Matrix (Complex Double)+ -> Matrix (Complex Double)+remapC = remapG c_remapC+remapQ :: Matrix CInt -> Matrix CInt -> Matrix (Complex Float) -> Matrix (Complex Float)+remapQ = remapG c_remapQ++type Rem x = OM CInt (OM CInt (OM x (OM x (IO CInt))))++foreign import ccall unsafe "remapD" c_remapD :: Rem Double+foreign import ccall unsafe "remapF" c_remapF :: Rem Float+foreign import ccall unsafe "remapI" c_remapI :: Rem CInt+foreign import ccall unsafe "remapC" c_remapC :: Rem (Complex Double)+foreign import ccall unsafe "remapQ" c_remapQ :: Rem (Complex Float)+foreign import ccall unsafe "remapL" c_remapL :: Rem Z++--------------------------------------------------------------------------------++rowOpAux :: (TransArray c, Storable a) =>+ (CInt -> Ptr a -> CInt -> CInt -> CInt -> CInt -> Trans c (IO CInt))+ -> Int -> a -> Int -> Int -> Int -> Int -> c -> IO ()+rowOpAux f c x i1 i2 j1 j2 m = do+ px <- newArray [x]+ (m # id) (f (fi c) px (fi i1) (fi i2) (fi j1) (fi j2)) #|"rowOp"+ free px++type RowOp x = CInt -> Ptr x -> CInt -> CInt -> CInt -> CInt -> x ::> Ok++foreign import ccall unsafe "rowop_double" c_rowOpD :: RowOp R+foreign import ccall unsafe "rowop_float" c_rowOpF :: RowOp Float+foreign import ccall unsafe "rowop_TCD" c_rowOpC :: RowOp C+foreign import ccall unsafe "rowop_TCF" c_rowOpQ :: RowOp (Complex Float)+foreign import ccall unsafe "rowop_int32_t" c_rowOpI :: RowOp I+foreign import ccall unsafe "rowop_int64_t" c_rowOpL :: RowOp Z+foreign import ccall unsafe "rowop_mod_int32_t" c_rowOpMI :: I -> RowOp I+foreign import ccall unsafe "rowop_mod_int64_t" c_rowOpML :: Z -> RowOp Z++--------------------------------------------------------------------------------++gemmg :: (TransArray c1, TransArray c, TransArray c2, TransArray c3)+ => Trans c3 (Trans c2 (Trans c1 (Trans c (IO CInt))))+ -> c3 -> c2 -> c1 -> c -> IO ()+gemmg f v m1 m2 m3 = (v # m1 # m2 #! m3) f #|"gemmg"++type Tgemm x = x :> x ::> x ::> x ::> Ok++foreign import ccall unsafe "gemm_double" c_gemmD :: Tgemm R+foreign import ccall unsafe "gemm_float" c_gemmF :: Tgemm Float+foreign import ccall unsafe "gemm_TCD" c_gemmC :: Tgemm C+foreign import ccall unsafe "gemm_TCF" c_gemmQ :: Tgemm (Complex Float)+foreign import ccall unsafe "gemm_int32_t" c_gemmI :: Tgemm I+foreign import ccall unsafe "gemm_int64_t" c_gemmL :: Tgemm Z+foreign import ccall unsafe "gemm_mod_int32_t" c_gemmMI :: I -> Tgemm I+foreign import ccall unsafe "gemm_mod_int64_t" c_gemmML :: Z -> Tgemm Z++--------------------------------------------------------------------------------++reorderAux :: (TransArray c, Storable t, Storable a1, Storable t1, Storable a) =>+ (CInt -> Ptr a -> CInt -> Ptr t1+ -> Trans c (CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt))+ -> Vector t1 -> c -> Vector t -> Vector a1+reorderAux f s d v = unsafePerformIO $ do+ k <- createVector (dim s)+ r <- createVector (dim v)+ (k # s # d # v #! r) f #| "reorderV"+ return r++type Reorder x = CV CInt (CV CInt (CV CInt (CV x (CV x (IO CInt)))))++foreign import ccall unsafe "reorderD" c_reorderD :: Reorder Double+foreign import ccall unsafe "reorderF" c_reorderF :: Reorder Float+foreign import ccall unsafe "reorderI" c_reorderI :: Reorder CInt+foreign import ccall unsafe "reorderC" c_reorderC :: Reorder (Complex Double)+foreign import ccall unsafe "reorderQ" c_reorderQ :: Reorder (Complex Float)+foreign import ccall unsafe "reorderL" c_reorderL :: Reorder Z++-- | Transpose an array with dimensions @dims@ by making a copy using @strides@. For example, for an array with 3 indices,+-- @(reorderVector strides dims v) ! ((i * dims ! 1 + j) * dims ! 2 + k) == v ! (i * strides ! 0 + j * strides ! 1 + k * strides ! 2)@+-- This function is intended to be used internally by tensor libraries.+reorderVector :: Element a+ => Vector CInt -- ^ @strides@: array strides+ -> Vector CInt -- ^ @dims@: array dimensions of new array @v@+ -> Vector a -- ^ @v@: flattened input array+ -> Vector a -- ^ @v'@: flattened output array+reorderVector = reorderV++--------------------------------------------------------------------------------++foreign import ccall unsafe "saveMatrix" c_saveMatrix+ :: CString -> CString -> Double ::> Ok++{- | save a matrix as a 2D ASCII table+-}+saveMatrix+ :: FilePath+ -> String -- ^ \"printf\" format (e.g. \"%.2f\", \"%g\", etc.)+ -> Matrix Double+ -> IO ()+saveMatrix name format m = do+ cname <- newCString name+ cformat <- newCString format+ (m # id) (c_saveMatrix cname cformat) #|"saveMatrix"+ free cname+ free cformat+ return ()++--------------------------------------------------------------------------------
+ src/Internal/Modular.hs view
@@ -0,0 +1,476 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{- |+Module : Internal.Modular+Copyright : (c) Alberto Ruiz 2015+License : BSD3+Stability : experimental++Proof of concept of statically checked modular arithmetic.++-}++module Internal.Modular(+ Mod, type (./.)+) where++import Internal.Vector+import Internal.Matrix hiding (size)+import Internal.Numeric+import Internal.Element+import Internal.Container+import Internal.Vectorized (prodI,sumI,prodL,sumL)+import Internal.LAPACK (multiplyI, multiplyL)+import Internal.Algorithms(luFact,LU(..))+import Internal.Util(Normed(..),Indexable(..),+ gaussElim, gaussElim_1, gaussElim_2,+ luST, luSolve', luPacked', magnit, invershur)+import Internal.ST(mutable)+#if MIN_VERSION_base(4,11,0)+import GHC.TypeLits hiding (Mod)+#else+import GHC.TypeLits+#endif+import Data.Proxy(Proxy)+import Foreign.ForeignPtr(castForeignPtr)+import Foreign.Storable+import Data.Ratio+import Data.Complex+import Control.DeepSeq ( NFData(..) )+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++++-- | Wrapper with a phantom integer for statically checked modular arithmetic.+newtype Mod (n :: Nat) t = Mod {unMod:: t}+ deriving (Storable)++instance (NFData t) => NFData (Mod n t)+ where+ rnf (Mod x) = rnf x++infixr 5 ./.+type (./.) x n = Mod n x++instance (Integral t, Enum t, KnownNat m) => Enum (Mod m t)+ where+ toEnum = l0 (\m x -> fromIntegral $ x `mod` (fromIntegral m))+ fromEnum = fromIntegral . unMod++instance (Eq t, KnownNat m) => Eq (Mod m t)+ where+ a == b = (unMod a) == (unMod b)++instance (Ord t, KnownNat m) => Ord (Mod m t)+ where+ compare a b = compare (unMod a) (unMod b)++instance (Integral t, Real t, KnownNat m) => Real (Mod m t)+ where+ toRational x = toInteger x % 1++instance (Integral t, KnownNat m) => Integral (Mod m t)+ where+ toInteger = toInteger . unMod+ quotRem a b = (Mod q, Mod r)+ where+ (q,r) = quotRem (unMod a) (unMod b)++-- | this instance is only valid for prime m+instance (Integral t, Show t, Eq t, KnownNat m) => Fractional (Mod m t)+ where+ recip x+ | x*r == 1 = r+ | otherwise = error $ show x ++" does not have a multiplicative inverse mod "++show m'+ where+ r = x^(m'-2 :: Integer)+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)++l2 :: forall m a b c. (Num c, KnownNat m) => (c -> a -> b -> c) -> Mod m a -> Mod m b -> Mod m c+l2 f (Mod u) (Mod v) = Mod (f m' u v)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++l1 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> Mod m a -> Mod m b+l1 f (Mod u) = Mod (f m' u)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++l0 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> a -> Mod m b+l0 f u = Mod (f m' u)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+++instance Show t => Show (Mod n t)+ where+ show = show . unMod++instance (Integral t, KnownNat n) => Num (Mod n t)+ where+ (+) = l2 (\m a b -> (a + b) `mod` (fromIntegral m))+ (*) = l2 (\m a b -> (a * b) `mod` (fromIntegral m))+ (-) = l2 (\m a b -> (a - b) `mod` (fromIntegral m))+ abs = l1 (const abs)+ signum = l1 (const signum)+ fromInteger = l0 (\m x -> fromInteger x `mod` (fromIntegral m))+++instance KnownNat m => Element (Mod m I)+ where+ constantD x n = i2f (constantD (unMod x) n)+ extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js+ setRect i j m x = setRect i j (f2iM m) (f2iM x)+ sortI = sortI . f2i+ sortV = i2f . sortV . f2i+ compareV u v = compareV (f2i u) (f2i v)+ selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g))+ remapM i j m = i2fM (remap i j (f2iM m))+ rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpMI m') c (unMod a) i1 i2 j1 j2 (f2iM x)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ gemm u a b c = gemmg (c_gemmMI m') (f2i u) (f2iM a) (f2iM b) (f2iM c)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ reorderV strides dims = i2f . reorderAux c_reorderI strides dims . f2i++instance KnownNat m => Element (Mod m Z)+ where+ constantD x n = i2f (constantD (unMod x) n)+ extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js+ setRect i j m x = setRect i j (f2iM m) (f2iM x)+ sortI = sortI . f2i+ sortV = i2f . sortV . f2i+ compareV u v = compareV (f2i u) (f2i v)+ selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g))+ remapM i j m = i2fM (remap i j (f2iM m))+ rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpML m') c (unMod a) i1 i2 j1 j2 (f2iM x)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ gemm u a b c = gemmg (c_gemmML m') (f2i u) (f2iM a) (f2iM b) (f2iM c)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ reorderV strides dims = i2f . reorderAux c_reorderL strides dims . f2i+++instance KnownNat m => CTrans (Mod m I)+instance KnownNat m => CTrans (Mod m Z)+++instance KnownNat m => Container Vector (Mod m I)+ where+ conj' = id+ size' = dim+ scale' s x = vmod (scale (unMod s) (f2i x))+ addConstant c x = vmod (addConstant (unMod c) (f2i x))+ add' a b = vmod (add' (f2i a) (f2i b))+ sub a b = vmod (sub (f2i a) (f2i b))+ mul a b = vmod (mul (f2i a) (f2i b))+ equal u v = equal (f2i u) (f2i v)+ scalar' x = fromList [x]+ konst' x = i2f . konst (unMod x)+ build' n f = build n (fromIntegral . f)+ cmap' = mapVector+ atIndex' x k = fromIntegral (atIndex (f2i x) k)+ minIndex' = minIndex . f2i+ maxIndex' = maxIndex . f2i+ minElement' = Mod . minElement . f2i+ maxElement' = Mod . maxElement . f2i+ sumElements' = fromIntegral . sumI m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ prodElements' = fromIntegral . prodI m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ step' = i2f . step . f2i+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' a b = ccompare (f2i a) (f2i b)+ cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g)+ scaleRecip s x = scale' s (cmap recip x)+ divide x y = mul x (cmap recip y)+ arctan2' = undefined+ cmod' m = vmod . cmod' (unMod m) . f2i+ fromInt' = vmod+ toInt' = f2i+ fromZ' = vmod . fromZ'+ toZ' = toZ' . f2i++instance KnownNat m => Container Vector (Mod m Z)+ where+ conj' = id+ size' = dim+ scale' s x = vmod (scale (unMod s) (f2i x))+ addConstant c x = vmod (addConstant (unMod c) (f2i x))+ add' a b = vmod (add' (f2i a) (f2i b))+ sub a b = vmod (sub (f2i a) (f2i b))+ mul a b = vmod (mul (f2i a) (f2i b))+ equal u v = equal (f2i u) (f2i v)+ scalar' x = fromList [x]+ konst' x = i2f . konst (unMod x)+ build' n f = build n (fromIntegral . f)+ cmap' = mapVector+ atIndex' x k = fromIntegral (atIndex (f2i x) k)+ minIndex' = minIndex . f2i+ maxIndex' = maxIndex . f2i+ minElement' = Mod . minElement . f2i+ maxElement' = Mod . maxElement . f2i+ sumElements' = fromIntegral . sumL m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ prodElements' = fromIntegral . prodL m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ step' = i2f . step . f2i+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' a b = ccompare (f2i a) (f2i b)+ cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g)+ scaleRecip s x = scale' s (cmap recip x)+ divide x y = mul x (cmap recip y)+ arctan2' = undefined+ cmod' m = vmod . cmod' (unMod m) . f2i+ fromInt' = vmod . fromInt'+ toInt' = toInt . f2i+ fromZ' = vmod+ toZ' = f2i+++instance (Storable t, Indexable (Vector t) t) => Indexable (Vector (Mod m t)) (Mod m t)+ where+ (!) = (@>)++type instance RealOf (Mod n I) = I+type instance RealOf (Mod n Z) = Z++instance KnownNat m => Product (Mod m I) where+ norm2 = undefined+ absSum = undefined+ norm1 = undefined+ normInf = undefined+ multiply = lift2m (multiplyI m')+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++instance KnownNat m => Product (Mod m Z) where+ norm2 = undefined+ absSum = undefined+ norm1 = undefined+ normInf = undefined+ multiply = lift2m (multiplyL m')+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++instance KnownNat m => Normed (Vector (Mod m I))+ where+ norm_0 = norm_0 . toInt+ norm_1 = norm_1 . toInt+ norm_2 = norm_2 . toInt+ norm_Inf = norm_Inf . toInt++instance KnownNat m => Normed (Vector (Mod m Z))+ where+ norm_0 = norm_0 . toZ+ norm_1 = norm_1 . toZ+ norm_2 = norm_2 . toZ+ norm_Inf = norm_Inf . toZ+++instance KnownNat m => Numeric (Mod m I)+instance KnownNat m => Numeric (Mod m Z)++i2f :: Storable t => Vector t -> Vector (Mod n t)+i2f v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n)+ where (fp,i,n) = unsafeToForeignPtr v++f2i :: Storable t => Vector (Mod n t) -> Vector t+f2i v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n)+ where (fp,i,n) = unsafeToForeignPtr v++f2iM :: (Element t, Element (Mod n t)) => Matrix (Mod n t) -> Matrix t+f2iM m = m { xdat = f2i (xdat m) }++i2fM :: (Element t, Element (Mod n t)) => Matrix t -> Matrix (Mod n t)+i2fM m = m { xdat = i2f (xdat m) }++vmod :: forall m t. (KnownNat m, Storable t, Integral t, Numeric t) => Vector t -> Vector (Mod m t)+vmod = i2f . cmod' m'+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++lift1 f a = vmod (f (f2i a))+lift2 f a b = vmod (f (f2i a) (f2i b))++lift2m f a b = liftMatrix vmod (f (f2iM a) (f2iM b))++instance KnownNat m => Num (Vector (Mod m I))+ where+ (+) = lift2 (+)+ (*) = lift2 (*)+ (-) = lift2 (-)+ abs = lift1 abs+ signum = lift1 signum+ negate = lift1 negate+ fromInteger x = fromInt (fromInteger x)++instance KnownNat m => Num (Vector (Mod m Z))+ where+ (+) = lift2 (+)+ (*) = lift2 (*)+ (-) = lift2 (-)+ abs = lift1 abs+ signum = lift1 signum+ negate = lift1 negate+ fromInteger x = fromZ (fromInteger x)++--------------------------------------------------------------------------------++instance (KnownNat m) => Testable (Matrix (Mod m I))+ where+ checkT _ = test++test = (ok, info)+ where+ v = fromList [3,-5,75] :: Vector (Mod 11 I)+ m = (3><3) [1..] :: Matrix (Mod 11 I)++ a = (3><3) [1,2 , 3+ ,4,5 , 6+ ,0,10,-3] :: Matrix I++ b = (3><2) [0..] :: Matrix I++ am = fromInt a :: Matrix (Mod 13 I)+ bm = fromInt b :: Matrix (Mod 13 I)+ ad = fromInt a :: Matrix Double+ bd = fromInt b :: Matrix Double++ g = (3><3) (repeat (40000)) :: Matrix I+ gm = fromInt g :: Matrix (Mod 100000 I)++ lg = (3><3) (repeat (3*10^(9::Int))) :: Matrix Z+ lgm = fromZ lg :: Matrix (Mod 10000000000 Z)++ gen n = diagRect 1 (konst 5 n) n n :: Numeric t => Matrix t+ + rgen n = gen n :: Matrix R+ cgen n = complex (rgen n) + fliprl (complex (rgen n)) * scalar (0:+1) :: Matrix C+ sgen n = single (cgen n)+ + checkGen x = norm_Inf $ flatten $ invg x <> x - ident (rows x)+ + invg t = gaussElim t (ident (rows t))++ checkLU okf t = norm_Inf $ flatten (l <> u <> p - t)+ where+ (l,u,p,_) = luFact (LU x' p')+ where+ (x',p') = mutable (luST okf) t++ checkSolve aa = norm_Inf $ flatten (aa <> x - bb)+ where+ bb = flipud aa+ x = luSolve' (luPacked' aa) bb++ tmm = diagRect 1 (fromList [2..6]) 5 5 :: Matrix (Mod 19 I)++ info = do+ print v+ print m+ print (tr m)+ print $ v+v+ print $ m+m+ print $ m <> m+ print $ m #> v++ print $ am <> gaussElim am bm - bm+ print $ ad <> gaussElim ad bd - bd++ print g+ print $ g <> g+ print gm+ print $ gm <> gm++ print lg+ print $ lg <> lg+ print lgm+ print $ lgm <> lgm+ + putStrLn "checkGen"+ print (checkGen (gen 5 :: Matrix R))+ print (checkGen (gen 5 :: Matrix Float))+ print (checkGen (cgen 5 :: Matrix C))+ print (checkGen (sgen 5 :: Matrix (Complex Float)))+ print (invg (gen 5) :: Matrix (Mod 7 I))+ print (invg (gen 5) :: Matrix (Mod 7 Z))+ + print $ mutable (luST (const True)) (gen 5 :: Matrix R)+ print $ mutable (luST (const True)) (gen 5 :: Matrix (Mod 11 Z))++ putStrLn "checkLU"+ print $ checkLU (magnit 0) (gen 5 :: Matrix R)+ print $ checkLU (magnit 0) (gen 5 :: Matrix Float)+ print $ checkLU (magnit 0) (cgen 5 :: Matrix C)+ print $ checkLU (magnit 0) (sgen 5 :: Matrix (Complex Float))+ print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))+ print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))++ putStrLn "checkSolve"+ print $ checkSolve (gen 5 :: Matrix R)+ print $ checkSolve (gen 5 :: Matrix Float)+ print $ checkSolve (cgen 5 :: Matrix C)+ print $ checkSolve (sgen 5 :: Matrix (Complex Float))+ print $ checkSolve (gen 5 :: Matrix (Mod 7 I))+ print $ checkSolve (gen 5 :: Matrix (Mod 7 Z))+ + putStrLn "luSolve'"+ print $ luSolve' (luPacked' tmm) (ident (rows tmm))+ print $ invershur tmm+++ ok = and+ [ toInt (m #> v) == cmod 11 (toInt m #> toInt v )+ , am <> gaussElim_1 am bm == bm+ , am <> gaussElim_2 am bm == bm+ , am <> gaussElim am bm == bm+ , (checkGen (gen 5 :: Matrix R)) < 1E-15+ , (checkGen (gen 5 :: Matrix Float)) < 2E-7+ , (checkGen (cgen 5 :: Matrix C)) < 1E-15+ , (checkGen (sgen 5 :: Matrix (Complex Float))) < 3E-7+ , (checkGen (gen 5 :: Matrix (Mod 7 I))) == 0+ , (checkGen (gen 5 :: Matrix (Mod 7 Z))) == 0+ , (checkLU (magnit 1E-10) (gen 5 :: Matrix R)) < 2E-15+ , (checkLU (magnit 1E-5) (gen 5 :: Matrix Float)) < 1E-6+ , (checkLU (magnit 1E-10) (cgen 5 :: Matrix C)) < 5E-15+ , (checkLU (magnit 1E-5) (sgen 5 :: Matrix (Complex Float))) < 1E-6+ , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))) == 0+ , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))) == 0+ , checkSolve (gen 5 :: Matrix R) < 2E-15+ , checkSolve (gen 5 :: Matrix Float) < 1E-6+ , checkSolve (cgen 5 :: Matrix C) < 4E-15+ , checkSolve (sgen 5 :: Matrix (Complex Float)) < 1E-6+ , checkSolve (gen 5 :: Matrix (Mod 7 I)) == 0+ , checkSolve (gen 5 :: Matrix (Mod 7 Z)) == 0+ , prodElements (konst (9:: Mod 10 I) (12::Int)) == product (replicate 12 (9:: Mod 10 I))+ , gm <> gm == konst 0 (3,3)+ , lgm <> lgm == konst 0 (3,3)+ , invershur tmm == luSolve' (luPacked' tmm) (ident (rows tmm))+ , luSolve' (luPacked' (tr $ ident 5 :: Matrix (I ./. 2))) (ident 5) == ident 5+ ]++
+ src/Internal/Numeric.hs view
@@ -0,0 +1,945 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Packed.Internal.Numeric+-- Copyright : (c) Alberto Ruiz 2010-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-----------------------------------------------------------------------------++module Internal.Numeric where++import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.ST as ST+import Internal.Conversion+import Internal.Vectorized+import Internal.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ,multiplyI,multiplyL)+import Data.List.Split(chunksOf)+import qualified Data.Vector.Storable as V++--------------------------------------------------------------------------------++type family IndexOf (c :: * -> *)++type instance IndexOf Vector = Int+type instance IndexOf Matrix = (Int,Int)++type family ArgOf (c :: * -> *) a++type instance ArgOf Vector a = a -> a+type instance ArgOf Matrix a = a -> a -> a++--------------------------------------------------------------------------------++-- | Basic element-by-element functions for numeric containers+class Element e => Container c e+ where+ conj' :: c e -> c e+ size' :: c e -> IndexOf c+ scalar' :: e -> c e+ scale' :: e -> c e -> c e+ addConstant :: e -> c e -> c e+ add' :: c e -> c e -> c e+ sub :: c e -> c e -> c e+ -- | element by element multiplication+ mul :: c e -> c e -> c e+ equal :: c e -> c e -> Bool+ cmap' :: (Element b) => (e -> b) -> c e -> c b+ konst' :: e -> IndexOf c -> c e+ build' :: IndexOf c -> (ArgOf c e) -> c e+ atIndex' :: c e -> IndexOf c -> e+ minIndex' :: c e -> IndexOf c+ maxIndex' :: c e -> IndexOf c+ minElement' :: c e -> e+ maxElement' :: c e -> e+ sumElements' :: c e -> e+ prodElements' :: c e -> e+ step' :: Ord e => c e -> c e+ ccompare' :: Ord e => c e -> c e -> c I+ cselect' :: c I -> c e -> c e -> c e -> c e+ find' :: (e -> Bool) -> c e -> [IndexOf c]+ assoc' :: IndexOf c -- ^ size+ -> e -- ^ default value+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result+ accum' :: c e -- ^ initial structure+ -> (e -> e -> e) -- ^ update function+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result++ -- | scale the element by element reciprocal of the object:+ --+ -- @scaleRecip 2 (fromList [5,i]) == 2 |> [0.4 :+ 0.0,0.0 :+ (-2.0)]@+ scaleRecip :: Fractional e => e -> c e -> c e+ -- | element by element division+ divide :: Fractional e => c e -> c e -> c e+ --+ -- element by element inverse tangent+ arctan2' :: Fractional e => c e -> c e -> c e+ cmod' :: Integral e => e -> c e -> c e+ fromInt' :: c I -> c e+ toInt' :: c e -> c I+ fromZ' :: c Z -> c e+ toZ' :: c e -> c Z++--------------------------------------------------------------------------++instance Container Vector I+ where+ conj' = id+ size' = dim+ scale' = vectorMapValI Scale+ addConstant = vectorMapValI AddConstant+ add' = vectorZipI Add+ sub = vectorZipI Sub+ mul = vectorZipI Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarI MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarI MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarI Min)+ maxElement' = emptyErrorV "maxElement" (toScalarI Max)+ sumElements' = sumI 1+ prodElements' = prodI 1+ step' = stepI+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = undefined -- cannot match+ divide = undefined+ arctan2' = undefined+ cmod' m x+ | m /= 0 = vectorMapValI ModVS m x+ | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x)+ fromInt' = id+ toInt' = id+ fromZ' = long2intV+ toZ' = int2longV+++instance Container Vector Z+ where+ conj' = id+ size' = dim+ scale' = vectorMapValL Scale+ addConstant = vectorMapValL AddConstant+ add' = vectorZipL Add+ sub = vectorZipL Sub+ mul = vectorZipL Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarL MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarL MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarL Min)+ maxElement' = emptyErrorV "maxElement" (toScalarL Max)+ sumElements' = sumL 1+ prodElements' = prodL 1+ step' = stepL+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = undefined -- cannot match+ divide = undefined+ arctan2' = undefined+ cmod' m x+ | m /= 0 = vectorMapValL ModVS m x+ | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x)+ fromInt' = int2longV+ toInt' = long2intV+ fromZ' = id+ toZ' = id++++instance Container Vector Float+ where+ conj' = id+ size' = dim+ scale' = vectorMapValF Scale+ addConstant = vectorMapValF AddConstant+ add' = vectorZipF Add+ sub = vectorZipF Sub+ mul = vectorZipF Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (round . toScalarF MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (round . toScalarF MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarF Min)+ maxElement' = emptyErrorV "maxElement" (toScalarF Max)+ sumElements' = sumF+ prodElements' = prodF+ step' = stepF+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = vectorMapValF Recip+ divide = vectorZipF Div+ arctan2' = vectorZipF ATan2+ cmod' = undefined+ fromInt' = int2floatV+ toInt' = float2IntV+ fromZ' = (single :: Vector R-> Vector Float) . fromZ'+ toZ' = toZ' . double+++instance Container Vector Double+ where+ conj' = id+ size' = dim+ scale' = vectorMapValR Scale+ addConstant = vectorMapValR AddConstant+ add' = vectorZipR Add+ sub = vectorZipR Sub+ mul = vectorZipR Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (round . toScalarR MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (round . toScalarR MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarR Min)+ maxElement' = emptyErrorV "maxElement" (toScalarR Max)+ sumElements' = sumR+ prodElements' = prodR+ step' = stepD+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = vectorMapValR Recip+ divide = vectorZipR Div+ arctan2' = vectorZipR ATan2+ cmod' = undefined+ fromInt' = int2DoubleV+ toInt' = double2IntV+ fromZ' = long2DoubleV+ toZ' = double2longV+++instance Container Vector (Complex Double)+ where+ conj' = conjugateC+ size' = dim+ scale' = vectorMapValC Scale+ addConstant = vectorMapValC AddConstant+ add' = vectorZipC Add+ sub = vectorZipC Sub+ mul = vectorZipC Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj'))+ maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj'))+ minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex')+ maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex')+ sumElements' = sumC+ prodElements' = prodC+ step' = undefined -- cannot match+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = undefined -- cannot match+ cselect' = selectCV selectV+ scaleRecip = vectorMapValC Recip+ divide = vectorZipC Div+ arctan2' = vectorZipC ATan2+ cmod' = undefined+ fromInt' = complex . int2DoubleV+ toInt' = toInt' . fst . fromComplex+ fromZ' = complex . long2DoubleV+ toZ' = toZ' . fst . fromComplex++instance Container Vector (Complex Float)+ where+ conj' = conjugateQ+ size' = dim+ scale' = vectorMapValQ Scale+ addConstant = vectorMapValQ AddConstant+ add' = vectorZipQ Add+ sub = vectorZipQ Sub+ mul = vectorZipQ Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj'))+ maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj'))+ minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex')+ maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex')+ sumElements' = sumQ+ prodElements' = prodQ+ step' = undefined -- cannot match+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = undefined -- cannot match+ cselect' = selectCV selectV+ scaleRecip = vectorMapValQ Recip+ divide = vectorZipQ Div+ arctan2' = vectorZipQ ATan2+ cmod' = undefined+ fromInt' = complex . int2floatV+ toInt' = toInt' . fst . fromComplex+ fromZ' = complex . single . long2DoubleV+ toZ' = toZ' . double . fst . fromComplex++---------------------------------------------------------------++instance (Num a, Element a, Container Vector a) => Container Matrix a+ where+ conj' = liftMatrix conj'+ size' = size+ scale' x = liftMatrix (scale' x)+ addConstant x = liftMatrix (addConstant x)+ add' = liftMatrix2 add'+ sub = liftMatrix2 sub+ mul = liftMatrix2 mul+ equal a b = cols a == cols b && flatten a `equal` flatten b+ scalar' x = (1><1) [x]+ konst' v (r,c) = matrixFromVector RowMajor r c (konst' v (r*c))+ build' = buildM+ cmap' f = liftMatrix (mapVector f)+ atIndex' = (@@>)+ minIndex' = emptyErrorM "minIndex of Matrix" $+ \m -> divMod (minIndex' $ flatten m) (cols m)+ maxIndex' = emptyErrorM "maxIndex of Matrix" $+ \m -> divMod (maxIndex' $ flatten m) (cols m)+ minElement' = emptyErrorM "minElement of Matrix" (atIndex' <*> minIndex')+ maxElement' = emptyErrorM "maxElement of Matrix" (atIndex' <*> maxIndex')+ sumElements' = sumElements' . flatten+ prodElements' = prodElements' . flatten+ step' = liftMatrix step'+ find' = findM+ assoc' = assocM+ accum' = accumM+ ccompare' = compareM+ cselect' = selectM+ scaleRecip x = liftMatrix (scaleRecip x)+ divide = liftMatrix2 divide+ arctan2' = liftMatrix2 arctan2'+ cmod' m x+ | m /= 0 = liftMatrix (cmod' m) x+ | otherwise = error $ "cmod 0 on matrix "++shSize x+ fromInt' = liftMatrix fromInt'+ toInt' = liftMatrix toInt'+ fromZ' = liftMatrix fromZ'+ toZ' = liftMatrix toZ'+++emptyErrorV msg f v =+ if dim v > 0+ then f v+ else error $ msg ++ " of empty Vector"++emptyErrorM msg f m =+ if rows m > 0 && cols m > 0+ then f m+ else error $ msg++" "++shSize m++--------------------------------------------------------------------------------++-- | create a structure with a single element+--+-- >>> let v = fromList [1..3::Double]+-- >>> v / scalar (norm2 v)+-- fromList [0.2672612419124244,0.5345224838248488,0.8017837257372732]+--+scalar :: Container c e => e -> c e+scalar = scalar'++-- | complex conjugate+conj :: Container c e => c e -> c e+conj = conj'+++arctan2 :: (Fractional e, Container c e) => c e -> c e -> c e+arctan2 = arctan2'++-- | 'mod' for integer arrays+--+-- >>> cmod 3 (range 5)+-- fromList [0,1,2,0,1]+cmod :: (Integral e, Container c e) => e -> c e -> c e+cmod = cmod'++-- |+-- >>>fromInt ((2><2) [0..3]) :: Matrix (Complex Double)+-- (2><2)+-- [ 0.0 :+ 0.0, 1.0 :+ 0.0+-- , 2.0 :+ 0.0, 3.0 :+ 0.0 ]+--+fromInt :: (Container c e) => c I -> c e+fromInt = fromInt'++toInt :: (Container c e) => c e -> c I+toInt = toInt'++fromZ :: (Container c e) => c Z -> c e+fromZ = fromZ'++toZ :: (Container c e) => c e -> c Z+toZ = toZ'++-- | like 'fmap' (cannot implement instance Functor because of Element class constraint)+cmap :: (Element b, Container c e) => (e -> b) -> c e -> c b+cmap = cmap'++-- | generic indexing function+--+-- >>> vector [1,2,3] `atIndex` 1+-- 2.0+--+-- >>> matrix 3 [0..8] `atIndex` (2,0)+-- 6.0+--+atIndex :: Container c e => c e -> IndexOf c -> e+atIndex = atIndex'++-- | index of minimum element+minIndex :: Container c e => c e -> IndexOf c+minIndex = minIndex'++-- | index of maximum element+maxIndex :: Container c e => c e -> IndexOf c+maxIndex = maxIndex'++-- | value of minimum element+minElement :: Container c e => c e -> e+minElement = minElement'++-- | value of maximum element+maxElement :: Container c e => c e -> e+maxElement = maxElement'++-- | the sum of elements+sumElements :: Container c e => c e -> e+sumElements = sumElements'++-- | the product of elements+prodElements :: Container c e => c e -> e+prodElements = prodElements'+++-- | A more efficient implementation of @cmap (\\x -> if x>0 then 1 else 0)@+--+-- >>> step $ linspace 5 (-1,1::Double)+-- 5 |> [0.0,0.0,0.0,1.0,1.0]+--+step+ :: (Ord e, Container c e)+ => c e+ -> c e+step = step'+++-- | Element by element version of @case compare a b of {LT -> l; EQ -> e; GT -> g}@.+--+-- Arguments with any dimension = 1 are automatically expanded:+--+-- >>> cond ((1><4)[1..]) ((3><1)[1..]) 0 100 ((3><4)[1..]) :: Matrix Double+-- (3><4)+-- [ 100.0, 2.0, 3.0, 4.0+-- , 0.0, 100.0, 7.0, 8.0+-- , 0.0, 0.0, 100.0, 12.0 ]+--+-- >>> let chop x = cond (abs x) 1E-6 0 0 x+--+cond+ :: (Ord e, Container c e, Container c x)+ => c e -- ^ a+ -> c e -- ^ b+ -> c x -- ^ l+ -> c x -- ^ e+ -> c x -- ^ g+ -> c x -- ^ result+cond a b l e g = cselect' (ccompare' a b) l e g+++-- | Find index of elements which satisfy a predicate+--+-- >>> find (>0) (ident 3 :: Matrix Double)+-- [(0,0),(1,1),(2,2)]+--+find+ :: Container c e+ => (e -> Bool)+ -> c e+ -> [IndexOf c]+find = find'+++-- | Create a structure from an association list+--+-- >>> assoc 5 0 [(3,7),(1,4)] :: Vector Double+-- fromList [0.0,4.0,0.0,7.0,0.0]+--+-- >>> assoc (2,3) 0 [((0,2),7),((1,0),2*i-3)] :: Matrix (Complex Double)+-- (2><3)+-- [ 0.0 :+ 0.0, 0.0 :+ 0.0, 7.0 :+ 0.0+-- , (-3.0) :+ 2.0, 0.0 :+ 0.0, 0.0 :+ 0.0 ]+--+assoc+ :: Container c e+ => IndexOf c -- ^ size+ -> e -- ^ default value+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result+assoc = assoc'+++-- | Modify a structure using an update function+--+-- >>> accum (ident 5) (+) [((1,1),5),((0,3),3)] :: Matrix Double+-- (5><5)+-- [ 1.0, 0.0, 0.0, 3.0, 0.0+-- , 0.0, 6.0, 0.0, 0.0, 0.0+-- , 0.0, 0.0, 1.0, 0.0, 0.0+-- , 0.0, 0.0, 0.0, 1.0, 0.0+-- , 0.0, 0.0, 0.0, 0.0, 1.0 ]+--+-- computation of histogram:+--+-- >>> accum (konst 0 7) (+) (map (flip (,) 1) [4,5,4,1,5,2,5]) :: Vector Double+-- fromList [0.0,1.0,1.0,0.0,2.0,3.0,0.0]+--+accum+ :: Container c e+ => c e -- ^ initial structure+ -> (e -> e -> e) -- ^ update function+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result+accum = accum'++--------------------------------------------------------------------------------++class Konst e d c | d -> c, c -> d+ where+ -- |+ -- >>> konst 7 3 :: Vector Float+ -- fromList [7.0,7.0,7.0]+ --+ -- >>> konst i (3::Int,4::Int)+ -- (3><4)+ -- [ 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0+ -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0+ -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 ]+ --+ konst :: e -> d -> c e++instance Container Vector e => Konst e Int Vector+ where+ konst = konst'++instance (Num e, Container Vector e) => Konst e (Int,Int) Matrix+ where+ konst = konst'++--------------------------------------------------------------------------------++class ( Container Vector t+ , Container Matrix t+ , Konst t Int Vector+ , Konst t (Int,Int) Matrix+ , CTrans t+ , Product t+ , Additive (Vector t)+ , Additive (Matrix t)+ , Linear t Vector+ , Linear t Matrix+ ) => Numeric t++instance Numeric Double+instance Numeric (Complex Double)+instance Numeric Float+instance Numeric (Complex Float)+instance Numeric I+instance Numeric Z++--------------------------------------------------------------------------------++--------------------------------------------------------------------------------++-- | Matrix product and related functions+class (Num e, Element e) => Product e where+ -- | matrix product+ multiply :: Matrix e -> Matrix e -> Matrix e+ -- | sum of absolute value of elements (differs in complex case from @norm1@)+ absSum :: Vector e -> RealOf e+ -- | sum of absolute value of elements+ norm1 :: Vector e -> RealOf e+ -- | euclidean norm+ norm2 :: Floating e => Vector e -> RealOf e+ -- | element of maximum magnitude+ normInf :: Vector e -> RealOf e++instance Product Float where+ norm2 = emptyVal (toScalarF Norm2)+ absSum = emptyVal (toScalarF AbsSum)+ norm1 = emptyVal (toScalarF AbsSum)+ normInf = emptyVal (maxElement . vectorMapF Abs)+ multiply = emptyMul multiplyF++instance Product Double where+ norm2 = emptyVal (toScalarR Norm2)+ absSum = emptyVal (toScalarR AbsSum)+ norm1 = emptyVal (toScalarR AbsSum)+ normInf = emptyVal (maxElement . vectorMapR Abs)+ multiply = emptyMul multiplyR++instance Product (Complex Float) where+ norm2 = emptyVal (toScalarQ Norm2)+ absSum = emptyVal (toScalarQ AbsSum)+ norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapQ Abs)+ normInf = emptyVal (maxElement . fst . fromComplex . vectorMapQ Abs)+ multiply = emptyMul multiplyQ++instance Product (Complex Double) where+ norm2 = emptyVal (toScalarC Norm2)+ absSum = emptyVal (toScalarC AbsSum)+ norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapC Abs)+ normInf = emptyVal (maxElement . fst . fromComplex . vectorMapC Abs)+ multiply = emptyMul multiplyC++instance Product I where+ norm2 = undefined+ absSum = emptyVal (sumElements . vectorMapI Abs)+ norm1 = absSum+ normInf = emptyVal (maxElement . vectorMapI Abs)+ multiply = emptyMul (multiplyI 1)++instance Product Z where+ norm2 = undefined+ absSum = emptyVal (sumElements . vectorMapL Abs)+ norm1 = absSum+ normInf = emptyVal (maxElement . vectorMapL Abs)+ multiply = emptyMul (multiplyL 1)+++emptyMul m a b+ | x1 == 0 && x2 == 0 || r == 0 || c == 0 = konst' 0 (r,c)+ | otherwise = m a b+ where+ r = rows a+ x1 = cols a+ x2 = rows b+ c = cols b++emptyVal f v =+ if dim v > 0+ then f v+ else 0++-- FIXME remove unused C wrappers+-- | unconjugated dot product+udot :: Product e => Vector e -> Vector e -> e+udot u v+ | dim u == dim v = val (asRow u `multiply` asColumn v)+ | otherwise = error $ "different dimensions "++show (dim u)++" and "++show (dim v)++" in dot product"+ where+ val m | dim u > 0 = m@@>(0,0)+ | otherwise = 0++----------------------------------------------------------++-- synonym for matrix product+mXm :: Product t => Matrix t -> Matrix t -> Matrix t+mXm = multiply++-- matrix - vector product+mXv :: Product t => Matrix t -> Vector t -> Vector t+mXv m v = flatten $ m `mXm` (asColumn v)++-- vector - matrix product+vXm :: Product t => Vector t -> Matrix t -> Vector t+vXm v m = flatten $ (asRow v) `mXm` m++{- | Outer product of two vectors.++>>> fromList [1,2,3] `outer` fromList [5,2,3]+(3><3)+ [ 5.0, 2.0, 3.0+ , 10.0, 4.0, 6.0+ , 15.0, 6.0, 9.0 ]++-}+outer :: (Product t) => Vector t -> Vector t -> Matrix t+outer u v = asColumn u `multiply` asRow v++{- | Kronecker product of two matrices.++@m1=(2><3)+ [ 1.0, 2.0, 0.0+ , 0.0, -1.0, 3.0 ]+m2=(4><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0 ]@++>>> kronecker m1 m2+(8><9)+ [ 1.0, 2.0, 3.0, 2.0, 4.0, 6.0, 0.0, 0.0, 0.0+ , 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.0, 0.0, 0.0+ , 7.0, 8.0, 9.0, 14.0, 16.0, 18.0, 0.0, 0.0, 0.0+ , 10.0, 11.0, 12.0, 20.0, 22.0, 24.0, 0.0, 0.0, 0.0+ , 0.0, 0.0, 0.0, -1.0, -2.0, -3.0, 3.0, 6.0, 9.0+ , 0.0, 0.0, 0.0, -4.0, -5.0, -6.0, 12.0, 15.0, 18.0+ , 0.0, 0.0, 0.0, -7.0, -8.0, -9.0, 21.0, 24.0, 27.0+ , 0.0, 0.0, 0.0, -10.0, -11.0, -12.0, 30.0, 33.0, 36.0 ]++-}+kronecker :: (Product t) => Matrix t -> Matrix t -> Matrix t+kronecker a b = fromBlocks+ . chunksOf (cols a)+ . map (reshape (cols b))+ . toRows+ $ flatten a `outer` flatten b++-------------------------------------------------------------------+++class Convert t where+ real :: Complexable c => c (RealOf t) -> c t+ complex :: Complexable c => c t -> c (ComplexOf t)+ single :: Complexable c => c t -> c (SingleOf t)+ double :: Complexable c => c t -> c (DoubleOf t)+ toComplex :: (Complexable c, RealElement t) => (c t, c t) -> c (Complex t)+ fromComplex :: (Complexable c, RealElement t) => c (Complex t) -> (c t, c t)+++instance Convert Double where+ real = id+ complex = comp'+ single = single'+ double = id+ toComplex = toComplex'+ fromComplex = fromComplex'++instance Convert Float where+ real = id+ complex = comp'+ single = id+ double = double'+ toComplex = toComplex'+ fromComplex = fromComplex'++instance Convert (Complex Double) where+ real = comp'+ complex = id+ single = single'+ double = id+ toComplex = toComplex'+ fromComplex = fromComplex'++instance Convert (Complex Float) where+ real = comp'+ complex = id+ single = id+ double = double'+ toComplex = toComplex'+ fromComplex = fromComplex'++-------------------------------------------------------------------++type family RealOf x++type instance RealOf Double = Double+type instance RealOf (Complex Double) = Double++type instance RealOf Float = Float+type instance RealOf (Complex Float) = Float++type instance RealOf I = I+type instance RealOf Z = Z++type ComplexOf x = Complex (RealOf x)++type family SingleOf x++type instance SingleOf Double = Float+type instance SingleOf Float = Float++type instance SingleOf (Complex a) = Complex (SingleOf a)++type family DoubleOf x++type instance DoubleOf Double = Double+type instance DoubleOf Float = Double++type instance DoubleOf (Complex a) = Complex (DoubleOf a)++type family ElementOf c++type instance ElementOf (Vector a) = a+type instance ElementOf (Matrix a) = a++------------------------------------------------------------++buildM (rc,cc) f = fromLists [ [f r c | c <- cs] | r <- rs ]+ where rs = map fromIntegral [0 .. (rc-1)]+ cs = map fromIntegral [0 .. (cc-1)]++buildV n f = fromList [f k | k <- ks]+ where ks = map fromIntegral [0 .. (n-1)]++--------------------------------------------------------++-- | Creates a square matrix with a given diagonal.+diag :: (Num a, Element a) => Vector a -> Matrix a+diag v = diagRect 0 v n n where n = dim v++-- | creates the identity matrix of given dimension+ident :: (Num a, Element a) => Int -> Matrix a+ident n = diag (constantD 1 n)++--------------------------------------------------------++findV p x = foldVectorWithIndex g [] x where+ g k z l = if p z then k:l else l++findM p x = map ((`divMod` cols x)) $ findV p (flatten x)++assocV n z xs = ST.runSTVector $ do+ v <- ST.newVector z n+ mapM_ (\(k,x) -> ST.writeVector v k x) xs+ return v++assocM (r,c) z xs = ST.runSTMatrix $ do+ m <- ST.newMatrix z r c+ mapM_ (\((i,j),x) -> ST.writeMatrix m i j x) xs+ return m++accumV v0 f xs = ST.runSTVector $ do+ v <- ST.thawVector v0+ mapM_ (\(k,x) -> ST.modifyVector v k (f x)) xs+ return v++accumM m0 f xs = ST.runSTMatrix $ do+ m <- ST.thawMatrix m0+ mapM_ (\((i,j),x) -> ST.modifyMatrix m i j (f x)) xs+ return m++----------------------------------------------------------------------++compareM a b = matrixFromVector RowMajor (rows a'') (cols a'') $ ccompare' a' b'+ where+ args@(a'':_) = conformMs [a,b]+ [a', b'] = map flatten args++compareCV f a b = f a' b'+ where+ [a', b'] = conformVs [a,b]++selectM c l e t = matrixFromVector RowMajor (rows a'') (cols a'') $ cselect' (toInt c') l' e' t'+ where+ args@(a'':_) = conformMs [fromInt c,l,e,t]+ [c', l', e', t'] = map flatten args++selectCV f c l e t = f (toInt c') l' e' t'+ where+ [c', l', e', t'] = conformVs [fromInt c,l,e,t]++--------------------------------------------------------------------------------++class CTrans t+ where+ ctrans :: Matrix t -> Matrix t+ ctrans = trans++instance CTrans Float+instance CTrans R+instance CTrans I+instance CTrans Z++instance CTrans C+ where+ ctrans = conj . trans++instance CTrans (Complex Float)+ where+ ctrans = conj . trans++class Transposable m mt | m -> mt, mt -> m+ where+ -- | conjugate transpose+ tr :: m -> mt+ -- | transpose+ tr' :: m -> mt++instance (CTrans t, Container Vector t) => Transposable (Matrix t) (Matrix t)+ where+ tr = ctrans+ tr' = trans++class Additive c+ where+ add :: c -> c -> c++class Linear t c+ where+ scale :: t -> c t -> c t+++instance Container Vector t => Linear t Vector+ where+ scale = scale'++instance Container Matrix t => Linear t Matrix+ where+ scale = scale'++instance Container Vector t => Additive (Vector t)+ where+ add = add'++instance Container Matrix t => Additive (Matrix t)+ where+ add = add'+++class Testable t+ where+ checkT :: t -> (Bool, IO())+ ioCheckT :: t -> IO (Bool, IO())+ ioCheckT = return . checkT++--------------------------------------------------------------------------------+
+ src/Internal/Random.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module : Numeric.LinearAlgebra.Random+-- Copyright : (c) Alberto Ruiz 2009-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Random vectors and matrices.+--+-----------------------------------------------------------------------------++module Internal.Random (+ Seed,+ RandDist(..),+ randomVector,+ gaussianSample,+ uniformSample,+ rand, randn+) where++import Internal.Vectorized+import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import Internal.Algorithms+import System.Random(randomIO)++-- | Obtains a matrix whose rows are pseudorandom samples from a multivariate+-- Gaussian distribution.+gaussianSample :: Seed+ -> Int -- ^ number of rows+ -> Vector Double -- ^ mean vector+ -> Herm Double -- ^ covariance matrix+ -> Matrix Double -- ^ result+gaussianSample seed n med cov = m where+ c = dim med+ meds = konst' 1 n `outer` med+ rs = reshape c $ randomVector seed Gaussian (c * n)+ m = rs `mXm` chol cov `add` meds++-- | Obtains a matrix whose rows are pseudorandom samples from a multivariate+-- uniform distribution.+uniformSample :: Seed+ -> Int -- ^ number of rows+ -> [(Double,Double)] -- ^ ranges for each column+ -> Matrix Double -- ^ result+uniformSample seed n rgs = m where+ (as,bs) = unzip rgs+ a = fromList as+ cs = zipWith subtract as bs+ d = dim a+ dat = toRows $ reshape n $ randomVector seed Uniform (n*d)+ am = konst' 1 n `outer` a+ m = fromColumns (zipWith scale cs dat) `add` am++-- | pseudorandom matrix with uniform elements between 0 and 1+randm :: RandDist+ -> Int -- ^ rows+ -> Int -- ^ columns+ -> IO (Matrix Double)+randm d r c = do+ seed <- randomIO+ return (reshape c $ randomVector seed d (r*c))++-- | pseudorandom matrix with uniform elements between 0 and 1+rand :: Int -> Int -> IO (Matrix Double)+rand = randm Uniform++{- | pseudorandom matrix with normal elements++>>> disp 3 =<< randn 3 5+3x5+0.386 -1.141 0.491 -0.510 1.512+0.069 -0.919 1.022 -0.181 0.745+0.313 -0.670 -0.097 -1.575 -0.583++-}+randn :: Int -> Int -> IO (Matrix Double)+randn = randm Gaussian+
+ src/Internal/ST.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------+-- |+-- Module : Internal.ST+-- Copyright : (c) Alberto Ruiz 2008+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- In-place manipulation inside the ST monad.+-- See @examples/inplace.hs@ in the repository.+--+-----------------------------------------------------------------------------++module Internal.ST (+ ST, runST,+ -- * Mutable Vectors+ STVector, newVector, thawVector, freezeVector, runSTVector,+ readVector, writeVector, modifyVector, liftSTVector,+ -- * Mutable Matrices+ STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix,+ readMatrix, writeMatrix, modifyMatrix, liftSTMatrix,+ mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..),+ -- * Unsafe functions+ newUndefinedVector,+ unsafeReadVector, unsafeWriteVector,+ unsafeThawVector, unsafeFreezeVector,+ newUndefinedMatrix,+ unsafeReadMatrix, unsafeWriteMatrix,+ unsafeThawMatrix, unsafeFreezeMatrix+) where++import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import Control.Monad.ST(ST, runST)+import Foreign.Storable(Storable, peekElemOff, pokeElemOff)+import Control.Monad.ST.Unsafe(unsafeIOToST)++{-# INLINE ioReadV #-}+ioReadV :: Storable t => Vector t -> Int -> IO t+ioReadV v k = unsafeWith v $ \s -> peekElemOff s k++{-# INLINE ioWriteV #-}+ioWriteV :: Storable t => Vector t -> Int -> t -> IO ()+ioWriteV v k x = unsafeWith v $ \s -> pokeElemOff s k x++newtype STVector s t = STVector (Vector t)++thawVector :: Storable t => Vector t -> ST s (STVector s t)+thawVector = unsafeIOToST . fmap STVector . cloneVector++unsafeThawVector :: Storable t => Vector t -> ST s (STVector s t)+unsafeThawVector = unsafeIOToST . return . STVector++runSTVector :: Storable t => (forall s . ST s (STVector s t)) -> Vector t+runSTVector st = runST (st >>= unsafeFreezeVector)++{-# INLINE unsafeReadVector #-}+unsafeReadVector :: Storable t => STVector s t -> Int -> ST s t+unsafeReadVector (STVector x) = unsafeIOToST . ioReadV x++{-# INLINE unsafeWriteVector #-}+unsafeWriteVector :: Storable t => STVector s t -> Int -> t -> ST s ()+unsafeWriteVector (STVector x) k = unsafeIOToST . ioWriteV x k++{-# INLINE modifyVector #-}+modifyVector :: (Storable t) => STVector s t -> Int -> (t -> t) -> ST s ()+modifyVector x k f = readVector x k >>= return . f >>= unsafeWriteVector x k++liftSTVector :: (Storable t) => (Vector t -> a) -> STVector s t -> ST s a+liftSTVector f (STVector x) = unsafeIOToST . fmap f . cloneVector $ x++freezeVector :: (Storable t) => STVector s t -> ST s (Vector t)+freezeVector v = liftSTVector id v++unsafeFreezeVector :: (Storable t) => STVector s t -> ST s (Vector t)+unsafeFreezeVector (STVector x) = unsafeIOToST . return $ x++{-# INLINE safeIndexV #-}+safeIndexV :: Storable t2+ => (STVector s t2 -> Int -> t) -> STVector t1 t2 -> Int -> t+safeIndexV f (STVector v) k+ | k < 0 || k>= dim v = error $ "out of range error in vector (dim="+ ++show (dim v)++", pos="++show k++")"+ | otherwise = f (STVector v) k++{-# INLINE readVector #-}+readVector :: Storable t => STVector s t -> Int -> ST s t+readVector = safeIndexV unsafeReadVector++{-# INLINE writeVector #-}+writeVector :: Storable t => STVector s t -> Int -> t -> ST s ()+writeVector = safeIndexV unsafeWriteVector++newUndefinedVector :: Storable t => Int -> ST s (STVector s t)+newUndefinedVector = unsafeIOToST . fmap STVector . createVector++{-# INLINE newVector #-}+newVector :: Storable t => t -> Int -> ST s (STVector s t)+newVector x n = do+ v <- newUndefinedVector n+ let go (-1) = return v+ go !k = unsafeWriteVector v k x >> go (k-1 :: Int)+ go (n-1)++-------------------------------------------------------------------------++{-# INLINE ioReadM #-}+ioReadM :: Storable t => Matrix t -> Int -> Int -> IO t+ioReadM m r c = ioReadV (xdat m) (r * xRow m + c * xCol m)+++{-# INLINE ioWriteM #-}+ioWriteM :: Storable t => Matrix t -> Int -> Int -> t -> IO ()+ioWriteM m r c val = ioWriteV (xdat m) (r * xRow m + c * xCol m) val+++newtype STMatrix s t = STMatrix (Matrix t)++thawMatrix :: Element t => Matrix t -> ST s (STMatrix s t)+thawMatrix = unsafeIOToST . fmap STMatrix . cloneMatrix++unsafeThawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t)+unsafeThawMatrix = unsafeIOToST . return . STMatrix++runSTMatrix :: Storable t => (forall s . ST s (STMatrix s t)) -> Matrix t+runSTMatrix st = runST (st >>= unsafeFreezeMatrix)++{-# INLINE unsafeReadMatrix #-}+unsafeReadMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t+unsafeReadMatrix (STMatrix x) r = unsafeIOToST . ioReadM x r++{-# INLINE unsafeWriteMatrix #-}+unsafeWriteMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()+unsafeWriteMatrix (STMatrix x) r c = unsafeIOToST . ioWriteM x r c++{-# INLINE modifyMatrix #-}+modifyMatrix :: (Storable t) => STMatrix s t -> Int -> Int -> (t -> t) -> ST s ()+modifyMatrix x r c f = readMatrix x r c >>= return . f >>= unsafeWriteMatrix x r c++liftSTMatrix :: (Element t) => (Matrix t -> a) -> STMatrix s t -> ST s a+liftSTMatrix f (STMatrix x) = unsafeIOToST . fmap f . cloneMatrix $ x++unsafeFreezeMatrix :: (Storable t) => STMatrix s t -> ST s (Matrix t)+unsafeFreezeMatrix (STMatrix x) = unsafeIOToST . return $ x+++freezeMatrix :: (Element t) => STMatrix s t -> ST s (Matrix t)+freezeMatrix m = liftSTMatrix id m++cloneMatrix :: Element t => Matrix t -> IO (Matrix t)+cloneMatrix m = copy (orderOf m) m++{-# INLINE safeIndexM #-}+safeIndexM :: (STMatrix s t2 -> Int -> Int -> t)+ -> STMatrix t1 t2 -> Int -> Int -> t+safeIndexM f (STMatrix m) r c+ | r<0 || r>=rows m ||+ c<0 || c>=cols m = error $ "out of range error in matrix (size="+ ++show (rows m,cols m)++", pos="++show (r,c)++")"+ | otherwise = f (STMatrix m) r c++{-# INLINE readMatrix #-}+readMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t+readMatrix = safeIndexM unsafeReadMatrix++{-# INLINE writeMatrix #-}+writeMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()+writeMatrix = safeIndexM unsafeWriteMatrix++setMatrix :: Element t => STMatrix s t -> Int -> Int -> Matrix t -> ST s ()+setMatrix (STMatrix x) i j m = unsafeIOToST $ setRect i j m x++newUndefinedMatrix :: Storable t => MatrixOrder -> Int -> Int -> ST s (STMatrix s t)+newUndefinedMatrix ord r c = unsafeIOToST $ fmap STMatrix $ createMatrix ord r c++{-# NOINLINE newMatrix #-}+newMatrix :: Storable t => t -> Int -> Int -> ST s (STMatrix s t)+newMatrix v r c = unsafeThawMatrix $ reshape c $ runSTVector $ newVector v (r*c)++--------------------------------------------------------------------------------++data ColRange = AllCols+ | ColRange Int Int+ | Col Int+ | FromCol Int++getColRange :: Int -> ColRange -> (Int, Int)+getColRange c AllCols = (0,c-1)+getColRange c (ColRange a b) = (a `mod` c, b `mod` c)+getColRange c (Col a) = (a `mod` c, a `mod` c)+getColRange c (FromCol a) = (a `mod` c, c-1)++data RowRange = AllRows+ | RowRange Int Int+ | Row Int+ | FromRow Int++getRowRange :: Int -> RowRange -> (Int, Int)+getRowRange r AllRows = (0,r-1)+getRowRange r (RowRange a b) = (a `mod` r, b `mod` r)+getRowRange r (Row a) = (a `mod` r, a `mod` r)+getRowRange r (FromRow a) = (a `mod` r, r-1)++data RowOper t = AXPY t Int Int ColRange+ | SCAL t RowRange ColRange+ | SWAP Int Int ColRange++rowOper :: (Num t, Element t) => RowOper t -> STMatrix s t -> ST s ()++rowOper (AXPY x i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 0 x i1' i2' j1 j2 m+ where+ (j1,j2) = getColRange (cols m) r+ i1' = i1 `mod` (rows m)+ i2' = i2 `mod` (rows m)++rowOper (SCAL x rr rc) (STMatrix m) = unsafeIOToST $ rowOp 1 x i1 i2 j1 j2 m+ where+ (i1,i2) = getRowRange (rows m) rr+ (j1,j2) = getColRange (cols m) rc++rowOper (SWAP i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 2 0 i1' i2' j1 j2 m+ where+ (j1,j2) = getColRange (cols m) r+ i1' = i1 `mod` (rows m)+ i2' = i2 `mod` (rows m)+++extractMatrix :: Element a => STMatrix t a -> RowRange -> ColRange -> ST s (Matrix a)+extractMatrix (STMatrix m) rr rc = unsafeIOToST (extractR (orderOf m) m 0 (idxs[i1,i2]) 0 (idxs[j1,j2]))+ where+ (i1,i2) = getRowRange (rows m) rr+ (j1,j2) = getColRange (cols m) rc++-- | r0 c0 height width+data Slice s t = Slice (STMatrix s t) Int Int Int Int++slice :: Element a => Slice t a -> Matrix a+slice (Slice (STMatrix m) r0 c0 nr nc) = subMatrix (r0,c0) (nr,nc) m++gemmm :: Element t => t -> Slice s t -> t -> Slice s t -> Slice s t -> ST s ()+gemmm beta (slice->r) alpha (slice->a) (slice->b) = res+ where+ res = unsafeIOToST (gemm v a b r)+ v = fromList [alpha,beta]+++mutable :: Element t => (forall s . (Int, Int) -> STMatrix s t -> ST s u) -> Matrix t -> (Matrix t,u)+mutable f a = runST $ do+ x <- thawMatrix a+ info <- f (rows a, cols a) x+ r <- unsafeFreezeMatrix x+ return (r,info)
+ src/Internal/Sparse.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Internal.Sparse(+ GMatrix(..), CSR(..), mkCSR, fromCSR, impureCSR,+ mkSparse, mkDiagR, mkDense,+ AssocMatrix,+ toDense,+ gmXv, (!#>)+)where++import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as M+import Control.Arrow((***))+import Control.Monad(when, foldM)+import Control.Monad.ST (runST)+import Control.Monad.Primitive (PrimMonad)+import Data.List(sort)+import Foreign.C.Types(CInt(..))++import Internal.Devel+import System.IO.Unsafe(unsafePerformIO)+import Foreign(Ptr)+import Text.Printf(printf)++type AssocMatrix = [(IndexOf Matrix, Double)]++data CSR = CSR+ { csrVals :: Vector Double+ , csrCols :: Vector CInt+ , csrRows :: Vector CInt+ , csrNRows :: Int+ , csrNCols :: Int+ } deriving Show++data CSC = CSC+ { cscVals :: Vector Double+ , cscRows :: Vector CInt+ , cscCols :: Vector CInt+ , cscNRows :: Int+ , cscNCols :: Int+ } deriving Show+++-- | Produce a CSR sparse matrix from a association matrix.+mkCSR :: AssocMatrix -> CSR+mkCSR ms =+ runST $ impureCSR runFold $ sort ms+ where+ runFold next initialise xtract as0 = do+ i0 <- initialise+ acc <- foldM next i0 as0+ xtract acc++-- | Produce a CSR sparse matrix by applying a generic folding function.+--+-- This allows one to build a CSR from an effectful streaming source+-- when combined with libraries like pipes, io-streams, or streaming.+--+-- For example+--+-- > impureCSR Pipes.Prelude.foldM :: PrimMonad m => Producer AssocEntry m () -> m CSR+-- > impureCSR Streaming.Prelude.foldM :: PrimMonad m => Stream (Of AssocEntry) m r -> m (Of CSR r)+--+impureCSR+ :: PrimMonad m+ => (forall x . (x -> (IndexOf Matrix, Double) -> m x) -> m x -> (x -> m CSR) -> r)+ -> r+impureCSR f = f next begin done+ where+ sfi = succ . fi+ begin = do+ mv <- M.unsafeNew 64+ mr <- M.unsafeNew 64+ mc <- M.unsafeNew 64+ return (mv, mr, mc, 0, 0, 0, -1)++ next (!mv, !mr, !mc, !idxVC, !idxR, !maxC, !curRow) ((r,c),d) = do+ when (r < curRow) $+ error (printf "impureCSR: row %i specified after %i" r curRow)++ let lenVC = M.length mv+ lenR = M.length mr+ maxC' = max maxC c++ (mv', mc') <-+ if idxVC >= lenVC then do+ mv' <- M.unsafeGrow mv lenVC+ mc' <- M.unsafeGrow mc lenVC+ return (mv', mc')+ else+ return (mv, mc)++ mr' <-+ if idxR >= lenR - 1 then+ M.unsafeGrow mr lenR+ else+ return mr++ M.unsafeWrite mc' idxVC (sfi c)+ M.unsafeWrite mv' idxVC d++ idxR' <-+ foldM+ (\idxR' _ -> idxR' + 1 <$ M.unsafeWrite mr' idxR' (sfi idxVC))+ idxR [1 .. (r-curRow)]++ return (mv', mr', mc', idxVC + 1, idxR', maxC', r)++ done (!mv, !mr, !mc, !idxVC, !idxR, !maxC, !curR) = do+ M.unsafeWrite mr idxR (sfi idxVC)+ vv <- V.unsafeFreeze (M.unsafeTake idxVC mv)+ vc <- V.unsafeFreeze (M.unsafeTake idxVC mc)+ vr <- V.unsafeFreeze (M.unsafeTake (idxR + 1) mr)+ return $ CSR vv vc vr (succ curR) (succ maxC)+++{- | General matrix with specialized internal representations for+ dense, sparse, diagonal, banded, and constant elements.++>>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)]+>>> m+SparseR {gmCSR = CSR {csrVals = fromList [1.0,2.0],+ csrCols = fromList [1000,2000],+ csrRows = fromList [1,2,3],+ csrNRows = 2,+ csrNCols = 2000},+ nRows = 2,+ nCols = 2000}++>>> let m = mkDense (mat 2 [1..4])+>>> m+Dense {gmDense = (2><2)+ [ 1.0, 2.0+ , 3.0, 4.0 ], nRows = 2, nCols = 2}++-}+data GMatrix+ = SparseR+ { gmCSR :: CSR+ , nRows :: Int+ , nCols :: Int+ }+ | SparseC+ { gmCSC :: CSC+ , nRows :: Int+ , nCols :: Int+ }+ | Diag+ { diagVals :: Vector Double+ , nRows :: Int+ , nCols :: Int+ }+ | Dense+ { gmDense :: Matrix Double+ , nRows :: Int+ , nCols :: Int+ }+-- | Banded+ deriving Show+++mkDense :: Matrix Double -> GMatrix+mkDense m = Dense{..}+ where+ gmDense = m+ nRows = rows m+ nCols = cols m++mkSparse :: AssocMatrix -> GMatrix+mkSparse = fromCSR . mkCSR++fromCSR :: CSR -> GMatrix+fromCSR csr = SparseR {..}+ where+ gmCSR@CSR {..} = csr+ nRows = csrNRows+ nCols = csrNCols+++mkDiagR :: Int -> Int -> Vector Double -> GMatrix+mkDiagR r c v+ | dim v <= min r c = Diag{..}+ | otherwise = error $ printf "mkDiagR: incorrect sizes (%d,%d) [%d]" r c (dim v)+ where+ nRows = r+ nCols = c+ diagVals = v+++type IV t = CInt -> Ptr CInt -> t+type V t = CInt -> Ptr Double -> t+type SMxV = V (IV (IV (V (V (IO CInt)))))++gmXv :: GMatrix -> Vector Double -> Vector Double+gmXv SparseR { gmCSR = CSR{..}, .. } v = unsafePerformIO $ do+ when (dim v /= nCols) $+ error (printf "gmXv (CSR): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v))++ r <- createVector nRows+ (csrVals # csrCols # csrRows # v #! r) c_smXv #|"CSRXv"+ return r++gmXv SparseC { gmCSC = CSC{..}, .. } v = unsafePerformIO $ do+ when (dim v /= nCols) $+ error (printf "gmXv (CSC): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v))++ r <- createVector nRows+ (cscVals # cscRows # cscCols # v #! r) c_smTXv #|"CSCXv"+ return r++gmXv Diag{..} v+ | dim v == nCols+ = vjoin [ subVector 0 (dim diagVals) v `mul` diagVals+ , konst 0 (nRows - dim diagVals) ]+ | otherwise = error $ printf "gmXv (Diag): incorrect sizes: (%d,%d) [%d] x %d"+ nRows nCols (dim diagVals) (dim v)++gmXv Dense{..} v+ | dim v == nCols+ = mXv gmDense v+ | otherwise = error $ printf "gmXv (Dense): incorrect sizes: (%d,%d) x %d"+ nRows nCols (dim v)+++{- | general matrix - vector product++>>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)]+m :: GMatrix+>>> m !#> vector [1..2000]+[1000.0,4000.0]+it :: Vector Double++-}+infixr 8 !#>+(!#>) :: GMatrix -> Vector Double -> Vector Double+(!#>) = gmXv++--------------------------------------------------------------------------------++foreign import ccall unsafe "smXv"+ c_smXv :: SMxV++foreign import ccall unsafe "smTXv"+ c_smTXv :: SMxV++--------------------------------------------------------------------------------++toDense :: AssocMatrix -> Matrix Double+toDense asm = assoc (r+1,c+1) 0 asm+ where+ (r,c) = (maximum *** maximum) . unzip . map fst $ asm+++instance Transposable CSR CSC+ where+ tr (CSR vs cs rs n m) = CSC vs cs rs m n+ tr' = tr++instance Transposable CSC CSR+ where+ tr (CSC vs rs cs n m) = CSR vs rs cs m n+ tr' = tr++instance Transposable GMatrix GMatrix+ where+ tr (SparseR s n m) = SparseC (tr s) m n+ tr (SparseC s n m) = SparseR (tr s) m n+ tr (Diag v n m) = Diag v m n+ tr (Dense a n m) = Dense (tr a) m n+ tr' = tr
+ src/Internal/Static.hs view
@@ -0,0 +1,588 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 708++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{- |+Module : Internal.Static+Copyright : (c) Alberto Ruiz 2006-14+License : BSD3+Stability : provisional++-}++module Internal.Static where+++import GHC.TypeLits+import qualified Numeric.LinearAlgebra as LA+import Numeric.LinearAlgebra hiding (konst,size,R,C)+import Internal.Vector as D hiding (R,C)+import Internal.ST+import Control.DeepSeq+import Data.Proxy(Proxy)+import Foreign.Storable(Storable)+import Text.Printf++import Data.Binary+import GHC.Generics (Generic)+import Data.Proxy (Proxy(..))++--------------------------------------------------------------------------------++type ℝ = Double+type ℂ = Complex Double++newtype Dim (n :: Nat) t = Dim t+ deriving (Show, Generic)++instance (KnownNat n, Binary a) => Binary (Dim n a) where+ get = do+ k <- get+ let n = natVal (Proxy :: Proxy n)+ if n == k+ then Dim <$> get+ else fail ("Expected dimension " ++ (show n) ++ ", but found dimension " ++ (show k))++ put (Dim x) = do+ put (natVal (Proxy :: Proxy n))+ put x++lift1F+ :: (c t -> c t)+ -> Dim n (c t) -> Dim n (c t)+lift1F f (Dim v) = Dim (f v)++lift2F+ :: (c t -> c t -> c t)+ -> Dim n (c t) -> Dim n (c t) -> Dim n (c t)+lift2F f (Dim u) (Dim v) = Dim (f u v)++instance NFData t => NFData (Dim n t) where+ rnf (Dim (force -> !_)) = ()++--------------------------------------------------------------------------------++newtype R n = R (Dim n (Vector ℝ))+ deriving (Num,Fractional,Floating,Generic,Binary)++newtype C n = C (Dim n (Vector ℂ))+ deriving (Num,Fractional,Floating,Generic)++newtype L m n = L (Dim m (Dim n (Matrix ℝ)))+ deriving (Generic, Binary)++newtype M m n = M (Dim m (Dim n (Matrix ℂ)))+ deriving (Generic)++mkR :: Vector ℝ -> R n+mkR = R . Dim++mkC :: Vector ℂ -> C n+mkC = C . Dim++mkL :: Matrix ℝ -> L m n+mkL x = L (Dim (Dim x))++mkM :: Matrix ℂ -> M m n+mkM x = M (Dim (Dim x))++instance NFData (R n) where+ rnf (R (force -> !_)) = ()++instance NFData (C n) where+ rnf (C (force -> !_)) = ()++instance NFData (L n m) where+ rnf (L (force -> !_)) = ()++instance NFData (M n m) where+ rnf (M (force -> !_)) = ()++--------------------------------------------------------------------------------++type V n t = Dim n (Vector t)++ud :: Dim n (Vector t) -> Vector t+ud (Dim v) = v++mkV :: forall (n :: Nat) t . t -> Dim n t+mkV = Dim+++vconcat :: forall n m t . (KnownNat n, KnownNat m, Numeric t)+ => V n t -> V m t -> V (n+m) t+(ud -> u) `vconcat` (ud -> v) = mkV (vjoin [u', v'])+ where+ du = fromIntegral . natVal $ (undefined :: Proxy n)+ dv = fromIntegral . natVal $ (undefined :: Proxy m)+ u' | du /= 1 && LA.size u == 1 = LA.konst (u D.@> 0) du+ | otherwise = u+ v' | dv /= 1 && LA.size v == 1 = LA.konst (v D.@> 0) dv+ | otherwise = v+++gvec2 :: Storable t => t -> t -> V 2 t+gvec2 a b = mkV $ runSTVector $ do+ v <- newUndefinedVector 2+ writeVector v 0 a+ writeVector v 1 b+ return v++gvec3 :: Storable t => t -> t -> t -> V 3 t+gvec3 a b c = mkV $ runSTVector $ do+ v <- newUndefinedVector 3+ writeVector v 0 a+ writeVector v 1 b+ writeVector v 2 c+ return v+++gvec4 :: Storable t => t -> t -> t -> t -> V 4 t+gvec4 a b c d = mkV $ runSTVector $ do+ v <- newUndefinedVector 4+ writeVector v 0 a+ writeVector v 1 b+ writeVector v 2 c+ writeVector v 3 d+ return v+++gvect :: forall n t . (Show t, KnownNat n, Numeric t) => String -> [t] -> V n t+gvect st xs'+ | ok = mkV v+ | not (null rest) && null (tail rest) = abort (show xs')+ | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")+ | otherwise = abort (show xs)+ where+ (xs,rest) = splitAt d xs'+ ok = LA.size v == d && null rest+ v = LA.fromList xs+ d = fromIntegral . natVal $ (undefined :: Proxy n)+ abort info = error $ st++" "++show d++" can't be created from elements "++info+++--------------------------------------------------------------------------------++type GM m n t = Dim m (Dim n (Matrix t))+++gmat :: forall m n t . (Show t, KnownNat m, KnownNat n, Numeric t) => String -> [t] -> GM m n t+gmat st xs'+ | ok = Dim (Dim x)+ | not (null rest) && null (tail rest) = abort (show xs')+ | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")+ | otherwise = abort (show xs)+ where+ (xs,rest) = splitAt (m'*n') xs'+ v = LA.fromList xs+ x = reshape n' v+ ok = null rest && ((n' == 0 && dim v == 0) || n'> 0 && (rem (LA.size v) n' == 0) && LA.size x == (m',n'))+ m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int+ n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int+ abort info = error $ st ++" "++show m' ++ " " ++ show n'++" can't be created from elements " ++ info++--------------------------------------------------------------------------------++class Num t => Sized t s d | s -> t, s -> d+ where+ konst :: t -> s+ unwrap :: s -> d t+ fromList :: [t] -> s+ extract :: s -> d t+ create :: d t -> Maybe s+ size :: s -> IndexOf d++singleV v = LA.size v == 1+singleM m = rows m == 1 && cols m == 1+++instance KnownNat n => Sized ℂ (C n) Vector+ where+ size _ = fromIntegral . natVal $ (undefined :: Proxy n)+ konst x = mkC (LA.scalar x)+ unwrap (C (Dim v)) = v+ fromList xs = C (gvect "C" xs)+ extract s@(unwrap -> v)+ | singleV v = LA.konst (v!0) (size s)+ | otherwise = v+ create v+ | LA.size v == size r = Just r+ | otherwise = Nothing+ where+ r = mkC v :: C n+++instance KnownNat n => Sized ℝ (R n) Vector+ where+ size _ = fromIntegral . natVal $ (undefined :: Proxy n)+ konst x = mkR (LA.scalar x)+ unwrap (R (Dim v)) = v+ fromList xs = R (gvect "R" xs)+ extract s@(unwrap -> v)+ | singleV v = LA.konst (v!0) (size s)+ | otherwise = v+ create v+ | LA.size v == size r = Just r+ | otherwise = Nothing+ where+ r = mkR v :: R n++++instance (KnownNat m, KnownNat n) => Sized ℝ (L m n) Matrix+ where+ size _ = ((fromIntegral . natVal) (undefined :: Proxy m)+ ,(fromIntegral . natVal) (undefined :: Proxy n))+ konst x = mkL (LA.scalar x)+ fromList xs = L (gmat "L" xs)+ unwrap (L (Dim (Dim m))) = m+ extract (isDiag -> Just (z,y,(m',n'))) = diagRect z y m' n'+ extract s@(unwrap -> a)+ | singleM a = LA.konst (a `atIndex` (0,0)) (size s)+ | otherwise = a+ create x+ | LA.size x == size r = Just r+ | otherwise = Nothing+ where+ r = mkL x :: L m n+++instance (KnownNat m, KnownNat n) => Sized ℂ (M m n) Matrix+ where+ size _ = ((fromIntegral . natVal) (undefined :: Proxy m)+ ,(fromIntegral . natVal) (undefined :: Proxy n))+ konst x = mkM (LA.scalar x)+ fromList xs = M (gmat "M" xs)+ unwrap (M (Dim (Dim m))) = m+ extract (isDiagC -> Just (z,y,(m',n'))) = diagRect z y m' n'+ extract s@(unwrap -> a)+ | singleM a = LA.konst (a `atIndex` (0,0)) (size s)+ | otherwise = a+ create x+ | LA.size x == size r = Just r+ | otherwise = Nothing+ where+ r = mkM x :: M m n++--------------------------------------------------------------------------------++instance (KnownNat n, KnownNat m) => Transposable (L m n) (L n m)+ where+ tr a@(isDiag -> Just _) = mkL (extract a)+ tr (extract -> a) = mkL (tr a)+ tr' = tr++instance (KnownNat n, KnownNat m) => Transposable (M m n) (M n m)+ where+ tr a@(isDiagC -> Just _) = mkM (extract a)+ tr (extract -> a) = mkM (tr a)+ tr' a@(isDiagC -> Just _) = mkM (extract a)+ tr' (extract -> a) = mkM (tr' a)++--------------------------------------------------------------------------------++isDiag :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ, Vector ℝ, (Int,Int))+isDiag (L x) = isDiagg x++isDiagC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ, Vector ℂ, (Int,Int))+isDiagC (M x) = isDiagg x+++isDiagg :: forall m n t . (Numeric t, KnownNat m, KnownNat n) => GM m n t -> Maybe (t, Vector t, (Int,Int))+isDiagg (Dim (Dim x))+ | singleM x = Nothing+ | rows x == 1 && m' > 1 || cols x == 1 && n' > 1 = Just (z,yz,(m',n'))+ | otherwise = Nothing+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int+ n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int+ v = flatten x+ z = v `atIndex` 0+ y = subVector 1 (LA.size v-1) v+ ny = LA.size y+ zeros = LA.konst 0 (max 0 (min m' n' - ny))+ yz = vjoin [y,zeros]++--------------------------------------------------------------------------------++instance KnownNat n => Show (R n)+ where+ show s@(R (Dim v))+ | singleV v = "(" ++ show (v!0) ++ " :: R " ++ show d ++ ")"+ | otherwise = "(vector " ++ show v ++ " :: R " ++ show d ++")"+ where+ d = size s++instance KnownNat n => Show (C n)+ where+ show s@(C (Dim v))+ | singleV v = "(" ++ show (v!0) ++ " :: C " ++ show d ++ ")"+ | otherwise = "(vector " ++ show v ++ " :: C " ++ show d ++")"+ where+ d = size s++instance (KnownNat m, KnownNat n) => Show (L m n)+ where+ show (isDiag -> Just (z,y,(m',n'))) = printf "(diag %s %s :: L %d %d)" (show z) (show y) m' n'+ show s@(L (Dim (Dim x)))+ | singleM x = printf "(%s :: L %d %d)" (show (x `atIndex` (0,0))) m' n'+ | otherwise = "(matrix" ++ dropWhile (/='\n') (show x) ++ " :: L " ++ show m' ++ " " ++ show n' ++ ")"+ where+ (m',n') = size s++instance (KnownNat m, KnownNat n) => Show (M m n)+ where+ show (isDiagC -> Just (z,y,(m',n'))) = printf "(diag %s %s :: M %d %d)" (show z) (show y) m' n'+ show s@(M (Dim (Dim x)))+ | singleM x = printf "(%s :: M %d %d)" (show (x `atIndex` (0,0))) m' n'+ | otherwise = "(matrix" ++ dropWhile (/='\n') (show x) ++ " :: M " ++ show m' ++ " " ++ show n' ++ ")"+ where+ (m',n') = size s++--------------------------------------------------------------------------------++instance (Num (Vector t), Numeric t )=> Num (Dim n (Vector t))+ where+ (+) = lift2F (+)+ (*) = lift2F (*)+ (-) = lift2F (-)+ abs = lift1F abs+ signum = lift1F signum+ negate = lift1F negate+ fromInteger x = Dim (fromInteger x)++instance (Num (Vector t), Fractional t, Numeric t) => Fractional (Dim n (Vector t))+ where+ fromRational x = Dim (fromRational x)+ (/) = lift2F (/)++instance (Fractional t, Floating (Vector t), Numeric t) => Floating (Dim n (Vector t)) where+ sin = lift1F sin+ cos = lift1F cos+ tan = lift1F tan+ asin = lift1F asin+ acos = lift1F acos+ atan = lift1F atan+ sinh = lift1F sinh+ cosh = lift1F cosh+ tanh = lift1F tanh+ asinh = lift1F asinh+ acosh = lift1F acosh+ atanh = lift1F atanh+ exp = lift1F exp+ log = lift1F log+ sqrt = lift1F sqrt+ (**) = lift2F (**)+ pi = Dim pi+++instance (Num (Vector t), Numeric t) => Num (Dim m (Dim n (Matrix t)))+ where+ (+) = (lift2F . lift2F) (+)+ (*) = (lift2F . lift2F) (*)+ (-) = (lift2F . lift2F) (-)+ abs = (lift1F . lift1F) abs+ signum = (lift1F . lift1F) signum+ negate = (lift1F . lift1F) negate+ fromInteger x = Dim (Dim (fromInteger x))++instance (Num (Vector t), Fractional t, Numeric t) => Fractional (Dim m (Dim n (Matrix t)))+ where+ fromRational x = Dim (Dim (fromRational x))+ (/) = (lift2F.lift2F) (/)++instance (Floating (Vector t), Floating t, Numeric t) => Floating (Dim m (Dim n (Matrix t))) where+ sin = (lift1F . lift1F) sin+ cos = (lift1F . lift1F) cos+ tan = (lift1F . lift1F) tan+ asin = (lift1F . lift1F) asin+ acos = (lift1F . lift1F) acos+ atan = (lift1F . lift1F) atan+ sinh = (lift1F . lift1F) sinh+ cosh = (lift1F . lift1F) cosh+ tanh = (lift1F . lift1F) tanh+ asinh = (lift1F . lift1F) asinh+ acosh = (lift1F . lift1F) acosh+ atanh = (lift1F . lift1F) atanh+ exp = (lift1F . lift1F) exp+ log = (lift1F . lift1F) log+ sqrt = (lift1F . lift1F) sqrt+ (**) = (lift2F . lift2F) (**)+ pi = Dim (Dim pi)++--------------------------------------------------------------------------------+++adaptDiag f a@(isDiag -> Just _) b | isFull b = f (mkL (extract a)) b+adaptDiag f a b@(isDiag -> Just _) | isFull a = f a (mkL (extract b))+adaptDiag f a b = f a b++isFull m = isDiag m == Nothing && not (singleM (unwrap m))+++lift1L f (L v) = L (f v)+lift2L f (L a) (L b) = L (f a b)+lift2LD f = adaptDiag (lift2L f)+++instance (KnownNat n, KnownNat m) => Num (L n m)+ where+ (+) = lift2LD (+)+ (*) = lift2LD (*)+ (-) = lift2LD (-)+ abs = lift1L abs+ signum = lift1L signum+ negate = lift1L negate+ fromInteger = L . Dim . Dim . fromInteger++instance (KnownNat n, KnownNat m) => Fractional (L n m)+ where+ fromRational = L . Dim . Dim . fromRational+ (/) = lift2LD (/)++instance (KnownNat n, KnownNat m) => Floating (L n m) where+ sin = lift1L sin+ cos = lift1L cos+ tan = lift1L tan+ asin = lift1L asin+ acos = lift1L acos+ atan = lift1L atan+ sinh = lift1L sinh+ cosh = lift1L cosh+ tanh = lift1L tanh+ asinh = lift1L asinh+ acosh = lift1L acosh+ atanh = lift1L atanh+ exp = lift1L exp+ log = lift1L log+ sqrt = lift1L sqrt+ (**) = lift2LD (**)+ pi = konst pi++--------------------------------------------------------------------------------++adaptDiagC f a@(isDiagC -> Just _) b | isFullC b = f (mkM (extract a)) b+adaptDiagC f a b@(isDiagC -> Just _) | isFullC a = f a (mkM (extract b))+adaptDiagC f a b = f a b++isFullC m = isDiagC m == Nothing && not (singleM (unwrap m))++lift1M f (M v) = M (f v)+lift2M f (M a) (M b) = M (f a b)+lift2MD f = adaptDiagC (lift2M f)++instance (KnownNat n, KnownNat m) => Num (M n m)+ where+ (+) = lift2MD (+)+ (*) = lift2MD (*)+ (-) = lift2MD (-)+ abs = lift1M abs+ signum = lift1M signum+ negate = lift1M negate+ fromInteger = M . Dim . Dim . fromInteger++instance (KnownNat n, KnownNat m) => Fractional (M n m)+ where+ fromRational = M . Dim . Dim . fromRational+ (/) = lift2MD (/)++instance (KnownNat n, KnownNat m) => Floating (M n m) where+ sin = lift1M sin+ cos = lift1M cos+ tan = lift1M tan+ asin = lift1M asin+ acos = lift1M acos+ atan = lift1M atan+ sinh = lift1M sinh+ cosh = lift1M cosh+ tanh = lift1M tanh+ asinh = lift1M asinh+ acosh = lift1M acosh+ atanh = lift1M atanh+ exp = lift1M exp+ log = lift1M log+ sqrt = lift1M sqrt+ (**) = lift2MD (**)+ pi = M pi++instance Additive (R n) where+ add = (+)++instance Additive (C n) where+ add = (+)++instance (KnownNat m, KnownNat n) => Additive (L m n) where+ add = (+)++instance (KnownNat m, KnownNat n) => Additive (M m n) where+ add = (+)++--------------------------------------------------------------------------------+++class Disp t+ where+ disp :: Int -> t -> IO ()+++instance (KnownNat m, KnownNat n) => Disp (L m n)+ where+ disp n x = do+ let a = extract x+ let su = LA.dispf n a+ printf "L %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)++instance (KnownNat m, KnownNat n) => Disp (M m n)+ where+ disp n x = do+ let a = extract x+ let su = LA.dispcf n a+ printf "M %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)+++instance KnownNat n => Disp (R n)+ where+ disp n v = do+ let su = LA.dispf n (asRow $ extract v)+ putStr "R " >> putStr (tail . dropWhile (/='x') $ su)++instance KnownNat n => Disp (C n)+ where+ disp n v = do+ let su = LA.dispcf n (asRow $ extract v)+ putStr "C " >> putStr (tail . dropWhile (/='x') $ su)++--------------------------------------------------------------------------------++overMatL' :: (KnownNat m, KnownNat n)+ => (LA.Matrix ℝ -> LA.Matrix ℝ) -> L m n -> L m n+overMatL' f = mkL . f . unwrap+{-# INLINE overMatL' #-}++overMatM' :: (KnownNat m, KnownNat n)+ => (LA.Matrix ℂ -> LA.Matrix ℂ) -> M m n -> M m n+overMatM' f = mkM . f . unwrap+{-# INLINE overMatM' #-}+++#else++module Numeric.LinearAlgebra.Static.Internal where++#endif+
+ src/Internal/Util.hs view
@@ -0,0 +1,914 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+{- |+Module : Internal.Util+Copyright : (c) Alberto Ruiz 2013+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++-}+-----------------------------------------------------------------------------++module Internal.Util(++ -- * Convenience functions+ vector, matrix,+ disp,+ formatSparse,+ approxInt,+ dispDots,+ dispBlanks,+ formatShort,+ dispShort,+ zeros, ones,+ diagl,+ row,+ col,+ (&), (¦), (|||), (——), (===),+ (?), (¿),+ Indexable(..), size,+ Numeric,+ rand, randn,+ cross,+ norm,+ ℕ,ℤ,ℝ,ℂ,iC,+ Normed(..), norm_Frob, norm_nuclear,+ magnit,+ normalize,+ mt,+ (~!~),+ pairwiseD2,+ rowOuters,+ null1,+ null1sym,+ -- * Convolution+ -- ** 1D+ corr, conv, corrMin,+ -- ** 2D+ corr2, conv2, separable,+ block2x2,block3x3,view1,unView1,foldMatrix,+ gaussElim_1, gaussElim_2, gaussElim,+ luST, luSolve', luSolve'', luPacked', luPacked'',+ invershur+) where++import Internal.Vector+import Internal.Matrix hiding (size)+import Internal.Numeric+import Internal.Element+import Internal.Container+import Internal.Vectorized+import Internal.IO+import Internal.Algorithms hiding (Normed,linearSolve',luSolve', luPacked')+import Numeric.Matrix()+import Numeric.Vector()+import Internal.Random+import Internal.Convolution+import Control.Monad(when,forM_)+import Text.Printf+import Data.List.Split(splitOn)+import Data.List(intercalate,sortBy,foldl')+import Control.Arrow((&&&),(***))+import Data.Complex+import Data.Function(on)+import Internal.ST+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++type ℝ = Double+type ℕ = Int+type ℤ = Int+type ℂ = Complex Double++-- | imaginary unit+iC :: C+iC = 0:+1++{- | Create a real vector.++>>> vector [1..5]+[1.0,2.0,3.0,4.0,5.0]+it :: Vector R++-}+vector :: [R] -> Vector R+vector = fromList++{- | Create a real matrix.++>>> matrix 5 [1..15]+(3><5)+ [ 1.0, 2.0, 3.0, 4.0, 5.0+ , 6.0, 7.0, 8.0, 9.0, 10.0+ , 11.0, 12.0, 13.0, 14.0, 15.0 ]++-}+matrix+ :: Int -- ^ number of columns+ -> [R] -- ^ elements in row order+ -> Matrix R+matrix c = reshape c . fromList+++{- | print a real matrix with given number of digits after the decimal point++>>> disp 5 $ ident 2 / 3+2x2+0.33333 0.00000+0.00000 0.33333++-}+disp :: Int -> Matrix Double -> IO ()++disp n = putStr . dispf n+++{- | create a real diagonal matrix from a list++>>> diagl [1,2,3]+(3><3)+ [ 1.0, 0.0, 0.0+ , 0.0, 2.0, 0.0+ , 0.0, 0.0, 3.0 ]++-}+diagl :: [Double] -> Matrix Double+diagl = diag . fromList++-- | a real matrix of zeros+zeros :: Int -- ^ rows+ -> Int -- ^ columns+ -> Matrix Double+zeros r c = konst 0 (r,c)++-- | a real matrix of ones+ones :: Int -- ^ rows+ -> Int -- ^ columns+ -> Matrix Double+ones r c = konst 1 (r,c)++-- | concatenation of real vectors+infixl 3 &+(&) :: Vector Double -> Vector Double -> Vector Double+a & b = vjoin [a,b]++{- | horizontal concatenation++>>> ident 3 ||| konst 7 (3,4)+(3><7)+ [ 1.0, 0.0, 0.0, 7.0, 7.0, 7.0, 7.0+ , 0.0, 1.0, 0.0, 7.0, 7.0, 7.0, 7.0+ , 0.0, 0.0, 1.0, 7.0, 7.0, 7.0, 7.0 ]++-}+infixl 3 |||+(|||) :: Element t => Matrix t -> Matrix t -> Matrix t+a ||| b = fromBlocks [[a,b]]++-- | a synonym for ('|||') (unicode 0x00a6, broken bar)+infixl 3 ¦+(¦) :: Matrix Double -> Matrix Double -> Matrix Double+(¦) = (|||)+++-- | vertical concatenation+--+(===) :: Element t => Matrix t -> Matrix t -> Matrix t+infixl 2 ===+a === b = fromBlocks [[a],[b]]++-- | a synonym for ('===') (unicode 0x2014, em dash)+(——) :: Matrix Double -> Matrix Double -> Matrix Double+infixl 2 ——+(——) = (===)+++-- | create a single row real matrix from a list+--+-- >>> row [2,3,1,8]+-- (1><4)+-- [ 2.0, 3.0, 1.0, 8.0 ]+--+row :: [Double] -> Matrix Double+row = asRow . fromList++-- | create a single column real matrix from a list+--+-- >>> col [7,-2,4]+-- (3><1)+-- [ 7.0+-- , -2.0+-- , 4.0 ]+--+col :: [Double] -> Matrix Double+col = asColumn . fromList++{- | extract rows++>>> (20><4) [1..] ? [2,1,1]+(3><4)+ [ 9.0, 10.0, 11.0, 12.0+ , 5.0, 6.0, 7.0, 8.0+ , 5.0, 6.0, 7.0, 8.0 ]++-}+infixl 9 ?+(?) :: Element t => Matrix t -> [Int] -> Matrix t+(?) = flip extractRows++{- | extract columns++(unicode 0x00bf, inverted question mark, Alt-Gr ?)++>>> (3><4) [1..] ¿ [3,0]+(3><2)+ [ 4.0, 1.0+ , 8.0, 5.0+ , 12.0, 9.0 ]++-}+infixl 9 ¿+(¿) :: Element t => Matrix t -> [Int] -> Matrix t+(¿)= flip extractColumns+++cross :: Product t => Vector t -> Vector t -> Vector t+-- ^ cross product (for three-element vectors)+cross x y | dim x == 3 && dim y == 3 = fromList [z1,z2,z3]+ | otherwise = error $ "the cross product requires 3-element vectors (sizes given: "+ ++show (dim x)++" and "++show (dim y)++")"+ where+ [x1,x2,x3] = toList x+ [y1,y2,y3] = toList y+ z1 = x2*y3-x3*y2+ z2 = x3*y1-x1*y3+ z3 = x1*y2-x2*y1++{-# SPECIALIZE cross :: Vector Double -> Vector Double -> Vector Double #-}+{-# SPECIALIZE cross :: Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) #-}++norm :: Vector Double -> Double+-- ^ 2-norm of real vector+norm = pnorm PNorm2++-- | p-norm for vectors, operator norm for matrices+class Normed a+ where+ norm_0 :: a -> R+ norm_1 :: a -> R+ norm_2 :: a -> R+ norm_Inf :: a -> R+++instance Normed (Vector R)+ where+ norm_0 v = sumElements (step (abs v - scalar (eps*normInf v)))+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Vector C)+ where+ norm_0 v = sumElements (step (fst (fromComplex (abs v)) - scalar (eps*normInf v)))+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Matrix R)+ where+ norm_0 = norm_0 . flatten+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Matrix C)+ where+ norm_0 = norm_0 . flatten+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Vector I)+ where+ norm_0 = fromIntegral . sumElements . step . abs+ norm_1 = fromIntegral . norm1+ norm_2 v = sqrt . fromIntegral $ dot v v+ norm_Inf = fromIntegral . normInf++instance Normed (Vector Z)+ where+ norm_0 = fromIntegral . sumElements . step . abs+ norm_1 = fromIntegral . norm1+ norm_2 v = sqrt . fromIntegral $ dot v v+ norm_Inf = fromIntegral . normInf++instance Normed (Vector Float)+ where+ norm_0 = norm_0 . double+ norm_1 = norm_1 . double+ norm_2 = norm_2 . double+ norm_Inf = norm_Inf . double++instance Normed (Vector (Complex Float))+ where+ norm_0 = norm_0 . double+ norm_1 = norm_1 . double+ norm_2 = norm_2 . double+ norm_Inf = norm_Inf . double++-- | Frobenius norm (Schatten p-norm with p=2)+norm_Frob :: (Normed (Vector t), Element t) => Matrix t -> R+norm_Frob = norm_2 . flatten++-- | Sum of singular values (Schatten p-norm with p=1)+norm_nuclear :: Field t => Matrix t -> R+norm_nuclear = sumElements . singularValues++{- | Check if the absolute value or complex magnitude is greater than a given threshold++>>> magnit 1E-6 (1E-12 :: R)+False+>>> magnit 1E-6 (3+iC :: C)+True+>>> magnit 0 (3 :: I ./. 5)+True++-}+magnit :: (Element t, Normed (Vector t)) => R -> t -> Bool+magnit e x = norm_1 (fromList [x]) > e+++-- | Obtains a vector in the same direction with 2-norm=1+normalize :: (Normed (Vector t), Num (Vector t), Field t) => Vector t -> Vector t+normalize v = v / real (scalar (norm_2 v))+++-- | trans . inv+mt :: Matrix Double -> Matrix Double+mt = trans . inv++--------------------------------------------------------------------------------+{- |++>>> size $ vector [1..10]+10+>>> size $ (2><5)[1..10::Double]+(2,5)++-}+size :: Container c t => c t -> IndexOf c+size = size'++{- | Alternative indexing function.++>>> vector [1..10] ! 3+4.0++On a matrix it gets the k-th row as a vector:++>>> matrix 5 [1..15] ! 1+[6.0,7.0,8.0,9.0,10.0]+it :: Vector Double++>>> matrix 5 [1..15] ! 1 ! 3+9.0++-}+class Indexable c t | c -> t , t -> c+ where+ infixl 9 !+ (!) :: c -> Int -> t++instance Indexable (Vector Double) Double+ where+ (!) = (@>)++instance Indexable (Vector Float) Float+ where+ (!) = (@>)++instance Indexable (Vector I) I+ where+ (!) = (@>)++instance Indexable (Vector Z) Z+ where+ (!) = (@>)++instance Indexable (Vector (Complex Double)) (Complex Double)+ where+ (!) = (@>)++instance Indexable (Vector (Complex Float)) (Complex Float)+ where+ (!) = (@>)++instance Element t => Indexable (Matrix t) (Vector t)+ where+ m ! j = subVector (j*c) c (flatten m)+ where+ c = cols m++--------------------------------------------------------------------------------++-- | Matrix of pairwise squared distances of row vectors+-- (using the matrix product trick in blog.smola.org)+pairwiseD2 :: Matrix Double -> Matrix Double -> Matrix Double+pairwiseD2 x y | ok = x2 `outer` oy + ox `outer` y2 - 2* x <> trans y+ | otherwise = error $ "pairwiseD2 with different number of columns: "+ ++ show (size x) ++ ", " ++ show (size y)+ where+ ox = one (rows x)+ oy = one (rows y)+ oc = one (cols x)+ one k = konst 1 k+ x2 = x * x <> oc+ y2 = y * y <> oc+ ok = cols x == cols y++--------------------------------------------------------------------------------++{- | outer products of rows++>>> a+(3><2)+ [ 1.0, 2.0+ , 10.0, 20.0+ , 100.0, 200.0 ]+>>> b+(3><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0 ]++>>> rowOuters a (b ||| 1)+(3><8)+ [ 1.0, 2.0, 3.0, 1.0, 2.0, 4.0, 6.0, 2.0+ , 40.0, 50.0, 60.0, 10.0, 80.0, 100.0, 120.0, 20.0+ , 700.0, 800.0, 900.0, 100.0, 1400.0, 1600.0, 1800.0, 200.0 ]++-}+rowOuters :: Matrix Double -> Matrix Double -> Matrix Double+rowOuters a b = a' * b'+ where+ a' = kronecker a (ones 1 (cols b))+ b' = kronecker (ones 1 (cols a)) b++--------------------------------------------------------------------------------++-- | solution of overconstrained homogeneous linear system+null1 :: Matrix R -> Vector R+null1 = last . toColumns . snd . rightSV++-- | solution of overconstrained homogeneous symmetric linear system+null1sym :: Herm R -> Vector R+null1sym = last . toColumns . snd . eigSH++--------------------------------------------------------------------------------++infixl 0 ~!~+c ~!~ msg = when c (error msg)++--------------------------------------------------------------------------------++formatSparse :: String -> String -> String -> Int -> Matrix Double -> String++formatSparse zeroI _zeroF sep _ (approxInt -> Just m) = format sep f m+ where+ f 0 = zeroI+ f x = printf "%.0f" x++formatSparse zeroI zeroF sep n m = format sep f m+ where+ f x | abs (x::Double) < 2*peps = zeroI++zeroF+ | abs (fromIntegral (round x::Int) - x) / abs x < 2*peps+ = printf ("%.0f."++replicate n ' ') x+ | otherwise = printf ("%."++show n++"f") x++approxInt m+ | norm_Inf (v - vi) < 2*peps * norm_Inf v = Just (reshape (cols m) vi)+ | otherwise = Nothing+ where+ v = flatten m+ vi = roundVector v++dispDots n = putStr . formatSparse "." (replicate n ' ') " " n++dispBlanks n = putStr . formatSparse "" "" " " n++formatShort sep fmt maxr maxc m = auxm4+ where+ (rm,cm) = size m+ (r1,r2,r3)+ | rm <= maxr = (rm,0,0)+ | otherwise = (maxr-3,rm-maxr+1,2)+ (c1,c2,c3)+ | cm <= maxc = (cm,0,0)+ | otherwise = (maxc-3,cm-maxc+1,2)+ [ [a,_,b]+ ,[_,_,_]+ ,[c,_,d]] = toBlocks [r1,r2,r3]+ [c1,c2,c3] m+ auxm = fromBlocks [[a,b],[c,d]]+ auxm2+ | cm > maxc = format "|" fmt auxm+ | otherwise = format sep fmt auxm+ auxm3+ | cm > maxc = map (f . splitOn "|") (lines auxm2)+ | otherwise = (lines auxm2)+ f items = intercalate sep (take (maxc-3) items) ++ " .. " +++ intercalate sep (drop (maxc-3) items)+ auxm4+ | rm > maxr = unlines (take (maxr-3) auxm3 ++ vsep : drop (maxr-3) auxm3)+ | otherwise = unlines auxm3+ vsep = map g (head auxm3)+ g '.' = ':'+ g _ = ' '+++dispShort :: Int -> Int -> Int -> Matrix Double -> IO ()+dispShort maxr maxc dec m =+ printf "%dx%d\n%s" (rows m) (cols m) (formatShort " " fmt maxr maxc m)+ where+ fmt = printf ("%."++show dec ++"f")++--------------------------------------------------------------------------------++-- matrix views++block2x2 r c m = [[m11,m12],[m21,m22]]+ where+ m11 = m ?? (Take r, Take c)+ m12 = m ?? (Take r, Drop c)+ m21 = m ?? (Drop r, Take c)+ m22 = m ?? (Drop r, Drop c)++block3x3 r nr c nc m = [[m ?? (er !! i, ec !! j) | j <- [0..2] ] | i <- [0..2] ]+ where+ er = [ Range 0 1 (r-1), Range r 1 (r+nr-1), Drop (nr+r) ]+ ec = [ Range 0 1 (c-1), Range c 1 (c+nc-1), Drop (nc+c) ]++view1 :: Numeric t => Matrix t -> Maybe (View1 t)+view1 m+ | rows m > 0 && cols m > 0 = Just (e, flatten m12, flatten m21 , m22)+ | otherwise = Nothing+ where+ [[m11,m12],[m21,m22]] = block2x2 1 1 m+ e = m11 `atIndex` (0, 0)++unView1 :: Numeric t => View1 t -> Matrix t+unView1 (e,r,c,m) = fromBlocks [[scalar e, asRow r],[asColumn c, m]]++type View1 t = (t, Vector t, Vector t, Matrix t)++foldMatrix :: Numeric t => (Matrix t -> Matrix t) -> (View1 t -> View1 t) -> (Matrix t -> Matrix t)+foldMatrix g f ( (f <$>) . view1 . g -> Just (e,r,c,m)) = unView1 (e, r, c, foldMatrix g f m)+foldMatrix _ _ m = m+++swapMax k m+ | rows m > 0 && j>0 = (j, m ?? (Pos (idxs swapped), All))+ | otherwise = (0,m)+ where+ j = maxIndex $ abs (tr m ! k)+ swapped = j:[1..j-1] ++ 0:[j+1..rows m-1]++down g a = foldMatrix g f a+ where+ f (e,r,c,m)+ | e /= 0 = (1, r', 0, m - outer c r')+ | otherwise = error "singular!"+ where+ r' = r / scalar e+++-- | generic reference implementation of gaussian elimination+--+-- @a <> gaussElim a b = b@+--+gaussElim_2+ :: (Eq t, Fractional t, Num (Vector t), Numeric t)+ => Matrix t -> Matrix t -> Matrix t++gaussElim_2 a b = flipudrl r+ where+ flipudrl = flipud . fliprl+ splitColsAt n = (takeColumns n &&& dropColumns n)+ go f x y = splitColsAt (cols a) (down f $ x ||| y)+ (a1,b1) = go (snd . swapMax 0) a b+ ( _, r) = go id (flipudrl $ a1) (flipudrl $ b1)++--------------------------------------------------------------------------------++gaussElim_1+ :: (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t)+ => Matrix t -> Matrix t -> Matrix t++gaussElim_1 x y = dropColumns (rows x) (flipud $ fromRows s2)+ where+ rs = toRows $ x ||| y+ s1 = fromRows $ pivotDown (rows x) 0 rs -- interesting+ s2 = pivotUp (rows x-1) (toRows $ flipud s1)++pivotDown+ :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t)+ => Int -> Int -> [Vector t] -> [Vector t]+pivotDown t n xs+ | t == n = []+ | otherwise = y : pivotDown t (n+1) ys+ where+ y:ys = redu (pivot n xs)++ pivot k = (const k &&& id)+ . sortBy (flip compare `on` (abs. (! k)))++ redu :: (Int, [Vector t]) -> [Vector t]+ redu (k,x:zs)+ | p == 0 = error "gauss: singular!" -- FIXME+ | otherwise = u : map f zs+ where+ p = x!k+ u = scale (recip (x!k)) x+ f z = z - scale (z!k) u+ redu (_,[]) = []+++pivotUp+ :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t)+ => Int -> [Vector t] -> [Vector t]+pivotUp n xs+ | n == -1 = []+ | otherwise = y : pivotUp (n-1) ys+ where+ y:ys = redu' (n,xs)++ redu' :: (Int, [Vector t]) -> [Vector t]+ redu' (k,x:zs) = u : map f zs+ where+ u = x+ f z = z - scale (z!k) u+ redu' (_,[]) = []++--------------------------------------------------------------------------------++gaussElim a b = dropColumns (rows a) $ fst $ mutable gaussST (a ||| b)++gaussST (r,_) x = do+ let n = r-1+ axpy m a i j = rowOper (AXPY a i j AllCols) m+ swap m i j = rowOper (SWAP i j AllCols) m+ scal m a i = rowOper (SCAL a (Row i) AllCols) m+ forM_ [0..n] $ \i -> do+ c <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i)+ swap x i (i+c)+ a <- readMatrix x i i+ when (a == 0) $ error "singular!"+ scal x (recip a) i+ forM_ [i+1..n] $ \j -> do+ b <- readMatrix x j i+ axpy x (-b) i j+ forM_ [n,n-1..1] $ \i -> do+ forM_ [i-1,i-2..0] $ \j -> do+ b <- readMatrix x j i+ axpy x (-b) i j++++luST ok (r,_) x = do+ let axpy m a i j = rowOper (AXPY a i j (FromCol (i+1))) m+ swap m i j = rowOper (SWAP i j AllCols) m+ p <- newUndefinedVector r+ forM_ [0..r-1] $ \i -> do+ k <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i)+ writeVector p i (k+i)+ swap x i (i+k)+ a <- readMatrix x i i+ when (ok a) $ do+ forM_ [i+1..r-1] $ \j -> do+ b <- (/a) <$> readMatrix x j i+ axpy x (-b) i j+ writeMatrix x j i b+ v <- unsafeFreezeVector p+ return (toList v)++{- | Experimental implementation of 'luPacked'+ for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'.++>>> let m = ident 5 + (5><5) [0..] :: Matrix (Z ./. 17)+(5><5)+ [ 1, 1, 2, 3, 4+ , 5, 7, 7, 8, 9+ , 10, 11, 13, 13, 14+ , 15, 16, 0, 2, 2+ , 3, 4, 5, 6, 8 ]++>>> let (l,u,p,s) = luFact $ luPacked' m+>>> l+(5><5)+ [ 1, 0, 0, 0, 0+ , 6, 1, 0, 0, 0+ , 12, 7, 1, 0, 0+ , 7, 10, 7, 1, 0+ , 8, 2, 6, 11, 1 ]+>>> u+(5><5)+ [ 15, 16, 0, 2, 2+ , 0, 13, 7, 13, 14+ , 0, 0, 15, 0, 11+ , 0, 0, 0, 15, 15+ , 0, 0, 0, 0, 1 ]++-}+luPacked' x = LU m p+ where+ (m,p) = mutable (luST (magnit 0)) x++--------------------------------------------------------------------------------++scalS a (Slice x r0 c0 nr nc) = rowOper (SCAL a (RowRange r0 (r0+nr-1)) (ColRange c0 (c0+nc-1))) x++view x k r = do+ d <- readMatrix x k k+ let rr = r-1-k+ o = if k < r-1 then 1 else 0+ s = Slice x (k+1) (k+1) rr rr+ u = Slice x k (k+1) o rr+ l = Slice x (k+1) k rr o+ return (d,u,l,s)++withVec r f = \s x -> do+ p <- newUndefinedVector r+ _ <- f s x p+ v <- unsafeFreezeVector p+ return v+++luPacked'' m = (id *** toList) (mutable (withVec (rows m) lu2) m)+ where+ lu2 (r,_) x p = do+ forM_ [0..r-1] $ \k -> do+ pivot x p k+ (d,u,l,s) <- view x k r+ when (magnit 0 d) $ do+ scalS (recip d) l+ gemmm 1 s (-1) l u++ pivot x p k = do+ j <- maxIndex . abs . flatten <$> extractMatrix x (FromRow k) (Col k)+ writeVector p k (j+k)+ swap k (k+j)+ where+ swap i j = rowOper (SWAP i j AllCols) x++--------------------------------------------------------------------------------++rowRange m = [0..rows m -1]++at k = Pos (idxs[k])++backSust' lup rhs = foldl' f (rhs?[]) (reverse ls)+ where+ ls = [ (d k , u k , b k) | k <- rowRange lup ]+ where+ d k = lup ?? (at k, at k)+ u k = lup ?? (at k, Drop (k+1))+ b k = rhs ?? (at k, All)++ f x (d,u,b) = (b - u<>x) / d+ ===+ x+++forwSust' lup rhs = foldl' f (rhs?[]) ls+ where+ ls = [ (l k , b k) | k <- rowRange lup ]+ where+ l k = lup ?? (at k, Take k)+ b k = rhs ?? (at k, All)++ f x (l,b) = x+ ===+ (b - l<>x)+++luSolve'' (LU lup p) b = backSust' lup (forwSust' lup pb)+ where+ pb = b ?? (Pos (fixPerm' p), All)++--------------------------------------------------------------------------------++forwSust lup rhs = fst $ mutable f rhs+ where+ f (r,c) x = do+ l <- unsafeThawMatrix lup+ let go k = gemmm 1 (Slice x k 0 1 c) (-1) (Slice l k 0 1 k) (Slice x 0 0 k c)+ mapM_ go [0..r-1]+++backSust lup rhs = fst $ mutable f rhs+ where+ f (r,c) m = do+ l <- unsafeThawMatrix lup+ let d k = recip (lup `atIndex` (k,k))+ u k = Slice l k (k+1) 1 (r-1-k)+ b k = Slice m k 0 1 c+ x k = Slice m (k+1) 0 (r-1-k) c+ scal k = rowOper (SCAL (d k) (Row k) AllCols) m++ go k = gemmm 1 (b k) (-1) (u k) (x k) >> scal k+ mapM_ go [r-1,r-2..0]+++{- | Experimental implementation of 'luSolve' for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'.++>>> let a = (2><2) [1,2,3,5] :: Matrix (Z ./. 13)+(2><2)+ [ 1, 2+ , 3, 5 ]+>>> b+(2><3)+ [ 5, 1, 3+ , 8, 6, 3 ]++>>> luSolve' (luPacked' a) b+(2><3)+ [ 4, 7, 4+ , 7, 10, 6 ]++-}+luSolve' (LU lup p) b = backSust lup (forwSust lup pb)+ where+ pb = b ?? (Pos (fixPerm' p), All)+++--------------------------------------------------------------------------------++data MatrixView t b+ = Elem t+ | Block b b b b+ deriving Show+++viewBlock' r c m+ | (rt,ct) == (1,1) = Elem (atM' m 0 0)+ | otherwise = Block m11 m12 m21 m22+ where+ (rt,ct) = size m+ m11 = subm (0,0) (r,c) m+ m12 = subm (0,c) (r,ct-c) m+ m21 = subm (r,0) (rt-r,c) m+ m22 = subm (r,c) (rt-r,ct-c) m+ subm = subMatrix++viewBlock m = viewBlock' n n m+ where+ n = rows m `div` 2++invershur (viewBlock -> Block a b c d) = fromBlocks [[a',b'],[c',d']]+ where+ r1 = invershur a+ r2 = c <> r1+ r3 = r1 <> b+ r4 = c <> r3+ r5 = r4-d+ r6 = invershur r5+ b' = r3 <> r6+ c' = r6 <> r2+ r7 = r3 <> c'+ a' = r1-r7+ d' = -r6++invershur x = recip x++--------------------------------------------------------------------------------++instance Testable (Matrix I) where+ checkT _ = test++test :: (Bool, IO())+test = (and ok, return ())+ where+ m = (3><4) [1..12] :: Matrix I+ r = (2><3) [1,2,3,4,3,2]+ c = (3><2) [0,4,4,1,2,3]+ p = (9><10) [0..89] :: Matrix I+ ep = (2><3) [10,24,32,44,31,23]+ md = fromInt m :: Matrix Double+ ok = [ tr m <> m == toInt (tr md <> md)+ , m <> tr m == toInt (md <> tr md)+ , m ?? (Take 2, Take 3) == remap (asColumn (range 2)) (asRow (range 3)) m+ , remap r (tr c) p == ep+ , tr p ?? (PosCyc (idxs[-5,13]), Pos (idxs[3,7,1])) == (2><3) [35,75,15,33,73,13]+ ]
+ src/Internal/Vector.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module : Internal.Vector+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--++module Internal.Vector(+ I,Z,R,C,+ fi,ti,+ Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith,+ createVector, avec, inlinePerformIO,+ toList, dim, (@>), at', (|>),+ vjoin, subVector, takesV, idxs,+ buildVector,+ asReal, asComplex,+ toByteString,fromByteString,+ zipVector, unzipVector, zipVectorWith, unzipVectorWith,+ foldVector, foldVectorG, foldVectorWithIndex, foldLoop,+ mapVector, mapVectorM, mapVectorM_,+ mapVectorWithIndex, mapVectorWithIndexM, mapVectorWithIndexM_+) where++import Foreign.Marshal.Array+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import Foreign.C.Types(CInt)+import Data.Int(Int64)+import Data.Complex+import System.IO.Unsafe(unsafePerformIO)+import GHC.ForeignPtr(mallocPlainForeignPtrBytes)+import GHC.Base(realWorld#, IO(IO), when)+import qualified Data.Vector.Storable as Vector+import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith)++import Data.Binary+import Data.Binary.Put+import Control.Monad(replicateM)+import qualified Data.ByteString.Internal as BS+import Data.Vector.Storable.Internal(updPtr)++type I = CInt+type Z = Int64+type R = Double+type C = Complex Double+++-- | specialized fromIntegral+fi :: Int -> CInt+fi = fromIntegral++-- | specialized fromIntegral+ti :: CInt -> Int+ti = fromIntegral+++-- | Number of elements+dim :: (Storable t) => Vector t -> Int+dim = Vector.length+{-# INLINE dim #-}+++-- C-Haskell vector adapter+{-# INLINE avec #-}+avec :: Storable a => Vector a -> (f -> IO r) -> ((CInt -> Ptr a -> f) -> IO r)+avec v f g = unsafeWith v $ \ptr -> f (g (fromIntegral (Vector.length v)) ptr)++-- allocates memory for a new vector+createVector :: Storable a => Int -> IO (Vector a)+createVector n = do+ when (n < 0) $ error ("trying to createVector of negative dim: "++show n)+ fp <- doMalloc undefined+ return $ unsafeFromForeignPtr fp 0 n+ where+ --+ -- Use the much cheaper Haskell heap allocated storage+ -- for foreign pointer space we control+ --+ doMalloc :: Storable b => b -> IO (ForeignPtr b)+ doMalloc dummy = do+ mallocPlainForeignPtrBytes (n * sizeOf dummy)++{- | creates a Vector from a list:++@> fromList [2,3,5,7]+4 |> [2.0,3.0,5.0,7.0]@++-}++safeRead :: Storable a => Vector a -> (Ptr a -> IO c) -> c+safeRead v = inlinePerformIO . unsafeWith v+{-# INLINE safeRead #-}++inlinePerformIO :: IO a -> a+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r+{-# INLINE inlinePerformIO #-}++{- extracts the Vector elements to a list++>>> toList (linspace 5 (1,10))+[1.0,3.25,5.5,7.75,10.0]++-}+toList :: Storable a => Vector a -> [a]+toList v = safeRead v $ peekArray (dim v)++{- | Create a vector from a list of elements and explicit dimension. The input+ list is truncated if it is too long, so it may safely+ be used, for instance, with infinite lists.++>>> 5 |> [1..]+[1.0,2.0,3.0,4.0,5.0]+it :: (Enum a, Num a, Foreign.Storable.Storable a) => Vector a++-}+(|>) :: (Storable a) => Int -> [a] -> Vector a+infixl 9 |>+n |> l+ | length l' == n = fromList l'+ | otherwise = error "list too short for |>"+ where+ l' = take n l+++-- | Create a vector of indexes, useful for matrix extraction using '(??)'+idxs :: [Int] -> Vector I+idxs js = fromList (map fromIntegral js) :: Vector I++{- | takes a number of consecutive elements from a Vector++>>> subVector 2 3 (fromList [1..10])+[3.0,4.0,5.0]+it :: (Enum t, Num t, Foreign.Storable.Storable t) => Vector t++-}+subVector :: Storable t => Int -- ^ index of the starting element+ -> Int -- ^ number of elements to extract+ -> Vector t -- ^ source+ -> Vector t -- ^ result+subVector = Vector.slice+{-# INLINE subVector #-}+++++{- | Reads a vector position:++>>> fromList [0..9] @> 7+7.0++-}+(@>) :: Storable t => Vector t -> Int -> t+infixl 9 @>+v @> n+ | n >= 0 && n < dim v = at' v n+ | otherwise = error "vector index out of range"+{-# INLINE (@>) #-}++-- | access to Vector elements without range checking+at' :: Storable a => Vector a -> Int -> a+at' v n = safeRead v $ flip peekElemOff n+{-# INLINE at' #-}++{- | concatenate a list of vectors++>>> vjoin [fromList [1..5::Double], konst 1 3]+[1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0]+it :: Vector Double++-}+vjoin :: Storable t => [Vector t] -> Vector t+vjoin [] = fromList []+vjoin [v] = v+vjoin as = unsafePerformIO $ do+ let tot = sum (map dim as)+ r <- createVector tot+ unsafeWith r $ \ptr ->+ joiner as tot ptr+ return r+ where joiner [] _ _ = return ()+ joiner (v:cs) _ p = do+ let n = dim v+ unsafeWith v $ \pb -> copyArray p pb n+ joiner cs 0 (advancePtr p n)+++{- | Extract consecutive subvectors of the given sizes.++>>> takesV [3,4] (linspace 10 (1,10::Double))+[[1.0,2.0,3.0],[4.0,5.0,6.0,7.0]]+it :: [Vector Double]++-}+takesV :: Storable t => [Int] -> Vector t -> [Vector t]+takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w)+ | otherwise = go ms w+ where go [] _ = []+ go (n:ns) v = subVector 0 n v+ : go ns (subVector n (dim v - n) v)++---------------------------------------------------------------++-- | transforms a complex vector into a real vector with alternating real and imaginary parts+asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a+asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n)+ where (fp,i,n) = unsafeToForeignPtr v++-- | transforms a real vector into a complex vector with alternating real and imaginary parts+asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a)+asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2)+ where (fp,i,n) = unsafeToForeignPtr v++--------------------------------------------------------------------------------+++-- | map on Vectors+mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b+mapVector f v = unsafePerformIO $ do+ w <- createVector (dim v)+ unsafeWith v $ \p ->+ unsafeWith w $ \q -> do+ let go (-1) = return ()+ go !k = do x <- peekElemOff p k+ pokeElemOff q k (f x)+ go (k-1)+ go (dim v -1)+ return w+{-# INLINE mapVector #-}++-- | zipWith for Vectors+zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c+zipVectorWith f u v = unsafePerformIO $ do+ let n = min (dim u) (dim v)+ w <- createVector n+ unsafeWith u $ \pu ->+ unsafeWith v $ \pv ->+ unsafeWith w $ \pw -> do+ let go (-1) = return ()+ go !k = do x <- peekElemOff pu k+ y <- peekElemOff pv k+ pokeElemOff pw k (f x y)+ go (k-1)+ go (n -1)+ return w+{-# INLINE zipVectorWith #-}++-- | unzipWith for Vectors+unzipVectorWith :: (Storable (a,b), Storable c, Storable d)+ => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d)+unzipVectorWith f u = unsafePerformIO $ do+ let n = dim u+ v <- createVector n+ w <- createVector n+ unsafeWith u $ \pu ->+ unsafeWith v $ \pv ->+ unsafeWith w $ \pw -> do+ let go (-1) = return ()+ go !k = do z <- peekElemOff pu k+ let (x,y) = f z+ pokeElemOff pv k x+ pokeElemOff pw k y+ go (k-1)+ go (n-1)+ return (v,w)+{-# INLINE unzipVectorWith #-}++foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b+foldVector f x v = unsafePerformIO $+ unsafeWith v $ \p -> do+ let go (-1) s = return s+ go !k !s = do y <- peekElemOff p k+ go (k-1::Int) (f y s)+ go (dim v -1) x+{-# INLINE foldVector #-}++-- the zero-indexed index is passed to the folding function+foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b+foldVectorWithIndex f x v = unsafePerformIO $+ unsafeWith v $ \p -> do+ let go (-1) s = return s+ go !k !s = do y <- peekElemOff p k+ go (k-1::Int) (f k y s)+ go (dim v -1) x+{-# INLINE foldVectorWithIndex #-}++foldLoop :: (Int -> t -> t) -> t -> Int -> t+foldLoop f s0 d = go (d - 1) s0+ where+ go 0 s = f (0::Int) s+ go !j !s = go (j - 1) (f j s)++foldVectorG :: Storable t1 => (Int -> (Int -> t1) -> t -> t) -> t -> Vector t1 -> t+foldVectorG f s0 v = foldLoop g s0 (dim v)+ where g !k !s = f k (safeRead v . flip peekElemOff) s+ {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479)+{-# INLINE foldVectorG #-}++-------------------------------------------------------------------++-- | monadic map over Vectors+-- the monad @m@ must be strict+mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b)+mapVectorM f v = do+ w <- return $! unsafePerformIO $! createVector (dim v)+ mapVectorM' w 0 (dim v -1)+ return w+ where mapVectorM' w' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f x+ return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f x+ _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ mapVectorM' w' (k+1) t+{-# INLINE mapVectorM #-}++-- | monadic map over Vectors+mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m ()+mapVectorM_ f v = do+ mapVectorM' 0 (dim v -1)+ where mapVectorM' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ f x+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ _ <- f x+ mapVectorM' (k+1) t+{-# INLINE mapVectorM_ #-}++-- | monadic map over Vectors with the zero-indexed index passed to the mapping function+-- the monad @m@ must be strict+mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b)+mapVectorWithIndexM f v = do+ w <- return $! unsafePerformIO $! createVector (dim v)+ mapVectorM' w 0 (dim v -1)+ return w+ where mapVectorM' w' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f k x+ return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f k x+ _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ mapVectorM' w' (k+1) t+{-# INLINE mapVectorWithIndexM #-}++-- | monadic map over Vectors with the zero-indexed index passed to the mapping function+mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m ()+mapVectorWithIndexM_ f v = do+ mapVectorM' 0 (dim v -1)+ where mapVectorM' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ f k x+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ _ <- f k x+ mapVectorM' (k+1) t+{-# INLINE mapVectorWithIndexM_ #-}+++mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b+--mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b])+mapVectorWithIndex f v = unsafePerformIO $ do+ w <- createVector (dim v)+ unsafeWith v $ \p ->+ unsafeWith w $ \q -> do+ let go (-1) = return ()+ go !k = do x <- peekElemOff p k+ pokeElemOff q k (f k x)+ go (k-1)+ go (dim v -1)+ return w+{-# INLINE mapVectorWithIndex #-}++--------------------------------------------------------------------------------++++-- a 64K cache, with a Double taking 13 bytes in Bytestring,+-- implies a chunk size of 5041+chunk :: Int+chunk = 5000++chunks :: Int -> [Int]+chunks d = let c = d `div` chunk+ m = d `mod` chunk+ in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk)++putVector :: (Storable t, Binary t) => Vector t -> Data.Binary.Put.PutM ()+putVector v = mapM_ put $! toList v++getVector :: (Storable a, Binary a) => Int -> Get (Vector a)+getVector d = do+ xs <- replicateM d get+ return $! fromList xs++--------------------------------------------------------------------------------++toByteString :: Storable t => Vector t -> BS.ByteString+toByteString v = BS.PS (castForeignPtr fp) (sz*o) (sz * dim v)+ where+ (fp,o,_n) = unsafeToForeignPtr v+ sz = sizeOf (v@>0)+++fromByteString :: Storable t => BS.ByteString -> Vector t+fromByteString (BS.PS fp o n) = r+ where+ r = unsafeFromForeignPtr (castForeignPtr (updPtr (`plusPtr` o) fp)) 0 n'+ n' = n `div` sz+ sz = sizeOf (r@>0)++--------------------------------------------------------------------------------++instance (Binary a, Storable a) => Binary (Vector a) where++ put v = do+ let d = dim v+ put d+ mapM_ putVector $! takesV (chunks d) v++ -- put = put . v2bs++ get = do+ d <- get+ vs <- mapM getVector $ chunks d+ return $! vjoin vs++ -- get = fmap bs2v get++++-------------------------------------------------------------------++{- | creates a Vector of the specified length using the supplied function to+ to map the index to the value at that index.++@> buildVector 4 fromIntegral+4 |> [0.0,1.0,2.0,3.0]@++-}+buildVector :: Storable a => Int -> (Int -> a) -> Vector a+buildVector len f =+ fromList $ map f [0 .. (len - 1)]+++-- | zip for Vectors+zipVector :: (Storable a, Storable b, Storable (a,b)) => Vector a -> Vector b -> Vector (a,b)+zipVector = zipVectorWith (,)++-- | unzip for Vectors+unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vector a,Vector b)+unzipVector = unzipVectorWith id++-------------------------------------------------------------------
+ src/Internal/Vectorized.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.Vectorized+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Low level interface to vector operations.+--+-----------------------------------------------------------------------------++module Internal.Vectorized where++import Internal.Vector+import Internal.Devel+import Data.Complex+import Foreign.Marshal.Alloc(free,malloc)+import Foreign.Marshal.Array(newArray,copyArray)+import Foreign.Ptr(Ptr)+import Foreign.Storable(peek,Storable)+import Foreign.C.Types+import Foreign.C.String+import System.IO.Unsafe(unsafePerformIO)+import Control.Monad(when)++infixr 1 #+(#) :: TransArray c => c -> (b -> IO r) -> TransRaw c b -> IO r+a # b = applyRaw a b+{-# INLINE (#) #-}++(#!) :: (TransArray c, TransArray c1) => c1 -> c -> TransRaw c1 (TransRaw c (IO r)) -> IO r+a #! b = a # b # id+{-# INLINE (#!) #-}++fromei :: Enum a => a -> CInt+fromei x = fromIntegral (fromEnum x) :: CInt++data FunCodeV = Sin+ | Cos+ | Tan+ | Abs+ | ASin+ | ACos+ | ATan+ | Sinh+ | Cosh+ | Tanh+ | ASinh+ | ACosh+ | ATanh+ | Exp+ | Log+ | Sign+ | Sqrt+ deriving Enum++data FunCodeSV = Scale+ | Recip+ | AddConstant+ | Negate+ | PowSV+ | PowVS+ | ModSV+ | ModVS+ deriving Enum++data FunCodeVV = Add+ | Sub+ | Mul+ | Div+ | Pow+ | ATan2+ | Mod+ deriving Enum++data FunCodeS = Norm2+ | AbsSum+ | MaxIdx+ | Max+ | MinIdx+ | Min+ deriving Enum++------------------------------------------------------------------++-- | sum of elements+sumF :: Vector Float -> Float+sumF = sumg c_sumF++-- | sum of elements+sumR :: Vector Double -> Double+sumR = sumg c_sumR++-- | sum of elements+sumQ :: Vector (Complex Float) -> Complex Float+sumQ = sumg c_sumQ++-- | sum of elements+sumC :: Vector (Complex Double) -> Complex Double+sumC = sumg c_sumC++sumI :: ( TransRaw c (CInt -> Ptr a -> IO CInt) ~ (CInt -> Ptr I -> I :> Ok)+ , TransArray c+ , Storable a+ )+ => I -> c -> a+sumI m = sumg (c_sumI m)++sumL :: ( TransRaw c (CInt -> Ptr a -> IO CInt) ~ (CInt -> Ptr Z -> Z :> Ok)+ , TransArray c+ , Storable a+ ) => Z -> c -> a+sumL m = sumg (c_sumL m)++sumg :: (TransArray c, Storable a) => TransRaw c (CInt -> Ptr a -> IO CInt) -> c -> a+sumg f x = unsafePerformIO $ do+ r <- createVector 1+ (x #! r) f #| "sum"+ return $ r @> 0++type TVV t = t :> t :> Ok++foreign import ccall unsafe "sumF" c_sumF :: TVV Float+foreign import ccall unsafe "sumR" c_sumR :: TVV Double+foreign import ccall unsafe "sumQ" c_sumQ :: TVV (Complex Float)+foreign import ccall unsafe "sumC" c_sumC :: TVV (Complex Double)+foreign import ccall unsafe "sumI" c_sumI :: I -> TVV I+foreign import ccall unsafe "sumL" c_sumL :: Z -> TVV Z++-- | product of elements+prodF :: Vector Float -> Float+prodF = prodg c_prodF++-- | product of elements+prodR :: Vector Double -> Double+prodR = prodg c_prodR++-- | product of elements+prodQ :: Vector (Complex Float) -> Complex Float+prodQ = prodg c_prodQ++-- | product of elements+prodC :: Vector (Complex Double) -> Complex Double+prodC = prodg c_prodC++prodI :: I-> Vector I -> I+prodI = prodg . c_prodI++prodL :: Z-> Vector Z -> Z+prodL = prodg . c_prodL++prodg :: (TransArray c, Storable a)+ => TransRaw c (CInt -> Ptr a -> IO CInt) -> c -> a+prodg f x = unsafePerformIO $ do+ r <- createVector 1+ (x #! r) f #| "prod"+ return $ r @> 0+++foreign import ccall unsafe "prodF" c_prodF :: TVV Float+foreign import ccall unsafe "prodR" c_prodR :: TVV Double+foreign import ccall unsafe "prodQ" c_prodQ :: TVV (Complex Float)+foreign import ccall unsafe "prodC" c_prodC :: TVV (Complex Double)+foreign import ccall unsafe "prodI" c_prodI :: I -> TVV I+foreign import ccall unsafe "prodL" c_prodL :: Z -> TVV Z++------------------------------------------------------------------++toScalarAux :: (Enum a, TransArray c, Storable a1)+ => (CInt -> TransRaw c (CInt -> Ptr a1 -> IO CInt)) -> a -> c -> a1+toScalarAux fun code v = unsafePerformIO $ do+ r <- createVector 1+ (v #! r) (fun (fromei code)) #|"toScalarAux"+ return (r @> 0)+++vectorMapAux :: (Enum a, Storable t, Storable a1)+ => (CInt -> CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt)+ -> a -> Vector t -> Vector a1+vectorMapAux fun code v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) (fun (fromei code)) #|"vectorMapAux"+ return r++vectorMapValAux :: (Enum a, Storable a2, Storable t, Storable a1)+ => (CInt -> Ptr a2 -> CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt)+ -> a -> a2 -> Vector t -> Vector a1+vectorMapValAux fun code val v = unsafePerformIO $ do+ r <- createVector (dim v)+ pval <- newArray [val]+ (v #! r) (fun (fromei code) pval) #|"vectorMapValAux"+ free pval+ return r++vectorZipAux :: (Enum a, TransArray c, Storable t, Storable a1)+ => (CInt -> CInt -> Ptr t -> TransRaw c (CInt -> Ptr a1 -> IO CInt))+ -> a -> Vector t -> c -> Vector a1+vectorZipAux fun code u v = unsafePerformIO $ do+ r <- createVector (dim u)+ (u # v #! r) (fun (fromei code)) #|"vectorZipAux"+ return r++---------------------------------------------------------------------++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarR :: FunCodeS -> Vector Double -> Double+toScalarR oper = toScalarAux c_toScalarR (fromei oper)++foreign import ccall unsafe "toScalarR" c_toScalarR :: CInt -> TVV Double++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarF :: FunCodeS -> Vector Float -> Float+toScalarF oper = toScalarAux c_toScalarF (fromei oper)++foreign import ccall unsafe "toScalarF" c_toScalarF :: CInt -> TVV Float++-- | obtains different functions of a vector: only norm1, norm2+toScalarC :: FunCodeS -> Vector (Complex Double) -> Double+toScalarC oper = toScalarAux c_toScalarC (fromei oper)++foreign import ccall unsafe "toScalarC" c_toScalarC :: CInt -> Complex Double :> Double :> Ok++-- | obtains different functions of a vector: only norm1, norm2+toScalarQ :: FunCodeS -> Vector (Complex Float) -> Float+toScalarQ oper = toScalarAux c_toScalarQ (fromei oper)++foreign import ccall unsafe "toScalarQ" c_toScalarQ :: CInt -> Complex Float :> Float :> Ok++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarI :: FunCodeS -> Vector CInt -> CInt+toScalarI oper = toScalarAux c_toScalarI (fromei oper)++foreign import ccall unsafe "toScalarI" c_toScalarI :: CInt -> TVV CInt++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarL :: FunCodeS -> Vector Z -> Z+toScalarL oper = toScalarAux c_toScalarL (fromei oper)++foreign import ccall unsafe "toScalarL" c_toScalarL :: CInt -> TVV Z+++------------------------------------------------------------------++-- | map of real vectors with given function+vectorMapR :: FunCodeV -> Vector Double -> Vector Double+vectorMapR = vectorMapAux c_vectorMapR++foreign import ccall unsafe "mapR" c_vectorMapR :: CInt -> TVV Double++-- | map of complex vectors with given function+vectorMapC :: FunCodeV -> Vector (Complex Double) -> Vector (Complex Double)+vectorMapC oper = vectorMapAux c_vectorMapC (fromei oper)++foreign import ccall unsafe "mapC" c_vectorMapC :: CInt -> TVV (Complex Double)++-- | map of real vectors with given function+vectorMapF :: FunCodeV -> Vector Float -> Vector Float+vectorMapF = vectorMapAux c_vectorMapF++foreign import ccall unsafe "mapF" c_vectorMapF :: CInt -> TVV Float++-- | map of real vectors with given function+vectorMapQ :: FunCodeV -> Vector (Complex Float) -> Vector (Complex Float)+vectorMapQ = vectorMapAux c_vectorMapQ++foreign import ccall unsafe "mapQ" c_vectorMapQ :: CInt -> TVV (Complex Float)++-- | map of real vectors with given function+vectorMapI :: FunCodeV -> Vector CInt -> Vector CInt+vectorMapI = vectorMapAux c_vectorMapI++foreign import ccall unsafe "mapI" c_vectorMapI :: CInt -> TVV CInt++-- | map of real vectors with given function+vectorMapL :: FunCodeV -> Vector Z -> Vector Z+vectorMapL = vectorMapAux c_vectorMapL++foreign import ccall unsafe "mapL" c_vectorMapL :: CInt -> TVV Z++-------------------------------------------------------------------++-- | map of real vectors with given function+vectorMapValR :: FunCodeSV -> Double -> Vector Double -> Vector Double+vectorMapValR oper = vectorMapValAux c_vectorMapValR (fromei oper)++foreign import ccall unsafe "mapValR" c_vectorMapValR :: CInt -> Ptr Double -> TVV Double++-- | map of complex vectors with given function+vectorMapValC :: FunCodeSV -> Complex Double -> Vector (Complex Double) -> Vector (Complex Double)+vectorMapValC = vectorMapValAux c_vectorMapValC++foreign import ccall unsafe "mapValC" c_vectorMapValC :: CInt -> Ptr (Complex Double) -> TVV (Complex Double)++-- | map of real vectors with given function+vectorMapValF :: FunCodeSV -> Float -> Vector Float -> Vector Float+vectorMapValF oper = vectorMapValAux c_vectorMapValF (fromei oper)++foreign import ccall unsafe "mapValF" c_vectorMapValF :: CInt -> Ptr Float -> TVV Float++-- | map of complex vectors with given function+vectorMapValQ :: FunCodeSV -> Complex Float -> Vector (Complex Float) -> Vector (Complex Float)+vectorMapValQ oper = vectorMapValAux c_vectorMapValQ (fromei oper)++foreign import ccall unsafe "mapValQ" c_vectorMapValQ :: CInt -> Ptr (Complex Float) -> TVV (Complex Float)++-- | map of real vectors with given function+vectorMapValI :: FunCodeSV -> CInt -> Vector CInt -> Vector CInt+vectorMapValI oper = vectorMapValAux c_vectorMapValI (fromei oper)++foreign import ccall unsafe "mapValI" c_vectorMapValI :: CInt -> Ptr CInt -> TVV CInt++-- | map of real vectors with given function+vectorMapValL :: FunCodeSV -> Z -> Vector Z -> Vector Z+vectorMapValL oper = vectorMapValAux c_vectorMapValL (fromei oper)++foreign import ccall unsafe "mapValL" c_vectorMapValL :: CInt -> Ptr Z -> TVV Z+++-------------------------------------------------------------------++type TVVV t = t :> t :> t :> Ok++-- | elementwise operation on real vectors+vectorZipR :: FunCodeVV -> Vector Double -> Vector Double -> Vector Double+vectorZipR = vectorZipAux c_vectorZipR++foreign import ccall unsafe "zipR" c_vectorZipR :: CInt -> TVVV Double++-- | elementwise operation on complex vectors+vectorZipC :: FunCodeVV -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double)+vectorZipC = vectorZipAux c_vectorZipC++foreign import ccall unsafe "zipC" c_vectorZipC :: CInt -> TVVV (Complex Double)++-- | elementwise operation on real vectors+vectorZipF :: FunCodeVV -> Vector Float -> Vector Float -> Vector Float+vectorZipF = vectorZipAux c_vectorZipF++foreign import ccall unsafe "zipF" c_vectorZipF :: CInt -> TVVV Float++-- | elementwise operation on complex vectors+vectorZipQ :: FunCodeVV -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float)+vectorZipQ = vectorZipAux c_vectorZipQ++foreign import ccall unsafe "zipQ" c_vectorZipQ :: CInt -> TVVV (Complex Float)++-- | elementwise operation on CInt vectors+vectorZipI :: FunCodeVV -> Vector CInt -> Vector CInt -> Vector CInt+vectorZipI = vectorZipAux c_vectorZipI++foreign import ccall unsafe "zipI" c_vectorZipI :: CInt -> TVVV CInt++-- | elementwise operation on CInt vectors+vectorZipL :: FunCodeVV -> Vector Z -> Vector Z -> Vector Z+vectorZipL = vectorZipAux c_vectorZipL++foreign import ccall unsafe "zipL" c_vectorZipL :: CInt -> TVVV Z++--------------------------------------------------------------------------------++foreign import ccall unsafe "vectorScan" c_vectorScan+ :: CString -> Ptr CInt -> Ptr (Ptr Double) -> IO CInt++vectorScan :: FilePath -> IO (Vector Double)+vectorScan s = do+ pp <- malloc+ pn <- malloc+ cs <- newCString s+ ok <- c_vectorScan cs pn pp+ when (not (ok == 0)) $+ error ("vectorScan: file \"" ++ s ++"\" not found")+ n <- fromIntegral <$> peek pn+ p <- peek pp+ v <- createVector n+ free pn+ free cs+ unsafeWith v $ \pv -> copyArray pv p n+ free p+ free pp+ return v++--------------------------------------------------------------------------------++type Seed = Int++data RandDist = Uniform -- ^ uniform distribution in [0,1)+ | Gaussian -- ^ normal distribution with mean zero and standard deviation one+ deriving Enum++-- | Obtains a vector of pseudorandom elements (use randomIO to get a random seed).+randomVector :: Seed+ -> RandDist -- ^ distribution+ -> Int -- ^ vector size+ -> Vector Double+randomVector seed dist n = unsafePerformIO $ do+ r <- createVector n+ (r # id) (c_random_vector (fi seed) ((fi.fromEnum) dist)) #|"randomVector"+ return r++foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> Double :> Ok++--------------------------------------------------------------------------------++roundVector :: Vector Double -> Vector Double+roundVector v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) c_round_vector #|"roundVector"+ return r++foreign import ccall unsafe "round_vector" c_round_vector :: TVV Double++--------------------------------------------------------------------------------++-- |+-- >>> range 5+-- [0,1,2,3,4]+-- it :: Vector I+--+range :: Int -> Vector I+range n = unsafePerformIO $ do+ r <- createVector n+ (r # id) c_range_vector #|"range"+ return r++foreign import ccall unsafe "range_vector" c_range_vector :: CInt :> Ok+++float2DoubleV :: Vector Float -> Vector Double+float2DoubleV = tog c_float2double++double2FloatV :: Vector Double -> Vector Float+double2FloatV = tog c_double2float++double2IntV :: Vector Double -> Vector CInt+double2IntV = tog c_double2int++int2DoubleV :: Vector CInt -> Vector Double+int2DoubleV = tog c_int2double++double2longV :: Vector Double -> Vector Z+double2longV = tog c_double2long++long2DoubleV :: Vector Z -> Vector Double+long2DoubleV = tog c_long2double+++float2IntV :: Vector Float -> Vector CInt+float2IntV = tog c_float2int++int2floatV :: Vector CInt -> Vector Float+int2floatV = tog c_int2float++int2longV :: Vector I -> Vector Z+int2longV = tog c_int2long++long2intV :: Vector Z -> Vector I+long2intV = tog c_long2int+++tog :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+tog f v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) f #|"tog"+ return r++foreign import ccall unsafe "float2double" c_float2double :: Float :> Double :> Ok+foreign import ccall unsafe "double2float" c_double2float :: Double :> Float :> Ok+foreign import ccall unsafe "int2double" c_int2double :: CInt :> Double :> Ok+foreign import ccall unsafe "double2int" c_double2int :: Double :> CInt :> Ok+foreign import ccall unsafe "long2double" c_long2double :: Z :> Double :> Ok+foreign import ccall unsafe "double2long" c_double2long :: Double :> Z :> Ok+foreign import ccall unsafe "int2float" c_int2float :: CInt :> Float :> Ok+foreign import ccall unsafe "float2int" c_float2int :: Float :> CInt :> Ok+foreign import ccall unsafe "int2long" c_int2long :: I :> Z :> Ok+foreign import ccall unsafe "long2int" c_long2int :: Z :> I :> Ok+++---------------------------------------------------------------++stepg :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+stepg f v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) f #|"step"+ return r++stepD :: Vector Double -> Vector Double+stepD = stepg c_stepD++stepF :: Vector Float -> Vector Float+stepF = stepg c_stepF++stepI :: Vector CInt -> Vector CInt+stepI = stepg c_stepI++stepL :: Vector Z -> Vector Z+stepL = stepg c_stepL+++foreign import ccall unsafe "stepF" c_stepF :: TVV Float+foreign import ccall unsafe "stepD" c_stepD :: TVV Double+foreign import ccall unsafe "stepI" c_stepI :: TVV CInt+foreign import ccall unsafe "stepL" c_stepL :: TVV Z++--------------------------------------------------------------------------------++conjugateAux :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+conjugateAux fun x = unsafePerformIO $ do+ v <- createVector (dim x)+ (x #! v) fun #|"conjugateAux"+ return v++conjugateQ :: Vector (Complex Float) -> Vector (Complex Float)+conjugateQ = conjugateAux c_conjugateQ+foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TVV (Complex Float)++conjugateC :: Vector (Complex Double) -> Vector (Complex Double)+conjugateC = conjugateAux c_conjugateC+foreign import ccall unsafe "conjugateC" c_conjugateC :: TVV (Complex Double)++--------------------------------------------------------------------------------++cloneVector :: Storable t => Vector t -> IO (Vector t)+cloneVector v = do+ let n = dim v+ r <- createVector n+ let f _ s _ d = copyArray d s n >> return 0+ (v #! r) f #|"cloneVector"+ return r++--------------------------------------------------------------------------------++constantAux :: (Storable a1, Storable a)+ => (Ptr a1 -> CInt -> Ptr a -> IO CInt) -> a1 -> Int -> Vector a+constantAux fun x n = unsafePerformIO $ do+ v <- createVector n+ px <- newArray [x]+ (v # id) (fun px) #|"constantAux"+ free px+ return v++type TConst t = Ptr t -> t :> Ok++foreign import ccall unsafe "constantF" cconstantF :: TConst Float+foreign import ccall unsafe "constantR" cconstantR :: TConst Double+foreign import ccall unsafe "constantQ" cconstantQ :: TConst (Complex Float)+foreign import ccall unsafe "constantC" cconstantC :: TConst (Complex Double)+foreign import ccall unsafe "constantI" cconstantI :: TConst CInt+foreign import ccall unsafe "constantL" cconstantL :: TConst Z++----------------------------------------------------------------------
+ src/Numeric/LinearAlgebra.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+{- |+Module : Numeric.LinearAlgebra+Copyright : (c) Alberto Ruiz 2006-15+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional+++-}+-----------------------------------------------------------------------------+module Numeric.LinearAlgebra (++ -- * Basic types and data manipulation+ -- | This package works with 2D ('Matrix') and 1D ('Vector')+ -- arrays of real ('R') or complex ('C') double precision numbers.+ -- Single precision and machine integers are also supported for+ -- basic arithmetic and data manipulation.+ module Numeric.LinearAlgebra.Data,++ -- * Numeric classes+ -- |+ -- The standard numeric classes are defined elementwise (commonly referred to+ -- as the Hadamard product or the Schur product):+ --+ -- >>> vector [1,2,3] * vector [3,0,-2]+ -- [3.0,0.0,-6.0]+ -- it :: Vector R+ --+ -- >>> matrix 3 [1..9] * ident 3+ -- (3><3)+ -- [ 1.0, 0.0, 0.0+ -- , 0.0, 5.0, 0.0+ -- , 0.0, 0.0, 9.0 ]++ -- * Autoconformable dimensions+ -- |+ -- In most operations, single-element vectors and matrices+ -- (created from numeric literals or using 'scalar'), and matrices+ -- with just one row or column, automatically+ -- expand to match the dimensions of the other operand:+ --+ -- >>> 5 + 2*ident 3 :: Matrix Double+ -- (3><3)+ -- [ 7.0, 5.0, 5.0+ -- , 5.0, 7.0, 5.0+ -- , 5.0, 5.0, 7.0 ]+ --+ -- >>> (4><3) [1..] + row [10,20,30]+ -- (4><3)+ -- [ 11.0, 22.0, 33.0+ -- , 14.0, 25.0, 36.0+ -- , 17.0, 28.0, 39.0+ -- , 20.0, 31.0, 42.0 ]+ --++ -- * Products+ -- ** Dot+ dot, (<.>),+ -- ** Matrix-vector+ (#>), (<#), (!#>),+ -- ** Matrix-matrix+ (<>),+ -- | The matrix product is also implemented in the "Data.Monoid" instance, where+ -- single-element matrices (created from numeric literals or using 'scalar')+ -- are used for scaling.+ --+ -- >>> import Data.Monoid as M+ -- >>> let m = matrix 3 [1..6]+ -- >>> m M.<> 2 M.<> diagl[0.5,1,0]+ -- (2><3)+ -- [ 1.0, 4.0, 0.0+ -- , 4.0, 10.0, 0.0 ]+ --+ -- 'mconcat' uses 'optimiseMult' to get the optimal association order.+++ -- ** Other+ outer, kronecker, cross,+ scale, add,+ sumElements, prodElements,++ -- * Linear systems+ -- ** General+ (<\>),+ linearSolveLS,+ linearSolveSVD,+ -- ** Determined+ linearSolve,+ luSolve, luPacked,+ luSolve', luPacked',+ -- ** Symmetric indefinite+ ldlSolve, ldlPacked,+ -- ** Positive definite+ cholSolve,+ -- ** Triangular+ UpLo(..),+ triSolve,+ -- ** Tridiagonal+ triDiagSolve,+ -- ** Sparse+ cgSolve,+ cgSolve',++ -- * Inverse and pseudoinverse+ inv, pinv, pinvTol,++ -- * Determinant and rank+ rcond, rank,+ det, invlndet,++ -- * Norms+ Normed(..),+ norm_Frob, norm_nuclear,++ -- * Nullspace and range+ orth,+ nullspace, null1, null1sym,++ -- * Singular value decomposition+ svd,+ thinSVD,+ compactSVD,+ compactSVDTol,+ singularValues,+ leftSV, rightSV,++ -- * Eigendecomposition+ eig, geig, eigSH,+ eigenvalues, geigenvalues, eigenvaluesSH,+ geigSH,++ -- * QR+ qr, thinQR, rq, thinRQ, qrRaw, qrgr,++ -- * Cholesky+ chol, mbChol,++ -- * LU+ lu, luFact,++ -- * Hessenberg+ hess,++ -- * Schur+ schur,++ -- * Matrix functions+ expm,+ sqrtm,+ matFunc,++ -- * Correlation and convolution+ corr, conv, corrMin, corr2, conv2,++ -- * Random arrays++ Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample,++ -- * Misc+ meanCov, rowOuters, pairwiseD2, normalize, peps, relativeError, magnit,+ haussholder, optimiseMult, udot, nullspaceSVD, orthSVD, ranksv,+ iC, sym, mTm, trustSym, unSym,+ -- * Auxiliary classes+ Element, Container, Product, Numeric, LSDiv, Herm,+ Complexable, RealElement,+ RealOf, ComplexOf, SingleOf, DoubleOf,+ IndexOf,+ Field, Linear(), Additive(),+ Transposable,+ LU(..),+ LDL(..),+ QR(..),+ CGState(..),+ Testable(..)+) where++import Numeric.LinearAlgebra.Data++import Numeric.Matrix()+import Numeric.Vector()+import Internal.Matrix+import Internal.Container hiding ((<>))+import Internal.Numeric hiding (mul)+import Internal.Algorithms hiding (linearSolve,Normed,orth,luPacked',linearSolve',luSolve',ldlPacked')+import qualified Internal.Algorithms as A+import Internal.Util+import Internal.Random+import Internal.Sparse((!#>))+import Internal.CG+import Internal.Conversion+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++{- | dense matrix product++>>> let a = (3><5) [1..]+>>> a+(3><5)+ [ 1.0, 2.0, 3.0, 4.0, 5.0+ , 6.0, 7.0, 8.0, 9.0, 10.0+ , 11.0, 12.0, 13.0, 14.0, 15.0 ]++>>> let b = (5><2) [1,3, 0,2, -1,5, 7,7, 6,0]+>>> b+(5><2)+ [ 1.0, 3.0+ , 0.0, 2.0+ , -1.0, 5.0+ , 7.0, 7.0+ , 6.0, 0.0 ]++>>> a <> b+(3><2)+ [ 56.0, 50.0+ , 121.0, 135.0+ , 186.0, 220.0 ]++-}+(<>) :: Numeric t => Matrix t -> Matrix t -> Matrix t+(<>) = mXm+infixr 8 <>+++{- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.++@+a = (2><2)+ [ 1.0, 2.0+ , 3.0, 5.0 ]+@++@+b = (2><3)+ [ 6.0, 1.0, 10.0+ , 15.0, 3.0, 26.0 ]+@++>>> linearSolve a b+Just (2><3)+ [ -1.4802973661668753e-15, 0.9999999999999997, 1.999999999999997+ , 3.000000000000001, 1.6653345369377348e-16, 4.000000000000002 ]++>>> let Just x = it+>>> disp 5 x+2x3+-0.00000 1.00000 2.00000+ 3.00000 0.00000 4.00000++>>> a <> x+(2><3)+ [ 6.0, 1.0, 10.0+ , 15.0, 3.0, 26.0 ]++-}+linearSolve m b = A.mbLinearSolve m b++-- | return an orthonormal basis of the null space of a matrix. See also 'nullspaceSVD'.+nullspace m = nullspaceSVD (Left (1*eps)) m (rightSV m)++-- | return an orthonormal basis of the range space of a matrix. See also 'orthSVD'.+orth m = orthSVD (Left (1*eps)) m (leftSV m)+
+ src/Numeric/LinearAlgebra/Data.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeOperators #-}++--------------------------------------------------------------------------------+{- |+Module : Numeric.LinearAlgebra.Data+Copyright : (c) Alberto Ruiz 2015+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++This module provides functions for creation and manipulation of vectors and matrices, IO, and other utilities.++-}+--------------------------------------------------------------------------------++module Numeric.LinearAlgebra.Data(++ -- * Elements+ R,C,I,Z,type(./.),++ -- * Vector+ {- | 1D arrays are storable vectors directly reexported from the vector package.+ -}++ fromList, toList, (|>), vector, range, idxs,++ -- * Matrix++ {- | The main data type of hmatrix is a 2D dense array defined on top of+ a storable vector. The internal representation is suitable for direct+ interface with standard numeric libraries.+ -}++ (><), matrix, tr, tr',++ -- * Dimensions++ size, rows, cols,++ -- * Conversion from\/to lists++ fromLists, toLists,+ row, col,++ -- * Conversions vector\/matrix++ flatten, reshape, asRow, asColumn,+ fromRows, toRows, fromColumns, toColumns,++ -- * Indexing++ atIndex,+ Indexable(..),++ -- * Construction+ scalar, Konst(..), Build(..), assoc, accum, linspace, -- ones, zeros,++ -- * Diagonal+ ident, diag, diagl, diagRect, takeDiag,++ -- * Vector extraction+ subVector, takesV, vjoin,++ -- * Matrix extraction+ Extractor(..), (??),++ (?), (¿), fliprl, flipud,++ subMatrix, takeRows, dropRows, takeColumns, dropColumns,++ remap,++ -- * Block matrix+ fromBlocks, (|||), (===), diagBlock, repmat, toBlocks, toBlocksEvery,++ -- * Mapping functions+ conj, cmap, cmod,++ step, cond,++ -- * Find elements+ find, maxIndex, minIndex, maxElement, minElement,+ sortVector, sortIndex,++ -- * Sparse+ AssocMatrix, toDense,+ mkSparse, mkDiagR, mkDense,++ -- * IO+ disp,+ loadMatrix, loadMatrix', saveMatrix,+ latexFormat,+ dispf, disps, dispcf, format,+ dispDots, dispBlanks, dispShort,+-- * Element conversion+ Convert(..),+ roundVector,+ fromInt,toInt,fromZ,toZ,+ -- * Misc+ arctan2,+ separable,+ fromArray2D,+ module Data.Complex,+ Mod,+ Vector, Matrix, GMatrix, nRows, nCols++) where++import Internal.Vector+import Internal.Vectorized+import Internal.Matrix hiding (size)+import Internal.Element+import Internal.IO+import Internal.Numeric+import Internal.Container+import Internal.Util hiding ((&))+import Data.Complex+import Internal.Sparse+import Internal.Modular++
+ src/Numeric/LinearAlgebra/Devel.hs view
@@ -0,0 +1,68 @@+--------------------------------------------------------------------------------+{- |+Module : Numeric.HMatrix.Devel+Copyright : (c) Alberto Ruiz 2014+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++The library can be easily extended using the tools in this module.++-}+--------------------------------------------------------------------------------++module Numeric.LinearAlgebra.Devel(+ -- * FFI tools+ -- | See @examples/devel@ in the repository.++ createVector, createMatrix,+ TransArray(..),+ MatrixOrder(..), orderOf, cmat, fmat,+ matrixFromVector,+ unsafeFromForeignPtr,+ unsafeToForeignPtr,+ check, (//), (#|),+ at', atM', fi, ti,++ -- * ST+ -- | In-place manipulation inside the ST monad.+ -- See @examples/inplace.hs@ in the repository.++ -- ** Mutable Vectors+ STVector, newVector, thawVector, freezeVector, runSTVector,+ readVector, writeVector, modifyVector, liftSTVector,+ -- ** Mutable Matrices+ STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix,+ readMatrix, writeMatrix, modifyMatrix, liftSTMatrix,+ mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..),+ -- ** Unsafe functions+ newUndefinedVector,+ unsafeReadVector, unsafeWriteVector,+ unsafeThawVector, unsafeFreezeVector,+ newUndefinedMatrix,+ unsafeReadMatrix, unsafeWriteMatrix,+ unsafeThawMatrix, unsafeFreezeMatrix,++ -- * Special maps and zips+ mapVectorWithIndex, zipVector, zipVectorWith, unzipVector, unzipVectorWith,+ mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_,+ foldLoop, foldVector, foldVectorG, foldVectorWithIndex,+ mapMatrixWithIndex, mapMatrixWithIndexM, mapMatrixWithIndexM_,+ liftMatrix, liftMatrix2, liftMatrix2Auto,++ -- * Sparse representation+ CSR(..), fromCSR, mkCSR, impureCSR,+ GMatrix(..),++ -- * Misc+ toByteString, fromByteString, showInternal, reorderVector++) where++import Internal.Devel+import Internal.ST+import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Sparse+
+ src/Numeric/LinearAlgebra/HMatrix.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------------------+{- |+Module : Numeric.LinearAlgebra.HMatrix+Copyright : (c) Alberto Ruiz 2006-14+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++compatibility with previous version, to be removed++-}+--------------------------------------------------------------------------------++module Numeric.LinearAlgebra.HMatrix (+ module Numeric.LinearAlgebra,+ (¦),(——),ℝ,ℂ,(<·>),app,mul, cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH'+) where++import Numeric.LinearAlgebra+import Internal.Util+import Internal.Algorithms(cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH')+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++infixr 8 <·>+(<·>) :: Numeric t => Vector t -> Vector t -> t+(<·>) = dot++app :: Numeric t => Matrix t -> Vector t -> Vector t+app m v = m #> v++mul :: Numeric t => Matrix t -> Matrix t -> Matrix t+mul a b = a <> b+
+ src/Numeric/LinearAlgebra/Static.hs view
@@ -0,0 +1,912 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Module : Numeric.LinearAlgebra.Static+Copyright : (c) Alberto Ruiz 2014+License : BSD3+Stability : experimental++Experimental interface with statically checked dimensions.++See code examples at http://dis.um.es/~alberto/hmatrix/static.html.++-}++module Numeric.LinearAlgebra.Static(+ -- * Vector+ ℝ, R,+ vec2, vec3, vec4, (&), (#), split, headTail,+ vector,+ linspace, range, dim,+ -- * Matrix+ L, Sq, build,+ row, col, (|||),(===), splitRows, splitCols,+ unrow, uncol,+ tr,+ eye,+ diag,+ blockAt,+ matrix,+ -- * Complex+ ℂ, C, M, Her, her, 𝑖,+ toComplex,+ fromComplex,+ complex,+ real,+ imag,+ sqMagnitude,+ magnitude,+ -- * Products+ (<>),(#>),(<.>),+ -- * Linear Systems+ linSolve, (<\>),+ -- * Factorizations+ svd, withCompactSVD, svdTall, svdFlat, Eigen(..),+ withNullspace, withOrth, qr, chol,+ -- * Norms+ Normed(..),+ -- * Random arrays+ Seed, RandDist(..),+ randomVector, rand, randn, gaussianSample, uniformSample,+ -- * Misc+ mean, meanCov,+ Disp(..), Domain(..),+ withVector, withMatrix, exactLength, exactDims,+ toRows, toColumns, withRows, withColumns,+ Sized(..), Diag(..), Sym, sym, mTm, unSym, (<·>)+) where+++import GHC.TypeLits+import Numeric.LinearAlgebra hiding (+ (<>),(#>),(<.>),Konst(..),diag, disp,(===),(|||),+ row,col,vector,matrix,linspace,toRows,toColumns,+ (<\>),fromList,takeDiag,svd,eig,eigSH,+ eigenvalues,eigenvaluesSH,build,+ qr,size,dot,chol,range,R,C,sym,mTm,unSym,+ randomVector,rand,randn,gaussianSample,uniformSample,meanCov,+ toComplex, fromComplex, complex, real, magnitude+ )+import qualified Numeric.LinearAlgebra as LA+import qualified Numeric.LinearAlgebra.Devel as LA+import Data.Proxy(Proxy(..))+import Internal.Static+import Control.Arrow((***))+import Text.Printf+import Data.Type.Equality ((:~:)(Refl))+import qualified Data.Bifunctor as BF (first)+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++ud1 :: R n -> Vector ℝ+ud1 (R (Dim v)) = v+++infixl 4 &+(&) :: forall n . KnownNat n+ => R n -> ℝ -> R (n+1)+u & x = u # (konst x :: R 1)++infixl 4 #+(#) :: forall n m . (KnownNat n, KnownNat m)+ => R n -> R m -> R (n+m)+(R u) # (R v) = R (vconcat u v)++++vec2 :: ℝ -> ℝ -> R 2+vec2 a b = R (gvec2 a b)++vec3 :: ℝ -> ℝ -> ℝ -> R 3+vec3 a b c = R (gvec3 a b c)+++vec4 :: ℝ -> ℝ -> ℝ -> ℝ -> R 4+vec4 a b c d = R (gvec4 a b c d)++vector :: KnownNat n => [ℝ] -> R n+vector = fromList++matrix :: (KnownNat m, KnownNat n) => [ℝ] -> L m n+matrix = fromList++linspace :: forall n . KnownNat n => (ℝ,ℝ) -> R n+linspace (a,b) = v+ where+ v = mkR (LA.linspace (size v) (a,b))++range :: forall n . KnownNat n => R n+range = v+ where+ v = mkR (LA.linspace d (1,fromIntegral d))+ d = size v++dim :: forall n . KnownNat n => R n+dim = v+ where+ v = mkR (scalar (fromIntegral $ size v))++--------------------------------------------------------------------------------+++ud2 :: L m n -> Matrix ℝ+ud2 (L (Dim (Dim x))) = x+++--------------------------------------------------------------------------------++diag :: KnownNat n => R n -> Sq n+diag = diagR 0++eye :: KnownNat n => Sq n+eye = diag 1++--------------------------------------------------------------------------------++blockAt :: forall m n . (KnownNat m, KnownNat n) => ℝ -> Int -> Int -> Matrix Double -> L m n+blockAt x r c a = res+ where+ z = scalar x+ z1 = LA.konst x (r,c)+ z2 = LA.konst x (max 0 (m'-(ra+r)), max 0 (n'-(ca+c)))+ ra = min (rows a) . max 0 $ m'-r+ ca = min (cols a) . max 0 $ n'-c+ sa = subMatrix (0,0) (ra, ca) a+ (m',n') = size res+ res = mkL $ fromBlocks [[z1,z,z],[z,sa,z],[z,z,z2]]++--------------------------------------------------------------------------------+++row :: R n -> L 1 n+row = mkL . asRow . ud1++--col :: R n -> L n 1+col v = tr . row $ v++unrow :: L 1 n -> R n+unrow = mkR . head . LA.toRows . ud2++--uncol :: L n 1 -> R n+uncol v = unrow . tr $ v+++infixl 2 ===+(===) :: (KnownNat r1, KnownNat r2, KnownNat c) => L r1 c -> L r2 c -> L (r1+r2) c+a === b = mkL (extract a LA.=== extract b)+++infixl 3 |||+-- (|||) :: (KnownNat r, KnownNat c1, KnownNat c2) => L r c1 -> L r c2 -> L r (c1+c2)+a ||| b = tr (tr a === tr b)+++type Sq n = L n n+--type CSq n = CL n n+++type GL = forall n m . (KnownNat n, KnownNat m) => L m n+type GSq = forall n . KnownNat n => Sq n++isKonst :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ,(Int,Int))+isKonst s@(unwrap -> x)+ | singleM x = Just (x `atIndex` (0,0), (size s))+ | otherwise = Nothing+++isKonstC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ,(Int,Int))+isKonstC s@(unwrap -> x)+ | singleM x = Just (x `atIndex` (0,0), (size s))+ | otherwise = Nothing+++infixr 8 <>+(<>) :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => L m k -> L k n -> L m n+(<>) = mulR+++infixr 8 #>+(#>) :: (KnownNat m, KnownNat n) => L m n -> R n -> R m+(#>) = appR+++infixr 8 <·>+(<·>) :: KnownNat n => R n -> R n -> ℝ+(<·>) = dotR++infixr 8 <.>+(<.>) :: KnownNat n => R n -> R n -> ℝ+(<.>) = dotR++--------------------------------------------------------------------------------++class Diag m d | m -> d+ where+ takeDiag :: m -> d+++instance KnownNat n => Diag (L n n) (R n)+ where+ takeDiag x = mkR (LA.takeDiag (extract x))+++instance KnownNat n => Diag (M n n) (C n)+ where+ takeDiag x = mkC (LA.takeDiag (extract x))++--------------------------------------------------------------------------------+++toComplex :: KnownNat n => (R n, R n) -> C n+toComplex (r,i) = mkC $ LA.toComplex (ud1 r, ud1 i)++fromComplex :: KnownNat n => C n -> (R n, R n)+fromComplex (C (Dim v)) = let (r,i) = LA.fromComplex v in (mkR r, mkR i)++complex :: KnownNat n => R n -> C n+complex r = mkC $ LA.toComplex (ud1 r, LA.konst 0 (size r))++real :: KnownNat n => C n -> R n+real = fst . fromComplex++imag :: KnownNat n => C n -> R n +imag = snd . fromComplex++sqMagnitude :: KnownNat n => C n -> R n+sqMagnitude c = let (r,i) = fromComplex c in r**2 + i**2++magnitude :: KnownNat n => C n -> R n+magnitude = sqrt . sqMagnitude++--------------------------------------------------------------------------------++linSolve :: (KnownNat m, KnownNat n) => L m m -> L m n -> Maybe (L m n)+linSolve (extract -> a) (extract -> b) = fmap mkL (LA.linearSolve a b)++(<\>) :: (KnownNat m, KnownNat n, KnownNat r) => L m n -> L m r -> L n r+(extract -> a) <\> (extract -> b) = mkL (a LA.<\> b)++svd :: (KnownNat m, KnownNat n) => L m n -> (L m m, R n, L n n)+svd (extract -> m) = (mkL u, mkR s', mkL v)+ where+ (u,s,v) = LA.svd m+ s' = vjoin [s, z]+ z = LA.konst 0 (max 0 (cols m - LA.size s))+++svdTall :: (KnownNat m, KnownNat n, n <= m) => L m n -> (L m n, R n, L n n)+svdTall (extract -> m) = (mkL u, mkR s, mkL v)+ where+ (u,s,v) = LA.thinSVD m+++svdFlat :: (KnownNat m, KnownNat n, m <= n) => L m n -> (L m m, R m, L n m)+svdFlat (extract -> m) = (mkL u, mkR s, mkL v)+ where+ (u,s,v) = LA.thinSVD m++--------------------------------------------------------------------------------++class Eigen m l v | m -> l, m -> v+ where+ eigensystem :: m -> (l,v)+ eigenvalues :: m -> l++newtype Sym n = Sym (Sq n) deriving Show+++sym :: KnownNat n => Sq n -> Sym n+sym m = Sym $ (m + tr m)/2++mTm :: (KnownNat m, KnownNat n) => L m n -> Sym n+mTm x = Sym (tr x <> x)++unSym :: Sym n -> Sq n+unSym (Sym x) = x+++𝑖 :: Sized ℂ s c => s+𝑖 = konst iC++newtype Her n = Her (M n n)++her :: KnownNat n => M n n -> Her n+her m = Her $ (m + LA.tr m)/2+++instance (KnownNat n) => Disp (Sym n)+ where+ disp n (Sym x) = do+ let a = extract x+ let su = LA.dispf n a+ printf "Sym %d" (cols a) >> putStr (dropWhile (/='\n') $ su)++instance (KnownNat n) => Disp (Her n)+ where+ disp n (Her x) = do+ let a = extract x+ let su = LA.dispcf n a+ printf "Her %d" (cols a) >> putStr (dropWhile (/='\n') $ su)+++instance KnownNat n => Eigen (Sym n) (R n) (L n n)+ where+ eigenvalues (Sym (extract -> m)) = mkR . LA.eigenvaluesSH . LA.trustSym $ m+ eigensystem (Sym (extract -> m)) = (mkR l, mkL v)+ where+ (l,v) = LA.eigSH . LA.trustSym $ m++instance KnownNat n => Eigen (Sq n) (C n) (M n n)+ where+ eigenvalues (extract -> m) = mkC . LA.eigenvalues $ m+ eigensystem (extract -> m) = (mkC l, mkM v)+ where+ (l,v) = LA.eig m++chol :: KnownNat n => Sym n -> Sq n+chol (extract . unSym -> m) = mkL $ LA.chol $ LA.trustSym m++--------------------------------------------------------------------------------++withNullspace+ :: forall m n z . (KnownNat m, KnownNat n)+ => L m n+ -> (forall k . (KnownNat k) => L n k -> z)+ -> z+withNullspace (LA.nullspace . extract -> a) f =+ case someNatVal $ fromIntegral $ cols a of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy k)) -> f (mkL a :: L n k)++withOrth+ :: forall m n z . (KnownNat m, KnownNat n)+ => L m n+ -> (forall k. (KnownNat k) => L n k -> z)+ -> z+withOrth (LA.orth . extract -> a) f =+ case someNatVal $ fromIntegral $ cols a of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy k)) -> f (mkL a :: L n k)++withCompactSVD+ :: forall m n z . (KnownNat m, KnownNat n)+ => L m n+ -> (forall k . (KnownNat k) => (L m k, R k, L n k) -> z)+ -> z+withCompactSVD (LA.compactSVD . extract -> (u,s,v)) f =+ case someNatVal $ fromIntegral $ LA.size s of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy k)) -> f (mkL u :: L m k, mkR s :: R k, mkL v :: L n k)++--------------------------------------------------------------------------------++qr :: (KnownNat m, KnownNat n) => L m n -> (L m m, L m n)+qr (extract -> x) = (mkL q, mkL r)+ where+ (q,r) = LA.qr x++-- use qrRaw?++--------------------------------------------------------------------------------++split :: forall p n . (KnownNat p, KnownNat n, p<=n) => R n -> (R p, R (n-p))+split (extract -> v) = ( mkR (subVector 0 p' v) ,+ mkR (subVector p' (LA.size v - p') v) )+ where+ p' = fromIntegral . natVal $ (undefined :: Proxy p) :: Int+++headTail :: (KnownNat n, 1<=n) => R n -> (ℝ, R (n-1))+headTail = ((! 0) . extract *** id) . split+++splitRows :: forall p m n . (KnownNat p, KnownNat m, KnownNat n, p<=m) => L m n -> (L p n, L (m-p) n)+splitRows (extract -> x) = ( mkL (takeRows p' x) ,+ mkL (dropRows p' x) )+ where+ p' = fromIntegral . natVal $ (undefined :: Proxy p) :: Int++splitCols :: forall p m n. (KnownNat p, KnownNat m, KnownNat n, KnownNat (n-p), p<=n) => L m n -> (L m p, L m (n-p))+splitCols = (tr *** tr) . splitRows . tr+++toRows :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R n]+toRows (LA.toRows . extract -> vs) = map mkR vs++withRows+ :: forall n z . KnownNat n+ => [R n]+ -> (forall m . KnownNat m => L m n -> z)+ -> z+withRows (LA.fromRows . map extract -> m) f =+ case someNatVal $ fromIntegral $ LA.rows m of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy m)) -> f (mkL m :: L m n)++toColumns :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R m]+toColumns (LA.toColumns . extract -> vs) = map mkR vs++withColumns+ :: forall m z . KnownNat m+ => [R m]+ -> (forall n . KnownNat n => L m n -> z)+ -> z+withColumns (LA.fromColumns . map extract -> m) f =+ case someNatVal $ fromIntegral $ LA.cols m of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy n)) -> f (mkL m :: L m n)++++--------------------------------------------------------------------------------++build+ :: forall m n . (KnownNat n, KnownNat m)+ => (ℝ -> ℝ -> ℝ)+ -> L m n+build f = r+ where+ r = mkL $ LA.build (size r) f++--------------------------------------------------------------------------------++withVector+ :: forall z+ . Vector ℝ+ -> (forall n . (KnownNat n) => R n -> z)+ -> z+withVector v f =+ case someNatVal $ fromIntegral $ LA.size v of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy m)) -> f (mkR v :: R m)++-- | Useful for constraining two dependently typed vectors to match each+-- other in length when they are unknown at compile-time.+exactLength+ :: forall n m . (KnownNat n, KnownNat m)+ => R m+ -> Maybe (R n)+exactLength v = do+ Refl <- sameNat (Proxy :: Proxy n) (Proxy :: Proxy m)+ return $ mkR (unwrap v)++withMatrix+ :: forall z+ . Matrix ℝ+ -> (forall m n . (KnownNat m, KnownNat n) => L m n -> z)+ -> z+withMatrix a f =+ case someNatVal $ fromIntegral $ rows a of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy m)) ->+ case someNatVal $ fromIntegral $ cols a of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy n)) ->+ f (mkL a :: L m n)++-- | Useful for constraining two dependently typed matrices to match each+-- other in dimensions when they are unknown at compile-time.+exactDims+ :: forall n m j k . (KnownNat n, KnownNat m, KnownNat j, KnownNat k)+ => L m n+ -> Maybe (L j k)+exactDims m = do+ Refl <- sameNat (Proxy :: Proxy m) (Proxy :: Proxy j)+ Refl <- sameNat (Proxy :: Proxy n) (Proxy :: Proxy k)+ return $ mkL (unwrap m)++randomVector+ :: forall n . KnownNat n+ => Seed+ -> RandDist+ -> R n+randomVector s d = mkR (LA.randomVector s d+ (fromInteger (natVal (Proxy :: Proxy n)))+ )++rand+ :: forall m n . (KnownNat m, KnownNat n)+ => IO (L m n)+rand = mkL <$> LA.rand (fromInteger (natVal (Proxy :: Proxy m)))+ (fromInteger (natVal (Proxy :: Proxy n)))++randn+ :: forall m n . (KnownNat m, KnownNat n)+ => IO (L m n)+randn = mkL <$> LA.randn (fromInteger (natVal (Proxy :: Proxy m)))+ (fromInteger (natVal (Proxy :: Proxy n)))++gaussianSample+ :: forall m n . (KnownNat m, KnownNat n)+ => Seed+ -> R n+ -> Sym n+ -> L m n+gaussianSample s (extract -> mu) (Sym (extract -> sigma)) =+ mkL $ LA.gaussianSample s (fromInteger (natVal (Proxy :: Proxy m)))+ mu (LA.trustSym sigma)++uniformSample+ :: forall m n . (KnownNat m, KnownNat n)+ => Seed+ -> R n -- ^ minimums of each row+ -> R n -- ^ maximums of each row+ -> L m n+uniformSample s (extract -> mins) (extract -> maxs) =+ mkL $ LA.uniformSample s (fromInteger (natVal (Proxy :: Proxy m)))+ (zip (LA.toList mins) (LA.toList maxs))++meanCov+ :: forall m n . (KnownNat m, KnownNat n, 1 <= m)+ => L m n+ -> (R n, Sym n)+meanCov (extract -> vs) = mkR *** (Sym . mkL . LA.unSym) $ LA.meanCov vs++--------------------------------------------------------------------------------++class Domain field vec mat | mat -> vec field, vec -> mat field, field -> mat vec+ where+ mul :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => mat m k -> mat k n -> mat m n+ app :: forall m n . (KnownNat m, KnownNat n) => mat m n -> vec n -> vec m+ dot :: forall n . (KnownNat n) => vec n -> vec n -> field+ cross :: vec 3 -> vec 3 -> vec 3+ diagR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => field -> vec k -> mat m n+ dvmap :: forall n. KnownNat n => (field -> field) -> vec n -> vec n+ dmmap :: forall n m. (KnownNat m, KnownNat n) => (field -> field) -> mat n m -> mat n m+ outer :: forall n m. (KnownNat m, KnownNat n) => vec n -> vec m -> mat n m+ zipWithVector :: forall n. KnownNat n => (field -> field -> field) -> vec n -> vec n -> vec n+ det :: forall n. KnownNat n => mat n n -> field+ invlndet :: forall n. KnownNat n => mat n n -> (mat n n, (field, field))+ expm :: forall n. KnownNat n => mat n n -> mat n n+ sqrtm :: forall n. KnownNat n => mat n n -> mat n n+ inv :: forall n. KnownNat n => mat n n -> mat n n+++instance Domain ℝ R L+ where+ mul = mulR+ app = appR+ dot = dotR+ cross = crossR+ diagR = diagRectR+ dvmap = mapR+ dmmap = mapL+ outer = outerR+ zipWithVector = zipWithR+ det = detL+ invlndet = invlndetL+ expm = expmL+ sqrtm = sqrtmL+ inv = invL++instance Domain ℂ C M+ where+ mul = mulC+ app = appC+ dot = dotC+ cross = crossC+ diagR = diagRectC+ dvmap = mapC+ dmmap = mapM'+ outer = outerC+ zipWithVector = zipWithC+ det = detM+ invlndet = invlndetM+ expm = expmM+ sqrtm = sqrtmM+ inv = invM++--------------------------------------------------------------------------------++mulR :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => L m k -> L k n -> L m n++mulR (isKonst -> Just (a,(_,k))) (isKonst -> Just (b,_)) = konst (a * b * fromIntegral k)++mulR (isDiag -> Just (0,a,_)) (isDiag -> Just (0,b,_)) = diagR 0 (mkR v :: R k)+ where+ v = a' * b'+ n = min (LA.size a) (LA.size b)+ a' = subVector 0 n a+ b' = subVector 0 n b++-- mulR (isDiag -> Just (0,a,_)) (extract -> b) = mkL (asColumn a * takeRows (LA.size a) b)++-- mulR (extract -> a) (isDiag -> Just (0,b,_)) = mkL (takeColumns (LA.size b) a * asRow b)++mulR a b = mkL (extract a LA.<> extract b)+++appR :: (KnownNat m, KnownNat n) => L m n -> R n -> R m+appR (isDiag -> Just (0, w, _)) v = mkR (w * subVector 0 (LA.size w) (extract v))+appR m v = mkR (extract m LA.#> extract v)+++dotR :: KnownNat n => R n -> R n -> ℝ+dotR (extract -> u) (extract -> v) = LA.dot u v+++crossR :: R 3 -> R 3 -> R 3+crossR (extract -> x) (extract -> y) = vec3 z1 z2 z3+ where+ z1 = x!1*y!2-x!2*y!1+ z2 = x!2*y!0-x!0*y!2+ z3 = x!0*y!1-x!1*y!0++outerR :: (KnownNat m, KnownNat n) => R n -> R m -> L n m+outerR (extract -> x) (extract -> y) = mkL (LA.outer x y)++mapR :: KnownNat n => (ℝ -> ℝ) -> R n -> R n+mapR f (unwrap -> v) = mkR (LA.cmap f v)++zipWithR :: KnownNat n => (ℝ -> ℝ -> ℝ) -> R n -> R n -> R n+zipWithR f (extract -> x) (extract -> y) = mkR (LA.zipVectorWith f x y)++mapL :: (KnownNat n, KnownNat m) => (ℝ -> ℝ) -> L n m -> L n m+mapL f = overMatL' (LA.cmap f)++detL :: KnownNat n => Sq n -> ℝ+detL = LA.det . unwrap++invlndetL :: KnownNat n => Sq n -> (L n n, (ℝ, ℝ))+invlndetL = BF.first mkL . LA.invlndet . unwrap++expmL :: KnownNat n => Sq n -> Sq n+expmL = overMatL' LA.expm++sqrtmL :: KnownNat n => Sq n -> Sq n+sqrtmL = overMatL' LA.sqrtm++invL :: KnownNat n => Sq n -> Sq n+invL = overMatL' LA.inv++--------------------------------------------------------------------------------++mulC :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => M m k -> M k n -> M m n++mulC (isKonstC -> Just (a,(_,k))) (isKonstC -> Just (b,_)) = konst (a * b * fromIntegral k)++mulC (isDiagC -> Just (0,a,_)) (isDiagC -> Just (0,b,_)) = diagR 0 (mkC v :: C k)+ where+ v = a' * b'+ n = min (LA.size a) (LA.size b)+ a' = subVector 0 n a+ b' = subVector 0 n b++-- mulC (isDiagC -> Just (0,a,_)) (extract -> b) = mkM (asColumn a * takeRows (LA.size a) b)++-- mulC (extract -> a) (isDiagC -> Just (0,b,_)) = mkM (takeColumns (LA.size b) a * asRow b)++mulC a b = mkM (extract a LA.<> extract b)+++appC :: (KnownNat m, KnownNat n) => M m n -> C n -> C m+appC (isDiagC -> Just (0, w, _)) v = mkC (w * subVector 0 (LA.size w) (extract v))+appC m v = mkC (extract m LA.#> extract v)+++dotC :: KnownNat n => C n -> C n -> ℂ+dotC (extract -> u) (extract -> v) = LA.dot u v+++crossC :: C 3 -> C 3 -> C 3+crossC (extract -> x) (extract -> y) = mkC (LA.fromList [z1, z2, z3])+ where+ z1 = x!1*y!2-x!2*y!1+ z2 = x!2*y!0-x!0*y!2+ z3 = x!0*y!1-x!1*y!0++outerC :: (KnownNat m, KnownNat n) => C n -> C m -> M n m+outerC (extract -> x) (extract -> y) = mkM (LA.outer x y)++mapC :: KnownNat n => (ℂ -> ℂ) -> C n -> C n+mapC f (unwrap -> v) = mkC (LA.cmap f v)++zipWithC :: KnownNat n => (ℂ -> ℂ -> ℂ) -> C n -> C n -> C n+zipWithC f (extract -> x) (extract -> y) = mkC (LA.zipVectorWith f x y)++mapM' :: (KnownNat n, KnownNat m) => (ℂ -> ℂ) -> M n m -> M n m+mapM' f = overMatM' (LA.cmap f)++detM :: KnownNat n => M n n -> ℂ+detM = LA.det . unwrap++invlndetM :: KnownNat n => M n n -> (M n n, (ℂ, ℂ))+invlndetM = BF.first mkM . LA.invlndet . unwrap++expmM :: KnownNat n => M n n -> M n n+expmM = overMatM' LA.expm++sqrtmM :: KnownNat n => M n n -> M n n+sqrtmM = overMatM' LA.sqrtm++invM :: KnownNat n => M n n -> M n n+invM = overMatM' LA.inv++--------------------------------------------------------------------------------++diagRectR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => ℝ -> R k -> L m n+diagRectR x v+ | m' == 1 = mkL (LA.diagRect x ev m' n')+ | m'*n' > 0 = r+ | otherwise = matrix []+ where+ r = mkL (asRow (vjoin [scalar x, ev, zeros]))+ ev = extract v+ zeros = LA.konst x (max 0 ((min m' n') - LA.size ev))+ (m',n') = size r+++diagRectC :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => ℂ -> C k -> M m n+diagRectC x v+ | m' == 1 = mkM (LA.diagRect x ev m' n')+ | m'*n' > 0 = r+ | otherwise = fromList []+ where+ r = mkM (asRow (vjoin [scalar x, ev, zeros]))+ ev = extract v+ zeros = LA.konst x (max 0 ((min m' n') - LA.size ev))+ (m',n') = size r++--------------------------------------------------------------------------------++mean :: (KnownNat n, 1<=n) => R n -> ℝ+mean v = v <·> (1/dim)++test :: (Bool, IO ())+test = (ok,info)+ where+ ok = extract (eye :: Sq 5) == ident 5+ && (unwrap .unSym) (mTm sm :: Sym 3) == tr ((3><3)[1..]) LA.<> (3><3)[1..]+ && unwrap (tm :: L 3 5) == LA.matrix 5 [1..15]+ && thingS == thingD+ && precS == precD+ && withVector (LA.vector [1..15]) sumV == sumElements (LA.fromList [1..15])++ info = do+ print $ u+ print $ v+ print (eye :: Sq 3)+ print $ ((u & 5) + 1) <·> v+ print (tm :: L 2 5)+ print (tm <> sm :: L 2 3)+ print thingS+ print thingD+ print precS+ print precD+ print $ withVector (LA.vector [1..15]) sumV+ splittest++ sumV w = w <·> konst 1++ u = vec2 3 5++ 𝕧 x = vector [x] :: R 1++ v = 𝕧 2 & 4 & 7++ tm :: GL+ tm = lmat 0 [1..]++ lmat :: forall m n . (KnownNat m, KnownNat n) => ℝ -> [ℝ] -> L m n+ lmat z xs = r+ where+ r = mkL . reshape n' . LA.fromList . take (m'*n') $ xs ++ repeat z+ (m',n') = size r++ sm :: GSq+ sm = lmat 0 [1..]++ thingS = (u & 1) <·> tr q #> q #> v+ where+ q = tm :: L 10 3++ thingD = vjoin [ud1 u, 1] LA.<.> tr m LA.#> m LA.#> ud1 v+ where+ m = LA.matrix 3 [1..30]++ precS = (1::Double) + (2::Double) * ((1 :: R 3) * (u & 6)) <·> konst 2 #> v+ precD = 1 + 2 * vjoin[ud1 u, 6] LA.<.> LA.konst 2 (LA.size (ud1 u) +1, LA.size (ud1 v)) LA.#> ud1 v+++splittest+ = do+ let v = range :: R 7+ a = snd (split v) :: R 4+ print $ a+ print $ snd . headTail . snd . headTail $ v+ print $ first (vec3 1 2 3)+ print $ second (vec3 1 2 3)+ print $ third (vec3 1 2 3)+ print $ (snd $ splitRows eye :: L 4 6)+ where+ first v = fst . headTail $ v+ second v = first . snd . headTail $ v+ third v = first . snd . headTail . snd . headTail $ v+++instance (KnownNat n', KnownNat m') => Testable (L n' m')+ where+ checkT _ = test++--------------------------------------------------------------------------------++instance KnownNat n => Normed (R n)+ where+ norm_0 v = norm_0 (extract v)+ norm_1 v = norm_1 (extract v)+ norm_2 v = norm_2 (extract v)+ norm_Inf v = norm_Inf (extract v)++instance (KnownNat m, KnownNat n) => Normed (L m n)+ where+ norm_0 m = norm_0 (extract m)+ norm_1 m = norm_1 (extract m)+ norm_2 m = norm_2 (extract m)+ norm_Inf m = norm_Inf (extract m)++mkSym f = Sym . f . unSym+mkSym2 f x y = Sym (f (unSym x) (unSym y))++instance KnownNat n => Num (Sym n)+ where+ (+) = mkSym2 (+)+ (*) = mkSym2 (*)+ (-) = mkSym2 (-)+ abs = mkSym abs+ signum = mkSym signum+ negate = mkSym negate+ fromInteger = Sym . fromInteger++instance KnownNat n => Fractional (Sym n)+ where+ fromRational = Sym . fromRational+ (/) = mkSym2 (/)++instance KnownNat n => Floating (Sym n)+ where+ sin = mkSym sin+ cos = mkSym cos+ tan = mkSym tan+ asin = mkSym asin+ acos = mkSym acos+ atan = mkSym atan+ sinh = mkSym sinh+ cosh = mkSym cosh+ tanh = mkSym tanh+ asinh = mkSym asinh+ acosh = mkSym acosh+ atanh = mkSym atanh+ exp = mkSym exp+ log = mkSym log+ sqrt = mkSym sqrt+ (**) = mkSym2 (**)+ pi = Sym pi++instance KnownNat n => Additive (Sym n) where+ add = (+)++instance KnownNat n => Transposable (Sym n) (Sym n) where+ tr = id+ tr' = id++instance KnownNat n => Transposable (Her n) (Her n) where+ tr = id+ tr' (Her m) = Her (tr' m)
+ src/Numeric/Matrix.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.Matrix+-- Copyright : (c) Alberto Ruiz 2014+-- License : BSD3+--+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Provides instances of standard classes 'Show', 'Read', 'Eq',+-- 'Num', 'Fractional', and 'Floating' for 'Matrix'.+--+-- In arithmetic operations one-component+-- vectors and matrices automatically expand to match the dimensions of the other operand.++-----------------------------------------------------------------------------++module Numeric.Matrix (+ ) where++-------------------------------------------------------------------++import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Numeric+import qualified Data.Monoid as M+import Data.List(partition)+import qualified Data.Foldable as F+import qualified Data.Semigroup as S+import Internal.Chain+import Foreign.Storable(Storable)+++-------------------------------------------------------------------++instance Container Matrix a => Eq (Matrix a) where+ (==) = equal++instance (Container Matrix a, Num a, Num (Vector a)) => Num (Matrix a) where+ (+) = liftMatrix2Auto (+)+ (-) = liftMatrix2Auto (-)+ negate = liftMatrix negate+ (*) = liftMatrix2Auto (*)+ signum = liftMatrix signum+ abs = liftMatrix abs+ fromInteger = (1><1) . return . fromInteger++---------------------------------------------------++instance (Container Vector a, Fractional a, Fractional (Vector a), Num (Matrix a)) => Fractional (Matrix a) where+ fromRational n = (1><1) [fromRational n]+ (/) = liftMatrix2Auto (/)++---------------------------------------------------------++instance (Floating a, Container Vector a, Floating (Vector a), Fractional (Matrix a)) => Floating (Matrix a) where+ sin = liftMatrix sin+ cos = liftMatrix cos+ tan = liftMatrix tan+ asin = liftMatrix asin+ acos = liftMatrix acos+ atan = liftMatrix atan+ sinh = liftMatrix sinh+ cosh = liftMatrix cosh+ tanh = liftMatrix tanh+ asinh = liftMatrix asinh+ acosh = liftMatrix acosh+ atanh = liftMatrix atanh+ exp = liftMatrix exp+ log = liftMatrix log+ (**) = liftMatrix2Auto (**)+ sqrt = liftMatrix sqrt+ pi = (1><1) [pi]++--------------------------------------------------------------------------------++isScalar :: Matrix t -> Bool+isScalar m = rows m == 1 && cols m == 1++adaptScalarM :: (Foreign.Storable.Storable t1, Foreign.Storable.Storable t2)+ => (t1 -> Matrix t2 -> t)+ -> (Matrix t1 -> Matrix t2 -> t)+ -> (Matrix t1 -> t2 -> t)+ -> Matrix t1+ -> Matrix t2+ -> t+adaptScalarM f1 f2 f3 x y+ | isScalar x = f1 (x @@>(0,0) ) y+ | isScalar y = f3 x (y @@>(0,0) )+ | otherwise = f2 x y++instance (Container Vector t, Eq t, Num (Vector t), Product t) => S.Semigroup (Matrix t)+ where+ (<>) = mappend+ sconcat = mconcat . F.toList++instance (Container Vector t, Eq t, Num (Vector t), Product t) => M.Monoid (Matrix t)+ where+ mempty = 1+ mappend = adaptScalarM scale mXm (flip scale)++ mconcat xs = work (partition isScalar xs)+ where+ work (ss,[]) = product ss+ work (ss,ms) = scl (product ss) (optimiseMult ms)+ scl x m+ | isScalar x && x00 == 1 = m+ | otherwise = scale x00 m+ where+ x00 = x @@> (0,0)
+ src/Numeric/Vector.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.Vector+-- Copyright : (c) Alberto Ruiz 2011+-- License : BSD3+--+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Provides instances of standard classes 'Show', 'Read', 'Eq',+-- 'Num', 'Fractional', and 'Floating' for 'Vector'.+--+-----------------------------------------------------------------------------++module Numeric.Vector () where++import Internal.Vectorized+import Internal.Vector+import Internal.Numeric+import Internal.Conversion+import Foreign.Storable(Storable)++-------------------------------------------------------------------++adaptScalar :: (Foreign.Storable.Storable t1, Foreign.Storable.Storable t2)+ => (t1 -> Vector t2 -> t)+ -> (Vector t1 -> Vector t2 -> t)+ -> (Vector t1 -> t2 -> t)+ -> Vector t1+ -> Vector t2+ -> t+adaptScalar f1 f2 f3 x y+ | dim x == 1 = f1 (x@>0) y+ | dim y == 1 = f3 x (y@>0)+ | otherwise = f2 x y++------------------------------------------------------------------++instance Num (Vector I) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapI Sign+ abs = vectorMapI Abs+ fromInteger = fromList . return . fromInteger++instance Num (Vector Z) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapL Sign+ abs = vectorMapL Abs+ fromInteger = fromList . return . fromInteger++instance Num (Vector Float) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapF Sign+ abs = vectorMapF Abs+ fromInteger = fromList . return . fromInteger++instance Num (Vector Double) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapR Sign+ abs = vectorMapR Abs+ fromInteger = fromList . return . fromInteger++instance Num (Vector (Complex Double)) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapC Sign+ abs = vectorMapC Abs+ fromInteger = fromList . return . fromInteger++instance Num (Vector (Complex Float)) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapQ Sign+ abs = vectorMapQ Abs+ fromInteger = fromList . return . fromInteger++---------------------------------------------------++instance (Container Vector a, Num (Vector a), Fractional a) => Fractional (Vector a) where+ fromRational n = fromList [fromRational n]+ (/) = adaptScalar f divide g where+ r `f` v = scaleRecip r v+ v `g` r = scale (recip r) v++-------------------------------------------------------++instance Floating (Vector Float) where+ sin = vectorMapF Sin+ cos = vectorMapF Cos+ tan = vectorMapF Tan+ asin = vectorMapF ASin+ acos = vectorMapF ACos+ atan = vectorMapF ATan+ sinh = vectorMapF Sinh+ cosh = vectorMapF Cosh+ tanh = vectorMapF Tanh+ asinh = vectorMapF ASinh+ acosh = vectorMapF ACosh+ atanh = vectorMapF ATanh+ exp = vectorMapF Exp+ log = vectorMapF Log+ sqrt = vectorMapF Sqrt+ (**) = adaptScalar (vectorMapValF PowSV) (vectorZipF Pow) (flip (vectorMapValF PowVS))+ pi = fromList [pi]++-------------------------------------------------------------++instance Floating (Vector Double) where+ sin = vectorMapR Sin+ cos = vectorMapR Cos+ tan = vectorMapR Tan+ asin = vectorMapR ASin+ acos = vectorMapR ACos+ atan = vectorMapR ATan+ sinh = vectorMapR Sinh+ cosh = vectorMapR Cosh+ tanh = vectorMapR Tanh+ asinh = vectorMapR ASinh+ acosh = vectorMapR ACosh+ atanh = vectorMapR ATanh+ exp = vectorMapR Exp+ log = vectorMapR Log+ sqrt = vectorMapR Sqrt+ (**) = adaptScalar (vectorMapValR PowSV) (vectorZipR Pow) (flip (vectorMapValR PowVS))+ pi = fromList [pi]++-------------------------------------------------------------++instance Floating (Vector (Complex Double)) where+ sin = vectorMapC Sin+ cos = vectorMapC Cos+ tan = vectorMapC Tan+ asin = vectorMapC ASin+ acos = vectorMapC ACos+ atan = vectorMapC ATan+ sinh = vectorMapC Sinh+ cosh = vectorMapC Cosh+ tanh = vectorMapC Tanh+ asinh = vectorMapC ASinh+ acosh = vectorMapC ACosh+ atanh = vectorMapC ATanh+ exp = vectorMapC Exp+ log = vectorMapC Log+ sqrt = vectorMapC Sqrt+ (**) = adaptScalar (vectorMapValC PowSV) (vectorZipC Pow) (flip (vectorMapValC PowVS))+ pi = fromList [pi]++-----------------------------------------------------------++instance Floating (Vector (Complex Float)) where+ sin = vectorMapQ Sin+ cos = vectorMapQ Cos+ tan = vectorMapQ Tan+ asin = vectorMapQ ASin+ acos = vectorMapQ ACos+ atan = vectorMapQ ATan+ sinh = vectorMapQ Sinh+ cosh = vectorMapQ Cosh+ tanh = vectorMapQ Tanh+ asinh = vectorMapQ ASinh+ acosh = vectorMapQ ACosh+ atanh = vectorMapQ ATanh+ exp = vectorMapQ Exp+ log = vectorMapQ Log+ sqrt = vectorMapQ Sqrt+ (**) = adaptScalar (vectorMapValQ PowSV) (vectorZipQ Pow) (flip (vectorMapValQ PowVS))+ pi = fromList [pi]