! E04NRF Example Program Text ! Mark 24 Release. NAG Copyright 2012. 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 ! .. Parameters .. Integer, Parameter :: 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 nag_library, Only: e04npf, e04nqf, e04nrf, e04nsf, e04ntf, e04nuf, & e04nxf, e04nyf, nag_wp, x04acf, x04baf Use e04nrfe_mod, Only: lencw, leniw, lenrw, nin, ninopt, nout, qphx ! .. 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 Character (8) :: prob Character (80) :: rec 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 (rec,99994) 'E04NRF Example Program Results' Call x04baf(nout,rec) ! 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 (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 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 = ' ' ! Call E04NPF to initialise E04NQF. ifail = 0 Call e04npf(cw,lencw,iw,leniw,rw,lenrw,ifail) ! 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) ! 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 (rec,'()') Call x04baf(nout,rec) ! Use E04NXF to find the value of integer-valued option ! 'Elastic mode'. ifail = 0 Call e04nxf('Elastic mode',elmode,cw,iw,rw,ifail) Write (rec,99998) elmode Call x04baf(nout,rec) ! 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 (rec,99997) featol Call x04baf(nout,rec) ! 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 (rec,'()') Call x04baf(nout,rec) Write (rec,99996) obj Call x04baf(nout,rec) Write (rec,99995) x(1:n) Call x04baf(nout,rec) 100 Continue 99999 Format (1X,A,I5,A,I5,A,A) 99998 Format (1X,'Option ''Elastic mode'' has the value ',I3,'.') 99997 Format (1X,'Option ''Feasibility tolerance'' has the value ',1P,E13.5, & '.') 99996 Format (1X,'Final objective value = ',1P,E11.3) 99995 Format (1X,'Optimal X = ',7F9.2) 99994 Format (1X,A) End Program e04nrfe