!   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