*     D02HBF Example Program Text
*     Mark 14 Revised. NAG Copyright 1989.
*     .. Parameters ..
      INTEGER          NOUT
      PARAMETER        (NOUT=6)
*     .. External Subroutines ..
      EXTERNAL         EX1, EX2
*     .. Executable Statements ..
      WRITE (NOUT,*) 'D02HBF Example Program Results'
      CALL EX1
      CALL EX2
      END
*
      SUBROUTINE EX1
*     .. Parameters ..
      INTEGER          NOUT
      PARAMETER        (NOUT=6)
      INTEGER          N, N1, SDW, M1
      PARAMETER        (N=2,N1=2,SDW=3*N+14+11,M1=6)
*     .. Local Scalars ..
      DOUBLE PRECISION H, X, X1
      INTEGER          I, IFAIL, J, OUTCHN
*     .. Local Arrays ..
      DOUBLE PRECISION E(N), P(N1), PE(N1), SOLN(N,M1), W(N,SDW)
*     .. External Subroutines ..
      EXTERNAL         AUX1, BCAUX1, D02HBF, RNAUX1, X04ABF
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE
*     .. Executable Statements ..
      WRITE (NOUT,*)
      OUTCHN = NOUT
      WRITE (NOUT,*)
      CALL X04ABF(1,OUTCHN)
      P(1) = 0.2D0
      P(2) = 0.0D0
      PE(1) = 1.0D-5
      PE(2) = 1.0D-3
      E(1) = 1.0D-4
      E(2) = 1.0D-4
*     * Set IFAIL to 111 to obtain monitoring information *
      IFAIL = 1
*
      CALL D02HBF(P,N1,PE,E,N,SOLN,M1,AUX1,BCAUX1,RNAUX1,W,SDW,IFAIL)
*
      IF (IFAIL.GE.0) THEN
         WRITE (NOUT,*) 'Case 1'
         WRITE (NOUT,*)
         IF (IFAIL.NE.0) THEN
            WRITE (NOUT,99999) 'IFAIL = ', IFAIL
            IF (IFAIL.LE.5 .AND. IFAIL.NE.1) THEN
               WRITE (NOUT,*)
               WRITE (NOUT,99996) 'W(1,2) = ', W(1,2), ' W(.,1) = ',
     +           (W(I,1),I=1,N)
            END IF
         ELSE
            WRITE (NOUT,*) 'Final parameters'
            WRITE (NOUT,99998) (P(I),I=1,N1)
            WRITE (NOUT,*)
            WRITE (NOUT,*) 'Final solution'
            WRITE (NOUT,*) 'X-value     Components of solution'
            CALL RNAUX1(X,X1,P)
            H = (X1-X)/DBLE(M1-1)
            DO 20 I = 1, M1
               WRITE (NOUT,99997) X + (I-1)*H, (SOLN(J,I),J=1,N)
   20       CONTINUE
         END IF
      ELSE
         WRITE (NOUT,99995) IFAIL
      END IF
      RETURN
*
99999 FORMAT (1X,A,I3)
99998 FORMAT (1X,1P,3E15.3)
99997 FORMAT (1X,F7.2,2F13.4)
99996 FORMAT (1X,A,F9.4,A,10E10.3)
99995 FORMAT (1X,/1X,' ** D02HBF returned with IFAIL = ',I5)
      END
*
      SUBROUTINE AUX1(X,Y,F,PARAM)
*     .. Parameters ..
      INTEGER          N
      PARAMETER        (N=2)
*     .. Scalar Arguments ..
      DOUBLE PRECISION X
*     .. Array Arguments ..
      DOUBLE PRECISION F(N), PARAM(N), Y(N)
*     .. Executable Statements ..
      F(1) = Y(2)
      F(2) = (Y(1)**3-Y(2))/(2.0D0*X)
      RETURN
      END
*
      SUBROUTINE RNAUX1(X,X1,PARAM)
*     .. Scalar Arguments ..
      DOUBLE PRECISION X, X1
*     .. Array Arguments ..
      DOUBLE PRECISION PARAM(2)
*     .. Executable Statements ..
      X = 0.1D0
      X1 = 16.0D0
      RETURN
      END
*
      SUBROUTINE BCAUX1(G,G1,PARAM)
*     .. Parameters ..
      INTEGER          N
      PARAMETER        (N=2)
*     .. Array Arguments ..
      DOUBLE PRECISION G(N), G1(N), PARAM(N)
*     .. Local Scalars ..
      DOUBLE PRECISION Z
*     .. Intrinsic Functions ..
      INTRINSIC        SQRT
