C     ( Last modified on 12 Mar 2014 at 07:20:00 )

C Copyright (C) 2002, 2004, 2005 Carnegie Mellon University,
C                                Dominique Orban and others.
C
C All Rights Reserved.
C This code is published under the Eclipse Public License.
C*******************************************************************************
      PROGRAM IPOPT_main
C
C     IPOPT CUTEst driver.
C     D. Orban,  adapted from Andreas Waechter's CUTE driver.
C     Adapted for C++ version by Andreas Waechter, Oct 2004
C     CUTEst evolution, Nick Gould, January 2013

C     Adapted for unconstrained and bound-constrained problem plus
C     counting calls to cutest subroutines and computing f and bounds
C     violation at final iterate, Ernesto G. Birgin, June 2019.

      IMPLICIT NONE
      INTEGER, PARAMETER :: cnr_input = 60, inp_input = 70, out = 6
      INTEGER, PARAMETER :: io_buffer = 11
      INTEGER :: n, m, nz, ierr, status
      INTEGER :: idx_style, nele_jac, nele_hess
      DOUBLE PRECISION :: f,finish,start,bdsvio
      CHARACTER ( LEN = 10 ) :: pname
      INTEGER, ALLOCATABLE, DIMENSION( : ) :: IDAT
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION( : ) :: DAT
      DOUBLE PRECISION :: CPU( 2 ), CALLS( 7 )
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION( : ) :: X, X_l, X_u
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION( : ) :: Z_l, Z_u, LAM
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION( : ) :: G, G_l, G_u
      INTEGER :: IPSOLVE
CNOT64 INTEGER :: iproblem, IPCREATE
      INTEGER*8 :: iproblem, IPCREATE
      EXTERNAL :: EV_F, EV_G, EV_GRAD_F, EV_JAC_G, EV_HESS

C     The following arrays are work space for the evaluation subroutines

      integer :: i
      logical :: ex
      double precision :: init_val

      integer :: fcnt,gcnt,hcnt
      common /counters/ fcnt,gcnt,hcnt

      fcnt = 0
      gcnt = 0
      hcnt = 0
      
C  Open the problem data file.

      OPEN( cnr_input, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *      STATUS = 'OLD' )
      REWIND( cnr_input )

C  compute problem dimensions

      CALL CUTEST_udimen( status, cnr_input, n )
      IF ( status /= 0 ) GO TO 910

      m = 0

C  allocate space

      ALLOCATE( X( n ), X_l( n ), X_u( n ), Z_l( n ), Z_u( n ),
     *     LAM( 1 ), G( 1 ), G_l( 1 ), G_u( 1 ), STAT = status )
      
      IF ( status /= 0 ) GO TO 990

C     set up the data structures necessary to hold the problem functions

      CALL CUTEST_usetup( status,cnr_input, out, io_buffer,
     *                    n, X, X_l, X_u )

      CALL CUTEST_pname( status, cnr_input, pname )

      CLOSE( cnr_input )

C  see if we want to set a different initial point

      INQUIRE( file = 'INITPOINT.VAL', exist = ex )
      IF ( ex ) THEN
         OPEN( inp_input, FILE = 'INITPOINT.VAL', STATUS = 'old' )
         READ( inp_input, '(D25.16)' ) init_val
         DO i = 1, n
           X( i ) = init_val
         END DO
         CLOSE( inp_input )
      endif

C  obtain the number of nonzeros in Hessian

      nele_jac = 0
      
      CALL CUTEST_udimsh( status, nele_hess )

C  allocate furter space

      nz = MAX( nele_hess, 2 * n )
C correction by Elizabeth Wong: 12/3/14
      ALLOCATE( DAT( 2 * n + nz ), IDAT( 2 * nz ), STAT = status )
      IF ( status /= 0 ) GO TO 990

C  get problem name

C  call IPOPT

      call cpu_time(start)

      idx_STYLE = 1
      iproblem = IPCREATE( n, X_L, X_U, m, G_L, G_U,
     *                     nele_jac, nele_hess, idx_style,
     *                     EV_F, EV_G, EV_GRAD_F, EV_JAC_G, EV_HESS )
      IF ( iproblem .EQ. 0 ) THEN
        write(*,*) 'Error creating Ipopt Problem.'
        STOP
      END IF
      ierr = IPSOLVE( iproblem, X, G, F, LAM, Z_L, Z_U, IDAT, DAT )
      CALL IPFREE( iproblem )
      
      call cpu_time(finish)

