Actual source code: rk.c
petsc-3.9.1 2018-04-29
1: /*
2: Code for time stepping with the Runge-Kutta method
4: Notes:
5: The general system is written as
7: Udot = F(t,U)
9: */
10: #include <petsc/private/tsimpl.h>
11: #include <petscdm.h>
13: static TSRKType TSRKDefault = TSRK3BS;
14: static PetscBool TSRKRegisterAllCalled;
15: static PetscBool TSRKPackageInitialized;
17: typedef struct _RKTableau *RKTableau;
18: struct _RKTableau {
19: char *name;
20: PetscInt order; /* Classical approximation order of the method i */
21: PetscInt s; /* Number of stages */
22: PetscInt p; /* Interpolation order */
23: PetscBool FSAL; /* flag to indicate if tableau is FSAL */
24: PetscReal *A,*b,*c; /* Tableau */
25: PetscReal *bembed; /* Embedded formula of order one less (order-1) */
26: PetscReal *binterp; /* Dense output formula */
27: PetscReal ccfl; /* Placeholder for CFL coefficient relative to forward Euler */
28: };
29: typedef struct _RKTableauLink *RKTableauLink;
30: struct _RKTableauLink {
31: struct _RKTableau tab;
32: RKTableauLink next;
33: };
34: static RKTableauLink RKTableauList;
36: typedef struct {
37: RKTableau tableau;
38: Vec *Y; /* States computed during the step */
39: Vec *YdotRHS; /* Function evaluations for the non-stiff part */
40: Vec *VecDeltaLam; /* Increment of the adjoint sensitivity w.r.t IC at stage */
41: Vec *VecDeltaMu; /* Increment of the adjoint sensitivity w.r.t P at stage */
42: Vec VecCostIntegral0; /* backup for roll-backs due to events */
43: PetscScalar *work; /* Scalar work */
44: PetscReal stage_time;
45: TSStepStatus status;
46: PetscReal ptime;
47: PetscReal time_step;
48: } TS_RK;
50: /*MC
51: TSRK1FE - First order forward Euler scheme.
53: This method has one stage.
55: Options database:
56: . -ts_rk_type 1fe
58: Level: advanced
60: .seealso: TSRK, TSRKType, TSRKSetType()
61: M*/
62: /*MC
63: TSRK2A - Second order RK scheme.
65: This method has two stages.
67: Options database:
68: . -ts_rk_type 2a
70: Level: advanced
72: .seealso: TSRK, TSRKType, TSRKSetType()
73: M*/
74: /*MC
75: TSRK3 - Third order RK scheme.
77: This method has three stages.
79: Options database:
80: . -ts_rk_type 3
82: Level: advanced
84: .seealso: TSRK, TSRKType, TSRKSetType()
85: M*/
86: /*MC
87: TSRK3BS - Third order RK scheme of Bogacki-Shampine with 2nd order embedded method.
89: This method has four stages with the First Same As Last (FSAL) property.
91: Options database:
92: . -ts_rk_type 3bs
94: Level: advanced
96: References: https://doi.org/10.1016/0893-9659(89)90079-7
98: .seealso: TSRK, TSRKType, TSRKSetType()
99: M*/
100: /*MC
101: TSRK4 - Fourth order RK scheme.
103: This is the classical Runge-Kutta method with four stages.
105: Options database:
106: . -ts_rk_type 4
108: Level: advanced
110: .seealso: TSRK, TSRKType, TSRKSetType()
111: M*/
112: /*MC
113: TSRK5F - Fifth order Fehlberg RK scheme with a 4th order embedded method.
115: This method has six stages.
117: Options database:
118: . -ts_rk_type 5f
120: Level: advanced
122: .seealso: TSRK, TSRKType, TSRKSetType()
123: M*/
124: /*MC
125: TSRK5DP - Fifth order Dormand-Prince RK scheme with the 4th order embedded method.
127: This method has seven stages with the First Same As Last (FSAL) property.
129: Options database:
130: . -ts_rk_type 5dp
132: Level: advanced
134: References: https://doi.org/10.1016/0771-050X(80)90013-3
136: .seealso: TSRK, TSRKType, TSRKSetType()
137: M*/
138: /*MC
139: TSRK5BS - Fifth order Bogacki-Shampine RK scheme with 4th order embedded method.
141: This method has eight stages with the First Same As Last (FSAL) property.
143: Options database:
144: . -ts_rk_type 5bs
146: Level: advanced
148: References: https://doi.org/10.1016/0898-1221(96)00141-1
150: .seealso: TSRK, TSRKType, TSRKSetType()
151: M*/
153: /*@C
154: TSRKRegisterAll - Registers all of the Runge-Kutta explicit methods in TSRK
156: Not Collective, but should be called by all processes which will need the schemes to be registered
158: Level: advanced
160: .keywords: TS, TSRK, register, all
162: .seealso: TSRKRegisterDestroy()
163: @*/
164: PetscErrorCode TSRKRegisterAll(void)
165: {
169: if (TSRKRegisterAllCalled) return(0);
170: TSRKRegisterAllCalled = PETSC_TRUE;
172: #define RC PetscRealConstant
173: {
174: const PetscReal
175: A[1][1] = {{0}},
176: b[1] = {RC(1.0)};
177: TSRKRegister(TSRK1FE,1,1,&A[0][0],b,NULL,NULL,0,NULL);
178: }
179: {
180: const PetscReal
181: A[2][2] = {{0,0},
182: {RC(1.0),0}},
183: b[2] = {RC(0.5),RC(0.5)},
184: bembed[2] = {RC(1.0),0};
185: TSRKRegister(TSRK2A,2,2,&A[0][0],b,NULL,bembed,0,NULL);
186: }
187: {
188: const PetscReal
189: A[3][3] = {{0,0,0},
190: {RC(2.0)/RC(3.0),0,0},
191: {RC(-1.0)/RC(3.0),RC(1.0),0}},
192: b[3] = {RC(0.25),RC(0.5),RC(0.25)};
193: TSRKRegister(TSRK3,3,3,&A[0][0],b,NULL,NULL,0,NULL);
194: }
195: {
196: const PetscReal
197: A[4][4] = {{0,0,0,0},
198: {RC(1.0)/RC(2.0),0,0,0},
199: {0,RC(3.0)/RC(4.0),0,0},
200: {RC(2.0)/RC(9.0),RC(1.0)/RC(3.0),RC(4.0)/RC(9.0),0}},
201: b[4] = {RC(2.0)/RC(9.0),RC(1.0)/RC(3.0),RC(4.0)/RC(9.0),0},
202: bembed[4] = {RC(7.0)/RC(24.0),RC(1.0)/RC(4.0),RC(1.0)/RC(3.0),RC(1.0)/RC(8.0)};
203: TSRKRegister(TSRK3BS,3,4,&A[0][0],b,NULL,bembed,0,NULL);
204: }
205: {
206: const PetscReal
207: A[4][4] = {{0,0,0,0},
208: {RC(0.5),0,0,0},
209: {0,RC(0.5),0,0},
210: {0,0,RC(1.0),0}},
211: b[4] = {RC(1.0)/RC(6.0),RC(1.0)/RC(3.0),RC(1.0)/RC(3.0),RC(1.0)/RC(6.0)};
212: TSRKRegister(TSRK4,4,4,&A[0][0],b,NULL,NULL,0,NULL);
213: }
214: {
215: const PetscReal
216: A[6][6] = {{0,0,0,0,0,0},
217: {RC(0.25),0,0,0,0,0},
218: {RC(3.0)/RC(32.0),RC(9.0)/RC(32.0),0,0,0,0},
219: {RC(1932.0)/RC(2197.0),RC(-7200.0)/RC(2197.0),RC(7296.0)/RC(2197.0),0,0,0},
220: {RC(439.0)/RC(216.0),RC(-8.0),RC(3680.0)/RC(513.0),RC(-845.0)/RC(4104.0),0,0},
221: {RC(-8.0)/RC(27.0),RC(2.0),RC(-3544.0)/RC(2565.0),RC(1859.0)/RC(4104.0),RC(-11.0)/RC(40.0),0}},
222: b[6] = {RC(16.0)/RC(135.0),0,RC(6656.0)/RC(12825.0),RC(28561.0)/RC(56430.0),RC(-9.0)/RC(50.0),RC(2.0)/RC(55.0)},
223: bembed[6] = {RC(25.0)/RC(216.0),0,RC(1408.0)/RC(2565.0),RC(2197.0)/RC(4104.0),RC(-1.0)/RC(5.0),0};
224: TSRKRegister(TSRK5F,5,6,&A[0][0],b,NULL,bembed,0,NULL);
225: }
226: {
227: const PetscReal
228: A[7][7] = {{0,0,0,0,0,0,0},
229: {RC(1.0)/RC(5.0),0,0,0,0,0,0},
230: {RC(3.0)/RC(40.0),RC(9.0)/RC(40.0),0,0,0,0,0},
231: {RC(44.0)/RC(45.0),RC(-56.0)/RC(15.0),RC(32.0)/RC(9.0),0,0,0,0},
232: {RC(19372.0)/RC(6561.0),RC(-25360.0)/RC(2187.0),RC(64448.0)/RC(6561.0),RC(-212.0)/RC(729.0),0,0,0},
233: {RC(9017.0)/RC(3168.0),RC(-355.0)/RC(33.0),RC(46732.0)/RC(5247.0),RC(49.0)/RC(176.0),RC(-5103.0)/RC(18656.0),0,0},
234: {RC(35.0)/RC(384.0),0,RC(500.0)/RC(1113.0),RC(125.0)/RC(192.0),RC(-2187.0)/RC(6784.0),RC(11.0)/RC(84.0),0}},
235: b[7] = {RC(35.0)/RC(384.0),0,RC(500.0)/RC(1113.0),RC(125.0)/RC(192.0),RC(-2187.0)/RC(6784.0),RC(11.0)/RC(84.0),0},
236: bembed[7] = {RC(5179.0)/RC(57600.0),0,RC(7571.0)/RC(16695.0),RC(393.0)/RC(640.0),RC(-92097.0)/RC(339200.0),RC(187.0)/RC(2100.0),RC(1.0)/RC(40.0)};
237: TSRKRegister(TSRK5DP,5,7,&A[0][0],b,NULL,bembed,0,NULL);
238: }
239: {
240: const PetscReal
241: A[8][8] = {{0,0,0,0,0,0,0,0},
242: {RC(1.0)/RC(6.0),0,0,0,0,0,0,0},
243: {RC(2.0)/RC(27.0),RC(4.0)/RC(27.0),0,0,0,0,0,0},
244: {RC(183.0)/RC(1372.0),RC(-162.0)/RC(343.0),RC(1053.0)/RC(1372.0),0,0,0,0,0},
245: {RC(68.0)/RC(297.0),RC(-4.0)/RC(11.0),RC(42.0)/RC(143.0),RC(1960.0)/RC(3861.0),0,0,0,0},
246: {RC(597.0)/RC(22528.0),RC(81.0)/RC(352.0),RC(63099.0)/RC(585728.0),RC(58653.0)/RC(366080.0),RC(4617.0)/RC(20480.0),0,0,0},
247: {RC(174197.0)/RC(959244.0),RC(-30942.0)/RC(79937.0),RC(8152137.0)/RC(19744439.0),RC(666106.0)/RC(1039181.0),RC(-29421.0)/RC(29068.0),RC(482048.0)/RC(414219.0),0,0},
248: {RC(587.0)/RC(8064.0),0,RC(4440339.0)/RC(15491840.0),RC(24353.0)/RC(124800.0),RC(387.0)/RC(44800.0),RC(2152.0)/RC(5985.0),RC(7267.0)/RC(94080.0),0}},
249: b[8] = {RC(587.0)/RC(8064.0),0,RC(4440339.0)/RC(15491840.0),RC(24353.0)/RC(124800.0),RC(387.0)/RC(44800.0),RC(2152.0)/RC(5985.0),RC(7267.0)/RC(94080.0),0},
250: bembed[8] = {RC(2479.0)/RC(34992.0),0,RC(123.0)/RC(416.0),RC(612941.0)/RC(3411720.0),RC(43.0)/RC(1440.0),RC(2272.0)/RC(6561.0),RC(79937.0)/RC(1113912.0),RC(3293.0)/RC(556956.0)};
251: TSRKRegister(TSRK5BS,5,8,&A[0][0],b,NULL,bembed,0,NULL);
252: }
253: #undef RC
254: return(0);
255: }
257: /*@C
258: TSRKRegisterDestroy - Frees the list of schemes that were registered by TSRKRegister().
260: Not Collective
262: Level: advanced
264: .keywords: TSRK, register, destroy
265: .seealso: TSRKRegister(), TSRKRegisterAll()
266: @*/
267: PetscErrorCode TSRKRegisterDestroy(void)
268: {
270: RKTableauLink link;
273: while ((link = RKTableauList)) {
274: RKTableau t = &link->tab;
275: RKTableauList = link->next;
276: PetscFree3(t->A,t->b,t->c);
277: PetscFree (t->bembed);
278: PetscFree (t->binterp);
279: PetscFree (t->name);
280: PetscFree (link);
281: }
282: TSRKRegisterAllCalled = PETSC_FALSE;
283: return(0);
284: }
286: /*@C
287: TSRKInitializePackage - This function initializes everything in the TSRK package. It is called
288: from PetscDLLibraryRegister() when using dynamic libraries, and on the first call to TSCreate_RK()
289: when using static libraries.
291: Level: developer
293: .keywords: TS, TSRK, initialize, package
294: .seealso: PetscInitialize()
295: @*/
296: PetscErrorCode TSRKInitializePackage(void)
297: {
301: if (TSRKPackageInitialized) return(0);
302: TSRKPackageInitialized = PETSC_TRUE;
303: TSRKRegisterAll();
304: PetscRegisterFinalize(TSRKFinalizePackage);
305: return(0);
306: }
308: /*@C
309: TSRKFinalizePackage - This function destroys everything in the TSRK package. It is
310: called from PetscFinalize().
312: Level: developer
314: .keywords: Petsc, destroy, package
315: .seealso: PetscFinalize()
316: @*/
317: PetscErrorCode TSRKFinalizePackage(void)
318: {
322: TSRKPackageInitialized = PETSC_FALSE;
323: TSRKRegisterDestroy();
324: return(0);
325: }
327: /*@C
328: TSRKRegister - register an RK scheme by providing the entries in the Butcher tableau and optionally embedded approximations and interpolation
330: Not Collective, but the same schemes should be registered on all processes on which they will be used
332: Input Parameters:
333: + name - identifier for method
334: . order - approximation order of method
335: . s - number of stages, this is the dimension of the matrices below
336: . A - stage coefficients (dimension s*s, row-major)
337: . b - step completion table (dimension s; NULL to use last row of A)
338: . c - abscissa (dimension s; NULL to use row sums of A)
339: . bembed - completion table for embedded method (dimension s; NULL if not available)
340: . p - Order of the interpolation scheme, equal to the number of columns of binterp
341: - binterp - Coefficients of the interpolation formula (dimension s*p; NULL to reuse b with p=1)
343: Notes:
344: Several RK methods are provided, this function is only needed to create new methods.
346: Level: advanced
348: .keywords: TS, register
350: .seealso: TSRK
351: @*/
352: PetscErrorCode TSRKRegister(TSRKType name,PetscInt order,PetscInt s,
353: const PetscReal A[],const PetscReal b[],const PetscReal c[],
354: const PetscReal bembed[],PetscInt p,const PetscReal binterp[])
355: {
356: PetscErrorCode ierr;
357: RKTableauLink link;
358: RKTableau t;
359: PetscInt i,j;
369: PetscNew(&link);
370: t = &link->tab;
372: PetscStrallocpy(name,&t->name);
373: t->order = order;
374: t->s = s;
375: PetscMalloc3(s*s,&t->A,s,&t->b,s,&t->c);
376: PetscMemcpy(t->A,A,s*s*sizeof(A[0]));
377: if (b) { PetscMemcpy(t->b,b,s*sizeof(b[0])); }
378: else for (i=0; i<s; i++) t->b[i] = A[(s-1)*s+i];
379: if (c) { PetscMemcpy(t->c,c,s*sizeof(c[0])); }
380: else for (i=0; i<s; i++) for (j=0,t->c[i]=0; j<s; j++) t->c[i] += A[i*s+j];
381: t->FSAL = PETSC_TRUE;
382: for (i=0; i<s; i++) if (t->A[(s-1)*s+i] != t->b[i]) t->FSAL = PETSC_FALSE;
384: if (bembed) {
385: PetscMalloc1(s,&t->bembed);
386: PetscMemcpy(t->bembed,bembed,s*sizeof(bembed[0]));
387: }
389: if (!binterp) { p = 1; binterp = t->b; }
390: t->p = p;
391: PetscMalloc1(s*p,&t->binterp);
392: PetscMemcpy(t->binterp,binterp,s*p*sizeof(binterp[0]));
394: link->next = RKTableauList;
395: RKTableauList = link;
396: return(0);
397: }
399: /*
400: The step completion formula is
402: x1 = x0 + h b^T YdotRHS
404: This function can be called before or after ts->vec_sol has been updated.
405: Suppose we have a completion formula (b) and an embedded formula (be) of different order.
406: We can write
408: x1e = x0 + h be^T YdotRHS
409: = x1 - h b^T YdotRHS + h be^T YdotRHS
410: = x1 + h (be - b)^T YdotRHS
412: so we can evaluate the method with different order even after the step has been optimistically completed.
413: */
414: static PetscErrorCode TSEvaluateStep_RK(TS ts,PetscInt order,Vec X,PetscBool *done)
415: {
416: TS_RK *rk = (TS_RK*)ts->data;
417: RKTableau tab = rk->tableau;
418: PetscScalar *w = rk->work;
419: PetscReal h;
420: PetscInt s = tab->s,j;
424: switch (rk->status) {
425: case TS_STEP_INCOMPLETE:
426: case TS_STEP_PENDING:
427: h = ts->time_step; break;
428: case TS_STEP_COMPLETE:
429: h = ts->ptime - ts->ptime_prev; break;
430: default: SETERRQ(PetscObjectComm((PetscObject)ts),PETSC_ERR_PLIB,"Invalid TSStepStatus");
431: }
432: if (order == tab->order) {
433: if (rk->status == TS_STEP_INCOMPLETE) {
434: VecCopy(ts->vec_sol,X);
435: for (j=0; j<s; j++) w[j] = h*tab->b[j];
436: VecMAXPY(X,s,w,rk->YdotRHS);
437: } else {VecCopy(ts->vec_sol,X);}
438: return(0);
439: } else if (order == tab->order-1) {
440: if (!tab->bembed) goto unavailable;
441: if (rk->status == TS_STEP_INCOMPLETE) { /* Complete with the embedded method (be) */
442: VecCopy(ts->vec_sol,X);
443: for (j=0; j<s; j++) w[j] = h*tab->bembed[j];
444: VecMAXPY(X,s,w,rk->YdotRHS);
445: } else { /* Rollback and re-complete using (be-b) */
446: VecCopy(ts->vec_sol,X);
447: for (j=0; j<s; j++) w[j] = h*(tab->bembed[j] - tab->b[j]);
448: VecMAXPY(X,s,w,rk->YdotRHS);
449: if (ts->vec_costintegral && ts->costintegralfwd) {
450: VecCopy(rk->VecCostIntegral0,ts->vec_costintegral);
451: }
452: }
453: if (done) *done = PETSC_TRUE;
454: return(0);
455: }
456: unavailable:
457: if (done) *done = PETSC_FALSE;
458: else SETERRQ3(PetscObjectComm((PetscObject)ts),PETSC_ERR_SUP,"RK '%s' of order %D cannot evaluate step at order %D. Consider using -ts_adapt_type none or a different method that has an embedded estimate.",tab->name,tab->order,order);
459: return(0);
460: }
462: static PetscErrorCode TSForwardCostIntegral_RK(TS ts)
463: {
464: TS_RK *rk = (TS_RK*)ts->data;
465: RKTableau tab = rk->tableau;
466: const PetscInt s = tab->s;
467: const PetscReal *b = tab->b,*c = tab->c;
468: Vec *Y = rk->Y;
469: PetscInt i;
470: PetscErrorCode ierr;
473: /* backup cost integral */
474: VecCopy(ts->vec_costintegral,rk->VecCostIntegral0);
475: for (i=s-1; i>=0; i--) {
476: /* Evolve ts->vec_costintegral to compute integrals */
477: TSComputeCostIntegrand(ts,rk->ptime+rk->time_step*(1.0-c[i]),Y[i],ts->vec_costintegrand);
478: VecAXPY(ts->vec_costintegral,rk->time_step*b[i],ts->vec_costintegrand);
479: }
480: return(0);
481: }
483: static PetscErrorCode TSAdjointCostIntegral_RK(TS ts)
484: {
485: TS_RK *rk = (TS_RK*)ts->data;
486: RKTableau tab = rk->tableau;
487: const PetscInt s = tab->s;
488: const PetscReal *b = tab->b,*c = tab->c;
489: Vec *Y = rk->Y;
490: PetscInt i;
491: PetscErrorCode ierr;
494: for (i=s-1; i>=0; i--) {
495: /* Evolve ts->vec_costintegral to compute integrals */
496: TSComputeCostIntegrand(ts,ts->ptime-ts->time_step*(1.0-c[i]),Y[i],ts->vec_costintegrand);
497: VecAXPY(ts->vec_costintegral,-ts->time_step*b[i],ts->vec_costintegrand);
498: }
499: return(0);
500: }
502: static PetscErrorCode TSRollBack_RK(TS ts)
503: {
504: TS_RK *rk = (TS_RK*)ts->data;
505: RKTableau tab = rk->tableau;
506: const PetscInt s = tab->s;
507: const PetscReal *b = tab->b;
508: PetscScalar *w = rk->work;
509: Vec *YdotRHS = rk->YdotRHS;
510: PetscInt j;
511: PetscReal h;
512: PetscErrorCode ierr;
515: switch (rk->status) {
516: case TS_STEP_INCOMPLETE:
517: case TS_STEP_PENDING:
518: h = ts->time_step; break;
519: case TS_STEP_COMPLETE:
520: h = ts->ptime - ts->ptime_prev; break;
521: default: SETERRQ(PetscObjectComm((PetscObject)ts),PETSC_ERR_PLIB,"Invalid TSStepStatus");
522: }
523: for (j=0; j<s; j++) w[j] = -h*b[j];
524: VecMAXPY(ts->vec_sol,s,w,YdotRHS);
525: return(0);
526: }
528: static PetscErrorCode TSStep_RK(TS ts)
529: {
530: TS_RK *rk = (TS_RK*)ts->data;
531: RKTableau tab = rk->tableau;
532: const PetscInt s = tab->s;
533: const PetscReal *A = tab->A,*c = tab->c;
534: PetscScalar *w = rk->work;
535: Vec *Y = rk->Y,*YdotRHS = rk->YdotRHS;
536: PetscBool FSAL = tab->FSAL;
537: TSAdapt adapt;
538: PetscInt i,j;
539: PetscInt rejections = 0;
540: PetscBool stageok,accept = PETSC_TRUE;
541: PetscReal next_time_step = ts->time_step;
542: PetscErrorCode ierr;
545: if (ts->steprollback || ts->steprestart) FSAL = PETSC_FALSE;
546: if (FSAL) { VecCopy(YdotRHS[s-1],YdotRHS[0]); }
548: rk->status = TS_STEP_INCOMPLETE;
549: while (!ts->reason && rk->status != TS_STEP_COMPLETE) {
550: PetscReal t = ts->ptime;
551: PetscReal h = ts->time_step;
552: for (i=0; i<s; i++) {
553: rk->stage_time = t + h*c[i];
554: TSPreStage(ts,rk->stage_time);
555: VecCopy(ts->vec_sol,Y[i]);
556: for (j=0; j<i; j++) w[j] = h*A[i*s+j];
557: VecMAXPY(Y[i],i,w,YdotRHS);
558: TSPostStage(ts,rk->stage_time,i,Y);
559: TSGetAdapt(ts,&adapt);
560: TSAdaptCheckStage(adapt,ts,rk->stage_time,Y[i],&stageok);
561: if (!stageok) goto reject_step;
562: if (FSAL && !i) continue;
563: TSComputeRHSFunction(ts,t+h*c[i],Y[i],YdotRHS[i]);
564: }
566: rk->status = TS_STEP_INCOMPLETE;
567: TSEvaluateStep(ts,tab->order,ts->vec_sol,NULL);
568: rk->status = TS_STEP_PENDING;
569: TSGetAdapt(ts,&adapt);
570: TSAdaptCandidatesClear(adapt);
571: TSAdaptCandidateAdd(adapt,tab->name,tab->order,1,tab->ccfl,(PetscReal)tab->s,PETSC_TRUE);
572: TSAdaptChoose(adapt,ts,ts->time_step,NULL,&next_time_step,&accept);
573: rk->status = accept ? TS_STEP_COMPLETE : TS_STEP_INCOMPLETE;
574: if (!accept) { /* Roll back the current step */
575: TSRollBack_RK(ts);
576: ts->time_step = next_time_step;
577: goto reject_step;
578: }
580: if (ts->costintegralfwd) { /* Save the info for the later use in cost integral evaluation*/
581: rk->ptime = ts->ptime;
582: rk->time_step = ts->time_step;
583: }
585: ts->ptime += ts->time_step;
586: ts->time_step = next_time_step;
587: break;
589: reject_step:
590: ts->reject++; accept = PETSC_FALSE;
591: if (!ts->reason && ++rejections > ts->max_reject && ts->max_reject >= 0) {
592: ts->reason = TS_DIVERGED_STEP_REJECTED;
593: PetscInfo2(ts,"Step=%D, step rejections %D greater than current TS allowed, stopping solve\n",ts->steps,rejections);
594: }
595: }
596: return(0);
597: }
599: static PetscErrorCode TSAdjointSetUp_RK(TS ts)
600: {
601: TS_RK *rk = (TS_RK*)ts->data;
602: RKTableau tab = rk->tableau;
603: PetscInt s = tab->s;
607: if (ts->adjointsetupcalled++) return(0);
608: VecDuplicateVecs(ts->vecs_sensi[0],s*ts->numcost,&rk->VecDeltaLam);
609: if(ts->vecs_sensip) {
610: VecDuplicateVecs(ts->vecs_sensip[0],s*ts->numcost,&rk->VecDeltaMu);
611: }
612: return(0);
613: }
615: static PetscErrorCode TSAdjointStep_RK(TS ts)
616: {
617: TS_RK *rk = (TS_RK*)ts->data;
618: RKTableau tab = rk->tableau;
619: const PetscInt s = tab->s;
620: const PetscReal *A = tab->A,*b = tab->b,*c = tab->c;
621: PetscScalar *w = rk->work;
622: Vec *Y = rk->Y,*VecDeltaLam = rk->VecDeltaLam,*VecDeltaMu = rk->VecDeltaMu;
623: PetscInt i,j,nadj;
624: PetscReal t = ts->ptime;
625: PetscErrorCode ierr;
626: PetscReal h = ts->time_step;
629: rk->status = TS_STEP_INCOMPLETE;
630: for (i=s-1; i>=0; i--) {
631: Mat J;
632: PetscReal stage_time = t + h*(1.0-c[i]);
633: PetscBool zero = PETSC_FALSE;
635: TSGetRHSJacobian(ts,&J,NULL,NULL,NULL);
636: TSComputeRHSJacobian(ts,stage_time,Y[i],J,J);
637: if (ts->vec_costintegral) {
638: TSAdjointComputeDRDYFunction(ts,stage_time,Y[i],ts->vecs_drdy);
639: }
640: /* Stage values of mu */
641: if (ts->vecs_sensip) {
642: TSAdjointComputeRHSJacobian(ts,stage_time,Y[i],ts->Jacp);
643: if (ts->vec_costintegral) {
644: TSAdjointComputeDRDPFunction(ts,stage_time,Y[i],ts->vecs_drdp);
645: }
646: }
648: if (b[i] == 0 && i == s-1) zero = PETSC_TRUE;
649: for (nadj=0; nadj<ts->numcost; nadj++) {
650: DM dm;
651: Vec VecSensiTemp;
653: TSGetDM(ts,&dm);
654: DMGetGlobalVector(dm,&VecSensiTemp);
655: /* Stage values of lambda */
656: if (!zero) {
657: VecCopy(ts->vecs_sensi[nadj],VecSensiTemp);
658: VecScale(VecSensiTemp,-h*b[i]);
659: for (j=i+1; j<s; j++) w[j-i-1] = -h*A[j*s+i];
660: VecMAXPY(VecSensiTemp,s-i-1,w,&VecDeltaLam[nadj*s+i+1]);
661: MatMultTranspose(J,VecSensiTemp,VecDeltaLam[nadj*s+i]);
662: } else {
663: VecSet(VecDeltaLam[nadj*s+i],0);
664: }
665: if (ts->vec_costintegral) {
666: VecAXPY(VecDeltaLam[nadj*s+i],-h*b[i],ts->vecs_drdy[nadj]);
667: }
669: /* Stage values of mu */
670: if (ts->vecs_sensip) {
671: if (!zero) {
672: MatMultTranspose(ts->Jacp,VecSensiTemp,VecDeltaMu[nadj*s+i]);
673: } else {
674: VecSet(VecDeltaMu[nadj*s+i],0);
675: }
676: if (ts->vec_costintegral) {
677: VecAXPY(VecDeltaMu[nadj*s+i],-h*b[i],ts->vecs_drdp[nadj]);
678: }
679: }
680: DMRestoreGlobalVector(dm,&VecSensiTemp);
681: }
682: }
684: for (j=0; j<s; j++) w[j] = 1.0;
685: for (nadj=0; nadj<ts->numcost; nadj++) {
686: VecMAXPY(ts->vecs_sensi[nadj],s,w,&VecDeltaLam[nadj*s]);
687: if (ts->vecs_sensip) {
688: VecMAXPY(ts->vecs_sensip[nadj],s,w,&VecDeltaMu[nadj*s]);
689: }
690: }
691: rk->status = TS_STEP_COMPLETE;
692: return(0);
693: }
695: static PetscErrorCode TSInterpolate_RK(TS ts,PetscReal itime,Vec X)
696: {
697: TS_RK *rk = (TS_RK*)ts->data;
698: PetscInt s = rk->tableau->s,p = rk->tableau->p,i,j;
699: PetscReal h;
700: PetscReal tt,t;
701: PetscScalar *b;
702: const PetscReal *B = rk->tableau->binterp;
703: PetscErrorCode ierr;
706: if (!B) SETERRQ1(PetscObjectComm((PetscObject)ts),PETSC_ERR_SUP,"TSRK %s does not have an interpolation formula",rk->tableau->name);
708: switch (rk->status) {
709: case TS_STEP_INCOMPLETE:
710: case TS_STEP_PENDING:
711: h = ts->time_step;
712: t = (itime - ts->ptime)/h;
713: break;
714: case TS_STEP_COMPLETE:
715: h = ts->ptime - ts->ptime_prev;
716: t = (itime - ts->ptime)/h + 1; /* In the interval [0,1] */
717: break;
718: default: SETERRQ(PetscObjectComm((PetscObject)ts),PETSC_ERR_PLIB,"Invalid TSStepStatus");
719: }
720: PetscMalloc1(s,&b);
721: for (i=0; i<s; i++) b[i] = 0;
722: for (j=0,tt=t; j<p; j++,tt*=t) {
723: for (i=0; i<s; i++) {
724: b[i] += h * B[i*p+j] * tt;
725: }
726: }
728: VecCopy(rk->Y[0],X);
729: VecMAXPY(X,s,b,rk->YdotRHS);
731: PetscFree(b);
732: return(0);
733: }
735: /*------------------------------------------------------------*/
737: static PetscErrorCode TSRKTableauReset(TS ts)
738: {
739: TS_RK *rk = (TS_RK*)ts->data;
740: RKTableau tab = rk->tableau;
744: if (!tab) return(0);
745: PetscFree(rk->work);
746: VecDestroyVecs(tab->s,&rk->Y);
747: VecDestroyVecs(tab->s,&rk->YdotRHS);
748: VecDestroyVecs(tab->s*ts->numcost,&rk->VecDeltaLam);
749: VecDestroyVecs(tab->s*ts->numcost,&rk->VecDeltaMu);
750: return(0);
751: }
753: static PetscErrorCode TSReset_RK(TS ts)
754: {
755: TS_RK *rk = (TS_RK*)ts->data;
759: TSRKTableauReset(ts);
760: VecDestroy(&rk->VecCostIntegral0);
761: return(0);
762: }
764: static PetscErrorCode DMCoarsenHook_TSRK(DM fine,DM coarse,void *ctx)
765: {
767: return(0);
768: }
770: static PetscErrorCode DMRestrictHook_TSRK(DM fine,Mat restrct,Vec rscale,Mat inject,DM coarse,void *ctx)
771: {
773: return(0);
774: }
777: static PetscErrorCode DMSubDomainHook_TSRK(DM dm,DM subdm,void *ctx)
778: {
780: return(0);
781: }
783: static PetscErrorCode DMSubDomainRestrictHook_TSRK(DM dm,VecScatter gscat,VecScatter lscat,DM subdm,void *ctx)
784: {
787: return(0);
788: }
789: /*
790: static PetscErrorCode RKSetAdjCoe(RKTableau tab)
791: {
792: PetscReal *A,*b;
793: PetscInt s,i,j;
794: PetscErrorCode ierr;
797: s = tab->s;
798: PetscMalloc2(s*s,&A,s,&b);
800: for (i=0; i<s; i++)
801: for (j=0; j<s; j++) {
802: A[i*s+j] = (tab->b[s-1-i]==0) ? 0: -tab->A[s-1-i+(s-1-j)*s] * tab->b[s-1-j] / tab->b[s-1-i];
803: PetscPrintf(PETSC_COMM_WORLD,"Coefficients: A[%D][%D]=%.6f\n",i,j,A[i*s+j]);
804: }
806: for (i=0; i<s; i++) b[i] = (tab->b[s-1-i]==0)? 0: -tab->b[s-1-i];
808: PetscMemcpy(tab->A,A,s*s*sizeof(A[0]));
809: PetscMemcpy(tab->b,b,s*sizeof(b[0]));
810: PetscFree2(A,b);
811: return(0);
812: }
813: */
815: static PetscErrorCode TSRKTableauSetUp(TS ts)
816: {
817: TS_RK *rk = (TS_RK*)ts->data;
818: RKTableau tab = rk->tableau;
822: PetscMalloc1(tab->s,&rk->work);
823: VecDuplicateVecs(ts->vec_sol,tab->s,&rk->Y);
824: VecDuplicateVecs(ts->vec_sol,tab->s,&rk->YdotRHS);
825: return(0);
826: }
829: static PetscErrorCode TSSetUp_RK(TS ts)
830: {
831: TS_RK *rk = (TS_RK*)ts->data;
833: DM dm;
836: TSCheckImplicitTerm(ts);
837: TSRKTableauSetUp(ts);
838: if (!rk->VecCostIntegral0 && ts->vec_costintegral && ts->costintegralfwd) { /* back up cost integral */
839: VecDuplicate(ts->vec_costintegral,&rk->VecCostIntegral0);
840: }
841: TSGetDM(ts,&dm);
842: DMCoarsenHookAdd(dm,DMCoarsenHook_TSRK,DMRestrictHook_TSRK,ts);
843: DMSubDomainHookAdd(dm,DMSubDomainHook_TSRK,DMSubDomainRestrictHook_TSRK,ts);
844: return(0);
845: }
848: /*------------------------------------------------------------*/
850: static PetscErrorCode TSSetFromOptions_RK(PetscOptionItems *PetscOptionsObject,TS ts)
851: {
852: TS_RK *rk = (TS_RK*)ts->data;
856: PetscOptionsHead(PetscOptionsObject,"RK ODE solver options");
857: {
858: RKTableauLink link;
859: PetscInt count,choice;
860: PetscBool flg;
861: const char **namelist;
862: for (link=RKTableauList,count=0; link; link=link->next,count++) ;
863: PetscMalloc1(count,(char***)&namelist);
864: for (link=RKTableauList,count=0; link; link=link->next,count++) namelist[count] = link->tab.name;
865: PetscOptionsEList("-ts_rk_type","Family of RK method","TSRKSetType",(const char*const*)namelist,count,rk->tableau->name,&choice,&flg);
866: if (flg) {TSRKSetType(ts,namelist[choice]);}
867: PetscFree(namelist);
868: }
869: PetscOptionsTail();
870: return(0);
871: }
873: static PetscErrorCode PetscFormatRealArray(char buf[],size_t len,const char *fmt,PetscInt n,const PetscReal x[])
874: {
876: PetscInt i;
877: size_t left,count;
878: char *p;
881: for (i=0,p=buf,left=len; i<n; i++) {
882: PetscSNPrintfCount(p,left,fmt,&count,x[i]);
883: if (count >= left) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_OUTOFRANGE,"Insufficient space in buffer");
884: left -= count;
885: p += count;
886: *p++ = ' ';
887: }
888: p[i ? 0 : -1] = 0;
889: return(0);
890: }
892: static PetscErrorCode TSView_RK(TS ts,PetscViewer viewer)
893: {
894: TS_RK *rk = (TS_RK*)ts->data;
895: PetscBool iascii;
899: PetscObjectTypeCompare((PetscObject)viewer,PETSCVIEWERASCII,&iascii);
900: if (iascii) {
901: RKTableau tab = rk->tableau;
902: TSRKType rktype;
903: char buf[512];
904: TSRKGetType(ts,&rktype);
905: PetscViewerASCIIPrintf(viewer," RK type %s\n",rktype);
906: PetscViewerASCIIPrintf(viewer," Order: %D\n",tab->order);
907: PetscViewerASCIIPrintf(viewer," FSAL property: %s\n",tab->FSAL ? "yes" : "no");
908: PetscFormatRealArray(buf,sizeof(buf),"% 8.6f",tab->s,tab->c);
909: PetscViewerASCIIPrintf(viewer," Abscissa c = %s\n",buf);
910: }
911: return(0);
912: }
914: static PetscErrorCode TSLoad_RK(TS ts,PetscViewer viewer)
915: {
917: TSAdapt adapt;
920: TSGetAdapt(ts,&adapt);
921: TSAdaptLoad(adapt,viewer);
922: return(0);
923: }
925: /*@C
926: TSRKSetType - Set the type of RK scheme
928: Logically collective
930: Input Parameter:
931: + ts - timestepping context
932: - rktype - type of RK-scheme
934: Options Database:
935: . -ts_rk_type - <1fe,2a,3,3bs,4,5f,5dp,5bs>
937: Level: intermediate
939: .seealso: TSRKGetType(), TSRK, TSRKType, TSRK1FE, TSRK2A, TSRK3, TSRK3BS, TSRK4, TSRK5F, TSRK5DP, TSRK5BS
940: @*/
941: PetscErrorCode TSRKSetType(TS ts,TSRKType rktype)
942: {
948: PetscTryMethod(ts,"TSRKSetType_C",(TS,TSRKType),(ts,rktype));
949: return(0);
950: }
952: /*@C
953: TSRKGetType - Get the type of RK scheme
955: Logically collective
957: Input Parameter:
958: . ts - timestepping context
960: Output Parameter:
961: . rktype - type of RK-scheme
963: Level: intermediate
965: .seealso: TSRKGetType()
966: @*/
967: PetscErrorCode TSRKGetType(TS ts,TSRKType *rktype)
968: {
973: PetscUseMethod(ts,"TSRKGetType_C",(TS,TSRKType*),(ts,rktype));
974: return(0);
975: }
977: static PetscErrorCode TSRKGetType_RK(TS ts,TSRKType *rktype)
978: {
979: TS_RK *rk = (TS_RK*)ts->data;
982: *rktype = rk->tableau->name;
983: return(0);
984: }
985: static PetscErrorCode TSRKSetType_RK(TS ts,TSRKType rktype)
986: {
987: TS_RK *rk = (TS_RK*)ts->data;
989: PetscBool match;
990: RKTableauLink link;
993: if (rk->tableau) {
994: PetscStrcmp(rk->tableau->name,rktype,&match);
995: if (match) return(0);
996: }
997: for (link = RKTableauList; link; link=link->next) {
998: PetscStrcmp(link->tab.name,rktype,&match);
999: if (match) {
1000: if (ts->setupcalled) {TSRKTableauReset(ts);}
1001: rk->tableau = &link->tab;
1002: if (ts->setupcalled) {TSRKTableauSetUp(ts);}
1003: ts->default_adapt_type = rk->tableau->bembed ? TSADAPTBASIC : TSADAPTNONE;
1004: return(0);
1005: }
1006: }
1007: SETERRQ1(PetscObjectComm((PetscObject)ts),PETSC_ERR_ARG_UNKNOWN_TYPE,"Could not find '%s'",rktype);
1008: return(0);
1009: }
1011: static PetscErrorCode TSGetStages_RK(TS ts,PetscInt *ns,Vec **Y)
1012: {
1013: TS_RK *rk = (TS_RK*)ts->data;
1016: *ns = rk->tableau->s;
1017: if (Y) *Y = rk->Y;
1018: return(0);
1019: }
1021: static PetscErrorCode TSDestroy_RK(TS ts)
1022: {
1026: TSReset_RK(ts);
1027: if (ts->dm) {
1028: DMCoarsenHookRemove(ts->dm,DMCoarsenHook_TSRK,DMRestrictHook_TSRK,ts);
1029: DMSubDomainHookRemove(ts->dm,DMSubDomainHook_TSRK,DMSubDomainRestrictHook_TSRK,ts);
1030: }
1031: PetscFree(ts->data);
1032: PetscObjectComposeFunction((PetscObject)ts,"TSRKGetType_C",NULL);
1033: PetscObjectComposeFunction((PetscObject)ts,"TSRKSetType_C",NULL);
1034: return(0);
1035: }
1037: /* ------------------------------------------------------------ */
1038: /*MC
1039: TSRK - ODE and DAE solver using Runge-Kutta schemes
1041: The user should provide the right hand side of the equation
1042: using TSSetRHSFunction().
1044: Notes:
1045: The default is TSRK3BS, it can be changed with TSRKSetType() or -ts_rk_type
1047: Level: beginner
1049: .seealso: TSCreate(), TS, TSSetType(), TSRKSetType(), TSRKGetType(), TSRKSetFullyImplicit(), TSRK2D, TTSRK2E, TSRK3,
1050: TSRK4, TSRK5, TSRKPRSSP2, TSRKBPR3, TSRKType, TSRKRegister()
1052: M*/
1053: PETSC_EXTERN PetscErrorCode TSCreate_RK(TS ts)
1054: {
1055: TS_RK *rk;
1059: TSRKInitializePackage();
1061: ts->ops->reset = TSReset_RK;
1062: ts->ops->destroy = TSDestroy_RK;
1063: ts->ops->view = TSView_RK;
1064: ts->ops->load = TSLoad_RK;
1065: ts->ops->setup = TSSetUp_RK;
1066: ts->ops->adjointsetup = TSAdjointSetUp_RK;
1067: ts->ops->step = TSStep_RK;
1068: ts->ops->interpolate = TSInterpolate_RK;
1069: ts->ops->evaluatestep = TSEvaluateStep_RK;
1070: ts->ops->rollback = TSRollBack_RK;
1071: ts->ops->setfromoptions = TSSetFromOptions_RK;
1072: ts->ops->getstages = TSGetStages_RK;
1073: ts->ops->adjointstep = TSAdjointStep_RK;
1075: ts->ops->adjointintegral = TSAdjointCostIntegral_RK;
1076: ts->ops->forwardintegral = TSForwardCostIntegral_RK;
1078: PetscNewLog(ts,&rk);
1079: ts->data = (void*)rk;
1081: PetscObjectComposeFunction((PetscObject)ts,"TSRKGetType_C",TSRKGetType_RK);
1082: PetscObjectComposeFunction((PetscObject)ts,"TSRKSetType_C",TSRKSetType_RK);
1084: TSRKSetType(ts,TSRKDefault);
1085: return(0);
1086: }