NAG Library Manual, Mark 30.2
Interfaces:  FL   CL   CPP   AD 

NAG FL Interface Introduction
Example description
!   D01ESF Example Program Text
!   Mark 30.2 Release. NAG Copyright 2024.

    Module d01esfe_mod

!     D01ESF Example Program Module:
!            User-defined Routines

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: f
    Contains
      Subroutine f(ni,ndim,nx,xtr,nntr,icolzp,irowix,xs,qs,fm,iflag,iuser,     &
        ruser)

!       .. Use Statements ..
        Use nag_library, Only: x06adf
!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: xtr
        Integer, Intent (Inout)        :: iflag
        Integer, Intent (In)           :: ndim, ni, nntr, nx
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: fm(ni,nx)
        Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
        Real (Kind=nag_wp), Intent (In) :: xs(nntr)
        Integer, Intent (In)           :: icolzp(nx+1), irowix(nntr), qs(nntr)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: s_ntr, s_tr
        Integer                        :: i, j, logs_hi, logs_lo, s_hi, s_lo,  &
                                          tid
!       .. Intrinsic Procedures ..
        Intrinsic                      :: log, real, sin, sum
!       .. Executable Statements ..

!       For each evaluation point x_i, i = 1, ..., nx, return in fm the
!       computed values of the ni integrands f_j, j = 1, ..., ni defined by

!         fm(j,i) = f_j(x_i)
!                                                         ndim
!                 = sin(j + S(i))*log(S(i)), where S(i) =  Sum  k*x_i(k).
!                                                          k=1

!       Split the S expression into two components, one involving only the
!       'trivial' value xtr:

!                ndim             ndim
!         S(i) =  Sum  (k*xtr)  +  Sum  (k*(x_i(k)-xtr))
!                 k=1              k=1

!                      ndim*(ndim+1)   ndim
!              = xtr * ------------- +  Sum  (k*(x_i(k)-xtr))
!                           2           k=1

!             := s_tr                + s_ntr(i)

!       By definition the summands in the s_ntr(i) term on the right-hand side
!       are zero for those k outside the range of indices defined in irowix.

!       As a demonstration of safely operating with the user arrays iuser and
!       ruser when running in parallel, 'partition' these based on the current
!       thread number. Store some of the s_tr and s_ntr computations in these
!       array sections.

!       The thread number, converted to 1-based numbering.
        tid = x06adf() + 1

        s_lo = iuser(tid)
        s_hi = s_lo + nx - 1
        logs_lo = s_hi + 1
        logs_hi = logs_lo + nx - 1

        If (iflag==0) Then
!         First call: nx=1, no non-trivial dimensions.
!         The constant s_tr can be reused by all subsequent calculations.
          s_tr = 0.5E0_nag_wp*xtr*real(ndim*(ndim+1),kind=nag_wp)
          ruser(1) = s_tr
          ruser(s_lo) = s_tr
          ruser(logs_lo) = log(s_tr)
        Else
!         Calculate S(i) = s_tr + s_ntr(i).
          s_tr = ruser(1)
          Do i = 1, nx
            s_ntr = sum(real(irowix(icolzp(i):icolzp(i+1)-                     &
              1),kind=nag_wp)*(xs(icolzp(i):icolzp(i+1)-1)-xtr))
            ruser(s_lo+i-1) = s_ntr + s_tr
            ruser(logs_lo+i-1) = log(s_ntr+s_tr)
          End Do
        End If

!       Finally we obtain fm(j,:) = sin(j+S(:))*log(S(:))
        Do j = 1, ni
          fm(j,:) = sin(real(j,kind=nag_wp)+ruser(s_lo:s_hi))*                 &
            ruser(logs_lo:logs_hi)
        End Do

        Return
      End Subroutine f
    End Module d01esfe_mod
    Program d01esfe

!     .. Use Statements ..
      Use d01esfe_mod, Only: f
      Use nag_library, Only: d01esf, d01zkf, d01zlf, nag_wp, x06acf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nout = 6
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: rvalue
      Integer                          :: ifail, j, liuser, lruser, maxnx,     &
                                          ndim, ni, optype, smpthd
      Character (16)                   :: cvalue
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: dinest(:), errest(:), opts(:),       &
                                          ruser(:)
      Integer, Allocatable             :: iopts(:), iuser(:), ivalid(:),       &
                                          maxdlv(:)
!     .. Executable Statements ..
      Write (nout,*) 'D01ESF Example Program Results'
      Write (nout,*)
      ni = 10
      ndim = 4

      Allocate (iopts(100),opts(100),ivalid(ni),dinest(ni),errest(ni),         &
        maxdlv(ndim))

!     Initialize option arrays.
      ifail = 0
      Call d01zkf('Initialize = D01ESF',iopts,100,opts,100,ifail)

!     Set any required options.
      Call d01zkf('Absolute Tolerance = 0.0',iopts,100,opts,100,ifail)
      Call d01zkf('Relative Tolerance = 1.0e-3',iopts,100,opts,100,ifail)
      Call d01zkf('Maximum Level = 6',iopts,100,opts,100,ifail)
      Call d01zkf('Index Level = 5',iopts,100,opts,100,ifail)

!     Set any required maximum dimension levels.
      maxdlv(:) = 0

!     As a demonstration of safely operating with the user arrays iuser and
!     ruser when running in parallel, we will 'partition' these in the user-
!     supplied function f based on the current thread number.
!     The size of these arrays is a function of Maximum Nx and the maximum
!     allowed number of OpenMP threads.

      ifail = 0
      Call d01zlf('Maximum Nx',maxnx,rvalue,cvalue,optype,iopts,opts,ifail)

      smpthd = x06acf()

      lruser = 1 + 2*maxnx*smpthd
      liuser = smpthd
      Allocate (iuser(liuser),ruser(lruser))

!     iuser stores the partition indices for ruser:
      iuser(1) = 2
      Do j = 2, smpthd
        iuser(j) = iuser(j-1) + 2*maxnx
      End Do

!     Approximate the integrals.
      ifail = -1
      Call d01esf(ni,ndim,f,maxdlv,dinest,errest,ivalid,iopts,opts,iuser,      &
        ruser,ifail)
      Select Case (ifail)
      Case (0,1,2,-1)
!       0: The result returned satisfies the requested accuracy requirements.
!       1, 2: The result returned is inaccurate for at least one integral.
!       -1: Exit was requested by setting iflag negative in f.
!           A result will be returned if at least one call to f was
!           successful.
        Write (nout,99999)
        Do j = 1, ni
          Write (nout,99998) j, dinest(j), errest(j), ivalid(j)
        End Do
      Case Default
!       If internal memory allocation failed consider reducing the options
!       'Maximum Nx' and 'Index Level', or run with fewer threads.
        Write (nout,99997) ifail
      End Select

99999 Format (1X,'Integral # | Estimated value | Error estimate | ',           &
        'Final state of integral')
99998 Format (1X,I11,'|',Es17.5,'|',Es16.5,'|',I8)
99997 Format (1X,'D01ESF exited with IFAIL = ',I8)
    End Program d01esfe