*     C05PBA Example Program Text
*     Mark 22 Release. NAG Copyright 2006.
*     .. Parameters ..
      INTEGER          N, LDFJAC, LWA
      PARAMETER        (N=9,LDFJAC=N,LWA=(N*(N+13))/2)
      INTEGER          NOUT
      PARAMETER        (NOUT=6)
*     .. Local Scalars ..
      DOUBLE PRECISION FNORM, TOL
      INTEGER          IFAIL, J
*     .. Local Arrays ..
      DOUBLE PRECISION FJAC(LDFJAC,N), FVEC(N), RUSER(5), WA(LWA), X(N)
      INTEGER          IUSER(1)
*     .. External Functions ..
      DOUBLE PRECISION F06EJF, X02AJF
      EXTERNAL         F06EJF, X02AJF
*     .. External Subroutines ..
      EXTERNAL         C05PBA, FCN
*     .. Intrinsic Functions ..
      INTRINSIC        SQRT
*     .. Executable Statements ..
      WRITE (NOUT,*) 'C05PBA Example Program Results'
      WRITE (NOUT,*)
*     The following starting values provide a rough solution.
      DO 20 J = 1, N
         X(J) = -1.0D0
   20 CONTINUE
*     Store the coefficients describing the system
      RUSER(1) = -1.0D0
      RUSER(2) = 3.0D0
      RUSER(3) = -2.0D0
      RUSER(4) = -2.0D0
      RUSER(5) = -1.0D0
*
      TOL = SQRT(X02AJF())
      IFAIL = 1
*
      CALL C05PBA(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,WA,LWA,IUSER,RUSER,IFAIL)
*
      IF (IFAIL.EQ.0) THEN
         FNORM = F06EJF(N,FVEC,1)
         WRITE (NOUT,99999) 'Final 2-norm of the residuals =', FNORM
         WRITE (NOUT,*)
         WRITE (NOUT,*) 'Final approximate solution'
         WRITE (NOUT,*)
         WRITE (NOUT,99998) (X(J),J=1,N)
      ELSE IF (IFAIL.LT.0) THEN
         WRITE (NOUT,*)
         WRITE (NOUT,99997) ' ** C05PBA returned with IFAIL = ', IFAIL
      ELSE
         WRITE (NOUT,99997) 'IFAIL = ', IFAIL
         IF (IFAIL.GE.2) THEN
            WRITE (NOUT,*)
            WRITE (NOUT,*) 'Approximate solution'
            WRITE (NOUT,*)
            WRITE (NOUT,99998) (X(J),J=1,N)
         END IF
      END IF
*
99999 FORMAT (1X,A,E12.4)
99998 FORMAT (1X,3F12.4)
99997 FORMAT (1X,A,I5)
      END
*
      SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG,IUSER,RUSER)
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        (ZERO=0.0D0)
*     .. Scalar Arguments ..
      INTEGER          IFLAG, LDFJAC, N
*     .. Array Arguments ..
      DOUBLE PRECISION FJAC(LDFJAC,N), FVEC(N), RUSER(5), X(N)
      INTEGER          IUSER(1)
*     .. Local Scalars ..
      INTEGER          J, K
*     .. Executable Statements ..
      IF (IFLAG.NE.2) THEN
         DO 20 K = 1, N
            FVEC(K) = (RUSER(2)+RUSER(3)*X(K))*X(K) - RUSER(5)
            IF (K.GT.1) FVEC(K) = FVEC(K) + RUSER(1)*X(K-1)
            IF (K.LT.N) FVEC(K) = FVEC(K) + RUSER(4)*X(K+1)
   20    CONTINUE
      ELSE
         DO 60 K = 1, N
            DO 40 J = 1, N
               FJAC(K,J) = ZERO
   40       CONTINUE
            FJAC(K,K) = RUSER(2) + 2.0D0*RUSER(3)*X(K)
            IF (K.GT.1) FJAC(K,K-1) = RUSER(1)
            IF (K.LT.N) FJAC(K,K+1) = RUSER(4)
   60    CONTINUE
      END IF
      RETURN
      END