* D02RAF Example Program Text * Mark 14 Revised. NAG Copyright 1989. * .. Parameters .. INTEGER N, MNP, IY, LWORK, LIWORK PARAMETER (N=3,MNP=40,IY=N,LWORK=MNP*(3*N*N+6*N+2) + +4*N*N+3*N,LIWORK=MNP*(2*N+1)+N) INTEGER NOUT PARAMETER (NOUT=6) * .. Local Scalars .. DOUBLE PRECISION DELEPS, TOL INTEGER I, IFAIL, IJAC, INIT, J, NP, NUMBEG, NUMMIX * .. Local Arrays .. DOUBLE PRECISION ABT(N), WORK(LWORK), X(MNP), Y(IY,MNP) INTEGER IWORK(LIWORK) * .. External Subroutines .. EXTERNAL D02RAF, FCN, G, JACEPS, JACGEP, JACOBF, JACOBG, + X04ABF * .. Executable Statements .. WRITE (NOUT,*) 'D02RAF Example Program Results' WRITE (NOUT,*) WRITE (NOUT,*) 'Calculation using analytic Jacobians' CALL X04ABF(1,NOUT) TOL = 1.0D-4 NP = 17 NUMBEG = 2 NUMMIX = 0 X(1) = 0.0D0 X(NP) = 10.0D0 INIT = 0 DELEPS = 0.1D0 IJAC = 1 * * Set IFAIL to 111 to obtain monitoring information * IFAIL = 11 * CALL D02RAF(N,MNP,NP,NUMBEG,NUMMIX,TOL,INIT,X,Y,N,ABT,FCN,G,IJAC, + JACOBF,JACOBG,DELEPS,JACEPS,JACGEP,WORK,LWORK,IWORK, + LIWORK,IFAIL) * IF (IFAIL.EQ.0 .OR. IFAIL.EQ.4) THEN IF (IFAIL.EQ.4) WRITE (NOUT,99996) + 'On exit from D02RAF IFAIL = ', IFAIL WRITE (NOUT,*) WRITE (NOUT,99999) 'Solution on final mesh of ', NP, ' points' WRITE (NOUT,*) + ' X(I) Y1(I) Y2(I) Y3(I)' WRITE (NOUT,99998) (X(J),(Y(I,J),I=1,N),J=1,NP) WRITE (NOUT,*) WRITE (NOUT,*) 'Maximum estimated error by components' WRITE (NOUT,99997) (ABT(I),I=1,N) ELSE WRITE (NOUT,99996) 'On exit from D02RAF IFAIL = ', IFAIL END IF STOP * 99999 FORMAT (1X,A,I2,A) 99998 FORMAT (1X,F10.3,3F13.4) 99997 FORMAT (11X,1P,3D13.2) 99996 FORMAT (1X,A,I3) END * SUBROUTINE FCN(X,EPS,Y,F,M) * .. Scalar Arguments .. DOUBLE PRECISION EPS, X INTEGER M * .. Array Arguments .. DOUBLE PRECISION F(M), Y(M) * .. Executable Statements .. F(1) = Y(2) F(2) = Y(3) F(3) = -Y(1)*Y(3) - 2.0D0*(1.0D0-Y(2)*Y(2))*EPS RETURN END * SUBROUTINE G(EPS,Y,Z,AL,M) * .. Scalar Arguments .. DOUBLE PRECISION EPS INTEGER M * .. Array Arguments .. DOUBLE PRECISION AL(M), Y(M), Z(M) * .. Executable Statements .. AL(1) = Y(1) AL(2) = Y(2) AL(3) = Z(2) - 1.0D0 RETURN END * SUBROUTINE JACEPS(X,EPS,Y,F,M) * .. Scalar Arguments .. DOUBLE PRECISION EPS, X INTEGER M * .. Array Arguments .. DOUBLE PRECISION F(M), Y(M) * .. Executable Statements .. F(1) = 0.0D0 F(2) = 0.0D0 F(3) = -2.0D0*(1.0D0-Y(2)*Y(2)) RETURN END * SUBROUTINE JACGEP(EPS,Y,Z,AL,M) * .. Scalar Arguments .. DOUBLE PRECISION EPS INTEGER M * .. Array Arguments .. DOUBLE PRECISION AL(M), Y(M), Z(M) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 20 I = 1, M AL(I) = 0.0D0 20 CONTINUE RETURN END * SUBROUTINE JACOBF(X,EPS,Y,F,M) * .. Scalar Arguments .. DOUBLE PRECISION EPS, X INTEGER M * .. Array Arguments .. DOUBLE PRECISION F(M,M), Y(M) * .. Local Scalars .. INTEGER I, J * .. Executable Statements .. DO 40 I = 1, M DO 20 J = 1, M F(I,J) = 0.0D0 20 CONTINUE 40 CONTINUE F(1,2) = 1.0D0 F(2,3) = 1.0D0 F(3,1) = -Y(3) F(3,2) = 4.0D0*Y(2)*EPS F(3,3) = -Y(1) RETURN END * SUBROUTINE JACOBG(EPS,Y,Z,A,B,M) * .. Scalar Arguments .. DOUBLE PRECISION EPS INTEGER M * .. Array Arguments .. DOUBLE PRECISION A(M,M), B(M,M), Y(M), Z(M) * .. Local Scalars .. INTEGER I, J * .. Executable Statements .. DO 40 I = 1, M DO 20 J = 1, M A(I,J) = 0.0D0 B(I,J) = 0.0D0 20 CONTINUE 40 CONTINUE A(1,1) = 1.0D0 A(2,2) = 1.0D0 B(3,2) = 1.0D0 RETURN END