!   Mark 24 Release. NAG Copyright 2012.
    Module d01rafe_mod

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter                   :: nout = 6
      Logical, Parameter                   :: disp_split_info = .True.
    Contains
      Subroutine d01rbf_monit(ni,ns,defint,errest,fcount,sinfoi,evals,ldi, &
        sinfor,fs,es,ldr,iuser,ruser)

!       .. Scalar Arguments ..
        Integer, Intent (In)                 :: ldi, ldr, ni, ns
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout)   :: defint(ni), errest(ni), ruser(*)
        Real (Kind=nag_wp), Intent (In)      :: es(ldr,*), fs(ldr,*),          &
                                                sinfor(ldr,*)
        Integer, Intent (In)                 :: evals(ldi,*), fcount(ni),      &
                                                sinfoi(ldi,*)
        Integer, Intent (Inout)              :: iuser(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)                   :: lbnd, ubnd
        Integer                              :: child1, child2, j, k, level,   &
                                                parent, sid
!       .. Executable Statements ..
        Continue
!       Display information on individual segments.
        If (.Not. disp_split_info) Then
          Go To 100
        End If
        Write (nout,*)
        Write (nout,99993)
        Do k = 1, ns
          Write (nout,*)
          sid = sinfoi(1,k)
          parent = sinfoi(2,k)
          child1 = sinfoi(3,k)
          child2 = sinfoi(4,k)
          level = sinfoi(5,k)
          lbnd = sinfor(1,k)
          ubnd = sinfor(2,k)
          Write (nout,99999) k, sid, parent, level
          If (child1>0) Then
            Write (nout,99998) child1, child2
          End If
          Write (nout,99997) lbnd, ubnd
          Do j = 1, ni
            If (evals(j,k)/=0) Then
              Write (nout,99996) j, fs(j,k)
              Write (nout,99995) j, es(j,k)
              If (evals(j,k)/=1) Then
                Write (nout,99994) j
              End If
            End If
          End Do
        End Do
100     Continue
        Return
99999   Format (' Segment ',I3,', SID = ',I3,', Parent = ',I3,', Level = ',I3, &
          '.')
99998   Format (' Children = (',I3,',',I3,')')
99997   Format (' Bounds (',Es11.4,',',Es11.4,')')
99996   Format (' Integral ',I2,' approximation:',1X,Es11.4,'.')
99995   Format (' Integral ',I2,' error estimate:',1X,Es11.4,'.')
99994   Format (' Integral ',I2, &
          ' evaluation has been superseded by descendants.')
99993   Format (' Information on splitting and evaluations over subregions. ')

      End Subroutine d01rbf_monit
      Subroutine display_option(optstr,optype,ivalue,rvalue,cvalue)
!       Subroutine to query optype and print the appropriate option values

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In)      :: rvalue
        Integer, Intent (In)                 :: ivalue, optype
        Character (*), Intent (In)           :: cvalue, optstr
!       .. Executable Statements ..
        Select Case (optype)
        Case (1)
          Write (nout,99999) optstr, ivalue
        Case (2)
          Write (nout,99998) optstr, rvalue
        Case (3)
          Write (nout,99997) optstr, cvalue
        Case (4)
          Write (nout,99996) optstr, ivalue, cvalue
        Case (5)
          Write (nout,99995) optstr, rvalue, cvalue
        Case Default
        End Select

        Flush (nout)

        Return
99999   Format (3X,A30,' : ',I13)
99998   Format (3X,A30,' : ',Es13.4)
99997   Format (3X,A30,' : ',8X,A16)
99996   Format (3X,A30,' : ',I13,3X,A16)
99995   Format (3X,A30,' : ',Es13.4,3X,A16)
      End Subroutine display_option
    End Module d01rafe_mod

    Program d01rafe

!     .. Use Statements ..
      Use nag_library, Only: d01raf, d01rbf, d01rcf, d01zkf, d01zlf, x01aaf
      Use d01rafe_mod, Only: d01rbf_monit, display_option, nag_wp, nout
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=nag_wp)                   :: a, b, pi, rvalue
      Integer                              :: ifail, irevcm, ivalue, j, lcmax, &
                                              lcmin, lcomm, lcusd, ldfm,       &
                                              ldfmrq, lenx, lenxrq, licmax,    &
                                              licmin, licomm, licusd, ni, nx,  &
                                              optype, sdfm, sdfmrq, sid
      Character (16)                       :: cvalue
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable      :: comm(:), defint(:), errest(:),   &
                                              fm(:,:), opts(:), ruser(:), x(:)
      Integer, Allocatable                 :: icomm(:), iopts(:), iuser(:),    &
                                              needi(:)
!     .. Intrinsic Procedures ..
      Intrinsic                            :: cos, sin
!     .. Executable Statements ..
      Continue
      Write (nout,*) 'D01RAF Example Program Results'
      Write (nout,*)

      pi = x01aaf(pi)

!     Setup phase.

!     set problem parameters
      ni = 2
