!   E05SAF Example Program Text
!   Mark 23 Release. NAG Copyright 2011.

    MODULE e05safe_mod

!      E05SAF 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 = -837.9657745448674_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, ndim = 2, nout = 6,  &
                                              npar = 5, report_freq = 100
       REAL (KIND=nag_wp), PARAMETER       ::                                  &
                                     x_target(ndim) = -420.9687463599820_nag_wp
    CONTAINS
!dec$ attributes offload : mic :: objfun_schwefel
       SUBROUTINE objfun_schwefel(mode,ndim,x,objf,vecout,nstate,iuser,ruser)
!         Objfun routine for the Schwefel function for E05SAF.

!         .. 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 DEFAULT
!         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, 
!            and return the result in VECOUT.
             vecout = sqrt(abs(x))
             vecout = sin(vecout) + 0.5E0_nag_wp*vecout*cos(vecout)
          END IF

          RETURN

!dec$ attributes offload : mic :: objfun_schwefel
       END SUBROUTINE objfun_schwefel
!dec$ attributes offload : mic :: monmod
       SUBROUTINE monmod(ndim,npar,x,xb,fb,xbest,fbest,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)                :: ndim, npar
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (IN)     :: fbest(npar), xb(ndim),        &
                                                 xbest(ndim,npar)
          REAL (KIND=nag_wp), INTENT (INOUT)  :: ruser(*), x(ndim,npar)
          INTEGER, INTENT (IN)                :: itt(6)
          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
             END IF
          END IF

!         If required set INFORM<0 to force exit
          inform = 0
          FLUSH (nout)

          RETURN
99999     FORMAT (1X,'* xb(',I3,') = ',F9.2)
99998     FORMAT (1X,'* fb = ',F9.5)

!dec$ attributes offload : mic :: monmod
       END SUBROUTINE monmod
!dec$ attributes offload : mic :: display_option
       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,A36,' : ',I13)
99998     FORMAT (3X,A36,' : ',F13.4)
99997     FORMAT (3X,A36,' : ',16X,A16)
99996     FORMAT (3X,A36,' : ',I13,3X,A16)
99995     FORMAT (3X,A36,' : ',F13.4,3X,A16)
!dec$ attributes offload : mic :: display_option
       END SUBROUTINE display_option

