-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>
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
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) \
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) \
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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 (<>);
+
+function Ada.Strings.Bounded.Equal_Case_Insensitive
+ (Left, Right : Bounded.Bounded_String)
+ return Boolean;
-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;
+pragma Preelaborate (Ada.Strings.Bounded.Equal_Case_Insensitive);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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.
-
--- This unit is not implemented in this GNAT configuration
+with Ada.Containers;
-package Interfaces.Fortran.BLAS is
+generic
+ with package Bounded is
+ new Ada.Strings.Bounded.Generic_Bounded_Length (<>);
- pragma Unimplemented_Unit;
+function Ada.Strings.Bounded.Hash_Case_Insensitive
+ (Key : Bounded.Bounded_String)
+ return Containers.Hash_Type;
-end Interfaces.Fortran.BLAS;
+pragma Preelaborate (Ada.Strings.Bounded.Hash_Case_Insensitive);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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);
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 \
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 \
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
$(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
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
("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
-- 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
---------------------------
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- 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);
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);
+
+ 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);
- Opt.Float_Format_Long := 'D';
+ 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 --
-- 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
projects / thirdparty / gcc.git / commitdiff
