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

    MODULE e04uhfe_mod

!      E04UHF 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, nin = 5, ninopt = 7,   &
                                              nout = 6
    CONTAINS
       SUBROUTINE objfun(mode,nonln,x,objf,objgrd,nstate,iuser,ruser)
!         Computes the nonlinear part of the objective function and its
!         gradient

!         .. Implicit None Statement ..
          IMPLICIT NONE
!         .. Scalar Arguments ..
          REAL (KIND=nag_wp), INTENT (OUT)    :: objf
          INTEGER, INTENT (INOUT)             :: mode
          INTEGER, INTENT (IN)                :: nonln, nstate
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (INOUT)  :: objgrd(nonln), ruser(*)
          REAL (KIND=nag_wp), INTENT (IN)     :: x(nonln)
          INTEGER, INTENT (INOUT)             :: iuser(*)
!         .. Executable Statements ..
          IF (mode==0 .OR. mode==2) THEN
             objf = 2.0E+0_nag_wp - x(1)*x(2)*x(3)*x(4)*x(5)/120.0E+0_nag_wp
          END IF

          IF (mode==1 .OR. mode==2) THEN
             objgrd(1) = -x(2)*x(3)*x(4)*x(5)/120.0E+0_nag_wp
             objgrd(2) = -x(1)*x(3)*x(4)*x(5)/120.0E+0_nag_wp
             objgrd(3) = -x(1)*x(2)*x(4)*x(5)/120.0E+0_nag_wp
             objgrd(4) = -x(1)*x(2)*x(3)*x(5)/120.0E+0_nag_wp
             objgrd(5) = -x(1)*x(2)*x(3)*x(4)/120.0E+0_nag_wp
          END IF

          RETURN

       END SUBROUTINE objfun
    END MODULE e04uhfe_mod
    PROGRAM e04uhfe

!      E04UHF Example Main Program

!      .. Use Statements ..
       USE nag_library, ONLY : e04ugf, e04ugm, e04uhf, e04ujf, nag_wp, x04abf, &
                               x04acf, x04baf
       USE e04uhfe_mod, ONLY : iset, nin, ninopt, nout, objfun
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Parameters ..
       CHARACTER (*), PARAMETER            :: fname = 'e04uhfe.opt'
!      .. Local Scalars ..
       REAL (KIND=nag_wp)                  :: obj, sinf
       INTEGER                             :: ifail, inform, iobj, leniz,      &
                                              lenz, m, miniz, minz, mode, n,   &
                                              ncnln, ninf, njnln, nname, nnz,  &
                                              nonln, ns, outchn
       CHARACTER (80)                      :: rec
       CHARACTER (1)                       :: start
!      .. Local Arrays ..
       REAL (KIND=nag_wp), ALLOCATABLE     :: a(:), bl(:), bu(:), clamda(:),   &
                                              xs(:), z(:)
       REAL (KIND=nag_wp)                  :: user(1)
       INTEGER, ALLOCATABLE                :: ha(:), istate(:), iz(:), ka(:)
       INTEGER                             :: iuser(1)
       CHARACTER (8), ALLOCATABLE          :: names(:)
!      .. Intrinsic Functions ..
       INTRINSIC                              max
!      .. Executable Statements ..
       WRITE (rec,99998) 'E04UHF Example Program Results'
       CALL x04baf(nout,rec)

!      Skip heading in data file.
       READ (nin,*)
       READ (nin,*) n, m
       READ (nin,*) ncnln, nonln, njnln
       READ (nin,*) start, nname
       nnz = 1
       ALLOCATE (ha(nnz),ka(n+1),istate(n+m),a(nnz),bl(n+m),bu(n+m),xs(n+m), &
          clamda(n+m),names(nname))

       READ (nin,*) names(1:nname)

!      Define the matrix A to contain a dummy `free' row that consists
!      of a single (zero) element subject to `infinite' upper and
!      lower bounds. Set up KA.

       iobj = -1

       ka(1) = 1

       a(1) = 0.0E+0_nag_wp
       ha(1) = 1

!      Columns 2,3,...,N of A are empty. Set the corresponding element
!      of KA to 2.

       ka(2:n) = 2
       ka(n+1) = nnz + 1

       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)

!      Set three options using E04UJF.

       CALL e04ujf(' Verify Level = -1 ')

       CALL e04ujf(' Major Iteration Limit = 25 ')

       CALL e04ujf(' Infinite Bound Size = 1.0D+25 ')

!      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 e04uhf(ninopt,inform)

       IF (inform/=0) THEN
          WRITE (rec,99999) 'E04UJF terminated with INFORM = ', inform
          CALL x04baf(nout,rec)
          GO TO 20
       END IF

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

       leniz = max(500,n+m)
       lenz = 500
       ALLOCATE (iz(leniz),z(lenz))

       ifail = 1
       CALL e04ugf(e04ugm,objfun,n,m,ncnln,nonln,njnln,iobj,nnz,a,ha,ka,bl,bu, &
          start,nname,names,ns,xs,istate,clamda,miniz,minz,ninf,sinf,obj,iz, &
          leniz,z,lenz,iuser,user,ifail)

       IF (ifail/=0 .AND. ifail/=15 .AND. ifail/=16) THEN
          WRITE (nout,99999) 'Query call to E04UGF failed with IFAIL =', ifail
          GO TO 20
       END IF

       DEALLOCATE (iz,z)

!      The length of the workspace required for the basis factors in this
!      problem is longer than the minimum returned by the query

       lenz = 2*minz
       leniz = 2*miniz
       ALLOCATE (iz(leniz),z(lenz))

       ifail = 0
       CALL e04ugf(e04ugm,objfun,n,m,ncnln,nonln,njnln,iobj,nnz,a,ha,ka,bl,bu, &
          start,nname,names,ns,xs,istate,clamda,miniz,minz,ninf,sinf,obj,iz, &
          leniz,z,lenz,iuser,user,ifail)
20     CONTINUE

99999  FORMAT (1X,A,I5)
99998  FORMAT (1X,A)
    END PROGRAM e04uhfe