1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- SYSTEM.GENERIC_REAL_BLAS --
9 -- Copyright (C) 2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada
.Unchecked_Conversion
; use Ada
;
35 with Interfaces
; use Interfaces
;
36 with Interfaces
.Fortran
; use Interfaces
.Fortran
;
37 with Interfaces
.Fortran
.BLAS
; use Interfaces
.Fortran
.BLAS
;
38 with System
.Generic_Array_Operations
; use System
.Generic_Array_Operations
;
40 package body System
.Generic_Real_BLAS
is
42 Is_Single
: constant Boolean :=
43 Real
'Machine_Mantissa = Fortran
.Real
'Machine_Mantissa
44 and then Fortran
.Real
(Real
'First) = Fortran
.Real
'First
45 and then Fortran
.Real
(Real
'Last) = Fortran
.Real
'Last;
47 Is_Double
: constant Boolean :=
48 Real
'Machine_Mantissa = Double_Precision
'Machine_Mantissa
50 Double_Precision
(Real
'First) = Double_Precision
'First
52 Double_Precision
(Real
'Last) = Double_Precision
'Last;
56 function To_Double_Precision
(X
: Real
) return Double_Precision
;
57 pragma Inline_Always
(To_Double_Precision
);
59 function To_Real
(X
: Double_Precision
) return Real
;
60 pragma Inline_Always
(To_Real
);
64 function To_Double_Precision
is new
65 Vector_Elementwise_Operation
67 Result_Scalar
=> Double_Precision
,
68 X_Vector
=> Real_Vector
,
69 Result_Vector
=> Double_Precision_Vector
,
70 Operation
=> To_Double_Precision
);
72 function To_Real
is new
73 Vector_Elementwise_Operation
74 (X_Scalar
=> Double_Precision
,
75 Result_Scalar
=> Real
,
76 X_Vector
=> Double_Precision_Vector
,
77 Result_Vector
=> Real_Vector
,
78 Operation
=> To_Real
);
80 function To_Double_Precision
is new
81 Matrix_Elementwise_Operation
83 Result_Scalar
=> Double_Precision
,
84 X_Matrix
=> Real_Matrix
,
85 Result_Matrix
=> Double_Precision_Matrix
,
86 Operation
=> To_Double_Precision
);
88 function To_Real
is new
89 Matrix_Elementwise_Operation
90 (X_Scalar
=> Double_Precision
,
91 Result_Scalar
=> Real
,
92 X_Matrix
=> Double_Precision_Matrix
,
93 Result_Matrix
=> Real_Matrix
,
94 Operation
=> To_Real
);
96 function To_Double_Precision
(X
: Real
) return Double_Precision
is
98 return Double_Precision
(X
);
99 end To_Double_Precision
;
101 function To_Real
(X
: Double_Precision
) return Real
is
113 Inc_X
: Integer := 1;
115 Inc_Y
: Integer := 1) return Real
120 type X_Ptr
is access all BLAS
.Real_Vector
(X
'Range);
121 type Y_Ptr
is access all BLAS
.Real_Vector
(Y
'Range);
122 function Conv_X
is new Unchecked_Conversion
(Address
, X_Ptr
);
123 function Conv_Y
is new Unchecked_Conversion
(Address
, Y_Ptr
);
125 return Real
(sdot
(N
, Conv_X
(X
'Address).all, Inc_X
,
126 Conv_Y
(Y
'Address).all, Inc_Y
));
131 type X_Ptr
is access all BLAS
.Double_Precision_Vector
(X
'Range);
132 type Y_Ptr
is access all BLAS
.Double_Precision_Vector
(Y
'Range);
133 function Conv_X
is new Unchecked_Conversion
(Address
, X_Ptr
);
134 function Conv_Y
is new Unchecked_Conversion
(Address
, Y_Ptr
);
136 return Real
(ddot
(N
, Conv_X
(X
'Address).all, Inc_X
,
137 Conv_Y
(Y
'Address).all, Inc_Y
));
141 return Real
(ddot
(N
, To_Double_Precision
(X
), Inc_X
,
142 To_Double_Precision
(Y
), Inc_Y
));
151 (Trans_A
: access constant Character;
152 Trans_B
: access constant Character;
162 C
: in out Real_Matrix
;
168 subtype A_Type
is BLAS
.Real_Matrix
(A
'Range (1), A
'Range (2));
169 subtype B_Type
is BLAS
.Real_Matrix
(B
'Range (1), B
'Range (2));
171 access all BLAS
.Real_Matrix
(C
'Range (1), C
'Range (2));
172 function Conv_A
is new Unchecked_Conversion
(Real_Matrix
, A_Type
);
173 function Conv_B
is new Unchecked_Conversion
(Real_Matrix
, B_Type
);
174 function Conv_C
is new Unchecked_Conversion
(Address
, C_Ptr
);
176 sgemm
(Trans_A
, Trans_B
, M
, N
, K
, Fortran
.Real
(Alpha
),
177 Conv_A
(A
), Ld_A
, Conv_B
(B
), Ld_B
, Fortran
.Real
(Beta
),
178 Conv_C
(C
'Address).all, Ld_C
);
184 Double_Precision_Matrix
(A
'Range (1), A
'Range (2));
186 Double_Precision_Matrix
(B
'Range (1), B
'Range (2));
188 access all Double_Precision_Matrix
(C
'Range (1), C
'Range (2));
189 function Conv_A
is new Unchecked_Conversion
(Real_Matrix
, A_Type
);
190 function Conv_B
is new Unchecked_Conversion
(Real_Matrix
, B_Type
);
191 function Conv_C
is new Unchecked_Conversion
(Address
, C_Ptr
);
193 dgemm
(Trans_A
, Trans_B
, M
, N
, K
, Double_Precision
(Alpha
),
194 Conv_A
(A
), Ld_A
, Conv_B
(B
), Ld_B
, Double_Precision
(Beta
),
195 Conv_C
(C
'Address).all, Ld_C
);
200 DP_C
: Double_Precision_Matrix
(C
'Range (1), C
'Range (2));
203 DP_C
:= To_Double_Precision
(C
);
206 dgemm
(Trans_A
, Trans_B
, M
, N
, K
, Double_Precision
(Alpha
),
207 To_Double_Precision
(A
), Ld_A
,
208 To_Double_Precision
(B
), Ld_B
, Double_Precision
(Beta
),
221 (Trans
: access constant Character;
228 Inc_X
: Integer := 1;
230 Y
: in out Real_Vector
;
231 Inc_Y
: Integer := 1)
236 subtype A_Type
is BLAS
.Real_Matrix
(A
'Range (1), A
'Range (2));
237 subtype X_Type
is BLAS
.Real_Vector
(X
'Range);
238 type Y_Ptr
is access all BLAS
.Real_Vector
(Y
'Range);
239 function Conv_A
is new Unchecked_Conversion
(Real_Matrix
, A_Type
);
240 function Conv_X
is new Unchecked_Conversion
(Real_Vector
, X_Type
);
241 function Conv_Y
is new Unchecked_Conversion
(Address
, Y_Ptr
);
243 sgemv
(Trans
, M
, N
, Fortran
.Real
(Alpha
),
244 Conv_A
(A
), Ld_A
, Conv_X
(X
), Inc_X
, Fortran
.Real
(Beta
),
245 Conv_Y
(Y
'Address).all, Inc_Y
);
251 Double_Precision_Matrix
(A
'Range (1), A
'Range (2));
252 subtype X_Type
is Double_Precision_Vector
(X
'Range);
253 type Y_Ptr
is access all Double_Precision_Vector
(Y
'Range);
254 function Conv_A
is new Unchecked_Conversion
(Real_Matrix
, A_Type
);
255 function Conv_X
is new Unchecked_Conversion
(Real_Vector
, X_Type
);
256 function Conv_Y
is new Unchecked_Conversion
(Address
, Y_Ptr
);
258 dgemv
(Trans
, M
, N
, Double_Precision
(Alpha
),
259 Conv_A
(A
), Ld_A
, Conv_X
(X
), Inc_X
,
260 Double_Precision
(Beta
),
261 Conv_Y
(Y
'Address).all, Inc_Y
);
266 DP_Y
: Double_Precision_Vector
(Y
'Range);
269 DP_Y
:= To_Double_Precision
(Y
);
272 dgemv
(Trans
, M
, N
, Double_Precision
(Alpha
),
273 To_Double_Precision
(A
), Ld_A
,
274 To_Double_Precision
(X
), Inc_X
, Double_Precision
(Beta
),
289 Inc_X
: Integer := 1) return Real
294 subtype X_Type
is BLAS
.Real_Vector
(X
'Range);
295 function Conv_X
is new Unchecked_Conversion
(Real_Vector
, X_Type
);
297 return Real
(snrm2
(N
, Conv_X
(X
), Inc_X
));
302 subtype X_Type
is Double_Precision_Vector
(X
'Range);
303 function Conv_X
is new Unchecked_Conversion
(Real_Vector
, X_Type
);
305 return Real
(dnrm2
(N
, Conv_X
(X
), Inc_X
));
309 return Real
(dnrm2
(N
, To_Double_Precision
(X
), Inc_X
));
313 end System
.Generic_Real_BLAS
;