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

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

    Module e04uhae_mod

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

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: objfun
!     .. Parameters ..
      Integer, Parameter, Public       :: iset = 1, lcwsav = 1, liwsav = 550,  &
                                          llwsav = 20, lrwsav = 550, nin = 5,  &
                                          ninopt = 7, nout = 6
    Contains
      Subroutine objfun(mode,nonln,x,objf,objgrd,nstate,iuser,ruser)
!       Computes the nonlinear part of the objective function and its
!       gradient

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: objf
        Integer, Intent (Inout)        :: mode
        Integer, Intent (In)           :: nonln, nstate
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout) :: objgrd(nonln), ruser(*)
        Real (Kind=nag_wp), Intent (In) :: x(nonln)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Executable Statements ..
        If (mode==0 .Or. mode==2) Then
          objf = 2.0E+0_nag_wp - x(1)*x(2)*x(3)*x(4)*x(5)/120.0E+0_nag_wp
        End If

        If (mode==1 .Or. mode==2) Then
          objgrd(1) = -x(2)*x(3)*x(4)*x(5)/120.0E+0_nag_wp
          objgrd(2) = -x(1)*x(3)*x(4)*x(5)/120.0E+0_nag_wp
          objgrd(3) = -x(1)*x(2)*x(4)*x(5)/120.0E+0_nag_wp
          objgrd(4) = -x(1)*x(2)*x(3)*x(5)/120.0E+0_nag_wp
          objgrd(5) = -x(1)*x(2)*x(3)*x(4)/120.0E+0_nag_wp
        End If

        Return

      End Subroutine objfun
    End Module e04uhae_mod
    Program e04uhae

!     E04UHA Example Main Program

!     .. Use Statements ..
      Use e04uhae_mod, Only: iset, lcwsav, liwsav, llwsav, lrwsav, nin,        &
                             ninopt, nout, objfun
      Use nag_library, Only: e04uga, e04ugm, e04uha, e04uja, e04wbf, nag_wp,   &
                             x04abf, x04acf, x04baf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Character (*), Parameter         :: fname = 'e04uhae.opt'
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: obj, sinf
      Integer                          :: i, ifail, inform, iobj, j, leniz,    &
                                          lenz, m, miniz, minz, mode, n,       &
                                          ncnln, ninf, njnln, nname, nnz,      &
                                          nonln, ns, outchn
      Character (80)                   :: rec
      Character (1)                    :: start
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:), bl(:), bu(:), clamda(:),       &
                                          xs(:), z(:)
      Real (Kind=nag_wp)               :: rwsav(lrwsav), user(1)
      Integer, Allocatable             :: ha(:), istate(:), iz(:), ka(:)
      Integer                          :: iuser(1), iwsav(liwsav)
      Logical                          :: lwsav(llwsav)
      Character (80)                   :: cwsav(lcwsav)
      Character (8), Allocatable       :: names(:)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: max
!     .. Executable Statements ..
      Write (rec,99990) 'E04UHA Example Program Results'
      Call x04baf(nout,rec)

!     Skip heading in data file.
      Read (nin,*)
      Read (nin,*) n, m
      Read (nin,*) ncnln, nonln, njnln
      Read (nin,*) start, nname
      nnz = 1
      Allocate (ha(nnz),ka(n+1),istate(n+m),a(nnz),bl(n+m),bu(n+m),xs(n+m),    &
        clamda(n+m),names(nname))

      Read (nin,*) names(1:nname)

!     Define the matrix A to contain a dummy `free' row that consists
!     of a single (zero) element subject to `infinite' upper and
!     lower bounds. Set up KA.

      iobj = -1

      ka(1) = 1

      a(1) = 0.0E+0_nag_wp
      ha(1) = 1

!     Columns 2,3,...,N of A are empty. Set the corresponding element
!     of KA to 2.

      ka(2:n) = 2
      ka(n+1) = nnz + 1

      Read (nin,*) bl(1:(n+m))
      Read (nin,*) bu(1:(n+m))

      If (start=='C') Then
        Read (nin,*) istate(1:n)
      Else If (start=='W') Then
        Read (nin,*) istate(1:(n+m))
      End If

      Read (nin,*) xs(1:n)

!     Set the unit number for advisory messages to OUTCHN.

      outchn = nout
      Call x04abf(iset,outchn)

!     Initialise E04UGA

      ifail = 0
      Call e04wbf('E04UGA',cwsav,lcwsav,lwsav,llwsav,iwsav,liwsav,rwsav,       &
        lrwsav,ifail)

