summaryrefslogtreecommitdiff
path: root/lib/Numeric/LinearAlgebra
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Numeric/LinearAlgebra')
-rw-r--r--lib/Numeric/LinearAlgebra/LAPACK.hs240
-rw-r--r--lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c14
-rw-r--r--lib/Numeric/LinearAlgebra/Linear.hs8
3 files changed, 104 insertions, 158 deletions
diff --git a/lib/Numeric/LinearAlgebra/LAPACK.hs b/lib/Numeric/LinearAlgebra/LAPACK.hs
index 628d4f8..315be17 100644
--- a/lib/Numeric/LinearAlgebra/LAPACK.hs
+++ b/lib/Numeric/LinearAlgebra/LAPACK.hs
@@ -1,4 +1,4 @@
1{-# OPTIONS_GHC -fglasgow-exts #-} 1{-# OPTIONS_GHC #-}
2----------------------------------------------------------------------------- 2-----------------------------------------------------------------------------
3-- | 3-- |
4-- Module : Numeric.LinearAlgebra.LAPACK 4-- Module : Numeric.LinearAlgebra.LAPACK
@@ -36,54 +36,52 @@ import Foreign
36 36
37----------------------------------------------------------------------------- 37-----------------------------------------------------------------------------
38foreign import ccall "LAPACK/lapack-aux.h svd_l_R" dgesvd :: TMMVM 38foreign import ccall "LAPACK/lapack-aux.h svd_l_R" dgesvd :: TMMVM
39foreign import ccall "LAPACK/lapack-aux.h svd_l_C" zgesvd :: TCMCMVCM
40foreign import ccall "LAPACK/lapack-aux.h svd_l_Rdd" dgesdd :: TMMVM
39 41
40-- | Wrapper for LAPACK's /dgesvd/, which computes the full svd decomposition of a real matrix. 42-- | Wrapper for LAPACK's /dgesvd/, which computes the full svd decomposition of a real matrix.
41-- 43--
42-- @(u,s,v)=full svdR m@ so that @m=u \<\> s \<\> 'trans' v@. 44-- @(u,s,v)=full svdR m@ so that @m=u \<\> s \<\> 'trans' v@.
43svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) 45svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)
44svdR x = unsafePerformIO $ do 46svdR = svdAux dgesvd "svdR" . fmat
45 u <- createMatrix ColumnMajor r r
46 s <- createVector (min r c)
47 v <- createMatrix ColumnMajor c c
48 dgesvd // mat fdat x // mat dat u // vec s // mat dat v // check "svdR" [fdat x]
49 return (u,s,trans v)
50 where r = rows x
51 c = cols x
52-----------------------------------------------------------------------------
53foreign import ccall "LAPACK/lapack-aux.h svd_l_Rdd" dgesdd :: TMMVM
54 47
55-- | Wrapper for LAPACK's /dgesvd/, which computes the full svd decomposition of a real matrix. 48-- | Wrapper for LAPACK's /dgesvd/, which computes the full svd decomposition of a real matrix.
56-- 49--
57-- @(u,s,v)=full svdRdd m@ so that @m=u \<\> s \<\> 'trans' v@. 50-- @(u,s,v)=full svdRdd m@ so that @m=u \<\> s \<\> 'trans' v@.
58svdRdd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) 51svdRdd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)
59svdRdd x = unsafePerformIO $ do 52svdRdd = svdAux dgesdd "svdRdd" . fmat
60 u <- createMatrix ColumnMajor r r
61 s <- createVector (min r c)
62 v <- createMatrix ColumnMajor c c
63 dgesdd // mat fdat x // mat dat u // vec s // mat dat v // check "svdRdd" [fdat x]
64 return (u,s,trans v)
65 where r = rows x
66 c = cols x
67
68-----------------------------------------------------------------------------
69foreign import ccall "LAPACK/lapack-aux.h svd_l_C" zgesvd :: TCMCMVCM
70 53
71-- | Wrapper for LAPACK's /zgesvd/, which computes the full svd decomposition of a complex matrix. 54-- | Wrapper for LAPACK's /zgesvd/, which computes the full svd decomposition of a complex matrix.
72-- 55--
73-- @(u,s,v)=full svdC m@ so that @m=u \<\> comp s \<\> 'trans' v@. 56-- @(u,s,v)=full svdC m@ so that @m=u \<\> comp s \<\> 'trans' v@.
74svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) 57svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))
75svdC x = unsafePerformIO $ do 58svdC = svdAux zgesvd "svdC" . fmat
59
60svdAux f st x = unsafePerformIO $ do
76 u <- createMatrix ColumnMajor r r 61 u <- createMatrix ColumnMajor r r
77 s <- createVector (min r c) 62 s <- createVector (min r c)
78 v <- createMatrix ColumnMajor c c 63 v <- createMatrix ColumnMajor c c
79 zgesvd // mat fdat x // mat dat u // vec s // mat dat v // check "svdC" [fdat x] 64 f // matf x // matf u // vec s // matf v // check st [fdat x]
80 return (u,s,trans v) 65 return (u,s,trans v)
81 where r = rows x 66 where r = rows x
82 c = cols x 67 c = cols x
83 68
84
85----------------------------------------------------------------------------- 69-----------------------------------------------------------------------------
70eigAux f st m
71 | r == 1 = (fromList [flatten m `at` 0], singleton 1)
72 | otherwise = unsafePerformIO $ do
73 l <- createVector r
74 v <- createMatrix ColumnMajor r r
75 dummy <- createMatrix ColumnMajor 1 1
76 f // matf m // matf dummy // vec l // matf v // check st [fdat m]
77 return (l,v)
78 where r = rows m
79
80
86foreign import ccall "LAPACK/lapack-aux.h eig_l_C" zgeev :: TCMCMCVCM 81foreign import ccall "LAPACK/lapack-aux.h eig_l_C" zgeev :: TCMCMCVCM
82foreign import ccall "LAPACK/lapack-aux.h eig_l_R" dgeev :: TMMCVM
83foreign import ccall "LAPACK/lapack-aux.h eig_l_S" dsyev :: TMVM
84foreign import ccall "LAPACK/lapack-aux.h eig_l_H" zheev :: TCMVCM
87 85
88-- | Wrapper for LAPACK's /zgeev/, which computes the eigenvalues and right eigenvectors of a general complex matrix: 86-- | Wrapper for LAPACK's /zgeev/, which computes the eigenvalues and right eigenvectors of a general complex matrix:
89-- 87--
@@ -92,18 +90,9 @@ foreign import ccall "LAPACK/lapack-aux.h eig_l_C" zgeev :: TCMCMCVCM
92-- The eigenvectors are the columns of v. 90-- The eigenvectors are the columns of v.
93-- The eigenvalues are not sorted. 91-- The eigenvalues are not sorted.
94eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double)) 92eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double))
95eigC m 93eigC = eigAux zgeev "eigC" . fmat
96 | r == 1 = (fromList [cdat m `at` 0], singleton 1)
97 | otherwise = unsafePerformIO $ do
98 l <- createVector r
99 v <- createMatrix ColumnMajor r r
100 dummy <- createMatrix ColumnMajor 1 1
101 zgeev // mat fdat m // mat dat dummy // vec l // mat dat v // check "eigC" [fdat m]
102 return (l,v)
103 where r = rows m
104 94
105----------------------------------------------------------------------------- 95-----------------------------------------------------------------------------
106foreign import ccall "LAPACK/lapack-aux.h eig_l_R" dgeev :: TMMCVM
107 96
108-- | Wrapper for LAPACK's /dgeev/, which computes the eigenvalues and right eigenvectors of a general real matrix: 97-- | Wrapper for LAPACK's /dgeev/, which computes the eigenvalues and right eigenvectors of a general real matrix:
109-- 98--
@@ -113,7 +102,7 @@ foreign import ccall "LAPACK/lapack-aux.h eig_l_R" dgeev :: TMMCVM
113-- The eigenvalues are not sorted. 102-- The eigenvalues are not sorted.
114eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double)) 103eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double))
115eigR m = (s', v'') 104eigR m = (s', v'')
116 where (s,v) = eigRaux m 105 where (s,v) = eigRaux (fmat m)
117 s' = toComplex (subVector 0 r (asReal s), subVector r r (asReal s)) 106 s' = toComplex (subVector 0 r (asReal s), subVector r r (asReal s))
118 v' = toRows $ trans v 107 v' = toRows $ trans v
119 v'' = fromColumns $ fixeig (toList s') v' 108 v'' = fromColumns $ fixeig (toList s') v'
@@ -121,12 +110,12 @@ eigR m = (s', v'')
121 110
122eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double) 111eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double)
123eigRaux m 112eigRaux m
124 | r == 1 = (fromList [(cdat m `at` 0):+0], singleton 1) 113 | r == 1 = (fromList [(flatten m `at` 0):+0], singleton 1)
125 | otherwise = unsafePerformIO $ do 114 | otherwise = unsafePerformIO $ do
126 l <- createVector r 115 l <- createVector r
127 v <- createMatrix ColumnMajor r r 116 v <- createMatrix ColumnMajor r r
128 dummy <- createMatrix ColumnMajor 1 1 117 dummy <- createMatrix ColumnMajor 1 1
129 dgeev // mat fdat m // mat dat dummy // vec l // mat dat v // check "eigR" [fdat m] 118 dgeev // matf m // matf dummy // vec l // matf v // check "eigR" [fdat m]
130 return (l,v) 119 return (l,v)
131 where r = rows m 120 where r = rows m
132 121
@@ -138,7 +127,6 @@ fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs)
138 where scale = vectorMapValR Scale 127 where scale = vectorMapValR Scale
139 128
140----------------------------------------------------------------------------- 129-----------------------------------------------------------------------------
141foreign import ccall "LAPACK/lapack-aux.h eig_l_S" dsyev :: TMVM
142 130
143-- | Wrapper for LAPACK's /dsyev/, which computes the eigenvalues and right eigenvectors of a symmetric real matrix: 131-- | Wrapper for LAPACK's /dsyev/, which computes the eigenvalues and right eigenvectors of a symmetric real matrix:
144-- 132--
@@ -148,20 +136,19 @@ foreign import ccall "LAPACK/lapack-aux.h eig_l_S" dsyev :: TMVM
148-- The eigenvalues are sorted in descending order (use eigS' for ascending order). 136-- The eigenvalues are sorted in descending order (use eigS' for ascending order).
149eigS :: Matrix Double -> (Vector Double, Matrix Double) 137eigS :: Matrix Double -> (Vector Double, Matrix Double)
150eigS m = (s', fliprl v) 138eigS m = (s', fliprl v)
151 where (s,v) = eigS' m 139 where (s,v) = eigS' (fmat m)
152 s' = fromList . reverse . toList $ s 140 s' = fromList . reverse . toList $ s
153 141
154eigS' m 142eigS' m
155 | r == 1 = (fromList [cdat m `at` 0], singleton 1) 143 | r == 1 = (fromList [flatten m `at` 0], singleton 1)
156 | otherwise = unsafePerformIO $ do 144 | otherwise = unsafePerformIO $ do
157 l <- createVector r 145 l <- createVector r
158 v <- createMatrix ColumnMajor r r 146 v <- createMatrix ColumnMajor r r
159 dsyev // mat fdat m // vec l // mat dat v // check "eigS" [fdat m] 147 dsyev // matf m // vec l // matf v // check "eigS" [fdat m]
160 return (l,v) 148 return (l,v)
161 where r = rows m 149 where r = rows m
162 150
163----------------------------------------------------------------------------- 151-----------------------------------------------------------------------------
164foreign import ccall "LAPACK/lapack-aux.h eig_l_H" zheev :: TCMVCM
165 152
166-- | Wrapper for LAPACK's /zheev/, which computes the eigenvalues and right eigenvectors of a hermitian complex matrix: 153-- | Wrapper for LAPACK's /zheev/, which computes the eigenvalues and right eigenvectors of a hermitian complex matrix:
167-- 154--
@@ -171,165 +158,120 @@ foreign import ccall "LAPACK/lapack-aux.h eig_l_H" zheev :: TCMVCM
171-- The eigenvalues are sorted in descending order (use eigH' for ascending order). 158-- The eigenvalues are sorted in descending order (use eigH' for ascending order).
172eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) 159eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))
173eigH m = (s', fliprl v) 160eigH m = (s', fliprl v)
174 where (s,v) = eigH' m 161 where (s,v) = eigH' (fmat m)
175 s' = fromList . reverse . toList $ s 162 s' = fromList . reverse . toList $ s
176 163
177eigH' m 164eigH' m
178 | r == 1 = (fromList [realPart (cdat m `at` 0)], singleton 1) 165 | r == 1 = (fromList [realPart (flatten m `at` 0)], singleton 1)
179 | otherwise = unsafePerformIO $ do 166 | otherwise = unsafePerformIO $ do
180 l <- createVector r 167 l <- createVector r
181 v <- createMatrix ColumnMajor r r 168 v <- createMatrix ColumnMajor r r
182 zheev // mat fdat m // vec l // mat dat v // check "eigH" [fdat m] 169 zheev // matf m // vec l // matf v // check "eigH" [fdat m]
183 return (l,v) 170 return (l,v)
184 where r = rows m 171 where r = rows m
185 172
186----------------------------------------------------------------------------- 173-----------------------------------------------------------------------------
187foreign import ccall "LAPACK/lapack-aux.h linearSolveR_l" dgesv :: TMMM 174foreign import ccall "LAPACK/lapack-aux.h linearSolveR_l" dgesv :: TMMM
175foreign import ccall "LAPACK/lapack-aux.h linearSolveC_l" zgesv :: TCMCMCM
188 176
189-- | Wrapper for LAPACK's /dgesv/, which solves a general real linear system (for several right-hand sides) internally using the lu decomposition. 177linearSolveSQAux f st a b
190linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double
191linearSolveR a b
192 | n1==n2 && n1==r = unsafePerformIO $ do 178 | n1==n2 && n1==r = unsafePerformIO $ do
193 s <- createMatrix ColumnMajor r c 179 s <- createMatrix ColumnMajor r c
194 dgesv // mat fdat a // mat fdat b // mat dat s // check "linearSolveR" [fdat a, fdat b] 180 f // matf a // matf b // matf s // check st [fdat a, fdat b]
195 return s 181 return s
196 | otherwise = error "linearSolveR of nonsquare matrix" 182 | otherwise = error $ st ++ " of nonsquare matrix"
197 where n1 = rows a 183 where n1 = rows a
198 n2 = cols a 184 n2 = cols a
199 r = rows b 185 r = rows b
200 c = cols b 186 c = cols b
201 187
202----------------------------------------------------------------------------- 188-- | Wrapper for LAPACK's /dgesv/, which solves a general real linear system (for several right-hand sides) internally using the lu decomposition.
203foreign import ccall "LAPACK/lapack-aux.h linearSolveC_l" zgesv :: TCMCMCM 189linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double
190linearSolveR a b = linearSolveSQAux dgesv "linearSolveR" (fmat a) (fmat b)
204 191
205-- | Wrapper for LAPACK's /zgesv/, which solves a general complex linear system (for several right-hand sides) internally using the lu decomposition. 192-- | Wrapper for LAPACK's /zgesv/, which solves a general complex linear system (for several right-hand sides) internally using the lu decomposition.
206linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) 193linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)
207linearSolveC a b 194linearSolveC a b = linearSolveSQAux zgesv "linearSolveC" (fmat a) (fmat b)
208 | n1==n2 && n1==r = unsafePerformIO $ do
209 s <- createMatrix ColumnMajor r c
210 zgesv // mat fdat a // mat fdat b // mat dat s // check "linearSolveC" [fdat a, fdat b]
211 return s
212 | otherwise = error "linearSolveC of nonsquare matrix"
213 where n1 = rows a
214 n2 = cols a
215 r = rows b
216 c = cols b
217 195
218----------------------------------------------------------------------------------- 196-----------------------------------------------------------------------------------
219foreign import ccall "LAPACK/lapack-aux.h linearSolveLSR_l" dgels :: TMMM 197foreign import ccall "LAPACK/lapack-aux.h linearSolveLSR_l" dgels :: TMMM
198foreign import ccall "LAPACK/lapack-aux.h linearSolveLSC_l" zgels :: TCMCMCM
199foreign import ccall "LAPACK/lapack-aux.h linearSolveSVDR_l" dgelss :: Double -> TMMM
200foreign import ccall "LAPACK/lapack-aux.h linearSolveSVDC_l" zgelss :: Double -> TCMCMCM
220 201
221-- | Wrapper for LAPACK's /dgels/, which obtains the least squared error solution of an overconstrained real linear system or the minimum norm solution of an underdetermined system, for several right-hand sides. For rank deficient systems use 'linearSolveSVDR'. 202linearSolveAux f st a b = unsafePerformIO $ do
222linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double
223linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $ linearSolveLSR_l a b
224
225linearSolveLSR_l a b = unsafePerformIO $ do
226 r <- createMatrix ColumnMajor (max m n) nrhs 203 r <- createMatrix ColumnMajor (max m n) nrhs
227 dgels // mat fdat a // mat fdat b // mat dat r // check "linearSolveLSR" [fdat a, fdat b] 204 f // matf a // matf b // matf r // check st [fdat a, fdat b]
228 return r 205 return r
229 where m = rows a 206 where m = rows a
230 n = cols a 207 n = cols a
231 nrhs = cols b 208 nrhs = cols b
232 209
233----------------------------------------------------------------------------------- 210-- | Wrapper for LAPACK's /dgels/, which obtains the least squared error solution of an overconstrained real linear system or the minimum norm solution of an underdetermined system, for several right-hand sides. For rank deficient systems use 'linearSolveSVDR'.
234foreign import ccall "LAPACK/lapack-aux.h linearSolveLSC_l" zgels :: TCMCMCM 211linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double
212linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $
213 linearSolveAux dgels "linearSolverLSR" (fmat a) (fmat b)
235 214
236-- | Wrapper for LAPACK's /zgels/, which obtains the least squared error solution of an overconstrained complex linear system or the minimum norm solution of an underdetermined system, for several right-hand sides. For rank deficient systems use 'linearSolveSVDC'. 215-- | Wrapper for LAPACK's /zgels/, which obtains the least squared error solution of an overconstrained complex linear system or the minimum norm solution of an underdetermined system, for several right-hand sides. For rank deficient systems use 'linearSolveSVDC'.
237linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) 216linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)
238linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $ linearSolveLSC_l a b 217linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $
239 218 linearSolveAux zgels "linearSolveLSC" (fmat a) (fmat b)
240linearSolveLSC_l a b = unsafePerformIO $ do
241 r <- createMatrix ColumnMajor (max m n) nrhs
242 zgels // mat fdat a // mat fdat b // mat dat r // check "linearSolveLSC" [fdat a, fdat b]
243 return r
244 where m = rows a
245 n = cols a
246 nrhs = cols b
247
248-----------------------------------------------------------------------------------
249foreign import ccall "LAPACK/lapack-aux.h linearSolveSVDR_l" dgelss :: Double -> TMMM
250 219
251-- | Wrapper for LAPACK's /dgelss/, which obtains the minimum norm solution to a real linear least squares problem Ax=B using the svd, for several right-hand sides. 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. 220-- | Wrapper for LAPACK's /dgelss/, which obtains the minimum norm solution to a real linear least squares problem Ax=B using the svd, for several right-hand sides. 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.
252linearSolveSVDR :: Maybe Double -- ^ rcond 221linearSolveSVDR :: Maybe Double -- ^ rcond
253 -> Matrix Double -- ^ coefficient matrix 222 -> Matrix Double -- ^ coefficient matrix
254 -> Matrix Double -- ^ right hand sides (as columns) 223 -> Matrix Double -- ^ right hand sides (as columns)
255 -> Matrix Double -- ^ solution vectors (as columns) 224 -> Matrix Double -- ^ solution vectors (as columns)
256linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveSVDR_l rcond a b 225linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $
257linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) a b 226 linearSolveAux (dgelss rcond) "linearSolveSVDR" (fmat a) (fmat b)
258 227linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) (fmat a) (fmat b)
259linearSolveSVDR_l rcond a b = unsafePerformIO $ do
260 r <- createMatrix ColumnMajor (max m n) nrhs
261 dgelss rcond // mat fdat a // mat fdat b // mat dat r // check "linearSolveSVDR" [fdat a, fdat b]
262 return r
263 where m = rows a
264 n = cols a
265 nrhs = cols b
266
267-----------------------------------------------------------------------------------
268foreign import ccall "LAPACK/lapack-aux.h linearSolveSVDC_l" zgelss :: Double -> TCMCMCM
269 228
270-- | Wrapper for LAPACK's /zgelss/, which obtains the minimum norm solution to a complex linear least squares problem Ax=B using the svd, for several right-hand sides. 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. 229-- | Wrapper for LAPACK's /zgelss/, which obtains the minimum norm solution to a complex linear least squares problem Ax=B using the svd, for several right-hand sides. 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.
271linearSolveSVDC :: Maybe Double -- ^ rcond 230linearSolveSVDC :: Maybe Double -- ^ rcond
272 -> Matrix (Complex Double) -- ^ coefficient matrix 231 -> Matrix (Complex Double) -- ^ coefficient matrix
273 -> Matrix (Complex Double) -- ^ right hand sides (as columns) 232 -> Matrix (Complex Double) -- ^ right hand sides (as columns)
274 -> Matrix (Complex Double) -- ^ solution vectors (as columns) 233 -> Matrix (Complex Double) -- ^ solution vectors (as columns)
275linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveSVDC_l rcond a b 234linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $
276linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) a b 235 linearSolveAux (zgelss rcond) "linearSolveSVDC" (fmat a) (fmat b)
277 236linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) (fmat a) (fmat b)
278linearSolveSVDC_l rcond a b = unsafePerformIO $ do
279 r <- createMatrix ColumnMajor (max m n) nrhs
280 zgelss rcond // mat fdat a // mat fdat b // mat dat r // check "linearSolveSVDC" [fdat a, fdat b]
281 return r
282 where m = rows a
283 n = cols a
284 nrhs = cols b
285 237
286----------------------------------------------------------------------------------- 238-----------------------------------------------------------------------------------
287foreign import ccall "LAPACK/lapack-aux.h chol_l_H" zpotrf :: TCMCM 239foreign import ccall "LAPACK/lapack-aux.h chol_l_H" zpotrf :: TCMCM
240foreign import ccall "LAPACK/lapack-aux.h chol_l_S" dpotrf :: TMM
288 241
289-- | Wrapper for LAPACK's /zpotrf/, which computes the Cholesky factorization of a 242-- | Wrapper for LAPACK's /zpotrf/, which computes the Cholesky factorization of a
290-- complex Hermitian positive definite matrix. 243-- complex Hermitian positive definite matrix.
291cholH :: Matrix (Complex Double) -> Matrix (Complex Double) 244cholH :: Matrix (Complex Double) -> Matrix (Complex Double)
292cholH a = unsafePerformIO $ do 245cholH = cholAux zpotrf "cholH" . fmat
293 r <- createMatrix ColumnMajor n n
294 zpotrf // mat fdat a // mat dat r // check "cholH" [fdat a]
295 return r
296 where n = rows a
297
298-----------------------------------------------------------------------------------
299foreign import ccall "LAPACK/lapack-aux.h chol_l_S" dpotrf :: TMM
300 246
301-- | Wrapper for LAPACK's /dpotrf/, which computes the Cholesky factorization of a 247-- | Wrapper for LAPACK's /dpotrf/, which computes the Cholesky factorization of a
302-- real symmetric positive definite matrix. 248-- real symmetric positive definite matrix.
303cholS :: Matrix Double -> Matrix Double 249cholS :: Matrix Double -> Matrix Double
304cholS a = unsafePerformIO $ do 250cholS = cholAux dpotrf "cholS" . fmat
251
252cholAux f st a = unsafePerformIO $ do
305 r <- createMatrix ColumnMajor n n 253 r <- createMatrix ColumnMajor n n
306 dpotrf // mat fdat a // mat dat r // check "cholS" [fdat a] 254 f // matf a // matf r // check st [fdat a]
307 return r 255 return r
308 where n = rows a 256 where n = rows a
309 257
310----------------------------------------------------------------------------------- 258-----------------------------------------------------------------------------------
311foreign import ccall "LAPACK/lapack-aux.h qr_l_R" dgeqr2 :: TMVM 259foreign import ccall "LAPACK/lapack-aux.h qr_l_R" dgeqr2 :: TMVM
260foreign import ccall "LAPACK/lapack-aux.h qr_l_C" zgeqr2 :: TCMCVCM
312 261
313-- | Wrapper for LAPACK's /dgeqr2/, which computes a QR factorization of a real matrix. 262-- | Wrapper for LAPACK's /dgeqr2/, which computes a QR factorization of a real matrix.
314qrR :: Matrix Double -> (Matrix Double, Vector Double) 263qrR :: Matrix Double -> (Matrix Double, Vector Double)
315qrR a = unsafePerformIO $ do 264qrR = qrAux dgeqr2 "qrR" . fmat
316 r <- createMatrix ColumnMajor m n
317 tau <- createVector mn
318 dgeqr2 // mat fdat a // vec tau // mat dat r // check "qrR" [fdat a]
319 return (r,tau)
320 where m = rows a
321 n = cols a
322 mn = min m n
323
324-----------------------------------------------------------------------------------
325foreign import ccall "LAPACK/lapack-aux.h qr_l_C" zgeqr2 :: TCMCVCM
326 265
327-- | Wrapper for LAPACK's /zgeqr2/, which computes a QR factorization of a complex matrix. 266-- | Wrapper for LAPACK's /zgeqr2/, which computes a QR factorization of a complex matrix.
328qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) 267qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))
329qrC a = unsafePerformIO $ do 268qrC = qrAux zgeqr2 "qrC" . fmat
269
270qrAux f st a = unsafePerformIO $ do
330 r <- createMatrix ColumnMajor m n 271 r <- createMatrix ColumnMajor m n
331 tau <- createVector mn 272 tau <- createVector mn
332 zgeqr2 // mat fdat a // vec tau // mat dat r // check "qrC" [fdat a] 273 withForeignPtr (fptr $ fdat $ a) $ \p ->
274 f m n p // vec tau // matf r // check st [fdat a]
333 return (r,tau) 275 return (r,tau)
334 where m = rows a 276 where m = rows a
335 n = cols a 277 n = cols a
@@ -337,52 +279,42 @@ qrC a = unsafePerformIO $ do
337 279
338----------------------------------------------------------------------------------- 280-----------------------------------------------------------------------------------
339foreign import ccall "LAPACK/lapack-aux.h hess_l_R" dgehrd :: TMVM 281foreign import ccall "LAPACK/lapack-aux.h hess_l_R" dgehrd :: TMVM
282foreign import ccall "LAPACK/lapack-aux.h hess_l_C" zgehrd :: TCMCVCM
340 283
341-- | Wrapper for LAPACK's /dgehrd/, which computes a Hessenberg factorization of a square real matrix. 284-- | Wrapper for LAPACK's /dgehrd/, which computes a Hessenberg factorization of a square real matrix.
342hessR :: Matrix Double -> (Matrix Double, Vector Double) 285hessR :: Matrix Double -> (Matrix Double, Vector Double)
343hessR a = unsafePerformIO $ do 286hessR = hessAux dgehrd "hessR" . fmat
344 r <- createMatrix ColumnMajor m n
345 tau <- createVector (mn-1)
346 dgehrd // mat fdat a // vec tau // mat dat r // check "hessR" [fdat a]
347 return (r,tau)
348 where m = rows a
349 n = cols a
350 mn = min m n
351
352-----------------------------------------------------------------------------------
353foreign import ccall "LAPACK/lapack-aux.h hess_l_C" zgehrd :: TCMCVCM
354 287
355-- | Wrapper for LAPACK's /zgehrd/, which computes a Hessenberg factorization of a square complex matrix. 288-- | Wrapper for LAPACK's /zgehrd/, which computes a Hessenberg factorization of a square complex matrix.
356hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) 289hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))
357hessC a = unsafePerformIO $ do 290hessC = hessAux zgehrd "hessC" . fmat
291
292hessAux f st a = unsafePerformIO $ do
358 r <- createMatrix ColumnMajor m n 293 r <- createMatrix ColumnMajor m n
359 tau <- createVector (mn-1) 294 tau <- createVector (mn-1)
360 zgehrd // mat fdat a // vec tau // mat dat r // check "hessC" [fdat a] 295 f // matf a // vec tau // matf r // check st [fdat a]
361 return (r,tau) 296 return (r,tau)
362 where m = rows a 297 where m = rows a
363 n = cols a 298 n = cols a
364 mn = min m n 299 mn = min m n
365 300
366----------------------------------------------------------------------------------- 301-----------------------------------------------------------------------------------
367foreign import ccall "LAPACK/lapack-aux.h schur_l_R" dgees :: TMMM 302foreign import ccall safe "LAPACK/lapack-aux.h schur_l_R" dgees :: TMMM
303foreign import ccall "LAPACK/lapack-aux.h schur_l_C" zgees :: TCMCMCM
368 304
369-- | Wrapper for LAPACK's /dgees/, which computes a Schur factorization of a square real matrix. 305-- | Wrapper for LAPACK's /dgees/, which computes a Schur factorization of a square real matrix.
370schurR :: Matrix Double -> (Matrix Double, Matrix Double) 306schurR :: Matrix Double -> (Matrix Double, Matrix Double)
371schurR a = unsafePerformIO $ do 307schurR = schurAux dgees "schurR" . fmat
372 u <- createMatrix ColumnMajor n n
373 s <- createMatrix ColumnMajor n n
374 dgees // mat fdat a // mat dat u // mat dat s // check "schurR" [fdat a]
375 return (u,s)
376 where n = rows a
377
378-----------------------------------------------------------------------------------
379foreign import ccall "LAPACK/lapack-aux.h schur_l_C" zgees :: TCMCMCM
380 308
381-- | Wrapper for LAPACK's /zgees/, which computes a Schur factorization of a square complex matrix. 309-- | Wrapper for LAPACK's /zgees/, which computes a Schur factorization of a square complex matrix.
382schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double)) 310schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double))
383schurC a = unsafePerformIO $ do 311schurC = schurAux zgees "schurC" . fmat
312
313schurAux f st a = unsafePerformIO $ do
384 u <- createMatrix ColumnMajor n n 314 u <- createMatrix ColumnMajor n n
385 s <- createMatrix ColumnMajor n n 315 s <- createMatrix ColumnMajor n n
386 zgees // mat fdat a // mat dat u // mat dat s // check "schurC" [fdat a] 316 f // matf a // matf u // matf s // check st [fdat a]
387 return (u,s) 317 return (u,s)
388 where n = rows a 318 where n = rows a
319
320-----------------------------------------------------------------------------------
diff --git a/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c b/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c
index 058232c..8392feb 100644
--- a/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c
+++ b/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c
@@ -709,6 +709,11 @@ int schur_l_R(KDMAT(a), DMAT(u), DMAT(s)) {
709 integer n = ac; 709 integer n = ac;
710 REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE); 710 REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE);
711 DEBUGMSG("schur_l_R"); 711 DEBUGMSG("schur_l_R");
712 int k;
713 //printf("---------------------------\n");
714 //printf("%p: ",ap); for(k=0;k<n*n;k++) printf("%f ",ap[k]); printf("\n");
715 //printf("%p: ",up); for(k=0;k<n*n;k++) printf("%f ",up[k]); printf("\n");
716 //printf("%p: ",sp); for(k=0;k<n*n;k++) printf("%f ",sp[k]); printf("\n");
712 memcpy(sp,ap,n*n*sizeof(double)); 717 memcpy(sp,ap,n*n*sizeof(double));
713 integer lwork = 6*n; // fixme 718 integer lwork = 6*n; // fixme
714 double *WORK = (double*)malloc(lwork*sizeof(double)); 719 double *WORK = (double*)malloc(lwork*sizeof(double));
@@ -719,6 +724,12 @@ int schur_l_R(KDMAT(a), DMAT(u), DMAT(s)) {
719 integer res; 724 integer res;
720 integer sdim; 725 integer sdim;
721 dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res); 726 dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res);
727 //printf("%p: ",ap); for(k=0;k<n*n;k++) printf("%f ",ap[k]); printf("\n");
728 //printf("%p: ",up); for(k=0;k<n*n;k++) printf("%f ",up[k]); printf("\n");
729 //printf("%p: ",sp); for(k=0;k<n*n;k++) printf("%f ",sp[k]); printf("\n");
730 if(res>0) {
731 return NOCONVER;
732 }
722 CHECK(res,res); 733 CHECK(res,res);
723 free(WR); 734 free(WR);
724 free(WI); 735 free(WI);
@@ -747,6 +758,9 @@ int schur_l_C(KCMAT(a), CMAT(u), CMAT(s)) {
747 zgees_ ("V","N",NULL,&n,(doublecomplex*)sp,&n,&sdim,W, 758 zgees_ ("V","N",NULL,&n,(doublecomplex*)sp,&n,&sdim,W,
748 (doublecomplex*)up,&n, 759 (doublecomplex*)up,&n,
749 WORK,&lwork,RWORK,BWORK,&res); 760 WORK,&lwork,RWORK,BWORK,&res);
761 if(res>0) {
762 return NOCONVER;
763 }
750 CHECK(res,res); 764 CHECK(res,res);
751 free(W); 765 free(W);
752 free(BWORK); 766 free(BWORK);
diff --git a/lib/Numeric/LinearAlgebra/Linear.hs b/lib/Numeric/LinearAlgebra/Linear.hs
index 13d69ab..3403591 100644
--- a/lib/Numeric/LinearAlgebra/Linear.hs
+++ b/lib/Numeric/LinearAlgebra/Linear.hs
@@ -20,7 +20,7 @@ module Numeric.LinearAlgebra.Linear (
20) where 20) where
21 21
22 22
23import Data.Packed.Internal 23import Data.Packed.Internal(multiply,at,partit)
24import Data.Packed 24import Data.Packed
25import Numeric.GSL.Vector 25import Numeric.GSL.Vector
26import Complex 26import Complex
@@ -68,7 +68,7 @@ instance Linear Matrix Double where
68 sub = liftMatrix2 sub 68 sub = liftMatrix2 sub
69 mul = liftMatrix2 mul 69 mul = liftMatrix2 mul
70 divide = liftMatrix2 divide 70 divide = liftMatrix2 divide
71 equal a b = cols a == cols b && cdat a `equal` cdat b 71 equal a b = cols a == cols b && flatten a `equal` flatten b
72 72
73 73
74instance Linear Matrix (Complex Double) where 74instance Linear Matrix (Complex Double) where
@@ -79,13 +79,13 @@ instance Linear Matrix (Complex Double) where
79 sub = liftMatrix2 sub 79 sub = liftMatrix2 sub
80 mul = liftMatrix2 mul 80 mul = liftMatrix2 mul
81 divide = liftMatrix2 divide 81 divide = liftMatrix2 divide
82 equal a b = cols a == cols b && cdat a `equal` cdat b 82 equal a b = cols a == cols b && flatten a `equal` flatten b
83 83
84-------------------------------------------------- 84--------------------------------------------------
85 85
86-- | euclidean inner product 86-- | euclidean inner product
87dot :: (Element t) => Vector t -> Vector t -> t 87dot :: (Element t) => Vector t -> Vector t -> t
88dot u v = dat (multiply r c) `at` 0 88dot u v = multiply r c @@> (0,0)
89 where r = asRow u 89 where r = asRow u
90 c = asColumn v 90 c = asColumn v
91 91