! D02QFF Example Program Text
! Mark 30.1 Release. NAG Copyright 2024.
Module d02qffe_mod
! D02QFF Example Program Module:
! Parameters and User-defined Routines
! .. Use Statements ..
Use nag_library, Only: nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Accessibility Statements ..
Private
Public :: fcn, g
! .. Parameters ..
Integer, Parameter, Public :: neqf = 2, neqg = 2, nin = 5, &
nout = 6
Integer, Parameter, Public :: latol = neqf
Integer, Parameter, Public :: liwork = 21 + 4*neqg
Integer, Parameter, Public :: lrtol = neqf
Integer, Parameter, Public :: lrwork = 23 + 23*neqf + 14*neqg
Contains
Subroutine fcn(neqf,x,y,f)
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: x
Integer, Intent (In) :: neqf
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: f(neqf)
Real (Kind=nag_wp), Intent (In) :: y(neqf)
! .. Executable Statements ..
f(1) = y(2)
f(2) = -y(1)
Return
End Subroutine fcn
Function g(neqf,x,y,yp,k)
! .. Function Return Value ..
Real (Kind=nag_wp) :: g
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: x
Integer, Intent (In) :: k, neqf
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (In) :: y(neqf), yp(neqf)
! .. Executable Statements ..
If (k==1) Then
g = yp(1)
Else
g = y(1)
End If
Return
End Function g
End Module d02qffe_mod
Program d02qffe
! D02QFF Example Main Program
! .. Use Statements ..
Use d02qffe_mod, Only: fcn, g, latol, liwork, lrtol, lrwork, neqf, neqg, &
nin, nout
Use nag_library, Only: d02qff, d02qwf, d02qxf, d02qyf, nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Local Scalars ..
Real (Kind=nag_wp) :: hlast, hmax, hnext, t, tcrit, tcurr, &
tolfac, tout, tstart
Integer :: badcmp, i, ifail, index, maxstp, &
nfail, nsucc, odlast, odnext, type
Logical :: alterg, crit, onestp, root, sophst, &
vectol
Character (1) :: statef
! .. Local Arrays ..
Real (Kind=nag_wp), Allocatable :: atol(:), resids(:), rtol(:), &
rwork(:), y(:), yp(:)
Integer, Allocatable :: events(:), iwork(:)
! .. Executable Statements ..
Write (nout,*) 'D02QFF Example Program Results'
! Skip heading in data file
Read (nin,*)
Allocate (atol(latol),resids(neqg),rtol(lrtol),rwork(lrwork),y(neqf), &
yp(neqf),events(neqg),iwork(liwork))
Read (nin,*) hmax, tstart, tcrit
Read (nin,*) statef
Read (nin,*) vectol, onestp, crit, sophst
Read (nin,*) maxstp
Read (nin,*) rtol(1:neqf)
Read (nin,*) atol(1:neqf)
! Initialize
ifail = 0
Call d02qwf(statef,neqf,vectol,atol,latol,rtol,lrtol,onestp,crit,tcrit, &
hmax,maxstp,neqg,alterg,sophst,rwork,lrwork,iwork,liwork,ifail)
t = tstart
tout = tcrit
Read (nin,*) y(1:neqf)
! Cycle through roots and print info when encountered.
findr: Do
ifail = -1
Call d02qff(fcn,neqf,t,y,tout,g,neqg,root,rwork,lrwork,iwork,liwork, &
ifail)
If (ifail/=0) Then
Exit findr
End If
ifail = 0
Call d02qxf(neqf,yp,tcurr,hlast,hnext,odlast,odnext,nsucc,nfail, &
tolfac,badcmp,rwork,lrwork,iwork,liwork,ifail)
If (.Not. root) Then
Exit findr
End If
ifail = 0
Call d02qyf(neqg,index,type,events,resids,rwork,lrwork,iwork,liwork, &
ifail)
Write (nout,99999) t
Write (nout,99998) index, type, resids(index)
Write (nout,99997) y(1), yp(1)
Do i = 1, neqg
If (i/=index) Then
If (events(i)/=0) Then
Write (nout,99996) i, events(i), resids(i)
End If
End If
End Do
If (tcurr>=tout) Then
Exit findr
End If
End Do findr
99999 Format (/,1X,'Root at ',1P,E13.5)
99998 Format (1X,'for event equation ',I2,' with type',I3,' and residual ',1P, &
E13.5)
99997 Format (1X,' Y(1) = ',1P,E13.5,' Y''(1) = ',1P,E13.5)
99996 Format (1X,'and also for event equation ',I2,' with type',I3, &
' and residual ',1P,E13.5)
End Program d02qffe