------------------------------------------------------------------------------- -- Copyright (C) 2000-2001 Centre National de la Recherche Scientifique -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- -- GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the Free Software -- -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- -- Author: Duncan Sands (Duncan.Sands@math.u-psud.fr) -- -- Departement de Mathematiques, Batiment 425, -- -- Universite de Paris-XI, Orsay, France. -- -- http://topo.math.u-psud.fr/~sands -- ------------------------------------------------------------------------------- -- Binding to the complex BLAS -- This package provides a thin binding to both the single and double -- precision complex BLAS. -- The precision (version) of the Fortran BLAS to be used is determined -- automatically from the generic parameter Float_Type. with Ada.Numerics.Generic_Complex_Types; generic type Float_Type is digits <>; -- The package determines whether to use the single precision (C) or the -- double precision (Z) Fortran BLAS for subroutine calls (or raise -- Unsupported_Precision_Error) based on the characteristics of -- Float_Type'Base with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Float_Type); type Complex_Type is new Complex_Types.Complex; type Index_Type is (<>); type Vector_Type is array (Index_Type range <>) of Complex_Type; -- Vector_Type may need to be of convention Fortran: -- pragma Convention (Fortran, Vector_Type); type Matrix_Type is array (Index_Type range <>, Index_Type range <>) of Complex_Type; -- Matrix_Type MUST be of convention Fortran (column-major order): -- pragma Convention (Fortran, Matrix_Type); package Ada_BLAS.Complex is pragma Pure (Ada_BLAS.Complex); Precision : constant Precision_Type; -- The precision (version) of the Fortran BLAS that will be used -------------- -- Level 1 -- -------------- -- SWAP: x <-> y procedure SWAP ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ); procedure SWAP (X, Y : in out Vector_Type); pragma Inline (SWAP); -- SCAL: x <- alpha x procedure SCAL ( N : in Natural; ALPHA : in Complex_Type; X : in out Vector_Type; INCX : in Natural ); procedure SCAL ( N : in Natural; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Natural ); procedure SCAL ( ALPHA : in Complex_Type; X : in out Vector_Type ); procedure SCAL ( ALPHA : in Float_Type'Base; X : in out Vector_Type ); pragma Inline (SCAL); -- COPY: y <- x procedure COPY ( N : in Natural; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ); procedure COPY ( X : in Vector_Type; Y : in out Vector_Type ); pragma Inline (COPY); -- AXPY: y <- alpha x + y procedure AXPY ( N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ); procedure AXPY ( ALPHA : in Complex_Type; X : in Vector_Type; Y : in out Vector_Type ); pragma Inline (AXPY); -- DOTU: dot <- x^T y function DOTU ( N : Natural; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Complex_Type; function DOTU (X, Y : Vector_Type) return Complex_Type; pragma Inline (DOTU); -- DOTC: dot <- x^H y function DOTC ( N : Natural; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Complex_Type; function DOTC (X, Y : Vector_Type) return Complex_Type; pragma Inline (DOTC); -- NRM2: nrm2 <- ||x||_2 function NRM2 ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base; function NRM2 (X : Vector_Type) return Float_Type'Base; pragma Inline (NRM2); -- ASUM: asum <- ||re(x)||_1 + ||im(x)||_1 function ASUM ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base; function ASUM (X : Vector_Type) return Float_Type'Base; pragma Inline (ASUM); -- AMAX: amax <- 1st k: |re(x_k)| + |im(x_k)| = max(|re(x_i)| + |im(x_i)|) -- Either ICAMAX (single precision) or IZAMAX (double precision) -- with the result converted to the correct value of Index_Type function AMAX ( N : Natural; X : Vector_Type; INCX : Natural ) return Index_Type; function AMAX (X : Vector_Type) return Index_Type; pragma Inline (AMAX); ------------- -- Level 2 -- ------------- -- GEMV: y <- alpha A x + beta y, y <- alpha A^T x + beta y, -- y <- alpha A^H x + beta y; A - M x N procedure GEMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ); procedure GEMV ( TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ); pragma Inline (GEMV); -- GBMV: y <- alpha A x + beta y, y <- alpha A^T x + beta y, -- y <- alpha A^H x + beta y; A - M x N procedure GBMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; KL : in Natural; KU : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ); procedure GBMV ( TRANS : in Transpose_Type; KL : in Natural; KU : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ); pragma Inline (GBMV); -- HEMV: y <- alpha A x + beta y procedure HEMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ); procedure HEMV ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ); pragma Inline (HEMV); -- HBMV: y <- alpha A x + beta y procedure HBMV ( UPLO : in Triangle_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ); procedure HBMV ( UPLO : in Triangle_Type; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ); pragma Inline (HBMV); -- HPMV: y <- alpha A x + beta y procedure HPMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ); procedure HPMV ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; AP : in Vector_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ); pragma Inline (HPMV); -- TRMV: x <- A x, x <- A^T x, x <- A^H x procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TRMV); -- TBMV: x <- A x, x <- A^T x, x <- A^H x procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TBMV); -- TPMV: x <- A x, x <- A^T x, x <- A^H x procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ); procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ); pragma Inline (TPMV); -- TRSV: x <- A^-1 x, x <- A^-T x, x <- A^-H x procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TRSV); -- TBSV: x <- A^-1 x, x <- A^-T x, x <- A^-H x procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TBSV); -- TPSV: x <- A^-1 x, x <- A^-T x, x <- A^-H x procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ); procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ); pragma Inline (TPSV); -- GERU: A <- alpha x y^T + A; A - M x N procedure GERU ( M : in Natural; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ); procedure GERU ( ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ); pragma Inline (GERU); -- GERC: A <- alpha x y^H + A; A - M x N procedure GERC ( M : in Natural; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ); procedure GERC ( ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ); pragma Inline (GERC); -- HER: A <- alpha x x^H + A procedure HER ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; A : in out Matrix_Type ); procedure HER ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; A : in out Matrix_Type ); pragma Inline (HER); -- HPR: A <- alpha x x^H + A procedure HPR ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; AP : in out Vector_Type ); procedure HPR ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; AP : in out Vector_Type ); pragma Inline (HPR); -- HER2: A <- alpha x y^H + y (alpha x)^H + A procedure HER2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ); procedure HER2 ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ); pragma Inline (HER2); -- HPR2: A <- alpha x y^H + y (alpha x)^H + A procedure HPR2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; AP : in out Vector_Type ); procedure HPR2 ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; AP : in out Vector_Type ); pragma Inline (HPR2); ------------- -- Level 3 -- ------------- -- GEMM: C <- alpha op(A) op(B) + beta C; -- op(X) = X, X^T, X^H; C - M x N procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; M : in Natural; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); pragma Inline (GEMM); -- SYMM: C <- alpha A B + beta C, C <- alpha B A + beta C; -- C - M x N; A = A^T procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); pragma Inline (SYMM); -- HEMM: C <- alpha A B + beta C, C <- alpha B A + beta C; -- C - M x N; A = A^H procedure HEMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); procedure HEMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); pragma Inline (HEMM); -- SYRK: C <- alpha A A^T + beta C, C <- alpha A^T A + beta C; -- C - N x N; C = C^T procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); pragma Inline (SYRK); -- HERK: C <- alpha A A^H + beta C, C <- alpha A^H A + beta C; -- C - N x N; C = C^H procedure HERK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); procedure HERK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); pragma Inline (HERK); -- SYR2K: C <- alpha A B^T + alpha B A^T + beta C, -- C <- alpha A^T B + alpha B^T A + beta C; -- C - N x N; C = C^T procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); pragma Inline (SYR2K); -- HER2K: C <- alpha A B^T + alpha B A^T + beta C, -- C <- alpha A^T B + alpha B^T A + beta C; -- C - N x N; C = C^T procedure HER2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); procedure HER2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ); pragma Inline (HER2K); -- TRMM: B <- alpha op(A) B, B <- alpha B op(A); -- op(A) = A, A^T, A^H; A triangular; B - M x N procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ); procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ); pragma Inline (TRMM); -- TRSM: B <- alpha op(A^-1) B, B <- alpha B op(A^-1); -- op(A) = A, A^T, A^H; A triangular; B - M x N procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ); procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ); pragma Inline (TRSM); private -- The following method of determining Precision was chosen in order to -- encourage compile time evaluation and thus, hopefully, dead code -- elimination. Constraint_Error will be raised if double and single -- precision are the same (this should never happen since the Fortran -- standard requires double precision to be more precise than single -- precision). I appreciate that the value of Precision is not -- guaranteed to be correct for all machines, all compilers and all values -- of Float_Type. However, I don't know any examples of it being wrong. -- IF PRECISION IS SET WRONGLY ON YOUR MACHINE, PLEASE LET ME KNOW! Precision : constant Precision_Type := Precision_Type'Val ( Precision_Type'Pos (Unsupported) - Boolean'Pos ( -- Test for double precision Float_Type'Base'Digits = Interfaces.Fortran.Double_Precision'Digits and Float_Type'Base'Size = Interfaces.Fortran.Double_Precision'Size ) - 2 * Boolean'Pos ( -- Test for single precision Float_Type'Base'Digits = Interfaces.Fortran.Real'Digits and Float_Type'Base'Size = Interfaces.Fortran.Real'Size ) ); end Ada_BLAS.Complex; ------------------------------------------------------------------------------- -- Copyright (C) 2000-2001 Centre National de la Recherche Scientifique -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- -- GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the Free Software -- -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- -- Author: Duncan Sands (Duncan.Sands@math.u-psud.fr) -- -- Departement de Mathematiques, Batiment 425, -- -- Universite de Paris-XI, Orsay, France. -- -- http://topo.math.u-psud.fr/~sands -- ------------------------------------------------------------------------------- -- Determines the BLAS precision corresponding to Float_Type'Base generic type Float_Type is digits <>; package Ada_BLAS.Get_Precision is pragma Pure (Ada_BLAS.Get_Precision); Precision : constant Precision_Type; private -- The following method of determining Precision was chosen in order to -- encourage compile time evaluation and thus, hopefully, dead code -- elimination. Constraint_Error will be raised if double and single -- precision are the same (this should never happen since the Fortran -- standard requires double precision to be more precise than single -- precision). I appreciate that the value of Precision is not -- guaranteed to be correct for all machines, all compilers and all values -- of Float_Type. However, I don't know any examples of it being wrong. -- IF PRECISION IS SET WRONGLY ON YOUR MACHINE, PLEASE LET ME KNOW! Precision : constant Precision_Type := Precision_Type'Val ( Precision_Type'Pos (Unsupported) - Boolean'Pos ( -- Test for double precision Float_Type'Base'Digits = Interfaces.Fortran.Double_Precision'Digits and Float_Type'Base'Size = Interfaces.Fortran.Double_Precision'Size ) - 2 * Boolean'Pos ( -- Test for single precision Float_Type'Base'Digits = Interfaces.Fortran.Real'Digits and Float_Type'Base'Size = Interfaces.Fortran.Real'Size ) ); end Ada_BLAS.Get_Precision; ------------------------------------------------------------------------------- -- Copyright (C) 2000-2001 Centre National de la Recherche Scientifique -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- -- GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the Free Software -- -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- -- Author: Duncan Sands (Duncan.Sands@math.u-psud.fr) -- -- Departement de Mathematiques, Batiment 425, -- -- Universite de Paris-XI, Orsay, France. -- -- http://topo.math.u-psud.fr/~sands -- ------------------------------------------------------------------------------- -- Binding to the real BLAS -- This package provides a thin binding to both the single and double -- precision real BLAS. -- The precision (version) of the Fortran BLAS to be used is determined -- automatically from the generic parameter Float_Type. generic type Float_Type is digits <>; -- The package determines whether to use the single precision (S) or the -- double precision (D) Fortran BLAS for subroutine calls (or raise -- Unsupported_Precision_Error) based on the characteristics of -- Float_Type'Base type Index_Type is (<>); type Vector_Type is array (Index_Type range <>) of Float_Type; -- Note: the previous line should read -- type Vector_Type is array (Index_Type range <>) of Float_Type'Base; -- but this does not compile with version 3.13p of the GNAT compiler. -- Vector_Type may need to be of convention Fortran: -- pragma Convention (Fortran, Vector_Type); type Matrix_Type is array (Index_Type range <>, Index_Type range <>) of Float_Type; -- Note: the previous two lines should read -- type Matrix_Type is array (Index_Type range <>, Index_Type range <>) -- of Float_Type'Base; -- but this does not compile with version 3.13p of the GNAT compiler. -- Matrix_Type MUST be of convention Fortran (column-major order): -- pragma Convention (Fortran, Matrix_Type); package Ada_BLAS.Real is pragma Pure (Ada_BLAS.Real); Precision : constant Precision_Type; -- The precision (version) of the Fortran BLAS that will be used type Modified_Givens is array (1 .. 5) of Float_Type'Base; pragma Convention (Fortran, Modified_Givens); -------------- -- Level 1 -- -------------- -- ROTG: Generate plane rotation procedure ROTG ( A, B : in out Float_Type'Base; C, S : out Float_Type'Base ); pragma Inline (ROTG); -- ROTMG: Generate modified plane rotation procedure ROTMG ( D1, D2 : in out Float_Type'Base; A : in out Float_Type'Base; B : in Float_Type'Base; PARAM : out Modified_Givens ); pragma Inline (ROTMG); -- ROT: Apply plane rotation procedure ROT ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer; C, S : in Float_Type'Base ); procedure ROT ( X, Y : in out Vector_Type; C, S : in Float_Type'Base ); pragma Inline (ROT); -- ROTM: Apply modified plane rotation procedure ROTM ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer; PARAM : in Modified_Givens ); procedure ROTM ( X, Y : in out Vector_Type; PARAM : in Modified_Givens ); pragma Inline (ROTM); -- SWAP: x <-> y procedure SWAP ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ); procedure SWAP (X, Y : in out Vector_Type); pragma Inline (SWAP); -- SCAL: x <- alpha x procedure SCAL ( N : in Natural; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Natural ); procedure SCAL ( ALPHA : in Float_Type'Base; X : in out Vector_Type ); pragma Inline (SCAL); -- COPY: y <- x procedure COPY ( N : in Natural; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ); procedure COPY ( X : in Vector_Type; Y : in out Vector_Type ); pragma Inline (COPY); -- AXPY: y <- alpha x + y procedure AXPY ( N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ); procedure AXPY ( ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in out Vector_Type ); pragma Inline (AXPY); -- DOT: dot <- x^T y function DOT ( N : Natural; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Float_Type'Base; function DOT (X, Y : Vector_Type) return Float_Type'Base; pragma Inline (DOT); -- DSDOT: dot <- alpha + x^T y (double precision accumulation) -- Either SDSDOT (single precision) or ALPHA + DDOT (double precision) function DSDOT ( N : Natural; ALPHA : Float_Type'Base; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Float_Type'Base; function DSDOT ( ALPHA : Float_Type'Base; X, Y : Vector_Type ) return Float_Type'Base; pragma Inline (DSDOT); -- NRM2: nrm2 <- ||x||_2 function NRM2 ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base; function NRM2 (X : Vector_Type) return Float_Type'Base; pragma Inline (NRM2); -- ASUM: asum <- ||x||_1 function ASUM ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base; function ASUM (X : Vector_Type) return Float_Type'Base; pragma Inline (ASUM); -- AMAX: amax <- 1st k: |x_k| = max(|x_i|) -- Either ISAMAX (single precision) or IDAMAX (double precision) -- with the result converted to the correct value of Index_Type function AMAX ( N : Natural; X : Vector_Type; INCX : Natural ) return Index_Type; function AMAX (X : Vector_Type) return Index_Type; pragma Inline (AMAX); ------------- -- Level 2 -- ------------- -- GEMV: y <- alpha A x + beta y, y <- alpha A^T x + beta y; A - M x N procedure GEMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ); procedure GEMV ( TRANS : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ); pragma Inline (GEMV); -- GBMV: y <- alpha A x + beta y, y <- alpha A^T x + beta y; A - M x N procedure GBMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; KL : in Natural; KU : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ); procedure GBMV ( TRANS : in Transpose_Type; KL : in Natural; KU : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ); pragma Inline (GBMV); -- SYMV: y <- alpha A x + beta y procedure SYMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ); procedure SYMV ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ); pragma Inline (SYMV); -- SBMV: y <- alpha A x + beta y procedure SBMV ( UPLO : in Triangle_Type; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ); procedure SBMV ( UPLO : in Triangle_Type; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ); pragma Inline (SBMV); -- SPMV: y <- alpha A x + beta y procedure SPMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ); procedure SPMV ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; AP : in Vector_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ); pragma Inline (SPMV); -- TRMV: x <- A x, x <- A^T x procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TRMV); -- TBMV: x <- A x, x <- A^T x procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TBMV); -- TPMV: x <- A x, x <- A^T x procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ); procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ); pragma Inline (TPMV); -- TRSV: x <- A^-1 x, x <- A^-T x procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TRSV); -- TBSV: x <- A^-1 x, x <- A^-T x procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ); procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ); pragma Inline (TBSV); -- TPSV: x <- A^-1 x, x <- A^-T x procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ); procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ); pragma Inline (TPSV); -- GER: A <- alpha x y^T + A; A - M x N procedure GER ( M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ); procedure GER ( ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ); pragma Inline (GER); -- SYR: A <- alpha x x^T + A procedure SYR ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; A : in out Matrix_Type ); procedure SYR ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; A : in out Matrix_Type ); pragma Inline (SYR); -- SPR: A <- alpha x x^T + A procedure SPR ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; AP : in out Vector_Type ); procedure SPR ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; AP : in out Vector_Type ); pragma Inline (SPR); -- SYR2: A <- alpha x y^T + alpha y x^T + A procedure SYR2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ); procedure SYR2 ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ); pragma Inline (SYR2); -- SPR2: A <- alpha x y^T + alpha y x^T + A procedure SPR2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; AP : in out Vector_Type ); procedure SPR2 ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in Vector_Type; AP : in out Vector_Type ); pragma Inline (SPR2); ------------- -- Level 3 -- ------------- -- GEMM: C <- alpha op(A) op(B) + beta C; -- op(X) = X, X^T, X^H; C - M x N procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; M : in Natural; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); pragma Inline (GEMM); -- SYMM: C <- alpha A B + beta C, C <- alpha B A + beta C; -- C - M x N; A = A^T procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); pragma Inline (SYMM); -- SYRK: C <- alpha A A^T + beta C, C <- alpha A^T A + beta C; -- C - N x N; C = C^T procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); pragma Inline (SYRK); -- SYR2K: C <- alpha A B^T + alpha B A^T + beta C, -- C <- alpha A^T B + alpha B^T A + beta C; -- C - N x N; C = C^T procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ); pragma Inline (SYR2K); -- TRMM: B <- alpha op(A) B, B <- alpha B op(A); -- op(A) = A, A^T, A^H; A triangular; B - M x N procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ); procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ); pragma Inline (TRMM); -- TRSM: B <- alpha op(A^-1) B, B <- alpha B op(A^-1); -- op(A) = A, A^T, A^H; A triangular; B - M x N procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ); procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ); pragma Inline (TRSM); private -- The following method of determining Precision was chosen in order to -- encourage compile time evaluation and thus, hopefully, dead code -- elimination. Constraint_Error will be raised if double and single -- precision are the same (this should never happen since the Fortran -- standard requires double precision to be more precise than single -- precision). I appreciate that the value of Precision is not -- guaranteed to be correct for all machines, all compilers and all values -- of Float_Type. However, I don't know any examples of it being wrong. -- IF PRECISION IS SET WRONGLY ON YOUR MACHINE, PLEASE LET ME KNOW! Precision : constant Precision_Type := Precision_Type'Val ( Precision_Type'Pos (Unsupported) - Boolean'Pos ( -- Test for double precision Float_Type'Base'Digits = Interfaces.Fortran.Double_Precision'Digits and Float_Type'Base'Size = Interfaces.Fortran.Double_Precision'Size ) - 2 * Boolean'Pos ( -- Test for single precision Float_Type'Base'Digits = Interfaces.Fortran.Real'Digits and Float_Type'Base'Size = Interfaces.Fortran.Real'Size ) ); end Ada_BLAS.Real; ------------------------------------------------------------------------------- -- Copyright (C) 2000-2001 Centre National de la Recherche Scientifique -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- -- GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the Free Software -- -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- -- Author: Duncan Sands (Duncan.Sands@math.u-psud.fr) -- -- Departement de Mathematiques, Batiment 425, -- -- Universite de Paris-XI, Orsay, France. -- -- http://topo.math.u-psud.fr/~sands -- ------------------------------------------------------------------------------- -- Binding to the BLAS -- This package provides definitions used by both the real and complex BLAS. -- You may need to modify Name_Prepend and Name_Append to suit your system. with Interfaces.Fortran; package Ada_BLAS is pragma Pure (Ada_BLAS); Argument_Error, Unsupported_Precision_Error : exception; type Precision_Type is ( Single, -- Fortran REAL Double, -- Fortran DOUBLE PRECISION Unsupported -- Not a standard Fortran precision ); type Diagonal_Type is ( -- For triangular matrices: Non_Unit_Triangular, -- Do not assume all diagonal elements equal 1 Unit_Triangular -- Assume all diagonal elements equal 1 ); type Side_Type is ( Left, -- A or op(A) on the left Right -- A or op(A) on the right ); type Transpose_Type is ( None, -- use X Transpose, -- use X^T Conjugate_Transpose -- use X^H ); type Triangle_Type is ( Upper_Triangle, -- Only upper triangle is referenced / upper triangular Lower_Triangle -- Only lower triangle is referenced / lower triangular ); private -- Strings that will be appended/prepended to each BLAS subroutine name -- to form the external name used when importing it. -- They may need to be modified for your system Name_Prepend : constant String := ""; Name_Append : constant String := "_"; use Interfaces.Fortran; Fortran_DIAG : constant array (Diagonal_Type) of Character_Set := ( Non_Unit_Triangular => 'N', Unit_Triangular => 'U' ); Fortran_SIDE : constant array (Side_Type) of Character_Set := ( Left => 'L', Right => 'R' ); Fortran_TRANS : constant array (Transpose_Type) of Character_Set := ( None => 'N', Transpose => 'T', Conjugate_Transpose => 'C' ); Fortran_UPLO : constant array (Triangle_Type) of Character_Set := ( Upper_Triangle => 'U', Lower_Triangle => 'L' ); end Ada_BLAS; with Ada_BLAS.Real; package Example_Support is type Vector is array (Positive range <>) of Float; pragma Convention (Fortran, Vector); -- May not be necessary type Matrix is array (Positive range <>, Positive range <>) of Float; pragma Convention (Fortran, Matrix); -- Necessary package Real_BLAS is new Ada_BLAS.Real ( Float_Type => Float, Index_Type => Positive, Vector_Type => Vector, Matrix_Type => Matrix ); end Example_Support; ------------------------------------------------------------------------------- -- Copyright (C) 2000 Centre National de la Recherche Scientifique (CNRS) -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- -- GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the Free Software -- -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- -- Author: Duncan Sands (Duncan.Sands@math.u-psud.fr) -- -- Departement de Mathematiques, Batiment 425, -- -- Universite de Paris-XI, Orsay, France. -- -- http://topo.math.u-psud.fr/~sands -- ------------------------------------------------------------------------------- package body Ada_BLAS.Complex is ---------- -- AMAX -- ---------- function ICAMAX ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Fortran_Integer; pragma Import (Fortran, ICAMAX, Name_Prepend & "icamax" & Name_Append); function IZAMAX ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Fortran_Integer; pragma Import (Fortran, IZAMAX, Name_Prepend & "izamax" & Name_Append); function AMAX ( N : Natural; X : Vector_Type; INCX : Natural ) return Index_Type is begin if N = 0 then return X'First; elsif (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => return Index_Type'Val ( Index_Type'Pos (X'First) + INCX * ( Integer ( ICAMAX (Fortran_Integer (N), X, Fortran_Integer (INCX)) ) - 1 ) ); when Double => return Index_Type'Val ( Index_Type'Pos (X'First) + INCX * ( Integer ( IZAMAX (Fortran_Integer (N), X, Fortran_Integer (INCX)) ) - 1 ) ); when Unsupported => raise Unsupported_Precision_Error; end case; end AMAX; function AMAX (X : Vector_Type) return Index_Type is begin if X'Length = 0 then return X'First; end if; case Precision is when Single => return Index_Type'Val ( Index_Type'Pos (X'First) - 1 + Integer ( ICAMAX (X'Length, X, 1) ) ); when Double => return Index_Type'Val ( Index_Type'Pos (X'First) - 1 + Integer ( IZAMAX (X'Length, X, 1) ) ); when Unsupported => raise Unsupported_Precision_Error; end case; end AMAX; ---------- -- ASUM -- ---------- function SCASUM ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, SCASUM, Name_Prepend & "scasum" & Name_Append); function DZASUM ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, DZASUM, Name_Prepend & "dzasum" & Name_Append); function ASUM ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base is begin if N > 0 and (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => return SCASUM (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Double => return DZASUM (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Unsupported => raise Unsupported_Precision_Error; end case; end ASUM; function ASUM (X : Vector_Type) return Float_Type'Base is begin case Precision is when Single => return SCASUM (X'Length, X, 1); when Double => return DZASUM (X'Length, X, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end ASUM; ---------- -- AXPY -- ---------- procedure CAXPY ( N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CAXPY, Name_Prepend & "caxpy" & Name_Append); procedure ZAXPY ( N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZAXPY, Name_Prepend & "zaxpy" & Name_Append); procedure AXPY ( N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => CAXPY ( Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => ZAXPY ( Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end AXPY; procedure AXPY ( ALPHA : in Complex_Type; X : in Vector_Type; Y : in out Vector_Type ) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => CAXPY (X'Length, ALPHA, X, 1, Y, 1); when Double => ZAXPY (X'Length, ALPHA, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end AXPY; ---------- -- COPY -- ---------- procedure CCOPY ( N : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CCOPY, Name_Prepend & "ccopy" & Name_Append); procedure ZCOPY ( N : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZCOPY, Name_Prepend & "zcopy" & Name_Append); procedure COPY ( N : in Natural; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => CCOPY ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => ZCOPY ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end COPY; procedure COPY ( X : in Vector_Type; Y : in out Vector_Type ) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => CCOPY (X'Length, X, 1, Y, 1); when Double => ZCOPY (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end COPY; ---------- -- DOTC -- ---------- function CDOTC ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer; Y : Vector_Type; INCY : Fortran_Integer ) return Complex_Type; pragma Import (Fortran, CDOTC, Name_Prepend & "cdotu" & Name_Append); function ZDOTC ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer; Y : Vector_Type; INCY : Fortran_Integer ) return Complex_Type; pragma Import (Fortran, ZDOTC, Name_Prepend & "zdotu" & Name_Append); function DOTC ( N : Natural; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Complex_Type is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => return CDOTC ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => return ZDOTC ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end DOTC; function DOTC (X, Y : Vector_Type) return Complex_Type is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => return CDOTC (X'Length, X, 1, Y, 1); when Double => return ZDOTC (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end DOTC; ---------- -- DOTU -- ---------- function CDOTU ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer; Y : Vector_Type; INCY : Fortran_Integer ) return Complex_Type; pragma Import (Fortran, CDOTU, Name_Prepend & "cdotu" & Name_Append); function ZDOTU ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer; Y : Vector_Type; INCY : Fortran_Integer ) return Complex_Type; pragma Import (Fortran, ZDOTU, Name_Prepend & "zdotu" & Name_Append); function DOTU ( N : Natural; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Complex_Type is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => return CDOTU ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => return ZDOTU ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end DOTU; function DOTU (X, Y : Vector_Type) return Complex_Type is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => return CDOTU (X'Length, X, 1, Y, 1); when Double => return ZDOTU (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end DOTU; ---------- -- GBMV -- ---------- procedure CGBMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; KL : in Fortran_Integer; KU : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CGBMV, Name_Prepend & "cgbmv" & Name_Append); procedure ZGBMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; KL : in Fortran_Integer; KU : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZGBMV, Name_Prepend & "zgbmv" & Name_Append); procedure GBMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; KL : in Natural; KU : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) <= KL + KU or A'Length (2) < N or INCX = 0 or INCY = 0 then raise Argument_Error; end if; case TRANS is when None => if (N - 1) * abs INCX >= X'Length or (M - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if (M - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; end case; case Precision is when Single => CGBMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => ZGBMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GBMV; procedure GBMV ( TRANS : in Transpose_Type; KL : in Natural; KU : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ) is M : Fortran_Integer; begin if A'Length (1) /= KL + KU + 1 or KU >= A'Length (2) then raise Argument_Error; end if; case TRANS is when None => if X'Length /= A'Length (2) or KL >= Y'Length then raise Argument_Error; end if; M := Y'Length; when Transpose | Conjugate_Transpose => if Y'Length /= A'Length (2) or KL >= X'Length then raise Argument_Error; end if; M := X'Length; end case; case Precision is when Single => CGBMV ( TRANS => Fortran_TRANS (TRANS), M => M, N => A'Length (2), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => ZGBMV ( TRANS => Fortran_TRANS (TRANS), M => M, N => A'Length (2), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end GBMV; ---------- -- GEMM -- ---------- procedure CGEMM ( TRANSA : in Character_Set; TRANSB : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, CGEMM, Name_Prepend & "cgemm" & Name_Append); procedure ZGEMM ( TRANSA : in Character_Set; TRANSB : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, ZGEMM, Name_Prepend & "zgemm" & Name_Append); procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; M : in Natural; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < M or C'Length (2) < N then raise Argument_Error; end if; case TRANSA is when None => if A'Length (1) < M or A'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < M then raise Argument_Error; end if; end case; case TRANSB is when None => if B'Length (1) < K or B'Length (2) < N then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if B'Length (1) < N or B'Length (2) < K then raise Argument_Error; end if; end case; case Precision is when Single => CGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => Fortran_Integer (M), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => Fortran_Integer (M), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMM; procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 then raise Argument_Error; end if; case TRANSA is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case TRANSB is when None => if B'Length (1) /= K or B'Length (2) /= C'Length (2) then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if B'Length (2) /= K or B'Length (1) /= C'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => CGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => C'Length (1), N => C'Length (2), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => C'Length (1), N => C'Length (2), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMM; ---------- -- GEMV -- ---------- procedure CGEMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CGEMV, Name_Prepend & "cgemv" & Name_Append); procedure ZGEMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZGEMV, Name_Prepend & "zgemv" & Name_Append); procedure GEMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < M or A'Length (2) < N or INCX = 0 or INCY = 0 then raise Argument_Error; end if; case TRANS is when None => if (N - 1) * abs INCX >= X'Length or (M - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if (M - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; end case; case Precision is when Single => CGEMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => ZGEMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMV; procedure GEMV ( TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ) is begin if A'Length (1) = 0 then raise Argument_Error; end if; case TRANS is when None => if X'Length /= A'Length (2) or Y'Length /= A'Length (1) then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if X'Length /= A'Length (1) or Y'Length /= A'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => CGEMV ( TRANS => Fortran_TRANS (TRANS), M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => ZGEMV ( TRANS => Fortran_TRANS (TRANS), M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMV; ---------- -- GERC -- ---------- procedure CGERC ( M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, CGERC, Name_Prepend & "cgerc" & Name_Append); procedure ZGERC ( M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, ZGERC, Name_Prepend & "zgerc" & Name_Append); procedure GERC ( M : in Natural; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) < M or A'Length (2) < N or INCX = 0 or INCY = 0 or (M - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => CGERC ( M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Double => ZGERC ( M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GERC; procedure GERC ( ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or X'Length /= A'Length (1) or Y'Length /= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => CGERC ( M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Double => ZGERC ( M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GERC; ---------- -- GERU -- ---------- procedure CGERU ( M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, CGERU, Name_Prepend & "cgeru" & Name_Append); procedure ZGERU ( M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, ZGERU, Name_Prepend & "zgeru" & Name_Append); procedure GERU ( M : in Natural; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) < M or A'Length (2) < N or INCX = 0 or INCY = 0 or (M - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => CGERU ( M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Double => ZGERU ( M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GERU; procedure GERU ( ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or X'Length /= A'Length (1) or Y'Length /= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => CGERU ( M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Double => ZGERU ( M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GERU; ---------- -- HBMV -- ---------- procedure CHBMV ( UPLO : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CHBMV, Name_Prepend & "chbmv" & Name_Append); procedure ZHBMV ( UPLO : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZHBMV, Name_Prepend & "zhbmv" & Name_Append); procedure HBMV ( UPLO : in Triangle_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) <= K or A'Length (2) < N or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHBMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => ZHBMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HBMV; procedure HBMV ( UPLO : in Triangle_Type; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ) is begin if A'Length (1) /= K + 1 or X'Length /= A'Length (2) or Y'Length /= A'Length (2) or K >= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => CHBMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (2), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => ZHBMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (2), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end HBMV; ---------- -- HEMM -- ---------- procedure CHEMM ( SIDE : in Character_Set; UPLO : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, CHEMM, Name_Prepend & "chemm" & Name_Append); procedure ZHEMM ( SIDE : in Character_Set; UPLO : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, ZHEMM, Name_Prepend & "zhemm" & Name_Append); procedure HEMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < M or C'Length (2) < N or B'Length (1) < M or B'Length (2) < N then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) < M or A'Length (2) < M then raise Argument_Error; end if; when Right => if A'Length (1) < N or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CHEMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZHEMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HEMM; procedure HEMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or A'Length (1) /= A'Length (2) or B'Length (1) /= C'Length (1) or B'Length (2) /= C'Length (2) then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; when Right => if A'Length (1) /= C'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => CHEMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => C'Length (1), N => C'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZHEMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => C'Length (1), N => C'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HEMM; ---------- -- HEMV -- ---------- procedure CHEMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CHEMV, Name_Prepend & "chemv" & Name_Append); procedure ZHEMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZHEMV, Name_Prepend & "zhemv" & Name_Append); procedure HEMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHEMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => ZHEMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HEMV; procedure HEMV ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; A : in Matrix_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or A'Length (1) /= X'Length or A'Length (1) /= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHEMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => ZHEMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end HEMV; --------- -- HER -- --------- procedure CHER ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, CHER, Name_Prepend & "cher" & Name_Append); procedure ZHER ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, ZHER, Name_Prepend & "zher" & Name_Append); procedure HER ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CHER ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), A => A, LDA => A'Length (1) ); when Double => ZHER ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HER; procedure HER ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or X'Length /= A'Length (1) then raise Argument_Error; end if; case Precision is when Single => CHER ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, A => A, LDA => A'Length (1) ); when Double => ZHER ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HER; ---------- -- HER2 -- ---------- procedure CHER2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, CHER2, Name_Prepend & "cher2" & Name_Append); procedure ZHER2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, ZHER2, Name_Prepend & "zher2" & Name_Append); procedure HER2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHER2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Double => ZHER2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HER2; procedure HER2 ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or X'Length /= A'Length (1) or Y'Length /= A'Length (1) then raise Argument_Error; end if; case Precision is when Single => CHER2 ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Double => ZHER2 ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HER2; ---------- -- HERK -- ---------- procedure CHERK ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, CHERK, Name_Prepend & "cherk" & Name_Append); procedure ZHERK ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, ZHERK, Name_Prepend & "zherk" & Name_Append); procedure HERK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < N or C'Length (2) < N then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) < N or A'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CHERK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZHERK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HERK; procedure HERK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) /= C'Length (2) then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case Precision is when Single => CHERK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZHERK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HERK; ----------- -- HER2K -- ----------- procedure CHER2K ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, CHER2K, Name_Prepend & "cher2k" & Name_Append); procedure ZHER2K ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, ZHER2K, Name_Prepend & "zher2k" & Name_Append); procedure HER2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < N or C'Length (2) < N then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) < N or A'Length (2) < K or B'Length (1) < N or B'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < N or B'Length (1) < K or B'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CHER2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZHER2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HER2K; procedure HER2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or A'Length (1) /= B'Length (1) or A'Length (2) /= B'Length (2) or C'Length (1) /= C'Length (2) then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case Precision is when Single => CHER2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZHER2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HER2K; ---------- -- HPMV -- ---------- procedure CHPMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CHPMV, Name_Prepend & "chpmv" & Name_Append); procedure ZHPMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZHPMV, Name_Prepend & "zhpmv" & Name_Append); procedure HPMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer; BETA : in Complex_Type; Y : in out Vector_Type; INCY : in Integer ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHPMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, AP => AP, X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => ZHPMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, AP => AP, X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end HPMV; procedure HPMV ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; AP : in Vector_Type; X : in Vector_Type; BETA : in Complex_Type; Y : in out Vector_Type ) is begin if AP'Length /= X'Length * (1 + X'Length) / 2 or X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHPMV ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, AP => AP, X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => ZHPMV ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, AP => AP, X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end HPMV; --------- -- HPR -- --------- procedure CHPR ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, CHPR, Name_Prepend & "chpr" & Name_Append); procedure ZHPR ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, ZHPR, Name_Prepend & "zhpr" & Name_Append); procedure HPR ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; AP : in out Vector_Type ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CHPR ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), AP => AP ); when Double => ZHPR ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end HPR; procedure HPR ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; AP : in out Vector_Type ) is begin if AP'Length /= X'Length * (X'Length + 1) / 2 then raise Argument_Error; end if; case Precision is when Single => CHPR ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, AP => AP ); when Double => ZHPR ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end HPR; ---------- -- HPR2 -- ---------- procedure CHPR2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, CHPR2, Name_Prepend & "chpr2" & Name_Append); procedure ZHPR2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, ZHPR2, Name_Prepend & "zhpr2" & Name_Append); procedure HPR2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Complex_Type; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; AP : in out Vector_Type ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHPR2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), AP => AP ); when Double => ZHPR2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end HPR2; procedure HPR2 ( UPLO : in Triangle_Type; ALPHA : in Complex_Type; X : in Vector_Type; Y : in Vector_Type; AP : in out Vector_Type ) is begin if AP'Length /= X'Length * (X'Length + 1) / 2 or X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => CHPR2 ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, AP => AP ); when Double => ZHPR2 ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end HPR2; ---------- -- NRM2 -- ---------- function SCNRM2 ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, SCNRM2, Name_Prepend & "scnrm2" & Name_Append); function DZNRM2 ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, DZNRM2, Name_Prepend & "dznrm2" & Name_Append); function NRM2 ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base is begin if N > 0 and (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => return SCNRM2 (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Double => return DZNRM2 (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Unsupported => raise Unsupported_Precision_Error; end case; end NRM2; function NRM2 (X : Vector_Type) return Float_Type'Base is begin case Precision is when Single => return SCNRM2 (X'Length, X, 1); when Double => return DZNRM2 (X'Length, X, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end NRM2; ---------- -- SCAL -- ---------- procedure CSCAL ( N : in Fortran_Integer; ALPHA : in Complex_Type; X : in out Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CSCAL, Name_Prepend & "cscal" & Name_Append); procedure CSSCAL ( N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CSSCAL, Name_Prepend & "csscal" & Name_Append); procedure ZSCAL ( N : in Fortran_Integer; ALPHA : in Complex_Type; X : in out Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZSCAL, Name_Prepend & "zscal" & Name_Append); procedure ZDSCAL ( N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZDSCAL, Name_Prepend & "zdscal" & Name_Append); procedure SCAL ( N : in Natural; ALPHA : in Complex_Type; X : in out Vector_Type; INCX : in Natural ) is begin if N > 0 and (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CSCAL (Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX)); when Double => ZSCAL (Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX)); when Unsupported => raise Unsupported_Precision_Error; end case; end SCAL; procedure SCAL ( N : in Natural; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Natural ) is begin if N > 0 and (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CSSCAL (Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX)); when Double => ZDSCAL (Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX)); when Unsupported => raise Unsupported_Precision_Error; end case; end SCAL; procedure SCAL ( ALPHA : in Complex_Type; X : in out Vector_Type ) is begin case Precision is when Single => CSCAL (X'Length, ALPHA, X, 1); when Double => ZSCAL (X'Length, ALPHA, X, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end SCAL; procedure SCAL ( ALPHA : in Float_Type'Base; X : in out Vector_Type ) is begin case Precision is when Single => CSSCAL (X'Length, ALPHA, X, 1); when Double => ZDSCAL (X'Length, ALPHA, X, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end SCAL; ---------- -- SWAP -- ---------- procedure CSWAP ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, CSWAP, Name_Prepend & "cswap" & Name_Append); procedure ZSWAP ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, ZSWAP, Name_Prepend & "zswap" & Name_Append); procedure SWAP ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => CSWAP ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => ZSWAP ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SWAP; procedure SWAP (X, Y : in out Vector_Type) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => CSWAP (X'Length, X, 1, Y, 1); when Double => ZSWAP (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end SWAP; ---------- -- SYMM -- ---------- procedure CSYMM ( SIDE : in Character_Set; UPLO : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, CSYMM, Name_Prepend & "csymm" & Name_Append); procedure ZSYMM ( SIDE : in Character_Set; UPLO : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, ZSYMM, Name_Prepend & "zsymm" & Name_Append); procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < M or C'Length (2) < N or B'Length (1) < M or B'Length (2) < N then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) < M or A'Length (2) < M then raise Argument_Error; end if; when Right => if A'Length (1) < N or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYMM; procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or A'Length (1) /= A'Length (2) or B'Length (1) /= C'Length (1) or B'Length (2) /= C'Length (2) then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; when Right => if A'Length (1) /= C'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => CSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => C'Length (1), N => C'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => C'Length (1), N => C'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYMM; ---------- -- SYRK -- ---------- procedure CSYRK ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, CSYRK, Name_Prepend & "csyrk" & Name_Append); procedure ZSYRK ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, ZSYRK, Name_Prepend & "zsyrk" & Name_Append); procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < N or C'Length (2) < N then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) < N or A'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYRK; procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) /= C'Length (2) then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case Precision is when Single => CSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYRK; ----------- -- SYR2K -- ----------- procedure CSYR2K ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, CSYR2K, Name_Prepend & "csyr2k" & Name_Append); procedure ZSYR2K ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Complex_Type; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, ZSYR2K, Name_Prepend & "zsyr2k" & Name_Append); procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < N or C'Length (2) < N then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) < N or A'Length (2) < K or B'Length (1) < N or B'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < N or B'Length (1) < K or B'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR2K; procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type; BETA : in Complex_Type; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or A'Length (1) /= B'Length (1) or A'Length (2) /= B'Length (2) or C'Length (1) /= C'Length (2) then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case Precision is when Single => CSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => ZSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR2K; ---------- -- TBMV -- ---------- procedure CTBMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CTBMV, Name_Prepend & "ctbmv" & Name_Append); procedure ZTBMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZTBMV, Name_Prepend & "ztbmv" & Name_Append); procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) <= K or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CTBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => ZTBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBMV; procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) /= K + 1 or X'Length /= A'Length (2) or K >= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => CTBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => ZTBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBMV; ---------- -- TBSV -- ---------- procedure CTBSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CTBSV, Name_Prepend & "ctbsv" & Name_Append); procedure ZTBSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZTBSV, Name_Prepend & "ztbsv" & Name_Append); procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) <= K or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CTBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => ZTBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBSV; procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) /= K + 1 or X'Length /= A'Length (2) or K >= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => CTBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => ZTBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBSV; ---------- -- TPMV -- ---------- procedure CTPMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CTPMV, Name_Prepend & "ctpmv" & Name_Append); procedure ZTPMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZTPMV, Name_Prepend & "ztpmv" & Name_Append); procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CTPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Double => ZTPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPMV; procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ) is begin if AP'Length /= X'Length * (1 + X'Length) / 2 then raise Argument_Error; end if; case Precision is when Single => CTPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Double => ZTPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPMV; ---------- -- TPSV -- ---------- procedure CTPSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CTPSV, Name_Prepend & "ctpsv" & Name_Append); procedure ZTPSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZTPSV, Name_Prepend & "ztpsv" & Name_Append); procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CTPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Double => ZTPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPSV; procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ) is begin if AP'Length /= X'Length * (1 + X'Length) / 2 then raise Argument_Error; end if; case Precision is when Single => CTPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Double => ZTPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPSV; ---------- -- TRMM -- ---------- procedure CTRMM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, CTRMM, Name_Prepend & "ctrmm" & Name_Append); procedure ZTRMM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, ZTRMM, Name_Prepend & "ztrmm" & Name_Append); procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or B'Length (1) < M or B'Length (2) < N then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) < M or A'Length (2) < M then raise Argument_Error; end if; when Right => if A'Length (1) < N or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CTRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => ZTRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMM; procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or A'Length (1) /= A'Length (2) then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) /= B'Length (1) then raise Argument_Error; end if; when Right => if A'Length (1) /= B'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => CTRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => ZTRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMM; ---------- -- TRMV -- ---------- procedure CTRMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CTRMV, Name_Prepend & "ctrmv" & Name_Append); procedure ZTRMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZTRMV, Name_Prepend & "ztrmv" & Name_Append); procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CTRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => ZTRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMV; procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or A'Length (1) /= X'Length then raise Argument_Error; end if; case Precision is when Single => CTRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => ZTRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMV; ---------- -- TRSM -- ---------- procedure CTRSM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, CTRSM, Name_Prepend & "ctrsm" & Name_Append); procedure ZTRSM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Complex_Type; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, ZTRSM, Name_Prepend & "ztrsm" & Name_Append); procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or B'Length (1) < M or B'Length (2) < N then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) < M or A'Length (2) < M then raise Argument_Error; end if; when Right => if A'Length (1) < N or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => CTRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => ZTRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSM; procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Complex_Type; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or A'Length (1) /= A'Length (2) then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) /= B'Length (1) then raise Argument_Error; end if; when Right => if A'Length (1) /= B'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => CTRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => ZTRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSM; ---------- -- TRSV -- ---------- procedure CTRSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, CTRSV, Name_Prepend & "ctrsv" & Name_Append); procedure ZTRSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, ZTRSV, Name_Prepend & "ztrsv" & Name_Append); procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => CTRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => ZTRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSV; procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or A'Length (1) /= X'Length then raise Argument_Error; end if; case Precision is when Single => CTRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => ZTRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSV; end Ada_BLAS.Complex; ------------------------------------------------------------------------------- -- Copyright (C) 2000 Centre National de la Recherche Scientifique (CNRS) -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- -- GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the Free Software -- -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- -- Author: Duncan Sands (Duncan.Sands@math.u-psud.fr) -- -- Departement de Mathematiques, Batiment 425, -- -- Universite de Paris-XI, Orsay, France. -- -- http://topo.math.u-psud.fr/~sands -- ------------------------------------------------------------------------------- package body Ada_BLAS.Real is ---------- -- AMAX -- ---------- function ISAMAX ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Fortran_Integer; pragma Import (Fortran, ISAMAX, Name_Prepend & "isamax" & Name_Append); function IDAMAX ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Fortran_Integer; pragma Import (Fortran, IDAMAX, Name_Prepend & "idamax" & Name_Append); function AMAX ( N : Natural; X : Vector_Type; INCX : Natural ) return Index_Type is begin if N = 0 then return X'First; elsif (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => return Index_Type'Val ( Index_Type'Pos (X'First) + INCX * ( Integer ( ISAMAX (Fortran_Integer (N), X, Fortran_Integer (INCX)) ) - 1 ) ); when Double => return Index_Type'Val ( Index_Type'Pos (X'First) + INCX * ( Integer ( IDAMAX (Fortran_Integer (N), X, Fortran_Integer (INCX)) ) - 1 ) ); when Unsupported => raise Unsupported_Precision_Error; end case; end AMAX; function AMAX (X : Vector_Type) return Index_Type is begin if X'Length = 0 then return X'First; end if; case Precision is when Single => return Index_Type'Val ( Index_Type'Pos (X'First) - 1 + Integer ( ISAMAX (X'Length, X, 1) ) ); when Double => return Index_Type'Val ( Index_Type'Pos (X'First) - 1 + Integer ( IDAMAX (X'Length, X, 1) ) ); when Unsupported => raise Unsupported_Precision_Error; end case; end AMAX; ---------- -- ASUM -- ---------- function SASUM ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, SASUM, Name_Prepend & "sasum" & Name_Append); function DASUM ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, DASUM, Name_Prepend & "dasum" & Name_Append); function ASUM ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base is begin if N > 0 and (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => return SASUM (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Double => return DASUM (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Unsupported => raise Unsupported_Precision_Error; end case; end ASUM; function ASUM (X : Vector_Type) return Float_Type'Base is begin case Precision is when Single => return SASUM (X'Length, X, 1); when Double => return DASUM (X'Length, X, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end ASUM; ---------- -- AXPY -- ---------- procedure SAXPY ( N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SAXPY, Name_Prepend & "saxpy" & Name_Append); procedure DAXPY ( N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DAXPY, Name_Prepend & "daxpy" & Name_Append); procedure AXPY ( N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => SAXPY ( Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => DAXPY ( Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end AXPY; procedure AXPY ( ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in out Vector_Type ) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SAXPY (X'Length, ALPHA, X, 1, Y, 1); when Double => DAXPY (X'Length, ALPHA, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end AXPY; ---------- -- COPY -- ---------- procedure SCOPY ( N : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SCOPY, Name_Prepend & "scopy" & Name_Append); procedure DCOPY ( N : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DCOPY, Name_Prepend & "dcopy" & Name_Append); procedure COPY ( N : in Natural; X : in Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => SCOPY ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => DCOPY ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end COPY; procedure COPY ( X : in Vector_Type; Y : in out Vector_Type ) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SCOPY (X'Length, X, 1, Y, 1); when Double => DCOPY (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end COPY; --------- -- DOT -- --------- function SDOT ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer; Y : Vector_Type; INCY : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, SDOT, Name_Prepend & "sdot" & Name_Append); function DDOT ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer; Y : Vector_Type; INCY : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, DDOT, Name_Prepend & "ddot" & Name_Append); function DOT ( N : Natural; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Float_Type'Base is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => return SDOT ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => return DDOT ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end DOT; function DOT (X, Y : Vector_Type) return Float_Type'Base is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => return SDOT (X'Length, X, 1, Y, 1); when Double => return DDOT (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end DOT; ----------- -- DSDOT -- ----------- function SDSDOT ( N : Fortran_Integer; ALPHA : Float_Type'Base; X : Vector_Type; INCX : Fortran_Integer; Y : Vector_Type; INCY : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, SDSDOT, Name_Prepend & "sdsdot" & Name_Append); function DSDOT ( N : Natural; ALPHA : Float_Type'Base; X : Vector_Type; INCX : Integer; Y : Vector_Type; INCY : Integer ) return Float_Type'Base is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => return SDSDOT ( Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => return ALPHA + DDOT ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end DSDOT; function DSDOT ( ALPHA : Float_Type'Base; X, Y : Vector_Type ) return Float_Type'Base is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => return SDSDOT (X'Length, ALPHA, X, 1, Y, 1); when Double => return ALPHA + DDOT (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end DSDOT; ---------- -- GBMV -- ---------- procedure SGBMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; KL : in Fortran_Integer; KU : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SGBMV, Name_Prepend & "sgbmv" & Name_Append); procedure DGBMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; KL : in Fortran_Integer; KU : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DGBMV, Name_Prepend & "dgbmv" & Name_Append); procedure GBMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; KL : in Natural; KU : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) <= KL + KU or A'Length (2) < N or INCX = 0 or INCY = 0 then raise Argument_Error; end if; case TRANS is when None => if (N - 1) * abs INCX >= X'Length or (M - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if (M - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; end case; case Precision is when Single => SGBMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => DGBMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GBMV; procedure GBMV ( TRANS : in Transpose_Type; KL : in Natural; KU : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ) is M : Fortran_Integer; begin if A'Length (1) /= KL + KU + 1 or KU >= A'Length (2) then raise Argument_Error; end if; case TRANS is when None => if X'Length /= A'Length (2) or KL >= Y'Length then raise Argument_Error; end if; M := Y'Length; when Transpose | Conjugate_Transpose => if Y'Length /= A'Length (2) or KL >= X'Length then raise Argument_Error; end if; M := X'Length; end case; case Precision is when Single => SGBMV ( TRANS => Fortran_TRANS (TRANS), M => M, N => A'Length (2), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => DGBMV ( TRANS => Fortran_TRANS (TRANS), M => M, N => A'Length (2), KL => Fortran_Integer (KL), KU => Fortran_Integer (KU), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end GBMV; ---------- -- GEMM -- ---------- procedure SGEMM ( TRANSA : in Character_Set; TRANSB : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, SGEMM, Name_Prepend & "sgemm" & Name_Append); procedure DGEMM ( TRANSA : in Character_Set; TRANSB : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, DGEMM, Name_Prepend & "dgemm" & Name_Append); procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; M : in Natural; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < M or C'Length (2) < N then raise Argument_Error; end if; case TRANSA is when None => if A'Length (1) < M or A'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < M then raise Argument_Error; end if; end case; case TRANSB is when None => if B'Length (1) < K or B'Length (2) < N then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if B'Length (1) < N or B'Length (2) < K then raise Argument_Error; end if; end case; case Precision is when Single => SGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => Fortran_Integer (M), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => Fortran_Integer (M), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMM; procedure GEMM ( TRANSA : in Transpose_Type; TRANSB : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 then raise Argument_Error; end if; case TRANSA is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case TRANSB is when None => if B'Length (1) /= K or B'Length (2) /= C'Length (2) then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if B'Length (2) /= K or B'Length (1) /= C'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => SGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => C'Length (1), N => C'Length (2), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DGEMM ( TRANSA => Fortran_TRANS (TRANSA), TRANSB => Fortran_TRANS (TRANSB), M => C'Length (1), N => C'Length (2), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMM; ---------- -- GEMV -- ---------- procedure SGEMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SGEMV, Name_Prepend & "sgemv" & Name_Append); procedure DGEMV ( TRANS : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DGEMV, Name_Prepend & "dgemv" & Name_Append); procedure GEMV ( TRANS : in Transpose_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < M or A'Length (2) < N or INCX = 0 or INCY = 0 then raise Argument_Error; end if; case TRANS is when None => if (N - 1) * abs INCX >= X'Length or (M - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if (M - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; end case; case Precision is when Single => SGEMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => DGEMV ( TRANS => Fortran_TRANS (TRANS), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMV; procedure GEMV ( TRANS : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ) is begin if A'Length (1) = 0 then raise Argument_Error; end if; case TRANS is when None => if X'Length /= A'Length (2) or Y'Length /= A'Length (1) then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if X'Length /= A'Length (1) or Y'Length /= A'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => SGEMV ( TRANS => Fortran_TRANS (TRANS), M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => DGEMV ( TRANS => Fortran_TRANS (TRANS), M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end GEMV; --------- -- GER -- --------- procedure SGER ( M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, SGER, Name_Prepend & "sger" & Name_Append); procedure DGER ( M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, DGER, Name_Prepend & "dger" & Name_Append); procedure GER ( M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) < M or A'Length (2) < N or INCX = 0 or INCY = 0 or (M - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => SGER ( M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Double => DGER ( M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GER; procedure GER ( ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or X'Length /= A'Length (1) or Y'Length /= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => SGER ( M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Double => DGER ( M => A'Length (1), N => A'Length (2), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end GER; ---------- -- NRM2 -- ---------- function SNRM2 ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, SNRM2, Name_Prepend & "snrm2" & Name_Append); function DNRM2 ( N : Fortran_Integer; X : Vector_Type; INCX : Fortran_Integer ) return Float_Type'Base; pragma Import (Fortran, DNRM2, Name_Prepend & "dnrm2" & Name_Append); function NRM2 ( N : Natural; X : Vector_Type; INCX : Natural ) return Float_Type'Base is begin if N > 0 and (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => return SNRM2 (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Double => return DNRM2 (Fortran_Integer (N), X, Fortran_Integer (INCX)); when Unsupported => raise Unsupported_Precision_Error; end case; end NRM2; function NRM2 (X : Vector_Type) return Float_Type'Base is begin case Precision is when Single => return SNRM2 (X'Length, X, 1); when Double => return DNRM2 (X'Length, X, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end NRM2; --------- -- ROT -- --------- procedure SROT ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer; C, S : in Float_Type'Base ); pragma Import (Fortran, SROT, Name_Prepend & "srot" & Name_Append); procedure DROT ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer; C, S : in Float_Type'Base ); pragma Import (Fortran, DROT, Name_Prepend & "drot" & Name_Append); procedure ROT ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer; C, S : in Float_Type'Base ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => SROT ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY), C, S ); when Double => DROT ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY), C, S ); when Unsupported => raise Unsupported_Precision_Error; end case; end ROT; procedure ROT ( X, Y : in out Vector_Type; C, S : in Float_Type'Base ) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SROT (X'Length, X, 1, Y, 1, C, S); when Double => DROT (X'Length, X, 1, Y, 1, C, S); when Unsupported => raise Unsupported_Precision_Error; end case; end ROT; ---------- -- ROTM -- ---------- procedure SROTM ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer; PARAM : in Modified_Givens ); pragma Import (Fortran, SROTM, Name_Prepend & "srotm" & Name_Append); procedure DROTM ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer; PARAM : in Modified_Givens ); pragma Import (Fortran, DROTM, Name_Prepend & "drotm" & Name_Append); procedure ROTM ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer; PARAM : in Modified_Givens ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => SROTM ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY), PARAM ); when Double => DROTM ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY), PARAM ); when Unsupported => raise Unsupported_Precision_Error; end case; end ROTM; procedure ROTM ( X, Y : in out Vector_Type; PARAM : in Modified_Givens ) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SROTM (X'Length, X, 1, Y, 1, PARAM); when Double => DROTM (X'Length, X, 1, Y, 1, PARAM); when Unsupported => raise Unsupported_Precision_Error; end case; end ROTM; ---------- -- ROTG -- ---------- procedure SROTG ( A, B : in out Float_Type'Base; C, S : out Float_Type'Base ); pragma Import (Fortran, SROTG, Name_Prepend & "srotg" & Name_Append); procedure DROTG ( A, B : in out Float_Type'Base; C, S : out Float_Type'Base ); pragma Import (Fortran, DROTG, Name_Prepend & "drotg" & Name_Append); procedure ROTG ( A, B : in out Float_Type'Base; C, S : out Float_Type'Base ) is begin case Precision is when Single => SROTG (A, B, C, S); when Double => DROTG (A, B, C, S); when Unsupported => raise Unsupported_Precision_Error; end case; end ROTG; ----------- -- ROTMG -- ----------- procedure SROTMG ( D1, D2 : in out Float_Type'Base; A : in out Float_Type'Base; B : in Float_Type'Base; PARAM : out Modified_Givens ); pragma Import (Fortran, SROTMG, Name_Prepend & "srotmg" & Name_Append); procedure DROTMG ( D1, D2 : in out Float_Type'Base; A : in out Float_Type'Base; B : in Float_Type'Base; PARAM : out Modified_Givens ); pragma Import (Fortran, DROTMG, Name_Prepend & "drotmg" & Name_Append); procedure ROTMG ( D1, D2 : in out Float_Type'Base; A : in out Float_Type'Base; B : in Float_Type'Base; PARAM : out Modified_Givens ) is begin case Precision is when Single => SROTMG (D1, D2, A, B, PARAM); when Double => DROTMG (D1, D2, A, B, PARAM); when Unsupported => raise Unsupported_Precision_Error; end case; end ROTMG; ---------- -- SBMV -- ---------- procedure SSBMV ( UPLO : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SSBMV, Name_Prepend & "ssbmv" & Name_Append); procedure DSBMV ( UPLO : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DSBMV, Name_Prepend & "dsbmv" & Name_Append); procedure SBMV ( UPLO : in Triangle_Type; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) <= K or A'Length (2) < N or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSBMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => DSBMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SBMV; procedure SBMV ( UPLO : in Triangle_Type; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ) is begin if A'Length (1) /= K + 1 or X'Length /= A'Length (2) or Y'Length /= A'Length (2) or K >= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => SSBMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (2), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => DSBMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (2), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end SBMV; ---------- -- SCAL -- ---------- procedure SSCAL ( N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, SSCAL, Name_Prepend & "sscal" & Name_Append); procedure DSCAL ( N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, DSCAL, Name_Prepend & "dscal" & Name_Append); procedure SCAL ( N : in Natural; ALPHA : in Float_Type'Base; X : in out Vector_Type; INCX : in Natural ) is begin if N > 0 and (N - 1) * INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => SSCAL (Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX)); when Double => DSCAL (Fortran_Integer (N), ALPHA, X, Fortran_Integer (INCX)); when Unsupported => raise Unsupported_Precision_Error; end case; end SCAL; procedure SCAL ( ALPHA : in Float_Type'Base; X : in out Vector_Type ) is begin case Precision is when Single => SSCAL (X'Length, ALPHA, X, 1); when Double => DSCAL (X'Length, ALPHA, X, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end SCAL; ---------- -- SPMV -- ---------- procedure SSPMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SSPMV, Name_Prepend & "sspmv" & Name_Append); procedure DSPMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DSPMV, Name_Prepend & "dspmv" & Name_Append); procedure SPMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSPMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, AP => AP, X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => DSPMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, AP => AP, X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SPMV; procedure SPMV ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; AP : in Vector_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ) is begin if AP'Length /= X'Length * (1 + X'Length) / 2 or X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSPMV ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, AP => AP, X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => DSPMV ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, AP => AP, X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end SPMV; --------- -- SPR -- --------- procedure SSPR ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, SSPR, Name_Prepend & "sspr" & Name_Append); procedure DSPR ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, DSPR, Name_Prepend & "dspr" & Name_Append); procedure SPR ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; AP : in out Vector_Type ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => SSPR ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), AP => AP ); when Double => DSPR ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end SPR; procedure SPR ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; AP : in out Vector_Type ) is begin if AP'Length /= X'Length * (X'Length + 1) / 2 then raise Argument_Error; end if; case Precision is when Single => SSPR ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, AP => AP ); when Double => DSPR ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end SPR; ---------- -- SPR2 -- ---------- procedure SSPR2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, SSPR2, Name_Prepend & "sspr2" & Name_Append); procedure DSPR2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; AP : in out Vector_Type ); pragma Import (Fortran, DSPR2, Name_Prepend & "dspr2" & Name_Append); procedure SPR2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; AP : in out Vector_Type ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSPR2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), AP => AP ); when Double => DSPR2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end SPR2; procedure SPR2 ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in Vector_Type; AP : in out Vector_Type ) is begin if AP'Length /= X'Length * (X'Length + 1) / 2 or X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSPR2 ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, AP => AP ); when Double => DSPR2 ( UPLO => Fortran_UPLO (UPLO), N => X'Length, ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, AP => AP ); when Unsupported => raise Unsupported_Precision_Error; end case; end SPR2; ---------- -- SWAP -- ---------- procedure SSWAP ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SSWAP, Name_Prepend & "sswap" & Name_Append); procedure DSWAP ( N : in Fortran_Integer; X : in out Vector_Type; INCX : in Fortran_Integer; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DSWAP, Name_Prepend & "dswap" & Name_Append); procedure SWAP ( N : in Natural; X : in out Vector_Type; INCX : in Integer; Y : in out Vector_Type; INCY : in Integer ) is begin if N > 0 and ( (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length ) then raise Argument_Error; end if; case Precision is when Single => SSWAP ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Double => DSWAP ( Fortran_Integer (N), X, Fortran_Integer (INCX), Y, Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SWAP; procedure SWAP (X, Y : in out Vector_Type) is begin if X'Length /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSWAP (X'Length, X, 1, Y, 1); when Double => DSWAP (X'Length, X, 1, Y, 1); when Unsupported => raise Unsupported_Precision_Error; end case; end SWAP; ---------- -- SYMM -- ---------- procedure SSYMM ( SIDE : in Character_Set; UPLO : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, SSYMM, Name_Prepend & "ssymm" & Name_Append); procedure DSYMM ( SIDE : in Character_Set; UPLO : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, DSYMM, Name_Prepend & "dsymm" & Name_Append); procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < M or C'Length (2) < N or B'Length (1) < M or B'Length (2) < N then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) < M or A'Length (2) < M then raise Argument_Error; end if; when Right => if A'Length (1) < N or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => SSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYMM; procedure SYMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or A'Length (1) /= A'Length (2) or B'Length (1) /= C'Length (1) or B'Length (2) /= C'Length (2) then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; when Right => if A'Length (1) /= C'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => SSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => C'Length (1), N => C'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DSYMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), M => C'Length (1), N => C'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYMM; ---------- -- SYMV -- ---------- procedure SSYMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, SSYMV, Name_Prepend & "ssymv" & Name_Append); procedure DSYMV ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Fortran_Integer ); pragma Import (Fortran, DSYMV, Name_Prepend & "dsymv" & Name_Append); procedure SYMV ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer; BETA : in Float_Type'Base; Y : in out Vector_Type; INCY : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSYMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Double => DSYMV ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX), BETA => BETA, Y => Y, INCY => Fortran_Integer (INCY) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYMV; procedure SYMV ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; X : in Vector_Type; BETA : in Float_Type'Base; Y : in out Vector_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or A'Length (1) /= X'Length or A'Length (1) /= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSYMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Double => DSYMV ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, A => A, LDA => A'Length (1), X => X, INCX => 1, BETA => BETA, Y => Y, INCY => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYMV; --------- -- SYR -- --------- procedure SSYR ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, SSYR, Name_Prepend & "ssyr" & Name_Append); procedure DSYR ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, DSYR, Name_Prepend & "dsyr" & Name_Append); procedure SYR ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => SSYR ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), A => A, LDA => A'Length (1) ); when Double => DSYR ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR; procedure SYR ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or X'Length /= A'Length (1) then raise Argument_Error; end if; case Precision is when Single => SSYR ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, A => A, LDA => A'Length (1) ); when Double => DSYR ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR; ---------- -- SYR2 -- ---------- procedure SSYR2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, SSYR2, Name_Prepend & "ssyr2" & Name_Append); procedure DSYR2 ( UPLO : in Character_Set; N : in Fortran_Integer; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Fortran_Integer; Y : in Vector_Type; INCY : in Fortran_Integer; A : in out Matrix_Type; LDA : in Fortran_Integer ); pragma Import (Fortran, DSYR2, Name_Prepend & "dsyr2" & Name_Append); procedure SYR2 ( UPLO : in Triangle_Type; N : in Natural; ALPHA : in Float_Type'Base; X : in Vector_Type; INCX : in Integer; Y : in Vector_Type; INCY : in Integer; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or INCY = 0 or (N - 1) * abs INCX >= X'Length or (N - 1) * abs INCY >= Y'Length then raise Argument_Error; end if; case Precision is when Single => SSYR2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Double => DSYR2 ( UPLO => Fortran_UPLO (UPLO), N => Fortran_Integer (N), ALPHA => ALPHA, X => X, INCX => Fortran_Integer (INCX), Y => Y, INCY => Fortran_Integer (INCY), A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR2; procedure SYR2 ( UPLO : in Triangle_Type; ALPHA : in Float_Type'Base; X : in Vector_Type; Y : in Vector_Type; A : in out Matrix_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or X'Length /= A'Length (1) or Y'Length /= A'Length (1) then raise Argument_Error; end if; case Precision is when Single => SSYR2 ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Double => DSYR2 ( UPLO => Fortran_UPLO (UPLO), N => A'Length (1), ALPHA => ALPHA, X => X, INCX => 1, Y => Y, INCY => 1, A => A, LDA => A'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR2; ---------- -- SYRK -- ---------- procedure SSYRK ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, SSYRK, Name_Prepend & "ssyrk" & Name_Append); procedure DSYRK ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, DSYRK, Name_Prepend & "dsyrk" & Name_Append); procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < N or C'Length (2) < N then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) < N or A'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => SSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYRK; procedure SYRK ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) /= C'Length (2) then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case Precision is when Single => SSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DSYRK ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYRK; ----------- -- SYR2K -- ----------- procedure SSYR2K ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, SSYR2K, Name_Prepend & "ssyr2k" & Name_Append); procedure DSYR2K ( UPLO : in Character_Set; TRANS : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer; BETA : in Float_Type'Base; C : in out Matrix_Type; LDC : in Fortran_Integer ); pragma Import (Fortran, DSYR2K, Name_Prepend & "dsyr2k" & Name_Append); procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; N : in Natural; K : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or C'Length (1) < N or C'Length (2) < N then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) < N or A'Length (2) < K or B'Length (1) < N or B'Length (2) < K then raise Argument_Error; end if; when Transpose | Conjugate_Transpose => if A'Length (1) < K or A'Length (2) < N or B'Length (1) < K or B'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => SSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => Fortran_Integer (N), K => Fortran_Integer (K), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR2K; procedure SYR2K ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type; BETA : in Float_Type'Base; C : in out Matrix_Type ) is K : Fortran_Integer; begin if A'Length (1) = 0 or B'Length (1) = 0 or C'Length (1) = 0 or A'Length (1) /= B'Length (1) or A'Length (2) /= B'Length (2) or C'Length (1) /= C'Length (2) then raise Argument_Error; end if; case TRANS is when None => if A'Length (1) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (2); when Transpose | Conjugate_Transpose => if A'Length (2) /= C'Length (1) then raise Argument_Error; end if; K := A'Length (1); end case; case Precision is when Single => SSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Double => DSYR2K ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), N => C'Length (1), K => K, ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1), BETA => BETA, C => C, LDC => C'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end SYR2K; ---------- -- TBMV -- ---------- procedure STBMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, STBMV, Name_Prepend & "stbmv" & Name_Append); procedure DTBMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, DTBMV, Name_Prepend & "dtbmv" & Name_Append); procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) <= K or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => STBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => DTBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBMV; procedure TBMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) /= K + 1 or X'Length /= A'Length (2) or K >= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => STBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => DTBMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBMV; ---------- -- TBSV -- ---------- procedure STBSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, STBSV, Name_Prepend & "stbsv" & Name_Append); procedure DTBSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; K : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, DTBSV, Name_Prepend & "dtbsv" & Name_Append); procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; K : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) <= K or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => STBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => DTBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBSV; procedure TBSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; K : in Natural; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) /= K + 1 or X'Length /= A'Length (2) or K >= A'Length (2) then raise Argument_Error; end if; case Precision is when Single => STBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => DTBSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (2), K => Fortran_Integer (K), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TBSV; ---------- -- TPMV -- ---------- procedure STPMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, STPMV, Name_Prepend & "stpmv" & Name_Append); procedure DTPMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, DTPMV, Name_Prepend & "dtpmv" & Name_Append); procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => STPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Double => DTPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPMV; procedure TPMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ) is begin if AP'Length /= X'Length * (1 + X'Length) / 2 then raise Argument_Error; end if; case Precision is when Single => STPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Double => DTPMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPMV; ---------- -- TPSV -- ---------- procedure STPSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, STPSV, Name_Prepend & "stpsv" & Name_Append); procedure DTPSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; AP : in Vector_Type; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, DTPSV, Name_Prepend & "dtpsv" & Name_Append); procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; AP : in Vector_Type; X : in Vector_Type; INCX : in Integer ) is begin if AP'Length < N * (N + 1) / 2 or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => STPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Double => DTPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), AP => AP, X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPSV; procedure TPSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; AP : in Vector_Type; X : in Vector_Type ) is begin if AP'Length /= X'Length * (1 + X'Length) / 2 then raise Argument_Error; end if; case Precision is when Single => STPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Double => DTPSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => X'Length, AP => AP, X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TPSV; ---------- -- TRMM -- ---------- procedure STRMM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, STRMM, Name_Prepend & "strmm" & Name_Append); procedure DTRMM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, DTRMM, Name_Prepend & "dtrmm" & Name_Append); procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or B'Length (1) < M or B'Length (2) < N then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) < M or A'Length (2) < M then raise Argument_Error; end if; when Right => if A'Length (1) < N or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => STRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => DTRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMM; procedure TRMM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or A'Length (1) /= A'Length (2) then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) /= B'Length (1) then raise Argument_Error; end if; when Right => if A'Length (1) /= B'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => STRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => DTRMM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMM; ---------- -- TRMV -- ---------- procedure STRMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, STRMV, Name_Prepend & "strmv" & Name_Append); procedure DTRMV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, DTRMV, Name_Prepend & "dtrmv" & Name_Append); procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => STRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => DTRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMV; procedure TRMV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or A'Length (1) /= X'Length then raise Argument_Error; end if; case Precision is when Single => STRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => DTRMV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRMV; ---------- -- TRSM -- ---------- procedure STRSM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, STRSM, Name_Prepend & "strsm" & Name_Append); procedure DTRSM ( SIDE : in Character_Set; UPLO : in Character_Set; TRANSA : in Character_Set; DIAG : in Character_Set; M : in Fortran_Integer; N : in Fortran_Integer; ALPHA : in Float_Type'Base; A : in Matrix_Type; LDA : in Fortran_Integer; B : in Matrix_Type; LDB : in Fortran_Integer ); pragma Import (Fortran, DTRSM, Name_Prepend & "dtrsm" & Name_Append); procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; M : in Natural; N : in Natural; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or B'Length (1) < M or B'Length (2) < N then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) < M or A'Length (2) < M then raise Argument_Error; end if; when Right => if A'Length (1) < N or A'Length (2) < N then raise Argument_Error; end if; end case; case Precision is when Single => STRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => DTRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => Fortran_Integer (M), N => Fortran_Integer (N), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSM; procedure TRSM ( SIDE : in Side_Type; UPLO : in Triangle_Type; TRANSA : in Transpose_Type; DIAG : in Diagonal_Type; ALPHA : in Float_Type'Base; A : in Matrix_Type; B : in Matrix_Type ) is begin if A'Length (1) = 0 or B'Length (1) = 0 or A'Length (1) /= A'Length (2) then raise Argument_Error; end if; case SIDE is when Left => if A'Length (1) /= B'Length (1) then raise Argument_Error; end if; when Right => if A'Length (1) /= B'Length (2) then raise Argument_Error; end if; end case; case Precision is when Single => STRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Double => DTRSM ( SIDE => Fortran_SIDE (SIDE), UPLO => Fortran_UPLO (UPLO), TRANSA => Fortran_TRANS (TRANSA), DIAG => Fortran_DIAG (DIAG), M => B'Length (1), N => B'Length (2), ALPHA => ALPHA, A => A, LDA => A'Length (1), B => B, LDB => B'Length (1) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSM; ---------- -- TRSV -- ---------- procedure STRSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, STRSV, Name_Prepend & "strsv" & Name_Append); procedure DTRSV ( UPLO : in Character_Set; TRANS : in Character_Set; DIAG : in Character_Set; N : in Fortran_Integer; A : in Matrix_Type; LDA : in Fortran_Integer; X : in Vector_Type; INCX : in Fortran_Integer ); pragma Import (Fortran, DTRSV, Name_Prepend & "dtrsv" & Name_Append); procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; N : in Natural; A : in Matrix_Type; X : in Vector_Type; INCX : in Integer ) is begin if A'Length (1) = 0 or A'Length (1) < N or A'Length (2) < N or INCX = 0 or (N - 1) * abs INCX >= X'Length then raise Argument_Error; end if; case Precision is when Single => STRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Double => DTRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => Fortran_Integer (N), A => A, LDA => A'Length (1), X => X, INCX => Fortran_Integer (INCX) ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSV; procedure TRSV ( UPLO : in Triangle_Type; TRANS : in Transpose_Type; DIAG : in Diagonal_Type; A : in Matrix_Type; X : in Vector_Type ) is begin if A'Length (1) = 0 or A'Length (1) /= A'Length (2) or A'Length (1) /= X'Length then raise Argument_Error; end if; case Precision is when Single => STRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Double => DTRSV ( UPLO => Fortran_UPLO (UPLO), TRANS => Fortran_TRANS (TRANS), DIAG => Fortran_DIAG (DIAG), N => A'Length (1), A => A, LDA => A'Length (1), X => X, INCX => 1 ); when Unsupported => raise Unsupported_Precision_Error; end case; end TRSV; end Ada_BLAS.Real; with Ada.Float_Text_IO; with Ada.Text_IO; with Example_Support; use Example_Support; procedure Example1 is A : Vector (1 .. 2) := (1.0, 1.0); B : Vector (1 .. 2) := (1.0, -1.0); D : Float := Real_BLAS.DOT (A, B); -- Does your compiler eliminate all overhead? begin Ada.Text_IO.Put ("Dot product is: "); Ada.Float_Text_IO.Put (D); Ada.Text_IO.New_Line; Ada.Text_IO.Flush; end Example1; ------------------------------------------------------------------------------- -- Copyright (C) 2000-2001 Centre National de la Recherche Scientifique -- -- -- -- This program is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- -- GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the Free Software -- -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- -- Author: Duncan Sands (Duncan.Sands@math.u-psud.fr) -- -- Departement de Mathematiques, Batiment 425, -- -- Universite de Paris-XI, Orsay, France. -- -- http://topo.math.u-psud.fr/~sands -- ------------------------------------------------------------------------------- -- Show the BLAS precisions corresponding to a sample of floating point types. with Ada.Text_IO; with Ada_BLAS.Get_Precision; with System; procedure Print_Precisions is package Precision_IO is new Ada.Text_IO.Enumeration_IO (Ada_BLAS.Precision_Type); generic type Float_Type is digits <>; procedure Print_Info; procedure Print_Info is package Fortran_Precision is new Ada_BLAS.Get_Precision (Float_Type); begin Ada.Text_IO.Put_Line ("Float_Type'Digits:" & Integer'Image (Float_Type'Digits)); Ada.Text_IO.Put_Line ("Float_Type'Base'Digits:" & Integer'Image (Float_Type'Base'Digits)); Ada.Text_IO.Put ("BLAS precision: "); Precision_IO.Put (Fortran_Precision.Precision); Ada.Text_IO.New_Line; end Print_Info; type Float_1 is digits 1; type Float_2 is digits System.Max_Digits / 4; type Float_3 is digits System.Max_Digits / 2; type Float_4 is digits 3 * System.Max_Digits / 4; type Float_5 is digits System.Max_Digits; procedure Print_1 is new Print_Info (Float_1); procedure Print_2 is new Print_Info (Float_2); procedure Print_3 is new Print_Info (Float_3); procedure Print_4 is new Print_Info (Float_4); procedure Print_5 is new Print_Info (Float_5); begin Ada.Text_IO.Put_Line ("-- Various BLAS precisions --"); Print_1; Ada.Text_IO.New_Line; Print_2; Ada.Text_IO.New_Line; Print_3; Ada.Text_IO.New_Line; Print_4; Ada.Text_IO.New_Line; Print_5; Ada.Text_IO.New_Line; end Print_Precisions;