File: /nfs/home/0/users/jenkins/mfix.git/model/dqmom/rkqs.f
1 SUBROUTINE rkqs(y, dydx, n, x, htry, eps, yscal, hdid, hnext)
2
3 IMPLICIT NONE
4
5
6
7 INTEGER, INTENT(in) :: N
8
9 DOUBLE PRECISION :: y(N), dydx(N), yscal(N)
10 DOUBLE PRECISION x, hTry, EPs, hDid, hNext
11
12
13
14 INTEGER i
15
16 DOUBLE PRECISION :: errmax, h, htemp, xnew
17 DOUBLE PRECISION :: yerr(N), ytemp(N)
18
19 DOUBLE PRECISION, parameter :: SAFETY = 0.9
20 DOUBLE PRECISION, parameter :: PGROW = -0.2
21 DOUBLE PRECISION, parameter :: PSHRNK = -0.25
22 DOUBLE PRECISION, parameter :: ERRCON = 1.89e-4
23
24 h=htry
25
26 do
27 call rkck(y,dydx,n,x,h,ytemp,yerr)
28 errmax=0.
29 do i=1,n
30 errmax=max(errmax,abs(yerr(i)/yscal(i)))
31 end do
32 errmax=errmax/eps
33 if(errmax<=1.0) exit
34 htemp=SAFETY*h*(errmax**PSHRNK)
35 h=sign(max(abs(htemp),0.1*abs(h)),h)
36 xnew=x+h
37 if(xnew==x) write(*,*) 'WARNING: stepsize underflow in rkqs'
38 enddo
39
40 HNEXT = merge(SAFETY*h*(errmax**PGROW), 5.0*h, errmax>ERRCON)
41
42 hdid=h
43 x=x+h
44 y(:)=ytemp(:)
45
46 RETURN
47 END SUBROUTINE rkqs
48