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

NAG AD Library Introduction
Example description
!   E05UC_T1W_F Example Program Text
!   Mark 30.2 Release. NAG Copyright 2024.

    Module e05uc_t1w_fe_mod

!     E05UC_T1W_F Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use nagad_library, Only: cos, nagad_t1w_w_rtype, sin, sqrt,              &
                               Operator (+), Operator (*), Operator (**),      &
                               Operator (-), Assignment (=), Operator (>=)
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: mystart, schwefel_confun,            &
                                          schwefel_obj
    Contains
      Subroutine schwefel_obj(ad_handle,mode,n,x,objf,objgrd,nstate,iuser,     &
        ruser)

!       .. Use Statements ..
        Use iso_c_binding, Only: c_ptr
!       .. Scalar Arguments ..
        Type (c_ptr), Intent (Inout)   :: ad_handle
        Type (nagad_t1w_w_rtype), Intent (Out) :: objf
        Integer, Intent (Inout)        :: mode
        Integer, Intent (In)           :: n, nstate
!       .. Array Arguments ..
        Type (nagad_t1w_w_rtype), Intent (Inout) :: objgrd(n), ruser(*)
        Type (nagad_t1w_w_rtype), Intent (In) :: x(n)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
        Integer                        :: i
!       .. Executable Statements ..
        If (nstate==1) Then
!         This is the first call.
!         Take any special action here if desired.
          Continue
        End If
        If (mode==0 .Or. mode==2) Then
!         Evaluate the objective function.
          objf = 0.0_nag_wp
          Do i = 1, n
            If (x(i)>=0.0_nag_wp) Then
              objf = objf + x(i)*sin(ruser(1)*sqrt(x(i)))
            Else
              objf = objf + x(i)*sin(ruser(1)*sqrt(-x(i)))
            End If
          End Do
        End If

        If (mode==1 .Or. mode==2) Then
!         Calculate the gradient of the objective function.
          Do i = 1, n
            If (x(i)>=0.0_nag_wp) Then
              objgrd(i) = sin(ruser(1)*sqrt(x(i))) +                           &
                0.5_nag_wp*ruser(1)*sqrt(x(i))*cos(ruser(1)*sqrt(x(i)))
            Else
              objgrd(i) = sin(ruser(1)*sqrt(-x(i))) +                          &
                0.5_nag_wp*ruser(1)*sqrt(-x(i))*cos(ruser(1)*sqrt(-x(i)))
            End If
          End Do
        End If

        Return
      End Subroutine schwefel_obj
      Subroutine schwefel_confun(ad_handle,mode,ncnln,n,ldcjsl,needc,x,c,cjsl, &
        nstate,iuser,ruser)

!       .. Use Statements ..
        Use iso_c_binding, Only: c_ptr
!       .. Scalar Arguments ..
        Type (c_ptr), Intent (Inout)   :: ad_handle
        Integer, Intent (In)           :: ldcjsl, n, ncnln, nstate
        Integer, Intent (Inout)        :: mode
!       .. Array Arguments ..
        Type (nagad_t1w_w_rtype), Intent (Out) :: c(ncnln)
        Type (nagad_t1w_w_rtype), Intent (Inout) :: cjsl(ldcjsl,n), ruser(*)
        Type (nagad_t1w_w_rtype), Intent (In) :: x(n)
        Integer, Intent (Inout)        :: iuser(*)
        Integer, Intent (In)           :: needc(ncnln)
!       .. Local Scalars ..
        Type (nagad_t1w_w_rtype)       :: t1, t2
        Integer                        :: k
        Logical                        :: evalc, evalcjsl
!       .. Executable Statements ..
        If (nstate==1) Then
!         This is the first call.
!         Take any special action here if desired.
          Continue
        End If

!       mode: what is required - constraints, derivatives, or both?
        evalc = (mode==0 .Or. mode==2)
        evalcjsl = (mode==1 .Or. mode==2)

loop_constraints: Do k = 1, ncnln

          If (needc(k)<=0) Then
            Cycle loop_constraints
          End If

          If (evalc) Then
!           Constraint values are required.
            Select Case (k)
            Case (1)
              c(k) = ruser(2)*x(1)**2 - ruser(3)*x(2)**2 + ruser(4)*x(1)*x(2)
            Case (2)
              c(k) = cos((x(1)*ruser(5))**2+(x(2)*ruser(6)))
            Case Default
!             This constraint is not coded (there are only two).
!             Terminate.
              mode = -1
              Exit loop_constraints
            End Select
          End If

          If (evalcjsl) Then
!           Constraint derivatives are required.
            Select Case (k)
            Case (1)
              cjsl(k,1) = 2.0_nag_wp*ruser(2)*x(1) + ruser(4)*x(2)
              cjsl(k,2) = -2.0_nag_wp*ruser(3)*x(2) + ruser(4)*x(1)
            Case (2)
              t1 = x(1)*ruser(5)
              t2 = x(2)*ruser(6)
              cjsl(k,1) = -sin(t1**2+t2)*2.0_nag_wp*t1*ruser(5)
              cjsl(k,2) = -sin(t1**2+t2)*ruser(6)
            End Select
          End If

        End Do loop_constraints

        Return
      End Subroutine schwefel_confun
      Subroutine mystart(ad_handle,npts,quas,n,repeat,bl,bu,iuser,ruser,mode)

