Program e04rjfe

!     E04RJF Example Program Text

!     Read in LP/QP problem stored in a MPS file, formulated it
!     as a handle and pass it to the solver.

!     Mark 26 Release. NAG Copyright 2016.

!     .. Use Statements ..
      Use nag_library, Only: e04mxf, e04raf, e04rff, e04rhf, e04rjf, e04rzf,   &
                             e04svf, e04zmf, nag_wp, x04acf, x04adf
      Use, Intrinsic                   :: iso_c_binding, Only: c_null_ptr,     &
                                          c_ptr
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: mpslst = 1, nin = 7, nout = 6
      Character (*), Parameter         :: fname_default = 'e04rjfe.opt'
!     .. Local Scalars ..
      Type (c_ptr)                     :: handle
      Integer                          :: idlc, idx, idx_c, idx_dest, ifail,   &
                                          inform, iobj, j, lintvar, m,         &
                                          maxlintvar, maxm, maxn, maxncolh,    &
                                          maxnnz, maxnnzh, minmax, mode, n,    &
                                          nargs, ncolh, nname, nnz, nnzc,      &
                                          nnzh, nnzu, nnzua, nnzuc
      Character (256)                  :: fname
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:), bl(:), bu(:), c(:), h(:),      &
                                          u(:), ua(:), uc(:), x(:)
      Real (Kind=nag_wp)               :: rinfo(32), stats(32)
      Integer, Allocatable             :: iccola(:), iccolh(:), icola(:),      &
                                          icolh(:), idxc(:), intvar(:),        &
                                          irowa(:), irowh(:)
      Character (8), Allocatable       :: crname(:)
      Character (8)                    :: pnames(5)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: command_argument_count, count,       &
                                          get_command_argument, trim
!     .. Executable Statements ..
      Continue

      Write (nout,*) 'E04RJF Example Program Results'
      Write (nout,*)

!     Use the first command line argument as the filename or
!     choose default hard-coded filename in 'fname_default'.
      nargs = command_argument_count()
      If (nargs>=1) Then
        Call get_command_argument(1,fname)
      Else
        fname = fname_default
      End If

      Write (nout,*) 'Reading MPS file:  ', trim(fname)
      Flush (nout)

!     Read the input MPS file.
      pnames(1:5) = '        '
      maxm = 0
      maxn = 0
      maxnnz = 0
      maxnnzh = 0
      maxncolh = 0
      maxlintvar = -1

!     Open the data file for reading.
      mode = 0
      ifail = 0
      Call x04acf(nin,fname,mode,ifail)

!     Call E04MXF in query mode to obtain an approximate problem size.
      Allocate (a(maxnnz),irowa(maxnnz),iccola(maxn+1),bl(maxn+maxm),          &
        bu(maxn+maxm),crname(maxn+maxm),h(maxnnzh),irowh(maxnnzh),             &
        iccolh(maxncolh+1),intvar(maxlintvar))
      ifail = 0
      Call e04mxf(nin,maxn,maxm,maxnnz,maxncolh,maxnnzh,maxlintvar,mpslst,n,m, &
        nnz,ncolh,nnzh,lintvar,iobj,a,irowa,iccola,bl,bu,pnames,nname,crname,  &
        h,irowh,iccolh,minmax,intvar,ifail)
      Deallocate (a,irowa,iccola,bl,bu,crname,h,irowh,iccolh)

!     Close the data file.
      ifail = 0
      Call x04adf(nin,ifail)

!     Set maximal problem size.
      maxm = m
      maxn = n
      maxnnz = nnz
      maxnnzh = nnzh
      maxncolh = ncolh

      Allocate (irowa(maxnnz),iccola(maxn+1),a(maxnnz),bl(maxn+maxm),          &
        bu(maxn+maxm),crname(maxn+maxm),irowh(maxnnzh),iccolh(maxncolh+1),     &
        h(maxnnzh),x(maxn),icolh(maxnnzh),icola(maxnnz))

!     Open the data file for reading.
      mode = 0
      ifail = 0
      Call x04acf(nin,fname,mode,ifail)

