*     E04VHF 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, E04VLF, E04VMF, USRFUN
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
      WRITE (NOUT,*) 'E04VHF Example Program Results'
*     Skip heading in data file
      READ (NIN,*)
      READ (NIN,*) N, NF
      READ (NIN,*) NEA, NEG, OBJROW, START
*
      IF (N.LE.NMAX .AND. NF.LE.NFMAX .AND. NEA.LE.LENAMX .AND. NEG.LE.
     +    LENGMX) THEN
         LENA = MAX(1,NEA)
         LENG = MAX(1,NEG)
         NXNAME = N
         NFNAME = NF
         OBJADD = 0.0D0
         PROB = ' '
*
*        Read the variable names XNAMES
         READ (NIN,*) (XNAMES(I),I=1,NXNAME)
*        Read the function names FNAMES
         READ (NIN,*) (FNAMES(I),I=1,NFNAME)
*
*        Read the sparse matrix A, the linear part of F
         DO 20 I = 1, NEA
*           For each element read row, column, A(row,column)
            READ (NIN,*) IAFUN(I), JAVAR(I), A(I)
   20    CONTINUE

*        Read the structure of sparse matrix G, the nonlinear part of F
         DO 40 I = 1, NEG
*           For each element read row, column
            READ (NIN,*) IGFUN(I), JGVAR(I)
   40    CONTINUE
*
*        Read the lower and upper bounds on the variables
         DO 60 I = 1, N
            READ (NIN,*) XLOW(I), XUPP(I)
   60    CONTINUE
*
*        Read the lower and upper bounds on the functions
         DO 80 I = 1, NF
            READ (NIN,*) FLOW(I), FUPP(I)
   80    CONTINUE
*
*        Initialise X, XSTATE, XMUL, F, FSTATE, FMUL
         READ (NIN,*) (X(I),I=1,N)
         READ (NIN,*) (XSTATE(I),I=1,N)
         READ (NIN,*) (XMUL(I),I=1,N)
         READ (NIN,*) (F(I),I=1,NF)
         READ (NIN,*) (FSTATE(I),I=1,NF)
         READ (NIN,*) (FMUL(I),I=1,NF)
*
*        Call E04VGF to initialise E04VHF.
         IFAIL = -1
         CALL E04VGF(CW,LENCW,IW,LENIW,RW,LENRW,IFAIL)
*
*        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)
*
*        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,99999) IFAIL
         IF (IFAIL.EQ.0) THEN
            WRITE (NOUT,99998) F(OBJROW)
            WRITE (NOUT,99997) (X(I),I=1,N)
         END IF
*
      END IF
      STOP
*
99999 FORMAT (1X,'On exit from E04VHF, IFAIL = ',I5)
99998 FORMAT (1X,'Final objective value = ',F11.1)
99997 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         COS, SIN
*     .. Executable Statements ..
      IF (NEEDF.GT.0) THEN
*        The nonlinear components of f_i(x) need to be assigned,
*        for i = 1 to NF
         F(1) = 1000.0D+0*SIN(-X(1)-0.25D+0) + 1000.0D+0*SIN(-X(2)
     +          -0.25D+0)
         F(2) = 1000.0D+0*SIN(X(1)-0.25D+0) + 1000.0D+0*SIN(X(1)-X(2)
     +          -0.25D+0)
         F(3) = 1000.0D+0*SIN(X(2)-X(1)-0.25D+0) + 1000.0D+0*SIN(X(2)
     +          -0.25D+0)
*        N.B. in this example there is no need to assign for the wholly
*        linear components f_4(x) and f_5(x).
         F(6) = 1.0D-6*X(3)**3 + 2.0D-6*X(4)**3/3.0D+0
      END IF
*
      IF (NEEDG.GT.0) THEN
*        The derivatives of the function f_i(x) need to be assigned.
*        G(k) should be set to partial derivative df_i(x)/dx_j where
*        i = IGFUN(k) and j = IGVAR(k), for k = 1 to LENG.
         G(1) = -1000.0D+0*COS(-X(1)-0.25D+0)
         G(2) = -1000.0D+0*COS(-X(2)-0.25D+0)
         G(3) = 1000.0D+0*COS(X(1)-0.25D+0) + 1000.0D+0*COS(X(1)-X(2)
     +          -0.25D+0)
         G(4) = -1000.0D+0*COS(X(1)-X(2)-0.25D+0)
         G(5) = -1000.0D+0*COS(X(2)-X(1)-0.25D+0)
         G(6) = 1000.0D+0*COS(X(2)-X(1)-0.25D+0) + 1000.0D+0*COS(X(2)
     +          -0.25D+0)
         G(7) = 3.0D-6*X(3)**2
         G(8) = 2.0D-6*X(4)**2
      END IF
*
      RETURN
      END