undef01.f90

Go to the documentation of this file.

!> @file undef01.f90
!! @ingroup FORT1THREAD_EXAMPLES
!!
!!
!! Test with some undefined Jacobian elements.
!!
!! This is a CONOPT implementation of the GAMS model:
!!
!! @verbatim
!! variable x1, x2, x3, x4, x5, x6, x7, x8  ;
!! equation e1, e2, e3, e4, e5, e6, e7  ;
!!
!! e1..      x2                     + x7      =e=  9;
!! e2.. x1      + x3      + x5      + x7 + x8 =e= 24;
!! e3.. x1           + x4 + x5                =e= 10;
!! e4..      x2           + x5                =e=  7;
!! e5..                x4 + x5           + x8 =e= 17;
!! e6.. x1      + x3           + x6           =e= 10;
!! e7.. x1           + x4           + x7      =l= 15;
!! x5.fx = 5; x8.fx = 8;
!!
!! model undef01 / all /;
!! solve undef01 using cns;
!! @endverbatim
!!
!! and the solution is xi = i for all i.
!!
!! The last 3 Jacobian elements are not defined.
!!
!!
!! For more information about the individual callbacks, please have a look at the source code.
 
#if defined(_WIN32) && !defined(_WIN64)
#define dec_directives_win32
#endif
 
!> Main program. A simple setup and call of CONOPT
!!
Program undef01
 
   Use proginfo
   Use conopt
   Use casedata_num
   implicit None
!
!  Declare the user callback routines as Integer, External:
!
   Integer, External :: tria_readmatrix ! Mandatory Matrix definition routine defined below
   Integer, External :: tria_fdeval     ! Function and Derivative evaluation routine
                                       ! needed a nonlinear model.
   Integer, External :: std_status     ! Standard callback for displaying solution status
   Integer, External :: std_solution   ! Standard callback for displaying solution values
   Integer, External :: std_message    ! Standard callback for managing messages
   Integer, External :: std_errmsg     ! Standard callback for managing error messages
   Integer, External :: std_triord     ! Standard callback for triangular order
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Tria_ReadMatrix
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Tria_FDEval
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_Status
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_Solution
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_Message
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_ErrMsg
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_TriOrd
#endif
!
!  Control vector
!
   INTEGER, Dimension(:), Pointer :: cntvect
   INTEGER :: coi_error
 
   Integer, parameter :: nvar = 8, neq = 7
 
   call startup
!
!  Create and initialize a Control Vector
!
   coi_error = coi_create( cntvect )
!
!  Tell CONOPT about the size of the model by populating the Control Vector:
!
   coi_error = max( coi_error, coidef_numvar( cntvect, nvar ) )  ! # variables
   coi_error = max( coi_error, coidef_numcon( cntvect, neq ) )  ! # constraints
   coi_error = max( coi_error, coidef_numnz( cntvect, 21 ) ) ! # nonzeros in the Jacobian
   coi_error = max( coi_error, coidef_numnlnz( cntvect, 0 ) )  ! # of which are nonlinear
   coi_error = max( coi_error, coidef_square( cntvect, 1 ) )  ! 1 means the model is square
   coi_error = max( coi_error, coidef_optfile( cntvect, 'undef01.opt' ) )
!
!  Tell CONOPT about the callback routines:
!
   coi_error = max( coi_error, coidef_readmatrix( cntvect, tria_readmatrix ) )
   coi_error = max( coi_error, coidef_fdeval( cntvect, tria_fdeval     ) )
   coi_error = max( coi_error, coidef_status( cntvect, std_status     ) )
   coi_error = max( coi_error, coidef_solution( cntvect, std_solution   ) )
   coi_error = max( coi_error, coidef_message( cntvect, std_message    ) )
   coi_error = max( coi_error, coidef_errmsg( cntvect, std_errmsg     ) )
   coi_error = max( coi_error, coidef_triord( cntvect, std_triord     ) )
!
!  Allocate space for the solution values so we can check them.
!
   do_allocate = .true.
 
#if defined(CONOPT_LICENSE_INT_1) && defined(CONOPT_LICENSE_INT_2) && defined(CONOPT_LICENSE_INT_3) && defined(CONOPT_LICENSE_TEXT)
   coi_error = max( coi_error, coidef_license( cntvect, conopt_license_int_1, conopt_license_int_2, conopt_license_int_3, conopt_license_text) )
