1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
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
use clp_interface_utils
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(:), allocatable, target :: fstrs
character(len=clp_default_message_len), dimension(:), pointer :: fstr_pointer
! 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
fstr_pointer => fstrs
end if
! Now that Fortran arrays are built, call the Fortran callback
if(associated(current_callback)) then
call current_callback(model, messageNumber, fdouble, fint, fstr_pointer)
end if
if(allocated(fstrs)) then
deallocate(fstrs)
end if
end subroutine Clp_boundCallbackInterface
end module clp_callback
|
