!   E04NLA Example Program Text
!   Mark 23 Release. NAG Copyright 2011.

    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
!      .. Parameters ..
       INTEGER, PARAMETER                  :: iset = 1, lcwsav = 1,            &
                                              liwsav = 380, llwsav = 20,       &
                                              lrwsav = 285, nin = 5,           &
                                              ninopt = 7, nout = 6
    CONTAINS
!dec$ attributes offload : mic :: qphx
       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.)

!         .. Implicit None Statement ..
          IMPLICIT NONE
!         .. 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.')
!dec$ attributes offload : mic :: qphx
       END SUBROUTINE qphx
    END MODULE e04nlae_mod
    PROGRAM e04nlae

!      E04NLA Example Main Program

!      .. Use Statements ..
       USE nag_library, ONLY : e04nka, e04nla, e04nma, e04wbf, nag_wp, x04abf, &
                               x04acf
       USE e04nlae_mod, ONLY : iset, lcwsav, liwsav, llwsav, lrwsav, nin,      &
                               ninopt, nout, qphx
!      .. 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 20
          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 20
       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 20
       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 20
       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

20     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
