(FILECREATED "29-Aug-86 15:55:35" {QV}<PEDERSEN>LISP>MATRIXTIMES.;1 9608
changes to: (VARS MATRIXTIMESCOMS)
(FUNCTIONS MATRIX-* MATRIX-VECTOR-* VECTOR-MATRIX-* VECTOR-VECTOR-*
MATRIX-MATRIX-*))
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT MATRIXTIMESCOMS)
(RPAQQ MATRIXTIMESCOMS ((* File created by Coms Manager.)
(FUNCTIONS MATRIX-* MATRIX-MATRIX-* MATRIX-VECTOR-* VECTOR-MATRIX-*
VECTOR-VECTOR-*)
(PROP FILETYPE MATRIXTIMES)
(DECLARE: DONTCOPY EVAL@COMPILE (LOCALVARS . T))))
(* File created by Coms Manager.)
(DEFUN MATRIX-* (MATRIX-A MATRIX-B &OPTIONAL MATRIX-RESULT) (CL:IF (VECTORP MATRIX-A)
(CL:IF (VECTORP MATRIX-B)
(VECTOR-VECTOR-* MATRIX-A
MATRIX-B)
(VECTOR-MATRIX-* MATRIX-A
MATRIX-B
MATRIX-RESULT))
(CL:IF (VECTORP MATRIX-B)
(MATRIX-VECTOR-* MATRIX-A
MATRIX-B
MATRIX-RESULT)
(MATRIX-MATRIX-* MATRIX-A
MATRIX-B
MATRIX-RESULT))))
(DEFUN MATRIX-MATRIX-* (MATRIX-A MATRIX-B &OPTIONAL MATRIX-RESULT)
(CL:IF (NOT (TYPEP MATRIX-A (QUOTE (ARRAY SINGLE-FLOAT (CL:* CL:*)))))
(CL:ERROR "Not a float matrix: ~S" MATRIX-A))
(CL:IF (NOT (TYPEP MATRIX-B (QUOTE (ARRAY SINGLE-FLOAT (CL:* CL:*)))))
(CL:ERROR "Not a float matrix: ~S" MATRIX-B))
(LET ((M (ARRAY-DIMENSION MATRIX-A 0))
(N (ARRAY-DIMENSION MATRIX-A 1))
(P (ARRAY-DIMENSION MATRIX-B 1)))
(CL:IF (NOT (EQL N (ARRAY-DIMENSION MATRIX-B 0)))
(CL:ERROR "Dimensionality mismatch"))
(CL:IF MATRIX-RESULT (CL:IF (AND (TYPEP MATRIX-RESULT (QUOTE (ARRAY SINGLE-FLOAT (CL:* CL:*))
))
(EQL M (ARRAY-DIMENSION MATRIX-RESULT 0))
(EQL P (ARRAY-DIMENSION MATRIX-RESULT 1)))
MATRIX-RESULT
(CL:ERROR "Result array of incorrect type: ~s" MATRIX-RESULT))
(SETQ MATRIX-RESULT (MAKE-ARRAY (LIST M P)
:ELEMENT-TYPE
(QUOTE SINGLE-FLOAT))))
(CL:DO ((A-BASE (%%GET-FLOAT-ARRAY-BASE MATRIX-A))
(B-BASE (%%GET-FLOAT-ARRAY-BASE MATRIX-B))
(R-BASE (%%GET-FLOAT-ARRAY-BASE MATRIX-RESULT))
(TWICE-M (LLSH M 1))
(TWICE-N (LLSH N 1))
(TWICE-P (LLSH P 1))
(A-START 0 (+ A-START TWICE-N))
(R-START 0 (+ R-START TWICE-P))
(I 0 (1+ I)))
((EQL I M)
MATRIX-RESULT)
(CL:DO ((B-START 0 (+ B-START 2))
(R-INDEX R-START (+ R-INDEX 2))
(K 0 (1+ K)))
((EQL K P))
(CL:DO ((A-INDEX A-START (+ A-INDEX 2))
(B-INDEX B-START (+ B-INDEX TWICE-P))
(J 0 (1+ J))
(PRODUCT 0.0))
((EQL J N)
(\PUTBASEFLOATP R-BASE R-INDEX PRODUCT))
(DECLARE (TYPE FLOATP PRODUCT))
(SETQ PRODUCT (+ PRODUCT (CL:* (\GETBASEFLOATP A-BASE A-INDEX)
(\GETBASEFLOATP B-BASE B-INDEX)))))))))
(DEFUN MATRIX-VECTOR-* (MATRIX VECTOR &OPTIONAL VECTOR-RESULT) "Multiply a matrix times a vector"
(CL:IF (NOT (TYPEP MATRIX (QUOTE (ARRAY SINGLE-FLOAT (CL:* CL:*)))))
(CL:ERROR "Not a float matrix: ~S" MATRIX))
(CL:IF (NOT (TYPEP VECTOR (QUOTE (VECTOR SINGLE-FLOAT))))
(CL:ERROR "Not a float vector: ~S" VECTOR))
(LET ((M (ARRAY-DIMENSION MATRIX 0))
(N (ARRAY-DIMENSION MATRIX 1)))
(CL:IF (NOT (EQL N (ARRAY-TOTAL-SIZE VECTOR)))
(CL:ERROR "Dimensionality mismatch"))
(CL:IF VECTOR-RESULT (CL:IF (AND (TYPEP VECTOR-RESULT (QUOTE (VECTOR SINGLE-FLOAT)))
(EQL M (ARRAY-TOTAL-SIZE VECTOR-RESULT)))
VECTOR-RESULT
(CL:ERROR "Result array of incorrect type: ~s" VECTOR-RESULT))
(SETQ VECTOR-RESULT (MAKE-VECTOR M :ELEMENT-TYPE (QUOTE SINGLE-FLOAT))))
(CL:DO ((MATRIX-BASE (%%GET-FLOAT-ARRAY-BASE MATRIX))
(VECTOR-BASE (%%GET-FLOAT-ARRAY-BASE VECTOR))
(RESULT-BASE (%%GET-FLOAT-ARRAY-BASE VECTOR-RESULT))
(TWICE-M (LLSH M 1))
(TWICE-N (LLSH N 1))
(MATRIX-START 0 (+ MATRIX-START TWICE-N))
(R-INDEX 0 (+ R-INDEX 2))
(I 0 (1+ I)))
((EQL I M)
VECTOR-RESULT)
(CL:DO ((M-INDEX MATRIX-START (+ M-INDEX 2))
(V-INDEX 0 (+ V-INDEX 2))
(PRODUCT 0.0)
(J 0 (1+ J)))
((EQL J N)
(\PUTBASEFLOATP RESULT-BASE R-INDEX PRODUCT))
(DECLARE (TYPE FLOATP PRODUCT))
(SETQ PRODUCT (+ PRODUCT (CL:* (\GETBASEFLOATP MATRIX-BASE M-INDEX)
(\GETBASEFLOATP VECTOR-BASE V-INDEX))))))))
(DEFUN VECTOR-MATRIX-* (VECTOR MATRIX &OPTIONAL VECTOR-RESULT) "Multiply a vector and a matrix"
(CL:IF (NOT (TYPEP VECTOR (QUOTE (VECTOR SINGLE-FLOAT))))
(CL:ERROR "Not a float vector: ~S" VECTOR))
(CL:IF (NOT (TYPEP MATRIX (QUOTE (ARRAY SINGLE-FLOAT (CL:* CL:*)))))
(CL:ERROR "Not a float matrix: ~S" MATRIX))
(LET ((N (ARRAY-TOTAL-SIZE VECTOR))
(P (ARRAY-DIMENSION MATRIX 1)))
(CL:IF (NOT (EQL N (ARRAY-DIMENSION MATRIX 0)))
(CL:ERROR "Dimensionality mismatch"))
(CL:IF VECTOR-RESULT (CL:IF (AND (TYPEP VECTOR-RESULT (QUOTE (VECTOR SINGLE-FLOAT)))
(EQL P (ARRAY-TOTAL-SIZE VECTOR-RESULT)))
VECTOR-RESULT
(CL:ERROR "Result array of incorrect type: ~s" VECTOR-RESULT))
(SETQ VECTOR-RESULT (MAKE-VECTOR P :ELEMENT-TYPE (QUOTE SINGLE-FLOAT))))
(CL:DO ((VECTOR-BASE (%%GET-FLOAT-ARRAY-BASE VECTOR))
(MATRIX-BASE (%%GET-FLOAT-ARRAY-BASE MATRIX))
(RESULT-BASE (%%GET-FLOAT-ARRAY-BASE VECTOR-RESULT))
(TWICE-N (LLSH N 1))
(TWICE-P (LLSH P 1))
(R-INDEX 0 (+ R-INDEX 2))
(MATRIX-START 0 (+ MATRIX-START 2))
(I 0 (1+ I)))
((EQL I P)
VECTOR-RESULT)
(DECLARE (TYPE FLOATP VECTOR-ELT))
(CL:DO ((V-INDEX 0 (+ V-INDEX 2))
(M-INDEX MATRIX-START (+ M-INDEX TWICE-P))
(PRODUCT 0.0)
(J 0 (1+ J)))
((EQL J N)
(\PUTBASEFLOATP RESULT-BASE R-INDEX PRODUCT))
(DECLARE (TYPE FLOATP PRODUCT))
(SETQ PRODUCT (+ PRODUCT (CL:* (\GETBASEFLOATP VECTOR-BASE V-INDEX)
(\GETBASEFLOATP MATRIX-BASE M-INDEX))))))))
(DEFUN VECTOR-VECTOR-* (VECTOR-A VECTOR-B) "Multiply two vectors"
(CL:IF (NOT (TYPEP VECTOR-A (QUOTE (VECTOR SINGLE-FLOAT))))
(CL:ERROR "Not a float vector: ~S" VECTOR-A))
(CL:IF (NOT (TYPEP VECTOR-B (QUOTE (VECTOR SINGLE-FLOAT))))
(CL:ERROR "Not a float vector: ~S" VECTOR-B))
(LET ((N (ARRAY-TOTAL-SIZE VECTOR-A)))
(CL:IF (NOT (EQL N (ARRAY-TOTAL-SIZE VECTOR-B)))
(CL:ERROR "Dimensionality mismatch"))
(CL:DO ((A-BASE (%%GET-FLOAT-ARRAY-BASE VECTOR-A))
(B-BASE (%%GET-FLOAT-ARRAY-BASE VECTOR-B))
(PRODUCT 0.0)
(LIMIT (LLSH N 1))
(I 0 (+ I 2)))
((EQL I LIMIT)
PRODUCT)
(DECLARE (TYPE FLOATP PRODUCT))
(SETQ PRODUCT (+ PRODUCT (CL:* (\GETBASEFLOATP A-BASE I)
(\GETBASEFLOATP B-BASE I)))))))
(PUTPROPS MATRIXTIMES FILETYPE COMPILE-FILE)
(DECLARE: DONTCOPY EVAL@COMPILE
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS MATRIXTIMES COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP