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

    MODULE e04usae_mod

!      E04USA Example Program Module:
!             Parameters and User-defined Routines

!      .. Use Statements ..
       USE nag_library, ONLY : 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 = 1,            &
                                              liwsav = 610, llwsav = 120,      &
                                              lrwsav = 475, nin = 5, nout = 6
    CONTAINS
!dec$ attributes offload : mic :: objfun
       SUBROUTINE objfun(mode,m,n,ldfj,needfi,x,f,fjac,nstate,iuser,ruser)
!         Routine to evaluate the subfunctions and their 1st derivatives.

!         .. Implicit None Statement ..
          IMPLICIT NONE
!         .. Parameters ..
          REAL (KIND=nag_wp), PARAMETER       :: a(44) = (/ 8.0_nag_wp,        &
                                                 8.0_nag_wp, 10.0_nag_wp,      &
                                                 10.0_nag_wp, 10.0_nag_wp,     &
                                                 10.0_nag_wp, 12.0_nag_wp,     &
                                                 12.0_nag_wp, 12.0_nag_wp,     &
                                                 12.0_nag_wp, 14.0_nag_wp,     &
                                                 14.0_nag_wp, 14.0_nag_wp,     &
                                                 16.0_nag_wp, 16.0_nag_wp,     &
                                                 16.0_nag_wp, 18.0_nag_wp,     &
                                                 18.0_nag_wp, 20.0_nag_wp,     &
                                                 20.0_nag_wp, 20.0_nag_wp,     &
                                                 22.0_nag_wp, 22.0_nag_wp,     &
                                                 22.0_nag_wp, 24.0_nag_wp,     &
                                                 24.0_nag_wp, 24.0_nag_wp,     &
                                                 26.0_nag_wp, 26.0_nag_wp,     &
                                                 26.0_nag_wp, 28.0_nag_wp,     &
                                                 28.0_nag_wp, 30.0_nag_wp,     &
                                                 30.0_nag_wp, 30.0_nag_wp,     &
                                                 32.0_nag_wp, 32.0_nag_wp,     &
                                                 34.0_nag_wp, 36.0_nag_wp,     &
                                                 36.0_nag_wp, 38.0_nag_wp,     &
                                                 38.0_nag_wp, 40.0_nag_wp,     &
                                                 42.0_nag_wp/)
!         .. Scalar Arguments ..
          INTEGER, INTENT (IN)                :: ldfj, m, n, needfi, nstate
          INTEGER, INTENT (INOUT)             :: mode
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (OUT)    :: f(m)
          REAL (KIND=nag_wp), INTENT (INOUT)  :: fjac(ldfj,n), ruser(*)
          REAL (KIND=nag_wp), INTENT (IN)     :: x(n)
          INTEGER, INTENT (INOUT)             :: iuser(*)
!         .. Local Scalars ..
          REAL (KIND=nag_wp)                  :: ai, temp, x1, x2
          INTEGER                             :: i
          LOGICAL                             :: mode02, mode12
!         .. Intrinsic Functions ..
          INTRINSIC                              exp
!         .. Executable Statements ..
          x1 = x(1)
          x2 = x(2)

          mode02 = (mode==0 .OR. mode==2)
          mode12 = (mode==1 .OR. mode==2)

LOOP:     DO i = 1, m

             IF (needfi==i) THEN
                f(i) = x1 + (0.49_nag_wp-x1)*exp(-x2*(a(i)-8.0_nag_wp))
                EXIT LOOP
             END IF

             ai = a(i)
             temp = exp(-x2*(ai-8.0_nag_wp))

             IF (mode02) THEN
                f(i) = x1 + (0.49_nag_wp-x1)*temp
             END IF

             IF (mode12) THEN
                fjac(i,1) = one - temp
                fjac(i,2) = -(0.49_nag_wp-x1)*(ai-8.0_nag_wp)*temp
             END IF

          END DO LOOP

          RETURN

!dec$ attributes offload : mic :: objfun
       END SUBROUTINE objfun
!dec$ attributes offload : mic :: confun
       SUBROUTINE confun(mode,ncnln,n,ldcj,needc,x,c,cjac,nstate,iuser,ruser)
!         Routine to evaluate the nonlinear constraint and its 1st
!         derivatives.

!         .. Implicit None Statement ..
          IMPLICIT NONE
!         .. Scalar Arguments ..
          INTEGER, INTENT (IN)                :: ldcj, n, ncnln, nstate
          INTEGER, INTENT (INOUT)             :: mode
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (OUT)    :: c(ncnln)
          REAL (KIND=nag_wp), INTENT (INOUT)  :: cjac(ldcj,n), ruser(*)
          REAL (KIND=nag_wp), INTENT (IN)     :: x(n)
          INTEGER, INTENT (INOUT)             :: iuser(*)
          INTEGER, INTENT (IN)                :: needc(ncnln)
!         .. Executable Statements ..
          IF (nstate==1) THEN

!            First call to CONFUN.  Set all 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
          END IF

          IF (needc(1)>0) THEN

             IF (mode==0 .OR. mode==2) THEN
                c(1) = -0.09_nag_wp - x(1)*x(2) + 0.49_nag_wp*x(2)
             END IF

             IF (mode==1 .OR. mode==2) THEN
                cjac(1,1) = -x(2)
                cjac(1,2) = -x(1) + 0.49_nag_wp
             END IF

          END IF

          RETURN

!dec$ attributes offload : mic :: confun
       END SUBROUTINE confun
    END MODULE e04usae_mod
    PROGRAM e04usae

!      E04USA Example Main Program

!      .. Use Statements ..
       USE nag_library, ONLY : dgemv, e04usa, e04wbf, nag_wp
       USE e04usae_mod, ONLY : confun, inc1, lcwsav, liwsav, llwsav, lrwsav,   &
                               nin, nout, objfun, one, zero
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Local Scalars ..
       REAL (KIND=nag_wp)                  :: objf
       INTEGER                             :: i, ifail, iter, j, lda, ldcj,    &
                                              ldfj, ldr, liwork, lwork, m, n,  &
                                              nclin, ncnln, sda, sdcjac
!      .. Local Arrays ..
       REAL (KIND=nag_wp), ALLOCATABLE     :: a(:,:), bl(:), bu(:), c(:),      &
                                              cjac(:,:), clamda(:), f(:),      &
                                              fjac(:,:), r(:,:), work(:),      &
                                              x(:), y(:)
       REAL (KIND=nag_wp)                  :: rwsav(lrwsav), user(1)
       INTEGER, ALLOCATABLE                :: istate(:), iwork(:)
       INTEGER                             :: iuser(1), iwsav(liwsav)
       LOGICAL                             :: lwsav(llwsav)
       CHARACTER (80)                      :: cwsav(lcwsav)
!      .. Intrinsic Functions ..
       INTRINSIC                              max
!      .. Executable Statements ..
       WRITE (nout,*) 'E04USA Example Program Results'

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

       READ (nin,*) m, n
       READ (nin,*) 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

       ldfj = m
       ldr = n

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

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

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

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

!      Initialise E04USA

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

!      Solve the problem

       ifail = -1
       CALL e04usa(m,n,nclin,ncnln,lda,ldcj,ldfj,ldr,a,bl,bu,y,confun,objfun, &
          iter,istate,c,cjac,f,fjac,clamda,objf,r,x,iwork,liwork,work,lwork, &
          iuser,user,lwsav,iwsav,rwsav,ifail)

       SELECT CASE (ifail)
       CASE (0: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 = ',G15.7)
    END PROGRAM e04usae
