! E04WEF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE e04wefe_mod ! E04WEF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: leniw = 600, lenrw = 600, & nin = 5, ninopt = 7, nout = 6 CONTAINS SUBROUTINE objfun(mode,n,x,objf,grad,nstate,iuser,ruser) ! Routine to evaluate objective function and its 1st derivatives. ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: objf INTEGER, INTENT (INOUT) :: mode INTEGER, INTENT (IN) :: n, nstate ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (INOUT) :: grad(n), ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Executable Statements .. IF (mode==0 .OR. mode==2) THEN objf = x(1)*x(4)*(x(1)+x(2)+x(3)) + x(3) END IF IF (mode==1 .OR. mode==2) THEN grad(1) = x(4)*(2.0E0_nag_wp*x(1)+x(2)+x(3)) grad(2) = x(1)*x(4) grad(3) = x(1)*x(4) + 1.0E0_nag_wp grad(4) = x(1)*(x(1)+x(2)+x(3)) END IF RETURN END SUBROUTINE objfun SUBROUTINE confun(mode,ncnln,n,ldcj,needc,x,ccon,cjac,nstate,iuser, & ruser) ! Routine to evaluate the nonlinear constraints and their 1st ! derivatives. ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ldcj, n, ncnln, nstate INTEGER, INTENT (INOUT) :: mode ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: ccon(max(1,ncnln)) REAL (KIND=nag_wp), INTENT (INOUT) :: cjac(ldcj,n), ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) INTEGER, INTENT (IN) :: needc(ncnln) ! .. Intrinsic Functions .. INTRINSIC max ! .. Executable Statements .. IF (nstate==1) THEN ! First call to CONFUN. Set all Jacobian elements to zero. ! Note that this will only work when 'Derivative Level = 3' ! (the default; see Section 11.2). cjac(1:ncnln,1:n) = 0.0E0_nag_wp END IF IF (needc(1)>0) THEN IF (mode==0 .OR. mode==2) THEN ccon(1) = x(1)**2 + x(2)**2 + x(3)**2 + x(4)**2 END IF IF (mode==1 .OR. mode==2) THEN cjac(1,1) = 2.0E0_nag_wp*x(1) cjac(1,2) = 2.0E0_nag_wp*x(2) cjac(1,3) = 2.0E0_nag_wp*x(3) cjac(1,4) = 2.0E0_nag_wp*x(4) END IF END IF IF (needc(2)>0) THEN IF (mode==0 .OR. mode==2) THEN ccon(2) = x(1)*x(2)*x(3)*x(4) END IF IF (mode==1 .OR. mode==2) THEN cjac(2,1) = x(2)*x(3)*x(4) cjac(2,2) = x(1)*x(3)*x(4) cjac(2,3) = x(1)*x(2)*x(4) cjac(2,4) = x(1)*x(2)*x(3) END IF END IF RETURN END SUBROUTINE confun END MODULE e04wefe_mod PROGRAM e04wefe ! E04WEF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : e04wcf, e04wdf, e04wef, e04wff, e04wgf, e04whf, & e04wkf, e04wlf, nag_wp, x04acf, x04baf USE e04wefe_mod, ONLY : confun, leniw, lenrw, nin, ninopt, nout, objfun ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. CHARACTER (*), PARAMETER :: fname = 'e04wefe.opt' ! .. Local Scalars .. REAL (KIND=nag_wp) :: bndinf, featol, objf INTEGER :: elmode, i, ifail, lda, ldcj, & ldh, majits, mode, n, nclin, & ncnln, sda, sdcjac CHARACTER (80) :: rec ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: a(:,:), bl(:), bu(:), ccon(:), & cjac(:,:), clamda(:), grad(:), & h(:,:), x(:) REAL (KIND=nag_wp) :: ruser(1), rw(lenrw) INTEGER, ALLOCATABLE :: istate(:) INTEGER :: iuser(1), iw(leniw) ! .. Intrinsic Functions .. INTRINSIC max ! .. Executable Statements .. WRITE (rec,99995) 'E04WEF Example Program Results' CALL x04baf(nout,rec) ! This program demonstrates the use of routines to set and ! get values of optional parameters associated with E04WDF. ! Skip heading in data file READ (nin,*) READ (nin,*) n, nclin, ncnln lda = max(1,nclin) IF (nclin>0) THEN sda = n ELSE sda = 1 END IF ldcj = max(1,ncnln) IF (ncnln>0) THEN sdcjac = n ELSE sdcjac = 1 END IF ldh = n ALLOCATE (istate(n+nclin+ncnln),a(lda,sda),bl(n+nclin+ncnln), & bu(n+nclin+ncnln),ccon(max(1,ncnln)),cjac(ldcj,sdcjac),clamda(n+ & nclin+ncnln),grad(n),h(ldh,n),x(n)) IF (nclin>0) THEN READ (nin,*) (a(i,1:sda),i=1,nclin) END IF READ (nin,*) bl(1:(n+nclin+ncnln)) READ (nin,*) bu(1:(n+nclin+ncnln)) READ (nin,*) x(1:n) ! Call E04WCF to initialise E04WDF. ifail = 0 CALL e04wcf(iw,leniw,rw,lenrw,ifail) ! By default E04WDF does not print monitoring ! information. Set the print file unit or the summary ! file unit to get information. ifail = 0 CALL e04wgf('Print file',nout,iw,rw,ifail) ! Open the options file for reading mode = 0 ifail = 0 CALL x04acf(ninopt,fname,mode,ifail) ! Use E04WEF to read some options from the options file ifail = 0 CALL e04wef(ninopt,iw,rw,ifail) WRITE (rec,'()') CALL x04baf(nout,rec) ! Use E04WKF to find the value of integer-valued option ! 'Elastic mode'. ifail = 0 CALL e04wkf('Elastic mode',elmode,iw,rw,ifail) WRITE (rec,99999) elmode CALL x04baf(nout,rec) ! Use E04WHF to set the value of real-valued option ! 'Infinite bound size'. bndinf = 1.0E10_nag_wp ifail = 0 CALL e04whf('Infinite bound size',bndinf,iw,rw,ifail) ! Use E04WLF to find the value of real-valued option ! 'Feasibility tolerance'. ifail = 0 CALL e04wlf('Feasibility tolerance',featol,iw,rw,ifail) WRITE (rec,99998) featol CALL x04baf(nout,rec) ! Use E04WFF to set the option 'Major iterations limit'. ifail = 0 CALL e04wff('Major iterations limit 50',iw,rw,ifail) ! Solve the problem. ifail = 0 CALL e04wdf(n,nclin,ncnln,lda,ldcj,ldh,a,bl,bu,confun,objfun,majits, & istate,ccon,cjac,clamda,objf,grad,h,x,iw,leniw,rw,lenrw,iuser,ruser, & ifail) WRITE (rec,'()') CALL x04baf(nout,rec) WRITE (rec,99997) objf CALL x04baf(nout,rec) WRITE (rec,99996) (x(i),i=1,n) CALL x04baf(nout,rec) 99999 FORMAT (1X,'Option ''Elastic mode'' has the value ',I3,'.') 99998 FORMAT (1X,'Option ''Feasibility tolerance'' has the value ',1P,E13.5, & '.') 99997 FORMAT (1X,'Final objective value = ',F11.3) 99996 FORMAT (1X,'Optimal X = ',7F9.2) 99995 FORMAT (1X,A) END PROGRAM e04wefe