Commit 36fdfe68 authored by Davis King's avatar Davis King
Browse files

Added a copy of CBLAS so we can use it when linking against a BLAS that

doesn't have it.
parent 64c7e966
#
# This is a CMake makefile. You can find the cmake utility and
# information about it at http://www.cmake.org
#
cmake_minimum_required(VERSION 2.8.4)
project(cblas)
enable_language (Fortran)
set(CMAKE_POSITION_INDEPENDENT_CODE True)
add_definitions(-DADD_ -DF77_INT=ptrdiff_t)
add_library(cblas STATIC
cblas_caxpy.c
#cblas_ccopy.c
cblas_cdotc_sub.c
cblas_cdotu_sub.c
#cblas_cgbmv.c
cblas_cgemm.c
cblas_cgemv.c
cblas_cgerc.c
cblas_cgeru.c
#cblas_chbmv.c
#cblas_chemm.c
#cblas_chemv.c
#cblas_cher2.c
#cblas_cher2k.c
#cblas_cher.c
#cblas_cherk.c
#cblas_chpmv.c
#cblas_chpr2.c
#cblas_chpr.c
cblas_cscal.c
#cblas_csscal.c
#cblas_cswap.c
#cblas_csymm.c
#cblas_csyr2k.c
#cblas_csyrk.c
#cblas_ctbmv.c
#cblas_ctbsv.c
#cblas_ctpmv.c
#cblas_ctpsv.c
#cblas_ctrmm.c
#cblas_ctrmv.c
cblas_ctrsm.c
#cblas_ctrsv.c
#cblas_dasum.c
cblas_daxpy.c
#cblas_dcopy.c
cblas_ddot.c
#cblas_dgbmv.c
cblas_dgemm.c
cblas_dgemv.c
cblas_dger.c
#cblas_dnrm2.c
#cblas_drot.c
#cblas_drotg.c
#cblas_drotm.c
#cblas_drotmg.c
#cblas_dsbmv.c
cblas_dscal.c
#cblas_dsdot.c
#cblas_dspmv.c
#cblas_dspr2.c
#cblas_dspr.c
#cblas_dswap.c
#cblas_dsymm.c
#cblas_dsymv.c
#cblas_dsyr2.c
#cblas_dsyr2k.c
#cblas_dsyr.c
#cblas_dsyrk.c
#cblas_dtbmv.c
#cblas_dtbsv.c
#cblas_dtpmv.c
#cblas_dtpsv.c
#cblas_dtrmm.c
#cblas_dtrmv.c
cblas_dtrsm.c
#cblas_dtrsv.c
#cblas_dzasum.c
#cblas_dznrm2.c
#cblas_icamax.c
#cblas_idamax.c
#cblas_isamax.c
#cblas_izamax.c
#cblas_sasum.c
cblas_saxpy.c
#cblas_scasum.c
#cblas_scnrm2.c
#cblas_scopy.c
cblas_sdot.c
#cblas_sdsdot.c
#cblas_sgbmv.c
cblas_sgemm.c
cblas_sgemv.c
cblas_sger.c
#cblas_snrm2.c
#cblas_srot.c
#cblas_srotg.c
#cblas_srotm.c
#cblas_srotmg.c
#cblas_ssbmv.c
cblas_sscal.c
#cblas_sspmv.c
#cblas_sspr2.c
#cblas_sspr.c
#cblas_sswap.c
#cblas_ssymm.c
#cblas_ssymv.c
#cblas_ssyr2.c
#cblas_ssyr2k.c
#cblas_ssyr.c
#cblas_ssyrk.c
#cblas_stbmv.c
#cblas_stbsv.c
#cblas_stpmv.c
#cblas_stpsv.c
#cblas_strmm.c
#cblas_strmv.c
cblas_strsm.c
#cblas_strsv.c
cblas_xerbla.c
cblas_zaxpy.c
#cblas_zcopy.c
cblas_zdotc_sub.c
cblas_zdotu_sub.c
#cblas_zdscal.c
#cblas_zgbmv.c
cblas_zgemm.c
cblas_zgemv.c
cblas_zgerc.c
cblas_zgeru.c
#cblas_zhbmv.c
#cblas_zhemm.c
#cblas_zhemv.c
#cblas_zher2.c
#cblas_zher2k.c
#cblas_zher.c
#cblas_zherk.c
#cblas_zhpmv.c
#cblas_zhpr2.c
#cblas_zhpr.c
cblas_zscal.c
#cblas_zswap.c
#cblas_zsymm.c
#cblas_zsyr2k.c
#cblas_zsyrk.c
#cblas_ztbmv.c
#cblas_ztbsv.c
#cblas_ztpmv.c
#cblas_ztpsv.c
#cblas_ztrmm.c
#cblas_ztrmv.c
cblas_ztrsm.c
#cblas_ztrsv.c
cdotcsub.f
cdotusub.f
dasumsub.f
ddotsub.f
dnrm2sub.f
dsdotsub.f
dzasumsub.f
dznrm2sub.f
icamaxsub.f
idamaxsub.f
isamaxsub.f
izamaxsub.f
sasumsub.f
scasumsub.f
scnrm2sub.f
sdotsub.f
sdsdotsub.f
snrm2sub.f
zdotcsub.f
zdotusub.f
)
This folder contains a copy of CBLAS (from http://www.netlib.org/blas/) which
has been setup so you can compile it with CMake. It also only compiles the
part of CBLAS needed by dlib.
Most BLAS libraries come with CBLAS, however, some don't. In particular, if
you are using the BLAS that comes with MATLAB then you will need this CBLAS
code linked into your own to get dlib working with MATLAB's built in BLAS.
This diff is collapsed.
/*
* cblas_caxpy.c
*
* The program is a C interface to caxpy.
*
* Written by Keita Teranishi. 2/11/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_caxpy( const int N, const void *alpha, const void *X,
const int incX, void *Y, const int incY)
{
#ifdef F77_INT
F77_INT F77_N=N, F77_incX=incX, F77_incY=incY;
#else
#define F77_N N
#define F77_incX incX
#define F77_incY incY
#endif
F77_caxpy( &F77_N, alpha, X, &F77_incX, Y, &F77_incY);
}
/*
* cblas_ccopy.c
*
* The program is a C interface to ccopy.
*
* Written by Keita Teranishi. 2/11/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_ccopy( const int N, const void *X,
const int incX, void *Y, const int incY)
{
#ifdef F77_INT
F77_INT F77_N=N, F77_incX=incX, F77_incY=incY;
#else
#define F77_N N
#define F77_incX incX
#define F77_incY incY
#endif
F77_ccopy( &F77_N, X, &F77_incX, Y, &F77_incY);
}
/*
* cblas_cdotc_sub.c
*
* The program is a C interface to cdotc.
* It calls the fortran wrapper before calling cdotc.
*
* Written by Keita Teranishi. 2/11/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cdotc_sub( const int N, const void *X, const int incX,
const void *Y, const int incY,void *dotc)
{
#ifdef F77_INT
F77_INT F77_N=N, F77_incX=incX, F77_incY=incY;
#else
#define F77_N N
#define F77_incX incX
#define F77_incY incY
#endif
F77_cdotc_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotc);
}
/*
* cblas_cdotu_sub.f
*
* The program is a C interface to cdotu.
* It calls the forteran wrapper before calling cdotu.
*
* Written by Keita Teranishi. 2/11/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cdotu_sub( const int N, const void *X,
const int incX, const void *Y, const int incY,void *dotu)
{
#ifdef F77_INT
F77_INT F77_N=N, F77_incX=incX, F77_incY=incY;
#else
#define F77_N N
#define F77_incX incX
#define F77_incY incY
#endif
F77_cdotu_sub( &F77_N, X, &F77_incX, Y, &F77_incY, dotu);
}
/*
* cblas_cgbmv.c
* The program is a C interface of cgbmv
*
* Keita Teranishi 5/20/98
*
*/
#include <stdio.h>
#include <stdlib.h>
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cgbmv(const enum CBLAS_ORDER order,
const enum CBLAS_TRANSPOSE TransA, const int M, const int N,
const int KL, const int KU,
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;
F77_INT F77_KL=KL,F77_KU=KU;
#else
#define F77_M M
#define F77_N N
#define F77_lda lda
#define F77_KL KL
#define F77_KU KU
#define F77_incX incx
#define F77_incY incY
#endif
int n=0, i=0, incx=incX;
const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta;
float ALPHA[2],BETA[2];
int tincY, tincx;
float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0;
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_cgbmv","Illegal TransA setting, %d\n", TransA);
return;
}
#ifdef F77_CHAR
F77_TA = C2F_CHAR(&TA);
#endif
F77_cgbmv(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha,
A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY);
}
else if (order == CblasRowMajor)
{
if (TransA == CblasNoTrans) TA = 'T';
else if (TransA == CblasTrans) TA = 'N';
else if (TransA == CblasConjTrans)
{
ALPHA[0]= *alp;
ALPHA[1]= -alp[1];
BETA[0]= *bet;
BETA[1]= -bet[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;
#ifdef F77_INT
F77_incX = 1;
#else
incx = 1;
#endif
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;
}
}
else x = (float *) X;
}
else
{
cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA);
return;
}
#ifdef F77_CHAR
F77_TA = C2F_CHAR(&TA);
#endif
if (TransA == CblasConjTrans)
F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA,
A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY);
else
F77_cgbmv(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha,
A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY);
if (TransA == CblasConjTrans)
{
if (x != X) free(x);
if (N > 0)
{
do
{
*y = -(*y);
y += i;
}
while (y != st);
}
}
}
else cblas_xerbla(1, "cblas_cgbmv", "Illegal Order setting, %d\n", order);
}
/*
*
* cblas_cgemm.c
* This program is a C interface to cgemm.
* Written by Keita Teranishi
* 4/8/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cgemm(const enum CBLAS_ORDER Order, const enum CBLAS_TRANSPOSE TransA,
const enum CBLAS_TRANSPOSE TransB, const int M, const int N,
const int K, const void *alpha, const void *A,
const int lda, const void *B, const int ldb,
const void *beta, void *C, const int ldc)
{
char TA, TB;
#ifdef F77_CHAR
F77_CHAR F77_TA, F77_TB;
#else
#define F77_TA &TA
#define F77_TB &TB
#endif
#ifdef F77_INT
F77_INT F77_M=M, F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb;
F77_INT F77_ldc=ldc;
#else
#define F77_M M
#define F77_N N
#define F77_K K
#define F77_lda lda
#define F77_ldb ldb
#define F77_ldc ldc
#endif
if( Order == CblasColMajor )
{
if(TransA == CblasTrans) TA='T';
else if ( TransA == CblasConjTrans ) TA='C';
else if ( TransA == CblasNoTrans ) TA='N';
else
{
cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA);
return;
}
if(TransB == CblasTrans) TB='T';
else if ( TransB == CblasConjTrans ) TB='C';
else if ( TransB == CblasNoTrans ) TB='N';
else
{
cblas_xerbla(3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB);
return;
}
#ifdef F77_CHAR
F77_TA = C2F_CHAR(&TA);
F77_TB = C2F_CHAR(&TB);
#endif
F77_cgemm(F77_TA, F77_TB, &F77_M, &F77_N, &F77_K, alpha, A,
&F77_lda, B, &F77_ldb, beta, C, &F77_ldc);
} else if (Order == CblasRowMajor)
{
if(TransA == CblasTrans) TB='T';
else if ( TransA == CblasConjTrans ) TB='C';
else if ( TransA == CblasNoTrans ) TB='N';
else
{
cblas_xerbla(2, "cblas_cgemm", "Illegal TransA setting, %d\n", TransA);
return;
}
if(TransB == CblasTrans) TA='T';
else if ( TransB == CblasConjTrans ) TA='C';
else if ( TransB == CblasNoTrans ) TA='N';
else
{
cblas_xerbla(2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB);
return;
}
#ifdef F77_CHAR
F77_TA = C2F_CHAR(&TA);
F77_TB = C2F_CHAR(&TB);
#endif
F77_cgemm(F77_TA, F77_TB, &F77_N, &F77_M, &F77_K, alpha, B,
&F77_ldb, A, &F77_lda, beta, C, &F77_ldc);
}
else cblas_xerbla(1, "cblas_cgemm", "Illegal Order setting, %d\n", Order);
return;
}
/*
* cblas_cgemv.c
* The program is a C interface of cgemv
*
* Keita Teranishi 5/20/98
*
*/
#include <stdio.h>
#include <stdlib.h>
#include "cblas.h"
#include "cblas_f77.h"
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, incx=incX;
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;
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);
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)
{
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);
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);
return;
}
/*
* cblas_cgerc.c
* The program is a C interface to cgerc.
*
* Keita Teranishi 5/20/98
*
*/
#include <stdio.h>
#include <stdlib.h>
#include "cblas.h"
#include "cblas_f77.h"
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;
}
/*
* cblas_cgeru.c
* The program is a C interface to cgeru.
*
* Keita Teranishi 5/20/98
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cgeru(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
if (order == CblasColMajor)
{
F77_cgeru( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A,
&F77_lda);
}
else if (order == CblasRowMajor)
{
F77_cgeru( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A,
&F77_lda);
}
else cblas_xerbla(1, "cblas_cgeru","Illegal Order setting, %d\n", order);
return;
}
/*
* cblas_chbmv.c
* The program is a C interface to chbmv
*
* Keita Teranishi 5/18/98
*
*/
#include "cblas.h"
#include "cblas_f77.h"
#include <stdio.h>
#include <stdlib.h>
void cblas_chbmv(const enum CBLAS_ORDER order,
const enum CBLAS_UPLO Uplo,const int N,const int K,
const void *alpha, const void *A, const int lda,
const void *X, const int incX, const void *beta,
void *Y, const int incY)
{
char UL;
#ifdef F77_CHAR
F77_CHAR F77_UL;
#else
#define F77_UL &UL
#endif
#ifdef F77_INT
F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_incX=incX, F77_incY=incY;
#else
#define F77_N N
#define F77_K K
#define F77_lda lda
#define F77_incX incx
#define F77_incY incY
#endif
int n, i=0, incx=incX;
const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta;
float ALPHA[2],BETA[2];
int tincY, tincx;
float *x=(float *)X, *y=(float *)Y, *st=0, *tx;
if (order == CblasColMajor)
{
if (Uplo == CblasLower) UL = 'L';
else if (Uplo == CblasUpper) UL = 'U';
else
{
cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n",Uplo );
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_chbmv(F77_UL, &F77_N, &F77_K, alpha, A, &F77_lda, X,
&F77_incX, beta, Y, &F77_incY);
}
else if (order == CblasRowMajor)
{
ALPHA[0]= *alp;
ALPHA[1]= -alp[1];
BETA[0]= *bet;
BETA[1]= -bet[1];
if (N > 0)
{
n = N << 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;
#ifdef F77_INT
F77_incX = 1;
#else
incx = 1;
#endif
if(incY > 0)
tincY = incY;
else
tincY = -incY;
y++;
i = tincY << 1;
n = i * N ;
st = y + n;
do {
*y = -(*y);
y += i;
} while(y != st);
y -= n;
} else
x = (float *) X;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_chbmv","Illegal Uplo setting, %d\n", Uplo);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_chbmv(F77_UL, &F77_N, &F77_K, ALPHA,
A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY);
}
else
{
cblas_xerbla(1, "cblas_chbmv","Illegal Order setting, %d\n", order);
return;
}
if ( order == CblasRowMajor )
{
if(X!=x)
free(x);
if (N > 0)
{
do
{
*y = -(*y);
y += i;
}
while (y != st);
}
}
return;
}
/*
*
* cblas_chemm.c
* This program is a C interface to chemm.
* Written by Keita Teranishi
* 4/8/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_chemm(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_chemm", "Illegal Side setting, %d\n", Side);
return;
}
if( Uplo == CblasUpper) UL='U';
else if ( Uplo == CblasLower ) UL='L';
else
{
cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_SD = C2F_CHAR(&SD);
#endif
F77_chemm(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_chemm", "Illegal Side setting, %d\n", Side);
return;
}
if( Uplo == CblasUpper) UL='L';
else if ( Uplo == CblasLower ) UL='U';
else
{
cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_SD = C2F_CHAR(&SD);
#endif
F77_chemm(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A,
&F77_lda, B, &F77_ldb, beta, C, &F77_ldc);
}
else cblas_xerbla(1, "cblas_chemm", "Illegal Order setting, %d\n", Order);
return;
}
/*
* cblas_chemv.c
* The program is a C interface to chemv
*
* Keita Teranishi 5/18/98
*
*/
#include <stdio.h>
#include <stdlib.h>
#include "cblas.h"
#include "cblas_f77.h"
void cblas_chemv(const enum CBLAS_ORDER order,
const enum CBLAS_UPLO Uplo, 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 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, F77_incY=incY;
#else
#define F77_N N
#define F77_lda lda
#define F77_incX incx
#define F77_incY incY
#endif
int n=0, i=0, incx=incX;
const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta;
float ALPHA[2],BETA[2];
int tincY, tincx;
float *x=(float *)X, *y=(float *)Y, *st=0, *tx;
if (order == CblasColMajor)
{
if (Uplo == CblasUpper) UL = 'U';
else if (Uplo == CblasLower) UL = 'L';
else
{
cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n",Uplo );
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_chemv(F77_UL, &F77_N, alpha, A, &F77_lda, X, &F77_incX,
beta, Y, &F77_incY);
}
else if (order == CblasRowMajor)
{
ALPHA[0]= *alp;
ALPHA[1]= -alp[1];
BETA[0]= *bet;
BETA[1]= -bet[1];
if (N > 0)
{
n = N << 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;
#ifdef F77_INT
F77_incX = 1;
#else
incx = 1;
#endif
if(incY > 0)
tincY = incY;
else
tincY = -incY;
y++;
i = tincY << 1;
n = i * N ;
st = y + n;
do {
*y = -(*y);
y += i;
} while(y != st);
y -= n;
} else
x = (float *) X;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_chemv","Illegal Uplo setting, %d\n", Uplo);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_chemv(F77_UL, &F77_N, ALPHA, A, &F77_lda, x, &F77_incX,
BETA, Y, &F77_incY);
}
else
{
cblas_xerbla(1, "cblas_chemv","Illegal Order setting, %d\n", order);
return;
}
if ( order == CblasRowMajor )
{
if ( X != x )
free(x);
if (N > 0)
{
do
{
*y = -(*y);
y += i;
}
while (y != st);
}
}
return;
}
/*
* cblas_cher.c
* The program is a C interface to cher.
*
* Keita Teranishi 5/20/98
*
*/
#include <stdio.h>
#include <stdlib.h>
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
const int N, const float alpha, const void *X, const int incX
,void *A, const 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_lda=lda, F77_incX=incX;
#else
#define F77_N N
#define F77_lda lda
#define F77_incX incx
#endif
int n, i, tincx, incx=incX;
float *x=(float *)X, *xx=(float *)X, *tx, *st;
if (order == CblasColMajor)
{
if (Uplo == CblasLower) UL = 'L';
else if (Uplo == CblasUpper) UL = 'U';
else
{
cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n",Uplo );
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_cher(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_cher","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(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;
#ifdef F77_INT
F77_incX = 1;
#else
incx = 1;
#endif
}
else x = (float *) X;
F77_cher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda);
} else
{
cblas_xerbla(1, "cblas_cher","Illegal Order setting, %d\n", order);
return;
}
if(X!=x)
free(x);
return;
}
/*
* cblas_cher2.c
* The program is a C interface to cher2.
*
* Keita Teranishi 3/23/98
*
*/
#include <stdio.h>
#include <stdlib.h>
#include "cblas.h"
#include "cblas_f77.h"
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)
{
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, F77_incY=incY;
#else
#define F77_N N
#define F77_lda lda
#define F77_incX incx
#define F77_incY incy
#endif
int n, i, j, tincx, tincy, incx=incX, incy=incY;
float *x=(float *)X, *xx=(float *)X, *y=(float *)Y,
*yy=(float *)Y, *tx, *ty, *stx, *sty;
if (order == CblasColMajor)
{
if (Uplo == CblasLower) UL = 'L';
else if (Uplo == CblasUpper) UL = 'U';
else
{
cblas_xerbla(2, "cblas_cher2","Illegal Uplo setting, %d\n",Uplo );
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_cher2(F77_UL, &F77_N, alpha, X, &F77_incX,
Y, &F77_incY, A, &F77_lda);
} else if (order == CblasRowMajor)
{
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_cher2","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(float));
y = malloc(n*sizeof(float));
tx = x;
ty = y;
if( incX > 0 ) {
i = incX << 1 ;
tincx = 2;
stx= x+n;
} else {
i = incX *(-2);
tincx = -2;
stx = x-2;
x +=(n-2);
}
if( incY > 0 ) {
j = incY << 1;
tincy = 2;
sty= y+n;
} else {
j = incY *(-2);
tincy = -2;
sty = y-2;
y +=(n-2);
}
do
{
*x = *xx;
x[1] = -xx[1];
x += tincx ;
xx += i;
}
while (x != stx);
do
{
*y = *yy;
y[1] = -yy[1];
y += tincy ;
yy += j;
}
while (y != sty);
x=tx;
y=ty;
#ifdef F77_INT
F77_incX = 1;
F77_incY = 1;
#else
incx = 1;
incy = 1;
#endif
} else
{
x = (float *) X;
y = (float *) Y;
}
F77_cher2(F77_UL, &F77_N, alpha, y, &F77_incY, x,
&F77_incX, A, &F77_lda);
} else
{
cblas_xerbla(1, "cblas_cher2","Illegal Order setting, %d\n", order);
return;
}
if(X!=x)
free(x);
if(Y!=y)
free(y);
return;
}
/*
*
* cblas_cher2k.c
* This program is a C interface to cher2k.
* Written by Keita Teranishi
* 4/8/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cher2k(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
const void *alpha, const void *A, const int lda,
const void *B, const int ldb, const float beta,
void *C, const int ldc)
{
char UL, TR;
#ifdef F77_CHAR
F77_CHAR F77_TR, F77_UL;
#else
#define F77_TR &TR
#define F77_UL &UL
#endif
#ifdef F77_INT
F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb;
F77_INT F77_ldc=ldc;
#else
#define F77_N N
#define F77_K K
#define F77_lda lda
#define F77_ldb ldb
#define F77_ldc ldc
#endif
float ALPHA[2];
const float *alp=(float *)alpha;
if( Order == CblasColMajor )
{
if( Uplo == CblasUpper) UL='U';
else if ( Uplo == CblasLower ) UL='L';
else
{
cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo);
return;
}
if( Trans == CblasTrans) TR ='T';
else if ( Trans == CblasConjTrans ) TR='C';
else if ( Trans == CblasNoTrans ) TR='N';
else
{
cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TR = C2F_CHAR(&TR);
#endif
F77_cher2k(F77_UL, F77_TR, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc);
} else if (Order == CblasRowMajor)
{
if( Uplo == CblasUpper) UL='L';
else if ( Uplo == CblasLower ) UL='U';
else
{
cblas_xerbla(2, "cblas_cher2k", "Illegal Uplo setting, %d\n", Uplo);
return;
}
if( Trans == CblasTrans) TR ='N';
else if ( Trans == CblasConjTrans ) TR='N';
else if ( Trans == CblasNoTrans ) TR='C';
else
{
cblas_xerbla(3, "cblas_cher2k", "Illegal Trans setting, %d\n", Trans);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TR = C2F_CHAR(&TR);
#endif
ALPHA[0]= *alp;
ALPHA[1]= -alp[1];
F77_cher2k(F77_UL,F77_TR, &F77_N, &F77_K, ALPHA, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc);
}
else cblas_xerbla(1, "cblas_cher2k", "Illegal Order setting, %d\n", Order);
return;
}
/*
*
* cblas_cherk.c
* This program is a C interface to cherk.
* Written by Keita Teranishi
* 4/8/1998
*
*/
#include "cblas.h"
#include "cblas_f77.h"
void cblas_cherk(const enum CBLAS_ORDER Order, const enum CBLAS_UPLO Uplo,
const enum CBLAS_TRANSPOSE Trans, const int N, const int K,
const float alpha, const void *A, const int lda,
const float beta, void *C, const int ldc)
{
char UL, TR;
#ifdef F77_CHAR
F77_CHAR F77_TR, F77_UL;
#else
#define F77_TR &TR
#define F77_UL &UL
#endif
#ifdef F77_INT
F77_INT F77_N=N, F77_K=K, F77_lda=lda;
F77_INT F77_ldc=ldc;
#else
#define F77_N N
#define F77_K K
#define F77_lda lda
#define F77_ldc ldc
#endif
if( Order == CblasColMajor )
{
if( Uplo == CblasUpper) UL='U';
else if ( Uplo == CblasLower ) UL='L';
else
{
cblas_xerbla(2, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo);
return;
}
if( Trans == CblasTrans) TR ='T';
else if ( Trans == CblasConjTrans ) TR='C';
else if ( Trans == CblasNoTrans ) TR='N';
else
{
cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TR = C2F_CHAR(&TR);
#endif
F77_cherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda,
&beta, C, &F77_ldc);
} else if (Order == CblasRowMajor)
{
if( Uplo == CblasUpper) UL='L';
else if ( Uplo == CblasLower ) UL='U';
else
{
cblas_xerbla(3, "cblas_cherk", "Illegal Uplo setting, %d\n", Uplo);
return;
}
if( Trans == CblasTrans) TR ='N';
else if ( Trans == CblasConjTrans ) TR='N';
else if ( Trans == CblasNoTrans ) TR='C';
else
{
cblas_xerbla(3, "cblas_cherk", "Illegal Trans setting, %d\n", Trans);
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_SD = C2F_CHAR(&SD);
#endif
F77_cherk(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda,
&beta, C, &F77_ldc);
}
else cblas_xerbla(1, "cblas_cherk", "Illegal Order setting, %d\n", Order);
return;
}
/*
* cblas_chpmv.c
* The program is a C interface of chpmv
*
* Keita Teranishi 5/18/98
*
*/
#include <stdio.h>
#include <stdlib.h>
#include "cblas.h"
#include "cblas_f77.h"
void cblas_chpmv(const enum CBLAS_ORDER order,
const enum CBLAS_UPLO Uplo,const int N,
const void *alpha, const void *AP,
const void *X, const int incX, const void *beta,
void *Y, const int incY)
{
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;
#else
#define F77_N N
#define F77_incX incx
#define F77_incY incY
#endif
int n, i=0, incx=incX;
const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta;
float ALPHA[2],BETA[2];
int tincY, tincx;
float *x=(float *)X, *y=(float *)Y, *st=0, *tx;
if (order == CblasColMajor)
{
if (Uplo == CblasLower) UL = 'L';
else if (Uplo == CblasUpper) UL = 'U';
else
{
cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n",Uplo );
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_chpmv(F77_UL, &F77_N, alpha, AP, X,
&F77_incX, beta, Y, &F77_incY);
}
else if (order == CblasRowMajor)
{
ALPHA[0]= *alp;
ALPHA[1]= -alp[1];
BETA[0]= *bet;
BETA[1]= -bet[1];
if (N > 0)
{
n = N << 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;
#ifdef F77_INT
F77_incX = 1;
#else
incx = 1;
#endif
if(incY > 0)
tincY = incY;
else
tincY = -incY;
y++;
i = tincY << 1;
n = i * N ;
st = y + n;
do {
*y = -(*y);
y += i;
} while(y != st);
y -= n;
} else
x = (float *) X;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_chpmv","Illegal Uplo setting, %d\n", Uplo );
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
#endif
F77_chpmv(F77_UL, &F77_N, ALPHA,
AP, x, &F77_incX, BETA, Y, &F77_incY);
}
else
{
cblas_xerbla(1, "cblas_chpmv","Illegal Order setting, %d\n", order);
return;
}
if ( order == CblasRowMajor )
{
if(X!=x)
free(x);
if (N > 0)
{
do
{
*y = -(*y);
y += i;
}
while (y != st);
}
}
return;
}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment