glas.precompiled.utility source code

1 /++
2 Copyright: Copyright © 2016-, Ilya Yaroshenko.
3 License: $(HTTP boost.org/LICENSE_1_0.txt, Boost License 1.0).
4 Authors: Ilya Yaroshenko
5 +/
6 module glas.precompiled.utility;
7 pragma(LDC_no_moduleinfo);
8 
9 import glas.ndslice;
10 import glas.fortran;
11 import ldc.attributes: weak;
12 import ldc.intrinsics: llvm_expect;
13 import std.experimental.ndslice.slice: Structure;
14 
15 extern(C) @system nothrow @nogc pragma(inline, false):
16 
17 
18 __gshared string[] _errors = [
19     "undefinded error", // 0
20     "unexpected flag", //1
21     "constraint: asl.length!1 == bsl.length!0",//2
22     "constraint: csl.length!0 == asl.length!0",//3
23     "constraint: csl.length!1 == bsl.length!1",//4
24     "constraint: abs(csl.stride!0) or abs(csl.stride!1) must be equal to 1",//5
25     "constraint: asl.length!0 == asl.length!1",//6
26     "constraint: abs(csl.stride!0) >= csl.length!0 || abs(csl.stride!1) >= csl.length!1",//7
27 ];
28 
29 string glas_error(int error_code)
30 {
31     if (error_code < _errors.length)
32         error_code = 0;
33     return _errors[error_code];
34 }
35 
36 int glas_validate_gemm_common(ref const Structure!2 as, ref const Structure!2 bs, ref const Structure!2 cs)
37 {
38     if (llvm_expect(as.lengths[1] != bs.lengths[0], false))
39         return 2;
40     if (llvm_expect(cs.lengths[0] != as.lengths[0], false))
41         return 3;
42     if (llvm_expect(cs.lengths[1] != bs.lengths[1], false))
43         return 4;
44     auto s0 = cs.strides[0] >= 0 ? cs.strides[0] : -cs.strides[0];
45     auto s1 = cs.strides[1] >= 0 ? cs.strides[1] : -cs.strides[1];
46     if (llvm_expect(s0 != 1 && s1 != 1, false))        
47         return 5;
48     if (llvm_expect(s0 < cs.lengths[0] && s1 < cs.lengths[1], false))
49         return 7;        
50     return 0;
51 }
52 
53 int glas_validate_gemm(Structure!2 as, Structure!2 bs, Structure!2 cs, ulong settings)
54 {
55     if (llvm_expect(settings & ~(ConjA | ConjB), false))
56         return 1;
57     if (auto ret = glas_validate_gemm_common(as, bs, cs))
58         return ret;
59     return 0;
60 }
61 
62 int glas_validate_symm(Structure!2 as, Structure!2 bs, Structure!2 cs, ulong settings)
63 {
64     if (llvm_expect(settings & ~(ConjA | ConjB | Left | Right | Upper | Lower), false))
65         return 1;
66     if (llvm_expect(as.lengths[0] != as.lengths[1], false))
67         return 6;
68     if (auto ret = glas_validate_gemm_common(as, bs, cs))
69         return ret;
70     return 0;
71 }
72 
73 /* -- LAPACK auxiliary routine (preliminary version) -- */
74 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
75 /* Courant Institute, Argonne National Lab, and Rice University */
76 /* February 29, 1992 */
77 /* .. Scalar Arguments .. */
78 /* .. */
79 /* Purpose */
80 /* ======= */
81 /* XERBLA is an error handler for the LAPACK routines. */
82 /* It is called by an LAPACK routine if an input parameter has an */
83 /* invalid value. A message is printed and execution stops. */
84 /* Installers may consider modifying the STOP statement in order to */
85 /* call system-specific exception-handling facilities. */
86 /* Arguments */
87 /* ========= */
88 /* SRNAME (input) CHARACTER*6 */
89 /* The name of the routine which called XERBLA. */
90 /* INFO (input) INTEGER */
91 /* The position of the invalid parameter in the parameter list */
92 /* of the calling routine. */
93 @weak int xerbla_(in char* srname, ref FortranInt info)
94 {
95     import core.stdc.stdio;
96     printf("** On entry to %6s, parameter number %2i had an illegal value\n", srname, info);
97     return 0;
98 }