NAG Library Manual, Mark 27.2
```!   E04UHA Example Program Text
!   Mark 27.2 Release. NAG Copyright 2021.

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

!       .. 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.
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))

!     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

If (start=='C') Then
Else If (start=='W') Then
End If

!     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
```