End of file
Contents
Index

F 17 Initial Value Problems for Ordinary Differential Equations

F 17.3 One-Step Methods


      SUBROUTINE DEQSSP (X,Y,FCT,XEND,H,HMAX,ABSERR,RELERR,IND,
     1                   IERR,AUXF)
C
C*****************************************************************
C                                                                *
C  Numerical solution of an ordinary differential equation       *
C                                                                *
C     Y' = F(X,Y) with given initial value  Y(X0) = Y0           *
C                                                                *
C  by a user specified one-step method.                          *
C  Any one of the following methods may be chosen:               *
C  1) EULER-CAUCHY polygonal method,                             *
C  2) method of HEUN, and                                        *
C  3) classical RUNGE-KUTTA method.                              *
C                                                                *
C  INPUT PARAMETERS:                                             *
C  =================                                             *
C                                                                *
C  X     : starting value for X.                                 *
C  Y     : initial value of the solution Y at X.                 *
C  FCT   : SUBROUTINE that evaluates the right hand side of the  *
C          differential equation. It has to be formatted as      *
C          follows:                                               *
C                                                                *
C             SUBROUTINE FCT(X,Y,F)                              *
C             DOUBLE PRECISION X,Y,F                             *
C                  .                                             *
C                  .                                             *
C                  .                                             *
C                                                                *
C          In the calling program it must be declared as         *
C          EXTERNAL. Its variables have the following meaning:   *
C             X   independent variable X.                        *
C             Y   dependent variable Y.                          *
C             F   function value of the right hand side F(X,Y)   *
C                 of the differential equation Y'=F(X,Y).        *
C  XEND  : value for X where the solution is desired; it may be  *
C          to the left of the starting value for X.              *
C  H     : step size for the next step. It is usually determined *
C          by the program.                                       *
C  HMAX  : maximum step size allowed, HMAX must be positive.     *
C  ABSERR: )                                                     *
C  RELERR: ) error parameters, which must be >= 0. The subroutine*
C            performs a mixed test:                              *
C              ABS (LOCAL ERROR) .LE. ABS(Y)*RELERR + ABSERR.    *
C           Thus, if RELERR is chosen as zero, this tests for the*
C           absolute error. If ABSERR is chosen as zero, this    *
C           tests for the relative error.                        *
C           RELERR and ABSERR should be chosen at least ten times*
C           larger than the machine constant. If this is not     *
C           the case the program defaults to these settings.     *
C  IND   : INTEGER vector IND(1:3).                              *
C          IND(1) indicates whether DEQSSP has already been      *
C          called:                                               *
C          = 0: DEQSSP was not been called during this program   *
C               run.                                             *
C          = 1: DEQSSP has been called during this run.          *
C          IND(2) indicates the method used:                     *
C          = 1: EULER-CAUCHY poygonal method.                    *
C          = 2: method of HEUN.                                  *
C          = 3: classical RUNGE-KUTTA method.                    *
C          IND(3) indicates whether integration is acceptable    *
C          beyond XEND (this can be used e.g. for discontinuities*
C          of the right hand side F of the differential equation)*
C          = 0: no restrictions.                                 *
C          = 1: the differential equation may only be integrated *
C               up to XEND.                                      *
C  AUXF : REAL auxiliary vector AUXF(0:4,3)                      *
C                                                                *
C  OUTPUT PARAMETERS:                                            *
C  ==================                                            *
C                                                                *
C  X     : X value for which solution is desired (should equal   *
C          input XEND)                                           *
C  Y     : value for the solution at X.                          *
C  H     : terminal step size used. It should remain unchanged   *
C          for the next call.                                    *
C  IND(1): after the first call set to 2, it should not be       *
C          changed.                                              *
C  IERR  : error parameter:                                      *
C          = 0: everything o.k. After re-setting of XEND, DEQSSP *
C               can be called again.                             *
C          = 1: everything o.k. After re-setting of XEND, DEQSSP *
C               can be called again. The solution has already    *
C               been determined up to the x value AUXF(IPTR,1)   *
C               with AUXF(IPTR,2) as its y value. For XEND .LT.  *
C               AUXF(IPTR,1) further solution values will be     *
C               determined by interpolation.                     *
C          = 2: after 500 function evaluations the procedure did *
C               not reach XEND. A repeated call without any      *
C               change of the parameters may be successful.      *
C               (otherwise, try to increase the error parameters)*
C          = 3: the step size is less than eight times the       *
C               machine constant at an x value. To continue with *
C               another call, H and the error parameters must be *
C               increased.                                       *
C          = 4: ABSERR or RELERR is negative or both             *
C               ABSERR = 0.0 and RELERR = 0.0.                   *
C          = 5: XEND is equal to X.                              *
C          = 6: HMAX is negative.                                *
C          = 7: number for method is erroneous.                  *
C          = 8: IND(3) is erroneous.                             *
C                                                                *
C  NOTES:                                                        *
C  ======                                                        *
C                                                                *
C  1) The program uses step size control by doubling or halving  *
C     the step size. Thus, it independently finds the step sizes *
C     for which the required error bounds can be maintained.     *
C  2) If the distance remaining towards XEND is smaller than     *
C     the current, automatically determined step size, the       *
C     solution at XEND is determined by interpolation.           *
C     The interpolation is effected by use of a circular buffer. *
C     This buffer has to contain a sufficient number of entries  *
C     before it can be used to interpolate with a sufficiently   *
C     high order. Thus it may happen that the solution is        *
C     determined much farther than to XEND in the first call.    *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: MACHPD                                  *
C                                                                *
C*****************************************************************
C                                                                *
C  author   : Jobst Hoffmann                                     *
C  date     : 04.21.1990                                         *
C  source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER IND(3),IBUF(3),ICTFV(3),ICTV(3)
C
      DIMENSION ERRHAT(3),AUXF(0:4,3),ERREST(3)