C     Display CUTEst statistics

      CALL CUTEST_ureport( status, CALLS, CPU )
      IF ( status /= 0 ) GO TO 910
      WRITE( out, 2000 ) pname, n, m, int(CALLS( 1 )), int(CALLS( 2 )),
     *     int(CALLS( 3 )), int(CALLS( 4 )), int(CALLS( 5 )),
     *     int(CALLS( 6 )), int(CALLS( 7 )), ierr, f, CPU( 1 ), CPU( 2 )

C     *****************************************************************
C     *****************************************************************
C     Just checking ...

      call cutest_ufn(status,n,x,f)

      bdsvio = 0.0d0
      do i = 1,n
         bdsvio = max( bdsvio, x(i) - x_u(i) )
         bdsvio = max( bdsvio, x_l(i) - x(i) )
      end do

      write(*,*) 'Computed by caller f.......................:',f
      write(*,*) 'Computed by caller constraints violation...:',0.0d0
      write(*,*) 'Computed by caller bounds violation........:',bdsvio
      write(*,*) 'Computed by caller CPU time................:',
     *                                                    finish-start

      open(20,file='ipopt-tabline.txt')
      write(20,*) 'Not killed by reaching the CPU time limit.'
      close(20)
C     *****************************************************************
C     *****************************************************************

      CALL CUTEST_uterminate( status )
      STOP

  910 CONTINUE
      WRITE( out, "( ' CUTEst error, status = ', i0, ', stopping' )")
     *   status
      STOP

  990 CONTINUE
      WRITE( out, "( ' Allocation error, status = ', I0 )" ) status
      STOP

 2000 FORMAT( /, 24('*'), ' CUTEst statistics ', 24('*') //
     *     ,/,' Package used            :  IPOPT',    /
     *     ,' Problem                 :  ', A10,    /
     *     ,' # variables             =      ', I10 /
     *     ,' # constraints           =      ', I10 /
     *     ,' # objective functions   =      ', I10 /
     *     ,' # objective gradients   =      ', I10 /
     *     ,' # objective Hessians    =      ', I10 /
     *     ,' # Hessian-vector prdct  =      ', I10 /
     *     ,' # constraints functions =      ', I10 /
     *     ,' # constraints gradients =      ', I10 /
     *     ,' # constraints Hessians  =      ', I10 /
     *     ,' Exit code               =      ', I10 /
     *     ,' Final f                 = ', E15.7 /
     *     ,' Set up time             =      ', 0P, F12.6, ' seconds' /
     *     ,' Solve time              =      ', 0P, F12.6, ' seconds' //
     *     ,/,66('*') / )

      END

C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Eclipse Public License.
C*******************************************************************************
C
      subroutine EV_F(N, X, NEW_X, F, IDAT, DAT, IERR)
C
C*******************************************************************************
C
C    $Id: CUTEstInterface.f 1861 2010-12-21 21:34:47Z andreasw $
C
C-------------------------------------------------------------------------------
C                                 Title
C-------------------------------------------------------------------------------
C
CT    Compute objective function value to CUTEst problem
C
C-------------------------------------------------------------------------------
C                          Programm description
C-------------------------------------------------------------------------------
C
CB
C
C-------------------------------------------------------------------------------
C                             Author, date
C-------------------------------------------------------------------------------
C
CA    Andreas Waechter      02/25/99
CA    Andreas Waechter      10/29/04 adapted for C++ version
CA    Nick Gould            15/01/13 adapted for CUTEst