!     Set three options using E04UJA.

      Call e04uja(' Verify Level = -1 ',lwsav,iwsav,rwsav,inform)

      If (inform==0) Then

        Call e04uja(' Major Iteration Limit = 25 ',lwsav,iwsav,rwsav,inform)

        If (inform==0) Then

          Call e04uja(' Infinite Bound Size = 1.0D+25 ',lwsav,iwsav,rwsav,     &
            inform)

        End If

      End If

      If (inform/=0) Then
        Write (rec,99991) 'E04UJA terminated with INFORM = ', inform
        Call x04baf(nout,rec)
        Go To 100
      End If

!     Open the options file for reading

      mode = 0

      ifail = 0
      Call x04acf(ninopt,fname,mode,ifail)

!     Read the options file for the remaining options.

      Call e04uha(ninopt,lwsav,iwsav,rwsav,inform)

      If (inform/=0) Then
        Write (rec,99991) 'E04UJA terminated with INFORM = ', inform
        Call x04baf(nout,rec)
        Go To 100
      End If

!     Solve the problem.
!     First call is a workspace query

      leniz = max(500,n+m)
      lenz = 500
      Allocate (iz(leniz),z(lenz))

      ifail = 1
      Call e04uga(e04ugm,objfun,n,m,ncnln,nonln,njnln,iobj,nnz,a,ha,ka,bl,bu,  &
        start,nname,names,ns,xs,istate,clamda,miniz,minz,ninf,sinf,obj,iz,     &
        leniz,z,lenz,iuser,user,lwsav,iwsav,rwsav,ifail)

      If (ifail/=0 .And. ifail/=15 .And. ifail/=16) Then
        Write (nout,99991) 'Query call to E04UGA failed with IFAIL =', ifail
        Go To 100
      End If

      Deallocate (iz,z)

!     The length of the workspace required for the basis factors in this
!     problem is longer than the minimum returned by the query

      lenz = 2*minz
      leniz = 2*miniz
      Allocate (iz(leniz),z(lenz))

      ifail = -1
      Call e04uga(e04ugm,objfun,n,m,ncnln,nonln,njnln,iobj,nnz,a,ha,ka,bl,bu,  &
        start,nname,names,ns,xs,istate,clamda,miniz,minz,ninf,sinf,obj,iz,     &
        leniz,z,lenz,iuser,user,lwsav,iwsav,rwsav,ifail)

      Select Case (ifail)
      Case (0:6)
        Write (rec,'()')
        Call x04baf(nout,rec)
        Write (rec,99999)
        Call x04baf(nout,rec)
        Write (rec,'()')
        Call x04baf(nout,rec)

        Do i = 1, n
          Write (rec,99998) i, istate(i), xs(i), clamda(i)
          Call x04baf(nout,rec)
        End Do

        Write (rec,'()')
        Call x04baf(nout,rec)
        Write (rec,'()')
        Call x04baf(nout,rec)
        Write (rec,99996)
        Call x04baf(nout,rec)
        Write (rec,'()')
        Call x04baf(nout,rec)

        If (ncnln>0) Then

          Do i = n + 1, n + ncnln
            j = i - n
            Write (rec,99995) j, istate(i), xs(i), clamda(i)
            Call x04baf(nout,rec)
          End Do

        End If

        If (ncnln==0 .And. m==1 .And. a(1)==0.0E0_nag_wp) Then
          Write (rec,99993) istate(n+1), xs(n+1), clamda(n+1)
          Call x04baf(nout,rec)
        Else If (m>ncnln) Then

          Do i = n + ncnln + 1, n + m
            j = i - n - ncnln

            If (i-n==iobj) Then
              Write (rec,99994) istate(i), xs(i), clamda(i)
              Call x04baf(nout,rec)
            Else
              Write (rec,99997) j, istate(i), xs(i), clamda(i)
              Call x04baf(nout,rec)
            End If

          End Do

        End If

        Write (rec,'()')
        Call x04baf(nout,rec)
        Write (rec,'()')
        Call x04baf(nout,rec)
        Write (rec,99992) obj
        Call x04baf(nout,rec)
      End Select

100   Continue

99999 Format (1X,'Variable',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99998 Format (1X,'Varble',1X,I2,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99997 Format (1X,'LinCon',1X,I2,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99996 Format (1X,'Constrnt',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99995 Format (1X,'NlnCon',1X,I2,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99994 Format (1X,'Free Row',2X,I3,4X,1P,G14.6,2X,1P,G12.4)
99993 Format (1X,'DummyRow',2X,I3,4X,1P,G14.6,2X,1P,G12.4)
99992 Format (1X,'Final objective value = ',1P,G15.7)
99991 Format (1X,A,I5)
99990 Format (1X,A)
    End Program e04uhae