Implemented the C example driver program in Fortran. Updates to name routines to read rather than write when appropriate. Minor callback fixes.

4 files changed, 159 insertions, 20 deletions

diff --git a/src/clp.f90 b/src/clp.f90
index cd34b95..24fc769 100644
--- a/src/clp.f90
+++ b/src/clp.f90
@@ -1082,22 +1082,24 @@ contains
     
     end function Clp_SetProblemName
     
-    subroutine Clp_problemName(model,maxNumberCharacters,array)
+    subroutine Clp_problemName(model,array)
     use clp_interface_utils
     use iso_c_binding
     implicit none
     
         type(c_ptr) :: model
-        integer(c_int), intent(in) :: maxNumberCharacters
-        character(len=*) :: array
+        character(len=*), intent(out) :: array
         
         type(c_ptr)::c_array
         
-        c_array = allocate_and_populate_c_string(array)
-        
-        call Clp_problemName_C(model, maxNumberCharacters, c_array)
+        array = ' '
         
-        call c_free(c_array)
+        c_array = c_allocate(int(len(array) + 1, kind=c_size_t))
+        if(c_associated(c_array)) then
+            call Clp_problemName_C(model, len(array), c_array)
+            call populate_fortran_string(c_array, array)
+            call c_free(c_array)
+        end if
         
     end subroutine Clp_problemName
 
@@ -1154,16 +1156,20 @@ contains
     
         type(c_ptr) :: model
         integer, intent(in)::iRow
-        character(*), intent(in) :: name
-        
+        character(*), intent(out) :: name
+
         type(c_ptr) :: np
-        
-        np = allocate_and_populate_c_string(name)
+
+        name = ' '
+
+        np = c_allocate(int(Clp_LengthNames(model)+1, kind=c_size_t))
         if(c_associated(np)) then
             call Clp_rowName_C(model, int(iRow, kind=c_int), np)
+            call populate_fortran_string(np, name)
             call c_free(np)
         end if
         
+        
     end subroutine Clp_rowName
     
     subroutine Clp_columnName(model,iColumn,name) 
@@ -1173,13 +1179,16 @@ contains
     
         type(c_ptr) :: model
         integer, intent(in)::iColumn
-        character(*), intent(in) :: name
-        
+        character(*), intent(out) :: name
+
         type(c_ptr) :: np
-        
-        np = allocate_and_populate_c_string(name)
+
+        name = ' '
+
+        np = c_allocate(int(Clp_LengthNames(model)+1, kind=c_size_t))
         if(c_associated(np)) then
-            call Clp_rowName_C(model, int(iColumn, kind=c_int), np)
+            call Clp_columnName_C(model, int(iColumn, kind=c_int), np)
+            call populate_fortran_string(np, name)
             call c_free(np)
         end if
         
diff --git a/src/clp_callback.f90 b/src/clp_callback.f90
index d403be7..905d575 100644
--- a/src/clp_callback.f90
+++ b/src/clp_callback.f90
@@ -25,6 +25,7 @@ contains
                                           nString, vString) bind(C)
     use iso_c_binding
     use clp_constants
+    use clp_interface_utils
     implicit none
     
         type(c_ptr), value :: model
@@ -34,8 +35,8 @@ contains
         
         real(kind=c_double), dimension(:), pointer :: fdouble
         integer(kind=c_int), dimension(:), pointer :: fint
-        character(len=clp_default_message_len), dimension(:), pointer :: fstrs
-        
+        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
@@ -55,14 +56,16 @@ contains
             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, fstrs)
+            call current_callback(model, messageNumber, fdouble, fint, fstr_pointer)
         end if
         
-        if(associated(fstrs)) then
+        if(allocated(fstrs)) then
             deallocate(fstrs)
         end if
     
