diff options
Diffstat (limited to 'lib/Numeric')
-rw-r--r-- | lib/Numeric/LinearAlgebra/Algorithms.hs | 54 | ||||
-rw-r--r-- | lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c | 78 | ||||
-rw-r--r-- | lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h | 6 |
3 files changed, 1 insertions, 137 deletions
diff --git a/lib/Numeric/LinearAlgebra/Algorithms.hs b/lib/Numeric/LinearAlgebra/Algorithms.hs index 45298b5..e2fec9d 100644 --- a/lib/Numeric/LinearAlgebra/Algorithms.hs +++ b/lib/Numeric/LinearAlgebra/Algorithms.hs | |||
@@ -139,16 +139,8 @@ instance Field (Complex Double) where | |||
139 | qr = unpackQR . qrC | 139 | qr = unpackQR . qrC |
140 | hess = unpackHess hessC | 140 | hess = unpackHess hessC |
141 | schur = schurC | 141 | schur = schurC |
142 | |||
143 | #if defined(WORKAROUND) | ||
144 | multiply = mulCW | ||
145 | #else | ||
146 | #if defined(EXPOSEBUG) | ||
147 | multiply = multiplyC | ||
148 | #else | ||
149 | multiply = multiplyC3 | 142 | multiply = multiplyC3 |
150 | #endif | 143 | |
151 | #endif | ||
152 | 144 | ||
153 | -- | Eigenvalues and Eigenvectors of a complex hermitian or real symmetric matrix using lapack's dsyev or zheev. | 145 | -- | Eigenvalues and Eigenvectors of a complex hermitian or real symmetric matrix using lapack's dsyev or zheev. |
154 | -- | 146 | -- |
@@ -639,47 +631,3 @@ multiplyC3 x y = unsafePerformIO $ multiply3 zgemm "cblas_zgemm" (fmat x) (fmat | |||
639 | return s | 631 | return s |
640 | -- if toLists s== toLists s then return s else error $ "HORROR " ++ (show (toLists s)) | 632 | -- if toLists s== toLists s then return s else error $ "HORROR " ++ (show (toLists s)) |
641 | | otherwise = error $ st ++ " (matrix product) of nonconformant matrices" | 633 | | otherwise = error $ st ++ " (matrix product) of nonconformant matrices" |
642 | |||
643 | ----------------------------------------------------------------------------------- | ||
644 | -- BLAS via auxiliary C | ||
645 | ----------------------------------------------------------------------------------- | ||
646 | |||
647 | -- foreign import ccall "multiply.h multiplyR2" dgemmc :: TMMM | ||
648 | -- foreign import ccall "multiply.h multiplyC2" zgemmc :: TCMCMCM | ||
649 | -- | ||
650 | -- multiply2 f st a b | ||
651 | -- | cols a == rows b = unsafePerformIO $ do | ||
652 | -- s <- createMatrix ColumnMajor (rows a) (cols b) | ||
653 | -- app3 f mat a mat b mat s st | ||
654 | -- if toLists s== toLists s then return s else error $ "AYYY " ++ (show (toLists s)) | ||
655 | -- | otherwise = error $ st ++ " (matrix product) of nonconformant matrices" | ||
656 | -- | ||
657 | -- multiplyR2 :: Matrix Double -> Matrix Double -> Matrix Double | ||
658 | -- multiplyR2 a b = multiply2 dgemmc "dgemmc" (fmat a) (fmat b) | ||
659 | -- | ||
660 | -- multiplyC2 :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) | ||
661 | -- multiplyC2 a b = multiply2 zgemmc "zgemmc" (fmat a) (fmat b) | ||
662 | |||
663 | ----------------------------------------------------------------------------------- | ||
664 | -- direct C multiplication, to expose the NaN bug | ||
665 | ----------------------------------------------------------------------------------- | ||
666 | |||
667 | -- foreign import ccall "multiply.h multiplyR" cmultiplyR :: TMMM | ||
668 | foreign import ccall "multiply.h multiplyC" cmultiplyC :: TCMCMCM | ||
669 | |||
670 | cmultiply f st a b | ||
671 | -- | cols a == rows b = | ||
672 | = unsafePerformIO $ do | ||
673 | s <- createMatrix RowMajor (rows a) (cols b) | ||
674 | app3 f mat a mat b mat s st | ||
675 | if toLists s== toLists s | ||
676 | then return s | ||
677 | else error $ "NaN FOUND!! " ++ (show (toLists s)) | ||
678 | -- return s | ||
679 | -- | otherwise = error $ st ++ " (matrix product) of nonconformant matrices" | ||
680 | |||
681 | -- multiplyR :: Matrix Double -> Matrix Double -> Matrix Double | ||
682 | -- multiplyR a b = cmultiply cmultiplyR "cmultiplyR" (cmat a) (cmat b) | ||
683 | |||
684 | multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) | ||
685 | multiplyC a b = cmultiply cmultiplyC "cmultiplyR" (cmat a) (cmat b) | ||
diff --git a/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c b/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c index 61cb002..310f6ee 100644 --- a/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c +++ b/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c | |||
@@ -814,81 +814,3 @@ int lu_l_C(KCMAT(a), DVEC(ipiv), CMAT(r)) { | |||
814 | free(auxipiv); | 814 | free(auxipiv); |
815 | OK | 815 | OK |
816 | } | 816 | } |
817 | |||
818 | //////////////////////////////////////////////////////////// | ||
819 | |||
820 | // int multiplyR(KDMAT(a),KDMAT(b),DMAT(r)) { | ||
821 | // REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE); | ||
822 | // int i,j,k; | ||
823 | // for (i=0;i<ar;i++) { | ||
824 | // for(j=0;j<bc;j++) { | ||
825 | // double temp = 0; | ||
826 | // for(k=0;k<ac;k++) { | ||
827 | // temp += ap[i*ac+k]*bp[k*bc+j]; | ||
828 | // } | ||
829 | // rp[i*rc+j] = temp; | ||
830 | // } | ||
831 | // } | ||
832 | // OK | ||
833 | // } | ||
834 | |||
835 | |||
836 | int multiplyC(KCMAT(a),KCMAT(b),CMAT(r)) { | ||
837 | REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE); | ||
838 | int i,j,k; | ||
839 | for (i=0;i<ar;i++) { | ||
840 | for(j=0;j<bc;j++) { | ||
841 | doublecomplex temp = {0,0}; | ||
842 | for(k=0;k<ac;k++) { | ||
843 | doublecomplex A = ((doublecomplex*)ap)[i*ac+k]; | ||
844 | doublecomplex B = ((doublecomplex*)bp)[k*bc+j]; | ||
845 | double w = A.r * B.r - A.i * B.i; | ||
846 | double w1 = A.r * B.r; | ||
847 | double w2 = A.i * B.i; | ||
848 | if(w != w) { | ||
849 | printf("at : %d %d %d\n",i,j,k); | ||
850 | printf("%f %f %f\n",A.i,B.i, A.i * B.i); | ||
851 | printf("%f %f %f\n",A.i,B.i, w2); | ||
852 | exit(1); | ||
853 | } | ||
854 | temp.r += (w + w1-w2)/2; | ||
855 | //temp.r += w; | ||
856 | temp.i += A.r * B.i + A.i * B.r; | ||
857 | } | ||
858 | ((doublecomplex*)rp)[i*rc+j] = temp; | ||
859 | } | ||
860 | } | ||
861 | OK | ||
862 | } | ||
863 | |||
864 | // void dgemm_(char *, char *, integer *, integer *, integer *, | ||
865 | // double *, const double *, integer *, const double *, | ||
866 | // integer *, double *, double *, integer *); | ||
867 | // | ||
868 | // void zgemm_(char *, char *, integer *, integer *, integer *, | ||
869 | // doublecomplex *, const doublecomplex *, integer *, const doublecomplex *, | ||
870 | // integer *, doublecomplex *, doublecomplex *, integer *); | ||
871 | // | ||
872 | // | ||
873 | // int multiplyR2(KDMAT(a),KDMAT(b),DMAT(r)) { | ||
874 | // REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE); | ||
875 | // double alpha = 1; | ||
876 | // double beta = 0; | ||
877 | // integer m = ar; | ||
878 | // integer n = bc; | ||
879 | // integer k = ac; | ||
880 | // int i,j; | ||
881 | // dgemm_("N","N",&m,&n,&k,&alpha,ap,&m,bp,&k,&beta,rp,&m); | ||
882 | // OK | ||
883 | // } | ||
884 | // | ||
885 | // int multiplyC2(KCMAT(a),KCMAT(b),CMAT(r)) { | ||
886 | // REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE); | ||
887 | // integer m = ar; | ||
888 | // integer n = bc; | ||
889 | // integer k = ac; | ||
890 | // doublecomplex alpha = {1,0}; | ||
891 | // doublecomplex beta = {0,0}; | ||
892 | // zgemm_("N","N",&m,&n,&k,&alpha,(doublecomplex*)ap,&m,(doublecomplex*)bp,&k,&beta,(doublecomplex*)rp,&m); | ||
893 | // OK | ||
894 | // } | ||
diff --git a/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h b/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h index e8cba30..79e52be 100644 --- a/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h +++ b/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h | |||
@@ -84,9 +84,3 @@ int schur_l_C(KCMAT(a), CMAT(u), CMAT(s)); | |||
84 | 84 | ||
85 | int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r)); | 85 | int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r)); |
86 | int lu_l_C(KCMAT(a), DVEC(ipiv), CMAT(r)); | 86 | int lu_l_C(KCMAT(a), DVEC(ipiv), CMAT(r)); |
87 | |||
88 | // int multiplyR(KDMAT(a),KDMAT(b),DMAT(r)); | ||
89 | // int multiplyC(KCMAT(a),KCMAT(b),CMAT(r)); | ||
90 | |||
91 | // int multiplyR2(KDMAT(a),KDMAT(b),DMAT(r)); | ||
92 | int multiplyC2(KCMAT(a),KCMAT(b),CMAT(r)); | ||