Actual source code: rk.c

  1: #define PETSCTS_DLL

  3: /*
  4:  * Code for Timestepping with Runge Kutta
  5:  *
  6:  * Written by
  7:  * Asbjorn Hoiland Aarrestad
  8:  * asbjorn@aarrestad.com
  9:  * http://asbjorn.aarrestad.com/
 10:  * 
 11:  */
 12:  #include src/ts/tsimpl.h
 13: #include "time.h"

 15: typedef struct {
 16:    Vec          y1,y2;  /* work wectors for the two rk permuations */
 17:    PetscInt     nok,nnok; /* counters for ok and not ok steps */
 18:    PetscReal    maxerror; /* variable to tell the maxerror allowed */
 19:    PetscReal    ferror; /* variable to tell (global maxerror)/(total time) */
 20:    PetscReal    tolerance; /* initial value set for maxerror by user */
 21:    Vec          tmp,tmp_y,*k; /* two temp vectors and the k vectors for rk */
 22:    PetscScalar  a[7][6]; /* rk scalars */
 23:    PetscScalar  b1[7],b2[7]; /* rk scalars */
 24:    PetscReal    c[7]; /* rk scalars */
 25:    PetscInt     p,s; /* variables to tell the size of the runge-kutta solver */
 26: } TS_Rk;

 31: PetscErrorCode PETSCTS_DLLEXPORT TSRKSetTolerance_RK(TS ts,PetscReal aabs)
 32: {
 33:   TS_Rk *rk = (TS_Rk*)ts->data;
 34: 
 36:   rk->tolerance = aabs;
 37:   return(0);
 38: }

 43: /*@
 44:    TSRKSetTolerance - Sets the total error the RK explicit time integrators 
 45:                       will allow over the given time interval.

 47:    Collective on TS

 49:    Input parameters:
 50: +    ts  - the time-step context
 51: -    aabs - the absolute tolerance  

 53:    Level: intermediate

 55: .keywords: RK, tolerance

 57: .seealso: TSPVodeSetTolerance()

 59: @*/
 60: PetscErrorCode PETSCTS_DLLEXPORT TSRKSetTolerance(TS ts,PetscReal aabs)
 61: {
 62:   PetscErrorCode ierr,(*f)(TS,PetscReal);
 63: 
 65:   PetscObjectQueryFunction((PetscObject)ts,"TSRKSetTolerance_C",(void (**)(void))&f);
 66:   if (f) {
 67:     (*f)(ts,aabs);
 68:   }
 69:   return(0);
 70: }


 75: static PetscErrorCode TSSetUp_Rk(TS ts)
 76: {
 77:   TS_Rk          *rk = (TS_Rk*)ts->data;

 81:   rk->nok      = 0;
 82:   rk->nnok     = 0;
 83:   rk->maxerror = rk->tolerance;

 85:   /* fixing maxerror: global vs local */
 86:   rk->ferror = rk->maxerror / (ts->max_time - ts->ptime);

 88:   /* 34.0/45.0 gives double precision division */
 89:   /* defining variables needed for Runge-Kutta computing */
 90:   /* when changing below, please remember to change a, b1, b2 and c above! */
 91:   /* Found in table on page 171: Dormand-Prince 5(4) */

 93:   /* are these right? */
 94:   rk->p=6;
 95:   rk->s=7;

 97:   rk->a[1][0]=1.0/5.0;
 98:   rk->a[2][0]=3.0/40.0;
 99:   rk->a[2][1]=9.0/40.0;
100:   rk->a[3][0]=44.0/45.0;
101:   rk->a[3][1]=-56.0/15.0;
102:   rk->a[3][2]=32.0/9.0;
103:   rk->a[4][0]=19372.0/6561.0;
104:   rk->a[4][1]=-25360.0/2187.0;
105:   rk->a[4][2]=64448.0/6561.0;
106:   rk->a[4][3]=-212.0/729.0;
107:   rk->a[5][0]=9017.0/3168.0;
108:   rk->a[5][1]=-355.0/33.0;
109:   rk->a[5][2]=46732.0/5247.0;
110:   rk->a[5][3]=49.0/176.0;
111:   rk->a[5][4]=-5103.0/18656.0;
112:   rk->a[6][0]=35.0/384.0;
113:   rk->a[6][1]=0.0;
114:   rk->a[6][2]=500.0/1113.0;
115:   rk->a[6][3]=125.0/192.0;
116:   rk->a[6][4]=-2187.0/6784.0;
117:   rk->a[6][5]=11.0/84.0;


120:   rk->c[0]=0.0;
121:   rk->c[1]=1.0/5.0;
122:   rk->c[2]=3.0/10.0;
123:   rk->c[3]=4.0/5.0;
124:   rk->c[4]=8.0/9.0;
125:   rk->c[5]=1.0;
126:   rk->c[6]=1.0;
127: 
128:   rk->b1[0]=35.0/384.0;
129:   rk->b1[1]=0.0;
130:   rk->b1[2]=500.0/1113.0;
131:   rk->b1[3]=125.0/192.0;
132:   rk->b1[4]=-2187.0/6784.0;
133:   rk->b1[5]=11.0/84.0;
134:   rk->b1[6]=0.0;

136:   rk->b2[0]=5179.0/57600.0;
137:   rk->b2[1]=0.0;
138:   rk->b2[2]=7571.0/16695.0;
139:   rk->b2[3]=393.0/640.0;
140:   rk->b2[4]=-92097.0/339200.0;
141:   rk->b2[5]=187.0/2100.0;
142:   rk->b2[6]=1.0/40.0;
143: 
144: 
145:   /* Found in table on page 170: Fehlberg 4(5) */
146:   /*  
147:   rk->p=5;
148:   rk->s=6;

150:   rk->a[1][0]=1.0/4.0;
151:   rk->a[2][0]=3.0/32.0;
152:   rk->a[2][1]=9.0/32.0;
153:   rk->a[3][0]=1932.0/2197.0;
154:   rk->a[3][1]=-7200.0/2197.0;
155:   rk->a[3][2]=7296.0/2197.0;
156:   rk->a[4][0]=439.0/216.0;
157:   rk->a[4][1]=-8.0;
158:   rk->a[4][2]=3680.0/513.0;
159:   rk->a[4][3]=-845.0/4104.0;
160:   rk->a[5][0]=-8.0/27.0;
161:   rk->a[5][1]=2.0;
162:   rk->a[5][2]=-3544.0/2565.0;
163:   rk->a[5][3]=1859.0/4104.0;
164:   rk->a[5][4]=-11.0/40.0;

166:   rk->c[0]=0.0;
167:   rk->c[1]=1.0/4.0;
168:   rk->c[2]=3.0/8.0;
169:   rk->c[3]=12.0/13.0;
170:   rk->c[4]=1.0;
171:   rk->c[5]=1.0/2.0;

173:   rk->b1[0]=25.0/216.0;
174:   rk->b1[1]=0.0;
175:   rk->b1[2]=1408.0/2565.0;
176:   rk->b1[3]=2197.0/4104.0;
177:   rk->b1[4]=-1.0/5.0;
178:   rk->b1[5]=0.0;
179:   
180:   rk->b2[0]=16.0/135.0;
181:   rk->b2[1]=0.0;
182:   rk->b2[2]=6656.0/12825.0;
183:   rk->b2[3]=28561.0/56430.0;
184:   rk->b2[4]=-9.0/50.0;
185:   rk->b2[5]=2.0/55.0;
186:   */
187:   /* Found in table on page 169: Merson 4("5") */
188:   /*
189:   rk->p=4;
190:   rk->s=5;
191:   rk->a[1][0] = 1.0/3.0;
192:   rk->a[2][0] = 1.0/6.0;
193:   rk->a[2][1] = 1.0/6.0;
194:   rk->a[3][0] = 1.0/8.0;
195:   rk->a[3][1] = 0.0;
196:   rk->a[3][2] = 3.0/8.0;
197:   rk->a[4][0] = 1.0/2.0;
198:   rk->a[4][1] = 0.0;
199:   rk->a[4][2] = -3.0/2.0;
200:   rk->a[4][3] = 2.0;

202:   rk->c[0] = 0.0;
203:   rk->c[1] = 1.0/3.0;
204:   rk->c[2] = 1.0/3.0;
205:   rk->c[3] = 0.5;
206:   rk->c[4] = 1.0;

208:   rk->b1[0] = 1.0/2.0;
209:   rk->b1[1] = 0.0;
210:   rk->b1[2] = -3.0/2.0;
211:   rk->b1[3] = 2.0;
212:   rk->b1[4] = 0.0;

214:   rk->b2[0] = 1.0/6.0;
215:   rk->b2[1] = 0.0;
216:   rk->b2[2] = 0.0;
217:   rk->b2[3] = 2.0/3.0;
218:   rk->b2[4] = 1.0/6.0;
219:   */

221:   /* making b2 -> e=b1-b2 */
222:   /*
223:     for(i=0;i<rk->s;i++){
224:      rk->b2[i] = (rk->b1[i]) - (rk->b2[i]);
225:   }
226:   */
227:   rk->b2[0]=71.0/57600.0;
228:   rk->b2[1]=0.0;
229:   rk->b2[2]=-71.0/16695.0;
230:   rk->b2[3]=71.0/1920.0;
231:   rk->b2[4]=-17253.0/339200.0;
232:   rk->b2[5]=22.0/525.0;
233:   rk->b2[6]=-1.0/40.0;

235:   /* initializing vectors */
236:   VecDuplicate(ts->vec_sol,&rk->y1);
237:   VecDuplicate(ts->vec_sol,&rk->y2);
238:   VecDuplicate(rk->y1,&rk->tmp);
239:   VecDuplicate(rk->y1,&rk->tmp_y);
240:   VecDuplicateVecs(rk->y1,rk->s,&rk->k);

242:   return(0);
243: }

