Manually applied jschueller's closed callback PR

libprima · Dec 7, 2023 · 953cfed · 953cfed
1 parent 2239699
commit 953cfed
Show file tree

Hide file tree

Showing 27 changed files with 726 additions and 157 deletions.
diff --git a/.github/actions/spelling/allow.txt b/.github/actions/spelling/allow.txt
@@ -45,6 +45,7 @@ BQPGASIM
 BROWNAL
 Bindel
 Broyden
+CCALLBACK
 CGRAD
 CHANDHEQ
 CHCKTST
@@ -2048,8 +2049,6 @@ COBJCON
 cobjfun
 cobjfuncon
 constrc
-evalcobj
-evalcobjcon
 execstack
 FUNPTR
 PROCPOINTER
@@ -2133,3 +2132,4 @@ TWOBARS
 lang
 archnorma
 orthtol
+fcn
diff --git a/c/bobyqa_c.f90 b/c/bobyqa_c.f90
@@ -13,9 +13,10 @@ module bobyqa_c_mod
 contains
 
 
-subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, ftarget, maxfun, npt, iprint, info) bind(C)
-use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_FUNPTR, C_PTR
-use, non_intrinsic :: cintrf_mod, only : COBJ
+subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, &
+    & ftarget, maxfun, npt, iprint, callback_ptr, info) bind(C)
+use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_FUNPTR, C_PTR, C_ASSOCIATED, C_F_PROCPOINTER
+use, non_intrinsic :: cintrf_mod, only : COBJ, CCALLBACK
 use, non_intrinsic :: consts_mod, only : RP, IK
 use, non_intrinsic :: bobyqa_mod, only : bobyqa
 implicit none
@@ -36,6 +37,7 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 integer(C_INT), intent(in), value :: maxfun
 integer(C_INT), intent(in), value :: npt
 integer(C_INT), intent(in), value :: iprint
+type(C_FUNPTR), intent(in), value :: callback_ptr
 integer(C_INT), intent(out) :: info
 
 ! Local variables
@@ -51,6 +53,8 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 real(RP) :: x_loc(n)
 real(RP) :: xl_loc(n)
 real(RP) :: xu_loc(n)
+procedure(CCALLBACK), pointer :: cb_ptr
+procedure(COBJ), pointer :: obj_ptr
 
 ! Read the inputs and convert them to the Fortran side types
 x_loc = real(x, kind(x_loc))
@@ -62,10 +66,19 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 maxfun_loc = int(maxfun, kind(maxfun_loc))
 npt_loc = int(npt, kind(npt_loc))
 iprint_loc = int(iprint, kind(iprint_loc))
+call C_F_PROCPOINTER(cobj_ptr, obj_ptr)
 
 ! Call the Fortran code
-call bobyqa(calfun, x_loc, f_loc, xl=xl_loc, xu=xu_loc, nf=nf_loc, rhobeg=rhobeg_loc, rhoend=rhoend_loc, &
-    & ftarget=ftarget_loc, maxfun=maxfun_loc, npt=npt_loc, iprint=iprint_loc, info=info_loc)
+if (C_ASSOCIATED(callback_ptr)) then
+    ! If a C callback function is provided, we capture it for use in the closure below
+    call C_F_PROCPOINTER(callback_ptr, cb_ptr)
+    ! And then we pass the closure to the Fortran code
+    call bobyqa(calfun, x_loc, f_loc, xl=xl_loc, xu=xu_loc, nf=nf_loc, rhobeg=rhobeg_loc, rhoend=rhoend_loc, &
+        & ftarget=ftarget_loc, maxfun=maxfun_loc, npt=npt_loc, iprint=iprint_loc, callback_fcn=callback_fcn, info=info_loc)
+else
+    call bobyqa(calfun, x_loc, f_loc, xl=xl_loc, xu=xu_loc, nf=nf_loc, rhobeg=rhobeg_loc, rhoend=rhoend_loc, &
+        & ftarget=ftarget_loc, maxfun=maxfun_loc, npt=npt_loc, iprint=iprint_loc, info=info_loc)
+end if
 
 ! Write the outputs
 x = real(x_loc, kind(x))
