*     E04VJF Example Program Text
*     Mark 21 Release. NAG Copyright 2004.
      IMPLICIT         NONE
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        (NIN=5,NOUT=6)
      INTEGER          NMAX, NFMAX, LENAMX, LENGMX
      PARAMETER        (NMAX=100,NFMAX=100,LENAMX=300,LENGMX=300)
      INTEGER          LENCW, LENIW, LENRW
      PARAMETER        (LENCW=600,LENIW=600,LENRW=600)
*     .. Local Scalars ..
      DOUBLE PRECISION OBJADD, SINF
      INTEGER          I, IFAIL, LENA, LENG, N, NEA, NEG, NF, NFNAME,
     +                 NINF, NS, NXNAME, OBJROW, START
      CHARACTER*8      PROB
*     .. Local Arrays ..
      DOUBLE PRECISION A(LENAMX), F(NFMAX), FLOW(NFMAX), FMUL(NFMAX),
     +                 FUPP(NFMAX), RUSER(1), RW(LENRW), X(NMAX),
     +                 XLOW(NMAX), XMUL(NMAX), XUPP(NMAX)
      INTEGER          FSTATE(NFMAX), IAFUN(LENAMX), IGFUN(LENGMX),
     +                 IUSER(1), IW(LENIW), JAVAR(LENAMX),
     +                 JGVAR(LENGMX), XSTATE(NMAX)
      CHARACTER*8      CUSER(1), CW(LENCW), FNAMES(NFMAX), XNAMES(NMAX)
*     .. External Subroutines ..
      EXTERNAL         E04VGF, E04VHF, E04VJF, E04VLF, E04VMF, USRFUN
*     .. Executable Statements ..
      WRITE (NOUT,*) 'E04VJF Example Program Results'
*     Skip heading in data file
      READ (NIN,*)
      READ (NIN,*) N, NF
*
      IF (N.LE.NMAX .AND. NF.LE.NFMAX) THEN
*
*        Call E04VGF to initialise E04VJF.
         IFAIL = -1
         CALL E04VGF(CW,LENCW,IW,LENIW,RW,LENRW,IFAIL)
*
         LENA = LENAMX
         LENG = LENGMX
*
*        Read the bounds on the variables.
         DO 20 I = 1, N
            READ (NIN,*) XLOW(I), XUPP(I)
   20    CONTINUE
*
         DO 40 I = 1, N
            X(I) = 0.0D0
   40    CONTINUE
*
*        Determine the Jacobian structure.
         IFAIL = 0
         CALL E04VJF(NF,N,USRFUN,IAFUN,JAVAR,A,LENA,NEA,IGFUN,JGVAR,
     +               LENG,NEG,X,XLOW,XUPP,CW,LENCW,IW,LENIW,RW,LENRW,
     +               CUSER,IUSER,RUSER,IFAIL)
*
*        Print the Jacobian structure.
         WRITE (NOUT,*)
         WRITE (NOUT,99999) NEA
         WRITE (NOUT,99998)
         WRITE (NOUT,99997)
         DO 60 I = 1, NEA
            WRITE (NOUT,99996) I, IAFUN(I), JAVAR(I), A(I)
   60    CONTINUE
         WRITE (NOUT,*)
         WRITE (NOUT,99995) NEG
         WRITE (NOUT,99994)
         WRITE (NOUT,99993)
         DO 80 I = 1, NEG
            WRITE (NOUT,99992) I, IGFUN(I), JGVAR(I)
   80    CONTINUE
*
*        Now that we have the determined the structure of the
*        Jacobian, set up the information necessary to solve
*        the optimization problem.
         START = 0
         NFNAME = 1
         NXNAME = 1
         PROB = 'E04VJFE'
         OBJADD = 0.0
         DO 100 I = 1, N
            X(I) = 0.0D0
            XSTATE(I) = 0
            XMUL(I) = 0.0D0
  100    CONTINUE
         DO 120 I = 1, NF
            F(I) = 0.0D0
            FSTATE(I) = 0
            FMUL(I) = 0.0D0
  120    CONTINUE
