!   E04RTF Example Program Text
!   Mark 30.2 Release. NAG Copyright 2024.

    Module e04rtfe_mod

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: monit

    Contains

      Subroutine monit(handle,rinfo,stats,iuser,ruser,cpuser,inform)

!       Monitoring function can be used to monitor the progress
!       or, for example,  to implement bespoke stopping criteria

!       .. Use Statements ..
        Use iso_c_binding, Only: c_ptr
!       .. Scalar Arguments ..
        Type (c_ptr), Intent (In)      :: cpuser, handle
        Integer, Intent (Inout)        :: inform
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (In) :: rinfo(100), stats(100)
        Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: tol
        Integer                        :: nout, tol_reached
!       .. Executable Statements ..

        nout = iuser(1)
        tol_reached = iuser(2)
        tol = ruser(1)
!       If x is close to the solution, print a message
        If (rinfo(15)<tol .And. rinfo(16)<tol .And. rinfo(17)<tol .And.        &
          rinfo(18)<tol) Then
          If (tol_reached==0) Then
            Write (nout,*)
            Write (nout,99999)                                                 &
              'monit() reports good approximate solution (tol =', tol, ')'
            iuser(2) = 1
          End If
        End If

        Return
99999   Format (5X,A,Es9.2,A)
      End Subroutine monit

    End Module e04rtfe_mod

    Program e04rtfe

!     .. Use Statements ..
      Use e04rtfe_mod, Only: monit
      Use iso_c_binding, Only: c_null_ptr, c_ptr
      Use nag_library, Only: e04ptf, e04raf, e04rhf, e04rjf, e04rtf, e04rzf,   &
                             e04zmf, nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nin = 5, nout = 6
!     .. Local Scalars ..
      Type (c_ptr)                     :: cpuser, handle
      Integer                          :: i, idlc, idqc, ifail, j, m, n, nnza, &
                                          nnzu, nnzuc, x_idx
      Logical                          :: verbose_output
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:), b(:), r0(:), u(:), uc(:),      &
                                          x(:), xl(:), xu(:)
      Real (Kind=nag_wp)               :: lc(3), lc_rhs(1), rinfo(100),        &
                                          ruser(1), stats(100)
      Integer, Allocatable             :: icola(:), idxr0(:), irowa(:)
      Integer                          :: icollc(3), irowlc(3), iuser(2)
!     .. Executable Statements ..

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

!     Skip Header in data file
      Read (nin,*)

!     Read dimensions of the problem
      Read (nin,*) n, m, nnza

!     Allocate memory to read data
      Allocate (a(nnza),icola(nnza),irowa(nnza),idxr0(n),r0(n),b(m),xl(n),     &
        xu(n))

!     Read problem data
      Read (nin,*) irowa(1:nnza)
      Read (nin,*) icola(1:nnza)
      Read (nin,*) a(1:nnza)
      Read (nin,*) b(1:m)
      Read (nin,*) xl(1:n)
      Read (nin,*) xu(1:n)

!     Compute -2*b'A as linear term in quadratic function
      r0(1:n) = 0.0_nag_wp
      idxr0(1:n) = (/(j,j=1,n)/)
      Do i = 1, nnza
        r0(icola(i)) = r0(icola(i)) + a(i)*b(irowa(i))
      End Do

!     Compute size of multipliers
!     One linear constraint in the model will have
!     2 multipliers for both bounds
      nnzu = 2*n + 2
!     No cone constraint in the model, so set nnzuc to 0
      nnzuc = 0

!     Allocate memory for final results
      Allocate (x(n),u(nnzu),uc(nnzuc))

!     Create the problem handle
      ifail = 0
      Call e04raf(handle,n,ifail)

!     Set quadratic objective function
      idqc = -1
      ifail = 0
      Call e04rtf(handle,0.0_nag_wp,n,idxr0,r0,m,nnza,irowa,icola,a,idqc,      &
        ifail)

!     Set box constraints
      ifail = 0
      Call e04rhf(handle,n,xl,xu,ifail)

!     Set linear constraint: x1 + x2 + x3 = 1
      irowlc(1:3) = 1
      icollc(1:3) = (/(j,j=1,n)/)
      lc(1:3) = 1.0_nag_wp
      lc_rhs = 1.0_nag_wp
      ifail = 0
      idlc = 0
      Call e04rjf(handle,1,lc_rhs,lc_rhs,3,irowlc,icollc,lc,idlc,ifail)

!     Turn on monitoring
      ifail = 0
      Call e04zmf(handle,'SOCP Monitor Frequency = 1',ifail)

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

      If (verbose_output) Then
!       Require printing of primal and dual solutions at the end of the solve
        ifail = 0
        Call e04zmf(handle,'Print Solution = YES',ifail)
      Else
!       Turn off printing of intermediate progress output
        ifail = 0
        Call e04zmf(handle,'Print Level = 1',ifail)
      End If

!     Call SOCP interior point solver
      cpuser = c_null_ptr
      iuser(1) = nout
      iuser(2) = 0
      ruser(1) = 1.0E-07_nag_wp
      ifail = -1
      Call e04ptf(handle,n,x,nnzu,u,nnzuc,uc,rinfo,stats,monit,iuser,ruser,    &
        cpuser,ifail)

!     Print solution if optimal or suboptimal solution found
      If (ifail==0 .Or. ifail==50) Then
        Write (nout,99999) 'Optimal X:'
        Write (nout,99997) 'x_idx', '    Value    '
        Do x_idx = 1, n
          Write (nout,99998) x_idx, x(x_idx)
        End Do
      End If

!     Free the handle memory
      ifail = 0
      Call e04rzf(handle,ifail)

99999 Format (1X,A)
99998 Format (2X,I5,3X,Es11.3e2)
99997 Format (2X,A5,3X,A12)

    End Program e04rtfe