* E04UCA Example Program Text * Mark 20 Release. NAG Copyright 2001. * .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN=5,NOUT=6) INTEGER NMAX, NCLMAX, NCNMAX PARAMETER (NMAX=10,NCLMAX=10,NCNMAX=10) INTEGER LDA, LDCJ, LDR PARAMETER (LDA=NCLMAX,LDCJ=NCNMAX,LDR=NMAX) INTEGER LIWORK, LWORK PARAMETER (LIWORK=100,LWORK=1000) INTEGER LCWSAV, LIWSAV, LLWSAV, LRWSAV PARAMETER (LCWSAV=1,LIWSAV=610,LLWSAV=120,LRWSAV=475) * .. Local Scalars .. DOUBLE PRECISION OBJF INTEGER I, IFAIL, ITER, J, N, NCLIN, NCNLN * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), BL(NMAX+NCLMAX+NCNMAX), + BU(NMAX+NCLMAX+NCNMAX), C(NCNMAX), + CJAC(LDCJ,NMAX), CLAMDA(NMAX+NCLMAX+NCNMAX), + OBJGRD(NMAX), R(LDR,NMAX), RUSER(1), + RWSAV(LRWSAV), WORK(LWORK), X(NMAX) INTEGER ISTATE(NMAX+NCLMAX+NCNMAX), IUSER(1), + IWORK(LIWORK), IWSAV(LIWSAV) LOGICAL LWSAV(LLWSAV) CHARACTER*80 CWSAV(LCWSAV) * .. External Subroutines .. EXTERNAL CONFUN, DGEMV, E04UCA, E04WBF, OBJFUN * .. Executable Statements .. WRITE (NOUT,*) 'E04UCA Example Program Results' * Skip heading in data file READ (NIN,*) READ (NIN,*) N, NCLIN, NCNLN IF (N.LE.NMAX .AND. NCLIN.LE.NCLMAX .AND. NCNLN.LE.NCNMAX) THEN * * Read A, BL, BU and X from data file * IF (NCLIN.GT.0) READ (NIN,*) ((A(I,J),J=1,N),I=1,NCLIN) READ (NIN,*) (BL(I),I=1,N+NCLIN+NCNLN) READ (NIN,*) (BU(I),I=1,N+NCLIN+NCNLN) READ (NIN,*) (X(I),I=1,N) * * Initialise E04UCA and check for error exits * IFAIL = 1 CALL E04WBF('E04UCA',CWSAV,LCWSAV,LWSAV,LLWSAV,IWSAV,LIWSAV, + RWSAV,LRWSAV,IFAIL) IF (IFAIL.NE.0) THEN WRITE (NOUT,99999) IFAIL ELSE * * Solve the problem * IFAIL = 1 * CALL E04UCA(N,NCLIN,NCNLN,LDA,LDCJ,LDR,A,BL,BU,CONFUN, + OBJFUN,ITER,ISTATE,C,CJAC,CLAMDA,OBJF,OBJGRD,R, + X,IWORK,LIWORK,WORK,LWORK,IUSER,RUSER,LWSAV, + IWSAV,RWSAV,IFAIL) * * Check for error exits * WRITE (NOUT,*) IF (IFAIL.GE.9) THEN WRITE (NOUT,99998) ELSE IF (IFAIL.EQ.7) THEN WRITE (NOUT,99997) ELSE IF (IFAIL.LT.0) THEN WRITE (NOUT,99996) ELSE WRITE (NOUT,99995) IFAIL WRITE (NOUT,*) WRITE (NOUT,99994) WRITE (NOUT,*) DO 20 I = 1, N WRITE (NOUT,99993) I, ISTATE(I), X(I), CLAMDA(I) 20 CONTINUE IF (NCLIN.GT.0) THEN * * Below is a call to the level 2 BLAS routine DGEMV. * This performs the matrix vector multiplication A*X * (linear constraint values) and puts the result in * the first NCLIN locations of WORK. * CALL DGEMV('N',NCLIN,N,1.0D0,A,LDA,X,1,0.0D0,WORK,1) WRITE (NOUT,*) WRITE (NOUT,*) WRITE (NOUT,99992) WRITE (NOUT,*) DO 40 I = N + 1, N + NCLIN J = I - N WRITE (NOUT,99991) J, ISTATE(I), WORK(J), CLAMDA(I) 40 CONTINUE END IF IF (NCNLN.GT.0) THEN WRITE (NOUT,*) WRITE (NOUT,*) WRITE (NOUT,99990) WRITE (NOUT,*) DO 60 I = N + NCLIN + 1, N + NCLIN + NCNLN J = I - N - NCLIN WRITE (NOUT,99989) J, ISTATE(I), C(J), CLAMDA(I) 60 CONTINUE END IF WRITE (NOUT,*) WRITE (NOUT,*) WRITE (NOUT,99988) OBJF END IF END IF END IF STOP * 99999 FORMAT (1X,'E04WBF returned with IFAIL = ',I4) 99998 FORMAT (1X,'An input parameter is invalid') 99997 FORMAT (1X,'User supplied derivatives are incorrect') 99996 FORMAT (1X,'MODE < 0 on exit from OBJFUN or CONFUN.',//' Problem', + ' abandoned.') 99995 FORMAT (1X,'E04UCA returned with IFAIL = ',I4) 99994 FORMAT (1X,'Varbl',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99993 FORMAT (1X,'V',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99992 FORMAT (1X,'L Con',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99991 FORMAT (1X,'L',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99990 FORMAT (1X,'N Con',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99989 FORMAT (1X,'N',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99988 FORMAT (1X,'Final objective value = ',1P,G15.7) END SUBROUTINE OBJFUN(MODE,N,X,OBJF,OBJGRD,NSTATE,IUSER,RUSER) * Routine to evaluate objective function and its 1st derivatives. * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER (ONE=1.0D0,TWO=2.0D0) * .. Scalar Arguments .. DOUBLE PRECISION OBJF INTEGER MODE, N, NSTATE * .. Array Arguments .. DOUBLE PRECISION OBJGRD(N), RUSER(*), X(N) INTEGER IUSER(*) * .. Executable Statements .. IF (MODE.EQ.0 .OR. MODE.EQ.2) OBJF = X(1)*X(4)*(X(1)+X(2)+X(3)) + + X(3) * IF (MODE.EQ.1 .OR. MODE.EQ.2) THEN OBJGRD(1) = X(4)*(TWO*X(1)+X(2)+X(3)) OBJGRD(2) = X(1)*X(4) OBJGRD(3) = X(1)*X(4) + ONE OBJGRD(4) = X(1)*(X(1)+X(2)+X(3)) END IF * RETURN END * SUBROUTINE CONFUN(MODE,NCNLN,N,LDCJ,NEEDC,X,C,CJAC,NSTATE,IUSER, + RUSER) * Routine to evaluate the nonlinear constraints and their 1st * derivatives. * .. Parameters .. DOUBLE PRECISION ZERO, TWO PARAMETER (ZERO=0.0D0,TWO=2.0D0) * .. Scalar Arguments .. INTEGER LDCJ, MODE, N, NCNLN, NSTATE * .. Array Arguments .. DOUBLE PRECISION C(*), CJAC(LDCJ,*), RUSER(*), X(N) INTEGER IUSER(*), NEEDC(*) * .. Local Scalars .. INTEGER I, J * .. Executable Statements .. IF (NSTATE.EQ.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). DO 40 J = 1, N DO 20 I = 1, NCNLN CJAC(I,J) = ZERO 20 CONTINUE 40 CONTINUE END IF * IF (NEEDC(1).GT.0) THEN IF (MODE.EQ.0 .OR. MODE.EQ.2) C(1) = X(1)**2 + X(2)**2 + X(3) + **2 + X(4)**2 IF (MODE.EQ.1 .OR. MODE.EQ.2) THEN CJAC(1,1) = TWO*X(1) CJAC(1,2) = TWO*X(2) CJAC(1,3) = TWO*X(3) CJAC(1,4) = TWO*X(4) END IF END IF * IF (NEEDC(2).GT.0) THEN IF (MODE.EQ.0 .OR. MODE.EQ.2) C(2) = X(1)*X(2)*X(3)*X(4) IF (MODE.EQ.1 .OR. MODE.EQ.2) THEN CJAC(2,1) = X(2)*X(3)*X(4) CJAC(2,2) = X(1)*X(3)*X(4) CJAC(2,3) = X(1)*X(2)*X(4) CJAC(2,4) = X(1)*X(2)*X(3) END IF END IF * RETURN END