245: /*------------------------------------------------------------*/
248: PetscErrorCode TSRkqs(TS ts,PetscReal t,PetscReal h)
249: {
250:   TS_Rk          *rk = (TS_Rk*)ts->data;
252:   PetscInt       j,l;
253:   PetscReal      tmp_t=t;
254:   PetscScalar    null=0.0,hh=h;

257:   /* k[0]=0  */
258:   VecSet(rk->k[0],null);
259: 
260:   /* k[0] = derivs(t,y1) */
261:   TSComputeRHSFunction(ts,t,rk->y1,rk->k[0]);
262:   /* looping over runge-kutta variables */
263:   /* building the k - array of vectors */
264:   for(j = 1 ; j < rk->s ; j++){

266:      /* rk->tmp = 0 */
267:      VecSet(rk->tmp,null);

269:      for(l=0;l<j;l++){
270:         /* tmp += a(j,l)*k[l] */
271:        VecAXPY(rk->tmp,rk->a[j][l],rk->k[l]);
272:      }

274:      /* VecView(rk->tmp,PETSC_VIEWER_STDOUT_WORLD); */
275: 
276:      /* k[j] = derivs(t+c(j)*h,y1+h*tmp,k(j)) */
277:      /* I need the following helpers:
278:         PetscScalar  tmp_t=t+c(j)*h
279:         Vec          tmp_y=h*tmp+y1
280:      */

282:      tmp_t = t + rk->c[j] * h;

284:      /* tmp_y = h * tmp + y1 */
285:      VecWAXPY(rk->tmp_y,hh,rk->tmp,rk->y1);

287:      /* rk->k[j]=0 */
288:      VecSet(rk->k[j],null);
289:      TSComputeRHSFunction(ts,tmp_t,rk->tmp_y,rk->k[j]);
290:   }

292:   /* tmp=0 and tmp_y=0 */
293:   VecSet(rk->tmp,null);
294:   VecSet(rk->tmp_y,null);
295: 
296:   for(j = 0 ; j < rk->s ; j++){
297:      /* tmp=b1[j]*k[j]+tmp  */
298:     VecAXPY(rk->tmp,rk->b1[j],rk->k[j]);
299:      /* tmp_y=b2[j]*k[j]+tmp_y */
300:     VecAXPY(rk->tmp_y,rk->b2[j],rk->k[j]);
301:   }

303:   /* y2 = hh * tmp_y */
304:   VecSet(rk->y2,null);
305:   VecAXPY(rk->y2,hh,rk->tmp_y);
306:   /* y1 = hh*tmp + y1 */
307:   VecAXPY(rk->y1,hh,rk->tmp);
308:   /* Finding difference between y1 and y2 */

310:   return(0);
311: }

