largerhs.f90

Go to the documentation of this file.

!> @file largerhs.f90
!! @ingroup FORT1THREAD_EXAMPLES
!!
!! 
!! Model with large right Hand Side
!! 
!! The model is a copy of force01 with adjusted right hand sides.
!! The model does not make sense -- it is only intended to test that
!! large right hand sides are flagged as errors.
!! Note that the large right hand side in e4 really means that the
!! constraint is non-binding. However, we still exclude it as an
!! error
!! 
!! This is a CONOPT implementation of the GAMS model:
!! 
!! @verbatim
!! variable x1, x2, x3, x4, x5, x6;
!! equation e1, e2, e3, e4, e5;
!! 
!! positive variable x4, x5;
!! x3.fx = 2;
!! x6.lo = 0;
!! 
!! e1 .. x1 +   x2                     =E= 2.e16;
!! e2 ..      4*x2 + x3                =E= 6;
!! e3 ..                  x4           =L= 1;
!! e4 ..        x2      + x4           =L= 1.e16;
!! e5 .. x1                  + x5 + x6 =L= 1;
!! 
!! model m / all /;
!! solve m using nlp minimizing x6;
!! solve m using nlp maximizing x6;
!! @endverbatim
!! 
!!
!! For more information about the individual callbacks, please have a look at the source code.
 
!> Main program. A simple setup and call of CONOPT
!!
Program largerhs
 
   Use proginfo
   Use coidef
   implicit None
!
!  Declare the user callback routines as Integer, External:
!
   Integer, External :: rhs_readmatrix ! Mandatory Matrix definition routine defined below
   Integer, External :: rhs_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
   Integer, External :: rhs_option     ! Option defining callback routine
#if defined(itl)
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Rhs_ReadMatrix
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Rhs_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
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Rhs_Option
#endif
!
!  Control vector
!
   INTEGER :: numcallback
   INTEGER, Dimension(:), Pointer :: cntvect
   INTEGER :: coi_error
 
   call startup
!
!  Create and initialize a Control Vector
!
   numcallback = coidef_size()
   Allocate( cntvect(numcallback) )
   coi_error = coidef_inifort( cntvect )
!
!  Tell CONOPT about the size of the model by populating the Control Vector:
!
   coi_error = max( coi_error, coidef_numvar( cntvect, 6 ) )  ! # variables
   coi_error = max( coi_error, coidef_numcon( cntvect, 5 ) )  ! # constraints
   coi_error = max( coi_error, coidef_numnz( cntvect, 10 ) ) ! # nonzeros in the Jacobian
   coi_error = max( coi_error, coidef_numnlnz( cntvect, 0 ) )  ! # of which are nonlinear
   coi_error = max( coi_error, coidef_optdir( cntvect, -1 ) ) ! Minimize
   coi_error = max( coi_error, coidef_objvar( cntvect, 6 ) )  ! Objective variable #
   coi_error = max( coi_error, coidef_optfile( cntvect, 'largerhs.opt' ) )
!
!  Tell CONOPT about the callback routines:
!
   coi_error = max( coi_error, coidef_readmatrix( cntvect, rhs_readmatrix ) )
   coi_error = max( coi_error, coidef_fdeval( cntvect, rhs_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     ) )
 
