minimizer.F90

Go to the documentation of this file.

!! Copyright (C) 2002-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch, M. Oliveira
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module minimizer_oct_m
  use debug_oct_m
  use global_oct_m
  use iso_c_binding
  use, intrinsic :: iso_fortran_env
  use lalg_basic_oct_m
  use profiling_oct_m
  use messages_oct_m
 
  implicit none
 
  private
  public ::                    &
    loct_1dminimize,           &
    minimize_fire,             &
    minimize_multidim,         &
    minimize_multidim_nograd,  &
    minimize_multidim_nlopt
 
 
  integer, public, parameter ::      &
    MINMETHOD_STEEPEST_DESCENT =  1, &
    minmethod_fr_cg            =  2, &
    minmethod_pr_cg            =  3, &
    minmethod_bfgs             =  4, &
    minmethod_bfgs2            =  5, &
    minmethod_nmsimplex        =  6, &
    minmethod_sd_native        = -1, &
    minmethod_nlopt_bobyqa     =  7, &
    minmethod_fire             =  8, &
    minmethod_nlopt_lbfgs      =  9
 
  abstract interface
    subroutine minimizer_function_i(n, x, val)
      import real64
      implicit none
      integer :: n
      real(real64) :: x(n)
      real(real64) :: val
    end subroutine minimizer_function_i
    subroutine minimizer_with_grad_i(n, x, val, getgrad, grad)
      import real64
      implicit none
      integer, intent(in)    :: n
      real(real64), intent(in)    :: x(n)
      real(real64), intent(inout) :: val
      integer, intent(in)    :: getgrad
      real(real64), intent(inout) :: grad(n)
    end subroutine minimizer_with_grad_i
    subroutine info_i(iter, n, val, maxdr, maxgrad, x)
      import real64
      implicit none
      integer, intent(in) :: iter
      integer, intent(in) :: n
      real(real64), intent(in) :: val
      real(real64), intent(in) :: maxdr
      real(real64), intent(in) :: maxgrad
      real(real64), intent(in) :: x(n)
    end subroutine info_i
    subroutine info_no_grad_i(iter, n, val, maxdr, x)
      import real64
      implicit none
      integer, intent(in) :: iter
      integer, intent(in) :: n
      real(real64), intent(in) :: val
      real(real64), intent(in) :: maxdr
      real(real64), intent(in) :: x(n)
    end subroutine info_no_grad_i
  end interface
 
 
  interface loct_1dminimize
    subroutine oct_1dminimize(a, b, m, f, status)
      import real64
      implicit none
      real(real64), intent(inout) :: a, b, m
      interface
        subroutine f(x, fx)
          import real64
          implicit none
          real(real64), intent(in)  :: x
          real(real64), intent(out) :: fx
        end subroutine f
      end interface
      integer, intent(out) :: status
    end subroutine oct_1dminimize
  end interface loct_1dminimize
 
  interface loct_minimize
    integer function oct_minimize(method, dim, x, step, line_tol, &
      tolgrad, toldr, maxiter, f, write_iter_info, minimum)
      import minimizer_with_grad_i, info_i, real64
      implicit none
      integer, intent(in)              :: method
      integer, intent(in)              :: dim
      real(real64), intent(inout)      :: x
      real(real64), intent(in)         :: step
      real(real64), intent(in)         :: line_tol
      real(real64), intent(in)         :: tolgrad
      real(real64), intent(in)         :: toldr
      integer, intent(in)              :: maxiter
      procedure(minimizer_with_grad_i) :: f
      procedure(info_i)                :: write_iter_info
      real(real64), intent(out)        :: minimum
    end function oct_minimize
  end interface loct_minimize
 
  interface loct_minimize_direct
    function oct_minimize_direct(method, dim, x, step, toldr, maxiter, f, write_iter_info, minimum)
      import minimizer_function_i, info_no_grad_i, real64
      implicit none
      integer                         :: oct_minimize_direct
      integer, intent(in)             :: method
      integer, intent(in)             :: dim
      real(real64), intent(inout)     :: x
      real(real64), intent(in)        :: step
      real(real64), intent(in)        :: toldr
      integer, intent(in)             :: maxiter
      procedure(minimizer_function_i) :: f
      procedure(info_no_grad_i)       :: write_iter_info
      real(real64), intent(out)       :: minimum
    end function oct_minimize_direct
  end interface loct_minimize_direct
 