315: static PetscErrorCode TSStep_Rk(TS ts,PetscInt *steps,PetscReal *ptime)
316: {
317:   TS_Rk          *rk = (TS_Rk*)ts->data;
319:   PetscReal      dt = 0.001; /* fixed first step guess */
320:   PetscReal      norm=0.0,dt_fac=0.0,fac = 0.0/*,ttmp=0.0*/;

323:   ierr=VecCopy(ts->vec_sol,rk->y1);
324:   *steps = -ts->steps;
325:   /* trying to save the vector */
326:   TSMonitor(ts,ts->steps,ts->ptime,ts->vec_sol);
327:   /* while loop to get from start to stop */
328:   while (ts->ptime < ts->max_time){
329:    /* calling rkqs */
330:      /*
331:        -- input
332:        ts        - pointer to ts
333:        ts->ptime - current time
334:        dt        - try this timestep
335:        y1        - solution for this step

337:        --output
338:        y1        - suggested solution
339:        y2        - check solution (runge - kutta second permutation)
340:      */
341:      TSRkqs(ts,ts->ptime,dt);
342:    /* checking for maxerror */
343:      /* comparing difference to maxerror */
344:      VecNorm(rk->y2,NORM_2,&norm);
345:      /* modifying maxerror to satisfy this timestep */
346:      rk->maxerror = rk->ferror * dt;
347:      /* PetscPrintf(PETSC_COMM_WORLD,"norm err: %f maxerror: %f dt: %f",norm,rk->maxerror,dt); */

349:    /* handling ok and not ok */
350:      if(norm < rk->maxerror){
351:         /* if ok: */
352:         ierr=VecCopy(rk->y1,ts->vec_sol); /* saves the suggested solution to current solution */
353:         ts->ptime += dt; /* storing the new current time */
354:         rk->nok++;
355:         fac=5.0;
356:         /* trying to save the vector */
357:        /* calling monitor */
358:        TSMonitor(ts,ts->steps,ts->ptime,ts->vec_sol);
359:      }else{
360:         /* if not OK */
361:         rk->nnok++;
362:         fac=1.0;
363:         ierr=VecCopy(ts->vec_sol,rk->y1);  /* restores old solution */
364:      }

366:      /*Computing next stepsize. See page 167 in Solving ODE 1
367:       *
368:       * h_new = h * min( facmax , max( facmin , fac * (tol/err)^(1/(p+1)) ) )
369:       * facmax set above
370:       * facmin
371:       */
372:      dt_fac = exp(log((rk->maxerror) / norm) / ((rk->p) + 1) ) * 0.9 ;

374:      if(dt_fac > fac){
375:         /*PetscPrintf(PETSC_COMM_WORLD,"changing fac %f\n",fac);*/
376:         dt_fac = fac;
377:      }

379:      /* computing new dt */
380:      dt = dt * dt_fac;

382:      if(ts->ptime+dt > ts->max_time){
383:         dt = ts->max_time - ts->ptime;
384:      }

386:      if(dt < 1e-14){
387:         PetscPrintf(PETSC_COMM_WORLD,"Very small steps: %f\n",dt);
388:         dt = 1e-14;
389:      }

391:      /* trying to purify h */
392:      /* (did not give any visible result) */
393:      /* ttmp = ts->ptime + dt;
394:         dt = ttmp - ts->ptime; */
395: 
396:      /* counting steps */
397:      ts->steps++;
398:   }
399: 
400:   ierr=VecCopy(rk->y1,ts->vec_sol);
401:   *steps += ts->steps;
402:   *ptime  = ts->ptime;
403:   return(0);
404: }

