mirror of git://gcc.gnu.org/git/gcc.git
[multiple changes]
2011-11-04 Robert Dewar <dewar@adacore.com> * sem_warn.adb (Warn_On_Useless_Assignment): More accurate test for call vs assign. * gcc-interface/Make-lang.in: Update dependencies. 2011-11-04 Robert Dewar <dewar@adacore.com> * sem_prag.adb: Detect more cases of Long_Float inconsistencies at compile time. 2011-11-04 Matthew Heaney <heaney@adacore.com> * Makefile.rtl, impunit.adb: Added a-sfecin.ads, * a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb], a-sbhcin.ad[sb], a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb], a-sulcin.ad[sb] * a-sfecin.ads, a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb], a-sbhcin.ad[sb], a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb], a-sulcin.ad[sb]: New files. 2011-11-04 Geert Bosch <bosch@adacore.com> * 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. From-SVN: r180935
This commit is contained in:
Arnaud Charlet
parent
635c6321d4
commit
a51cd0ece5
|
|
@ -1,7 +1,30 @@
|
|||
2011-11-04 Eric Botcazou <ebotcazou@adacore.com>
|
||||
2011-11-04 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Do not assert
|
||||
that the type of the parameters isn't dummy in type_annotate_only mode.
|
||||
* sem_warn.adb (Warn_On_Useless_Assignment): More accurate test
|
||||
for call vs assign.
|
||||
* gcc-interface/Make-lang.in: Update dependencies.
|
||||
|
||||
2011-11-04 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* sem_prag.adb: Detect more cases of Long_Float inconsistencies at
|
||||
compile time.
|
||||
|
||||
2011-11-04 Matthew Heaney <heaney@adacore.com>
|
||||
|
||||
* Makefile.rtl, impunit.adb: Added a-sfecin.ads,
|
||||
* a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb], a-sbhcin.ad[sb],
|
||||
a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb], a-sulcin.ad[sb]
|
||||
* a-sfecin.ads, a-sfhcin.ads, a-sflcin.ads, a-sbecin.ad[sb],
|
||||
a-sbhcin.ad[sb], a-sblcin.ad[sb], a-suecin.ad[sb], a-suhcin.ad[sb],
|
||||
a-sulcin.ad[sb]: New files.
|
||||
|
||||
2011-11-04 Geert Bosch <bosch@adacore.com>
|
||||
|
||||
* 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.
|
||||
|
||||
2011-11-04 Matthew Heaney <heaney@adacore.com>
|
||||
|
||||
|
|
@ -11,6 +34,11 @@
|
|||
a-convec.ad[sb], a-coinve.ad[sb] (Assign, Copy): New operations
|
||||
added to package.
|
||||
|
||||
2011-11-04 Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Do not assert
|
||||
that the type of the parameters isn't dummy in type_annotate_only mode.
|
||||
|
||||
2011-11-04 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* sem_ch12.adb: Minor reformatting
|
||||
|
|
|
|||
|
|
@ -214,9 +214,15 @@ GNATRTL_NONTASKING_OBJS= \
|
|||
a-rbtgbo$(objext) \
|
||||
a-rbtgbk$(objext) \
|
||||
a-rbtgso$(objext) \
|
||||
a-sbecin$(objext) \
|
||||
a-sbhcin$(objext) \
|
||||
a-sblcin$(objext) \
|
||||
a-scteio$(objext) \
|
||||
a-secain$(objext) \
|
||||
a-sequio$(objext) \
|
||||
a-sfecin$(objext) \
|
||||
a-sfhcin$(objext) \
|
||||
a-sflcin$(objext) \
|
||||
a-sfteio$(objext) \
|
||||
a-sfwtio$(objext) \
|
||||
a-sfztio$(objext) \
|
||||
|
|
@ -261,10 +267,13 @@ GNATRTL_NONTASKING_OBJS= \
|
|||
a-stzsea$(objext) \
|
||||
a-stzsup$(objext) \
|
||||
a-stzunb$(objext) \
|
||||
a-suecin$(objext) \
|
||||
a-suenco$(objext) \
|
||||
a-suenst$(objext) \
|
||||
a-suewst$(objext) \
|
||||
a-suezst$(objext) \
|
||||
a-suhcin$(objext) \
|
||||
a-sulcin$(objext) \
|
||||
a-suteio$(objext) \
|
||||
a-swbwha$(objext) \
|
||||
a-swfwha$(objext) \
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- I N T E R F A C E S . F O R T R A N . B L A S --
|
||||
-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2006-2010, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2011, 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- --
|
||||
|
|
@ -24,15 +24,17 @@
|
|||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Version for Mac OS X
|
||||
with Ada.Strings.Equal_Case_Insensitive;
|
||||
|
||||
package body Interfaces.Fortran.BLAS is
|
||||
pragma Linker_Options ("-lgnala");
|
||||
pragma Linker_Options ("-lm");
|
||||
pragma Linker_Options ("-Wl,-framework,vecLib");
|
||||
end Interfaces.Fortran.BLAS;
|
||||
function Ada.Strings.Bounded.Equal_Case_Insensitive
|
||||
(Left, Right : Bounded.Bounded_String)
|
||||
return Boolean
|
||||
is
|
||||
begin
|
||||
return Ada.Strings.Equal_Case_Insensitive
|
||||
(Left => Bounded.To_String (Left),
|
||||
Right => Bounded.To_String (Right));
|
||||
end Ada.Strings.Bounded.Equal_Case_Insensitive;
|
||||
|
|
@ -1,12 +1,16 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- I N T E R F A C E S . F O R T R A N . B L A S --
|
||||
-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2006-2009, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- 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- --
|
||||
|
|
@ -24,19 +28,15 @@
|
|||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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.
|
||||
generic
|
||||
with package Bounded is
|
||||
new Ada.Strings.Bounded.Generic_Bounded_Length (<>);
|
||||
|
||||
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;
|
||||
function Ada.Strings.Bounded.Equal_Case_Insensitive
|
||||
(Left, Right : Bounded.Bounded_String)
|
||||
return Boolean;
|
||||
|
||||
pragma Preelaborate (Ada.Strings.Bounded.Equal_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Hash_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Bounded.Hash_Case_Insensitive
|
||||
(Key : Bounded.Bounded_String)
|
||||
return Containers.Hash_Type
|
||||
is
|
||||
begin
|
||||
return Ada.Strings.Hash_Case_Insensitive (Bounded.To_String (Key));
|
||||
end Ada.Strings.Bounded.Hash_Case_Insensitive;
|
||||
|
|
@ -1,12 +1,16 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- I N T E R F A C E S . F O R T R A N . B L A S --
|
||||
-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2006-2009, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- 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- --
|
||||
|
|
@ -24,22 +28,17 @@
|
|||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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.
|
||||
with Ada.Containers;
|
||||
|
||||
-- This unit is not implemented in this GNAT configuration
|
||||
generic
|
||||
with package Bounded is
|
||||
new Ada.Strings.Bounded.Generic_Bounded_Length (<>);
|
||||
|
||||
package Interfaces.Fortran.BLAS is
|
||||
function Ada.Strings.Bounded.Hash_Case_Insensitive
|
||||
(Key : Bounded.Bounded_String)
|
||||
return Containers.Hash_Type;
|
||||
|
||||
pragma Unimplemented_Unit;
|
||||
|
||||
end Interfaces.Fortran.BLAS;
|
||||
pragma Preelaborate (Ada.Strings.Bounded.Hash_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Less_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Bounded.Less_Case_Insensitive
|
||||
(Left, Right : Bounded.Bounded_String)
|
||||
return Boolean
|
||||
is
|
||||
begin
|
||||
return Ada.Strings.Less_Case_Insensitive
|
||||
(Left => Bounded.To_String (Left),
|
||||
Right => Bounded.To_String (Right));
|
||||
end Ada.Strings.Bounded.Less_Case_Insensitive;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
generic
|
||||
with package Bounded is
|
||||
new Ada.Strings.Bounded.Generic_Bounded_Length (<>);
|
||||
|
||||
function Ada.Strings.Bounded.Less_Case_Insensitive
|
||||
(Left, Right : Bounded.Bounded_String)
|
||||
return Boolean;
|
||||
|
||||
pragma Preelaborate (Ada.Strings.Bounded.Less_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.FIXED.EQUAL_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Equal_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Fixed.Equal_Case_Insensitive
|
||||
(Left, Right : String)
|
||||
return Boolean renames Ada.Strings.Equal_Case_Insensitive;
|
||||
|
||||
pragma Pure (Ada.Strings.Fixed.Equal_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.FIXED.HASH_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Containers;
|
||||
with Ada.Strings.Hash_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Fixed.Hash_Case_Insensitive
|
||||
(Key : String)
|
||||
return Containers.Hash_Type renames Ada.Strings.Hash_Case_Insensitive;
|
||||
|
||||
pragma Pure (Ada.Strings.Fixed.Hash_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.FIXED.LESS_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Less_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Fixed.Less_Case_Insensitive
|
||||
(Left, Right : String)
|
||||
return Boolean renames Ada.Strings.Less_Case_Insensitive;
|
||||
|
||||
pragma Pure (Ada.Strings.Fixed.Less_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Unbounded.Aux;
|
||||
with Ada.Strings.Equal_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Unbounded.Equal_Case_Insensitive
|
||||
(Left, Right : Unbounded.Unbounded_String)
|
||||
return Boolean
|
||||
is
|
||||
SL, SR : Aux.Big_String_Access;
|
||||
LL, LR : Natural;
|
||||
|
||||
begin
|
||||
Aux.Get_String (Left, SL, LL);
|
||||
Aux.Get_String (Right, SR, LR);
|
||||
|
||||
return Ada.Strings.Equal_Case_Insensitive
|
||||
(Left => SL (1 .. LL),
|
||||
Right => SR (1 .. LR));
|
||||
end Ada.Strings.Unbounded.Equal_Case_Insensitive;
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
function Ada.Strings.Unbounded.Equal_Case_Insensitive
|
||||
(Left, Right : Unbounded.Unbounded_String)
|
||||
return Boolean;
|
||||
|
||||
pragma Preelaborate (Ada.Strings.Unbounded.Equal_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Unbounded.Aux;
|
||||
with Ada.Strings.Hash_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Unbounded.Hash_Case_Insensitive
|
||||
(Key : Unbounded.Unbounded_String)
|
||||
return Containers.Hash_Type
|
||||
is
|
||||
S : Aux.Big_String_Access;
|
||||
L : Natural;
|
||||
|
||||
begin
|
||||
Aux.Get_String (Key, S, L);
|
||||
return Ada.Strings.Hash_Case_Insensitive (S (1 .. L));
|
||||
end Ada.Strings.Unbounded.Hash_Case_Insensitive;
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Containers;
|
||||
|
||||
function Ada.Strings.Unbounded.Hash_Case_Insensitive
|
||||
(Key : Unbounded.Unbounded_String)
|
||||
return Containers.Hash_Type;
|
||||
|
||||
pragma Preelaborate (Ada.Strings.Unbounded.Hash_Case_Insensitive);
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Strings.Unbounded.Aux;
|
||||
with Ada.Strings.Less_Case_Insensitive;
|
||||
|
||||
function Ada.Strings.Unbounded.Less_Case_Insensitive
|
||||
(Left, Right : Unbounded.Unbounded_String)
|
||||
return Boolean
|
||||
is
|
||||
SL, SR : Aux.Big_String_Access;
|
||||
LL, LR : Natural;
|
||||
|
||||
begin
|
||||
Aux.Get_String (Left, SL, LL);
|
||||
Aux.Get_String (Right, SR, LR);
|
||||
|
||||
return Ada.Strings.Less_Case_Insensitive
|
||||
(Left => SL (1 .. LL),
|
||||
Right => SR (1 .. LR));
|
||||
end Ada.Strings.Unbounded.Less_Case_Insensitive;
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
function Ada.Strings.Unbounded.Less_Case_Insensitive
|
||||
(Left, Right : Unbounded.Unbounded_String)
|
||||
return Boolean;
|
||||
|
||||
pragma Preelaborate (Ada.Strings.Unbounded.Less_Case_Insensitive);
|
||||
|
|
@ -1953,32 +1953,35 @@ ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
|
|||
|
||||
ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
|
||||
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
|
||||
ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \
|
||||
ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
|
||||
ada/elists.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \
|
||||
ada/erroutc.ads ada/erroutc.adb ada/exp_ch2.ads ada/exp_ch2.adb \
|
||||
ada/exp_code.ads ada/exp_smem.ads ada/exp_tss.ads ada/exp_util.ads \
|
||||
ada/exp_vfpt.ads ada/expander.ads ada/fname.ads ada/gnat.ads \
|
||||
ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads \
|
||||
ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib-load.ads \
|
||||
ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
|
||||
ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads ada/rident.ads \
|
||||
ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \
|
||||
ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \
|
||||
ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \
|
||||
ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \
|
||||
ada/sem_ch9.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \
|
||||
ada/sem_util.ads ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \
|
||||
ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
|
||||
ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \
|
||||
ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
|
||||
ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
|
||||
ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
|
||||
ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
|
||||
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
|
||||
ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
|
||||
ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
|
||||
ada/urealp.ads ada/widechar.ads
|
||||
ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
|
||||
ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \
|
||||
ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
|
||||
ada/errout.adb ada/erroutc.ads ada/erroutc.adb ada/eval_fat.ads \
|
||||
ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch2.adb ada/exp_ch4.ads \
|
||||
ada/exp_code.ads ada/exp_pakd.ads ada/exp_smem.ads ada/exp_tss.ads \
|
||||
ada/exp_util.ads ada/exp_vfpt.ads ada/expander.ads ada/fname.ads \
|
||||
ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
|
||||
ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads \
|
||||
ada/interfac.ads ada/lib.ads ada/lib-load.ads ada/namet.ads \
|
||||
ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
|
||||
ada/opt.ads ada/output.ads ada/par_sco.ads ada/restrict.ads \
|
||||
ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \
|
||||
ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads \
|
||||
ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \
|
||||
ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \
|
||||
ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_eval.ads ada/sem_prag.ads \
|
||||
ada/sem_res.ads ada/sem_util.ads ada/sem_warn.ads ada/sem_warn.adb \
|
||||
ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \
|
||||
ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
|
||||
ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
|
||||
ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
|
||||
ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
|
||||
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
|
||||
ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
|
||||
ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \
|
||||
ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
|
||||
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \
|
||||
ada/widechar.ads
|
||||
|
||||
ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
|
||||
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
|
||||
|
|
|
|||
|
|
@ -2116,7 +2116,6 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),)
|
|||
SO_OPTS = -shared-libgcc
|
||||
LIBGNAT_TARGET_PAIRS = \
|
||||
a-intnam.ads<a-intnam-darwin.ads \
|
||||
i-forbla.adb<i-forbla-darwin.adb \
|
||||
s-inmaop.adb<s-inmaop-posix.adb \
|
||||
s-osinte.adb<s-osinte-darwin.adb \
|
||||
s-osinte.ads<s-osinte-darwin.ads \
|
||||
|
|
@ -2238,10 +2237,8 @@ LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \
|
|||
|
||||
include $(fsrcdir)/ada/Makefile.rtl
|
||||
|
||||
GNATRTL_LINEARALGEBRA_OBJS = i-forbla.o i-forlap.o
|
||||
|
||||
GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \
|
||||
$(GNATRTL_LINEARALGEBRA_OBJS) memtrack.o
|
||||
memtrack.o
|
||||
|
||||
# Default run time files
|
||||
|
||||
|
|
@ -2538,9 +2535,6 @@ gnatlib: ../stamp-gnatlib1-$(RTSDIR) ../stamp-gnatlib2-$(RTSDIR)
|
|||
$(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnarl$(arext) \
|
||||
$(addprefix $(RTSDIR)/,$(GNATRTL_TASKING_OBJS))
|
||||
$(RANLIB_FOR_TARGET) $(RTSDIR)/libgnarl$(arext)
|
||||
$(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnala$(arext) \
|
||||
$(addprefix $(RTSDIR)/,$(GNATRTL_LINEARALGEBRA_OBJS))
|
||||
$(RANLIB_FOR_TARGET) $(RTSDIR)/libgnala$(arext)
|
||||
ifeq ($(GMEM_LIB),gmemlib)
|
||||
$(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgmem$(arext) \
|
||||
$(RTSDIR)/memtrack.o
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
|
|
@ -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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
|
|
@ -487,9 +487,6 @@ package body Impunit is
|
|||
("a-ciormu", F), -- Ada.Containers.Indefinite_Ordered_Multisets
|
||||
("a-coormu", F), -- Ada.Containers.Ordered_Multisets
|
||||
("a-crdlli", F), -- Ada.Containers.Restricted_Doubly_Linked_Lists
|
||||
("a-secain", F), -- Ada.Strings.Equal_Case_Insensitive
|
||||
("a-shcain", F), -- Ada.Strings.Hash_Case_Insensitive
|
||||
("a-slcain", F), -- Ada.Strings.Less_Case_Insensitive
|
||||
("a-szuzti", F), -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO
|
||||
("a-zchuni", F), -- Ada.Wide_Wide_Characters.Unicode
|
||||
("a-ztcstr", F), -- Ada.Wide_Wide_Text_IO.C_Streams
|
||||
|
|
@ -497,6 +494,18 @@ package body Impunit is
|
|||
-- Note: strictly the following should be Ada 2012 units, but it seems
|
||||
-- harmless (and useful) to make then available in Ada 2005 mode.
|
||||
|
||||
("a-secain", T), -- Ada.Strings.Equal_Case_Insensitive
|
||||
("a-shcain", T), -- Ada.Strings.Hash_Case_Insensitive
|
||||
("a-slcain", T), -- Ada.Strings.Less_Case_Insensitive
|
||||
("a-sfecin", T), -- Ada.Strings.Fixed.Equal_Case_Insensitive
|
||||
("a-sfhcin", T), -- Ada.Strings.Fixed.Hash_Case_Insensitive
|
||||
("a-sflcin", T), -- Ada.Strings.Fixed.Less_Case_Insensitive
|
||||
("a-sbecin", T), -- Ada.Strings.Bounded.Equal_Case_Insensitive
|
||||
("a-sbhcin", T), -- Ada.Strings.Bounded.Hash_Case_Insensitive
|
||||
("a-sblcin", T), -- Ada.Strings.Bounded.Less_Case_Insensitive
|
||||
("a-suecin", T), -- Ada.Strings.Unbounded.Equal_Case_Insensitive
|
||||
("a-suhcin", T), -- Ada.Strings.Unbounded.Hash_Case_Insensitive
|
||||
("a-sulcin", T), -- Ada.Strings.Unbounded.Less_Case_Insensitive
|
||||
("a-suezst", T), -- Ada.Strings.UTF_Encoding.Wide_Wide_Strings
|
||||
|
||||
---------------------------
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Unchecked_Conversion; use Ada;
|
||||
with Interfaces; use Interfaces;
|
||||
with Interfaces.Fortran; use Interfaces.Fortran;
|
||||
with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
|
||||
with System.Generic_Array_Operations; use System.Generic_Array_Operations;
|
||||
|
||||
package body System.Generic_Complex_BLAS is
|
||||
|
||||
Is_Single : constant Boolean :=
|
||||
Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
|
||||
and then Fortran.Real (Real'First) = Fortran.Real'First
|
||||
and then Fortran.Real (Real'Last) = Fortran.Real'Last;
|
||||
|
||||
Is_Double : constant Boolean :=
|
||||
Real'Machine_Mantissa = Double_Precision'Machine_Mantissa
|
||||
and then
|
||||
Double_Precision (Real'First) = Double_Precision'First
|
||||
and then
|
||||
Double_Precision (Real'Last) = Double_Precision'Last;
|
||||
|
||||
subtype Complex is Complex_Types.Complex;
|
||||
|
||||
-- Local subprograms
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision;
|
||||
pragma Inline (To_Double_Precision);
|
||||
|
||||
function To_Double_Complex (X : Complex) return Double_Complex;
|
||||
pragma Inline (To_Double_Complex);
|
||||
|
||||
function To_Complex (X : Double_Complex) return Complex;
|
||||
function To_Complex (X : Fortran.Complex) return Complex;
|
||||
pragma Inline (To_Complex);
|
||||
|
||||
function To_Fortran (X : Complex) return Fortran.Complex;
|
||||
pragma Inline (To_Fortran);
|
||||
|
||||
-- Instantiations
|
||||
|
||||
function To_Double_Complex is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Complex_Types.Complex,
|
||||
Result_Scalar => Fortran.Double_Complex,
|
||||
X_Vector => Complex_Vector,
|
||||
Result_Vector => BLAS.Double_Complex_Vector,
|
||||
Operation => To_Double_Complex);
|
||||
|
||||
function To_Complex is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Fortran.Double_Complex,
|
||||
Result_Scalar => Complex,
|
||||
X_Vector => BLAS.Double_Complex_Vector,
|
||||
Result_Vector => Complex_Vector,
|
||||
Operation => To_Complex);
|
||||
|
||||
function To_Double_Complex is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Complex,
|
||||
Result_Scalar => Double_Complex,
|
||||
X_Matrix => Complex_Matrix,
|
||||
Result_Matrix => BLAS.Double_Complex_Matrix,
|
||||
Operation => To_Double_Complex);
|
||||
|
||||
function To_Complex is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Double_Complex,
|
||||
Result_Scalar => Complex,
|
||||
X_Matrix => BLAS.Double_Complex_Matrix,
|
||||
Result_Matrix => Complex_Matrix,
|
||||
Operation => To_Complex);
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision is
|
||||
begin
|
||||
return Double_Precision (X);
|
||||
end To_Double_Precision;
|
||||
|
||||
function To_Double_Complex (X : Complex) return Double_Complex is
|
||||
begin
|
||||
return (To_Double_Precision (X.Re), To_Double_Precision (X.Im));
|
||||
end To_Double_Complex;
|
||||
|
||||
function To_Complex (X : Double_Complex) return Complex is
|
||||
begin
|
||||
return (Real (X.Re), Real (X.Im));
|
||||
end To_Complex;
|
||||
|
||||
function To_Complex (X : Fortran.Complex) return Complex is
|
||||
begin
|
||||
return (Real (X.Re), Real (X.Im));
|
||||
end To_Complex;
|
||||
|
||||
function To_Fortran (X : Complex) return Fortran.Complex is
|
||||
begin
|
||||
return (Fortran.Real (X.Re), Fortran.Real (X.Im));
|
||||
end To_Fortran;
|
||||
|
||||
---------
|
||||
-- dot --
|
||||
---------
|
||||
|
||||
function dot
|
||||
(N : Positive;
|
||||
X : Complex_Vector;
|
||||
Inc_X : Integer := 1;
|
||||
Y : Complex_Vector;
|
||||
Inc_Y : Integer := 1) return Complex
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
type X_Ptr is access all BLAS.Complex_Vector (X'Range);
|
||||
type Y_Ptr is access all BLAS.Complex_Vector (Y'Range);
|
||||
function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
|
||||
function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
return To_Complex (BLAS.cdotu (N, Conv_X (X'Address).all, Inc_X,
|
||||
Conv_Y (Y'Address).all, Inc_Y));
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
type X_Ptr is access all BLAS.Double_Complex_Vector (X'Range);
|
||||
type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range);
|
||||
function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
|
||||
function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
return To_Complex (BLAS.zdotu (N, Conv_X (X'Address).all, Inc_X,
|
||||
Conv_Y (Y'Address).all, Inc_Y));
|
||||
end;
|
||||
|
||||
else
|
||||
return To_Complex (BLAS.zdotu (N, To_Double_Complex (X), Inc_X,
|
||||
To_Double_Complex (Y), Inc_Y));
|
||||
end if;
|
||||
end dot;
|
||||
|
||||
----------
|
||||
-- gemm --
|
||||
----------
|
||||
|
||||
procedure gemm
|
||||
(Trans_A : access constant Character;
|
||||
Trans_B : access constant Character;
|
||||
M : Positive;
|
||||
N : Positive;
|
||||
K : Positive;
|
||||
Alpha : Complex := (1.0, 0.0);
|
||||
A : Complex_Matrix;
|
||||
Ld_A : Integer;
|
||||
B : Complex_Matrix;
|
||||
Ld_B : Integer;
|
||||
Beta : Complex := (0.0, 0.0);
|
||||
C : in out Complex_Matrix;
|
||||
Ld_C : Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2));
|
||||
subtype B_Type is BLAS.Complex_Matrix (B'Range (1), B'Range (2));
|
||||
type C_Ptr is
|
||||
access all BLAS.Complex_Matrix (C'Range (1), C'Range (2));
|
||||
function Conv_A is
|
||||
new Unchecked_Conversion (Complex_Matrix, A_Type);
|
||||
function Conv_B is
|
||||
new Unchecked_Conversion (Complex_Matrix, B_Type);
|
||||
function Conv_C is
|
||||
new Unchecked_Conversion (Address, C_Ptr);
|
||||
begin
|
||||
BLAS.cgemm (Trans_A, Trans_B, M, N, K, To_Fortran (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_B (B), Ld_B, To_Fortran (Beta),
|
||||
Conv_C (C'Address).all, Ld_C);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
subtype A_Type is
|
||||
BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
subtype B_Type is
|
||||
BLAS.Double_Complex_Matrix (B'Range (1), B'Range (2));
|
||||
type C_Ptr is access all
|
||||
BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2));
|
||||
function Conv_A is
|
||||
new Unchecked_Conversion (Complex_Matrix, A_Type);
|
||||
function Conv_B is
|
||||
new Unchecked_Conversion (Complex_Matrix, B_Type);
|
||||
function Conv_C is new Unchecked_Conversion (Address, C_Ptr);
|
||||
begin
|
||||
BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_B (B), Ld_B,
|
||||
To_Double_Complex (Beta),
|
||||
Conv_C (C'Address).all, Ld_C);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_C : BLAS.Double_Complex_Matrix (C'Range (1), C'Range (2));
|
||||
begin
|
||||
if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then
|
||||
DP_C := To_Double_Complex (C);
|
||||
end if;
|
||||
|
||||
BLAS.zgemm (Trans_A, Trans_B, M, N, K, To_Double_Complex (Alpha),
|
||||
To_Double_Complex (A), Ld_A,
|
||||
To_Double_Complex (B), Ld_B, To_Double_Complex (Beta),
|
||||
DP_C, Ld_C);
|
||||
|
||||
C := To_Complex (DP_C);
|
||||
end;
|
||||
end if;
|
||||
end gemm;
|
||||
|
||||
----------
|
||||
-- gemv --
|
||||
----------
|
||||
|
||||
procedure gemv
|
||||
(Trans : access constant Character;
|
||||
M : Natural := 0;
|
||||
N : Natural := 0;
|
||||
Alpha : Complex := (1.0, 0.0);
|
||||
A : Complex_Matrix;
|
||||
Ld_A : Positive;
|
||||
X : Complex_Vector;
|
||||
Inc_X : Integer := 1;
|
||||
Beta : Complex := (0.0, 0.0);
|
||||
Y : in out Complex_Vector;
|
||||
Inc_Y : Integer := 1)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2));
|
||||
subtype X_Type is BLAS.Complex_Vector (X'Range);
|
||||
type Y_Ptr is access all BLAS.Complex_Vector (Y'Range);
|
||||
function Conv_A is
|
||||
new Unchecked_Conversion (Complex_Matrix, A_Type);
|
||||
function Conv_X is
|
||||
new Unchecked_Conversion (Complex_Vector, X_Type);
|
||||
function Conv_Y is
|
||||
new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
BLAS.cgemv (Trans, M, N, To_Fortran (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_X (X), Inc_X, To_Fortran (Beta),
|
||||
Conv_Y (Y'Address).all, Inc_Y);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
subtype A_Type is
|
||||
BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
subtype X_Type is
|
||||
BLAS.Double_Complex_Vector (X'Range);
|
||||
type Y_Ptr is access all BLAS.Double_Complex_Vector (Y'Range);
|
||||
function Conv_A is
|
||||
new Unchecked_Conversion (Complex_Matrix, A_Type);
|
||||
function Conv_X is
|
||||
new Unchecked_Conversion (Complex_Vector, X_Type);
|
||||
function Conv_Y is
|
||||
new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_X (X), Inc_X,
|
||||
To_Double_Complex (Beta),
|
||||
Conv_Y (Y'Address).all, Inc_Y);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_Y : BLAS.Double_Complex_Vector (Y'Range);
|
||||
begin
|
||||
if Beta.Re /= 0.0 or else Beta.Im /= 0.0 then
|
||||
DP_Y := To_Double_Complex (Y);
|
||||
end if;
|
||||
|
||||
BLAS.zgemv (Trans, M, N, To_Double_Complex (Alpha),
|
||||
To_Double_Complex (A), Ld_A,
|
||||
To_Double_Complex (X), Inc_X, To_Double_Complex (Beta),
|
||||
DP_Y, Inc_Y);
|
||||
|
||||
Y := To_Complex (DP_Y);
|
||||
end;
|
||||
end if;
|
||||
end gemv;
|
||||
|
||||
----------
|
||||
-- nrm2 --
|
||||
----------
|
||||
|
||||
function nrm2
|
||||
(N : Natural;
|
||||
X : Complex_Vector;
|
||||
Inc_X : Integer := 1) return Real
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
subtype X_Type is BLAS.Complex_Vector (X'Range);
|
||||
function Conv_X is
|
||||
new Unchecked_Conversion (Complex_Vector, X_Type);
|
||||
begin
|
||||
return Real (BLAS.scnrm2 (N, Conv_X (X), Inc_X));
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
subtype X_Type is BLAS.Double_Complex_Vector (X'Range);
|
||||
function Conv_X is
|
||||
new Unchecked_Conversion (Complex_Vector, X_Type);
|
||||
begin
|
||||
return Real (BLAS.dznrm2 (N, Conv_X (X), Inc_X));
|
||||
end;
|
||||
|
||||
else
|
||||
return Real (BLAS.dznrm2 (N, To_Double_Complex (X), Inc_X));
|
||||
end if;
|
||||
end nrm2;
|
||||
|
||||
end System.Generic_Complex_BLAS;
|
||||
|
|
@ -1,102 +0,0 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- 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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
|
|
@ -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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Unchecked_Conversion; use Ada;
|
||||
with Interfaces; use Interfaces;
|
||||
with Interfaces.Fortran; use Interfaces.Fortran;
|
||||
with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
|
||||
with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK;
|
||||
with System.Generic_Array_Operations; use System.Generic_Array_Operations;
|
||||
|
||||
package body System.Generic_Complex_LAPACK is
|
||||
|
||||
Is_Single : constant Boolean :=
|
||||
Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
|
||||
and then Fortran.Real (Real'First) = Fortran.Real'First
|
||||
and then Fortran.Real (Real'Last) = Fortran.Real'Last;
|
||||
|
||||
Is_Double : constant Boolean :=
|
||||
Real'Machine_Mantissa = Double_Precision'Machine_Mantissa
|
||||
and then
|
||||
Double_Precision (Real'First) = Double_Precision'First
|
||||
and then
|
||||
Double_Precision (Real'Last) = Double_Precision'Last;
|
||||
|
||||
subtype Complex is Complex_Types.Complex;
|
||||
|
||||
-- Local subprograms
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision;
|
||||
pragma Inline (To_Double_Precision);
|
||||
|
||||
function To_Real (X : Double_Precision) return Real;
|
||||
pragma Inline (To_Real);
|
||||
|
||||
function To_Double_Complex (X : Complex) return Double_Complex;
|
||||
pragma Inline (To_Double_Complex);
|
||||
|
||||
function To_Complex (X : Double_Complex) return Complex;
|
||||
pragma Inline (To_Complex);
|
||||
|
||||
-- Instantiations
|
||||
|
||||
function To_Double_Precision is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Real,
|
||||
Result_Scalar => Double_Precision,
|
||||
X_Vector => Real_Vector,
|
||||
Result_Vector => Double_Precision_Vector,
|
||||
Operation => To_Double_Precision);
|
||||
|
||||
function To_Real is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Double_Precision,
|
||||
Result_Scalar => Real,
|
||||
X_Vector => Double_Precision_Vector,
|
||||
Result_Vector => Real_Vector,
|
||||
Operation => To_Real);
|
||||
|
||||
function To_Double_Complex is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Complex,
|
||||
Result_Scalar => Double_Complex,
|
||||
X_Matrix => Complex_Matrix,
|
||||
Result_Matrix => Double_Complex_Matrix,
|
||||
Operation => To_Double_Complex);
|
||||
|
||||
function To_Complex is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Double_Complex,
|
||||
Result_Scalar => Complex,
|
||||
X_Matrix => Double_Complex_Matrix,
|
||||
Result_Matrix => Complex_Matrix,
|
||||
Operation => To_Complex);
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision is
|
||||
begin
|
||||
return Double_Precision (X);
|
||||
end To_Double_Precision;
|
||||
|
||||
function To_Real (X : Double_Precision) return Real is
|
||||
begin
|
||||
return Real (X);
|
||||
end To_Real;
|
||||
|
||||
function To_Double_Complex (X : Complex) return Double_Complex is
|
||||
begin
|
||||
return (To_Double_Precision (X.Re), To_Double_Precision (X.Im));
|
||||
end To_Double_Complex;
|
||||
|
||||
function To_Complex (X : Double_Complex) return Complex is
|
||||
begin
|
||||
return (Real (X.Re), Real (X.Im));
|
||||
end To_Complex;
|
||||
|
||||
-----------
|
||||
-- getrf --
|
||||
-----------
|
||||
|
||||
procedure getrf
|
||||
(M : Natural;
|
||||
N : Natural;
|
||||
A : in out Complex_Matrix;
|
||||
Ld_A : Positive;
|
||||
I_Piv : out Integer_Vector;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Complex_Matrix (A'Range (1), A'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
begin
|
||||
cgetrf (M, N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv), Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
begin
|
||||
zgetrf (M, N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv), Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
begin
|
||||
DP_A := To_Double_Complex (A);
|
||||
zgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info);
|
||||
A := To_Complex (DP_A);
|
||||
end;
|
||||
end if;
|
||||
end getrf;
|
||||
|
||||
-----------
|
||||
-- getri --
|
||||
-----------
|
||||
|
||||
procedure getri
|
||||
(N : Natural;
|
||||
A : in out Complex_Matrix;
|
||||
Ld_A : Positive;
|
||||
I_Piv : Integer_Vector;
|
||||
Work : in out Complex_Vector;
|
||||
L_Work : Integer;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Complex_Matrix (A'Range (1), A'Range (2));
|
||||
type Work_Ptr is
|
||||
access all BLAS.Complex_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
cgetri (N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
type Work_Ptr is
|
||||
access all Double_Complex_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
zgetri (N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
DP_Work : Double_Complex_Vector (Work'Range);
|
||||
begin
|
||||
DP_A := To_Double_Complex (A);
|
||||
zgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv),
|
||||
DP_Work, L_Work, Info);
|
||||
A := To_Complex (DP_A);
|
||||
Work (1) := To_Complex (DP_Work (1));
|
||||
end;
|
||||
end if;
|
||||
end getri;
|
||||
|
||||
-----------
|
||||
-- getrs --
|
||||
-----------
|
||||
|
||||
procedure getrs
|
||||
(Trans : access constant Character;
|
||||
N : Natural;
|
||||
N_Rhs : Natural;
|
||||
A : Complex_Matrix;
|
||||
Ld_A : Positive;
|
||||
I_Piv : Integer_Vector;
|
||||
B : in out Complex_Matrix;
|
||||
Ld_B : Positive;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
subtype A_Type is BLAS.Complex_Matrix (A'Range (1), A'Range (2));
|
||||
type B_Ptr is
|
||||
access all BLAS.Complex_Matrix (B'Range (1), B'Range (2));
|
||||
function Conv_A is
|
||||
new Unchecked_Conversion (Complex_Matrix, A_Type);
|
||||
function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
|
||||
begin
|
||||
cgetrs (Trans, N, N_Rhs,
|
||||
Conv_A (A), Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_B (B'Address).all, Ld_B,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
subtype A_Type is
|
||||
Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
type B_Ptr is
|
||||
access all Double_Complex_Matrix (B'Range (1), B'Range (2));
|
||||
function Conv_A is
|
||||
new Unchecked_Conversion (Complex_Matrix, A_Type);
|
||||
function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
|
||||
begin
|
||||
zgetrs (Trans, N, N_Rhs,
|
||||
Conv_A (A), Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_B (B'Address).all, Ld_B,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
DP_B : Double_Complex_Matrix (B'Range (1), B'Range (2));
|
||||
begin
|
||||
DP_A := To_Double_Complex (A);
|
||||
DP_B := To_Double_Complex (B);
|
||||
zgetrs (Trans, N, N_Rhs,
|
||||
DP_A, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
DP_B, Ld_B,
|
||||
Info);
|
||||
B := To_Complex (DP_B);
|
||||
end;
|
||||
end if;
|
||||
end getrs;
|
||||
|
||||
procedure heevr
|
||||
(Job_Z : access constant Character;
|
||||
Rng : access constant Character;
|
||||
Uplo : access constant Character;
|
||||
N : Natural;
|
||||
A : in out Complex_Matrix;
|
||||
Ld_A : Positive;
|
||||
Vl, Vu : Real := 0.0;
|
||||
Il, Iu : Integer := 1;
|
||||
Abs_Tol : Real := 0.0;
|
||||
M : out Integer;
|
||||
W : out Real_Vector;
|
||||
Z : out Complex_Matrix;
|
||||
Ld_Z : Positive;
|
||||
I_Supp_Z : out Integer_Vector;
|
||||
Work : out Complex_Vector;
|
||||
L_Work : Integer;
|
||||
R_Work : out Real_Vector;
|
||||
LR_Work : Integer;
|
||||
I_Work : out Integer_Vector;
|
||||
LI_Work : Integer;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Complex_Matrix (A'Range (1), A'Range (2));
|
||||
type W_Ptr is
|
||||
access all BLAS.Real_Vector (W'Range);
|
||||
type Z_Ptr is
|
||||
access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2));
|
||||
type Work_Ptr is access all BLAS.Complex_Vector (Work'Range);
|
||||
type R_Work_Ptr is access all BLAS.Real_Vector (R_Work'Range);
|
||||
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_W is new Unchecked_Conversion (Address, W_Ptr);
|
||||
function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
function Conv_R_Work is
|
||||
new Unchecked_Conversion (Address, R_Work_Ptr);
|
||||
begin
|
||||
cheevr (Job_Z, Rng, Uplo, N,
|
||||
Conv_A (A'Address).all, Ld_A,
|
||||
Fortran.Real (Vl), Fortran.Real (Vu),
|
||||
Il, Iu, Fortran.Real (Abs_Tol), M,
|
||||
Conv_W (W'Address).all,
|
||||
Conv_Z (Z'Address).all, Ld_Z,
|
||||
LAPACK.Integer_Vector (I_Supp_Z),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Conv_R_Work (R_Work'Address).all, LR_Work,
|
||||
LAPACK.Integer_Vector (I_Work), LI_Work, Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
type W_Ptr is
|
||||
access all BLAS.Double_Precision_Vector (W'Range);
|
||||
type Z_Ptr is
|
||||
access all BLAS.Double_Complex_Matrix (Z'Range (1), Z'Range (2));
|
||||
type Work_Ptr is
|
||||
access all BLAS.Double_Complex_Vector (Work'Range);
|
||||
type R_Work_Ptr is
|
||||
access all BLAS.Double_Precision_Vector (R_Work'Range);
|
||||
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_W is new Unchecked_Conversion (Address, W_Ptr);
|
||||
function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
function Conv_R_Work is
|
||||
new Unchecked_Conversion (Address, R_Work_Ptr);
|
||||
begin
|
||||
zheevr (Job_Z, Rng, Uplo, N,
|
||||
Conv_A (A'Address).all, Ld_A,
|
||||
Double_Precision (Vl), Double_Precision (Vu),
|
||||
Il, Iu, Double_Precision (Abs_Tol), M,
|
||||
Conv_W (W'Address).all,
|
||||
Conv_Z (Z'Address).all, Ld_Z,
|
||||
LAPACK.Integer_Vector (I_Supp_Z),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Conv_R_Work (R_Work'Address).all, LR_Work,
|
||||
LAPACK.Integer_Vector (I_Work), LI_Work, Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Complex_Matrix (A'Range (1), A'Range (2));
|
||||
DP_W : Double_Precision_Vector (W'Range);
|
||||
DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2));
|
||||
DP_Work : Double_Complex_Vector (Work'Range);
|
||||
DP_R_Work : Double_Precision_Vector (R_Work'Range);
|
||||
|
||||
begin
|
||||
DP_A := To_Double_Complex (A);
|
||||
|
||||
zheevr (Job_Z, Rng, Uplo, N,
|
||||
DP_A, Ld_A,
|
||||
Double_Precision (Vl), Double_Precision (Vu),
|
||||
Il, Iu, Double_Precision (Abs_Tol), M,
|
||||
DP_W, DP_Z, Ld_Z,
|
||||
LAPACK.Integer_Vector (I_Supp_Z),
|
||||
DP_Work, L_Work,
|
||||
DP_R_Work, LR_Work,
|
||||
LAPACK.Integer_Vector (I_Work), LI_Work, Info);
|
||||
|
||||
A := To_Complex (DP_A);
|
||||
W := To_Real (DP_W);
|
||||
Z := To_Complex (DP_Z);
|
||||
|
||||
Work (1) := To_Complex (DP_Work (1));
|
||||
R_Work (1) := To_Real (DP_R_Work (1));
|
||||
end;
|
||||
end if;
|
||||
end heevr;
|
||||
|
||||
-----------
|
||||
-- steqr --
|
||||
-----------
|
||||
|
||||
procedure steqr
|
||||
(Comp_Z : access constant Character;
|
||||
N : Natural;
|
||||
D : in out Real_Vector;
|
||||
E : in out Real_Vector;
|
||||
Z : in out Complex_Matrix;
|
||||
Ld_Z : Positive;
|
||||
Work : out Real_Vector;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
type D_Ptr is access all BLAS.Real_Vector (D'Range);
|
||||
type E_Ptr is access all BLAS.Real_Vector (E'Range);
|
||||
type Z_Ptr is
|
||||
access all BLAS.Complex_Matrix (Z'Range (1), Z'Range (2));
|
||||
type Work_Ptr is
|
||||
access all BLAS.Real_Vector (Work'Range);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
csteqr (Comp_Z, N,
|
||||
Conv_D (D'Address).all,
|
||||
Conv_E (E'Address).all,
|
||||
Conv_Z (Z'Address).all,
|
||||
Ld_Z,
|
||||
Conv_Work (Work'Address).all,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
type D_Ptr is access all Double_Precision_Vector (D'Range);
|
||||
type E_Ptr is access all Double_Precision_Vector (E'Range);
|
||||
type Z_Ptr is
|
||||
access all Double_Complex_Matrix (Z'Range (1), Z'Range (2));
|
||||
type Work_Ptr is
|
||||
access all Double_Precision_Vector (Work'Range);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
zsteqr (Comp_Z, N,
|
||||
Conv_D (D'Address).all,
|
||||
Conv_E (E'Address).all,
|
||||
Conv_Z (Z'Address).all,
|
||||
Ld_Z,
|
||||
Conv_Work (Work'Address).all,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_D : Double_Precision_Vector (D'Range);
|
||||
DP_E : Double_Precision_Vector (E'Range);
|
||||
DP_Z : Double_Complex_Matrix (Z'Range (1), Z'Range (2));
|
||||
DP_Work : Double_Precision_Vector (Work'Range);
|
||||
begin
|
||||
DP_D := To_Double_Precision (D);
|
||||
DP_E := To_Double_Precision (E);
|
||||
|
||||
if Comp_Z.all = 'V' then
|
||||
DP_Z := To_Double_Complex (Z);
|
||||
end if;
|
||||
|
||||
zsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info);
|
||||
|
||||
D := To_Real (DP_D);
|
||||
E := To_Real (DP_E);
|
||||
|
||||
if Comp_Z.all /= 'N' then
|
||||
Z := To_Complex (DP_Z);
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end steqr;
|
||||
|
||||
end System.Generic_Complex_LAPACK;
|
||||
|
|
@ -1,131 +0,0 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- 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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
|
|
@ -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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Unchecked_Conversion; use Ada;
|
||||
with Interfaces; use Interfaces;
|
||||
with Interfaces.Fortran; use Interfaces.Fortran;
|
||||
with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
|
||||
with System.Generic_Array_Operations; use System.Generic_Array_Operations;
|
||||
|
||||
package body System.Generic_Real_BLAS is
|
||||
|
||||
Is_Single : constant Boolean :=
|
||||
Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
|
||||
and then Fortran.Real (Real'First) = Fortran.Real'First
|
||||
and then Fortran.Real (Real'Last) = Fortran.Real'Last;
|
||||
|
||||
Is_Double : constant Boolean :=
|
||||
Real'Machine_Mantissa = Double_Precision'Machine_Mantissa
|
||||
and then
|
||||
Double_Precision (Real'First) = Double_Precision'First
|
||||
and then
|
||||
Double_Precision (Real'Last) = Double_Precision'Last;
|
||||
|
||||
-- Local subprograms
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision;
|
||||
pragma Inline_Always (To_Double_Precision);
|
||||
|
||||
function To_Real (X : Double_Precision) return Real;
|
||||
pragma Inline_Always (To_Real);
|
||||
|
||||
-- Instantiations
|
||||
|
||||
function To_Double_Precision is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Real,
|
||||
Result_Scalar => Double_Precision,
|
||||
X_Vector => Real_Vector,
|
||||
Result_Vector => Double_Precision_Vector,
|
||||
Operation => To_Double_Precision);
|
||||
|
||||
function To_Real is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Double_Precision,
|
||||
Result_Scalar => Real,
|
||||
X_Vector => Double_Precision_Vector,
|
||||
Result_Vector => Real_Vector,
|
||||
Operation => To_Real);
|
||||
|
||||
function To_Double_Precision is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Real,
|
||||
Result_Scalar => Double_Precision,
|
||||
X_Matrix => Real_Matrix,
|
||||
Result_Matrix => Double_Precision_Matrix,
|
||||
Operation => To_Double_Precision);
|
||||
|
||||
function To_Real is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Double_Precision,
|
||||
Result_Scalar => Real,
|
||||
X_Matrix => Double_Precision_Matrix,
|
||||
Result_Matrix => Real_Matrix,
|
||||
Operation => To_Real);
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision is
|
||||
begin
|
||||
return Double_Precision (X);
|
||||
end To_Double_Precision;
|
||||
|
||||
function To_Real (X : Double_Precision) return Real is
|
||||
begin
|
||||
return Real (X);
|
||||
end To_Real;
|
||||
|
||||
---------
|
||||
-- dot --
|
||||
---------
|
||||
|
||||
function dot
|
||||
(N : Positive;
|
||||
X : Real_Vector;
|
||||
Inc_X : Integer := 1;
|
||||
Y : Real_Vector;
|
||||
Inc_Y : Integer := 1) return Real
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
type X_Ptr is access all BLAS.Real_Vector (X'Range);
|
||||
type Y_Ptr is access all BLAS.Real_Vector (Y'Range);
|
||||
function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
|
||||
function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
return Real (sdot (N, Conv_X (X'Address).all, Inc_X,
|
||||
Conv_Y (Y'Address).all, Inc_Y));
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
type X_Ptr is access all BLAS.Double_Precision_Vector (X'Range);
|
||||
type Y_Ptr is access all BLAS.Double_Precision_Vector (Y'Range);
|
||||
function Conv_X is new Unchecked_Conversion (Address, X_Ptr);
|
||||
function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
return Real (ddot (N, Conv_X (X'Address).all, Inc_X,
|
||||
Conv_Y (Y'Address).all, Inc_Y));
|
||||
end;
|
||||
|
||||
else
|
||||
return Real (ddot (N, To_Double_Precision (X), Inc_X,
|
||||
To_Double_Precision (Y), Inc_Y));
|
||||
end if;
|
||||
end dot;
|
||||
|
||||
----------
|
||||
-- gemm --
|
||||
----------
|
||||
|
||||
procedure gemm
|
||||
(Trans_A : access constant Character;
|
||||
Trans_B : access constant Character;
|
||||
M : Positive;
|
||||
N : Positive;
|
||||
K : Positive;
|
||||
Alpha : Real := 1.0;
|
||||
A : Real_Matrix;
|
||||
Ld_A : Integer;
|
||||
B : Real_Matrix;
|
||||
Ld_B : Integer;
|
||||
Beta : Real := 0.0;
|
||||
C : in out Real_Matrix;
|
||||
Ld_C : Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2));
|
||||
subtype B_Type is BLAS.Real_Matrix (B'Range (1), B'Range (2));
|
||||
type C_Ptr is
|
||||
access all BLAS.Real_Matrix (C'Range (1), C'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
|
||||
function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type);
|
||||
function Conv_C is new Unchecked_Conversion (Address, C_Ptr);
|
||||
begin
|
||||
sgemm (Trans_A, Trans_B, M, N, K, Fortran.Real (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_B (B), Ld_B, Fortran.Real (Beta),
|
||||
Conv_C (C'Address).all, Ld_C);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
subtype A_Type is
|
||||
Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
subtype B_Type is
|
||||
Double_Precision_Matrix (B'Range (1), B'Range (2));
|
||||
type C_Ptr is
|
||||
access all Double_Precision_Matrix (C'Range (1), C'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
|
||||
function Conv_B is new Unchecked_Conversion (Real_Matrix, B_Type);
|
||||
function Conv_C is new Unchecked_Conversion (Address, C_Ptr);
|
||||
begin
|
||||
dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_B (B), Ld_B, Double_Precision (Beta),
|
||||
Conv_C (C'Address).all, Ld_C);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_C : Double_Precision_Matrix (C'Range (1), C'Range (2));
|
||||
begin
|
||||
if Beta /= 0.0 then
|
||||
DP_C := To_Double_Precision (C);
|
||||
end if;
|
||||
|
||||
dgemm (Trans_A, Trans_B, M, N, K, Double_Precision (Alpha),
|
||||
To_Double_Precision (A), Ld_A,
|
||||
To_Double_Precision (B), Ld_B, Double_Precision (Beta),
|
||||
DP_C, Ld_C);
|
||||
|
||||
C := To_Real (DP_C);
|
||||
end;
|
||||
end if;
|
||||
end gemm;
|
||||
|
||||
----------
|
||||
-- gemv --
|
||||
----------
|
||||
|
||||
procedure gemv
|
||||
(Trans : access constant Character;
|
||||
M : Natural := 0;
|
||||
N : Natural := 0;
|
||||
Alpha : Real := 1.0;
|
||||
A : Real_Matrix;
|
||||
Ld_A : Positive;
|
||||
X : Real_Vector;
|
||||
Inc_X : Integer := 1;
|
||||
Beta : Real := 0.0;
|
||||
Y : in out Real_Vector;
|
||||
Inc_Y : Integer := 1)
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2));
|
||||
subtype X_Type is BLAS.Real_Vector (X'Range);
|
||||
type Y_Ptr is access all BLAS.Real_Vector (Y'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
|
||||
function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
|
||||
function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
sgemv (Trans, M, N, Fortran.Real (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_X (X), Inc_X, Fortran.Real (Beta),
|
||||
Conv_Y (Y'Address).all, Inc_Y);
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
subtype A_Type is
|
||||
Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
subtype X_Type is Double_Precision_Vector (X'Range);
|
||||
type Y_Ptr is access all Double_Precision_Vector (Y'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
|
||||
function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
|
||||
function Conv_Y is new Unchecked_Conversion (Address, Y_Ptr);
|
||||
begin
|
||||
dgemv (Trans, M, N, Double_Precision (Alpha),
|
||||
Conv_A (A), Ld_A, Conv_X (X), Inc_X,
|
||||
Double_Precision (Beta),
|
||||
Conv_Y (Y'Address).all, Inc_Y);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_Y : Double_Precision_Vector (Y'Range);
|
||||
begin
|
||||
if Beta /= 0.0 then
|
||||
DP_Y := To_Double_Precision (Y);
|
||||
end if;
|
||||
|
||||
dgemv (Trans, M, N, Double_Precision (Alpha),
|
||||
To_Double_Precision (A), Ld_A,
|
||||
To_Double_Precision (X), Inc_X, Double_Precision (Beta),
|
||||
DP_Y, Inc_Y);
|
||||
|
||||
Y := To_Real (DP_Y);
|
||||
end;
|
||||
end if;
|
||||
end gemv;
|
||||
|
||||
----------
|
||||
-- nrm2 --
|
||||
----------
|
||||
|
||||
function nrm2
|
||||
(N : Natural;
|
||||
X : Real_Vector;
|
||||
Inc_X : Integer := 1) return Real
|
||||
is
|
||||
begin
|
||||
if Is_Single then
|
||||
declare
|
||||
subtype X_Type is BLAS.Real_Vector (X'Range);
|
||||
function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
|
||||
begin
|
||||
return Real (snrm2 (N, Conv_X (X), Inc_X));
|
||||
end;
|
||||
|
||||
elsif Is_Double then
|
||||
declare
|
||||
subtype X_Type is Double_Precision_Vector (X'Range);
|
||||
function Conv_X is new Unchecked_Conversion (Real_Vector, X_Type);
|
||||
begin
|
||||
return Real (dnrm2 (N, Conv_X (X), Inc_X));
|
||||
end;
|
||||
|
||||
else
|
||||
return Real (dnrm2 (N, To_Double_Precision (X), Inc_X));
|
||||
end if;
|
||||
end nrm2;
|
||||
|
||||
end System.Generic_Real_BLAS;
|
||||
|
|
@ -1,96 +0,0 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- 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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
|
|
@ -1,564 +0,0 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- SYSTEM.GENERIC_REAL_LAPACK --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2009, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Unchecked_Conversion; use Ada;
|
||||
with Interfaces; use Interfaces;
|
||||
with Interfaces.Fortran; use Interfaces.Fortran;
|
||||
with Interfaces.Fortran.BLAS; use Interfaces.Fortran.BLAS;
|
||||
with Interfaces.Fortran.LAPACK; use Interfaces.Fortran.LAPACK;
|
||||
with System.Generic_Array_Operations; use System.Generic_Array_Operations;
|
||||
|
||||
package body System.Generic_Real_LAPACK is
|
||||
|
||||
Is_Real : constant Boolean :=
|
||||
Real'Machine_Mantissa = Fortran.Real'Machine_Mantissa
|
||||
and then Fortran.Real (Real'First) = Fortran.Real'First
|
||||
and then Fortran.Real (Real'Last) = Fortran.Real'Last;
|
||||
|
||||
Is_Double_Precision : constant Boolean :=
|
||||
Real'Machine_Mantissa =
|
||||
Double_Precision'Machine_Mantissa
|
||||
and then
|
||||
Double_Precision (Real'First) =
|
||||
Double_Precision'First
|
||||
and then
|
||||
Double_Precision (Real'Last) =
|
||||
Double_Precision'Last;
|
||||
|
||||
-- Local subprograms
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision;
|
||||
pragma Inline_Always (To_Double_Precision);
|
||||
|
||||
function To_Real (X : Double_Precision) return Real;
|
||||
pragma Inline_Always (To_Real);
|
||||
|
||||
-- Instantiations
|
||||
|
||||
function To_Double_Precision is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Real,
|
||||
Result_Scalar => Double_Precision,
|
||||
X_Vector => Real_Vector,
|
||||
Result_Vector => Double_Precision_Vector,
|
||||
Operation => To_Double_Precision);
|
||||
|
||||
function To_Real is new
|
||||
Vector_Elementwise_Operation
|
||||
(X_Scalar => Double_Precision,
|
||||
Result_Scalar => Real,
|
||||
X_Vector => Double_Precision_Vector,
|
||||
Result_Vector => Real_Vector,
|
||||
Operation => To_Real);
|
||||
|
||||
function To_Double_Precision is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Real,
|
||||
Result_Scalar => Double_Precision,
|
||||
X_Matrix => Real_Matrix,
|
||||
Result_Matrix => Double_Precision_Matrix,
|
||||
Operation => To_Double_Precision);
|
||||
|
||||
function To_Real is new
|
||||
Matrix_Elementwise_Operation
|
||||
(X_Scalar => Double_Precision,
|
||||
Result_Scalar => Real,
|
||||
X_Matrix => Double_Precision_Matrix,
|
||||
Result_Matrix => Real_Matrix,
|
||||
Operation => To_Real);
|
||||
|
||||
function To_Double_Precision (X : Real) return Double_Precision is
|
||||
begin
|
||||
return Double_Precision (X);
|
||||
end To_Double_Precision;
|
||||
|
||||
function To_Real (X : Double_Precision) return Real is
|
||||
begin
|
||||
return Real (X);
|
||||
end To_Real;
|
||||
|
||||
-----------
|
||||
-- getrf --
|
||||
-----------
|
||||
|
||||
procedure getrf
|
||||
(M : Natural;
|
||||
N : Natural;
|
||||
A : in out Real_Matrix;
|
||||
Ld_A : Positive;
|
||||
I_Piv : out Integer_Vector;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Real then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
begin
|
||||
sgetrf (M, N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv), Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double_Precision then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
begin
|
||||
dgetrf (M, N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv), Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
begin
|
||||
DP_A := To_Double_Precision (A);
|
||||
dgetrf (M, N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv), Info);
|
||||
A := To_Real (DP_A);
|
||||
end;
|
||||
end if;
|
||||
end getrf;
|
||||
|
||||
-----------
|
||||
-- getri --
|
||||
-----------
|
||||
|
||||
procedure getri
|
||||
(N : Natural;
|
||||
A : in out Real_Matrix;
|
||||
Ld_A : Positive;
|
||||
I_Piv : Integer_Vector;
|
||||
Work : in out Real_Vector;
|
||||
L_Work : Integer;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Real then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
|
||||
type Work_Ptr is
|
||||
access all BLAS.Real_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
sgetri (N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double_Precision then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
type Work_Ptr is
|
||||
access all Double_Precision_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
dgetri (N, Conv_A (A'Address).all, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
DP_Work : Double_Precision_Vector (Work'Range);
|
||||
begin
|
||||
DP_A := To_Double_Precision (A);
|
||||
dgetri (N, DP_A, Ld_A, LAPACK.Integer_Vector (I_Piv),
|
||||
DP_Work, L_Work, Info);
|
||||
A := To_Real (DP_A);
|
||||
Work (1) := To_Real (DP_Work (1));
|
||||
end;
|
||||
end if;
|
||||
end getri;
|
||||
|
||||
-----------
|
||||
-- getrs --
|
||||
-----------
|
||||
|
||||
procedure getrs
|
||||
(Trans : access constant Character;
|
||||
N : Natural;
|
||||
N_Rhs : Natural;
|
||||
A : Real_Matrix;
|
||||
Ld_A : Positive;
|
||||
I_Piv : Integer_Vector;
|
||||
B : in out Real_Matrix;
|
||||
Ld_B : Positive;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Real then
|
||||
declare
|
||||
subtype A_Type is BLAS.Real_Matrix (A'Range (1), A'Range (2));
|
||||
type B_Ptr is
|
||||
access all BLAS.Real_Matrix (B'Range (1), B'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
|
||||
function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
|
||||
begin
|
||||
sgetrs (Trans, N, N_Rhs,
|
||||
Conv_A (A), Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_B (B'Address).all, Ld_B,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double_Precision then
|
||||
declare
|
||||
subtype A_Type is
|
||||
Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
type B_Ptr is
|
||||
access all Double_Precision_Matrix (B'Range (1), B'Range (2));
|
||||
function Conv_A is new Unchecked_Conversion (Real_Matrix, A_Type);
|
||||
function Conv_B is new Unchecked_Conversion (Address, B_Ptr);
|
||||
begin
|
||||
dgetrs (Trans, N, N_Rhs,
|
||||
Conv_A (A), Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
Conv_B (B'Address).all, Ld_B,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
DP_B : Double_Precision_Matrix (B'Range (1), B'Range (2));
|
||||
begin
|
||||
DP_A := To_Double_Precision (A);
|
||||
DP_B := To_Double_Precision (B);
|
||||
dgetrs (Trans, N, N_Rhs,
|
||||
DP_A, Ld_A,
|
||||
LAPACK.Integer_Vector (I_Piv),
|
||||
DP_B, Ld_B,
|
||||
Info);
|
||||
B := To_Real (DP_B);
|
||||
end;
|
||||
end if;
|
||||
end getrs;
|
||||
|
||||
-----------
|
||||
-- orgtr --
|
||||
-----------
|
||||
|
||||
procedure orgtr
|
||||
(Uplo : access constant Character;
|
||||
N : Natural;
|
||||
A : in out Real_Matrix;
|
||||
Ld_A : Positive;
|
||||
Tau : Real_Vector;
|
||||
Work : out Real_Vector;
|
||||
L_Work : Integer;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Real then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
|
||||
subtype Tau_Type is BLAS.Real_Vector (Tau'Range);
|
||||
type Work_Ptr is
|
||||
access all BLAS.Real_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_Tau is
|
||||
new Unchecked_Conversion (Real_Vector, Tau_Type);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
sorgtr (Uplo, N,
|
||||
Conv_A (A'Address).all, Ld_A,
|
||||
Conv_Tau (Tau),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double_Precision then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
subtype Tau_Type is Double_Precision_Vector (Tau'Range);
|
||||
type Work_Ptr is
|
||||
access all Double_Precision_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_Tau is
|
||||
new Unchecked_Conversion (Real_Vector, Tau_Type);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
dorgtr (Uplo, N,
|
||||
Conv_A (A'Address).all, Ld_A,
|
||||
Conv_Tau (Tau),
|
||||
Conv_Work (Work'Address).all, L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
DP_Work : Double_Precision_Vector (Work'Range);
|
||||
DP_Tau : Double_Precision_Vector (Tau'Range);
|
||||
begin
|
||||
DP_A := To_Double_Precision (A);
|
||||
DP_Tau := To_Double_Precision (Tau);
|
||||
dorgtr (Uplo, N, DP_A, Ld_A, DP_Tau, DP_Work, L_Work, Info);
|
||||
A := To_Real (DP_A);
|
||||
Work (1) := To_Real (DP_Work (1));
|
||||
end;
|
||||
end if;
|
||||
end orgtr;
|
||||
|
||||
-----------
|
||||
-- steqr --
|
||||
-----------
|
||||
|
||||
procedure steqr
|
||||
(Comp_Z : access constant Character;
|
||||
N : Natural;
|
||||
D : in out Real_Vector;
|
||||
E : in out Real_Vector;
|
||||
Z : in out Real_Matrix;
|
||||
Ld_Z : Positive;
|
||||
Work : out Real_Vector;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Real then
|
||||
declare
|
||||
type D_Ptr is access all BLAS.Real_Vector (D'Range);
|
||||
type E_Ptr is access all BLAS.Real_Vector (E'Range);
|
||||
type Z_Ptr is
|
||||
access all BLAS.Real_Matrix (Z'Range (1), Z'Range (2));
|
||||
type Work_Ptr is
|
||||
access all BLAS.Real_Vector (Work'Range);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
ssteqr (Comp_Z, N,
|
||||
Conv_D (D'Address).all,
|
||||
Conv_E (E'Address).all,
|
||||
Conv_Z (Z'Address).all,
|
||||
Ld_Z,
|
||||
Conv_Work (Work'Address).all,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double_Precision then
|
||||
declare
|
||||
type D_Ptr is access all Double_Precision_Vector (D'Range);
|
||||
type E_Ptr is access all Double_Precision_Vector (E'Range);
|
||||
type Z_Ptr is
|
||||
access all Double_Precision_Matrix (Z'Range (1), Z'Range (2));
|
||||
type Work_Ptr is
|
||||
access all Double_Precision_Vector (Work'Range);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
function Conv_Z is new Unchecked_Conversion (Address, Z_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
dsteqr (Comp_Z, N,
|
||||
Conv_D (D'Address).all,
|
||||
Conv_E (E'Address).all,
|
||||
Conv_Z (Z'Address).all,
|
||||
Ld_Z,
|
||||
Conv_Work (Work'Address).all,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_D : Double_Precision_Vector (D'Range);
|
||||
DP_E : Double_Precision_Vector (E'Range);
|
||||
DP_Z : Double_Precision_Matrix (Z'Range (1), Z'Range (2));
|
||||
DP_Work : Double_Precision_Vector (Work'Range);
|
||||
begin
|
||||
DP_D := To_Double_Precision (D);
|
||||
DP_E := To_Double_Precision (E);
|
||||
|
||||
if Comp_Z.all = 'V' then
|
||||
DP_Z := To_Double_Precision (Z);
|
||||
end if;
|
||||
|
||||
dsteqr (Comp_Z, N, DP_D, DP_E, DP_Z, Ld_Z, DP_Work, Info);
|
||||
|
||||
D := To_Real (DP_D);
|
||||
E := To_Real (DP_E);
|
||||
Z := To_Real (DP_Z);
|
||||
end;
|
||||
end if;
|
||||
end steqr;
|
||||
|
||||
-----------
|
||||
-- sterf --
|
||||
-----------
|
||||
|
||||
procedure sterf
|
||||
(N : Natural;
|
||||
D : in out Real_Vector;
|
||||
E : in out Real_Vector;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Real then
|
||||
declare
|
||||
type D_Ptr is access all BLAS.Real_Vector (D'Range);
|
||||
type E_Ptr is access all BLAS.Real_Vector (E'Range);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
begin
|
||||
ssterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double_Precision then
|
||||
declare
|
||||
type D_Ptr is access all Double_Precision_Vector (D'Range);
|
||||
type E_Ptr is access all Double_Precision_Vector (E'Range);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
begin
|
||||
dsterf (N, Conv_D (D'Address).all, Conv_E (E'Address).all, Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_D : Double_Precision_Vector (D'Range);
|
||||
DP_E : Double_Precision_Vector (E'Range);
|
||||
|
||||
begin
|
||||
DP_D := To_Double_Precision (D);
|
||||
DP_E := To_Double_Precision (E);
|
||||
|
||||
dsterf (N, DP_D, DP_E, Info);
|
||||
|
||||
D := To_Real (DP_D);
|
||||
E := To_Real (DP_E);
|
||||
end;
|
||||
end if;
|
||||
end sterf;
|
||||
|
||||
-----------
|
||||
-- sytrd --
|
||||
-----------
|
||||
|
||||
procedure sytrd
|
||||
(Uplo : access constant Character;
|
||||
N : Natural;
|
||||
A : in out Real_Matrix;
|
||||
Ld_A : Positive;
|
||||
D : out Real_Vector;
|
||||
E : out Real_Vector;
|
||||
Tau : out Real_Vector;
|
||||
Work : out Real_Vector;
|
||||
L_Work : Integer;
|
||||
Info : access Integer)
|
||||
is
|
||||
begin
|
||||
if Is_Real then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all BLAS.Real_Matrix (A'Range (1), A'Range (2));
|
||||
type D_Ptr is access all BLAS.Real_Vector (D'Range);
|
||||
type E_Ptr is access all BLAS.Real_Vector (E'Range);
|
||||
type Tau_Ptr is access all BLAS.Real_Vector (Tau'Range);
|
||||
type Work_Ptr is
|
||||
access all BLAS.Real_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
ssytrd (Uplo, N,
|
||||
Conv_A (A'Address).all, Ld_A,
|
||||
Conv_D (D'Address).all,
|
||||
Conv_E (E'Address).all,
|
||||
Conv_Tau (Tau'Address).all,
|
||||
Conv_Work (Work'Address).all,
|
||||
L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
elsif Is_Double_Precision then
|
||||
declare
|
||||
type A_Ptr is
|
||||
access all Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
type D_Ptr is access all Double_Precision_Vector (D'Range);
|
||||
type E_Ptr is access all Double_Precision_Vector (E'Range);
|
||||
type Tau_Ptr is access all Double_Precision_Vector (Tau'Range);
|
||||
type Work_Ptr is
|
||||
access all Double_Precision_Vector (Work'Range);
|
||||
function Conv_A is new Unchecked_Conversion (Address, A_Ptr);
|
||||
function Conv_D is new Unchecked_Conversion (Address, D_Ptr);
|
||||
function Conv_E is new Unchecked_Conversion (Address, E_Ptr);
|
||||
function Conv_Tau is new Unchecked_Conversion (Address, Tau_Ptr);
|
||||
function Conv_Work is new Unchecked_Conversion (Address, Work_Ptr);
|
||||
begin
|
||||
dsytrd (Uplo, N,
|
||||
Conv_A (A'Address).all, Ld_A,
|
||||
Conv_D (D'Address).all,
|
||||
Conv_E (E'Address).all,
|
||||
Conv_Tau (Tau'Address).all,
|
||||
Conv_Work (Work'Address).all,
|
||||
L_Work,
|
||||
Info);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
DP_A : Double_Precision_Matrix (A'Range (1), A'Range (2));
|
||||
DP_D : Double_Precision_Vector (D'Range);
|
||||
DP_E : Double_Precision_Vector (E'Range);
|
||||
DP_Tau : Double_Precision_Vector (Tau'Range);
|
||||
DP_Work : Double_Precision_Vector (Work'Range);
|
||||
begin
|
||||
DP_A := To_Double_Precision (A);
|
||||
|
||||
dsytrd (Uplo, N, DP_A, Ld_A, DP_D, DP_E, DP_Tau,
|
||||
DP_Work, L_Work, Info);
|
||||
|
||||
if L_Work /= -1 then
|
||||
A := To_Real (DP_A);
|
||||
D := To_Real (DP_D);
|
||||
E := To_Real (DP_E);
|
||||
Tau := To_Real (DP_Tau);
|
||||
end if;
|
||||
|
||||
Work (1) := To_Real (DP_Work (1));
|
||||
end;
|
||||
end if;
|
||||
end sytrd;
|
||||
|
||||
end System.Generic_Real_LAPACK;
|
||||
|
|
@ -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 --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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;
|
||||
|
|
@ -10952,7 +10952,8 @@ package body Sem_Prag is
|
|||
|
||||
-- pragma Long_Float (D_Float | G_Float);
|
||||
|
||||
when Pragma_Long_Float =>
|
||||
when Pragma_Long_Float => Long_Float : declare
|
||||
begin
|
||||
GNAT_Pragma;
|
||||
Check_Valid_Configuration_Pragma;
|
||||
Check_Arg_Count (1);
|
||||
|
|
@ -10967,22 +10968,42 @@ package body Sem_Prag is
|
|||
|
||||
if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
|
||||
if Opt.Float_Format_Long = 'G' then
|
||||
Error_Pragma ("G_Float previously specified");
|
||||
end if;
|
||||
Error_Pragma_Arg
|
||||
("G_Float previously specified", Arg1);
|
||||
|
||||
Opt.Float_Format_Long := 'D';
|
||||
elsif Current_Sem_Unit /= Main_Unit
|
||||
and then Opt.Float_Format_Long /= 'D'
|
||||
then
|
||||
Error_Pragma_Arg
|
||||
("main unit not compiled with pragma Long_Float (D_Float)",
|
||||
"\pragma% must be used consistently for whole partition",
|
||||
Arg1);
|
||||
|
||||
else
|
||||
Opt.Float_Format_Long := 'D';
|
||||
end if;
|
||||
|
||||
-- G_Float case (this is the default, does not need overriding)
|
||||
|
||||
else
|
||||
if Opt.Float_Format_Long = 'D' then
|
||||
Error_Pragma ("D_Float previously specified");
|
||||
end if;
|
||||
|
||||
Opt.Float_Format_Long := 'G';
|
||||
elsif Current_Sem_Unit /= Main_Unit
|
||||
and then Opt.Float_Format_Long /= 'G'
|
||||
then
|
||||
Error_Pragma_Arg
|
||||
("main unit not compiled with pragma Long_Float (G_Float)",
|
||||
"\pragma% must be used consistently for whole partition",
|
||||
Arg1);
|
||||
|
||||
else
|
||||
Opt.Float_Format_Long := 'G';
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Set_Standard_Fpt_Formats;
|
||||
end Long_Float;
|
||||
|
||||
-----------------------
|
||||
-- Machine_Attribute --
|
||||
|
|
|
|||
|
|
@ -3993,39 +3993,59 @@ package body Sem_Warn is
|
|||
-- Case of assigned value never referenced
|
||||
|
||||
if No (N) then
|
||||
declare
|
||||
LA : constant Node_Id := Last_Assignment (Ent);
|
||||
|
||||
-- Don't give this for OUT and IN OUT formals, since
|
||||
-- clearly caller may reference the assigned value. Also
|
||||
-- never give such warnings for internal variables.
|
||||
begin
|
||||
-- Don't give this for OUT and IN OUT formals, since
|
||||
-- clearly caller may reference the assigned value. Also
|
||||
-- never give such warnings for internal variables.
|
||||
|
||||
if Ekind (Ent) = E_Variable
|
||||
and then not Is_Internal_Name (Chars (Ent))
|
||||
then
|
||||
if Referenced_As_Out_Parameter (Ent) then
|
||||
Error_Msg_NE
|
||||
("?& modified by call, but value never referenced",
|
||||
Last_Assignment (Ent), Ent);
|
||||
else
|
||||
Error_Msg_NE -- CODEFIX
|
||||
("?useless assignment to&, value never referenced!",
|
||||
Last_Assignment (Ent), Ent);
|
||||
if Ekind (Ent) = E_Variable
|
||||
and then not Is_Internal_Name (Chars (Ent))
|
||||
then
|
||||
-- Give appropriate message, distinguishing between
|
||||
-- assignment statements and out parameters.
|
||||
|
||||
if Nkind_In (Parent (LA), N_Procedure_Call_Statement,
|
||||
N_Parameter_Association)
|
||||
then
|
||||
Error_Msg_NE
|
||||
("?& modified by call, but value never "
|
||||
& "referenced", LA, Ent);
|
||||
|
||||
else
|
||||
Error_Msg_NE -- CODEFIX
|
||||
("?useless assignment to&, value never "
|
||||
& "referenced!", LA, Ent);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- Case of assigned value overwritten
|
||||
|
||||
else
|
||||
Error_Msg_Sloc := Sloc (N);
|
||||
declare
|
||||
LA : constant Node_Id := Last_Assignment (Ent);
|
||||
|
||||
if Referenced_As_Out_Parameter (Ent) then
|
||||
Error_Msg_NE
|
||||
("?& modified by call, but value overwritten #!",
|
||||
Last_Assignment (Ent), Ent);
|
||||
else
|
||||
Error_Msg_NE -- CODEFIX
|
||||
("?useless assignment to&, value overwritten #!",
|
||||
Last_Assignment (Ent), Ent);
|
||||
end if;
|
||||
begin
|
||||
Error_Msg_Sloc := Sloc (N);
|
||||
|
||||
-- Give appropriate message, distinguishing between
|
||||
-- assignment statements and out parameters.
|
||||
|
||||
if Nkind_In (Parent (LA), N_Procedure_Call_Statement,
|
||||
N_Parameter_Association)
|
||||
then
|
||||
Error_Msg_NE
|
||||
("?& modified by call, but value overwritten #!",
|
||||
LA, Ent);
|
||||
else
|
||||
Error_Msg_NE -- CODEFIX
|
||||
("?useless assignment to&, value overwritten #!",
|
||||
LA, Ent);
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Clear last assignment indication and we are done
|
||||
|
|
|
|||
Loading…
Reference in New Issue