!       Sets the initial points.
!       A typical user-defined start procedure.
!       Only nonzero elements of quas need to be specified here.

!       .. Use Statements ..
        Use iso_c_binding, Only: c_ptr
        Use nag_library, Only: g05kgf, g05saf, nag_wp
!       .. Scalar Arguments ..
        Type (c_ptr), Intent (Inout)   :: ad_handle
        Integer, Intent (Inout)        :: mode
        Integer, Intent (In)           :: n, npts
        Logical, Intent (In)           :: repeat
!       .. Array Arguments ..
        Type (nagad_t1w_w_rtype), Intent (In) :: bl(n), bu(n)
        Type (nagad_t1w_w_rtype), Intent (Inout) :: quas(n,npts), ruser(*)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: rq
        Integer                        :: genid, i, ifail, lstate, subid
!       .. Local Arrays ..
        Real (Kind=nag_wp), Allocatable :: rquas(:)
        Integer, Allocatable           :: state(:)
!       .. Intrinsic Procedures ..
        Intrinsic                      :: real
!       .. Executable Statements ..
        If (repeat) Then
!         Generate a uniform spread of points between bl and bu.
          Do i = 1, npts
            rq = real(i-1,kind=nag_wp)/real(npts-1,kind=nag_wp)
            quas(1:n,i) = bl(1:n) + rq*(bu(1:n)-bl(1:n))
          End Do
        Else
!         Generate a non-repeatable spread of points between bl and bu.
          genid = 2
          subid = 53
          lstate = -1
          Allocate (state(lstate),rquas(n))
          ifail = 0
          Call g05kgf(genid,subid,state,lstate,ifail)
          Deallocate (state)
          Allocate (state(lstate))
          ifail = 0
          Call g05kgf(genid,subid,state,lstate,ifail)
          Do i = 1, npts
            ifail = 0
            Call g05saf(n,state,rquas,ifail)
            quas(1:n,i) = bl(1:n) + (bu(1:n)-bl(1:n))*rquas(1:n)
          End Do
          Deallocate (state,rquas)
        End If
!       Set mode negative to terminate execution for any reason.
        mode = 0
        Return
      End Subroutine mystart
    End Module e05uc_t1w_fe_mod
    Program e05uc_t1w_fe

!     E05UC_T1W_F Example Main Program

!     .. Use Statements ..
      Use e05uc_t1w_fe_mod, Only: mystart, schwefel_confun, schwefel_obj
      Use iso_c_binding, Only: c_ptr
      Use nagad_library, Only: dgemv_t1w, e05uc_t1w_f, e05zk_t1w_f,            &
                               nagad_t1w_set_derivative, nagad_t1w_w_rtype,    &
                               x10aa_t1w_f, x10ab_t1w_f, Assignment (=)
      Use nag_library, Only: nag_wp, x04caf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: n = 2, nclin = 1, ncnln = 2,         &
                                          nin = 5, nout = 6
!     .. Local Scalars ..
      Type (c_ptr)                     :: ad_handle
      Type (nagad_t1w_w_rtype)         :: alpha, beta
      Integer                          :: i, ifail, j, k, l, lda, ldc, ldcjac, &
                                          ldclda, ldobjd, ldr, ldx, liopts,    &
                                          listat, lopts, nb, npts, sda,        &
                                          sdcjac, sdr
      Logical                          :: repeat
!     .. Local Arrays ..
      Type (nagad_t1w_w_rtype), Allocatable :: a(:,:), bl(:), bu(:), c(:,:),   &
                                          cjac(:,:,:), clamda(:,:), objf(:),   &
                                          objgrd(:,:), opts(:), r(:,:,:),      &
                                          work(:), x(:,:)
      Type (nagad_t1w_w_rtype)         :: ruser(6)
      Real (Kind=nag_wp)               :: x_r(6)
      Integer, Allocatable             :: info(:), iopts(:), istate(:,:),      &
                                          iter(:)
      Integer                          :: iuser(1)
!     .. Executable Statements ..
      Write (nout,*) 'E05UC_T1W_F Example Program Results'
      Flush (nout)