C
      LOGICAL ERRV,FULL
C
      SAVE IPTR,FULL,LEN,FMACHP
C
      DATA IBEG/1/ METH/2/ IEND/3/
      DATA ICTMAX/500/ IBUF/2,3,5/ ICTFV/1,3,7/ ICTV/2,5,11/
      DATA ERRHAT/0.2D0,0.1D0,0.02D0/ ERREST/1.0D0,3.0D0,15.0D0/
C
      IF ( IND(IBEG) .EQ. 1 ) GOTO 10
C
C     determine the machine constant
C.
      FMACHP = 1.0D0
    5 FMACHP = 0.5D0 * FMACHP
      IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 5
      FMACHP = FMACHP * 2.0D0
C
      IERR = 0
      IND(IBEG) = 1
C.
C     determine the length of the circular buffer needed for the
C     interpolation and initialize pointer to the first element
C     of this buffer
C.
      LEN = IBUF(IND(METH))
      IPTR = 0
      FULL = .FALSE.
   10 IF ( IERR .EQ. 1 ) THEN
C.
C        the solution is known up to the point (X,Y) =
C        (AUXF(IPTR,1), AUXF(IPTR,2)). Further output
C        values may be produced by interpolation.
C.
         X0 = X
         Y0 = Y
         X1 = AUXF(IPTR,1)
         Y1 = AUXF(IPTR,2)
         GOTO 170
      ELSEIF ( IERR .EQ. 2 ) THEN
C.
C        repeat call after excessive number of function calls
C.
         ICOUNT = 0
         GOTO 120
      ENDIF
C.
C     Input data error check, initialize variables
C.
      IF ( ABSERR .LE. 0.0D0 .AND. RELERR .LE. 0.0D0 ) THEN
         IERR = 4
         RETURN
      ELSEIF ( XEND .EQ. X ) THEN
         IERR = 5
         RETURN
      ELSEIF ( HMAX .LE. 0.0D0 ) THEN
         IERR = 6
         RETURN
      ELSEIF ( IND(METH) .LT. 1 .OR. IND(METH) .GT. 3 ) THEN
         IERR = 7
         RETURN
      ELSEIF ( IND(IEND) .LT. 0 .OR. IND(IEND) .GT. 1 ) THEN
         IERR = 8
         RETURN
      ENDIF
      ICOUNT = 0
