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 28.3 Release. NAG Copyright 2022.
! .. Use Statements ..
Use, Intrinsic :: iso_c_binding, Only: c_null_ptr, &
c_ptr
Use nag_library, Only: e04mxf, e04raf, e04rff, e04rhf, e04rjf, e04rzf, &
e04svf, e04zmf, nag_wp, x04acf, x04adf
! .. 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 ..
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