* D02PXF Example Program Text * Mark 17 Revised. NAG Copyright 1995. * .. Parameters .. INTEGER NOUT PARAMETER (NOUT=6) INTEGER NEQ, NWANT, LENINT, LENWRK, METHOD PARAMETER (NEQ=2,NWANT=1,LENINT=NEQ+5*NWANT,LENWRK=32*NEQ, + METHOD=2) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0) * .. Local Scalars .. DOUBLE PRECISION HNEXT, HSTART, PI, TEND, TINC, TNOW, TOL, TSTART, + TWANT, WASTE INTEGER I, IFAIL, J, L, NPTS, STPCST, STPSOK, TOTF LOGICAL ERRASS * .. Local Arrays .. DOUBLE PRECISION THRES(NEQ), WORK(LENWRK), WRKINT(LENINT), + YNOW(NEQ), YPNOW(NEQ), YPWANT(NWANT), + YSTART(NEQ), YWANT(NWANT) * .. External Functions .. DOUBLE PRECISION X01AAF EXTERNAL X01AAF * .. External Subroutines .. EXTERNAL D02PDF, D02PVF, D02PXF, D02PYF, F * .. Executable Statements .. WRITE (NOUT,*) 'D02PXF Example Program Results' * * Set initial conditions and input for D02PVF * PI = X01AAF(ZERO) TSTART = ZERO YSTART(1) = ZERO YSTART(2) = ONE TEND = TWO*PI DO 20 L = 1, NEQ THRES(L) = 1.0D-8 20 CONTINUE ERRASS = .FALSE. HSTART = ZERO * * Set output control * NPTS = 16 TINC = TEND/NPTS * DO 80 I = 1, 2 IF (I.EQ.1) TOL = 1.0D-3 IF (I.EQ.2) TOL = 1.0D-4 * IFAIL = 1 CALL D02PVF(NEQ,TSTART,YSTART,TEND,TOL,THRES,METHOD, + 'Complex Task',ERRASS,HSTART,WORK,LENWRK,IFAIL) IF (IFAIL.NE.0) THEN WRITE (NOUT,99999) IFAIL GO TO 100 END IF * WRITE (NOUT,'(/A,E8.1)') ' Calculation with TOL = ', TOL WRITE (NOUT,'(/A/)') ' t y1 y1''' WRITE (NOUT,'(1X,F6.3,2(3X,F8.4))') TSTART, (YSTART(L),L=1,NEQ) * J = NPTS - 1 TWANT = TEND - J*TINC * 40 CONTINUE IFAIL = -1 CALL D02PDF(F,TNOW,YNOW,YPNOW,WORK,IFAIL) * IF (IFAIL.EQ.0) THEN 60 CONTINUE IF (TWANT.LE.TNOW) THEN IFAIL = 0 CALL D02PXF(TWANT,'Both',NWANT,YWANT,YPWANT,F,WORK, + WRKINT,LENINT,IFAIL) WRITE (NOUT,'(1X,F6.3,2(3X,F8.4))') TWANT, YWANT(1), + YPWANT(1) J = J - 1 TWANT = TEND - J*TINC GO TO 60 END IF IF (TNOW.LT.TEND) GO TO 40 END IF * IFAIL = 0 CALL D02PYF(TOTF,STPCST,WASTE,STPSOK,HNEXT,IFAIL) WRITE (NOUT,'(/A,I6)') + ' Cost of the integration in evaluations of F is', TOTF * 80 CONTINUE 100 CONTINUE * 99999 FORMAT (1X,/1X,' ** D02PVF returned with IFAIL = ',I5) END SUBROUTINE F(T,Y,YP) * .. Scalar Arguments .. DOUBLE PRECISION T * .. Array Arguments .. DOUBLE PRECISION Y(*), YP(*) * .. Executable Statements .. YP(1) = Y(2) YP(2) = -Y(1) RETURN END