!     lower (a) and upper (b) bounds
      a = 0.0E0_nag_wp
      b = pi
      Allocate (opts(100),iopts(100),iuser(1),ruser(1))

!     initialize option arrays
      ifail = 0
      Call d01zkf('Initialize = d01raf',iopts,100,opts,100,ifail)
!     set any non-default options required
      Call d01zkf('Quadrature Rule = gk41',iopts,100,opts,100,ifail)
      Call d01zkf('Absolute Tolerance = 1.0e-7',iopts,100,opts,100,ifail)
      Call d01zkf('Relative Tolerance = 1.0e-7',iopts,100,opts,100,ifail)

!     determine maximum requried array lengths
      ifail = -1
      Call d01rcf(ni,lenxrq,ldfmrq,sdfmrq,licmin,licmax,lcmin,lcmax,iopts, &
        opts,ifail)
      ldfm = ldfmrq
      sdfm = sdfmrq
      lenx = lenxrq
      licomm = licmax
      lcomm = lcmax

!     Allocate remaining arrays
      Allocate (icomm(licomm),needi(ni),comm(lcomm),fm(ldfm,sdfm),defint(ni), &
        errest(ni),x(lenx))


!       Solve phase.
!       Use D01RAF to evaluate the definate integrals of:
!       f_1 = (x*sin(2*x))*cos(15*x)
!       f_2 = (x*sin(2*x))*(x*cos(50*x))

!     set initial irevcm
      irevcm = 1
      ifail = -1

      Do While (irevcm/=0)

        Call d01raf(irevcm,ni,a,b,sid,needi,x,lenx,nx,fm,ldfm,defint,errest, &
          iopts,opts,icomm,licomm,comm,lcomm,ifail)

        Select Case (irevcm)
        Case (11)
!             Initial returns.
!             These will occur during the non-adaptive phase.
!             All values must be supplied.
!             DEFINT and ERREST do not contain approximations
!              over the complete interval at this stage.

!         Calculate x*sin(2*x), storing the result in fm(2,1:nx) for re-use.
          fm(2,1:nx) = x(1:nx)*sin(2.0E0_nag_wp*x(1:nx))

!         Calculate f1
          fm(1,1:nx) = fm(2,1:nx)*cos(15.0E0_nag_wp*x(1:nx))

!         Complete f2 calculation.
          fm(2,1:nx) = fm(2,1:nx)*x(1:nx)*cos(50.0E0_nag_wp*x(1:nx))

        Case (12)
!             Intermediate returns.
!             These will occur during the adaptive phase.
!             All requested values must be supplied.
!             DEFINT and ERREST do not contain approximations
!              over the complete interval at this stage.
!               
!             Calculate x*sin(2*x).
          fm(2,1:nx) = x(1:nx)*sin(2.0E0_nag_wp*x(1:nx))

!         Calculate f1 if required.
          If (needi(1)==1) Then
            fm(1,1:nx) = fm(2,1:nx)*cos(15.0E0_nag_wp*x(1:nx))
          End If

!         Complete f2 calculation if required.
          If (needi(2)==1) Then
            fm(2,1:nx) = fm(2,1:nx)*x(1:nx)*cos(50.0E0_nag_wp*x(1:nx))
          End If
        Case (0)
!         Final return. Test IFAIL.
          Select Case (ifail)
          Case (0:3)
!         Useful information has been returned.
          Case Default
!           An unrecoverable error has been detected.
            Go To 100
          End Select
        End Select

      End Do

!     query some currently set options and statistics.
      ifail = 0
      Call d01zlf('Quadrature rule',ivalue,rvalue,cvalue,optype,iopts,opts, &
        ifail)
      Call display_option('Quadrature rule',optype,ivalue,rvalue,cvalue)

      Call d01zlf('Maximum Subdivisions',ivalue,rvalue,cvalue,optype,iopts, &
        opts,ifail)
      Call display_option('Maximum Subdivisions',optype,ivalue,rvalue,cvalue)

      Call d01zlf('Extrapolation',ivalue,rvalue,cvalue,optype,iopts,opts, &
        ifail)
      Call display_option('Extrapolation',optype,ivalue,rvalue,cvalue)

      Call d01zlf('Extrapolation Safeguard',ivalue,rvalue,cvalue,optype,iopts, &
        opts,ifail)
      Call display_option('Extrapolation safeguard',optype,ivalue,rvalue, &
        cvalue)

!     print solution
      Write (nout,99999)
      Do j = 1, ni
        Write (nout,99998) j, needi(j), defint(j), errest(j)
      End Do

!     Investigate subdivision strategy
      Call d01rbf(d01rbf_monit,ni,defint,errest,icomm,licomm,licusd,comm, &
        lcomm,lcusd,iuser,ruser,ifail)

100   Continue

99999 Format (' Integral |  NEEDI  |   DEFINT   |   ERREST   ')
99998 Format (2(1X,I9),2(1X,Es12.4))
    End Program d01rafe