406: /*------------------------------------------------------------*/
409: static PetscErrorCode TSDestroy_Rk(TS ts)
410: {
411:   TS_Rk          *rk = (TS_Rk*)ts->data;
413:   PetscInt       i;

415:   /* REMEMBER TO DESTROY ALL */
416: 
418:   if (rk->y1) {VecDestroy(rk->y1);}
419:   if (rk->y2) {VecDestroy(rk->y2);}
420:   if (rk->tmp) {VecDestroy(rk->tmp);}
421:   if (rk->tmp_y) {VecDestroy(rk->tmp_y);}
422:   for(i=0;i<rk->s;i++){
423:      if (rk->k[i]) {VecDestroy(rk->k[i]);}
424:   }
425:   PetscFree(rk);
426:   return(0);
427: }
428: /*------------------------------------------------------------*/

432: static PetscErrorCode TSSetFromOptions_Rk(TS ts)
433: {
434:   TS_Rk          *rk = (TS_Rk*)ts->data;

438:   PetscOptionsHead("RK ODE solver options");
439:     PetscOptionsReal("-ts_rk_tol","Tolerance for convergence","TSRKSetTolerance",rk->tolerance,&rk->tolerance,PETSC_NULL);
440:   PetscOptionsTail();
441:   return(0);
442: }

