End of file
Contents
Index
SUBROUTINE FRKFSY(A,DA,N,Y,DES,H,HMX,ABSERR,RELERR,IERR)
C
C*****************************************************************
C *
C A system of ordinary differential equations of 1st order is *
C integrated by applying the RUNGE-KUTTA-FEHLBERG method *
C [ of order O(H**5) ] with estimates for the local error and *
C step size control. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C A : starting value for the integration interval *
C DA : length of the integration interval; *
C DA may be < 0.0 if we want to integrate to the left. *
C N : number of equations; N < 11. *
C Y : vector Y(1:N); the initial values at A *
C DES : SUBROUTINE, that describes the system of differential*
C equations, given in the following form: *
C SUBROUTINE DES(X,Y,YS) *
C X : independent variable *
C Y : vector of dependent variables *
C YS: vector YS(I)=DY(I)/DX of derivatives *
C at X, I=1,...,N *
C Y and YS are dimensioned as DOUBLE *
C PRECISION Y(1), YS(1), however, they may *
C be to be used as a vector of length N. *
C example : SUBROUTINE DES(X,Y,YS) *
C DOUBLE PRECISION Y(1),YS(1) *
C YS(1)=Y(1) *
C YS(2)=-Y(2) *
C RETURN *
C END *
C H : initial step size; if H is provided unrealistically, *
C H is modified internally; H may be negative if *
C DA < 0.0. *
C HMX : upper bound for the step size magnitude used during *
C calculation. HMX > 0.0 *
C ABSERR :] bounds for the acceptable local error, relative to *
C RELERR :] the current step size. If the following holds for *
C :] each component of the computed solution Y(I) *
C ABS ( estimate of the local error) .LE. *
C ABS(H)*(RELERR*ABS(Y(I))+ABSERR), *
C then the solution is accepted in the current step. *
C If ABSERR = 0.0, we test for the relative error; *
C If RELERR = 0.0, we test for the absolute error. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C A : last x value for which a solution was successfully *
C determined. Normally the following will hold: *
C A on output = A on input + DA. *
C Y : computed solution vector at A on output *
C H : optimal step size, which was used for the last step. *
C IERR : = 1, everything o.k.; solution found at A + DA. *
C = 2, after 3000 calls of SUBROUTINE DES we stop with-*
C out having reached the endpoint A+DA. If com- *
C putations are to be continued, call FRKFSY again*
C with unchanged parameters. *
C = 3, false input data; i.e. *
C ABSERR.LT.0.0 or RELERR.LT.0.0 or *
C ABSERR + RELERR = 0.0 or HMX.LE.0.0: Return. *
C = 4, the optimal step size cannot be achieved for the*
C computer. RETURN *
C *
C----------------------------------------------------------------*
C *
C subroutines required : MACHPD *
C *
C *
C sources : SHAMPINE/ALLEN, see [SHAM73]. *
C *
C*****************************************************************
C *
C author : Richard Reuter *
C date : 02.09.1983 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DOUBLE PRECISION YT(10),T(10),R(10),K1(10),K2(10)
DOUBLE PRECISION K3(10),K4(10),K5(10),K6(10)
DOUBLE PRECISION Y(N)
C
C determine machine constant
C
FMACHP = 1.0D0
2 FMACHP = 0.5D0 * FMACHP
IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 2
FMACHP = FMACHP * 2.0D0
C
C check the input data
C
IERR=3
IF(RELERR .LT. 0.0D0 .OR. ABSERR .LT. 0.0D0 .OR.
1 RELERR+ABSERR .EQ. 0.0D0 .OR. HMX .LE. 0.0D0) RETURN
C
IERR=4
B=A+DA
IF(DABS(DA) .LE. 13.0D0*FMACHP*DMAX1(DABS(A),DABS(B))) RETURN
C
HMAX=DMIN1(HMX,DABS(DA))
IF(DABS(H) .LE. 13.0D0*FMACHP*DABS(A)) H=HMAX
C
C Initialize counter for calls of SUBROUTINE DES
C
LFD=0
IAD=0
C
C H is bounded by HMAX and is chosen so that the
C endpoint B is reached, if possible.
C
3 H=DSIGN(DMIN1(DABS(H),HMAX),DA)
IF(DABS(B-A) .LE. 1.25D0*DABS(H)) THEN
HF=H
C
C if IAD=1 and H=B-A acceptable, we stop after
C the next integration step.
C
IAD=1
H=B-A
END IF
C
C an integration step is executed
C
CALL DES(A,Y,K1)
LFD=LFD+1
5 CONTINUE
X=0.25D0*H
DO 6 I=1,N
YT(I)=Y(I)+X*K1(I)
6 CONTINUE
X=A+X
CALL DES(X,YT,K2)
DO 7 I=1,N
YT(I)=Y(I)+H*(K1(I)*(3.0D0/32.0D0)+K2(I)*(9.0D0/32.0D0))
7 CONTINUE
X=A+H*(3.0D0/8.0D0)
CALL DES(X,YT,K3)
DO 8 I=1,N
YT(I)=Y(I)+H*(K1(I)*(1932.0D0/2197.0D0)
1 -K2(I)*(7200.0D0/2197.0D0)
1 +K3(I)*(7296.0D0/2197.0D0))
8 CONTINUE
X=A+H*(12.0D0/13.0D0)
CALL DES(X,YT,K4)
DO 9 I=1,N
YT(I)=Y(I)+H*(K1(I)*(439.0D0/216.0D0)-8.0D0*K2(I)
1 +K3(I)*(3680.0D0/513.0D0)
1 -K4(I)*(845.0D0/4104.0D0))
9 CONTINUE
X=A+H
CALL DES(X,YT,K5)
DO 10 I=1,N
YT(I)=Y(I)+H*(-K1(I)*(8.0D0/27.0D0)+2.0D0*K2(I)
1 -K3(I)*(3544.0D0/2565.0D0)
1 +K4(I)*(1859.0D0/4104.0D0)
1 -K5(I)*(11.0D0/40.0D0))
10 CONTINUE
X=A+0.5D0*H
CALL DES(X,YT,K6)
DO 11 I=1,N
T(I)=K1(I)*(25.0D0/216.0D0)+K3(I)*(1408.0D0/2565.0D0)
1 +K4(I)*(2197.0D0/4104.0D0)-K5(I)*0.20D0
YT(I)=Y(I)+H*T(I)
11 CONTINUE
C
C YT(I) now represents the latest result of this pass.
C Determine R(I), the estimate of the local
C error, relative to the current step size.
C
DO 12 I=1,N
R(I)=K1(I)/360.0D0-K3(I)*(128.0D0/4275.0D0)
1 -K4(I)*(2197.0D0/75240.0D0)+K5(I)/50.0D0
1 +K6(I)*(2.0D0/55.0D0)
12 CONTINUE
C
C Check accuracy
C
QUOT=0.0D0
DO 13 I=1,N
TR=DABS(R(I))/(RELERR*DABS(YT(I))+ABSERR)
QUOT=DMAX1(QUOT,TR)
13 CONTINUE
C
C If QOUOT.LE.1.0 ==> integration step is accepted
C
IF(QUOT .LE. 1.0D0) THEN
C
C result is accepted
C
DO 14 I=1,N
Y(I)=YT(I)
14 CONTINUE
A=A+H
C
C if A=B , RETURN
C
IF(IAD .EQ. 1) THEN
IERR=1
H=HF
RETURN
END IF
C
C prepare next step
C
QUOT=DMAX1(QUOT,6.5536D-4)
END IF
QUOT=DMIN1(QUOT,4096.0D0)
H=0.8D0*H/DSQRT(DSQRT(QUOT))
C
C We just achieved that H was increased by at most a factor of 5,
C or alternatively, that it was decreased by a factor of 10
C at most
C
IF(DABS(H) .LE. 13.0D0*FMACHP*DABS(A)) THEN
IERR=4
RETURN
END IF
LFD=LFD+5
IF(LFD .GE. 2995) THEN
IERR=2
RETURN
END IF
IF(QUOT .LE. 1.0D0) THEN
C
C the step was successful. Continue with another step.
C
GOTO 3
ELSE
C
C the step is repeated for a smaller H.
C
IAD=0
GOTO 5
END IF
END
Begin of file
Contents
Index