@@ -82,13 +95,69 @@ subroutine bobyqa_c(cobj_ptr, data_ptr, n, x, f, xl, xu, nf, rhobeg, rhoend, fta
 !--------------------------------------------------------------------------------------------------!
 subroutine calfun(x_sub, f_sub)
 use, non_intrinsic :: consts_mod, only : RP
-use, non_intrinsic :: cintrf_mod, only : evalcobj
+use, intrinsic :: iso_c_binding, only : C_DOUBLE
 implicit none
 real(RP), intent(in) :: x_sub(:)
 real(RP), intent(out) :: f_sub
-call evalcobj(cobj_ptr, data_ptr, x_sub, f_sub)
+
+! Local variables
+real(C_DOUBLE) :: x_sub_loc(size(x_sub))
+real(C_DOUBLE) :: f_sub_loc
+
+! Read the inputs and convert them to the types specified in COBJ
+x_sub_loc = real(x_sub, kind(x_sub_loc))
+
+! Call the C objective function
+call obj_ptr(x_sub_loc, f_sub_loc, data_ptr)
+
+! Write the output
+f_sub = real(f_sub_loc, kind(f_sub))
+
 end subroutine calfun
 
+! We name some variables _sub to avoid masking the parent variables
+subroutine callback_fcn(x_sub, f_sub, nf_sub, tr, cstrv, nlconstr, terminate)
+use, non_intrinsic :: consts_mod, only : RP, IK
+use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_BOOL
+implicit none
+real(RP), intent(in) :: x_sub(:)
+real(RP), intent(in) :: f_sub
+integer(IK), intent(in) :: nf_sub
+integer(IK), intent(in) :: tr
+real(RP), intent(in) :: cstrv
+real(RP), intent(in) :: nlconstr(:)
+logical, intent(out) :: terminate
+
+! Local variables
+integer(C_INT) :: n_sub_loc
+real(C_DOUBLE) :: x_sub_loc(size(x_sub))
+real(C_DOUBLE) :: f_sub_loc
+integer(C_INT) :: nf_sub_loc
+integer(C_INT) :: tr_loc
+real(C_DOUBLE) :: cstrv_loc
+integer(C_INT) :: m_nlconstr
+real(C_DOUBLE) :: nlconstr_loc(size(nlconstr))
+logical(C_BOOL) :: terminate_loc
+
+! Read the inputs and convert them to the types specified in CCALLBACK
+n_sub_loc = size(x_sub)
+x_sub_loc = real(x_sub, kind(x_sub_loc))
+f_sub_loc = real(f_sub, kind(f_sub_loc))
+nf_sub_loc = int(nf_sub, kind(nf_sub_loc))
+tr_loc = int(tr, kind(tr_loc))
+cstrv_loc = real(cstrv, kind(cstrv_loc))
+m_nlconstr = size(nlconstr)
+nlconstr_loc = real(nlconstr, kind(nlconstr_loc))
+
+! Call the C objective function
+call cb_ptr(n_sub_loc, x_sub_loc, f_sub_loc, nf_sub_loc, tr_loc, cstrv_loc, m_nlconstr, nlconstr_loc, terminate_loc)
+
+! Write the output
+terminate = logical(terminate_loc, kind(terminate))
+
+end subroutine callback_fcn
+
+
 end subroutine bobyqa_c
 
 

diff --git a/c/cintrf.f90 b/c/cintrf.f90
@@ -7,7 +7,7 @@ module cintrf_mod
 
 implicit none
 private
-public :: COBJ, COBJCON, evalcobj, evalcobjcon
+public :: COBJ, COBJCON, CCALLBACK
 
 
 abstract interface
@@ -31,66 +31,23 @@ subroutine COBJCON(x, f, constr, data_ptr) bind(c)
     type(C_PTR), intent(in), value :: data_ptr
     end subroutine COBJCON
 
-end interface
-
-
-contains
-
-
-subroutine evalcobj(cobj_ptr, data_ptr, x, f)
-use, non_intrinsic :: consts_mod, only : RP
-use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_FUNPTR, C_F_PROCPOINTER, C_PTR
-implicit none
-type(C_FUNPTR), intent(in) :: cobj_ptr
-type(C_PTR), intent(in), value :: data_ptr
-real(RP), intent(in) :: x(:)
-real(RP), intent(out) :: f
-
-! Local variables
-procedure(COBJ), pointer :: obj_ptr
-real(C_DOUBLE) :: x_loc(size(x))
-real(C_DOUBLE) :: f_loc
-
-! Read the inputs and convert them to the types specified in COBJ
-x_loc = real(x, kind(x_loc))
-call C_F_PROCPOINTER(cobj_ptr, obj_ptr)
-
-! Call the C objective function
-call obj_ptr(x_loc, f_loc, data_ptr)
-
-! Write the output
-f = real(f_loc, kind(f))
-
-end subroutine evalcobj
-
-
-subroutine evalcobjcon(cobjcon_ptr, data_ptr, x, f, constr)
-use, non_intrinsic :: consts_mod, only : RP
-use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_FUNPTR, C_F_PROCPOINTER, C_PTR
-implicit none
-type(C_FUNPTR), intent(in) :: cobjcon_ptr
-type(C_PTR), intent(in), value :: data_ptr
-real(RP), intent(in) :: x(:)
-real(RP), intent(out) :: f
-real(RP), intent(out) :: constr(:)
-
-! Local variables
-procedure(COBJCON), pointer :: objcon_ptr
-real(C_DOUBLE) :: x_loc(size(x))
-real(C_DOUBLE) :: f_loc
-real(C_DOUBLE) :: constr_loc(size(constr))
-
-! Read the inputs and convert them to the types specified in COBJCON
-x_loc = real(x, kind(x_loc))
-call C_F_PROCPOINTER(cobjcon_ptr, objcon_ptr)
+    subroutine CCALLBACK(n, x, f, nf, tr, cstrv, m_nlcon, nlconstr, terminate) bind(c)
+    use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_BOOL, C_INT
+    implicit none
+    integer(C_INT), intent(in), value :: n
+    ! We cannot use assumed-shape arrays for C interoperability
+    real(C_DOUBLE), intent(in) :: x(*)
+    real(C_DOUBLE), intent(in), value :: f
+    integer(C_INT), intent(in), value :: nf
+    integer(C_INT), intent(in), value :: tr
+    real(C_DOUBLE), intent(in), value :: cstrv
+    integer(C_INT), intent(in), value :: m_nlcon
+    real(C_DOUBLE), intent(in) :: nlconstr(*)
+    logical(C_BOOL), intent(out) :: terminate
+    end subroutine CCALLBACK
 
-! Call the C objective function
-call objcon_ptr(x_loc, f_loc, constr_loc, data_ptr)
 
-! Write the output
-f = real(f_loc, kind(f))
-constr = real(constr_loc, kind(constr))
+end interface
 
-end subroutine evalcobjcon
 
 end module cintrf_mod
diff --git a/c/cobyla_c.f90 b/c/cobyla_c.f90
@@ -12,10 +12,10 @@ module cobyla_c_mod
 contains
 
 
-subroutine cobyla_c(m_nlcon, cobjcon_ptr, data_ptr, n, x, f, cstrv, nlconstr, m_ineq, Aineq, bineq, m_eq, Aeq, beq, xl, xu, &
-    & f0, nlconstr0, nf, rhobeg, rhoend, ftarget, maxfun, iprint, info) bind(C)
-use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_FUNPTR, C_PTR
-use, non_intrinsic :: cintrf_mod, only : COBJCON
+subroutine cobyla_c(m_nlcon, cobjcon_ptr, data_ptr, n, x, f, cstrv, nlconstr, m_ineq, Aineq, bineq, m_eq, Aeq, beq, &
+    & xl, xu, f0, nlconstr0, nf, rhobeg, rhoend, ftarget, maxfun, iprint, callback_ptr, info) bind(C)
+use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_FUNPTR, C_PTR, C_ASSOCIATED, C_F_PROCPOINTER
+use, non_intrinsic :: cintrf_mod, only : COBJCON, CCALLBACK
 use, non_intrinsic :: consts_mod, only : RP, IK
 use, non_intrinsic :: cobyla_mod, only : cobyla
 implicit none
@@ -46,6 +46,7 @@ subroutine cobyla_c(m_nlcon, cobjcon_ptr, data_ptr, n, x, f, cstrv, nlconstr, m_
 real(C_DOUBLE), intent(in), value :: ftarget
 integer(C_INT), intent(in), value :: maxfun
 integer(C_INT), intent(in), value :: iprint
+type(C_FUNPTR), intent(in), value :: callback_ptr
 integer(C_INT), intent(out) :: info
 
 ! Local variables
@@ -69,6 +70,8 @@ subroutine cobyla_c(m_nlcon, cobjcon_ptr, data_ptr, n, x, f, cstrv, nlconstr, m_
 real(RP) :: xu_loc(n)
 real(RP) :: f0_loc
 real(RP) :: nlconstr0_loc(m_nlcon)
+procedure(CCALLBACK), pointer :: cb_ptr
+procedure(COBJCON), pointer :: objcon_ptr
 
 ! Read the inputs and convert them to the Fortran side types
 ! Note that `transpose` is needed when reading 2D arrays, since they are stored in the row-major
@@ -88,13 +91,25 @@ subroutine cobyla_c(m_nlcon, cobjcon_ptr, data_ptr, n, x, f, cstrv, nlconstr, m_
 maxfun_loc = int(maxfun, kind(maxfun_loc))
 iprint_loc = int(iprint, kind(iprint_loc))
 m_nlcon_loc = int(m_nlcon, kind(m_nlcon_loc))
+call C_F_PROCPOINTER(cobjcon_ptr, objcon_ptr)
 
 ! Call the Fortran code
-call cobyla(calcfc, m_nlcon_loc, x_loc, f_loc, cstrv=cstrv_loc, nlconstr=nlconstr_loc, &
-    & Aineq=Aineq_loc, bineq=bineq_loc, Aeq=Aeq_loc, beq=beq_loc, &
-    & xl=xl_loc, xu=xu_loc, f0=f0_loc, nlconstr0=nlconstr0_loc, nf=nf_loc, &
-    & rhobeg=rhobeg_loc, rhoend=rhoend_loc, ftarget=ftarget_loc, maxfun=maxfun_loc, &
-    & iprint=iprint_loc, info=info_loc)
+if (C_ASSOCIATED(callback_ptr)) then
+    ! If a C callback function is provided, we capture it for use in the closure below
+    call C_F_PROCPOINTER(callback_ptr, cb_ptr)
+    ! And then we pass the closure to the Fortran code
+    call cobyla(calcfc, m_nlcon_loc, x_loc, f_loc, cstrv=cstrv_loc, nlconstr=nlconstr_loc, &
+        & Aineq=Aineq_loc, bineq=bineq_loc, Aeq=Aeq_loc, beq=beq_loc, &
+        & xl=xl_loc, xu=xu_loc, f0=f0_loc, nlconstr0=nlconstr0_loc, nf=nf_loc, &
+        & rhobeg=rhobeg_loc, rhoend=rhoend_loc, ftarget=ftarget_loc, maxfun=maxfun_loc, &
+        & iprint=iprint_loc, callback_fcn=callback_fcn, info=info_loc)
+else
+    call cobyla(calcfc, m_nlcon_loc, x_loc, f_loc, cstrv=cstrv_loc, nlconstr=nlconstr_loc, &
+        & Aineq=Aineq_loc, bineq=bineq_loc, Aeq=Aeq_loc, beq=beq_loc, &
+        & xl=xl_loc, xu=xu_loc, f0=f0_loc, nlconstr0=nlconstr0_loc, nf=nf_loc, &
+        & rhobeg=rhobeg_loc, rhoend=rhoend_loc, ftarget=ftarget_loc, maxfun=maxfun_loc, &
+        & iprint=iprint_loc, info=info_loc)
+end if
 
 ! Write the outputs
 x = real(x_loc, kind(x))
@@ -113,14 +128,73 @@ subroutine cobyla_c(m_nlcon, cobjcon_ptr, data_ptr, n, x, f, cstrv, nlconstr, m_
 !--------------------------------------------------------------------------------------------------!
 subroutine calcfc(x_sub, f_sub, constr_sub)
 use, non_intrinsic :: consts_mod, only : RP
-use, non_intrinsic :: cintrf_mod, only : evalcobjcon
+use, intrinsic :: iso_c_binding, only : C_DOUBLE
 implicit none
 real(RP), intent(in) :: x_sub(:)
 real(RP), intent(out) :: f_sub
 real(RP), intent(out) :: constr_sub(:)
-call evalcobjcon(cobjcon_ptr, data_ptr, x_sub, f_sub, constr_sub)
+
+! Local variables
+real(C_DOUBLE) :: x_sub_loc(size(x_sub))
+real(C_DOUBLE) :: f_sub_loc
+real(C_DOUBLE) :: constr_sub_loc(size(constr_sub))
+
+! Read the inputs and convert them to the types specified in COBJCON
+x_sub_loc = real(x_sub, kind(x_sub_loc))
+
+! Call the C objective function
+call objcon_ptr(x_sub_loc, f_sub_loc, constr_sub_loc, data_ptr)
+
+! Write the output
+f_sub = real(f_sub_loc, kind(f_sub))
+constr_sub = real(constr_sub_loc, kind(constr_sub))
+
 end subroutine calcfc
 
+
+! We name some variables _sub to avoid masking the parent variables
+subroutine callback_fcn(x_sub, f_sub, nf_sub, tr, cstrv, nlconstr, terminate)
+use, non_intrinsic :: consts_mod, only : RP, IK
+use, intrinsic :: iso_c_binding, only : C_DOUBLE, C_INT, C_BOOL
+implicit none
+real(RP), intent(in) :: x_sub(:)
+real(RP), intent(in) :: f_sub
+integer(IK), intent(in) :: nf_sub
+integer(IK), intent(in) :: tr
+real(RP), intent(in) :: cstrv
+real(RP), intent(in) :: nlconstr(:)
+logical, intent(out) :: terminate
+
+! Local variables
+integer(C_INT) :: n_sub_loc
+real(C_DOUBLE) :: x_sub_loc(size(x_sub))
+real(C_DOUBLE) :: f_sub_loc
+integer(C_INT) :: nf_sub_loc
+integer(C_INT) :: tr_loc
+real(C_DOUBLE) :: cstrv_loc
+integer(C_INT) :: m_nlconstr
+real(C_DOUBLE) :: nlconstr_loc(size(nlconstr))
+logical(C_BOOL) :: terminate_loc
+
+! Read the inputs and convert them to the types specified in CCALLBACK
+n_sub_loc = size(x_sub)
+x_sub_loc = real(x_sub, kind(x_sub_loc))
+f_sub_loc = real(f_sub, kind(f_sub_loc))
+nf_sub_loc = int(nf_sub, kind(nf_sub_loc))
+tr_loc = int(tr, kind(tr_loc))
+cstrv_loc = real(cstrv, kind(cstrv_loc))
+m_nlconstr = size(nlconstr)
+nlconstr_loc = real(nlconstr, kind(nlconstr_loc))
+
+! Call the C objective function
+call cb_ptr(n_sub_loc, x_sub_loc, f_sub_loc, nf_sub_loc, tr_loc, cstrv_loc, m_nlconstr, nlconstr_loc, terminate_loc)
+
+! Write the output
+terminate = logical(terminate_loc, kind(terminate))
+
+end subroutine callback_fcn
+
+
 end subroutine cobyla_c