#endif
 
   If ( coi_error .ne. 0 ) THEN
      write(*,*)
      write(*,*) '**** Fatal Error while loading CONOPT Callback routines.'
      write(*,*)
      call flog( "Skipping Solve due to setup errors", 1 )
   ENDIF
!
!  Start CONOPT:
!
   casenum = 1;
   coi_error = coi_solve( cntvect )
   If ( coi_error /= 400 ) then
      call flog( "COI_Solve did not return 400 as expected.", 1 )
   endif
   write(*,*)
   write(*,*) 'Successful return for undef01.'
 
   if ( coi_free(cntvect) /= 0 ) call flog( "Error while freeing control vector",1)
 
   call flog( "Successful Solve", 0 )
!
!  Free solution memory
!
   call finalize
 
End Program undef01
!
! ============================================================================
!  Define information about the model:
!
 
!>  Define information about the model
!!
!! @include{doc} readMatrix_params.dox
Integer Function tria_readmatrix( lower, curr, upper, vsta, type, rhs, esta,      &
                                 colsta, rowno, value, nlflag, n, m, nz,  &
                                 usrmem )
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Tria_ReadMatrix
#endif
   Use casedata_num
   implicit none
   integer, intent (in)                      :: n      ! number of variables
   integer, intent (in)                      :: m      ! number of constraints
   integer, intent (in)                      :: nz     ! number of nonzeros
   real*8,  intent (in out), dimension(n)    :: lower  ! vector of lower bounds
   real*8,  intent (in out), dimension(n)    :: curr   ! vector of initial values
   real*8,  intent (in out), dimension(n)    :: upper  ! vector of upper bounds
   integer, intent (in out), dimension(n)    :: vsta   ! vector of initial variable status
                                                       ! (not defined here)
   integer, intent (out),    dimension(m)    :: type   ! vector of equation types
   integer, intent (in out), dimension(m)    :: esta   ! vector of initial equation status
                                                       ! (not defined here)
   real*8,  intent (in out), dimension(m)    :: rhs    ! vector of right hand sides
   integer, intent (in out), dimension(n+1)  :: colsta ! vector with start of column indices
   integer, intent (out),    dimension(nz)   :: rowno  ! vector of row numbers
   integer, intent (in out), dimension(nz)   :: nlflag ! vector of nonlinearity flags
   real*8,  intent (in out), dimension(nz)   :: value  ! vector of matrix values
   real*8   usrmem(*)                                  ! optional user memory
 
   integer :: i
!
!  Information about Variables:
!  Default: Lower = -Inf, Curr = 0, and Upper = +inf.
!  Default: the status information in Vsta is not used.
!
   lower(8) = 8.0d0      ! In most cases variable x8
   upper(8) = 8.0d0      ! is fixed at 8.
   curr(8)  = 8.d0
   lower(5) = 5.0d0      ! In most cases variable x5
   upper(5) = 5.0d0      ! is fixed at 5.
   curr(5)  = 5.d0
   If ( casenum == 2 ) Then
      lower(8) = lower(1)      ! In case 2 variable x8 is free
      upper(8) = upper(1)
      curr(8)  = 0.d0
   Endif
   If ( casenum == 3 ) Then
      lower(5) = lower(1)      ! In case 3 variable x5 is free
      upper(5) = upper(1)
      curr(5)  = 0.d0
      lower(8) = lower(1)      ! In case 3 variable x8 is free
      upper(8) = upper(1)
      curr(8)  = 0.d0
      lower(2) = 2.d0          ! In case 3 variable x2 is fixed at 2
      upper(2) = 2.d0
      lower(6) = 6.d0          ! In case 3 variable x6 is fixed at 6
      upper(6) = 6.d0
   Endif
   if ( casenum == 4 ) Then
      lower(3) = 4.d0       ! In case 3 x3 has a lower bound of 4
      curr(3)  = 4.d0
   Endif
   if ( casenum == 5 ) Then
      lower(3) = 4.d0       ! In case 4 x3 is fixed at 4
      upper(3) = 4.d0
      curr(3)  = 4.d0
   Endif
