From jivestgarden at common-lisp.net Mon Nov 2 20:06:51 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Mon, 02 Nov 2009 15:06:51 -0500 Subject: [lisplab-cvs] r107 - src/matrix Message-ID: Author: jivestgarden Date: Mon Nov 2 15:06:51 2009 New Revision: 107 Log: In the middle of refactoring. May not work Added: src/matrix/store-operators.lisp src/matrix/store-ordinary-functions.lisp Modified: lisplab.asd src/matrix/level1-util.lisp src/matrix/level2-matrix-dge.lisp src/matrix/level2-matrix-zge.lisp Modified: lisplab.asd ============================================================================== --- lisplab.asd (original) +++ lisplab.asd Mon Nov 2 15:06:51 2009 @@ -62,7 +62,12 @@ :components ( (:file "level1-interface") - (:file "level1-util") + + ;; These three should be independent of the rest + (:file "level1-util") + (:file "store-operators") + (:file "store-ordinary-functions") + (:file "level1-classes") (:file "level1-constructors") (:file "level1-matrix") Modified: src/matrix/level1-util.lisp ============================================================================== --- src/matrix/level1-util.lisp (original) +++ src/matrix/level1-util.lisp Mon Nov 2 15:06:51 2009 @@ -19,9 +19,19 @@ ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; TODO: change name of this to something about blas store +;;; +;;; This file contains manipulations of simple double-float arrays +;;; and should be called by the spesialized matrix methods. +;;; The purpose of this layer is that it can be used by +;;; many classes such as matrix-base-dge and matrix-base-ddi, etc. +;;; +;;; The content of this file must be highly optimized +;;; and should not depend anything exept Common Lisp itself. (in-package :lisplab) +;;; Things that are common both for real and complex stores + (deftype type-blas-store () '(simple-array double-float (*))) @@ -32,10 +42,7 @@ #-:sbcl (deftype type-blas-idx () 'fixnum) - (declaim (inline column-major-idx)) -(declaim (inline ref-blas-real-store (setf ref-blas-real-store))) -(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store))) (declaim (ftype (function (type-blas-idx @@ -44,6 +51,21 @@ type-blas-idx) column-major-idx)) +(defun column-major-idx (i j rows) + (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows))))) + +(defun copy-matrix-stores (a b) + (let ((len (length a))) + (declare (type type-blas-store a b) + (type type-blas-idx len)) + (dotimes (i len) + (setf (aref b i) (aref a i)))) + b) + +;;;; The real store + +(declaim (inline ref-blas-real-store (setf ref-blas-real-store))) + (declaim (ftype (function (type-blas-store type-blas-idx @@ -52,6 +74,14 @@ double-float) ref-blas-real-store)) +(defun ref-blas-real-store (store row col rows) + "Matrix accessor for the real blas store" + (aref (truly-the type-blas-store store) + (truly-the type-blas-idx + (column-major-idx (truly-the type-blas-idx row) + (truly-the type-blas-idx col) + rows)))) + (declaim (ftype (function (double-float type-blas-store @@ -61,35 +91,6 @@ ) double-float) (setf ref-blas-real-store))) -(declaim (ftype (function - (type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx) - (complex double-float)) - ref-blas-complex-store)) - -(declaim (ftype (function - ((complex double-float) - type-blas-store - type-blas-idx - type-blas-idx - type-blas-idx - ) - (complex double-float)) - (setf ref-blas-complex-store))) - -(defun column-major-idx (i j rows) - (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows))))) - -(defun ref-blas-real-store (store row col rows) - "Accessor for the real blas store" - (aref (truly-the type-blas-store store) - (truly-the type-blas-idx - (column-major-idx (truly-the type-blas-idx row) - (truly-the type-blas-idx col) - rows)))) - (defun (setf ref-blas-real-store) (value store row col rows) (setf (aref (truly-the type-blas-store store) @@ -101,11 +102,13 @@ value) (defun allocate-real-store (size &optional (initial-element 0.0)) + ;; All matrix double and complex double constructors + ;; should call this one (let ((x (coerce initial-element 'double-float))) (declare (type double-float x) (type type-blas-idx size)) - ;; Stupid efficiency hack, on SBCL. All matrix double and complex double - ;; should call this one + ;; Stupid efficiency hack for SBCL. Allocations of arrays with zeros + ;; is significantly faster than others! (if (= x 0.0) (make-array size :element-type 'double-float @@ -113,9 +116,55 @@ (make-array size :element-type 'double-float :initial-element x)))) - + +;;; Hopfully helpful iterators + +(defmacro with-indices-df-1 (a m idx &body body) + "Iterats over all the indices of one array" + `(let ((,m ,a)) + (declare (type type-blas-store ,m)) + (dotimes (,idx (length ,m)) + (declare (type type-blas-idx ,idx)) + , at body))) + +(defmacro with-elements-df-1 (a elm &body body) + "Iterats over all the elements of one array" + (let ((m (gensym)) + (idx (gensym))) + `(let ((,m ,a)) + (declare (type type-blas-store ,m)) + (dotimes (,idx (length ,m)) + (declare (type type-blas-idx ,idx)) + (let ((,elm (aref ,m ,idx))) + (declare (type double-float ,elm)) + , at body))))) + +;;;; The complex store + +(defun allocate-complex-store (size &optional (value 0.0)) + (let* ((2size (* 2 size)) + (rv (coerce (realpart value) 'double-float)) + (iv (coerce (imagpart value) 'double-float)) + (store (allocate-real-store 2size iv))) + (declare (type type-blas-idx 2size) + (type double-float rv iv)) + (when (/= rv iv) + (loop for i from 0 below 2size by 2 do + (setf (aref store i) rv))) + store)) + +(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store))) + +(declaim (ftype (function + (type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx) + (complex double-float)) + ref-blas-complex-store)) + (defun ref-blas-complex-store (store row col rows) - "Accessor for the complet blas store" + "Matrix accessor for the complet blas store" (let ((idx (truly-the type-blas-idx (* 2 (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) @@ -124,6 +173,16 @@ (complex (aref store idx) (aref store (1+ idx))))) +(declaim (ftype (function + ((complex double-float) + type-blas-store + type-blas-idx + type-blas-idx + type-blas-idx + ) + (complex double-float)) + (setf ref-blas-complex-store))) + (defun (setf ref-blas-complex-store) (value store row col rows) (let ((idx (truly-the type-blas-idx (* 2 (column-major-idx (truly-the type-blas-idx row) @@ -134,22 +193,31 @@ (aref store (1+ idx)) (imagpart value)) value)) -(defun allocate-complex-store (size &optional (value 0.0)) - (let* ((2size (* 2 size)) - (rv (coerce (realpart value) 'double-float)) - (iv (coerce (imagpart value) 'double-float)) - (store (allocate-real-store 2size iv))) - (declare (type type-blas-idx 2size) - (type double-float rv iv)) - (when (/= rv iv) - (loop for i from 0 below 2size by 2 do - (setf (aref store i) rv))) - store)) +(declaim (ftype (function + (type-blas-store + type-blas-idx) + (complex double-float)) + vref-blas-complex-store)) + +(defun vref-blas-complex-store (store idx) + "Matrix accessor for the complex blas store" + (let ((idx2 (truly-the type-blas-idx (* 2 idx)))) + (declare (type-blas-idx idx2)) + (complex (aref store idx2) + (aref store (1+ idx2))))) + +(declaim (ftype (function + ((complex double-float) + type-blas-store + type-blas-idx + ) + (complex double-float)) + (setf vref-blas-complex-store))) + +(defun (setf vref-blas-complex-store) (value store idx) + (let ((idx2 (truly-the type-blas-idx (* 2 idx)))) + (declare (type-blas-idx idx2)) + (setf (aref store idx2) (realpart value) + (aref store (1+ idx2)) (imagpart value)) + value)) -(defun copy-matrix-stores (a b) - (let ((len (length a))) - (declare (type type-blas-store a b) - (type type-blas-idx len)) - (dotimes (i len) - (setf (aref b i) (aref a i)))) - b) \ No newline at end of file Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Mon Nov 2 15:06:51 2009 @@ -48,12 +48,9 @@ out) (defmethod msum ((m matrix-base-dge)) - (let ((sum 0.0) - (m0 (matrix-store m))) - (declare (type double-float sum) - (type type-blas-store m0)) - (dotimes (i (length m0)) - (incf sum (aref m0 i))) + (let ((sum 0.0)) + (with-elements-df-1 (matrix-store m) x + (incf sum x)) sum)) (defmethod .some (pred (a matrix-base-dge) &rest args) @@ -64,62 +61,128 @@ (let ((stores (mapcar #'matrix-store (cons a args)))) (apply #'every pred stores))) -(defmacro def-binary-op-matrix-base-dge (new old) + +;;; Matrix and real + +(define-constant +generic-function-dfa-df-map+ + '((.add . +_dfa-df) + (.sub . -_dfa-df) + (.mul . *_dfa-df) + (.div . /_dfa-df) + (.expt . ^_dfa-df) + (.max . max_dfa-df) + (.min . min_dfa-df))) + +(defmacro defmethod-dfa-df (name underlying-function) (let ((a (gensym "a")) (b (gensym "b")) - (len (gensym "len")) - (store (gensym "store")) - (store2 (gensym "store2")) - (i (gensym "i"))) - `(progn - (defmethod ,new ((,a matrix-base-dge) (,b real)) - (let* ((,a (copy ,a)) - (,store (matrix-store ,a)) - (,b (coerce ,b 'double-float)) - (,len (size ,a))) - (declare (type double-float ,b) - (type type-blas-store ,store) - (type type-blas-idx ,len)) - (dotimes (,i ,len) - (setf (aref ,store ,i) (,old (aref ,store ,i) ,b))) - ,a)) - (defmethod ,new ((,a real) (,b matrix-base-dge)) - (let* ((,b (copy ,b)) - (,store (matrix-store ,b)) - (,a (coerce ,a 'double-float)) - (,len (size ,b))) - (declare (type double-float ,a) - (type type-blas-store ,store) - (type type-blas-idx ,len)) - (dotimes (,i ,len) - (setf (aref ,store ,i) (,old ,a (aref ,store ,i)))) - ,b)) - (defmethod ,new ((,a matrix-base-dge) (,b matrix-base-dge)) - (let* ((,a (copy ,a)) - (,store (matrix-store ,a)) - (,store2 (matrix-store ,b)) - (,len (size ,a))) - (declare (type type-blas-store ,store) - (type type-blas-store ,store2) - (type type-blas-idx ,len)) - (dotimes (,i ,len) - (setf (aref ,store ,i) (,old (aref ,store ,i) (aref ,store2 ,i)))) - ,a))))) + (c (gensym "c"))) + `(defmethod ,name ((,a matrix-base-dge) (,b real)) + (let ((,c (mcreate ,a))) + (,underlying-function (matrix-store ,a) (coerce ,b 'double-float) (matrix-store ,c)) + ,c)))) -(def-binary-op-matrix-base-dge .add +) +(defmacro expand-generic-function-dfa-df-map () + (cons 'progn + (mapcar (lambda (x) + `(defmethod-dfa-df ,(car x) ,(cdr x))) + +generic-function-dfa-df-map+))) + +(expand-generic-function-dfa-df-map) + +;;; Real and matrix + +(define-constant +generic-function-df-dfa-map+ + '((.add . +_df-dfa) + (.sub . -_df-dfa) + (.mul . *_df-dfa) + (.div . /_df-dfa) + (.expt . ^_df-dfa) + (.max . max_df-dfa) + (.min . min_df-dfa))) -(def-binary-op-matrix-base-dge .sub -) +(defmacro defmethod-df-dfa (name underlying-function) + (let ((a (gensym "a")) + (b (gensym "b")) + (c (gensym "c"))) + `(defmethod ,name ((,a real) (,b matrix-base-dge)) + (let ((,c (mcreate ,b))) + (,underlying-function (coerce ,a 'double-float) (matrix-store ,b) (matrix-store ,c)) + ,c)))) -(def-binary-op-matrix-base-dge .mul *) +(defmacro expand-generic-function-df-dfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defmethod-df-dfa ,(car x) ,(cdr x))) + +generic-function-df-dfa-map+))) + +(expand-generic-function-df-dfa-map) + +;;;; Matrix and matrix + +(define-constant +generic-function-dfa-dfa-map+ + '((.add . +_dfa-dfa) + (.sub . -_dfa-dfa) + (.mul . *_dfa-dfa) + (.div . /_dfa-dfa) + (.expt . ^_dfa-dfa) + (.max . max_dfa-dfa) + (.min . min_dfa-dfa))) -(def-binary-op-matrix-base-dge .div /) +(defmacro defmethod-dfa-dfa (name underlying-function) + (let ((a (gensym "a")) + (b (gensym "b")) + (c (gensym "c"))) + `(defmethod ,name ((,a matrix-base-dge) (,b matrix-base-dge)) + (let ((,c (mcreate ,a))) + (,underlying-function (matrix-store ,a) (matrix-store ,b) (matrix-store ,c)) + ,c)))) -(def-binary-op-matrix-base-dge .expt expt) +(defmacro expand-generic-function-dfa-dfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defmethod-dfa-dfa ,(car x) ,(cdr x))) + +generic-function-dfa-dfa-map+))) -(def-binary-op-matrix-base-dge .min min) +(expand-generic-function-dfa-dfa-map) -(def-binary-op-matrix-base-dge .max max) +;;; The ordinary functions + +;;;; Matrix and matrix + +(define-constant +generic-function-dfa-to-dfa-map+ ;really bad name + '((.sin . sin_dfa) (.cos . cos_dfa) (.tan . tan_dfa) + (.atan . atan_dfa) + (.sinh . sinh_dfa) (.cosh . cosh_dfa) (.tanh . tanh_dfa) + (.asinh . asinh_dfa) (.acosh . acosh_dfa) + (.exp . exp_dfa) (.sqrt . sqrt_dfat) (.conjugate . conjugate_dfa) + (.realpart . realpart_dfa) (.imagpart . imagpart_dfa) (.abs . abs_dfa))) + +(defmacro defmethod-dfa-to-dfa (name underlying-function) + (let ((a (gensym "a")) + (b (gensym "b"))) + `(defmethod ,name ((,a matrix-base-dge)) + (let ((,b (mcreate ,a))) + (,underlying-function (matrix-store ,a) (matrix-store ,b) ) + ,b)))) + +(defmacro expand-generic-function-dfa-to-dfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defmethod-dfa-to-dfa ,(car x) ,(cdr x))) + +generic-function-dfa-to-dfa-map+))) +(expand-generic-function-dfa-to-dfa-map) + +;;; The reset must wait until tomorrow + + + + + +;;;; Old code + +#| (defmacro each-matrix-element-df-to-df (x form) "Applies a form on each element of an matrix-dge. The form must @@ -196,27 +259,66 @@ (defmethod .besh2 (n (x matrix-base-dge)) (each-matrix-element-df-to-complex-df x (.besh2 n x))) +|# #| +;;; Old code -(defmethod .imagpart ((a matrix-base-dge)) - (mcreate a 0)) +(defmacro def-binary-op-matrix-base-dge (new old) + (let ((a (gensym "a")) + (b (gensym "b")) + (len (gensym "len")) + (store (gensym "store")) + (store2 (gensym "store2")) + (i (gensym "i"))) + `(progn + (defmethod ,new ((,a matrix-base-dge) (,b real)) + (let* ((,a (copy ,a)) + (,store (matrix-store ,a)) + (,b (coerce ,b 'double-float)) + (,len (size ,a))) + (declare (type double-float ,b) + (type type-blas-store ,store) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (aref ,store ,i) (,old (aref ,store ,i) ,b))) + ,a)) + (defmethod ,new ((,a real) (,b matrix-base-dge)) + (let* ((,b (copy ,b)) + (,store (matrix-store ,b)) + (,a (coerce ,a 'double-float)) + (,len (size ,b))) + (declare (type double-float ,a) + (type type-blas-store ,store) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (aref ,store ,i) (,old ,a (aref ,store ,i)))) + ,b)) + (defmethod ,new ((,a matrix-base-dge) (,b matrix-base-dge)) + (let* ((,a (copy ,a)) + (,store (matrix-store ,a)) + (,store2 (matrix-store ,b)) + (,len (size ,a))) + (declare (type type-blas-store ,store) + (type type-blas-store ,store2) + (type type-blas-idx ,len)) + (dotimes (,i ,len) + (setf (aref ,store ,i) (,old (aref ,store ,i) (aref ,store2 ,i)))) + ,a))))) -(defmethod .realpart ((a matrix-base-dge)) - (copy a)) +(def-binary-op-matrix-base-dge .add +) -(defmethod .abs ((a matrix-base-dge)) - (let ((b (mcreate a))) - (copy-contents a b #'abs) - b)) +(def-binary-op-matrix-base-dge .sub -) +(def-binary-op-matrix-base-dge .mul *) -(defmacro expand-on-matrix-dge-lisplab-two-argument-functions-alist () - (cons 'progn - (mapcar (lambda (name) - `(def-binary-op-matrix-base-dge ,(car name) ,(cdr name))) - +lisplab-two-argument-functions-alist+))) +(def-binary-op-matrix-base-dge .div /) + +(def-binary-op-matrix-base-dge .expt expt) + +(def-binary-op-matrix-base-dge .min min) + +(def-binary-op-matrix-base-dge .max max) -(expand-on-matrix-dge-lisplab-two-argument-functions-alist) |# \ No newline at end of file Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Mon Nov 2 15:06:51 2009 @@ -107,6 +107,8 @@ (sqrt (+ (* x x) (* y y)))))) b)) +;;; Old code + (defmacro def-binary-op-matrix-base-zge (new old) ;;; TODO speed up for real numbers. Is it worth the work? (let ((a (gensym "a")) @@ -191,6 +193,97 @@ (def-binary-op-matrix-base-zge .expt expt) +;;;; new code + + ;;; Matrix and complex + +(define-constant +generic-function-cdfa-cdf-map+ + '((.add . +_cdfa-cdf) + (.sub . -_cdfa-cdf) + (.mul . *_cdfa-cdf) + (.div . /_cdfa-cdf) + (.expt . ^_cdfa-cdf) + (.max . max_cdfa-cdf) + (.min . min_cdfa-cdf))) + +(defmacro defmethod-cdfa-cdf (name underlying-function) + (let ((a (gensym "a")) + (b (gensym "b")) + (c (gensym "c"))) + `(defmethod ,name ((,a matrix-base-zge) (,b number)) + (let ((,c (mcreate ,a))) + (,underlying-function (matrix-store ,a) + (coerce ,b '(complex double-float)) + (matrix-store ,c)) + ,c)))) + +(defmacro expand-generic-function-cdfa-cdf-map () + (cons 'progn + (mapcar (lambda (x) + `(defmethod-cdfa-cdf ,(car x) ,(cdr x))) + +generic-function-cdfa-cdf-map+))) + +(expand-generic-function-cdfa-cdf-map) + +;;; Real and matrix + +(define-constant +generic-function-cdf-cdfa-map+ + '((.add . +_cdf-cdfa) + (.sub . -_cdf-cdfa) + (.mul . *_cdf-cdfa) + (.div . /_cdf-cdfa) + (.expt . ^_cdf-cdfa) + (.max . max_cdf-cdfa) + (.min . min_cdf-cdfa))) + +(defmacro defmethod-cdf-cdfa (name underlying-function) + (let ((a (gensym "a")) + (b (gensym "b")) + (c (gensym "c"))) + `(defmethod ,name ((,a number) (,b matrix-base-zge)) + (let ((,c (mcreate ,b))) + (,underlying-function (coerce ,a '(complex double-float)) + (matrix-store ,b) + (matrix-store ,c)) + ,c)))) + +(defmacro expand-generic-function-cdf-cdfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defmethod-cdf-cdfa ,(car x) ,(cdr x))) + +generic-function-cdf-cdfa-map+))) + +(expand-generic-function-cdf-cdfa-map) + +;;;; Matrix and matrix + +(define-constant +generic-function-cdfa-cdfa-map+ + '((.add . +_cdfa-cdfa) + (.sub . -_cdfa-cdfa) + (.mul . *_cdfa-cdfa) + (.div . /_cdfa-cdfa) + (.expt . ^_cdfa-cdfa) + (.max . max_cdfa-cdfa) + (.min . min_cdfa-cdfa))) + +(defmacro defmethod-cdfa-cdfa (name underlying-function) + (let ((a (gensym "a")) + (b (gensym "b")) + (c (gensym "c"))) + `(defmethod ,name ((,a matrix-base-zge) (,b matrix-base-zge)) + (let ((,c (mcreate ,a))) + (,underlying-function (matrix-store ,a) (matrix-store ,b) (matrix-store ,c)) + ,c)))) + +(defmacro expand-generic-function-cdfa-cdfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defmethod-cdfa-cdfa ,(car x) ,(cdr x))) + +generic-function-cdfa-cdfa-map+))) + +(expand-generic-function-cdfa-cdfa-map) + + (defmacro each-element-function-matrix-base-zge (x form) "Applies a form on each element of an matrix-base-zge." Added: src/matrix/store-operators.lisp ============================================================================== --- (empty file) +++ src/matrix/store-operators.lisp Mon Nov 2 15:06:51 2009 @@ -0,0 +1,249 @@ +;;; Lisplab, store-operators.lisp +;;; Double float and complex double float operators (such as +,-,*, etc) on +;;; simple arrays. Used by the matrix implementations. +;;; + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +;;; TODO: change name of this to something about blas store +;;; +;;; This file contains manipulations of simple double-float arrays +;;; and should be called by the spesialized matrix methods. +;;; The purpose of this layer is that it can be used by +;;; many classes such as matrix-base-dge and matrix-base-ddi, etc. +;;; +;;; The content of this file must be highly optimized +;;; and should not depend anything exept Common Lisp itself. + +(in-package :lisplab) + +;;; TODO: there must be some easier way to generate the code in this file, +;;; but I have not the energy to do it. I do, however, think that +;;; the basic idea of having a layer of ordinary functions is correct. + +;;; The reason for generating ordinary functions and not using methods, +;;; is that the real and complex stores have the same type! + +;;; The reason for having both real and complex in the same file is that +;;; not all operators function on both real and complex arguments. Care must +;;; be taken. This is also the reason why it's hard to generate more code +;;; automatically. + +;;; The below code generates ordinary lisp functions +;;; for element-wise operations on simple double-float arrays. +;;; They use a naming conventions, which should be pretty easy to +;;; guess, such as df = double float and cdfa = complex double float array. +;;; +;;; (The last one should for consistnt naming be changed to zdfa, but its not really important) + + +;;; Array and number + +(define-constant +operators-dfa-df-map+ + '((+ . +_dfa-df) + (- . -_dfa-df) + (* . *_dfa-df) + (/ . /_dfa-df) + (expt . ^_dfa-df) + (max . max_dfa-df) + (min . min_dfa-df) + (log . log_dfa-df) ;; Note the log here + )) + +(defmacro defun-dfa-df (name op) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type type-blas-store ,a ,out) + (type double-float ,b)) + (dotimes (,i (length ,a)) + (setf (aref ,out ,i) (,op (aref ,a ,i) ,b))) + ,out))) + +(defmacro expand-operators-dfa-df-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-dfa-df ,(cdr x) ,(car x))) + +operators-dfa-df-map+))) + +(expand-operators-dfa-df-map) + +;;; The three parts of code below contains some common strucutre that could +;;; in principle be joined, and there is also some clumsy code, +;;; but I have not the energy to find out how to clean up. + +;;; Number and array + +(define-constant +operators-df-dfa-map+ + '((+ . +_df-dfa) + (- . -_df-dfa) + (* . *_df-dfa) + (/ . /_df-dfa) + (expt . ^_df-dfa) + (max . max_df-dfa) + (min . min_df-dfa) + (log . log_df-dfa))) + +(defmacro defun-df-dfa (name op) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type type-blas-store ,b ,out) + (type double-float ,a)) + (dotimes (,i (length ,b)) + (setf (aref ,out ,i) (,op ,a (aref ,b ,i)))) + ,out))) + +(defmacro expand-operators-df-dfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-df-dfa ,(cdr x) ,(car x))) + +operators-df-dfa-map+))) + +(expand-operators-df-dfa-map) + +;;; Array and array + +(define-constant +operators-dfa-dfa-map+ + '((+ . +_dfa-dfa) + (- . -_dfa-dfa) + (* . *_dfa-dfa) + (/ . /_dfa-dfa) + (expt . ^_dfa-dfa) + (max . max_dfa-dfa) + (min . min_dfa-dfa) + (log . log_dfa-dfa))) + +(defmacro defun-dfa-dfa (name op) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type type-blas-store ,a ,b ,out)) + (dotimes (,i (length ,a)) + (setf (aref ,out ,i) (,op (aref ,a ,i) (aref ,b ,i)))) + ,out))) + +(defmacro expand-operators-dfa-dfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-dfa-dfa ,(cdr x) ,(car x))) + +operators-dfa-dfa-map+))) + +(expand-operators-dfa-dfa-map) + + +;;; Now the complex operators + + +;;; Array and number + +(define-constant +operators-cdfa-cdf-map+ + '((+ . +_cdfa-cdf) + (- . -_cdfa-cdf) + (* . *_cdfa-cdf) + (/ . /_cdfa-cdf) + (expt . ^_cdfa-cdf) + )) + +(defmacro defun-cdfa-cdf (name op) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type type-blas-store ,a ,out) + (type (complex double-float) ,b)) + (dotimes (,i (floor (length ,a) 2)) + (setf (vref-blas-complex-store ,out ,i) + (coerce (,op (vref-blas-complex-store ,a ,i) ,b) '(complex double-float)))) + ,out))) + +(defmacro expand-operators-cdfa-cdf-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-cdfa-cdf ,(cdr x) ,(car x))) + +operators-cdfa-cdf-map+))) + +(expand-operators-cdfa-cdf-map) + +;;; The three parts of code below contains some common strucutre that could +;;; in principle be joined, and there is also some clumsy code, +;;; but I have not the energy to find out how to clean up. + +;;; Number and array + +(define-constant +operators-cdf-cdfa-map+ + '((+ . +_cdf-cdfa) + (- . -_cdf-cdfa) + (* . *_cdf-cdfa) + (/ . /_cdf-cdfa) + (expt . ^_cdf-cdfa))) + +(defmacro defun-cdf-cdfa (name op) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type type-blas-store ,b ,out) + (type (complex double-float) ,a)) + (dotimes (,i (floor (length ,b) 2)) + (setf (vref-blas-complex-store ,out ,i) (,op ,a (vref-blas-complex-store ,b ,i)))) + ,out))) + +(defmacro expand-operators-cdf-cdfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-cdf-cdfa ,(cdr x) ,(car x))) + +operators-cdf-cdfa-map+))) + +(expand-operators-cdf-cdfa-map) + +;;; Array and array + +(define-constant +operators-cdfa-cdfa-map+ + '((+ . +_cdfa-cdfa) + (- . -_cdfa-cdfa) + (* . *_cdfa-cdfa) + (/ . /_cdfa-cdfa) + (expt . ^_cdfa-cdfa))) + +(defmacro defun-cdfa-cdfa (name op) + (let ((a (gensym)) + (b (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,b ,out) + (declare (type type-blas-store ,a ,b ,out)) + (dotimes (,i (floor (length ,a) 2)) + (setf (vref-blas-complex-store ,out ,i) + (,op (vref-blas-complex-store ,a ,i) (vref-blas-complex-store ,b ,i)))) + ,out))) + +(defmacro expand-operators-cdfa-cdfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-cdfa-cdfa ,(cdr x) ,(car x))) + +operators-cdfa-cdfa-map+))) + +(expand-operators-cdfa-cdfa-map) \ No newline at end of file Added: src/matrix/store-ordinary-functions.lisp ============================================================================== --- (empty file) +++ src/matrix/store-ordinary-functions.lisp Mon Nov 2 15:06:51 2009 @@ -0,0 +1,136 @@ +;;; Lisplab, store-ordinary-functions.lisp +;;; Double float and complex double float ordinary functions (such as sin, log, etc) on +;;; simple arrays. Used by the matrix implementations. +;;; + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +;;; TODO: change name of this to something about blas store +;;; +;;; This file contains manipulations of simple double-float arrays +;;; and should be called by the spesialized matrix methods. +;;; The purpose of this layer is that it can be used by +;;; many classes such as matrix-base-dge and matrix-base-ddi, etc. +;;; +;;; The content of this file must be highly optimized +;;; and should not depend anything exept Common Lisp itself. + +(in-package :lisplab) + +;;; Now the ordinary functions + +;;; Double-float to double float + +(define-constant +ordinary-functions-dfa-to-dfa-map+ + '((sin . sin_dfa) (cos . cos_dfa) (tan . tan_dfa) + (atan . atan_dfa) + (sinh . sinh_dfa) (cosh . cosh_dfa) (tanh . tanh_dfa) + (asinh . asinh_dfa) (acosh . acosh_dfa) + (exp . exp_dfa) (sqrt . sqrt_dfat) (conjugate . conjugate_dfa) + (realpart . realpart_dfa) (imagpart . imagpart_dfa) (abs . abs_dfa))) + +(defmacro defun-dfa-to-dfa (name op) + (let ((a (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,out) + (declare (type type-blas-store ,a ,out)) + (dotimes (,i (length ,a)) + (setf (aref ,out ,i) (,op (aref ,a ,i)))) + ,out))) + +(defmacro expand-ordinary-functions-dfa-to-dfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-dfa ,(cdr x) ,(car x))) + +ordinary-functions-dfa-map+))) + +(expand-ordinary-functions-dfa-to-dfa-map) + +;;; double float to complex double float + +(define-constant +ordinary-functions-dfa-to-cdfa-map+ + '((asin . asin_dfa) (acos . acos_dfa) (atanh . atanh_dfa))) + +(defmacro defun-dfa-to-cdfa (name op) + (let ((a (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,out) + (declare (type type-blas-store ,a ,out)) + (dotimes (,i (length ,a)) + (setf (vref-blas-complex-store ,out ,i) (,op (aref ,a ,i)))) + ,out))) + +(defmacro expand-ordinary-functions-dfa-to-cdfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-dfa ,(cdr x) ,(car x))) + +ordinary-functions-dfa-to-cdfa-map+))) + +(expand-ordinary-functions-dfa-to-cdfa-map) + +;;; Complex double float to double float + +(define-constant +ordinary-functions-cdfa-to-dfa-map+ + '((realpart . realpart_cdfa) (imagpart . imagpart_cdfa) (abs . cabs_dfa))) + +(defmacro defun-cdfa-to-dfa (name op) + (let ((a (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,out) + (declare (type type-blas-store ,a ,out)) + (dotimes (,i (floor (length ,a) 2)) + (setf (aref ,out ,i) (,op (vref-blas-complex-store ,a ,i)))) + ,out))) + +(defmacro expand-ordinary-functions-cdfa-to-dfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-dfa ,(cdr x) ,(car x))) + +ordinary-functions-cdfa-to-dfa-map+))) + +(expand-ordinary-functions-cdfa-to-dfa-map) + +;;; Complex double float to complex double float + +(define-constant +ordinary-functions-cdfa-to-cdfa-map+ + '((sin . sin_cdfa) (cos . cos_cdfa) (tan . tan_cdfa) + (atan . atan_cdfa) + (sinh . sinh_cdfa) (cosh . cosh_cdfa) (tanh . tanh_cdfa) + (asinh . asinh_cdfa) (acosh . acosh_cdfa) + (exp . exp_cdfa) (sqrt . sqrt_cdfat) (conjugate . conjugate_cdfa) + (asin . asin_cdfa) (acos . acos_cdfa) (atanh . atanh_cdfa))) + +(defmacro defun-cdfa-to-cdfa (name op) + (let ((a (gensym)) + (out (gensym)) + (i (gensym))) + `(defun ,name (,a ,out) + (declare (type type-blas-store ,a ,out)) + (dotimes (,i (floor (length ,a) 2)) + (setf (vref-blas-complex-store ,out ,i) (,op (vref-blas-complex-store ,a ,i)))) + ,out))) + +(defmacro expand-ordinary-functions-cdfa-to-cdfa-map () + (cons 'progn + (mapcar (lambda (x) + `(defun-dfa ,(cdr x) ,(car x))) + +ordinary-functions-cdfa-to-cdfa-map+))) + +(expand-ordinary-functions-cdfa-to-cdfa-map) \ No newline at end of file From jivestgarden at common-lisp.net Tue Nov 3 14:53:01 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Tue, 03 Nov 2009 09:53:01 -0500 Subject: [lisplab-cvs] r108 - src/matrix Message-ID: Author: jivestgarden Date: Tue Nov 3 09:53:01 2009 New Revision: 108 Log: bugfix Modified: src/matrix/store-ordinary-functions.lisp Modified: src/matrix/store-ordinary-functions.lisp ============================================================================== --- src/matrix/store-ordinary-functions.lisp (original) +++ src/matrix/store-ordinary-functions.lisp Tue Nov 3 09:53:01 2009 @@ -56,8 +56,8 @@ (defmacro expand-ordinary-functions-dfa-to-dfa-map () (cons 'progn (mapcar (lambda (x) - `(defun-dfa ,(cdr x) ,(car x))) - +ordinary-functions-dfa-map+))) + `(defun-dfa-to-dfa ,(cdr x) ,(car x))) + +ordinary-functions-dfa-to-dfa-map+))) (expand-ordinary-functions-dfa-to-dfa-map) @@ -79,7 +79,7 @@ (defmacro expand-ordinary-functions-dfa-to-cdfa-map () (cons 'progn (mapcar (lambda (x) - `(defun-dfa ,(cdr x) ,(car x))) + `(defun-dfa-to-cdfa ,(cdr x) ,(car x))) +ordinary-functions-dfa-to-cdfa-map+))) (expand-ordinary-functions-dfa-to-cdfa-map) @@ -102,7 +102,7 @@ (defmacro expand-ordinary-functions-cdfa-to-dfa-map () (cons 'progn (mapcar (lambda (x) - `(defun-dfa ,(cdr x) ,(car x))) + `(defun-cdfa-to-dfa ,(cdr x) ,(car x))) +ordinary-functions-cdfa-to-dfa-map+))) (expand-ordinary-functions-cdfa-to-dfa-map) @@ -130,7 +130,7 @@ (defmacro expand-ordinary-functions-cdfa-to-cdfa-map () (cons 'progn (mapcar (lambda (x) - `(defun-dfa ,(cdr x) ,(car x))) + `(defun-cdfa-to-cdfa ,(cdr x) ,(car x))) +ordinary-functions-cdfa-to-cdfa-map+))) (expand-ordinary-functions-cdfa-to-cdfa-map) \ No newline at end of file From jivestgarden at common-lisp.net Sun Nov 8 11:30:22 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 08 Nov 2009 06:30:22 -0500 Subject: [lisplab-cvs] r109 - src/matrix Message-ID: Author: jivestgarden Date: Sun Nov 8 06:30:22 2009 New Revision: 109 Log: refactored structure Added: src/matrix/level1-dge.lisp src/matrix/level1-funmat.lisp src/matrix/level1-ge.lisp src/matrix/level1-zge.lisp Modified: lisplab.asd src/matrix/level1-classes.lisp src/matrix/level1-matrix.lisp Modified: lisplab.asd ============================================================================== --- lisplab.asd (original) +++ lisplab.asd Sun Nov 8 06:30:22 2009 @@ -63,16 +63,22 @@ ( (:file "level1-interface") - ;; These three should be independent of the rest - (:file "level1-util") - (:file "store-operators") - (:file "store-ordinary-functions") + ;; The three double-float store utility files should + ;; depend on the CL package only + (:file "level1-util") + (:file "store-operators") + (:file "store-ordinary-functions") (:file "level1-classes") (:file "level1-constructors") (:file "level1-matrix") + + (:file "level1-ge") + (:file "level1-dge") + (:file "level1-zge") + (:file "level1-funmat") (:file "level1-sparse") - (:file "level1-array") + (:file "level1-array") (:file "level2-interface") (:file "level2-constructors") Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Sun Nov 8 06:30:22 2009 @@ -101,78 +101,6 @@ ;;; The actual classes meant for instantiation -;;;; General matrices with unspecified element types - -(defclass matrix-ge - (matrix-structure-general matrix-element-base matrix-implementation-lisp) - ((matrix-store - :initarg :store - :initform nil - :reader matrix-store - :type (simple-array t (*)))) - (:documentation "A full matrix (rows x cols) with unspecified matrix element types.")) - -(defmethod initialize-instance :after ((m matrix-ge) &key (value 0)) - (with-slots (rows cols size matrix-store) m - (setf size (* rows cols)) - (unless matrix-store - (setf matrix-store (make-array size :initial-element value))))) - -;;; Double float general matrices - -(defclass matrix-base-dge - (matrix-structure-general matrix-element-double-float matrix-implementation-base) - ((matrix-store - :initarg :store - :initform nil - :reader matrix-store - :type type-blas-store))) - -(defmethod initialize-instance :after ((m matrix-base-dge) &key (value 0)) - (with-slots (rows cols size matrix-store) m - (setf size (* rows cols)) - (unless matrix-store - (setf matrix-store (allocate-real-store size value))))) - -(defclass matrix-lisp-dge (matrix-implementation-lisp matrix-base-dge) () - (:documentation "A full matrix (rows x cols) with double float elements. -Executes in lisp only.")) - -(defclass matrix-blas-dge (matrix-implementation-blas matrix-lisp-dge) () - (:documentation "A full matrix (rows x cols) with double float elements. -Executes in alien blas/lapack only.")) - -(defclass matrix-dge (matrix-blas-dge) () - (:documentation "A full matrix (rows x cols) with double float matrix elements. -Executes first in alien blas/lapack if possible. If not it executes in lisp.")) - -;;; Complex double float general matrices - -(defclass matrix-base-zge - (matrix-structure-general matrix-element-complex-double-float matrix-implementation-base) - ((matrix-store - :initarg :store - :initform nil - :accessor matrix-store - :type type-blas-store))) - -(defmethod initialize-instance :after ((m matrix-base-zge) &key (value 0)) - (with-slots (rows cols size matrix-store) m - (setf size (* rows cols)) - (unless matrix-store - (setf matrix-store (allocate-complex-store size value))))) - -(defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) () - (:documentation "A full matrix (rows x cols) with complex double float elements. -Executes in lisp only.")) - -(defclass matrix-blas-zge (matrix-implementation-blas matrix-lisp-zge) () - (:documentation "A full matrix (rows x cols) with complex double float elements. -Executes in alien blas/lapack only.")) - -(defclass matrix-zge (matrix-blas-zge) () - (:documentation "A full matrix (rows x cols) with complex double float matrix elements. -Executes first in alien blas/lapack if possible. If not it executes in lisp.")) ;;; Double float diagonal matrices @@ -190,35 +118,6 @@ (matrix-structure-diagonal matrix-element-complex-double-float matrix-implementation-base) ()) -;;; Function matrices (matrices without a store) - -(defclass function-matrix - (matrix-structure-general matrix-element-base matrix-implementation-base) - ((mref - :initarg :mref - :initform (constantly 0) - :accessor function-matrix-mref - :type function) - (set-mref - :initarg :set-mref - :initform (constantly nil) - :accessor function-matrix-set-mref - :type function) - (vref - :initarg :vref - :initform (constantly 0) - :accessor function-matrix-vref - :type function) - (set-vref - :initarg :set-vref - :initform (constantly nil) - :accessor function-matrix-set-vref - :type function)) - (:documentation "Matrix without a store.")) - -(defmethod initialize-instance :after ((m function-matrix) &key) - (with-slots (rows cols size matrix-store) m - (setf size (* rows cols)))) Added: src/matrix/level1-dge.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-dge.lisp Sun Nov 8 06:30:22 2009 @@ -0,0 +1,74 @@ +;;; Lisplab, level1-dge.lisp +;;; General, double-float matrices + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +;;; Double float general classes + +(defclass matrix-base-dge + (matrix-structure-general matrix-element-double-float matrix-implementation-base) + ((matrix-store + :initarg :store + :initform nil + :reader matrix-store + :type type-blas-store))) + +(defmethod initialize-instance :after ((m matrix-base-dge) &key (value 0)) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)) + (unless matrix-store + (setf matrix-store (allocate-real-store size value))))) + +(defclass matrix-lisp-dge (matrix-implementation-lisp matrix-base-dge) () + (:documentation "A full matrix (rows x cols) with double float elements. +Executes in lisp only.")) + +(defclass matrix-blas-dge (matrix-implementation-blas matrix-lisp-dge) () + (:documentation "A full matrix (rows x cols) with double float elements. +Executes in alien blas/lapack only.")) + +(defclass matrix-dge (matrix-blas-dge) () + (:documentation "A full matrix (rows x cols) with double float matrix elements. +Executes first in alien blas/lapack if possible. If not it executes in lisp.")) + + +;;; All leve1 methods spcialized for dge + +(defmethod mref ((matrix matrix-base-dge) row col) + (ref-blas-real-store (slot-value matrix 'matrix-store) row col (slot-value matrix 'rows))) + +(defmethod (setf mref) (value (matrix matrix-base-dge) row col) + (let ((val2 (coerce value 'double-float))) + (declare (type double-float val2)) + (setf (ref-blas-real-store (slot-value matrix 'matrix-store) + row col (slot-value matrix 'rows)) + val2) + val2)) + +(defmethod vref ((matrix matrix-base-dge) idx) + (aref (the type-blas-store (slot-value matrix 'matrix-store)) idx)) + +(defmethod (setf vref) (value (matrix matrix-base-dge) idx) + (let ((val2 (coerce value 'double-float))) + (declare (type double-float val2)) + (setf (aref (the type-blas-store (slot-value matrix 'matrix-store)) idx) + val2) + val2)) + + Added: src/matrix/level1-funmat.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-funmat.lisp Sun Nov 8 06:30:22 2009 @@ -0,0 +1,64 @@ +;;; Lisplab, level1-dge.lisp +;;; General, storeless matrices + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +;;; Function matrices (matrices without a store) + +(defclass function-matrix + (matrix-structure-general matrix-element-base matrix-implementation-base) + ((mref + :initarg :mref + :initform (constantly 0) + :accessor function-matrix-mref + :type function) + (set-mref + :initarg :set-mref + :initform (constantly nil) + :accessor function-matrix-set-mref + :type function) + (vref + :initarg :vref + :initform (constantly 0) + :accessor function-matrix-vref + :type function) + (set-vref + :initarg :set-vref + :initform (constantly nil) + :accessor function-matrix-set-vref + :type function)) + (:documentation "Matrix without a store.")) + +(defmethod initialize-instance :after ((m function-matrix) &key) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)))) + +;;; Level1 methods specialized for the function matrix + +(defmethod mref ((f function-matrix) row col) + (funcall (function-matrix-mref f) f row col)) + +(defmethod (setf mref) (value (f function-matrix) row col) + (funcall (function-matrix-set-mref f) value f row col)) + +(defmethod vref ((f function-matrix) idx) + (funcall (function-matrix-vref f) f idx)) + +(defmethod (setf vref) (value (f function-matrix) idx) + (funcall (function-matrix-set-vref f) value f idx)) Added: src/matrix/level1-ge.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-ge.lisp Sun Nov 8 06:30:22 2009 @@ -0,0 +1,55 @@ +;;; Lisplab, level1-dge.lisp +;;; General, untyped matrices + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +;;;; General matrices with unspecified element types + +(defclass matrix-ge + (matrix-structure-general matrix-element-base matrix-implementation-lisp) + ((matrix-store + :initarg :store + :initform nil + :reader matrix-store + :type (simple-array t (*)))) + (:documentation "A full matrix (rows x cols) with unspecified matrix element types.")) + +(defmethod initialize-instance :after ((m matrix-ge) &key (value 0)) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)) + (unless matrix-store + (setf matrix-store (make-array size :initial-element value))))) + +;;; Level methods specialized for untyped, general matrices + +(defmethod mref ((matrix matrix-ge) row col) + (aref (slot-value matrix 'matrix-store) + (column-major-idx row col (slot-value matrix 'rows)))) + +(defmethod (setf mref) (value (matrix matrix-ge) row col) + (setf (aref (slot-value matrix 'matrix-store) + (column-major-idx row col (slot-value matrix 'rows))) + value)) + +(defmethod vref ((matrix matrix-ge) idx) + (aref (slot-value matrix 'matrix-store) idx)) + +(defmethod (setf vref) (value (matrix matrix-ge) idx) + (setf (aref (slot-value matrix 'matrix-store) idx) + value)) Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Sun Nov 8 06:30:22 2009 @@ -40,20 +40,22 @@ (list (rows matrix) (cols matrix)))) (defmethod print-object ((matrix matrix-base) stream) + "Prints matrix as an unreadable object. The number of printed +rows and columns is limited by *lisplab-print-size*." (print-unreadable-object (matrix stream :type t :identity t) (let ((rows (min (rows matrix) *lisplab-print-size*)) (cols (min (cols matrix) *lisplab-print-size*))) - (format stream " ~Ax~A~&" (rows matrix) (cols matrix)) + (format stream " ~ax~a~&" (rows matrix) (cols matrix)) (dotimes (i rows) (dotimes (j cols) - (format stream "~S " (mref matrix i j))) + (format stream "~a " (mref matrix i j))) (when (< cols (cols matrix)) (format stream "...")) (princ #\Newline stream)) (when (< rows (rows matrix)) (format stream "...~%"))))) -;;;; General cration +;;;; Matrix constructors (defmethod make-matrix-instance ((type symbol) dim value) (make-instance type :rows (car dim) :cols (cadr dim) :value value)) @@ -64,82 +66,6 @@ (defmethod make-matrix-instance ((description list) dim value) (make-matrix-instance (find-matrix-class description) dim value)) -;;; The general matrix -(defmethod mref ((matrix matrix-ge) row col) - (aref (slot-value matrix 'matrix-store) - (column-major-idx row col (slot-value matrix 'rows)))) - -(defmethod (setf mref) (value (matrix matrix-ge) row col) - (setf (aref (slot-value matrix 'matrix-store) - (column-major-idx row col (slot-value matrix 'rows))) - value)) - -(defmethod vref ((matrix matrix-ge) idx) - (aref (slot-value matrix 'matrix-store) idx)) - -(defmethod (setf vref) (value (matrix matrix-ge) idx) - (setf (aref (slot-value matrix 'matrix-store) idx) - value)) - -;;; Spcialized for blas-dge - -(defmethod mref ((matrix matrix-base-dge) row col) - (ref-blas-real-store (slot-value matrix 'matrix-store) row col (slot-value matrix 'rows))) - -(defmethod (setf mref) (value (matrix matrix-base-dge) row col) - (let ((val2 (coerce value 'double-float))) - (declare (type double-float val2)) - (setf (ref-blas-real-store (slot-value matrix 'matrix-store) - row col (slot-value matrix 'rows)) - val2) - val2)) - -(defmethod vref ((matrix matrix-base-dge) idx) - (aref (the type-blas-store (slot-value matrix 'matrix-store)) idx)) - -(defmethod (setf vref) (value (matrix matrix-base-dge) idx) - (let ((val2 (coerce value 'double-float))) - (declare (type double-float val2)) - (setf (aref (the type-blas-store (slot-value matrix 'matrix-store)) idx) - val2) - val2)) - -;;; Spcialized for blas-zge - -(defmethod mref ((matrix matrix-base-zge) row col) - (ref-blas-complex-store (slot-value matrix 'matrix-store) - row col (slot-value matrix 'rows))) - -(defmethod (setf mref) (value (matrix matrix-base-zge) row col) - (let ((val2 (coerce value '(complex double-float)))) - (declare (type (complex double-float) val2)) - (setf (ref-blas-complex-store (slot-value matrix 'matrix-store) - row col (slot-value matrix 'rows)) - val2) - val2)) - -(defmethod vref ((matrix matrix-base-zge) i) - (ref-blas-complex-store (slot-value matrix 'matrix-store) i 0 1)) - -(defmethod (setf vref) (value (matrix matrix-base-zge) i) - (let ((val2 (coerce value '(complex double-float)))) - (declare (type (complex double-float) val2)) - (setf (ref-blas-complex-store (slot-value matrix 'matrix-store) i 0 1) - val2) - val2)) - -;;; Function matrix - -(defmethod mref ((f function-matrix) row col) - (funcall (function-matrix-mref f) f row col)) -(defmethod (setf mref) (value (f function-matrix) row col) - (funcall (function-matrix-set-mref f) value f row col)) - -(defmethod vref ((f function-matrix) idx) - (funcall (function-matrix-vref f) f idx)) - -(defmethod (setf vref) (value (f function-matrix) idx) - (funcall (function-matrix-set-vref f) value f idx)) Added: src/matrix/level1-zge.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-zge.lisp Sun Nov 8 06:30:22 2009 @@ -0,0 +1,74 @@ +;;; Lisplab, level1-zge.lisp +;;; General, complex double-float matrices + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +;;; Complex double float general matrices + +(defclass matrix-base-zge + (matrix-structure-general matrix-element-complex-double-float matrix-implementation-base) + ((matrix-store + :initarg :store + :initform nil + :accessor matrix-store + :type type-blas-store))) + +(defmethod initialize-instance :after ((m matrix-base-zge) &key (value 0)) + (with-slots (rows cols size matrix-store) m + (setf size (* rows cols)) + (unless matrix-store + (setf matrix-store (allocate-complex-store size value))))) + +(defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) () + (:documentation "A full matrix (rows x cols) with complex double float elements. +Executes in lisp only.")) + +(defclass matrix-blas-zge (matrix-implementation-blas matrix-lisp-zge) () + (:documentation "A full matrix (rows x cols) with complex double float elements. +Executes in alien blas/lapack only.")) + +(defclass matrix-zge (matrix-blas-zge) () + (:documentation "A full matrix (rows x cols) with complex double float matrix elements. +Executes first in alien blas/lapack if possible. If not it executes in lisp.")) + + +;;; Level1 methods specialized for zge + +(defmethod mref ((matrix matrix-base-zge) row col) + (ref-blas-complex-store (slot-value matrix 'matrix-store) + row col (slot-value matrix 'rows))) + +(defmethod (setf mref) (value (matrix matrix-base-zge) row col) + (let ((val2 (coerce value '(complex double-float)))) + (declare (type (complex double-float) val2)) + (setf (ref-blas-complex-store (slot-value matrix 'matrix-store) + row col (slot-value matrix 'rows)) + val2) + val2)) + +(defmethod vref ((matrix matrix-base-zge) i) + (ref-blas-complex-store (slot-value matrix 'matrix-store) i 0 1)) + +(defmethod (setf vref) (value (matrix matrix-base-zge) i) + (let ((val2 (coerce value '(complex double-float)))) + (declare (type (complex double-float) val2)) + (setf (ref-blas-complex-store (slot-value matrix 'matrix-store) i 0 1) + val2) + val2)) + From jivestgarden at common-lisp.net Sun Nov 8 16:30:10 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 08 Nov 2009 11:30:10 -0500 Subject: [lisplab-cvs] r110 - src/matrix Message-ID: Author: jivestgarden Date: Sun Nov 8 11:30:09 2009 New Revision: 110 Log: diagnoal and tridigonal matrices Added: src/matrix/level1-ddiag.lisp src/matrix/level1-dgt.lisp Modified: lisplab.asd src/matrix/level1-classes.lisp src/matrix/level1-constructors.lisp src/matrix/level1-dge.lisp src/matrix/level1-ge.lisp src/matrix/level1-interface.lisp src/matrix/level1-matrix.lisp src/matrix/level1-zge.lisp src/matrix/level2-constructors.lisp Modified: lisplab.asd ============================================================================== --- lisplab.asd (original) +++ lisplab.asd Sun Nov 8 11:30:09 2009 @@ -76,6 +76,8 @@ (:file "level1-ge") (:file "level1-dge") (:file "level1-zge") + (:file "level1-ddiag") + (:file "level1-dgt") (:file "level1-funmat") (:file "level1-sparse") (:file "level1-array") Modified: src/matrix/level1-classes.lisp ============================================================================== --- src/matrix/level1-classes.lisp (original) +++ src/matrix/level1-classes.lisp Sun Nov 8 11:30:09 2009 @@ -1,5 +1,5 @@ ;;; Lisplab, level1-classes.lisp -;;; Level1, matrix classes +;;; Level1, abstract matrix classes ;;; Copyright (C) 2009 Joern Inge Vestgaarden ;;; @@ -23,8 +23,6 @@ (in-package :lisplab) -(declaim (inline matrix-store)) - (defclass matrix-base () ()) ;;; The matrix element tells the element type of the matrix @@ -92,13 +90,16 @@ :reader size :type type-blas-idx))) -(defclass matrix-structure-diagonal (matrix-structure-base) - ((size - :initarg :size +(defclass matrix-structure-square (matrix-structure-base) + ((rowcols + :initarg :rowcols :initform 0 - :accessor size - :type type-blas-idx))) + :reader rowcols + :type type-blas-idx))) + + +#| REMOVE ;;; The actual classes meant for instantiation @@ -118,9 +119,4 @@ (matrix-structure-diagonal matrix-element-complex-double-float matrix-implementation-base) ()) - - - - - - +|# \ No newline at end of file Modified: src/matrix/level1-constructors.lisp ============================================================================== --- src/matrix/level1-constructors.lisp (original) +++ src/matrix/level1-constructors.lisp Sun Nov 8 11:30:09 2009 @@ -1,5 +1,5 @@ ;;; Lisplab, level1-constructors.lisp -;;; +;;; A symbolic naming scheme for matrix construction. ;;; Copyright (C) 2009 Joern Inge Vestgaarden ;;; @@ -22,6 +22,19 @@ (in-package :lisplab) +;;;; Matrix constructors + +(defmethod make-matrix-instance ((type standard-class) dim value) + (make-instance type :dim dim :value value)) + +(defmethod make-matrix-instance ((type symbol) dim value) + (make-matrix-instance (find-class type) dim value)) + +(defmethod make-matrix-instance ((description list) dim value) + (make-matrix-instance (find-matrix-class description) dim value)) + + + ;; A scheme for matrix creations (defvar *matrix-class-to-description* (make-hash-table)) @@ -39,14 +52,14 @@ (let* ((entry (gethash description *matrix-description-to-class*))) (unless entry - (error "No matrix of structure ~A." description)) + (error "No matrix of structure ~a." description)) entry)) (defun find-matrix-description (class) (let* ((entry (gethash class *matrix-class-to-description*))) (unless entry - (error "No matrix description of class ~A." class)) + (error "No matrix description of class ~a." class)) entry)) (defun create-matrix-description (obj &key et s i) @@ -58,21 +71,6 @@ (if et et (first d0)) (if s s (second d0)) (if i i (third d0))))) - -;;; Adding all the matrix descriptions - -(add-matrix-class 'matrix-base-ge :any :ge :base) -(add-matrix-class 'matrix-ge :any :ge :any) -(add-matrix-class 'matrix-base-dge :d :ge :base) -(add-matrix-class 'matrix-lisp-dge :d :ge :lisp) -(add-matrix-class 'matrix-blas-dge :d :ge :blas) -(add-matrix-class 'matrix-dge :d :ge :any) - -(add-matrix-class 'matrix-base-zge :z :ge :base) -(add-matrix-class 'matrix-lisp-zge :z :ge :lisp) -(add-matrix-class 'matrix-blas-zge :z :ge :blas) -(add-matrix-class 'matrix-zge :z :ge :any) -;;; TODO the other types need also conventions Added: src/matrix/level1-ddiag.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-ddiag.lisp Sun Nov 8 11:30:09 2009 @@ -0,0 +1,74 @@ +;;; Lisplab, level1-dge.lisp +;;; Diagonal double-float matrices + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +;;; TODO: bidiagnonal matrices + +;;; Note: not optimzied, but I see no good reason to optimzized them either. + +(in-package :lisplab) + +(defclass matrix-base-ddi + (matrix-structure-square matrix-element-double-float matrix-implementation-base) + ((diagonal-store + :initarg :diagonal-store + :initform nil + :type type-blas-store))) + +(defmethod initialize-instance :after ((m matrix-base-ddi) &key dim (value 0)) + (with-slots (rowcols diagonal-store) m + (setf rowcols dim) + (unless diagonal-store + (setf diagonal-store (allocate-real-store rowcols value))))) + +(defclass matrix-lisp-ddi (matrix-implementation-lisp matrix-base-ddi) ()) + +(defclass matrix-blas-ddi (matrix-implementation-blas matrix-lisp-ddi) ()) + +(defclass matrix-ddi (matrix-blas-ddi) ()) + +;;; Add classes to the generic matrix creation scheme +(add-matrix-class 'matrix-base-ddi :d :di :base) +(add-matrix-class 'matrix-lisp-ddi :d :di :lisp) +(add-matrix-class 'matrix-blas-ddi :d :di :blas) +(add-matrix-class 'matrix-ddi :d :di :any) + +;;; Methods spezilied for the diagnoal matrices + +(defmethod mref ((matrix matrix-base-ddi) row col) + (if (= row col) + (aref (slot-value matrix 'diagonal-store) row) + 0.0)) + +(defmethod (setf mref) (value (matrix matrix-base-ddi) row col) + (if (= row col) + (setf (aref (slot-value matrix 'diagonal-store) row) + (coerce value 'double-float)) + (warn "Array out of bonds for diagonal matrix. Ignored."))) + +(defmethod size ((matrix matrix-base-ddi)) + (slot-value matrix 'rowcols)) + +(defmethod vref ((matrix matrix-base-ddi) idx) + (aref (slot-value matrix 'diagonal-store) idx)) + +(defmethod (setf vref) (value (matrix matrix-base-dge) idx) + (let ((val2 (coerce value 'double-float))) + (setf (aref (the type-blas-store (slot-value matrix 'matrix-store)) idx) + val2) + val2)) Modified: src/matrix/level1-dge.lisp ============================================================================== --- src/matrix/level1-dge.lisp (original) +++ src/matrix/level1-dge.lisp Sun Nov 8 11:30:09 2009 @@ -29,9 +29,11 @@ :reader matrix-store :type type-blas-store))) -(defmethod initialize-instance :after ((m matrix-base-dge) &key (value 0)) +(defmethod initialize-instance :after ((m matrix-base-dge) &key dim (value 0)) (with-slots (rows cols size matrix-store) m - (setf size (* rows cols)) + (setf rows (car dim) + cols (cadr dim) + size (* rows cols)) (unless matrix-store (setf matrix-store (allocate-real-store size value))))) @@ -47,6 +49,11 @@ (:documentation "A full matrix (rows x cols) with double float matrix elements. Executes first in alien blas/lapack if possible. If not it executes in lisp.")) +;;; Add classes to the generic matrix creation scheme +(add-matrix-class 'matrix-base-dge :d :ge :base) +(add-matrix-class 'matrix-lisp-dge :d :ge :lisp) +(add-matrix-class 'matrix-blas-dge :d :ge :blas) +(add-matrix-class 'matrix-dge :d :ge :any) ;;; All leve1 methods spcialized for dge Added: src/matrix/level1-dgt.lisp ============================================================================== --- (empty file) +++ src/matrix/level1-dgt.lisp Sun Nov 8 11:30:09 2009 @@ -0,0 +1,117 @@ +;;; Lisplab, level1-dgt.lisp +;;; Tridiagonal double-float matrices + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +;;; Note: not optimzied, but I see no good reason to optimzized them either. + +(in-package :lisplab) + +;;; Tridiagonal matrices + +(defclass matrix-base-dgt + (matrix-structure-square matrix-element-double-float matrix-implementation-base) + ((size + :initarg :size + :type type-blas-idx) + (diagonal-store + :initarg :diagonal-store + :initform nil + :type type-blas-store) + (subdiagonal-store + :initarg :subdiagonal-store + :initform nil + :type type-blas-store) + (superdiagonal-store + :initarg :superdiagonal-store + :initform nil + :type type-blas-store))) + +(defmethod initialize-instance :after ((m matrix-base-dgt) &key dim (value 0)) + (with-slots (rowcols size diagonal-store subdiagonal-store superdiagonal-store) m + (setf rowcols dim + size (- (* 3 rowcols) 2)) + (unless diagonal-store + (setf diagonal-store (allocate-real-store rowcols value))) + (unless subdiagonal-store + (setf subdiagonal-store (allocate-real-store (1- rowcols) value))) + (unless superdiagonal-store + (setf superdiagonal-store (allocate-real-store (1- rowcols) value))))) + +(defclass matrix-lisp-dgt (matrix-implementation-lisp matrix-base-dgt) ()) + +(defclass matrix-blas-dgt (matrix-implementation-blas matrix-lisp-dgt) ()) + +(defclass matrix-dgt (matrix-blas-dgt) ()) + +;;; Add classes to the generic matrix creation scheme +(add-matrix-class 'matrix-base-dgt :d :gt :base) +(add-matrix-class 'matrix-lisp-dgt :d :gt :lisp) +(add-matrix-class 'matrix-blas-dgt :d :gt :blas) +(add-matrix-class 'matrix-dgt :d :gt :any) + +;;; Methods spezilied for the tridiagnoal matrices + +(defmethod mref ((matrix matrix-base-dgt) row col) + (cond ((= row col) + (aref (slot-value matrix 'diagonal-store) row)) + ((= (1- row) col) + (aref (slot-value matrix 'subdiagonal-store) col)) + ((= (1+ row) col) 8 + (aref (slot-value matrix 'superdiagonal-store) row)) + (t 0.0))) + +(defmethod (setf mref) (value (matrix matrix-base-dgt) row col) + (let ((val2 (coerce value 'double-float))) + (cond ((= row col) + (setf (aref (slot-value matrix 'diagonal-store) row) + val2)) + ((= (1- row) col) + (setf (aref (slot-value matrix 'subdiagonal-store) col) + val2)) + ((= (1+ row) col) + (setf (aref (slot-value matrix 'superdiagonal-store) row) + val2)) + (t + (warn "Array out of bonds for tridiagonal matrix. Ignored."))))) + +(defmethod vref ((matrix matrix-base-dgt) idx) + (let ((len (slot-value matrix 'rowcols))) + (cond ((< idx len) + (aref (slot-value matrix 'diagonal-store) idx)) + ((< idx (- (* 2 len) 1)) + (aref (slot-value matrix 'superdiagonal-store) (- idx len))) + ((< idx (slot-value matrix 'size)) + (aref (slot-value matrix 'subdiagonal-store) (- idx (- (* 2 len) 1)))) + (t + (warn "Array out of bonds for tridiagonal matrix. Ignored."))))) + +(defmethod (setf vref) (value (matrix matrix-base-dge) idx) + (let ((val2 (coerce value 'double-float)) + (len (slot-value matrix 'rowcols))) + (cond ((< idx len) + (setf (aref (slot-value matrix 'diagonal-store) idx) + val2)) + ((< idx (- (* 2 len) 1)) + (setf (aref (slot-value matrix 'superdiagonal-store) (- idx len)) + val2)) + ((< idx (- (* 3 len) 2)) + (setf (aref (slot-value matrix 'subdiagonal-store) (- idx (- (* 2 len) 1))) + val2)) + (t + (warn "Array out of bonds for tridiagonal matrix. Ignored."))) + val2)) Modified: src/matrix/level1-ge.lisp ============================================================================== --- src/matrix/level1-ge.lisp (original) +++ src/matrix/level1-ge.lisp Sun Nov 8 11:30:09 2009 @@ -30,9 +30,15 @@ :type (simple-array t (*)))) (:documentation "A full matrix (rows x cols) with unspecified matrix element types.")) -(defmethod initialize-instance :after ((m matrix-ge) &key (value 0)) +;;; Add class to the generic matrix creation scheme +(add-matrix-class 'matrix-base-ge :any :ge :base) +(add-matrix-class 'matrix-ge :any :ge :any) + +(defmethod initialize-instance :after ((m matrix-ge) &key dim (value 0)) (with-slots (rows cols size matrix-store) m - (setf size (* rows cols)) + (setf rows (car dim) + cols (cadr dim) + size (* rows cols)) (unless matrix-store (setf matrix-store (make-array size :initial-element value))))) Modified: src/matrix/level1-interface.lisp ============================================================================== --- src/matrix/level1-interface.lisp (original) +++ src/matrix/level1-interface.lisp Sun Nov 8 11:30:09 2009 @@ -72,3 +72,11 @@ (defgeneric (setf cols) (value matrix)) +;;; Integral routines for access to matrix store + +(declaim (inline matrix-store)) + +(defgeneric matrix-store (x) + (:documentation "Returns the store of the matrix")) + + Modified: src/matrix/level1-matrix.lisp ============================================================================== --- src/matrix/level1-matrix.lisp (original) +++ src/matrix/level1-matrix.lisp Sun Nov 8 11:30:09 2009 @@ -55,16 +55,13 @@ (when (< rows (rows matrix)) (format stream "...~%"))))) -;;;; Matrix constructors +;;; Spezialized for square matrices -(defmethod make-matrix-instance ((type symbol) dim value) - (make-instance type :rows (car dim) :cols (cadr dim) :value value)) +(defmethod rows ((matrix matrix-structure-square)) + (slot-value matrix 'rowcols)) -(defmethod make-matrix-instance ((type standard-class) dim value) - (make-instance type :rows (car dim) :cols (cadr dim) :value value)) - -(defmethod make-matrix-instance ((description list) dim value) - (make-matrix-instance (find-matrix-class description) dim value)) +(defmethod cols ((matrix matrix-structure-square)) + (slot-value matrix 'rowcols)) Modified: src/matrix/level1-zge.lisp ============================================================================== --- src/matrix/level1-zge.lisp (original) +++ src/matrix/level1-zge.lisp Sun Nov 8 11:30:09 2009 @@ -29,9 +29,11 @@ :accessor matrix-store :type type-blas-store))) -(defmethod initialize-instance :after ((m matrix-base-zge) &key (value 0)) +(defmethod initialize-instance :after ((m matrix-base-zge) &key dim (value 0)) (with-slots (rows cols size matrix-store) m - (setf size (* rows cols)) + (setf rows (car dim) + cols (cadr dim) + size (* rows cols)) (unless matrix-store (setf matrix-store (allocate-complex-store size value))))) @@ -48,6 +50,13 @@ Executes first in alien blas/lapack if possible. If not it executes in lisp.")) +;;; Add classes to the generic matrix creation scheme +(add-matrix-class 'matrix-base-zge :z :ge :base) +(add-matrix-class 'matrix-lisp-zge :z :ge :lisp) +(add-matrix-class 'matrix-blas-zge :z :ge :blas) +(add-matrix-class 'matrix-zge :z :ge :any) + + ;;; Level1 methods specialized for zge (defmethod mref ((matrix matrix-base-zge) row col) Modified: src/matrix/level2-constructors.lisp ============================================================================== --- src/matrix/level2-constructors.lisp (original) +++ src/matrix/level2-constructors.lisp Sun Nov 8 11:30:09 2009 @@ -62,7 +62,11 @@ (convert (list x) type))) (defmethod mnew (type value rows &optional cols) - (make-matrix-instance type (list rows cols) value)) + (make-matrix-instance type + (if cols + (list rows cols) + rows) + value)) (defmacro mmat (type &body args) "Creates a matrix." From jivestgarden at common-lisp.net Sat Nov 14 19:58:39 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 14 Nov 2009 14:58:39 -0500 Subject: [lisplab-cvs] r112 - src/core src/matrix Message-ID: Author: jivestgarden Date: Sat Nov 14 14:58:38 2009 New Revision: 112 Log: cleaned up more Modified: package.lisp src/core/level0-default.lisp src/core/level0-functions.lisp src/core/level0-interface.lisp src/matrix/level2-function.lisp src/matrix/level2-matrix-dge.lisp src/matrix/level2-matrix-zge.lisp src/matrix/level2-operator.lisp Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Sat Nov 14 14:58:38 2009 @@ -74,8 +74,10 @@ ".MAX" ".MIN" ".ABS" - ".IMAGPART" - ".REALPART" + ".IM" + ".RE" + ".CONJ" + ".COMPLEX" ".=" "./=" ".<" @@ -87,7 +89,8 @@ ".DIV" ".SUB" ".EXPT" - ".CONJ" + + ;; Elementary functions ".SIN" ".COS" ".TAN" @@ -101,9 +104,12 @@ ".ACOSH" ".ATANH" ".LOG" + ".LN" ".EXP" ".SQR" ".SQRT" + + ;; Special functions ".AI" ".BESJ" ".BESY" Modified: src/core/level0-default.lisp ============================================================================== --- src/core/level0-default.lisp (original) +++ src/core/level0-default.lisp Sat Nov 14 14:58:38 2009 @@ -58,10 +58,10 @@ :z) -(defmethod function-output-type-spec ((fun (eql '.realpart)) (input-spec (eql :z))) +(defmethod function-output-type-spec ((fun (eql '.re)) (input-spec (eql :z))) :d) -(defmethod function-output-type-spec ((fun (eql '.imagpart)) (input-spec (eql :z))) +(defmethod function-output-type-spec ((fun (eql '.im)) (input-spec (eql :z))) :d) (defmethod function-output-type-spec ((fun (eql '.abs)) (input-spec (eql :z))) Modified: src/core/level0-functions.lisp ============================================================================== --- src/core/level0-functions.lisp (original) +++ src/core/level0-functions.lisp Sat Nov 14 14:58:38 2009 @@ -65,12 +65,15 @@ (defmethod .abs ((a number)) (abs a)) -(defmethod .realpart ((a number)) +(defmethod .re ((a number)) (realpart a)) -(defmethod .imagpart ((a number)) +(defmethod .im ((a number)) (imagpart a)) +(defmethod .complex ((a number) (b number)) + (complex a b)) + (defmethod .max ((a number) (b number)) (max a b)) @@ -123,7 +126,7 @@ (.asinh . asinh) (.acosh . acosh) (.atanh . atanh) (.exp . exp) (.ln . log) (.sqrt . sqrt) (.sqr . sqr) - (.realpart . realpart)(.imagpart . imagpart) (.abs . abs) + (.re . realpart)(.im . imagpart) (.abs . abs) (.conj . conjugate))) (defmacro expand-num-num () Modified: src/core/level0-interface.lisp ============================================================================== --- src/core/level0-interface.lisp (original) +++ src/core/level0-interface.lisp Sat Nov 14 14:58:38 2009 @@ -63,15 +63,18 @@ (defgeneric .abs (a) (:documentation "Generialized abs.")) -(defgeneric .realpart (a) +(defgeneric .re (a) (:documentation "Generialized realpart.")) -(defgeneric .imagpart (a) +(defgeneric .im (a) (:documentation "Generialized abs.")) (defgeneric .conj (a) (:documentation "Generalized conjugate.")) +(defgeneric .complex (a b) + (:documentation "Generalized complex.")) + ;;; Binary boolean operators (defgeneric .= (a b &optional (accuracy)) Modified: src/matrix/level2-function.lisp ============================================================================== --- src/matrix/level2-function.lisp (original) +++ src/matrix/level2-function.lisp Sat Nov 14 14:58:38 2009 @@ -31,7 +31,7 @@ .asin .acos .atan .sinh .cosh .tanh .asinh .acosh .atanh - .realpart .imagpart .abs + .re .im .abs .exp .ln .sqr .sqrt .conj )) (defmacro expand-each-element-ordinary-functions () Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Sat Nov 14 14:58:38 2009 @@ -164,7 +164,7 @@ (.sinh . sinh_dfa) (.cosh . cosh_dfa) (.tanh . tanh_dfa) (.asinh . asinh_dfa) (.acosh . acosh_dfa) (.exp . exp_dfa) (.ln . log_dfa) (.sqrt . sqrt_dfat) (.conjugate . conjugate_dfa) - (.realpart . realpart_dfa) (.imagpart . imagpart_dfa) (.abs . abs_dfa))) + (.re . realpart_dfa) (.im . imagpart_dfa) (.abs . abs_dfa))) (defmacro defmethod-dfa-to-dfa (name underlying-function) (let ((a (gensym "a")) Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Sat Nov 14 14:58:38 2009 @@ -1,7 +1,6 @@ ;;; Lisplab, level2-matrix-zge.lisp ;;; Optimizations for complex matrices. - ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or @@ -148,6 +147,39 @@ (expand-generic-function-cdfa-cdfa-map) +;;;; The cross terms, where one input is real, the other complex + +(defmacro def-cross-complex-real-method (name type1 type2) + ;; Assumes output type same as input + ;; Note will crash if input is not converted properly!!!!!! + (let ((a (gensym)) + (b (gensym)) + (spec (gensym))) + `(defmethod ,name ((,a ,type1) (,b ,type2)) + ;; This is not the fastest possible, but rather fast + (let ((,spec (operator-output-type-spec ',name + (type-spec ,a) + (type-spec ,b)))) + ;; Assumes that input is something with a well-defined spec + (,name (if (matrix? ,a) (convert ,a ,spec) ,a) + (if (matrix? ,b) (convert ,b ,spec) ,b)))))) + +(defmacro def-all-cross-complex-real-methods (name) + `(progn + (def-cross-complex-real-method ,name complex matrix-base-dge) + (def-cross-complex-real-method ,name matrix-base-dge complex) + (def-cross-complex-real-method ,name matrix-base-zge matrix-base-dge) + (def-cross-complex-real-method ,name matrix-base-dge matrix-base-zge) + 'done)) + +(def-all-cross-complex-real-methods .add) +(def-all-cross-complex-real-methods .sub) +(def-all-cross-complex-real-methods .mul) +(def-all-cross-complex-real-methods .div) +(def-all-cross-complex-real-methods .expt) + + + ;;;; Ordinary functions (define-constant +generic-function-cdfa-to-cdfa-map+ ;really bad name @@ -173,19 +205,19 @@ (expand-generic-function-cdfa-to-cdfa-map) -;;;; Exceptions +;;;; Exceptions, in that output is real for complex input -(defmethod .imagpart ((a matrix-base-zge)) +(defmethod .im ((a matrix-base-zge)) (let ((out (make-matrix-instance - (function-output-type-spec '.imagpart (type-spec a)) + (function-output-type-spec '.im (type-spec a)) (dim a) 0))) (imagpart_cdfa (matrix-store a) (matrix-store out)) out)) -(defmethod .realpart ((a matrix-base-zge)) +(defmethod .re ((a matrix-base-zge)) (let ((out (make-matrix-instance - (function-output-type-spec '.realpart (type-spec a)) + (function-output-type-spec '.re (type-spec a)) (dim a) 0))) (realpart_cdfa (matrix-store a) (matrix-store out)) Modified: src/matrix/level2-operator.lisp ============================================================================== --- src/matrix/level2-operator.lisp (original) +++ src/matrix/level2-operator.lisp Sat Nov 14 14:58:38 2009 @@ -19,6 +19,13 @@ (in-package :lisplab) +(defmethod .complex ((a matrix-base) (b matrix-base)) + (.+ a (.* %i b))) +(defmethod .complex ((a matrix-base) b) + (.+ a (.* %i b))) +(defmethod .complex (a (b matrix-base)) + (.+ a (.* %i b))) + ;;;; Basic boolean operators (defmethod .= ((a matrix-base) (b matrix-base) &optional acc) From jivestgarden at common-lisp.net Sat Nov 14 20:28:45 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 14 Nov 2009 15:28:45 -0500 Subject: [lisplab-cvs] r113 - src/core src/matrix src/test Message-ID: Author: jivestgarden Date: Sat Nov 14 15:28:44 2009 New Revision: 113 Log: Many bugfixes Modified: lisplab.asd src/core/level0-default.lisp src/matrix/level2-matrix-dge.lisp src/matrix/level2-matrix-zge.lisp src/test/test-methods.lisp Modified: lisplab.asd ============================================================================== --- lisplab.asd (original) +++ lisplab.asd Sat Nov 14 15:28:44 2009 @@ -81,7 +81,7 @@ (:file "level1-dgt") (:file "level1-funmat") (:file "level1-sparse") - ; (:file "level1-array") + (:file "level1-array") ;; Level2, non-spezialized (:file "level2-interface") Modified: src/core/level0-default.lisp ============================================================================== --- src/core/level0-default.lisp (original) +++ src/core/level0-default.lisp Sat Nov 14 15:28:44 2009 @@ -54,7 +54,7 @@ (defmethod function-output-type-spec ((fun (eql '.besh1)) (input-spec (eql :d))) :z) -(defmethod function-output-type-spec ((fun (eql '.besh1)) (input-spec (eql :d))) +(defmethod function-output-type-spec ((fun (eql '.besh2)) (input-spec (eql :d))) :z) Modified: src/matrix/level2-matrix-dge.lisp ============================================================================== --- src/matrix/level2-matrix-dge.lisp (original) +++ src/matrix/level2-matrix-dge.lisp Sat Nov 14 15:28:44 2009 @@ -28,8 +28,7 @@ (defmethod copy ((matrix matrix-base-dge)) (make-instance (class-name (class-of matrix)) :store (copy-seq (the type-blas-store (matrix-store matrix))) - :rows (rows matrix) - :cols (cols matrix))) + :dim (dim matrix))) (defmethod copy-contents ((a matrix-base-dge) (b matrix-base-dge) &optional (converter nil)) (let ((store-a (matrix-store a)) Modified: src/matrix/level2-matrix-zge.lisp ============================================================================== --- src/matrix/level2-matrix-zge.lisp (original) +++ src/matrix/level2-matrix-zge.lisp Sat Nov 14 15:28:44 2009 @@ -28,8 +28,7 @@ (defmethod copy ((matrix matrix-base-zge)) (make-instance (class-name (class-of matrix)) :store (copy-seq (the type-blas-store (matrix-store matrix))) - :rows (rows matrix) - :cols (cols matrix))) + :dim (dim matrix))) (defmethod copy-contents ((a matrix-base-zge) (b matrix-base-zge) &optional (converter nil)) Modified: src/test/test-methods.lisp ============================================================================== --- src/test/test-methods.lisp (original) +++ src/test/test-methods.lisp Sat Nov 14 15:28:44 2009 @@ -37,7 +37,7 @@ .sinh .cosh .tanh .asinh .acosh .atanh .exp .sqr .sqrt .conj - .realpart .imagpart .abs + .re .im .abs .erf .erfc .gamma )) (mapc (lambda (x) (simple-non-nil-check '.besj (list 1 x))) args) From jivestgarden at common-lisp.net Sat Nov 14 20:43:08 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 14 Nov 2009 15:43:08 -0500 Subject: [lisplab-cvs] r114 - src/linalg Message-ID: Author: jivestgarden Date: Sat Nov 14 15:43:08 2009 New Revision: 114 Log: moved file Added: src/linalg/level3-linalg-dge.lisp - copied unchanged from r108, /src/linalg/level3-linalg-blas-real.lisp Removed: src/linalg/level3-linalg-blas-real.lisp Modified: lisplab.asd Modified: lisplab.asd ============================================================================== --- lisplab.asd (original) +++ lisplab.asd Sat Nov 14 15:43:08 2009 @@ -116,7 +116,7 @@ :components ((:file "level3-linalg-interface") (:file "level3-linalg-generic") - (:file "level3-linalg-blas-real"))) + (:file "level3-linalg-dge"))) ;; ;; Fast Fourier transform (Level 3) From jivestgarden at common-lisp.net Sat Nov 14 20:49:18 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sat, 14 Nov 2009 15:49:18 -0500 Subject: [lisplab-cvs] r115 - src/io Message-ID: Author: jivestgarden Date: Sat Nov 14 15:49:18 2009 New Revision: 115 Log: changed convention for dlmwrite paramter order Modified: src/io/level3-io-interface.lisp src/io/level3-io.lisp Modified: src/io/level3-io-interface.lisp ============================================================================== --- src/io/level3-io-interface.lisp (original) +++ src/io/level3-io-interface.lisp Sat Nov 14 15:49:18 2009 @@ -19,7 +19,7 @@ (in-package :lisplab) -(defgeneric dlmwrite (matrix file-or-stream &key dlm printer) +(defgeneric dlmwrite (file-or-stream matrix &key dlm printer) (:documentation "Write matrix to ASCII-delimited file or stream")) (defgeneric dlmread (class in) Modified: src/io/level3-io.lisp ============================================================================== --- src/io/level3-io.lisp (original) +++ src/io/level3-io.lisp Sat Nov 14 15:49:18 2009 @@ -32,7 +32,6 @@ (defmacro in-dir (dir &body body) "Temperarily binds *default-pathname-defaults* to dir. When directory does not exists, it is created." - ;; TODO move to the part dealing with files (let ((path (gensym)) (dir2 (gensym))) `(let* ((,dir2 ,dir) @@ -46,12 +45,12 @@ (let ((*default-pathname-defaults* ,path)) , at body)))) -(defmethod dlmwrite ((x number) out &key (printer #'prin1) dlm) +(defmethod dlmwrite (out (x number) &key (printer #'prin1) dlm) (declare (ignore dlm)) (dlmwrite (dcol x) out :printer printer)) -(defmethod dlmwrite ((a matrix-base) - (stream stream) +(defmethod dlmwrite ((stream stream) + (a matrix-base) &key (dlm " ") (printer #'prin1)) @@ -62,20 +61,20 @@ (when (< j (1- (cols a))) (princ dlm stream))))) -(defmethod dlmwrite ((a matrix-base) - (name pathname) +(defmethod dlmwrite ((name pathname) + (a matrix-base) &key (dlm " ") (printer #'prin1)) (with-open-file (stream name :direction :output :if-exists :supersede) - (dlmwrite a stream :dlm dlm :printer printer))) + (dlmwrite stream a :dlm dlm :printer printer))) -(defmethod dlmwrite ((a matrix-base) - (name string) +(defmethod dlmwrite ((name string) + (a matrix-base) &key (dlm " ") (printer #'prin1)) - (dlmwrite a (pathname name) :dlm dlm :printer printer)) + (dlmwrite (pathname name) a :dlm dlm :printer printer)) (defun dlmread-list (in) "Helper function that reads a delimited file as a list of lists." @@ -110,7 +109,7 @@ (defmethod dlmread (class (name string)) (dlmread class (pathname name))) -(defun pgmwrite (m filename +(defun pgmwrite (filename m &key (verbose nil) (max (mmax m)) @@ -138,7 +137,7 @@ (format t "pgmwrite ~20A (~3Ax~3A)~%" filename rows cols)) t)) -(defun pswrite (m filename +(defun pswrite (filename m &key (max (mmax m)) (min (mmin m))) From jivestgarden at common-lisp.net Sun Nov 15 18:11:20 2009 From: jivestgarden at common-lisp.net (=?UTF-8?Q?J=C3=B8rn_Inge_Vestg=C3=A5rden?=) Date: Sun, 15 Nov 2009 13:11:20 -0500 Subject: [lisplab-cvs] r116 - src/matlisp src/matrix Message-ID: Author: jivestgarden Date: Sun Nov 15 13:11:19 2009 New Revision: 116 Log: added tridag lin-solve Added: src/matlisp/tridiag.lisp Modified: lisplab.asd package.lisp src/matlisp/lapack.lisp src/matrix/level1-dgt.lisp Modified: lisplab.asd ============================================================================== --- lisplab.asd (original) +++ lisplab.asd Sun Nov 15 13:11:19 2009 @@ -178,7 +178,8 @@ (:file "lapack") (:file "mul") (:file "inv") - (:file "geev"))))) + (:file "geev") + (:file "tridiag"))))) (defsystem :lisplab-fftw :depends-on (:lisplab-base) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Sun Nov 15 13:11:19 2009 @@ -133,6 +133,8 @@ "MATRIX-GE" "MATRIX-DGE" "MATRIX-ZGE" + "MATRIX-DGT" + "MATRIX-DDI" "FUNCTION-MATRIX" "MATRIX-SPARSE" "*LISPLAB-PRINT-SIZE*" Modified: src/matlisp/lapack.lisp ============================================================================== --- src/matlisp/lapack.lisp (original) +++ src/matlisp/lapack.lisp Sun Nov 15 13:11:19 2009 @@ -1628,4 +1628,243 @@ (IPIV (* :integer) :input) (WORK (* :complex-double-float) :workspace-output) (LWORK :integer :input) - (INFO :integer :output)) \ No newline at end of file + (INFO :integer :output)) + +(def-fortran-routine dgttrf :void + "-- LAPACK routine (version 3.2) -- + -- LAPACK is a software package provided by Univ. of Tennessee, -- + -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + November 2006 + + .. Scalar Arguments .. + INTEGER INFO, N + .. + .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) + .. + + Purpose + ======= + + DGTTRF computes an LU factorization of a real tridiagonal matrix A + using elimination with partial pivoting and row interchanges. + + The factorization has the form + A = L * U + where L is a product of permutation and unit lower bidiagonal + matrices and U is upper triangular with nonzeros in only the main + diagonal and first two superdiagonals. + + Arguments + ========= + + N (input) INTEGER + The order of the matrix A. + + DL (input/output) DOUBLE PRECISION array, dimension (N-1) + On entry, DL must contain the (n-1) sub-diagonal elements of + A. + + On exit, DL is overwritten by the (n-1) multipliers that + define the matrix L from the LU factorization of A. + + D (input/output) DOUBLE PRECISION array, dimension (N) + On entry, D must contain the diagonal elements of A. + + On exit, D is overwritten by the n diagonal elements of the + upper triangular matrix U from the LU factorization of A. + + DU (input/output) DOUBLE PRECISION array, dimension (N-1) + On entry, DU must contain the (n-1) super-diagonal elements + of A. + + On exit, DU is overwritten by the (n-1) elements of the first + super-diagonal of U. + + DU2 (output) DOUBLE PRECISION array, dimension (N-2) + On exit, DU2 is overwritten by the (n-2) elements of the + second super-diagonal of U. + + IPIV (output) INTEGER array, dimension (N) + The pivot indices; for 1 <= i <= n, row i of the matrix was + interchanged with row IPIV(i). IPIV(i) will always be either + i or i+1; IPIV(i) = i indicates a row interchange was not + required. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -k, the k-th argument had an illegal value + > 0: if INFO = k, U(k,k) is exactly zero. The factorization + has been completed, but the factor U is exactly + singular, and division by zero will occur if it is used + to solve a system of equations." + (N :integer :input) + (DL (* :double-float) :input-output) + (D (* :double-float) :input-output) + (DU (* :double-float) :input-output) + (DU2 (* :double-float) :input-output) + (IPIV (* :integer) :input) + (INFO :integer :output)) + +(def-fortran-routine dgttrs :void + "-- LAPACK routine (version 3.2) -- + -- LAPACK is a software package provided by Univ. of Tennessee, -- + -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + November 2006 + + .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDB, N, NRHS + .. + .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) + .. + + Purpose + ======= + + DGTTRS solves one of the systems of equations + A*X = B or A'*X = B, + with a tridiagonal matrix A using the LU factorization computed + by DGTTRF. + + Arguments + ========= + + TRANS (input) CHARACTER*1 + Specifies the form of the system of equations. + = 'N': A * X = B (No transpose) + = 'T': A'* X = B (Transpose) + = 'C': A'* X = B (Conjugate transpose = Transpose) + + N (input) INTEGER + The order of the matrix A. + + NRHS (input) INTEGER + The number of right hand sides, i.e., the number of columns + of the matrix B. NRHS >= 0. + + DL (input) DOUBLE PRECISION array, dimension (N-1) + The (n-1) multipliers that define the matrix L from the + LU factorization of A. + + D (input) DOUBLE PRECISION array, dimension (N) + The n diagonal elements of the upper triangular matrix U from + the LU factorization of A. + + DU (input) DOUBLE PRECISION array, dimension (N-1) + The (n-1) elements of the first super-diagonal of U. + + DU2 (input) DOUBLE PRECISION array, dimension (N-2) + The (n-2) elements of the second super-diagonal of U. + + IPIV (input) INTEGER array, dimension (N) + The pivot indices; for 1 <= i <= n, row i of the matrix was + interchanged with row IPIV(i). IPIV(i) will always be either + i or i+1; IPIV(i) = i indicates a row interchange was not + required. + + B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) + On entry, the matrix of right hand side vectors B. + On exit, B is overwritten by the solution vectors X. + + LDB (input) INTEGER + The leading dimension of the array B. LDB >= max(1,N). + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value" + (trans :string :input) + (N :integer :input) + (NRHS :integer :input) + (DL (* :double-float) :input) + (D (* :double-float) :input) + (DU (* :double-float) :input) + (DU2 (* :double-float) :input) + (IPIV (* :integer) :input) + (B (* :double-float) :input-output) + (LDB :integer :input) + (INFO :integer :output)) + +(def-fortran-routine dgtsv :void + "-- LAPACK routine (version 3.2) -- + -- LAPACK is a software package provided by Univ. of Tennessee, -- + -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + November 2006 + + .. Scalar Arguments .. + INTEGER INFO, LDB, N, NRHS + .. + .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) + .. + + Purpose + ======= + + DGTSV solves the equation + + A*X = B, + + where A is an n by n tridiagonal matrix, by Gaussian elimination with + partial pivoting. + + Note that the equation A'*X = B may be solved by interchanging the + order of the arguments DU and DL. + + Arguments + ========= + + N (input) INTEGER + The order of the matrix A. N >= 0. + + NRHS (input) INTEGER + The number of right hand sides, i.e., the number of columns + of the matrix B. NRHS >= 0. + + DL (input/output) DOUBLE PRECISION array, dimension (N-1) + On entry, DL must contain the (n-1) sub-diagonal elements of + A. + + On exit, DL is overwritten by the (n-2) elements of the + second super-diagonal of the upper triangular matrix U from + the LU factorization of A, in DL(1), ..., DL(n-2). + + D (input/output) DOUBLE PRECISION array, dimension (N) + On entry, D must contain the diagonal elements of A. + + On exit, D is overwritten by the n diagonal elements of U. + + DU (input/output) DOUBLE PRECISION array, dimension (N-1) + On entry, DU must contain the (n-1) super-diagonal elements + of A. + + On exit, DU is overwritten by the (n-1) elements of the first + super-diagonal of U. + + B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) + On entry, the N by NRHS matrix of right hand side matrix B. + On exit, if INFO = 0, the N by NRHS solution matrix X. + + LDB (input) INTEGER + The leading dimension of the array B. LDB >= max(1,N). + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + > 0: if INFO = i, U(i,i) is exactly zero, and the solution + has not been computed. The factorization has not been + completed unless i = N." + (N :integer :input) + (NRHS :integer :input) + (DL (* :double-float) :input-output) + (D (* :double-float) :input-output) + (DU (* :double-float) :input-output) + (B (* :double-float) :input-output) + (LDB :integer :input) + (INFO :integer :output)) + + + Added: src/matlisp/tridiag.lisp ============================================================================== --- (empty file) +++ src/matlisp/tridiag.lisp Sun Nov 15 13:11:19 2009 @@ -0,0 +1,38 @@ +;;; Lisplab, matliap/tridiag.lisp +;;; Lapack-based, tridiagonal routines + +;;; Copyright (C) 2009 Joern Inge Vestgaarden +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License along +;;; with this program; if not, write to the Free Software Foundation, Inc., +;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +(in-package :lisplab) + +(defmethod lin-solve ((A matrix-lisp-dgt) (b matrix-blas-dge)) + (lin-solve! (copy A) (copy b))) + +(defmethod lin-solve! ((A matrix-lisp-dgt) (b matrix-blas-dge)) + ;; TODO catch error from input + (if cl-user::*lisplab-liblapack-path* + (let* ((N (cols A))) + (f77::dgtsv N + 1 + (slot-value a 'subdiagonal-store ) + (slot-value a 'diagonal-store) + (slot-value a 'superdiagonal-store) + (matrix-store b) + N + 0) + b) + (call-next-method))) \ No newline at end of file Modified: src/matrix/level1-dgt.lisp ============================================================================== --- src/matrix/level1-dgt.lisp (original) +++ src/matrix/level1-dgt.lisp Sun Nov 15 13:11:19 2009 @@ -95,8 +95,7 @@ ((= (1+ row) col) (setf (aref (slot-value matrix 'superdiagonal-store) row) val2)) - (t - (warn "Array out of bonds for tridiagonal matrix. Ignored."))))) + #+nil (t (warn "Array out of bonds for tridiagonal matrix. Ignored."))))) (defmethod vref ((matrix matrix-base-dgt) idx) (let ((len (slot-value matrix 'rowcols))) @@ -106,7 +105,7 @@ (aref (slot-value matrix 'superdiagonal-store) (- idx len))) ((< idx (slot-value matrix 'size)) (aref (slot-value matrix 'subdiagonal-store) (- idx (- (* 2 len) 1)))) - (t + #+nil (t (warn "Array out of bonds for tridiagonal matrix. Ignored."))))) (defmethod (setf vref) (value (matrix matrix-base-dgt) idx) @@ -121,6 +120,6 @@ ((< idx (- (* 3 len) 2)) (setf (aref (slot-value matrix 'subdiagonal-store) (- idx (- (* 2 len) 1))) val2)) - (t + #+nil (t (warn "Array out of bonds for tridiagonal matrix. Ignored."))) val2))