diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/s-gerela.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/s-gerela.adb | 564 |
1 files changed, 0 insertions, 564 deletions
diff --git a/gcc-4.4.3/gcc/ada/s-gerela.adb b/gcc-4.4.3/gcc/ada/s-gerela.adb deleted file mode 100644 index 57d3640ad..000000000 --- a/gcc-4.4.3/gcc/ada/s-gerela.adb +++ /dev/null @@ -1,564 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.GENERIC_REAL_LAPACK -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -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; |