! E04NRF Example Program Text
! Mark 27.0 Release. NAG Copyright 2019.
Module e04nrfe_mod
! E04NRF 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 :: lencw = 600, leniw = 600, &
lenrw = 600, nin = 5, ninopt = 7, &
nout = 6
Contains
Subroutine qphx(ncolh,x,hx,nstate,cuser,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(*)
Character (8), Intent (Inout) :: cuser(*)
! .. Executable Statements ..
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)
Return
End Subroutine qphx
End Module e04nrfe_mod
Program e04nrfe
! E04NRF Example Main Program
! .. Use Statements ..
Use e04nrfe_mod, Only: lencw, leniw, lenrw, nin, ninopt, nout, qphx
Use nag_library, Only: e04npf, e04nqf, e04nrf, e04nsf, e04ntf, e04nuf, &
e04nxf, e04nyf, nag_wp, x04acf
! .. Implicit None Statement ..
Implicit None
! .. Parameters ..
Character (*), Parameter :: fname = 'e04nrfe.opt'
! .. Local Scalars ..
Real (Kind=nag_wp) :: bndinf, featol, obj, objadd, sinf
Integer :: elmode, i, icol, ifail, iobj, jcol, &
lenc, m, mode, n, ncolh, ne, ninf, &
nname, ns
Logical :: verbose_output
Character (8) :: prob
Character (1) :: start
! .. Local Arrays ..
Real (Kind=nag_wp), Allocatable :: acol(:), bl(:), bu(:), c(:), pi(:), &
rc(:), x(:)
Real (Kind=nag_wp) :: ruser(1), rw(lenrw)
Integer, Allocatable :: helast(:), hs(:), inda(:), loca(:)
Integer :: iuser(1), iw(leniw)
Character (8) :: cuser(1), cw(lencw)
Character (8), Allocatable :: names(:)
! .. Intrinsic Procedures ..
Intrinsic :: max
! .. Executable Statements ..
Write (nout,*) 'E04NRF Example Program Results'
! This program demonstrates the use of routines to set and
! get values of optional parameters associated with E04NQF.
! Skip heading in data file.
Read (nin,*)
Read (nin,*) n, m
Read (nin,*) ne, iobj, ncolh, start, nname
Allocate (inda(ne),loca(n+1),helast(n+m),hs(n+m),acol(ne),bl(n+m), &
bu(n+m),x(n+m),pi(m),rc(n+m),names(nname))
Read (nin,*) names(1:nname)
! Read the matrix ACOL from data file. Set up LOCA.
jcol = 1
loca(jcol) = 1
Do i = 1, ne
! Element ( INDA( I ), ICOL ) is stored in ACOL( I ).
Read (nin,*) acol(i), inda(i), icol
If (icol<jcol) Then
! Elements not ordered by increasing column index.
Write (nout,99999) 'Element in column', icol, &
' found after element in column', jcol, '. Problem', ' abandoned.'
Go To 100
Else If (icol==jcol+1) Then
! Index in ACOL of the start of the ICOL-th column equals I.
loca(icol) = i
jcol = icol
Else If (icol>jcol+1) Then
! Index in ACOL 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 LOCA to I.
loca((jcol+1):icol) = i
jcol = icol
End If
End Do
loca(n+1) = ne + 1
If (n>icol) Then
! Columns N,N-1,...,ICOL+1 are empty. Set the corresponding
! elements of LOCA accordingly.
Do i = n, icol + 1, -1
loca(i) = loca(i+1)
End Do
End If
Read (nin,*) bl(1:(n+m))
Read (nin,*) bu(1:(n+m))
If (start=='C') Then
Read (nin,*) hs(1:n)
Else If (start=='W') Then
Read (nin,*) hs(1:(n+m))
End If
Read (nin,*) x(1:n)
! We have no explicit objective vector so set LENC = 0; the
! objective vector is stored in row IOBJ of ACOL.
lenc = 0
Allocate (c(max(1,lenc)))
objadd = 0.0E0_nag_wp
prob = ' '
Write (nout,99998) n, m
! Call E04NPF to initialize E04NQF.
ifail = 0
Call e04npf(cw,lencw,iw,leniw,rw,lenrw,ifail)
! Set this to .True. to cause e04nqf to produce intermediate
! progress output
verbose_output = .False.
If (verbose_output) Then
! By default E04NQF does not print monitoring information.
! Use E04NTF to set the integer-valued option 'Print file'
! unit number to get information.
ifail = 0
Call e04ntf('Print file',nout,cw,iw,rw,ifail)
End If
! Open the options file for reading
mode = 0
ifail = 0
Call x04acf(ninopt,fname,mode,ifail)
! Use E04NRF to read the options file for the remaining
! options
ifail = 0
Call e04nrf(ninopt,cw,iw,rw,ifail)
Write (nout,*)
! Use E04NXF to find the value of integer-valued option
! 'Elastic mode'.
ifail = 0
Call e04nxf('Elastic mode',elmode,cw,iw,rw,ifail)
Write (nout,99997) elmode
! If Elastic Mode is nonzero, set HELAST.
If (elmode/=0) Then
helast(1:(n+m)) = 0
End If
! Use E04NUF to set the value of real-valued option
! 'Infinite bound size'.
bndinf = 1.0E10_nag_wp
ifail = 0
Call e04nuf('Infinite bound size',bndinf,cw,iw,rw,ifail)
! Use E04NYF to find the value of real-valued option
! 'Feasibility tolerance'.
ifail = 0
Call e04nyf('Feasibility tolerance',featol,cw,iw,rw,ifail)
Write (nout,99996) featol
! Use E04NSF to set the option 'Iterations limit'.
ifail = 0
Call e04nsf('Iterations limit 50',cw,iw,rw,ifail)
! Solve the QP problem.
ifail = 0
Call e04nqf(start,qphx,m,n,ne,nname,lenc,ncolh,iobj,objadd,prob,acol, &
inda,loca,bl,bu,c,names,helast,hs,x,pi,rc,ns,ninf,sinf,obj,cw,lencw, &
iw,leniw,rw,lenrw,cuser,iuser,ruser,ifail)
Write (nout,*)
Write (nout,99995) obj
Write (nout,99994) x(1:n)
100 Continue
99999 Format (1X,A,I5,A,I5,A,A)
99998 Format (1X,/,1X,'QP problem contains ',I3,' variables and ',I3, &
' linear constraints')
99997 Format (1X,'Option ''Elastic mode'' has the value ',I3,'.')
99996 Format (1X,'Option ''Feasibility tolerance'' has the value ',1P,E11.3, &
'.')
99995 Format (1X,'Final objective value = ',1P,E11.3)
99994 Format (1X,'Optimal X = ',7F9.2)
End Program e04nrfe