446: static PetscErrorCode TSView_Rk(TS ts,PetscViewer viewer)
447: {
448:    TS_Rk          *rk = (TS_Rk*)ts->data;
450: 
452:    PetscPrintf(PETSC_COMM_WORLD,"  number of ok steps: %D\n",rk->nok);
453:    PetscPrintf(PETSC_COMM_WORLD,"  number of rejected steps: %D\n",rk->nnok);
454:    return(0);
455: }

457: /* ------------------------------------------------------------ */
458: /*MC
459:       TS_RK - ODE solver using the explicit Runge-Kutta methods

461:    Options Database:
462: .  -ts_rk_tol <tol> Tolerance for convergence

464:   Contributed by: Asbjorn Hoiland Aarrestad, asbjorn@aarrestad.com, http://asbjorn.aarrestad.com/

466:   Level: beginner

468: .seealso:  TSCreate(), TS, TSSetType(), TS_EULER, TSRKSetTolerance()

470: M*/

475: PetscErrorCode PETSCTS_DLLEXPORT TSCreate_Rk(TS ts)
476: {
477:   TS_Rk          *rk;

481:   ts->ops->setup           = TSSetUp_Rk;
482:   ts->ops->step            = TSStep_Rk;
483:   ts->ops->destroy         = TSDestroy_Rk;
484:   ts->ops->setfromoptions  = TSSetFromOptions_Rk;
485:   ts->ops->view            = TSView_Rk;

487:   PetscNew(TS_Rk,&rk);
488:   PetscLogObjectMemory(ts,sizeof(TS_Rk));
489:   ts->data = (void*)rk;

491:   PetscObjectComposeFunctionDynamic((PetscObject)ts,"TSRKSetTolerance_C","TSRKSetTolerance_RK",TSRKSetTolerance_RK);

493:   return(0);
494: }