NAG Library Manual, Mark 30
Interfaces:  FL   CL   CPP   AD 

NAG FL Interface Introduction
Example description
!   E04MXF Example Program Text
!   Mark 30.0 Release. NAG Copyright 2024.

    Module e04mxfe_mod

!     E04MXF Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: qphx
    Contains
      Subroutine qphx(ncolh,x,hx,nstate,cuser,iuser,ruser)

!       Subroutine to compute H*x.

!       Note: IUSER and RUSER contain the following data:
!       RUSER(1:NNZH) = H(1:NNZH)
!       IUSER(1:NCOLH+1) = ICCOLH(1:NCOLH+1)
!       IUSER(NCOLH+2:NNZH+NCOLH+1) = IROWH(1:NNZH)

!       .. Scalar Arguments ..
        Integer, Intent (In)           :: ncolh, nstate
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: hx(ncolh)
        Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
        Real (Kind=nag_wp), Intent (In) :: x(ncolh)
        Integer, Intent (Inout)        :: iuser(*)
        Character (8), Intent (Inout)  :: cuser(*)
!       .. Local Scalars ..
        Integer                        :: end, icol, idx, irow, start
!       .. Executable Statements ..
        hx(1:ncolh) = 0.0E0_nag_wp

        Do icol = 1, ncolh
          start = iuser(icol)
          end = iuser(icol+1) - 1

          Do idx = start, end
            irow = iuser(ncolh+1+idx)
            hx(irow) = hx(irow) + x(icol)*ruser(idx)
            If (irow/=icol) Then
              hx(icol) = hx(icol) + x(irow)*ruser(idx)
            End If

          End Do

        End Do

        Return
      End Subroutine qphx
    End Module e04mxfe_mod

    Program e04mxfe

!     .. Use Statements ..
      Use e04mxfe_mod, Only: qphx
      Use nag_library, Only: e04mxf, e04npf, e04nqf, e04nsf, e04ntf, nag_wp,   &
                             x04acf, x04adf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: lencw = 600, leniw = 600,            &
                                          lenrw = 600, mpslst = 1, nin = 7,    &
                                          nout = 6
      Logical, Parameter               :: readints = .False.
      Character (*), Parameter         :: fname = 'e04mxfe.opt'
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: obj, objadd, sinf
      Integer                          :: i, ifail, iobj, lenc, lintvar, m,    &
                                          maxlintvar, maxm, maxn, maxncolh,    &
                                          maxnnz, maxnnzh, minmax, mode, n,    &
                                          ncolh, ninf, nname, nnz, nnzh, ns
      Logical                          :: verbose_output
      Character (1)                    :: start
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:), bl(:), bu(:), c(:), h(:),      &
                                          pi(:), rc(:), ruser(:), rw(:), x(:)
      Integer, Allocatable             :: helast(:), hs(:), iccola(:),         &
                                          iccolh(:), intvar(:), irowa(:),      &
                                          irowh(:), iuser(:), iw(:)
      Character (8), Allocatable       :: crname(:), cw(:)
      Character (8)                    :: cuser(1), pnames(5)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: max, min
!     .. Executable Statements ..
      Write (nout,*) 'E04MXF Example Program Results'
      Flush (nout)

!     Initialize
      pnames(1:5) = '        '
      maxm = 0
      maxn = 0
      maxnnz = 0
      maxnnzh = 0
      maxncolh = 0
      maxlintvar = 0

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

!     Call e04mxf in query mode
      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,intvar)

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

!     set maxm maxn and maxnnz
      maxm = m
      maxn = n
      maxnnz = nnz
      maxnnzh = nnzh
      maxncolh = ncolh
      If (readints) Then
        maxlintvar = lintvar
      Else
        maxlintvar = -1
      End If

!     Allocate memory
      Allocate (irowa(maxnnz),iccola(maxn+1),a(maxnnz),bl(maxn+maxm),          &
        bu(maxn+maxm),crname(maxn+maxm),irowh(maxnnzh),iccolh(maxncolh+1),     &
        h(maxnnzh),intvar(maxlintvar))

!     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)

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

!     Data has been read. Set up and run the solver

      Allocate (iw(leniw),rw(lenrw),cw(lencw))

!     Call e04npf to initialize workspace
      ifail = 0
      Call e04npf(cw,lencw,iw,leniw,rw,lenrw,ifail)

!     Call option setter e04nsf to change the direction of optimization.
!     Minimization is assumed by default.
      If (minmax==1) Then
        ifail = 0
        Call e04nsf('Maximize',cw,iw,rw,ifail)
      Else If (minmax==0) Then
        ifail = 0
        Call e04nsf('Feasible Point',cw,iw,rw,ifail)
      End If

!     Set this to .True. to cause e04nqf to produce intermediate
!     progress output
      verbose_output = .False.

      If (verbose_output) Then
!       By default E04NQF does not print monitoring
!       information. Set the print file unit or the summary
!       file unit to get information.
        ifail = 0
        Call e04ntf('Print file',nout,cw,iw,rw,ifail)
      Else
        Write (nout,99999) n, m
      End If

!     We have no explicit objective vector so set LENC = 0; the
!     objective vector is stored in row IOBJ of ACOL.
      lenc = 0
      objadd = 0.0E0_nag_wp
      start = 'C'

      Allocate (c(max(1,lenc)),helast(n+m),x(n+m),pi(m),rc(n+m),hs(n+m),iuser( &
        ncolh+1+nnzh),ruser(nnzh))

      helast(1:n+m) = 0
      hs(1:n+m) = 0
      Do i = 1, n + m
        x(i) = min(max(0.0E0_nag_wp,bl(i)),bu(i))
      End Do

      If (ncolh>0) Then
!       Store the non zeros of H in ruser for use by qphx
        ruser(1:nnzh) = h(1:nnzh)

!       Store iccolh and irowh in iuser for use by qphx
        iuser(1:ncolh+1) = iccolh(1:ncolh+1)
        iuser(ncolh+2:nnzh+ncolh+1) = irowh(1:nnzh)
      End If

!     Call e04nqf to solve the problem
      ifail = 0
      Call e04nqf(start,qphx,m,n,nnz,nname,lenc,ncolh,iobj,objadd,pnames(1),a, &
        irowa,iccola,bl,bu,c,crname,helast,hs,x,pi,rc,ns,ninf,sinf,obj,cw,     &
        lencw,iw,leniw,rw,lenrw,cuser,iuser,ruser,ifail)

      If (.Not. verbose_output) Then
        Write (nout,*)
        Write (nout,99998) obj
        Write (nout,*) 'Optimal X = '
        Write (nout,99997) x(1:n)
      End If

99999 Format (1X,/,1X,'Problem contains ',I3,' variables and ',I3,             &
        ' linear constraints')
99998 Format (1X,'Final objective value = ',1P,E11.3)
99997 Format (14X,7F9.2)
    End Program e04mxfe