!   E04RSF Example Program Text
!   Mark 30.1 Release. NAG Copyright 2024.

    Module e04rsfe_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 e04rsfe_mod

    Program e04rsfe

!     .. Use Statements ..
      Use e04rsfe_mod, Only: monit
      Use iso_c_binding, Only: c_null_ptr, c_ptr
      Use nag_library, Only: e04ptf, e04raf, e04rsf, e04rzf, e04zmf, nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nin = 5, nout = 6
!     .. Local Scalars ..
      Type (c_ptr)                     :: cpuser, handle
      Real (Kind=nag_wp)               :: s
      Integer                          :: idqc, ifail, n, nnzq0, nnzq1, nnzu,  &
                                          nnzuc, x_idx
      Logical                          :: verbose_output
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: q0(:), q1(:), r0(:), r1(:), u(:),    &
                                          uc(:), x(:)
      Real (Kind=nag_wp)               :: rinfo(100), ruser(1), stats(100)
      Integer, Allocatable             :: icolq0(:), icolq1(:), idxr0(:),      &
                                          idxr1(:), irowq0(:), irowq1(:)
      Integer                          :: iuser(2)
!     .. Executable Statements ..

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

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

!     Read dimensions of the problem
      Read (nin,*) n, nnzq0, nnzq1

!     Allocate memory to read data
      Allocate (irowq0(nnzq0),icolq0(nnzq0),q0(nnzq0),irowq1(nnzq1),           &
        icolq1(nnzq1),q1(nnzq1),idxr0(n),r0(n),idxr1(n),r1(n))

!     Read problem data
      Read (nin,*) irowq0(1:nnzq0)
      Read (nin,*) icolq0(1:nnzq0)
      Read (nin,*) q0(1:nnzq0)
      Read (nin,*) irowq1(1:nnzq1)
      Read (nin,*) icolq1(1:nnzq1)
      Read (nin,*) q1(1:nnzq1)
      Read (nin,*) idxr0(1:n)
      Read (nin,*) r0(1:n)
      Read (nin,*) idxr1(1:n)
      Read (nin,*) r1(1:n)
      Read (nin,*) s

!     Compute size of multipliers
!     One quadratic constraint in the model will have
!     2 multipliers for both bounds
      nnzu = 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 objective function
      idqc = -1
      ifail = 0
      Call e04rsf(handle,0.0_nag_wp,n,idxr0,r0,nnzq0,irowq0,icolq0,q0,idqc,    &
        ifail)

!     Set quadratic constraint
      idqc = 0
      ifail = 0
      Call e04rsf(handle,s,n,idxr1,r1,nnzq1,irowq1,icolq1,q1,idqc,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 e04rsfe