!
!  Information about Constraints:
!  Default: Rhs = 0
!  Default: the status information in Esta and the function
!           value in FV are not used.
!  Default: Type: There is no default.
!           0 = Equality,
!           1 = Greater than or equal,
!           2 = Less than or equal,
!           3 = Non binding.
!
   rhs(1)  =  9.0d0
   rhs(2)  = 24.0d0
   rhs(3)  = 10.0d0
   rhs(4)  =  7.0d0
   rhs(5)  = 17.0d0
   rhs(6)  = 10.0d0
   rhs(7)  = 15.0d0
   do i = 1, 6
      type(i) = 0 ! Equality
   enddo
   type(7) = 2 ! Less than or equal
!
!  Information about the Jacobian. CONOPT expects a columnwise
!  representation in Rowno, Value, Nlflag and Colsta.
!
!  Colsta = Start of column indices (No Defaults):
!  Rowno  = Row indices
!  Value  = Value of derivative (by default only linear
!                                derivatives are used)
!  Nlflag = 0 for linear and 1 for nonlinear derivative
!           (not needed for completely linear models)
!
! e1..      x2                     + x7      =e= 9;
! e2.. x1      + x3      + x5      + x7 + x8 =e= 24;
! e3.. x1           + x4 + x5                =e= 10;
! e4..      x2           + x5                =e= 7;
! e5..                x4 + x5           + x8 =e= 17;
! e6.. x1      + x3           + x6           =e= 10;
! e7.. x1           + x4           + x7      =l= 15;
!
   colsta(1) =  1
   colsta(2) =  5
   colsta(3) =  7
   colsta(4) =  9
   colsta(5) = 12
   colsta(6) = 16
   colsta(7) = 17
   colsta(8) = 20
   colsta(9) = 22
   rowno(1)  =  2
   rowno(2)  =  3
   rowno(3)  =  6
   rowno(4)  =  7
   rowno(5)  =  1
   rowno(6)  =  4
   rowno(7)  =  2
   rowno(8)  =  6
   rowno(9)  =  3
   rowno(10) =  5
   rowno(11) =  7
   rowno(12) =  2
   rowno(13) =  3
   rowno(14) =  4
   rowno(15) =  5
   rowno(16) =  6
   rowno(17) =  1
   rowno(18) =  2
   rowno(19) =  7
   rowno(20) =  2
   rowno(21) =  5
!
!  Nonlinearity Structure: The model is linear and nlflag is not needed.
!
!  Value (Linear only): All Jacobian elements are 1
!
   do i = 1, 18 ! The last 3 elements are not defined. Should give an error.
      value(i) = 1.0d0
   enddo
 
  tria_readmatrix = 0 ! Return value means OK
 
end Function tria_readmatrix
!
!==========================================================================
!  Compute nonlinear terms and non-constant Jacobian elements
!
 
!>  Compute nonlinear terms and non-constant Jacobian elements
!!
!! @include{doc} fdeval_params.dox
Integer Function tria_fdeval( x, g, jac, rowno, jcnm, mode, ignerr, errcnt, &
                              n, nz, thread, usrmem )
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Tria_FDEval
#endif
   implicit none
   integer, intent (in)                      :: n      ! number of variables
   integer, intent (in)                      :: rowno  ! number of the row to be evaluated
   integer, intent (in)                      :: nz     ! number of nonzeros in this row
   real*8,  intent (in),     dimension(n)    :: x      ! vector of current solution values
   real*8,  intent (in out)                  :: g      ! constraint value
   real*8,  intent (in out), dimension(n)    :: jac    ! vector of derivatives for current constraint
   integer, intent (in),     dimension(nz)   :: jcnm   ! list of variables that appear nonlinearly
                                                       ! in this row. Ffor information only.
   integer, intent (in)                      :: mode   ! evaluation mode: 1 = function value
                                                       ! 2 = derivatives, 3 = both
   integer, intent (in)                      :: ignerr ! if 1 then errors can be ignored as long
                                                       ! as errcnt is incremented
   integer, intent (in out)                  :: errcnt ! error counter to be incremented in case
                                                       ! of function evaluation errors.
   integer, intent (in)                      :: thread
   real*8   usrmem(*)                                  ! optional user memory
 
!
!  The model is linear and FDEval should never be called.
!
   tria_fdeval = 1
 
end Function tria_fdeval