! D01UAF Example Program Text ! Mark 24 Release. NAG Copyright 2012. Module d01uafe_mod ! D01UAF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. Use nag_library, Only: nag_wp ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Integer, Parameter :: i_funid = 1 Integer, Parameter :: liuser = i_funid Integer, Parameter :: lruser = 1 Contains Subroutine d01uaf_f(x,nx,fv,iflag,iuser,ruser) ! .. Implicit None Statement .. Implicit None ! .. Scalar Arguments .. Integer, Intent (Inout) :: iflag Integer, Intent (In) :: nx ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: fv(nx) Real (Kind=nag_wp), Intent (Inout) :: ruser(*) Real (Kind=nag_wp), Intent (In) :: x(nx) Integer, Intent (Inout) :: iuser(*) ! .. Intrinsic Procedures .. Intrinsic :: exp, log ! .. Executable Statements .. Select Case (iuser(i_funid)) Case (1) fv = 4.0E0_nag_wp/(1.0E0_nag_wp+x*x) Case (2) fv = 1.0E0_nag_wp/(x*x*log(x)) Case (3) fv = exp(-x)/x Case (4) fv = 1.0E0_nag_wp/x Case (5) fv = exp(-3.0E0_nag_wp*x*x-4.0E0_nag_wp*x-1.0E0_nag_wp) Case (6) fv = exp(2.0E0_nag_wp*x+2.0E0_nag_wp) Case Default iflag = -1 End Select End Subroutine d01uaf_f End Module d01uafe_mod Program d01uafe ! D01UAF Example Main Program ! .. Use Statements .. Use nag_library, Only: d01uaf, nag_wp Use d01uafe_mod, Only: d01uaf_f, i_funid, liuser, lruser ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Integer, Parameter :: nout = 6 ! .. Local Scalars .. Real (Kind=nag_wp) :: a, b, dinest Integer :: funid, i, ifail, key, nstor ! .. Local Arrays .. Real (Kind=nag_wp) :: ruser(lruser) Integer :: iuser(liuser) ! .. Executable Statements .. Write (nout,*) 'D01UAF Example Program Results' cases: Do funid = 1, 6 Write (nout,*) Select Case (funid) Case (1) Write (nout,*) 'Gauss-Legendre example' a = 0.0_nag_wp b = 1.0_nag_wp key = 0 Case (2) Write (nout,*) 'Rational Gauss example' a = 2.0_nag_wp b = 0.0_nag_wp key = -5 Case (3) Write (nout,*) 'Gauss-Laguerre example (adjusted weights)' a = 2.0_nag_wp b = 1.0_nag_wp key = -3 Case (4) Write (nout,*) 'Gauss-Laguerre example (normal weights)' a = 2.0_nag_wp b = 1.0_nag_wp key = 3 Case (5) Write (nout,*) 'Gauss-Hermite example (adjusted weights)' a = -1.0_nag_wp b = 3.0_nag_wp key = -4 Case (6) Write (nout,*) 'Gauss-Hermite example (normal weights)' a = -1.0_nag_wp b = 3.0_nag_wp key = 4 End Select iuser(i_funid) = funid Do i = 1, 6 nstor = 2**(i) ifail = -1 Call d01uaf(key,a,b,nstor,d01uaf_f,dinest,iuser,ruser,ifail) Select Case (ifail) Case (:-1) ! Error flag returned by d01uaf_f Exit cases Case (0,1) ! The definite integral has been estimated. Write (nout,99999) nstor, dinest Case Default ! Illegal parameters on entry to d01uaf Exit cases End Select End Do Write (nout,*) End Do cases 99999 Format (1X,I5,' Points Answer = ',F10.5) End Program d01uafe