comdecl.f90

Go to the documentation of this file.

#if defined(_WIN32) && !defined(_WIN64)
#define dec_directives_win32
#endif
 
Module proginfo
!
!  Module with information about the progress of the program used to
!  check if the examples execute properly and write messages accordingly.
!
   IMPLICIT NONE
   Character(len=128):: Progname    ! Program name
   Integer :: Stacalls = 0 ! Number of times Std_Status has been called
   Integer :: solcalls = 0 ! Number of times Std_Solution has been called
   real*8  :: obj          ! Objective in last Std_Status
   Integer :: mstat    = 0 ! Value of MODSTA in last Std_Status
   Integer :: sstat    = 0 ! Value of SOLSTA in last Std_Status
   Integer :: miter    = 0 ! Value of ITER in last Std_Status
   Integer :: c_infeas = 0 ! Count of infeasibilities in last Std_Solution
   Integer :: c_nonopt = 0 ! Count of non-optimalities in last Std_Solution
   Integer :: c_unbnd  = 0 ! Count of unbounded in last Std_Solution
   real*8, Dimension(:), Pointer :: xprim, xdual ! Primal and dual values for variables
   real*8, Dimension(:), Pointer :: uprim, udual ! Primal and dual values for equations
   Integer, Dimension(:), Pointer :: xbasc, xstat  ! Basis and Status value for variables
   Integer, Dimension(:), Pointer :: ubasc, ustat  ! Basis and Status value for equations
   Logical :: do_allocate ! If set to .true. then allocate above vectors at first call to Std_Solution
   Integer :: maxvar, maxcon ! If defined then these sizes are used to allocate space
                             ! for variable and constraint related vectors with Do_allocate
 
   Integer, Parameter :: minimize = 1, maximize = 2, infeasible = 3
!  Basis status for variables:
   Integer, Parameter :: bslower = 0, bsupper = 1, bsbasic = 2, bssuper = 3
 
   Contains
!
!  Nullify pointers, get the name of the program, and write the first
!  status-line with "Starting to execute".
!
   Subroutine startup
!$    Use OMP_Lib
      IMPLICIT NONE
!$    Integer :: MaxThread
      Nullify(xprim); Nullify(xdual)
      Nullify(uprim); Nullify(udual)
      read(*,"(A)") progname
      call flog( "Starting to execute", 0 )