#if defined(LICENSE_INT_1) && defined(LICENSE_INT_2) && defined(LICENSE_INT_3) && defined(LICENSE_TEXT)
   coi_error = max( coi_error, coidef_license( cntvect, license_int_1, license_int_2, license_int_3, 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:
!
   coi_error = coi_solve( cntvect )
 
   write(*,*)
   write(*,*) 'End of LargeRhs example. Return code=',coi_error
!
!  The large right hand side should result in a setup error and a nonzero
!  return code in COI_Error
!
   If ( coi_error == 0 ) then
      call flog( "Expected errors were not found during solution", 1 )
   endif
!
!  Now repeat with an option that changes the upper bound
!
   coi_error = 0
   coi_error = max( coi_error, coidef_option( cntvect, rhs_option     ) )
   If ( coi_error .ne. 0 ) THEN
      write(*,*)
      write(*,*) '**** Fatal Error while loading CONOPT Callback routines for 2nd solve.'
      write(*,*)
      call flog( "Skipping 2nd Solve due to setup errors", 1 )
   ENDIF
!
!  Start CONOPT:
!
   coi_error = coi_solve( cntvect )
 
   if ( coi_free(cntvect) /= 0 ) call flog( "Error while freeing control vector",1)
 
   call flog( "Successful Solve", 0 )
 
End Program largerhs
!
! ============================================================================
!  Define information about the model:
!
 
!>  Define information about the model
!!
!! @include{doc} readMatrix_params.dox
Integer Function rhs_readmatrix( lower, curr, upper, vsta, type, rhs, esta,      &
                                 colsta, rowno, value, nlflag, n, m, nz,  &
                                 usrmem )
#if defined(itl)
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Rhs_ReadMatrix
#endif
   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
!
!  Information about Variables:
!  Default: Lower = -Inf, Curr = 0, and Upper = +inf.
!  Default: the status information in Vsta is not used.
!
!  The model uses defaults
!
!  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.
!
!  Constraint 1: e1
!  Rhs = 2.0 and type Equality
!
   rhs(1)  = 2.0d16 ! Special value
   type(1) = 0
!
!  Constraint 2: e2
!  Rhs = 6.0 and type Equality
!
   rhs(2)  = 6.0d0
   type(2) = 0
!
!  Constraint 3: e3
!  Rhs = 1.0 and type Less than or equal
!
   rhs(3) = 1.0d0
   type(3) = 2
!
!  Constraint 4: e4
!  Rhs = 1.0 and type Less than or equal
!
   rhs(4) = 1.0d16 ! Special value
   type(4) = 2
!
!  Constraint 5: e5
!  Rhs = 1.0 and type Less than or equal
!
   rhs(5) = 1.0d0
   type(5) = 2
!
!  Non-default Bounds
!
   lower(3) = 2.0d0
   upper(3) = 2.0d0
   lower(4) = 0.0d0
   lower(5) = 0.0d0
   lower(6) = 0.0d0
!
!  Information about the Jacobian. We use the standard method with
!  Rowno, Value, Nlflag and Colsta and we do not use Colno.
!
!  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)
!
!  Indices
!       x(1)  x(2)  x(3)  x(4)  x(5)  x(6)
!  1:    1     3
!  2:          4     6
!  3:                      7
!  4:          5           8
!  5:    2                       9     10
!
   colsta(1) =  1
   colsta(2) =  3
   colsta(3) =  6
   colsta(4) =  7
   colsta(5) =  9
   colsta(6) = 10
   colsta(7) = 11
   rowno(1)  =  1
   rowno(2)  =  5
   rowno(3)  =  1
   rowno(4)  =  2
   rowno(5)  =  4
   rowno(6)  =  2
   rowno(7)  =  3
   rowno(8)  =  4
   rowno(9)  =  5
   rowno(10) =  5
!
!  Nonlinearity Structure: Model is linear
!
!
!  Value (Linear only)
!       x(1)  x(2)  x(3)  x(4)  x(5)  x(6)
!  1:   1.0   1.0
!  2:         4.0    1.0
!  3:                     1.0
!  4:         1.0         1.0
!  5:   1.0                      1.0    1.0
!
   value(1)  =  1.d0
   value(2)  =  1.d0
   value(3)  =  1.d0
   value(4)  =  4.d0
   value(5)  =  1.d0
   value(6)  =  1.d0
   value(7)  =  1.d0
   value(8)  =  1.d0
   value(9)  =  1.d0
   value(10) =  1.d0
 
  rhs_readmatrix = 0 ! Return value means OK
 
end Function rhs_readmatrix
!
!==========================================================================
!  Compute nonlinear terms and non-constant Jacobian elements
!
 
!>  Compute nonlinear terms and non-constant Jacobian elements
!!
!! @include{doc} fdeval_params.dox
Integer Function rhs_fdeval( x, g, jac, rowno, jcnm, mode, ignerr, errcnt, &
                              n, nz, thread, usrmem )
#if defined(itl)
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Rhs_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 not be called.
!
   rhs_fdeval = 1
 
end Function rhs_fdeval
 
 
!>  Sets runtime options
!!
!! @include{doc} option_params.dox
Integer Function rhs_option( ncall, rval, ival, lval, usrmem, name )
#if defined(itl)
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Rhs_Option
#endif
   integer  ncall, ival, lval
   character(Len=*) :: name
   real*8   rval
   real*8   usrmem(*)                                  ! optional user memory
 
   Select case (ncall)
   case (1)
      name = 'Lim_Variable'
      rval = 1.d20
   case default
      name = ' '
   end Select
   rhs_option = 0
 
end Function rhs_option