/*@
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);
}
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);
}
