Actual source code: dt.c

petsc-dev 2014-02-02
Report Typos and Errors
  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: }