void
inverse(std::vector<PetscScalar> & A, unsigned int n)
{
mooseAssert(n >= 1, "MatrixTools::inverse - n (leading dimension) needs to be positive");
mooseAssert(n <= std::numeric_limits<int>::max(),
"MatrixTools::inverse - n (leading dimension) too large");
std::vector<PetscBLASInt> ipiv(n);
std::vector<PetscScalar> buffer(n * 64);
// Following does a LU decomposition of "square matrix A"
// upon return "A = P*L*U" if return_value == 0
// Here I use quotes because A is actually an array of length n^2, not a matrix of size n-by-n
int return_value;
LAPACKgetrf_(reinterpret_cast<int *>(&n),
reinterpret_cast<int *>(&n),
&A[0],
reinterpret_cast<int *>(&n),
&ipiv[0],
&return_value);
if (return_value != 0)
throw MooseException(
return_value < 0
? "Argument " + Moose::stringify(-return_value) +
" was invalid during LU factorization in MatrixTools::inverse."
: "Matrix on-diagonal entry " + Moose::stringify(return_value) +
" was exactly zero during LU factorization in MatrixTools::inverse.");
// get the inverse of A
int buffer_size = buffer.size();
#if PETSC_VERSION_LESS_THAN(3, 5, 0)
FORTRAN_CALL(dgetri)
(reinterpret_cast<int *>(&n),
&A[0],
reinterpret_cast<int *>(&n),
&ipiv[0],
&buffer[0],
&buffer_size,
&return_value);
#else
LAPACKgetri_(reinterpret_cast<int *>(&n),
&A[0],
reinterpret_cast<int *>(&n),
&ipiv[0],
&buffer[0],
&buffer_size,
&return_value);
#endif
if (return_value != 0)
throw MooseException(return_value < 0
? "Argument " + Moose::stringify(-return_value) +
" was invalid during invert in MatrixTools::inverse."
: "Matrix on-diagonal entry " + Moose::stringify(return_value) +
" was exactly zero during invert in MatrixTools::inverse.");
}
/*@C
PetscLinearRegression - Gives the best least-squares linear fit to some x-y data points
Input Parameters:
+ n - The number of points
. x - The x-values
- y - The y-values
Output Parameters:
+ slope - The slope of the best-fit line
- intercept - The y-intercept of the best-fit line
Level: intermediate
.seealso: PetscConvEstGetConvRate()
@*/
PetscErrorCode PetscLinearRegression(PetscInt n, const PetscReal x[], const PetscReal y[], PetscReal *slope, PetscReal *intercept)
{
PetscScalar H[4];
PetscReal *X, *Y, beta[2];
PetscInt i, j, k;
PetscErrorCode ierr;
PetscFunctionBegin;
*slope = *intercept = 0.0;
ierr = PetscMalloc2(n*2, &X, n*2, &Y);CHKERRQ(ierr);
for (k = 0; k < n; ++k) {
/* X[n,2] = [1, x] */
X[k*2+0] = 1.0;
X[k*2+1] = x[k];
}
/* H = X^T X */
for (i = 0; i < 2; ++i) {
for (j = 0; j < 2; ++j) {
H[i*2+j] = 0.0;
for (k = 0; k < n; ++k) {
H[i*2+j] += X[k*2+i] * X[k*2+j];
}
}
}
/* H = (X^T X)^{-1} */
{
PetscBLASInt two = 2, ipiv[2], info;
PetscScalar work[2];
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
PetscStackCallBLAS("LAPACKgetrf", LAPACKgetrf_(&two, &two, H, &two, ipiv, &info));
PetscStackCallBLAS("LAPACKgetri", LAPACKgetri_(&two, H, &two, ipiv, work, &two, &info));
ierr = PetscFPTrapPop();CHKERRQ(ierr);
}
/* Y = H X^T */
for (i = 0; i < 2; ++i) {
for (k = 0; k < n; ++k) {
Y[i*n+k] = 0.0;
for (j = 0; j < 2; ++j) {
Y[i*n+k] += PetscRealPart(H[i*2+j]) * X[k*2+j];
}
}
}
/* beta = Y error = [y-intercept, slope] */
for (i = 0; i < 2; ++i) {
beta[i] = 0.0;
for (k = 0; k < n; ++k) {
beta[i] += Y[i*n+k] * y[k];
}
}
ierr = PetscFree2(X, Y);CHKERRQ(ierr);
*intercept = beta[0];
*slope = beta[1];
PetscFunctionReturn(0);
}
PetscErrorCode DSCond_NHEP(DS ds,PetscReal *cond)
{
#if defined(PETSC_MISSING_LAPACK_GETRF) || defined(SLEPC_MISSING_LAPACK_GETRI) || defined(SLEPC_MISSING_LAPACK_LANGE) || defined(SLEPC_MISSING_LAPACK_LANHS)
PetscFunctionBegin;
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GETRF/GETRI/LANGE/LANHS - Lapack routines are unavailable");
#else
PetscErrorCode ierr;
PetscScalar *work;
PetscReal *rwork;
PetscBLASInt *ipiv;
PetscBLASInt lwork,info,n,ld;
PetscReal hn,hin;
PetscScalar *A;
PetscFunctionBegin;
ierr = PetscBLASIntCast(ds->n,&n);CHKERRQ(ierr);
ierr = PetscBLASIntCast(ds->ld,&ld);CHKERRQ(ierr);
lwork = 8*ld;
ierr = DSAllocateWork_Private(ds,lwork,ld,ld);CHKERRQ(ierr);
work = ds->work;
rwork = ds->rwork;
ipiv = ds->iwork;
/* use workspace matrix W to avoid overwriting A */
ierr = DSAllocateMat_Private(ds,DS_MAT_W);CHKERRQ(ierr);
A = ds->mat[DS_MAT_W];
ierr = PetscMemcpy(A,ds->mat[DS_MAT_A],sizeof(PetscScalar)*ds->ld*ds->ld);CHKERRQ(ierr);
/* norm of A */
if (ds->state<DS_STATE_INTERMEDIATE) hn = LAPACKlange_("I",&n,&n,A,&ld,rwork);
else hn = LAPACKlanhs_("I",&n,A,&ld,rwork);
/* norm of inv(A) */
PetscStackCallBLAS("LAPACKgetrf",LAPACKgetrf_(&n,&n,A,&ld,ipiv,&info));
if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGETRF %d",info);
PetscStackCallBLAS("LAPACKgetri",LAPACKgetri_(&n,A,&ld,ipiv,work,&lwork,&info));
if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGETRI %d",info);
hin = LAPACKlange_("I",&n,&n,A,&ld,rwork);
*cond = hn*hin;
PetscFunctionReturn(0);
#endif
}
PetscErrorCode PetscFESetUp_Composite(PetscFE fem)
{
PetscFE_Composite *cmp = (PetscFE_Composite *) fem->data;
DM K;
PetscReal *subpoint;
PetscBLASInt *pivots;
PetscBLASInt n, info;
PetscScalar *work, *invVscalar;
PetscInt dim, pdim, spdim, j, s;
PetscErrorCode ierr;
PetscFunctionBegin;
/* Get affine mapping from reference cell to each subcell */
ierr = PetscDualSpaceGetDM(fem->dualSpace, &K);CHKERRQ(ierr);
ierr = DMGetDimension(K, &dim);CHKERRQ(ierr);
ierr = DMPlexGetCellRefiner_Internal(K, &cmp->cellRefiner);CHKERRQ(ierr);
ierr = CellRefinerGetAffineTransforms_Internal(cmp->cellRefiner, &cmp->numSubelements, &cmp->v0, &cmp->jac, &cmp->invjac);CHKERRQ(ierr);
/* Determine dof embedding into subelements */
ierr = PetscDualSpaceGetDimension(fem->dualSpace, &pdim);CHKERRQ(ierr);
ierr = PetscSpaceGetDimension(fem->basisSpace, &spdim);CHKERRQ(ierr);
ierr = PetscMalloc1(cmp->numSubelements*spdim,&cmp->embedding);CHKERRQ(ierr);
ierr = DMGetWorkArray(K, dim, MPIU_REAL, &subpoint);CHKERRQ(ierr);
for (s = 0; s < cmp->numSubelements; ++s) {
PetscInt sd = 0;
for (j = 0; j < pdim; ++j) {
PetscBool inside;
PetscQuadrature f;
PetscInt d, e;
ierr = PetscDualSpaceGetFunctional(fem->dualSpace, j, &f);CHKERRQ(ierr);
/* Apply transform to first point, and check that point is inside subcell */
for (d = 0; d < dim; ++d) {
subpoint[d] = -1.0;
for (e = 0; e < dim; ++e) subpoint[d] += cmp->invjac[(s*dim + d)*dim+e]*(f->points[e] - cmp->v0[s*dim+e]);
}
ierr = CellRefinerInCellTest_Internal(cmp->cellRefiner, subpoint, &inside);CHKERRQ(ierr);
if (inside) {cmp->embedding[s*spdim+sd++] = j;}
}
if (sd != spdim) SETERRQ3(PetscObjectComm((PetscObject) fem), PETSC_ERR_PLIB, "Subelement %d has %d dual basis vectors != %d", s, sd, spdim);
}
ierr = DMRestoreWorkArray(K, dim, MPIU_REAL, &subpoint);CHKERRQ(ierr);
/* Construct the change of basis from prime basis to nodal basis for each subelement */
ierr = PetscMalloc1(cmp->numSubelements*spdim*spdim,&fem->invV);CHKERRQ(ierr);
ierr = PetscMalloc2(spdim,&pivots,spdim,&work);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
ierr = PetscMalloc1(cmp->numSubelements*spdim*spdim,&invVscalar);CHKERRQ(ierr);
#else
invVscalar = fem->invV;
#endif
for (s = 0; s < cmp->numSubelements; ++s) {
for (j = 0; j < spdim; ++j) {
PetscReal *Bf;
PetscQuadrature f;
const PetscReal *points, *weights;
PetscInt Nc, Nq, q, k;
ierr = PetscDualSpaceGetFunctional(fem->dualSpace, cmp->embedding[s*spdim+j], &f);CHKERRQ(ierr);
ierr = PetscQuadratureGetData(f, NULL, &Nc, &Nq, &points, &weights);CHKERRQ(ierr);
ierr = PetscMalloc1(f->numPoints*spdim*Nc,&Bf);CHKERRQ(ierr);
ierr = PetscSpaceEvaluate(fem->basisSpace, Nq, points, Bf, NULL, NULL);CHKERRQ(ierr);
for (k = 0; k < spdim; ++k) {
/* n_j \cdot \phi_k */
invVscalar[(s*spdim + j)*spdim+k] = 0.0;
for (q = 0; q < Nq; ++q) {
invVscalar[(s*spdim + j)*spdim+k] += Bf[q*spdim+k]*weights[q];
}
}
ierr = PetscFree(Bf);CHKERRQ(ierr);
}
n = spdim;
PetscStackCallBLAS("LAPACKgetrf", LAPACKgetrf_(&n, &n, &invVscalar[s*spdim*spdim], &n, pivots, &info));
PetscStackCallBLAS("LAPACKgetri", LAPACKgetri_(&n, &invVscalar[s*spdim*spdim], &n, pivots, work, &n, &info));
}
#if defined(PETSC_USE_COMPLEX)
for (s = 0; s <cmp->numSubelements*spdim*spdim; s++) fem->invV[s] = PetscRealPart(invVscalar[s]);
ierr = PetscFree(invVscalar);CHKERRQ(ierr);
#endif
ierr = PetscFree2(pivots,work);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
