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

NAG FL Interface Introduction
Example description
!   E04NLA Example Program Text
!   Mark 30.1 Release. NAG Copyright 2024.

    Module e04nlae_mod

!     E04NLA 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
!     .. Parameters ..
      Integer, Parameter, Public       :: iset = 1, lcwsav = 1, liwsav = 380,  &
                                          llwsav = 20, lrwsav = 285, nin = 5,  &
                                          ninopt = 7, nout = 6
    Contains
      Subroutine qphx(nstate,ncolh,x,hx,iuser,ruser)

!       Routine to compute H*x. (In this version of QPHX, the Hessian
!       matrix H is not referenced explicitly.)

!       .. 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(*)
!       .. Executable Statements ..
        If (nstate==1) Then

!         First entry.

          Write (nout,*)
          Write (nout,99999) ncolh
          Flush (nout)
        End If

        hx(1) = 2.0E0_nag_wp*x(1)
        hx(2) = 2.0E0_nag_wp*x(2)
        hx(3) = 2.0E0_nag_wp*(x(3)+x(4))
        hx(4) = hx(3)
        hx(5) = 2.0E0_nag_wp*x(5)
        hx(6) = 2.0E0_nag_wp*(x(6)+x(7))
        hx(7) = hx(6)

        If (nstate>=2) Then

!         Final entry.

          Write (nout,*)
          Write (nout,99998)
          Flush (nout)
        End If

        Return

99999   Format (1X,'This is the E04NLA example.   NCOLH =',I4,'.')
99998   Format (1X,'Finished the E04NLA example.')
      End Subroutine qphx
    End Module e04nlae_mod
    Program e04nlae

!     E04NLA Example Main Program

!     .. Use Statements ..
      Use e04nlae_mod, Only: iset, lcwsav, liwsav, llwsav, lrwsav, nin,        &
                             ninopt, nout, qphx
      Use nag_library, Only: e04nka, e04nla, e04nma, e04wbf, nag_wp, x04abf,   &
                             x04acf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Character (*), Parameter         :: fname = 'e04nlae.opt'
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: obj, sinf
      Integer                          :: i, icol, ifail, inform, iobj, jcol,  &
                                          leniz, lenz, m, miniz, minz, mode,   &
                                          n, ncolh, ninf, nname, nnz, ns,      &
                                          outchn
      Character (1)                    :: start
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:), bl(:), bu(:), clamda(:),       &
                                          xs(:), z(:)
      Real (Kind=nag_wp)               :: ruser(1), rwsav(lrwsav)
      Integer, Allocatable             :: ha(:), istate(:), iz(:), ka(:)
      Integer                          :: iuser(1), iwsav(liwsav)
      Logical                          :: lwsav(llwsav)
      Character (8), Allocatable       :: crname(:)
      Character (80)                   :: cwsav(lcwsav)
      Character (8)                    :: names(5)
!     .. Executable Statements ..
      Write (nout,99992) 'E04NLA Example Program Results'
      Flush (nout)

!     Skip heading in data file.
      Read (nin,*)

      Read (nin,*) n, m
      Read (nin,*) nnz, iobj, ncolh, start, nname

      Allocate (ha(nnz),ka(n+1),istate(n+m),a(nnz),bl(n+m),bu(n+m),xs(n+m),    &
        clamda(n+m),crname(nname))

      Read (nin,*) names(1:5)
      Read (nin,*) crname(1:nname)

!     Read the matrix A from data file. Set up KA.

      jcol = 1
      ka(jcol) = 1

      Do i = 1, nnz

!       Element ( HA( I ), ICOL ) is stored in A( I ).

        Read (nin,*) a(i), ha(i), icol

        If (icol<jcol) Then

!         Elements not ordered by increasing column index.

          Write (nout,*)
          Write (nout,99998) 'Element in column', icol,                        &
            ' found after element in column', jcol, '. Problem', ' abandoned.'
          Flush (nout)
          Go To 100
        Else If (icol==jcol+1) Then

!         Index in A of the start of the ICOL-th column equals I.

          ka(icol) = i
          jcol = icol
        Else If (icol>jcol+1) Then

!         Index in A of the start of the ICOL-th column equals I,
!         but columns JCOL+1,JCOL+2,...,ICOL-1 are empty. Set the
!         corresponding elements of KA to I.

          ka((jcol+1):icol) = i
          jcol = icol
        End If

      End Do

      ka(n+1) = nnz + 1

