// Matrix power by squaring: P = A^b (A is garbage on exit)
static void matpow_by_squaring(double *A, int n, int b, double *P)
{
double *TMP;
mateye(n, P);
// Trivial cases
if (b == 0)
return;
if (b == 1)
{
matcopy(n, A, P);
return;
}
// General case
TMP = malloc(n*n*sizeof(double));
while (b)
{
if (b&1)
{
matprod(n, P, A, TMP);
matcopy(n, TMP, P);
}
b >>= 1;
matprod(n, A, A, TMP);
matcopy(n, TMP, A);
}
free(TMP);
}
/* The gateway function */
void mexFunction( int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[])
{
double *inMatrix1; /* 1xN input matrix */
double *inMatrix2; /* 1xN input matrix */
size_t ncols; /* size of matrix */
double *outMatrix; /* output matrix */
/* check for proper number of arguments */
if(nrhs!=2) {
mexErrMsgIdAndTxt("MyToolbox:arrayProduct:nrhs","Two inputs required.");
}
if(nlhs!=1) {
mexErrMsgIdAndTxt("MyToolbox:arrayProduct:nlhs","One output required.");
}
/* get the value of the scalar input */
inMatrix1 = mxGetPr(prhs[0]);
/* create a pointer to the real data in the input matrix */
inMatrix2 = mxGetPr(prhs[1]);
/* get dimensions of the input matrix */
ncols = mxGetN(prhs[1]);
/* create the output matrix */
plhs[0] = mxCreateDoubleMatrix((mwSize)ncols,(mwSize)ncols,mxREAL);
/* get a pointer to the real data in the output matrix */
outMatrix = mxGetPr(plhs[0]);
/* call the computational routine */
matprod(inMatrix1,inMatrix2,outMatrix,(mwSize)ncols);
}
/* computes matrix product between submatrix of M and vector v */
SEXP submatprod(SEXP M, SEXP v, SEXP am, SEXP nr, SEXP nc) {
R_len_t a = INTEGER(am)[0], nrm = INTEGER(nr)[0], ncm = INTEGER(nc)[0];
SEXP ans;
PROTECT(ans = allocVector(REALSXP, nrm));
matprod(REAL(M) + a, nrm, ncm,
REAL(v), ncm, 1, REAL(ans));
UNPROTECT(1);
return(ans);
}
int main(int argc, char *argv[]) {
int c, n_tot, n_inc, nvecs, a, b, L_inc, L_tot, l, i ;
char *geno_file, *evec_file, *freq_file, *outfile ; //, outfile[250] ;
double *v, *x, *xx, *y, *freq ;
bool *snp_include, *indiv_include, *evec_include, rescale=FALSE, verbose=false ;
FILE *f ;
while((c = getopt(argc, argv, "a:b:N:V:L:g:e:f:o:sv")) != -1) {
switch(c) {
case 'a':
a = atoi(optarg) - 1; break ;
case 'b':
b = atoi(optarg) ; break ;
case 'N':
n_tot = atoi(optarg) ; break ;
case 'V':
nvecs = atoi(optarg) ; break ;
case 'L':
L_tot = atoi(optarg) ; break ;
case 'g':
geno_file = optarg ; break ;
case 'e':
evec_file = optarg ; break ;
case 'f':
freq_file = optarg ; break ;
case 'o':
outfile = optarg ; break ;
case 's':
rescale = TRUE ; break ;
case 'v':
verbose = true ; break ;
case '?':
ERROR("Unrecognised option") ;
}
}
assert(a >= 0 && b >= a) ;
// PRINT("%s\t/* Construct inclusion vectors */\n", timestring()) ; fflush(stdout) ;
indiv_include = NULL ;
n_inc = n_tot ;
evec_include = NULL ;
snp_include = ALLOC(L_tot, bool) ;
L_inc = 0 ;
for(l = 0 ; l < L_tot ; l++) {
snp_include[l] = (l >= a && l < b) ;
if( snp_include[l] ) L_inc++ ;
}
assert(L_inc == b - a) ;
if(verbose) {
PRINT("# %s\tComputing projection of genotype data into Principal Coordinate space\n",
timestring()) ; fflush(stdout) ;
PRINT("# number of SNPs = %d\n", L_tot) ;
// PRINT("# [a,b) = [%d,%d) -> L_inc = %d\n", a, b, L_inc) ;
PRINT("# number of individuals = %d\n", n_tot) ;
// PRINT("n_inc = %d\n", n_inc) ;
PRINT("# number of PCs = %d\n", nvecs) ;
PRINT("# genotype data file = %s\n", geno_file) ;
PRINT("# Principal components file = %s\n", evec_file) ;
PRINT("# Allele frequency file = %s\n", freq_file) ;
// PRINT("outfile = %s\n", outfile) ;
}
if(verbose)
PRINT("%s\t/* Read eigenvectors */\n", timestring()) ; fflush(stdout) ;
// v = nvecs x L_inc, column major
v = ALLOC(L_inc * nvecs, double) ; // was nvecs * ninc in snpload.c
f = fopen(evec_file, "r") ;
read_submatrix_double(f, nvecs, evec_include, L_tot, snp_include, "%lf", v) ; // differs from snpload.c
fclose(f) ;
if(verbose)
PRINT("%s\t/* Read genotypes */\n", timestring()) ; fflush(stdout) ;
// x is n_tot x L_inc, column major
x = ALLOC(L_inc * n_inc, double) ;
f = fopen(geno_file, "r") ;
read_submatrix_genotypes_double(f, n_tot, indiv_include, L_tot, snp_include, x) ;
fclose(f) ;
if(verbose) {
PRINT("%s\t/* First %d entries of genotypes x: */\n", timestring(), MIN(n_inc*nvecs, 100)) ;
for(i = 0 ; i < MIN(n_inc*nvecs, 100) ; i++) PRINT("%lf ", x[i]) ;
putchar('\n') ;
}
if(verbose)
PRINT("%s\t/* Read freqs */\n", timestring()) ; fflush(stdout) ;
freq = ALLOC(L_inc, double) ;
f = fopen(freq_file, "r") ;
read_submatrix_double(f, L_tot, snp_include, 1, NULL, "%lf", freq) ;
fclose(f) ;
if(verbose)
PRINT("%s\t/* Set NAs to freq */\n", timestring()) ; fflush(stdout) ;
xx = x ;
for(l = 0 ; l < L_inc ; l++)
for(i = 0 ; i < n_inc ; i++, xx++) {
if( rescale ) {
if(*xx == MISSING) *xx = 0.0 ;
else {
*xx -= 2 * freq[l];
*xx /= sqrt(2 * freq[l] * (1 - freq[l]));
}
}
else if(*xx == MISSING) *xx = 2*freq[l] ;
}
if(verbose) {
PRINT("%s\t/* First %d entries of freqs: */\n", timestring(), MIN(L_inc, 100)) ;
for(i = 0 ; i < MIN(L_inc, 100) ; i++) PRINT("%lf ", freq[i]) ;
putchar('\n') ;
}
if(verbose)
PRINT("%s\t/* Compute projection */\n", timestring()) ; fflush(stdout) ;
/* Now compute XV' which is n_tot x nvecs */
y = matprod(x, v, FALSE, TRUE, n_tot, L_inc, nvecs, L_inc, 1.0) ; // differs from snpload.c
// sprintf(outfile, "%s-%d-%d", outfile_partial, a+1, b) ;
f = fopen(outfile, "w") ;
write_matrix_double(y, f, n_tot, nvecs, "%lf ") ; // differs from snpload.c
fclose(f) ;
FREE(y) ;
FREE(snp_include) ;
FREE(v) ;
FREE(x) ;
FREE(freq) ;
if(verbose) PRINT("%s\t/* Done */\n", timestring()) ;
return 0 ;
}
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */
SEXP attribute_hidden do_earg_matprod(SEXP call, SEXP op, SEXP arg_x, SEXP arg_y, SEXP rho)
{
int ldx, ldy, nrx, ncx, nry, ncy, mode;
SEXP x = arg_x, y = arg_y, xdims, ydims, ans;
Rboolean sym;
sym = isNull(y);
if (sym && (PRIMVAL(op) > 0)) y = x;
if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
errorcall(call, _("requires numeric/complex matrix/vector arguments"));
xdims = getDimAttrib(x);
ydims = getDimAttrib(y);
ldx = length(xdims);
ldy = length(ydims);
if (ldx != 2 && ldy != 2) { /* x and y non-matrices */
if (PRIMVAL(op) == 0) {
nrx = 1;
ncx = LENGTH(x);
}
else {
nrx = LENGTH(x);
ncx = 1;
}
nry = LENGTH(y);
ncy = 1;
}
else if (ldx != 2) { /* x not a matrix */
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
nrx = 0;
ncx = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(x) == nry) { /* x as row vector */
nrx = 1;
ncx = nry; /* == LENGTH(x) */
}
else if (nry == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(x) == nry) { /* x is a col vector */
nrx = nry; /* == LENGTH(x) */
ncx = 1;
}
/* else if (nry == 1) ... not being too tolerant
to treat x as row vector, as t(x) *is* row vector */
}
else { /* tcrossprod */
if (LENGTH(x) == ncy) { /* x as row vector */
nrx = 1;
ncx = ncy; /* == LENGTH(x) */
}
else if (ncy == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldy != 2) { /* y not a matrix */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = 0;
ncy = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(y) == ncx) { /* y as col vector */
nry = ncx;
ncy = 1;
}
else if (ncx == 1) { /* y as row vector */
nry = 1;
ncy = LENGTH(y);
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(y) == nrx) { /* y is a col vector */
nry = nrx;
ncy = 1;
}
}
else { /* tcrossprod -- y is a col vector */
nry = LENGTH(y);
ncy = 1;
}
}
else { /* x and y matrices */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
}
/* nr[ow](.) and nc[ol](.) are now defined for x and y */
if (PRIMVAL(op) == 0) {
/* primitive, so use call */
if (ncx != nry)
errorcall(call, _("non-conformable arguments"));
}
else if (PRIMVAL(op) == 1) {
if (nrx != nry)
error(_("non-conformable arguments"));
}
else {
if (ncx != ncy)
error(_("non-conformable arguments"));
}
if (isComplex(x) || isComplex(y))
mode = CPLXSXP;
else
mode = REALSXP;
x = coerceVector(x, mode);
y = coerceVector(y, mode);
if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */
PROTECT(ans = allocMatrix(mode, nrx, ncy));
if (mode == CPLXSXP)
cmatprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else
matprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
PROTECT(xdims = getDimNamesAttrib(x));
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2 || ncx == 1) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
#define YDIMS_ET_CETERA \
if (ydims != R_NilValue) { \
if (ldy == 2) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \
dny = getNamesAttrib(ydims); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \
} else if (nry == 1) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \
dny = getNamesAttrib(ydims); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \
} \
} \
\
/* We sometimes attach a dimnames attribute \
* whose elements are all NULL ... \
* This is ugly but causes no real damage. \
* Now (2.1.0 ff), we don't anymore: */ \
if (VECTOR_ELT(dimnames,0) != R_NilValue || \
VECTOR_ELT(dimnames,1) != R_NilValue) { \
if (dnx != R_NilValue || dny != R_NilValue) \
setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \
setAttrib(ans, R_DimNamesSymbol, dimnames); \
} \
UNPROTECT(2)
YDIMS_ET_CETERA;
}
}
else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */
PROTECT(ans = allocMatrix(mode, ncx, ncy));
if (mode == CPLXSXP)
if(sym)
ccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(x), nry, ncy, COMPLEX(ans));
else
ccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else {
if(sym)
symcrossprod(REAL(x), nrx, ncx, REAL(ans));
else
crossprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
}
PROTECT(xdims = getDimNamesAttrib(x));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
}
}
YDIMS_ET_CETERA;
}
}
else { /* op == 2: tcrossprod() */
PROTECT(ans = allocMatrix(mode, nrx, nry));
if (mode == CPLXSXP)
if(sym)
tccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(x), nry, ncy, COMPLEX(ans));
else
tccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else {
if(sym)
symtcrossprod(REAL(x), nrx, ncx, REAL(ans));
else
tcrossprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
}
PROTECT(xdims = getDimNamesAttrib(x));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
if (ydims != R_NilValue) {
if (ldy == 2) {
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0));
dny = getNamesAttrib(ydims);
if(!isNull(dny))
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0));
}
}
if (VECTOR_ELT(dimnames,0) != R_NilValue ||
VECTOR_ELT(dimnames,1) != R_NilValue) {
if (dnx != R_NilValue || dny != R_NilValue)
setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
setAttrib(ans, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
}
UNPROTECT(3);
return ans;
}
inline std::pair<typename SteadyStateUpscaler<Traits>::permtensor_t,
typename SteadyStateUpscaler<Traits>::permtensor_t>
SteadyStateUpscaler<Traits>::
upscaleSteadyState(const int flow_direction,
const std::vector<double>& initial_saturation,
const double boundary_saturation,
const double pressure_drop,
const permtensor_t& upscaled_perm)
{
static int count = 0;
++count;
int num_cells = this->ginterf_.numberOfCells();
// No source or sink.
std::vector<double> src(num_cells, 0.0);
Opm::SparseVector<double> injection(num_cells);
// Gravity.
Dune::FieldVector<double, 3> gravity(0.0);
if (use_gravity_) {
gravity[2] = Opm::unit::gravity;
}
if (gravity.two_norm() > 0.0) {
OPM_MESSAGE("Warning: Gravity is experimental for flow solver.");
}
// Set up initial saturation profile.
std::vector<double> saturation = initial_saturation;
// Set up boundary conditions.
setupUpscalingConditions(this->ginterf_, this->bctype_, flow_direction,
pressure_drop, boundary_saturation, this->twodim_hack_, this->bcond_);
// Set up solvers.
if (flow_direction == 0) {
this->flow_solver_.init(this->ginterf_, this->res_prop_, gravity, this->bcond_);
}
transport_solver_.initObj(this->ginterf_, this->res_prop_, this->bcond_);
// Run pressure solver.
this->flow_solver_.solve(this->res_prop_, saturation, this->bcond_, src,
this->residual_tolerance_, this->linsolver_verbosity_,
this->linsolver_type_, false,
this->linsolver_maxit_, this->linsolver_prolongate_factor_,
this->linsolver_smooth_steps_);
double max_mod = this->flow_solver_.postProcessFluxes();
std::cout << "Max mod = " << max_mod << std::endl;
// Do a run till steady state. For now, we just do some pressure and transport steps...
std::vector<double> saturation_old = saturation;
for (int iter = 0; iter < simulation_steps_; ++iter) {
// Run transport solver.
transport_solver_.transportSolve(saturation, stepsize_, gravity, this->flow_solver_.getSolution(), injection);
// Run pressure solver.
this->flow_solver_.solve(this->res_prop_, saturation, this->bcond_, src,
this->residual_tolerance_, this->linsolver_verbosity_,
this->linsolver_type_, false,
this->linsolver_maxit_, this->linsolver_prolongate_factor_,
this->linsolver_smooth_steps_);
max_mod = this->flow_solver_.postProcessFluxes();
std::cout << "Max mod = " << max_mod << std::endl;
// Print in-out flows if requested.
if (print_inoutflows_) {
std::pair<double, double> w_io, o_io;
computeInOutFlows(w_io, o_io, this->flow_solver_.getSolution(), saturation);
std::cout << "Pressure step " << iter
<< "\nWater flow [in] " << w_io.first
<< " [out] " << w_io.second
<< "\nOil flow [in] " << o_io.first
<< " [out] " << o_io.second
<< std::endl;
}
// Output.
if (output_vtk_) {
writeVtkOutput(this->ginterf_,
this->res_prop_,
this->flow_solver_.getSolution(),
saturation,
std::string("output-steadystate")
+ '-' + boost::lexical_cast<std::string>(count)
+ '-' + boost::lexical_cast<std::string>(flow_direction)
+ '-' + boost::lexical_cast<std::string>(iter));
}
// Comparing old to new.
int num_cells = saturation.size();
double maxdiff = 0.0;
for (int i = 0; i < num_cells; ++i) {
maxdiff = std::max(maxdiff, std::fabs(saturation[i] - saturation_old[i]));
}
#ifdef VERBOSE
std::cout << "Maximum saturation change: " << maxdiff << std::endl;
#endif
if (maxdiff < sat_change_threshold_) {
#ifdef VERBOSE
std::cout << "Maximum saturation change is under steady state threshold." << std::endl;
#endif
break;
}
// Copy to old.
saturation_old = saturation;
}
// Compute phase mobilities.
// First: compute maximal mobilities.
typedef typename Super::ResProp::Mobility Mob;
Mob m;
double m1max = 0;
double m2max = 0;
for (int c = 0; c < num_cells; ++c) {
this->res_prop_.phaseMobility(0, c, saturation[c], m.mob);
m1max = maxMobility(m1max, m.mob);
this->res_prop_.phaseMobility(1, c, saturation[c], m.mob);
m2max = maxMobility(m2max, m.mob);
}
// Second: set thresholds.
const double mob1_abs_thres = relperm_threshold_ / this->res_prop_.viscosityFirstPhase();
const double mob1_rel_thres = m1max / maximum_mobility_contrast_;
const double mob1_threshold = std::max(mob1_abs_thres, mob1_rel_thres);
const double mob2_abs_thres = relperm_threshold_ / this->res_prop_.viscositySecondPhase();
const double mob2_rel_thres = m2max / maximum_mobility_contrast_;
const double mob2_threshold = std::max(mob2_abs_thres, mob2_rel_thres);
// Third: extract and threshold.
std::vector<Mob> mob1(num_cells);
std::vector<Mob> mob2(num_cells);
for (int c = 0; c < num_cells; ++c) {
this->res_prop_.phaseMobility(0, c, saturation[c], mob1[c].mob);
thresholdMobility(mob1[c].mob, mob1_threshold);
this->res_prop_.phaseMobility(1, c, saturation[c], mob2[c].mob);
thresholdMobility(mob2[c].mob, mob2_threshold);
}
// Compute upscaled relperm for each phase.
ReservoirPropertyFixedMobility<Mob> fluid_first(mob1);
permtensor_t eff_Kw = Super::upscaleEffectivePerm(fluid_first);
ReservoirPropertyFixedMobility<Mob> fluid_second(mob2);
permtensor_t eff_Ko = Super::upscaleEffectivePerm(fluid_second);
// Set the steady state saturation fields for eventual outside access.
last_saturation_state_.swap(saturation);
// Compute the (anisotropic) upscaled mobilities.
// eff_Kw := lambda_w*K
// => lambda_w = eff_Kw*inv(K);
permtensor_t lambda_w(matprod(eff_Kw, inverse3x3(upscaled_perm)));
permtensor_t lambda_o(matprod(eff_Ko, inverse3x3(upscaled_perm)));
// Compute (anisotropic) upscaled relative permeabilities.
// lambda = k_r/mu
permtensor_t k_rw(lambda_w);
k_rw *= this->res_prop_.viscosityFirstPhase();
permtensor_t k_ro(lambda_o);
k_ro *= this->res_prop_.viscositySecondPhase();
return std::make_pair(k_rw, k_ro);
}
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */
SEXP attribute_hidden do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int ldx, ldy, nrx, ncx, nry, ncy, mode;
SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans;
Rboolean sym;
if (PRIMVAL(op) == 0 && /* %*% is primitive, the others are .Internal() */
(IS_S4_OBJECT(x) || IS_S4_OBJECT(y))
&& R_has_methods(op)) {
SEXP s, value;
/* Remove argument names to ensure positional matching */
for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
value = R_possible_dispatch(call, op, args, rho, FALSE);
if (value) return value;
}
sym = isNull(y);
if (sym && (PRIMVAL(op) > 0)) y = x;
if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
errorcall(call, _("requires numeric/complex matrix/vector arguments"));
xdims = getAttrib(x, R_DimSymbol);
ydims = getAttrib(y, R_DimSymbol);
ldx = length(xdims);
ldy = length(ydims);
if (ldx != 2 && ldy != 2) { /* x and y non-matrices */
// for crossprod, allow two cases: n x n ==> (1,n) x (n,1); 1 x n = (n, 1) x (1, n)
if (PRIMVAL(op) == 1 && LENGTH(x) == 1) {
nrx = ncx = nry = 1;
ncy = LENGTH(y);
}
else {
nry = LENGTH(y);
ncy = 1;
if (PRIMVAL(op) == 0) {
nrx = 1;
ncx = LENGTH(x);
if(ncx == 1) { // y as row vector
ncy = nry;
nry = 1;
}
}
else {
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldx != 2) { /* x not a matrix */
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
nrx = 0;
ncx = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(x) == nry) { /* x as row vector */
nrx = 1;
ncx = nry; /* == LENGTH(x) */
}
else if (nry == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(x) == nry) { /* x is a col vector */
nrx = nry; /* == LENGTH(x) */
ncx = 1;
}
/* else if (nry == 1) ... not being too tolerant
to treat x as row vector, as t(x) *is* row vector */
}
else { /* tcrossprod */
if (LENGTH(x) == ncy) { /* x as row vector */
nrx = 1;
ncx = ncy; /* == LENGTH(x) */
}
else if (ncy == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldy != 2) { /* y not a matrix */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = 0;
ncy = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(y) == ncx) { /* y as col vector */
nry = ncx;
ncy = 1;
}
else if (ncx == 1) { /* y as row vector */
nry = 1;
ncy = LENGTH(y);
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(y) == nrx) { /* y is a col vector */
nry = nrx;
ncy = 1;
} else if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
}
else { // tcrossprod
if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
else { // y is a col vector
nry = LENGTH(y);
ncy = 1;
}
}
}
else { /* x and y matrices */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
}
/* nr[ow](.) and nc[ol](.) are now defined for x and y */
if (PRIMVAL(op) == 0) {
/* primitive, so use call */
if (ncx != nry)
errorcall(call, _("non-conformable arguments"));
}
else if (PRIMVAL(op) == 1) {
if (nrx != nry)
error(_("non-conformable arguments"));
}
else {
if (ncx != ncy)
error(_("non-conformable arguments"));
}
if (isComplex(CAR(args)) || isComplex(CADR(args)))
mode = CPLXSXP;
else
mode = REALSXP;
SETCAR(args, coerceVector(CAR(args), mode));
SETCADR(args, coerceVector(CADR(args), mode));
if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */
PROTECT(ans = allocMatrix(mode, nrx, ncy));
if (mode == CPLXSXP)
cmatprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else
matprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2 || ncx == 1) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
#define YDIMS_ET_CETERA \
if (ydims != R_NilValue) { \
if (ldy == 2) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \
} else if (nry == 1) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \
} \
} \
\
/* We sometimes attach a dimnames attribute \
* whose elements are all NULL ... \
* This is ugly but causes no real damage. \
* Now (2.1.0 ff), we don't anymore: */ \
if (VECTOR_ELT(dimnames,0) != R_NilValue || \
VECTOR_ELT(dimnames,1) != R_NilValue) { \
if (dnx != R_NilValue || dny != R_NilValue) \
setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \
setAttrib(ans, R_DimNamesSymbol, dimnames); \
} \
UNPROTECT(2)
YDIMS_ET_CETERA;
}
}
else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */
PROTECT(ans = allocMatrix(mode, ncx, ncy));
if (mode == CPLXSXP)
if(sym)
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
crossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
}
}
YDIMS_ET_CETERA;
}
}
else { /* op == 2: tcrossprod() */
PROTECT(ans = allocMatrix(mode, nrx, nry));
if (mode == CPLXSXP)
if(sym)
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symtcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
tcrossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
if (ydims != R_NilValue) {
if (ldy == 2) {
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0));
dny = getAttrib(ydims, R_NamesSymbol);
if(!isNull(dny))
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0));
}
}
if (VECTOR_ELT(dimnames,0) != R_NilValue ||
VECTOR_ELT(dimnames,1) != R_NilValue) {
if (dnx != R_NilValue || dny != R_NilValue)
setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
setAttrib(ans, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
}
UNPROTECT(3);
return ans;
}
int main(void) {
// Construct a new 3x6 matrix
MATRIX a = new_matrix(3,6);
puts("Initial matrix a:");
print_matrix(&a);
puts("Modified matrix a:");
set(&a, 1, 1, 20.0);
set(&a, 2, 2, 40.0);
set(&a, 0, 4, 60.0);
set(&a, 2, 5, 80.0);
change(&a);
print_matrix(&a);
puts("Element a(2,2):");
print_value(get(&a, 2, 2));
puts("");
puts("Element a(0,4):");
print_value(get(&a, 0, 4));
puts("");
// Construct a new 6x5 matrix
MATRIX b = new_matrix(6,5);
set(&b, 0, 4, 10.0);
set(&b, 2, 3, 30.0);
set(&b, 3, 1, 50.0);
set(&b, 5, 0, 70.0);
change(&b);
puts("Matrix b:");
print_matrix(&b);
puts("");
// Construct a new 4x7 matrix
MATRIX c = new_matrix(4,7);
set(&c, 0, 1, 10.0);
set(&c, 1, 2, 10.0);
set(&c, 2, 3, 10.0);
set(&c, 3, 4, 10.0);
set(&c, 3, 5, 10.0);
set(&c, 2, 6, 10.0);
change(&c);
puts("Matrix c:");
print_matrix(&c);
puts("");
// Test matprod with a product defined case
puts("The product ab is:");
MATRIX m = matprod(&a,&b);
print_matrix(&m);
puts("");
// Test matprod with an undefined product case
puts("The product ac is:");
MATRIX n = matprod(&a,&c);
print_matrix(&n);
puts("");
// Destruct matrices when done
delete_matrix(a);
delete_matrix(b);
delete_matrix(c);
delete_matrix(m);
delete_matrix(n);
return 0;
}
int main( int argc, char *argv[] ) {
int n=1000,i,k, tb=100;
clock_t tic,toc;
int nb=n/tb; //numero de bloques
double *A = (double *) malloc( n*n*sizeof(double) );
double *B = (double *) malloc( n*n*sizeof(double) );
double *C = (double *) malloc( n*n*sizeof(double) );
/* Reservamos memoria para los datos */
/* Lo probamos */
int j;
for( j=0; j<n; j++ ) {
for( i=0; i<n; i++ ) {
A[i+j*n] = ((double) rand()/ RAND_MAX);
}
}
for( j=0; j<n; j++ ) {
for( i=0; i<n; i++ ) {
B[i+j*n] = ((double) rand()/ RAND_MAX);
}
}
tic = clock();
matprod(A,B,C,n);
toc = clock();
printf("\n Elapsed: %f seconds\n", (double)(toc - tic) / CLOCKS_PER_SEC);
// Print_matrix(C, n);
/*a bloques sin copia*/
for( j=0; j<n; j++ ) {
for( i=0; i<n; i++ ) {
C[i+j*n] = 0.0;
}
}
// Print_matrix(C, n);
tic = clock();
matprodbloques(A,B,C,n,tb);
toc = clock();
printf("\n Elapsed bloques sin copia: %f seconds\n", (double)(toc - tic) / CLOCKS_PER_SEC);
// Print_matrix(C, n);
for( j=0; j<n; j++ ) {
for( i=0; i<n; i++ ) {
C[i+j*n] = 0.0;
}
}
/*a bloques con copia*/
tic = clock();
To_blocked(A, n, tb);
To_blocked(B, n, tb);
Blocked_mat_mult(A,B,C,nb,tb);
From_blocked(C, n, tb);
toc = clock();
printf("\n Elapsed bloques con copia: %f seconds\n", (double)(toc - tic) / CLOCKS_PER_SEC);
// Print_matrix(C, n);
free(A);
free(B);
free(C);
return 0;
}