!     Skip heading in data file
      Read (nin,*)

      Read (nin,*) nb, npts
      Read (nin,*) repeat

      lda = nclin

      If (nclin>0) Then
        sda = n
      Else
        sda = 1
      End If

      ldx = n
      ldobjd = n
      ldc = ncnln
      ldcjac = ncnln

      If (ncnln>0) Then
        sdcjac = n
      Else
        sdcjac = 0
      End If

      ldr = n
      sdr = n
      ldclda = n + nclin + ncnln
      listat = n + nclin + ncnln
      liopts = 740
      lopts = 485
      Allocate (a(lda,sda),bl(n+nclin+ncnln),bu(n+nclin+ncnln),x(ldx,nb),      &
        objf(nb),objgrd(ldobjd,nb),iter(nb),c(ldc,nb),cjac(ldcjac,sdcjac,nb),  &
        r(ldr,sdr,nb),clamda(ldclda,nb),istate(listat,nb),iopts(liopts),       &
        opts(lopts),info(nb),work(nclin))

      bl(1:n) = -500.0_nag_wp
      bl(n+1:n+nclin) = -10000.0_nag_wp
      bl(n+nclin+1:n+nclin+1) = -1.0_nag_wp
      bl(n+nclin+1:n+nclin+ncnln) = -0.9_nag_wp
      bu(1:n) = 500.0_nag_wp
      bu(n+1:n+nclin) = 10.0_nag_wp
      bu(n+nclin+1:n+nclin+1) = 500000.0_nag_wp
      bu(n+nclin+2:n+nclin+ncnln) = 0.9_nag_wp

      a(1,1) = 3.0_nag_wp
      a(1,2) = -2.0_nag_wp

      ruser(1) = 1.0_nag_wp
      ruser(2) = 1.0_nag_wp
      ruser(3) = 1.0_nag_wp
      ruser(4) = 3.0_nag_wp
      ruser(5) = 0.005_nag_wp
      ruser(6) = 0.01_nag_wp

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

      Do i = 1, 6

        Call nagad_t1w_set_derivative(ruser(i),1.0_nag_wp)
!       Initialize the solver.

        ifail = 0
        Call e05zk_t1w_f(ad_handle,'Initialize = E05UCF',iopts,liopts,opts,    &
          lopts,ifail)

!       Solve the problem.

        ifail = -1
        Call e05uc_t1w_f(ad_handle,n,nclin,ncnln,a,lda,bl,bu,schwefel_confun,  &
          schwefel_obj,npts,x,ldx,mystart,repeat,nb,objf,objgrd,ldobjd,iter,c, &
          ldc,cjac,ldcjac,sdcjac,r,ldr,sdr,clamda,ldclda,istate,listat,iopts,  &
          opts,iuser,ruser,info,ifail)

        If (ifail/=0 .And. ifail/=8) Then
          Go To 100
        End If
        ruser(i)%tangent = 0.0_nag_wp
        x_r(i) = objf(1)%tangent
      End Do

      Select Case (ifail)
      Case (0)
        l = nb
      Case (8)
        l = info(nb)
        Write (nout,99992) iter(nb)
      Case Default
        Go To 100
      End Select

loop: Do i = 1, l
        Write (nout,99999) i
        Write (nout,99998) info(i)
        Write (nout,99997) 'Varbl'
        Do j = 1, n
          Write (nout,99996) 'V', j, istate(j,i), x(j,i)%value,                &
            clamda(j,i)%value
        End Do
        If (nclin>0) Then
          Write (nout,99997) 'L Con'

!         Below is a call to the tangent linear version of DGEMV.
!         This performs the matrix vector multiplication A*X
!         (linear constraint values) and puts the result in
!         the first NCLIN locations of WORK.
          alpha = 1.0_nag_wp
          beta = 0.0_nag_wp
          Call dgemv_t1w('N',nclin,n,alpha,a,lda,x(1,i),1,beta,work,1)

          Do k = n + 1, n + nclin
            j = k - n
            Write (nout,99996) 'L', j, istate(k,i), work(j)%value,             &
              clamda(k,i)%value
          End Do
        End If
        If (ncnln>0) Then
          Write (nout,99997) 'N Con'
          Do k = n + nclin + 1, n + nclin + ncnln
            j = k - n - nclin
            Write (nout,99996) 'N', j, istate(k,i), c(j,i)%value,              &
              clamda(k,i)%value
          End Do
        End If
        Write (nout,99995) objf(i)%value
        Write (nout,99994)
        Write (nout,99993)(clamda(k,i)%value,k=1,n+nclin+ncnln)

        If (l==1) Then
          Exit loop
        End If

        Write (nout,*)

        Write (nout,*)                                                         &
          ' ------------------------------------------------------ '

      End Do loop

      Write (nout,*)
      Write (nout,*) ' Derivatives calculated: First order tangents'
      Write (nout,*) ' Computational mode    : algorithmic'
      Write (nout,*)
      Call x04caf('General',' ',6,1,x_r,6,' dobjf/druser',ifail)
      Write (nout,*)

100   Continue

!     Remove computational data object
      Call x10ab_t1w_f(ad_handle,ifail)

99999 Format (/,1X,'Solution number',I16)
99998 Format (/,1X,'Local minimization exited with code',I5)
99997 Format (/,1X,A,2X,'Istate',3X,'Value',9X,'Lagr Mult',/)
99996 Format (1X,A,2(1X,I3),4X,F12.4,2X,F12.4)
99995 Format (/,1X,'Final objective value = ',1X,F12.4)
99994 Format (/,1X,'QP multipliers')
99993 Format (1X,F12.4)
99992 Format (1X,I16,' starting points converged')
    End Program e05uc_t1w_fe