*
*        The row containing the objective function.
         READ (NIN,*) OBJROW
*
*        Read the bounds on the functions.
         DO 140 I = 1, NF
            READ (NIN,*) FLOW(I), FUPP(I)
  140    CONTINUE
*
*        By default E04VHF does not print monitoring
*        information. Set the print file unit or the summary
*        file unit to get information.
         CALL E04VMF('Print file',NOUT,CW,IW,RW,IFAIL)
*
*        Tell E04VHF that we supply no derivatives in USRFUN.
         CALL E04VLF('Derivative option 0',CW,IW,RW,IFAIL)
*
*        Solve the problem.
         IFAIL = -1
         CALL E04VHF(START,NF,N,NXNAME,NFNAME,OBJADD,OBJROW,PROB,USRFUN,
     +               IAFUN,JAVAR,A,LENA,NEA,IGFUN,JGVAR,LENG,NEG,XLOW,
     +               XUPP,XNAMES,FLOW,FUPP,FNAMES,X,XSTATE,XMUL,F,
     +               FSTATE,FMUL,NS,NINF,SINF,CW,LENCW,IW,LENIW,RW,
     +               LENRW,CUSER,IUSER,RUSER,IFAIL)
*
         WRITE (NOUT,*)
         WRITE (NOUT,99991) IFAIL
         IF (IFAIL.EQ.0 .OR. IFAIL.EQ.4) THEN
            WRITE (NOUT,99990) F(OBJROW)
            WRITE (NOUT,99989) (X(I),I=1,N)
         END IF
      END IF
*
      STOP
*
99999 FORMAT (1X,'NEA (the number of non-zero entries in A) = ',I3)
99998 FORMAT (1X,'  I     IAFUN(I)   JAVAR(I)          A(I)')
99997 FORMAT (1X,'----    --------   --------   -----------')
99996 FORMAT (1X,I3,2I10,1P,E18.4)
99995 FORMAT (1X,'NEG (the number of non-zero entries in G) = ',I3)
99994 FORMAT (1X,'  I     IGFUN(I)   JGVAR(I)')
99993 FORMAT (1X,'----    --------   --------')
99992 FORMAT (1X,I3,2I10)
99991 FORMAT (1X,'On exit from E04VHF, IFAIL = ',I5)
99990 FORMAT (1X,'Final objective value = ',F11.1)
99989 FORMAT (1X,'Optimal X = ',7F9.2)
      END

      SUBROUTINE USRFUN(STATUS,N,X,NEEDF,NF,F,NEEDG,LENG,G,CUSER,IUSER,
     +                  RUSER)
      IMPLICIT          NONE
*     .. Scalar Arguments ..
      INTEGER           LENG, N, NEEDF, NEEDG, NF, STATUS
*     .. Array Arguments ..
      DOUBLE PRECISION  F(NF), G(LENG), RUSER(*), X(N)
      INTEGER           IUSER(*)
      CHARACTER*8       CUSER(*)
*     .. Intrinsic Functions ..
      INTRINSIC         SIN
*     .. Executable Statements ..
      IF (NEEDF.GT.0) THEN
         F(1) = 1000.0D+0*SIN(-X(1)-0.25D+0) + 1000.0D+0*SIN(-X(2)
     +          -0.25D+0) - X(3)
         F(2) = 1000.0D+0*SIN(X(1)-0.25D+0) + 1000.0D+0*SIN(X(1)-X(2)
     +          -0.25D+0) - X(4)
         F(3) = 1000.0D+0*SIN(X(2)-X(1)-0.25D+0) + 1000.0D+0*SIN(X(2)
     +          -0.25D+0)
         F(4) = -X(1) + X(2)
         F(5) = X(1) - X(2)
         F(6) = 1.0D-6*X(3)**3 + 2.0D-6*X(4)**3/3.0D+0 + 3*X(3) + 2*X(4)
      END IF
*
      END