!     Call E04MXF to read the problem.
      ifail = 0
      Call e04mxf(nin,maxn,maxm,maxnnz,maxncolh,maxnnzh,maxlintvar,mpslst,n,m, &
        nnz,ncolh,nnzh,lintvar,iobj,a,irowa,iccola,bl,bu,pnames,nname,crname,  &
        h,irowh,iccolh,minmax,intvar,ifail)

      Write (nout,*) 'MPS/QPS file read'
      Flush (nout)

!     Close the data file.
      ifail = 0
      Call x04adf(nin,ifail)

!     Data has been read. Set up the problem to the solver.

!     Initialize handle.
      handle = c_null_ptr
      ifail = 0
      Call e04raf(handle,n,ifail)

!     Move linear objective from A to C.
      If (iobj>0) Then
!       Shift bounds.
        Do j = iobj, m - 1
          bl(n+j) = bl(n+j+1)
          bu(n+j) = bu(n+j+1)
        End Do
        m = m - 1
!       Extract row IOBJ.
!       Count how many nonzeros will be needed in C.
        nnzc = count(irowa(1:nnz)==iobj)
        Allocate (idxc(nnzc),c(nnzc))
        idx = 1
        idx_c = 1
        idx_dest = 1
        Do j = 1, n
          Do idx = idx, iccola(j+1) - 1
            If (irowa(idx)<iobj) Then
              a(idx_dest) = a(idx)
              irowa(idx_dest) = irowa(idx)
              idx_dest = idx_dest + 1
            Else If (irowa(idx)==iobj) Then
              idxc(idx_c) = j
              c(idx_c) = a(idx)
              idx_c = idx_c + 1
            Else
              a(idx_dest) = a(idx)
              irowa(idx_dest) = irowa(idx) - 1
              idx_dest = idx_dest + 1
            End If
          End Do
          iccola(j+1) = idx_dest
        End Do
        nnz = idx_dest - 1
      Else
!       There is no linear part of the objective function.
        nnzc = 0
        Allocate (idxc(nnzc),c(nnzc))
      End If
!     Convert (decompress) ICCOLA() to ICOLA().
      Do j = 1, n
        icola(iccola(j):iccola(j+1)-1) = j
      End Do

!     Add objective function to the problem formulation.
      If (nnzh==0) Then
!       The objective is a (sparse) linear function.
        ifail = 0
        Call e04rff(handle,nnzc,idxc,c,nnzh,irowh,icolh,h,ifail)
      Else
!       The objective is a quadratic function.
!       Transform (decompress) ICCOLH() -> ICOLH().
        Do j = 1, ncolh
          icolh(iccolh(j):iccolh(j+1)-1) = j
        End Do
!       E04MX returned L triangle, E04RFF needs U triangle -> swap.
        ifail = 0
        Call e04rff(handle,nnzc,idxc,c,nnzh,icolh,irowh,h,ifail)
      End If

!     Add box constraints to the formulation.
      ifail = 0
      Call e04rhf(handle,n,bl,bu,ifail)

!     Add linear constraints.
      idlc = 0
      ifail = 0
      Call e04rjf(handle,m,bl(n+1:n+m),bu(n+1:n+m),nnz,irowa,icola,a,idlc,     &
        ifail)

      Write (nout,*) 'The problem was set-up'
      Flush (nout)

!     Call the solver.

!     Set optional arguments.
      ifail = 0
      Call e04zmf(handle,'Print Options = No',ifail)

!     Set up a starting point and call the solver.
!     Let's ignore Lagrangian multipliers U/UA.
      x(:) = 0.0_nag_wp
      nnzu = 0
      nnzuc = 0
      nnzua = 0
      Allocate (u(nnzu),uc(nnzuc),ua(nnzua))

      ifail = 0
      Call e04svf(handle,n,x,nnzu,u,nnzuc,uc,nnzua,ua,rinfo,stats,inform,      &
        ifail)

      Write (nout,*)
      Write (nout,*) 'Optimal solution:'
      Write (nout,99999) x(1:n)
99999 Format (1X,'X = ',3F9.2)
      Flush (nout)

!     Destroy the handle.
      ifail = 0
      Call e04rzf(handle,ifail)

    End Program e04rjfe