From patchwork Fri Nov 4 10:56:32 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 123609 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 049AFB6F8C for ; Fri, 4 Nov 2011 21:57:30 +1100 (EST) Received: (qmail 16436 invoked by alias); 4 Nov 2011 10:57:28 -0000 Received: (qmail 16409 invoked by uid 22791); 4 Nov 2011 10:57:14 -0000 X-SWARE-Spam-Status: No, hits=-0.2 required=5.0 tests=AWL, BAYES_00, KAM_VIAGRA1, TW_BG, TW_DZ, TW_ZN X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 04 Nov 2011 10:56:36 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 63C152BB0BB; Fri, 4 Nov 2011 06:56:32 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id PUXtCllKVAEx; Fri, 4 Nov 2011 06:56:32 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 41F4F2BACD6; Fri, 4 Nov 2011 06:56:32 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 4038C3FEE8; Fri, 4 Nov 2011 06:56:32 -0400 (EDT) Date: Fri, 4 Nov 2011 06:56:32 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Geert Bosch Subject: [Ada] Remove partial interface to BLAS/LAPACK Message-ID: <20111104105632.GA25626@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This was previously used for implementing linear algebra support. As this is now implemented in pure Ada, and the binding was incomplete and adds unwanted dependencies on the external BLAS/LAPACK libraries, they are now removed, together with the wrappers that allows their use in generic packages. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-11-04 Geert Bosch * i-forbla-unimplemented.ads, s-gecola.adb, s-gecola.ads, s-gerebl.adb, s-gerebl.ads, i-forbla.adb, i-forbla.ads, i-forlap.ads, i-forbla-darwin.adb, s-gecobl.adb, s-gecobl.ads, s-gerela.adb, s-gerela.ads: Remove partial interface to BLAS/LAPACK. * gcc-interface/Makefile.in: Remove libgnala and related objects. Index: i-forbla-unimplemented.ads =================================================================== --- i-forbla-unimplemented.ads (revision 180929) +++ i-forbla-unimplemented.ads (working copy) @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a thin binding to the standard Fortran BLAS library. --- Documentation and a reference BLAS implementation is available from --- ftp://ftp.netlib.org. The main purpose of this package is to facilitate --- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and --- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS --- routines may be added over time. - --- This unit is not implemented in this GNAT configuration - -package Interfaces.Fortran.BLAS is - - pragma Unimplemented_Unit; - -end Interfaces.Fortran.BLAS; Index: s-gecola.adb =================================================================== --- s-gecola.adb (revision 180929) +++ s-gecola.adb (working copy) @@ -1,493 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-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_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; Index: s-gecola.ads =================================================================== --- s-gecola.ads (revision 180929) +++ s-gecola.ads (working copy) @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-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. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -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; Index: s-gerebl.adb =================================================================== --- s-gerebl.adb (revision 180929) +++ s-gerebl.adb (working copy) @@ -1,311 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ R E A L _ B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-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 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; Index: s-gerebl.ads =================================================================== --- s-gerebl.ads (revision 180929) +++ s-gerebl.ads (working copy) @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.GENERIC_REAL_BLAS -- --- -- --- S p e c -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -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; Index: i-forbla.adb =================================================================== --- i-forbla.adb (revision 180929) +++ i-forbla.adb (working copy) @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-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. -- --- -- ------------------------------------------------------------------------------- - --- This Interfaces.Fortran.Blas package body contains the required linker --- pragmas for automatically linking with the LAPACK linear algebra support --- library, and the systems math library. Alternative bodies can be supplied --- if different sets of libraries are needed. - -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; Index: i-forbla.ads =================================================================== --- i-forbla.ads (revision 180929) +++ i-forbla.ads (working copy) @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a thin binding to the standard Fortran BLAS library. --- Documentation and a reference BLAS implementation is available from --- ftp://ftp.netlib.org. The main purpose of this package is to facilitate --- implementation of the Ada 2005 Ada.Numerics.Generic_Real_Arrays and --- Ada.Numerics.Generic_Complex_Arrays packages. Bindings to other BLAS --- routines may be added over time. - --- As actual linker arguments to link with the BLAS implementation differs --- according to platform and chosen BLAS implementation, the linker arguments --- are given in the body of this package. The body may need to be modified in --- order to link with different BLAS implementations tuned to the specific --- target. - -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; Index: i-forlap.ads =================================================================== --- i-forlap.ads (revision 180929) +++ i-forlap.ads (working copy) @@ -1,414 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-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. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required if non-RM package ??? - -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; Index: i-forbla-darwin.adb =================================================================== --- i-forbla-darwin.adb (revision 180929) +++ i-forbla-darwin.adb (working copy) @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N . B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2010, 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. -- --- -- ------------------------------------------------------------------------------- - --- Version for Mac OS X - -package body Interfaces.Fortran.BLAS is - pragma Linker_Options ("-lgnala"); - pragma Linker_Options ("-lm"); - pragma Linker_Options ("-Wl,-framework,vecLib"); -end Interfaces.Fortran.BLAS; Index: s-gecobl.adb =================================================================== --- s-gecobl.adb (revision 180929) +++ s-gecobl.adb (working copy) @@ -1,350 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-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 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; Index: s-gecobl.ads =================================================================== --- s-gecobl.ads (revision 180929) +++ s-gecobl.ads (working copy) @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ C O M P L E X _ B L A S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-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. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -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; Index: s-gerela.adb =================================================================== --- s-gerela.adb (revision 180929) +++ s-gerela.adb (working copy) @@ -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 -- --- . -- --- -- --- 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; Index: s-gerela.ads =================================================================== --- s-gerela.ads (revision 180929) +++ s-gerela.ads (working copy) @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ R E A L _ L A P A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-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. -- --- -- ------------------------------------------------------------------------------- - --- Package comment required ??? - -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; Index: gcc-interface/Makefile.in =================================================================== --- gcc-interface/Makefile.in (revision 180929) +++ gcc-interface/Makefile.in (working copy) @@ -2116,7 +2116,6 @@ SO_OPTS = -shared-libgcc LIBGNAT_TARGET_PAIRS = \ a-intnam.ads