Module x10ba_a1w_fe_mod

!     .. Use Statements ..
      Use iso_c_binding, Only: c_funloc, c_int, c_ptr
      Use nagad_library, Only: nagad_a1w_get_derivative,                       &
                               nagad_a1w_inc_derivative,                       &
                               nagad_a1w_ir_register_variable,                 &
                               nagad_a1w_w_rtype, x10ba_a1w_f, x10bb_a1w_f,    &
                               x10bj_a1w_f, x10cj_a1w_f, Assignment (=)
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: comp_eval, procarg

    Contains
      Subroutine procarg(ad_handle,x,y)

!       .. Scalar Arguments ..
        Type (c_ptr)                   :: ad_handle
        Type (nagad_a1w_w_rtype), Intent (In) :: x
        Type (nagad_a1w_w_rtype), Intent (Out) :: y
!       .. Local Scalars ..
        Type (c_ptr)                   :: cb_handle
        Integer                        :: ifail
!       .. Intrinsic Procedures ..
        Intrinsic                      :: log
!       .. Executable Statements ..

!       Create callback data object
        ifail = 0
        Call x10ba_a1w_f(cb_handle,ifail)

!       Write x to callback data object
        ifail = 0
        Call x10bj_a1w_f(cb_handle,x,ifail)

!       Evaluate primal y value
        y = 0.0_nag_wp
        y%value = log(1.0_nag_wp+x%value)

!       Register y
        Call nagad_a1w_ir_register_variable(y)

!       Write y to callback data object
        ifail = 0
        Call x10bj_a1w_f(cb_handle,y,ifail)

!       Push comp_eval onto global tape
        ifail = 0
        Call x10bb_a1w_f(cb_handle,c_funloc(comp_eval),ifail)
      End Subroutine procarg
      Subroutine comp_eval(callmode,cb_handle) Bind (C)

!       .. Scalar Arguments ..
        Type (c_ptr), Value            :: cb_handle
        Integer (Kind=c_int), Value    :: callmode
!       .. Local Scalars ..
        Type (nagad_a1w_w_rtype)       :: x, y
        Real (Kind=nag_wp)             :: xa, ya
        Integer                        :: ifail
!       .. Executable Statements ..
        If (callmode/=1) Then

!         Read x and y from callback data object
          ifail = 0
          Call x10cj_a1w_f(cb_handle,x,ifail)
          Call x10cj_a1w_f(cb_handle,y,ifail)

!         Get algorithmic derivative of z w.r.t. y
          ya = nagad_a1w_get_derivative(y)
!         Evaluate derivative w.r.t. x = dz/dy * dy/dx
          xa = ya*1.0_nag_wp/(1.0_nag_wp+x%value)
!         Increment derivative w.r.t x
          Call nagad_a1w_inc_derivative(x,xa)
        End If
      End Subroutine comp_eval
    End Module x10ba_a1w_fe_mod

    Program x10ba_a1w_fe

!     X10BA_A1W_F Example Program Text
!     Mark 27.3 Release. NAG Copyright 2021.

!     .. Use Statements ..
      Use iso_c_binding, Only: c_ptr
      Use nagad_library, Only: log, nagad_a1w_get_derivative,                  &
                               nagad_a1w_ir_create => x10za_a1w_f,             &
                               nagad_a1w_ir_interpret_adjoint_sparse,          &
                               nagad_a1w_ir_register_variable,                 &
                               nagad_a1w_ir_remove, nagad_a1w_set_derivative,  &
                               nagad_a1w_w_rtype, nagad_algorithmic,           &
                               nagad_dstate, x10aa_a1w_f, x10ab_a1w_f,         &
                               x10ac_a1w_f, x10bc_a1w_f, Assignment (=),       &
                               Operator (+)
      Use nag_library, Only: nag_wp
      Use x10ba_a1w_fe_mod, Only: procarg
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nout = 6
!     .. Local Scalars ..
      Type (c_ptr), Volatile           :: ad_handle
      Type (nagad_a1w_w_rtype)         :: x, x1, y, y1
      Real (Kind=nag_wp)               :: dydx, dydx_exp
      Integer                          :: cb_mode, ifail, mode
!     .. Executable Statements ..
      Write (nout,*) 'X10BA_A1W_F Example Program Results'

!     Create AD tape
      Call nagad_a1w_ir_create

      x = 0.1_nag_wp
      x1 = x
      Write (nout,*)
      Write (nout,*) 'Testing Callback insertion'

!     Create AD configuration data object
      ifail = 0
      Call x10aa_a1w_f(ad_handle,ifail)

!     Set computational mode to nagad_algorithmic
      mode = nagad_algorithmic
      ifail = 0
      Call x10ac_a1w_f(ad_handle,mode,ifail)

!     Evaluate derivative first by operator extensions
      Write (nout,*)
      Write (nout,*) '  1. Direct algorithmic differentiation'

      Call nagad_a1w_ir_register_variable(x)

!     Set callback computational mode
      cb_mode = nagad_dstate
      ifail = 0
      Call x10bc_a1w_f(ad_handle,cb_mode,ifail)

      y = log(1.0_nag_wp+x)

!     Get derivatives
      Call nagad_a1w_set_derivative(y,1.0_nag_wp)
      Call nagad_a1w_ir_interpret_adjoint_sparse(ifail)

      dydx = nagad_a1w_get_derivative(x)
      dydx_exp = 1.0_nag_wp/(1.0_nag_wp+x%value)

      Write (nout,99999) 'Input value of x             : ', x%value
      Write (nout,99999) 'Output value of ln(1+x)      : ', y%value
      Write (nout,99999) 'AD evaluated derivative      : ', dydx
      Write (nout,99999) 'Directly computed derivative : ', dydx_exp

!     Now evaluate adjoint of supplied routine procarg manually
!     using the companion callback comp_eval

      Write (nout,*)
      Write (nout,*) '  1. Differentiation via callback'

      Call procarg(ad_handle,x1,y1)

      Call nagad_a1w_set_derivative(y1,1.0_nag_wp)
      Call nagad_a1w_ir_interpret_adjoint_sparse(ifail)

      dydx = nagad_a1w_get_derivative(x1)

      Write (nout,99999) 'Input value of x1            : ', x1%value
      Write (nout,99999) 'Output value of ln(1+x)      : ', y1%value
      Write (nout,99999) 'Callback evaluated derivative: ', dydx
99999 Format (1X,A,1P,E11.3)

!     Remove computational data object and tape
      Call x10ab_a1w_f(ad_handle,ifail)
      Call nagad_a1w_ir_remove

    End Program x10ba_a1w_fe