From 9fac184765c3756de6b22cf110a6fc3f626d2fe1 Mon Sep 17 00:00:00 2001
From: Jeffrey Armstrong <jeff@approximatrix.com>
Date: Thu, 29 Oct 2020 12:36:45 -0400
Subject: Added handling of callbacks in a Fortran-esque manner

---
 src/clp.f90           | 25 ++++++++++++++++--
 src/clp_callback.f90  | 71 +++++++++++++++++++++++++++++++++++++++++++++++++++
 src/clp_constants.F90 |  3 +++
 3 files changed, 97 insertions(+), 2 deletions(-)
 create mode 100644 src/clp_callback.f90

(limited to 'src')

diff --git a/src/clp.f90 b/src/clp.f90
index 2c8692a..cd34b95 100644
--- a/src/clp.f90
+++ b/src/clp.f90
@@ -1,5 +1,7 @@
 module clp
     use iso_c_binding
+    use clp_callback, only: fortran_cb
+    use clp_constants
     implicit none
     
         interface
@@ -498,10 +500,10 @@ module clp
                 use iso_c_binding
                     type(c_ptr) :: model
             end subroutine
-            subroutine Clp_registerCallBack(model,userCallBack) bind(C,name="Clp_registerCallBack")
+            subroutine Clp_registerCallBack_C(model,userCallBack) bind(C,name="Clp_registerCallBack")
                 use iso_c_binding
                     type(c_ptr), value :: model
-                    type(c_ptr), value :: userCallBack
+                    type(c_funptr), value :: userCallBack
             end subroutine
             subroutine Clp_clearCallBack(model) bind(C,name="Clp_clearCallBack")
                 use iso_c_binding
@@ -1700,4 +1702,23 @@ contains
         
     end subroutine Clp_integerInformation
 
+    subroutine Clp_registerCallback(model, cb)
+    use iso_c_binding
+    use clp_callback
+    implicit none
+    
+        type(c_ptr) :: model
+        procedure(fortran_cb) :: cb
+        
+        if(associated(current_callback)) then
+            Write(*,*) "*** WARNING: Clp Fortran Library supports only a single callback"
+            Write(*,*) "***          Reassigning current callback"
+        end if 
+        
+        current_callback => cb
+        
+        call Clp_Registercallback_C(model, c_funloc(Clp_boundCallbackInterface))
+        
+    end subroutine Clp_registerCallback
+
 end module clp
diff --git a/src/clp_callback.f90 b/src/clp_callback.f90
new file mode 100644
index 0000000..d403be7
--- /dev/null
+++ b/src/clp_callback.f90
@@ -0,0 +1,71 @@
+module clp_callback
+use iso_c_binding
+implicit none
+
+    interface fortran_cb
+        subroutine fortran_cb(mdl, msg, dbls, ints, strings)
+        use iso_c_binding
+        use clp_constants
+        implicit none
+            type(c_ptr) :: mdl
+            integer :: msg
+            real(kind=c_double), dimension(:), pointer :: dbls
+            integer(kind=c_int), dimension(:), pointer :: ints
+            character(len=clp_default_message_len), dimension(:), pointer :: strings
+        end subroutine fortran_cb
+    end interface
+    
+    procedure(fortran_cb), pointer:: current_callback
+    
+contains
+
+    subroutine Clp_boundCallbackInterface(model, messageNumber, &
+                                          nDouble, vDouble, &
+                                          nInt, vInt, &
+                                          nString, vString) bind(C)
+    use iso_c_binding
+    use clp_constants
+    implicit none
+    
+        type(c_ptr), value :: model
+        integer(c_int), value :: messageNumber
+        integer(c_int), value :: nDouble, nInt, nString
+        type(c_ptr), value :: vDouble, vInt, vString
+        
+        real(kind=c_double), dimension(:), pointer :: fdouble
+        integer(kind=c_int), dimension(:), pointer :: fint
+        character(len=clp_default_message_len), dimension(:), pointer :: fstrs
+        
+        ! For converting C strings
+        type(c_ptr), dimension(:), pointer :: c_strings
+        integer::i
+    
+        if(nDouble > 0 .and. c_associated(vDouble)) then
+            call c_f_pointer(vDouble, fdouble, (/ nDouble /))
+        end if
+        
+        if(nInt > 0 .and. c_associated(vInt)) then
+            call c_f_pointer(vInt, fint, (/ nInt /))
+        end if
+        
+        if(nString > 0 .and. c_associated(vString)) then
+            allocate(fstrs(nString))
+            fstrs = ' '
+            call c_f_pointer(vString, c_strings, (/ nString /))
+            do i = 1, nString
+                call populate_fortran_string(c_strings(i), fstrs(i))
+            end do
+        end if
+        
+        ! Now that Fortran arrays are built, call the Fortran callback
+        if(associated(current_callback)) then
+            call current_callback(model, messageNumber, fdouble, fint, fstrs)
+        end if
+        
+        if(associated(fstrs)) then
+            deallocate(fstrs)
+        end if
+    
+    end subroutine Clp_boundCallbackInterface
+    
+end module clp_callback
\ No newline at end of file
diff --git a/src/clp_constants.F90 b/src/clp_constants.F90
index 5a44089..5451bba 100644
--- a/src/clp_constants.F90
+++ b/src/clp_constants.F90
@@ -11,6 +11,9 @@ module clp_constants
     integer, parameter :: CoinBigIndex_t = c_long_long
 #endif
     
+    ! Default message string length
+    integer, parameter::clp_default_message_len = 128
+    
     enum, bind(c)
         enumerator :: Status_isFree = 0
         enumerator :: Status_basic
-- 
cgit v1.2.3