===================================================================
@@ -1,45 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-
-package Interfaces.Fortran.BLAS is
-
- pragma Unimplemented_Unit;
-
-end Interfaces.Fortran.BLAS;
===================================================================
@@ -1,493 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Conversion; use Ada;
-with Interfaces; use Interfaces;
-with Interfaces.Fortran; use Interfaces.Fortran;
-with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
-with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK;
-with System.Generic_Array_Operations; use System.Generic_Array_Operations;
-
-package body System.Generic_Complex_LAPACK is
-
- Is_Single : constant Boolean :=
- Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
- and then Fortran.Real (Real'First) = Fortran.Real'First
- and then Fortran.Real (Real'Last) = Fortran.Real'Last;
-
- Is_Double : constant Boolean :=
- Real'Machine_Mantissa = Double_Precision'Machine_Mantissa
- and then
- Double_Precision (Real'First) = Double_Precision'First
- and then
- Double_Precision (Real'Last) = Double_Precision'Last;
-
- subtype Complex is Complex_Types.Complex;
-
- -- Local subprograms
-
- function To_Double_Precision (X : Real) return Double_Precision;
- pragma Inline (To_Double_Precision);
-
- function To_Real (X : Double_Precision) return Real;
- pragma Inline (To_Real);
-
- function To_Double_Complex (X : Complex) return Double_Complex;
- pragma Inline (To_Double_Complex);
-
- function To_Complex (X : Double_Complex) return Complex;
- pragma Inline (To_Complex);
-
- -- Instantiations
-
- function To_Double_Precision is new
- Vector_Elementwise_Operation
- (X_Scalar => Real,
- Result_Scalar => Double_Precision,
- X_Vector => Real_Vector,
- Result_Vector => Double_Precision_Vector,
- Operation => To_Double_Precision);
-
- function To_Real is new
- Vector_Elementwise_Operation
- (X_Scalar => Double_Precision,
- Result_Scalar => Real,
- X_Vector => Double_Precision_Vector,
- Result_Vector => Real_Vector,
- Operation => To_Real);
-
- function To_Double_Complex is new
- Matrix_Elementwise_Operation
- (X_Scalar => Complex,
- Result_Scalar => Double_Complex,
- X_Matrix => Complex_Matrix,
- Result_Matrix => Double_Complex_Matrix,
- Operation => To_Double_Complex);
-
- function To_Complex is new
- Matrix_Elementwise_Operation
- (X_Scalar => Double_Complex,
- Result_Scalar => Complex,
- X_Matrix => Double_Complex_Matrix,
- Result_Matrix => Complex_Matrix,
- Operation => To_Complex);
-
- function To_Double_Precision (X : Real) return Double_Precision is
- begin
- return Double_Precision (X);
- end To_Double_Precision;
-
- function To_Real (X : Double_Precision) return Real is
- begin
- return Real (X);
- end To_Real;
-
- function To_Double_Complex (X : Complex) return Double_Complex is
- begin
- return (To_Double_Precision (X.Re), To_Double_Precision (X.Im));
- end To_Double_Complex;
-
- function To_Complex (X : Double_Complex) return Complex is
- begin
- return (Real (X.Re), Real (X.Im));
- end To_Complex;
-
- -----------
- -- getrf --
- -----------
-
- procedure getrf
- (M : Natural;
- N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer)
- is
- begin
- if Is_Single then
- declare
- type A_Ptr is
- access all BLAS.Complex_Matrix (A'Range (1), A'Range (2));
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- begin
- cgetrf (M, N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv), Info);
- end;
-
- elsif Is_Double then
- declare
- type A_Ptr is
- access all Double_Complex_Matrix (A'Range (1), A'Range (2));
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- begin
- zgetrf (M, N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv), Info);
- end;
-
- else
- declare
- DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
- begin
- DP_A := To_Double_Complex (A);
- zgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info);
- A := To_Complex (DP_A);
- end;
- end if;
- end getrf;
-
- -----------
- -- getri --
- -----------
-
- procedure getri
- (N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Complex_Vector;
- L_Work : Integer;
- Info : access Integer)
- is
- begin
- if Is_Single then
- declare
- type A_Ptr is
- access all BLAS.Complex_Matrix (A'Range (1), A'Range (2));
- type Work_Ptr is
- access all BLAS.Complex_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- cgetri (N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_Work (Work'Address).all, L_Work,
- Info);
- end;
-
- elsif Is_Double then
- declare
- type A_Ptr is
- access all Double_Complex_Matrix (A'Range (1), A'Range (2));
- type Work_Ptr is
- access all Double_Complex_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- zgetri (N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_Work (Work'Address).all, L_Work,
- Info);
- end;
-
- else
- declare
- DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
- DP_Work : Double_Complex_Vector (Work'Range);
- begin
- DP_A := To_Double_Complex (A);
- zgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv),
- DP_Work, L_Work, Info);
- A := To_Complex (DP_A);
- Work (1) := To_Complex (DP_Work (1));
- end;
- end if;
- end getri;
-
- -----------
- -- getrs --
- -----------
-
- procedure getrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Complex_Matrix;
- Ld_B : Positive;
- Info : access Integer)
- is
- begin
- if Is_Single then
- declare
- subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2));
- type B_Ptr is
- access all BLAS.Complex_Matrix (B'Range (1), B'Range (2));
- function Conv_A is
- new Unchecked_Conversion (Complex_Matrix, A_Type);
- function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
- begin
- cgetrs (Trans, N, N_Rhs,
- Conv_A (A), Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_B (B'Address).all, Ld_B,
- Info);
- end;
-
- elsif Is_Double then
- declare
- subtype A_Type is
- Double_Complex_Matrix (A'Range (1), A'Range (2));
- type B_Ptr is
- access all Double_Complex_Matrix (B'Range (1), B'Range (2));
- function Conv_A is
- new Unchecked_Conversion (Complex_Matrix, A_Type);
- function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
- begin
- zgetrs (Trans, N, N_Rhs,
- Conv_A (A), Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_B (B'Address).all, Ld_B,
- Info);
- end;
-
- else
- declare
- DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
- DP_B : Double_Complex_Matrix (B'Range (1), B'Range (2));
- begin
- DP_A := To_Double_Complex (A);
- DP_B := To_Double_Complex (B);
- zgetrs (Trans, N, N_Rhs,
- DP_A, Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- DP_B, Ld_B,
- Info);
- B := To_Complex (DP_B);
- end;
- end if;
- end getrs;
-
- procedure heevr
- (Job_Z : access constant Character;
- Rng : access constant Character;
- Uplo : access constant Character;
- N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- Vl, Vu : Real := 0.0;
- Il, Iu : Integer := 1;
- Abs_Tol : Real := 0.0;
- M : out Integer;
- W : out Real_Vector;
- Z : out Complex_Matrix;
- Ld_Z : Positive;
- I_Supp_Z : out Integer_Vector;
- Work : out Complex_Vector;
- L_Work : Integer;
- R_Work : out Real_Vector;
- LR_Work : Integer;
- I_Work : out Integer_Vector;
- LI_Work : Integer;
- Info : access Integer)
- is
- begin
- if Is_Single then
- declare
- type A_Ptr is
- access all BLAS.Complex_Matrix (A'Range (1), A'Range (2));
- type W_Ptr is
- access all BLAS.Real_Vector (W'Range);
- type Z_Ptr is
- access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2));
- type Work_Ptr is access all BLAS.Complex_Vector (Work'Range);
- type R_Work_Ptr is access all BLAS.Real_Vector (R_Work'Range);
-
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_W is new Unchecked_Conversion (Address, W_Ptr);
- function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- function Conv_R_Work is
- new Unchecked_Conversion (Address, R_Work_Ptr);
- begin
- cheevr (Job_Z, Rng, Uplo, N,
- Conv_A (A'Address).all, Ld_A,
- Fortran.Real (Vl), Fortran.Real (Vu),
- Il, Iu, Fortran.Real (Abs_Tol), M,
- Conv_W (W'Address).all,
- Conv_Z (Z'Address).all, Ld_Z,
- LAPACK.Integer_Vector (I_Supp_Z),
- Conv_Work (Work'Address).all, L_Work,
- Conv_R_Work (R_Work'Address).all, LR_Work,
- LAPACK.Integer_Vector (I_Work), LI_Work, Info);
- end;
-
- elsif Is_Double then
- declare
- type A_Ptr is
- access all BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2));
- type W_Ptr is
- access all BLAS.Double_Precision_Vector (W'Range);
- type Z_Ptr is
- access all BLAS.Double_Complex_Matrix (Z'Range (1), Z'Range (2));
- type Work_Ptr is
- access all BLAS.Double_Complex_Vector (Work'Range);
- type R_Work_Ptr is
- access all BLAS.Double_Precision_Vector (R_Work'Range);
-
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_W is new Unchecked_Conversion (Address, W_Ptr);
- function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- function Conv_R_Work is
- new Unchecked_Conversion (Address, R_Work_Ptr);
- begin
- zheevr (Job_Z, Rng, Uplo, N,
- Conv_A (A'Address).all, Ld_A,
- Double_Precision (Vl), Double_Precision (Vu),
- Il, Iu, Double_Precision (Abs_Tol), M,
- Conv_W (W'Address).all,
- Conv_Z (Z'Address).all, Ld_Z,
- LAPACK.Integer_Vector (I_Supp_Z),
- Conv_Work (Work'Address).all, L_Work,
- Conv_R_Work (R_Work'Address).all, LR_Work,
- LAPACK.Integer_Vector (I_Work), LI_Work, Info);
- end;
-
- else
- declare
- DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
- DP_W : Double_Precision_Vector (W'Range);
- DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2));
- DP_Work : Double_Complex_Vector (Work'Range);
- DP_R_Work : Double_Precision_Vector (R_Work'Range);
-
- begin
- DP_A := To_Double_Complex (A);
-
- zheevr (Job_Z, Rng, Uplo, N,
- DP_A, Ld_A,
- Double_Precision (Vl), Double_Precision (Vu),
- Il, Iu, Double_Precision (Abs_Tol), M,
- DP_W, DP_Z, Ld_Z,
- LAPACK.Integer_Vector (I_Supp_Z),
- DP_Work, L_Work,
- DP_R_Work, LR_Work,
- LAPACK.Integer_Vector (I_Work), LI_Work, Info);
-
- A := To_Complex (DP_A);
- W := To_Real (DP_W);
- Z := To_Complex (DP_Z);
-
- Work (1) := To_Complex (DP_Work (1));
- R_Work (1) := To_Real (DP_R_Work (1));
- end;
- end if;
- end heevr;
-
- -----------
- -- steqr --
- -----------
-
- procedure steqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Z : in out Complex_Matrix;
- Ld_Z : Positive;
- Work : out Real_Vector;
- Info : access Integer)
- is
- begin
- if Is_Single then
- declare
- type D_Ptr is access all BLAS.Real_Vector (D'Range);
- type E_Ptr is access all BLAS.Real_Vector (E'Range);
- type Z_Ptr is
- access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2));
- type Work_Ptr is
- access all BLAS.Real_Vector (Work'Range);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- csteqr (Comp_Z, N,
- Conv_D (D'Address).all,
- Conv_E (E'Address).all,
- Conv_Z (Z'Address).all,
- Ld_Z,
- Conv_Work (Work'Address).all,
- Info);
- end;
-
- elsif Is_Double then
- declare
- type D_Ptr is access all Double_Precision_Vector (D'Range);
- type E_Ptr is access all Double_Precision_Vector (E'Range);
- type Z_Ptr is
- access all Double_Complex_Matrix (Z'Range (1), Z'Range (2));
- type Work_Ptr is
- access all Double_Precision_Vector (Work'Range);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- zsteqr (Comp_Z, N,
- Conv_D (D'Address).all,
- Conv_E (E'Address).all,
- Conv_Z (Z'Address).all,
- Ld_Z,
- Conv_Work (Work'Address).all,
- Info);
- end;
-
- else
- declare
- DP_D : Double_Precision_Vector (D'Range);
- DP_E : Double_Precision_Vector (E'Range);
- DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2));
- DP_Work : Double_Precision_Vector (Work'Range);
- begin
- DP_D := To_Double_Precision (D);
- DP_E := To_Double_Precision (E);
-
- if Comp_Z.all = 'V' then
- DP_Z := To_Double_Complex (Z);
- end if;
-
- zsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info);
-
- D := To_Real (DP_D);
- E := To_Real (DP_E);
-
- if Comp_Z.all /= 'N' then
- Z := To_Complex (DP_Z);
- end if;
- end;
- end if;
- end steqr;
-
-end System.Generic_Complex_LAPACK;
===================================================================
@@ -1,131 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-with Ada.Numerics.Generic_Complex_Types;
-generic
- type Real is digits <>;
- type Real_Vector is array (Integer range <>) of Real;
-
- with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- type Complex_Vector is array (Integer range <>) of Complex;
- type Complex_Matrix is array (Integer range <>, Integer range <>)
- of Complex;
-package System.Generic_Complex_LAPACK is
- pragma Pure;
-
- type Integer_Vector is array (Integer range <>) of Integer;
-
- Upper : aliased constant Character := 'U';
- Lower : aliased constant Character := 'L';
-
- -- LAPACK Computational Routines
-
- -- getrf computes LU factorization of a general m-by-n matrix
-
- procedure getrf
- (M : Natural;
- N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer);
-
- -- getri computes inverse of an LU-factored square matrix,
- -- with multiple right-hand sides
-
- procedure getri
- (N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Complex_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- -- getrs solves a system of linear equations with an LU-factored
- -- square matrix, with multiple right-hand sides
-
- procedure getrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Complex_Matrix;
- Ld_B : Positive;
- Info : access Integer);
-
- -- heevr computes selected eigenvalues and, optionally,
- -- eigenvectors of a Hermitian matrix using the Relatively
- -- Robust Representations
-
- procedure heevr
- (Job_Z : access constant Character;
- Rng : access constant Character;
- Uplo : access constant Character;
- N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- Vl, Vu : Real := 0.0;
- Il, Iu : Integer := 1;
- Abs_Tol : Real := 0.0;
- M : out Integer;
- W : out Real_Vector;
- Z : out Complex_Matrix;
- Ld_Z : Positive;
- I_Supp_Z : out Integer_Vector;
- Work : out Complex_Vector;
- L_Work : Integer;
- R_Work : out Real_Vector;
- LR_Work : Integer;
- I_Work : out Integer_Vector;
- LI_Work : Integer;
- Info : access Integer);
-
- -- steqr computes all eigenvalues and eigenvectors of a symmetric or
- -- Hermitian matrix reduced to tridiagonal form (QR algorithm)
-
- procedure steqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Z : in out Complex_Matrix;
- Ld_Z : Positive;
- Work : out Real_Vector;
- Info : access Integer);
-
-end System.Generic_Complex_LAPACK;
===================================================================
@@ -1,311 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Conversion; use Ada;
-with Interfaces; use Interfaces;
-with Interfaces.Fortran; use Interfaces.Fortran;
-with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
-with System.Generic_Array_Operations; use System.Generic_Array_Operations;
-
-package body System.Generic_Real_BLAS is
-
- Is_Single : constant Boolean :=
- Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
- and then Fortran.Real (Real'First) = Fortran.Real'First
- and then Fortran.Real (Real'Last) = Fortran.Real'Last;
-
- Is_Double : constant Boolean :=
- Real'Machine_Mantissa = Double_Precision'Machine_Mantissa
- and then
- Double_Precision (Real'First) = Double_Precision'First
- and then
- Double_Precision (Real'Last) = Double_Precision'Last;
-
- -- Local subprograms
-
- function To_Double_Precision (X : Real) return Double_Precision;
- pragma Inline_Always (To_Double_Precision);
-
- function To_Real (X : Double_Precision) return Real;
- pragma Inline_Always (To_Real);
-
- -- Instantiations
-
- function To_Double_Precision is new
- Vector_Elementwise_Operation
- (X_Scalar => Real,
- Result_Scalar => Double_Precision,
- X_Vector => Real_Vector,
- Result_Vector => Double_Precision_Vector,
- Operation => To_Double_Precision);
-
- function To_Real is new
- Vector_Elementwise_Operation
- (X_Scalar => Double_Precision,
- Result_Scalar => Real,
- X_Vector => Double_Precision_Vector,
- Result_Vector => Real_Vector,
- Operation => To_Real);
-
- function To_Double_Precision is new
- Matrix_Elementwise_Operation
- (X_Scalar => Real,
- Result_Scalar => Double_Precision,
- X_Matrix => Real_Matrix,
- Result_Matrix => Double_Precision_Matrix,
- Operation => To_Double_Precision);
-
- function To_Real is new
- Matrix_Elementwise_Operation
- (X_Scalar => Double_Precision,
- Result_Scalar => Real,
- X_Matrix => Double_Precision_Matrix,
- Result_Matrix => Real_Matrix,
- Operation => To_Real);
-
- function To_Double_Precision (X : Real) return Double_Precision is
- begin
- return Double_Precision (X);
- end To_Double_Precision;
-
- function To_Real (X : Double_Precision) return Real is
- begin
- return Real (X);
- end To_Real;
-
- ---------
- -- dot --
- ---------
-
- function dot
- (N : Positive;
- X : Real_Vector;
- Inc_X : Integer := 1;
- Y : Real_Vector;
- Inc_Y : Integer := 1) return Real
- is
- begin
- if Is_Single then
- declare
- type X_Ptr is access all BLAS.Real_Vector (X'Range);
- type Y_Ptr is access all BLAS.Real_Vector (Y'Range);
- function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
- function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
- begin
- return Real (sdot (N, Conv_X (X'Address).all, Inc_X,
- Conv_Y (Y'Address).all, Inc_Y));
- end;
-
- elsif Is_Double then
- declare
- type X_Ptr is access all BLAS.Double_Precision_Vector (X'Range);
- type Y_Ptr is access all BLAS.Double_Precision_Vector (Y'Range);
- function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
- function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
- begin
- return Real (ddot (N, Conv_X (X'Address).all, Inc_X,
- Conv_Y (Y'Address).all, Inc_Y));
- end;
-
- else
- return Real (ddot (N, To_Double_Precision (X), Inc_X,
- To_Double_Precision (Y), Inc_Y));
- end if;
- end dot;
-
- ----------
- -- gemm --
- ----------
-
- procedure gemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Real := 1.0;
- A : Real_Matrix;
- Ld_A : Integer;
- B : Real_Matrix;
- Ld_B : Integer;
- Beta : Real := 0.0;
- C : in out Real_Matrix;
- Ld_C : Integer)
- is
- begin
- if Is_Single then
- declare
- subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2));
- subtype B_Type is BLAS.Real_Matrix (B'Range (1), B'Range (2));
- type C_Ptr is
- access all BLAS.Real_Matrix (C'Range (1), C'Range (2));
- function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
- function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type);
- function Conv_C is new Unchecked_Conversion (Address, C_Ptr);
- begin
- sgemm (Trans_A, Trans_B, M, N, K, Fortran.Real (Alpha),
- Conv_A (A), Ld_A, Conv_B (B), Ld_B, Fortran.Real (Beta),
- Conv_C (C'Address).all, Ld_C);
- end;
-
- elsif Is_Double then
- declare
- subtype A_Type is
- Double_Precision_Matrix (A'Range (1), A'Range (2));
- subtype B_Type is
- Double_Precision_Matrix (B'Range (1), B'Range (2));
- type C_Ptr is
- access all Double_Precision_Matrix (C'Range (1), C'Range (2));
- function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
- function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type);
- function Conv_C is new Unchecked_Conversion (Address, C_Ptr);
- begin
- dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha),
- Conv_A (A), Ld_A, Conv_B (B), Ld_B, Double_Precision (Beta),
- Conv_C (C'Address).all, Ld_C);
- end;
-
- else
- declare
- DP_C : Double_Precision_Matrix (C'Range (1), C'Range (2));
- begin
- if Beta /= 0.0 then
- DP_C := To_Double_Precision (C);
- end if;
-
- dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha),
- To_Double_Precision (A), Ld_A,
- To_Double_Precision (B), Ld_B, Double_Precision (Beta),
- DP_C, Ld_C);
-
- C := To_Real (DP_C);
- end;
- end if;
- end gemm;
-
- ----------
- -- gemv --
- ----------
-
- procedure gemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Real := 1.0;
- A : Real_Matrix;
- Ld_A : Positive;
- X : Real_Vector;
- Inc_X : Integer := 1;
- Beta : Real := 0.0;
- Y : in out Real_Vector;
- Inc_Y : Integer := 1)
- is
- begin
- if Is_Single then
- declare
- subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2));
- subtype X_Type is BLAS.Real_Vector (X'Range);
- type Y_Ptr is access all BLAS.Real_Vector (Y'Range);
- function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
- function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
- function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
- begin
- sgemv (Trans, M, N, Fortran.Real (Alpha),
- Conv_A (A), Ld_A, Conv_X (X), Inc_X, Fortran.Real (Beta),
- Conv_Y (Y'Address).all, Inc_Y);
- end;
-
- elsif Is_Double then
- declare
- subtype A_Type is
- Double_Precision_Matrix (A'Range (1), A'Range (2));
- subtype X_Type is Double_Precision_Vector (X'Range);
- type Y_Ptr is access all Double_Precision_Vector (Y'Range);
- function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
- function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
- function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
- begin
- dgemv (Trans, M, N, Double_Precision (Alpha),
- Conv_A (A), Ld_A, Conv_X (X), Inc_X,
- Double_Precision (Beta),
- Conv_Y (Y'Address).all, Inc_Y);
- end;
-
- else
- declare
- DP_Y : Double_Precision_Vector (Y'Range);
- begin
- if Beta /= 0.0 then
- DP_Y := To_Double_Precision (Y);
- end if;
-
- dgemv (Trans, M, N, Double_Precision (Alpha),
- To_Double_Precision (A), Ld_A,
- To_Double_Precision (X), Inc_X, Double_Precision (Beta),
- DP_Y, Inc_Y);
-
- Y := To_Real (DP_Y);
- end;
- end if;
- end gemv;
-
- ----------
- -- nrm2 --
- ----------
-
- function nrm2
- (N : Natural;
- X : Real_Vector;
- Inc_X : Integer := 1) return Real
- is
- begin
- if Is_Single then
- declare
- subtype X_Type is BLAS.Real_Vector (X'Range);
- function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
- begin
- return Real (snrm2 (N, Conv_X (X), Inc_X));
- end;
-
- elsif Is_Double then
- declare
- subtype X_Type is Double_Precision_Vector (X'Range);
- function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
- begin
- return Real (dnrm2 (N, Conv_X (X), Inc_X));
- end;
-
- else
- return Real (dnrm2 (N, To_Double_Precision (X), Inc_X));
- end if;
- end nrm2;
-
-end System.Generic_Real_BLAS;
===================================================================
@@ -1,96 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-generic
- type Real is digits <>;
- type Real_Vector is array (Integer range <>) of Real;
- type Real_Matrix is array (Integer range <>, Integer range <>) of Real;
-package System.Generic_Real_BLAS is
- pragma Pure;
-
- -- Although BLAS support is only available for IEEE single and double
- -- compatible floating-point types, this unit will accept any type
- -- and apply conversions as necessary, with possible loss of
- -- precision and range.
-
- No_Trans : aliased constant Character := 'N';
- Trans : aliased constant Character := 'T';
- Conj_Trans : aliased constant Character := 'C';
-
- -- BLAS Level 1 Subprograms and Types
-
- function dot
- (N : Positive;
- X : Real_Vector;
- Inc_X : Integer := 1;
- Y : Real_Vector;
- Inc_Y : Integer := 1) return Real;
-
- function nrm2
- (N : Natural;
- X : Real_Vector;
- Inc_X : Integer := 1) return Real;
-
- procedure gemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Real := 1.0;
- A : Real_Matrix;
- Ld_A : Positive;
- X : Real_Vector;
- Inc_X : Integer := 1; -- must be non-zero
- Beta : Real := 0.0;
- Y : in out Real_Vector;
- Inc_Y : Integer := 1); -- must be non-zero
-
- -- BLAS Level 3
-
- -- gemm s, d, c, z Matrix-matrix product of general matrices
-
- procedure gemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Real := 1.0;
- A : Real_Matrix;
- Ld_A : Integer;
- B : Real_Matrix;
- Ld_B : Integer;
- Beta : Real := 0.0;
- C : in out Real_Matrix;
- Ld_C : Integer);
-
-end System.Generic_Real_BLAS;
===================================================================
@@ -1,42 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-package body Interfaces.Fortran.BLAS is
- pragma Linker_Options ("-lgnala");
- pragma Linker_Options ("-llapack");
- pragma Linker_Options ("-lblas");
- pragma Linker_Options ("-lm");
-end Interfaces.Fortran.BLAS;
===================================================================
@@ -1,261 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-
-package Interfaces.Fortran.BLAS is
- pragma Pure;
- pragma Elaborate_Body;
-
- No_Trans : aliased constant Character := 'N';
- Trans : aliased constant Character := 'T';
- Conj_Trans : aliased constant Character := 'C';
-
- -- Vector types
-
- type Real_Vector is array (Integer range <>) of Real;
-
- type Complex_Vector is array (Integer range <>) of Complex;
-
- type Double_Precision_Vector is array (Integer range <>)
- of Double_Precision;
-
- type Double_Complex_Vector is array (Integer range <>) of Double_Complex;
-
- -- Matrix types
-
- type Real_Matrix is array (Integer range <>, Integer range <>)
- of Real;
-
- type Double_Precision_Matrix is array (Integer range <>, Integer range <>)
- of Double_Precision;
-
- type Complex_Matrix is array (Integer range <>, Integer range <>)
- of Complex;
-
- type Double_Complex_Matrix is array (Integer range <>, Integer range <>)
- of Double_Complex;
-
- -- BLAS Level 1
-
- function sdot
- (N : Positive;
- X : Real_Vector;
- Inc_X : Integer := 1;
- Y : Real_Vector;
- Inc_Y : Integer := 1) return Real;
-
- function ddot
- (N : Positive;
- X : Double_Precision_Vector;
- Inc_X : Integer := 1;
- Y : Double_Precision_Vector;
- Inc_Y : Integer := 1) return Double_Precision;
-
- function cdotu
- (N : Positive;
- X : Complex_Vector;
- Inc_X : Integer := 1;
- Y : Complex_Vector;
- Inc_Y : Integer := 1) return Complex;
-
- function zdotu
- (N : Positive;
- X : Double_Complex_Vector;
- Inc_X : Integer := 1;
- Y : Double_Complex_Vector;
- Inc_Y : Integer := 1) return Double_Complex;
-
- function snrm2
- (N : Natural;
- X : Real_Vector;
- Inc_X : Integer := 1) return Real;
-
- function dnrm2
- (N : Natural;
- X : Double_Precision_Vector;
- Inc_X : Integer := 1) return Double_Precision;
-
- function scnrm2
- (N : Natural;
- X : Complex_Vector;
- Inc_X : Integer := 1) return Real;
-
- function dznrm2
- (N : Natural;
- X : Double_Complex_Vector;
- Inc_X : Integer := 1) return Double_Precision;
-
- -- BLAS Level 2
-
- procedure sgemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Real := 1.0;
- A : Real_Matrix;
- Ld_A : Positive;
- X : Real_Vector;
- Inc_X : Integer := 1; -- must be non-zero
- Beta : Real := 0.0;
- Y : in out Real_Vector;
- Inc_Y : Integer := 1); -- must be non-zero
-
- procedure dgemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Double_Precision := 1.0;
- A : Double_Precision_Matrix;
- Ld_A : Positive;
- X : Double_Precision_Vector;
- Inc_X : Integer := 1; -- must be non-zero
- Beta : Double_Precision := 0.0;
- Y : in out Double_Precision_Vector;
- Inc_Y : Integer := 1); -- must be non-zero
-
- procedure cgemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Complex := (1.0, 1.0);
- A : Complex_Matrix;
- Ld_A : Positive;
- X : Complex_Vector;
- Inc_X : Integer := 1; -- must be non-zero
- Beta : Complex := (0.0, 0.0);
- Y : in out Complex_Vector;
- Inc_Y : Integer := 1); -- must be non-zero
-
- procedure zgemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Double_Complex := (1.0, 1.0);
- A : Double_Complex_Matrix;
- Ld_A : Positive;
- X : Double_Complex_Vector;
- Inc_X : Integer := 1; -- must be non-zero
- Beta : Double_Complex := (0.0, 0.0);
- Y : in out Double_Complex_Vector;
- Inc_Y : Integer := 1); -- must be non-zero
-
- -- BLAS Level 3
-
- procedure sgemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Real := 1.0;
- A : Real_Matrix;
- Ld_A : Integer;
- B : Real_Matrix;
- Ld_B : Integer;
- Beta : Real := 0.0;
- C : in out Real_Matrix;
- Ld_C : Integer);
-
- procedure dgemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Double_Precision := 1.0;
- A : Double_Precision_Matrix;
- Ld_A : Integer;
- B : Double_Precision_Matrix;
- Ld_B : Integer;
- Beta : Double_Precision := 0.0;
- C : in out Double_Precision_Matrix;
- Ld_C : Integer);
-
- procedure cgemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Complex := (1.0, 1.0);
- A : Complex_Matrix;
- Ld_A : Integer;
- B : Complex_Matrix;
- Ld_B : Integer;
- Beta : Complex := (0.0, 0.0);
- C : in out Complex_Matrix;
- Ld_C : Integer);
-
- procedure zgemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Double_Complex := (1.0, 1.0);
- A : Double_Complex_Matrix;
- Ld_A : Integer;
- B : Double_Complex_Matrix;
- Ld_B : Integer;
- Beta : Double_Complex := (0.0, 0.0);
- C : in out Double_Complex_Matrix;
- Ld_C : Integer);
-
-private
- pragma Import (Fortran, cdotu, "cdotu_");
- pragma Import (Fortran, cgemm, "cgemm_");
- pragma Import (Fortran, cgemv, "cgemv_");
- pragma Import (Fortran, ddot, "ddot_");
- pragma Import (Fortran, dgemm, "dgemm_");
- pragma Import (Fortran, dgemv, "dgemv_");
- pragma Import (Fortran, dnrm2, "dnrm2_");
- pragma Import (Fortran, dznrm2, "dznrm2_");
- pragma Import (Fortran, scnrm2, "scnrm2_");
- pragma Import (Fortran, sdot, "sdot_");
- pragma Import (Fortran, sgemm, "sgemm_");
- pragma Import (Fortran, sgemv, "sgemv_");
- pragma Import (Fortran, snrm2, "snrm2_");
- pragma Import (Fortran, zdotu, "zdotu_");
- pragma Import (Fortran, zgemm, "zgemm_");
- pragma Import (Fortran, zgemv, "zgemv_");
-end Interfaces.Fortran.BLAS;
===================================================================
@@ -1,414 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-with Interfaces.Fortran.BLAS;
-package Interfaces.Fortran.LAPACK is
- pragma Pure;
-
- type Integer_Vector is array (Integer range <>) of Integer;
-
- Upper : aliased constant Character := 'U';
- Lower : aliased constant Character := 'L';
-
- subtype Real_Vector is BLAS.Real_Vector;
- subtype Real_Matrix is BLAS.Real_Matrix;
- subtype Double_Precision_Vector is BLAS.Double_Precision_Vector;
- subtype Double_Precision_Matrix is BLAS.Double_Precision_Matrix;
- subtype Complex_Vector is BLAS.Complex_Vector;
- subtype Complex_Matrix is BLAS.Complex_Matrix;
- subtype Double_Complex_Vector is BLAS.Double_Complex_Vector;
- subtype Double_Complex_Matrix is BLAS.Double_Complex_Matrix;
-
- -- LAPACK Computational Routines
-
- -- gerfs Refines the solution of a system of linear equations with
- -- a general matrix and estimates its error
- -- getrf Computes LU factorization of a general m-by-n matrix
- -- getri Computes inverse of an LU-factored general matrix
- -- square matrix, with multiple right-hand sides
- -- getrs Solves a system of linear equations with an LU-factored
- -- square matrix, with multiple right-hand sides
- -- hetrd Reduces a complex Hermitian matrix to tridiagonal form
- -- heevr Computes selected eigenvalues and, optionally, eigenvectors of
- -- a Hermitian matrix using the Relatively Robust Representations
- -- orgtr Generates the real orthogonal matrix Q determined by sytrd
- -- steqr Computes all eigenvalues and eigenvectors of a symmetric or
- -- Hermitian matrix reduced to tridiagonal form (QR algorithm)
- -- sterf Computes all eigenvalues of a real symmetric
- -- tridiagonal matrix using QR algorithm
- -- sytrd Reduces a real symmetric matrix to tridiagonal form
-
- procedure sgetrf
- (M : Natural;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer);
-
- procedure dgetrf
- (M : Natural;
- N : Natural;
- A : in out Double_Precision_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer);
-
- procedure cgetrf
- (M : Natural;
- N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer);
-
- procedure zgetrf
- (M : Natural;
- N : Natural;
- A : in out Double_Complex_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer);
-
- procedure sgetri
- (N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Real_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure dgetri
- (N : Natural;
- A : in out Double_Precision_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Double_Precision_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure cgetri
- (N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Complex_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure zgetri
- (N : Natural;
- A : in out Double_Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Double_Complex_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure sgetrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Real_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Real_Matrix;
- Ld_B : Positive;
- Info : access Integer);
-
- procedure dgetrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Double_Precision_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Double_Precision_Matrix;
- Ld_B : Positive;
- Info : access Integer);
-
- procedure cgetrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Complex_Matrix;
- Ld_B : Positive;
- Info : access Integer);
-
- procedure zgetrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Double_Complex_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Double_Complex_Matrix;
- Ld_B : Positive;
- Info : access Integer);
-
- procedure cheevr
- (Job_Z : access constant Character;
- Rng : access constant Character;
- Uplo : access constant Character;
- N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- Vl, Vu : Real := 0.0;
- Il, Iu : Integer := 1;
- Abs_Tol : Real := 0.0;
- M : out Integer;
- W : out Real_Vector;
- Z : out Complex_Matrix;
- Ld_Z : Positive;
- I_Supp_Z : out Integer_Vector;
- Work : out Complex_Vector;
- L_Work : Integer;
- R_Work : out Real_Vector;
- LR_Work : Integer;
- I_Work : out Integer_Vector;
- LI_Work : Integer;
- Info : access Integer);
-
- procedure zheevr
- (Job_Z : access constant Character;
- Rng : access constant Character;
- Uplo : access constant Character;
- N : Natural;
- A : in out Double_Complex_Matrix;
- Ld_A : Positive;
- Vl, Vu : Double_Precision := 0.0;
- Il, Iu : Integer := 1;
- Abs_Tol : Double_Precision := 0.0;
- M : out Integer;
- W : out Double_Precision_Vector;
- Z : out Double_Complex_Matrix;
- Ld_Z : Positive;
- I_Supp_Z : out Integer_Vector;
- Work : out Double_Complex_Vector;
- L_Work : Integer;
- R_Work : out Double_Precision_Vector;
- LR_Work : Integer;
- I_Work : out Integer_Vector;
- LI_Work : Integer;
- Info : access Integer);
-
- procedure chetrd
- (Uplo : access constant Character;
- N : Natural;
- A : in out Complex_Matrix;
- Ld_A : Positive;
- D : out Real_Vector;
- E : out Real_Vector;
- Tau : out Complex_Vector;
- Work : out Complex_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure zhetrd
- (Uplo : access constant Character;
- N : Natural;
- A : in out Double_Complex_Matrix;
- Ld_A : Positive;
- D : out Double_Precision_Vector;
- E : out Double_Precision_Vector;
- Tau : out Double_Complex_Vector;
- Work : out Double_Complex_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure ssytrd
- (Uplo : access constant Character;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- D : out Real_Vector;
- E : out Real_Vector;
- Tau : out Real_Vector;
- Work : out Real_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure dsytrd
- (Uplo : access constant Character;
- N : Natural;
- A : in out Double_Precision_Matrix;
- Ld_A : Positive;
- D : out Double_Precision_Vector;
- E : out Double_Precision_Vector;
- Tau : out Double_Precision_Vector;
- Work : out Double_Precision_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure ssterf
- (N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Info : access Integer);
-
- procedure dsterf
- (N : Natural;
- D : in out Double_Precision_Vector;
- E : in out Double_Precision_Vector;
- Info : access Integer);
-
- procedure sorgtr
- (Uplo : access constant Character;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- Tau : Real_Vector;
- Work : out Real_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure dorgtr
- (Uplo : access constant Character;
- N : Natural;
- A : in out Double_Precision_Matrix;
- Ld_A : Positive;
- Tau : Double_Precision_Vector;
- Work : out Double_Precision_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure sstebz
- (Rng : access constant Character;
- Order : access constant Character;
- N : Natural;
- Vl, Vu : Real := 0.0;
- Il, Iu : Integer := 1;
- Abs_Tol : Real := 0.0;
- D : Real_Vector;
- E : Real_Vector;
- M : out Natural;
- N_Split : out Natural;
- W : out Real_Vector;
- I_Block : out Integer_Vector;
- I_Split : out Integer_Vector;
- Work : out Real_Vector;
- I_Work : out Integer_Vector;
- Info : access Integer);
-
- procedure dstebz
- (Rng : access constant Character;
- Order : access constant Character;
- N : Natural;
- Vl, Vu : Double_Precision := 0.0;
- Il, Iu : Integer := 1;
- Abs_Tol : Double_Precision := 0.0;
- D : Double_Precision_Vector;
- E : Double_Precision_Vector;
- M : out Natural;
- N_Split : out Natural;
- W : out Double_Precision_Vector;
- I_Block : out Integer_Vector;
- I_Split : out Integer_Vector;
- Work : out Double_Precision_Vector;
- I_Work : out Integer_Vector;
- Info : access Integer);
-
- procedure ssteqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Z : in out Real_Matrix;
- Ld_Z : Positive;
- Work : out Real_Vector;
- Info : access Integer);
-
- procedure dsteqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Double_Precision_Vector;
- E : in out Double_Precision_Vector;
- Z : in out Double_Precision_Matrix;
- Ld_Z : Positive;
- Work : out Double_Precision_Vector;
- Info : access Integer);
-
- procedure csteqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Z : in out Complex_Matrix;
- Ld_Z : Positive;
- Work : out Real_Vector;
- Info : access Integer);
-
- procedure zsteqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Double_Precision_Vector;
- E : in out Double_Precision_Vector;
- Z : in out Double_Complex_Matrix;
- Ld_Z : Positive;
- Work : out Double_Precision_Vector;
- Info : access Integer);
-
-private
- pragma Import (Fortran, csteqr, "csteqr_");
- pragma Import (Fortran, cgetrf, "cgetrf_");
- pragma Import (Fortran, cgetri, "cgetri_");
- pragma Import (Fortran, cgetrs, "cgetrs_");
- pragma Import (Fortran, cheevr, "cheevr_");
- pragma Import (Fortran, chetrd, "chetrd_");
- pragma Import (Fortran, dgetrf, "dgetrf_");
- pragma Import (Fortran, dgetri, "dgetri_");
- pragma Import (Fortran, dgetrs, "dgetrs_");
- pragma Import (Fortran, dsytrd, "dsytrd_");
- pragma Import (Fortran, dstebz, "dstebz_");
- pragma Import (Fortran, dsterf, "dsterf_");
- pragma Import (Fortran, dorgtr, "dorgtr_");
- pragma Import (Fortran, dsteqr, "dsteqr_");
- pragma Import (Fortran, sgetrf, "sgetrf_");
- pragma Import (Fortran, sgetri, "sgetri_");
- pragma Import (Fortran, sgetrs, "sgetrs_");
- pragma Import (Fortran, sorgtr, "sorgtr_");
- pragma Import (Fortran, sstebz, "sstebz_");
- pragma Import (Fortran, ssterf, "ssterf_");
- pragma Import (Fortran, ssteqr, "ssteqr_");
- pragma Import (Fortran, ssytrd, "ssytrd_");
- pragma Import (Fortran, zgetrf, "zgetrf_");
- pragma Import (Fortran, zgetri, "zgetri_");
- pragma Import (Fortran, zgetrs, "zgetrs_");
- pragma Import (Fortran, zheevr, "zheevr_");
- pragma Import (Fortran, zhetrd, "zhetrd_");
- pragma Import (Fortran, zsteqr, "zsteqr_");
-end Interfaces.Fortran.LAPACK;
===================================================================
@@ -1,38 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-package body Interfaces.Fortran.BLAS is
- pragma Linker_Options ("-lgnala");
- pragma Linker_Options ("-lm");
- pragma Linker_Options ("-Wl,-framework,vecLib");
-end Interfaces.Fortran.BLAS;
===================================================================
@@ -1,350 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Conversion; use Ada;
-with Interfaces; use Interfaces;
-with Interfaces.Fortran; use Interfaces.Fortran;
-with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
-with System.Generic_Array_Operations; use System.Generic_Array_Operations;
-
-package body System.Generic_Complex_BLAS is
-
- Is_Single : constant Boolean :=
- Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
- and then Fortran.Real (Real'First) = Fortran.Real'First
- and then Fortran.Real (Real'Last) = Fortran.Real'Last;
-
- Is_Double : constant Boolean :=
- Real'Machine_Mantissa = Double_Precision'Machine_Mantissa
- and then
- Double_Precision (Real'First) = Double_Precision'First
- and then
- Double_Precision (Real'Last) = Double_Precision'Last;
-
- subtype Complex is Complex_Types.Complex;
-
- -- Local subprograms
-
- function To_Double_Precision (X : Real) return Double_Precision;
- pragma Inline (To_Double_Precision);
-
- function To_Double_Complex (X : Complex) return Double_Complex;
- pragma Inline (To_Double_Complex);
-
- function To_Complex (X : Double_Complex) return Complex;
- function To_Complex (X : Fortran.Complex) return Complex;
- pragma Inline (To_Complex);
-
- function To_Fortran (X : Complex) return Fortran.Complex;
- pragma Inline (To_Fortran);
-
- -- Instantiations
-
- function To_Double_Complex is new
- Vector_Elementwise_Operation
- (X_Scalar => Complex_Types.Complex,
- Result_Scalar => Fortran.Double_Complex,
- X_Vector => Complex_Vector,
- Result_Vector => BLAS.Double_Complex_Vector,
- Operation => To_Double_Complex);
-
- function To_Complex is new
- Vector_Elementwise_Operation
- (X_Scalar => Fortran.Double_Complex,
- Result_Scalar => Complex,
- X_Vector => BLAS.Double_Complex_Vector,
- Result_Vector => Complex_Vector,
- Operation => To_Complex);
-
- function To_Double_Complex is new
- Matrix_Elementwise_Operation
- (X_Scalar => Complex,
- Result_Scalar => Double_Complex,
- X_Matrix => Complex_Matrix,
- Result_Matrix => BLAS.Double_Complex_Matrix,
- Operation => To_Double_Complex);
-
- function To_Complex is new
- Matrix_Elementwise_Operation
- (X_Scalar => Double_Complex,
- Result_Scalar => Complex,
- X_Matrix => BLAS.Double_Complex_Matrix,
- Result_Matrix => Complex_Matrix,
- Operation => To_Complex);
-
- function To_Double_Precision (X : Real) return Double_Precision is
- begin
- return Double_Precision (X);
- end To_Double_Precision;
-
- function To_Double_Complex (X : Complex) return Double_Complex is
- begin
- return (To_Double_Precision (X.Re), To_Double_Precision (X.Im));
- end To_Double_Complex;
-
- function To_Complex (X : Double_Complex) return Complex is
- begin
- return (Real (X.Re), Real (X.Im));
- end To_Complex;
-
- function To_Complex (X : Fortran.Complex) return Complex is
- begin
- return (Real (X.Re), Real (X.Im));
- end To_Complex;
-
- function To_Fortran (X : Complex) return Fortran.Complex is
- begin
- return (Fortran.Real (X.Re), Fortran.Real (X.Im));
- end To_Fortran;
-
- ---------
- -- dot --
- ---------
-
- function dot
- (N : Positive;
- X : Complex_Vector;
- Inc_X : Integer := 1;
- Y : Complex_Vector;
- Inc_Y : Integer := 1) return Complex
- is
- begin
- if Is_Single then
- declare
- type X_Ptr is access all BLAS.Complex_Vector (X'Range);
- type Y_Ptr is access all BLAS.Complex_Vector (Y'Range);
- function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
- function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
- begin
- return To_Complex (BLAS.cdotu (N, Conv_X (X'Address).all, Inc_X,
- Conv_Y (Y'Address).all, Inc_Y));
- end;
-
- elsif Is_Double then
- declare
- type X_Ptr is access all BLAS.Double_Complex_Vector (X'Range);
- type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range);
- function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
- function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
- begin
- return To_Complex (BLAS.zdotu (N, Conv_X (X'Address).all, Inc_X,
- Conv_Y (Y'Address).all, Inc_Y));
- end;
-
- else
- return To_Complex (BLAS.zdotu (N, To_Double_Complex (X), Inc_X,
- To_Double_Complex (Y), Inc_Y));
- end if;
- end dot;
-
- ----------
- -- gemm --
- ----------
-
- procedure gemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Complex := (1.0, 0.0);
- A : Complex_Matrix;
- Ld_A : Integer;
- B : Complex_Matrix;
- Ld_B : Integer;
- Beta : Complex := (0.0, 0.0);
- C : in out Complex_Matrix;
- Ld_C : Integer)
- is
- begin
- if Is_Single then
- declare
- subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2));
- subtype B_Type is BLAS.Complex_Matrix (B'Range (1), B'Range (2));
- type C_Ptr is
- access all BLAS.Complex_Matrix (C'Range (1), C'Range (2));
- function Conv_A is
- new Unchecked_Conversion (Complex_Matrix, A_Type);
- function Conv_B is
- new Unchecked_Conversion (Complex_Matrix, B_Type);
- function Conv_C is
- new Unchecked_Conversion (Address, C_Ptr);
- begin
- BLAS.cgemm (Trans_A, Trans_B, M, N, K, To_Fortran (Alpha),
- Conv_A (A), Ld_A, Conv_B (B), Ld_B, To_Fortran (Beta),
- Conv_C (C'Address).all, Ld_C);
- end;
-
- elsif Is_Double then
- declare
- subtype A_Type is
- BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2));
- subtype B_Type is
- BLAS.Double_Complex_Matrix (B'Range (1), B'Range (2));
- type C_Ptr is access all
- BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2));
- function Conv_A is
- new Unchecked_Conversion (Complex_Matrix, A_Type);
- function Conv_B is
- new Unchecked_Conversion (Complex_Matrix, B_Type);
- function Conv_C is new Unchecked_Conversion (Address, C_Ptr);
- begin
- BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha),
- Conv_A (A), Ld_A, Conv_B (B), Ld_B,
- To_Double_Complex (Beta),
- Conv_C (C'Address).all, Ld_C);
- end;
-
- else
- declare
- DP_C : BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2));
- begin
- if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then
- DP_C := To_Double_Complex (C);
- end if;
-
- BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha),
- To_Double_Complex (A), Ld_A,
- To_Double_Complex (B), Ld_B, To_Double_Complex (Beta),
- DP_C, Ld_C);
-
- C := To_Complex (DP_C);
- end;
- end if;
- end gemm;
-
- ----------
- -- gemv --
- ----------
-
- procedure gemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Complex := (1.0, 0.0);
- A : Complex_Matrix;
- Ld_A : Positive;
- X : Complex_Vector;
- Inc_X : Integer := 1;
- Beta : Complex := (0.0, 0.0);
- Y : in out Complex_Vector;
- Inc_Y : Integer := 1)
- is
- begin
- if Is_Single then
- declare
- subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2));
- subtype X_Type is BLAS.Complex_Vector (X'Range);
- type Y_Ptr is access all BLAS.Complex_Vector (Y'Range);
- function Conv_A is
- new Unchecked_Conversion (Complex_Matrix, A_Type);
- function Conv_X is
- new Unchecked_Conversion (Complex_Vector, X_Type);
- function Conv_Y is
- new Unchecked_Conversion (Address, Y_Ptr);
- begin
- BLAS.cgemv (Trans, M, N, To_Fortran (Alpha),
- Conv_A (A), Ld_A, Conv_X (X), Inc_X, To_Fortran (Beta),
- Conv_Y (Y'Address).all, Inc_Y);
- end;
-
- elsif Is_Double then
- declare
- subtype A_Type is
- BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2));
- subtype X_Type is
- BLAS.Double_Complex_Vector (X'Range);
- type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range);
- function Conv_A is
- new Unchecked_Conversion (Complex_Matrix, A_Type);
- function Conv_X is
- new Unchecked_Conversion (Complex_Vector, X_Type);
- function Conv_Y is
- new Unchecked_Conversion (Address, Y_Ptr);
- begin
- BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha),
- Conv_A (A), Ld_A, Conv_X (X), Inc_X,
- To_Double_Complex (Beta),
- Conv_Y (Y'Address).all, Inc_Y);
- end;
-
- else
- declare
- DP_Y : BLAS.Double_Complex_Vector (Y'Range);
- begin
- if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then
- DP_Y := To_Double_Complex (Y);
- end if;
-
- BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha),
- To_Double_Complex (A), Ld_A,
- To_Double_Complex (X), Inc_X, To_Double_Complex (Beta),
- DP_Y, Inc_Y);
-
- Y := To_Complex (DP_Y);
- end;
- end if;
- end gemv;
-
- ----------
- -- nrm2 --
- ----------
-
- function nrm2
- (N : Natural;
- X : Complex_Vector;
- Inc_X : Integer := 1) return Real
- is
- begin
- if Is_Single then
- declare
- subtype X_Type is BLAS.Complex_Vector (X'Range);
- function Conv_X is
- new Unchecked_Conversion (Complex_Vector, X_Type);
- begin
- return Real (BLAS.scnrm2 (N, Conv_X (X), Inc_X));
- end;
-
- elsif Is_Double then
- declare
- subtype X_Type is BLAS.Double_Complex_Vector (X'Range);
- function Conv_X is
- new Unchecked_Conversion (Complex_Vector, X_Type);
- begin
- return Real (BLAS.dznrm2 (N, Conv_X (X), Inc_X));
- end;
-
- else
- return Real (BLAS.dznrm2 (N, To_Double_Complex (X), Inc_X));
- end if;
- end nrm2;
-
-end System.Generic_Complex_BLAS;
===================================================================
@@ -1,102 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-with Ada.Numerics.Generic_Complex_Types;
-
-generic
- type Real is digits <>;
- with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- type Complex_Vector is array (Integer range <>) of Complex;
- type Complex_Matrix is array (Integer range <>, Integer range <>)
- of Complex;
-package System.Generic_Complex_BLAS is
- pragma Pure;
-
- -- Although BLAS support is only available for IEEE single and double
- -- compatible floating-point types, this unit will accept any type
- -- and apply conversions as necessary, with possible loss of
- -- precision and range.
-
- No_Trans : aliased constant Character := 'N';
- Trans : aliased constant Character := 'T';
- Conj_Trans : aliased constant Character := 'C';
-
- -- BLAS Level 1 Subprograms and Types
-
- function dot
- (N : Positive;
- X : Complex_Vector;
- Inc_X : Integer := 1;
- Y : Complex_Vector;
- Inc_Y : Integer := 1) return Complex;
-
- function nrm2
- (N : Natural;
- X : Complex_Vector;
- Inc_X : Integer := 1) return Real;
-
- procedure gemv
- (Trans : access constant Character;
- M : Natural := 0;
- N : Natural := 0;
- Alpha : Complex := (1.0, 0.0);
- A : Complex_Matrix;
- Ld_A : Positive;
- X : Complex_Vector;
- Inc_X : Integer := 1; -- must be non-zero
- Beta : Complex := (0.0, 0.0);
- Y : in out Complex_Vector;
- Inc_Y : Integer := 1); -- must be non-zero
-
- -- BLAS Level 3
-
- -- gemm s, d, c, z Matrix-matrix product of general matrices
-
- procedure gemm
- (Trans_A : access constant Character;
- Trans_B : access constant Character;
- M : Positive;
- N : Positive;
- K : Positive;
- Alpha : Complex := (1.0, 0.0);
- A : Complex_Matrix;
- Ld_A : Integer;
- B : Complex_Matrix;
- Ld_B : Integer;
- Beta : Complex := (0.0, 0.0);
- C : in out Complex_Matrix;
- Ld_C : Integer);
-
-end System.Generic_Complex_BLAS;
===================================================================
@@ -1,564 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Conversion; use Ada;
-with Interfaces; use Interfaces;
-with Interfaces.Fortran; use Interfaces.Fortran;
-with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
-with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK;
-with System.Generic_Array_Operations; use System.Generic_Array_Operations;
-
-package body System.Generic_Real_LAPACK is
-
- Is_Real : constant Boolean :=
- Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
- and then Fortran.Real (Real'First) = Fortran.Real'First
- and then Fortran.Real (Real'Last) = Fortran.Real'Last;
-
- Is_Double_Precision : constant Boolean :=
- Real'Machine_Mantissa =
- Double_Precision'Machine_Mantissa
- and then
- Double_Precision (Real'First) =
- Double_Precision'First
- and then
- Double_Precision (Real'Last) =
- Double_Precision'Last;
-
- -- Local subprograms
-
- function To_Double_Precision (X : Real) return Double_Precision;
- pragma Inline_Always (To_Double_Precision);
-
- function To_Real (X : Double_Precision) return Real;
- pragma Inline_Always (To_Real);
-
- -- Instantiations
-
- function To_Double_Precision is new
- Vector_Elementwise_Operation
- (X_Scalar => Real,
- Result_Scalar => Double_Precision,
- X_Vector => Real_Vector,
- Result_Vector => Double_Precision_Vector,
- Operation => To_Double_Precision);
-
- function To_Real is new
- Vector_Elementwise_Operation
- (X_Scalar => Double_Precision,
- Result_Scalar => Real,
- X_Vector => Double_Precision_Vector,
- Result_Vector => Real_Vector,
- Operation => To_Real);
-
- function To_Double_Precision is new
- Matrix_Elementwise_Operation
- (X_Scalar => Real,
- Result_Scalar => Double_Precision,
- X_Matrix => Real_Matrix,
- Result_Matrix => Double_Precision_Matrix,
- Operation => To_Double_Precision);
-
- function To_Real is new
- Matrix_Elementwise_Operation
- (X_Scalar => Double_Precision,
- Result_Scalar => Real,
- X_Matrix => Double_Precision_Matrix,
- Result_Matrix => Real_Matrix,
- Operation => To_Real);
-
- function To_Double_Precision (X : Real) return Double_Precision is
- begin
- return Double_Precision (X);
- end To_Double_Precision;
-
- function To_Real (X : Double_Precision) return Real is
- begin
- return Real (X);
- end To_Real;
-
- -----------
- -- getrf --
- -----------
-
- procedure getrf
- (M : Natural;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer)
- is
- begin
- if Is_Real then
- declare
- type A_Ptr is
- access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- begin
- sgetrf (M, N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv), Info);
- end;
-
- elsif Is_Double_Precision then
- declare
- type A_Ptr is
- access all Double_Precision_Matrix (A'Range (1), A'Range (2));
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- begin
- dgetrf (M, N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv), Info);
- end;
-
- else
- declare
- DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
- begin
- DP_A := To_Double_Precision (A);
- dgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info);
- A := To_Real (DP_A);
- end;
- end if;
- end getrf;
-
- -----------
- -- getri --
- -----------
-
- procedure getri
- (N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Real_Vector;
- L_Work : Integer;
- Info : access Integer)
- is
- begin
- if Is_Real then
- declare
- type A_Ptr is
- access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
- type Work_Ptr is
- access all BLAS.Real_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- sgetri (N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_Work (Work'Address).all, L_Work,
- Info);
- end;
-
- elsif Is_Double_Precision then
- declare
- type A_Ptr is
- access all Double_Precision_Matrix (A'Range (1), A'Range (2));
- type Work_Ptr is
- access all Double_Precision_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- dgetri (N, Conv_A (A'Address).all, Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_Work (Work'Address).all, L_Work,
- Info);
- end;
-
- else
- declare
- DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
- DP_Work : Double_Precision_Vector (Work'Range);
- begin
- DP_A := To_Double_Precision (A);
- dgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv),
- DP_Work, L_Work, Info);
- A := To_Real (DP_A);
- Work (1) := To_Real (DP_Work (1));
- end;
- end if;
- end getri;
-
- -----------
- -- getrs --
- -----------
-
- procedure getrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Real_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Real_Matrix;
- Ld_B : Positive;
- Info : access Integer)
- is
- begin
- if Is_Real then
- declare
- subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2));
- type B_Ptr is
- access all BLAS.Real_Matrix (B'Range (1), B'Range (2));
- function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
- function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
- begin
- sgetrs (Trans, N, N_Rhs,
- Conv_A (A), Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_B (B'Address).all, Ld_B,
- Info);
- end;
-
- elsif Is_Double_Precision then
- declare
- subtype A_Type is
- Double_Precision_Matrix (A'Range (1), A'Range (2));
- type B_Ptr is
- access all Double_Precision_Matrix (B'Range (1), B'Range (2));
- function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
- function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
- begin
- dgetrs (Trans, N, N_Rhs,
- Conv_A (A), Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- Conv_B (B'Address).all, Ld_B,
- Info);
- end;
-
- else
- declare
- DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
- DP_B : Double_Precision_Matrix (B'Range (1), B'Range (2));
- begin
- DP_A := To_Double_Precision (A);
- DP_B := To_Double_Precision (B);
- dgetrs (Trans, N, N_Rhs,
- DP_A, Ld_A,
- LAPACK.Integer_Vector (I_Piv),
- DP_B, Ld_B,
- Info);
- B := To_Real (DP_B);
- end;
- end if;
- end getrs;
-
- -----------
- -- orgtr --
- -----------
-
- procedure orgtr
- (Uplo : access constant Character;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- Tau : Real_Vector;
- Work : out Real_Vector;
- L_Work : Integer;
- Info : access Integer)
- is
- begin
- if Is_Real then
- declare
- type A_Ptr is
- access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
- subtype Tau_Type is BLAS.Real_Vector (Tau'Range);
- type Work_Ptr is
- access all BLAS.Real_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_Tau is
- new Unchecked_Conversion (Real_Vector, Tau_Type);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- sorgtr (Uplo, N,
- Conv_A (A'Address).all, Ld_A,
- Conv_Tau (Tau),
- Conv_Work (Work'Address).all, L_Work,
- Info);
- end;
-
- elsif Is_Double_Precision then
- declare
- type A_Ptr is
- access all Double_Precision_Matrix (A'Range (1), A'Range (2));
- subtype Tau_Type is Double_Precision_Vector (Tau'Range);
- type Work_Ptr is
- access all Double_Precision_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_Tau is
- new Unchecked_Conversion (Real_Vector, Tau_Type);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- dorgtr (Uplo, N,
- Conv_A (A'Address).all, Ld_A,
- Conv_Tau (Tau),
- Conv_Work (Work'Address).all, L_Work,
- Info);
- end;
-
- else
- declare
- DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
- DP_Work : Double_Precision_Vector (Work'Range);
- DP_Tau : Double_Precision_Vector (Tau'Range);
- begin
- DP_A := To_Double_Precision (A);
- DP_Tau := To_Double_Precision (Tau);
- dorgtr (Uplo, N, DP_A, Ld_A, DP_Tau, DP_Work, L_Work, Info);
- A := To_Real (DP_A);
- Work (1) := To_Real (DP_Work (1));
- end;
- end if;
- end orgtr;
-
- -----------
- -- steqr --
- -----------
-
- procedure steqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Z : in out Real_Matrix;
- Ld_Z : Positive;
- Work : out Real_Vector;
- Info : access Integer)
- is
- begin
- if Is_Real then
- declare
- type D_Ptr is access all BLAS.Real_Vector (D'Range);
- type E_Ptr is access all BLAS.Real_Vector (E'Range);
- type Z_Ptr is
- access all BLAS.Real_Matrix (Z'Range (1), Z'Range (2));
- type Work_Ptr is
- access all BLAS.Real_Vector (Work'Range);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- ssteqr (Comp_Z, N,
- Conv_D (D'Address).all,
- Conv_E (E'Address).all,
- Conv_Z (Z'Address).all,
- Ld_Z,
- Conv_Work (Work'Address).all,
- Info);
- end;
-
- elsif Is_Double_Precision then
- declare
- type D_Ptr is access all Double_Precision_Vector (D'Range);
- type E_Ptr is access all Double_Precision_Vector (E'Range);
- type Z_Ptr is
- access all Double_Precision_Matrix (Z'Range (1), Z'Range (2));
- type Work_Ptr is
- access all Double_Precision_Vector (Work'Range);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- dsteqr (Comp_Z, N,
- Conv_D (D'Address).all,
- Conv_E (E'Address).all,
- Conv_Z (Z'Address).all,
- Ld_Z,
- Conv_Work (Work'Address).all,
- Info);
- end;
-
- else
- declare
- DP_D : Double_Precision_Vector (D'Range);
- DP_E : Double_Precision_Vector (E'Range);
- DP_Z : Double_Precision_Matrix (Z'Range (1), Z'Range (2));
- DP_Work : Double_Precision_Vector (Work'Range);
- begin
- DP_D := To_Double_Precision (D);
- DP_E := To_Double_Precision (E);
-
- if Comp_Z.all = 'V' then
- DP_Z := To_Double_Precision (Z);
- end if;
-
- dsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info);
-
- D := To_Real (DP_D);
- E := To_Real (DP_E);
- Z := To_Real (DP_Z);
- end;
- end if;
- end steqr;
-
- -----------
- -- sterf --
- -----------
-
- procedure sterf
- (N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Info : access Integer)
- is
- begin
- if Is_Real then
- declare
- type D_Ptr is access all BLAS.Real_Vector (D'Range);
- type E_Ptr is access all BLAS.Real_Vector (E'Range);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- begin
- ssterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info);
- end;
-
- elsif Is_Double_Precision then
- declare
- type D_Ptr is access all Double_Precision_Vector (D'Range);
- type E_Ptr is access all Double_Precision_Vector (E'Range);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- begin
- dsterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info);
- end;
-
- else
- declare
- DP_D : Double_Precision_Vector (D'Range);
- DP_E : Double_Precision_Vector (E'Range);
-
- begin
- DP_D := To_Double_Precision (D);
- DP_E := To_Double_Precision (E);
-
- dsterf (N, DP_D, DP_E, Info);
-
- D := To_Real (DP_D);
- E := To_Real (DP_E);
- end;
- end if;
- end sterf;
-
- -----------
- -- sytrd --
- -----------
-
- procedure sytrd
- (Uplo : access constant Character;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- D : out Real_Vector;
- E : out Real_Vector;
- Tau : out Real_Vector;
- Work : out Real_Vector;
- L_Work : Integer;
- Info : access Integer)
- is
- begin
- if Is_Real then
- declare
- type A_Ptr is
- access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
- type D_Ptr is access all BLAS.Real_Vector (D'Range);
- type E_Ptr is access all BLAS.Real_Vector (E'Range);
- type Tau_Ptr is access all BLAS.Real_Vector (Tau'Range);
- type Work_Ptr is
- access all BLAS.Real_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- ssytrd (Uplo, N,
- Conv_A (A'Address).all, Ld_A,
- Conv_D (D'Address).all,
- Conv_E (E'Address).all,
- Conv_Tau (Tau'Address).all,
- Conv_Work (Work'Address).all,
- L_Work,
- Info);
- end;
-
- elsif Is_Double_Precision then
- declare
- type A_Ptr is
- access all Double_Precision_Matrix (A'Range (1), A'Range (2));
- type D_Ptr is access all Double_Precision_Vector (D'Range);
- type E_Ptr is access all Double_Precision_Vector (E'Range);
- type Tau_Ptr is access all Double_Precision_Vector (Tau'Range);
- type Work_Ptr is
- access all Double_Precision_Vector (Work'Range);
- function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
- function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
- function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
- function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr);
- function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
- begin
- dsytrd (Uplo, N,
- Conv_A (A'Address).all, Ld_A,
- Conv_D (D'Address).all,
- Conv_E (E'Address).all,
- Conv_Tau (Tau'Address).all,
- Conv_Work (Work'Address).all,
- L_Work,
- Info);
- end;
-
- else
- declare
- DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
- DP_D : Double_Precision_Vector (D'Range);
- DP_E : Double_Precision_Vector (E'Range);
- DP_Tau : Double_Precision_Vector (Tau'Range);
- DP_Work : Double_Precision_Vector (Work'Range);
- begin
- DP_A := To_Double_Precision (A);
-
- dsytrd (Uplo, N, DP_A, Ld_A, DP_D, DP_E, DP_Tau,
- DP_Work, L_Work, Info);
-
- if L_Work /= -1 then
- A := To_Real (DP_A);
- D := To_Real (DP_D);
- E := To_Real (DP_E);
- Tau := To_Real (DP_Tau);
- end if;
-
- Work (1) := To_Real (DP_Work (1));
- end;
- end if;
- end sytrd;
-
-end System.Generic_Real_LAPACK;
===================================================================
@@ -1,128 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-generic
- type Real is digits <>;
- type Real_Vector is array (Integer range <>) of Real;
- type Real_Matrix is array (Integer range <>, Integer range <>) of Real;
-package System.Generic_Real_LAPACK is
- pragma Pure;
-
- type Integer_Vector is array (Integer range <>) of Integer;
-
- Upper : aliased constant Character := 'U';
- Lower : aliased constant Character := 'L';
-
- -- LAPACK Computational Routines
-
- -- gerfs Refines the solution of a system of linear equations with
- -- a general matrix and estimates its error
- -- getrf Computes LU factorization of a general m-by-n matrix
- -- getri Computes inverse of an LU-factored general matrix
- -- square matrix, with multiple right-hand sides
- -- getrs Solves a system of linear equations with an LU-factored
- -- square matrix, with multiple right-hand sides
- -- orgtr Generates the Float orthogonal matrix Q determined by sytrd
- -- steqr Computes all eigenvalues and eigenvectors of a symmetric or
- -- Hermitian matrix reduced to tridiagonal form (QR algorithm)
- -- sterf Computes all eigenvalues of a Float symmetric
- -- tridiagonal matrix using QR algorithm
- -- sytrd Reduces a Float symmetric matrix to tridiagonal form
-
- procedure getrf
- (M : Natural;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- I_Piv : out Integer_Vector;
- Info : access Integer);
-
- procedure getri
- (N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- Work : in out Real_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure getrs
- (Trans : access constant Character;
- N : Natural;
- N_Rhs : Natural;
- A : Real_Matrix;
- Ld_A : Positive;
- I_Piv : Integer_Vector;
- B : in out Real_Matrix;
- Ld_B : Positive;
- Info : access Integer);
-
- procedure orgtr
- (Uplo : access constant Character;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- Tau : Real_Vector;
- Work : out Real_Vector;
- L_Work : Integer;
- Info : access Integer);
-
- procedure sterf
- (N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Info : access Integer);
-
- procedure steqr
- (Comp_Z : access constant Character;
- N : Natural;
- D : in out Real_Vector;
- E : in out Real_Vector;
- Z : in out Real_Matrix;
- Ld_Z : Positive;
- Work : out Real_Vector;
- Info : access Integer);
-
- procedure sytrd
- (Uplo : access constant Character;
- N : Natural;
- A : in out Real_Matrix;
- Ld_A : Positive;
- D : out Real_Vector;
- E : out Real_Vector;
- Tau : out Real_Vector;
- Work : out Real_Vector;
- L_Work : Integer;
- Info : access Integer);
-
-end System.Generic_Real_LAPACK;
===================================================================
@@ -2116,7 +2116,6 @@
SO_OPTS = -shared-libgcc
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-darwin.ads \
- i-forbla.adb<i-forbla-darwin.adb \
s-inmaop.adb<s-inmaop-posix.adb \
s-osinte.adb<s-osinte-darwin.adb \
s-osinte.ads<s-osinte-darwin.ads \
@@ -2238,10 +2237,8 @@
include $(fsrcdir)/ada/Makefile.rtl
-GNATRTL_LINEARALGEBRA_OBJS = i-forbla.o i-forlap.o
-
GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \
- $(GNATRTL_LINEARALGEBRA_OBJS) memtrack.o
+ memtrack.o
# Default run time files
@@ -2538,9 +2535,6 @@
$(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnarl$(arext) \
$(addprefix $(RTSDIR)/,$(GNATRTL_TASKING_OBJS))
$(RANLIB_FOR_TARGET) $(RTSDIR)/libgnarl$(arext)
- $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnala$(arext) \
- $(addprefix $(RTSDIR)/,$(GNATRTL_LINEARALGEBRA_OBJS))
- $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnala$(arext)
ifeq ($(GMEM_LIB),gmemlib)
$(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgmem$(arext) \
$(RTSDIR)/memtrack.o