! D02UDF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE d02udfe_mod ! D02UDF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. REAL (KIND=nag_wp), PARAMETER :: a = 0.0_nag_wp REAL (KIND=nag_wp), PARAMETER :: b = 1.5_nag_wp REAL (KIND=nag_wp), PARAMETER :: one = 1.0_nag_wp INTEGER, PARAMETER :: nin = 5, nout = 6 LOGICAL, PARAMETER :: reqerr = .FALSE. CONTAINS FUNCTION fcn(x) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Function Return Value .. REAL (KIND=nag_wp) :: fcn ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: x ! .. Intrinsic Functions .. INTRINSIC exp ! .. Executable Statements .. fcn = (one+one)*x + exp(-x) RETURN END FUNCTION fcn FUNCTION deriv(x) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Function Return Value .. REAL (KIND=nag_wp) :: deriv ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: x ! .. Intrinsic Functions .. INTRINSIC exp ! .. Executable Statements .. deriv = one + one - exp(-x) RETURN END FUNCTION deriv END MODULE d02udfe_mod PROGRAM d02udfe ! D02UDF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : d02ucf, d02udf, x02ajf USE d02udfe_mod, ONLY : a, b, deriv, fcn, nag_wp, nin, nout, reqerr ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. REAL (KIND=nag_wp) :: scale, teneps, uxerr INTEGER :: i, ifail, n ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: f(:), fd(:), x(:) ! .. Intrinsic Functions .. INTRINSIC abs, int, max ! .. Executable Statements .. WRITE (nout,*) ' D02UDF Example Program Results ' WRITE (nout,*) READ (nin,*) READ (nin,*) n ALLOCATE (f(n+1),fd(n+1),x(n+1)) ! Set up solution grid ifail = 0 CALL d02ucf(n,a,b,x,ifail) ! Evaluate fcn on Chebyshev grid. DO i = 1, n + 1 f(i) = fcn(x(i)) END DO ! Calculate derivative of fcn. ifail = 0 CALL d02udf(n,f,fd,ifail) scale = 2.0_nag_wp/(b-a) fd(1:n+1) = scale*fd(1:n+1) ! Print function and its derivative WRITE (nout,*) ' Original Function F and numerical derivative Fx' WRITE (nout,*) WRITE (nout,99999) WRITE (nout,99998) (x(i),f(i),fd(i),i=1,n+1) IF (reqerr) THEN uxerr = 0.0_nag_wp DO i = 1, n + 1 uxerr = max(uxerr,abs(fd(i)-deriv(x(i)))) END DO teneps = 100.0_nag_wp*x02ajf() WRITE (nout,99997) 100*(int(uxerr/teneps)+1) END IF 99999 FORMAT (1X,T8,'X',T18,'F',T28,'Fx') 99998 FORMAT (1X,3F10.4) 99997 FORMAT (1X,'Fx is within a multiple ',I8,' of machine precision.') END PROGRAM d02udfe