contains
 
  subroutine minimize_multidim_nograd(method, dim, x, step, toldr, maxiter, f, write_iter_info, minimum, ierr)
    integer, intent(in)    :: method
    integer, intent(in)    :: dim
    real(real64), intent(inout) :: x(:)
    real(real64), intent(in)    :: step
    real(real64), intent(in)    :: toldr
    integer, intent(in)         :: maxiter
    procedure(minimizer_function_i) :: f
    procedure(info_no_grad_i)   :: write_iter_info
    real(real64), intent(out)   :: minimum
    integer, intent(out)   :: ierr
 
    push_sub(minimize_multidim_nograd)
 
    assert(ubound(x, dim = 1) >= dim)
 
    ierr = 0
    select case (method)
    case (minmethod_nmsimplex)
      ierr = loct_minimize_direct(method, dim, x(1), step, toldr, maxiter, f, write_iter_info, minimum)
    end select
 
    pop_sub(minimize_multidim_nograd)
 
  end subroutine minimize_multidim_nograd
 
 
  subroutine minimize_multidim_nlopt(ierr, method, dim, x, step, toldr, maxiter, f, minimum, lb, ub)
    integer,                  intent(out)   :: ierr
    integer,                  intent(in)    :: method
    integer,                  intent(in)    :: dim
    real(real64), contiguous, intent(inout) :: x(:)
    real(real64),             intent(in)    :: step
    real(real64),             intent(in)    :: toldr
    integer,                  intent(in)    :: maxiter
    interface
      subroutine f(val, n, x, grad, need_gradient, f_data)
        use iso_c_binding
        real(c_double), intent(out) :: val
        integer(c_int), intent(in)  :: n
        real(c_double), intent(in)  :: x(*)
        real(c_double), intent(out) :: grad(*)
        integer(c_int), intent(in)  :: need_gradient
        type(c_ptr),    intent(in)  :: f_data
      end subroutine f
    end interface
    real(real64), intent(out)   :: minimum
    real(real64), intent(in), optional :: lb(:), ub(:)
#if defined(HAVE_NLOPT)
 
    interface
      subroutine nlo_create(opt, alg, n)
        use iso_c_binding
        type(c_ptr),    intent(out) :: opt
        integer(c_int), intent(in)  :: alg
        integer(c_int), intent(in)  :: n
      end subroutine nlo_create
 
      subroutine nlo_set_lower_bounds(ret, opt, lower_bounds)
        use iso_c_binding
        integer(c_int), intent(out)   :: ret
        type(c_ptr),    intent(inout) :: opt
        real(c_double), intent(in)    :: lower_bounds(*)
      end subroutine nlo_set_lower_bounds
 
      subroutine nlo_set_upper_bounds(ret, opt, upper_bounds)
        use iso_c_binding
        integer(c_int), intent(out)   :: ret
        type(c_ptr),    intent(inout) :: opt
        real(c_double), intent(in)    :: upper_bounds(*)
      end subroutine nlo_set_upper_bounds
 
      subroutine nlo_set_min_objective(ret, opt, f, f_data)
        use iso_c_binding
        integer(c_int), intent(out)   :: ret
        type(c_ptr),    intent(inout) :: opt
        interface
          subroutine f(val, n, x, grad, need_gradient, f_data)
            use iso_c_binding
            real(c_double), intent(out) :: val
            integer(c_int), intent(in)  :: n
            real(c_double), intent(in)  :: x(*)
            real(c_double), intent(out) :: grad(*)
            integer(c_int), intent(in)  :: need_gradient
            type(c_ptr),    intent(in)  :: f_data
          end subroutine f
        end interface
        type(c_ptr),    intent(in)    :: f_data
      end subroutine nlo_set_min_objective
 
      subroutine nlo_set_xtol_abs1(ret, opt, xtol_abs)
        use iso_c_binding
        integer(c_int), intent(out)   :: ret
        type(c_ptr),    intent(inout) :: opt
        real(c_double), intent(in)    :: xtol_abs
      end subroutine nlo_set_xtol_abs1
 
      subroutine nlo_set_initial_step1(ret, opt, initial_step1)
        use iso_c_binding
        integer(c_int), intent(out)   :: ret
        type(c_ptr),    intent(inout) :: opt
        real(c_double), intent(in)    :: initial_step1
      end subroutine nlo_set_initial_step1
 
      subroutine nlo_set_maxeval(ret, opt, maxeval)
        use iso_c_binding
        integer(c_int), intent(out)   :: ret
        type(c_ptr),    intent(inout) :: opt
        integer(c_int), intent(in)    :: maxeval
      end subroutine nlo_set_maxeval
 
      subroutine nlo_optimize(ret, opt, x, optf)
        use iso_c_binding
        integer(c_int), intent(out)   :: ret
        type(c_ptr),    intent(inout) :: opt
        real(c_double), intent(inout) :: x(*)
        real(c_double), intent(out)   :: optf
      end subroutine nlo_optimize
 
      subroutine nlo_destroy(opt)
        use iso_c_binding
        type(c_ptr), intent(inout) :: opt
      end subroutine nlo_destroy
    end interface
 
    type(c_ptr) :: opt
    integer :: ires
    ! The following values are taken from the ''nlopt.f'' file installed by NLopt.
    integer, parameter :: NLOPT_LD_LBFGS  = 11
    integer, parameter :: NLOPT_LN_BOBYQA = 34
 
    opt = c_null_ptr
    select case (method)
    case (minmethod_nlopt_bobyqa)
      call nlo_create(opt, nlopt_ln_bobyqa, dim)
    case (minmethod_nlopt_lbfgs)
      call nlo_create(opt, nlopt_ld_lbfgs, dim)
    end select
 
    if (present(lb)) then
      call nlo_set_lower_bounds(ires, opt, lb)
    end if
    if (present(ub)) then
      call nlo_set_upper_bounds(ires, opt, ub)
    end if
 
    call nlo_set_min_objective(ires, opt, f, c_null_ptr)
    ! This would set an inequality constraint (TODO)
    ! call nlo_add_inequality_constraint(ires, opt, myconstraint, d1, 1.0e-8_real64)
 
    call nlo_set_xtol_abs1(ires, opt, toldr)
    call nlo_set_initial_step1(ires, opt, step)
    call nlo_set_maxeval(ires, opt, maxiter)
 
    call nlo_optimize(ires, opt, x, minimum)
    ierr = ires
    call nlo_destroy(opt)
