* E04UQA Example Program Text * Mark 20 Release. NAG Copyright 2001. * .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN=5,NOUT=6) INTEGER MMAX, NMAX, NCLMAX, NCNMAX PARAMETER (MMAX=50,NMAX=10,NCLMAX=10,NCNMAX=10) INTEGER LDA, LDCJ, LDFJ, LDR PARAMETER (LDA=NCLMAX,LDCJ=NCNMAX,LDFJ=MMAX,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, INFORM, ITER, J, JFAIL, M, N, NCLIN, + NCNLN, OUTCHN * .. Local Arrays .. DOUBLE PRECISION A(LDA,NMAX), BL(NMAX+NCLMAX+NCNMAX), + BU(NMAX+NCLMAX+NCNMAX), C(NCNMAX), + CJAC(LDCJ,NMAX), CLAMDA(NMAX+NCLMAX+NCNMAX), + F(MMAX), FJAC(LDFJ,NMAX), R(LDR,NMAX), + RWSAV(LRWSAV), USER(1), WORK(LWORK), X(NMAX), + Y(MMAX) INTEGER ISTATE(NMAX+NCLMAX+NCNMAX), IUSER(1), + IWORK(LIWORK), IWSAV(LIWSAV) LOGICAL LWSAV(LLWSAV) CHARACTER*80 CWSAV(LCWSAV) * .. External Subroutines .. EXTERNAL CONFUN, DGEMV, E04UQA, E04URA, E04USA, E04WBF, + OBJFUN, X04ABF * .. Executable Statements .. WRITE (NOUT,*) 'E04UQA Example Program Results' OUTCHN = NOUT * Skip heading in data file READ (NIN,*) READ (NIN,*) M, N READ (NIN,*) NCLIN, NCNLN IF (M.LE.MMAX .AND. N.LE.NMAX .AND. NCLIN.LE.NCLMAX .AND. + NCNLN.LE.NCNMAX) THEN * * Read A, Y, BL, BU and X from data file * IF (NCLIN.GT.0) READ (NIN,*) ((A(I,J),J=1,N),I=1,NCLIN) READ (NIN,*) (Y(I),I=1,M) 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 the unit number for advisory messages to OUTCHN * CALL X04ABF(1,OUTCHN) * * Initialise using E04WBF and check for error exits * JFAIL = 1 IFAIL = 1 CALL E04WBF('E04USA',CWSAV,LCWSAV,LWSAV,LLWSAV,IWSAV,LIWSAV, + RWSAV,LRWSAV,IFAIL) IF (IFAIL.EQ.0) THEN JFAIL = 2 * * Set two options using E04URF * CALL E04URA(' Infinite Bound Size = 1.0D+25 ',LWSAV,IWSAV, + RWSAV,INFORM) IF (INFORM.EQ.0) THEN CALL E04URA(' Verify Level = -1 ',LWSAV,IWSAV,RWSAV, + INFORM) IF (INFORM.EQ.0) THEN JFAIL = 3 * * Read the options file for the remaining options * CALL E04UQA(NIN,LWSAV,IWSAV,RWSAV,INFORM) IF (INFORM.EQ.0) JFAIL = 0 END IF END IF END IF * IF (JFAIL.EQ.0) THEN * * Solve the problem * IFAIL = 1 * CALL E04USA(M,N,NCLIN,NCNLN,LDA,LDCJ,LDFJ,LDR,A,BL,BU,Y, + CONFUN,OBJFUN,ITER,ISTATE,C,CJAC,F,FJAC,CLAMDA, + OBJF,R,X,IWORK,LIWORK,WORK,LWORK,IUSER,USER, + LWSAV,IWSAV,RWSAV,IFAIL) * * Check for error exits * WRITE (NOUT,*) IF (IFAIL.EQ.9) THEN WRITE (NOUT,99999) ELSE IF (IFAIL.GE.0) THEN WRITE (NOUT,99998) IFAIL WRITE (NOUT,*) WRITE (NOUT,99997) WRITE (NOUT,*) DO 20 I = 1, N WRITE (NOUT,99996) 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,99995) WRITE (NOUT,*) DO 40 I = N + 1, N + NCLIN J = I - N WRITE (NOUT,99994) J, ISTATE(I), WORK(J), CLAMDA(I) 40 CONTINUE END IF IF (NCNLN.GT.0) THEN WRITE (NOUT,*) WRITE (NOUT,*) WRITE (NOUT,99993) WRITE (NOUT,*) DO 60 I = N + NCLIN + 1, N + NCLIN + NCNLN J = I - N - NCLIN WRITE (NOUT,99992) J, ISTATE(I), C(J), CLAMDA(I) 60 CONTINUE END IF WRITE (NOUT,*) WRITE (NOUT,*) WRITE (NOUT,99991) OBJF ELSE IF (IFAIL.EQ.-399) THEN WRITE (NOUT,99990) IFAIL ELSE IF (IFAIL.LT.0) THEN WRITE (NOUT,99989) END IF ELSE IF (JFAIL.EQ.1) THEN WRITE (NOUT,99988) ' ** E04WBF returned with IFAIL = ', + IFAIL ELSE IF (JFAIL.EQ.2) THEN WRITE (NOUT,99988) 'E04URA terminated with INFORM = ', + INFORM ELSE IF (JFAIL.EQ.3) THEN WRITE (NOUT,99988) 'E04UQA terminated with INFORM = ', + INFORM END IF * ELSE WRITE (NOUT,99987) END IF * 99999 FORMAT (1X,' ** An input parameter is invalid') 99998 FORMAT (1X,'E04USA returned with IFAIL = ',I4) 99997 FORMAT (1X,'Varbl',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99996 FORMAT (1X,'V',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99995 FORMAT (1X,'L Con',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99994 FORMAT (1X,'L',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99993 FORMAT (1X,'N Con',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99992 FORMAT (1X,'N',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99991 FORMAT (1X,'Final objective value = ',G15.7) 99990 FORMAT (1X,' ** E04USA returned with IFAIL = ',I5) 99989 FORMAT (1X,'MODE < 0 on exit from OBJFUN or CONFUN.',//' Problem', + ' abandoned.') 99988 FORMAT (1X,A,I5) 99987 FORMAT (1X,'At least one of M, N, NCLIN or NCNLN is too large') END SUBROUTINE OBJFUN(MODE,M,N,LDFJ,NEEDFI,X,F,FJAC,NSTATE,IUSER,USER) * Routine to evaluate the subfunctions and their 1st derivatives. * .. Parameters .. DOUBLE PRECISION PT49, ONE, EIGHT PARAMETER (PT49=0.49D0,ONE=1.0D0,EIGHT=8.0D0) * .. Scalar Arguments .. INTEGER LDFJ, M, MODE, N, NEEDFI, NSTATE * .. Array Arguments .. DOUBLE PRECISION F(*), FJAC(LDFJ,*), USER(*), X(N) INTEGER IUSER(*) * .. Local Scalars .. DOUBLE PRECISION AI, TEMP, X1, X2 INTEGER I LOGICAL MODE02, MODE12 * .. Local Arrays .. DOUBLE PRECISION A(44) * .. Intrinsic Functions .. INTRINSIC EXP * .. Data statements .. DATA A/8.0D0, 8.0D0, 10.0D0, 10.0D0, 10.0D0, 10.0D0, + 12.0D0, 12.0D0, 12.0D0, 12.0D0, 14.0D0, 14.0D0, + 14.0D0, 16.0D0, 16.0D0, 16.0D0, 18.0D0, 18.0D0, + 20.0D0, 20.0D0, 20.0D0, 22.0D0, 22.0D0, 22.0D0, + 24.0D0, 24.0D0, 24.0D0, 26.0D0, 26.0D0, 26.0D0, + 28.0D0, 28.0D0, 30.0D0, 30.0D0, 30.0D0, 32.0D0, + 32.0D0, 34.0D0, 36.0D0, 36.0D0, 38.0D0, 38.0D0, + 40.0D0, 42.0D0/ * .. Executable Statements .. X1 = X(1) X2 = X(2) MODE02 = MODE .EQ. 0 .OR. MODE .EQ. 2 MODE12 = MODE .EQ. 1 .OR. MODE .EQ. 2 DO 20 I = 1, M IF (NEEDFI.EQ.I) THEN F(I) = X1 + (PT49-X1)*EXP(-X2*(A(I)-EIGHT)) RETURN ELSE AI = A(I) TEMP = EXP(-X2*(AI-EIGHT)) IF (MODE02) F(I) = X1 + (PT49-X1)*TEMP IF (MODE12) THEN FJAC(I,1) = ONE - TEMP FJAC(I,2) = -(PT49-X1)*(AI-EIGHT)*TEMP END IF END IF 20 CONTINUE * RETURN END * SUBROUTINE CONFUN(MODE,NCNLN,N,LDCJ,NEEDC,X,C,CJAC,NSTATE,IUSER, + USER) * Routine to evaluate the nonlinear constraint and its 1st * derivatives. * .. Parameters .. DOUBLE PRECISION ZERO, PT09, PT49 PARAMETER (ZERO=0.0D0,PT09=0.09D0,PT49=0.49D0) * .. Scalar Arguments .. INTEGER LDCJ, MODE, N, NCNLN, NSTATE * .. Array Arguments .. DOUBLE PRECISION C(*), CJAC(LDCJ,*), USER(*), 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) = -PT09 - X(1)*X(2) + + PT49*X(2) IF (MODE.EQ.1 .OR. MODE.EQ.2) THEN CJAC(1,1) = -X(2) CJAC(1,2) = -X(1) + PT49 END IF END IF * RETURN END