! E04NLA Example Program Text ! Mark 24 Release. NAG Copyright 2012. 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 ! .. Parameters .. Integer, Parameter :: 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 nag_library, Only: e04nka, e04nla, e04nma, e04wbf, nag_wp, x04abf, & x04acf Use e04nlae_mod, Only: iset, lcwsav, liwsav, llwsav, lrwsav, nin, & ninopt, nout, qphx ! .. 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 (icoljcol+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