--- /dev/null
+! Copyright (C) 2009 Joe Groff
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences strings words.symbol classes.struct ;
+QUALIFIED-WITH: alien.syntax c
+IN: alien.fortran
+
+ARTICLE: "alien.fortran-abis" "Fortran ABIs"
+"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
+{ $list
+ { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
+ { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
+ { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
+ { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
+}
+"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
+
+ARTICLE: "alien.fortran-types" "Fortran types"
+"The Fortran FFI recognizes the following Fortran types:"
+{ $list
+ { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." }
+ { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." }
+ { { $snippet "REAL" } " specifies a single-precision floating-point real value." }
+ { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." }
+ { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." }
+ { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
+ { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
+ { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
+ { "Struct classes defined by " { $link POSTPONE: STRUCT: } " are also supported as parameter and return types." }
+}
+"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
+
+HELP: FUNCTION:
+{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
+{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
+
+HELP: SUBROUTINE:
+{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
+{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
+
+HELP: LIBRARY:
+{ $syntax "LIBRARY: name" }
+{ $values { "name" "a logical library name" } }
+{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
+
+HELP: add-fortran-library
+{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
+{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
+;
+
+HELP: fortran-invoke
+{ $values
+ { "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
+}
+{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." }
+;
+
+ARTICLE: "alien.fortran" "Fortran FFI"
+"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
+{ $subsections
+ "alien.fortran-types"
+ "alien.fortran-abis"
+ add-fortran-library
+ POSTPONE: LIBRARY:
+ POSTPONE: FUNCTION:
+ POSTPONE: SUBROUTINE:
+ fortran-invoke
+} ;
+
+ABOUT: "alien.fortran"
--- /dev/null
+! (c) 2009 Joe Groff, see BSD license
+USING: accessors alien alien.c-types alien.complex
+alien.data alien.fortran alien.fortran.private alien.strings
+classes.struct arrays assocs byte-arrays combinators fry
+generalizations io.encodings.ascii kernel macros
+macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
+FROM: alien.syntax => pointer: ;
+QUALIFIED-WITH: alien.c-types c
+IN: alien.fortran.tests
+
+<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
+LIBRARY: (alien.fortran-tests)
+STRUCT: fortran_test_record
+ { FOO int }
+ { BAR double[2] }
+ { BAS char[4] } ;
+
+intel-unix-abi fortran-abi [
+
+ ! fortran-name>symbol-name
+
+ [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
+ [ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
+ [ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
+
+ ! fortran-type>c-type
+
+ [ c:short ]
+ [ "integer*2" fortran-type>c-type ] unit-test
+
+ [ c:int ]
+ [ "integer*4" fortran-type>c-type ] unit-test
+
+ [ c:int ]
+ [ "INTEGER" fortran-type>c-type ] unit-test
+
+ [ c:longlong ]
+ [ "iNteger*8" fortran-type>c-type ] unit-test
+
+ [ { c:int 0 } ]
+ [ "integer(*)" fortran-type>c-type ] unit-test
+
+ [ { c:int 0 } ]
+ [ "integer(3,*)" fortran-type>c-type ] unit-test
+
+ [ { c:int 3 } ]
+ [ "integer(3)" fortran-type>c-type ] unit-test
+
+ [ { c:int 6 } ]
+ [ "integer(3,2)" fortran-type>c-type ] unit-test
+
+ [ { c:int 24 } ]
+ [ "integer(4,3,2)" fortran-type>c-type ] unit-test
+
+ [ c:char ]
+ [ "character" fortran-type>c-type ] unit-test
+
+ [ c:char ]
+ [ "character*1" fortran-type>c-type ] unit-test
+
+ [ { c:char 17 } ]
+ [ "character*17" fortran-type>c-type ] unit-test
+
+ [ { c:char 17 } ]
+ [ "character(17)" fortran-type>c-type ] unit-test
+
+ [ c:int ]
+ [ "logical" fortran-type>c-type ] unit-test
+
+ [ c:float ]
+ [ "real" fortran-type>c-type ] unit-test
+
+ [ c:double ]
+ [ "double-precision" fortran-type>c-type ] unit-test
+
+ [ c:float ]
+ [ "real*4" fortran-type>c-type ] unit-test
+
+ [ c:double ]
+ [ "real*8" fortran-type>c-type ] unit-test
+
+ [ complex-float ]
+ [ "complex" fortran-type>c-type ] unit-test
+
+ [ complex-double ]
+ [ "double-complex" fortran-type>c-type ] unit-test
+
+ [ complex-float ]
+ [ "complex*8" fortran-type>c-type ] unit-test
+
+ [ complex-double ]
+ [ "complex*16" fortran-type>c-type ] unit-test
+
+ [ fortran_test_record ]
+ [
+ [
+ "alien.fortran.tests" use-vocab
+ "fortran_test_record" fortran-type>c-type
+ ] with-manifest
+ ] unit-test
+
+ ! fortran-arg-type>c-type
+
+ [ pointer: c:int { } ]
+ [ "integer" fortran-arg-type>c-type ] unit-test
+
+ [ pointer: { c:int 3 } { } ]
+ [ "integer(3)" fortran-arg-type>c-type ] unit-test
+
+ [ pointer: { c:int 0 } { } ]
+ [ "integer(*)" fortran-arg-type>c-type ] unit-test
+
+ [ pointer: fortran_test_record { } ]
+ [
+ [
+ "alien.fortran.tests" use-vocab
+ "fortran_test_record" fortran-arg-type>c-type
+ ] with-manifest
+ ] unit-test
+
+ [ pointer: c:char { } ]
+ [ "character" fortran-arg-type>c-type ] unit-test
+
+ [ pointer: c:char { } ]
+ [ "character(1)" fortran-arg-type>c-type ] unit-test
+
+ [ pointer: { c:char 17 } { long } ]
+ [ "character(17)" fortran-arg-type>c-type ] unit-test
+
+ ! fortran-ret-type>c-type
+
+ [ c:char { } ]
+ [ "character(1)" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: { c:char 17 } long } ]
+ [ "character(17)" fortran-ret-type>c-type ] unit-test
+
+ [ c:int { } ]
+ [ "integer" fortran-ret-type>c-type ] unit-test
+
+ [ c:int { } ]
+ [ "logical" fortran-ret-type>c-type ] unit-test
+
+ [ c:float { } ]
+ [ "real" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: { c:float 0 } } ]
+ [ "real(*)" fortran-ret-type>c-type ] unit-test
+
+ [ c:double { } ]
+ [ "double-precision" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: complex-float } ]
+ [ "complex" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: complex-double } ]
+ [ "double-complex" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: { c:int 0 } } ]
+ [ "integer(*)" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: fortran_test_record } ]
+ [
+ [
+ "alien.fortran.tests" use-vocab
+ "fortran_test_record" fortran-ret-type>c-type
+ ] with-manifest
+ ] unit-test
+
+ ! fortran-sig>c-sig
+
+ [ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
+ [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
+ unit-test
+
+ [ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
+ [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
+ unit-test
+
+ [ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
+ [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
+ unit-test
+
+ [ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
+ [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
+ unit-test
+
+ ! (fortran-invoke)
+
+ [ [
+ ! [fortran-args>c-args]
+ {
+ [ {
+ [ ascii string>alien ]
+ [ longlong <ref> ]
+ [ float <ref> ]
+ [ <complex-float> ]
+ [ 1 0 ? c:short <ref> ]
+ } spread ]
+ [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
+ } 5 ncleave
+ ! [fortran-invoke]
+ [
+ c:void "funpack" "funtimes_"
+ { pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
+ alien-invoke
+ ] 6 nkeep
+ ! [fortran-results>]
+ shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
+ {
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ float deref ]
+ [ drop ]
+ [ drop ]
+ } spread
+ ] ] [
+ f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
+ (fortran-invoke)
+ ] unit-test
+
+ [ [
+ ! [fortran-args>c-args]
+ {
+ [ { [ ] } spread ]
+ [ { [ drop ] } spread ]
+ } 1 ncleave
+ ! [fortran-invoke]
+ [ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
+ 1 nkeep
+ ! [fortran-results>]
+ shuffle( reta aa -- reta aa )
+ { [ ] [ drop ] } spread
+ ] ] [
+ "REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
+ (fortran-invoke)
+ ] unit-test
+
+ [ [
+ ! [<fortran-result>]
+ [ complex-float heap-size <byte-array> ] 1 ndip
+ ! [fortran-args>c-args]
+ { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
+ ! [fortran-invoke]
+ [
+ c:void "funpack" "fun_times_"
+ { pointer: complex-float pointer: { c:float 0 } }
+ alien-invoke
+ ] 2 nkeep
+ ! [fortran-results>]
+ shuffle( reta aa -- reta aa )
+ { [ *complex-float ] [ drop ] } spread
+ ] ] [
+ "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
+ (fortran-invoke)
+ ] unit-test
+
+ [ [
+ ! [<fortran-result>]
+ [ 20 <byte-array> 20 ] 0 ndip
+ ! [fortran-invoke]
+ [
+ c:void "funpack" "fun_times_"
+ { pointer: { c:char 20 } long }
+ alien-invoke
+ ] 2 nkeep
+ ! [fortran-results>]
+ shuffle( reta retb -- reta retb )
+ { [ ] [ ascii alien>nstring ] } spread
+ ] ] [
+ "CHARACTER*20" "funpack" "FUN_TIMES" { }
+ (fortran-invoke)
+ ] unit-test
+
+ [ [
+ ! [<fortran-result>]
+ [ 10 <byte-array> 10 ] 3 ndip
+ ! [fortran-args>c-args]
+ {
+ [ {
+ [ ascii string>alien ]
+ [ float <ref> ]
+ [ ascii string>alien ]
+ } spread ]
+ [ { [ length ] [ drop ] [ length ] } spread ]
+ } 3 ncleave
+ ! [fortran-invoke]
+ [
+ c:void "funpack" "fun_times_"
+ { pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long }
+ alien-invoke
+ ] 7 nkeep
+ ! [fortran-results>]
+ shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
+ {
+ [ ]
+ [ ascii alien>nstring ]
+ [ ]
+ [ ascii alien>nstring ]
+ [ float deref ]
+ [ ]
+ [ ascii alien>nstring ]
+ } spread
+ ] ] [
+ "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
+ (fortran-invoke)
+ ] unit-test
+
+] with-variable ! intel-unix-abi
+
+intel-windows-abi fortran-abi [
+
+ [ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test
+ [ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
+ [ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
+
+] with-variable
+
+f2c-abi fortran-abi [
+
+ [ { c:char 1 } ]
+ [ "character(1)" fortran-type>c-type ] unit-test
+
+ [ pointer: c:char { c:long } ]
+ [ "character" fortran-arg-type>c-type ] unit-test
+
+ [ c:void { pointer: c:char c:long } ]
+ [ "character" fortran-ret-type>c-type ] unit-test
+
+ [ c:double { } ]
+ [ "real" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: { c:float 0 } } ]
+ [ "real(*)" fortran-ret-type>c-type ] unit-test
+
+ [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
+ [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
+ [ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
+
+] with-variable
+
+gfortran-abi fortran-abi [
+
+ [ c:float { } ]
+ [ "real" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: { c:float 0 } } ]
+ [ "real(*)" fortran-ret-type>c-type ] unit-test
+
+ [ complex-float { } ]
+ [ "complex" fortran-ret-type>c-type ] unit-test
+
+ [ complex-double { } ]
+ [ "double-complex" fortran-ret-type>c-type ] unit-test
+
+ [ { char 1 } ]
+ [ "character(1)" fortran-type>c-type ] unit-test
+
+ [ pointer: c:char { c:long } ]
+ [ "character" fortran-arg-type>c-type ] unit-test
+
+ [ c:void { pointer: c:char c:long } ]
+ [ "character" fortran-ret-type>c-type ] unit-test
+
+ [ complex-float { } ]
+ [ "complex" fortran-ret-type>c-type ] unit-test
+
+ [ complex-double { } ]
+ [ "double-complex" fortran-ret-type>c-type ] unit-test
+
+ [ c:void { pointer: { complex-double 3 } } ]
+ [ "double-complex(3)" fortran-ret-type>c-type ] unit-test
+
+] with-variable
--- /dev/null
+! (c) 2009 Joe Groff, see BSD license
+USING: accessors alien alien.complex alien.c-types alien.data
+alien.parser grouping alien.strings alien.syntax arrays ascii
+assocs byte-arrays combinators combinators.short-circuit fry
+generalizations kernel lexer macros math math.parser namespaces
+parser sequences sequences.generalizations splitting
+stack-checker vectors vocabs.parser words locals
+io.encodings.ascii io.encodings.string shuffle effects
+math.ranges math.order sorting strings system alien.libraries ;
+QUALIFIED-WITH: alien.c-types c
+IN: alien.fortran
+
+SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
+
+<<
+: add-f2c-libraries ( -- )
+ "I77" "libI77.so" cdecl add-library
+ "F77" "libF77.so" cdecl add-library ;
+
+! os netbsd? [ add-f2c-libraries ] when
+>>
+
+: alien>nstring ( alien len encoding -- string )
+ [ memory>byte-array ] dip decode ;
+
+ERROR: invalid-fortran-type type ;
+
+DEFER: fortran-sig>c-sig
+DEFER: fortran-ret-type>c-type
+DEFER: fortran-arg-type>c-type
+DEFER: fortran-name>symbol-name
+
+SYMBOL: library-fortran-abis
+SYMBOL: fortran-abi
+library-fortran-abis [ H{ } clone ] initialize
+
+<PRIVATE
+
+: lowercase-name-with-underscore ( name -- name' )
+ >lower "_" append ;
+: lowercase-name-with-extra-underscore ( name -- name' )
+ >lower CHAR: _ over member?
+ [ "__" append ] [ "_" append ] if ;
+
+HOOK: fortran-c-abi fortran-abi ( -- abi )
+M: f2c-abi fortran-c-abi cdecl ;
+M: g95-abi fortran-c-abi cdecl ;
+M: gfortran-abi fortran-c-abi cdecl ;
+M: intel-unix-abi fortran-c-abi cdecl ;
+M: intel-windows-abi fortran-c-abi cdecl ;
+
+HOOK: real-functions-return-double? fortran-abi ( -- ? )
+M: f2c-abi real-functions-return-double? t ;
+M: g95-abi real-functions-return-double? f ;
+M: gfortran-abi real-functions-return-double? f ;
+M: intel-unix-abi real-functions-return-double? f ;
+M: intel-windows-abi real-functions-return-double? f ;
+
+HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
+M: f2c-abi complex-functions-return-by-value? f ;
+M: g95-abi complex-functions-return-by-value? f ;
+M: gfortran-abi complex-functions-return-by-value? t ;
+M: intel-unix-abi complex-functions-return-by-value? f ;
+M: intel-windows-abi complex-functions-return-by-value? f ;
+
+HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
+M: f2c-abi character(1)-maps-to-char? f ;
+M: g95-abi character(1)-maps-to-char? f ;
+M: gfortran-abi character(1)-maps-to-char? f ;
+M: intel-unix-abi character(1)-maps-to-char? t ;
+M: intel-windows-abi character(1)-maps-to-char? t ;
+
+HOOK: mangle-name fortran-abi ( name -- name' )
+M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
+M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
+M: gfortran-abi mangle-name lowercase-name-with-underscore ;
+M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
+M: intel-windows-abi mangle-name >upper ;
+
+TUPLE: fortran-type dims size out? ;
+
+TUPLE: number-type < fortran-type ;
+TUPLE: integer-type < number-type ;
+TUPLE: logical-type < integer-type ;
+TUPLE: real-type < number-type ;
+TUPLE: double-precision-type < number-type ;
+
+TUPLE: character-type < fortran-type ;
+TUPLE: misc-type < fortran-type name ;
+
+TUPLE: complex-type < number-type ;
+TUPLE: real-complex-type < complex-type ;
+TUPLE: double-complex-type < complex-type ;
+
+CONSTANT: fortran>c-types H{
+ { "character" character-type }
+ { "integer" integer-type }
+ { "logical" logical-type }
+ { "real" real-type }
+ { "double-precision" double-precision-type }
+ { "complex" real-complex-type }
+ { "double-complex" double-complex-type }
+}
+
+: append-dimensions ( base-c-type type -- c-type )
+ dims>> [ product 2array ] when* ;
+
+MACRO: size-case-type ( cases -- )
+ [ invalid-fortran-type ] suffix
+ '[ [ size>> _ case ] [ append-dimensions ] bi ] ;
+
+: simple-type ( type base-c-type -- c-type )
+ swap
+ [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
+ [ append-dimensions ] bi ;
+
+: new-fortran-type ( out? dims size class -- type )
+ new [ [ size<< ] [ dims<< ] [ out?<< ] tri ] keep ;
+
+GENERIC: (fortran-type>c-type) ( type -- c-type )
+
+M: f (fortran-type>c-type) drop c:void ;
+
+M: integer-type (fortran-type>c-type)
+ {
+ { f [ c:int ] }
+ { 1 [ c:char ] }
+ { 2 [ c:short ] }
+ { 4 [ c:int ] }
+ { 8 [ c:longlong ] }
+ } size-case-type ;
+M: real-type (fortran-type>c-type)
+ {
+ { f [ c:float ] }
+ { 4 [ c:float ] }
+ { 8 [ c:double ] }
+ } size-case-type ;
+M: real-complex-type (fortran-type>c-type)
+ {
+ { f [ complex-float ] }
+ { 8 [ complex-float ] }
+ { 16 [ complex-double ] }
+ } size-case-type ;
+
+M: double-precision-type (fortran-type>c-type)
+ c:double simple-type ;
+M: double-complex-type (fortran-type>c-type)
+ complex-double simple-type ;
+M: misc-type (fortran-type>c-type)
+ dup name>> parse-c-type simple-type ;
+
+: single-char? ( character-type -- ? )
+ { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
+
+: fix-character-type ( character-type -- character-type' )
+ clone dup size>>
+ [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
+ [ dup dims>> [ ] [ f >>dims ] if ] if
+ dup single-char? [ f >>dims ] when ;
+
+M: character-type (fortran-type>c-type)
+ fix-character-type c:char simple-type ;
+
+: dimension>number ( string -- number )
+ dup "*" = [ drop 0 ] [ string>number ] if ;
+
+: parse-out ( string -- string' out? )
+ "!" ?head ;
+
+: parse-dims ( string -- string' dim )
+ "(" split1 dup
+ [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
+
+: parse-size ( string -- string' size )
+ "*" split1 dup [ string>number ] when ;
+
+: (parse-fortran-type) ( fortran-type-string -- type )
+ parse-out swap parse-dims swap parse-size swap
+ >lower fortran>c-types ?at
+ [ new-fortran-type ] [ misc-type boa ] if ;
+
+: parse-fortran-type ( fortran-type-string/f -- type/f )
+ dup [ (parse-fortran-type) ] when ;
+
+GENERIC: added-c-args ( type -- args )
+
+M: fortran-type added-c-args drop { } ;
+M: character-type added-c-args fix-character-type single-char? [ { } ] [ { c:long } ] if ;
+
+GENERIC: returns-by-value? ( type -- ? )
+
+M: f returns-by-value? drop t ;
+M: fortran-type returns-by-value? drop f ;
+M: number-type returns-by-value? dims>> not ;
+M: character-type returns-by-value? fix-character-type single-char? ;
+M: complex-type returns-by-value?
+ { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
+
+GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
+
+M: f (fortran-ret-type>c-type) drop c:void ;
+M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
+M: real-type (fortran-ret-type>c-type)
+ drop real-functions-return-double? [ c:double ] [ c:float ] if ;
+
+GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
+
+: args?dims ( type quot -- main-quot added-quot )
+ [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
+
+M: integer-type (fortran-arg>c-args)
+ [
+ size>> {
+ { f [ [ c:int <ref> ] [ drop ] ] }
+ { 1 [ [ c:char <ref> ] [ drop ] ] }
+ { 2 [ [ c:short <ref> ] [ drop ] ] }
+ { 4 [ [ c:int <ref> ] [ drop ] ] }
+ { 8 [ [ c:longlong <ref> ] [ drop ] ] }
+ [ invalid-fortran-type ]
+ } case
+ ] args?dims ;
+
+M: logical-type (fortran-arg>c-args)
+ [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
+
+M: real-type (fortran-arg>c-args)
+ [
+ size>> {
+ { f [ [ c:float <ref> ] [ drop ] ] }
+ { 4 [ [ c:float <ref> ] [ drop ] ] }
+ { 8 [ [ c:double <ref> ] [ drop ] ] }
+ [ invalid-fortran-type ]
+ } case
+ ] args?dims ;
+
+M: real-complex-type (fortran-arg>c-args)
+ [
+ size>> {
+ { f [ [ <complex-float> ] [ drop ] ] }
+ { 8 [ [ <complex-float> ] [ drop ] ] }
+ { 16 [ [ <complex-double> ] [ drop ] ] }
+ [ invalid-fortran-type ]
+ } case
+ ] args?dims ;
+
+M: double-precision-type (fortran-arg>c-args)
+ [ drop [ c:double <ref> ] [ drop ] ] args?dims ;
+
+M: double-complex-type (fortran-arg>c-args)
+ [ drop [ <complex-double> ] [ drop ] ] args?dims ;
+
+M: character-type (fortran-arg>c-args)
+ fix-character-type single-char?
+ [ [ first c:char <ref> ] [ drop ] ]
+ [ [ ascii string>alien ] [ length ] ] if ;
+
+M: misc-type (fortran-arg>c-args)
+ drop [ ] [ drop ] ;
+
+GENERIC: (fortran-result>) ( type -- quots )
+
+: result?dims ( type quot -- quot )
+ [ dup dims>> [ drop { [ ] } ] ] dip if ; inline
+
+M: integer-type (fortran-result>)
+ [
+ size>> {
+ { f [ { [ c:int deref ] } ] }
+ { 1 [ { [ c:char deref ] } ] }
+ { 2 [ { [ c:short deref ] } ] }
+ { 4 [ { [ c:int deref ] } ] }
+ { 8 [ { [ c:longlong deref ] } ] }
+ [ invalid-fortran-type ]
+ } case
+ ] result?dims ;
+
+M: logical-type (fortran-result>)
+ [ call-next-method first [ zero? not ] append 1array ] result?dims ;
+
+M: real-type (fortran-result>)
+ [ size>> {
+ { f [ { [ c:float deref ] } ] }
+ { 4 [ { [ c:float deref ] } ] }
+ { 8 [ { [ c:double deref ] } ] }
+ [ invalid-fortran-type ]
+ } case ] result?dims ;
+
+M: real-complex-type (fortran-result>)
+ [ size>> {
+ { f [ { [ *complex-float ] } ] }
+ { 8 [ { [ *complex-float ] } ] }
+ { 16 [ { [ *complex-double ] } ] }
+ [ invalid-fortran-type ]
+ } case ] result?dims ;
+
+M: double-precision-type (fortran-result>)
+ [ drop { [ c:double deref ] } ] result?dims ;
+
+M: double-complex-type (fortran-result>)
+ [ drop { [ *complex-double ] } ] result?dims ;
+
+M: character-type (fortran-result>)
+ fix-character-type single-char?
+ [ { [ c:char deref 1string ] } ]
+ [ { [ ] [ ascii alien>nstring ] } ] if ;
+
+M: misc-type (fortran-result>)
+ drop { [ ] } ;
+
+GENERIC: (<fortran-result>) ( type -- quot )
+
+M: fortran-type (<fortran-result>)
+ (fortran-type>c-type) \ heap-size \ <byte-array> [ ] 3sequence ;
+
+M: character-type (<fortran-result>)
+ fix-character-type dims>> product dup
+ [ \ <byte-array> ] dip [ ] 3sequence ;
+
+: [<fortran-result>] ( return parameters -- quot )
+ [ parse-fortran-type ] dip
+ over returns-by-value?
+ [ 2drop [ ] ]
+ [ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
+
+: [fortran-args>c-args] ( parameters -- quot )
+ [ [ ] ] [
+ [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
+ [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
+ \ ncleave [ ] 3sequence
+ ] if-empty ;
+
+:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
+ return parameters fortran-sig>c-sig :> ( c-return c-parameters )
+ function fortran-name>symbol-name :> c-function
+ [args>args]
+ c-return library c-function c-parameters \ alien-invoke
+ 5 [ ] nsequence
+ c-parameters length \ nkeep
+ [ ] 3sequence ;
+
+: [fortran-out-param>] ( parameter -- quot )
+ parse-fortran-type
+ [ (fortran-result>) ] [ out?>> ] bi
+ [ ] [ [ drop [ drop ] ] map ] if ;
+
+: [fortran-return>] ( return -- quot )
+ parse-fortran-type {
+ { [ dup not ] [ drop { } ] }
+ { [ dup returns-by-value? ] [ drop { [ ] } ] }
+ [ (fortran-result>) ]
+ } cond ;
+
+: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
+
+: (shuffle-map) ( return parameters -- ret par )
+ [
+ fortran-ret-type>c-type length swap void? [ 1 + ] unless
+ letters swap head [ "ret" swap suffix ] map
+ ] [
+ [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
+ [ first2 letters swap head [ "" 2sequence ] with map ] map concat
+ ] bi* ;
+
+: (fortran-in-shuffle) ( ret par -- seq )
+ [ second ] sort-with append ;
+
+: (fortran-out-shuffle) ( ret par -- seq )
+ append ;
+
+: [fortran-result-shuffle] ( return parameters -- quot )
+ (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
+ \ shuffle-effect [ ] 2sequence ;
+
+: [fortran-results>] ( return parameters -- quot )
+ [ [fortran-result-shuffle] ]
+ [ drop [fortran-return>] ]
+ [ nip [ [fortran-out-param>] ] map concat ] 2tri
+ append
+ \ spread [ ] 2sequence append ;
+
+: (add-fortran-library) ( fortran-abi name -- )
+ library-fortran-abis get-global set-at ;
+
+PRIVATE>
+
+: add-fortran-library ( name soname fortran-abi -- )
+ [ fortran-abi [ fortran-c-abi ] with-variable add-library ]
+ [ nip swap (add-fortran-library) ] 3bi ;
+
+: fortran-name>symbol-name ( fortran-name -- c-name )
+ mangle-name ;
+
+: fortran-type>c-type ( fortran-type -- c-type )
+ parse-fortran-type (fortran-type>c-type) ;
+
+: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
+ parse-fortran-type
+ [ (fortran-type>c-type) <pointer> ]
+ [ added-c-args ] bi ;
+: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
+ parse-fortran-type dup returns-by-value?
+ [ (fortran-ret-type>c-type) { } ] [
+ c:void swap
+ [ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
+ ] if ;
+
+: fortran-arg-types>c-types ( fortran-types -- c-types )
+ [ length <vector> 1 <vector> ] keep
+ [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
+ append >array ;
+
+: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
+ [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
+
+: set-fortran-abi ( library -- )
+ library-fortran-abis get-global at fortran-abi set ;
+
+: (fortran-invoke) ( return library function parameters -- quot )
+ {
+ [ 2nip [<fortran-result>] ]
+ [ nip nip nip [fortran-args>c-args] ]
+ [ [fortran-invoke] ]
+ [ 2nip [fortran-results>] ]
+ } 4 ncleave 4 nappend ;
+
+MACRO: fortran-invoke ( return library function parameters -- )
+ { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
+
+: parse-arglist ( parameters return -- types effect )
+ [
+ 2 group
+ [ unzip [ "," ?tail drop ] map ]
+ [ [ first "!" head? ] filter [ second "," ?tail drop "'" append ] map ] bi
+ ] [ [ ] [ prefix ] if-void ]
+ bi* <effect> ;
+
+:: define-fortran-function ( return library function parameters -- )
+ function create-function
+ return library function parameters return [ c:void ] unless* parse-arglist
+ [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
+
+SYNTAX: SUBROUTINE:
+ f current-library get scan-token ";" parse-tokens
+ [ "()" subseq? not ] filter define-fortran-function ;
+
+SYNTAX: FUNCTION:
+ scan-token current-library get scan-token ";" parse-tokens
+ [ "()" subseq? not ] filter define-fortran-function ;
+
+SYNTAX: LIBRARY:
+ scan-token
+ [ current-library set ]
+ [ set-fortran-abi ] bi ;
+
--- /dev/null
+GNU Fortran/G77/F2C alien interface
--- /dev/null
+fortran
+ffi
--- /dev/null
+USING: alien.fortran help.markup help.syntax math.blas.config ;
+IN: math.blas.config
+
+ARTICLE: "math.blas.config" "Configuring the BLAS interface"
+"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
+{ $subsections
+ blas-library
+ blas-fortran-abi
+ deploy-blas?
+}
+"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link ".factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet ".factor-rc" } " would look like this:"
+{ $code """
+USING: math.blas.config namespaces ;
+"X:\\path\\to\\acml.dll" blas-library set-global
+intel-windows-abi blas-fortran-abi set-global
+t deploy-blas? set-global
+""" }
+"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
+;
+
+HELP: blas-library
+{ $var-description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: blas-fortran-abi
+{ $var-description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: deploy-blas?
+{ $var-description "If set to a true value, the BLAS library will be configured to deploy with applications that use it. To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+ABOUT: "math.blas.config"
--- /dev/null
+USING: alien.fortran combinators kernel namespaces system ;
+IN: math.blas.config
+
+SYMBOLS: blas-library blas-fortran-abi deploy-blas? ;
+
+blas-library [
+ {
+ { [ os macosx? ] [ "libblas.dylib" ] }
+ { [ os windows? ] [ "blas.dll" ] }
+ [ "libblas.so" ]
+ } cond
+] initialize
+
+blas-fortran-abi [
+ {
+ { [ os macosx? ] [ intel-unix-abi ] }
+ { [ os windows? cpu x86.32? and ] [ f2c-abi ] }
+ { [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
+ ! { [ os freebsd? ] [ gfortran-abi ] }
+ { [ os linux? ] [ gfortran-abi ] }
+ [ f2c-abi ]
+ } cond
+] initialize
+
+deploy-blas? [ os macosx? not ] initialize
--- /dev/null
+USING: alien.fortran kernel math.blas.config namespaces ;
+FROM: alien.libraries => deploy-library ;
+IN: math.blas.ffi
+
+<<
+"blas" blas-library blas-fortran-abi [ get ] bi@
+add-fortran-library
+
+deploy-blas? get [ "blas" deploy-library ] when
+>>
+
+LIBRARY: blas
+
+! Level 1 BLAS (scalar-vector and vector-vector)
+
+FUNCTION: REAL SDSDOT
+ ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-PRECISION DSDOT
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: REAL SDOT
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-PRECISION DDOT
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+
+FUNCTION: COMPLEX CDOTU
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+FUNCTION: COMPLEX CDOTC
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+
+FUNCTION: DOUBLE-COMPLEX ZDOTU
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-COMPLEX ZDOTC
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+
+FUNCTION: REAL SNRM2
+ ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+FUNCTION: REAL SASUM
+ ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+
+FUNCTION: DOUBLE-PRECISION DNRM2
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+FUNCTION: DOUBLE-PRECISION DASUM
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+
+FUNCTION: REAL SCNRM2
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: REAL SCASUM
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+
+FUNCTION: DOUBLE-PRECISION DZNRM2
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: DOUBLE-PRECISION DZASUM
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+FUNCTION: INTEGER ISAMAX
+ ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER IDAMAX
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER ICAMAX
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER IZAMAX
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: SSWAP
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SCOPY
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SAXPY
+ ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: DSWAP
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DCOPY
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DAXPY
+ ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: CSWAP
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CCOPY
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CAXPY
+ ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: ZSWAP
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZCOPY
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZAXPY
+ ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: SSCAL
+ ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: DSCAL
+ ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: CSCAL
+ ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZSCAL
+ ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CSSCAL
+ ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZDSCAL
+ ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: SROTG
+ ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ;
+SUBROUTINE: SROTMG
+ ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ;
+SUBROUTINE: SROT
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ;
+SUBROUTINE: SROTM
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ;
+
+SUBROUTINE: DROTG
+ ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ;
+SUBROUTINE: DROTMG
+ ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ;
+SUBROUTINE: DROT
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ;
+SUBROUTINE: DROTM
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ;
+
+! LEVEL 2 BLAS (MATRIX-VECTOR)
+
+SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX, REAL BETA,
+ REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, REAL ALPHA,
+ REAL(*) A, INTEGER LDA, REAL(*) X,
+ INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: STRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: STBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA,
+ DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA,
+ DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DTRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: DTBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX, COMPLEX BETA,
+ COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, COMPLEX ALPHA,
+ COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
+ INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CTRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: CTBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA,
+ DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
+ INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+
+SUBROUTINE: SSYMV ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) A,
+ INTEGER LDA, REAL(*) X, INTEGER INCX,
+ REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SSBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A,
+ INTEGER LDA, REAL(*) X, INTEGER INCX,
+ REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SSPMV ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) AP,
+ REAL(*) X, INTEGER INCX,
+ REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SGER ( INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) X, INTEGER INCX,
+ REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ;
+SUBROUTINE: SSYR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) A, INTEGER LDA ) ;
+SUBROUTINE: SSPR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) AP ) ;
+SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A,
+ INTEGER LDA ) ;
+SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ;
+
+SUBROUTINE: DSYMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+ INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DSBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+ INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DSPMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP,
+ DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DGER ( INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
+SUBROUTINE: DSYR ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
+SUBROUTINE: DSPR ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) AP ) ;
+SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A,
+ INTEGER LDA ) ;
+SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ;
+
+
+SUBROUTINE: CHEMV ( CHARACTER*1 UPLO,
+ INTEGER N, COMPLEX ALPHA, COMPLEX(*) A,
+ INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CHBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
+ INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CHPMV ( CHARACTER*1 UPLO,
+ INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP,
+ COMPLEX(*) X, INTEGER INCX,
+ COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CGERU ( INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CGERC ( INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHER ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHPR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, COMPLEX(*) X,
+ INTEGER INCX, COMPLEX(*) A ) ;
+SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ;
+
+SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+ INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+ INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZGERU ( INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZGERC ( INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHER ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHPR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X,
+ INTEGER INCX, DOUBLE-COMPLEX(*) A ) ;
+SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ;
+
+! LEVEL 3 BLAS (MATRIX-MATRIX)
+
+SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, REAL ALPHA, REAL(*) A,
+ INTEGER LDA, REAL(*) B, INTEGER LDB,
+ REAL BETA, REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB, REAL BETA,
+ REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL BETA, REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB, REAL BETA,
+ REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: STRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB ) ;
+SUBROUTINE: STRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+ INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
+ DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
+ DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DTRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
+SUBROUTINE: DTRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
+ INTEGER LDA, COMPLEX(*) B, INTEGER LDB,
+ COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CTRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB ) ;
+SUBROUTINE: CTRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+ INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
+SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: CHEMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CHERK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, COMPLEX(*) A, INTEGER LDA,
+ REAL BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CHER2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, REAL BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHERK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
--- /dev/null
+Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library
--- /dev/null
+math
+bindings
+fortran
--- /dev/null
+USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
+IN: math.blas.matrices
+
+ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
+"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
+{ $subsections "math.blas-types" }
+"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
+{ $subsections "math.blas.vectors" }
+"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
+{ $subsections "math.blas.matrices" }
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
+{ $subsections "math.blas.config" } ;
+
+ARTICLE: "math.blas-types" "BLAS interface types"
+"BLAS vectors come in single- and double-precision, real and complex flavors:"
+{ $subsections
+ float-blas-vector
+ double-blas-vector
+ complex-float-blas-vector
+ complex-double-blas-vector
+}
+"These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
+{ $subsections
+ float-blas-matrix
+ double-blas-matrix
+ complex-float-blas-matrix
+ complex-double-blas-matrix
+}
+"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
+{ $subsections
+ <float-blas-vector>
+ <double-blas-vector>
+ <complex-float-blas-vector>
+ <complex-double-blas-vector>
+ <float-blas-matrix>
+ <double-blas-matrix>
+ <complex-float-blas-matrix>
+ <complex-double-blas-matrix>
+}
+"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
+{ $subsections
+ <empty-vector>
+ <empty-matrix>
+}
+"BLAS vectors and matrices can also be constructed from other Factor sequences:"
+{ $subsections
+ >float-blas-vector
+ >double-blas-vector
+ >complex-float-blas-vector
+ >complex-double-blas-vector
+ >float-blas-matrix
+ >double-blas-matrix
+ >complex-float-blas-matrix
+ >complex-double-blas-matrix
+} ;
+
+ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
+"Transposing and slicing matrices:"
+{ $subsections
+ Mtranspose
+ Mrows
+ Mcols
+ Msub
+}
+"Matrix-vector products:"
+{ $subsections
+ n*M.V+n*V!
+ n*M.V+n*V
+ n*M.V
+ M.V
+}
+"Vector outer products:"
+{ $subsections
+ n*V(*)V+M!
+ n*V(*)Vconj+M!
+ n*V(*)V+M
+ n*V(*)Vconj+M
+ n*V(*)V
+ n*V(*)Vconj
+ V(*)
+ V(*)conj
+}
+"Matrix products:"
+{ $subsections
+ n*M.M+n*M!
+ n*M.M+n*M
+ n*M.M
+ M.
+}
+"Scalar-matrix products:"
+{ $subsections
+ n*M!
+ n*M
+ M*n
+ M/n
+}
+"Literal syntax:"
+{ $subsections
+ POSTPONE: smatrix{
+ POSTPONE: dmatrix{
+ POSTPONE: cmatrix{
+ POSTPONE: zmatrix{
+} ;
+
+
+ABOUT: "math.blas.matrices"
+
+HELP: blas-matrix-base
+{ $class-description "The base class for all BLAS matrix types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
+{ $list
+ { { $link float-blas-matrix } }
+ { { $link double-blas-matrix } }
+ { { $link complex-float-blas-matrix } }
+ { { $link complex-double-blas-matrix } }
+}
+"All of these subclasses share the same tuple layout:"
+{ $list
+ { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
+ { { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" }
+ { { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" }
+ { "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." }
+} } ;
+
+{ blas-vector-base blas-matrix-base } related-words
+
+HELP: float-blas-matrix
+{ $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+HELP: double-blas-matrix
+{ $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+HELP: complex-float-blas-matrix
+{ $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+HELP: complex-double-blas-matrix
+{ $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
+
+{
+ float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix
+ float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector
+} related-words
+
+HELP: Mwidth
+{ $values { "matrix" blas-matrix-base } { "width" integer } }
+{ $description "Returns the number of columns in " { $snippet "matrix" } "." } ;
+
+HELP: Mheight
+{ $values { "matrix" blas-matrix-base } { "height" integer } }
+{ $description "Returns the number of rows in " { $snippet "matrix" } "." } ;
+
+{ Mwidth Mheight } related-words
+
+HELP: n*M.V+n*V!
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "y=alpha*A.x+b*y" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." }
+{ $side-effects "y" } ;
+
+HELP: n*V(*)V+M!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)y+A" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." }
+{ $side-effects "A" } ;
+
+HELP: n*V(*)Vconj+M!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)yconj+A" blas-matrix-base } }
+{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." }
+{ $side-effects "A" } ;
+
+HELP: n*M.M+n*M!
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "C=alpha*A.B+beta*C" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." }
+{ $side-effects "C" } ;
+
+HELP: <empty-matrix>
+{ $values { "rows" integer } { "cols" integer } { "exemplar" blas-vector-base blas-matrix-base } { "matrix" blas-matrix-base } }
+{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ;
+
+{ <zero-vector> <empty-vector> <empty-matrix> } related-words
+
+HELP: n*M.V+n*V
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "alpha*A.x+b*y" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ;
+
+HELP: n*V(*)V+M
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)y+A" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
+
+HELP: n*V(*)Vconj+M
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)yconj+A" blas-matrix-base } }
+{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ;
+
+HELP: n*M.M+n*M
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "alpha*A.B+beta*C" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
+
+HELP: n*M.V
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "alpha*A.x" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
+
+HELP: M.V
+{ $values { "A" blas-matrix-base } { "x" blas-vector-base } { "A.x" blas-vector-base } }
+{ $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
+
+{ n*M.V+n*V! n*M.V+n*V n*M.V M.V } related-words
+
+HELP: n*V(*)V
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)y" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
+
+HELP: n*V(*)Vconj
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)yconj" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
+
+HELP: V(*)
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)y" blas-matrix-base } }
+{ $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
+
+HELP: V(*)conj
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)yconj" blas-matrix-base } }
+{ $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
+
+{ n*V(*)V+M! n*V(*)Vconj+M! n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words
+
+HELP: n*M.M
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "alpha*A.B" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
+
+HELP: M.
+{ $values { "A" blas-matrix-base } { "B" blas-matrix-base } { "A.B" blas-matrix-base } }
+{ $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
+
+{ n*M.M+n*M! n*M.M+n*M n*M.M M. } related-words
+
+HELP: Msub
+{ $values { "matrix" blas-matrix-base } { "row" integer } { "col" integer } { "height" integer } { "width" integer } { "sub" blas-matrix-base } }
+{ $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ;
+
+HELP: Mrows
+{ $values { "A" blas-matrix-base } { "rows" sequence } }
+{ $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
+
+HELP: Mcols
+{ $values { "A" blas-matrix-base } { "cols" sequence } }
+{ $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
+
+HELP: n*M!
+{ $values { "n" number } { "A" blas-matrix-base } { "A=n*A" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." }
+{ $side-effects "A" } ;
+
+HELP: n*M
+{ $values { "n" number } { "A" blas-matrix-base } { "n*A" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
+
+HELP: M*n
+{ $values { "A" blas-matrix-base } { "n" number } { "A*n" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
+
+HELP: M/n
+{ $values { "A" blas-matrix-base } { "n" number } { "A/n" blas-matrix-base } }
+{ $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
+
+{ n*M! n*M M*n M/n } related-words
+
+HELP: Mtranspose
+{ $values { "matrix" blas-matrix-base } { "matrix^T" blas-matrix-base } }
+{ $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ;
+
+HELP: element-type
+{ $values { "v" blas-vector-base blas-matrix-base } { "type" string } }
+{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ;
+
+HELP: <empty-vector>
+{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
+{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
+
+HELP: smatrix{
+{ $syntax """smatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+}""" }
+{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: dmatrix{
+{ $syntax """dmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 1.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ { 0.0 0.0 0.0 1.0 }
+}""" }
+{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: cmatrix{
+{ $syntax """cmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+}""" }
+{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+HELP: zmatrix{
+{ $syntax """zmatrix{
+ { 1.0 0.0 0.0 1.0 }
+ { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 -1.0 3.0 }
+ { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
+}""" }
+{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+
+{
+ POSTPONE: smatrix{ POSTPONE: dmatrix{
+ POSTPONE: cmatrix{ POSTPONE: zmatrix{
+} related-words
--- /dev/null
+USING: kernel math.blas.matrices math.blas.vectors
+sequences tools.test ;
+IN: math.blas.matrices.tests
+
+! clone
+
+[ smatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+} ] [
+ smatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } clone
+] unit-test
+[ f ] [
+ smatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } dup clone eq?
+] unit-test
+
+[ dmatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+} ] [
+ dmatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } clone
+] unit-test
+[ f ] [
+ dmatrix{
+ { 1.0 2.0 3.0 }
+ { 4.0 5.0 6.0 }
+ { 7.0 8.0 9.0 }
+ } dup clone eq?
+] unit-test
+
+[ cmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+} ] [
+ cmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } clone
+] unit-test
+[ f ] [
+ cmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } dup clone eq?
+] unit-test
+
+[ zmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+} ] [
+ zmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } clone
+] unit-test
+[ f ] [
+ zmatrix{
+ { C{ 1.0 1.0 } 2.0 3.0 }
+ { 4.0 C{ 5.0 2.0 } 6.0 }
+ { 7.0 8.0 C{ 9.0 3.0 } }
+ } dup clone eq?
+] unit-test
+
+! M.V
+
+[ svector{ 3.0 1.0 6.0 } ] [
+ smatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ svector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ svector{ -2.0 1.0 3.0 14.0 } ] [
+ smatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ svector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+[ dvector{ 3.0 1.0 6.0 } ] [
+ dmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ dvector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ dvector{ -2.0 1.0 3.0 14.0 } ] [
+ dmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 0.0 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ dvector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+[ cvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
+ cmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ cvector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ cvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
+ cmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ cvector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+[ zvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
+ zmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ }
+ zvector{ 1.0 2.0 3.0 1.0 }
+ M.V
+] unit-test
+[ zvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
+ zmatrix{
+ { 0.0 1.0 0.0 1.0 }
+ { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
+ { 0.0 0.0 1.0 3.0 }
+ } Mtranspose
+ zvector{ 1.0 2.0 3.0 }
+ M.V
+] unit-test
+
+! V(*)
+
+[ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 4.0 6.0 8.0 }
+ { 3.0 6.0 9.0 12.0 }
+} ] [
+ svector{ 1.0 2.0 3.0 } svector{ 1.0 2.0 3.0 4.0 } V(*)
+] unit-test
+
+[ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 4.0 6.0 8.0 }
+ { 3.0 6.0 9.0 12.0 }
+} ] [
+ dvector{ 1.0 2.0 3.0 } dvector{ 1.0 2.0 3.0 4.0 } V(*)
+] unit-test
+
+[ cmatrix{
+ { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
+ { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
+ { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
+} ] [
+ cvector{ 1.0 2.0 C{ 3.0 3.0 } } cvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
+] unit-test
+
+[ zmatrix{
+ { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
+ { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
+ { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
+} ] [
+ zvector{ 1.0 2.0 C{ 3.0 3.0 } } zvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
+] unit-test
+
+! M.
+
+[ smatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 4.0 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ smatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } smatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ smatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 4.0 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ smatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose smatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+[ dmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 4.0 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ dmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } dmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ dmatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 4.0 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ dmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 2.0 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose dmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+[ cmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ cmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } cmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ cmatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ cmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose cmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+[ zmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 0.0 -3.0 0.0 0.0 }
+ { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
+ { 0.0 0.0 0.0 0.0 0.0 }
+} ] [
+ zmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } zmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } M.
+] unit-test
+
+[ zmatrix{
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
+ { 0.0 -3.0 0.0 0.0 }
+ { 4.0 0.0 0.0 0.0 }
+ { 0.0 0.0 10.0 0.0 }
+} ] [
+ zmatrix{
+ { 1.0 0.0 0.0 4.0 0.0 }
+ { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
+ { 0.0 0.0 3.0 0.0 0.0 }
+ } Mtranspose zmatrix{
+ { 1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 }
+ { 0.0 2.0 0.0 }
+ { 0.0 0.0 0.0 }
+ } Mtranspose M.
+] unit-test
+
+! n*M
+
+[ smatrix{
+ { 2.0 0.0 }
+ { 0.0 2.0 }
+} ] [
+ 2.0 smatrix{
+ { 1.0 0.0 }
+ { 0.0 1.0 }
+ } n*M
+] unit-test
+
+[ dmatrix{
+ { 2.0 0.0 }
+ { 0.0 2.0 }
+} ] [
+ 2.0 dmatrix{
+ { 1.0 0.0 }
+ { 0.0 1.0 }
+ } n*M
+] unit-test
+
+[ cmatrix{
+ { C{ 2.0 1.0 } 0.0 }
+ { 0.0 C{ -1.0 2.0 } }
+} ] [
+ C{ 2.0 1.0 } cmatrix{
+ { 1.0 0.0 }
+ { 0.0 C{ 0.0 1.0 } }
+ } n*M
+] unit-test
+
+[ zmatrix{
+ { C{ 2.0 1.0 } 0.0 }
+ { 0.0 C{ -1.0 2.0 } }
+} ] [
+ C{ 2.0 1.0 } zmatrix{
+ { 1.0 0.0 }
+ { 0.0 C{ 0.0 1.0 } }
+ } n*M
+] unit-test
+
+! Mrows, Mcols
+
+[ svector{ 3.0 3.0 3.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols nth
+] unit-test
+[ svector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols length
+] unit-test
+[ svector{ 3.0 3.0 3.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows nth
+] unit-test
+[ svector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ smatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows length
+] unit-test
+
+[ dvector{ 3.0 3.0 3.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols nth
+] unit-test
+[ dvector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mcols length
+] unit-test
+[ dvector{ 3.0 3.0 3.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows nth
+] unit-test
+[ dvector{ 3.0 2.0 3.0 4.0 } ] [
+ 2 dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ dmatrix{
+ { 1.0 2.0 3.0 4.0 }
+ { 2.0 2.0 3.0 4.0 }
+ { 3.0 2.0 3.0 4.0 }
+ } Mtranspose Mrows length
+] unit-test
+
+[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols nth
+] unit-test
+[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols length
+] unit-test
+[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows nth
+] unit-test
+[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ cmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows length
+] unit-test
+
+[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols nth
+] unit-test
+[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows nth
+] unit-test
+[ 3 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mrows length
+] unit-test
+[ 4 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mcols length
+] unit-test
+[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows nth
+] unit-test
+[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
+ 2 zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols nth
+] unit-test
+[ 3 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mcols length
+] unit-test
+[ 4 ] [
+ zmatrix{
+ { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
+ { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
+ { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
+ } Mtranspose Mrows length
+] unit-test
+
+! Msub
+
+[ smatrix{
+ { 3.0 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ smatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ smatrix{
+ { 3.0 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ smatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
+[ dmatrix{
+ { 3.0 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ dmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ dmatrix{
+ { 3.0 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ dmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 3.0 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
+[ cmatrix{
+ { C{ 3.0 3.0 } 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ cmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ cmatrix{
+ { C{ 3.0 3.0 } 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ cmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
+[ zmatrix{
+ { C{ 3.0 3.0 } 2.0 1.0 }
+ { 0.0 1.0 0.0 }
+} ] [
+ zmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } 1 2 2 3 Msub
+] unit-test
+
+[ zmatrix{
+ { C{ 3.0 3.0 } 0.0 }
+ { 2.0 1.0 }
+ { 1.0 0.0 }
+} ] [
+ zmatrix{
+ { 0.0 1.0 2.0 3.0 2.0 }
+ { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
+ { 2.0 3.0 0.0 1.0 0.0 }
+ } Mtranspose 2 1 3 2 Msub
+] unit-test
+
--- /dev/null
+USING: accessors alien alien.c-types alien.complex
+alien.data arrays byte-arrays combinators
+combinators.short-circuit fry kernel locals macros math
+math.blas.ffi math.blas.vectors math.blas.vectors.private
+math.complex math.functions math.order functors words
+sequences sequences.merged sequences.private shuffle
+parser prettyprint.backend prettyprint.custom ascii
+specialized-arrays ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: complex-double
+IN: math.blas.matrices
+
+TUPLE: blas-matrix-base underlying ld rows cols transpose ;
+
+: Mtransposed? ( matrix -- ? )
+ transpose>> ; inline
+: Mwidth ( matrix -- width )
+ dup Mtransposed? [ rows>> ] [ cols>> ] if ; inline
+: Mheight ( matrix -- height )
+ dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
+
+GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
+GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
+GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
+GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
+
+<PRIVATE
+
+: (blas-transpose) ( matrix -- integer )
+ transpose>> [ "T" ] [ "N" ] if ;
+
+GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
+
+: (validate-gemv) ( A x y -- )
+ {
+ [ drop [ Mwidth ] [ length>> ] bi* = ]
+ [ nip [ Mheight ] [ length>> ] bi* = ]
+ } 3&&
+ [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ]
+ unless ;
+
+:: (prepare-gemv)
+ ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
+ y )
+ A x y (validate-gemv)
+ A (blas-transpose)
+ A rows>>
+ A cols>>
+ alpha
+ A
+ A ld>>
+ x
+ x inc>>
+ beta
+ y
+ y inc>>
+ y ; inline
+
+: (validate-ger) ( x y A -- )
+ {
+ [ [ length>> ] [ drop ] [ Mheight ] tri* = ]
+ [ [ drop ] [ length>> ] [ Mwidth ] tri* = ]
+ } 3&&
+ [ "Mismatched vertices and matrix in vector outer product" throw ]
+ unless ;
+
+:: (prepare-ger)
+ ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld
+ A )
+ x y A (validate-ger)
+ A rows>>
+ A cols>>
+ alpha
+ x
+ x inc>>
+ y
+ y inc>>
+ A
+ A ld>>
+ A f >>transpose ; inline
+
+: (validate-gemm) ( A B C -- )
+ {
+ [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ]
+ [ [ Mheight ] [ drop ] [ Mheight ] tri* = ]
+ [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ]
+ } 3&&
+ [ "Mismatched matrices in matrix multiplication" throw ]
+ unless ;
+
+:: (prepare-gemm)
+ ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
+ C )
+ A B C (validate-gemm)
+ A (blas-transpose)
+ B (blas-transpose)
+ C rows>>
+ C cols>>
+ A Mwidth
+ alpha
+ A
+ A ld>>
+ B
+ B ld>>
+ beta
+ C
+ C ld>>
+ C f >>transpose ; inline
+
+: (>matrix) ( arrays >c-array -- c-array ld rows cols transpose )
+ '[ <merged> @ ] [ length dup ] [ first length ] tri f ; inline
+
+PRIVATE>
+
+! XXX should do a dense clone
+M: blas-matrix-base clone
+ [
+ [ {
+ [ underlying>> ]
+ [ ld>> ]
+ [ cols>> ]
+ [ element-type heap-size ]
+ } cleave * * memory>byte-array ]
+ [ {
+ [ ld>> ]
+ [ rows>> ]
+ [ cols>> ]
+ [ transpose>> ]
+ } cleave ]
+ bi
+ ] keep (blas-matrix-like) ;
+
+! XXX try rounding stride to next 128 bit bound for better vectorizin'
+: <empty-matrix> ( rows cols exemplar -- matrix )
+ [ element-type heap-size * * <byte-array> ]
+ [ 2drop ]
+ [ [ f ] dip (blas-matrix-like) ] 3tri ;
+
+: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y )
+ clone n*M.V+n*V! ;
+: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A )
+ clone n*V(*)V+M! ;
+: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A )
+ clone n*V(*)Vconj+M! ;
+: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C )
+ clone n*M.M+n*M! ;
+
+: n*M.V ( alpha A x -- alpha*A.x )
+ 1.0 2over [ Mheight ] dip <empty-vector>
+ n*M.V+n*V! ; inline
+
+: M.V ( A x -- A.x )
+ [ 1.0 ] 2dip n*M.V ; inline
+
+: n*V(*)V ( alpha x y -- alpha*x(*)y )
+ 2dup [ length>> ] bi@ pick <empty-matrix>
+ n*V(*)V+M! ;
+: n*V(*)Vconj ( alpha x y -- alpha*x(*)yconj )
+ 2dup [ length>> ] bi@ pick <empty-matrix>
+ n*V(*)Vconj+M! ;
+
+: V(*) ( x y -- x(*)y )
+ [ 1.0 ] 2dip n*V(*)V ; inline
+: V(*)conj ( x y -- x(*)yconj )
+ [ 1.0 ] 2dip n*V(*)Vconj ; inline
+
+: n*M.M ( alpha A B -- alpha*A.B )
+ 2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
+ [ 1.0 ] dip n*M.M+n*M! ;
+
+: M. ( A B -- A.B )
+ [ 1.0 ] 2dip n*M.M ; inline
+
+:: (Msub) ( matrix row col height width -- data ld rows cols )
+ matrix ld>> col * row + matrix element-type heap-size *
+ matrix underlying>> <displaced-alien>
+ matrix ld>>
+ height
+ width ;
+
+:: Msub ( matrix row col height width -- sub )
+ matrix dup transpose>>
+ [ col row width height ]
+ [ row col height width ] if (Msub)
+ matrix transpose>> matrix (blas-matrix-like) ;
+
+TUPLE: blas-matrix-rowcol-sequence
+ parent inc rowcol-length rowcol-jump length ;
+C: <blas-matrix-rowcol-sequence> blas-matrix-rowcol-sequence
+
+INSTANCE: blas-matrix-rowcol-sequence sequence
+
+M: blas-matrix-rowcol-sequence length
+ length>> ;
+M: blas-matrix-rowcol-sequence nth-unsafe
+ {
+ [
+ [ rowcol-jump>> ]
+ [ parent>> element-type heap-size ]
+ [ parent>> underlying>> ] tri
+ [ * * ] dip <displaced-alien>
+ ]
+ [ rowcol-length>> ]
+ [ inc>> ]
+ [ parent>> ]
+ } cleave (blas-vector-like) ;
+
+: (Mcols) ( A -- columns )
+ { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] }
+ cleave <blas-matrix-rowcol-sequence> ;
+: (Mrows) ( A -- rows )
+ { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] }
+ cleave <blas-matrix-rowcol-sequence> ;
+
+: Mrows ( A -- rows )
+ dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
+: Mcols ( A -- cols )
+ dup transpose>> [ (Mrows) ] [ (Mcols) ] if ;
+
+: n*M! ( n A -- A=n*A )
+ [ (Mcols) [ n*V! drop ] with each ] keep ;
+
+: n*M ( n A -- n*A )
+ clone n*M! ; inline
+
+: M*n ( A n -- A*n )
+ swap n*M ; inline
+: M/n ( A n -- A/n )
+ recip swap n*M ; inline
+
+: Mtranspose ( matrix -- matrix^T )
+ [ {
+ [ underlying>> ]
+ [ ld>> ] [ rows>> ]
+ [ cols>> ]
+ [ transpose>> not ]
+ } cleave ] keep (blas-matrix-like) ;
+
+M: blas-matrix-base equal?
+ {
+ [ [ Mwidth ] bi@ = ]
+ [ [ Mcols ] bi@ [ = ] 2all? ]
+ } 2&& ;
+
+<<
+
+FUNCTOR: (define-blas-matrix) ( TYPE T U C -- )
+
+VECTOR IS ${TYPE}-blas-vector
+<VECTOR> IS <${TYPE}-blas-vector>
+XGEMV IS ${T}GEMV
+XGEMM IS ${T}GEMM
+XGERU IS ${T}GER${U}
+XGERC IS ${T}GER${C}
+
+MATRIX DEFINES-CLASS ${TYPE}-blas-matrix
+<MATRIX> DEFINES <${TYPE}-blas-matrix>
+>MATRIX DEFINES >${TYPE}-blas-matrix
+
+t [ T >lower ]
+
+XMATRIX{ DEFINES ${t}matrix{
+
+WHERE
+
+TUPLE: MATRIX < blas-matrix-base ;
+: <MATRIX> ( underlying ld rows cols transpose -- matrix )
+ MATRIX boa ; inline
+
+M: MATRIX element-type
+ drop TYPE ;
+M: MATRIX (blas-matrix-like)
+ drop <MATRIX> ;
+M: VECTOR (blas-matrix-like)
+ drop <MATRIX> ;
+M: MATRIX (blas-vector-like)
+ drop <VECTOR> ;
+
+: >MATRIX ( arrays -- matrix )
+ [ TYPE >c-array underlying>> ] (>matrix) <MATRIX> ;
+
+M: VECTOR n*M.V+n*V!
+ (prepare-gemv) [ XGEMV ] dip ;
+M: MATRIX n*M.M+n*M!
+ (prepare-gemm) [ XGEMM ] dip ;
+M: MATRIX n*V(*)V+M!
+ (prepare-ger) [ XGERU ] dip ;
+M: MATRIX n*V(*)Vconj+M!
+ (prepare-ger) [ XGERC ] dip ;
+
+SYNTAX: XMATRIX{ \ } [ >MATRIX ] parse-literal ;
+
+M: MATRIX pprint-delims
+ drop \ XMATRIX{ \ } ;
+
+;FUNCTOR
+
+
+: define-real-blas-matrix ( TYPE T -- )
+ "" "" (define-blas-matrix) ;
+: define-complex-blas-matrix ( TYPE T -- )
+ "U" "C" (define-blas-matrix) ;
+
+float "S" define-real-blas-matrix
+double "D" define-real-blas-matrix
+complex-float "C" define-complex-blas-matrix
+complex-double "Z" define-complex-blas-matrix
+
+>>
+
+M: blas-matrix-base >pprint-sequence Mrows ;
+M: blas-matrix-base pprint* pprint-object ;
--- /dev/null
+BLAS level 2 and 3 matrix-vector and matrix-matrix operations
--- /dev/null
+math
+bindings
--- /dev/null
+BLAS level 1 vector operations
--- /dev/null
+math
+bindings
--- /dev/null
+USING: alien byte-arrays help.markup help.syntax math sequences ;
+IN: math.blas.vectors
+
+ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
+"Slicing vectors:"
+{ $subsections Vsub }
+"Taking the norm (magnitude) of a vector:"
+{ $subsections Vnorm }
+"Summing and taking the maximum of elements:"
+{ $subsections
+ Vasum
+ Viamax
+ Vamax
+}
+"Scalar-vector products:"
+{ $subsections
+ n*V!
+ n*V
+ V*n
+ V/n
+ Vneg
+}
+"Vector addition:"
+{ $subsections
+ n*V+V!
+ n*V+V
+ V+
+ V-
+}
+"Vector inner products:"
+{ $subsections
+ V.
+ V.conj
+}
+"Literal syntax:"
+{ $subsections
+ POSTPONE: svector{
+ POSTPONE: dvector{
+ POSTPONE: cvector{
+ POSTPONE: zvector{
+} ;
+
+ABOUT: "math.blas.vectors"
+
+HELP: blas-vector-base
+{ $class-description "The base class for all BLAS vector types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
+{ $list
+ { { $link float-blas-vector } }
+ { { $link double-blas-vector } }
+ { { $link complex-float-blas-vector } }
+ { { $link complex-double-blas-vector } }
+}
+"All of these subclasses share the same tuple layout:"
+{ $list
+ { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
+ { { $snippet "length" } " indicates the length of the vector;" }
+ { "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
+} } ;
+
+HELP: float-blas-vector
+{ $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: double-blas-vector
+{ $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: complex-float-blas-vector
+{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: complex-double-blas-vector
+{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+
+HELP: n*V+V!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } }
+{ $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." }
+{ $side-effects "y" } ;
+
+HELP: n*V!
+{ $values { "alpha" number } { "x" blas-vector-base } { "x=alpha*x" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." }
+{ $side-effects "x" } ;
+
+HELP: V.
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x.y" number } }
+{ $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ;
+
+HELP: V.conj
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "xconj.y" number } }
+{ $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ;
+
+HELP: Vnorm
+{ $values { "x" blas-vector-base } { "norm" number } }
+{ $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ;
+
+HELP: Vasum
+{ $values { "x" blas-vector-base } { "sum" number } }
+{ $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ;
+
+HELP: Vswap
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x=y" blas-vector-base } { "y=x" blas-vector-base } }
+{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." }
+{ $side-effects "x" "y" } ;
+
+HELP: Viamax
+{ $values { "x" blas-vector-base } { "max-i" integer } }
+{ $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ;
+
+HELP: Vamax
+{ $values { "x" blas-vector-base } { "max" number } }
+{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the element closest to the beginning. Corresponds to the IxAMAX routines in BLAS." } ;
+
+{ Viamax Vamax } related-words
+
+HELP: <zero-vector>
+{ $values { "exemplar" blas-vector-base } { "zero" blas-vector-base } }
+{ $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link <empty-vector> } "." } ;
+
+HELP: n*V+V
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x+y" blas-vector-base } }
+{ $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: n*V
+{ $values { "alpha" "a number" } { "x" blas-vector-base } { "alpha*x" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+HELP: V+
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x+y" blas-vector-base } }
+{ $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: V-
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x-y" blas-vector-base } }
+{ $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
+
+HELP: Vneg
+{ $values { "x" blas-vector-base } { "-x" blas-vector-base } }
+{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result." } ;
+
+HELP: V*n
+{ $values { "x" blas-vector-base } { "alpha" number } { "x*alpha" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+HELP: V/n
+{ $values { "x" blas-vector-base } { "alpha" number } { "x/alpha" blas-vector-base } }
+{ $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
+
+{ n*V+V! n*V! n*V+V n*V V+ V- Vneg V*n V/n } related-words
+
+HELP: Vsub
+{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
+{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
+
+HELP: svector{
+{ $syntax "svector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link float-blas-vector } "." } ;
+
+HELP: dvector{
+{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
+{ $description "Construct a literal " { $link double-blas-vector } "." } ;
+
+HELP: cvector{
+{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ;
+
+HELP: zvector{
+{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
+{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ;
+
+{
+ POSTPONE: svector{ POSTPONE: dvector{
+ POSTPONE: cvector{ POSTPONE: zvector{
+} related-words
+
--- /dev/null
+USING: kernel math.blas.vectors math.functions sequences tools.test ;
+IN: math.blas.vectors.tests
+
+! clone
+
+[ svector{ 1.0 2.0 3.0 } ] [ svector{ 1.0 2.0 3.0 } clone ] unit-test
+[ f ] [ svector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
+[ dvector{ 1.0 2.0 3.0 } ] [ dvector{ 1.0 2.0 3.0 } clone ] unit-test
+[ f ] [ dvector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
+[ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
+[ f ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
+[ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
+[ f ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
+
+! nth
+
+[ 1.0 ] [ 2 svector{ 3.0 2.0 1.0 } nth ] unit-test
+[ 1.0 ] [ 2 dvector{ 3.0 2.0 1.0 } nth ] unit-test
+
+[ C{ 1.0 2.0 } ]
+[ 2 cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
+
+[ C{ 1.0 2.0 } ]
+[ 2 zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
+
+! set-nth
+
+[ svector{ 3.0 2.0 0.0 } ] [ 0.0 2 svector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
+[ dvector{ 3.0 2.0 0.0 } ] [ 0.0 2 dvector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
+
+[ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
+ C{ 3.0 4.0 } 2
+ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
+ [ set-nth ] keep
+] unit-test
+[ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
+ C{ 3.0 4.0 } 2
+ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
+ [ set-nth ] keep
+] unit-test
+
+! V+
+
+[ svector{ 11.0 22.0 } ] [ svector{ 1.0 2.0 } svector{ 10.0 20.0 } V+ ] unit-test
+[ dvector{ 11.0 22.0 } ] [ dvector{ 1.0 2.0 } dvector{ 10.0 20.0 } V+ ] unit-test
+
+[ cvector{ 11.0 C{ 22.0 33.0 } } ]
+[ cvector{ 1.0 C{ 2.0 3.0 } } cvector{ 10.0 C{ 20.0 30.0 } } V+ ]
+unit-test
+
+[ zvector{ 11.0 C{ 22.0 33.0 } } ]
+[ zvector{ 1.0 C{ 2.0 3.0 } } zvector{ 10.0 C{ 20.0 30.0 } } V+ ]
+unit-test
+
+! V-
+
+[ svector{ 9.0 18.0 } ] [ svector{ 10.0 20.0 } svector{ 1.0 2.0 } V- ] unit-test
+[ dvector{ 9.0 18.0 } ] [ dvector{ 10.0 20.0 } dvector{ 1.0 2.0 } V- ] unit-test
+
+[ cvector{ 9.0 C{ 18.0 27.0 } } ]
+[ cvector{ 10.0 C{ 20.0 30.0 } } cvector{ 1.0 C{ 2.0 3.0 } } V- ]
+unit-test
+
+[ zvector{ 9.0 C{ 18.0 27.0 } } ]
+[ zvector{ 10.0 C{ 20.0 30.0 } } zvector{ 1.0 C{ 2.0 3.0 } } V- ]
+unit-test
+
+! Vneg
+
+[ svector{ 1.0 -2.0 } ] [ svector{ -1.0 2.0 } Vneg ] unit-test
+[ dvector{ 1.0 -2.0 } ] [ dvector{ -1.0 2.0 } Vneg ] unit-test
+
+[ cvector{ 1.0 C{ -2.0 3.0 } } ] [ cvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
+[ zvector{ 1.0 C{ -2.0 3.0 } } ] [ zvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
+
+! n*V
+
+[ svector{ 100.0 200.0 } ] [ 10.0 svector{ 10.0 20.0 } n*V ] unit-test
+[ dvector{ 100.0 200.0 } ] [ 10.0 dvector{ 10.0 20.0 } n*V ] unit-test
+
+[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ C{ 10.0 2.0 } cvector{ 2.0 C{ 1.0 1.0 } } n*V ]
+unit-test
+
+[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ C{ 10.0 2.0 } zvector{ 2.0 C{ 1.0 1.0 } } n*V ]
+unit-test
+
+! V*n
+
+[ svector{ 100.0 200.0 } ] [ svector{ 10.0 20.0 } 10.0 V*n ] unit-test
+[ dvector{ 100.0 200.0 } ] [ dvector{ 10.0 20.0 } 10.0 V*n ] unit-test
+
+[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ cvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
+unit-test
+
+[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
+[ zvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
+unit-test
+
+! V/n
+
+[ svector{ 1.0 2.0 } ] [ svector{ 4.0 8.0 } 4.0 V/n ] unit-test
+[ dvector{ 1.0 2.0 } ] [ dvector{ 4.0 8.0 } 4.0 V/n ] unit-test
+
+[ cvector{ C{ 0.0 -4.0 } 1.0 } ]
+[ cvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
+unit-test
+
+[ zvector{ C{ 0.0 -4.0 } 1.0 } ]
+[ zvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
+unit-test
+
+! V.
+
+[ 7.0 ] [ svector{ 1.0 2.5 } svector{ 2.0 2.0 } V. ] unit-test
+[ 7.0 ] [ dvector{ 1.0 2.5 } dvector{ 2.0 2.0 } V. ] unit-test
+[ C{ 7.0 7.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
+[ C{ 7.0 7.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
+
+! V.conj
+
+[ C{ 7.0 3.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
+[ C{ 7.0 3.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
+
+! Vnorm
+
+[ t ] [ svector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test
+[ t ] [ dvector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test
+
+[ t ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test
+[ t ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test
+
+! Vasum
+
+[ 6.0 ] [ svector{ 1.0 2.0 -3.0 } Vasum ] unit-test
+[ 6.0 ] [ dvector{ 1.0 2.0 -3.0 } Vasum ] unit-test
+
+[ 15.0 ] [ cvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
+[ 15.0 ] [ zvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
+
+! Vswap
+
+[ svector{ 2.0 2.0 } svector{ 1.0 1.0 } ]
+[ svector{ 1.0 1.0 } svector{ 2.0 2.0 } Vswap ]
+unit-test
+
+[ dvector{ 2.0 2.0 } dvector{ 1.0 1.0 } ]
+[ dvector{ 1.0 1.0 } dvector{ 2.0 2.0 } Vswap ]
+unit-test
+
+[ cvector{ 2.0 C{ 2.0 2.0 } } cvector{ C{ 1.0 1.0 } 1.0 } ]
+[ cvector{ C{ 1.0 1.0 } 1.0 } cvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
+unit-test
+
+[ zvector{ 2.0 C{ 2.0 2.0 } } zvector{ C{ 1.0 1.0 } 1.0 } ]
+[ zvector{ C{ 1.0 1.0 } 1.0 } zvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
+unit-test
+
+! Viamax
+
+[ 3 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 3 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 0 ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
+[ 0 ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
+
+! Vamax
+
+[ -6.0 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ -6.0 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ C{ 2.0 -5.0 } ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
+[ C{ 2.0 -5.0 } ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
+
+! Vsub
+
+[ svector{ -5.0 4.0 -6.0 } ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ dvector{ -5.0 4.0 -6.0 } ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ cvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ cvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
+[ zvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ zvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
--- /dev/null
+USING: accessors alien alien.c-types alien.complex alien.data
+arrays ascii byte-arrays combinators combinators.short-circuit
+fry kernel math math.blas.ffi math.complex math.functions
+math.order sequences sequences.private functors words locals
+parser prettyprint.backend prettyprint.custom specialized-arrays ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: complex-double
+IN: math.blas.vectors
+
+TUPLE: blas-vector-base underlying length inc ;
+
+INSTANCE: blas-vector-base virtual-sequence
+
+GENERIC: element-type ( v -- type )
+
+GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
+GENERIC: n*V! ( alpha x -- x=alpha*x )
+GENERIC: V. ( x y -- x.y )
+GENERIC: V.conj ( x y -- xconj.y )
+GENERIC: Vnorm ( x -- norm )
+GENERIC: Vasum ( x -- sum )
+GENERIC: Vswap ( x y -- x=y y=x )
+GENERIC: Viamax ( x -- max-i )
+
+<PRIVATE
+
+GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
+
+GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
+
+: shorter-length ( v1 v2 -- length )
+ [ length>> ] bi@ min ; inline
+: data-and-inc ( v -- data inc )
+ [ ] [ inc>> ] bi ; inline
+: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
+ [ data-and-inc ] bi@ ; inline
+
+:: (prepare-copy)
+ ( v element-size -- length v-data v-inc v-dest-data v-dest-inc
+ copy-data copy-length copy-inc )
+ v [ length>> ] [ data-and-inc ] bi
+ v length>> element-size * <byte-array>
+ 1
+ over v length>> 1 ;
+
+: (prepare-swap)
+ ( v1 v2 -- length v1-data v1-inc v2-data v2-inc
+ v1 v2 )
+ [ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
+
+:: (prepare-axpy)
+ ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
+ v2 )
+ v1 v2 shorter-length
+ n
+ v1 v2 datas-and-incs
+ v2 ;
+
+:: (prepare-scal)
+ ( n v -- length n v-data v-inc
+ v )
+ v length>>
+ n
+ v data-and-inc
+ v ;
+
+: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
+ [ shorter-length ] [ datas-and-incs ] 2bi ;
+
+: (prepare-nrm2) ( v -- length data inc )
+ [ length>> ] [ data-and-inc ] bi ;
+
+PRIVATE>
+
+: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
+: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
+
+:: V+ ( x y -- x+y )
+ 1.0 x y n*V+V ; inline
+:: V- ( x y -- x-y )
+ -1.0 y x n*V+V ; inline
+
+: Vneg ( x -- -x )
+ -1.0 swap n*V ; inline
+
+: V*n ( x alpha -- x*alpha )
+ swap n*V ; inline
+: V/n ( x alpha -- x/alpha )
+ recip swap n*V ; inline
+
+: Vamax ( x -- max )
+ [ Viamax ] keep nth ; inline
+
+:: Vsub ( v start length -- sub )
+ v inc>> start * v element-type heap-size *
+ v underlying>> <displaced-alien>
+ length v inc>> v (blas-vector-like) ;
+
+: <zero-vector> ( exemplar -- zero )
+ [ element-type heap-size <byte-array> ]
+ [ length>> 0 ]
+ [ (blas-vector-like) ] tri ;
+
+: <empty-vector> ( length exemplar -- vector )
+ [ element-type heap-size * <byte-array> ]
+ [ 1 swap ] 2bi
+ (blas-vector-like) ;
+
+M: blas-vector-base equal?
+ {
+ [ [ length ] bi@ = ]
+ [ [ = ] 2all? ]
+ } 2&& ;
+
+M: blas-vector-base length
+ length>> ;
+M: blas-vector-base virtual-exemplar
+ (blas-direct-array) ;
+M: blas-vector-base virtual@
+ [ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
+
+: float>arg ( f -- f ) ; inline
+: double>arg ( f -- f ) ; inline
+: arg>float ( f -- f ) ; inline
+: arg>double ( f -- f ) ; inline
+
+<<
+
+FUNCTOR: (define-blas-vector) ( TYPE T -- )
+
+<DIRECT-ARRAY> IS <direct-${TYPE}-array>
+XCOPY IS ${T}COPY
+XSWAP IS ${T}SWAP
+IXAMAX IS I${T}AMAX
+
+VECTOR DEFINES-CLASS ${TYPE}-blas-vector
+<VECTOR> DEFINES <${TYPE}-blas-vector>
+>VECTOR DEFINES >${TYPE}-blas-vector
+
+t [ T >lower ]
+
+XVECTOR{ DEFINES ${t}vector{
+
+XAXPY IS ${T}AXPY
+XSCAL IS ${T}SCAL
+
+WHERE
+
+TUPLE: VECTOR < blas-vector-base ;
+: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
+
+: >VECTOR ( seq -- v )
+ [ TYPE >c-array underlying>> ] [ length ] bi 1 <VECTOR> ;
+
+M: VECTOR clone
+ TYPE heap-size (prepare-copy)
+ [ XCOPY ] 3dip <VECTOR> ;
+
+M: VECTOR element-type
+ drop TYPE ;
+M: VECTOR Vswap
+ (prepare-swap) [ XSWAP ] 2dip ;
+M: VECTOR Viamax
+ (prepare-nrm2) IXAMAX 1 - ;
+
+M: VECTOR (blas-vector-like)
+ drop <VECTOR> ;
+
+M: VECTOR (blas-direct-array)
+ [ underlying>> ]
+ [ [ length>> ] [ inc>> ] bi * ] bi
+ <DIRECT-ARRAY> ;
+
+M: VECTOR n*V+V!
+ (prepare-axpy) [ XAXPY ] dip ;
+M: VECTOR n*V!
+ (prepare-scal) [ XSCAL ] dip ;
+
+SYNTAX: XVECTOR{ \ } [ >VECTOR ] parse-literal ;
+
+M: VECTOR pprint-delims
+ drop \ XVECTOR{ \ } ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
+
+VECTOR IS ${TYPE}-blas-vector
+XDOT IS ${T}DOT
+XNRM2 IS ${T}NRM2
+XASUM IS ${T}ASUM
+
+WHERE
+
+M: VECTOR V.
+ (prepare-dot) XDOT ;
+M: VECTOR V.conj
+ (prepare-dot) XDOT ;
+M: VECTOR Vnorm
+ (prepare-nrm2) XNRM2 ;
+M: VECTOR Vasum
+ (prepare-nrm2) XASUM ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
+
+VECTOR IS ${TYPE}-blas-vector
+XDOTU IS ${C}DOTU
+XDOTC IS ${C}DOTC
+XXNRM2 IS ${S}${C}NRM2
+XXASUM IS ${S}${C}ASUM
+
+WHERE
+
+M: VECTOR V.
+ (prepare-dot) XDOTU ;
+M: VECTOR V.conj
+ (prepare-dot) XDOTC ;
+M: VECTOR Vnorm
+ (prepare-nrm2) XXNRM2 ;
+M: VECTOR Vasum
+ (prepare-nrm2) XXASUM ;
+
+;FUNCTOR
+
+
+: define-real-blas-vector ( TYPE T -- )
+ [ (define-blas-vector) ]
+ [ (define-real-blas-vector) ] 2bi ;
+: define-complex-blas-vector ( TYPE C S -- )
+ [ drop (define-blas-vector) ]
+ [ (define-complex-blas-vector) ] 3bi ;
+
+float "S" define-real-blas-vector
+double "D" define-real-blas-vector
+complex-float "C" "S" define-complex-blas-vector
+complex-double "Z" "D" define-complex-blas-vector
+
+>>
+
+M: blas-vector-base >pprint-sequence ;
+M: blas-vector-base pprint* pprint-object ;
+++ /dev/null
-! Copyright (C) 2009 Joe Groff
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences strings words.symbol classes.struct ;
-QUALIFIED-WITH: alien.syntax c
-IN: alien.fortran
-
-ARTICLE: "alien.fortran-abis" "Fortran ABIs"
-"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
-{ $list
- { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
- { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
- { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
- { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
-}
-"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
-
-ARTICLE: "alien.fortran-types" "Fortran types"
-"The Fortran FFI recognizes the following Fortran types:"
-{ $list
- { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." }
- { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." }
- { { $snippet "REAL" } " specifies a single-precision floating-point real value." }
- { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." }
- { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." }
- { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
- { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
- { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
- { "Struct classes defined by " { $link POSTPONE: STRUCT: } " are also supported as parameter and return types." }
-}
-"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
-
-HELP: FUNCTION:
-{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
-{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
-
-HELP: SUBROUTINE:
-{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
-{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
-
-HELP: LIBRARY:
-{ $syntax "LIBRARY: name" }
-{ $values { "name" "a logical library name" } }
-{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
-
-HELP: add-fortran-library
-{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
-{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
-;
-
-HELP: fortran-invoke
-{ $values
- { "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
-}
-{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." }
-;
-
-ARTICLE: "alien.fortran" "Fortran FFI"
-"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
-{ $subsections
- "alien.fortran-types"
- "alien.fortran-abis"
- add-fortran-library
- POSTPONE: LIBRARY:
- POSTPONE: FUNCTION:
- POSTPONE: SUBROUTINE:
- fortran-invoke
-} ;
-
-ABOUT: "alien.fortran"
+++ /dev/null
-! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.complex
-alien.data alien.fortran alien.fortran.private alien.strings
-classes.struct arrays assocs byte-arrays combinators fry
-generalizations io.encodings.ascii kernel macros
-macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
-FROM: alien.syntax => pointer: ;
-QUALIFIED-WITH: alien.c-types c
-IN: alien.fortran.tests
-
-<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
-LIBRARY: (alien.fortran-tests)
-STRUCT: fortran_test_record
- { FOO int }
- { BAR double[2] }
- { BAS char[4] } ;
-
-intel-unix-abi fortran-abi [
-
- ! fortran-name>symbol-name
-
- [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
- [ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
- [ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
-
- ! fortran-type>c-type
-
- [ c:short ]
- [ "integer*2" fortran-type>c-type ] unit-test
-
- [ c:int ]
- [ "integer*4" fortran-type>c-type ] unit-test
-
- [ c:int ]
- [ "INTEGER" fortran-type>c-type ] unit-test
-
- [ c:longlong ]
- [ "iNteger*8" fortran-type>c-type ] unit-test
-
- [ { c:int 0 } ]
- [ "integer(*)" fortran-type>c-type ] unit-test
-
- [ { c:int 0 } ]
- [ "integer(3,*)" fortran-type>c-type ] unit-test
-
- [ { c:int 3 } ]
- [ "integer(3)" fortran-type>c-type ] unit-test
-
- [ { c:int 6 } ]
- [ "integer(3,2)" fortran-type>c-type ] unit-test
-
- [ { c:int 24 } ]
- [ "integer(4,3,2)" fortran-type>c-type ] unit-test
-
- [ c:char ]
- [ "character" fortran-type>c-type ] unit-test
-
- [ c:char ]
- [ "character*1" fortran-type>c-type ] unit-test
-
- [ { c:char 17 } ]
- [ "character*17" fortran-type>c-type ] unit-test
-
- [ { c:char 17 } ]
- [ "character(17)" fortran-type>c-type ] unit-test
-
- [ c:int ]
- [ "logical" fortran-type>c-type ] unit-test
-
- [ c:float ]
- [ "real" fortran-type>c-type ] unit-test
-
- [ c:double ]
- [ "double-precision" fortran-type>c-type ] unit-test
-
- [ c:float ]
- [ "real*4" fortran-type>c-type ] unit-test
-
- [ c:double ]
- [ "real*8" fortran-type>c-type ] unit-test
-
- [ complex-float ]
- [ "complex" fortran-type>c-type ] unit-test
-
- [ complex-double ]
- [ "double-complex" fortran-type>c-type ] unit-test
-
- [ complex-float ]
- [ "complex*8" fortran-type>c-type ] unit-test
-
- [ complex-double ]
- [ "complex*16" fortran-type>c-type ] unit-test
-
- [ fortran_test_record ]
- [
- [
- "alien.fortran.tests" use-vocab
- "fortran_test_record" fortran-type>c-type
- ] with-manifest
- ] unit-test
-
- ! fortran-arg-type>c-type
-
- [ pointer: c:int { } ]
- [ "integer" fortran-arg-type>c-type ] unit-test
-
- [ pointer: { c:int 3 } { } ]
- [ "integer(3)" fortran-arg-type>c-type ] unit-test
-
- [ pointer: { c:int 0 } { } ]
- [ "integer(*)" fortran-arg-type>c-type ] unit-test
-
- [ pointer: fortran_test_record { } ]
- [
- [
- "alien.fortran.tests" use-vocab
- "fortran_test_record" fortran-arg-type>c-type
- ] with-manifest
- ] unit-test
-
- [ pointer: c:char { } ]
- [ "character" fortran-arg-type>c-type ] unit-test
-
- [ pointer: c:char { } ]
- [ "character(1)" fortran-arg-type>c-type ] unit-test
-
- [ pointer: { c:char 17 } { long } ]
- [ "character(17)" fortran-arg-type>c-type ] unit-test
-
- ! fortran-ret-type>c-type
-
- [ c:char { } ]
- [ "character(1)" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: { c:char 17 } long } ]
- [ "character(17)" fortran-ret-type>c-type ] unit-test
-
- [ c:int { } ]
- [ "integer" fortran-ret-type>c-type ] unit-test
-
- [ c:int { } ]
- [ "logical" fortran-ret-type>c-type ] unit-test
-
- [ c:float { } ]
- [ "real" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: { c:float 0 } } ]
- [ "real(*)" fortran-ret-type>c-type ] unit-test
-
- [ c:double { } ]
- [ "double-precision" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: complex-float } ]
- [ "complex" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: complex-double } ]
- [ "double-complex" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: { c:int 0 } } ]
- [ "integer(*)" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: fortran_test_record } ]
- [
- [
- "alien.fortran.tests" use-vocab
- "fortran_test_record" fortran-ret-type>c-type
- ] with-manifest
- ] unit-test
-
- ! fortran-sig>c-sig
-
- [ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
- [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
- unit-test
-
- [ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
- [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
- unit-test
-
- [ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
- [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
- unit-test
-
- [ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
- [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
- unit-test
-
- ! (fortran-invoke)
-
- [ [
- ! [fortran-args>c-args]
- {
- [ {
- [ ascii string>alien ]
- [ longlong <ref> ]
- [ float <ref> ]
- [ <complex-float> ]
- [ 1 0 ? c:short <ref> ]
- } spread ]
- [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
- } 5 ncleave
- ! [fortran-invoke]
- [
- c:void "funpack" "funtimes_"
- { pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
- alien-invoke
- ] 6 nkeep
- ! [fortran-results>]
- shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
- {
- [ drop ]
- [ drop ]
- [ drop ]
- [ float deref ]
- [ drop ]
- [ drop ]
- } spread
- ] ] [
- f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
- (fortran-invoke)
- ] unit-test
-
- [ [
- ! [fortran-args>c-args]
- {
- [ { [ ] } spread ]
- [ { [ drop ] } spread ]
- } 1 ncleave
- ! [fortran-invoke]
- [ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
- 1 nkeep
- ! [fortran-results>]
- shuffle( reta aa -- reta aa )
- { [ ] [ drop ] } spread
- ] ] [
- "REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
- (fortran-invoke)
- ] unit-test
-
- [ [
- ! [<fortran-result>]
- [ complex-float heap-size <byte-array> ] 1 ndip
- ! [fortran-args>c-args]
- { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
- ! [fortran-invoke]
- [
- c:void "funpack" "fun_times_"
- { pointer: complex-float pointer: { c:float 0 } }
- alien-invoke
- ] 2 nkeep
- ! [fortran-results>]
- shuffle( reta aa -- reta aa )
- { [ *complex-float ] [ drop ] } spread
- ] ] [
- "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
- (fortran-invoke)
- ] unit-test
-
- [ [
- ! [<fortran-result>]
- [ 20 <byte-array> 20 ] 0 ndip
- ! [fortran-invoke]
- [
- c:void "funpack" "fun_times_"
- { pointer: { c:char 20 } long }
- alien-invoke
- ] 2 nkeep
- ! [fortran-results>]
- shuffle( reta retb -- reta retb )
- { [ ] [ ascii alien>nstring ] } spread
- ] ] [
- "CHARACTER*20" "funpack" "FUN_TIMES" { }
- (fortran-invoke)
- ] unit-test
-
- [ [
- ! [<fortran-result>]
- [ 10 <byte-array> 10 ] 3 ndip
- ! [fortran-args>c-args]
- {
- [ {
- [ ascii string>alien ]
- [ float <ref> ]
- [ ascii string>alien ]
- } spread ]
- [ { [ length ] [ drop ] [ length ] } spread ]
- } 3 ncleave
- ! [fortran-invoke]
- [
- c:void "funpack" "fun_times_"
- { pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long }
- alien-invoke
- ] 7 nkeep
- ! [fortran-results>]
- shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
- {
- [ ]
- [ ascii alien>nstring ]
- [ ]
- [ ascii alien>nstring ]
- [ float deref ]
- [ ]
- [ ascii alien>nstring ]
- } spread
- ] ] [
- "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
- (fortran-invoke)
- ] unit-test
-
-] with-variable ! intel-unix-abi
-
-intel-windows-abi fortran-abi [
-
- [ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test
- [ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
- [ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
-
-] with-variable
-
-f2c-abi fortran-abi [
-
- [ { c:char 1 } ]
- [ "character(1)" fortran-type>c-type ] unit-test
-
- [ pointer: c:char { c:long } ]
- [ "character" fortran-arg-type>c-type ] unit-test
-
- [ c:void { pointer: c:char c:long } ]
- [ "character" fortran-ret-type>c-type ] unit-test
-
- [ c:double { } ]
- [ "real" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: { c:float 0 } } ]
- [ "real(*)" fortran-ret-type>c-type ] unit-test
-
- [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
- [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
- [ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
-
-] with-variable
-
-gfortran-abi fortran-abi [
-
- [ c:float { } ]
- [ "real" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: { c:float 0 } } ]
- [ "real(*)" fortran-ret-type>c-type ] unit-test
-
- [ complex-float { } ]
- [ "complex" fortran-ret-type>c-type ] unit-test
-
- [ complex-double { } ]
- [ "double-complex" fortran-ret-type>c-type ] unit-test
-
- [ { char 1 } ]
- [ "character(1)" fortran-type>c-type ] unit-test
-
- [ pointer: c:char { c:long } ]
- [ "character" fortran-arg-type>c-type ] unit-test
-
- [ c:void { pointer: c:char c:long } ]
- [ "character" fortran-ret-type>c-type ] unit-test
-
- [ complex-float { } ]
- [ "complex" fortran-ret-type>c-type ] unit-test
-
- [ complex-double { } ]
- [ "double-complex" fortran-ret-type>c-type ] unit-test
-
- [ c:void { pointer: { complex-double 3 } } ]
- [ "double-complex(3)" fortran-ret-type>c-type ] unit-test
-
-] with-variable
+++ /dev/null
-! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.complex alien.c-types alien.data
-alien.parser grouping alien.strings alien.syntax arrays ascii
-assocs byte-arrays combinators combinators.short-circuit fry
-generalizations kernel lexer macros math math.parser namespaces
-parser sequences sequences.generalizations splitting
-stack-checker vectors vocabs.parser words locals
-io.encodings.ascii io.encodings.string shuffle effects
-math.ranges math.order sorting strings system alien.libraries ;
-QUALIFIED-WITH: alien.c-types c
-IN: alien.fortran
-
-SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
-
-<<
-: add-f2c-libraries ( -- )
- "I77" "libI77.so" cdecl add-library
- "F77" "libF77.so" cdecl add-library ;
-
-os netbsd? [ add-f2c-libraries ] when
->>
-
-: alien>nstring ( alien len encoding -- string )
- [ memory>byte-array ] dip decode ;
-
-ERROR: invalid-fortran-type type ;
-
-DEFER: fortran-sig>c-sig
-DEFER: fortran-ret-type>c-type
-DEFER: fortran-arg-type>c-type
-DEFER: fortran-name>symbol-name
-
-SYMBOL: library-fortran-abis
-SYMBOL: fortran-abi
-library-fortran-abis [ H{ } clone ] initialize
-
-<PRIVATE
-
-: lowercase-name-with-underscore ( name -- name' )
- >lower "_" append ;
-: lowercase-name-with-extra-underscore ( name -- name' )
- >lower CHAR: _ over member?
- [ "__" append ] [ "_" append ] if ;
-
-HOOK: fortran-c-abi fortran-abi ( -- abi )
-M: f2c-abi fortran-c-abi cdecl ;
-M: g95-abi fortran-c-abi cdecl ;
-M: gfortran-abi fortran-c-abi cdecl ;
-M: intel-unix-abi fortran-c-abi cdecl ;
-M: intel-windows-abi fortran-c-abi cdecl ;
-
-HOOK: real-functions-return-double? fortran-abi ( -- ? )
-M: f2c-abi real-functions-return-double? t ;
-M: g95-abi real-functions-return-double? f ;
-M: gfortran-abi real-functions-return-double? f ;
-M: intel-unix-abi real-functions-return-double? f ;
-M: intel-windows-abi real-functions-return-double? f ;
-
-HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
-M: f2c-abi complex-functions-return-by-value? f ;
-M: g95-abi complex-functions-return-by-value? f ;
-M: gfortran-abi complex-functions-return-by-value? t ;
-M: intel-unix-abi complex-functions-return-by-value? f ;
-M: intel-windows-abi complex-functions-return-by-value? f ;
-
-HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
-M: f2c-abi character(1)-maps-to-char? f ;
-M: g95-abi character(1)-maps-to-char? f ;
-M: gfortran-abi character(1)-maps-to-char? f ;
-M: intel-unix-abi character(1)-maps-to-char? t ;
-M: intel-windows-abi character(1)-maps-to-char? t ;
-
-HOOK: mangle-name fortran-abi ( name -- name' )
-M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
-M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
-M: gfortran-abi mangle-name lowercase-name-with-underscore ;
-M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
-M: intel-windows-abi mangle-name >upper ;
-
-TUPLE: fortran-type dims size out? ;
-
-TUPLE: number-type < fortran-type ;
-TUPLE: integer-type < number-type ;
-TUPLE: logical-type < integer-type ;
-TUPLE: real-type < number-type ;
-TUPLE: double-precision-type < number-type ;
-
-TUPLE: character-type < fortran-type ;
-TUPLE: misc-type < fortran-type name ;
-
-TUPLE: complex-type < number-type ;
-TUPLE: real-complex-type < complex-type ;
-TUPLE: double-complex-type < complex-type ;
-
-CONSTANT: fortran>c-types H{
- { "character" character-type }
- { "integer" integer-type }
- { "logical" logical-type }
- { "real" real-type }
- { "double-precision" double-precision-type }
- { "complex" real-complex-type }
- { "double-complex" double-complex-type }
-}
-
-: append-dimensions ( base-c-type type -- c-type )
- dims>> [ product 2array ] when* ;
-
-MACRO: size-case-type ( cases -- )
- [ invalid-fortran-type ] suffix
- '[ [ size>> _ case ] [ append-dimensions ] bi ] ;
-
-: simple-type ( type base-c-type -- c-type )
- swap
- [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
- [ append-dimensions ] bi ;
-
-: new-fortran-type ( out? dims size class -- type )
- new [ [ size<< ] [ dims<< ] [ out?<< ] tri ] keep ;
-
-GENERIC: (fortran-type>c-type) ( type -- c-type )
-
-M: f (fortran-type>c-type) drop c:void ;
-
-M: integer-type (fortran-type>c-type)
- {
- { f [ c:int ] }
- { 1 [ c:char ] }
- { 2 [ c:short ] }
- { 4 [ c:int ] }
- { 8 [ c:longlong ] }
- } size-case-type ;
-M: real-type (fortran-type>c-type)
- {
- { f [ c:float ] }
- { 4 [ c:float ] }
- { 8 [ c:double ] }
- } size-case-type ;
-M: real-complex-type (fortran-type>c-type)
- {
- { f [ complex-float ] }
- { 8 [ complex-float ] }
- { 16 [ complex-double ] }
- } size-case-type ;
-
-M: double-precision-type (fortran-type>c-type)
- c:double simple-type ;
-M: double-complex-type (fortran-type>c-type)
- complex-double simple-type ;
-M: misc-type (fortran-type>c-type)
- dup name>> parse-c-type simple-type ;
-
-: single-char? ( character-type -- ? )
- { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
-
-: fix-character-type ( character-type -- character-type' )
- clone dup size>>
- [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
- [ dup dims>> [ ] [ f >>dims ] if ] if
- dup single-char? [ f >>dims ] when ;
-
-M: character-type (fortran-type>c-type)
- fix-character-type c:char simple-type ;
-
-: dimension>number ( string -- number )
- dup "*" = [ drop 0 ] [ string>number ] if ;
-
-: parse-out ( string -- string' out? )
- "!" ?head ;
-
-: parse-dims ( string -- string' dim )
- "(" split1 dup
- [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
-
-: parse-size ( string -- string' size )
- "*" split1 dup [ string>number ] when ;
-
-: (parse-fortran-type) ( fortran-type-string -- type )
- parse-out swap parse-dims swap parse-size swap
- >lower fortran>c-types ?at
- [ new-fortran-type ] [ misc-type boa ] if ;
-
-: parse-fortran-type ( fortran-type-string/f -- type/f )
- dup [ (parse-fortran-type) ] when ;
-
-GENERIC: added-c-args ( type -- args )
-
-M: fortran-type added-c-args drop { } ;
-M: character-type added-c-args fix-character-type single-char? [ { } ] [ { c:long } ] if ;
-
-GENERIC: returns-by-value? ( type -- ? )
-
-M: f returns-by-value? drop t ;
-M: fortran-type returns-by-value? drop f ;
-M: number-type returns-by-value? dims>> not ;
-M: character-type returns-by-value? fix-character-type single-char? ;
-M: complex-type returns-by-value?
- { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
-
-GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
-
-M: f (fortran-ret-type>c-type) drop c:void ;
-M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
-M: real-type (fortran-ret-type>c-type)
- drop real-functions-return-double? [ c:double ] [ c:float ] if ;
-
-GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
-
-: args?dims ( type quot -- main-quot added-quot )
- [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
-
-M: integer-type (fortran-arg>c-args)
- [
- size>> {
- { f [ [ c:int <ref> ] [ drop ] ] }
- { 1 [ [ c:char <ref> ] [ drop ] ] }
- { 2 [ [ c:short <ref> ] [ drop ] ] }
- { 4 [ [ c:int <ref> ] [ drop ] ] }
- { 8 [ [ c:longlong <ref> ] [ drop ] ] }
- [ invalid-fortran-type ]
- } case
- ] args?dims ;
-
-M: logical-type (fortran-arg>c-args)
- [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
-
-M: real-type (fortran-arg>c-args)
- [
- size>> {
- { f [ [ c:float <ref> ] [ drop ] ] }
- { 4 [ [ c:float <ref> ] [ drop ] ] }
- { 8 [ [ c:double <ref> ] [ drop ] ] }
- [ invalid-fortran-type ]
- } case
- ] args?dims ;
-
-M: real-complex-type (fortran-arg>c-args)
- [
- size>> {
- { f [ [ <complex-float> ] [ drop ] ] }
- { 8 [ [ <complex-float> ] [ drop ] ] }
- { 16 [ [ <complex-double> ] [ drop ] ] }
- [ invalid-fortran-type ]
- } case
- ] args?dims ;
-
-M: double-precision-type (fortran-arg>c-args)
- [ drop [ c:double <ref> ] [ drop ] ] args?dims ;
-
-M: double-complex-type (fortran-arg>c-args)
- [ drop [ <complex-double> ] [ drop ] ] args?dims ;
-
-M: character-type (fortran-arg>c-args)
- fix-character-type single-char?
- [ [ first c:char <ref> ] [ drop ] ]
- [ [ ascii string>alien ] [ length ] ] if ;
-
-M: misc-type (fortran-arg>c-args)
- drop [ ] [ drop ] ;
-
-GENERIC: (fortran-result>) ( type -- quots )
-
-: result?dims ( type quot -- quot )
- [ dup dims>> [ drop { [ ] } ] ] dip if ; inline
-
-M: integer-type (fortran-result>)
- [
- size>> {
- { f [ { [ c:int deref ] } ] }
- { 1 [ { [ c:char deref ] } ] }
- { 2 [ { [ c:short deref ] } ] }
- { 4 [ { [ c:int deref ] } ] }
- { 8 [ { [ c:longlong deref ] } ] }
- [ invalid-fortran-type ]
- } case
- ] result?dims ;
-
-M: logical-type (fortran-result>)
- [ call-next-method first [ zero? not ] append 1array ] result?dims ;
-
-M: real-type (fortran-result>)
- [ size>> {
- { f [ { [ c:float deref ] } ] }
- { 4 [ { [ c:float deref ] } ] }
- { 8 [ { [ c:double deref ] } ] }
- [ invalid-fortran-type ]
- } case ] result?dims ;
-
-M: real-complex-type (fortran-result>)
- [ size>> {
- { f [ { [ *complex-float ] } ] }
- { 8 [ { [ *complex-float ] } ] }
- { 16 [ { [ *complex-double ] } ] }
- [ invalid-fortran-type ]
- } case ] result?dims ;
-
-M: double-precision-type (fortran-result>)
- [ drop { [ c:double deref ] } ] result?dims ;
-
-M: double-complex-type (fortran-result>)
- [ drop { [ *complex-double ] } ] result?dims ;
-
-M: character-type (fortran-result>)
- fix-character-type single-char?
- [ { [ c:char deref 1string ] } ]
- [ { [ ] [ ascii alien>nstring ] } ] if ;
-
-M: misc-type (fortran-result>)
- drop { [ ] } ;
-
-GENERIC: (<fortran-result>) ( type -- quot )
-
-M: fortran-type (<fortran-result>)
- (fortran-type>c-type) \ heap-size \ <byte-array> [ ] 3sequence ;
-
-M: character-type (<fortran-result>)
- fix-character-type dims>> product dup
- [ \ <byte-array> ] dip [ ] 3sequence ;
-
-: [<fortran-result>] ( return parameters -- quot )
- [ parse-fortran-type ] dip
- over returns-by-value?
- [ 2drop [ ] ]
- [ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
-
-: [fortran-args>c-args] ( parameters -- quot )
- [ [ ] ] [
- [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
- [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
- \ ncleave [ ] 3sequence
- ] if-empty ;
-
-:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
- return parameters fortran-sig>c-sig :> ( c-return c-parameters )
- function fortran-name>symbol-name :> c-function
- [args>args]
- c-return library c-function c-parameters \ alien-invoke
- 5 [ ] nsequence
- c-parameters length \ nkeep
- [ ] 3sequence ;
-
-: [fortran-out-param>] ( parameter -- quot )
- parse-fortran-type
- [ (fortran-result>) ] [ out?>> ] bi
- [ ] [ [ drop [ drop ] ] map ] if ;
-
-: [fortran-return>] ( return -- quot )
- parse-fortran-type {
- { [ dup not ] [ drop { } ] }
- { [ dup returns-by-value? ] [ drop { [ ] } ] }
- [ (fortran-result>) ]
- } cond ;
-
-: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
-
-: (shuffle-map) ( return parameters -- ret par )
- [
- fortran-ret-type>c-type length swap void? [ 1 + ] unless
- letters swap head [ "ret" swap suffix ] map
- ] [
- [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
- [ first2 letters swap head [ "" 2sequence ] with map ] map concat
- ] bi* ;
-
-: (fortran-in-shuffle) ( ret par -- seq )
- [ second ] sort-with append ;
-
-: (fortran-out-shuffle) ( ret par -- seq )
- append ;
-
-: [fortran-result-shuffle] ( return parameters -- quot )
- (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
- \ shuffle-effect [ ] 2sequence ;
-
-: [fortran-results>] ( return parameters -- quot )
- [ [fortran-result-shuffle] ]
- [ drop [fortran-return>] ]
- [ nip [ [fortran-out-param>] ] map concat ] 2tri
- append
- \ spread [ ] 2sequence append ;
-
-: (add-fortran-library) ( fortran-abi name -- )
- library-fortran-abis get-global set-at ;
-
-PRIVATE>
-
-: add-fortran-library ( name soname fortran-abi -- )
- [ fortran-abi [ fortran-c-abi ] with-variable add-library ]
- [ nip swap (add-fortran-library) ] 3bi ;
-
-: fortran-name>symbol-name ( fortran-name -- c-name )
- mangle-name ;
-
-: fortran-type>c-type ( fortran-type -- c-type )
- parse-fortran-type (fortran-type>c-type) ;
-
-: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
- parse-fortran-type
- [ (fortran-type>c-type) <pointer> ]
- [ added-c-args ] bi ;
-: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
- parse-fortran-type dup returns-by-value?
- [ (fortran-ret-type>c-type) { } ] [
- c:void swap
- [ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
- ] if ;
-
-: fortran-arg-types>c-types ( fortran-types -- c-types )
- [ length <vector> 1 <vector> ] keep
- [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
- append >array ;
-
-: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
- [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
-
-: set-fortran-abi ( library -- )
- library-fortran-abis get-global at fortran-abi set ;
-
-: (fortran-invoke) ( return library function parameters -- quot )
- {
- [ 2nip [<fortran-result>] ]
- [ nip nip nip [fortran-args>c-args] ]
- [ [fortran-invoke] ]
- [ 2nip [fortran-results>] ]
- } 4 ncleave 4 nappend ;
-
-MACRO: fortran-invoke ( return library function parameters -- )
- { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
-
-: parse-arglist ( parameters return -- types effect )
- [
- 2 group
- [ unzip [ "," ?tail drop ] map ]
- [ [ first "!" head? ] filter [ second "," ?tail drop "'" append ] map ] bi
- ] [ [ ] [ prefix ] if-void ]
- bi* <effect> ;
-
-:: define-fortran-function ( return library function parameters -- )
- function create-function
- return library function parameters return [ c:void ] unless* parse-arglist
- [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
-
-SYNTAX: SUBROUTINE:
- f current-library get scan ";" parse-tokens
- [ "()" subseq? not ] filter define-fortran-function ;
-
-SYNTAX: FUNCTION:
- scan current-library get scan ";" parse-tokens
- [ "()" subseq? not ] filter define-fortran-function ;
-
-SYNTAX: LIBRARY:
- scan
- [ current-library set ]
- [ set-fortran-abi ] bi ;
-
+++ /dev/null
-GNU Fortran/G77/F2C alien interface
+++ /dev/null
-fortran
-ffi
+++ /dev/null
-USING: alien.fortran help.markup help.syntax math.blas.config ;
-IN: math.blas.config
-
-ARTICLE: "math.blas.config" "Configuring the BLAS interface"
-"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
-{ $subsections
- blas-library
- blas-fortran-abi
- deploy-blas?
-}
-"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link ".factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet ".factor-rc" } " would look like this:"
-{ $code """
-USING: math.blas.config namespaces ;
-"X:\\path\\to\\acml.dll" blas-library set-global
-intel-windows-abi blas-fortran-abi set-global
-t deploy-blas? set-global
-""" }
-"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
-;
-
-HELP: blas-library
-{ $var-description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
-
-HELP: blas-fortran-abi
-{ $var-description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
-
-HELP: deploy-blas?
-{ $var-description "If set to a true value, the BLAS library will be configured to deploy with applications that use it. To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
-
-ABOUT: "math.blas.config"
+++ /dev/null
-USING: alien.fortran combinators kernel namespaces system ;
-IN: math.blas.config
-
-SYMBOLS: blas-library blas-fortran-abi deploy-blas? ;
-
-blas-library [
- {
- { [ os macosx? ] [ "libblas.dylib" ] }
- { [ os windows? ] [ "blas.dll" ] }
- [ "libblas.so" ]
- } cond
-] initialize
-
-blas-fortran-abi [
- {
- { [ os macosx? ] [ intel-unix-abi ] }
- { [ os windows? cpu x86.32? and ] [ f2c-abi ] }
- { [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
- { [ os freebsd? ] [ gfortran-abi ] }
- { [ os linux? ] [ gfortran-abi ] }
- [ f2c-abi ]
- } cond
-] initialize
-
-deploy-blas? [ os macosx? not ] initialize
+++ /dev/null
-USING: alien.fortran kernel math.blas.config namespaces ;
-FROM: alien.libraries => deploy-library ;
-IN: math.blas.ffi
-
-<<
-"blas" blas-library blas-fortran-abi [ get ] bi@
-add-fortran-library
-
-deploy-blas? get [ "blas" deploy-library ] when
->>
-
-LIBRARY: blas
-
-! Level 1 BLAS (scalar-vector and vector-vector)
-
-FUNCTION: REAL SDSDOT
- ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
-FUNCTION: DOUBLE-PRECISION DSDOT
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
-FUNCTION: REAL SDOT
- ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
-FUNCTION: DOUBLE-PRECISION DDOT
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-
-FUNCTION: COMPLEX CDOTU
- ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
-FUNCTION: COMPLEX CDOTC
- ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
-
-FUNCTION: DOUBLE-COMPLEX ZDOTU
- ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-FUNCTION: DOUBLE-COMPLEX ZDOTC
- ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-
-FUNCTION: REAL SNRM2
- ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
-FUNCTION: REAL SASUM
- ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
-
-FUNCTION: DOUBLE-PRECISION DNRM2
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-FUNCTION: DOUBLE-PRECISION DASUM
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-
-FUNCTION: REAL SCNRM2
- ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
-FUNCTION: REAL SCASUM
- ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
-
-FUNCTION: DOUBLE-PRECISION DZNRM2
- ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-FUNCTION: DOUBLE-PRECISION DZASUM
- ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-
-FUNCTION: INTEGER ISAMAX
- ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
-FUNCTION: INTEGER IDAMAX
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-FUNCTION: INTEGER ICAMAX
- ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
-FUNCTION: INTEGER IZAMAX
- ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-
-SUBROUTINE: SSWAP
- ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: SCOPY
- ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: SAXPY
- ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
-
-SUBROUTINE: DSWAP
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DCOPY
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DAXPY
- ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-
-SUBROUTINE: CSWAP
- ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CCOPY
- ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CAXPY
- ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
-
-SUBROUTINE: ZSWAP
- ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZCOPY
- ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZAXPY
- ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-
-SUBROUTINE: SSCAL
- ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ;
-SUBROUTINE: DSCAL
- ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-SUBROUTINE: CSCAL
- ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: ZSCAL
- ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: CSSCAL
- ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: ZDSCAL
- ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-
-SUBROUTINE: SROTG
- ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ;
-SUBROUTINE: SROTMG
- ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ;
-SUBROUTINE: SROT
- ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ;
-SUBROUTINE: SROTM
- ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ;
-
-SUBROUTINE: DROTG
- ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ;
-SUBROUTINE: DROTMG
- ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ;
-SUBROUTINE: DROT
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ;
-SUBROUTINE: DROTM
- ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ;
-
-! LEVEL 2 BLAS (MATRIX-VECTOR)
-
-SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- REAL ALPHA, REAL(*) A, INTEGER LDA,
- REAL(*) X, INTEGER INCX, REAL BETA,
- REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- INTEGER KL, INTEGER KU, REAL ALPHA,
- REAL(*) A, INTEGER LDA, REAL(*) X,
- INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: STRMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, REAL(*) A, INTEGER LDA,
- REAL(*) X, INTEGER INCX ) ;
-SUBROUTINE: STBMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
- REAL(*) X, INTEGER INCX ) ;
-SUBROUTINE: STPMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
-SUBROUTINE: STRSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X,
- INTEGER INCX ) ;
-SUBROUTINE: STBSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
- REAL(*) X, INTEGER INCX ) ;
-SUBROUTINE: STPSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
-
-SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA,
- DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA,
- DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
- INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DTRMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-SUBROUTINE: DTBMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-SUBROUTINE: DTPMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-SUBROUTINE: DTRSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
- INTEGER INCX ) ;
-SUBROUTINE: DTBSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-SUBROUTINE: DTPSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
-
-SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) X, INTEGER INCX, COMPLEX BETA,
- COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- INTEGER KL, INTEGER KU, COMPLEX ALPHA,
- COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
- INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CTRMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: CTBMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: CTPMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: CTRSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
- INTEGER INCX ) ;
-SUBROUTINE: CTBSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: CTPSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
-
-SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA,
- DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
- INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA,
- DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
- INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
- INTEGER INCX ) ;
-SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
- INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
-
-
-SUBROUTINE: SSYMV ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, REAL(*) A,
- INTEGER LDA, REAL(*) X, INTEGER INCX,
- REAL BETA, REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: SSBMV ( CHARACTER*1 UPLO,
- INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A,
- INTEGER LDA, REAL(*) X, INTEGER INCX,
- REAL BETA, REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: SSPMV ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, REAL(*) AP,
- REAL(*) X, INTEGER INCX,
- REAL BETA, REAL(*) Y, INTEGER INCY ) ;
-SUBROUTINE: SGER ( INTEGER M, INTEGER N,
- REAL ALPHA, REAL(*) X, INTEGER INCX,
- REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ;
-SUBROUTINE: SSYR ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, REAL(*) X,
- INTEGER INCX, REAL(*) A, INTEGER LDA ) ;
-SUBROUTINE: SSPR ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, REAL(*) X,
- INTEGER INCX, REAL(*) AP ) ;
-SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, REAL(*) X,
- INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A,
- INTEGER LDA ) ;
-SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, REAL(*) X,
- INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ;
-
-SUBROUTINE: DSYMV ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
- INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
- DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DSBMV ( CHARACTER*1 UPLO,
- INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
- INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
- DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DSPMV ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP,
- DOUBLE-PRECISION(*) X, INTEGER INCX,
- DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
-SUBROUTINE: DGER ( INTEGER M, INTEGER N,
- DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX,
- DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
-SUBROUTINE: DSYR ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
- INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
-SUBROUTINE: DSPR ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
- INTEGER INCX, DOUBLE-PRECISION(*) AP ) ;
-SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
- INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A,
- INTEGER LDA ) ;
-SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
- INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ;
-
-
-SUBROUTINE: CHEMV ( CHARACTER*1 UPLO,
- INTEGER N, COMPLEX ALPHA, COMPLEX(*) A,
- INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
- COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CHBMV ( CHARACTER*1 UPLO,
- INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
- INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
- COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CHPMV ( CHARACTER*1 UPLO,
- INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP,
- COMPLEX(*) X, INTEGER INCX,
- COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: CGERU ( INTEGER M, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
- COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: CGERC ( INTEGER M, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
- COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: CHER ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX,
- COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: CHPR ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, COMPLEX(*) X,
- INTEGER INCX, COMPLEX(*) A ) ;
-SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
- COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
- COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ;
-
-SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
- INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO,
- INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
- INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO,
- INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP,
- DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
-SUBROUTINE: ZGERU ( INTEGER M, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: ZGERC ( INTEGER M, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: ZHER ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: ZHPR ( CHARACTER*1 UPLO,
- INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X,
- INTEGER INCX, DOUBLE-COMPLEX(*) A ) ;
-SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
-SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
- DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ;
-
-! LEVEL 3 BLAS (MATRIX-MATRIX)
-
-SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA,
- CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
- INTEGER K, REAL ALPHA, REAL(*) A,
- INTEGER LDA, REAL(*) B, INTEGER LDB,
- REAL BETA, REAL(*) C, INTEGER LDC ) ;
-SUBROUTINE: SSYMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, INTEGER M, INTEGER N,
- REAL ALPHA, REAL(*) A, INTEGER LDA,
- REAL(*) B, INTEGER LDB, REAL BETA,
- REAL(*) C, INTEGER LDC ) ;
-SUBROUTINE: SSYRK ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- REAL ALPHA, REAL(*) A, INTEGER LDA,
- REAL BETA, REAL(*) C, INTEGER LDC ) ;
-SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- REAL ALPHA, REAL(*) A, INTEGER LDA,
- REAL(*) B, INTEGER LDB, REAL BETA,
- REAL(*) C, INTEGER LDC ) ;
-SUBROUTINE: STRMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- REAL ALPHA, REAL(*) A, INTEGER LDA,
- REAL(*) B, INTEGER LDB ) ;
-SUBROUTINE: STRSM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- REAL ALPHA, REAL(*) A, INTEGER LDA,
- REAL(*) B, INTEGER LDB ) ;
-
-SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA,
- CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
- INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
- INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB,
- DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
-SUBROUTINE: DSYMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, INTEGER M, INTEGER N,
- DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
- DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
-SUBROUTINE: DSYRK ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
-SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
- DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
-SUBROUTINE: DTRMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
-SUBROUTINE: DTRSM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
- DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
-
-SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA,
- CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
- INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
- INTEGER LDA, COMPLEX(*) B, INTEGER LDB,
- COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: CSYMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, INTEGER M, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
- COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: CSYRK ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
- COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: CTRMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) B, INTEGER LDB ) ;
-SUBROUTINE: CTRSM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) B, INTEGER LDB ) ;
-
-SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA,
- CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
- INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
- INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB,
- DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, INTEGER M, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
- DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
- DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
-SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
- CHARACTER*1 DIAG, INTEGER M, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
-
-SUBROUTINE: CHEMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, INTEGER M, INTEGER N,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
- COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: CHERK ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- REAL ALPHA, COMPLEX(*) A, INTEGER LDA,
- REAL BETA, COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: CHER2K ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
- COMPLEX(*) B, INTEGER LDB, REAL BETA,
- COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE,
- CHARACTER*1 UPLO, INTEGER M, INTEGER N,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
- DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: ZHERK ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
-SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO,
- CHARACTER*1 TRANS, INTEGER N, INTEGER K,
- DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
- DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA,
- DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+++ /dev/null
-Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library
+++ /dev/null
-math
-bindings
-fortran
+++ /dev/null
-USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
-IN: math.blas.matrices
-
-ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
-"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
-{ $subsections "math.blas-types" }
-"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
-{ $subsections "math.blas.vectors" }
-"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
-{ $subsections "math.blas.matrices" }
-"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
-{ $subsections "math.blas.config" } ;
-
-ARTICLE: "math.blas-types" "BLAS interface types"
-"BLAS vectors come in single- and double-precision, real and complex flavors:"
-{ $subsections
- float-blas-vector
- double-blas-vector
- complex-float-blas-vector
- complex-double-blas-vector
-}
-"These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
-{ $subsections
- float-blas-matrix
- double-blas-matrix
- complex-float-blas-matrix
- complex-double-blas-matrix
-}
-"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
-{ $subsections
- <float-blas-vector>
- <double-blas-vector>
- <complex-float-blas-vector>
- <complex-double-blas-vector>
- <float-blas-matrix>
- <double-blas-matrix>
- <complex-float-blas-matrix>
- <complex-double-blas-matrix>
-}
-"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
-{ $subsections
- <empty-vector>
- <empty-matrix>
-}
-"BLAS vectors and matrices can also be constructed from other Factor sequences:"
-{ $subsections
- >float-blas-vector
- >double-blas-vector
- >complex-float-blas-vector
- >complex-double-blas-vector
- >float-blas-matrix
- >double-blas-matrix
- >complex-float-blas-matrix
- >complex-double-blas-matrix
-} ;
-
-ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
-"Transposing and slicing matrices:"
-{ $subsections
- Mtranspose
- Mrows
- Mcols
- Msub
-}
-"Matrix-vector products:"
-{ $subsections
- n*M.V+n*V!
- n*M.V+n*V
- n*M.V
- M.V
-}
-"Vector outer products:"
-{ $subsections
- n*V(*)V+M!
- n*V(*)Vconj+M!
- n*V(*)V+M
- n*V(*)Vconj+M
- n*V(*)V
- n*V(*)Vconj
- V(*)
- V(*)conj
-}
-"Matrix products:"
-{ $subsections
- n*M.M+n*M!
- n*M.M+n*M
- n*M.M
- M.
-}
-"Scalar-matrix products:"
-{ $subsections
- n*M!
- n*M
- M*n
- M/n
-}
-"Literal syntax:"
-{ $subsections
- POSTPONE: smatrix{
- POSTPONE: dmatrix{
- POSTPONE: cmatrix{
- POSTPONE: zmatrix{
-} ;
-
-
-ABOUT: "math.blas.matrices"
-
-HELP: blas-matrix-base
-{ $class-description "The base class for all BLAS matrix types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
-{ $list
- { { $link float-blas-matrix } }
- { { $link double-blas-matrix } }
- { { $link complex-float-blas-matrix } }
- { { $link complex-double-blas-matrix } }
-}
-"All of these subclasses share the same tuple layout:"
-{ $list
- { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
- { { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" }
- { { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" }
- { "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." }
-} } ;
-
-{ blas-vector-base blas-matrix-base } related-words
-
-HELP: float-blas-matrix
-{ $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: double-blas-matrix
-{ $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: complex-float-blas-matrix
-{ $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: complex-double-blas-matrix
-{ $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-
-{
- float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix
- float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector
-} related-words
-
-HELP: Mwidth
-{ $values { "matrix" blas-matrix-base } { "width" integer } }
-{ $description "Returns the number of columns in " { $snippet "matrix" } "." } ;
-
-HELP: Mheight
-{ $values { "matrix" blas-matrix-base } { "height" integer } }
-{ $description "Returns the number of rows in " { $snippet "matrix" } "." } ;
-
-{ Mwidth Mheight } related-words
-
-HELP: n*M.V+n*V!
-{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "y=alpha*A.x+b*y" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." }
-{ $side-effects "y" } ;
-
-HELP: n*V(*)V+M!
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)y+A" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." }
-{ $side-effects "A" } ;
-
-HELP: n*V(*)Vconj+M!
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)yconj+A" blas-matrix-base } }
-{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." }
-{ $side-effects "A" } ;
-
-HELP: n*M.M+n*M!
-{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "C=alpha*A.B+beta*C" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." }
-{ $side-effects "C" } ;
-
-HELP: <empty-matrix>
-{ $values { "rows" integer } { "cols" integer } { "exemplar" blas-vector-base blas-matrix-base } { "matrix" blas-matrix-base } }
-{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ;
-
-{ <zero-vector> <empty-vector> <empty-matrix> } related-words
-
-HELP: n*M.V+n*V
-{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "alpha*A.x+b*y" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ;
-
-HELP: n*V(*)V+M
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)y+A" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
-
-HELP: n*V(*)Vconj+M
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)yconj+A" blas-matrix-base } }
-{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ;
-
-HELP: n*M.M+n*M
-{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "alpha*A.B+beta*C" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ;
-
-HELP: n*M.V
-{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "alpha*A.x" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
-
-HELP: M.V
-{ $values { "A" blas-matrix-base } { "x" blas-vector-base } { "A.x" blas-vector-base } }
-{ $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ;
-
-{ n*M.V+n*V! n*M.V+n*V n*M.V M.V } related-words
-
-HELP: n*V(*)V
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)y" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
-
-HELP: n*V(*)Vconj
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)yconj" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
-
-HELP: V(*)
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)y" blas-matrix-base } }
-{ $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ;
-
-HELP: V(*)conj
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)yconj" blas-matrix-base } }
-{ $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ;
-
-{ n*V(*)V+M! n*V(*)Vconj+M! n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words
-
-HELP: n*M.M
-{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "alpha*A.B" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
-
-HELP: M.
-{ $values { "A" blas-matrix-base } { "B" blas-matrix-base } { "A.B" blas-matrix-base } }
-{ $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ;
-
-{ n*M.M+n*M! n*M.M+n*M n*M.M M. } related-words
-
-HELP: Msub
-{ $values { "matrix" blas-matrix-base } { "row" integer } { "col" integer } { "height" integer } { "width" integer } { "sub" blas-matrix-base } }
-{ $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ;
-
-HELP: Mrows
-{ $values { "A" blas-matrix-base } { "rows" sequence } }
-{ $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
-
-HELP: Mcols
-{ $values { "A" blas-matrix-base } { "cols" sequence } }
-{ $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ;
-
-HELP: n*M!
-{ $values { "n" number } { "A" blas-matrix-base } { "A=n*A" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." }
-{ $side-effects "A" } ;
-
-HELP: n*M
-{ $values { "n" number } { "A" blas-matrix-base } { "n*A" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
-
-HELP: M*n
-{ $values { "A" blas-matrix-base } { "n" number } { "A*n" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
-
-HELP: M/n
-{ $values { "A" blas-matrix-base } { "n" number } { "A/n" blas-matrix-base } }
-{ $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ;
-
-{ n*M! n*M M*n M/n } related-words
-
-HELP: Mtranspose
-{ $values { "matrix" blas-matrix-base } { "matrix^T" blas-matrix-base } }
-{ $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ;
-
-HELP: element-type
-{ $values { "v" blas-vector-base blas-matrix-base } { "type" string } }
-{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ;
-
-HELP: <empty-vector>
-{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
-{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
-
-HELP: smatrix{
-{ $syntax """smatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 1.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- { 0.0 0.0 0.0 1.0 }
-}""" }
-{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: dmatrix{
-{ $syntax """dmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 1.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- { 0.0 0.0 0.0 1.0 }
-}""" }
-{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: cmatrix{
-{ $syntax """cmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 -1.0 3.0 }
- { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-}""" }
-{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-HELP: zmatrix{
-{ $syntax """zmatrix{
- { 1.0 0.0 0.0 1.0 }
- { 0.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 -1.0 3.0 }
- { 0.0 0.0 0.0 C{ 0.0 -1.0 } }
-}""" }
-{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
-
-{
- POSTPONE: smatrix{ POSTPONE: dmatrix{
- POSTPONE: cmatrix{ POSTPONE: zmatrix{
-} related-words
+++ /dev/null
-USING: kernel math.blas.matrices math.blas.vectors
-sequences tools.test ;
-IN: math.blas.matrices.tests
-
-! clone
-
-[ smatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
-} ] [
- smatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } clone
-] unit-test
-[ f ] [
- smatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } dup clone eq?
-] unit-test
-
-[ dmatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
-} ] [
- dmatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } clone
-] unit-test
-[ f ] [
- dmatrix{
- { 1.0 2.0 3.0 }
- { 4.0 5.0 6.0 }
- { 7.0 8.0 9.0 }
- } dup clone eq?
-] unit-test
-
-[ cmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
-} ] [
- cmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } clone
-] unit-test
-[ f ] [
- cmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } dup clone eq?
-] unit-test
-
-[ zmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
-} ] [
- zmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } clone
-] unit-test
-[ f ] [
- zmatrix{
- { C{ 1.0 1.0 } 2.0 3.0 }
- { 4.0 C{ 5.0 2.0 } 6.0 }
- { 7.0 8.0 C{ 9.0 3.0 } }
- } dup clone eq?
-] unit-test
-
-! M.V
-
-[ svector{ 3.0 1.0 6.0 } ] [
- smatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- svector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ svector{ -2.0 1.0 3.0 14.0 } ] [
- smatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- svector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-[ dvector{ 3.0 1.0 6.0 } ] [
- dmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- dvector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ dvector{ -2.0 1.0 3.0 14.0 } ] [
- dmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 0.0 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- dvector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-[ cvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
- cmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- cvector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ cvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
- cmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- cvector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-[ zvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [
- zmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- }
- zvector{ 1.0 2.0 3.0 1.0 }
- M.V
-] unit-test
-[ zvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [
- zmatrix{
- { 0.0 1.0 0.0 1.0 }
- { -1.0 C{ 0.0 1.0 } 0.0 2.0 }
- { 0.0 0.0 1.0 3.0 }
- } Mtranspose
- zvector{ 1.0 2.0 3.0 }
- M.V
-] unit-test
-
-! V(*)
-
-[ smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 4.0 6.0 8.0 }
- { 3.0 6.0 9.0 12.0 }
-} ] [
- svector{ 1.0 2.0 3.0 } svector{ 1.0 2.0 3.0 4.0 } V(*)
-] unit-test
-
-[ dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 4.0 6.0 8.0 }
- { 3.0 6.0 9.0 12.0 }
-} ] [
- dvector{ 1.0 2.0 3.0 } dvector{ 1.0 2.0 3.0 4.0 } V(*)
-] unit-test
-
-[ cmatrix{
- { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
- { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
- { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
-} ] [
- cvector{ 1.0 2.0 C{ 3.0 3.0 } } cvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
-] unit-test
-
-[ zmatrix{
- { 1.0 2.0 C{ 3.0 -3.0 } 4.0 }
- { 2.0 4.0 C{ 6.0 -6.0 } 8.0 }
- { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } }
-} ] [
- zvector{ 1.0 2.0 C{ 3.0 3.0 } } zvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*)
-] unit-test
-
-! M.
-
-[ smatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 4.0 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- smatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } smatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ smatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 4.0 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- smatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose smatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-[ dmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 4.0 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- dmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } dmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ dmatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 4.0 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- dmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 2.0 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose dmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-[ cmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- cmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } cmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ cmatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- cmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose cmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-[ zmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 0.0 -3.0 0.0 0.0 }
- { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 }
- { 0.0 0.0 0.0 0.0 0.0 }
-} ] [
- zmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } zmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } M.
-] unit-test
-
-[ zmatrix{
- { 1.0 0.0 0.0 0.0 }
- { 0.0 0.0 C{ 4.0 -4.0 } 0.0 }
- { 0.0 -3.0 0.0 0.0 }
- { 4.0 0.0 0.0 0.0 }
- { 0.0 0.0 10.0 0.0 }
-} ] [
- zmatrix{
- { 1.0 0.0 0.0 4.0 0.0 }
- { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 }
- { 0.0 0.0 3.0 0.0 0.0 }
- } Mtranspose zmatrix{
- { 1.0 0.0 0.0 }
- { 0.0 0.0 -1.0 }
- { 0.0 2.0 0.0 }
- { 0.0 0.0 0.0 }
- } Mtranspose M.
-] unit-test
-
-! n*M
-
-[ smatrix{
- { 2.0 0.0 }
- { 0.0 2.0 }
-} ] [
- 2.0 smatrix{
- { 1.0 0.0 }
- { 0.0 1.0 }
- } n*M
-] unit-test
-
-[ dmatrix{
- { 2.0 0.0 }
- { 0.0 2.0 }
-} ] [
- 2.0 dmatrix{
- { 1.0 0.0 }
- { 0.0 1.0 }
- } n*M
-] unit-test
-
-[ cmatrix{
- { C{ 2.0 1.0 } 0.0 }
- { 0.0 C{ -1.0 2.0 } }
-} ] [
- C{ 2.0 1.0 } cmatrix{
- { 1.0 0.0 }
- { 0.0 C{ 0.0 1.0 } }
- } n*M
-] unit-test
-
-[ zmatrix{
- { C{ 2.0 1.0 } 0.0 }
- { 0.0 C{ -1.0 2.0 } }
-} ] [
- C{ 2.0 1.0 } zmatrix{
- { 1.0 0.0 }
- { 0.0 C{ 0.0 1.0 } }
- } n*M
-] unit-test
-
-! Mrows, Mcols
-
-[ svector{ 3.0 3.0 3.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols nth
-] unit-test
-[ svector{ 3.0 2.0 3.0 4.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows nth
-] unit-test
-[ 3 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows length
-] unit-test
-[ 4 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols length
-] unit-test
-[ svector{ 3.0 3.0 3.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows nth
-] unit-test
-[ svector{ 3.0 2.0 3.0 4.0 } ] [
- 2 smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- smatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows length
-] unit-test
-
-[ dvector{ 3.0 3.0 3.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols nth
-] unit-test
-[ dvector{ 3.0 2.0 3.0 4.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows nth
-] unit-test
-[ 3 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mrows length
-] unit-test
-[ 4 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mcols length
-] unit-test
-[ dvector{ 3.0 3.0 3.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows nth
-] unit-test
-[ dvector{ 3.0 2.0 3.0 4.0 } ] [
- 2 dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- dmatrix{
- { 1.0 2.0 3.0 4.0 }
- { 2.0 2.0 3.0 4.0 }
- { 3.0 2.0 3.0 4.0 }
- } Mtranspose Mrows length
-] unit-test
-
-[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols nth
-] unit-test
-[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows nth
-] unit-test
-[ 3 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows length
-] unit-test
-[ 4 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols length
-] unit-test
-[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows nth
-] unit-test
-[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- cmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows length
-] unit-test
-
-[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols nth
-] unit-test
-[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows nth
-] unit-test
-[ 3 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mrows length
-] unit-test
-[ 4 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mcols length
-] unit-test
-[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows nth
-] unit-test
-[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [
- 2 zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols nth
-] unit-test
-[ 3 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mcols length
-] unit-test
-[ 4 ] [
- zmatrix{
- { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } }
- { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } }
- { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } }
- } Mtranspose Mrows length
-] unit-test
-
-! Msub
-
-[ smatrix{
- { 3.0 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- smatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ smatrix{
- { 3.0 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- smatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
-[ dmatrix{
- { 3.0 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- dmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ dmatrix{
- { 3.0 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- dmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 3.0 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
-[ cmatrix{
- { C{ 3.0 3.0 } 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- cmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ cmatrix{
- { C{ 3.0 3.0 } 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- cmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
-[ zmatrix{
- { C{ 3.0 3.0 } 2.0 1.0 }
- { 0.0 1.0 0.0 }
-} ] [
- zmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } 1 2 2 3 Msub
-] unit-test
-
-[ zmatrix{
- { C{ 3.0 3.0 } 0.0 }
- { 2.0 1.0 }
- { 1.0 0.0 }
-} ] [
- zmatrix{
- { 0.0 1.0 2.0 3.0 2.0 }
- { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 }
- { 2.0 3.0 0.0 1.0 0.0 }
- } Mtranspose 2 1 3 2 Msub
-] unit-test
-
+++ /dev/null
-USING: accessors alien alien.c-types alien.complex
-alien.data arrays byte-arrays combinators
-combinators.short-circuit fry kernel locals macros math
-math.blas.ffi math.blas.vectors math.blas.vectors.private
-math.complex math.functions math.order functors words
-sequences sequences.merged sequences.private shuffle
-parser prettyprint.backend prettyprint.custom ascii
-specialized-arrays ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: double
-SPECIALIZED-ARRAY: complex-float
-SPECIALIZED-ARRAY: complex-double
-IN: math.blas.matrices
-
-TUPLE: blas-matrix-base underlying ld rows cols transpose ;
-
-: Mtransposed? ( matrix -- ? )
- transpose>> ; inline
-: Mwidth ( matrix -- width )
- dup Mtransposed? [ rows>> ] [ cols>> ] if ; inline
-: Mheight ( matrix -- height )
- dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
-
-GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
-GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
-GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
-GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
-
-<PRIVATE
-
-: (blas-transpose) ( matrix -- integer )
- transpose>> [ "T" ] [ "N" ] if ;
-
-GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
-
-: (validate-gemv) ( A x y -- )
- {
- [ drop [ Mwidth ] [ length>> ] bi* = ]
- [ nip [ Mheight ] [ length>> ] bi* = ]
- } 3&&
- [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ]
- unless ;
-
-:: (prepare-gemv)
- ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
- y )
- A x y (validate-gemv)
- A (blas-transpose)
- A rows>>
- A cols>>
- alpha
- A
- A ld>>
- x
- x inc>>
- beta
- y
- y inc>>
- y ; inline
-
-: (validate-ger) ( x y A -- )
- {
- [ [ length>> ] [ drop ] [ Mheight ] tri* = ]
- [ [ drop ] [ length>> ] [ Mwidth ] tri* = ]
- } 3&&
- [ "Mismatched vertices and matrix in vector outer product" throw ]
- unless ;
-
-:: (prepare-ger)
- ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld
- A )
- x y A (validate-ger)
- A rows>>
- A cols>>
- alpha
- x
- x inc>>
- y
- y inc>>
- A
- A ld>>
- A f >>transpose ; inline
-
-: (validate-gemm) ( A B C -- )
- {
- [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ]
- [ [ Mheight ] [ drop ] [ Mheight ] tri* = ]
- [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ]
- } 3&&
- [ "Mismatched matrices in matrix multiplication" throw ]
- unless ;
-
-:: (prepare-gemm)
- ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
- C )
- A B C (validate-gemm)
- A (blas-transpose)
- B (blas-transpose)
- C rows>>
- C cols>>
- A Mwidth
- alpha
- A
- A ld>>
- B
- B ld>>
- beta
- C
- C ld>>
- C f >>transpose ; inline
-
-: (>matrix) ( arrays >c-array -- c-array ld rows cols transpose )
- '[ <merged> @ ] [ length dup ] [ first length ] tri f ; inline
-
-PRIVATE>
-
-! XXX should do a dense clone
-M: blas-matrix-base clone
- [
- [ {
- [ underlying>> ]
- [ ld>> ]
- [ cols>> ]
- [ element-type heap-size ]
- } cleave * * memory>byte-array ]
- [ {
- [ ld>> ]
- [ rows>> ]
- [ cols>> ]
- [ transpose>> ]
- } cleave ]
- bi
- ] keep (blas-matrix-like) ;
-
-! XXX try rounding stride to next 128 bit bound for better vectorizin'
-: <empty-matrix> ( rows cols exemplar -- matrix )
- [ element-type heap-size * * <byte-array> ]
- [ 2drop ]
- [ [ f ] dip (blas-matrix-like) ] 3tri ;
-
-: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y )
- clone n*M.V+n*V! ;
-: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A )
- clone n*V(*)V+M! ;
-: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A )
- clone n*V(*)Vconj+M! ;
-: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C )
- clone n*M.M+n*M! ;
-
-: n*M.V ( alpha A x -- alpha*A.x )
- 1.0 2over [ Mheight ] dip <empty-vector>
- n*M.V+n*V! ; inline
-
-: M.V ( A x -- A.x )
- [ 1.0 ] 2dip n*M.V ; inline
-
-: n*V(*)V ( alpha x y -- alpha*x(*)y )
- 2dup [ length>> ] bi@ pick <empty-matrix>
- n*V(*)V+M! ;
-: n*V(*)Vconj ( alpha x y -- alpha*x(*)yconj )
- 2dup [ length>> ] bi@ pick <empty-matrix>
- n*V(*)Vconj+M! ;
-
-: V(*) ( x y -- x(*)y )
- [ 1.0 ] 2dip n*V(*)V ; inline
-: V(*)conj ( x y -- x(*)yconj )
- [ 1.0 ] 2dip n*V(*)Vconj ; inline
-
-: n*M.M ( alpha A B -- alpha*A.B )
- 2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
- [ 1.0 ] dip n*M.M+n*M! ;
-
-: M. ( A B -- A.B )
- [ 1.0 ] 2dip n*M.M ; inline
-
-:: (Msub) ( matrix row col height width -- data ld rows cols )
- matrix ld>> col * row + matrix element-type heap-size *
- matrix underlying>> <displaced-alien>
- matrix ld>>
- height
- width ;
-
-:: Msub ( matrix row col height width -- sub )
- matrix dup transpose>>
- [ col row width height ]
- [ row col height width ] if (Msub)
- matrix transpose>> matrix (blas-matrix-like) ;
-
-TUPLE: blas-matrix-rowcol-sequence
- parent inc rowcol-length rowcol-jump length ;
-C: <blas-matrix-rowcol-sequence> blas-matrix-rowcol-sequence
-
-INSTANCE: blas-matrix-rowcol-sequence sequence
-
-M: blas-matrix-rowcol-sequence length
- length>> ;
-M: blas-matrix-rowcol-sequence nth-unsafe
- {
- [
- [ rowcol-jump>> ]
- [ parent>> element-type heap-size ]
- [ parent>> underlying>> ] tri
- [ * * ] dip <displaced-alien>
- ]
- [ rowcol-length>> ]
- [ inc>> ]
- [ parent>> ]
- } cleave (blas-vector-like) ;
-
-: (Mcols) ( A -- columns )
- { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] }
- cleave <blas-matrix-rowcol-sequence> ;
-: (Mrows) ( A -- rows )
- { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] }
- cleave <blas-matrix-rowcol-sequence> ;
-
-: Mrows ( A -- rows )
- dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
-: Mcols ( A -- cols )
- dup transpose>> [ (Mrows) ] [ (Mcols) ] if ;
-
-: n*M! ( n A -- A=n*A )
- [ (Mcols) [ n*V! drop ] with each ] keep ;
-
-: n*M ( n A -- n*A )
- clone n*M! ; inline
-
-: M*n ( A n -- A*n )
- swap n*M ; inline
-: M/n ( A n -- A/n )
- recip swap n*M ; inline
-
-: Mtranspose ( matrix -- matrix^T )
- [ {
- [ underlying>> ]
- [ ld>> ] [ rows>> ]
- [ cols>> ]
- [ transpose>> not ]
- } cleave ] keep (blas-matrix-like) ;
-
-M: blas-matrix-base equal?
- {
- [ [ Mwidth ] bi@ = ]
- [ [ Mcols ] bi@ [ = ] 2all? ]
- } 2&& ;
-
-<<
-
-FUNCTOR: (define-blas-matrix) ( TYPE T U C -- )
-
-VECTOR IS ${TYPE}-blas-vector
-<VECTOR> IS <${TYPE}-blas-vector>
-XGEMV IS ${T}GEMV
-XGEMM IS ${T}GEMM
-XGERU IS ${T}GER${U}
-XGERC IS ${T}GER${C}
-
-MATRIX DEFINES-CLASS ${TYPE}-blas-matrix
-<MATRIX> DEFINES <${TYPE}-blas-matrix>
->MATRIX DEFINES >${TYPE}-blas-matrix
-
-t [ T >lower ]
-
-XMATRIX{ DEFINES ${t}matrix{
-
-WHERE
-
-TUPLE: MATRIX < blas-matrix-base ;
-: <MATRIX> ( underlying ld rows cols transpose -- matrix )
- MATRIX boa ; inline
-
-M: MATRIX element-type
- drop TYPE ;
-M: MATRIX (blas-matrix-like)
- drop <MATRIX> ;
-M: VECTOR (blas-matrix-like)
- drop <MATRIX> ;
-M: MATRIX (blas-vector-like)
- drop <VECTOR> ;
-
-: >MATRIX ( arrays -- matrix )
- [ TYPE >c-array underlying>> ] (>matrix) <MATRIX> ;
-
-M: VECTOR n*M.V+n*V!
- (prepare-gemv) [ XGEMV ] dip ;
-M: MATRIX n*M.M+n*M!
- (prepare-gemm) [ XGEMM ] dip ;
-M: MATRIX n*V(*)V+M!
- (prepare-ger) [ XGERU ] dip ;
-M: MATRIX n*V(*)Vconj+M!
- (prepare-ger) [ XGERC ] dip ;
-
-SYNTAX: XMATRIX{ \ } [ >MATRIX ] parse-literal ;
-
-M: MATRIX pprint-delims
- drop \ XMATRIX{ \ } ;
-
-;FUNCTOR
-
-
-: define-real-blas-matrix ( TYPE T -- )
- "" "" (define-blas-matrix) ;
-: define-complex-blas-matrix ( TYPE T -- )
- "U" "C" (define-blas-matrix) ;
-
-float "S" define-real-blas-matrix
-double "D" define-real-blas-matrix
-complex-float "C" define-complex-blas-matrix
-complex-double "Z" define-complex-blas-matrix
-
->>
-
-M: blas-matrix-base >pprint-sequence Mrows ;
-M: blas-matrix-base pprint* pprint-object ;
+++ /dev/null
-BLAS level 2 and 3 matrix-vector and matrix-matrix operations
+++ /dev/null
-math
-bindings
+++ /dev/null
-BLAS level 1 vector operations
+++ /dev/null
-math
-bindings
+++ /dev/null
-USING: alien byte-arrays help.markup help.syntax math sequences ;
-IN: math.blas.vectors
-
-ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
-"Slicing vectors:"
-{ $subsections Vsub }
-"Taking the norm (magnitude) of a vector:"
-{ $subsections Vnorm }
-"Summing and taking the maximum of elements:"
-{ $subsections
- Vasum
- Viamax
- Vamax
-}
-"Scalar-vector products:"
-{ $subsections
- n*V!
- n*V
- V*n
- V/n
- Vneg
-}
-"Vector addition:"
-{ $subsections
- n*V+V!
- n*V+V
- V+
- V-
-}
-"Vector inner products:"
-{ $subsections
- V.
- V.conj
-}
-"Literal syntax:"
-{ $subsections
- POSTPONE: svector{
- POSTPONE: dvector{
- POSTPONE: cvector{
- POSTPONE: zvector{
-} ;
-
-ABOUT: "math.blas.vectors"
-
-HELP: blas-vector-base
-{ $class-description "The base class for all BLAS vector types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:"
-{ $list
- { { $link float-blas-vector } }
- { { $link double-blas-vector } }
- { { $link complex-float-blas-vector } }
- { { $link complex-double-blas-vector } }
-}
-"All of these subclasses share the same tuple layout:"
-{ $list
- { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
- { { $snippet "length" } " indicates the length of the vector;" }
- { "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
-} } ;
-
-HELP: float-blas-vector
-{ $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: double-blas-vector
-{ $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: complex-float-blas-vector
-{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: complex-double-blas-vector
-{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-
-HELP: n*V+V!
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } }
-{ $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." }
-{ $side-effects "y" } ;
-
-HELP: n*V!
-{ $values { "alpha" number } { "x" blas-vector-base } { "x=alpha*x" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." }
-{ $side-effects "x" } ;
-
-HELP: V.
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x.y" number } }
-{ $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ;
-
-HELP: V.conj
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "xconj.y" number } }
-{ $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ;
-
-HELP: Vnorm
-{ $values { "x" blas-vector-base } { "norm" number } }
-{ $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ;
-
-HELP: Vasum
-{ $values { "x" blas-vector-base } { "sum" number } }
-{ $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ;
-
-HELP: Vswap
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x=y" blas-vector-base } { "y=x" blas-vector-base } }
-{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." }
-{ $side-effects "x" "y" } ;
-
-HELP: Viamax
-{ $values { "x" blas-vector-base } { "max-i" integer } }
-{ $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ;
-
-HELP: Vamax
-{ $values { "x" blas-vector-base } { "max" number } }
-{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the element closest to the beginning. Corresponds to the IxAMAX routines in BLAS." } ;
-
-{ Viamax Vamax } related-words
-
-HELP: <zero-vector>
-{ $values { "exemplar" blas-vector-base } { "zero" blas-vector-base } }
-{ $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link <empty-vector> } "." } ;
-
-HELP: n*V+V
-{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x+y" blas-vector-base } }
-{ $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
-
-HELP: n*V
-{ $values { "alpha" "a number" } { "x" blas-vector-base } { "alpha*x" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
-
-HELP: V+
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x+y" blas-vector-base } }
-{ $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
-
-HELP: V-
-{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x-y" blas-vector-base } }
-{ $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ;
-
-HELP: Vneg
-{ $values { "x" blas-vector-base } { "-x" blas-vector-base } }
-{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result." } ;
-
-HELP: V*n
-{ $values { "x" blas-vector-base } { "alpha" number } { "x*alpha" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
-
-HELP: V/n
-{ $values { "x" blas-vector-base } { "alpha" number } { "x/alpha" blas-vector-base } }
-{ $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ;
-
-{ n*V+V! n*V! n*V+V n*V V+ V- Vneg V*n V/n } related-words
-
-HELP: Vsub
-{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
-{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
-
-HELP: svector{
-{ $syntax "svector{ 1.0 -2.0 3.0 }" }
-{ $description "Construct a literal " { $link float-blas-vector } "." } ;
-
-HELP: dvector{
-{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
-{ $description "Construct a literal " { $link double-blas-vector } "." } ;
-
-HELP: cvector{
-{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ;
-
-HELP: zvector{
-{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ;
-
-{
- POSTPONE: svector{ POSTPONE: dvector{
- POSTPONE: cvector{ POSTPONE: zvector{
-} related-words
-
+++ /dev/null
-USING: kernel math.blas.vectors math.functions sequences tools.test ;
-IN: math.blas.vectors.tests
-
-! clone
-
-[ svector{ 1.0 2.0 3.0 } ] [ svector{ 1.0 2.0 3.0 } clone ] unit-test
-[ f ] [ svector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
-[ dvector{ 1.0 2.0 3.0 } ] [ dvector{ 1.0 2.0 3.0 } clone ] unit-test
-[ f ] [ dvector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test
-[ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
-[ f ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
-[ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test
-[ f ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test
-
-! nth
-
-[ 1.0 ] [ 2 svector{ 3.0 2.0 1.0 } nth ] unit-test
-[ 1.0 ] [ 2 dvector{ 3.0 2.0 1.0 } nth ] unit-test
-
-[ C{ 1.0 2.0 } ]
-[ 2 cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
-
-[ C{ 1.0 2.0 } ]
-[ 2 zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test
-
-! set-nth
-
-[ svector{ 3.0 2.0 0.0 } ] [ 0.0 2 svector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
-[ dvector{ 3.0 2.0 0.0 } ] [ 0.0 2 dvector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test
-
-[ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
- C{ 3.0 4.0 } 2
- cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
- [ set-nth ] keep
-] unit-test
-[ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [
- C{ 3.0 4.0 } 2
- zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } }
- [ set-nth ] keep
-] unit-test
-
-! V+
-
-[ svector{ 11.0 22.0 } ] [ svector{ 1.0 2.0 } svector{ 10.0 20.0 } V+ ] unit-test
-[ dvector{ 11.0 22.0 } ] [ dvector{ 1.0 2.0 } dvector{ 10.0 20.0 } V+ ] unit-test
-
-[ cvector{ 11.0 C{ 22.0 33.0 } } ]
-[ cvector{ 1.0 C{ 2.0 3.0 } } cvector{ 10.0 C{ 20.0 30.0 } } V+ ]
-unit-test
-
-[ zvector{ 11.0 C{ 22.0 33.0 } } ]
-[ zvector{ 1.0 C{ 2.0 3.0 } } zvector{ 10.0 C{ 20.0 30.0 } } V+ ]
-unit-test
-
-! V-
-
-[ svector{ 9.0 18.0 } ] [ svector{ 10.0 20.0 } svector{ 1.0 2.0 } V- ] unit-test
-[ dvector{ 9.0 18.0 } ] [ dvector{ 10.0 20.0 } dvector{ 1.0 2.0 } V- ] unit-test
-
-[ cvector{ 9.0 C{ 18.0 27.0 } } ]
-[ cvector{ 10.0 C{ 20.0 30.0 } } cvector{ 1.0 C{ 2.0 3.0 } } V- ]
-unit-test
-
-[ zvector{ 9.0 C{ 18.0 27.0 } } ]
-[ zvector{ 10.0 C{ 20.0 30.0 } } zvector{ 1.0 C{ 2.0 3.0 } } V- ]
-unit-test
-
-! Vneg
-
-[ svector{ 1.0 -2.0 } ] [ svector{ -1.0 2.0 } Vneg ] unit-test
-[ dvector{ 1.0 -2.0 } ] [ dvector{ -1.0 2.0 } Vneg ] unit-test
-
-[ cvector{ 1.0 C{ -2.0 3.0 } } ] [ cvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
-[ zvector{ 1.0 C{ -2.0 3.0 } } ] [ zvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test
-
-! n*V
-
-[ svector{ 100.0 200.0 } ] [ 10.0 svector{ 10.0 20.0 } n*V ] unit-test
-[ dvector{ 100.0 200.0 } ] [ 10.0 dvector{ 10.0 20.0 } n*V ] unit-test
-
-[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ C{ 10.0 2.0 } cvector{ 2.0 C{ 1.0 1.0 } } n*V ]
-unit-test
-
-[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ C{ 10.0 2.0 } zvector{ 2.0 C{ 1.0 1.0 } } n*V ]
-unit-test
-
-! V*n
-
-[ svector{ 100.0 200.0 } ] [ svector{ 10.0 20.0 } 10.0 V*n ] unit-test
-[ dvector{ 100.0 200.0 } ] [ dvector{ 10.0 20.0 } 10.0 V*n ] unit-test
-
-[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ cvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
-unit-test
-
-[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ]
-[ zvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ]
-unit-test
-
-! V/n
-
-[ svector{ 1.0 2.0 } ] [ svector{ 4.0 8.0 } 4.0 V/n ] unit-test
-[ dvector{ 1.0 2.0 } ] [ dvector{ 4.0 8.0 } 4.0 V/n ] unit-test
-
-[ cvector{ C{ 0.0 -4.0 } 1.0 } ]
-[ cvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
-unit-test
-
-[ zvector{ C{ 0.0 -4.0 } 1.0 } ]
-[ zvector{ C{ 4.0 -4.0 } C{ 1.0 1.0 } } C{ 1.0 1.0 } V/n ]
-unit-test
-
-! V.
-
-[ 7.0 ] [ svector{ 1.0 2.5 } svector{ 2.0 2.0 } V. ] unit-test
-[ 7.0 ] [ dvector{ 1.0 2.5 } dvector{ 2.0 2.0 } V. ] unit-test
-[ C{ 7.0 7.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
-[ C{ 7.0 7.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test
-
-! V.conj
-
-[ C{ 7.0 3.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
-[ C{ 7.0 3.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test
-
-! Vnorm
-
-[ t ] [ svector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test
-[ t ] [ dvector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test
-
-[ t ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test
-[ t ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test
-
-! Vasum
-
-[ 6.0 ] [ svector{ 1.0 2.0 -3.0 } Vasum ] unit-test
-[ 6.0 ] [ dvector{ 1.0 2.0 -3.0 } Vasum ] unit-test
-
-[ 15.0 ] [ cvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
-[ 15.0 ] [ zvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test
-
-! Vswap
-
-[ svector{ 2.0 2.0 } svector{ 1.0 1.0 } ]
-[ svector{ 1.0 1.0 } svector{ 2.0 2.0 } Vswap ]
-unit-test
-
-[ dvector{ 2.0 2.0 } dvector{ 1.0 1.0 } ]
-[ dvector{ 1.0 1.0 } dvector{ 2.0 2.0 } Vswap ]
-unit-test
-
-[ cvector{ 2.0 C{ 2.0 2.0 } } cvector{ C{ 1.0 1.0 } 1.0 } ]
-[ cvector{ C{ 1.0 1.0 } 1.0 } cvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
-unit-test
-
-[ zvector{ 2.0 C{ 2.0 2.0 } } zvector{ C{ 1.0 1.0 } 1.0 } ]
-[ zvector{ C{ 1.0 1.0 } 1.0 } zvector{ 2.0 C{ 2.0 2.0 } } Vswap ]
-unit-test
-
-! Viamax
-
-[ 3 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
-[ 3 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test
-[ 0 ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
-[ 0 ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test
-
-! Vamax
-
-[ -6.0 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
-[ -6.0 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test
-[ C{ 2.0 -5.0 } ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
-[ C{ 2.0 -5.0 } ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test
-
-! Vsub
-
-[ svector{ -5.0 4.0 -6.0 } ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
-[ dvector{ -5.0 4.0 -6.0 } ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test
-[ cvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ cvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
-[ zvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ zvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test
+++ /dev/null
-USING: accessors alien alien.c-types alien.complex alien.data
-arrays ascii byte-arrays combinators combinators.short-circuit
-fry kernel math math.blas.ffi math.complex math.functions
-math.order sequences sequences.private functors words locals
-parser prettyprint.backend prettyprint.custom specialized-arrays ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: double
-SPECIALIZED-ARRAY: complex-float
-SPECIALIZED-ARRAY: complex-double
-IN: math.blas.vectors
-
-TUPLE: blas-vector-base underlying length inc ;
-
-INSTANCE: blas-vector-base virtual-sequence
-
-GENERIC: element-type ( v -- type )
-
-GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
-GENERIC: n*V! ( alpha x -- x=alpha*x )
-GENERIC: V. ( x y -- x.y )
-GENERIC: V.conj ( x y -- xconj.y )
-GENERIC: Vnorm ( x -- norm )
-GENERIC: Vasum ( x -- sum )
-GENERIC: Vswap ( x y -- x=y y=x )
-GENERIC: Viamax ( x -- max-i )
-
-<PRIVATE
-
-GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
-
-GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
-
-: shorter-length ( v1 v2 -- length )
- [ length>> ] bi@ min ; inline
-: data-and-inc ( v -- data inc )
- [ ] [ inc>> ] bi ; inline
-: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
- [ data-and-inc ] bi@ ; inline
-
-:: (prepare-copy)
- ( v element-size -- length v-data v-inc v-dest-data v-dest-inc
- copy-data copy-length copy-inc )
- v [ length>> ] [ data-and-inc ] bi
- v length>> element-size * <byte-array>
- 1
- over v length>> 1 ;
-
-: (prepare-swap)
- ( v1 v2 -- length v1-data v1-inc v2-data v2-inc
- v1 v2 )
- [ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
-
-:: (prepare-axpy)
- ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
- v2 )
- v1 v2 shorter-length
- n
- v1 v2 datas-and-incs
- v2 ;
-
-:: (prepare-scal)
- ( n v -- length n v-data v-inc
- v )
- v length>>
- n
- v data-and-inc
- v ;
-
-: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
- [ shorter-length ] [ datas-and-incs ] 2bi ;
-
-: (prepare-nrm2) ( v -- length data inc )
- [ length>> ] [ data-and-inc ] bi ;
-
-PRIVATE>
-
-: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
-: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
-
-:: V+ ( x y -- x+y )
- 1.0 x y n*V+V ; inline
-:: V- ( x y -- x-y )
- -1.0 y x n*V+V ; inline
-
-: Vneg ( x -- -x )
- -1.0 swap n*V ; inline
-
-: V*n ( x alpha -- x*alpha )
- swap n*V ; inline
-: V/n ( x alpha -- x/alpha )
- recip swap n*V ; inline
-
-: Vamax ( x -- max )
- [ Viamax ] keep nth ; inline
-
-:: Vsub ( v start length -- sub )
- v inc>> start * v element-type heap-size *
- v underlying>> <displaced-alien>
- length v inc>> v (blas-vector-like) ;
-
-: <zero-vector> ( exemplar -- zero )
- [ element-type heap-size <byte-array> ]
- [ length>> 0 ]
- [ (blas-vector-like) ] tri ;
-
-: <empty-vector> ( length exemplar -- vector )
- [ element-type heap-size * <byte-array> ]
- [ 1 swap ] 2bi
- (blas-vector-like) ;
-
-M: blas-vector-base equal?
- {
- [ [ length ] bi@ = ]
- [ [ = ] 2all? ]
- } 2&& ;
-
-M: blas-vector-base length
- length>> ;
-M: blas-vector-base virtual-exemplar
- (blas-direct-array) ;
-M: blas-vector-base virtual@
- [ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
-
-: float>arg ( f -- f ) ; inline
-: double>arg ( f -- f ) ; inline
-: arg>float ( f -- f ) ; inline
-: arg>double ( f -- f ) ; inline
-
-<<
-
-FUNCTOR: (define-blas-vector) ( TYPE T -- )
-
-<DIRECT-ARRAY> IS <direct-${TYPE}-array>
-XCOPY IS ${T}COPY
-XSWAP IS ${T}SWAP
-IXAMAX IS I${T}AMAX
-
-VECTOR DEFINES-CLASS ${TYPE}-blas-vector
-<VECTOR> DEFINES <${TYPE}-blas-vector>
->VECTOR DEFINES >${TYPE}-blas-vector
-
-t [ T >lower ]
-
-XVECTOR{ DEFINES ${t}vector{
-
-XAXPY IS ${T}AXPY
-XSCAL IS ${T}SCAL
-
-WHERE
-
-TUPLE: VECTOR < blas-vector-base ;
-: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
-
-: >VECTOR ( seq -- v )
- [ TYPE >c-array underlying>> ] [ length ] bi 1 <VECTOR> ;
-
-M: VECTOR clone
- TYPE heap-size (prepare-copy)
- [ XCOPY ] 3dip <VECTOR> ;
-
-M: VECTOR element-type
- drop TYPE ;
-M: VECTOR Vswap
- (prepare-swap) [ XSWAP ] 2dip ;
-M: VECTOR Viamax
- (prepare-nrm2) IXAMAX 1 - ;
-
-M: VECTOR (blas-vector-like)
- drop <VECTOR> ;
-
-M: VECTOR (blas-direct-array)
- [ underlying>> ]
- [ [ length>> ] [ inc>> ] bi * ] bi
- <DIRECT-ARRAY> ;
-
-M: VECTOR n*V+V!
- (prepare-axpy) [ XAXPY ] dip ;
-M: VECTOR n*V!
- (prepare-scal) [ XSCAL ] dip ;
-
-SYNTAX: XVECTOR{ \ } [ >VECTOR ] parse-literal ;
-
-M: VECTOR pprint-delims
- drop \ XVECTOR{ \ } ;
-
-;FUNCTOR
-
-
-FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
-
-VECTOR IS ${TYPE}-blas-vector
-XDOT IS ${T}DOT
-XNRM2 IS ${T}NRM2
-XASUM IS ${T}ASUM
-
-WHERE
-
-M: VECTOR V.
- (prepare-dot) XDOT ;
-M: VECTOR V.conj
- (prepare-dot) XDOT ;
-M: VECTOR Vnorm
- (prepare-nrm2) XNRM2 ;
-M: VECTOR Vasum
- (prepare-nrm2) XASUM ;
-
-;FUNCTOR
-
-
-FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
-
-VECTOR IS ${TYPE}-blas-vector
-XDOTU IS ${C}DOTU
-XDOTC IS ${C}DOTC
-XXNRM2 IS ${S}${C}NRM2
-XXASUM IS ${S}${C}ASUM
-
-WHERE
-
-M: VECTOR V.
- (prepare-dot) XDOTU ;
-M: VECTOR V.conj
- (prepare-dot) XDOTC ;
-M: VECTOR Vnorm
- (prepare-nrm2) XXNRM2 ;
-M: VECTOR Vasum
- (prepare-nrm2) XXASUM ;
-
-;FUNCTOR
-
-
-: define-real-blas-vector ( TYPE T -- )
- [ (define-blas-vector) ]
- [ (define-real-blas-vector) ] 2bi ;
-: define-complex-blas-vector ( TYPE C S -- )
- [ drop (define-blas-vector) ]
- [ (define-complex-blas-vector) ] 3bi ;
-
-float "S" define-real-blas-vector
-double "D" define-real-blas-vector
-complex-float "C" "S" define-complex-blas-vector
-complex-double "Z" "D" define-complex-blas-vector
-
->>
-
-M: blas-vector-base >pprint-sequence ;
-M: blas-vector-base pprint* pprint-object ;
projects / factor.git / commitdiff