/*@
PetscDTGaussQuadrature - create Gauss quadrature
Not Collective
Input Arguments:
+ npoints - number of points
. a - left end of interval (often-1)
- b - right end of interval (often +1)
Output Arguments:
+ x - quadrature points
- w - quadrature weights
Level: intermediate
References:
Golub and Welsch, Calculation of Quadrature Rules, Math. Comp. 23(106), 221--230, 1969.
.seealso: PetscDTLegendreEval()
@*/
PetscErrorCode PetscDTGaussQuadrature(PetscInt npoints,PetscReal a,PetscReal b,PetscReal *x,PetscReal *w)
{
PetscErrorCode ierr;
PetscInt i;
PetscReal *work;
PetscScalar *Z;
PetscBLASInt N,LDZ,info;
PetscFunctionBegin;
/* Set up the Golub-Welsch system */
for (i=0; i<npoints; i++) {
x[i] = 0; /* diagonal is 0 */
if (i) w[i-1] = 0.5 / PetscSqrtReal(1 - 1./PetscSqr(2*i));
}
ierr = PetscRealView(npoints-1,w,PETSC_VIEWER_STDOUT_SELF);CHKERRQ(ierr);
ierr = PetscMalloc2(npoints*npoints,PetscScalar,&Z,PetscMax(1,2*npoints-2),PetscReal,&work);CHKERRQ(ierr);
ierr = PetscBLASIntCast(npoints,&N);CHKERRQ(ierr);
LDZ = N;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
PetscStackCall("LAPACKsteqr",LAPACKsteqr_("I",&N,x,w,Z,&LDZ,work,&info));
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"xSTEQR error");
for (i=0; i<(npoints+1)/2; i++) {
PetscReal y = 0.5 * (-x[i] + x[npoints-i-1]); /* enforces symmetry */
x[i] = (a+b)/2 - y*(b-a)/2;
x[npoints-i-1] = (a+b)/2 + y*(b-a)/2;
w[i] = w[npoints-1-i] = (b-a)*PetscSqr(0.5*PetscAbsScalar(Z[i*npoints] + Z[(npoints-i-1)*npoints]));
}
ierr = PetscFree2(Z,work);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode SNESMonitorJacUpdateSpectrum(SNES snes,PetscInt it,PetscReal fnorm,void *ctx)
{
#if defined(PETSC_MISSING_LAPACK_GEEV)
SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
#elif defined(PETSC_HAVE_ESSL)
SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"GEEV - No support for ESSL Lapack Routines");
#else
Vec X;
Mat J,dJ,dJdense;
PetscErrorCode ierr;
PetscErrorCode (*func)(SNES,Vec,Mat*,Mat*,MatStructure*,void*);
PetscInt n,i;
PetscBLASInt nb,lwork;
PetscReal *eigr,*eigi;
MatStructure flg = DIFFERENT_NONZERO_PATTERN;
PetscScalar *work;
PetscScalar *a;
PetscFunctionBegin;
if (it == 0) PetscFunctionReturn(0);
/* create the difference between the current update and the current jacobian */
ierr = SNESGetSolution(snes,&X);CHKERRQ(ierr);
ierr = SNESGetJacobian(snes,&J,NULL,&func,NULL);CHKERRQ(ierr);
ierr = MatDuplicate(J,MAT_COPY_VALUES,&dJ);CHKERRQ(ierr);
ierr = SNESComputeJacobian(snes,X,&dJ,&dJ,&flg);CHKERRQ(ierr);
ierr = MatAXPY(dJ,-1.0,J,SAME_NONZERO_PATTERN);CHKERRQ(ierr);
/* compute the spectrum directly */
ierr = MatConvert(dJ,MATSEQDENSE,MAT_INITIAL_MATRIX,&dJdense);CHKERRQ(ierr);
ierr = MatGetSize(dJ,&n,NULL);CHKERRQ(ierr);
ierr = PetscBLASIntCast(n,&nb);CHKERRQ(ierr);
lwork = 3*nb;
ierr = PetscMalloc(n*sizeof(PetscReal),&eigr);CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscReal),&eigi);CHKERRQ(ierr);
ierr = PetscMalloc(lwork*sizeof(PetscScalar),&work);CHKERRQ(ierr);
ierr = MatDenseGetArray(dJdense,&a);CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
{
PetscBLASInt lierr;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
PetscStackCall("LAPACKgeev",LAPACKgeev_("N","N",&nb,a,&nb,eigr,eigi,NULL,&nb,NULL,&nb,work,&lwork,&lierr));
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"geev() error %d",lierr);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
}
#else
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not coded for complex");
#endif
PetscPrintf(PetscObjectComm((PetscObject)snes),"Eigenvalues of J_%d - J_%d:\n",it,it-1);CHKERRQ(ierr);
for (i=0;i<n;i++) {
PetscPrintf(PetscObjectComm((PetscObject)snes),"%5d: %20.5g + %20.5gi\n",i,eigr[i],eigi[i]);CHKERRQ(ierr);
}
ierr = MatDenseRestoreArray(dJdense,&a);CHKERRQ(ierr);
ierr = MatDestroy(&dJ);CHKERRQ(ierr);
ierr = MatDestroy(&dJdense);CHKERRQ(ierr);
ierr = PetscFree(eigr);CHKERRQ(ierr);
ierr = PetscFree(eigi);CHKERRQ(ierr);
ierr = PetscFree(work);CHKERRQ(ierr);
PetscFunctionReturn(0);
#endif
}
/*@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);
}
/* Overwrites A. Can only handle full-rank problems with m>=n
* A in column-major format
* Ainv in row-major format
* tau has length m
* worksize must be >= max(1,n)
*/
static PetscErrorCode PetscDTPseudoInverseQR(PetscInt m,PetscInt mstride,PetscInt n,PetscReal *A_in,PetscReal *Ainv_out,PetscScalar *tau,PetscInt worksize,PetscScalar *work)
{
PetscErrorCode ierr;
PetscBLASInt M,N,K,lda,ldb,ldwork,info;
PetscScalar *A,*Ainv,*R,*Q,Alpha;
PetscFunctionBegin;
#if defined(PETSC_USE_COMPLEX)
{
PetscInt i,j;
ierr = PetscMalloc2(m*n,PetscScalar,&A,m*n,PetscScalar,&Ainv);CHKERRQ(ierr);
for (j=0; j<n; j++) {
for (i=0; i<m; i++) A[i+m*j] = A_in[i+mstride*j];
}
mstride = m;
}
#else
A = A_in;
Ainv = Ainv_out;
#endif
ierr = PetscBLASIntCast(m,&M);CHKERRQ(ierr);
ierr = PetscBLASIntCast(n,&N);CHKERRQ(ierr);
ierr = PetscBLASIntCast(mstride,&lda);CHKERRQ(ierr);
ierr = PetscBLASIntCast(worksize,&ldwork);CHKERRQ(ierr);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
LAPACKgeqrf_(&M,&N,A,&lda,tau,work,&ldwork,&info);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xGEQRF error");
R = A; /* Upper triangular part of A now contains R, the rest contains the elementary reflectors */
/* Extract an explicit representation of Q */
Q = Ainv;
ierr = PetscMemcpy(Q,A,mstride*n*sizeof(PetscScalar));CHKERRQ(ierr);
K = N; /* full rank */
LAPACKungqr_(&M,&N,&K,Q,&lda,tau,work,&ldwork,&info);
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xORGQR/xUNGQR error");
/* Compute A^{-T} = (R^{-1} Q^T)^T = Q R^{-T} */
Alpha = 1.0;
ldb = lda;
BLAStrsm_("Right","Upper","ConjugateTranspose","NotUnitTriangular",&M,&N,&Alpha,R,&lda,Q,&ldb);
/* Ainv is Q, overwritten with inverse */
#if defined(PETSC_USE_COMPLEX)
{
PetscInt i;
for (i=0; i<m*n; i++) Ainv_out[i] = PetscRealPart(Ainv[i]);
ierr = PetscFree2(A,Ainv);CHKERRQ(ierr);
}
#endif
PetscFunctionReturn(0);
}
PetscErrorCode KSPComputeExtremeSingularValues_GMRES(KSP ksp,PetscReal *emax,PetscReal *emin)
{
#if defined(PETSC_MISSING_LAPACK_GESVD)
PetscFunctionBegin;
/*
The Cray math libraries on T3D/T3E, and early versions of Intel Math Kernel Libraries (MKL)
for PCs do not seem to have the DGESVD() lapack routines
*/
SETERRQ(((PetscObject)ksp)->comm,PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable\nNot able to provide singular value estimates.");
#else
KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt n = gmres->it + 1,i,N = gmres->max_k + 2;
PetscBLASInt bn, bN ,lwork, idummy,lierr;
PetscScalar *R = gmres->Rsvd,*work = R + N*N,sdummy;
PetscReal *realpart = gmres->Dsvd;
PetscFunctionBegin;
bn = PetscBLASIntCast(n);
bN = PetscBLASIntCast(N);
lwork = PetscBLASIntCast(5*N);
idummy = PetscBLASIntCast(N);
if (n <= 0) {
*emax = *emin = 1.0;
PetscFunctionReturn(0);
}
/* copy R matrix to work space */
ierr = PetscMemcpy(R,gmres->hh_origin,(gmres->max_k+2)*(gmres->max_k+1)*sizeof(PetscScalar));
CHKERRQ(ierr);
/* zero below diagonal garbage */
for (i=0; i<n; i++) {
R[i*N+i+1] = 0.0;
}
/* compute Singular Values */
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);
CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr);
#else
LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,realpart+N,&lierr);
#endif
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in SVD Lapack routine %d",(int)lierr);
ierr = PetscFPTrapPop();
CHKERRQ(ierr);
*emin = realpart[n-1];
*emax = realpart[0];
#endif
PetscFunctionReturn(0);
}
/*
DenseTridiagonal - Solves a real tridiagonal Hermitian Eigenvalue Problem.
Input Parameters:
+ n - dimension of the eigenproblem
. D - pointer to the array containing the diagonal elements
- E - pointer to the array containing the off-diagonal elements
Output Parameters:
+ w - pointer to the array to store the computed eigenvalues
- V - pointer to the array to store the eigenvectors
Notes:
If V is NULL then the eigenvectors are not computed.
This routine use LAPACK routines xSTEVR.
*/
static PetscErrorCode DenseTridiagonal(PetscInt n_,PetscReal *D,PetscReal *E,PetscReal *w,PetscScalar *V)
{
#if defined(SLEPC_MISSING_LAPACK_STEVR)
PetscFunctionBegin;
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"STEVR - Lapack routine is unavailable");
#else
PetscErrorCode ierr;
PetscReal abstol = 0.0,vl,vu,*work;
PetscBLASInt il,iu,m,*isuppz,n,lwork,*iwork,liwork,info;
const char *jobz;
#if defined(PETSC_USE_COMPLEX)
PetscInt i,j;
PetscReal *VV;
#endif
PetscFunctionBegin;
ierr = PetscBLASIntCast(n_,&n);CHKERRQ(ierr);
ierr = PetscBLASIntCast(20*n_,&lwork);CHKERRQ(ierr);
ierr = PetscBLASIntCast(10*n_,&liwork);CHKERRQ(ierr);
if (V) {
jobz = "V";
#if defined(PETSC_USE_COMPLEX)
ierr = PetscMalloc1(n*n,&VV);CHKERRQ(ierr);
#endif
} else jobz = "N";
ierr = PetscMalloc3(2*n,&isuppz,lwork,&work,liwork,&iwork);CHKERRQ(ierr);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
PetscStackCallBLAS("LAPACKstevr",LAPACKstevr_(jobz,"A",&n,D,E,&vl,&vu,&il,&iu,&abstol,&m,w,VV,&n,isuppz,work,&lwork,iwork,&liwork,&info));
#else
PetscStackCallBLAS("LAPACKstevr",LAPACKstevr_(jobz,"A",&n,D,E,&vl,&vu,&il,&iu,&abstol,&m,w,V,&n,isuppz,work,&lwork,iwork,&liwork,&info));
#endif
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack DSTEVR %d",info);
#if defined(PETSC_USE_COMPLEX)
if (V) {
for (i=0;i<n;i++)
for (j=0;j<n;j++)
V[i*n+j] = VV[i*n+j];
ierr = PetscFree(VV);CHKERRQ(ierr);
}
#endif
ierr = PetscFree3(isuppz,work,iwork);CHKERRQ(ierr);
PetscFunctionReturn(0);
#endif
}
PetscErrorCode SNESNGMRESFormCombinedSolution_Private(SNES snes,PetscInt l,Vec XM,Vec FM,PetscReal fMnorm,Vec X,Vec XA,Vec FA)
{
SNES_NGMRES *ngmres = (SNES_NGMRES*) snes->data;
PetscInt i,j;
Vec *Fdot = ngmres->Fdot;
Vec *Xdot = ngmres->Xdot;
PetscScalar *beta = ngmres->beta;
PetscScalar *xi = ngmres->xi;
PetscScalar alph_total = 0.;
PetscErrorCode ierr;
PetscReal nu;
Vec Y = snes->work[2];
PetscBool changed_y,changed_w;
PetscFunctionBegin;
nu = fMnorm*fMnorm;
/* construct the right hand side and xi factors */
ierr = VecMDot(FM,l,Fdot,xi);CHKERRQ(ierr);
for (i = 0; i < l; i++) beta[i] = nu - xi[i];
/* construct h */
for (j = 0; j < l; j++) {
for (i = 0; i < l; i++) {
H(i,j) = Q(i,j)-xi[i]-xi[j]+nu;
}
}
if (l == 1) {
/* simply set alpha[0] = beta[0] / H[0, 0] */
if (H(0,0) != 0.) beta[0] = beta[0]/H(0,0);
else beta[0] = 0.;
} else {
#if defined(PETSC_MISSING_LAPACK_GELSS)
SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"NGMRES with LS requires the LAPACK GELSS routine.");
#else
ierr = PetscBLASIntCast(l,&ngmres->m);CHKERRQ(ierr);
ierr = PetscBLASIntCast(l,&ngmres->n);CHKERRQ(ierr);
ngmres->info = 0;
ngmres->rcond = -1.;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
PetscStackCall("LAPACKgelss",LAPACKgelss_(&ngmres->m,&ngmres->n,&ngmres->nrhs,ngmres->h,&ngmres->lda,ngmres->beta,&ngmres->ldb,ngmres->s,&ngmres->rcond,&ngmres->rank,ngmres->work,&ngmres->lwork,ngmres->rwork,&ngmres->info));
#else
PetscStackCall("LAPACKgelss",LAPACKgelss_(&ngmres->m,&ngmres->n,&ngmres->nrhs,ngmres->h,&ngmres->lda,ngmres->beta,&ngmres->ldb,ngmres->s,&ngmres->rcond,&ngmres->rank,ngmres->work,&ngmres->lwork,&ngmres->info));
#endif
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (ngmres->info < 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"Bad argument to GELSS");
if (ngmres->info > 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD failed to converge");
#endif
}
for (i=0; i<l; i++) {
if (PetscIsInfOrNanScalar(beta[i])) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD generated inconsistent output");
}
alph_total = 0.;
for (i = 0; i < l; i++) alph_total += beta[i];
ierr = VecCopy(XM,XA);CHKERRQ(ierr);
ierr = VecScale(XA,1.-alph_total);CHKERRQ(ierr);
ierr = VecMAXPY(XA,l,beta,Xdot);CHKERRQ(ierr);
/* check the validity of the step */
ierr = VecCopy(XA,Y);CHKERRQ(ierr);
ierr = VecAXPY(Y,-1.0,X);CHKERRQ(ierr);
ierr = SNESLineSearchPostCheck(snes->linesearch,X,Y,XA,&changed_y,&changed_w);CHKERRQ(ierr);
if (!ngmres->approxfunc) {ierr = SNESComputeFunction(snes,XA,FA);CHKERRQ(ierr);}
else {
ierr = VecCopy(FM,FA);CHKERRQ(ierr);
ierr = VecScale(FA,1.-alph_total);CHKERRQ(ierr);
ierr = VecMAXPY(FA,l,beta,Fdot);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
/* approximately solve the overdetermined system:
2*F(x_i)\cdot F(\x_j)\alpha_i = 0
\alpha_i = 1
Which minimizes the L2 norm of the linearization of:
||F(\sum_i \alpha_i*x_i)||^2
With the constraint that \sum_i\alpha_i = 1
Where x_i is the solution from the ith subsolver.
*/
static PetscErrorCode SNESCompositeApply_AdditiveOptimal(SNES snes,Vec X,Vec B,Vec F,PetscReal *fnorm)
{
PetscErrorCode ierr;
SNES_Composite *jac = (SNES_Composite*)snes->data;
SNES_CompositeLink next = jac->head;
Vec *Xes = jac->Xes,*Fes = jac->Fes;
PetscInt i,j;
PetscScalar tot,total,ftf;
PetscReal min_fnorm;
PetscInt min_i;
SNESConvergedReason reason;
PetscFunctionBegin;
if (!next) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_ARG_WRONGSTATE,"No composite SNESes supplied via SNESCompositeAddSNES() or -snes_composite_sneses");
if (snes->normschedule == SNES_NORM_ALWAYS) {
next = jac->head;
ierr = SNESSetInitialFunction(next->snes,F);CHKERRQ(ierr);
while (next->next) {
next = next->next;
ierr = SNESSetInitialFunction(next->snes,F);CHKERRQ(ierr);
}
}
next = jac->head;
i = 0;
ierr = VecCopy(X,Xes[i]);CHKERRQ(ierr);
ierr = SNESSolve(next->snes,B,Xes[i]);CHKERRQ(ierr);
ierr = SNESGetConvergedReason(next->snes,&reason);CHKERRQ(ierr);
if (reason < 0 && reason != SNES_DIVERGED_MAX_IT) {
jac->innerFailures++;
if (jac->innerFailures >= snes->maxFailures) {
snes->reason = SNES_DIVERGED_INNER;
PetscFunctionReturn(0);
}
}
while (next->next) {
i++;
next = next->next;
ierr = VecCopy(X,Xes[i]);CHKERRQ(ierr);
ierr = SNESSolve(next->snes,B,Xes[i]);CHKERRQ(ierr);
ierr = SNESGetConvergedReason(next->snes,&reason);CHKERRQ(ierr);
if (reason < 0 && reason != SNES_DIVERGED_MAX_IT) {
jac->innerFailures++;
if (jac->innerFailures >= snes->maxFailures) {
snes->reason = SNES_DIVERGED_INNER;
PetscFunctionReturn(0);
}
}
}
/* all the solutions are collected; combine optimally */
for (i=0;i<jac->n;i++) {
for (j=0;j<i+1;j++) {
ierr = VecDotBegin(Fes[i],Fes[j],&jac->h[i + j*jac->n]);CHKERRQ(ierr);
}
ierr = VecDotBegin(Fes[i],F,&jac->g[i]);CHKERRQ(ierr);
}
for (i=0;i<jac->n;i++) {
for (j=0;j<i+1;j++) {
ierr = VecDotEnd(Fes[i],Fes[j],&jac->h[i + j*jac->n]);CHKERRQ(ierr);
if (i == j) jac->fnorms[i] = PetscSqrtReal(PetscRealPart(jac->h[i + j*jac->n]));
}
ierr = VecDotEnd(Fes[i],F,&jac->g[i]);CHKERRQ(ierr);
}
ftf = (*fnorm)*(*fnorm);
for (i=0; i<jac->n; i++) {
for (j=i+1;j<jac->n;j++) {
jac->h[i + j*jac->n] = jac->h[j + i*jac->n];
}
}
for (i=0; i<jac->n; i++) {
for (j=0; j<jac->n; j++) {
jac->h[i + j*jac->n] = jac->h[i + j*jac->n] - jac->g[j] - jac->g[i] + ftf;
}
jac->beta[i] = ftf - jac->g[i];
}
#if defined(PETSC_MISSING_LAPACK_GELSS)
SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"SNESCOMPOSITE with ADDITIVEOPTIMAL requires the LAPACK GELSS routine.");
#else
jac->info = 0;
jac->rcond = -1.;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
PetscStackCall("LAPACKgelss",LAPACKgelss_(&jac->n,&jac->n,&jac->nrhs,jac->h,&jac->lda,jac->beta,&jac->lda,jac->s,&jac->rcond,&jac->rank,jac->work,&jac->lwork,jac->rwork,&jac->info));
#else
PetscStackCall("LAPACKgelss",LAPACKgelss_(&jac->n,&jac->n,&jac->nrhs,jac->h,&jac->lda,jac->beta,&jac->lda,jac->s,&jac->rcond,&jac->rank,jac->work,&jac->lwork,&jac->info));
#endif
ierr = PetscFPTrapPop();CHKERRQ(ierr);
if (jac->info < 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"Bad argument to GELSS");
if (jac->info > 0) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD failed to converge");
#endif
tot = 0.;
total = 0.;
for (i=0; i<jac->n; i++) {
if (snes->errorifnotconverged && PetscIsInfOrNanScalar(jac->beta[i])) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_LIB,"SVD generated inconsistent output");
ierr = PetscInfo2(snes,"%D: %g\n",i,(double)PetscRealPart(jac->beta[i]));CHKERRQ(ierr);
tot += jac->beta[i];
total += PetscAbsScalar(jac->beta[i]);
}
ierr = VecScale(X,(1. - tot));CHKERRQ(ierr);
ierr = VecMAXPY(X,jac->n,jac->beta,Xes);CHKERRQ(ierr);
ierr = SNESComputeFunction(snes,X,F);CHKERRQ(ierr);
if (snes->xl && snes->xu) {
ierr = SNESVIComputeInactiveSetFnorm(snes, F, X, fnorm);CHKERRQ(ierr);
} else {
ierr = VecNorm(F, NORM_2, fnorm);CHKERRQ(ierr);
}
/* take the minimum-normed candidate if it beats the combination by a factor of rtol or the combination has stagnated */
min_fnorm = jac->fnorms[0];
min_i = 0;
for (i=0; i<jac->n; i++) {
if (jac->fnorms[i] < min_fnorm) {
min_fnorm = jac->fnorms[i];
min_i = i;
}
}
/* stagnation or divergence restart to the solution of the solver that failed the least */
if (PetscRealPart(total) < jac->stol || min_fnorm*jac->rtol < *fnorm) {
ierr = VecCopy(jac->Xes[min_i],X);CHKERRQ(ierr);
ierr = VecCopy(jac->Fes[min_i],F);CHKERRQ(ierr);
*fnorm = min_fnorm;
}
PetscFunctionReturn(0);
}
static PetscErrorCode PCSetUp_SVD(PC pc)
{
#if defined(PETSC_MISSING_LAPACK_GESVD)
SETERRQ(PetscObjectComm((PetscObject)pc),PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable\nNot able to provide singular value estimates.");
#else
PC_SVD *jac = (PC_SVD*)pc->data;
PetscErrorCode ierr;
PetscScalar *a,*u,*v,*d,*work;
PetscBLASInt nb,lwork;
PetscInt i,n;
PetscMPIInt size;
PetscFunctionBegin;
ierr = MatDestroy(&jac->A);CHKERRQ(ierr);
ierr = MPI_Comm_size(((PetscObject)pc->pmat)->comm,&size);CHKERRQ(ierr);
if (size > 1) {
Mat redmat;
PetscInt M;
ierr = MatGetSize(pc->pmat,&M,NULL);CHKERRQ(ierr);
ierr = MatGetRedundantMatrix(pc->pmat,size,PETSC_COMM_SELF,M,MAT_INITIAL_MATRIX,&redmat);CHKERRQ(ierr);
ierr = MatConvert(redmat,MATSEQDENSE,MAT_INITIAL_MATRIX,&jac->A);CHKERRQ(ierr);
ierr = MatDestroy(&redmat);CHKERRQ(ierr);
} else {
ierr = MatConvert(pc->pmat,MATSEQDENSE,MAT_INITIAL_MATRIX,&jac->A);CHKERRQ(ierr);
}
if (!jac->diag) { /* assume square matrices */
ierr = MatGetVecs(jac->A,&jac->diag,&jac->work);CHKERRQ(ierr);
}
if (!jac->U) {
ierr = MatDuplicate(jac->A,MAT_DO_NOT_COPY_VALUES,&jac->U);CHKERRQ(ierr);
ierr = MatDuplicate(jac->A,MAT_DO_NOT_COPY_VALUES,&jac->Vt);CHKERRQ(ierr);
}
ierr = MatGetSize(pc->pmat,&n,NULL);CHKERRQ(ierr);
ierr = PetscBLASIntCast(n,&nb);CHKERRQ(ierr);
lwork = 5*nb;
ierr = PetscMalloc(lwork*sizeof(PetscScalar),&work);CHKERRQ(ierr);
ierr = MatDenseGetArray(jac->A,&a);CHKERRQ(ierr);
ierr = MatDenseGetArray(jac->U,&u);CHKERRQ(ierr);
ierr = MatDenseGetArray(jac->Vt,&v);CHKERRQ(ierr);
ierr = VecGetArray(jac->diag,&d);CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
{
PetscBLASInt lierr;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
PetscStackCall("LAPACKgesvd",LAPACKgesvd_("A","A",&nb,&nb,a,&nb,d,u,&nb,v,&nb,work,&lwork,&lierr));
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"gesv() error %d",lierr);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
}
#else
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not coded for complex");
#endif
ierr = MatDenseRestoreArray(jac->A,&a);CHKERRQ(ierr);
ierr = MatDenseRestoreArray(jac->U,&u);CHKERRQ(ierr);
ierr = MatDenseRestoreArray(jac->Vt,&v);CHKERRQ(ierr);
for (i=n-1; i>=0; i--) if (PetscRealPart(d[i]) > jac->zerosing) break;
jac->nzero = n-1-i;
if (jac->monitor) {
ierr = PetscViewerASCIIAddTab(jac->monitor,((PetscObject)pc)->tablevel);CHKERRQ(ierr);
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: condition number %14.12e, %D of %D singular values are (nearly) zero\n",(double)PetscRealPart(d[0]/d[n-1]),jac->nzero,n);CHKERRQ(ierr);
if (n >= 10) { /* print 5 smallest and 5 largest */
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: smallest singular values: %14.12e %14.12e %14.12e %14.12e %14.12e\n",(double)PetscRealPart(d[n-1]),(double)PetscRealPart(d[n-2]),(double)PetscRealPart(d[n-3]),(double)PetscRealPart(d[n-4]),(double)PetscRealPart(d[n-5]));CHKERRQ(ierr);
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: largest singular values : %14.12e %14.12e %14.12e %14.12e %14.12e\n",(double)PetscRealPart(d[4]),(double)PetscRealPart(d[3]),(double)PetscRealPart(d[2]),(double)PetscRealPart(d[1]),(double)PetscRealPart(d[0]));CHKERRQ(ierr);
} else { /* print all singular values */
char buf[256],*p;
size_t left = sizeof(buf),used;
PetscInt thisline;
for (p=buf,i=n-1,thisline=1; i>=0; i--,thisline++) {
ierr = PetscSNPrintfCount(p,left," %14.12e",&used,(double)PetscRealPart(d[i]));CHKERRQ(ierr);
left -= used;
p += used;
if (thisline > 4 || i==0) {
ierr = PetscViewerASCIIPrintf(jac->monitor," SVD: singular values:%s\n",buf);CHKERRQ(ierr);
p = buf;
thisline = 0;
}
}
}
ierr = PetscViewerASCIISubtractTab(jac->monitor,((PetscObject)pc)->tablevel);CHKERRQ(ierr);
}
ierr = PetscInfo2(pc,"Largest and smallest singular values %14.12e %14.12e\n",(double)PetscRealPart(d[0]),(double)PetscRealPart(d[n-1]));CHKERRQ(ierr);
for (i=0; i<n-jac->nzero; i++) d[i] = 1.0/d[i];
for (; i<n; i++) d[i] = 0.0;
if (jac->essrank > 0) for (i=0; i<n-jac->nzero-jac->essrank; i++) d[i] = 0.0; /* Skip all but essrank eigenvalues */
ierr = PetscInfo1(pc,"Number of zero or nearly singular values %D\n",jac->nzero);CHKERRQ(ierr);
ierr = VecRestoreArray(jac->diag,&d);CHKERRQ(ierr);
#if defined(foo)
{
PetscViewer viewer;
ierr = PetscViewerBinaryOpen(PETSC_COMM_SELF,"joe",FILE_MODE_WRITE,&viewer);CHKERRQ(ierr);
ierr = MatView(jac->A,viewer);CHKERRQ(ierr);
ierr = MatView(jac->U,viewer);CHKERRQ(ierr);
ierr = MatView(jac->Vt,viewer);CHKERRQ(ierr);
ierr = VecView(jac->diag,viewer);CHKERRQ(ierr);
ierr = PetscViewerDestroy(viewer);CHKERRQ(ierr);
}
#endif
ierr = PetscFree(work);CHKERRQ(ierr);
PetscFunctionReturn(0);
#endif
}
/*@
KSPComputeEigenvaluesExplicitly - Computes all of the eigenvalues of the
preconditioned operator using LAPACK.
Collective on KSP
Input Parameter:
+ ksp - iterative context obtained from KSPCreate()
- n - size of arrays r and c
Output Parameters:
+ r - real part of computed eigenvalues
- c - complex part of computed eigenvalues
Notes:
This approach is very slow but will generally provide accurate eigenvalue
estimates. This routine explicitly forms a dense matrix representing
the preconditioned operator, and thus will run only for relatively small
problems, say n < 500.
Many users may just want to use the monitoring routine
KSPMonitorSingularValue() (which can be set with option -ksp_monitor_singular_value)
to print the singular values at each iteration of the linear solve.
The preconditoner operator, rhs vector, solution vectors should be
set before this routine is called. i.e use KSPSetOperators(),KSPSolve() or
KSPSetOperators()
Level: advanced
.keywords: KSP, compute, eigenvalues, explicitly
.seealso: KSPComputeEigenvalues(), KSPMonitorSingularValue(), KSPComputeExtremeSingularValues(), KSPSetOperators(), KSPSolve()
@*/
PetscErrorCode KSPComputeEigenvaluesExplicitly(KSP ksp,PetscInt nmax,PetscReal *r,PetscReal *c)
{
Mat BA;
PetscErrorCode ierr;
PetscMPIInt size,rank;
MPI_Comm comm = ((PetscObject)ksp)->comm;
PetscScalar *array;
Mat A;
PetscInt m,row,nz,i,n,dummy;
const PetscInt *cols;
const PetscScalar *vals;
PetscFunctionBegin;
ierr = KSPComputeExplicitOperator(ksp,&BA);CHKERRQ(ierr);
ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr);
ierr = MPI_Comm_rank(comm,&rank);CHKERRQ(ierr);
ierr = MatGetSize(BA,&n,&n);CHKERRQ(ierr);
if (size > 1) { /* assemble matrix on first processor */
ierr = MatCreate(((PetscObject)ksp)->comm,&A);CHKERRQ(ierr);
if (!rank) {
ierr = MatSetSizes(A,n,n,n,n);CHKERRQ(ierr);
} else {
ierr = MatSetSizes(A,0,0,n,n);CHKERRQ(ierr);
}
ierr = MatSetType(A,MATMPIDENSE);CHKERRQ(ierr);
ierr = MatMPIDenseSetPreallocation(A,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscLogObjectParent(BA,A);CHKERRQ(ierr);
ierr = MatGetOwnershipRange(BA,&row,&dummy);CHKERRQ(ierr);
ierr = MatGetLocalSize(BA,&m,&dummy);CHKERRQ(ierr);
for (i=0; i<m; i++) {
ierr = MatGetRow(BA,row,&nz,&cols,&vals);CHKERRQ(ierr);
ierr = MatSetValues(A,1,&row,nz,cols,vals,INSERT_VALUES);CHKERRQ(ierr);
ierr = MatRestoreRow(BA,row,&nz,&cols,&vals);CHKERRQ(ierr);
row++;
}
ierr = MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatDenseGetArray(A,&array);CHKERRQ(ierr);
} else {
ierr = MatDenseGetArray(BA,&array);CHKERRQ(ierr);
}
#if defined(PETSC_HAVE_ESSL)
/* ESSL has a different calling sequence for dgeev() and zgeev() than standard LAPACK */
if (!rank) {
PetscScalar sdummy,*cwork;
PetscReal *work,*realpart;
PetscBLASInt clen,idummy,lwork,bn,zero = 0;
PetscInt *perm;
#if !defined(PETSC_USE_COMPLEX)
clen = n;
#else
clen = 2*n;
#endif
ierr = PetscMalloc(clen*sizeof(PetscScalar),&cwork);CHKERRQ(ierr);
idummy = -1; /* unused */
bn = PetscBLASIntCast(n);
lwork = 5*n;
ierr = PetscMalloc(lwork*sizeof(PetscReal),&work);CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscReal),&realpart);CHKERRQ(ierr);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
LAPACKgeev_(&zero,array,&bn,cwork,&sdummy,&idummy,&idummy,&bn,work,&lwork);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
ierr = PetscFree(work);CHKERRQ(ierr);
/* For now we stick with the convention of storing the real and imaginary
components of evalues separately. But is this what we really want? */
ierr = PetscMalloc(n*sizeof(PetscInt),&perm);CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
for (i=0; i<n; i++) {
realpart[i] = cwork[2*i];
perm[i] = i;
}
ierr = PetscSortRealWithPermutation(n,realpart,perm);CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = cwork[2*perm[i]];
c[i] = cwork[2*perm[i]+1];
}
#else
for (i=0; i<n; i++) {
realpart[i] = PetscRealPart(cwork[i]);
perm[i] = i;
}
ierr = PetscSortRealWithPermutation(n,realpart,perm);CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = PetscRealPart(cwork[perm[i]]);
c[i] = PetscImaginaryPart(cwork[perm[i]]);
}
#endif
ierr = PetscFree(perm);CHKERRQ(ierr);
ierr = PetscFree(realpart);CHKERRQ(ierr);
ierr = PetscFree(cwork);CHKERRQ(ierr);
}
#elif !defined(PETSC_USE_COMPLEX)
if (!rank) {
PetscScalar *work;
PetscReal *realpart,*imagpart;
PetscBLASInt idummy,lwork;
PetscInt *perm;
idummy = n;
lwork = 5*n;
ierr = PetscMalloc(2*n*sizeof(PetscReal),&realpart);CHKERRQ(ierr);
imagpart = realpart + n;
ierr = PetscMalloc(5*n*sizeof(PetscReal),&work);CHKERRQ(ierr);
#if defined(PETSC_MISSING_LAPACK_GEEV)
SETERRQ(((PetscObject)ksp)->comm,PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
#else
{
PetscBLASInt lierr;
PetscScalar sdummy;
PetscBLASInt bn = PetscBLASIntCast(n);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
LAPACKgeev_("N","N",&bn,array,&bn,realpart,imagpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr);
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine %d",(int)lierr);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
}
#endif
ierr = PetscFree(work);CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscInt),&perm);CHKERRQ(ierr);
for (i=0; i<n; i++) { perm[i] = i;}
ierr = PetscSortRealWithPermutation(n,realpart,perm);CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = realpart[perm[i]];
c[i] = imagpart[perm[i]];
}
ierr = PetscFree(perm);CHKERRQ(ierr);
ierr = PetscFree(realpart);CHKERRQ(ierr);
}
#else
if (!rank) {
PetscScalar *work,*eigs;
PetscReal *rwork;
PetscBLASInt idummy,lwork;
PetscInt *perm;
idummy = n;
lwork = 5*n;
ierr = PetscMalloc(5*n*sizeof(PetscScalar),&work);CHKERRQ(ierr);
ierr = PetscMalloc(2*n*sizeof(PetscReal),&rwork);CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscScalar),&eigs);CHKERRQ(ierr);
#if defined(PETSC_MISSING_LAPACK_GEEV)
SETERRQ(((PetscObject)ksp)->comm,PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
#else
{
PetscBLASInt lierr;
PetscScalar sdummy;
PetscBLASInt nb = PetscBLASIntCast(n);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
LAPACKgeev_("N","N",&nb,array,&nb,eigs,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,rwork,&lierr);
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine %d",(int)lierr);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
}
#endif
ierr = PetscFree(work);CHKERRQ(ierr);
ierr = PetscFree(rwork);CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscInt),&perm);CHKERRQ(ierr);
for (i=0; i<n; i++) { perm[i] = i;}
for (i=0; i<n; i++) { r[i] = PetscRealPart(eigs[i]);}
ierr = PetscSortRealWithPermutation(n,r,perm);CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = PetscRealPart(eigs[perm[i]]);
c[i] = PetscImaginaryPart(eigs[perm[i]]);
}
ierr = PetscFree(perm);CHKERRQ(ierr);
ierr = PetscFree(eigs);CHKERRQ(ierr);
}
#endif
if (size > 1) {
ierr = MatDenseRestoreArray(A,&array);CHKERRQ(ierr);
ierr = MatDestroy(&A);CHKERRQ(ierr);
} else {
ierr = MatDenseRestoreArray(BA,&array);CHKERRQ(ierr);
}
ierr = MatDestroy(&BA);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
int getQ1(Mat *pA){
int i,j;
PetscInt m,n;
PetscBLASInt M,N,K,lda,ldwork,info;
PetscScalar *tau,*work;
PetscInt worksize;
PetscErrorCode ierr;
ierr = MatGetSize(*pA,&m,&n);CHKERRQ(ierr);
PetscBLASIntCast(m,&M);
PetscBLASIntCast(n,&N);
worksize=m;
PetscBLASIntCast(worksize,&ldwork);
PetscMalloc1(m, &tau);//worksize,&work);
PetscMalloc1(worksize,&work);
K = N; /*full rank*/
lda = M ; //N - row domain M - col domain
//ierr = PetscPrintf (PETSC_COMM_SELF,"L72\n");CHKERRQ(ierr);
//ierr = MatView(*pA,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"L74\n");CHKERRQ(ierr);
PetscScalar *v;//[4]={0};
PetscInt *Is; //[4]={0,1,2,3};
PetscInt nC;// = 4;
PetscReal arr[10*4];
for(i=0; i<10; i++){
ierr = MatGetRow(*pA,i,&nC,(const PetscInt **)&Is,(const PetscScalar **)&v); CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"get row %d %d\n", i, nC);CHKERRQ(ierr);
for(j=0; j<nC; j++){
arr[i+10*Is[j]]=v[j];
}
ierr = MatRestoreRow(*pA,i,&nC,(const PetscInt**)&Is,(const PetscScalar**)&v); CHKERRQ(ierr);
}
//ierr = PetscPrintf (PETSC_COMM_SELF,"new L72\n");CHKERRQ(ierr);
//ierr = MatView(*pA,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"new L74\n");CHKERRQ(ierr);
//for(i=0;i<40; i++){
// ierr = PetscPrintf (PETSC_COMM_SELF,"arr[%d] = %f\n",i,arr[i]);CHKERRQ(ierr);
//}
/* Do QR */
PetscFPTrapPush(PETSC_FP_TRAP_OFF);
LAPACKgeqrf_(&M,&N,arr,&lda,tau,work,&ldwork,&info);
PetscFPTrapPop();
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xGEQRF error");
/*Extract an explicit representation of Q */
//PetscMemcpy(Q,A,mstride*n*sizeof(PetscScalar));
LAPACKungqr_(&M,&N,&K,arr,&lda,tau,work,&ldwork,&info);
if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xORGQR/xUNGQR error");
//ierr = PetscPrintf (PETSC_COMM_SELF,"\nWe store Q1 in arr:\n");CHKERRQ(ierr);
//for(i=0;i<40; i++){
// ierr = PetscPrintf (PETSC_COMM_SELF,"arr[%d] = %f\n",i,arr[i]);CHKERRQ(ierr);
//}
for (i=0; i<10; i++) {
for(j=0; j<4; j++) {
ierr = MatSetValues(*pA,1,&i,1,&j,&arr[i+j*10],INSERT_VALUES);CHKERRQ(ierr);
}
}
ierr = MatAssemblyBegin(*pA,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(*pA,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
//ierr = PetscPrintf (PETSC_COMM_SELF,"\nThe Q1 we are going to return is\n");CHKERRQ(ierr);
//ierr = MatView(*pA,PETSC_VIEWER_STDOUT_WORLD);CHKERRQ(ierr);
//ierr = PetscFree(arr);CHKERRQ(ierr);
return 0;
}
PetscErrorCode KSPComputeEigenvalues_GMRES(KSP ksp,PetscInt nmax,PetscReal *r,PetscReal *c,PetscInt *neig)
{
#if defined(PETSC_HAVE_ESSL)
KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt n = gmres->it + 1,N = gmres->max_k + 1;
PetscInt i,*perm;
PetscScalar *R = gmres->Rsvd;
PetscScalar *cwork = R + N*N,sdummy;
PetscReal *work,*realpart = gmres->Dsvd ;
PetscBLASInt zero = 0,bn,bN,idummy,lwork;
PetscFunctionBegin;
bn = PetscBLASIntCast(n);
bN = PetscBLASIntCast(N);
idummy = -1; /* unused */
lwork = PetscBLASIntCast(5*N);
if (nmax < n) SETERRQ(((PetscObject)ksp)->comm,PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
*neig = n;
if (!n) {
PetscFunctionReturn(0);
}
/* copy R matrix to work space */
ierr = PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
CHKERRQ(ierr);
/* compute eigenvalues */
/* for ESSL version need really cwork of length N (complex), 2N
(real); already at least 5N of space has been allocated */
ierr = PetscMalloc(lwork*sizeof(PetscReal),&work);
CHKERRQ(ierr);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);
CHKERRQ(ierr);
LAPACKgeev_(&zero,R,&bN,cwork,&sdummy,&idummy,&idummy,&bn,work,&lwork);
ierr = PetscFPTrapPop();
CHKERRQ(ierr);
ierr = PetscFree(work);
CHKERRQ(ierr);
/* For now we stick with the convention of storing the real and imaginary
components of evalues separately. But is this what we really want? */
ierr = PetscMalloc(n*sizeof(PetscInt),&perm);
CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
for (i=0; i<n; i++) {
realpart[i] = cwork[2*i];
perm[i] = i;
}
ierr = PetscSortRealWithPermutation(n,realpart,perm);
CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = cwork[2*perm[i]];
c[i] = cwork[2*perm[i]+1];
}
#else
for (i=0; i<n; i++) {
realpart[i] = PetscRealPart(cwork[i]);
perm[i] = i;
}
ierr = PetscSortRealWithPermutation(n,realpart,perm);
CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = PetscRealPart(cwork[perm[i]]);
c[i] = PetscImaginaryPart(cwork[perm[i]]);
}
#endif
ierr = PetscFree(perm);
CHKERRQ(ierr);
#elif defined(PETSC_MISSING_LAPACK_GEEV)
PetscFunctionBegin;
SETERRQ(((PetscObject)ksp)->comm,PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
#elif !defined(PETSC_USE_COMPLEX)
KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt n = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
PetscBLASInt bn, bN, lwork, idummy, lierr;
PetscScalar *R = gmres->Rsvd,*work = R + N*N;
PetscScalar *realpart = gmres->Dsvd,*imagpart = realpart + N,sdummy;
PetscFunctionBegin;
bn = PetscBLASIntCast(n);
bN = PetscBLASIntCast(N);
lwork = PetscBLASIntCast(5*N);
idummy = PetscBLASIntCast(N);
if (nmax < n) SETERRQ(((PetscObject)ksp)->comm,PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
*neig = n;
if (!n) {
PetscFunctionReturn(0);
}
/* copy R matrix to work space */
ierr = PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
CHKERRQ(ierr);
/* compute eigenvalues */
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);
CHKERRQ(ierr);
LAPACKgeev_("N","N",&bn,R,&bN,realpart,imagpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr);
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine %d",(int)lierr);
ierr = PetscFPTrapPop();
CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscInt),&perm);
CHKERRQ(ierr);
for (i=0; i<n; i++) {
perm[i] = i;
}
ierr = PetscSortRealWithPermutation(n,realpart,perm);
CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = realpart[perm[i]];
c[i] = imagpart[perm[i]];
}
ierr = PetscFree(perm);
CHKERRQ(ierr);
#else
KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt n = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
PetscScalar *R = gmres->Rsvd,*work = R + N*N,*eigs = work + 5*N,sdummy;
PetscBLASInt bn,bN,lwork,idummy,lierr;
PetscFunctionBegin;
bn = PetscBLASIntCast(n);
bN = PetscBLASIntCast(N);
lwork = PetscBLASIntCast(5*N);
idummy = PetscBLASIntCast(N);
if (nmax < n) SETERRQ(((PetscObject)ksp)->comm,PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
*neig = n;
if (!n) {
PetscFunctionReturn(0);
}
/* copy R matrix to work space */
ierr = PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
CHKERRQ(ierr);
/* compute eigenvalues */
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);
CHKERRQ(ierr);
LAPACKgeev_("N","N",&bn,R,&bN,eigs,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,gmres->Dsvd,&lierr);
if (lierr) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine");
ierr = PetscFPTrapPop();
CHKERRQ(ierr);
ierr = PetscMalloc(n*sizeof(PetscInt),&perm);
CHKERRQ(ierr);
for (i=0; i<n; i++) {
perm[i] = i;
}
for (i=0; i<n; i++) {
r[i] = PetscRealPart(eigs[i]);
}
ierr = PetscSortRealWithPermutation(n,r,perm);
CHKERRQ(ierr);
for (i=0; i<n; i++) {
r[i] = PetscRealPart(eigs[perm[i]]);
c[i] = PetscImaginaryPart(eigs[perm[i]]);
}
ierr = PetscFree(perm);
CHKERRQ(ierr);
#endif
PetscFunctionReturn(0);
}
int main(int argc, char **args)
{
Mat A, L;
AppCtx ctx;
PetscViewer viewer;
PetscErrorCode ierr;
ierr = PetscInitialize(&argc, &args, (char *) 0, help);CHKERRQ(ierr);
ierr = ProcessOptions(&ctx);CHKERRQ(ierr);
/* Load matrix */
ierr = PetscViewerBinaryOpen(PETSC_COMM_WORLD, ctx.matFilename, FILE_MODE_READ, &viewer);CHKERRQ(ierr);
ierr = MatCreate(PETSC_COMM_WORLD, &A);CHKERRQ(ierr);
ierr = MatLoad(A, viewer);CHKERRQ(ierr);
ierr = PetscViewerDestroy(&viewer);CHKERRQ(ierr);
/* Make graph Laplacian from matrix */
ierr = MatLaplacian(A, 1.0e-12, &L);CHKERRQ(ierr);
/* Check Laplacian */
PetscReal norm;
Vec x, y;
ierr = MatGetVecs(L, &x, NULL);CHKERRQ(ierr);
ierr = VecDuplicate(x, &y);CHKERRQ(ierr);
ierr = VecSet(x, 1.0);CHKERRQ(ierr);
ierr = MatMult(L, x, y);CHKERRQ(ierr);
ierr = VecNorm(y, NORM_INFINITY, &norm);CHKERRQ(ierr);
if (norm > 1.0e-10) SETERRQ(PetscObjectComm((PetscObject) y), PETSC_ERR_PLIB, "Invalid graph Laplacian");
ierr = VecDestroy(&x);CHKERRQ(ierr);
ierr = VecDestroy(&y);CHKERRQ(ierr);
/* Compute Fiedler vector, and perhaps more vectors */
Mat LD;
PetscScalar *a, *realpart, *imagpart, *eigvec, *work, sdummy;
PetscBLASInt bn, bN, lwork, lierr, idummy;
PetscInt n, i;
ierr = MatConvert(L, MATDENSE, MAT_INITIAL_MATRIX, &LD);CHKERRQ(ierr);
ierr = MatGetLocalSize(LD, &n, NULL);CHKERRQ(ierr);
ierr = MatDenseGetArray(LD, &a);CHKERRQ(ierr);
ierr = PetscBLASIntCast(n, &bn);CHKERRQ(ierr);
ierr = PetscBLASIntCast(n, &bN);CHKERRQ(ierr);
ierr = PetscBLASIntCast(5*n,&lwork);CHKERRQ(ierr);
ierr = PetscBLASIntCast(1,&idummy);CHKERRQ(ierr);
ierr = PetscMalloc4(n,PetscScalar,&realpart,n,PetscScalar,&imagpart,n*n,PetscScalar,&eigvec,lwork,PetscScalar,&work);CHKERRQ(ierr);
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
PetscStackCall("LAPACKgeev", LAPACKgeev_("N","V",&bn,a,&bN,realpart,imagpart,&sdummy,&idummy,eigvec,&bN,work,&lwork,&lierr));
if (lierr) SETERRQ1(PETSC_COMM_SELF, PETSC_ERR_LIB, "Error in LAPACK routine %d", (int) lierr);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
PetscReal *r, *c;
PetscInt *perm;
ierr = PetscMalloc3(n,PetscInt,&perm,n,PetscReal,&r,n,PetscReal,&c);CHKERRQ(ierr);
for (i = 0; i < n; ++i) perm[i] = i;
ierr = PetscSortRealWithPermutation(n,realpart,perm);CHKERRQ(ierr);
for (i = 0; i < n; ++i) {
r[i] = realpart[perm[i]];
c[i] = imagpart[perm[i]];
}
for (i = 0; i < n; ++i) {
realpart[i] = r[i];
imagpart[i] = c[i];
}
/* Output spectrum */
if (ctx.showSpectrum) {
ierr = PetscPrintf(PETSC_COMM_SELF, "Spectrum\n");CHKERRQ(ierr);
for (i = 0; i < n; ++i) {ierr = PetscPrintf(PETSC_COMM_SELF, "%d: Real %g Imag %g\n", i, realpart[i], imagpart[i]);CHKERRQ(ierr);}
}
/* Check lowest eigenvalue and eigenvector */
PetscInt evInd = perm[0];
if ((realpart[0] > 1.0e-12) || (imagpart[0] > 1.0e-12)) SETERRQ(PetscObjectComm((PetscObject) L), PETSC_ERR_PLIB, "Graph Laplacian must have lowest eigenvalue 0");
for (i = 0; i < n; ++i) {
if (fabs(eigvec[evInd*n+i] - eigvec[evInd*n+0]) > 1.0e-10) SETERRQ3(PetscObjectComm((PetscObject) L), PETSC_ERR_PLIB, "Graph Laplacian must have constant lowest eigenvector ev_%d %g != ev_0 %g", i, eigvec[evInd*n+i], eigvec[evInd*n+0]);
}
/* Output Fiedler vector */
evInd = perm[1];
if (ctx.showFiedler) {
ierr = PetscPrintf(PETSC_COMM_SELF, "Fiedler vector, Re{ev} %g\n", realpart[1]);CHKERRQ(ierr);
for (i = 0; i < n; ++i) {ierr = PetscPrintf(PETSC_COMM_SELF, "%d: %g\n", i, eigvec[evInd*n+i]);CHKERRQ(ierr);}
}
/* Construct Fiedler partition */
IS fIS, fIS2;
PetscInt *fperm, *fperm2, pos, neg, posSize = 0;
ierr = PetscMalloc(n * sizeof(PetscInt), &fperm);CHKERRQ(ierr);
for (i = 0; i < n; ++i) {
if (eigvec[evInd*n+i] > 0.0) ++posSize;
}
ierr = PetscMalloc(n * sizeof(PetscInt), &fperm2);CHKERRQ(ierr);
for (i = 0; i < n; ++i) fperm[i] = i;
ierr = PetscSortRealWithPermutation(n, &eigvec[evInd*n], fperm);CHKERRQ(ierr);
for (i = 0; i < n; ++i) fperm2[n-1-i] = fperm[i];
for (i = 0, pos = 0, neg = posSize; i < n; ++i) {
if (eigvec[evInd*n+i] > 0.0) fperm[pos++] = i;
else fperm[neg++] = i;
}
ierr = ISCreateGeneral(PetscObjectComm((PetscObject) L), n, fperm, PETSC_OWN_POINTER, &fIS);CHKERRQ(ierr);
ierr = ISSetPermutation(fIS);CHKERRQ(ierr);
ierr = ISCreateGeneral(PetscObjectComm((PetscObject) L), n, fperm2, PETSC_OWN_POINTER, &fIS2);CHKERRQ(ierr);
ierr = ISSetPermutation(fIS2);CHKERRQ(ierr);
ierr = PetscFree3(perm,r,c);CHKERRQ(ierr);
ierr = PetscFree4(realpart,imagpart,eigvec,work);CHKERRQ(ierr);
ierr = MatDenseRestoreArray(LD, &a);CHKERRQ(ierr);
ierr = MatDestroy(&LD);CHKERRQ(ierr);
ierr = MatDestroy(&L);CHKERRQ(ierr);
/* Permute matrix */
Mat AR, AR2;
ierr = MatPermute(A, fIS, fIS, &AR);CHKERRQ(ierr);
ierr = MatView(A, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = MatView(AR, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = ISDestroy(&fIS);CHKERRQ(ierr);
ierr = MatPermute(A, fIS2, fIS2, &AR2);CHKERRQ(ierr);
ierr = MatView(AR2, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = ISDestroy(&fIS2);CHKERRQ(ierr);
ierr = MatDestroy(&AR);CHKERRQ(ierr);
AR = AR2;
/* Extract blocks and reorder */
Mat AP, AN, APR, ANR;
IS ispos, isneg, rpermpos, cpermpos, rpermneg, cpermneg;
PetscInt bw, bwr;
ierr = ISCreateStride(PETSC_COMM_SELF, posSize, 0, 1, &ispos);CHKERRQ(ierr);
ierr = ISCreateStride(PETSC_COMM_SELF, n - posSize, posSize, 1, &isneg);CHKERRQ(ierr);
ierr = MatGetSubMatrix(AR, ispos, ispos, MAT_INITIAL_MATRIX, &AP);CHKERRQ(ierr);
ierr = MatGetSubMatrix(AR, isneg, isneg, MAT_INITIAL_MATRIX, &AN);CHKERRQ(ierr);
ierr = ISDestroy(&ispos);CHKERRQ(ierr);
ierr = ISDestroy(&isneg);CHKERRQ(ierr);
ierr = MatGetOrdering(AP, ctx.matOrdtype, &rpermpos, &cpermpos);CHKERRQ(ierr);
ierr = MatGetOrdering(AN, ctx.matOrdtype, &rpermneg, &cpermneg);CHKERRQ(ierr);
ierr = MatPermute(AP, rpermpos, cpermpos, &APR);CHKERRQ(ierr);
ierr = MatComputeBandwidth(AP, 0.0, &bw);CHKERRQ(ierr);
ierr = MatComputeBandwidth(APR, 0.0, &bwr);CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD, "Reduced positive bandwidth from %d to %d\n", bw, bwr);CHKERRQ(ierr);
ierr = MatPermute(AN, rpermneg, cpermneg, &ANR);CHKERRQ(ierr);
ierr = MatComputeBandwidth(AN, 0.0, &bw);CHKERRQ(ierr);
ierr = MatComputeBandwidth(ANR, 0.0, &bwr);CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD, "Reduced negative bandwidth from %d to %d\n", bw, bwr);CHKERRQ(ierr);
ierr = MatView(AP, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = MatView(APR, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = MatView(AN, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = MatView(ANR, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
/* Reorder original matrix */
Mat ARR;
IS rperm, cperm;
PetscInt *idx;
const PetscInt *cidx;
ierr = PetscMalloc(n * sizeof(PetscInt), &idx);CHKERRQ(ierr);
ierr = ISGetIndices(rpermpos, &cidx);CHKERRQ(ierr);
for (i = 0; i < posSize; ++i) idx[i] = cidx[i];
ierr = ISRestoreIndices(rpermpos, &cidx);CHKERRQ(ierr);
ierr = ISGetIndices(rpermneg, &cidx);CHKERRQ(ierr);
for (i = posSize; i < n; ++i) idx[i] = cidx[i-posSize] + posSize;
ierr = ISRestoreIndices(rpermneg, &cidx);CHKERRQ(ierr);
ierr = ISCreateGeneral(PETSC_COMM_SELF, n, idx, PETSC_OWN_POINTER, &rperm);CHKERRQ(ierr);
ierr = ISSetPermutation(rperm);CHKERRQ(ierr);
ierr = PetscMalloc(n * sizeof(PetscInt), &idx);CHKERRQ(ierr);
ierr = ISGetIndices(cpermpos, &cidx);CHKERRQ(ierr);
for (i = 0; i < posSize; ++i) idx[i] = cidx[i];
ierr = ISRestoreIndices(cpermpos, &cidx);CHKERRQ(ierr);
ierr = ISGetIndices(cpermneg, &cidx);CHKERRQ(ierr);
for (i = posSize; i < n; ++i) idx[i] = cidx[i-posSize] + posSize;
ierr = ISRestoreIndices(cpermneg, &cidx);CHKERRQ(ierr);
ierr = ISCreateGeneral(PETSC_COMM_SELF, n, idx, PETSC_OWN_POINTER, &cperm);CHKERRQ(ierr);
ierr = ISSetPermutation(cperm);CHKERRQ(ierr);
ierr = MatPermute(AR, rperm, cperm, &ARR);CHKERRQ(ierr);
ierr = MatView(ARR, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = ISDestroy(&rperm);CHKERRQ(ierr);
ierr = ISDestroy(&cperm);CHKERRQ(ierr);
ierr = ISDestroy(&rpermpos);CHKERRQ(ierr);
ierr = ISDestroy(&cpermpos);CHKERRQ(ierr);
ierr = ISDestroy(&rpermneg);CHKERRQ(ierr);
ierr = ISDestroy(&cpermneg);CHKERRQ(ierr);
ierr = MatDestroy(&AP);CHKERRQ(ierr);
ierr = MatDestroy(&AN);CHKERRQ(ierr);
ierr = MatDestroy(&APR);CHKERRQ(ierr);
ierr = MatDestroy(&ANR);CHKERRQ(ierr);
/* Compare bands */
Mat B, BR;
ierr = MatCreateSubMatrixBanded(A, 50, 0.95, &B);CHKERRQ(ierr);
ierr = MatCreateSubMatrixBanded(ARR, 50, 0.95, &BR);CHKERRQ(ierr);
ierr = MatView(B, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = MatView(BR, PETSC_VIEWER_DRAW_WORLD);CHKERRQ(ierr);
ierr = MatDestroy(&B);CHKERRQ(ierr);
ierr = MatDestroy(&BR);CHKERRQ(ierr);
/* Cleanup */
ierr = MatDestroy(&ARR);CHKERRQ(ierr);
ierr = MatDestroy(&AR);CHKERRQ(ierr);
ierr = MatDestroy(&A);CHKERRQ(ierr);
ierr = PetscFinalize();
return 0;
}
static PetscErrorCode GLLStuffs(DomainData dd, GLLData *glldata)
{
PetscErrorCode ierr;
PetscReal *M,si;
PetscScalar x,z0,z1,z2,Lpj,Lpr,rhoGLj,rhoGLk;
PetscBLASInt pm1,lierr;
PetscInt i,j,n,k,s,r,q,ii,jj,p=dd.p;
PetscInt xloc,yloc,zloc,xyloc,xyzloc;
PetscFunctionBeginUser;
/* Gauss-Lobatto-Legendre nodes zGL on [-1,1] */
ierr = PetscMalloc1(p+1,&glldata->zGL);CHKERRQ(ierr);
ierr = PetscMemzero(glldata->zGL,(p+1)*sizeof(*glldata->zGL));CHKERRQ(ierr);
glldata->zGL[0]=-1.0;
glldata->zGL[p]= 1.0;
if (p > 1) {
if (p == 2) glldata->zGL[1]=0.0;
else {
ierr = PetscMalloc1(p-1,&M);CHKERRQ(ierr);
for (i=0; i<p-1; i++) {
si = (PetscReal)(i+1.0);
M[i]=0.5*PetscSqrtReal(si*(si+2.0)/((si+0.5)*(si+1.5)));
}
pm1 = p-1;
ierr = PetscFPTrapPush(PETSC_FP_TRAP_OFF);CHKERRQ(ierr);
PetscStackCallBLAS("LAPACKsteqr",LAPACKsteqr_("N",&pm1,&glldata->zGL[1],M,&x,&pm1,M,&lierr));
if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in STERF Lapack routine %d",(int)lierr);
ierr = PetscFPTrapPop();CHKERRQ(ierr);
ierr = PetscFree(M);CHKERRQ(ierr);
}
}
/* Weights for 1D quadrature */
ierr = PetscMalloc1(p+1,&glldata->rhoGL);CHKERRQ(ierr);
glldata->rhoGL[0]=2.0/(PetscScalar)(p*(p+1.0));
glldata->rhoGL[p]=glldata->rhoGL[0];
z2 = -1; /* Dummy value to avoid -Wmaybe-initialized */
for (i=1; i<p; i++) {
x = glldata->zGL[i];
z0 = 1.0;
z1 = x;
for (n=1; n<p; n++) {
z2 = x*z1*(2.0*n+1.0)/(n+1.0)-z0*(PetscScalar)(n/(n+1.0));
z0 = z1;
z1 = z2;
}
glldata->rhoGL[i]=2.0/(p*(p+1.0)*z2*z2);
}
/* Auxiliary mat for laplacian */
ierr = PetscMalloc1(p+1,&glldata->A);CHKERRQ(ierr);
ierr = PetscMalloc1((p+1)*(p+1),&glldata->A[0]);CHKERRQ(ierr);
for (i=1; i<p+1; i++) glldata->A[i]=glldata->A[i-1]+p+1;
for (j=1; j<p; j++) {
x =glldata->zGL[j];
z0=1.0;
z1=x;
for (n=1; n<p; n++) {
z2=x*z1*(2.0*n+1.0)/(n+1.0)-z0*(PetscScalar)(n/(n+1.0));
z0=z1;
z1=z2;
}
Lpj=z2;
for (r=1; r<p; r++) {
if (r == j) {
glldata->A[j][j]=2.0/(3.0*(1.0-glldata->zGL[j]*glldata->zGL[j])*Lpj*Lpj);
} else {
x = glldata->zGL[r];
z0 = 1.0;
z1 = x;
for (n=1; n<p; n++) {
z2=x*z1*(2.0*n+1.0)/(n+1.0)-z0*(PetscScalar)(n/(n+1.0));
z0=z1;
z1=z2;
}
Lpr = z2;
glldata->A[r][j]=4.0/(p*(p+1.0)*Lpj*Lpr*(glldata->zGL[j]-glldata->zGL[r])*(glldata->zGL[j]-glldata->zGL[r]));
}
}
}
for (j=1; j<p+1; j++) {
x = glldata->zGL[j];
z0 = 1.0;
z1 = x;
for (n=1; n<p; n++) {
z2=x*z1*(2.0*n+1.0)/(n+1.0)-z0*(PetscScalar)(n/(n+1.0));
z0=z1;
z1=z2;
}
Lpj = z2;
glldata->A[j][0]=4.0*PetscPowRealInt(-1.0,p)/(p*(p+1.0)*Lpj*(1.0+glldata->zGL[j])*(1.0+glldata->zGL[j]));
glldata->A[0][j]=glldata->A[j][0];
}
for (j=0; j<p; j++) {
x = glldata->zGL[j];
z0 = 1.0;
z1 = x;
for (n=1; n<p; n++) {
z2=x*z1*(2.0*n+1.0)/(n+1.0)-z0*(PetscScalar)(n/(n+1.0));
z0=z1;
z1=z2;
}
Lpj=z2;
glldata->A[p][j]=4.0/(p*(p+1.0)*Lpj*(1.0-glldata->zGL[j])*(1.0-glldata->zGL[j]));
glldata->A[j][p]=glldata->A[p][j];
}
glldata->A[0][0]=0.5+(p*(p+1.0)-2.0)/6.0;
glldata->A[p][p]=glldata->A[0][0];
/* compute element matrix */
xloc = p+1;
yloc = p+1;
zloc = p+1;
if (dd.dim<2) yloc=1;
if (dd.dim<3) zloc=1;
xyloc = xloc*yloc;
xyzloc = xloc*yloc*zloc;
ierr = MatCreate(PETSC_COMM_SELF,&glldata->elem_mat);CHKERRQ(ierr);
ierr = MatSetSizes(glldata->elem_mat,xyzloc,xyzloc,xyzloc,xyzloc);CHKERRQ(ierr);
ierr = MatSetType(glldata->elem_mat,MATSEQAIJ);CHKERRQ(ierr);
ierr = MatSeqAIJSetPreallocation(glldata->elem_mat,xyzloc,NULL);CHKERRQ(ierr); /* overestimated */
ierr = MatZeroEntries(glldata->elem_mat);CHKERRQ(ierr);
ierr = MatSetOption(glldata->elem_mat,MAT_IGNORE_ZERO_ENTRIES,PETSC_TRUE);CHKERRQ(ierr);
for (k=0; k<zloc; k++) {
if (dd.dim>2) rhoGLk=glldata->rhoGL[k];
else rhoGLk=1.0;
for (j=0; j<yloc; j++) {
if (dd.dim>1) rhoGLj=glldata->rhoGL[j];
else rhoGLj=1.0;
for (i=0; i<xloc; i++) {
ii = k*xyloc+j*xloc+i;
s = k;
r = j;
for (q=0; q<xloc; q++) {
jj = s*xyloc+r*xloc+q;
ierr = MatSetValue(glldata->elem_mat,jj,ii,glldata->A[i][q]*rhoGLj*rhoGLk,ADD_VALUES);CHKERRQ(ierr);
}
if (dd.dim>1) {
s=k;
q=i;
for (r=0; r<yloc; r++) {
jj = s*xyloc+r*xloc+q;
ierr = MatSetValue(glldata->elem_mat,jj,ii,glldata->A[j][r]*glldata->rhoGL[i]*rhoGLk,ADD_VALUES);CHKERRQ(ierr);
}
}
if (dd.dim>2) {
r=j;
q=i;
for (s=0; s<zloc; s++) {
jj = s*xyloc+r*xloc+q;
ierr = MatSetValue(glldata->elem_mat,jj,ii,glldata->A[k][s]*rhoGLj*glldata->rhoGL[i],ADD_VALUES);CHKERRQ(ierr);
}
}
}
}
}
ierr = MatAssemblyBegin(glldata->elem_mat,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd (glldata->elem_mat,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
#if DEBUG
{
Vec lvec,rvec;
PetscReal norm;
ierr = MatCreateVecs(glldata->elem_mat,&lvec,&rvec);CHKERRQ(ierr);
ierr = VecSet(lvec,1.0);CHKERRQ(ierr);
ierr = MatMult(glldata->elem_mat,lvec,rvec);CHKERRQ(ierr);
ierr = VecNorm(rvec,NORM_INFINITY,&norm);CHKERRQ(ierr);
printf("Test null space of elem mat % 1.14e\n",norm);
ierr = VecDestroy(&lvec);CHKERRQ(ierr);
ierr = VecDestroy(&rvec);CHKERRQ(ierr);
}
#endif
PetscFunctionReturn(0);
}