* E04UFA 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) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER (ZERO=0.0D+0,ONE=1.0D+0,TWO=2.0D+0) INTEGER LCWSAV, LIWSAV, LLWSAV, LRWSAV PARAMETER (LCWSAV=5,LIWSAV=610,LLWSAV=120,LRWSAV=475) * .. Local Scalars .. DOUBLE PRECISION OBJF INTEGER I, IFAIL, IREVCM, 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), RWSAV(LRWSAV), + WORK(LWORK), X(NMAX) INTEGER ISTATE(NMAX+NCLMAX+NCNMAX), IWORK(LIWORK), + IWSAV(LIWSAV), NEEDC(NCNMAX) LOGICAL LWSAV(LLWSAV) CHARACTER*80 CWSAV(LCWSAV) * .. External Subroutines .. EXTERNAL DGEMV, E04UFA, E04WBF * .. Executable Statements .. WRITE (NOUT,*) 'E04UFA 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) * * Set all constraint 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 * * Initialise E04UFA and check for error exits * IFAIL = 1 CALL E04WBF('E04UFA',CWSAV,LCWSAV,LWSAV,LLWSAV,IWSAV,LIWSAV, + RWSAV,LRWSAV,IFAIL) IF (IFAIL.NE.0) THEN WRITE (NOUT,99999) IFAIL ELSE * * Solve the problem. * IREVCM = 0 IFAIL = 1 * 60 CONTINUE * CALL E04UFA(IREVCM,N,NCLIN,NCNLN,LDA,LDCJ,LDR,A,BL,BU,ITER, + ISTATE,C,CJAC,CLAMDA,OBJF,OBJGRD,R,X,NEEDC, + IWORK,LIWORK,WORK,LWORK,CWSAV,LWSAV,IWSAV,RWSAV, + IFAIL) * * On intermediate exit IFAIL should not have been changed * and IREVCM should be > 0. * IF (IREVCM.GT.0) THEN IF (IREVCM.EQ.1 .OR. IREVCM.EQ.3) THEN * Evaluate the objective function. OBJF = X(1)*X(4)*(X(1)+X(2)+X(3)) + X(3) END IF IF (IREVCM.EQ.2 .OR. IREVCM.EQ.3) THEN * Evaluate the objective gradient. 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 * IF (IREVCM.EQ.4 .OR. IREVCM.EQ.6) THEN * Evaluate the nonlinear constraint functions. IF (NEEDC(1).GT.0) C(1) = X(1)**2 + X(2)**2 + X(3) + **2 + X(4)**2 IF (NEEDC(2).GT.0) C(2) = X(1)*X(2)*X(3)*X(4) END IF IF (IREVCM.EQ.5 .OR. IREVCM.EQ.6) THEN * Evaluate the constraint Jacobian. IF (NEEDC(1).GT.0) 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 IF (NEEDC(2).GT.0) 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 GO TO 60 ELSE IF (IFAIL.GE.9) THEN WRITE (NOUT,99998) ELSE IF (IFAIL.EQ.7) THEN WRITE (NOUT,99997) ELSE IF (IFAIL.GE.0) THEN WRITE (NOUT,99996) IFAIL WRITE (NOUT,*) WRITE (NOUT,99995) WRITE (NOUT,*) DO 80 I = 1, N WRITE (NOUT,99994) I, ISTATE(I), X(I), CLAMDA(I) 80 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,99993) WRITE (NOUT,*) DO 100 I = N + 1, N + NCLIN J = I - N WRITE (NOUT,99992) J, ISTATE(I), WORK(J), CLAMDA(I) 100 CONTINUE END IF IF (NCNLN.GT.0) THEN WRITE (NOUT,*) WRITE (NOUT,*) WRITE (NOUT,99991) WRITE (NOUT,*) DO 120 I = N + NCLIN + 1, N + NCLIN + NCNLN J = I - N - NCLIN WRITE (NOUT,99990) J, ISTATE(I), C(J), CLAMDA(I) 120 CONTINUE END IF WRITE (NOUT,*) WRITE (NOUT,*) WRITE (NOUT,99989) OBJF ELSE WRITE (NOUT,99988) IFAIL END IF END IF ELSE WRITE (NOUT,99987) END IF * 99999 FORMAT (1X,/1X,' ** E04WBF returned with IFAIL = ',I5) 99998 FORMAT (1X,' ** An input parameter is invalid') 99997 FORMAT (1X,' ** User supplied derivatives are incorrect') 99996 FORMAT (1X,'E04UFA returned with IFAIL = ',I4) 99995 FORMAT (1X,'Varbl',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99994 FORMAT (1X,'V',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99993 FORMAT (1X,'L Con',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99992 FORMAT (1X,'L',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99991 FORMAT (1X,'N Con',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99990 FORMAT (1X,'N',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99989 FORMAT (1X,'Final objective value = ',1P,G15.7) 99988 FORMAT (1X,/1X,' ** E04UFA returned with IFAIL = ',I5) 99987 FORMAT (1X,' At least one of N, NCLIN or NCNLN is too large') END