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

    MODULE e04zcfe_mod

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

!      .. Use Statements ..
       USE nag_library, ONLY : nag_wp
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Parameters ..
       INTEGER, PARAMETER                  :: nin = 5, nout = 6
    CONTAINS
!dec$ attributes offload : mic :: objfun
       SUBROUTINE objfun(mode,n,x,objf,objgrd,nstate)

!         .. Implicit None Statement ..
          IMPLICIT NONE
!         .. Scalar Arguments ..
          REAL (KIND=nag_wp), INTENT (OUT)    :: objf
          INTEGER, INTENT (INOUT)             :: mode
          INTEGER, INTENT (IN)                :: n, nstate
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (OUT)    :: objgrd(n)
          REAL (KIND=nag_wp), INTENT (IN)     :: x(n)
!         .. Executable Statements ..
          objf = x(2)*x(6) - x(1)*x(7) + x(3)*x(7) + x(5)*x(8) - x(4)*x(9) - &
             x(3)*x(8)
          objf = -objf
          objgrd(1) = x(7)
          objgrd(2) = -x(6)
          objgrd(3) = -x(7) + x(8)
          objgrd(4) = x(9)
          objgrd(5) = -x(8)
          objgrd(6) = -x(2)
          objgrd(7) = -x(3) + x(1)
          objgrd(8) = -x(5) + x(3)
          objgrd(9) = x(4)

          RETURN

!dec$ attributes offload : mic :: objfun
       END SUBROUTINE objfun
!dec$ attributes offload : mic :: confun
       SUBROUTINE confun(mode,ncnln,n,ldcjac,x,c,cjac,nstate)

!         The zero elements of Jacobian matrix are set only once. This
!         occurs during the first call to CONFUN (NSTATE = 1).

!         .. Implicit None Statement ..
          IMPLICIT NONE
!         .. Scalar Arguments ..
          INTEGER, INTENT (IN)                :: ldcjac, n, ncnln, nstate
          INTEGER, INTENT (INOUT)             :: mode
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (OUT)    :: c(ldcjac)
          REAL (KIND=nag_wp), INTENT (INOUT)  :: cjac(ldcjac,n)
          REAL (KIND=nag_wp), INTENT (IN)     :: x(n)
!         .. Executable Statements ..
          IF (nstate==1) THEN
             cjac(1:ncnln,1:n) = 0.0E0_nag_wp
          END IF

          c(1) = x(1)**2 + x(6)**2
          cjac(1,1) = 2.0E0_nag_wp*x(1)
          cjac(1,6) = 2.0E0_nag_wp*x(6)
          c(2) = (x(2)-x(1))**2 + (x(7)-x(6))**2
          cjac(2,1) = -2.0E0_nag_wp*(x(2)-x(1))
          cjac(2,2) = 2.0E0_nag_wp*(x(2)-x(1))
          cjac(2,6) = -2.0E0_nag_wp*(x(7)-x(6))
          cjac(2,7) = 2.0E0_nag_wp*(x(7)-x(6))
          c(3) = (x(3)-x(1))**2 + x(6)**2
          cjac(3,1) = -2.0E0_nag_wp*(x(3)-x(1))
          cjac(3,3) = 2.0E0_nag_wp*(x(3)-x(1))
          cjac(3,6) = 2.0E0_nag_wp*x(6)
          c(4) = (x(1)-x(4))**2 + (x(6)-x(8))**2
          cjac(4,1) = 2.0E0_nag_wp*(x(1)-x(4))
          cjac(4,4) = -2.0E0_nag_wp*(x(1)-x(4))
          cjac(4,6) = 2.0E0_nag_wp*(x(6)-x(8))
          cjac(4,8) = -2.0E0_nag_wp*(x(6)-x(8))
          c(5) = (x(1)-x(5))**2 + (x(6)-x(9))**2
          cjac(5,1) = 2.0E0_nag_wp*(x(1)-x(5))
          cjac(5,5) = -2.0E0_nag_wp*(x(1)-x(5))
          cjac(5,6) = 2.0E0_nag_wp*(x(6)-x(9))
          cjac(5,9) = -2.0E0_nag_wp*(x(6)-x(9))
          c(6) = x(2)**2 + x(7)**2
          cjac(6,2) = 2.0E0_nag_wp*x(2)
          cjac(6,7) = 2.0E0_nag_wp*x(7)
          c(7) = (x(3)-x(2))**2 + x(7)**2
          cjac(7,2) = -2.0E0_nag_wp*(x(3)-x(2))
          cjac(7,3) = 2.0E0_nag_wp*(x(3)-x(2))
          cjac(7,7) = 2.0E0_nag_wp*x(7)
          c(8) = (x(4)-x(2))**2 + (x(8)-x(7))**2
          cjac(8,2) = -2.0E0_nag_wp*(x(4)-x(2))
          cjac(8,4) = 2.0E0_nag_wp*(x(4)-x(2))
          cjac(8,7) = -2.0E0_nag_wp*(x(8)-x(7))
          cjac(8,8) = 2.0E0_nag_wp*(x(8)-x(7))
          c(9) = (x(2)-x(5))**2 + (x(7)-x(9))**2
          cjac(9,2) = 2.0E0_nag_wp*(x(2)-x(5))
          cjac(9,5) = -2.0E0_nag_wp*(x(2)-x(5))
          cjac(9,7) = 2.0E0_nag_wp*(x(7)-x(9))
          cjac(9,9) = -2.0E0_nag_wp*(x(7)-x(9))
          c(10) = x(3)**2
          cjac(10,3) = 2.0E0_nag_wp*x(3)
          c(11) = (x(4)-x(3))**2 + x(8)**2
          cjac(11,3) = -2.0E0_nag_wp*(x(4)-x(3))
          cjac(11,4) = 2.0E0_nag_wp*(x(4)-x(3))
          cjac(11,8) = 2.0E0_nag_wp*x(8)
          c(12) = (x(5)-x(3))**2 + x(9)**2
          cjac(12,3) = -2.0E0_nag_wp*(x(5)-x(3))
          cjac(12,5) = 2.0E0_nag_wp*(x(5)-x(3))
          cjac(12,9) = 2.0E0_nag_wp*x(9)
          c(13) = x(4)**2 + x(8)**2
          cjac(13,4) = 2.0E0_nag_wp*x(4)
          cjac(13,8) = 2.0E0_nag_wp*x(8)
          c(14) = (x(4)-x(5))**2 + (x(9)-x(8))**2
          cjac(14,4) = 2.0E0_nag_wp*(x(4)-x(5))
          cjac(14,5) = -2.0E0_nag_wp*(x(4)-x(5))
          cjac(14,8) = -2.0E0_nag_wp*(x(9)-x(8))
          cjac(14,9) = 2.0E0_nag_wp*(x(9)-x(8))
          c(15) = x(5)**2 + x(9)**2
          cjac(15,5) = 2.0E0_nag_wp*x(5)
          cjac(15,9) = 2.0E0_nag_wp*x(9)

          RETURN

!dec$ attributes offload : mic :: confun
       END SUBROUTINE confun
    END MODULE e04zcfe_mod
    PROGRAM e04zcfe

!      E04ZCF Example Main Program

!      .. Use Statements ..
       USE nag_library, ONLY : e04zcf, nag_wp
       USE e04zcfe_mod, ONLY : confun, nin, nout, objfun
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Local Scalars ..
       REAL (KIND=nag_wp)                  :: objf
       INTEGER                             :: i, ifail, k, ldcjac, lwork, n,   &
                                              ncnln
!      .. Local Arrays ..
       REAL (KIND=nag_wp), ALLOCATABLE     :: c(:), cjac(:,:), objgrd(:),      &
                                              work(:), x(:)
!      .. Intrinsic Functions ..
       INTRINSIC                              max
!      .. Executable Statements ..
       WRITE (nout,*) 'E04ZCF Example Program Results'

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

       n = 9
       ncnln = 15
       ldcjac = max(1,ncnln)
       lwork = 4*n + ncnln + n*ldcjac
       ALLOCATE (c(ldcjac),cjac(ldcjac,n),objgrd(n),x(n),work(lwork))

!      Read in two points and check the derivatives at each point.

LOOP:  DO k = 1, 2
          READ (nin,*) x(1:n)

          ifail = -1
          CALL e04zcf(n,ncnln,ldcjac,confun,objfun,c,cjac,objf,objgrd,x,work, &
             lwork,ifail)

          SELECT CASE (ifail)
          CASE (0)
             WRITE (nout,*)
             WRITE (nout,*) 'Derivatives probably correct at the point'
             WRITE (nout,99999) x(1:n)
          CASE (2)
             WRITE (nout,*) &
                'Probable error in derivative of objective function'
             WRITE (nout,99999) x(1:n)
             WRITE (nout,*) 'The computed gradients are'
             WRITE (nout,99999) objgrd(1:n)
          CASE (3:)
             i = ifail - 2
             WRITE (nout,99998) 'Probable error in derivative of constraint', &
                i, '  at the point'
             WRITE (nout,99999) x(1:n)
             WRITE (nout,*) 'The computed gradients of this constraint are'
             WRITE (nout,99999) cjac(i,1:n)
          CASE DEFAULT
             EXIT LOOP
          END SELECT

       END DO LOOP

99999  FORMAT (1X,1P,5E12.4)
99998  FORMAT (1X,A,I4,A)
    END PROGRAM e04zcfe
