! D03PHF Example Program Text ! Mark 24 Release. NAG Copyright 2012. Module d03phfe_mod ! D03PHF 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 :: one = 1.0_nag_wp Integer, Parameter :: itrace = 0, ncode = 1, nin = 5, & nout = 6, npde = 1, nxi = 1 ! .. Local Scalars .. Real (Kind=nag_wp) :: ts Contains Subroutine odedef(npde,t,ncode,v,vdot,nxi,xi,ucp,ucpx,rcp,ucpt,ucptx,f, & ires) ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: t Integer, Intent (Inout) :: ires Integer, Intent (In) :: ncode, npde, nxi ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: f(ncode) Real (Kind=nag_wp), Intent (In) :: rcp(npde,*), ucp(npde,*), & ucpt(npde,*), ucptx(npde,*), & ucpx(npde,*), v(ncode), & vdot(ncode), xi(nxi) ! .. Executable Statements .. If (ires==1) Then f(1) = vdot(1) - v(1)*ucp(1,1) - ucpx(1,1) - one - t Else If (ires==-1) Then f(1) = vdot(1) End If Return End Subroutine odedef Subroutine pdedef(npde,t,x,u,ux,ncode,v,vdot,p,q,r,ires) ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: t, x Integer, Intent (Inout) :: ires Integer, Intent (In) :: ncode, npde ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: p(npde,npde), q(npde), r(npde) Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde), v(ncode), & vdot(ncode) ! .. Executable Statements .. p(1,1) = v(1)*v(1) r(1) = ux(1) q(1) = -x*ux(1)*v(1)*vdot(1) Return End Subroutine pdedef Subroutine bndary(npde,t,u,ux,ncode,v,vdot,ibnd,beta,gamma,ires) ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: t Integer, Intent (In) :: ibnd, ncode, npde Integer, Intent (Inout) :: ires ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: beta(npde), gamma(npde) Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde), v(ncode), & vdot(ncode) ! .. Intrinsic Procedures .. Intrinsic :: exp ! .. Executable Statements .. beta(1) = one If (ibnd==0) Then gamma(1) = -v(1)*exp(t) Else gamma(1) = -v(1)*vdot(1) End If Return End Subroutine bndary Subroutine uvinit(npde,npts,x,u,ncode,neqn) ! Routine for PDE initial values ! .. Scalar Arguments .. Integer, Intent (In) :: ncode, neqn, npde, npts ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: u(neqn) Real (Kind=nag_wp), Intent (In) :: x(npts) ! .. Local Scalars .. Integer :: i ! .. Intrinsic Procedures .. Intrinsic :: exp ! .. Executable Statements .. Do i = 1, npts u(i) = exp(ts*(one-x(i))) - one End Do u(neqn) = ts Return End Subroutine uvinit Subroutine exact(time,npts,x,u) ! Exact solution (for comparison purpose) ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: time Integer, Intent (In) :: npts ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: u(npts) Real (Kind=nag_wp), Intent (In) :: x(npts) ! .. Local Scalars .. Integer :: i ! .. Intrinsic Procedures .. Intrinsic :: exp ! .. Executable Statements .. Do i = 1, npts u(i) = exp(time*(one-x(i))) - one End Do Return End Subroutine exact End Module d03phfe_mod Program d03phfe ! D03PHF Example Main Program ! .. Use Statements .. Use nag_library, Only: d03phf, nag_wp Use d03phfe_mod, Only: bndary, exact, itrace, ncode, nin, nout, npde, & nxi, odedef, pdedef, ts, uvinit ! .. Implicit None Statement .. Implicit None ! .. Local Scalars .. Real (Kind=nag_wp) :: tout Integer :: i, ifail, ind, it, itask, itol, & latol, lenode, lisave, lrsave, & lrtol, m, neqn, npts, nwkres Logical :: theta Character (1) :: laopt, norm ! .. Local Arrays .. Real (Kind=nag_wp) :: algopt(30), xi(nxi) Real (Kind=nag_wp), Allocatable :: atol(:), exy(:), rsave(:), & rtol(:), u(:), x(:) Integer, Allocatable :: isave(:) ! .. Intrinsic Procedures .. Intrinsic :: mod, real ! .. Executable Statements .. Write (nout,*) 'D03PHF Example Program Results' ! Skip heading in data file Read (nin,*) Read (nin,*) m, npts neqn = npde*npts + ncode nwkres = npde*(npts+6*nxi+3*npde+15) + ncode + nxi + 7*npts + 2 lenode = 11*neqn + 50 lrsave = neqn*neqn + neqn + nwkres + lenode lisave = 25*neqn + 24 Allocate (exy(npts),u(neqn),rsave(lrsave),x(npts),isave(lisave)) Read (nin,*) itol latol = 1 lrtol = 1 If (itol>2) latol = neqn If (mod(itol,2)==0) lrtol = neqn Allocate (atol(latol),rtol(lrtol)) Read (nin,*) atol(1:latol), rtol(1:lrtol) Read (nin,*) ts ! Set break-points Do i = 1, npts x(i) = real(i-1,kind=nag_wp)/real(npts-1,kind=nag_wp) End Do Read (nin,*) xi(1:nxi) Read (nin,*) norm, laopt ind = 0 itask = 1 ! Set theta to .TRUE. if the Theta integrator is required theta = .False. algopt(1:30) = 0.0_nag_wp If (theta) Then algopt(1) = 2.0_nag_wp End If ! Loop over output value of t Call uvinit(npde,npts,x,u,ncode,neqn) tout = 0.2_nag_wp Do it = 1, 5 ! ifail: behaviour on error exit ! =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft ifail = 0 Call d03phf(npde,m,ts,tout,pdedef,bndary,u,npts,x,ncode,odedef,nxi,xi, & neqn,rtol,atol,itol,norm,laopt,algopt,rsave,lrsave,isave,lisave, & itask,itrace,ind,ifail) If (it==1) Then Write (nout,99997) atol, npts Write (nout,99999) x(1:npts-5:4), x(npts) End If ! Print against the exact solution. Call exact(tout,npts,x,exy) Write (nout,99998) ts Write (nout,99995) u(1:npts-5:4), u(npts:neqn) Write (nout,99994) exy(1:npts-5:4), exy(npts), ts ! Select next time to solve to for output. tout = 2.0_nag_wp*tout End Do Write (nout,99996) isave(1), isave(2), isave(3), isave(5) 99999 Format (' X ',5F9.3/) 99998 Format (' T = ',F6.3) 99997 Format (//' Simple coupled PDE using BDF '/' Accuracy require', & 'ment =',E10.3,' Number of points = ',I4/) 99996 Format (' Number of integration steps in time = ',I6/' Number o', & 'f function evaluations = ',I6/' Number of Jacobian eval','uations =', & I6/' Number of iterations = ',I6) 99995 Format (1X,'App. sol. ',F7.3,4F9.3,' ODE sol. =',F8.3) 99994 Format (1X,'Exact sol. ',F7.3,4F9.3,' ODE sol. =',F8.3/) End Program d03phfe