* E04ZCA Example Program Text * Mark 20 Release. NAG Copyright 2001. * .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN=5,NOUT=6) * .. Local Scalars .. DOUBLE PRECISION OBJF INTEGER I, IFAIL, J, K, LWORK, N, NCNLN, NROWJ * .. Local Arrays .. DOUBLE PRECISION C(20), CJAC(20,9), OBJGRD(9), RUSER(1), + WORK(351), X(9) INTEGER IUSER(1) * .. External Subroutines .. EXTERNAL CONFUN, E04ZCA, OBJFUN * .. Data statements .. DATA NROWJ/20/, LWORK/351/ * .. Executable Statements .. WRITE (NOUT,*) 'E04ZCA Example Program Results' * Skip heading in data file READ (NIN,*) N = 9 NCNLN = 15 * Read in two points and check the derivatives at each point. DO 20 K = 1, 2 READ (NIN,99999) (X(J),J=1,N) IFAIL = 1 * CALL E04ZCA(N,NCNLN,NROWJ,CONFUN,OBJFUN,C,CJAC,OBJF,OBJGRD,X, + WORK,LWORK,IUSER,RUSER,IFAIL) * WRITE (NOUT,*) IF (IFAIL.EQ.0) THEN WRITE (NOUT,*) + 'Derivatives probably correct at the point' WRITE (NOUT,99998) (X(J),J=1,N) ELSE IF (IFAIL.EQ.1) THEN WRITE (NOUT,*) 'Incorrect parameter supplied to E04ZCA' STOP ELSE IF (IFAIL.EQ.2) THEN WRITE (NOUT,*) + 'Probable error in derivative of objective function' WRITE (NOUT,99998) (X(J),J=1,N) WRITE (NOUT,*) 'The computed gradients are' WRITE (NOUT,99998) (OBJGRD(J),J=1,N) ELSE I = IFAIL - 2 WRITE (NOUT,99997) + 'Probable error in derivative of constraint', I, + ' at the point' WRITE (NOUT,99998) (X(J),J=1,N) WRITE (NOUT,*) + 'The computed gradients of this constraint are' WRITE (NOUT,99998) (CJAC(I,J),J=1,N) END IF 20 CONTINUE STOP * 99999 FORMAT (1X,9F6.2) 99998 FORMAT (1X,1P,5D12.4) 99997 FORMAT (1X,A,I4,A) END * SUBROUTINE OBJFUN(MODE,N,X,OBJF,OBJGRD,NSTATE,IUSER,RUSER) * .. Scalar Arguments .. DOUBLE PRECISION OBJF INTEGER MODE, N, NSTATE * .. Array Arguments .. DOUBLE PRECISION OBJGRD(N), RUSER(1), X(N) INTEGER IUSER(1) * .. 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 CONFUN(MODE,NCNLN,N,NROWJ,X,C,CJAC,NSTATE,IUSER,RUSER) * .. Parameters .. DOUBLE PRECISION ZERO, TWO PARAMETER (ZERO=0.0D0,TWO=2.0D0) * .. Scalar Arguments .. INTEGER MODE, N, NCNLN, NROWJ, NSTATE * .. Array Arguments .. DOUBLE PRECISION C(NROWJ), CJAC(NROWJ,N), RUSER(1), X(N) INTEGER IUSER(1) * .. Local Scalars .. INTEGER I, J * .. Executable Statements .. * The zero elements of Jacobian matrix are set only once. This * occurs during the first call to CONFUN (NSTATE = 1). IF (NSTATE.EQ.1) THEN DO 40 J = 1, N DO 20 I = 1, NCNLN CJAC(I,J) = ZERO 20 CONTINUE 40 CONTINUE END IF C(1) = X(1)**2 + X(6)**2 CJAC(1,1) = TWO*X(1) CJAC(1,6) = TWO*X(6) C(2) = (X(2)-X(1))**2 + (X(7)-X(6))**2 CJAC(2,1) = -TWO*(X(2)-X(1)) CJAC(2,2) = TWO*(X(2)-X(1)) CJAC(2,6) = -TWO*(X(7)-X(6)) CJAC(2,7) = TWO*(X(7)-X(6)) C(3) = (X(3)-X(1))**2 + X(6)**2 CJAC(3,1) = -TWO*(X(3)-X(1)) CJAC(3,3) = TWO*(X(3)-X(1)) CJAC(3,6) = TWO*X(6) C(4) = (X(1)-X(4))**2 + (X(6)-X(8))**2 CJAC(4,1) = TWO*(X(1)-X(4)) CJAC(4,4) = -TWO*(X(1)-X(4)) CJAC(4,6) = TWO*(X(6)-X(8)) CJAC(4,8) = -TWO*(X(6)-X(8)) C(5) = (X(1)-X(5))**2 + (X(6)-X(9))**2 CJAC(5,1) = TWO*(X(1)-X(5)) CJAC(5,5) = -TWO*(X(1)-X(5)) CJAC(5,6) = TWO*(X(6)-X(9)) CJAC(5,9) = -TWO*(X(6)-X(9)) C(6) = X(2)**2 + X(7)**2 CJAC(6,2) = TWO*X(2) CJAC(6,7) = TWO*X(7) C(7) = (X(3)-X(2))**2 + X(7)**2 CJAC(7,2) = -TWO*(X(3)-X(2)) CJAC(7,3) = TWO*(X(3)-X(2)) CJAC(7,7) = TWO*X(7) C(8) = (X(4)-X(2))**2 + (X(8)-X(7))**2 CJAC(8,2) = -TWO*(X(4)-X(2)) CJAC(8,4) = TWO*(X(4)-X(2)) CJAC(8,7) = -TWO*(X(8)-X(7)) CJAC(8,8) = TWO*(X(8)-X(7)) C(9) = (X(2)-X(5))**2 + (X(7)-X(9))**2 CJAC(9,2) = TWO*(X(2)-X(5)) CJAC(9,5) = -TWO*(X(2)-X(5)) CJAC(9,7) = TWO*(X(7)-X(9)) CJAC(9,9) = -TWO*(X(7)-X(9)) C(10) = X(3)**2 CJAC(10,3) = TWO*X(3) C(11) = (X(4)-X(3))**2 + X(8)**2 CJAC(11,3) = -TWO*(X(4)-X(3)) CJAC(11,4) = TWO*(X(4)-X(3)) CJAC(11,8) = TWO*X(8) C(12) = (X(5)-X(3))**2 + X(9)**2 CJAC(12,3) = -TWO*(X(5)-X(3)) CJAC(12,5) = TWO*(X(5)-X(3)) CJAC(12,9) = TWO*X(9) C(13) = X(4)**2 + X(8)**2 CJAC(13,4) = TWO*X(4) CJAC(13,8) = TWO*X(8) C(14) = (X(4)-X(5))**2 + (X(9)-X(8))**2 CJAC(14,4) = TWO*(X(4)-X(5)) CJAC(14,5) = -TWO*(X(4)-X(5)) CJAC(14,8) = -TWO*(X(9)-X(8)) CJAC(14,9) = TWO*(X(9)-X(8)) C(15) = X(5)**2 + X(9)**2 CJAC(15,5) = TWO*X(5) CJAC(15,9) = TWO*X(9) RETURN END