C.
C     start computation, store the starting values in AUXF
C.
      HLOC = H
      X0 = X
      Y0 = Y
      AUXF(IPTR,1) = X
      AUXF(IPTR,2) = Y
C.
C     determine step size
C.
      IF ( DABS(H) .GT. HMAX ) H = HMAX
      IF ( IND(IEND) .EQ. 0 ) THEN
         H = DSIGN(H,XEND - X)
      ELSE
         H = DSIGN(DMIN1(DABS(H),DABS(XEND-X)*0.5D0),XEND-X)
      ENDIF
      IF ( DABS(H) .LE. 8.0D0*FMACHP*DABS(X) ) THEN
         H = HLOC
         IERR = 3
         RETURN
      ENDIF
C.
C     switch between the three allowed methods
C.
      GOTO (20,50,80) IND(METH)
C.
C     *** EULER-CAUCHY  polygonal method ***
C.
   20 CONTINUE
   30 CALL FCT (X0,Y0,F0)
      XH = X0 + H
      X1 = XH + H
      Y2 = Y0 + 2.0D0*H*F0
   40 YH = Y0 + H*F0
      CALL FCT (XH,YH,F1)
      Y1 = YH + H*F1
      GOTO 110
C.
C     *** method of HEUN ***
C.
   50 CONTINUE
   60 CALL FCT (X0,Y0,F0)
      XH = X0 + H
      X1 = XH + H
      Y2 = Y0 + 2.0D0*H*F0
      CALL FCT (X1,Y2,F2)
      Y2 = Y0 + H*(F0+F2)
   70 YH = Y0 + H*F0
      CALL FCT (XH,YH,FH)
      YH = Y0 + 0.5D0*H*(F0+FH)
      CALL FCT (XH,YH,FH)
      Y1 = YH + H*FH
      CALL FCT (X1,Y1,F1)
      Y1 = YH + 0.5D0*H*(FH+F1)
      GOTO 110
C.
C     *** classical RUNGE-KUTTA method ***
C.
   80 CONTINUE
   90 CALL FCT (X0,Y0,F0)
      XH = X0 + H
      X1 = XH + H
      RK12 = 2.0D0*H*F0
      CALL FCT (XH,Y0+0.5D0*RK12,F2)
      RK22 = 2.0D0*H*F2
      CALL FCT (XH,Y0+0.5D0*RK22,F2)
      RK32 = 2.0D0*H*F2
      CALL FCT (X1,Y0+RK32,F2)
      RK42 = 2.0D0*H*F2
      Y2 = Y0 + (RK12 + 2.0D0*(RK22 + RK32) + RK42)/6.0D0
  100 RK11 = H*F0
      CALL FCT (X0+0.5D0*H,Y0+0.5D0*RK11,FH)
      RK21 = H*FH
      CALL FCT (X0+0.5D0*H,Y0+0.5D0*RK21,FH)
      RK31 = H*FH
      CALL FCT (XH,Y0+RK31,FH)
      RK41 = H*FH
      YH = Y0 + (RK11 + 2.0D0*(RK21 + RK31) + RK41)/6.0D0
      CALL FCT (XH,YH,F1)
      RK11 = H*F1
      CALL FCT (XH+0.5D0*H,YH+0.5D0*RK11,F1)
      RK21 = H*F1
      CALL FCT (XH+0.5D0*H,YH+0.5D0*RK21,F1)
      RK31 = H*F1
      CALL FCT (X1,YH+RK31,F1)
      RK41 = H*F1
      Y1 = YH + (RK11 + 2.0D0*(RK21 + RK31) + RK41)/6.0D0
