diff options
Diffstat (limited to 'src/clp_callback.f90')
| -rw-r--r-- | src/clp_callback.f90 | 71 |
1 files changed, 71 insertions, 0 deletions
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 |