!     Columns N,N-1,...,ICOL+1 are empty. Set the corresponding
!     elements of KA accordingly.

      Do i = n, icol + 1, -1
        ka(i) = ka(i+1)
      End Do

      Read (nin,*) bl(1:(n+m))
      Read (nin,*) bu(1:(n+m))

      If (start=='C') Then
        Read (nin,*) istate(1:n)
      Else If (start=='W') Then
        Read (nin,*) istate(1:(n+m))
      End If

      Read (nin,*) xs(1:n)

!     Set the unit number for advisory messages to OUTCHN.

      outchn = nout
      Call x04abf(iset,outchn)

!     Initialise E04NKA

      ifail = 0
      Call e04wbf('E04NKA',cwsav,lcwsav,lwsav,llwsav,iwsav,liwsav,rwsav,       &
        lrwsav,ifail)

!     Set three options using E04NMF.

      Call e04nma(' Check Frequency = 10 ',lwsav,iwsav,rwsav,inform)

      If (inform==0) Then

        Call e04nma(' Crash Tolerance = 0.05 ',lwsav,iwsav,rwsav,inform)

        If (inform==0) Then

          Call e04nma(' Infinite Bound Size = 1.0E+25 ',lwsav,iwsav,rwsav,     &
            inform)

        End If

      End If

      If (inform/=0) Then
        Write (nout,99999) 'E04NMA terminated with INFORM = ', inform
        Flush (nout)
        Go To 100
      End If

!     Open the options file for reading

      mode = 0

      ifail = 0
      Call x04acf(ninopt,fname,mode,ifail)

!     Read the options file for the remaining options.

      Call e04nla(ninopt,lwsav,iwsav,rwsav,inform)

      If (inform/=0) Then
        Write (nout,99999) 'E04NLA terminated with INFORM = ', inform
        Flush (nout)
        Go To 100
      End If

!     Solve the QP problem.
!     First call is a workspace query

      leniz = 1
      lenz = 1
      Allocate (iz(leniz),z(lenz))

      ifail = 1
      Call e04nka(n,m,nnz,iobj,ncolh,qphx,a,ha,ka,bl,bu,start,names,nname,     &
        crname,ns,xs,istate,miniz,minz,ninf,sinf,obj,clamda,iz,leniz,z,lenz,   &
        iuser,ruser,lwsav,iwsav,rwsav,ifail)

      If (ifail/=0 .And. ifail/=12 .And. ifail/=13) Then
        Write (nout,99999) 'Query call to E04NKA failed with IFAIL =', ifail
        Go To 100
      End If

      Deallocate (iz,z)

      lenz = minz
      leniz = miniz
      Allocate (iz(leniz),z(lenz))

      ifail = -1
      Call e04nka(n,m,nnz,iobj,ncolh,qphx,a,ha,ka,bl,bu,start,names,nname,     &
        crname,ns,xs,istate,miniz,minz,ninf,sinf,obj,clamda,iz,leniz,z,lenz,   &
        iuser,ruser,lwsav,iwsav,rwsav,ifail)

      Select Case (ifail)
      Case (0:6,8:)
        Write (nout,*)
        Write (nout,99997)
        Write (nout,*)
        Flush (nout)

        Do i = 1, n
          Write (nout,99996) crname(i), istate(i), xs(i), clamda(i)
          Flush (nout)
        End Do

        If (m>0) Then
          Write (nout,*)
          Write (nout,*)
          Write (nout,99995)
          Write (nout,'()')

          Do i = n + 1, n + m
            Write (nout,99994) crname(i), istate(i), xs(i), clamda(i)
          End Do
          Flush (nout)

        End If

        Write (nout,*)
        Write (nout,*)
        Write (nout,99993) obj
        Flush (nout)
      End Select

100   Continue

99999 Format (1X,A,I5)
99998 Format (1X,A,I5,A,I5,A,A)
99997 Format (1X,'Variable',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99996 Format (1X,1X,A,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99995 Format (1X,'Constrnt',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99994 Format (1X,1X,A,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99993 Format (1X,'Final objective value = ',G15.7)
99992 Format (1X,A)
    End Program e04nlae