summaryrefslogtreecommitdiff
path: root/lib/Numeric
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Numeric')
-rw-r--r--lib/Numeric/LinearAlgebra/Algorithms.hs54
-rw-r--r--lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c78
-rw-r--r--lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h6
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
668foreign import ccall "multiply.h multiplyC" cmultiplyC :: TCMCMCM
669
670cmultiply 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
684multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)
685multiplyC 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
836int 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
85int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r)); 85int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r));
86int lu_l_C(KCMAT(a), DVEC(ipiv), CMAT(r)); 86int 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));
92int multiplyC2(KCMAT(a),KCMAT(b),CMAT(r));