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 8 void 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 88 void F77_xerbla(F77_Char F77_srname, void *vinfo) 89 #else 90 void 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
