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(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 will 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);
24      cblas_ok = FALSE;
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 = %d INSTEAD OF %d in %s *******\n",info, cblas_info, rout);
82      cblas_lerr = PASSED;
83      cblas_ok = FALSE;
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}
126