From 9b380489a4084097380b18f58bb2116613f891ee Mon Sep 17 00:00:00 2001 From: Jeffrey Armstrong Date: Thu, 29 Oct 2020 16:10:53 -0400 Subject: Implemented the C example driver program in Fortran. Updates to name routines to read rather than write when appropriate. Minor callback fixes. --- src/clp.f90 | 41 ++++++++++------ src/clp_callback.f90 | 11 +++-- src/examples/basic.f90 | 30 ++++++++++++ src/examples/driver.f90 | 127 ++++++++++++++++++++++++++++++++++++++++++++++++ src/main.f90 | 30 ------------ 5 files changed, 189 insertions(+), 50 deletions(-) create mode 100644 src/examples/basic.f90 create mode 100644 src/examples/driver.f90 delete mode 100644 src/main.f90 (limited to 'src') 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/examples/basic.f90 b/src/examples/basic.f90 new file mode 100644 index 0000000..ee69d39 --- /dev/null +++ b/src/examples/basic.f90 @@ -0,0 +1,30 @@ +program main + use iso_c_binding + use clp + use clp_constants + implicit none + + integer :: ret + + type(c_ptr) :: lp + real(8), dimension(0:4) :: obj + real(8), dimension(0:4) :: row1 + + lp = Clp_newModel() + + call Clp_resize(lp,4,4) + +! row1(0) = 0; row1(1) = 1; row1(2) = 1; row1(3) = 1; ret = add_constraint(lp,row1,LE,100.0_8); + +! write (*,*) Clp_VersionMajor() +! write (*,*) Clp_VersionMinor() +! write (*,*) Clp_VersionRelease() + + + write (*,*) Clp_numberRows(lp) + write (*,*) Clp_numberColumns(lp) + +! call Clp_printModel(lp,"name"//c_null_char) ! seems to be broken when model is not defined + + call Clp_deleteModel(lp) +end 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 diff --git a/src/main.f90 b/src/main.f90 deleted file mode 100644 index ee69d39..0000000 --- a/src/main.f90 +++ /dev/null @@ -1,30 +0,0 @@ -program main - use iso_c_binding - use clp - use clp_constants - implicit none - - integer :: ret - - type(c_ptr) :: lp - real(8), dimension(0:4) :: obj - real(8), dimension(0:4) :: row1 - - lp = Clp_newModel() - - call Clp_resize(lp,4,4) - -! row1(0) = 0; row1(1) = 1; row1(2) = 1; row1(3) = 1; ret = add_constraint(lp,row1,LE,100.0_8); - -! write (*,*) Clp_VersionMajor() -! write (*,*) Clp_VersionMinor() -! write (*,*) Clp_VersionRelease() - - - write (*,*) Clp_numberRows(lp) - write (*,*) Clp_numberColumns(lp) - -! call Clp_printModel(lp,"name"//c_null_char) ! seems to be broken when model is not defined - - call Clp_deleteModel(lp) -end -- cgit v1.2.3