! E04ZCA Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE e04zcae_mod ! E04ZCA 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 SUBROUTINE objfun(mode,n,x,objf,objgrd,nstate,iuser,ruser) ! .. 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 (INOUT) :: ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) ! .. 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 END SUBROUTINE objfun SUBROUTINE confun(mode,ncnln,n,ldcjac,x,c,cjac,nstate,iuser,ruser) ! 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), ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) ! .. 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 END SUBROUTINE confun END MODULE e04zcae_mod PROGRAM e04zcae ! E04ZCA Example Main Program ! .. Use Statements .. USE nag_library, ONLY : e04zca, nag_wp USE e04zcae_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(:) REAL (KIND=nag_wp) :: ruser(1) INTEGER :: iuser(1) ! .. Intrinsic Functions .. INTRINSIC max ! .. Executable Statements .. WRITE (nout,*) 'E04ZCA 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 e04zca(n,ncnln,ldcjac,confun,objfun,c,cjac,objf,objgrd,x,work, & lwork,iuser,ruser,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 e04zcae