! E04NQF Example Program Text ! Mark 24 Release. NAG Copyright 2012. Module e04nqfe_mod ! E04NQF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. Use nag_library, Only: nag_wp ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Integer, Parameter :: lencw = 600, leniw = 600, & lenrw = 600, nin = 5, 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 e04nqfe_mod Program e04nqfe ! E04NQF Example Main Program ! .. Use Statements .. Use nag_library, Only: e04npf, e04nqf, e04ntf, nag_wp Use e04nqfe_mod, Only: lencw, leniw, lenrw, nin, nout, qphx ! .. Implicit None Statement .. Implicit None ! .. Local Scalars .. Real (Kind=nag_wp) :: obj, objadd, sinf Integer :: i, icol, ifail, iobj, jcol, & lenc, m, n, ncolh, ne, ninf, & nname, ns 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,*) 'E04NQF Example Program Results' Flush (nout) ! 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 (icoljcol+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 ! 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 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) ! Call E04NPF to initialise E04NQF. ifail = 0 Call e04npf(cw,lencw,iw,leniw,rw,lenrw,ifail) ! By default E04NQF does not print monitoring ! information. Set the print file unit or the summary ! file unit to get information. ifail = 0 Call e04ntf('Print file',nout,cw,iw,rw,ifail) ! 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 = ' ' ! Do not allow any elastic variables (i.e. they cannot be ! infeasible). If we'd set optional argument "Elastic mode" to 0, ! we wouldn't need to set the individual elements of array HELAST. helast(1:(n+m)) = 0 ! 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,99998) obj Write (nout,99997) x(1:n) 100 Continue 99999 Format (1X,A,I5,A,I5,A,A) 99998 Format (1X,'Final objective value = ',1P,E11.3) 99997 Format (1X,'Optimal X = ',7F9.2) End Program e04nqfe