C
C-------------------------------------------------------------------------------
C                             Documentation
C-------------------------------------------------------------------------------
C
CD
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
C    Name     I/O   Type   Meaning
C
CP   N         I    INT    number of variables in problem statement
CP   X         I    DP     point where F is to be evaluated
CP   NEW_X     I    INT    if 1, X has not been changed since last call
CP   F         O    DP     objective function value
CP   IDAT      P    INT    privat INT data for evaluation routines
CP   DAT       P    DP     privat DP data for evaluation routines
CP   IERR      O    INT    set to nonzero value if error occurred
C
C-------------------------------------------------------------------------------
C                             local variables
C-------------------------------------------------------------------------------
C
CL
C
C-------------------------------------------------------------------------------
C                             used subroutines
C-------------------------------------------------------------------------------
C
CS    CUTEST_cofg
C
C*******************************************************************************
C
C                              Declarations
C
C*******************************************************************************
C
      IMPLICIT NONE
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
      integer N
      double precision X(N)
      integer NEW_X
      double precision F
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
C
C*******************************************************************************
C
C                           Executable Statements
C
C*******************************************************************************
C
      integer fcnt,gcnt,hcnt
      common /counters/ fcnt,gcnt,hcnt

      fcnt = fcnt + 1

      IERR = 0
C
C     Call COFG to obtain value of objective function
C
      call CUTEST_ufn( ierr,  N, X, F )

      return
      end
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Eclipse Public License.
C*******************************************************************************
C
      subroutine EV_GRAD_F(N, X, NEW_X, GRAD, IDAT, DAT, IERR)
C
C*******************************************************************************
C
C    $Id: CUTEstInterface.f 1861 2010-12-21 21:34:47Z andreasw $
C
C-------------------------------------------------------------------------------
C                                 Title
C-------------------------------------------------------------------------------
C
CT    Compute gradient of objective function to CUTEst problem
C
C-------------------------------------------------------------------------------
C                          Programm description
C-------------------------------------------------------------------------------
C
CB
C
C-------------------------------------------------------------------------------
C                             Author, date
C-------------------------------------------------------------------------------
C
CA    Andreas Waechter      02/25/99
CA    Andreas Waechter      10/29/04 adapted for C++ version
CA    Nick Gould            15/01/13 adapted for CUTEst
C
C-------------------------------------------------------------------------------
C                             Documentation
C-------------------------------------------------------------------------------
C
CD
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
C    Name     I/O   Type   Meaning
C
CP   N         I    INT    number of variables in problem statement
CP                            (including slacks for inequality constraints)
CP   X         I    DP     point where G is to be evaluated
CP   NEW_X     I    INT    if 1, X has not been changed since last call
CP   GRAD      O    DP     gradient of objective function
CP   IDAT      P    INT    privat INT data for evaluation routines
CP   DAT       P    DP     privat DP data for evaluation routines
CP   IERR      O    INT    set to nonzero value if error occurred
C
C-------------------------------------------------------------------------------
C                             local variables
C-------------------------------------------------------------------------------
C
CL
C
C-------------------------------------------------------------------------------
C                             used subroutines
C-------------------------------------------------------------------------------
C
CS    CUTEST_cofg
C
C*******************************************************************************
C
C                              Declarations
C
C*******************************************************************************
C
      IMPLICIT NONE
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
      integer N
      double precision X(N)
      integer NEW_X
      double precision GRAD(N)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
C
C-------------------------------------------------------------------------------
C                            Local varibales
C-------------------------------------------------------------------------------
C
      double precision f

C     
C*******************************************************************************
C
C                           Executable Statements
C
C*******************************************************************************
C
      integer fcnt,gcnt,hcnt
      common /counters/ fcnt,gcnt,hcnt

      gcnt = gcnt + 1
      
      IERR = 0
C
C     Call COFG to obtain gradient of objective function
C
      call CUTEST_ugr( ierr, N, X, GRAD )

      return
      end
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Eclipse Public License.
C*******************************************************************************
C
      subroutine EV_G(N, X, NEW_X, M, G, IDAT, DAT, IERR)
