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

    MODULE e04uhae_mod

!      E04UHA 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 = 550, llwsav = 20,       &
                                              lrwsav = 550, nin = 5,           &
                                              ninopt = 7, nout = 6
    CONTAINS
!dec$ attributes offload : mic :: objfun
       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

!dec$ attributes offload : mic :: objfun
       END SUBROUTINE objfun
    END MODULE e04uhae_mod
    PROGRAM e04uhae

!      E04UHA Example Main Program

!      .. Use Statements ..
       USE nag_library, ONLY : e04uga, e04ugm, e04uha, e04uja, e04wbf, nag_wp, &
                               x04abf, x04acf, x04baf
       USE e04uhae_mod, ONLY : iset, lcwsav, liwsav, llwsav, lrwsav, nin,      &
                               ninopt, nout, objfun
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Parameters ..
       CHARACTER (*), PARAMETER            :: fname = 'e04uhae.opt'
!      .. Local Scalars ..
       REAL (KIND=nag_wp)                  :: obj, sinf
       INTEGER                             :: i, ifail, inform, iobj, j,       &
                                              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)                  :: rwsav(lrwsav), user(1)
       INTEGER, ALLOCATABLE                :: ha(:), istate(:), iz(:), ka(:)
       INTEGER                             :: iuser(1), iwsav(liwsav)
       LOGICAL                             :: lwsav(llwsav)
       CHARACTER (80)                      :: cwsav(lcwsav)
       CHARACTER (8), ALLOCATABLE          :: names(:)
!      .. Intrinsic Functions ..
       INTRINSIC                              max
!      .. Executable Statements ..
       WRITE (rec,99990) 'E04UHA 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)

!      Initialise E04UGA

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

!      Set three options using E04UJA.

       CALL e04uja(' Verify Level = -1 ',lwsav,iwsav,rwsav,inform)

       IF (inform==0) THEN

          CALL e04uja(' Major Iteration Limit = 25 ',lwsav,iwsav,rwsav,inform)

          IF (inform==0) THEN

             CALL e04uja(' Infinite Bound Size = 1.0D+25 ',lwsav,iwsav,rwsav, &
                inform)

          END IF

       END IF

       IF (inform/=0) THEN
          WRITE (rec,99991) 'E04UJA terminated with INFORM = ', inform
          CALL x04baf(nout,rec)
          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 e04uha(ninopt,lwsav,iwsav,rwsav,inform)

       IF (inform/=0) THEN
          WRITE (rec,99991) 'E04UJA 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 e04uga(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,lwsav,iwsav,rwsav,ifail)

       IF (ifail/=0 .AND. ifail/=15 .AND. ifail/=16) THEN
          WRITE (nout,99991) 'Query call to E04UGA 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 = -1
       CALL e04uga(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,lwsav,iwsav,rwsav,ifail)

       SELECT CASE (ifail)
       CASE (0:6)
          WRITE (rec,'()')
          CALL x04baf(nout,rec)
          WRITE (rec,99999)
          CALL x04baf(nout,rec)
          WRITE (rec,'()')
          CALL x04baf(nout,rec)

          DO i = 1, n
             WRITE (rec,99998) i, istate(i), xs(i), clamda(i)
             CALL x04baf(nout,rec)
          END DO

          WRITE (rec,'()')
          CALL x04baf(nout,rec)
          WRITE (rec,'()')
          CALL x04baf(nout,rec)
          WRITE (rec,99996)
          CALL x04baf(nout,rec)
          WRITE (rec,'()')
          CALL x04baf(nout,rec)

          IF (ncnln>0) THEN

             DO i = n + 1, n + ncnln
                j = i - n
                WRITE (rec,99995) j, istate(i), xs(i), clamda(i)
                CALL x04baf(nout,rec)
             END DO

          END IF

          IF (ncnln==0 .AND. m==1 .AND. a(1)==0.0E0_nag_wp) THEN
             WRITE (rec,99993) istate(n+1), xs(n+1), clamda(n+1)
             CALL x04baf(nout,rec)
          ELSE IF (m>ncnln) THEN

             DO i = n + ncnln + 1, n + m
                j = i - n - ncnln

                IF (i-n==iobj) THEN
                   WRITE (rec,99994) istate(i), xs(i), clamda(i)
                   CALL x04baf(nout,rec)
                ELSE
                   WRITE (rec,99997) j, istate(i), xs(i), clamda(i)
                   CALL x04baf(nout,rec)
                END IF

             END DO

          END IF

          WRITE (rec,'()')
          CALL x04baf(nout,rec)
          WRITE (rec,'()')
          CALL x04baf(nout,rec)
          WRITE (rec,99992) obj
          CALL x04baf(nout,rec)
       END SELECT

20     CONTINUE

99999  FORMAT (1X,'Variable',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99998  FORMAT (1X,'Varble',1X,I2,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99997  FORMAT (1X,'LinCon',1X,I2,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99996  FORMAT (1X,'Constrnt',2X,'Istate',5X,'Value',9X,'Lagr Mult')
99995  FORMAT (1X,'NlnCon',1X,I2,1X,I3,4X,1P,G14.6,2X,1P,G12.4)
99994  FORMAT (1X,'Free Row',2X,I3,4X,1P,G14.6,2X,1P,G12.4)
99993  FORMAT (1X,'DummyRow',2X,I3,4X,1P,G14.6,2X,1P,G12.4)
99992  FORMAT (1X,'Final objective value = ',1P,G15.7)
99991  FORMAT (1X,A,I5)
99990  FORMAT (1X,A)
    END PROGRAM e04uhae
