! D02QFF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE d02qffe_mod ! D02QFF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: neqf = 2, neqg = 2, nin = 5, & nout = 6 INTEGER, PARAMETER :: latol = neqf INTEGER, PARAMETER :: liwork = 21 + 4*neqg INTEGER, PARAMETER :: lrtol = neqf INTEGER, PARAMETER :: lrwork = 23 + 23*neqf + 14*neqg CONTAINS SUBROUTINE fcn(neqf,x,y,f) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: x INTEGER, INTENT (IN) :: neqf ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: f(neqf) REAL (KIND=nag_wp), INTENT (IN) :: y(neqf) ! .. Executable Statements .. f(1) = y(2) f(2) = -y(1) RETURN END SUBROUTINE fcn FUNCTION g(neqf,x,y,yp,k) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Function Return Value .. REAL (KIND=nag_wp) :: g ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: x INTEGER, INTENT (IN) :: k, neqf ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: y(neqf), yp(neqf) ! .. Executable Statements .. IF (k==1) THEN g = yp(1) ELSE g = y(1) END IF RETURN END FUNCTION g END MODULE d02qffe_mod PROGRAM d02qffe ! D02QFF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : d02qff, d02qwf, d02qxf, d02qyf USE d02qffe_mod, ONLY : fcn, g, latol, liwork, lrtol, lrwork, nag_wp, & neqf, neqg, nin, nout ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. REAL (KIND=nag_wp) :: hlast, hmax, hnext, t, tcrit, & tcurr, tolfac, tout, tstart INTEGER :: badcmp, i, ifail, index, maxstp, & nfail, nsucc, odlast, odnext, type LOGICAL :: alterg, crit, onestp, root, & sophst, vectol CHARACTER (1) :: statef ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: atol(:), resids(:), rtol(:), & rwork(:), y(:), yp(:) INTEGER, ALLOCATABLE :: events(:), iwork(:) ! .. Executable Statements .. WRITE (nout,*) 'D02QFF Example Program Results' ! Skip heading in data file READ (nin,*) ALLOCATE (atol(latol),resids(neqg),rtol(lrtol),rwork(lrwork),y(neqf), & yp(neqf),events(neqg),iwork(liwork)) READ (nin,*) hmax, tstart, tcrit READ (nin,*) statef READ (nin,*) vectol, onestp, crit, sophst READ (nin,*) maxstp READ (nin,*) rtol(1:neqf) READ (nin,*) atol(1:neqf) ! Initialize ifail = 0 CALL d02qwf(statef,neqf,vectol,atol,latol,rtol,lrtol,onestp,crit,tcrit, & hmax,maxstp,neqg,alterg,sophst,rwork,lrwork,iwork,liwork,ifail) t = tstart tout = tcrit READ (nin,*) y(1:neqf) ! Cycle through roots and print info when encountered. FINDR: DO ifail = -1 CALL d02qff(fcn,neqf,t,y,tout,g,neqg,root,rwork,lrwork,iwork,liwork, & ifail) IF (ifail/=0) EXIT FINDR ifail = 0 CALL d02qxf(neqf,yp,tcurr,hlast,hnext,odlast,odnext,nsucc,nfail, & tolfac,badcmp,rwork,lrwork,iwork,liwork,ifail) IF ( .NOT. root) EXIT FINDR ifail = 0 CALL d02qyf(neqg,index,type,events,resids,rwork,lrwork,iwork,liwork, & ifail) WRITE (nout,99999) t WRITE (nout,99998) index, type, resids(index) WRITE (nout,99997) y(1), yp(1) DO i = 1, neqg IF (i/=index) THEN IF (events(i)/=0) THEN WRITE (nout,99996) i, events(i), resids(i) END IF END IF END DO IF (tcurr>=tout) EXIT FINDR END DO FINDR 99999 FORMAT (/1X,'Root at ',1P,E13.5) 99998 FORMAT (1X,'for event equation ',I2,' with type',I3,' and residual ', & 1P,E13.5) 99997 FORMAT (1X,' Y(1) = ',1P,E13.5,' Y''(1) = ',1P,E13.5) 99996 FORMAT (1X,'and also for event equation ',I2,' with type',I3, & ' and residual ',1P,E13.5) END PROGRAM d02qffe