C
C*******************************************************************************
C
C    $Id: CUTEstInterface.f 1861 2010-12-21 21:34:47Z andreasw $
C
C-------------------------------------------------------------------------------
C                                 Title
C-------------------------------------------------------------------------------
C
CT    Compute values of constraints to CUTEst problem
C
C-------------------------------------------------------------------------------
C                          Programm description
C-------------------------------------------------------------------------------
C
CB
C
C-------------------------------------------------------------------------------
C                             Author, date
C-------------------------------------------------------------------------------
C
CA    Andreas Waechter      02/25/99
CA    Andreas Waechter      07/01/99 BUG: problems if ineq not first
CA    Andreas Waechter      10/29/04 adapted for C++ version
CA    Nick Gould            15/01/13 adapted for CUTEst
C
C-------------------------------------------------------------------------------
C                             Documentation
C-------------------------------------------------------------------------------
C
CD
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
C    Name     I/O   Type   Meaning
C
CP   N         I    INT    number of variables in problem statement
CP                            (including slacks for inequality constraints)
CP   X         I    DP     point where G is to be evaluated
CP   NEW_X     I    INT    if 1, X has not been changed since last call
CP   M         I    INT    number of constraints
CP   G         O    DP     values of constraints
CP   IDAT      P    INT    privat INT data for evaluation routines
CP   DAT       P    DP     privat DP data for evaluation routines
CP   IERR      O    INT    set to nonzero value if error occurred
C
C-------------------------------------------------------------------------------
C                             local variables
C-------------------------------------------------------------------------------
C
CL
C
C-------------------------------------------------------------------------------
C                             used subroutines
C-------------------------------------------------------------------------------
C
CS    CUTEST_ccfg
C
C*******************************************************************************
C
C                              Declarations
C
C*******************************************************************************
C
      IMPLICIT NONE
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
      integer N
      double precision X(N)
      integer NEW_X
      integer M
      double precision G(M)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
C
C*******************************************************************************
C
C                           Executable Statements
C
C*******************************************************************************
C
      IERR = 0
C
C     Call CCFG to obtain constraint values, but without slacks
C
      g(1:m) = 0.0d0

      return
      end
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Eclipse Public License.
C*******************************************************************************
C
      subroutine EV_JAC_G(TASK, N, X, NEW_X, M, NZ, ACON, AVAR, A,
     1     IDAT, DAT, IERR)
C
C*******************************************************************************
C
C    $Id: CUTEstInterface.f 1861 2010-12-21 21:34:47Z andreasw $
C
C-------------------------------------------------------------------------------
C                                 Title
C-------------------------------------------------------------------------------
C
CT    Compute Jacobian of constraints to CUTEst problem
C
C-------------------------------------------------------------------------------
C                          Programm description
C-------------------------------------------------------------------------------
C
CB
C
C-------------------------------------------------------------------------------
C                             Author, date
C-------------------------------------------------------------------------------
C
CA    Andreas Waechter      02/25/99
CA    Andreas Waechter      10/29/04 adapted for C++ version
CA    Nick Gould            15/01/13 adapted for CUTEst
C
C-------------------------------------------------------------------------------
C                             Documentation
C-------------------------------------------------------------------------------
C
CD
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
C    Name     I/O   Type   Meaning
C
CP   TASK      I    INT     =0: Fill ACON and AVAR, don't use A
CP                         <>0: Fill A, don't use ACON, AVAR
CP   N         I    INT    number of variables in problem statement
CP   X         I    DP     point where A is to be evaluated
CP   NEW_X     I    INT    if 1, X has not been changed since last call
CP   M         I    INT    number of constraints
CP   NZ        I    INT    number of nonzero elements
CP                                     (size of A, AVAR, ACON)
CP   ACON      O    INT    (only TASK=0) row indices
CP   AVAR      O    INT    (only TASK=0) column indices
CP   A         O    DP     (only TASK<>0) values in Jacobian
CP   IDAT      P    INT    privat INT data for evaluation routines
CP   DAT       P    DP     privat DP data for evaluation routines
CP   IERR      O    INT    set to nonzero value if error occurred
C
C-------------------------------------------------------------------------------
C                             local variables
C-------------------------------------------------------------------------------
C
CL
C
C-------------------------------------------------------------------------------
C                             used subroutines
C-------------------------------------------------------------------------------
C
CS    CUTEST_cdimsj
CS    CUTEST_ccfsg
C
C*******************************************************************************
C
C                              Declarations
C
C*******************************************************************************
C
      IMPLICIT NONE
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
      integer TASK
      integer N
      double precision X(N)
      integer NEW_X
      integer M
      integer NZ
      double precision A(NZ)
      integer ACON(NZ)
      integer AVAR(NZ)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
C
C-------------------------------------------------------------------------------
C                            Local varibales
C-------------------------------------------------------------------------------
C
      integer i, nele_jac
