72 lines
2.1 KiB
C
72 lines
2.1 KiB
C
#include <string.h> // for `mem*` functions.
|
|
|
|
#include "config.h"
|
|
#include "matrix.h"
|
|
|
|
#include <R_ext/BLAS.h>
|
|
|
|
void matrixprod(const double *A, const int nrowA, const int ncolA,
|
|
const double *B, const int nrowB, const int ncolB,
|
|
double *C) {
|
|
const double one = 1.0;
|
|
const double zero = 0.0;
|
|
|
|
// DGEMM with parameterization:
|
|
// C <- A %*% B
|
|
F77_NAME(dgemm)("N", "N", &nrowA, &ncolB, &ncolA,
|
|
&one, A, &nrowA, B, &nrowB,
|
|
&zero, C, &nrowA);
|
|
}
|
|
|
|
void crossprod(const double *A, const int nrowA, const int ncolA,
|
|
const double *B, const int nrowB, const int ncolB,
|
|
double *C) {
|
|
const double one = 1.0;
|
|
const double zero = 0.0;
|
|
|
|
// DGEMM with parameterization:
|
|
// C <- t(A) %*% B
|
|
F77_NAME(dgemm)("T", "N", &ncolA, &ncolB, &nrowA,
|
|
&one, A, &nrowA, B, &nrowB,
|
|
&zero, C, &ncolA);
|
|
}
|
|
|
|
void nullProj(const double *B, const int nrowB, const int ncolB,
|
|
double *Q) {
|
|
const double minusOne = -1.0;
|
|
const double one = 1.0;
|
|
|
|
// Initialize as identity matrix.
|
|
memset(Q, 0, sizeof(double) * nrowB * nrowB);
|
|
double *Q_diag, *Q_end = Q + nrowB * nrowB;
|
|
for (Q_diag = Q; Q_diag < Q_end; Q_diag += nrowB + 1) {
|
|
*Q_diag = 1.0;
|
|
}
|
|
|
|
// DGEMM with parameterization:
|
|
// C <- (-1.0 * B %*% t(B)) + C
|
|
F77_NAME(dgemm)("N", "T", &nrowB, &nrowB, &ncolB,
|
|
&minusOne, B, &nrowB, B, &nrowB,
|
|
&one, Q, &nrowB);
|
|
}
|
|
|
|
// A dence skwe-symmetric rank 2 update.
|
|
// Perform the update
|
|
// C := alpha (A * B^T - B * A^T) + beta C
|
|
void skewSymRank2k(const int nrow, const int ncol,
|
|
double alpha, const double *A, const double *B,
|
|
double beta,
|
|
double *C) {
|
|
F77_NAME(dgemm)("N", "T",
|
|
&nrow, &nrow, &ncol,
|
|
&alpha, A, &nrow, B, &nrow,
|
|
&beta, C, &nrow);
|
|
|
|
alpha *= -1.0;
|
|
beta = 1.0;
|
|
F77_NAME(dgemm)("N", "T",
|
|
&nrow, &nrow, &ncol,
|
|
&alpha, B, &nrow, A, &nrow,
|
|
&beta, C, &nrow);
|
|
}
|