*     .. Executable Statements ..
      Z = 0.1D0
      G(1) = 0.1D0 + PARAM(1)*SQRT(Z)*0.1D0 + 0.01D0*Z
      G(2) = PARAM(1)*0.05D0/SQRT(Z) + 0.01D0
      G1(1) = 1.0D0/6.0D0
      G1(2) = PARAM(2)
      RETURN
      END
*
      SUBROUTINE EX2
*     .. Parameters ..
      INTEGER          NOUT
      PARAMETER        (NOUT=6)
      INTEGER          N, N1, SDW, M1
      PARAMETER        (N=3,N1=3,SDW=3*N+14+11,M1=6)
*     .. Local Scalars ..
      DOUBLE PRECISION H, X, X1
      INTEGER          I, IFAIL, J, OUTCHN
*     .. Local Arrays ..
      DOUBLE PRECISION E(N), P(N1), PE(N1), SOLN(N,M1), W(N,SDW)
*     .. External Subroutines ..
      EXTERNAL         AUX2, BCAUX2, D02HBF, RNAUX2, X04ABF
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE
*     .. Executable Statements ..
      WRITE (NOUT,*)
      OUTCHN = NOUT
      WRITE (NOUT,*)
      CALL X04ABF(1,OUTCHN)
      P(1) = 32.0D0
      P(2) = 6000.0D0
      P(3) = 0.54D0
      PE(1) = 1.0D-5
      PE(2) = 1.0D-4
      PE(3) = 1.0D-4
      E(1) = 1.0D-2
      E(2) = 1.0D-2
      E(3) = 1.0D-2
*     * Set IFAIL to 111 to obtain monitoring information *
      IFAIL = 1
*
      CALL D02HBF(P,N1,PE,E,N,SOLN,M1,AUX2,BCAUX2,RNAUX2,W,SDW,IFAIL)
*
      IF (IFAIL.LT.0) GO TO 40
      WRITE (NOUT,*) 'Case 2'
      WRITE (NOUT,*)
      IF (IFAIL.NE.0) THEN
         WRITE (NOUT,99999) 'IFAIL = ', IFAIL
         IF (IFAIL.LE.5 .AND. IFAIL.NE.1) THEN
            WRITE (NOUT,*)
            WRITE (NOUT,99996) 'W(1,2) = ', W(1,2), ' W(.,1) = ',
     +        (W(I,1),I=1,N)
         END IF
      ELSE
         WRITE (NOUT,*) 'Final parameters'
         WRITE (NOUT,99998) (P(I),I=1,N1)
         WRITE (NOUT,*)
         WRITE (NOUT,*) 'Final solution'
         WRITE (NOUT,*) 'X-value     Components of solution'
         CALL RNAUX2(X,X1,P)
         H = (X1-X)/DBLE(M1-1)
         DO 20 I = 1, M1
            WRITE (NOUT,99997) X + (I-1)*H, (SOLN(J,I),J=1,N)
   20    CONTINUE
      END IF
   40 CONTINUE
      RETURN
*
99999 FORMAT (1X,A,I3)
99998 FORMAT (1X,1P,3E15.3)
99997 FORMAT (1X,F7.0,2F13.1,F13.3)
99996 FORMAT (1X,A,F9.4,A,10E10.3)
      END
*
      SUBROUTINE AUX2(X,Y,F,PARAM)
*     .. Parameters ..
      INTEGER          N
      PARAMETER        (N=3)
*     .. Scalar Arguments ..
      DOUBLE PRECISION X
*     .. Array Arguments ..
      DOUBLE PRECISION F(N), PARAM(N), Y(N)
*     .. Intrinsic Functions ..
      INTRINSIC        COS, TAN
*     .. Executable Statements ..
      F(1) = TAN(Y(3))
      F(2) = -PARAM(1)*TAN(Y(3))/Y(2) - 0.00002D0*Y(2)/COS(Y(3))
      F(3) = -PARAM(1)/Y(2)**2
      RETURN
      END
*
      SUBROUTINE RNAUX2(X,X1,PARAM)
*     .. Parameters ..
      INTEGER          N
      PARAMETER        (N=3)
*     .. Scalar Arguments ..
      DOUBLE PRECISION X, X1
*     .. Array Arguments ..
      DOUBLE PRECISION PARAM(N)
*     .. Executable Statements ..
      X = 0.0D0
      X1 = PARAM(2)
      RETURN
      END
*
      SUBROUTINE BCAUX2(G,G1,PARAM)
*     .. Parameters ..
      INTEGER          N
      PARAMETER        (N=3)
*     .. Array Arguments ..
      DOUBLE PRECISION G(N), G1(N), PARAM(N)
*     .. Executable Statements ..
      G(1) = 0.0D0
      G(2) = 500.0D0
      G(3) = 0.5D0
      G1(1) = 0.0D0
      G1(2) = 450.0D0
      G1(3) = PARAM(3)
      RETURN
      END