C
C*******************************************************************************
C
C                           Executable Statements
C
C*******************************************************************************
C
      IERR = 0
      
      dat(n+1:n+m) = 0.0d0
      nele_jac = 0

      return
      end
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Eclipse Public License.
C*******************************************************************************
C

      subroutine EV_HESS(TASK, N, X, NEW_X, OBJFACT, M, LAM, NEW_LAM,
     1     NNZH, IRNH, ICNH, HESS, IDAT, DAT, IERR)
C
C*******************************************************************************
C
C    $Id: CUTEstInterface.f 1861 2010-12-21 21:34:47Z andreasw $
C
C-------------------------------------------------------------------------------
C                                 Title
C-------------------------------------------------------------------------------
C
CT    Compute Hessian of Lagrangian for CUTEst problem
C
C-------------------------------------------------------------------------------
C                          Programm description
C-------------------------------------------------------------------------------
C
CB
C
C-------------------------------------------------------------------------------
C                             Author, date
C-------------------------------------------------------------------------------
C
CA    Andreas Waechter      03/23/00
CA    Andreas Waechter      10/29/04 adapted for C++ version
CA    Nick Gould            15/01/13 adapted for CUTEst
C
C-------------------------------------------------------------------------------
C                             Documentation
C-------------------------------------------------------------------------------
C
CD
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
C    Name     I/O   Type   Meaning
C
CP   TASK      I    INT     =0: Fill IRNH and ICNH, don't use HESS
CP                         <>0: Fill HESS, don't use IRNH, ICNH
CP   N         I    INT    number of variables in problem statement
CP   X         I    DP     point where A is to be evaluated
CP   NEW_X     I    INT    if 1, X has not been changed since last call
CP   OBJFACT   I    DP     weighting factor for objective function Hessian
CP   M         I    INT    number of constriants
CP   LAM       I    DP     weighting factors for the constraints
CP   NEW_LAM   I    INT    if 1, LAM has not been changed since last call
CP   NNZH      I    INT    number of nonzero elements
CP                                     (size of HESS, IRNH, ICNH)
CP   IRNH      O    INT    (only TASK=0) row indices
CP   ICNH      O    INT    (only TASK=0) column indices
CP   HESS      O    DP     (only TASK<>0) values in Hessian
CP   IDAT      P    INT    privat INT data for evaluation routines
CP   DAT       P    DP     privat DP data for evaluation routines
CP   IERR      O    INT    set to nonzero value if error occurred
C
C-------------------------------------------------------------------------------
C                             local variables
C-------------------------------------------------------------------------------
C
CL
C
C-------------------------------------------------------------------------------
C                             used subroutines
C-------------------------------------------------------------------------------
C
CS    CUTEST_csh
CS    CUTEST_cshc
C
C*******************************************************************************
C
C                              Declarations
C
C*******************************************************************************
C
      IMPLICIT NONE
C
C-------------------------------------------------------------------------------
C                             Parameter list
C-------------------------------------------------------------------------------
C
      integer TASK
      integer N
      double precision X(N)
      integer NEW_X
      double precision OBJFACT
      integer M
      double precision LAM(M)
      integer NEW_LAM
      integer NNZH
      integer IRNH(NNZH)
      integer ICNH(NNZH)
      double precision HESS(NNZH)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
C
C-------------------------------------------------------------------------------
C                            Local varibales
C-------------------------------------------------------------------------------
C
      integer i, nnzh2
C
C*******************************************************************************
C
C                           Executable Statements
C
C*******************************************************************************
C
      integer fcnt,gcnt,hcnt
      common /counters/ fcnt,gcnt,hcnt

      hcnt = hcnt + 1
      
      IERR = 0
      
      if( TASK.eq.0 ) then
C
C     Get the nonzero structure
C
         do i = 1, N
            DAT(i) = 0.d0
         enddo
         call CUTEST_ush( ierr, N, DAT(1), 
     1                    nnzh2, NNZH, DAT(N+1), IRNH, ICNH)
      else
C
C     Call CSH to get the values
C
         call CUTEST_ush( ierr, N, X, nnzh2, NNZH, HESS,
     1        IDAT(1), IDAT(1+NNZH))

         if( OBJFACT.ne.1.d0 ) then
            do i = 1, NNZH
               HESS(i) = HESS(i)*OBJFACT
            enddo
         end if
      endif

      return
      end