#else
    ierr = 0
    minimum = -m_huge
#endif
  end subroutine minimize_multidim_nlopt
 
 
  !----------------------------------------------
  subroutine minimize_multidim(method, dim, x, step, line_tol, tolgrad, toldr, maxiter, f, write_iter_info, minimum, ierr)
    integer, intent(in)         :: method
    integer, intent(in)         :: dim
    real(real64), intent(inout) :: x(:)
    real(real64), intent(in)    :: step
    real(real64), intent(in)    :: line_tol
    real(real64), intent(in)    :: tolgrad
    real(real64), intent(in)    :: toldr
    integer, intent(in)         :: maxiter
    procedure(minimizer_with_grad_i) :: f
    procedure(info_i)           :: write_iter_info
    real(real64), intent(out)   :: minimum
    integer, intent(out)        :: ierr
 
    push_sub(minimize_multidim)
 
    assert(ubound(x, dim = 1) >= dim)
 
    select case (method)
    case (minmethod_sd_native)
      call minimize_sd(dim, x, step, maxiter, f, write_iter_info, minimum, ierr)
 
    case default
      ierr = loct_minimize(method, dim, x(1), step, line_tol, tolgrad, toldr, maxiter, f, write_iter_info, minimum)
 
    end select
 
    pop_sub(minimize_multidim)
 
  end subroutine minimize_multidim
 
  !----------------------------------------------
 
  subroutine minimize_sd(dim, x, step, maxiter, f, write_iter_info, minimum, ierr)
    integer, intent(in)         :: dim
    real(real64), intent(inout) :: x(:)
    real(real64), intent(in)    :: step
    integer, intent(in)         :: maxiter
    procedure(minimizer_with_grad_i) :: f
    procedure(info_i)           :: write_iter_info
    real(real64), intent(out)   :: minimum
    integer,      intent(out)   :: ierr
 
    integer :: iter
    real(real64), allocatable :: grad(:)
    real(real64) :: step2, maxgrad
 
    push_sub(minimize_sd)
 
    safe_allocate(grad(1:dim))
 
    step2 = step*10.0_real64
    do iter = 1, maxiter
      call f(dim, x, minimum, 1, grad)
 
      maxgrad = maxval(abs(grad))
 
      call write_iter_info(iter, dim, minimum, maxgrad*step2, maxgrad, x)
 
      x(1:dim) = x(1:dim) - step2*grad(1:dim)
 
      step2 = step2*0.99_real64
    end do
    ierr = 0
 
    pop_sub(minimize_sd)
  end subroutine minimize_sd
 
  !----------------------------------------------
  subroutine minimize_fire(dim, space_dim, x, step, tolgrad, maxiter, f, write_iter_info, en, ierr, mass, integrator)
    integer,      intent(in)    :: dim
    integer,      intent(in)    :: space_dim
    real(real64), intent(inout) :: x(:)
    real(real64), intent(in)    :: step
    real(real64), intent(in)    :: tolgrad
    integer,      intent(in)    :: maxiter
    procedure(minimizer_with_grad_i) :: f
    procedure(info_i)           :: write_iter_info
    real(real64), intent(out)   :: en
    integer,      intent(out)   :: ierr
    real(real64), intent(in)    :: mass(:)
    integer,      intent(in)    :: integrator
 
    real(real64), allocatable :: grad(:), old_grad(:)
 
    integer :: p_times, iter, ia, offset
    real(real64) :: dt, alpha, p_value, dt_max
    real(real64), allocatable :: grad_atoms(:), vel(:), dr_i(:), x_old(:), dr_atoms(:)
 
    ! Parameters from the original paper
    integer, parameter :: n_min = 5
    real(real64), parameter :: f_alpha = 0.99_real64
    real(real64), parameter :: f_inc = 1.1_real64
    real(real64), parameter :: f_dec = 0.5_real64
    real(real64), parameter :: alpha_start = 0.1_real64
 
    real(real64), parameter :: maxmove = 0.2_real64 * p_ang
 
    push_sub(minimize_fire)
 
    ! dim must be a multiple of space_dim
    assert(mod(dim,space_dim) == 0)
    assert(size(x) == dim)
 
    safe_allocate(grad_atoms(1:dim/space_dim))
    safe_allocate(grad(1:dim))
    safe_allocate(old_grad(1:dim))
    safe_allocate(vel(1:dim))
    safe_allocate(dr_atoms(1:dim/space_dim))
    safe_allocate(x_old(1:dim))
    safe_allocate(dr_i(1:dim))
 
    ! Initial values
    ierr = 0
    x_old(:) = x(:)
    vel = m_zero
    dt = step
    alpha = alpha_start
    dr_i = m_zero
    dt_max = 10.0_real64 * dt
    p_times = 0
    call f(dim, x, en, 1, grad)
    grad = -grad
    old_grad(:) = grad(:)
 
    do iter = 1, maxiter
 
      ! Perform the MD step: get new gradients from the new positions
      select case (integrator)
        ! Velocity verlet - update the positions
      case (option__gofireintegrator__verlet)
        dr_i(1:dim) = vel(1:dim) * dt + m_half * grad(1:dim) / mass(1:dim) * dt **2
      case (option__gofireintegrator__euler)
        ! Euler method
        dr_i(1:dim) = vel(1:dim)*dt
      end select
 
      ! Get the norms of the displacements for each atom
      do ia = 1, dim/space_dim
        offset = space_dim * (ia -1)
        dr_atoms(ia) = norm2(dr_i(offset+1:offset+space_dim))
        ! Rescale the displacement to avoid too large changes
        if (dr_atoms(ia) > maxmove) then
          dr_i(offset+1:offset+space_dim) = maxmove * dr_i(offset+1:offset+space_dim) / dr_atoms(ia)
          dr_atoms(ia) = maxmove
        end if
      end do
 
      ! Get the new position
      x(1:dim) = x_old(1:dim) + dr_i(1:dim)
 
      ! Get the new gradient
      call f(dim, x, en, 1, grad)
      grad = -grad
 
      ! Molecular dynamics step for getting the new velocities
      select case (integrator)
      case (option__gofireintegrator__verlet)
        ! Velocity Verlet - update velocities
        vel(1:dim) = vel(1:dim) + m_half*(grad(1:dim) + old_grad(1:dim))*dt/mass(1:dim)
      case (option__gofireintegrator__euler)
        ! Euler method
        vel(1:dim) = vel(1:dim) + grad(1:dim)*dt/mass(1:dim)
      end select
 
      ! Now that we performed the MD part, we correct the velocitites
 
      ! Perform step F1: compute P = F.v
      p_value = dot_product(grad, vel)
 
      ! Step F2: v-> (1-\alpha)v + \alpha \hat{F}.|v|
      if (iter > 1) then
        vel(1:dim) = (m_one - alpha) * vel(1:dim) + alpha * grad(1:dim) * lalg_nrm2(dim, vel) / lalg_nrm2(dim,grad)
      end if
 
      ! Perform step F3
      if (p_value > m_zero) then
        p_times = p_times + 1
        if (p_times > n_min) then
          dt = min(dt * f_inc , dt_max)
          alpha = alpha * f_alpha
        end if
 
      else ! or step F4
        p_times = 0
        dt = dt * f_dec
        vel = m_zero
        alpha = alpha_start
      end if
 
      ! Get the norms of the gradients for each atom
      do ia = 0, dim/space_dim - 1
        grad_atoms(ia+1) = norm2(grad(space_dim*ia+1:space_dim*ia+space_dim))
      end do
 
      ! Output for each iteration step
      call write_iter_info(iter, dim, en, maxval(dr_atoms), maxval(abs(grad_atoms)), x)
 
      ! Check convergence
      if (maxval(abs(grad_atoms(1:))) < tolgrad) exit
 
      x_old(1:dim) = x(1:dim)
      old_grad(:) = grad(:)
    end do
 
    ierr = -iter
 
    safe_deallocate_a(dr_atoms)
    safe_deallocate_a(x_old)
    safe_deallocate_a(dr_i)
    safe_deallocate_a(vel)
    safe_deallocate_a(grad)
    safe_deallocate_a(old_grad)
    safe_deallocate_a(grad_atoms)
 
    pop_sub(minimize_fire)
 
  end subroutine minimize_fire
 
end module minimizer_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: