jens
05da8712f6
git-svn-id: http://moon:8086/svn/software/trunk/libsrc/_to_be_added@1 b431acfa-c32f-4a4a-93f1-934dc6c82436
351 lines
11 KiB
C
Executable File
351 lines
11 KiB
C
Executable File
// ------------------------------------------------------------
|
|
// lapack_cwrap.c
|
|
// Wrapping LAPACK FORTRAN-function to C-Functions
|
|
// Libraries needed:
|
|
// lapack.a blas.a and libg2c.a (if available)
|
|
//
|
|
// 26.02.2005, J.Ahrensfeld
|
|
// ------------------------------------------------------------
|
|
|
|
// ------------------------------------------------------------
|
|
// LAPACK functions
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
|
|
extern
|
|
void dgesv_(int *N, int *NHRS, double *A, int *LDA,
|
|
int *IPIV, double *B, int *LDB, int *INFO);
|
|
|
|
int dgesv(int N, int NHRS, double *A, int LDA, int *IPIV,
|
|
double *B, int LDB)
|
|
{
|
|
int info;
|
|
|
|
dgesv_(&N, &NHRS, A, &LDA, IPIV, B, &LDB, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
|
|
extern
|
|
void dsyev_(char *JOBZ, char *UPLO, int *N, double *A, int *LDA,
|
|
double *W, double *WORK, int *LWORK, int *INFO);
|
|
|
|
int dsyev(char JOBZ, char UPLO, int N, double *A, int LDA,
|
|
double *W, double *WORK, int LWORK)
|
|
{
|
|
int info;
|
|
|
|
dsyev_(&JOBZ, &UPLO, &N, A, &LDA, W, WORK, &LWORK, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// Extern declaration of FORTRAN routine
|
|
extern
|
|
void dgtsv_(int *Np, int *NRHSp, double *DL, double *D, double *DU,
|
|
double *B, int *LDBp, int *INFOp);
|
|
|
|
// C-Wrapper function
|
|
int dgtsv(int N, int NRHS, double *DL, double *D, double *DU,
|
|
double *B, int ldb)
|
|
{
|
|
int info;
|
|
dgtsv_ (&N, &NRHS, DL, D, DU, B, &ldb, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )
|
|
extern
|
|
void dgebrd_(int *M, int *N, double *A, int *LDA, double *D, double *E,
|
|
double *TAUQ, double *TAUP, double *WORK, int *LWORK, int *INFO);
|
|
|
|
int dgebrd(int M, int N, double *A, int LDA, double *D, double *E,
|
|
double *TAUQ, double *TAUP, double *WORK, int LWORK)
|
|
|
|
{
|
|
int info;
|
|
dgebrd_(&M, &N, A, &LDA, D, E, TAUQ, TAUP, WORK, &LWORK, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
|
|
// LDU, C, LDC, WORK, INFO )
|
|
extern
|
|
void dbdsqr_(char *UPLO, int *N, int *NCVT, int *NRU, int *NCC, double *D,
|
|
double *E, double *VT, int *LDVT, double *U, int *LDU,
|
|
double *C, int *LDC, double *WORK, int *INFO);
|
|
|
|
int dbdsqr(char UPLO, int N, int NCVT, int NRU, int NCC, double *D,
|
|
double *E, double *VT, int LDVT, double *U, int LDU,
|
|
double *C, int LDC, double *WORK)
|
|
{
|
|
int info;
|
|
dbdsqr_(&UPLO, &N, &NCVT, &NRU, &NCC, D, E, VT, &LDVT, U, &LDU,
|
|
C, &LDC, WORK, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
int dgesvd(char JOBU, char JOBVT, int M, int N, double *A, int LDA, double *S,
|
|
double *U, int LDU, double *VT, int LDVT, double *WORK, int LWORK);
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
|
|
// WORK, LWORK, INFO )
|
|
extern
|
|
void dgesvd_(char *JOBU, char *JOBVT, int *M, int *N, double *A, int *LDA,
|
|
double *S, double *U, int *LDU, double *VT, int *LDVT,
|
|
double *WORK, int *LWORK, int *INFO);
|
|
|
|
int dgesvd(char JOBU, char JOBVT, int M, int N, double *A, int LDA, double *S,
|
|
double *U, int LDU, double *VT, int LDVT, double *WORK, int LWORK)
|
|
{
|
|
int info;
|
|
dgesvd_(&JOBU, &JOBVT, &M, &N, A, &LDA, S, U, &LDU, VT, &LDVT,
|
|
WORK, &LWORK, &info);
|
|
|
|
|
|
return info;
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
|
|
extern
|
|
void dgetri_(int *N, double *A, int *LDA, int *IPIV, double *WORK, int *LWORK, int *INFO);
|
|
|
|
int dgetri(int N, double *A, int LDA, int *IPIV, double *WORK, int LWORK)
|
|
{
|
|
|
|
int info;
|
|
dgetri_(&N, A, &LDA, IPIV, WORK, &LWORK, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )
|
|
extern
|
|
void dpotri_(char *UPLO, int *N, double *A, int *LDA, int *INFO);
|
|
|
|
int dpotri(char UPLO, int N, double *A, int LDA)
|
|
{
|
|
|
|
int info;
|
|
dpotri_(&UPLO, &N, A, &LDA, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )
|
|
extern
|
|
void dgecon_(char *NORM, int *N, double *A, int *LDA, double *ANORM, double *RCOND,
|
|
double *DWORK, int *IWORK, int *INFO);
|
|
|
|
int dgecon(char NORM, int N, double *A, int LDA, double ANORM, double *RCOND,
|
|
double *DWORK, int *IWORK)
|
|
{
|
|
int info;
|
|
dgecon_(&NORM, &N, A, &LDA, &ANORM, RCOND, DWORK, IWORK, &info);
|
|
|
|
return info;
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// BLAS functions LEVEL 1
|
|
// ------------------------------------------------------------
|
|
// subroutine dswap(n,dx,incx,dy,incy)
|
|
// interchanges two vectors.
|
|
extern
|
|
void dswap_ (int *n, double *dx, int *incx, double *dy, int *incy);
|
|
|
|
void dswap (int n, double *dx, int incx, double *dy, int incy)
|
|
{
|
|
dswap_ (&n, dx, &incx, dy, &incy);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// subroutine dcopy(n,dx,incx,dy,incy)
|
|
// copies a vector, x, to a vector, y.
|
|
extern
|
|
void dcopy_ (int *n, double *dx, int *incx, double *dy, int *incy);
|
|
|
|
void dcopy (int n, double *dx, int incx, double *dy, int incy)
|
|
{
|
|
dcopy_ (&n, dx, &incx, dy, &incy);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// subroutine dscal(n,da,dx,incx)
|
|
// scales a vector by a constant.
|
|
extern
|
|
void dscal_ (int *n, double *da, double *dx, int *incx);
|
|
|
|
void dscal (int n, double da, double *dx, int incx)
|
|
{
|
|
dscal_ (&n, &da, dx, &incx);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// subroutine daxpy(n,da,dx,incx,dy,incy)
|
|
// constant times a vector plus a vector.
|
|
extern
|
|
void daxpy_ (int *n, double *da, double *dx, int *incx, double *dy, int *incy);
|
|
|
|
void daxpy (int n, double da, double *dx, int incx, double *dy, int incy)
|
|
{
|
|
daxpy_ (&n, &da, dx, &incx, dy, &incy);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// function ddot(n,dx,incx,dy,incy)
|
|
// forms the dot product of two vectors.
|
|
extern
|
|
double ddot_ (int *n, double *dx, int *incx, double *dy, int *incy);
|
|
|
|
double ddot (int n, double *dx, int incx, double *dy, int incy)
|
|
{
|
|
return ddot_ (&n, dx, &incx, dy, &incy);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// function DNRM2 ( N, X, INCX )
|
|
// DNRM2 returns the euclidean norm of a vector via the function
|
|
// DNRM2 := sqrt( x'*x )
|
|
extern
|
|
double dnrm2_ (int *n, double *dx, int *incx);
|
|
|
|
double dnrm2 (int n, double *dx, int incx)
|
|
{
|
|
return dnrm2_ (&n, dx, &incx);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// function dasum(n,dx,incx)
|
|
// takes the sum of the absolute values.
|
|
extern
|
|
double dasum_ (int *n, double *dx, int *incx);
|
|
|
|
double dasum (int n, double *dx, int incx)
|
|
{
|
|
return dasum_ (&n, dx, &incx);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// function idamax(n,dx,incx)
|
|
// finds the index of element having max. absolute value.
|
|
extern
|
|
int idamax_ (int *n, double *dx, int *incx);
|
|
|
|
int idamax (int n, double *dx, int incx)
|
|
{
|
|
int i;
|
|
|
|
i = idamax_ (&n, dx, &incx);
|
|
|
|
if (i > 0)
|
|
return i - 1;
|
|
else
|
|
return i;
|
|
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// BLAS functions LEVEL 2
|
|
// ------------------------------------------------------------
|
|
|
|
// SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
|
|
extern
|
|
void dgemv_(char *TRANS, int *M, int *N, double *ALPHA, double *A, int *LDA,
|
|
double *X, int *INCX, double *BETA, double *Y, int *INCY);
|
|
|
|
void dgemv(char TRANS, int M, int N, double ALPHA, double *A, int LDA,
|
|
double *X, int INCX, double BETA, double *Y, int INCY)
|
|
{
|
|
|
|
dgemv_(&TRANS, &M, &N, &ALPHA, A, &LDA, X, &INCX, &BETA, Y, &INCY);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
|
|
extern void dger_(int *m,int *n, double *alpha, double *x, int *incx,
|
|
double *y, int *incy, double *A, int *lda);
|
|
|
|
void dger(int m,int n, double alpha, double *x, int incx,
|
|
double *y, int incy, double *A, int lda)
|
|
{
|
|
dger_(&m, &n, &alpha, x, &incx, y, &incy, A, &lda);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA )
|
|
extern void dsyr_(char *UPLO, int *n, double *alpha, double *x, int *incx,
|
|
double *A, int *lda);
|
|
|
|
void dsyr(char UPLO, int n, double alpha, double *x, int incx, double *A, int lda)
|
|
{
|
|
dsyr_(&UPLO, &n, &alpha, x, &incx, A, &lda);
|
|
}
|
|
|
|
// ------------------------------------------------------------
|
|
// BLAS functions LEVEL 3
|
|
// ------------------------------------------------------------
|
|
|
|
// SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA,
|
|
extern
|
|
void dsyrk_(char *UPLO, char *TRANS, int *N, int *K, double *ALPHA,
|
|
double *A, int *LDA, double *BETA, double *C, int *LDC);
|
|
|
|
void dsyrk(char UPLO, char TRANS, int N, int K, double ALPHA,
|
|
double *A, int LDA, double BETA, double *C, int LDC)
|
|
{
|
|
dsyrk_(&UPLO, &TRANS, &N, &K, &ALPHA, A, &LDA, &BETA, C, &LDC);
|
|
}
|
|
|
|
// SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
|
|
extern
|
|
void dgemm_(char *TRANSA, char *TRANSB, int *M, int *N, int *K, double *ALPHA,
|
|
double *A, int *LDA, double *B, int *LDB, double *BETA, double *C, int *LDC);
|
|
|
|
void dgemm(char TRANSA, char TRANSB, int M, int N, int K, double ALPHA,
|
|
double *A, int LDA, double *B, int LDB, double BETA, double *C, int LDC)
|
|
{
|
|
|
|
dgemm_(&TRANSA, &TRANSB, &M, &N, &K, &ALPHA, A, &LDA, B, &LDB, &BETA, C, &LDC);
|
|
|
|
}
|
|
|
|
// SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
|
|
extern
|
|
void dtrmm_(char *SIDE, char *UPLO, char *TRANSA, char *DIAG, int *M, int *N,
|
|
double *ALPHA, double *A, int *LDA, double *B, int *LDB);
|
|
|
|
void dtrmm(char SIDE, char UPLO, char TRANSA, char DIAG, int M, int N,
|
|
double ALPHA, double *A, int LDA, double *B, int LDB)
|
|
{
|
|
|
|
dtrmm_(&SIDE, &UPLO, &TRANSA, &DIAG, &M, &N, &ALPHA, A, &LDA, B, &LDB);
|
|
|
|
}
|
|
|
|
// SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
|
|
extern
|
|
void dtrsm_(char *SIDE, char *UPLO, char *TRANSA, char *DIAG, int *M, int *N,
|
|
double *ALPHA, double *A, int *LDA, double *B, int *LDB);
|
|
|
|
void dtrsm(char SIDE, char UPLO, char TRANSA, char DIAG, int M, int N,
|
|
double ALPHA, double *A, int LDA, double *B, int LDB)
|
|
{
|
|
|
|
dtrsm_(&SIDE, &UPLO, &TRANSA, &DIAG, &M, &N, &ALPHA, A, &LDA, B, &LDB);
|
|
|
|
}
|
|
|