! Mark 24 Release. NAG Copyright 2012. Module d01rafe_mod ! .. Use Statements .. Use nag_library, Only: nag_wp ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Integer, Parameter :: nout = 6 Logical, Parameter :: disp_split_info = .True. Contains Subroutine d01rbf_monit(ni,ns,defint,errest,fcount,sinfoi,evals,ldi, & sinfor,fs,es,ldr,iuser,ruser) ! .. Scalar Arguments .. Integer, Intent (In) :: ldi, ldr, ni, ns ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Inout) :: defint(ni), errest(ni), ruser(*) Real (Kind=nag_wp), Intent (In) :: es(ldr,*), fs(ldr,*), & sinfor(ldr,*) Integer, Intent (In) :: evals(ldi,*), fcount(ni), & sinfoi(ldi,*) Integer, Intent (Inout) :: iuser(*) ! .. Local Scalars .. Real (Kind=nag_wp) :: lbnd, ubnd Integer :: child1, child2, j, k, level, & parent, sid ! .. Executable Statements .. Continue ! Display information on individual segments. If (.Not. disp_split_info) Then Go To 100 End If Write (nout,*) Write (nout,99993) Do k = 1, ns Write (nout,*) sid = sinfoi(1,k) parent = sinfoi(2,k) child1 = sinfoi(3,k) child2 = sinfoi(4,k) level = sinfoi(5,k) lbnd = sinfor(1,k) ubnd = sinfor(2,k) Write (nout,99999) k, sid, parent, level If (child1>0) Then Write (nout,99998) child1, child2 End If Write (nout,99997) lbnd, ubnd Do j = 1, ni If (evals(j,k)/=0) Then Write (nout,99996) j, fs(j,k) Write (nout,99995) j, es(j,k) If (evals(j,k)/=1) Then Write (nout,99994) j End If End If End Do End Do 100 Continue Return 99999 Format (' Segment ',I3,', SID = ',I3,', Parent = ',I3,', Level = ',I3, & '.') 99998 Format (' Children = (',I3,',',I3,')') 99997 Format (' Bounds (',Es11.4,',',Es11.4,')') 99996 Format (' Integral ',I2,' approximation:',1X,Es11.4,'.') 99995 Format (' Integral ',I2,' error estimate:',1X,Es11.4,'.') 99994 Format (' Integral ',I2, & ' evaluation has been superseded by descendants.') 99993 Format (' Information on splitting and evaluations over subregions. ') End Subroutine d01rbf_monit Subroutine display_option(optstr,optype,ivalue,rvalue,cvalue) ! Subroutine to query optype and print the appropriate option values ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: rvalue Integer, Intent (In) :: ivalue, optype Character (*), Intent (In) :: cvalue, optstr ! .. Executable Statements .. Select Case (optype) Case (1) Write (nout,99999) optstr, ivalue Case (2) Write (nout,99998) optstr, rvalue Case (3) Write (nout,99997) optstr, cvalue Case (4) Write (nout,99996) optstr, ivalue, cvalue Case (5) Write (nout,99995) optstr, rvalue, cvalue Case Default End Select Flush (nout) Return 99999 Format (3X,A30,' : ',I13) 99998 Format (3X,A30,' : ',Es13.4) 99997 Format (3X,A30,' : ',8X,A16) 99996 Format (3X,A30,' : ',I13,3X,A16) 99995 Format (3X,A30,' : ',Es13.4,3X,A16) End Subroutine display_option End Module d01rafe_mod Program d01rafe ! .. Use Statements .. Use nag_library, Only: d01raf, d01rbf, d01rcf, d01zkf, d01zlf, x01aaf Use d01rafe_mod, Only: d01rbf_monit, display_option, nag_wp, nout ! .. Implicit None Statement .. Implicit None ! .. Local Scalars .. Real (Kind=nag_wp) :: a, b, pi, rvalue Integer :: ifail, irevcm, ivalue, j, lcmax, & lcmin, lcomm, lcusd, ldfm, & ldfmrq, lenx, lenxrq, licmax, & licmin, licomm, licusd, ni, nx, & optype, sdfm, sdfmrq, sid Character (16) :: cvalue ! .. Local Arrays .. Real (Kind=nag_wp), Allocatable :: comm(:), defint(:), errest(:), & fm(:,:), opts(:), ruser(:), x(:) Integer, Allocatable :: icomm(:), iopts(:), iuser(:), & needi(:) ! .. Intrinsic Procedures .. Intrinsic :: cos, sin ! .. Executable Statements .. Continue Write (nout,*) 'D01RAF Example Program Results' Write (nout,*) pi = x01aaf(pi) ! Setup phase. ! set problem parameters ni = 2 ! lower (a) and upper (b) bounds a = 0.0E0_nag_wp b = pi Allocate (opts(100),iopts(100),iuser(1),ruser(1)) ! initialize option arrays ifail = 0 Call d01zkf('Initialize = d01raf',iopts,100,opts,100,ifail) ! set any non-default options required Call d01zkf('Quadrature Rule = gk41',iopts,100,opts,100,ifail) Call d01zkf('Absolute Tolerance = 1.0e-7',iopts,100,opts,100,ifail) Call d01zkf('Relative Tolerance = 1.0e-7',iopts,100,opts,100,ifail) ! determine maximum requried array lengths ifail = -1 Call d01rcf(ni,lenxrq,ldfmrq,sdfmrq,licmin,licmax,lcmin,lcmax,iopts, & opts,ifail) ldfm = ldfmrq sdfm = sdfmrq lenx = lenxrq licomm = licmax lcomm = lcmax ! Allocate remaining arrays Allocate (icomm(licomm),needi(ni),comm(lcomm),fm(ldfm,sdfm),defint(ni), & errest(ni),x(lenx)) ! Solve phase. ! Use D01RAF to evaluate the definate integrals of: ! f_1 = (x*sin(2*x))*cos(15*x) ! f_2 = (x*sin(2*x))*(x*cos(50*x)) ! set initial irevcm irevcm = 1 ifail = -1 Do While (irevcm/=0) Call d01raf(irevcm,ni,a,b,sid,needi,x,lenx,nx,fm,ldfm,defint,errest, & iopts,opts,icomm,licomm,comm,lcomm,ifail) Select Case (irevcm) Case (11) ! Initial returns. ! These will occur during the non-adaptive phase. ! All values must be supplied. ! DEFINT and ERREST do not contain approximations ! over the complete interval at this stage. ! Calculate x*sin(2*x), storing the result in fm(2,1:nx) for re-use. fm(2,1:nx) = x(1:nx)*sin(2.0E0_nag_wp*x(1:nx)) ! Calculate f1 fm(1,1:nx) = fm(2,1:nx)*cos(15.0E0_nag_wp*x(1:nx)) ! Complete f2 calculation. fm(2,1:nx) = fm(2,1:nx)*x(1:nx)*cos(50.0E0_nag_wp*x(1:nx)) Case (12) ! Intermediate returns. ! These will occur during the adaptive phase. ! All requested values must be supplied. ! DEFINT and ERREST do not contain approximations ! over the complete interval at this stage. ! ! Calculate x*sin(2*x). fm(2,1:nx) = x(1:nx)*sin(2.0E0_nag_wp*x(1:nx)) ! Calculate f1 if required. If (needi(1)==1) Then fm(1,1:nx) = fm(2,1:nx)*cos(15.0E0_nag_wp*x(1:nx)) End If ! Complete f2 calculation if required. If (needi(2)==1) Then fm(2,1:nx) = fm(2,1:nx)*x(1:nx)*cos(50.0E0_nag_wp*x(1:nx)) End If Case (0) ! Final return. Test IFAIL. Select Case (ifail) Case (0:3) ! Useful information has been returned. Case Default ! An unrecoverable error has been detected. Go To 100 End Select End Select End Do ! query some currently set options and statistics. ifail = 0 Call d01zlf('Quadrature rule',ivalue,rvalue,cvalue,optype,iopts,opts, & ifail) Call display_option('Quadrature rule',optype,ivalue,rvalue,cvalue) Call d01zlf('Maximum Subdivisions',ivalue,rvalue,cvalue,optype,iopts, & opts,ifail) Call display_option('Maximum Subdivisions',optype,ivalue,rvalue,cvalue) Call d01zlf('Extrapolation',ivalue,rvalue,cvalue,optype,iopts,opts, & ifail) Call display_option('Extrapolation',optype,ivalue,rvalue,cvalue) Call d01zlf('Extrapolation Safeguard',ivalue,rvalue,cvalue,optype,iopts, & opts,ifail) Call display_option('Extrapolation safeguard',optype,ivalue,rvalue, & cvalue) ! print solution Write (nout,99999) Do j = 1, ni Write (nout,99998) j, needi(j), defint(j), errest(j) End Do ! Investigate subdivision strategy Call d01rbf(d01rbf_monit,ni,defint,errest,icomm,licomm,licusd,comm, & lcomm,lcusd,iuser,ruser,ifail) 100 Continue 99999 Format (' Integral | NEEDI | DEFINT | ERREST ') 99998 Format (2(1X,I9),2(1X,Es12.4)) End Program d01rafe