NAG Library Manual, Mark 28.5
```!   E04NLA Example Program Text
!   Mark 28.5 Release. NAG Copyright 2022.

Module e04nlae_mod

!     E04NLA 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                           :: qphx
!     .. Parameters ..
Integer, Parameter, Public       :: iset = 1, lcwsav = 1, liwsav = 380,  &
llwsav = 20, lrwsav = 285, nin = 5,  &
ninopt = 7, nout = 6
Contains
Subroutine qphx(nstate,ncolh,x,hx,iuser,ruser)

!       Routine to compute H*x. (In this version of QPHX, the Hessian
!       matrix H is not referenced explicitly.)

!       .. Scalar Arguments ..
Integer, Intent (In)           :: ncolh, nstate
!       .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: hx(ncolh)
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Real (Kind=nag_wp), Intent (In) :: x(ncolh)
Integer, Intent (Inout)        :: iuser(*)
!       .. Executable Statements ..
If (nstate==1) Then

!         First entry.

Write (nout,*)
Write (nout,99999) ncolh
Flush (nout)
End If

hx(1) = 2.0E0_nag_wp*x(1)
hx(2) = 2.0E0_nag_wp*x(2)
hx(3) = 2.0E0_nag_wp*(x(3)+x(4))
hx(4) = hx(3)
hx(5) = 2.0E0_nag_wp*x(5)
hx(6) = 2.0E0_nag_wp*(x(6)+x(7))
hx(7) = hx(6)

If (nstate>=2) Then

!         Final entry.

Write (nout,*)
Write (nout,99998)
Flush (nout)
End If

Return

99999   Format (1X,'This is the E04NLA example.   NCOLH =',I4,'.')
99998   Format (1X,'Finished the E04NLA example.')
End Subroutine qphx
End Module e04nlae_mod
Program e04nlae

!     E04NLA Example Main Program

!     .. Use Statements ..
Use e04nlae_mod, Only: iset, lcwsav, liwsav, llwsav, lrwsav, nin,        &
ninopt, nout, qphx
Use nag_library, Only: e04nka, e04nla, e04nma, e04wbf, nag_wp, x04abf,   &
x04acf
!     .. Implicit None Statement ..
Implicit None
!     .. Parameters ..
Character (*), Parameter         :: fname = 'e04nlae.opt'
!     .. Local Scalars ..
Real (Kind=nag_wp)               :: obj, sinf
Integer                          :: i, icol, ifail, inform, iobj, jcol,  &
leniz, lenz, m, miniz, minz, mode,   &
n, ncolh, ninf, nname, nnz, ns,      &
outchn
Character (1)                    :: start
!     .. Local Arrays ..
Real (Kind=nag_wp), Allocatable  :: a(:), bl(:), bu(:), clamda(:),       &
xs(:), z(:)
Real (Kind=nag_wp)               :: ruser(1), rwsav(lrwsav)
Integer, Allocatable             :: ha(:), istate(:), iz(:), ka(:)
Integer                          :: iuser(1), iwsav(liwsav)
Logical                          :: lwsav(llwsav)
Character (8), Allocatable       :: crname(:)
Character (80)                   :: cwsav(lcwsav)
Character (8)                    :: names(5)
!     .. Executable Statements ..
Write (nout,99992) 'E04NLA Example Program Results'
Flush (nout)

!     Skip heading in data file.

Read (nin,*) nnz, iobj, ncolh, start, nname

Allocate (ha(nnz),ka(n+1),istate(n+m),a(nnz),bl(n+m),bu(n+m),xs(n+m),    &
clamda(n+m),crname(nname))

!     Read the matrix A from data file. Set up KA.

jcol = 1
ka(jcol) = 1

Do i = 1, nnz

!       Element ( HA( I ), ICOL ) is stored in A( I ).

If (icol<jcol) Then

!         Elements not ordered by increasing column index.

Write (nout,*)
Write (nout,99998) 'Element in column', icol,                        &
' found after element in column', jcol, '. Problem', ' abandoned.'
Flush (nout)
Go To 100
Else If (icol==jcol+1) Then

!         Index in A of the start of the ICOL-th column equals I.

ka(icol) = i
jcol = icol
Else If (icol>jcol+1) Then

!         Index in A of the start of the ICOL-th column equals I,
!         but columns JCOL+1,JCOL+2,...,ICOL-1 are empty. Set the
!         corresponding elements of KA to I.

ka((jcol+1):icol) = i
jcol = icol
End If

End Do

ka(n+1) = nnz + 1

!     Columns N,N-1,...,ICOL+1 are empty. Set the corresponding
!     elements of KA accordingly.

Do i = n, icol + 1, -1
ka(i) = ka(i+1)
End Do

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 E04NKA

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

!     Set three options using E04NMF.

Call e04nma(' Check Frequency = 10 ',lwsav,iwsav,rwsav,inform)

If (inform==0) Then

Call e04nma(' Crash Tolerance = 0.05 ',lwsav,iwsav,rwsav,inform)

If (inform==0) Then

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

End If

End If

If (inform/=0) Then
Write (nout,99999) 'E04NMA terminated with INFORM = ', inform
Flush (nout)
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 e04nla(ninopt,lwsav,iwsav,rwsav,inform)

If (inform/=0) Then
Write (nout,99999) 'E04NLA terminated with INFORM = ', inform
Flush (nout)
Go To 100
End If

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

leniz = 1
lenz = 1
Allocate (iz(leniz),z(lenz))

ifail = 1
Call e04nka(n,m,nnz,iobj,ncolh,qphx,a,ha,ka,bl,bu,start,names,nname,     &
crname,ns,xs,istate,miniz,minz,ninf,sinf,obj,clamda,iz,leniz,z,lenz,   &
iuser,ruser,lwsav,iwsav,rwsav,ifail)

If (ifail/=0 .And. ifail/=12 .And. ifail/=13) Then
Write (nout,99999) 'Query call to E04NKA failed with IFAIL =', ifail
Go To 100
End If

Deallocate (iz,z)

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

ifail = -1
Call e04nka(n,m,nnz,iobj,ncolh,qphx,a,ha,ka,bl,bu,start,names,nname,     &
crname,ns,xs,istate,miniz,minz,ninf,sinf,obj,clamda,iz,leniz,z,lenz,   &
iuser,ruser,lwsav,iwsav,rwsav,ifail)

Select Case (ifail)
Case (0:6,8:)
Write (nout,*)
Write (nout,99997)
Write (nout,*)
Flush (nout)

Do i = 1, n
Write (nout,99996) crname(i), istate(i), xs(i), clamda(i)
Flush (nout)
End Do

If (m>0) Then
Write (nout,*)
Write (nout,*)
Write (nout,99995)
Write (nout,'()')

Do i = n + 1, n + m
Write (nout,99994) crname(i), istate(i), xs(i), clamda(i)
End Do
Flush (nout)

End If

Write (nout,*)
Write (nout,*)
Write (nout,99993) obj
Flush (nout)
End Select

100   Continue

99999 Format (1X,A,I5)
99998 Format (1X,A,I5,A,I5,A,A)
99997 Format (1X,'Variable',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99996 Format (1X,1X,A,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99995 Format (1X,'Constrnt',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99994 Format (1X,1X,A,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99993 Format (1X,'Final objective value = ',G15.7)
99992 Format (1X,A)
End Program e04nlae
```