perturb_and_evaluate Subroutine

private subroutine perturb_and_evaluate(me, x, vm, xp, fp, nfcnev, ier, first)

Perturb the x vector and evaluate the function.

If the function evaluation is not valid, it will perturb and try again. Until a valid function is obtained or the maximum number of function evaluations is reached.

Type Bound

simulated_annealing_type

Arguments

Type IntentOptional Attributes Name
class(simulated_annealing_type), intent(inout) :: me
real(kind=wp), intent(in), dimension(:) :: x

input optimization variable vector to perturb

real(kind=wp), intent(in), dimension(:) :: vm

step length vector

real(kind=wp), intent(out), dimension(:) :: xp

the perturbed x value

real(kind=wp), intent(out) :: fp

the value of the user function at xp

integer, intent(inout) :: nfcnev

total number of function evaluations

integer, intent(inout) :: ier

status output code

logical, intent(in), optional :: first

to use the input x the first time


Calls

proc~~perturb_and_evaluate~~CallsGraph proc~perturb_and_evaluate simulated_annealing_module::simulated_annealing_type%perturb_and_evaluate proc~uniform simulated_annealing_module::uniform proc~perturb_and_evaluate->proc~uniform proc~uniform_random_number simulated_annealing_module::uniform_random_number proc~uniform->proc~uniform_random_number

Called by

proc~~perturb_and_evaluate~~CalledByGraph proc~perturb_and_evaluate simulated_annealing_module::simulated_annealing_type%perturb_and_evaluate proc~sa simulated_annealing_module::simulated_annealing_type%sa proc~sa->proc~perturb_and_evaluate

Source Code

    subroutine perturb_and_evaluate(me,x,vm,xp,fp,nfcnev,ier,first)

    implicit none

    class(simulated_annealing_type),intent(inout) :: me
    real(wp),dimension(:),intent(in)  :: x       !! input optimization variable vector to perturb
    real(wp),dimension(:),intent(in)  :: vm      !! step length vector
    real(wp),dimension(:),intent(out) :: xp      !! the perturbed `x` value
    real(wp),intent(out)              :: fp      !! the value of the user function at `xp`
    integer,intent(inout)             :: nfcnev  !! total number of function evaluations
    integer,intent(inout)             :: ier     !! status output code
    logical,intent(in),optional       :: first   !! to use the input `x` the first time

    integer :: i         !! counter
    integer :: istat     !! user function status code
    logical :: first_try !! local copy of `first`
    real(wp) :: lower    !! lower bound to use for random interval
    real(wp) :: upper    !! upper bound to use for random interval

    if (present(first)) then
        first_try = first
    else
        first_try = .false.
    end if

    do

        if (first_try) then
            if (me%use_initial_guess) then
                ! use the initial guess
                ! [note if this evauation fails, the subsequent ones
                !  are perturbed from this one]
                xp = x
                first_try = .false.
            else
                ! a random point in the bounds:
                ! [if it fails, a new random one is tried next time]
                do i = 1, me%n
                    xp(i) = uniform(me%lb(i),me%ub(i))
                    !xp(i) = me%lb(i) + (me%ub(i)-me%lb(i))*uniform_random_number()
                end do
            end if
        else
            ! perturb all of them:
            do i = 1, me%n
                lower = max( me%lb(i), x(i) - vm(i) )
                upper = min( me%ub(i), x(i) + vm(i) )
                xp(i) = uniform(lower,upper)
                !xp(i) = lower + (upper-lower)*uniform_random_number()
            end do
        end if

        ! evaluate the function with the trial
        ! point xp and return as fp.
        call me%fcn(xp, fp, istat)

        ! function eval counter:
        nfcnev = nfcnev + 1

        !  if too many function evaluations occur, terminate the algorithm.
        if (nfcnev > me%maxevl) then
            if (me%iprint>0) then
                write(me%iunit, '(A)') ' too many function evaluations; consider'
                write(me%iunit, '(A)') ' increasing maxevl or eps, or decreasing'
                write(me%iunit, '(A)') ' nt or rt. these results are likely to be'
                write(me%iunit, '(A)') ' poor.'
            end if
            ier = 1
            return
        end if

        select case (istat)
        case(-2)
            ! user stop
            write(me%iunit, '(A)') ' user stopped in function.'
            ier = 4
            exit
        case(-1)
            ! try another one until we get a valid evaluation
            cycle
        case default
            ! continue
        end select

        exit ! finished

    end do

    end subroutine perturb_and_evaluate