! D02UDF Example Program Text ! Mark 24 Release. NAG Copyright 2012. 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) ! .. Function Return Value .. Real (Kind=nag_wp) :: fcn ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: x ! .. Intrinsic Procedures .. Intrinsic :: exp ! .. Executable Statements .. fcn = (one+one)*x + exp(-x) Return End Function fcn Function deriv(x) ! .. Function Return Value .. Real (Kind=nag_wp) :: deriv ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: x ! .. Intrinsic Procedures .. 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, nag_wp, x02ajf Use d02udfe_mod, Only: a, b, deriv, fcn, 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 Procedures .. 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