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     ! Dummy Arguments:
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     ! Local Variables:
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