Fortran doesn’t support anonymous functions. The simple work around is to write a function that has a name.
There are then two possible approaches in modern Fortran for capturing the value of any additional parameters required for the function beyond the variable being minimised:
-
The procedure to be minimised is expressed as a deferred binding of an abstract type (a functor type), with the additional parameters for the underlying function available as components of concrete extensions of the abstract type. If necessary one of the components can be a procedure pointer or another object of a functor type.
-
The procedure to be minimised is an internal (F2008) or module procedure, with the additional parameters provided by host association.
What’s best depends on specific circumstances.
Examples of both approaches are in the following.
MODULE Minimizer
IMPLICIT NONE
PRIVATE
INTEGER, PARAMETER, PUBLIC :: rk = KIND(1.0)
PUBLIC :: MinimizeFunctor
PUBLIC :: MinimizeProcedure
TYPE, PUBLIC, ABSTRACT :: Functor
CONTAINS
PROCEDURE(functor_Evaluate), DEFERRED :: Evaluate
END TYPE Functor
ABSTRACT INTERFACE
FUNCTION functor_Evaluate(obj, x)
IMPORT :: Functor
IMPORT :: rk
IMPLICIT NONE
CLASS(Functor), INTENT(IN) :: obj
REAL(rk), INTENT(IN) :: x
REAL(rk) :: functor_Evaluate
END FUNCTION functor_Evaluate
END INTERFACE
CONTAINS
SUBROUTINE MinimizeFunctor(fun, lower, upper, location, value)
CLASS(functor), INTENT(IN) :: fun
REAL(rk), INTENT(IN) :: lower
REAL(rk), INTENT(IN) :: upper
REAL(rk), INTENT(OUT) :: location
REAL(rk), INTENT(OUT) :: value
INTEGER :: c1
REAL(rk) :: x_1
REAL(rk) :: x_2
REAL(rk) :: f_1
REAL(rk) :: f_2
REAL(rk) :: x_lower
REAL(rk) :: x_upper
c1 = 1
x_lower = lower
x_upper = upper
f_1 = fun%Evaluate(x_1)
f_2 = fun%Evaluate(x_2)
location = 0
DO WHILE (c1 < 10)
IF (f_1 > f_2) THEN
x_lower = x_1
x_1 = x_2
f_1 = f_2
x_2 = x_lower + (x_upper - x_lower) * 0.618_rk
f_2 = fun%Evaluate(x_2)
ELSE
x_upper = x_2
x_2 = x_1
f_2 = f_1
x_1 = x_lower + (x_upper - x_lower) * 0.382_rk
f_1 = fun%Evaluate(x_1)
END IF
c1 = c1 + 1
END DO
location = (x_Lower + x_upper) / 2.0
value = fun%Evaluate(location)
END SUBROUTINE MinimizeFunctor
SUBROUTINE MinimizeProcedure(fun, lower, upper, location, value)
INTERFACE
FUNCTION fun(x)
IMPORT :: rk
IMPLICIT NONE
REAL(rk), INTENT(IN) :: x
REAL(rk) :: fun
END FUNCTION fun
END INTERFACE
REAL(rk), INTENT(IN) :: lower
REAL(rk), INTENT(IN) :: upper
REAL(rk), INTENT(OUT) :: location
REAL(rk), INTENT(OUT) :: value
INTEGER :: c1
REAL(rk) :: x_1
REAL(rk) :: x_2
REAL(rk) :: f_1
REAL(rk) :: f_2
REAL(rk) :: x_lower
REAL(rk) :: x_upper
c1 = 1
x_lower = lower
x_upper = upper
f_1 = fun(x_1)
f_2 = fun(x_2)
location = 0
DO WHILE (c1 < 10)
IF (f_1 > f_2) THEN
x_lower = x_1
x_1 = x_2
f_1 = f_2
x_2 = x_lower + (x_upper - x_lower) * 0.618_rk
f_2 = fun(x_2)
ELSE
x_upper = x_2
x_2 = x_1
f_2 = f_1
x_1 = x_lower + (x_upper - x_lower) * 0.382_rk
f_1 = fun(x_1)
END IF
c1 = c1 + 1
END DO
location = (x_Lower + x_upper) / 2.0
value = fun(location)
END SUBROUTINE MinimizeProcedure
END MODULE Minimizer
MODULE m
USE Minimizer
IMPLICIT NONE
PRIVATE
PUBLIC :: RunFunctor
PUBLIC :: RunProcedure
TYPE, EXTENDS(Functor) :: MyFunctor
PROCEDURE(fun_ptr_intf), POINTER, NOPASS :: fun_ptr
INTEGER :: arr1(2)
INTEGER :: arr2(2)
CONTAINS
PROCEDURE :: Evaluate
END TYPE MyFunctor
ABSTRACT INTERFACE
FUNCTION fun_ptr_intf(x1, x2)
IMPORT :: rk
IMPLICIT NONE
REAL(rk), INTENT(IN) :: x1
REAL(rk), INTENT(IN) :: x2
REAL(rk) :: fun_ptr_intf
END FUNCTION fun_ptr_intf
END INTERFACE
CONTAINS
FUNCTION Evaluate(obj, x)
CLASS(MyFunctor), INTENT(IN) :: obj
REAL(rk), INTENT(IN) :: x
REAL(rk) :: Evaluate
Evaluate = obj%fun_ptr( &
obj%arr1(1) + x * obj%arr2(1), &
obj%arr1(2) + x * obj%arr2(2) )
END FUNCTION Evaluate
FUNCTION fun1(x1, x2)
REAL(rk), INTENT(IN) :: x1
REAL(rk), INTENT(IN) :: x2
REAL(rk) :: fun1
fun1 = 3 * x1**2 + 4 * x2**2 + 5 * x1 + 6 * x2 + 10.0_rk
END FUNCTION fun1
SUBROUTINE RunFunctor
TYPE(MyFunctor) :: obj
REAL(rk) :: location
REAL(rk) :: value
obj%fun_ptr => fun1
obj%arr1 = [ 4, 5]
obj%arr2 = [-2, 3]
CALL MinimizeFunctor(obj, 0.0_rk, 1.0_rk, location, value)
PRINT *, location, value
END SUBROUTINE RunFunctor
SUBROUTINE RunProcedure
REAL(rk) :: location
REAL(rk) :: value
INTEGER :: arr1(2)
INTEGER :: arr2(2)
arr1 = [ 4, 5]
arr2 = [-2, 3]
CALL MinimizeProcedure(fun, 0.0_rk, 1.0_rk, location, value)
PRINT *, location, value
CONTAINS
FUNCTION fun(x)
REAL(rk), INTENT(IN) :: x
REAL(rk) :: fun
fun = fun1( &
arr1(1) + x * arr2(1), &
arr1(2) + x * arr2(2) )
END FUNCTION fun
END SUBROUTINE RunProcedure
END MODULE m
PROGRAM p
USE m
IMPLICIT NONE
CALL RunFunctor
CALL RunProcedure
END PROGRAM p