diff options
Diffstat (limited to 'packages/base')
-rw-r--r-- | packages/base/THANKS.md | 12 | ||||
-rw-r--r-- | packages/base/hmatrix.cabal | 4 | ||||
-rw-r--r-- | packages/base/src/Internal/Algorithms.hs | 86 | ||||
-rw-r--r-- | packages/base/src/Internal/C/lapack-aux.c | 156 | ||||
-rw-r--r-- | packages/base/src/Internal/LAPACK.hs | 52 | ||||
-rw-r--r-- | packages/base/src/Internal/Numeric.hs | 25 | ||||
-rw-r--r-- | packages/base/src/Internal/Util.hs | 9 | ||||
-rw-r--r-- | packages/base/src/Numeric/LinearAlgebra.hs | 5 |
8 files changed, 329 insertions, 20 deletions
diff --git a/packages/base/THANKS.md b/packages/base/THANKS.md index 7e82d40..45ded81 100644 --- a/packages/base/THANKS.md +++ b/packages/base/THANKS.md | |||
@@ -160,7 +160,7 @@ module reorganization, monadic mapVectorM, and many other improvements. | |||
160 | - Denis Laxalde separated the gsl tests from the base ones. | 160 | - Denis Laxalde separated the gsl tests from the base ones. |
161 | 161 | ||
162 | - Dominic Steinitz (idontgetoutmuch) reported a bug in the static diagonal creation functions and | 162 | - Dominic Steinitz (idontgetoutmuch) reported a bug in the static diagonal creation functions and |
163 | added Cholesky to Static. | 163 | added Cholesky to Static. He also added support for tridiagonal matrix solver. |
164 | 164 | ||
165 | - Dylan Thurston reported an error in the glpk documentation and ambiguity in | 165 | - Dylan Thurston reported an error in the glpk documentation and ambiguity in |
166 | the description of linearSolve. | 166 | the description of linearSolve. |
@@ -170,7 +170,8 @@ module reorganization, monadic mapVectorM, and many other improvements. | |||
170 | 170 | ||
171 | - Ian Ross reported the max/minIndex bug. | 171 | - Ian Ross reported the max/minIndex bug. |
172 | 172 | ||
173 | - Niklas Hambüchen improved the documentation. | 173 | - Niklas Hambüchen improved the documentation and fixed compilation with GHC-8.2 |
174 | adding type signatures. | ||
174 | 175 | ||
175 | - "erdeszt" optimized "conv" using a direct vector reverse. | 176 | - "erdeszt" optimized "conv" using a direct vector reverse. |
176 | 177 | ||
@@ -203,7 +204,8 @@ module reorganization, monadic mapVectorM, and many other improvements. | |||
203 | - Ilan Godik and Douglas McClean helped with Windows support. | 204 | - Ilan Godik and Douglas McClean helped with Windows support. |
204 | 205 | ||
205 | - Vassil Keremidchiev fixed the cabal options for OpenBlas, fixed several installation | 206 | - Vassil Keremidchiev fixed the cabal options for OpenBlas, fixed several installation |
206 | issues, and added support for stack-based build. | 207 | issues, and added support for stack-based build. He also added support for LTS 8.15 |
208 | under Windows. | ||
207 | 209 | ||
208 | - Greg Nwosu fixed arm compilation | 210 | - Greg Nwosu fixed arm compilation |
209 | 211 | ||
@@ -224,7 +226,9 @@ fixed the CPP issue in cabal files, and made many other contributions. | |||
224 | Andras Slemmer fixed the bug. Thank you all. | 226 | Andras Slemmer fixed the bug. Thank you all. |
225 | 227 | ||
226 | - Kevin Slagle implemented thinQR and thinRQ, much faster than the original qr, | 228 | - Kevin Slagle implemented thinQR and thinRQ, much faster than the original qr, |
227 | and added compactSVDTol. | 229 | and added compactSVDTol. He also added an optimized reorderVector for hTensor. |
228 | 230 | ||
229 | - "fedeinthemix" suggested a better name and a more general type for unitary. | 231 | - "fedeinthemix" suggested a better name and a more general type for unitary. |
230 | 232 | ||
233 | - Huw Campbell fixed a bug in equal. | ||
234 | |||
diff --git a/packages/base/hmatrix.cabal b/packages/base/hmatrix.cabal index 4d01e57..968a00e 100644 --- a/packages/base/hmatrix.cabal +++ b/packages/base/hmatrix.cabal | |||
@@ -1,5 +1,5 @@ | |||
1 | Name: hmatrix | 1 | Name: hmatrix |
2 | Version: 0.18.0.0 | 2 | Version: 0.18.1.0 |
3 | License: BSD3 | 3 | License: BSD3 |
4 | License-file: LICENSE | 4 | License-file: LICENSE |
5 | Author: Alberto Ruiz | 5 | Author: Alberto Ruiz |
@@ -130,7 +130,7 @@ library | |||
130 | 130 | ||
131 | if os(windows) | 131 | if os(windows) |
132 | if flag(openblas) | 132 | if flag(openblas) |
133 | extra-libraries: libopenblas, libgcc_s_seh-1, libgfortran-3, libquadmath-0 | 133 | extra-libraries: libopenblas, libgcc_s_seh-1, libgfortran, libquadmath-0 |
134 | else | 134 | else |
135 | extra-libraries: blas lapack | 135 | extra-libraries: blas lapack |
136 | 136 | ||
diff --git a/packages/base/src/Internal/Algorithms.hs b/packages/base/src/Internal/Algorithms.hs index 70d65d7..99c9e34 100644 --- a/packages/base/src/Internal/Algorithms.hs +++ b/packages/base/src/Internal/Algorithms.hs | |||
@@ -20,13 +20,16 @@ imported from "Numeric.LinearAlgebra.LAPACK". | |||
20 | -} | 20 | -} |
21 | ----------------------------------------------------------------------------- | 21 | ----------------------------------------------------------------------------- |
22 | 22 | ||
23 | module Internal.Algorithms where | 23 | module Internal.Algorithms ( |
24 | module Internal.Algorithms, | ||
25 | UpLo(..) | ||
26 | ) where | ||
24 | 27 | ||
25 | import Internal.Vector | 28 | import Internal.Vector |
26 | import Internal.Matrix | 29 | import Internal.Matrix |
27 | import Internal.Element | 30 | import Internal.Element |
28 | import Internal.Conversion | 31 | import Internal.Conversion |
29 | import Internal.LAPACK as LAPACK | 32 | import Internal.LAPACK |
30 | import Internal.Numeric | 33 | import Internal.Numeric |
31 | import Data.List(foldl1') | 34 | import Data.List(foldl1') |
32 | import qualified Data.Array as A | 35 | import qualified Data.Array as A |
@@ -58,6 +61,8 @@ class (Numeric t, | |||
58 | mbLinearSolve' :: Matrix t -> Matrix t -> Maybe (Matrix t) | 61 | mbLinearSolve' :: Matrix t -> Matrix t -> Maybe (Matrix t) |
59 | linearSolve' :: Matrix t -> Matrix t -> Matrix t | 62 | linearSolve' :: Matrix t -> Matrix t -> Matrix t |
60 | cholSolve' :: Matrix t -> Matrix t -> Matrix t | 63 | cholSolve' :: Matrix t -> Matrix t -> Matrix t |
64 | triSolve' :: UpLo -> Matrix t -> Matrix t -> Matrix t | ||
65 | triDiagSolve' :: Vector t -> Vector t -> Vector t -> Matrix t -> Matrix t | ||
61 | ldlPacked' :: Matrix t -> (Matrix t, [Int]) | 66 | ldlPacked' :: Matrix t -> (Matrix t, [Int]) |
62 | ldlSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t | 67 | ldlSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t |
63 | linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t | 68 | linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t |
@@ -83,6 +88,8 @@ instance Field Double where | |||
83 | linearSolve' = linearSolveR -- (luSolve . luPacked) ?? | 88 | linearSolve' = linearSolveR -- (luSolve . luPacked) ?? |
84 | mbLinearSolve' = mbLinearSolveR | 89 | mbLinearSolve' = mbLinearSolveR |
85 | cholSolve' = cholSolveR | 90 | cholSolve' = cholSolveR |
91 | triSolve' = triSolveR | ||
92 | triDiagSolve' = triDiagSolveR | ||
86 | linearSolveLS' = linearSolveLSR | 93 | linearSolveLS' = linearSolveLSR |
87 | linearSolveSVD' = linearSolveSVDR Nothing | 94 | linearSolveSVD' = linearSolveSVDR Nothing |
88 | eig' = eigR | 95 | eig' = eigR |
@@ -112,6 +119,8 @@ instance Field (Complex Double) where | |||
112 | linearSolve' = linearSolveC | 119 | linearSolve' = linearSolveC |
113 | mbLinearSolve' = mbLinearSolveC | 120 | mbLinearSolve' = mbLinearSolveC |
114 | cholSolve' = cholSolveC | 121 | cholSolve' = cholSolveC |
122 | triSolve' = triSolveC | ||
123 | triDiagSolve' = triDiagSolveC | ||
115 | linearSolveLS' = linearSolveLSC | 124 | linearSolveLS' = linearSolveLSC |
116 | linearSolveSVD' = linearSolveSVDC Nothing | 125 | linearSolveSVD' = linearSolveSVDC Nothing |
117 | eig' = eigC | 126 | eig' = eigC |
@@ -350,6 +359,79 @@ cholSolve | |||
350 | -> Matrix t -- ^ solution | 359 | -> Matrix t -- ^ solution |
351 | cholSolve = {-# SCC "cholSolve" #-} cholSolve' | 360 | cholSolve = {-# SCC "cholSolve" #-} cholSolve' |
352 | 361 | ||
362 | -- | Solve a triangular linear system. If `Upper` is specified then | ||
363 | -- all elements below the diagonal are ignored; if `Lower` is | ||
364 | -- specified then all elements above the diagonal are ignored. | ||
365 | triSolve | ||
366 | :: Field t | ||
367 | => UpLo -- ^ `Lower` or `Upper` | ||
368 | -> Matrix t -- ^ coefficient matrix | ||
369 | -> Matrix t -- ^ right hand sides | ||
370 | -> Matrix t -- ^ solution | ||
371 | triSolve = {-# SCC "triSolve" #-} triSolve' | ||
372 | |||
373 | -- | Solve a tridiagonal linear system. Suppose you wish to solve \(Ax = b\) where | ||
374 | -- | ||
375 | -- \[ | ||
376 | -- A = | ||
377 | -- \begin{bmatrix} | ||
378 | -- 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 | ||
379 | -- \\ 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 | ||
380 | -- \\ 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 | ||
381 | -- \\ 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 | ||
382 | -- \\ 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 | ||
383 | -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 | ||
384 | -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 | ||
385 | -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 | ||
386 | -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 | ||
387 | -- \end{bmatrix} | ||
388 | -- \quad | ||
389 | -- b = | ||
390 | -- \begin{bmatrix} | ||
391 | -- 1.0 & 1.0 & 1.0 | ||
392 | -- \\ 1.0 & -1.0 & 2.0 | ||
393 | -- \\ 1.0 & 1.0 & 3.0 | ||
394 | -- \\ 1.0 & -1.0 & 4.0 | ||
395 | -- \\ 1.0 & 1.0 & 5.0 | ||
396 | -- \\ 1.0 & -1.0 & 6.0 | ||
397 | -- \\ 1.0 & 1.0 & 7.0 | ||
398 | -- \\ 1.0 & -1.0 & 8.0 | ||
399 | -- \\ 1.0 & 1.0 & 9.0 | ||
400 | -- \end{bmatrix} | ||
401 | -- \] | ||
402 | -- | ||
403 | -- then | ||
404 | -- | ||
405 | -- @ | ||
406 | -- dL = fromList [3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0] | ||
407 | -- d = fromList [1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0] | ||
408 | -- dU = fromList [4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0] | ||
409 | -- | ||
410 | -- b = (9><3) | ||
411 | -- [ | ||
412 | -- 1.0, 1.0, 1.0, | ||
413 | -- 1.0, -1.0, 2.0, | ||
414 | -- 1.0, 1.0, 3.0, | ||
415 | -- 1.0, -1.0, 4.0, | ||
416 | -- 1.0, 1.0, 5.0, | ||
417 | -- 1.0, -1.0, 6.0, | ||
418 | -- 1.0, 1.0, 7.0, | ||
419 | -- 1.0, -1.0, 8.0, | ||
420 | -- 1.0, 1.0, 9.0 | ||
421 | -- ] | ||
422 | -- | ||
423 | -- x = triDiagSolve dL d dU b | ||
424 | -- @ | ||
425 | -- | ||
426 | triDiagSolve | ||
427 | :: Field t | ||
428 | => Vector t -- ^ lower diagonal: \(n - 1\) elements | ||
429 | -> Vector t -- ^ diagonal: \(n\) elements | ||
430 | -> Vector t -- ^ upper diagonal: \(n - 1\) elements | ||
431 | -> Matrix t -- ^ right hand sides | ||
432 | -> Matrix t -- ^ solution | ||
433 | triDiagSolve = {-# SCC "triDiagSolve" #-} triDiagSolve' | ||
434 | |||
353 | -- | 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. | 435 | -- | 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. |
354 | linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t | 436 | linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t |
355 | linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD' | 437 | linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD' |
diff --git a/packages/base/src/Internal/C/lapack-aux.c b/packages/base/src/Internal/C/lapack-aux.c index ff7ad92..5018a45 100644 --- a/packages/base/src/Internal/C/lapack-aux.c +++ b/packages/base/src/Internal/C/lapack-aux.c | |||
@@ -584,6 +584,162 @@ int cholSolveC_l(KOCMAT(a),OCMAT(b)) { | |||
584 | OK | 584 | OK |
585 | } | 585 | } |
586 | 586 | ||
587 | //////// triangular real linear system //////////// | ||
588 | |||
589 | int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, | ||
590 | doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * | ||
591 | info); | ||
592 | |||
593 | int triSolveR_l_u(KODMAT(a),ODMAT(b)) { | ||
594 | integer n = ar; | ||
595 | integer lda = aXc; | ||
596 | integer nhrs = bc; | ||
597 | REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); | ||
598 | DEBUGMSG("triSolveR_l_u"); | ||
599 | integer res; | ||
600 | dtrtrs_ ("U", | ||
601 | "N", | ||
602 | "N", | ||
603 | &n,&nhrs, | ||
604 | (double*)ap, &lda, | ||
605 | bp, &n, | ||
606 | &res); | ||
607 | CHECK(res,res); | ||
608 | OK | ||
609 | } | ||
610 | |||
611 | int triSolveR_l_l(KODMAT(a),ODMAT(b)) { | ||
612 | integer n = ar; | ||
613 | integer lda = aXc; | ||
614 | integer nhrs = bc; | ||
615 | REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); | ||
616 | DEBUGMSG("triSolveR_l_l"); | ||
617 | integer res; | ||
618 | dtrtrs_ ("L", | ||
619 | "N", | ||
620 | "N", | ||
621 | &n,&nhrs, | ||
622 | (double*)ap, &lda, | ||
623 | bp, &n, | ||
624 | &res); | ||
625 | CHECK(res,res); | ||
626 | OK | ||
627 | } | ||
628 | |||
629 | //////// triangular complex linear system //////////// | ||
630 | |||
631 | int ztrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, | ||
632 | doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, | ||
633 | integer *info); | ||
634 | |||
635 | int triSolveC_l_u(KOCMAT(a),OCMAT(b)) { | ||
636 | integer n = ar; | ||
637 | integer lda = aXc; | ||
638 | integer nhrs = bc; | ||
639 | REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); | ||
640 | DEBUGMSG("triSolveC_l_u"); | ||
641 | integer res; | ||
642 | ztrtrs_ ("U", | ||
643 | "N", | ||
644 | "N", | ||
645 | &n,&nhrs, | ||
646 | (doublecomplex*)ap, &lda, | ||
647 | bp, &n, | ||
648 | &res); | ||
649 | CHECK(res,res); | ||
650 | OK | ||
651 | } | ||
652 | |||
653 | int triSolveC_l_l(KOCMAT(a),OCMAT(b)) { | ||
654 | integer n = ar; | ||
655 | integer lda = aXc; | ||
656 | integer nhrs = bc; | ||
657 | REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); | ||
658 | DEBUGMSG("triSolveC_l_u"); | ||
659 | integer res; | ||
660 | ztrtrs_ ("L", | ||
661 | "N", | ||
662 | "N", | ||
663 | &n,&nhrs, | ||
664 | (doublecomplex*)ap, &lda, | ||
665 | bp, &n, | ||
666 | &res); | ||
667 | CHECK(res,res); | ||
668 | OK | ||
669 | } | ||
670 | |||
671 | //////// tridiagonal real linear system //////////// | ||
672 | |||
673 | int dgttrf_(integer *n, | ||
674 | doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, | ||
675 | integer *ipiv, | ||
676 | integer *info); | ||
677 | |||
678 | int dgttrs_(char *trans, integer *n, integer *nrhs, | ||
679 | doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, | ||
680 | integer *ipiv, doublereal *b, integer *ldb, | ||
681 | integer *info); | ||
682 | |||
683 | int triDiagSolveR_l(DVEC(dl), DVEC(d), DVEC(du), ODMAT(b)) { | ||
684 | integer n = dn; | ||
685 | integer nhrs = bc; | ||
686 | REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE); | ||
687 | DEBUGMSG("triDiagSolveR_l"); | ||
688 | integer res; | ||
689 | integer* ipiv = (integer*)malloc(n*sizeof(integer)); | ||
690 | double* du2 = (double*)malloc((n - 2)*sizeof(double)); | ||
691 | dgttrf_ (&n, | ||
692 | dlp, dp, dup, du2, | ||
693 | ipiv, | ||
694 | &res); | ||
695 | CHECK(res,res); | ||
696 | dgttrs_ ("N", | ||
697 | &n,&nhrs, | ||
698 | dlp, dp, dup, du2, | ||
699 | ipiv, bp, &n, | ||
700 | &res); | ||
701 | CHECK(res,res); | ||
702 | free(ipiv); | ||
703 | free(du2); | ||
704 | OK | ||
705 | } | ||
706 | |||
707 | //////// tridiagonal complex linear system //////////// | ||
708 | |||
709 | int zgttrf_(integer *n, | ||
710 | doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, | ||
711 | integer *ipiv, | ||
712 | integer *info); | ||
713 | |||
714 | int zgttrs_(char *trans, integer *n, integer *nrhs, | ||
715 | doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, | ||
716 | integer *ipiv, doublecomplex *b, integer *ldb, | ||
717 | integer *info); | ||
718 | |||
719 | int triDiagSolveC_l(CVEC(dl), CVEC(d), CVEC(du), OCMAT(b)) { | ||
720 | integer n = dn; | ||
721 | integer nhrs = bc; | ||
722 | REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE); | ||
723 | DEBUGMSG("triDiagSolveC_l"); | ||
724 | integer res; | ||
725 | integer* ipiv = (integer*)malloc(n*sizeof(integer)); | ||
726 | doublecomplex* du2 = (doublecomplex*)malloc((n - 2)*sizeof(doublecomplex)); | ||
727 | zgttrf_ (&n, | ||
728 | dlp, dp, dup, du2, | ||
729 | ipiv, | ||
730 | &res); | ||
731 | CHECK(res,res); | ||
732 | zgttrs_ ("N", | ||
733 | &n,&nhrs, | ||
734 | dlp, dp, dup, du2, | ||
735 | ipiv, bp, &n, | ||
736 | &res); | ||
737 | CHECK(res,res); | ||
738 | free(ipiv); | ||
739 | free(du2); | ||
740 | OK | ||
741 | } | ||
742 | |||
587 | //////////////////// least squares real linear system //////////// | 743 | //////////////////// least squares real linear system //////////// |
588 | 744 | ||
589 | int dgels_(char *trans, integer *m, integer *n, integer * | 745 | int dgels_(char *trans, integer *m, integer *n, integer * |
diff --git a/packages/base/src/Internal/LAPACK.hs b/packages/base/src/Internal/LAPACK.hs index 231109a..e306454 100644 --- a/packages/base/src/Internal/LAPACK.hs +++ b/packages/base/src/Internal/LAPACK.hs | |||
@@ -406,6 +406,58 @@ cholSolveR a b = linearSolveSQAux2 id dpotrs "cholSolveR" (fmat a) b | |||
406 | cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) | 406 | cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) |
407 | cholSolveC a b = linearSolveSQAux2 id zpotrs "cholSolveC" (fmat a) b | 407 | cholSolveC a b = linearSolveSQAux2 id zpotrs "cholSolveC" (fmat a) b |
408 | 408 | ||
409 | -------------------------------------------------------------------------------- | ||
410 | foreign import ccall unsafe "triSolveR_l_u" dtrtrs_u :: R ::> R ::> Ok | ||
411 | foreign import ccall unsafe "triSolveC_l_u" ztrtrs_u :: C ::> C ::> Ok | ||
412 | foreign import ccall unsafe "triSolveR_l_l" dtrtrs_l :: R ::> R ::> Ok | ||
413 | foreign import ccall unsafe "triSolveC_l_l" ztrtrs_l :: C ::> C ::> Ok | ||
414 | |||
415 | |||
416 | linearSolveTRAux2 g f st a b | ||
417 | | n1==n2 && n1==r = unsafePerformIO . g $ do | ||
418 | s <- copy ColumnMajor b | ||
419 | (a #! s) f #| st | ||
420 | return s | ||
421 | | otherwise = error $ st ++ " of nonsquare matrix" | ||
422 | where | ||
423 | n1 = rows a | ||
424 | n2 = cols a | ||
425 | r = rows b | ||
426 | |||
427 | data UpLo = Lower | Upper | ||
428 | |||
429 | -- | Solves a triangular system of linear equations. | ||
430 | triSolveR :: UpLo -> Matrix Double -> Matrix Double -> Matrix Double | ||
431 | triSolveR Lower a b = linearSolveTRAux2 id dtrtrs_l "triSolveR" (fmat a) b | ||
432 | triSolveR Upper a b = linearSolveTRAux2 id dtrtrs_u "triSolveR" (fmat a) b | ||
433 | |||
434 | -- | Solves a triangular system of linear equations. | ||
435 | triSolveC :: UpLo -> Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) | ||
436 | triSolveC Lower a b = linearSolveTRAux2 id ztrtrs_l "triSolveC" (fmat a) b | ||
437 | triSolveC Upper a b = linearSolveTRAux2 id ztrtrs_u "triSolveC" (fmat a) b | ||
438 | |||
439 | -------------------------------------------------------------------------------- | ||
440 | foreign import ccall unsafe "triDiagSolveR_l" dgttrs :: R :> R :> R :> R ::> Ok | ||
441 | foreign import ccall unsafe "triDiagSolveC_l" zgttrs :: C :> C :> C :> C ::> Ok | ||
442 | |||
443 | linearSolveGTAux2 g f st dl d du b | ||
444 | | ndl == nd - 1 && | ||
445 | ndu == nd - 1 && | ||
446 | nd == r = unsafePerformIO . g $ do | ||
447 | s <- copy ColumnMajor b | ||
448 | (dl # d # du #! s) f #| st | ||
449 | return s | ||
450 | | otherwise = error $ st ++ " of nonsquare matrix" | ||
451 | where | ||
452 | ndl = dim dl | ||
453 | nd = dim d | ||
454 | ndu = dim du | ||
455 | r = rows b | ||
456 | |||
457 | -- | Solves a tridiagonal system of linear equations. | ||
458 | triDiagSolveR dl d du b = linearSolveGTAux2 id dgttrs "triDiagSolveR" dl d du b | ||
459 | triDiagSolveC dl d du b = linearSolveGTAux2 id zgttrs "triDiagSolveC" dl d du b | ||
460 | |||
409 | ----------------------------------------------------------------------------------- | 461 | ----------------------------------------------------------------------------------- |
410 | 462 | ||
411 | foreign import ccall unsafe "linearSolveLSR_l" dgels :: R ::> R ::> Ok | 463 | foreign import ccall unsafe "linearSolveLSR_l" dgels :: R ::> R ::> Ok |
diff --git a/packages/base/src/Internal/Numeric.hs b/packages/base/src/Internal/Numeric.hs index dd74165..c9ef0c5 100644 --- a/packages/base/src/Internal/Numeric.hs +++ b/packages/base/src/Internal/Numeric.hs | |||
@@ -25,6 +25,7 @@ import Internal.Conversion | |||
25 | import Internal.Vectorized | 25 | import Internal.Vectorized |
26 | import Internal.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ,multiplyI,multiplyL) | 26 | import Internal.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ,multiplyI,multiplyL) |
27 | import Data.List.Split(chunksOf) | 27 | import Data.List.Split(chunksOf) |
28 | import qualified Data.Vector.Storable as V | ||
28 | 29 | ||
29 | -------------------------------------------------------------------------------- | 30 | -------------------------------------------------------------------------------- |
30 | 31 | ||
@@ -102,8 +103,8 @@ instance Container Vector I | |||
102 | add' = vectorZipI Add | 103 | add' = vectorZipI Add |
103 | sub = vectorZipI Sub | 104 | sub = vectorZipI Sub |
104 | mul = vectorZipI Mul | 105 | mul = vectorZipI Mul |
105 | equal u v = dim u == dim v && maxElement' (vectorMapI Abs (sub u v)) == 0 | 106 | equal = (==) |
106 | scalar' x = fromList [x] | 107 | scalar' = V.singleton |
107 | konst' = constantD | 108 | konst' = constantD |
108 | build' = buildV | 109 | build' = buildV |
109 | cmap' = mapVector | 110 | cmap' = mapVector |
@@ -141,8 +142,8 @@ instance Container Vector Z | |||
141 | add' = vectorZipL Add | 142 | add' = vectorZipL Add |
142 | sub = vectorZipL Sub | 143 | sub = vectorZipL Sub |
143 | mul = vectorZipL Mul | 144 | mul = vectorZipL Mul |
144 | equal u v = dim u == dim v && maxElement' (vectorMapL Abs (sub u v)) == 0 | 145 | equal = (==) |
145 | scalar' x = fromList [x] | 146 | scalar' = V.singleton |
146 | konst' = constantD | 147 | konst' = constantD |
147 | build' = buildV | 148 | build' = buildV |
148 | cmap' = mapVector | 149 | cmap' = mapVector |
@@ -181,8 +182,8 @@ instance Container Vector Float | |||
181 | add' = vectorZipF Add | 182 | add' = vectorZipF Add |
182 | sub = vectorZipF Sub | 183 | sub = vectorZipF Sub |
183 | mul = vectorZipF Mul | 184 | mul = vectorZipF Mul |
184 | equal u v = dim u == dim v && maxElement (vectorMapF Abs (sub u v)) == 0.0 | 185 | equal = (==) |
185 | scalar' x = fromList [x] | 186 | scalar' = V.singleton |
186 | konst' = constantD | 187 | konst' = constantD |
187 | build' = buildV | 188 | build' = buildV |
188 | cmap' = mapVector | 189 | cmap' = mapVector |
@@ -218,8 +219,8 @@ instance Container Vector Double | |||
218 | add' = vectorZipR Add | 219 | add' = vectorZipR Add |
219 | sub = vectorZipR Sub | 220 | sub = vectorZipR Sub |
220 | mul = vectorZipR Mul | 221 | mul = vectorZipR Mul |
221 | equal u v = dim u == dim v && maxElement (vectorMapR Abs (sub u v)) == 0.0 | 222 | equal = (==) |
222 | scalar' x = fromList [x] | 223 | scalar' = V.singleton |
223 | konst' = constantD | 224 | konst' = constantD |
224 | build' = buildV | 225 | build' = buildV |
225 | cmap' = mapVector | 226 | cmap' = mapVector |
@@ -255,8 +256,8 @@ instance Container Vector (Complex Double) | |||
255 | add' = vectorZipC Add | 256 | add' = vectorZipC Add |
256 | sub = vectorZipC Sub | 257 | sub = vectorZipC Sub |
257 | mul = vectorZipC Mul | 258 | mul = vectorZipC Mul |
258 | equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 | 259 | equal = (==) |
259 | scalar' x = fromList [x] | 260 | scalar' = V.singleton |
260 | konst' = constantD | 261 | konst' = constantD |
261 | build' = buildV | 262 | build' = buildV |
262 | cmap' = mapVector | 263 | cmap' = mapVector |
@@ -291,8 +292,8 @@ instance Container Vector (Complex Float) | |||
291 | add' = vectorZipQ Add | 292 | add' = vectorZipQ Add |
292 | sub = vectorZipQ Sub | 293 | sub = vectorZipQ Sub |
293 | mul = vectorZipQ Mul | 294 | mul = vectorZipQ Mul |
294 | equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 | 295 | equal = (==) |
295 | scalar' x = fromList [x] | 296 | scalar' = V.singleton |
296 | konst' = constantD | 297 | konst' = constantD |
297 | build' = buildV | 298 | build' = buildV |
298 | cmap' = mapVector | 299 | cmap' = mapVector |
diff --git a/packages/base/src/Internal/Util.hs b/packages/base/src/Internal/Util.hs index 17d3e50..ec21fe4 100644 --- a/packages/base/src/Internal/Util.hs +++ b/packages/base/src/Internal/Util.hs | |||
@@ -2,6 +2,7 @@ | |||
2 | {-# LANGUAGE FlexibleInstances #-} | 2 | {-# LANGUAGE FlexibleInstances #-} |
3 | {-# LANGUAGE MultiParamTypeClasses #-} | 3 | {-# LANGUAGE MultiParamTypeClasses #-} |
4 | {-# LANGUAGE FunctionalDependencies #-} | 4 | {-# LANGUAGE FunctionalDependencies #-} |
5 | {-# LANGUAGE ScopedTypeVariables #-} | ||
5 | {-# LANGUAGE ViewPatterns #-} | 6 | {-# LANGUAGE ViewPatterns #-} |
6 | 7 | ||
7 | 8 | ||
@@ -613,6 +614,9 @@ gaussElim_1 x y = dropColumns (rows x) (flipud $ fromRows s2) | |||
613 | s1 = fromRows $ pivotDown (rows x) 0 rs -- interesting | 614 | s1 = fromRows $ pivotDown (rows x) 0 rs -- interesting |
614 | s2 = pivotUp (rows x-1) (toRows $ flipud s1) | 615 | s2 = pivotUp (rows x-1) (toRows $ flipud s1) |
615 | 616 | ||
617 | pivotDown | ||
618 | :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t) | ||
619 | => Int -> Int -> [Vector t] -> [Vector t] | ||
616 | pivotDown t n xs | 620 | pivotDown t n xs |
617 | | t == n = [] | 621 | | t == n = [] |
618 | | otherwise = y : pivotDown t (n+1) ys | 622 | | otherwise = y : pivotDown t (n+1) ys |
@@ -622,6 +626,7 @@ pivotDown t n xs | |||
622 | pivot k = (const k &&& id) | 626 | pivot k = (const k &&& id) |
623 | . sortBy (flip compare `on` (abs. (!k))) | 627 | . sortBy (flip compare `on` (abs. (!k))) |
624 | 628 | ||
629 | redu :: (Int, [Vector t]) -> [Vector t] | ||
625 | redu (k,x:zs) | 630 | redu (k,x:zs) |
626 | | p == 0 = error "gauss: singular!" -- FIXME | 631 | | p == 0 = error "gauss: singular!" -- FIXME |
627 | | otherwise = u : map f zs | 632 | | otherwise = u : map f zs |
@@ -632,12 +637,16 @@ pivotDown t n xs | |||
632 | redu (_,[]) = [] | 637 | redu (_,[]) = [] |
633 | 638 | ||
634 | 639 | ||
640 | pivotUp | ||
641 | :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t) | ||
642 | => Int -> [Vector t] -> [Vector t] | ||
635 | pivotUp n xs | 643 | pivotUp n xs |
636 | | n == -1 = [] | 644 | | n == -1 = [] |
637 | | otherwise = y : pivotUp (n-1) ys | 645 | | otherwise = y : pivotUp (n-1) ys |
638 | where | 646 | where |
639 | y:ys = redu' (n,xs) | 647 | y:ys = redu' (n,xs) |
640 | 648 | ||
649 | redu' :: (Int, [Vector t]) -> [Vector t] | ||
641 | redu' (k,x:zs) = u : map f zs | 650 | redu' (k,x:zs) = u : map f zs |
642 | where | 651 | where |
643 | u = x | 652 | u = x |
diff --git a/packages/base/src/Numeric/LinearAlgebra.hs b/packages/base/src/Numeric/LinearAlgebra.hs index badf8f9..fd100e0 100644 --- a/packages/base/src/Numeric/LinearAlgebra.hs +++ b/packages/base/src/Numeric/LinearAlgebra.hs | |||
@@ -94,6 +94,11 @@ module Numeric.LinearAlgebra ( | |||
94 | ldlSolve, ldlPacked, | 94 | ldlSolve, ldlPacked, |
95 | -- ** Positive definite | 95 | -- ** Positive definite |
96 | cholSolve, | 96 | cholSolve, |
97 | -- ** Triangular | ||
98 | UpLo(..), | ||
99 | triSolve, | ||
100 | -- ** Tridiagonal | ||
101 | triDiagSolve, | ||
97 | -- ** Sparse | 102 | -- ** Sparse |
98 | cgSolve, | 103 | cgSolve, |
99 | cgSolve', | 104 | cgSolve', |