diff options
Diffstat (limited to 'lib/Numeric')
-rw-r--r-- | lib/Numeric/GSL/Matrix.hs | 72 | ||||
-rw-r--r-- | lib/Numeric/GSL/Minimization.hs | 8 | ||||
-rw-r--r-- | lib/Numeric/LinearAlgebra/LAPACK.hs | 240 | ||||
-rw-r--r-- | lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c | 14 | ||||
-rw-r--r-- | lib/Numeric/LinearAlgebra/Linear.hs | 8 |
5 files changed, 155 insertions, 187 deletions
diff --git a/lib/Numeric/GSL/Matrix.hs b/lib/Numeric/GSL/Matrix.hs index 5a5c19e..e803c53 100644 --- a/lib/Numeric/GSL/Matrix.hs +++ b/lib/Numeric/GSL/Matrix.hs | |||
@@ -44,12 +44,14 @@ import Complex | |||
44 | 44 | ||
45 | -} | 45 | -} |
46 | eigSg :: Matrix Double -> (Vector Double, Matrix Double) | 46 | eigSg :: Matrix Double -> (Vector Double, Matrix Double) |
47 | eigSg m | 47 | eigSg = eigSg . cmat |
48 | |||
49 | eigSg' m | ||
48 | | r == 1 = (fromList [cdat m `at` 0], singleton 1) | 50 | | r == 1 = (fromList [cdat m `at` 0], singleton 1) |
49 | | otherwise = unsafePerformIO $ do | 51 | | otherwise = unsafePerformIO $ do |
50 | l <- createVector r | 52 | l <- createVector r |
51 | v <- createMatrix RowMajor r r | 53 | v <- createMatrix RowMajor r r |
52 | c_eigS // mat cdat m // vec l // mat dat v // check "eigSg" [cdat m] | 54 | c_eigS // matc m // vec l // matc v // check "eigSg" [cdat m] |
53 | return (l,v) | 55 | return (l,v) |
54 | where r = rows m | 56 | where r = rows m |
55 | foreign import ccall "gsl-aux.h eigensystemR" c_eigS :: TMVM | 57 | foreign import ccall "gsl-aux.h eigensystemR" c_eigS :: TMVM |
@@ -75,12 +77,14 @@ foreign import ccall "gsl-aux.h eigensystemR" c_eigS :: TMVM | |||
75 | 77 | ||
76 | -} | 78 | -} |
77 | eigHg :: Matrix (Complex Double)-> (Vector Double, Matrix (Complex Double)) | 79 | eigHg :: Matrix (Complex Double)-> (Vector Double, Matrix (Complex Double)) |
78 | eigHg m | 80 | eigHg = eigHg' . cmat |
81 | |||
82 | eigHg' m | ||
79 | | r == 1 = (fromList [realPart $ cdat m `at` 0], singleton 1) | 83 | | r == 1 = (fromList [realPart $ cdat m `at` 0], singleton 1) |
80 | | otherwise = unsafePerformIO $ do | 84 | | otherwise = unsafePerformIO $ do |
81 | l <- createVector r | 85 | l <- createVector r |
82 | v <- createMatrix RowMajor r r | 86 | v <- createMatrix RowMajor r r |
83 | c_eigH // mat cdat m // vec l // mat dat v // check "eigHg" [cdat m] | 87 | c_eigH // matc m // vec l // matc v // check "eigHg" [cdat m] |
84 | return (l,v) | 88 | return (l,v) |
85 | where r = rows m | 89 | where r = rows m |
86 | foreign import ccall "gsl-aux.h eigensystemC" c_eigH :: TCMVCM | 90 | foreign import ccall "gsl-aux.h eigensystemC" c_eigH :: TCMVCM |
@@ -109,14 +113,14 @@ foreign import ccall "gsl-aux.h eigensystemC" c_eigH :: TCMVCM | |||
109 | -} | 113 | -} |
110 | svdg :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) | 114 | svdg :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) |
111 | svdg x = if rows x >= cols x | 115 | svdg x = if rows x >= cols x |
112 | then svd' x | 116 | then svd' (cmat x) |
113 | else (v, s, u) where (u,s,v) = svd' (trans x) | 117 | else (v, s, u) where (u,s,v) = svd' (cmat (trans x)) |
114 | 118 | ||
115 | svd' x = unsafePerformIO $ do | 119 | svd' x = unsafePerformIO $ do |
116 | u <- createMatrix RowMajor r c | 120 | u <- createMatrix RowMajor r c |
117 | s <- createVector c | 121 | s <- createVector c |
118 | v <- createMatrix RowMajor c c | 122 | v <- createMatrix RowMajor c c |
119 | c_svd // mat cdat x // mat dat u // vec s // mat dat v // check "svdg" [cdat x] | 123 | c_svd // matc x // matc u // vec s // matc v // check "svdg" [cdat x] |
120 | return (u,s,v) | 124 | return (u,s,v) |
121 | where r = rows x | 125 | where r = rows x |
122 | c = cols x | 126 | c = cols x |
@@ -140,30 +144,36 @@ foreign import ccall "gsl-aux.h svd" c_svd :: TMMVM | |||
140 | 144 | ||
141 | -} | 145 | -} |
142 | qr :: Matrix Double -> (Matrix Double, Matrix Double) | 146 | qr :: Matrix Double -> (Matrix Double, Matrix Double) |
143 | qr x = unsafePerformIO $ do | 147 | qr = qr' . cmat |
148 | |||
149 | qr' x = unsafePerformIO $ do | ||
144 | q <- createMatrix RowMajor r r | 150 | q <- createMatrix RowMajor r r |
145 | rot <- createMatrix RowMajor r c | 151 | rot <- createMatrix RowMajor r c |
146 | c_qr // mat cdat x // mat dat q // mat dat rot // check "qr" [cdat x] | 152 | c_qr // matc x // matc q // matc rot // check "qr" [cdat x] |
147 | return (q,rot) | 153 | return (q,rot) |
148 | where r = rows x | 154 | where r = rows x |
149 | c = cols x | 155 | c = cols x |
150 | foreign import ccall "gsl-aux.h QR" c_qr :: TMMM | 156 | foreign import ccall "gsl-aux.h QR" c_qr :: TMMM |
151 | 157 | ||
152 | qrPacked :: Matrix Double -> (Matrix Double, Vector Double) | 158 | qrPacked :: Matrix Double -> (Matrix Double, Vector Double) |
153 | qrPacked x = unsafePerformIO $ do | 159 | qrPacked = qrPacked' . cmat |
160 | |||
161 | qrPacked' x = unsafePerformIO $ do | ||
154 | qr <- createMatrix RowMajor r c | 162 | qr <- createMatrix RowMajor r c |
155 | tau <- createVector (min r c) | 163 | tau <- createVector (min r c) |
156 | c_qrPacked // mat cdat x // mat dat qr // vec tau // check "qrUnpacked" [cdat x] | 164 | c_qrPacked // matc x // matc qr // vec tau // check "qrUnpacked" [cdat x] |
157 | return (qr,tau) | 165 | return (qr,tau) |
158 | where r = rows x | 166 | where r = rows x |
159 | c = cols x | 167 | c = cols x |
160 | foreign import ccall "gsl-aux.h QRpacked" c_qrPacked :: TMMV | 168 | foreign import ccall "gsl-aux.h QRpacked" c_qrPacked :: TMMV |
161 | 169 | ||
162 | unpackQR :: (Matrix Double, Vector Double) -> (Matrix Double, Matrix Double) | 170 | unpackQR :: (Matrix Double, Vector Double) -> (Matrix Double, Matrix Double) |
163 | unpackQR (qr,tau) = unsafePerformIO $ do | 171 | unpackQR (qr,tau) = unpackQR' (cmat qr, tau) |
172 | |||
173 | unpackQR' (qr,tau) = unsafePerformIO $ do | ||
164 | q <- createMatrix RowMajor r r | 174 | q <- createMatrix RowMajor r r |
165 | rot <- createMatrix RowMajor r c | 175 | rot <- createMatrix RowMajor r c |
166 | c_qrUnpack // mat cdat qr // vec tau // mat dat q // mat dat rot // check "qrUnpack" [cdat qr,tau] | 176 | c_qrUnpack // matc qr // vec tau // matc q // matc rot // check "qrUnpack" [cdat qr,tau] |
167 | return (q,rot) | 177 | return (q,rot) |
168 | where r = rows qr | 178 | where r = rows qr |
169 | c = cols qr | 179 | c = cols qr |
@@ -183,17 +193,21 @@ type TMVMM = Int -> Int -> PD -> Int -> PD -> TMM | |||
183 | 193 | ||
184 | -} | 194 | -} |
185 | cholR :: Matrix Double -> Matrix Double | 195 | cholR :: Matrix Double -> Matrix Double |
186 | cholR x = unsafePerformIO $ do | 196 | cholR = cholR' . cmat |
197 | |||
198 | cholR' x = unsafePerformIO $ do | ||
187 | res <- createMatrix RowMajor r r | 199 | res <- createMatrix RowMajor r r |
188 | c_cholR // mat cdat x // mat dat res // check "cholR" [cdat x] | 200 | c_cholR // matc x // matc res // check "cholR" [cdat x] |
189 | return res | 201 | return res |
190 | where r = rows x | 202 | where r = rows x |
191 | foreign import ccall "gsl-aux.h cholR" c_cholR :: TMM | 203 | foreign import ccall "gsl-aux.h cholR" c_cholR :: TMM |
192 | 204 | ||
193 | cholC :: Matrix (Complex Double) -> Matrix (Complex Double) | 205 | cholC :: Matrix (Complex Double) -> Matrix (Complex Double) |
194 | cholC x = unsafePerformIO $ do | 206 | cholC = cholC' . cmat |
207 | |||
208 | cholC' x = unsafePerformIO $ do | ||
195 | res <- createMatrix RowMajor r r | 209 | res <- createMatrix RowMajor r r |
196 | c_cholC // mat cdat x // mat dat res // check "cholC" [cdat x] | 210 | c_cholC // matc x // matc res // check "cholC" [cdat x] |
197 | return res | 211 | return res |
198 | where r = rows x | 212 | where r = rows x |
199 | foreign import ccall "gsl-aux.h cholC" c_cholC :: TCMCM | 213 | foreign import ccall "gsl-aux.h cholC" c_cholC :: TCMCM |
@@ -204,10 +218,12 @@ foreign import ccall "gsl-aux.h cholC" c_cholC :: TCMCM | |||
204 | {- -| efficient multiplication by the inverse of a matrix (for real matrices) | 218 | {- -| efficient multiplication by the inverse of a matrix (for real matrices) |
205 | -} | 219 | -} |
206 | luSolveR :: Matrix Double -> Matrix Double -> Matrix Double | 220 | luSolveR :: Matrix Double -> Matrix Double -> Matrix Double |
207 | luSolveR a b | 221 | luSolveR a b = luSolveR' (cmat a) (cmat b) |
222 | |||
223 | luSolveR' a b | ||
208 | | n1==n2 && n1==r = unsafePerformIO $ do | 224 | | n1==n2 && n1==r = unsafePerformIO $ do |
209 | s <- createMatrix RowMajor r c | 225 | s <- createMatrix RowMajor r c |
210 | c_luSolveR // mat cdat a // mat cdat b // mat dat s // check "luSolveR" [cdat a, cdat b] | 226 | c_luSolveR // matc a // matc b // matc s // check "luSolveR" [cdat a, cdat b] |
211 | return s | 227 | return s |
212 | | otherwise = error "luSolveR of nonsquare matrix" | 228 | | otherwise = error "luSolveR of nonsquare matrix" |
213 | where n1 = rows a | 229 | where n1 = rows a |
@@ -219,10 +235,12 @@ foreign import ccall "gsl-aux.h luSolveR" c_luSolveR :: TMMM | |||
219 | {- -| efficient multiplication by the inverse of a matrix (for complex matrices). | 235 | {- -| efficient multiplication by the inverse of a matrix (for complex matrices). |
220 | -} | 236 | -} |
221 | luSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) | 237 | luSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) |
222 | luSolveC a b | 238 | luSolveC a b = luSolveC' (cmat a) (cmat b) |
239 | |||
240 | luSolveC' a b | ||
223 | | n1==n2 && n1==r = unsafePerformIO $ do | 241 | | n1==n2 && n1==r = unsafePerformIO $ do |
224 | s <- createMatrix RowMajor r c | 242 | s <- createMatrix RowMajor r c |
225 | c_luSolveC // mat cdat a // mat cdat b // mat dat s // check "luSolveC" [cdat a, cdat b] | 243 | c_luSolveC // matc a // matc b // matc s // check "luSolveC" [cdat a, cdat b] |
226 | return s | 244 | return s |
227 | | otherwise = error "luSolveC of nonsquare matrix" | 245 | | otherwise = error "luSolveC of nonsquare matrix" |
228 | where n1 = rows a | 246 | where n1 = rows a |
@@ -234,9 +252,11 @@ foreign import ccall "gsl-aux.h luSolveC" c_luSolveC :: TCMCMCM | |||
234 | {- | lu decomposition of real matrix (packed as a vector including l, u, the permutation and sign) | 252 | {- | lu decomposition of real matrix (packed as a vector including l, u, the permutation and sign) |
235 | -} | 253 | -} |
236 | luRaux :: Matrix Double -> Vector Double | 254 | luRaux :: Matrix Double -> Vector Double |
237 | luRaux x = unsafePerformIO $ do | 255 | luRaux = luRaux' . cmat |
256 | |||
257 | luRaux' x = unsafePerformIO $ do | ||
238 | res <- createVector (r*r+r+1) | 258 | res <- createVector (r*r+r+1) |
239 | c_luRaux // mat cdat x // vec res // check "luRaux" [cdat x] | 259 | c_luRaux // matc x // vec res // check "luRaux" [cdat x] |
240 | return res | 260 | return res |
241 | where r = rows x | 261 | where r = rows x |
242 | c = cols x | 262 | c = cols x |
@@ -245,9 +265,11 @@ foreign import ccall "gsl-aux.h luRaux" c_luRaux :: TMV | |||
245 | {- | lu decomposition of complex matrix (packed as a vector including l, u, the permutation and sign) | 265 | {- | lu decomposition of complex matrix (packed as a vector including l, u, the permutation and sign) |
246 | -} | 266 | -} |
247 | luCaux :: Matrix (Complex Double) -> Vector (Complex Double) | 267 | luCaux :: Matrix (Complex Double) -> Vector (Complex Double) |
248 | luCaux x = unsafePerformIO $ do | 268 | luCaux = luCaux' . cmat |
269 | |||
270 | luCaux' x = unsafePerformIO $ do | ||
249 | res <- createVector (r*r+r+1) | 271 | res <- createVector (r*r+r+1) |
250 | c_luCaux // mat cdat x // vec res // check "luCaux" [cdat x] | 272 | c_luCaux // matc x // vec res // check "luCaux" [cdat x] |
251 | return res | 273 | return res |
252 | where r = rows x | 274 | where r = rows x |
253 | c = cols x | 275 | c = cols x |
diff --git a/lib/Numeric/GSL/Minimization.hs b/lib/Numeric/GSL/Minimization.hs index e93f8cb..f523849 100644 --- a/lib/Numeric/GSL/Minimization.hs +++ b/lib/Numeric/GSL/Minimization.hs | |||
@@ -186,12 +186,12 @@ foreign import ccall "wrapper" | |||
186 | 186 | ||
187 | aux_vTov :: (Vector Double -> Vector Double) -> (Int -> Ptr Double -> Ptr Double -> IO()) | 187 | aux_vTov :: (Vector Double -> Vector Double) -> (Int -> Ptr Double -> Ptr Double -> IO()) |
188 | aux_vTov f n p r = g where | 188 | aux_vTov f n p r = g where |
189 | V {fptr = pr, ptr = t} = f x | 189 | v@V {fptr = pr} = f x |
190 | x = createV n copy "aux_vTov" [] | 190 | x = createV n copy "aux_vTov" [] |
191 | copy n q = do | 191 | copy n q = do |
192 | copyArray q p n | 192 | copyArray q p n |
193 | return 0 | 193 | return 0 |
194 | g = withForeignPtr pr $ \_ -> copyArray r t n | 194 | g = withForeignPtr pr $ \_ -> copyArray r (ptr v) n |
195 | 195 | ||
196 | -------------------------------------------------------------------- | 196 | -------------------------------------------------------------------- |
197 | 197 | ||
@@ -202,10 +202,10 @@ createV n fun msg ptrs = unsafePerformIO $ do | |||
202 | 202 | ||
203 | createM r c fun msg ptrs = unsafePerformIO $ do | 203 | createM r c fun msg ptrs = unsafePerformIO $ do |
204 | r <- createMatrix RowMajor r c | 204 | r <- createMatrix RowMajor r c |
205 | fun // mat cdat r // check msg ptrs | 205 | fun // matc r // check msg ptrs |
206 | return r | 206 | return r |
207 | 207 | ||
208 | createMIO r c fun msg ptrs = do | 208 | createMIO r c fun msg ptrs = do |
209 | r <- createMatrix RowMajor r c | 209 | r <- createMatrix RowMajor r c |
210 | fun // mat cdat r // check msg ptrs | 210 | fun // matc r // check msg ptrs |
211 | return r | 211 | return r |
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 | ----------------------------------------------------------------------------- |
38 | foreign import ccall "LAPACK/lapack-aux.h svd_l_R" dgesvd :: TMMVM | 38 | foreign import ccall "LAPACK/lapack-aux.h svd_l_R" dgesvd :: TMMVM |
39 | foreign import ccall "LAPACK/lapack-aux.h svd_l_C" zgesvd :: TCMCMVCM | ||
40 | foreign 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@. |
43 | svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) | 45 | svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) |
44 | svdR x = unsafePerformIO $ do | 46 | svdR = 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 | ----------------------------------------------------------------------------- | ||
53 | foreign 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@. |
58 | svdRdd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) | 51 | svdRdd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) |
59 | svdRdd x = unsafePerformIO $ do | 52 | svdRdd = 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 | ----------------------------------------------------------------------------- | ||
69 | foreign 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@. |
74 | svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) | 57 | svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) |
75 | svdC x = unsafePerformIO $ do | 58 | svdC = svdAux zgesvd "svdC" . fmat |
59 | |||
60 | svdAux 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 | ----------------------------------------------------------------------------- |
70 | eigAux 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 | |||
86 | foreign import ccall "LAPACK/lapack-aux.h eig_l_C" zgeev :: TCMCMCVCM | 81 | foreign import ccall "LAPACK/lapack-aux.h eig_l_C" zgeev :: TCMCMCVCM |
82 | foreign import ccall "LAPACK/lapack-aux.h eig_l_R" dgeev :: TMMCVM | ||
83 | foreign import ccall "LAPACK/lapack-aux.h eig_l_S" dsyev :: TMVM | ||
84 | foreign 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. |
94 | eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double)) | 92 | eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double)) |
95 | eigC m | 93 | eigC = 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 | ----------------------------------------------------------------------------- |
106 | foreign 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. |
114 | eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double)) | 103 | eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double)) |
115 | eigR m = (s', v'') | 104 | eigR 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 | ||
122 | eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double) | 111 | eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double) |
123 | eigRaux m | 112 | eigRaux 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 | ----------------------------------------------------------------------------- |
141 | foreign 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). |
149 | eigS :: Matrix Double -> (Vector Double, Matrix Double) | 137 | eigS :: Matrix Double -> (Vector Double, Matrix Double) |
150 | eigS m = (s', fliprl v) | 138 | eigS 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 | ||
154 | eigS' m | 142 | eigS' 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 | ----------------------------------------------------------------------------- |
164 | foreign 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). |
172 | eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) | 159 | eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) |
173 | eigH m = (s', fliprl v) | 160 | eigH 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 | ||
177 | eigH' m | 164 | eigH' 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 | ----------------------------------------------------------------------------- |
187 | foreign import ccall "LAPACK/lapack-aux.h linearSolveR_l" dgesv :: TMMM | 174 | foreign import ccall "LAPACK/lapack-aux.h linearSolveR_l" dgesv :: TMMM |
175 | foreign 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. | 177 | linearSolveSQAux f st a b |
190 | linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double | ||
191 | linearSolveR 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. |
203 | foreign import ccall "LAPACK/lapack-aux.h linearSolveC_l" zgesv :: TCMCMCM | 189 | linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double |
190 | linearSolveR 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. |
206 | linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) | 193 | linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) |
207 | linearSolveC a b | 194 | linearSolveC 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 | ----------------------------------------------------------------------------------- |
219 | foreign import ccall "LAPACK/lapack-aux.h linearSolveLSR_l" dgels :: TMMM | 197 | foreign import ccall "LAPACK/lapack-aux.h linearSolveLSR_l" dgels :: TMMM |
198 | foreign import ccall "LAPACK/lapack-aux.h linearSolveLSC_l" zgels :: TCMCMCM | ||
199 | foreign import ccall "LAPACK/lapack-aux.h linearSolveSVDR_l" dgelss :: Double -> TMMM | ||
200 | foreign 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'. | 202 | linearSolveAux f st a b = unsafePerformIO $ do |
222 | linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double | ||
223 | linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $ linearSolveLSR_l a b | ||
224 | |||
225 | linearSolveLSR_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'. |
234 | foreign import ccall "LAPACK/lapack-aux.h linearSolveLSC_l" zgels :: TCMCMCM | 211 | linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double |
212 | linearSolveLSR 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'. |
237 | linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) | 216 | linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) |
238 | linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $ linearSolveLSC_l a b | 217 | linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $ |
239 | 218 | linearSolveAux zgels "linearSolveLSC" (fmat a) (fmat b) | |
240 | linearSolveLSC_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 | ----------------------------------------------------------------------------------- | ||
249 | foreign 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. |
252 | linearSolveSVDR :: Maybe Double -- ^ rcond | 221 | linearSolveSVDR :: 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) |
256 | linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveSVDR_l rcond a b | 225 | linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ |
257 | linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) a b | 226 | linearSolveAux (dgelss rcond) "linearSolveSVDR" (fmat a) (fmat b) |
258 | 227 | linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) (fmat a) (fmat b) | |
259 | linearSolveSVDR_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 | ----------------------------------------------------------------------------------- | ||
268 | foreign 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. |
271 | linearSolveSVDC :: Maybe Double -- ^ rcond | 230 | linearSolveSVDC :: 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) |
275 | linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveSVDC_l rcond a b | 234 | linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ |
276 | linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) a b | 235 | linearSolveAux (zgelss rcond) "linearSolveSVDC" (fmat a) (fmat b) |
277 | 236 | linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) (fmat a) (fmat b) | |
278 | linearSolveSVDC_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 | ----------------------------------------------------------------------------------- |
287 | foreign import ccall "LAPACK/lapack-aux.h chol_l_H" zpotrf :: TCMCM | 239 | foreign import ccall "LAPACK/lapack-aux.h chol_l_H" zpotrf :: TCMCM |
240 | foreign 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. |
291 | cholH :: Matrix (Complex Double) -> Matrix (Complex Double) | 244 | cholH :: Matrix (Complex Double) -> Matrix (Complex Double) |
292 | cholH a = unsafePerformIO $ do | 245 | cholH = 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 | ----------------------------------------------------------------------------------- | ||
299 | foreign 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. |
303 | cholS :: Matrix Double -> Matrix Double | 249 | cholS :: Matrix Double -> Matrix Double |
304 | cholS a = unsafePerformIO $ do | 250 | cholS = cholAux dpotrf "cholS" . fmat |
251 | |||
252 | cholAux 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 | ----------------------------------------------------------------------------------- |
311 | foreign import ccall "LAPACK/lapack-aux.h qr_l_R" dgeqr2 :: TMVM | 259 | foreign import ccall "LAPACK/lapack-aux.h qr_l_R" dgeqr2 :: TMVM |
260 | foreign 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. |
314 | qrR :: Matrix Double -> (Matrix Double, Vector Double) | 263 | qrR :: Matrix Double -> (Matrix Double, Vector Double) |
315 | qrR a = unsafePerformIO $ do | 264 | qrR = 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 | ----------------------------------------------------------------------------------- | ||
325 | foreign 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. |
328 | qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) | 267 | qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) |
329 | qrC a = unsafePerformIO $ do | 268 | qrC = qrAux zgeqr2 "qrC" . fmat |
269 | |||
270 | qrAux 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 | ----------------------------------------------------------------------------------- |
339 | foreign import ccall "LAPACK/lapack-aux.h hess_l_R" dgehrd :: TMVM | 281 | foreign import ccall "LAPACK/lapack-aux.h hess_l_R" dgehrd :: TMVM |
282 | foreign 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. |
342 | hessR :: Matrix Double -> (Matrix Double, Vector Double) | 285 | hessR :: Matrix Double -> (Matrix Double, Vector Double) |
343 | hessR a = unsafePerformIO $ do | 286 | hessR = 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 | ----------------------------------------------------------------------------------- | ||
353 | foreign 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. |
356 | hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) | 289 | hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) |
357 | hessC a = unsafePerformIO $ do | 290 | hessC = hessAux zgehrd "hessC" . fmat |
291 | |||
292 | hessAux 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 | ----------------------------------------------------------------------------------- |
367 | foreign import ccall "LAPACK/lapack-aux.h schur_l_R" dgees :: TMMM | 302 | foreign import ccall safe "LAPACK/lapack-aux.h schur_l_R" dgees :: TMMM |
303 | foreign 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. |
370 | schurR :: Matrix Double -> (Matrix Double, Matrix Double) | 306 | schurR :: Matrix Double -> (Matrix Double, Matrix Double) |
371 | schurR a = unsafePerformIO $ do | 307 | schurR = 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 | ----------------------------------------------------------------------------------- | ||
379 | foreign 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. |
382 | schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double)) | 310 | schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double)) |
383 | schurC a = unsafePerformIO $ do | 311 | schurC = schurAux zgees "schurC" . fmat |
312 | |||
313 | schurAux 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 | ||
23 | import Data.Packed.Internal | 23 | import Data.Packed.Internal(multiply,at,partit) |
24 | import Data.Packed | 24 | import Data.Packed |
25 | import Numeric.GSL.Vector | 25 | import Numeric.GSL.Vector |
26 | import Complex | 26 | import 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 | ||
74 | instance Linear Matrix (Complex Double) where | 74 | instance 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 |
87 | dot :: (Element t) => Vector t -> Vector t -> t | 87 | dot :: (Element t) => Vector t -> Vector t -> t |
88 | dot u v = dat (multiply r c) `at` 0 | 88 | dot 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 | ||