From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/s-gerela.adb | 564 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 564 insertions(+) create mode 100644 gcc/ada/s-gerela.adb (limited to 'gcc/ada/s-gerela.adb') diff --git a/gcc/ada/s-gerela.adb b/gcc/ada/s-gerela.adb new file mode 100644 index 000000000..57d3640ad --- /dev/null +++ b/gcc/ada/s-gerela.adb @@ -0,0 +1,564 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3