! E04NRF Example Program Text ! Mark 23 Release. NAG Copyright 2011. 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.) ! .. Implicit None Statement .. IMPLICIT NONE ! .. 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 Functions .. 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) 20 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