diff --git a/src/main.f90 b/src/examples/basic.f90
index ee69d39..ee69d39 100644
--- a/src/main.f90
+++ b/src/examples/basic.f90
diff --git a/src/examples/driver.f90 b/src/examples/driver.f90
new file mode 100644
index 0000000..afcaee5
--- /dev/null
+++ b/src/examples/driver.f90
@@ -0,0 +1,127 @@
+program driver
+use clp
+use iso_c_binding
+implicit none
+
+    type(c_ptr)::model
+    integer::status
+    character(len=8)::arg
+    
+    character(len=512)::sample
+    character(len=80)::problemName
+    
+    model = clp_newmodel()
+    
+    call Clp_Registercallback(model, callback)
+    
+    if(command_argument_count() >= 1) then
+        call get_command_argument(1, sample)
+    else
+        sample = "data/p0033.mps"
+    end if
+    status = clp_readMps(model, trim(sample), 1, 0)
+
+    if(status /= 0) then
+        Print *, "Bad readMps "//trim(sample)
+        stop
+    end if
+
+    if(command_argument_count() == 2) then
+        call get_command_argument(2, arg)
+        if(arg == 'primal') then
+            status = Clp_initialPrimalSolve(model)
+        else
+            status = Clp_initialDualSolve(model)
+        end if
+    else
+        status = Clp_initialDualSolve(model)
+    end if
+    
+    call Clp_Problemname(model, problemName)
+    
+    Print *, "Model "//trim(problemName)//" has ", &
+             Clp_numberRows(model), " rows and ", &
+             Clp_numberColumns(model), " columns"
+    
+    ! Proceed past stop to print solution
+    !stop
+    
+    call output_solution(model)
+    
+contains 
+
+    subroutine callback(model, msg, dbls, ints, strings)
+    use iso_c_binding
+    use clp_constants
+    implicit none
+        
+        type(c_ptr) :: model
+        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
+        
+        integer::i
+        
+        select case(msg)
+        
+            case (1000002)
+                ! Coin0002
+                Print *, "Name of problem is "//trim(strings(1))
+                Write(*, 100, advance='no') "row", ints(1)
+                Write(*, 100, advance='no') "col", ints(2)
+                Write(*, 100) " el", ints(3)
+100             Format(1X,A3,1X,I5)
+
+            case(5)
+                ! Clp0005
+                do i = 1, 3
+                    Write(*, '(1X, I6,1X, F13.6)') ints(i), dbls(i)
+                end do
+            
+        end select
+        
+    end subroutine callback
+
+    subroutine output_solution(model)
+    use clp
+    use iso_c_binding
+    implicit none
+    
+        type(c_ptr):: model
+        integer::numberColumns, icolumn
+        real(kind=c_double), dimension(:), pointer::columnPrimal, columnDual
+        real(kind=c_double), dimension(:), pointer::columnLower, columnUpper
+        real(kind=c_double), dimension(:), pointer::columnObjective
+        
+        real(kind=8)::v
+        character(len=20)::cname
+        
+        numberColumns = Clp_NumberColumns(model)
+        
+        columnPrimal => Clp_PrimalColumnSolution(model)
+        columnDual => Clp_DualColumnSolution(model)
+        columnLower => Clp_ColumnLower(model)
+        columnUpper => Clp_ColumnUpper(model)
+        columnObjective => Clp_Objective(model)
+        
+        write(*, '(14X, 5A13)') "Primal", "Dual", "Lower", "Upper", "Cost"
+        
+        do icolumn = 0, numberColumns-1
+            v = columnPrimal(icolumn)
+            if(v > 1.0E-8 .or. v < -1.0E-8) then
+                call clp_columnName(model, icolumn, cname)
+            
+                write(*, '(I6, 1X, A7, 5F13.6)') icolumn, cname, &
+                                             columnPrimal(icolumn), &
+                                             columnDual(icolumn), &
+                                             columnLower(icolumn), &
+                                             columnUpper(icolumn), &
+                                             columnObjective(icolumn)
+                                             
+            end if
+        end do
+        
+    end subroutine output_solution
+end program driver
+    
\ No newline at end of file