triabad12.f90

Go to the documentation of this file.

!> @file triabad12.f90
!! @ingroup FORT1THREAD_EXAMPLES
!!
!! This is a CONOPT implementation of the GAMS model:
!! 
!! @verbatim
!! variable x1, x2, x3, x4;
!! equation e1, e2, e3, e4, e5;
!! 
!! e1 .. sqr(x1) =E= 1;
!! e2 .. power(x2,3) =E= 1;
!! e3 .. x1 + x3 =E= 2;
!! e4 .. x3 + sqr(x2) =E= 2;
!! e5 .. x4 =E= x1 + x3;
!! 
!! x1.l = 0.999;
!! x2.l = 0.010;
!! 
!! model m / all /;
!! solve m using nlp maximizing x4;
!! @endverbatim
!! 
!! Similar to triabad11 but with one extra recursive equation added.
!! First e1 and e2 are recursive singletons and e1 will be solved first
!! for x1 due to the better initial value.
!! Given x1, e2 and e3 are recursive singletons, and e3 will be solved
!! first with respect to x3 because it is linear.
!! Given x1 and x3, e2, e4, and e5 are recursive singletons. e5 is
!! linear so it is solved first wrt x4, the objective function.
!! Finally e2 and e4 both candidate equations and the one to be selected
!! depends on the pivot size and since we expect x2 < 1, e4 should
!! have the better pivot.
!! 
!!
!! 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 triabad12
 
   Use proginfo
   Use conopt
   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
!
!  Create and initialize a Control Vector
!
   call startup
 
   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, 4 ) )  ! # variables
   coi_error = max( coi_error, coidef_numcon( cntvect, 5 ) )  ! # constraints
   coi_error = max( coi_error, coidef_numnz( cntvect, 9 ) )  ! # nonzeros in the Jacobian
   coi_error = max( coi_error, coidef_numnlnz( cntvect, 3 ) )  ! # of which are nonlinear
   coi_error = max( coi_error, coidef_optdir( cntvect, -1 ) ) ! Minimize
   coi_error = max( coi_error, coidef_objvar( cntvect, 4 ) )  ! Objective is variable 4
   coi_error = max( coi_error, coidef_optfile( cntvect, 'triabad12.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     ) )
 
#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
!
!  Save the solution so we can check the duals:
!
   do_allocate = .true.
!
!  Start CONOPT:
!
   coi_error = coi_solve( cntvect )
 
   write(*,*)
   write(*,*) 'End of Triabad12 example. Return code=',coi_error
 
   If ( coi_error /= 0 ) then
      call flog( "Errors encountered during solution", 1 )
   elseif ( stacalls == 0 .or. solcalls == 0 ) then
      call flog( "Status or Solution routine was not called", 1 )
   elseif ( sstat /= 1 .or. mstat /= 2 ) then
      call flog( "Solver and Model Status was not as expected (1,2)", 1 )
   elseif ( abs( obj-2.0d0 ) > 0.000001d0 ) then
      call flog( "Incorrect objective returned", 1 )
   Else
      Call checkdual( 'Triabad12', infeasible )
   endif
 
   if ( coi_free(cntvect) /= 0 ) call flog( "Error while freeing control vector",1)
 
   call flog( "Successful Solve", 0 )
 
End Program triabad12
!
! ============================================================================
!  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
   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 initial values for x1 and x2
!
   curr(1) =  0.999d0
   curr(2) =  0.01d0
!
!  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 = 1.0 and type Equality
!
   rhs(1)  = 1.0d0
   type(1) = 0
!
!  Constraint 2: e2
!  Rhs = 1.0 and type Equality
!
   rhs(2)  = 1.0d0
   type(2) = 0
!
!  Constraint 3: e3
!  Rhs = 2.0 and type Equality
!
   rhs(3)  = 2.0d0
   type(3) = 0
!
!  Constraint 4: e4
!  Rhs = 2.0 and type Equality
!
   rhs(4)  = 2.0d0
   type(4) = 0
!
!  Constraint 5: e5
!  Rhs = 0.0 and type Equality
!
   type(5) = 0
!
!  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)
!
!  Indices
!       x(1)  x(2)  x(3)  x(4)
!  1:    1
!  2:          4
!  3:    2           6
!  4:          5     7
!  5:    3           8     9
!
   colsta(1) =  1
   colsta(2) =  4
   colsta(3) =  6
   colsta(4) =  9
   colsta(5) = 10
   rowno(1)  =  1
   rowno(2)  =  3
   rowno(3)  =  5
   rowno(4)  =  2
   rowno(5)  =  4
   rowno(6)  =  3
   rowno(7)  =  4
   rowno(8)  =  5
   rowno(9)  =  5
!
!  Nonlinearity Structure: L = 0 are linear and NL = 1 are nonlinear
!       x(1)  x(2)  x(3)  x(4)
!  1:    NL
!  2:         NL
!  3:     L          L
!  4:         NL     L
!  5:     L          L    L
!
   nlflag(1) =  1
   nlflag(2) =  0
   nlflag(3) =  0
   nlflag(4) =  1
   nlflag(5) =  1
   nlflag(6) =  0
   nlflag(7) =  0
   nlflag(8) =  0
   nlflag(9) =  0
!  e1 .. sqr(x1) =E= 1;
!  e2 .. power(x2,3) =E= 1;
!  e3 .. x1 + x3 =E= 2;
!  e4 .. x3 + sqr(x2) =E= 2;
!  e5 .. x4 =E= x1 + x3;
!
!  Value (Linear only)
!       x(1)  x(2)  x(3)  x(4)
!  1:    NL
!  2:         NL
!  3:   1.0         1.0
!  4:         NL    1.0
!  5:  -1.0        -1.0   1.0
!
   value(2)  =  1.d0
   value(3)  = -1.d0
   value(6)  =  1.d0
   value(7)  =  1.d0
   value(8)  = -1.d0
   value(9)  =  1.d0
 
  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
!
!  Row 1: e1 .. sqr(x1) =E= 1;
!
   if ( rowno == 1 ) then
!
!  Mode = 1 or 3. G = sqr(x1)
!
      if ( mode == 1 .or. mode == 3 ) then
         g    = x(1)*x(1)
      endif
!
!  Mode = 2 or 3: Derivative values:
!
      if ( mode .eq. 2 .or. mode .eq. 3 ) then
         jac(1) = 2.d0*x(1)
      endif
      tria_fdeval = 0
   else if ( rowno == 2 ) then
!
!  e2 .. power(x2,3) =E= 1;
!
      if ( mode == 1 .or. mode == 3 ) then
         g    = x(2)*x(2)*x(2)
      endif
      if ( mode .eq. 2 .or. mode .eq. 3 ) then
         jac(2) = 3.d0*x(2)*x(2)
      endif
      tria_fdeval = 0
   else if ( rowno == 4 ) then
!
!  e4 .. x3 + sqr(x2) =E= 2;
!
      if ( mode == 1 .or. mode == 3 ) then
         g    = x(2)*x(2)
      endif
      if ( mode .eq. 2 .or. mode .eq. 3 ) then
         jac(2) = 2.d0*x(2)
      endif
      tria_fdeval = 0
   else
      tria_fdeval = 1
   endif
 
end Function tria_fdeval