kusano 2b45e8
#include <stdio.h></stdio.h>
kusano 2b45e8
#include <ctype.h></ctype.h>
kusano 2b45e8
#include <stdarg.h></stdarg.h>
kusano 2b45e8
#include <string.h></string.h>
kusano 2b45e8
#include "common.h"
kusano 2b45e8
#include "cblas_test.h"
kusano 2b45e8
kusano 2b45e8
void cblas_xerbla(blasint info, char *rout, char *form, ...)
kusano 2b45e8
{
kusano 2b45e8
   extern int cblas_lerr, cblas_info, cblas_ok;
kusano 2b45e8
   extern int link_xerbla;
kusano 2b45e8
   extern int RowMajorStrg;
kusano 2b45e8
   extern char *cblas_rout;
kusano 2b45e8
   
kusano 2b45e8
   /* Initially, c__3chke will call this routine with 
kusano 2b45e8
    * global variable link_xerbla=1, and F77_xerbla will set link_xerbla=0. 
kusano 2b45e8
    * This is done to fool the linker into loading these subroutines first 
kusano 2b45e8
    * instead of ones in the CBLAS or the legacy BLAS library.
kusano 2b45e8
    */
kusano 2b45e8
   if (link_xerbla) return;
kusano 2b45e8
kusano 2b45e8
   if (cblas_rout != NULL && strcmp(cblas_rout, rout) != 0){
kusano 2b45e8
      printf("***** XERBLA WAS CALLED WITH SRNAME = <%s> INSTEAD OF <%s> *******\n", rout, cblas_rout);
kusano 2b45e8
      cblas_ok = FALSE;
kusano 2b45e8
   }
kusano 2b45e8
kusano 2b45e8
   if (RowMajorStrg)
kusano 2b45e8
   {
kusano 2b45e8
      /* To properly check leading dimension problems in cblas__gemm, we 
kusano 2b45e8
       * need to do the following trick. When cblas__gemm is called with 
kusano 2b45e8
       * CblasRowMajor, the arguments A and B switch places in the call to 
kusano 2b45e8
       * f77__gemm. Thus when we test for bad leading dimension problems 
kusano 2b45e8
       * for A and B, lda is in position 11 instead of 9, and ldb is in 
kusano 2b45e8
       * position 9 instead of 11.
kusano 2b45e8
       */
kusano 2b45e8
      if (strstr(rout,"gemm") != 0)
kusano 2b45e8
      {
kusano 2b45e8
         if      (info == 5 ) info =  4;
kusano 2b45e8
         else if (info == 4 ) info =  5;
kusano 2b45e8
         else if (info == 11) info =  9;
kusano 2b45e8
         else if (info == 9 ) info = 11;
kusano 2b45e8
      }
kusano 2b45e8
      else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0)
kusano 2b45e8
      {
kusano 2b45e8
         if      (info == 5 ) info =  4;
kusano 2b45e8
         else if (info == 4 ) info =  5;
kusano 2b45e8
      }
kusano 2b45e8
      else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0)
kusano 2b45e8
      {
kusano 2b45e8
         if      (info == 7 ) info =  6;
kusano 2b45e8
         else if (info == 6 ) info =  7;
kusano 2b45e8
      }
kusano 2b45e8
      else if (strstr(rout,"gemv") != 0)
kusano 2b45e8
      {
kusano 2b45e8
         if      (info == 4)  info = 3;
kusano 2b45e8
         else if (info == 3)  info = 4;
kusano 2b45e8
      }
kusano 2b45e8
      else if (strstr(rout,"gbmv") != 0)
kusano 2b45e8
      {
kusano 2b45e8
         if      (info == 4)  info = 3;
kusano 2b45e8
         else if (info == 3)  info = 4;
kusano 2b45e8
         else if (info == 6)  info = 5;
kusano 2b45e8
         else if (info == 5)  info = 6;
kusano 2b45e8
      }
kusano 2b45e8
      else if (strstr(rout,"ger") != 0)
kusano 2b45e8
      {
kusano 2b45e8
         if      (info == 3) info = 2;
kusano 2b45e8
         else if (info == 2) info = 3;
kusano 2b45e8
         else if (info == 8) info = 6;
kusano 2b45e8
         else if (info == 6) info = 8;
kusano 2b45e8
      }
kusano 2b45e8
      else if ( ( strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0 )
kusano 2b45e8
               && strstr(rout,"her2k") == 0 )
kusano 2b45e8
      {
kusano 2b45e8
         if      (info == 8) info = 6;
kusano 2b45e8
         else if (info == 6) info = 8;
kusano 2b45e8
      }
kusano 2b45e8
   }
kusano 2b45e8
kusano 2b45e8
   if (info != cblas_info){
kusano 2b45e8
      printf("***** XERBLA WAS CALLED WITH INFO = %d INSTEAD OF %d in %s *******\n",info, cblas_info, rout);
kusano 2b45e8
      cblas_lerr = PASSED;
kusano 2b45e8
      cblas_ok = FALSE;
kusano 2b45e8
   } else cblas_lerr = FAILED;
kusano 2b45e8
}
kusano 2b45e8
kusano 2b45e8
#ifdef F77_Char
kusano 2b45e8
void F77_xerbla(F77_Char F77_srname, void *vinfo)
kusano 2b45e8
#else
kusano 2b45e8
void F77_xerbla(char *srname, void *vinfo)
kusano 2b45e8
#endif
kusano 2b45e8
{
kusano 2b45e8
#ifdef F77_Char
kusano 2b45e8
   char *srname;
kusano 2b45e8
#endif
kusano 2b45e8
kusano 2b45e8
   char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'};
kusano 2b45e8
kusano 2b45e8
#ifdef F77_Integer
kusano 2b45e8
   F77_Integer *info=vinfo;
kusano 2b45e8
   F77_Integer i;
kusano 2b45e8
   extern F77_Integer link_xerbla;
kusano 2b45e8
#else
kusano 2b45e8
   int *info=vinfo;
kusano 2b45e8
   int i;
kusano 2b45e8
   extern int link_xerbla;
kusano 2b45e8
#endif
kusano 2b45e8
#ifdef F77_Char
kusano 2b45e8
   srname = F2C_STR(F77_srname, XerblaStrLen);
kusano 2b45e8
#endif
kusano 2b45e8
kusano 2b45e8
   /* See the comment in cblas_xerbla() above */
kusano 2b45e8
   if (link_xerbla)
kusano 2b45e8
   {
kusano 2b45e8
      link_xerbla = 0;
kusano 2b45e8
      return;
kusano 2b45e8
   }
kusano 2b45e8
   for(i=0;  i  < 6; i++) rout[i+6] = tolower(srname[i]);
kusano 2b45e8
   for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0';
kusano 2b45e8
   
kusano 2b45e8
   /* We increment *info by 1 since the CBLAS interface adds one more
kusano 2b45e8
    * argument to all level 2 and 3 routines.
kusano 2b45e8
    */
kusano 2b45e8
   cblas_xerbla(*info+1,rout,"");
kusano 2b45e8
}
kusano 2b45e8
kusano 2b45e8
#ifdef USE64BITINT
kusano 2b45e8
#undef int
kusano 2b45e8
#endif
kusano 2b45e8
kusano 2b45e8
int    BLASFUNC(xerbla)(char *name, blasint *info, blasint length) {
kusano 2b45e8
kusano 2b45e8
  F77_xerbla(name, info);
kusano 2b45e8
kusano 2b45e8
};
kusano 2b45e8
kusano 2b45e8