    PROGRAM e04ufae

!      E04UFA Example Program Text

!      Mark 23 Release. NAG Copyright 2011.

!      .. Use Statements ..
       USE nag_library, ONLY : dgemv, e04ufa, e04wbf, nag_wp
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Parameters ..
       REAL (KIND=nag_wp), PARAMETER   :: one = 1.0_nag_wp
       REAL (KIND=nag_wp), PARAMETER   :: zero = 0.0_nag_wp
       INTEGER, PARAMETER              :: inc1 = 1, lcwsav = 5, liwsav = 610,  &
                                          llwsav = 120, lrwsav = 475, nin = 5, &
                                          nout = 6
!      .. Local Scalars ..
       REAL (KIND=nag_wp)              :: objf
       INTEGER                         :: i, ifail, irevcm, iter, j, lda,      &
                                          ldcj, ldr, liwork, lwork, n, nclin,  &
                                          ncnln, sda, sdcjac
!      .. Local Arrays ..
       REAL (KIND=nag_wp), ALLOCATABLE :: a(:,:), bl(:), bu(:), c(:),          &
                                          cjac(:,:), clamda(:), objgrd(:),     &
                                          r(:,:), work(:), x(:)
       REAL (KIND=nag_wp)              :: rwsav(lrwsav)
       INTEGER, ALLOCATABLE            :: istate(:), iwork(:), needc(:)
       INTEGER                         :: iwsav(liwsav)
       LOGICAL                         :: lwsav(llwsav)
       CHARACTER (80)                  :: cwsav(lcwsav)
!      .. Intrinsic Functions ..
       INTRINSIC                          max
!      .. Executable Statements ..
       WRITE (nout,*) 'E04UFA Example Program Results'

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

       READ (nin,*) n, nclin, ncnln
       liwork = 3*n + nclin + 2*ncnln
       lda = max(1,nclin)

       IF (nclin>0) THEN
          sda = n
       ELSE
          sda = 1
       END IF

       ldcj = max(1,ncnln)

       IF (ncnln>0) THEN
          sdcjac = n
       ELSE
          sdcjac = 1
       END IF

       ldr = n

       IF (ncnln==0 .AND. nclin>0) THEN
          lwork = 2*n**2 + 21*n + 11*nclin + 2
       ELSE IF (ncnln>0 .AND. nclin>=0) THEN
          lwork = 2*n**2 + n*nclin + 2*n*ncnln + 21*n + 11*nclin + 22*ncnln + &
             1
       ELSE
          lwork = 21*n + 2
       END IF

       ALLOCATE (istate(n+nclin+ncnln),iwork(liwork),a(lda,sda), &
          bl(n+nclin+ncnln),bu(n+nclin+ncnln),c(max(1, &
          ncnln)),cjac(ldcj,sdcjac),clamda(n+nclin+ncnln),objgrd(n),r(ldr,n), &
          x(n),work(lwork),needc(max(1,ncnln)))

       IF (nclin>0) THEN
          READ (nin,*) (a(i,1:n),i=1,nclin)
       END IF

       READ (nin,*) bl(1:(n+nclin+ncnln))
       READ (nin,*) bu(1:(n+nclin+ncnln))
       READ (nin,*) x(1:n)

!      Set all constraint Jacobian elements to zero.
!      Note that this will only work when 'Derivative Level = 3'
!      (the default; see Section 11.2).

       cjac(1:ncnln,1:n) = zero

!      Initialise E04UFA

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

!      Solve the problem.

       irevcm = 0
       ifail = -1

REVCOMM: DO

          CALL e04ufa(irevcm,n,nclin,ncnln,lda,ldcj,ldr,a,bl,bu,iter,istate,c, &
             cjac,clamda,objf,objgrd,r,x,needc,iwork,liwork,work,lwork,cwsav, &
             lwsav,iwsav,rwsav,ifail)

!         On intermediate exit IFAIL should not have been changed
!         and IREVCM should be > 0.

          IF (irevcm==0) THEN
             EXIT REVCOMM
          END IF

          IF (irevcm==1 .OR. irevcm==3) THEN

!            Evaluate the objective function.

             objf = x(1)*x(4)*(x(1)+x(2)+x(3)) + x(3)
          END IF

          IF (irevcm==2 .OR. irevcm==3) THEN

!            Evaluate the objective gradient.

             objgrd(1) = x(4)*(x(1)+x(1)+x(2)+x(3))
             objgrd(2) = x(1)*x(4)
             objgrd(3) = x(1)*x(4) + one
             objgrd(4) = x(1)*(x(1)+x(2)+x(3))
          END IF

          IF (irevcm==4 .OR. irevcm==6) THEN

!            Evaluate the nonlinear constraint functions.

             IF (needc(1)>0) THEN
                c(1) = x(1)**2 + x(2)**2 + x(3)**2 + x(4)**2
             END IF

             IF (needc(2)>0) THEN
                c(2) = x(1)*x(2)*x(3)*x(4)
             END IF

          END IF

          IF (irevcm==5 .OR. irevcm==6) THEN

!            Evaluate the constraint Jacobian.

             IF (needc(1)>0) THEN
                cjac(1,1) = x(1) + x(1)
                cjac(1,2) = x(2) + x(2)
                cjac(1,3) = x(3) + x(3)
                cjac(1,4) = x(4) + x(4)
             END IF

             IF (needc(2)>0) THEN
                cjac(2,1) = x(2)*x(3)*x(4)
                cjac(2,2) = x(1)*x(3)*x(4)
                cjac(2,3) = x(1)*x(2)*x(4)
                cjac(2,4) = x(1)*x(2)*x(3)
             END IF

          END IF

       END DO REVCOMM

       SELECT CASE (ifail)
       CASE (0:6,8)
          WRITE (nout,*)
          WRITE (nout,99999)
          WRITE (nout,*)

          DO i = 1, n
             WRITE (nout,99998) i, istate(i), x(i), clamda(i)
          END DO

          IF (nclin>0) THEN

!            A*x --> work.
!            The NAG name equivalent of dgemv is f06paf
             CALL dgemv('N',nclin,n,one,a,lda,x,inc1,zero,work,inc1)

             WRITE (nout,*)
             WRITE (nout,*)
             WRITE (nout,99997)
             WRITE (nout,*)

             DO i = n + 1, n + nclin
                j = i - n
                WRITE (nout,99996) j, istate(i), work(j), clamda(i)
             END DO

          END IF

          IF (ncnln>0) THEN
             WRITE (nout,*)
             WRITE (nout,*)
             WRITE (nout,99995)
             WRITE (nout,*)

             DO i = n + nclin + 1, n + nclin + ncnln
                j = i - n - nclin
                WRITE (nout,99994) j, istate(i), c(j), clamda(i)
             END DO

          END IF

          WRITE (nout,*)
          WRITE (nout,*)
          WRITE (nout,99993) objf
       END SELECT

99999  FORMAT (1X,'Varbl',2X,'Istate',3X,'Value',9X,'Lagr Mult')
99998  FORMAT (1X,'V',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4)
99997  FORMAT (1X,'L Con',2X,'Istate',3X,'Value',9X,'Lagr Mult')
99996  FORMAT (1X,'L',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4)
99995  FORMAT (1X,'N Con',2X,'Istate',3X,'Value',9X,'Lagr Mult')
99994  FORMAT (1X,'N',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4)
99993  FORMAT (1X,'Final objective value = ',1P,G15.7)
    END PROGRAM e04ufae