!dec$ attributes offload : mic :: display_result
       SUBROUTINE display_result(ndim,xb,fb,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 (10), PARAMETER           :: clabs(1:2) = (/               &
                                                 'x_target  ',  'xb        '  /)
          CHARACTER (1), PARAMETER            :: diag =   'N',  labcol =       &
                                                 'C',  labrow =   'I',         &
                                                 matrix =   'G'
          CHARACTER (5), PARAMETER            :: form = 'F12.2'
!         .. Scalar Arguments ..
          REAL (KIND=nag_wp), INTENT (IN)     :: fb
          INTEGER, INTENT (IN)                :: inform, ndim
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (IN)     :: xb(ndim)
          INTEGER, INTENT (IN)                :: itt(6)
!         .. Local Scalars ..
          INTEGER                             :: ifail, ldxcom
          CHARACTER (ncols)                   :: title
!         .. Local Arrays ..
          REAL (KIND=nag_wp), ALLOCATABLE     :: xcom(:,:)
!         .. Executable Statements ..
!         Display final counters.
          WRITE (nout,*) ' Algorithm Statistics'
          WRITE (nout,*) ' --------------------'
          WRITE (nout,99997) 'Total complete iterations             : ', &
             itt(1)
          WRITE (nout,99997) 'Complete iterations since improvement : ', &
             itt(2)
          WRITE (nout,99997) 'Total particles converged to xb       : ', &
             itt(3)
          WRITE (nout,99997) 'Total improvements to global optimum  : ', &
             itt(4)
          WRITE (nout,99997) 'Total function evaluations            : ', &
             itt(5)
          WRITE (nout,99997) 'Total particles re-initialized        : ', &
             itt(6)

!         Display why finalization occurred.
          WRITE (nout,*)
          SELECT CASE (inform)
          CASE (1)
             WRITE (nout,99996) 'Target value achieved'
          CASE (2)
             WRITE (nout,99996) 'Minimum swarm standard deviation obtained'
          CASE (3)
             WRITE (nout,99996) 'Sufficient particles converged'
          CASE (4)
             WRITE (nout,99996) 'Maximum static iterations attained'
          CASE (5)
             WRITE (nout,99996) 'Maximum complete iterations attained'
          CASE (6)
             WRITE (nout,99996) 'Maximum function evaluations exceeded'
          CASE (:-1)
             WRITE (nout,99995) inform
          CASE DEFAULT
          END SELECT

!         Display final objective value and location.
          WRITE (nout,*)
          WRITE (nout,99999) f_target
          WRITE (nout,99998) fb
          FLUSH (nout)

          ldxcom = ndim
          ALLOCATE (xcom(ldxcom,2))
          xcom(1:ndim,1) = x_target(1:ndim)
          xcom(1:ndim,2) = xb(1:ndim)

          WRITE (nout,*)
          title = 'Comparison between known and achieved optima.'
          ifail = 0
          CALL x04cbf(matrix,diag,ndim,2,xcom,ldxcom,form,title,labrow,clabs, &
             labcol,clabs,ncols,indent,ifail)

          DEALLOCATE (xcom)

          WRITE (nout,*)

          RETURN
99999     FORMAT ('  Known objective optimum ',13X,' : ',F13.5)
99998     FORMAT ('  Achieved objective value',13X,' : ',F13.5)
99997     FORMAT (2X,A40,I13)
99996     FORMAT (2X,'Solution Status : ',A43)
99995     FORMAT ('  User termination case                    :',I16)
!dec$ attributes offload : mic :: display_result
       END SUBROUTINE display_result
    END MODULE e05safe_mod
    PROGRAM e05safe
!      E05SAF Example Main Program

!      This example program demonstrates how to use E05SAF in standard
!        execution, and with a selection of coupled local minimizers.
!      The non-default option 'REPEATABILITY ON' is used here, giving
!        repeatable results.

!      .. Use Statements ..
       USE nag_library, ONLY : e05saf, e05zkf, e05zlf
       USE e05safe_mod, ONLY : display_option, display_result, f_target,       &
                               liopts, liuser, lopts, lruser, monmod, nag_wp,  &
                               ndim, nout, npar, objfun_schwefel
!      .. 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), bu(ndim), opts(lopts), &
                                              ruser(lruser), xb(ndim)
       INTEGER                             :: iopts(liopts), itt(6),           &
                                              iuser(liuser)
!      .. Executable Statements ..
!      Print advisory information.
       WRITE (nout,*) 'E05SAF Example Program Results'
       WRITE (nout,*)
       WRITE (nout,*) 'Minimization of the Schwefel function.'
       WRITE (nout,*)

!      Set problem specific values.
!      Set box bounds.       
       bl(1:ndim) = -500.0_nag_wp
       bu(1:ndim) = 500.0_nag_wp

!      Initialize the option arrays for E05SAF.
       ifail = 0
       CALL e05zkf('Initialize = E05SAF',iopts,liopts,opts,lopts,ifail)

!      Query some default option values.
       WRITE (nout,*) '  Default Option Queries:'
       WRITE (nout,*)
       ifail = 0
       optstr = 'Boundary'
       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
       CALL e05zkf('Repeatability = On',iopts,liopts,opts,lopts,ifail)
       ifail = 0
       CALL e05zkf('Verify Gradients = Off',iopts,liopts,opts,lopts,ifail)
       ifail = 0
       CALL e05zkf('Boundary = Hyperspherical',iopts,liopts,opts,lopts,ifail)
       ifail = 0
       CALL e05zkf('Maximum iterations static = 150',iopts,liopts,opts,lopts, &
          ifail)
       ifail = 0
       CALL e05zkf('Repulsion Initialize = 30',iopts,liopts,opts,lopts,ifail)
       ifail = 0
       CALL e05zkf('Repulsion Finalize = 30',iopts,liopts,opts,lopts,ifail)

