! E04NLA Example Program Text
! Mark 30.3 Release. nAG Copyright 2024.
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,*)
Read (nin,*) n, m
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 (nin,*) names(1:5)
Read (nin,*) crname(1: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 ).
Read (nin,*) a(i), ha(i), icol
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
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 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