LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
c_xerbla.c
Go to the documentation of this file.
1#include <stdio.h>
2#include <ctype.h>
3#include <stdarg.h>
4#include <string.h>
5#include "cblas.h"
6#include "cblas_test.h"
7
8void cblas_xerbla(CBLAS_INT info, const char *rout, const char *form, ...)
9{
10 extern int cblas_lerr, cblas_info, cblas_ok;
11 extern int link_xerbla;
12 extern int RowMajorStrg;
13 extern char *cblas_rout;
14
15 /* Initially, c__3chke may call this routine with
16 * global variable link_xerbla=1, and F77_xerbla will set link_xerbla=0.
17 * This is done to fool the linker into loading these subroutines first
18 * instead of ones in the CBLAS or the legacy BLAS library.
19 */
20 if (link_xerbla) return;
21
22 if (cblas_rout != NULL && strcmp(cblas_rout, rout) != 0){
23 printf("***** XERBLA WAS CALLED WITH SRNAME = <%s> INSTEAD OF <%s> *******\n", rout, cblas_rout);
25 }
26
27 if (RowMajorStrg)
28 {
29 /* To properly check leading dimension problems in cblas__gemm, we
30 * need to do the following trick. When cblas__gemm is called with
31 * CblasRowMajor, the arguments A and B switch places in the call to
32 * f77__gemm. Thus when we test for bad leading dimension problems
33 * for A and B, lda is in position 11 instead of 9, and ldb is in
34 * position 9 instead of 11.
35 */
36 if (strstr(rout,"gemm") != 0)
37 {
38 if (info == 5 ) info = 4;
39 else if (info == 4 ) info = 5;
40 else if (info == 11) info = 9;
41 else if (info == 9 ) info = 11;
42 }
43 else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0)
44 {
45 if (info == 5 ) info = 4;
46 else if (info == 4 ) info = 5;
47 }
48 else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0)
49 {
50 if (info == 7 ) info = 6;
51 else if (info == 6 ) info = 7;
52 }
53 else if (strstr(rout,"gemv") != 0)
54 {
55 if (info == 4) info = 3;
56 else if (info == 3) info = 4;
57 }
58 else if (strstr(rout,"gbmv") != 0)
59 {
60 if (info == 4) info = 3;
61 else if (info == 3) info = 4;
62 else if (info == 6) info = 5;
63 else if (info == 5) info = 6;
64 }
65 else if (strstr(rout,"ger") != 0)
66 {
67 if (info == 3) info = 2;
68 else if (info == 2) info = 3;
69 else if (info == 8) info = 6;
70 else if (info == 6) info = 8;
71 }
72 else if ( ( strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0 )
73 && strstr(rout,"her2k") == 0 )
74 {
75 if (info == 8) info = 6;
76 else if (info == 6) info = 8;
77 }
78 }
79
80 if (info != cblas_info){
81 printf("***** XERBLA WAS CALLED WITH INFO = %" CBLAS_IFMT " INSTEAD OF %d in %s *******\n",info, cblas_info, rout);
84 } else cblas_lerr = FAILED;
85}
86
87#ifdef F77_Char
88void F77_xerbla(F77_Char F77_srname, void *vinfo)
89#else
90void F77_xerbla(char *srname, void *vinfo)
91#endif
92{
93#ifdef F77_Char
94 char *srname;
95#endif
96
97 char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'};
98
99#ifdef F77_Integer
100 F77_Integer *info=vinfo;
101 F77_Integer i;
102 extern F77_Integer link_xerbla;
103#else
104 int *info=vinfo;
105 int i;
106 extern int link_xerbla;
107#endif
108#ifdef F77_Char
109 srname = F2C_STR(F77_srname, XerblaStrLen);
110#endif
111
112 /* See the comment in cblas_xerbla() above */
113 if (link_xerbla)
114 {
115 link_xerbla = 0;
116 return;
117 }
118 for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]);
119 for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0';
120
121 /* We increment *info by 1 since the CBLAS interface adds one more
122 * argument to all level 2 and 3 routines.
123 */
124 cblas_xerbla(*info+1,rout,"");
125}
int link_xerbla
Definition: c_c2chke.c:7
int cblas_lerr
Definition: c_c2chke.c:6
int cblas_info
Definition: c_c2chke.c:6
int cblas_ok
Definition: c_c2chke.c:6
char * cblas_rout
Definition: c_c2chke.c:8
void cblas_xerbla(CBLAS_INT info, const char *rout, const char *form,...)
Definition: c_xerbla.c:8
#define CBLAS_IFMT
Definition: cblas.h:35
#define CBLAS_INT
Definition: cblas.h:24
#define F77_xerbla(...)
Definition: cblas_f77.h:548
int RowMajorStrg
Definition: cblas_globals.c:2
#define FAILED
Definition: cblas_test.h:15
#define FALSE
Definition: cblas_test.h:14
#define PASSED
Definition: cblas_test.h:11
#define XerblaStrLen
Definition: xerbla.c:6