!      Call E05SAF to search for the global optimum.
!      Non-zero IFAIL expected on exit here, so use IFAIL=1 (quiet) on entry.
       ifail = 1
       CALL e05saf(ndim,npar,xb,fb,bl,bu,objfun_schwefel,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,xb,fb,itt,inform)
       CASE (3)
!         Exit flag set in OBJFUN or MONMOD and returned in INFORM.
          CALL display_result(ndim,xb,fb,itt,inform)
       CASE DEFAULT
!         An error was detected. Print message since IFAIL=1 on entry.
          WRITE (nout,99998) '** E05SAF returned with an error, IFAIL = ', &
             ifail
          CONTINUE
       END SELECT

!      ------------------------------------------------------------------
       WRITE (nout,*) '2. Solution using coupled local minimizer E04CBF'
       WRITE (nout,*)

!      Set an objective target.
       ifail = 0
       WRITE (optstr,99999) 'Target Objective Value', f_target
       CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail)
       ifail = 0
       WRITE (optstr,99999) 'Target Objective Tolerance', 1.0E-5_nag_wp
       CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail)
       ifail = 0
       WRITE (optstr,99999) 'Target Objective Safeguard', 1.0E-8_nag_wp
       CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail)

!      Set the local minimizer to be E04CBF and set corresponding options.
       ifail = 0
       CALL e05zkf('Local Minimizer = E04CBF',iopts,liopts,opts,lopts,ifail)
       ifail = 0
       CALL e05zkf('Local Interior Iterations = 10',iopts,liopts,opts,lopts, &
          ifail)
       ifail = 0
       CALL e05zkf('Local Exterior Iterations = 20',iopts,liopts,opts,lopts, &
          ifail)
       ifail = 0
       WRITE (optstr,99999) 'Local Interior Tolerance', 1.0E-4_nag_wp
       CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail)
       ifail = 0
       WRITE (optstr,99999) 'Local Exterior Tolerance', 1.0E-4_nag_wp
       CALL e05zkf(optstr,iopts,liopts,opts,lopts,ifail)

!      Call E05SAF to search for the global optimum.
       ifail = -1
       CALL e05saf(ndim,npar,xb,fb,bl,bu,objfun_schwefel,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,xb,fb,itt,inform)
       CASE (3)
!         Exit flag set in OBJFUN or MONMOD and returned in INFORM.
          CALL display_result(ndim,xb,fb,itt,inform)
       CASE DEFAULT
!         An error was detected.
          CONTINUE
       END SELECT

!      -----------------------------------------------------------------
       WRITE (nout,*) '3. Solution using coupled local minimizer E04DGF'
       WRITE (nout,*)

!      Set the local minimizer to be E04DGF and set corresponding options.
       ifail = 0
       CALL e05zkf('Local Minimizer = E04DGF',iopts,liopts,opts,lopts,ifail)
       ifail = 0
       CALL e05zkf('Local Interior Iterations = 5',iopts,liopts,opts,lopts, &
          ifail)
       ifail = 0
       CALL e05zkf('Local Exterior Iterations = 20',iopts,liopts,opts,lopts, &
          ifail)

!      Call E05SAF to search for the global optimum.
       ifail = -1
       CALL e05saf(ndim,npar,xb,fb,bl,bu,objfun_schwefel,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,xb,fb,itt,inform)
       CASE (3)
!         Exit flag set in OBJFUN or MONMOD and returned in INFORM.
          CALL display_result(ndim,xb,fb,itt,inform)
       CASE DEFAULT
!         An error was detected.
          CONTINUE
       END SELECT

99999  FORMAT (A,' = ',E32.16)
99998  FORMAT (1X,A,I6)
    END PROGRAM e05safe
