comdeclp.f90

Go to the documentation of this file.

#if defined(_WIN32) && !defined(_WIN64)
#define dec_directives_win32
#endif
 
Module proginfop
!
!  Module with information about the program used to check if the
!  example executed properly and write messages accordingly.
!  This is a version for parallel use with less functionality than
!  in the standard comdecl.f90 version
!
   Implicit NONE
   Character(len=128):: Progname    ! Program name
   Logical :: Nameread = .false.
   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
   Logical :: debug    = .false. ! Can be used to turn extra output on.
 
   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
      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')
!$    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 proginfop
!
!  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 proginfop
   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.
!
   Use proginfop
   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
   CHARACTER*5, Parameter, Dimension(4) :: basc = (/ 'Lower','Upper','Basic','Super' /)
   CHARACTER*6, Parameter, Dimension(4) :: stat = (/ 'Normal','NonOpt','Infeas','Unbnd ' /)
 
   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))
   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))
   ENDDO
   Call flush(10)
 
   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 proginfop
   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 proginfop
   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)
1001  FORMAT('Variable',i8,' : ',a)
1002  FORMAT('Equation',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(*)
 
   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
                         forcedlower     =  7, & ! A variable is forced to the lower bound by a ForcingLower or
                                                 ! ForcingUpper constraint.
                         forcedupper     =  8, & ! A variable is forced to the upper bound by a ForcingLower or
                                                 ! ForcingUpper constraint.
                         forcinglower    =  9, & ! A constraint is forcing all variables in it to a bound
                                                 ! and it works as an =L= constraint.
                         forcingupper    = 10, & ! 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  = 11, & ! An equation has only one nonfixed variable, but it cannot
                                                 ! be solved either because the variable will exceed a bound.
                         pretriainfeasp  = 12, & ! An equation has only one nonfixed variable, but it cannot
                                                 ! be solved either because the pivot (derivative) is too small.
                         forcinginfeas   = 13, & ! A constraint is infeasible due to bounds on all variables
                         inconsistentrow = 14    ! All structural variables are fixed and the row in infeasible
                                                 ! or the row is feasible due to bounds on all variables.
 
!   write(10,*) 'TriOrd: Mode=',mode,' Type=',Type,' Status=',Status,' Irow=',Irow,' Icol=',Icol,' Inf=',Inf,' Value=',Value,' Resid=',Resid
   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 (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 (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 (pretriainfeasp)
         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 moved to the 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