Actual source code: dt.c
petsc-dev 2014-02-02
1: /* Discretization tools */
3: #include <petscconf.h>
4: #if defined(PETSC_HAVE_MATHIMF_H)
5: #include <mathimf.h> /* this needs to be included before math.h */
6: #endif
8: #include <petscdt.h> /*I "petscdt.h" I*/
9: #include <petscblaslapack.h>
10: #include <petsc-private/petscimpl.h>
11: #include <petscviewer.h>
12: #include <petscdmplex.h>
13: #include <petscdmshell.h>
17: PetscErrorCode PetscQuadratureDestroy(PetscQuadrature *q)
18: {
22: PetscFree(q->points);
23: PetscFree(q->weights);
24: return(0);
25: }
29: PetscErrorCode PetscQuadratureView(PetscQuadrature quad, PetscViewer viewer)
30: {
31: PetscInt q, d;
35: PetscViewerASCIIPrintf(viewer, "Quadrature on %d points\n (", quad.numPoints);
36: for (q = 0; q < quad.numPoints; ++q) {
37: for (d = 0; d < quad.dim; ++d) {
38: if (d) PetscViewerASCIIPrintf(viewer, ", ");
39: PetscViewerASCIIPrintf(viewer, "%g\n", quad.points[q*quad.dim+d]);
40: }
41: PetscViewerASCIIPrintf(viewer, ") %g\n", quad.weights[q]);
42: }
43: return(0);
44: }
48: /*@
49: PetscDTLegendreEval - evaluate Legendre polynomial at points
51: Not Collective
53: Input Arguments:
54: + npoints - number of spatial points to evaluate at
55: . points - array of locations to evaluate at
56: . ndegree - number of basis degrees to evaluate
57: - degrees - sorted array of degrees to evaluate
59: Output Arguments:
60: + B - row-oriented basis evaluation matrix B[point*ndegree + degree] (dimension npoints*ndegrees, allocated by caller) (or NULL)
61: . D - row-oriented derivative evaluation matrix (or NULL)
62: - D2 - row-oriented second derivative evaluation matrix (or NULL)
64: Level: intermediate
66: .seealso: PetscDTGaussQuadrature()
67: @*/
68: PetscErrorCode PetscDTLegendreEval(PetscInt npoints,const PetscReal *points,PetscInt ndegree,const PetscInt *degrees,PetscReal *B,PetscReal *D,PetscReal *D2)
69: {
70: PetscInt i,maxdegree;
73: if (!npoints || !ndegree) return(0);
74: maxdegree = degrees[ndegree-1];
75: for (i=0; i<npoints; i++) {
76: PetscReal pm1,pm2,pd1,pd2,pdd1,pdd2,x;
77: PetscInt j,k;
78: x = points[i];
79: pm2 = 0;
80: pm1 = 1;
81: pd2 = 0;
82: pd1 = 0;
83: pdd2 = 0;
84: pdd1 = 0;
85: k = 0;
86: if (degrees[k] == 0) {
87: if (B) B[i*ndegree+k] = pm1;
88: if (D) D[i*ndegree+k] = pd1;
89: if (D2) D2[i*ndegree+k] = pdd1;
90: k++;
91: }
92: for (j=1; j<=maxdegree; j++,k++) {
93: PetscReal p,d,dd;
94: p = ((2*j-1)*x*pm1 - (j-1)*pm2)/j;
95: d = pd2 + (2*j-1)*pm1;
96: dd = pdd2 + (2*j-1)*pd1;
97: pm2 = pm1;
98: pm1 = p;
99: pd2 = pd1;
100: pd1 = d;
101: pdd2 = pdd1;
102: pdd1 = dd;
103: if (degrees[k] == j) {
104: if (B) B[i*ndegree+k] = p;
105: if (D) D[i*ndegree+k] = d;
106: if (D2) D2[i*ndegree+k] = dd;
107: }
108: }
109: }
110: return(0);
111: }
115: /*@
116: PetscDTGaussQuadrature - create Gauss quadrature
118: Not Collective
120: Input Arguments:
121: + npoints - number of points
122: . a - left end of interval (often-1)
123: - b - right end of interval (often +1)
125: Output Arguments:
126: + x - quadrature points
127: - w - quadrature weights
129: Level: intermediate
131: References:
132: Golub and Welsch, Calculation of Quadrature Rules, Math. Comp. 23(106), 221--230, 1969.
134: .seealso: PetscDTLegendreEval()
135: @*/
136: PetscErrorCode PetscDTGaussQuadrature(PetscInt npoints,PetscReal a,PetscReal b,PetscReal *x,PetscReal *w)
137: {
139: PetscInt i;
140: PetscReal *work;
141: PetscScalar *Z;
142: PetscBLASInt N,LDZ,info;
145: /* Set up the Golub-Welsch system */
146: for (i=0; i<npoints; i++) {
147: x[i] = 0; /* diagonal is 0 */
148: if (i) w[i-1] = 0.5 / PetscSqrtReal(1 - 1./PetscSqr(2*i));
149: }
150: PetscRealView(npoints-1,w,PETSC_VIEWER_STDOUT_SELF);
151: PetscMalloc2(npoints*npoints,&Z,PetscMax(1,2*npoints-2),&work);
152: PetscBLASIntCast(npoints,&N);
153: LDZ = N;
154: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
155: PetscStackCallBLAS("LAPACKsteqr",LAPACKsteqr_("I",&N,x,w,Z,&LDZ,work,&info));
156: PetscFPTrapPop();
157: if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"xSTEQR error");
159: for (i=0; i<(npoints+1)/2; i++) {
160: PetscReal y = 0.5 * (-x[i] + x[npoints-i-1]); /* enforces symmetry */
161: x[i] = (a+b)/2 - y*(b-a)/2;
162: x[npoints-i-1] = (a+b)/2 + y*(b-a)/2;
164: w[i] = w[npoints-1-i] = (b-a)*PetscSqr(0.5*PetscAbsScalar(Z[i*npoints] + Z[(npoints-i-1)*npoints]));
165: }
166: PetscFree2(Z,work);
167: return(0);
168: }
172: /* Evaluates the nth jacobi polynomial with weight parameters a,b at a point x.
173: Recurrence relations implemented from the pseudocode given in Karniadakis and Sherwin, Appendix B */
174: PETSC_STATIC_INLINE PetscErrorCode PetscDTFactorial_Internal(PetscInt n, PetscReal *factorial)
175: {
176: PetscReal f = 1.0;
177: PetscInt i;
180: for (i = 1; i < n+1; ++i) f *= i;
181: *factorial = f;
182: return(0);
183: }
187: /* Evaluates the nth jacobi polynomial with weight parameters a,b at a point x.
188: Recurrence relations implemented from the pseudocode given in Karniadakis and Sherwin, Appendix B */
189: PETSC_STATIC_INLINE PetscErrorCode PetscDTComputeJacobi(PetscReal a, PetscReal b, PetscInt n, PetscReal x, PetscReal *P)
190: {
191: PetscReal apb, pn1, pn2;
192: PetscInt k;
195: if (!n) {*P = 1.0; return(0);}
196: if (n == 1) {*P = 0.5 * (a - b + (a + b + 2.0) * x); return(0);}
197: apb = a + b;
198: pn2 = 1.0;
199: pn1 = 0.5 * (a - b + (apb + 2.0) * x);
200: *P = 0.0;
201: for (k = 2; k < n+1; ++k) {
202: PetscReal a1 = 2.0 * k * (k + apb) * (2.0*k + apb - 2.0);
203: PetscReal a2 = (2.0 * k + apb - 1.0) * (a*a - b*b);
204: PetscReal a3 = (2.0 * k + apb - 2.0) * (2.0 * k + apb - 1.0) * (2.0 * k + apb);
205: PetscReal a4 = 2.0 * (k + a - 1.0) * (k + b - 1.0) * (2.0 * k + apb);
207: a2 = a2 / a1;
208: a3 = a3 / a1;
209: a4 = a4 / a1;
210: *P = (a2 + a3 * x) * pn1 - a4 * pn2;
211: pn2 = pn1;
212: pn1 = *P;
213: }
214: return(0);
215: }
219: /* Evaluates the first derivative of P_{n}^{a,b} at a point x. */
220: PETSC_STATIC_INLINE PetscErrorCode PetscDTComputeJacobiDerivative(PetscReal a, PetscReal b, PetscInt n, PetscReal x, PetscReal *P)
221: {
222: PetscReal nP;
226: if (!n) {*P = 0.0; return(0);}
227: PetscDTComputeJacobi(a+1, b+1, n-1, x, &nP);
228: *P = 0.5 * (a + b + n + 1) * nP;
229: return(0);
230: }
234: /* Maps from [-1,1]^2 to the (-1,1) reference triangle */
235: PETSC_STATIC_INLINE PetscErrorCode PetscDTMapSquareToTriangle_Internal(PetscReal x, PetscReal y, PetscReal *xi, PetscReal *eta)
236: {
238: *xi = 0.5 * (1.0 + x) * (1.0 - y) - 1.0;
239: *eta = y;
240: return(0);
241: }
245: /* Maps from [-1,1]^2 to the (-1,1) reference triangle */
246: PETSC_STATIC_INLINE PetscErrorCode PetscDTMapCubeToTetrahedron_Internal(PetscReal x, PetscReal y, PetscReal z, PetscReal *xi, PetscReal *eta, PetscReal *zeta)
247: {
249: *xi = 0.25 * (1.0 + x) * (1.0 - y) * (1.0 - z) - 1.0;
250: *eta = 0.5 * (1.0 + y) * (1.0 - z) - 1.0;
251: *zeta = z;
252: return(0);
253: }
257: static PetscErrorCode PetscDTGaussJacobiQuadrature1D_Internal(PetscInt npoints, PetscReal a, PetscReal b, PetscReal *x, PetscReal *w)
258: {
259: PetscInt maxIter = 100;
260: PetscReal eps = 1.0e-8;
261: PetscReal a1, a2, a3, a4, a5, a6;
262: PetscInt k;
267: a1 = PetscPowReal(2.0, a+b+1);
268: #if defined(PETSC_HAVE_TGAMMA)
269: a2 = tgamma(a + npoints + 1);
270: a3 = tgamma(b + npoints + 1);
271: a4 = tgamma(a + b + npoints + 1);
272: #else
273: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"tgamma() - math routine is unavailable.");
274: #endif
276: PetscDTFactorial_Internal(npoints, &a5);
277: a6 = a1 * a2 * a3 / a4 / a5;
278: /* Computes the m roots of P_{m}^{a,b} on [-1,1] by Newton's method with Chebyshev points as initial guesses.
279: Algorithm implemented from the pseudocode given by Karniadakis and Sherwin and Python in FIAT */
280: for (k = 0; k < npoints; ++k) {
281: PetscReal r = -PetscCosReal((2.0*k + 1.0) * PETSC_PI / (2.0 * npoints)), dP;
282: PetscInt j;
284: if (k > 0) r = 0.5 * (r + x[k-1]);
285: for (j = 0; j < maxIter; ++j) {
286: PetscReal s = 0.0, delta, f, fp;
287: PetscInt i;
289: for (i = 0; i < k; ++i) s = s + 1.0 / (r - x[i]);
290: PetscDTComputeJacobi(a, b, npoints, r, &f);
291: PetscDTComputeJacobiDerivative(a, b, npoints, r, &fp);
292: delta = f / (fp - f * s);
293: r = r - delta;
294: if (fabs(delta) < eps) break;
295: }
296: x[k] = r;
297: PetscDTComputeJacobiDerivative(a, b, npoints, x[k], &dP);
298: w[k] = a6 / (1.0 - PetscSqr(x[k])) / PetscSqr(dP);
299: }
300: return(0);
301: }
305: /*@C
306: PetscDTGaussJacobiQuadrature - create Gauss-Jacobi quadrature for a simplex
308: Not Collective
310: Input Arguments:
311: + dim - The simplex dimension
312: . order - The quadrature order
313: . a - left end of interval (often-1)
314: - b - right end of interval (often +1)
316: Output Arguments:
317: . q - A PetscQuadrature object
319: Level: intermediate
321: References:
322: Karniadakis and Sherwin.
323: FIAT
325: .seealso: PetscDTGaussQuadrature()
326: @*/
327: PetscErrorCode PetscDTGaussJacobiQuadrature(PetscInt dim, PetscInt order, PetscReal a, PetscReal b, PetscQuadrature *q)
328: {
329: PetscInt npoints = dim > 1 ? dim > 2 ? order*PetscSqr(order) : PetscSqr(order) : order;
330: PetscReal *px, *wx, *py, *wy, *pz, *wz, *x, *w;
331: PetscInt i, j, k;
335: if ((a != -1.0) || (b != 1.0)) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_ARG_OUTOFRANGE, "Must use default internal right now");
336: PetscMalloc1(npoints*dim, &x);
337: PetscMalloc1(npoints, &w);
338: switch (dim) {
339: case 0:
340: PetscFree(x);
341: PetscFree(w);
342: PetscMalloc1(1, &x);
343: PetscMalloc1(1, &w);
344: x[0] = 0.0;
345: w[0] = 1.0;
346: break;
347: case 1:
348: PetscDTGaussJacobiQuadrature1D_Internal(order, 0.0, 0.0, x, w);
349: break;
350: case 2:
351: PetscMalloc4(order,&px,order,&wx,order,&py,order,&wy);
352: PetscDTGaussJacobiQuadrature1D_Internal(order, 0.0, 0.0, px, wx);
353: PetscDTGaussJacobiQuadrature1D_Internal(order, 1.0, 0.0, py, wy);
354: for (i = 0; i < order; ++i) {
355: for (j = 0; j < order; ++j) {
356: PetscDTMapSquareToTriangle_Internal(px[i], py[j], &x[(i*order+j)*2+0], &x[(i*order+j)*2+1]);
357: w[i*order+j] = 0.5 * wx[i] * wy[j];
358: }
359: }
360: PetscFree4(px,wx,py,wy);
361: break;
362: case 3:
363: PetscMalloc6(order,&px,order,&wx,order,&py,order,&wy,order,&pz,order,&wz);
364: PetscDTGaussJacobiQuadrature1D_Internal(order, 0.0, 0.0, px, wx);
365: PetscDTGaussJacobiQuadrature1D_Internal(order, 1.0, 0.0, py, wy);
366: PetscDTGaussJacobiQuadrature1D_Internal(order, 2.0, 0.0, pz, wz);
367: for (i = 0; i < order; ++i) {
368: for (j = 0; j < order; ++j) {
369: for (k = 0; k < order; ++k) {
370: PetscDTMapCubeToTetrahedron_Internal(px[i], py[j], pz[k], &x[((i*order+j)*order+k)*3+0], &x[((i*order+j)*order+k)*3+1], &x[((i*order+j)*order+k)*3+2]);
371: w[(i*order+j)*order+k] = 0.125 * wx[i] * wy[j] * wz[k];
372: }
373: }
374: }
375: PetscFree6(px,wx,py,wy,pz,wz);
376: break;
377: default:
378: SETERRQ1(PETSC_COMM_SELF, PETSC_ERR_ARG_OUTOFRANGE, "Cannot construct quadrature rule for dimension %d", dim);
379: }
380: q->dim = dim;
381: q->numPoints = npoints;
382: q->points = x;
383: q->weights = w;
384: return(0);
385: }
389: /* Overwrites A. Can only handle full-rank problems with m>=n
390: * A in column-major format
391: * Ainv in row-major format
392: * tau has length m
393: * worksize must be >= max(1,n)
394: */
395: static PetscErrorCode PetscDTPseudoInverseQR(PetscInt m,PetscInt mstride,PetscInt n,PetscReal *A_in,PetscReal *Ainv_out,PetscScalar *tau,PetscInt worksize,PetscScalar *work)
396: {
398: PetscBLASInt M,N,K,lda,ldb,ldwork,info;
399: PetscScalar *A,*Ainv,*R,*Q,Alpha;
402: #if defined(PETSC_USE_COMPLEX)
403: {
404: PetscInt i,j;
405: PetscMalloc2(m*n,&A,m*n,&Ainv);
406: for (j=0; j<n; j++) {
407: for (i=0; i<m; i++) A[i+m*j] = A_in[i+mstride*j];
408: }
409: mstride = m;
410: }
411: #else
412: A = A_in;
413: Ainv = Ainv_out;
414: #endif
416: PetscBLASIntCast(m,&M);
417: PetscBLASIntCast(n,&N);
418: PetscBLASIntCast(mstride,&lda);
419: PetscBLASIntCast(worksize,&ldwork);
420: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
421: LAPACKgeqrf_(&M,&N,A,&lda,tau,work,&ldwork,&info);
422: PetscFPTrapPop();
423: if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xGEQRF error");
424: R = A; /* Upper triangular part of A now contains R, the rest contains the elementary reflectors */
426: /* Extract an explicit representation of Q */
427: Q = Ainv;
428: PetscMemcpy(Q,A,mstride*n*sizeof(PetscScalar));
429: K = N; /* full rank */
430: LAPACKungqr_(&M,&N,&K,Q,&lda,tau,work,&ldwork,&info);
431: if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"xORGQR/xUNGQR error");
433: /* Compute A^{-T} = (R^{-1} Q^T)^T = Q R^{-T} */
434: Alpha = 1.0;
435: ldb = lda;
436: BLAStrsm_("Right","Upper","ConjugateTranspose","NotUnitTriangular",&M,&N,&Alpha,R,&lda,Q,&ldb);
437: /* Ainv is Q, overwritten with inverse */
439: #if defined(PETSC_USE_COMPLEX)
440: {
441: PetscInt i;
442: for (i=0; i<m*n; i++) Ainv_out[i] = PetscRealPart(Ainv[i]);
443: PetscFree2(A,Ainv);
444: }
445: #endif
446: return(0);
447: }
451: /* Computes integral of L_p' over intervals {(x0,x1),(x1,x2),...} */
452: static PetscErrorCode PetscDTLegendreIntegrate(PetscInt ninterval,const PetscReal *x,PetscInt ndegree,const PetscInt *degrees,PetscBool Transpose,PetscReal *B)
453: {
455: PetscReal *Bv;
456: PetscInt i,j;
459: PetscMalloc1((ninterval+1)*ndegree,&Bv);
460: /* Point evaluation of L_p on all the source vertices */
461: PetscDTLegendreEval(ninterval+1,x,ndegree,degrees,Bv,NULL,NULL);
462: /* Integral over each interval: \int_a^b L_p' = L_p(b)-L_p(a) */
463: for (i=0; i<ninterval; i++) {
464: for (j=0; j<ndegree; j++) {
465: if (Transpose) B[i+ninterval*j] = Bv[(i+1)*ndegree+j] - Bv[i*ndegree+j];
466: else B[i*ndegree+j] = Bv[(i+1)*ndegree+j] - Bv[i*ndegree+j];
467: }
468: }
469: PetscFree(Bv);
470: return(0);
471: }
475: /*@
476: PetscDTReconstructPoly - create matrix representing polynomial reconstruction using cell intervals and evaluation at target intervals
478: Not Collective
480: Input Arguments:
481: + degree - degree of reconstruction polynomial
482: . nsource - number of source intervals
483: . sourcex - sorted coordinates of source cell boundaries (length nsource+1)
484: . ntarget - number of target intervals
485: - targetx - sorted coordinates of target cell boundaries (length ntarget+1)
487: Output Arguments:
488: . R - reconstruction matrix, utarget = sum_s R[t*nsource+s] * usource[s]
490: Level: advanced
492: .seealso: PetscDTLegendreEval()
493: @*/
494: PetscErrorCode PetscDTReconstructPoly(PetscInt degree,PetscInt nsource,const PetscReal *sourcex,PetscInt ntarget,const PetscReal *targetx,PetscReal *R)
495: {
497: PetscInt i,j,k,*bdegrees,worksize;
498: PetscReal xmin,xmax,center,hscale,*sourcey,*targety,*Bsource,*Bsinv,*Btarget;
499: PetscScalar *tau,*work;
505: if (degree >= nsource) SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_ARG_INCOMP,"Reconstruction degree %D must be less than number of source intervals %D",degree,nsource);
506: #if defined(PETSC_USE_DEBUG)
507: for (i=0; i<nsource; i++) {
508: if (sourcex[i] >= sourcex[i+1]) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Source interval %D has negative orientation (%g,%g)",i,(double)sourcex[i],(double)sourcex[i+1]);
509: }
510: for (i=0; i<ntarget; i++) {
511: if (targetx[i] >= targetx[i+1]) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Target interval %D has negative orientation (%g,%g)",i,(double)targetx[i],(double)targetx[i+1]);
512: }
513: #endif
514: xmin = PetscMin(sourcex[0],targetx[0]);
515: xmax = PetscMax(sourcex[nsource],targetx[ntarget]);
516: center = (xmin + xmax)/2;
517: hscale = (xmax - xmin)/2;
518: worksize = nsource;
519: PetscMalloc4(degree+1,&bdegrees,nsource+1,&sourcey,nsource*(degree+1),&Bsource,worksize,&work);
520: PetscMalloc4(nsource,&tau,nsource*(degree+1),&Bsinv,ntarget+1,&targety,ntarget*(degree+1),&Btarget);
521: for (i=0; i<=nsource; i++) sourcey[i] = (sourcex[i]-center)/hscale;
522: for (i=0; i<=degree; i++) bdegrees[i] = i+1;
523: PetscDTLegendreIntegrate(nsource,sourcey,degree+1,bdegrees,PETSC_TRUE,Bsource);
524: PetscDTPseudoInverseQR(nsource,nsource,degree+1,Bsource,Bsinv,tau,nsource,work);
525: for (i=0; i<=ntarget; i++) targety[i] = (targetx[i]-center)/hscale;
526: PetscDTLegendreIntegrate(ntarget,targety,degree+1,bdegrees,PETSC_FALSE,Btarget);
527: for (i=0; i<ntarget; i++) {
528: PetscReal rowsum = 0;
529: for (j=0; j<nsource; j++) {
530: PetscReal sum = 0;
531: for (k=0; k<degree+1; k++) {
532: sum += Btarget[i*(degree+1)+k] * Bsinv[k*nsource+j];
533: }
534: R[i*nsource+j] = sum;
535: rowsum += sum;
536: }
537: for (j=0; j<nsource; j++) R[i*nsource+j] /= rowsum; /* normalize each row */
538: }
539: PetscFree4(bdegrees,sourcey,Bsource,work);
540: PetscFree4(tau,Bsinv,targety,Btarget);
541: return(0);
542: }