181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#include <stdio.h> 281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#include <ctype.h> 381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#include <stdarg.h> 481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#include <string.h> 581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#include "cblas.h" 681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#include "cblas_test.h" 781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murrayvoid cblas_xerbla(int info, const char *rout, const char *form, ...) 981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray{ 1081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray extern int cblas_lerr, cblas_info, cblas_ok; 1181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray extern int link_xerbla; 1281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray extern int RowMajorStrg; 1381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray extern char *cblas_rout; 1481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 1581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray /* Initially, c__3chke will call this routine with 1681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * global variable link_xerbla=1, and F77_xerbla will set link_xerbla=0. 1781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * This is done to fool the linker into loading these subroutines first 1881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * instead of ones in the CBLAS or the legacy BLAS library. 1981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray */ 2081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (link_xerbla) return; 2181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 2281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (cblas_rout != NULL && strcmp(cblas_rout, rout) != 0){ 2381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray printf("***** XERBLA WAS CALLED WITH SRNAME = <%s> INSTEAD OF <%s> *******\n", rout, cblas_rout); 2481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray cblas_ok = FALSE; 2581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 2681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 2781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (RowMajorStrg) 2881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 2981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray /* To properly check leading dimension problems in cblas__gemm, we 3081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * need to do the following trick. When cblas__gemm is called with 3181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * CblasRowMajor, the arguments A and B switch places in the call to 3281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * f77__gemm. Thus when we test for bad leading dimension problems 3381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * for A and B, lda is in position 11 instead of 9, and ldb is in 3481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * position 9 instead of 11. 3581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray */ 3681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (strstr(rout,"gemm") != 0) 3781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 3881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info == 5 ) info = 4; 3981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 4 ) info = 5; 4081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 11) info = 9; 4181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 9 ) info = 11; 4281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 4381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) 4481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 4581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info == 5 ) info = 4; 4681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 4 ) info = 5; 4781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 4881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0) 4981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 5081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info == 7 ) info = 6; 5181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 6 ) info = 7; 5281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 5381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (strstr(rout,"gemv") != 0) 5481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 5581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info == 4) info = 3; 5681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 3) info = 4; 5781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 5881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (strstr(rout,"gbmv") != 0) 5981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 6081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info == 4) info = 3; 6181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 3) info = 4; 6281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 6) info = 5; 6381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 5) info = 6; 6481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 6581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (strstr(rout,"ger") != 0) 6681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 6781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info == 3) info = 2; 6881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 2) info = 3; 6981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 8) info = 6; 7081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 6) info = 8; 7181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 7281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if ( ( strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0 ) 7381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray && strstr(rout,"her2k") == 0 ) 7481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 7581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info == 8) info = 6; 7681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray else if (info == 6) info = 8; 7781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 7881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 7981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 8081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (info != cblas_info){ 8181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray printf("***** XERBLA WAS CALLED WITH INFO = %d INSTEAD OF %d in %s *******\n",info, cblas_info, rout); 8281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray cblas_lerr = PASSED; 8381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray cblas_ok = FALSE; 8481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } else cblas_lerr = FAILED; 8581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray} 8681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 8781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#ifdef F77_Char 8881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murrayvoid F77_xerbla(F77_Char F77_srname, void *vinfo) 8981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#else 9081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murrayvoid F77_xerbla(char *srname, void *vinfo) 9181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#endif 9281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray{ 9381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#ifdef F77_Char 9481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray char *srname; 9581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#endif 9681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 9781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; 9881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 9981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#ifdef F77_Integer 10081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray F77_Integer *info=vinfo; 10181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray F77_Integer i; 10281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray extern F77_Integer link_xerbla; 10381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#else 10481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray int *info=vinfo; 10581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray int i; 10681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray extern int link_xerbla; 10781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#endif 10881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#ifdef F77_Char 10981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray srname = F2C_STR(F77_srname, XerblaStrLen); 11081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray#endif 11181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 11281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray /* See the comment in cblas_xerbla() above */ 11381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray if (link_xerbla) 11481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray { 11581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray link_xerbla = 0; 11681253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray return; 11781253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray } 11881253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]); 11981253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; 12081253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray 12181253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray /* We increment *info by 1 since the CBLAS interface adds one more 12281253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray * argument to all level 2 and 3 routines. 12381253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray */ 12481253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray cblas_xerbla(*info+1,rout,""); 12581253e9afbc34b99e9adc22ddf33a1bfac56c697Tim Murray} 126