int clapack_zgeqrf (const enum CBLAS_ORDER Order, ATL_CINT M, ATL_CINT N, void *A, ATL_CINT lda, void *TAU) { int ierr=0; if (Order != CblasRowMajor && Order != CblasColMajor) { ierr = -1; cblas_xerbla(1, "clapack_zgeqrf", "Order must be %d or %d, but is set to %d\n", CblasRowMajor, CblasColMajor, Order); } if (M < 0) { ierr = -2; cblas_xerbla(2, "clapack_zgeqrf", "M cannot be less than zero 0,; is set to %d.\n", M); } if (N < 0) { ierr = -3; cblas_xerbla(3, "clapack_zgeqrf", "N cannot be less than zero 0,; is set to %d.\n", N); } if (Order == CblasColMajor) { if (lda < M || lda < 1) { ierr = -5; cblas_xerbla(5, "clapack_zgeqrf", "lda must be >= MAX(M,1): lda=%d M=%d\n", lda, M); } } else { if (lda < N || lda < 1) { ierr = -5; cblas_xerbla(5, "clapack_zgeqrf", "lda must be >= MAX(N,1): lda=%d N=%d\n", lda, N); } } if (ierr) return(ierr); if (Order == CblasColMajor) return(ATL_zgeqrf(M, N, A, lda, TAU, NULL, 0)); else return(ATL_zgelqf(N, M, A, lda, TAU, NULL, 0)); }
void F77_xerbla(char *srname, void *vinfo) #endif { #ifdef F77_CHAR char *srname; #endif char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; int *info=vinfo; int i; extern int CBLAS_CallFromC; #ifdef F77_CHAR srname = F2C_STR(F77_srname, XerblaStrLen); #endif if (CBLAS_CallFromC) { for(i=0; i != XerblaStrLen; i++) rout[i+6] = tolower(srname[i]); rout[XerblaStrLen+6] = '\0'; cblas_xerbla(*info+1,rout,""); } else { fprintf(stderr, "Parameter %d to routine %s was incorrect\n", *info, srname); } }
void cblas_sspr(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const int N, const float alpha, const float *X, const int incX, float *A) { int info = 2000; #define x X #ifndef NoCblasErrorChecks if (Order != CblasColMajor && Order != CblasRowMajor) info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(2, info, "UPLO must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (!incX) info = cblas_errprn(6, info, "incX cannot be zero; is set to %d.", incX); if (info != 2000) { cblas_xerbla(info, "cblas_sspr", ""); return; } #endif if (incX < 0) x += (1-N)*incX; if (Order == CblasColMajor) ATL_sspr(Uplo, N, alpha, x, incX, A); else ATL_sspr(( (Uplo == CblasUpper) ? CblasLower : CblasUpper ), N, alpha, x, incX, A); }
void cblas_dger(const enum CBLAS_ORDER order, const int M, const int N, const double alpha, const double *X, const int incX, const double *Y, const int incY, double *A, const int lda) { #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; #else #define F77_M M #define F77_N N #define F77_incX incX #define F77_incY incY #define F77_lda lda #endif if (order == CblasColMajor) { F77_dger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (order == CblasRowMajor) { F77_dger( &F77_N, &F77_M ,&alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_dger", "Illegal Order setting, %d\n", order); return; }
void cblas_zgeru(const enum CBLAS_ORDER order, const integer M, const integer N, const void *alpha, const void *X, const integer incX, const void *Y, const integer incY, void *A, const integer lda) { #define F77_M M #define F77_N N #define F77_incX incX #define F77_incY incY #define F77_lda lda extern integer CBLAS_CallFromC; extern integer RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { zgeru_( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (order == CblasRowMajor) { RowMajorStrg = 1; zgeru_( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_zgeru", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
void cblas_sger(enum CBLAS_ORDER order, f77_int M, f77_int N, const float alpha, const float *X, f77_int incX, const float *Y, f77_int incY, float *A, f77_int lda) { #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; #else #define F77_M M #define F77_N N #define F77_incX incX #define F77_incY incY #define F77_lda lda #endif extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { F77_sger( &F77_M, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (order == CblasRowMajor) { RowMajorStrg = 1; F77_sger( &F77_N, &F77_M, &alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_sger", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
void cblas_dger2(const enum CBLAS_ORDER Order, ATL_CINT M, ATL_CINT N, const double alpha, const double *X, ATL_CINT incX, const double *Y, ATL_CINT incY, const double beta, const double *W, ATL_CINT incW, const double *Z, ATL_CINT incZ, double *A, ATL_CINT lda) { int info = 2000; #define x X #define y Y #define w W #define z Z #ifndef NoCblasErrorChecks if (M < 0) info = cblas_errprn(2, info, "M cannot be less than zero; is set to %d.", M); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (!incX) info = cblas_errprn(6, info, "incX cannot be zero; is set to %d.", incX); if (!incY) info = cblas_errprn(8, info, "incY cannot be zero; is set to %d.", incY); if (!incW) info = cblas_errprn(11, info, "incW cannot be zero; is set to %d.", incW); if (!incZ) info = cblas_errprn(13, info, "incZ cannot be zero; is set to %d.", incZ); if (Order == CblasColMajor) { if (lda < M || lda < 1) info = cblas_errprn(15, info, "lda must be >= MAX(M,1): lda=%d M=%d", lda, M); } else if (Order == CblasRowMajor) { if (lda < N || lda < 1) info = cblas_errprn(15, info, "lda must be >= MAX(N,1): lda=%d M=%d", lda, N); } else info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (info != 2000) { cblas_xerbla(info, "cblas_dger2", ""); return; } #endif if (incX < 0) x += (1-M)*incX; if (incY < 0) y += (1-N)*incY; if (incW < 0) w += (1-M)*incW; if (incZ < 0) z += (1-N)*incZ; if (Order == CblasColMajor) ATL_dger2(M, N, alpha, x, incX, y, incY, beta, w, incW, z, incZ, A, lda); else ATL_dger2(N, M, alpha, y, incY, x, incX, beta, w, incW, z, incZ, A, lda); }
void cblas_zgerc(const enum CBLAS_ORDER Order, const int M, const int N, const void *alpha, const void *X, const int incX, const void *Y, const int incY, void *A, const int lda) { int info = 2000; const double *x = X, *y = Y; void *vy; double *y0; double one[2] = {ATL_rone, ATL_rzero}; #ifndef NoCblasErrorChecks if (M < 0) info = cblas_errprn(2, info, "M cannot be less than zero; is set to %d.", M); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (!incX) info = cblas_errprn(6, info, "incX cannot be zero; is set to %d.", incX); if (!incY) info = cblas_errprn(8, info, "incY cannot be zero; is set to %d.", incY); if (Order == CblasColMajor) { if (lda < M || lda < 1) info = cblas_errprn(10, info, "lda must be >= MAX(M,1): lda=%d M=%d", lda, M); } else if (Order == CblasRowMajor) { if (lda < N || lda < 1) info = cblas_errprn(10, info, "lda must be >= MAX(N,1): lda=%d M=%d", lda, N); } else info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (info != 2000) { cblas_xerbla(info, "cblas_zgerc", ""); return; } #endif if (incX < 0) x += (1-M)*incX<<1; if (incY < 0) y += (1-N)*incY<<1; if (Order == CblasColMajor) ATL_zgerc(M, N, alpha, x, incX, y, incY, A, lda); else { vy = malloc(ATL_Cachelen + ATL_MulBySize(N)); ATL_assert(vy); y0 = ATL_AlignPtr(vy); ATL_zmoveConj(N, alpha, y, incY, y0, 1); ATL_zgeru(N, M, one, y0, 1, x, incX, A, lda); free(vy); } }
void cblas_cher2(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const int N, const void *alpha, const void *X, const int incX, const void *Y, const int incY, void *A, const int lda) { int info = 2000; void *vx, *vy; float *x0, *y0; const float *x=X, *y=Y, *alp=alpha; const float one[2]={ATL_rone, ATL_rzero}; #ifndef NoCblasErrorChecks if (Order != CblasColMajor && Order != CblasRowMajor) info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(2, info, "UPLO must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (!incX) info = cblas_errprn(6, info, "incX cannot be zero; is set to %d.", incX); if (!incY) info = cblas_errprn(8, info, "incY cannot be zero; is set to %d.", incY); if (lda < N || lda < 1) info = cblas_errprn(10, info, "lda must be >= MAX(N,1): lda=%d N=%d", lda, N); if (info != 2000) { cblas_xerbla(info, "cblas_cher2", ""); return; } #endif if (incX < 0) x += (1-N)*incX<<1; if (incY < 0) y += (1-N)*incY<<1; if (Order == CblasColMajor) ATL_cher2(Uplo, N, alpha, x, incX, y, incY, A, lda); else if (alp[0] != ATL_rzero || alp[1] != ATL_rzero) { vx = malloc(ATL_Cachelen + ATL_MulBySize(N)); vy = malloc(ATL_Cachelen + ATL_MulBySize(N)); ATL_assert(vx != NULL && vy != NULL); x0 = ATL_AlignPtr(vx); y0 = ATL_AlignPtr(vy); ATL_cmoveConj(N, alpha, y, incY, y0, 1); ATL_ccopyConj(N, x, incX, x0, 1); ATL_cher2(( (Uplo == CblasUpper) ? CblasLower : CblasUpper ), N, one, y0, 1, x0, 1, A, lda); free(vx); free(vy); } else ATL_cher2(( (Uplo == CblasUpper) ? CblasLower : CblasUpper ), N, alpha, y, incY, x, incX, A, lda); }
int clapack_strtri(const enum ATLAS_ORDER Order, const enum ATLAS_UPLO Uplo, const enum ATLAS_DIAG Diag, const int N, float *A, const int lda) { int ierr; if (Order != CblasRowMajor && Order != CblasColMajor) { ierr = -1; cblas_xerbla(1, "clapack_strtri", "Order must be %d or %d, but is set to %d\n", CblasRowMajor, CblasColMajor, Order); } if (Uplo != CblasUpper && Uplo != CblasLower) { ierr = -2; cblas_xerbla(2, "clapack_strtri", "Uplo must be %d or %d, but is set to %d\n", CblasUpper, CblasLower, Uplo); } if (Diag != CblasUnit && Diag != CblasNonUnit) { ierr = -3; cblas_xerbla(3, "clapack_strtri", "Diag must be %d or %d, but is set to %d\n", CblasNonUnit, CblasUnit, Diag); } if (N < 0) { ierr = -4; cblas_xerbla(4, "clapack_strtri", "N cannot be less than zero 0,; is set to %d.\n", N); } if (lda < N || lda < 1) { ierr = -6; cblas_xerbla(6, "clapack_strtri", "lda must be >= MAX(N,1): lda=%d N=%d\n", lda, N); } if (ierr) ierr = ATL_strtri(Order, Uplo, Diag, N, A, lda); return(ierr); }
void cblas_ctbmv(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TA, const enum CBLAS_DIAG Diag, const int N, const int K, const void *A, const int lda, void *X, const int incX) { int info = 2000; enum CBLAS_UPLO uplo; enum CBLAS_TRANSPOSE ta; float *x = X; #ifndef NoCblasErrorChecks if (Order != CblasColMajor && Order != CblasRowMajor) info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(2, info, "UPLO must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (TA != CblasNoTrans && TA != CblasTrans && TA != CblasConjTrans) info = cblas_errprn(3, info, "TransA must be %d, %d or %d, but is set to %d", CblasNoTrans, CblasTrans, CblasConjTrans, TA); if (Diag != CblasUnit && Diag != CblasNonUnit) info = cblas_errprn(4, info, "DIAG must be %d or %d, but is set to %d", CblasUnit, CblasNonUnit, Diag); if (N < 0) info = cblas_errprn(5, info, "N cannot be less than zero; is set to %d.", N); if (K < 0) info = cblas_errprn(6, info, "Valid K: 0 < K < N; K=%d, N=%d.", K, N); if (lda < K+1) info = cblas_errprn(8, info, "lda must be >= K+1: lda=%d K=%d", lda, K); if (!incX) info = cblas_errprn(10, info, "incX cannot be zero; is set to %d.", incX); if (info != 2000) { cblas_xerbla(info, "cblas_ctbmv", ""); return; } #endif if (incX < 0) x += (1-N)*incX<<1; if (Order == CblasColMajor) ATL_ctbmv(Uplo, TA, Diag, N, K, A, lda, x, incX); else { uplo = ( (Uplo == CblasUpper) ? CblasLower : CblasUpper ); if (TA == CblasNoTrans) ta = CblasTrans; else if (TA == CblasConjTrans) ta = AtlasConj; else ta = CblasNoTrans; ATL_ctbmv(uplo, ta, Diag, N, K, A, lda, x, incX); } }
void sgemv_( const char* trans, const int* m, const int* n, const float* alpha, const float* A, const int* ldA, const float* X, const int* incX, const float* beta, float* Y, const int* incY ) { /* It is safe to use the original SGEMV if we are not using AVX on Mavericks * or the input arrays A, X and Y are all aligned on 32 byte boundaries. */ #define BADARRAY(x) (((npy_intp)(void*)x) % 32) const int use_sgemm = AVX_and_10_9 && (BADARRAY(A) || BADARRAY(X) || BADARRAY(Y)); if (!use_sgemm) { accelerate_sgemv(trans,m,n,alpha,A,ldA,X,incX,beta,Y,incY); return; } /* Arrays are misaligned, the CPU supports AVX, and we are running * Mavericks. * * Emulation of SGEMV with SGEMM: * * SGEMV allows vectors to be strided. SGEMM requires all arrays to be * contiguous along the leading dimension. To emulate striding in SGEMV * with the leading dimension arguments in SGEMM we compute * * Y = alpha * op(A) @ X + beta * Y * * as * * Y.T = alpha * X.T @ op(A).T + beta * Y.T * * Because Fortran uses column major order and X.T and Y.T are row vectors, * the leading dimensions of X.T and Y.T in SGEMM become equal to the * strides of the the column vectors X and Y in SGEMV. */ switch (*trans) { case 'T': case 't': case 'C': case 'c': accelerate_cblas_sgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 1, *n, *m, *alpha, X, *incX, A, *ldA, *beta, Y, *incY ); break; case 'N': case 'n': accelerate_cblas_sgemm( CblasColMajor, CblasNoTrans, CblasTrans, 1, *m, *n, *alpha, X, *incX, A, *ldA, *beta, Y, *incY ); break; default: cblas_xerbla(1, "SGEMV", "Illegal transpose setting: %c\n", *trans); } }
void cblas_dtrmv(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TA, const enum CBLAS_DIAG Diag, const int N, const double *A, const int lda, double *X, const int incX) { int info = 2000; enum CBLAS_UPLO uplo; enum CBLAS_TRANSPOSE ta; #define x X #ifndef NoCblasErrorChecks if (Order != CblasColMajor && Order != CblasRowMajor) info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(2, info, "UPLO must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (TA != CblasNoTrans && TA != CblasTrans && TA != CblasConjTrans) info = cblas_errprn(3, info, "TransA must be %d, %d or %d, but is set to %d", CblasNoTrans, CblasTrans, CblasConjTrans, TA); if (Diag != CblasUnit && Diag != CblasNonUnit) info = cblas_errprn(4, info, "DIAG must be %d or %d, but is set to %d", CblasUnit, CblasNonUnit, Diag); if (N < 0) info = cblas_errprn(5, info, "N cannot be less than zero; is set to %d.", N); if (lda < N || lda < 1) info = cblas_errprn(7, info, "lda must be >= MAX(N,1): lda=%d N=%d", lda, N); if (!incX) info = cblas_errprn(9, info, "incX cannot be zero; is set to %d.", incX); if (info != 2000) { cblas_xerbla(info, "cblas_dtrmv", ""); return; } #endif if (incX < 0) x += (1-N)*incX; if (Order == CblasColMajor) ATL_dtrmv(Uplo, TA, Diag, N, A, lda, x, incX); else { uplo = ( (Uplo == CblasUpper) ? CblasLower : CblasUpper ); if (TA == CblasNoTrans) ta = CblasTrans; else ta = CblasNoTrans; ATL_dtrmv(uplo, ta, Diag, N, A, lda, x, incX); } }
void cblas_zher(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const int N, const double alpha, const void *X, const int incX, void *A, const int lda) { int info = 2000; void *vx; double one[2] = {ATL_rone, ATL_rzero}; double *x0; const double *x=X; #ifndef NoCblasErrorChecks if (Order != CblasColMajor && Order != CblasRowMajor) info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(2, info, "UPLO must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (!incX) info = cblas_errprn(6, info, "incX cannot be zero; is set to %d.", incX); if (lda < N || lda < 1) info = cblas_errprn(8, info, "lda must be >= MAX(N,1): lda=%d N=%d", lda, N); if (info != 2000) { cblas_xerbla(info, "cblas_zher", ""); return; } #endif if (incX < 0) x += (1-N)*incX<<1; if (Order == CblasColMajor) ATL_zher(Uplo, N, alpha, x, incX, A, lda); else if (alpha != ATL_rzero) { vx = malloc(ATL_Cachelen + ATL_MulBySize(N)); ATL_assert(vx); x0 = ATL_AlignPtr(vx); ATL_zmoveConj(N, one, x, incX, x0, 1); ATL_zher(( (Uplo == CblasUpper) ? CblasLower : CblasUpper ), N, alpha, x0, 1, A, lda); free(vx); } else ATL_zher(( (Uplo == CblasUpper) ? CblasLower : CblasUpper ), N, ATL_rzero, x, incX, A, lda); }
void cblas_sger (const enum CBLAS_ORDER Order, const int M, const int N, const float alpha, const float *X, const int incX, const float *Y, const int incY, float *A, const int lda) { int info = 2000; #define x X #define y Y #ifndef NoCblasErrorChecks if (M < 0) info = cblas_errprn(2, info, "M cannot be less than zero; is set to %d.", M); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (!incX) info = cblas_errprn(6, info, "incX cannot be zero; is set to %d.", incX); if (!incY) info = cblas_errprn(8, info, "incY cannot be zero; is set to %d.", incY); if (Order == CblasColMajor) { if (lda < M || lda < 1) info = cblas_errprn(10, info, "lda must be >= MAX(M,1): lda=%d M=%d", lda, M); } else if (Order == CblasRowMajor) { if (lda < N || lda < 1) info = cblas_errprn(10, info, "lda must be >= MAX(N,1): lda=%d M=%d", lda, N); } else info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (info != 2000) { cblas_xerbla(info, "cblas_sger", ""); return; } #endif if (incX < 0) x += (1-M)*incX; if (incY < 0) y += (1-N)*incY; if (Order == CblasColMajor) ATL_sger(M, N, alpha, x, incX, y, incY, A, lda); else ATL_sger(N, M, alpha, y, incY, x, incX, A, lda); }
void cblas_dsbmv(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const int N, const int K, const double alpha, const double *A, const int lda, const double *X, const int incX, const double beta, double *Y, const int incY) { int info = 2000; const enum CBLAS_UPLO ruplo = (Uplo == CblasUpper) ? CblasLower : CblasUpper; #define x X #define y Y #ifndef NoCblasErrorChecks if (Order != CblasColMajor && Order != CblasRowMajor) info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(2, info, "Uplo must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (K < 0) info = cblas_errprn(4, info, "Valid K: 0 < K < N; K=%d, N=%d.", K, N); if (lda < K+1) info = cblas_errprn(7, info, "lda cannot be less than K+1; K=%d, lda=%d\n", K, lda); if (!incX) info = cblas_errprn(9, info, "incX cannot be zero; is set to %d.", incX); if (!incY) info = cblas_errprn(12, info, "incY cannot be zero; is set to %d.", incY); if (info != 2000) { cblas_xerbla(info, "cblas_dsbmv", ""); return; } #endif if (incX < 0) x += (1-N)*incX; if (incY < 0) y += (1-N)*incY; if (Order == CblasColMajor) ATL_dsbmv(Uplo, N, K, alpha, A, lda, x, incX, beta, y, incY); else ATL_dsbmv(ruplo, N, K, alpha, A, lda, x, incX, beta, y, incY); }
void cblas_ssyr2(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo, const int N, const float alpha, const float *X, const int incX, const float *Y, const int incY, float *A, const int lda) { int info = 2000; #define x X #define y Y #ifndef NoCblasErrorChecks if (Order != CblasColMajor && Order != CblasRowMajor) info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(2, info, "UPLO must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (N < 0) info = cblas_errprn(3, info, "N cannot be less than zero; is set to %d.", N); if (!incX) info = cblas_errprn(6, info, "incX cannot be zero; is set to %d.", incX); if (!incY) info = cblas_errprn(8, info, "incY cannot be zero; is set to %d.", incY); if (lda < N || lda < 1) info = cblas_errprn(10, info, "lda must be >= MAX(N,1): lda=%d N=%d", lda, N); if (info != 2000) { cblas_xerbla(info, "cblas_ssyr2", ""); return; } #endif if (incX < 0) x += (1-N)*incX; if (incY < 0) y += (1-N)*incY; if (Order == CblasColMajor) ATL_ssyr2(Uplo, N, alpha, x, incX, y, incY, A, lda); else ATL_ssyr2(( (Uplo == CblasUpper) ? CblasLower : CblasUpper ), N, alpha, y, incY, x, incX, A, lda); }
int clapack_cposv(const enum ATLAS_ORDER Order, const enum ATLAS_UPLO Uplo, const int N, const int NRHS, void *A, const int lda, void *B, const int ldb) { int ierr = 0; if (Order != CblasRowMajor && Order != CblasColMajor) { ierr = -1; cblas_xerbla(1, "clapack_cposv", "Order must be %d or %d, but is set to %d\n", CblasRowMajor, CblasColMajor, Order); } if (Uplo != CblasUpper && Uplo != CblasLower) { ierr = -2; cblas_xerbla(2, "clapack_cposv", "Uplo must be %d or %d, but is set to %d\n", CblasUpper, CblasLower, Uplo); } if (N < 0) { ierr = -3; cblas_xerbla(3, "clapack_cposv", "N cannot be less than zero 0,; is set to %d.\n", N); } if (NRHS < 0) { ierr = -4; cblas_xerbla(4, "clapack_cposv", "NRHS cannot be less than zero 0,; is set to %d.\n", NRHS); } if (lda < N || lda < 1) { ierr = -6; cblas_xerbla(6, "clapack_cposv", "lda must be >= MAX(N,1): lda=%d N=%d\n", lda, N); } if (ldb < N || ldb < 1) { ierr = -8; cblas_xerbla(8, "clapack_cposv", "ldb must be >= MAX(N,1): ldb=%d N=%d\n", ldb, N); } if (!ierr) ierr = ATL_cpotrf(Order, Uplo, N, A, lda); if (!ierr) ATL_cpotrs(Order, Uplo, N, NRHS, A, lda, B, ldb); return(ierr); }
int clapack_dgetrs (const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE Trans, const int N, const int NRHS, const double *A, const int lda, const int *ipiv, double *B, const int ldb) { int ierr=0; if (Order != CblasRowMajor && Order != CblasColMajor) { ierr = -1; cblas_xerbla(1, "clapack_dgetrs", "Order must be %d or %d, but is set to %d\n", CblasRowMajor, CblasColMajor, Order); } if (Trans != CblasNoTrans && Trans != CblasTrans && Trans != CblasConjTrans) { ierr = -2; cblas_xerbla(2, "clapack_dgetrs", "Trans must be %d, %d, or %d, but is set to %d\n", CblasNoTrans, CblasTrans, CblasConjTrans); } if (N < 0) { ierr = -3; cblas_xerbla(3, "clapack_dgetrs", "N cannot be less than zero 0,; is set to %d.\n", N); } if (NRHS < 0) { ierr = -4; cblas_xerbla(4, "clapack_dgetrs", "NRHS cannot be less than zero 0,; is set to %d.\n", NRHS); } if (lda < N || lda < 1) { ierr = -6; cblas_xerbla(6, "clapack_dgetrs", "lda must be >= MAX(N,1): lda=%d N=%d\n", lda, N); } if (ldb < N || ldb < 1) { ierr = -9; cblas_xerbla(9, "clapack_dgetrs", "ldb must be >= MAX(N,1): lda=%d N=%d\n", lda, N); } if (!ierr) ATL_dgetrs(Order, Trans, N, NRHS, A, lda, ipiv, B, ldb); return(ierr); }
void cblas_cgeru(const CBLAS_LAYOUT layout, const int M, const int N, const void *alpha, const void *X, const int incX, const void *Y, const int incY, void *A, const int lda) { #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; #else #define F77_M M #define F77_N N #define F77_incX incX #define F77_incY incY #define F77_lda lda #endif extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (layout == CblasColMajor) { F77_cgeru( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; F77_cgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_cgeru","Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
void F77_xerbla(char *srname, void *vinfo) #endif { #ifdef F77_Char char *srname; #endif char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; #ifdef F77_Integer F77_Integer *info=vinfo; F77_Integer i; extern F77_Integer link_xerbla; #else int *info=vinfo; int i; extern int link_xerbla; #endif #ifdef F77_Char srname = F2C_STR(F77_srname, XerblaStrLen); #endif /* See the comment in cblas_xerbla() above */ if (link_xerbla) { link_xerbla = 0; return; } for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]); for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; /* We increment *info by 1 since the CBLAS interface adds one more * argument to all level 2 and 3 routines. */ cblas_xerbla(*info+1,rout,""); }
int clapack_sgetri(const enum CBLAS_ORDER Order, const int N, float *A, const int lda, const int *ipiv) { int ierr=0, lwrk; int Mjoin(PATL,GetNB)(); void *vp; lwrk = Mjoin(PATL,GetNB)(); if (lwrk <= N) lwrk *= N; else lwrk = N*N; vp = malloc(ATL_Cachelen + ATL_MulBySize(lwrk)); if (vp) { ierr = ATL_getri(Order, N, A, lda, ipiv, ATL_AlignPtr(vp), &lwrk); free(vp); } else { cblas_xerbla(7, "clapack_sgetri", "Cannot allocate workspace of %d\n", lwrk); return(-7); } return(ierr); }
void cblas_zher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const CBLAS_INT_TYPE N, const double alpha, const void *X, const CBLAS_INT_TYPE incX ,void *A, const CBLAS_INT_TYPE lda) { char UL; #ifdef F77_CHAR F77_CHAR F77_UL; #else #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; #else #define F77_N N #define F77_lda lda #define F77_incX incx #endif CBLAS_INT_TYPE n, i, tincx, incx=incX; double *x=(double *)X, *xx=(double *)X, *tx, *st; if (order == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; else { cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n",Uplo ); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_zher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); } else if (order == CblasRowMajor) { if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n", Uplo); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif if (N > 0) { n = N << 1; x = malloc(n*sizeof(double)); tx = x; if( incX > 0 ) { i = incX << 1 ; tincx = 2; st= x+n; } else { i = incX *(-2); tincx = -2; st = x-2; x +=(n-2); } do { *x = *xx; x[1] = -xx[1]; x += tincx ; xx += i; } while (x != st); x=tx; #ifdef F77_INT F77_incX = 1; #else incx = 1; #endif } else x = (double *) X; F77_zher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); } else cblas_xerbla(1, "cblas_zher", "Illegal Order setting, %d\n", order); if(X!=x) free(x); return; }
void cblas_strmv(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, const int N, const float *A, const int lda, float *X, const int incX) { char TA; char UL; char DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_DI; #else #define F77_TA &TA #define F77_UL &UL #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; #else #define F77_N N #define F77_lda lda #define F77_incX incX #endif extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (layout == CblasColMajor) { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; else { cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; else { cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_strmv","Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) TA = 'N'; else { cblas_xerbla(3, "cblas_strmv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_strmv","Illegal Diag setting, %d\n", Diag); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_strmv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); } else cblas_xerbla(1, "cblas_strmv", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
void cblas_cgerc(const enum CBLAS_ORDER order, const int M, const int N, const void *alpha, const void *X, const int incX, const void *Y, const int incY, void *A, const int lda) { #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; #else #define F77_M M #define F77_N N #define F77_incX incX #define F77_incY incy #define F77_lda lda #endif int n, i, tincy, incy=incY; float *y=(float *)Y, *yy=(float *)Y, *ty, *st; if (order == CblasColMajor) { F77_cgerc( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (order == CblasRowMajor) { if (N > 0) { n = N << 1; y = malloc(n*sizeof(float)); ty = y; if( incY > 0 ) { i = incY << 1; tincy = 2; st= y+n; } else { i = incY *(-2); tincy = -2; st = y-2; y +=(n-2); } do { *y = *yy; y[1] = -yy[1]; y += tincy ; yy += i; } while (y != st); y = ty; #ifdef F77_INT F77_incY = 1; #else incy = 1; #endif } else y = (float *) Y; F77_cgeru( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A, &F77_lda); if(Y!=y) free(y); } else cblas_xerbla(1, "cblas_cgerc", "Illegal Order setting, %d\n", order); return; }
void cblas_ztrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag, const int N, const void *A, const int lda, void *X, const int incX) { char TA; char UL; char DI; #ifdef F77_CHAR F77_CHAR F77_TA, F77_UL, F77_DI; #else #define F77_TA &TA #define F77_UL &UL #define F77_DI &DI #endif #ifdef F77_INT F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; #else #define F77_N N #define F77_lda lda #define F77_incX incX #endif int n, i=0, tincX; double *st=0,*x=(double *)X; if (order == CblasColMajor) { if (Uplo == CblasUpper) UL = 'U'; else if (Uplo == CblasLower) UL = 'L'; else { cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); return; } if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; else { cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); } else if (order == CblasRowMajor) { if (Uplo == CblasUpper) UL = 'L'; else if (Uplo == CblasLower) UL = 'U'; else { cblas_xerbla(2, "cblas_ztrsv","Illegal Uplo setting, %d\n", Uplo); return; } if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) { TA = 'N'; if ( N > 0) { if ( incX > 0 ) tincX = incX; else tincX = -incX; n = N*2*(tincX); x++; st=x+n; i = tincX << 1; do { *x = -(*x); x+=i; } while (x != st); x -= n; } } else { cblas_xerbla(3, "cblas_ztrsv","Illegal TransA setting, %d\n", TransA); return; } if (Diag == CblasUnit) DI = 'U'; else if (Diag == CblasNonUnit) DI = 'N'; else { cblas_xerbla(4, "cblas_ztrsv","Illegal Diag setting, %d\n", Diag); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_TA = C2F_CHAR(&TA); F77_DI = C2F_CHAR(&DI); #endif F77_ztrsv( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X, &F77_incX); if (TransA == CblasConjTrans) { if (N > 0) { do { *x = -(*x); x += i; } while (x != st); } } } else cblas_xerbla(1, "cblas_ztrsv", "Illegal Order setting, %d\n", order); return; }
void cblas_ssyr2(enum CBLAS_ORDER order, enum CBLAS_UPLO Uplo, f77_int N, const float alpha, const float *X, f77_int incX, const float *Y, f77_int incY, float *A, f77_int lda) { char UL; #ifdef F77_CHAR F77_CHAR F77_UL; #else #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77_lda=lda; #else #define F77_N N #define F77_incX incX #define F77_incY incY #define F77_lda lda #endif extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { if (Uplo == CblasLower) UL = 'L'; else if (Uplo == CblasUpper) UL = 'U'; else { cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else if (order == CblasRowMajor) { RowMajorStrg = 1; if (Uplo == CblasLower) UL = 'U'; else if (Uplo == CblasUpper) UL = 'L'; else { cblas_xerbla(2, "cblas_ssyr2","Illegal Uplo setting, %d\n",Uplo ); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); #endif F77_ssyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, &F77_lda); } else cblas_xerbla(1, "cblas_ssyr2", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
void cblas_ctrmm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, const enum CBLAS_UPLO Uplo, const enum CBLAS_TRANSPOSE TA, const enum CBLAS_DIAG Diag, const int M, const int N, const void * alpha, const void *A, const int lda, void *B, const int ldb) { enum CBLAS_SIDE side; enum CBLAS_UPLO uplo; int info=2000; #ifndef NoCblasErrorChecks if (Order == CblasColMajor) { if (Side == CblasLeft) { if ( (lda < M) || (lda < 1) ) info = cblas_errprn(10, info,"lda must be >= MAX(M,1): lda=%d M=%d", lda, M); } else if (Side == CblasRight) { if ( (lda < N) || (lda < 1) ) info = cblas_errprn(10, info,"lda must be >= MAX(N,1): lda=%d N=%d", lda, N); } else info = cblas_errprn(2, info, "SIDE must be %d or %d, but is set to %d", CblasRight, CblasLeft, Side); if ( (ldb < M) || (ldb < 1) ) info = cblas_errprn(12, info, "ldb must be >= MAX(M,1): ldb=%d M=%d", ldb, M); } else if (Order == CblasRowMajor) { if (Side == CblasLeft) { if ( (lda < M) || (lda < 1) ) info = cblas_errprn(10, info,"lda must be >= MAX(M,1): lda=%d M=%d", lda, M); } else if (Side == CblasRight) { if ( (lda < N) || (lda < 1) ) info = cblas_errprn(10, info,"lda must be >= MAX(N,1): lda=%d N=%d", lda, N); } else info = cblas_errprn(2, info, "SIDE must be %d or %d, but is set to %d", CblasRight, CblasLeft, Side); if ( (ldb < N) || (ldb < 1) ) info = cblas_errprn(12, info, "ldb must be >= MAX(N,1): ldb=%d N=%d", ldb, N); } else info = cblas_errprn(1, info, "Order must be %d or %d, but is set to %d", CblasRowMajor, CblasColMajor, Order); if (Uplo != CblasUpper && Uplo != CblasLower) info = cblas_errprn(3, info, "UPLO must be %d or %d, but is set to %d", CblasUpper, CblasLower, Uplo); if (TA != AtlasNoTrans && TA != AtlasTrans && TA != AtlasConjTrans) info = cblas_errprn(4, info, "TransA must be %d, %d or %d, but is set to %d", CblasNoTrans, CblasTrans, CblasConjTrans, TA); if (Diag != CblasUnit && Diag != CblasNonUnit) info = cblas_errprn(5, info, "UPLO must be %d or %d, but is set to %d", CblasUnit, CblasNonUnit, Diag); if (M < 0) info = cblas_errprn(6, info, "M cannot be less than zero; it is set to %d.", M); if (N < 0) info = cblas_errprn(7, info, "N cannot be less than zero; it is set to %d.", N); if (info != 2000) { cblas_xerbla(info, "cblas_ctrmm", ""); return; } #endif if (Order == CblasColMajor) ATL_ctrmm(Side, Uplo, TA, Diag, M, N, alpha, A, lda, B, ldb); else { if (Side == CblasLeft) side = CblasRight; else side = CblasLeft; if (Uplo == CblasUpper) uplo = CblasLower; else uplo = CblasUpper; ATL_ctrmm(side, uplo, TA, Diag, N, M, alpha, A, lda, B, ldb); } }
void cblas_cgemv(const enum CBLAS_ORDER order, const enum CBLAS_TRANSPOSE TransA, const int M, const int N, const void *alpha, const void *A, const int lda, const void *X, const int incX, const void *beta, void *Y, const int incY) { char TA; #ifdef F77_CHAR F77_CHAR F77_TA; #else #define F77_TA &TA #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; #else #define F77_M M #define F77_N N #define F77_lda lda #define F77_incX incx #define F77_incY incY #endif int n=0, i=0; const float *xx= (const float *)X; float ALPHA[2],BETA[2]; int tincY, tincx; float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0; const float *stx = x; extern int CBLAS_CallFromC; extern int RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if (order == CblasColMajor) { if (TransA == CblasNoTrans) TA = 'N'; else if (TransA == CblasTrans) TA = 'T'; else if (TransA == CblasConjTrans) TA = 'C'; else { cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif F77_cgemv(F77_TA, &F77_M, &F77_N, alpha, A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY); } else if (order == CblasRowMajor) { RowMajorStrg = 1; if (TransA == CblasNoTrans) TA = 'T'; else if (TransA == CblasTrans) TA = 'N'; else if (TransA == CblasConjTrans) { ALPHA[0]= *( (const float *) alpha ); ALPHA[1]= -( *( (const float *) alpha+1) ); BETA[0]= *( (const float *) beta ); BETA[1]= -( *( (const float *) beta+1 ) ); TA = 'N'; if (M > 0) { n = M << 1; x = malloc(n*sizeof(float)); tx = x; if( incX > 0 ) { i = incX << 1 ; tincx = 2; st= x+n; } else { i = incX *(-2); tincx = -2; st = x-2; x +=(n-2); } do { *x = *xx; x[1] = -xx[1]; x += tincx ; xx += i; } while (x != st); x=tx; F77_incX = 1; if(incY > 0) tincY = incY; else tincY = -incY; y++; if (N > 0) { i = tincY << 1; n = i * N ; st = y + n; do { *y = -(*y); y += i; } while(y != st); y -= n; } stx = x; } else stx = (const float *)X; } else { cblas_xerbla(2, "cblas_cgemv","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_TA = C2F_CHAR(&TA); #endif if (TransA == CblasConjTrans) F77_cgemv(F77_TA, &F77_N, &F77_M, ALPHA, A, &F77_lda, stx, &F77_incX, BETA, Y, &F77_incY); else F77_cgemv(F77_TA, &F77_N, &F77_M, alpha, A, &F77_lda, x, &F77_incX, beta, Y, &F77_incY); if (TransA == CblasConjTrans) { if (x != (const float *)X) free(x); if (N > 0) { do { *y = -(*y); y += i; } while (y != st); } } } else cblas_xerbla(1, "cblas_cgemv", "Illegal Order setting, %d\n", order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }
void cblas_zhemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, const enum CBLAS_UPLO Uplo, const int M, const int N, const void *alpha, const void *A, const int lda, const void *B, const int ldb, const void *beta, void *C, const int ldc) { char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else #define F77_SD &SD #define F77_UL &UL #endif #ifdef F77_INT F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; F77_INT F77_ldc=ldc; #else #define F77_M M #define F77_N N #define F77_lda lda #define F77_ldb ldb #define F77_ldc ldc #endif if( Order == CblasColMajor ) { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; else { cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); return; } if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; else { cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_SD = C2F_CHAR(&SD); #endif F77_zhemm(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else if (Order == CblasRowMajor) { if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; else { cblas_xerbla(2, "cblas_zhemm", "Illegal Side setting, %d\n", Side); return; } if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; else { cblas_xerbla(3, "cblas_zhemm", "Illegal Uplo setting, %d\n", Uplo); return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_SD = C2F_CHAR(&SD); #endif F77_zhemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else cblas_xerbla(1, "cblas_zhemm", "Illegal Order setting, %d\n", Order); return; }