    PROGRAM e04ndae

!      E04NDA Example Program Text

!      Mark 23 Release. NAG Copyright 2011.

!      .. Use Statements ..
       USE nag_library, ONLY : dgemv, e04nca, e04nda, e04nea, e04wbf, nag_wp,  &
                               x04abf, x04acf, x04baf
!      .. 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, iset = 1, lcwsav = 1,      &
                                          liwsav = 610, llwsav = 120,          &
                                          lrwsav = 475, nin = 5, ninopt = 7,   &
                                          nout = 6
       CHARACTER (*), PARAMETER        :: fname = 'e04ndae.opt'
!      .. Local Scalars ..
       REAL (KIND=nag_wp)              :: obj
       INTEGER                         :: i, ifail, inform, iter, j, lda, ldc, &
                                          liwork, lwork, m, mode, n, nclin,    &
                                          outchn, sdc
       CHARACTER (80)                  :: rec
!      .. Local Arrays ..
       REAL (KIND=nag_wp), ALLOCATABLE :: a(:,:), b(:), bl(:), bu(:), c(:,:),  &
                                          clamda(:), cvec(:), work(:), x(:)
       REAL (KIND=nag_wp)              :: rwsav(lrwsav)
       INTEGER, ALLOCATABLE            :: istate(:), iwork(:), kx(:)
       INTEGER                         :: iwsav(liwsav)
       LOGICAL                         :: lwsav(llwsav)
       CHARACTER (80)                  :: cwsav(lcwsav)
!      .. Intrinsic Functions ..
       INTRINSIC                          max
!      .. Executable Statements ..
       WRITE (rec,99993) 'E04NDA Example Program Results'
       CALL x04baf(nout,rec)

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

       READ (nin,*) m, n, nclin
       liwork = n
       ldc = max(1,nclin)
       lda = max(1,m)

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

!      This particular example problem is of type QP2, so we allocate
!      A(LDA,N), CVEC(N), B(1) and define LWORK as below

       IF (nclin>0) THEN
          lwork = 2*n**2 + 10*n + 6*nclin
       ELSE
          lwork = 10*n
       END IF

       ALLOCATE (istate(n+nclin),kx(n),iwork(liwork),c(ldc,sdc),bl(n+nclin), &
          bu(n+nclin),cvec(n),x(n),a(lda,n),b(1),clamda(n+nclin),work(lwork))

       READ (nin,*) cvec(1:n)
       READ (nin,*) (a(i,1:n),i=1,m)
       READ (nin,*) (c(i,1:sdc),i=1,nclin)
       READ (nin,*) bl(1:(n+nclin))
       READ (nin,*)
       READ (nin,*) bu(1:(n+nclin))
       READ (nin,*)
       READ (nin,*) x(1:n)

!      Set the unit number for advisory messages to OUTCHN

       outchn = nout
       CALL x04abf(iset,outchn)

!      Initialise E04NCA

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

!      Set one option using E04NEA

       CALL e04nea(' Problem Type = QP2 ',lwsav,iwsav,rwsav,inform)

       IF (inform/=0) THEN
          WRITE (rec,99999) ' ** E04NEA 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 e04nda(ninopt,lwsav,iwsav,rwsav,inform)

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

!      Solve the problem

       ifail = -1
       CALL e04nca(m,n,nclin,ldc,lda,c,bl,bu,cvec,istate,kx,x,a,b,iter,obj, &
          clamda,iwork,liwork,work,lwork,lwsav,iwsav,rwsav,ifail)

       SELECT CASE (ifail)
       CASE (0:5,7:)
          WRITE (rec,'()')
          CALL x04baf(nout,rec)
          WRITE (rec,99998)
          CALL x04baf(nout,rec)
          WRITE (rec,'()')
          CALL x04baf(nout,rec)

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

          IF (nclin>0) THEN

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

             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)

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

          END IF

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

20     CONTINUE

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