! E05SBF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE e05sbfe_mod ! E05SBF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. REAL (KIND=nag_wp), PARAMETER :: & f_target_c = -731.70709230672696_nag_wp REAL (KIND=nag_wp), PARAMETER :: & f_target_u = -837.9657745448674_nag_wp REAL (KIND=nag_wp), PARAMETER :: & x_target = -420.9687463599820_nag_wp REAL (KIND=nag_wp), PARAMETER :: zero = 0.0_nag_wp INTEGER, PARAMETER :: detail_level = 0, liopts = 100, & liuser = 1, lopts = 100, & lruser = 1, ncon = 3, ndim = 2, & nout = 6, npar = 20, & report_freq = 100 REAL (KIND=nag_wp), PARAMETER :: & c_scale(ncon) = (/ 2490.0_nag_wp, & 750000.0_nag_wp, 0.1_nag_wp/) REAL (KIND=nag_wp), PARAMETER :: c_target_c(ncon) = (/ zero, & zero, zero/) REAL (KIND=nag_wp), PARAMETER :: c_target_u(ncon) = (/ zero, & 31644.05623568455_nag_wp, & 0.07574889943398055_nag_wp/) REAL (KIND=nag_wp), PARAMETER :: & x_target_c(ndim) = (/ -394.1470221120988_nag_wp, & -433.48214189947606_nag_wp/) REAL (KIND=nag_wp), PARAMETER :: x_target_u(ndim) = (/ x_target, & x_target/) CONTAINS SUBROUTINE objfun_schwefel(mode,ndim,x,objf,vecout,nstate,iuser,ruser) ! Objfun routine for the Schwefel function for E05SBF. ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (INOUT) :: objf INTEGER, INTENT (INOUT) :: mode INTEGER, INTENT (IN) :: ndim, nstate ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (INOUT) :: ruser(*), vecout(ndim) REAL (KIND=nag_wp), INTENT (IN) :: x(ndim) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Local Scalars .. LOGICAL :: evalobjf, evalobjg ! .. Intrinsic Functions .. INTRINSIC abs, cos, sin, sqrt, sum ! .. Executable Statements .. ! Test NSTATE to indicate what stage of computation has been reached. SELECT CASE (nstate) CASE (2) ! OBJFUN is called for the very first time. CASE (1) ! OBJFUN is called on entry to a NAG local minimizer. CASE (0) ! This will be the normal value of NSTATE. END SELECT ! Test MODE to determine whether to calculate OBJF and/or OBJGRD. evalobjf = .FALSE. evalobjg = .FALSE. SELECT CASE (mode) CASE (0,5) ! Only the value of the objective function is needed. evalobjf = .TRUE. CASE (1,6) ! Only the values of the NDIM gradients are required. evalobjg = .TRUE. CASE (2,7) ! Both the objective function and the NDIM gradients are required. evalobjf = .TRUE. evalobjg = .TRUE. END SELECT IF (evalobjf) THEN ! Evaluate the objective function. objf = sum(x(1:ndim)*sin(sqrt(abs(x(1:ndim))))) END IF IF (evalobjg) THEN ! Calculate the gradient of the objective function. vecout = sqrt(abs(x)) vecout = sin(vecout) + 0.5E0_nag_wp*vecout*cos(vecout) END IF RETURN END SUBROUTINE objfun_schwefel SUBROUTINE confun_non_linear(mode,ncon,ndim,ldcj,needc,x,c,cjac,nstate, & iuser,ruser) ! Subroutine used to supply constraints ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ldcj, ncon, ndim, nstate INTEGER, INTENT (INOUT) :: mode ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: c(ncon) REAL (KIND=nag_wp), INTENT (INOUT) :: cjac(ldcj,ndim), ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(ndim) INTEGER, INTENT (INOUT) :: iuser(*) INTEGER, INTENT (IN) :: needc(ncon) ! .. Local Scalars .. INTEGER :: k LOGICAL :: evalc, evalcjac ! .. Intrinsic Functions .. INTRINSIC cos ! .. Executable Statements .. ! Test NSTATE to determine whether the local minimizer is being called ! for the first time from a new start point IF (nstate==1) THEN ! Set any constant elements of the Jacobian matrix. cjac(1,1) = 3.0_nag_wp cjac(1,2) = -2.0_nag_wp END IF ! MODE: are constraints, derivatives, or both are required? evalc = mode == 0 .OR. mode == 2 evalcjac = mode == 1 .OR. mode == 2 LOOP_CONSTRAINTS: DO k = 1, ncon ! Only those for which needc is non-zero need be set. IF (needc(k)<=0) THEN CYCLE LOOP_CONSTRAINTS END IF IF (evalc) THEN ! Constraint values are required. SELECT CASE (k) CASE (1) c(k) = 3.0_nag_wp*x(1) - 2.0_nag_wp*x(2) CASE (2) c(k) = x(1)**2 - x(2)**2 + 3.0_nag_wp*x(1)*x(2) CASE (3) c(k) = cos((x(1)/200.0_nag_wp)**2+(x(2)/100.0_nag_wp)) CASE DEFAULT c(k) = zero END SELECT END IF IF (evalcjac) THEN ! Constraint derivatives (CJAC) are required. SELECT CASE (k) CASE (1) ! Constant derivatives set when NSTATE=1 remain throughout ! the local minimization. CONTINUE CASE (2) ! If the constraint derivatives are known and are readily ! calculated, populate CJAC when required. cjac(k,1) = 2.0_nag_wp*x(1) + 3.0_nag_wp*x(2) cjac(k,2) = -2.0_nag_wp*x(2) + 3.0_nag_wp*x(1) CASE DEFAULT ! Any elements of CJAC left unaltered will be approximated ! using finite differences when required. CONTINUE END SELECT END IF END DO LOOP_CONSTRAINTS ! If an immediate exit is required, return MODE<0 mode = 0 RETURN END SUBROUTINE confun_non_linear SUBROUTINE monmod(ndim,ncon,npar,x,xb,fb,cb,xbest,fbest,cbest,itt, & iuser,ruser,inform) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: fb INTEGER, INTENT (INOUT) :: inform INTEGER, INTENT (IN) :: ncon, ndim, npar ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: cb(ncon), cbest(ncon,npar), & fbest(npar), xb(ndim), & xbest(ndim,npar) REAL (KIND=nag_wp), INTENT (INOUT) :: ruser(*), x(ndim,npar) INTEGER, INTENT (IN) :: itt(7) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Local Scalars .. INTEGER :: k ! .. Intrinsic Functions .. INTRINSIC modulo ! .. Executable Statements .. IF (detail_level>=2) THEN ! Report on the first iteration, and every report_freq iterations. IF (itt(1)==1 .OR. modulo(itt(1),report_freq)==0) THEN WRITE (nout,*) WRITE (nout,*) '* Current global optimum candidate:' DO k = 1, ndim WRITE (nout,99999) k, xb(k) END DO WRITE (nout,*) '* Current global optimum value:' WRITE (nout,99998) fb WRITE (nout,99997) DO k = 1, ncon WRITE (nout,99996) k, cb(k) END DO END IF END IF ! If required set INFORM<0 to force exit inform = 0 RETURN 99999 FORMAT (1X,'* xb(',I3,') = ',F9.2) 99998 FORMAT (1X,'* fb = ',F9.5) 99997 FORMAT ('** Current global optimum constraint violations **') 99996 FORMAT (1X,'* cb(',I3,') = ',F9.2) END SUBROUTINE monmod SUBROUTINE display_option(optstr,optype,ivalue,rvalue,cvalue) ! Subroutine to query optype and print the appropriate option values ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: rvalue INTEGER, INTENT (IN) :: ivalue, optype CHARACTER (*), INTENT (IN) :: cvalue, optstr ! .. Executable Statements .. SELECT CASE (optype) CASE (1) WRITE (nout,99999) optstr, ivalue CASE (2) WRITE (nout,99998) optstr, rvalue CASE (3) WRITE (nout,99997) optstr, cvalue CASE (4) WRITE (nout,99996) optstr, ivalue, cvalue CASE (5) WRITE (nout,99995) optstr, rvalue, cvalue CASE DEFAULT END SELECT FLUSH (nout) RETURN 99999 FORMAT (3X,A39,' : ',I13) 99998 FORMAT (3X,A39,' : ',F13.4) 99997 FORMAT (3X,A39,' : ',16X,A16) 99996 FORMAT (3X,A39,' : ',I13,3X,A16) 99995 FORMAT (3X,A39,' : ',F13.4,3X,A16) END SUBROUTINE display_option SUBROUTINE display_result(ndim,ncon,xb,fb,cb,itt,inform) ! Display final results in comparison to known global optimum. ! .. Use Statements .. USE nag_library, ONLY : x04cbf ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: indent = 1, ncols = 79 CHARACTER (11), PARAMETER :: clabs(1:6) = (/ & 'x_target_u ', & 'x_target_c ', & 'xb ', & 'c_target_u ', & 'c_target_c ', & 'cb ' /) CHARACTER (1), PARAMETER :: diag = 'D', labcol = & 'C', labrow = 'I', & matrix = 'G' CHARACTER (5), PARAMETER :: fmtc = 'f12.5', fmtx = 'f12.2' ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: fb INTEGER, INTENT (IN) :: inform, ncon, ndim ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: cb(ncon), xb(ndim) INTEGER, INTENT (IN) :: itt(7) ! .. Local Scalars .. INTEGER :: ifail, ldcom CHARACTER (ncols) :: titlec, titlex ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: ccom(:,:), xcom(:,:) ! .. Executable Statements .. ! Display final counters. WRITE (nout,*) ' Algorithm Statistics' WRITE (nout,*) ' --------------------' WRITE (nout,99994) 'Total complete iterations ', & itt(1) WRITE (nout,99994) 'Complete iterations since improvement ', & itt(2) WRITE (nout,99994) 'Total particles converged to xb ', & itt(3) WRITE (nout,99994) 'Total improvements to global optimum ', & itt(4) WRITE (nout,99994) 'Total function evaluations ', & itt(5) WRITE (nout,99994) 'Total particles re-initialized ', & itt(6) WRITE (nout,99994) 'Total constraints violated ', & itt(7) ! Display why finalization occurred. WRITE (nout,*) SELECT CASE (inform) CASE (1) WRITE (nout,99999) 'Target value achieved' CASE (2) WRITE (nout,99999) 'Minimum swarm standard deviation obtained' CASE (3) WRITE (nout,99999) 'Sufficient particles converged' CASE (4) WRITE (nout,99999) 'No improvement in preset iteration limit' CASE (5) WRITE (nout,99999) 'Maximum complete iterations attained' CASE (6) WRITE (nout,99999) 'Maximum function evaluations exceeded' CASE (7) WRITE (nout,99999) 'Constrained point located' CASE (:-1) WRITE (nout,99998) inform CASE DEFAULT END SELECT ! Display final objective value and location. WRITE (nout,*) WRITE (nout,99997) f_target_u WRITE (nout,99996) f_target_c WRITE (nout,99995) fb FLUSH (nout) ldcom = ndim ALLOCATE (xcom(ldcom,3)) xcom(1:ndim,1) = x_target_u(1:ndim) xcom(1:ndim,2) = x_target_c(1:ndim) xcom(1:ndim,3) = xb(1:ndim) WRITE (nout,*) titlex = 'Comparison between known and achieved optima.' ifail = 0 CALL x04cbf(matrix,diag,ndim,3,xcom,ldcom,fmtx,titlex,labrow,clabs, & labcol,clabs,ncols,indent,ifail) DEALLOCATE (xcom) IF (ncon>0) THEN ldcom = ncon ALLOCATE (ccom(ldcom,3)) ccom(1:ncon,1) = c_target_u(1:ncon)/c_scale(1:ncon) ccom(1:ncon,2) = c_target_c(1:ncon)/c_scale(1:ncon) ccom(1:ncon,3) = cb(1:ncon)/c_scale(1:ncon) WRITE (nout,*) FLUSH (nout) titlec = 'Comparison between scaled constraint violations.' ifail = 0 CALL x04cbf(matrix,diag,ncon,3,ccom,ldcom,fmtc,titlec,labrow, & clabs,labcol,clabs(4:6),ncols,indent,ifail) DEALLOCATE (ccom) END IF WRITE (nout,*) RETURN 99999 FORMAT (2X,'Solution Status : ',A38) 99998 FORMAT (' User termination case : ',I13) 99997 FORMAT (' Known unconstrained objective minimum : ',F13.3) 99996 FORMAT (' Best Known constrained objective minimum : ',F13.3) 99995 FORMAT (' Achieved objective value : ',F13.3) 99994 FORMAT (2X,A40,' :',I13) END SUBROUTINE display_result END MODULE e05sbfe_mod PROGRAM e05sbfe ! E05SBF Example Main Program ! This example program demonstrates how to use E05SBF in standard ! execution, and with E04UCF as a coupled local minimizer. ! The non-default option 'REPEATABILITY ON' is used here, giving ! repeatable results. ! .. Use Statements .. USE nag_library, ONLY : e05sbf, e05zkf, e05zlf USE e05sbfe_mod, ONLY : confun_non_linear, display_option, & display_result, f_target_c, liopts, liuser, & lopts, lruser, monmod, nag_wp, ncon, ndim, & nout, npar, objfun_schwefel, zero ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. REAL (KIND=nag_wp) :: fb, rvalue INTEGER :: ifail, inform, ivalue, optype CHARACTER (16) :: cvalue CHARACTER (80) :: optstr ! .. Local Arrays .. REAL (KIND=nag_wp) :: bl(ndim+ncon), bu(ndim+ncon), & cb(ncon), cbest(ncon,npar), & fbest(ndim,npar), opts(lopts), & ruser(lruser), xb(ndim), & xbest(ndim,npar) INTEGER :: iopts(liopts), itt(7), & iuser(liuser) ! .. Executable Statements .. ! Print advisory information. WRITE (nout,*) 'E05SBF Example Program Results' WRITE (nout,*) WRITE (nout,*) 'Minimization of the Schwefel function.' WRITE (nout,*) 'Subject to one linear and two nonlinear constraints.' WRITE (nout,*) xbest = zero fbest = zero cbest = zero ! Set problem specific values. ! Set box bounds. bl(1:ndim) = -500.0_nag_wp bu(1:ndim) = 500.0_nag_wp ! Set constraint bounds. bl((ndim+1):(ndim+ncon)) = (/ -1.0E6_nag_wp, -1.0_nag_wp, -0.9_nag_wp/) bu((ndim+1):(ndim+ncon)) = (/ 10.0_nag_wp, 5.0E5_nag_wp, 0.9_nag_wp/) ! Initialize the option arrays for E05SBF. ifail = 0 CALL e05zkf('Initialize = E05SBF',iopts,liopts,opts,lopts,ifail) ! Query some default option values. WRITE (nout,*) ' Default Option Queries:' WRITE (nout,*) ivalue = 0 rvalue = 0.0_nag_wp ifail = 0 optstr = 'Constraint Norm' CALL e05zlf(optstr,ivalue,rvalue,cvalue,optype,iopts,opts,ifail) CALL display_option(optstr,optype,ivalue,rvalue,cvalue) ifail = 0 optstr = 'Maximum Iterations Completed' CALL e05zlf(optstr,ivalue,rvalue,cvalue,optype,iopts,opts,ifail) CALL display_option(optstr,optype,ivalue,rvalue,cvalue) ifail = 0 optstr = 'Distance Tolerance' CALL e05zlf(optstr,ivalue,rvalue,cvalue,optype,iopts,opts,ifail) CALL display_option(optstr,optype,ivalue,rvalue,cvalue) ! ------------------------------------------------------------------ WRITE (nout,*) WRITE (nout,*) '1. Solution without using coupled local minimizer' WRITE (nout,*) ! Set various options to non-default values if required. ifail = 0 WRITE (optstr,99999) 'Distance Tolerance', rvalue*0.1_nag_wp CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail) ifail = 0 WRITE (optstr,99999) 'Constraint Tolerance', 1.0E-4_nag_wp CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail) ifail = 0 CALL e05zkf('Constraint Norm = Euclidean',iopts,liopts,opts,lopts, & ifail) ifail = 0 CALL e05zkf('Repeatability = On',iopts,liopts,opts,lopts,ifail) ifail = 0 WRITE (optstr,99999) 'Target Objective Value', f_target_c CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail) ifail = 0 WRITE (optstr,99999) 'Target Objective Tolerance', 1.0E-4_nag_wp CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail) ! Call E05SBF to search for the global optimum. ! Non-zero IFAIL expected on exit here, so use IFAIL=1 (quiet) on entry. ifail = 1 CALL e05sbf(ndim,ncon,npar,xb,fb,cb,bl,bu,xbest,fbest,cbest, & objfun_schwefel,confun_non_linear,monmod,iopts,opts,iuser,ruser,itt, & inform,ifail) ! It is essential to test IFAIL on exit. SELECT CASE (ifail) CASE (0,1) ! No errors, best found optimum at xb returned in fb. CALL display_result(ndim,ncon,xb,fb,cb,itt,inform) CASE (3) ! Exit flag set in OBJFUN, CONFUN or MONMOD and returned in INFORM. CALL display_result(ndim,ncon,xb,fb,cb,itt,inform) CASE DEFAULT ! An error was detected. Print message since IFAIL=1 on entry. WRITE (nout,99998) '** E05SBF returned with an error, IFAIL = ', & ifail CONTINUE END SELECT ! ------------------------------------------------------------------ WRITE (nout,*) '2. Solution using coupled local minimizer E04UCF' WRITE (nout,*) ! Set the local minimizer to be E04UCF and set corresponding options. ifail = 0 CALL e05zkf('Local Minimizer = E04UCF',iopts,liopts,opts,lopts,ifail) ifail = 0 CALL e05zkf('Local Interior Major Iterations = 15',iopts,liopts,opts, & lopts,ifail) ifail = 0 CALL e05zkf('Local Interior Minor Iterations = 5',iopts,liopts,opts, & lopts,ifail) ifail = 0 CALL e05zkf('Local Exterior Major Iterations = 50',iopts,liopts,opts, & lopts,ifail) ifail = 0 CALL e05zkf('Local Exterior Minor Iterations = 15',iopts,liopts,opts, & lopts,ifail) ! Query the option Distance Tolerance ifail = 0 optstr = 'Distance Tolerance' CALL e05zlf(optstr,ivalue,rvalue,cvalue,optype,iopts,opts,ifail) ! Adjust Distance Tolerance dependent upon its current value WRITE (optstr,99999) 'Distance Tolerance', rvalue*10.0_nag_wp ifail = 0 CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail) ifail = 0 WRITE (optstr,99999) 'Local Interior Tolerance', rvalue CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail) ifail = 0 WRITE (optstr,99999) 'Local Exterior Tolerance', rvalue*1.0E-4_nag_wp CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail) ! Call E05SBF to search for the global optimum. ifail = 1 CALL e05sbf(ndim,ncon,npar,xb,fb,cb,bl,bu,xbest,fbest,cbest, & objfun_schwefel,confun_non_linear,monmod,iopts,opts,iuser,ruser,itt, & inform,ifail) ! It is essential to test IFAIL on exit. SELECT CASE (ifail) CASE (0,1) ! E05SBF encountered no errors during operation, ! and will have returned the best found optimum. CALL display_result(ndim,ncon,xb,fb,cb,itt,inform) CASE (3) ! Exit flag set in OBJFUN, CONFUN or MONMOD and returned in INFORM. CALL display_result(ndim,ncon,xb,fb,cb,itt,inform) CASE DEFAULT ! An error was detected. Print message since IFAIL=1 on entry. WRITE (nout,99998) '** E05SBF returned with an error, IFAIL = ', & ifail CONTINUE END SELECT 99999 FORMAT (A,' = ',E32.16) 99998 FORMAT (1X,A,I6) END PROGRAM e05sbfe