! E04UHA Example Program Text ! Mark 24 Release. NAG Copyright 2012. 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 ! .. Parameters .. Integer, Parameter :: 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 nag_library, Only: e04uga, e04ugm, e04uha, e04uja, e04wbf, nag_wp, & x04abf, x04acf, x04baf Use e04uhae_mod, Only: iset, lcwsav, liwsav, llwsav, lrwsav, nin, & ninopt, nout, objfun ! .. 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