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

NAG FL Interface Introduction
Example description
!   H02DAF Example Program Text
!   Mark 30.0 Release. NAG Copyright 2024.

    Module h02dafe_mod

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: confun, objfun
    Contains
      Subroutine objfun(mode,n,varcon,x,objmip,objgrd,nstate,iuser,ruser)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: objmip
        Integer, Intent (Inout)        :: mode
        Integer, Intent (In)           :: n, nstate
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout) :: objgrd(n), ruser(*)
        Real (Kind=nag_wp), Intent (In) :: x(n)
        Integer, Intent (Inout)        :: iuser(*)
        Integer, Intent (In)           :: varcon(*)
!       .. Executable Statements ..

        If (mode==0) Then
!         Objective value
          objmip = x(1)*(4.0_nag_wp*x(1)+3.0_nag_wp*x(2)-x(3)) +               &
            x(2)*(3.0_nag_wp*x(1)+6.0_nag_wp*x(2)+x(3)) +                      &
            x(3)*(x(2)-x(1)+10.0_nag_wp*x(3))
        Else
!         Objective gradients for continuous variables
          objgrd(1) = 8.0_nag_wp*x(1) + 6.0_nag_wp*x(2) - 2.0_nag_wp*x(3)
          objgrd(2) = 6.0_nag_wp*x(1) + 12.0_nag_wp*x(2) + 2.0_nag_wp*x(3)
          objgrd(3) = 2.0_nag_wp*(x(2)-x(1)) + 20.0_nag_wp*x(3)
          objgrd(4) = 0.0_nag_wp
        End If
        Return
      End Subroutine objfun

      Subroutine confun(mode,ncnln,n,varcon,x,c,cjac,nstate,iuser,ruser)

!       .. Parameters ..
        Real (Kind=nag_wp), Parameter  :: eight = 8.0_nag_wp
        Real (Kind=nag_wp), Parameter  :: nine = 9.0_nag_wp
        Real (Kind=nag_wp), Parameter  :: seven = 7.0_nag_wp
        Real (Kind=nag_wp), Parameter  :: twelve = 12.0_nag_wp
        Real (Kind=nag_wp), Parameter  :: zero = 0.0_nag_wp
!       .. Scalar Arguments ..
        Integer, Intent (Inout)        :: mode
        Integer, Intent (In)           :: n, ncnln, nstate
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: c(ncnln)
        Real (Kind=nag_wp), Intent (Inout) :: cjac(ncnln,n), ruser(*)
        Real (Kind=nag_wp), Intent (In) :: x(n)
        Integer, Intent (Inout)        :: iuser(*)
        Integer, Intent (In)           :: varcon(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: rho
        Integer                        :: p
!       .. Intrinsic Procedures ..
        Intrinsic                      :: real
!       .. Executable Statements ..

        If (mode==0) Then
!         Constraints
          p = iuser(1)
          rho = ruser(1)

!         Mean return rho:
          c(1) = eight*x(1) + nine*x(2) + twelve*x(3) + seven*x(4) - rho
!         Maximum of p assets in portfolio:
          c(2) = real(p,kind=nag_wp) - x(5) - x(6) - x(7) - x(8)
        Else
!         Jacobian
          cjac(1,1:4) = (/eight,nine,twelve,seven/)
!          c(2) does not include continuous variables which requires
!          that their derivatives are zero
          cjac(2,1:4) = zero
        End If

        Return
      End Subroutine confun
    End Module h02dafe_mod

    Program h02dafe

!     .. Use Statements ..
      Use h02dafe_mod, Only: confun, objfun
      Use nag_library, Only: h02daf, h02zkf, h02zlf, nag_wp, x04caf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=nag_wp), Parameter    :: bigish = 1.0E3_nag_wp
      Real (Kind=nag_wp), Parameter    :: one = 1.0_nag_wp
      Real (Kind=nag_wp), Parameter    :: zero = 0.0_nag_wp
      Integer, Parameter               :: nout = 6
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: acc, accqp, objmip
      Integer                          :: ifail, ivalue, lda, liopts, lopts,   &
                                          maxit, n, nclin, ncnln, optype
      Character (40)                   :: cvalue
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:,:), ax(:), bl(:), bu(:), c(:),   &
                                          cjac(:,:), d(:), objgrd(:), x(:)
      Real (Kind=nag_wp)               :: opts(100), ruser(1)
      Integer                          :: iopts(200), iuser(1)
      Integer, Allocatable             :: varcon(:)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: size
!     .. Executable Statements ..
      Write (nout,*) 'H02DAF Example Program Results'
      Write (nout,*)
      Flush (nout)

      n = 8
      nclin = 5
      ncnln = 2

      lda = nclin
      Allocate (a(lda,n),d(nclin),ax(nclin),bl(n),bu(n),varcon(n+nclin+ncnln), &
        x(n),c(ncnln),cjac(ncnln,n),objgrd(n))

!     Set variable types: continuous then binary
      varcon(1:4) = 0
      varcon(5:8) = 1

!     Set continuous variable bounds
      bl(1:4) = zero
      bu(1:4) = bigish

!     Bounds for binary variables need not be provided
      bl(5:8) = zero
      bu(5:8) = one

!     Set linear constraint, equality first
      varcon(n+1) = 3
      varcon(n+2:n+nclin) = 4

!     Set Ax=d then Ax>=d
      a(1:nclin,1:n) = zero
      a(1,1:4) = one
      a(2,(/1,5/)) = (/-one,one/)
      a(3,(/2,6/)) = (/-one,one/)
      a(4,(/3,7/)) = (/-one,one/)
      a(5,(/4,8/)) = (/-one,one/)
      d(1) = one
      d(2:5) = zero

!     Set constraints supplied by CONFUN, equality first
      varcon(n+nclin+1) = 3
      varcon(n+nclin+2) = 4

      liopts = size(iopts)
      lopts = size(opts)

!     Initialize communication arrays
      ifail = 0
      Call h02zkf('Initialize = H02DAF',iopts,liopts,opts,lopts,ifail)

!     Optimization parameters
      maxit = 500
      acc = 1.0E-6_nag_wp

!     Initial estimate (binary variables need not be given)
      x(1:4) = one
      x(5:8) = zero

!     Portfolio parameters p and rho
      iuser(1) = 3
      ruser(1) = 10.0_nag_wp

      ifail = 0
      Call h02daf(n,nclin,ncnln,a,lda,d,ax,bl,bu,varcon,x,confun,c,cjac,       &
        objfun,objgrd,maxit,acc,objmip,iopts,opts,iuser,ruser,ifail)

!     Results
      If (ifail==0) Then
        Call x04caf('G','N',n,1,x,n,'Final estimate:',ifail)

!       Query the accuracy of the mixed integer QP solver
        ifail = -1
        Call h02zlf('QP Accuracy',ivalue,accqp,cvalue,optype,iopts,opts,ifail)
        If (ifail==0) Then

          Write (nout,'(/1x,a,1x,g12.4)')                                      &
            'Requested accuracy of QP subproblems', accqp
        End If
        Write (nout,'(1x,a,1x,g12.4)') 'Optimised value:', objmip
      Else
        Write (nout,'(/1x,a,i4/)') 'h02daf returns ifail = ', ifail
      End If
    End Program h02dafe