diff options
Diffstat (limited to 'packages/base/src')
-rw-r--r-- | packages/base/src/Internal/Algorithms.hs | 18 | ||||
-rw-r--r-- | packages/base/src/Internal/Modular.hs | 2 | ||||
-rw-r--r-- | packages/base/src/Numeric/LinearAlgebra.hs | 1 |
3 files changed, 16 insertions, 5 deletions
diff --git a/packages/base/src/Internal/Algorithms.hs b/packages/base/src/Internal/Algorithms.hs index d2f17f4..ee3ddff 100644 --- a/packages/base/src/Internal/Algorithms.hs +++ b/packages/base/src/Internal/Algorithms.hs | |||
@@ -470,17 +470,25 @@ eigenvaluesSH (Her m) = eigenvaluesSH' m | |||
470 | 470 | ||
471 | -------------------------------------------------------------- | 471 | -------------------------------------------------------------- |
472 | 472 | ||
473 | -- | QR decomposition of a matrix in compact form. (The orthogonal matrix is not explicitly formed.) | ||
474 | data QR t = QR (Matrix t) (Vector t) | ||
475 | |||
473 | -- | QR factorization. | 476 | -- | QR factorization. |
474 | -- | 477 | -- |
475 | -- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular. | 478 | -- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular. |
476 | qr :: Field t => Matrix t -> (Matrix t, Matrix t) | 479 | qr :: Field t => Matrix t -> (Matrix t, Matrix t) |
477 | qr = {-# SCC "qr" #-} unpackQR . qr' | 480 | qr = {-# SCC "qr" #-} unpackQR . qr' |
478 | 481 | ||
479 | qrRaw m = qr' m | 482 | -- | Compute the QR decomposition of a matrix in compact form. |
483 | qrRaw :: Field t => Matrix t -> QR t | ||
484 | qrRaw m = QR x v | ||
485 | where | ||
486 | (x,v) = qr' m | ||
480 | 487 | ||
481 | {- | generate a matrix with k orthogonal columns from the output of qrRaw | 488 | -- | generate a matrix with k orthogonal columns from the compact QR decomposition obtained by 'qrRaw'. |
482 | -} | 489 | -- |
483 | qrgr n (a,t) | 490 | qrgr :: Field t => Int -> QR t -> Matrix t |
491 | qrgr n (QR a t) | ||
484 | | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)" | 492 | | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)" |
485 | | otherwise = qrgr' n (a,t) | 493 | | otherwise = qrgr' n (a,t) |
486 | 494 | ||
@@ -870,6 +878,8 @@ fixPerm' s = res $ mutable f s0 | |||
870 | triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]] | 878 | triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]] |
871 | where el p q = if q-p>=h then v else 1 - v | 879 | where el p q = if q-p>=h then v else 1 - v |
872 | 880 | ||
881 | -- | Compute the explicit LU decomposition from the compact one obtained by 'luPacked'. | ||
882 | luFact :: Numeric t => LU t -> (Matrix t, Matrix t, Matrix t, t) | ||
873 | luFact (LU l_u perm) | 883 | luFact (LU l_u perm) |
874 | | r <= c = (l ,u ,p, s) | 884 | | r <= c = (l ,u ,p, s) |
875 | | otherwise = (l',u',p, s) | 885 | | otherwise = (l',u',p, s) |
diff --git a/packages/base/src/Internal/Modular.hs b/packages/base/src/Internal/Modular.hs index a3421a8..239c742 100644 --- a/packages/base/src/Internal/Modular.hs +++ b/packages/base/src/Internal/Modular.hs | |||
@@ -371,7 +371,7 @@ test = (ok, info) | |||
371 | 371 | ||
372 | checkLU okf t = norm_Inf $ flatten (l <> u <> p - t) | 372 | checkLU okf t = norm_Inf $ flatten (l <> u <> p - t) |
373 | where | 373 | where |
374 | (l,u,p,_ :: Int) = luFact (LU x' p') | 374 | (l,u,p,_) = luFact (LU x' p') |
375 | where | 375 | where |
376 | (x',p') = mutable (luST okf) t | 376 | (x',p') = mutable (luST okf) t |
377 | 377 | ||
diff --git a/packages/base/src/Numeric/LinearAlgebra.hs b/packages/base/src/Numeric/LinearAlgebra.hs index 7be2600..a1c0158 100644 --- a/packages/base/src/Numeric/LinearAlgebra.hs +++ b/packages/base/src/Numeric/LinearAlgebra.hs | |||
@@ -162,6 +162,7 @@ module Numeric.LinearAlgebra ( | |||
162 | Transposable, | 162 | Transposable, |
163 | LU(..), | 163 | LU(..), |
164 | LDL(..), | 164 | LDL(..), |
165 | QR(..), | ||
165 | CGState(..), | 166 | CGState(..), |
166 | Testable(..) | 167 | Testable(..) |
167 | ) where | 168 | ) where |