!
!  Open the Progname.lst and Progname.sta files on unit 10 and 11
!
      open(10,file=trim(progname) // '.lst',status='Unknown')
      open(11,file=trim(progname) // '.sta',status='Unknown')
      do_allocate = .false.
      maxvar = 0; maxcon = 0
!$    maxthread = OMP_GET_MAX_THREADS() ! We make the call to force the right libraries to be loaded.
   End Subroutine startup
!
!  Write a one-line status report used to monitor in the Progname.rc file
!  how far the program has progressed.
!
   Subroutine flog( Msg, Code )
      IMPLICIT NONE
      character(len=*), Intent(IN) :: Msg
      Integer, Intent(IN) :: Code
 
      open(15,file=trim(progname) // '.rc',action='write',form='formatted',status='unknown')
      write(15,"(A,': ',A)") trim(progname), msg
      close(15)
      if ( code /= 0 ) then ! Error return.
         close(10)          ! Close the Status and
         close(11)          ! Document files and
         stop 1             ! Stop
      Endif
   End Subroutine flog
 
End Module proginfo
!
!  Standard routines for Message, Status, Solution, and ErrMsg called
!  Std_Message, Std_Status, Std_Solution, and Std_ErrMsg.
!  The routines assume that the documentation file is opened as unit
!  10 and that the status file is opened as unit 11.
!  The routines are use in the model if they are defined as callbacks
!  using the COIDEF_* routines. Otherwise, they will be ignored.
!  The routines are intended as inspiration for some more realistic
!  and useful implementations.
!
Integer Function std_status( MODSTA, SOLSTA, ITER, OBJVAL, USRMEM )
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_Status
#endif
!
!  Simple implementation in which we write to all files
!
   Use proginfo
   IMPLICIT NONE
   INTEGER, Intent(IN)        :: modsta, solsta, iter
   real*8,  Intent(IN)        :: objval
   real*8,  Intent(IN OUT)    :: usrmem(*)
 
   WRITE(*,*)
   WRITE(*,*) 'CONOPT has finished optimizing.'
   WRITE(*,*) 'Model status   =',modsta
   WRITE(*,*) 'Solver status  =',solsta
   WRITE(*,*) 'Iteration count=',iter
   WRITE(*,*) 'Objective value=',objval
 
   WRITE(10,*)
   WRITE(10,*) 'CONOPT has finished optimizing.'
   WRITE(10,*) 'Model status   =',modsta
   WRITE(10,*) 'Solver status  =',solsta
   WRITE(10,*) 'Iteration count=',iter
   WRITE(10,*) 'Objective value=',objval
 
   WRITE(11,*)
   WRITE(11,*) 'Model status   =',modsta
   WRITE(11,*) 'Solver status  =',solsta
   WRITE(11,*) 'Objective value=',objval
   Call flush(10)
   Call flush(11)
 
   stacalls = stacalls + 1
   obj   = objval
   mstat = modsta
   sstat = solsta
   miter = iter
 
   std_status = 0
 
END Function std_status
 
Integer Function std_solution( XVAL, XMAR, XBAS, XSTA, YVAL, YMAR, YBAS, YSTA, N, M, USRMEM )
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_Solution
#endif
!
!  Simple implementation in which we write the solution values to
!  the 'Documentation file' on unit 10.
!  If Xprim and Uprim are allocated with enough space, the primal and
!  dual solutions are also saved to Xprim and Uprim.
!
   Use proginfo
   IMPLICIT NONE
   INTEGER, Intent(IN)                  :: n, m
   INTEGER, Intent(IN),    Dimension(N) :: xbas, xsta
   INTEGER, Intent(IN),    Dimension(M) :: ybas, ysta
   real*8,  Intent(IN),    Dimension(N) :: xval, xmar
   real*8,  Intent(IN),    Dimension(M) :: yval, ymar
   real*8,  Intent(IN OUT)              :: usrmem(*)
 
   INTEGER :: i, na, ma
   CHARACTER*5, Parameter, Dimension(4) :: basc = (/ 'Lower','Upper','Basic','Super' /)
   CHARACTER*6, Parameter, Dimension(4) :: stat = (/ 'Normal','NonOpt','Infeas','Unbnd ' /)
 
   c_infeas = 0
   c_nonopt = 0
   c_unbnd  = 0
   WRITE(10,"(/' Variable    Solution value    Reduced cost   Var-Basc    Var-stat')")
   DO i = 1, n
      WRITE(10,"(1P,I7,E20.6,E16.6,4X,A5,7X,A6 )") i, xval(i), xmar(i), basc(1+xbas(i)), stat(1+xsta(i))
      if ( xsta(i) == 1 ) c_nonopt = c_nonopt + 1
      if ( xsta(i) == 2 ) c_infeas = c_infeas + 1
      if ( xsta(i) == 3 ) c_unbnd  = c_unbnd  + 1
   ENDDO
 
   WRITE(10,"(/' Constrnt    Activity level    Marginal cost  Con-Basc    Con-stat')")
   DO i = 1, m
      WRITE(10,"(1P,I7,E20.6,E16.6,4X,A5,7X,A6 )") i, yval(i), ymar(i), basc(1+ybas(i)), stat(1+ysta(i))
      if ( ysta(i) == 1 ) c_nonopt = c_nonopt + 1
      if ( ysta(i) == 2 ) c_infeas = c_infeas + 1
      if ( ysta(i) == 3 ) c_unbnd  = c_unbnd  + 1
   ENDDO
   if ( c_nonopt > 0 ) write(10,"(/' Number of non-optimalities =',i5)") c_nonopt
   if ( c_infeas > 0 ) write(10,"(/' Number of infeasibilities  =',i5)") c_infeas
   Call flush(10)
   Call flush(11)
 
   If ( do_allocate ) Then
      If ( maxvar > 0 ) then; na = maxvar; else; na = n; Endif
      If ( maxcon > 0 ) then; ma = maxcon; else; ma = m; Endif
      Allocate( xprim(na), xdual(na), uprim(ma), udual(ma), xbasc(na), xstat(na), ubasc(ma), ustat(ma) )
      do_allocate = .false.
   Endif
   If ( associated(xprim) .and. associated(xdual) .and. associated(uprim) .and. associated(udual) ) Then
      If ( Size(xprim) >= n .and. Size(xdual) >= n .AND. Size(uprim) >= m .and. Size(udual) >= m ) Then
         xprim(1:n) = xval(1:n)
         xdual(1:n) = xmar(1:n)
         uprim(1:m) = yval(1:m)
         udual(1:m) = ymar(1:m)
      Endif
   Endif
   If ( associated(xbasc) .and. associated(xstat) .and. associated(ubasc) .and. associated(ustat) ) Then
      If ( Size(xbasc) >= n .and. Size(xstat) >= n .AND. Size(ubasc) >= m .and. Size(ustat) >= m ) Then
         xbasc(1:n) = xbas(1:n)
         xstat(1:n) = xsta(1:n)
         ubasc(1:m) = ybas(1:m)
         ustat(1:m) = ysta(1:m)
      Endif
   Endif
   solcalls = solcalls + 1
   std_solution = 0
 
END Function std_solution
 
Integer Function std_message( SMSG, DMSG, NMSG, LLEN, USRMEM, MSGV )
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_Message
#endif
!
!  Simple implementation in which we only write the 'Screen file'
!  to unit *, the 'Status file' to unit 11, and the 'Documentation file'
!  to unit 10.
!
   Use proginfo
   IMPLICIT NONE
 
   INTEGER,            Intent(IN)                   :: smsg, dmsg, nmsg
   INTEGER,            Intent(IN) ,  Dimension(*)   :: llen
   CHARACTER(Len=133), Intent(IN),   Dimension(*)   :: msgv
   real*8,             Intent(IN OUT)               :: usrmem(*)
 
   Integer :: i
!
!  write to screen
!
   do i = 1, smsg
      write(*,"(A)") msgv(i)(1:llen(i))
   enddo
!
!  write to status file
!
   do i = 1, nmsg
      write(11,"(A)") msgv(i)(1:llen(i))
   enddo
!
!  write to document file
!
   do i = 1, dmsg
      write(10,"(A)") msgv(i)(1:llen(i))
   enddo
   Call flush(10)
   Call flush(11)
 
   std_message = 0
 
END Function std_message
 
Integer Function std_errmsg( ROWNO, COLNO, POSNO, MSGLEN, USRMEM, MSG )
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_ErrMsg
#endif
!
!  Simple implementation of ErrMsg in which we just write 'Variable XX',
!  'Equation YY' or 'Variable XX appearing in Equation YY' followed by
!  the text. We write both to the 'Documentation file' on unit 10 and
!  to the 'Status File' on unit 11.
!
   Use proginfo
   IMPLICIT NONE
 
   INTEGER,          Intent(IN)                    :: rowno, colno, posno, msglen
   CHARACTER(len=*), Intent(IN)                    :: msg
   real*8,           Intent(IN OUT)                :: usrmem(*)
!
!  If Rowno = 0 then the message is about a Column.
!  If Colno = 0 then the message is abuut a Row.
!  Otherwise, the message is about (Rowno,Colno)
!
   IF    ( rowno .EQ. 0 ) THEN  ! Must be a column (error) message
      WRITE(10,1001) colno, msg(1:msglen)
      WRITE(11,1001) colno, msg(1:msglen)
   ELSEIF ( colno .EQ. 0 ) THEN  ! Must be a row (error) message
      WRITE(10,1002) rowno, msg(1:msglen)
      WRITE(11,1002) rowno, msg(1:msglen)
   ELSE                          ! Must be a (row,col) (error) message
      WRITE(10,1000) colno, rowno, msg(1:msglen)
      WRITE(11,1000) colno, rowno, msg(1:msglen)
   ENDIF
   Call flush(10)
   Call flush(11)
1002  FORMAT('Equation',i8,' : ',a)
1001  FORMAT('Variable',i8,' : ',a)
1000  FORMAT('Variable',i8,' appearing in Equation',i8,' : ',a)
 
   std_errmsg = 0
 
END Function std_errmsg
 
Integer Function std_triord( Mode, Type, Status, Irow, Icol, Inf, Value, Resid, Usrmem )
#ifdef dec_directives_win32
!DEC$ ATTRIBUTES STDCALL, REFERENCE, NOMIXED_STR_LEN_ARG :: Std_TriOrd
#endif
!
!  Simple implementation of the TriOrd callback routine.
!
   Implicit NONE
   INTEGER, INTENT(IN)                  :: mode, Type, status, irow, icol, inf
   real*8,  INTENT(IN)                  :: VALUE, resid
   real*8,  Intent(IN OUT)              :: usrmem(*)
 
!  This list has been copied here from src/preaction.inc
!  Eventually, it should maybe move into conopt.f90 and conopt.h.
   Integer, Parameter :: pretriangular   =  1, & ! Fix a structural variable from an equality equation
                         fixedcolumn     =  2, & ! Fix a structural variable from equal lower and upper bouunds
                         dependentrow    =  3, & ! All structural variables are fixed and the row is feasible
                         redundantrow    =  4, & ! The row is feasible due to bounds on all variables.
                         impliedlower    =  5, & ! Change a simple inequality to a lower bound
                         impliedupper    =  6, & ! Change a simple inequality to an upper bound
                         impliedrange    =  7, & ! Changed a ranged constraint to both a lower and an upper bound.
                         forcedlower     =  8, & ! A variable is forced to the lower bound by a ForcingLower or
                                                 ! ForcingUpper constraint.
                         forcedupper     =  9, & ! A variable is forced to the upper bound by a ForcingLower or
                                                 ! ForcingUpper constraint.
                         forcedvalue     = 10, & ! A variable if forced to a value equal to an implied but not
                                                 ! original bound by a ForcingLower or ForcingUpper constraint
                         forcinglower    = 11, & ! A constraint is forcing all variables in it to a bound
                                                 ! and it works as an =L= constraint.
                         forcingupper    = 12, & ! A constraint is forcing all variables in it to a bound
                                                 ! and it works as an =G= constraint.
!
!  Any of the next actions will terminate the pre-processor and there can therefore only be one of them
!  and only in an infeasible model.
!
                         pretriainfeasb  = 13, & ! An equation has only one nonfixed variable, but it cannot
                                                 ! be solved because the variable will exceed a bound.
                         pretriainfeasl  = 14, & ! An equation has only one nonfixed variable, but it cannot
                                                 ! be solved because the infeasibility is at a (local) minimum.
                         forcinginfeas   = 15, & ! A constraint is infeasible due to bounds on all variables
                         inconsistentrow = 16, & ! All structural variables are fixed and the row in infeasible
                         wforcinginfeas  = 17, & ! A constraint is forcing but based on weak bound so no traceback
!
!  FixedDual is only used if the preprocessor terminates properly (feasible) and is always last
!
                         fixeddual       = 18    ! A variable is fixed based on dual information.
 
   If ( mode == -1 ) THEN
      write(10,"(/'The preprocessing transformation are described below in detection order:'/)")
   Else if ( mode == -2 ) Then
      write(10,"(//'The order of the critical transformations is:'/)")
   Endif
   Select case (type)
      Case (pretriangular)
         If ( inf == 0 ) Then
            WRITE(10,"('Equation',i7,' solved with respect to variable',i7,'. Value=',1p,e18.10)") irow, icol, value
         Elseif ( inf == 1 ) Then
            WRITE(10,"('Equation',i7,' solved with respect to variable',i7,'. Value=',9x,'+Infinity')") irow, icol
         Else
            WRITE(10,"('Equation',i7,' solved with respect to variable',i7,'. Value=',9x,'-Infinity')") irow, icol
         Endif
      Case (fixedcolumn)
         WRITE(10,"('Variable',i7,' fixed at value=',1p,e18.10)") icol, value
      Case (dependentrow)
         WRITE(10,"('Equation',i7,' is dependent (all variables are fixed.)')") irow
      Case (redundantrow)
         WRITE(10,"('Equation',i7,' is redundant (will later be solved with respect to the slack.)')") irow
      Case (impliedlower)
         WRITE(10,"('Equation',i7,' turned into lower bound on variable',i7,'. Bound=',1p,e18.10)") irow, icol, value
      Case (impliedupper)
         WRITE(10,"('Equation',i7,' turned into upper bound on variable',i7,'. Bound=',1p,e18.10)") irow, icol, value
      Case (impliedrange)
         WRITE(10,"('Ranged Equation',i7,' turned into two bounds on variable',i7,'. Bound=',1p,e18.10)") irow, icol, value
      Case (forcedlower)
         WRITE(10,"('Variable',i7,' forced to lower bound=',1p,e18.10)") icol, value
      Case (forcedupper)
         WRITE(10,"('Variable',i7,' forced to upper bound=',1p,e18.10)") icol, value
      Case (forcedvalue)
         WRITE(10,"('Variable',i7,' forced to implied bound=',1p,e18.10)") icol, value
      Case (forcinglower)
         WRITE(10,"('Previous variables were forced by equation',i7,' binding as a less than or equal constraint.')") irow
      Case (forcingupper)
         WRITE(10,"('Previous variables were forced by equation',i7,' binding as a greater than or equal constraint.')") irow
      Case (pretriainfeasb)
         WRITE(10,"('Equation',i7,' cannot be solved with respect to variable',i7,' due to bounds. Value=',1p,e18.10)") &
            irow, icol, value
      Case (pretriainfeasl)
         WRITE(10, &
    "('Equation',i7,' cannot be solved with respect to variable',i7,'. Infeasibility has local minimum at',1p,e18.10)") &
            irow, icol, value
      Case (forcinginfeas)
         WRITE(10,"('Equation',i7,' is still infeasible after the above variables have been forced to their best bounds.')") irow
      Case (inconsistentrow)
         WRITE(10,"('Equation',i7,' cannot be solved. No free variables left.')") irow
      Case Default
         WRITE(10,"('Pretriangular action=',i7,' not implemented yet.')") type
         stop 1
   End Select
   If ( resid /= 0.d0 ) write(10,"('Residual after last transformation=',1p,e18.10)") resid
   Call flush(10)
 
   std_triord = 0
 
End Function std_triord
 
Subroutine checkdual( Case, MinMax )
!
!  This routine can check if the status and dual information is
!  consistent.
!  Case is a string to be added in front of any error messages.
!  MinMax defines termination status of the model according to
!  Integer, Parameter :: Minimize = 1, Maximize = 2, Infeasible = 3
!  The solution must not be in an intermediate state.
!
!  The solution must have been saved using DO_Allocate and the size
!  of the model must correspond to the sizes of the allocated vectors,
!  i.e. MaxVar and MaxCon cannot be used with this routine.
!
   Use proginfo
   Implicit NONE
   Character(Len=*), Intent(IN) :: Case
   INTEGER, INTENT(IN) :: MinMax
 
   real*8, Parameter :: opttol = 2.d-6
   Integer :: I
   Character(Len=120) Text
 
   If ( solcalls <= 0 ) Return
   If ( .not. ( associated(xprim) .and. associated(xdual) .and. associated(uprim) .and. associated(udual) ) ) Return
   If ( .not. ( associated(xbasc) .and. associated(xstat) .and. associated(ubasc) .and. associated(ustat) ) ) Return
!
!  Check variable status. Must be normal
!
   do i = 1, Size(xstat)
      If ( xstat(i) /= 0 ) then
         write(text, "(A,': Status of variable',i6,' is not zero(normal). Is',i10)") Case, i, xstat(i)
         call flog( trim(text), 1 )
      Endif
   Enddo
!
!  Check Variable Basis status is consistent with the reduced cost in Xdual
!
   do i = 1, size(xbasc)
      select case(xbasc(i))
         case(bslower)
            if ( minmax == maximize ) then
               if ( xdual(i) > opttol ) then
                  write(text, "(A,': Max and variable',i6,' at lower. Reduced cost is positive:',1p,d15.6)") Case, i, xdual(i)
                  call flog( trim(text), 1 )
               Endif
            else ! Minimize or infeasible
               if ( xdual(i) < -opttol ) then
                  write(text, "(A,': Min and variable',i6,' at lower. Reduced cost is negative:',1p,d15.6)") Case, i, xdual(i)
                  call flog( trim(text), 1 )
               Endif
            endif
         case(bsupper)
            if ( minmax == maximize ) then
               if ( xdual(i) < -opttol ) then
                  write(text, "(A,': Max and variable',i6,' at upper. Reduced cost is negative:',1p,d15.6)") Case, i, xdual(i)
                  call flog( trim(text), 1 )
               Endif
            else ! Minimize or infeasible
               if ( xdual(i) > opttol ) then
                  write(text, "(A,': Min and variable',i6,' at upper. Reduced cost is positive:',1p,d15.6)") Case, i, xdual(i)
                  call flog( trim(text), 1 )
               Endif
            endif
         case(bsbasic)
            if ( xdual(i) /= 0.d0 ) then
               write(text, "(A,': Basic variable',i6,' does not have reduced cost zero. Is',1p,d15.6)") Case, i, xdual(i)
               call flog( trim(text), 1 )
            Endif
         case(bssuper)
            if ( abs( xdual(i) ) > opttol ) then
               write(text, "(A,': Superbasic variable',i6,' does not have small reduced cost. Is',1p,d15.6)") Case, i, xdual(i)
               call flog( trim(text), 1 )
            Endif
         case default
            write(text, "(A,': Variable',i6,' bas illegal basis status:',I10)") Case, i, xbasc(i)
            call flog( trim(text), 1 )
      end select
   enddo
!
!  Check Equation status. Must be normal if the model is not infeasible
!
   if ( minmax /= infeasible ) then
      do i = 1, Size(ustat)
         If ( ustat(i) /= 0 ) then
            write(text, "(A,': Status of constraint',i6,' is not zero(normal). Is',i10)") Case, i, ustat(i)
            call flog( trim(text), 1 )
         Endif
      Enddo
   Endif
!
!  Check Constraint Basis status is consistent with the reduced cost in Xdual
!
   do i = 1, size(ubasc)
      select case(ubasc(i))
         case(bslower)
            if ( minmax == maximize ) then
               if ( udual(i) > opttol ) then
                  write(text, "(A,': Max and constraint',i6,' at lower. Reduced cost is positive:',1p,d15.6)") Case, i, udual(i)
                  call flog( trim(text), 1 )
               Endif
            else ! Minimize or infeasible
               if ( udual(i) < -opttol ) then
                  write(text, "(A,': Min and constraint',i6,' at lower. Reduced cost is negative:',1p,d15.6)") Case, i, udual(i)
                  call flog( trim(text), 1 )
               Endif
            endif
         case(bsupper)
            if ( minmax == maximize ) then
               if ( udual(i) < -opttol ) then
                  write(text, "(A,': Max and constraint',i6,' at upper. Reduced cost is negative:',1p,d15.6)") Case, i, udual(i)
                  call flog( trim(text), 1 )
               Endif
            else ! Minimize or infeasible
               if ( udual(i) > opttol ) then
                  write(text, "(A,': Min and constraint',i6,' at upper. Reduced cost is positive:',1p,d15.6)") Case, i, udual(i)
                  call flog( trim(text), 1 )
               Endif
            endif
         case(bsbasic)
            if ( minmax /= infeasible .and. udual(i) /= 0.d0 ) then
               write(text, "(A,': Basic constraint',i6,' does not have reduced cost zero. Is',1p,d15.6)") Case, i, udual(i)
               call flog( trim(text), 1 )
            Endif
         case(bssuper)
            if ( minmax /= infeasible .and. abs( udual(i) ) > opttol ) then
               write(text, "(A,': Superbasic constraint',i6,' does not have small reduced cost. Is',1p,d15.6)") Case, i, udual(i)
               call flog( trim(text), 1 )
            Endif
         case default
            write(text, "(A,': Constraint',i6,' bas illegal basis status:',I10)") Case, i, ubasc(i)
            call flog( trim(text), 1 )
      end select
   enddo
 
End Subroutine checkdual