! E04UHA Example Program Text
! Mark 30.1 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