C.
C     count the number of function evaluations
C.
  110 ICOUNT = ICOUNT + ICTV(IND(METH))
      IF ( ERRV ) THEN
         ERRV = .FALSE.
         ICOUNT = ICOUNT + ICTFV(IND(METH))
      ENDIF
      IF ( ICOUNT .GT. ICTMAX ) THEN
         IERR = 2
         X = AUXF(IPTR,1)
         Y = AUXF(IPTR,2)
         RETURN
      ENDIF
C.
C     error estimate
C.
  120 D = DABS(Y1 - Y2)/ERREST(IND(METH))
      IF ( D .GT. ABSERR + DABS(Y1)*RELERR ) THEN
         ERRV = .TRUE.
C.
C        computation was unsuccessful, recompute with
C        half the step size
C.
         H = 0.5D0*H
         IF ( DABS(H) .LE. 8.0D0*FMACHP*DABS(X) ) THEN
            IERR = 3
            X = AUXF(IPTR,1)
            Y = AUXF(IPTR,2)
            RETURN
         ENDIF
         X1 = XH
         XH = X0 + H
         Y2 = YH
         GOTO (40,70,100) IND(METH)
      ELSE
C.
C        computation was successful, compute an improved
C        estimate ...
C.
         GOTO (130,140,150) IND(METH)
C.
C        ... for EULER-CAUCHY ...
C.
  130    Y1 = 2.0D0*Y1 - Y2
         GOTO 160
C.
C        ... for HEUN ...
C.
  140    Y1 = ( 4.0D0*Y1 - Y2 )/3.0D0
         GOTO 160
C.
C        ... for RUNGE-KUTTA ...
C.
  150    Y1 = (16.0D0*Y1 - Y2)/15.0D0
C.
C        ... and the new values are stored in the buffer AUXF
C.
  160    IF ( IPTR + 2 .EQ. LEN ) FULL = .TRUE.
         IPTR = MOD(IPTR+1,LEN)
         AUXF(IPTR,1) = X1
         AUXF(IPTR,2) = Y1
      ENDIF
C.
C     if the solution varies only slightly, the next step may be
C     executed with double the previous step size, provided this
C     does not exceed the maximal allowable step size
C.
      IF ( D .LT. ERRHAT(IND(METH))*(ABSERR + DABS(Y1)*RELERR) )
     F                      H = DSIGN(DMIN1(DABS(2.0D0*H),HMAX),H)
C.
C     if XEND was not been reached, another step will be
C     executed. Otherwise ...
C.
  170 IF ( (X1 - XEND)*DSIGN(1.0D0,H) ) 180,190,200
  180 IF ( IND(IEND) .EQ. 1 ) THEN
         HLOC = H
         H = DSIGN(DMIN1(DABS(H),DABS(XEND-X1)*0.5D0),XEND-X1)
      ENDIF
      X0 = X1
      Y0 = Y1
      GOTO (30,60,90) IND(METH)
C.
C     ... return to calling program ...
C.
  190 X = X1
      Y = Y1
      IERR = 0
      RETURN
C.
C     ... or the desired solution is obtained by interpolation
C     in case that the steps went beyond XEND.
C     If there are not sufficiently many values in the buffer
C     we perform another step.
C.
  200 IF ( .NOT. FULL ) THEN
         X0 = X1
         Y0 = Y1
         GOTO (30,60,90) IND(METH)
      ENDIF
      DO 210 I=0,LEN-1
         AUXF(I,3) = AUXF(I,2)
  210 CONTINUE
      DO 230 I=1,LEN-1
         DO 220 K=LEN-1,I,-1
            XDIF = AUXF(K,1) - AUXF(K-I,1)
            AUXF(K,3) = (AUXF(K,3) - AUXF(K-1,3))/XDIF
  220    CONTINUE
  230 CONTINUE
      Y = AUXF(LEN-1,3)
      DO 240 I=LEN-2,0,-1
         Y = Y*(XEND - AUXF(I,1)) + AUXF(I,3)
  240 CONTINUE
      X = XEND
      IERR = 1
      RETURN
C
      END


Begin of file
Contents
Index