! D03PRF Example Program Text
! Mark 30.1 Release. NAG Copyright 2024.
Module d03prfe_mod
! D03PRF Example Program Module:
! Parameters and User-defined Routines
! .. Use Statements ..
Use nag_library, Only: nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Accessibility Statements ..
Private
Public :: bndary, exact, monitf, pdedef, &
uvinit
! .. Parameters ..
Real (Kind=nag_wp), Parameter :: half = 0.5_nag_wp
Real (Kind=nag_wp), Parameter :: two = 2.0_nag_wp
Integer, Parameter, Public :: itrace = 0, nin = 5, nleft = 1, &
nout = 6, npde = 2, nv = 0, &
nxfix = 0, nxi = 0
Contains
Subroutine uvinit(npde,npts,nxi,x,xi,u,nv,v)
! .. Use Statements ..
Use nag_library, Only: x01aaf
! .. Scalar Arguments ..
Integer, Intent (In) :: npde, npts, nv, nxi
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: u(npde,npts), v(nv)
Real (Kind=nag_wp), Intent (In) :: x(npts), xi(nxi)
! .. Local Scalars ..
Real (Kind=nag_wp) :: pi
Integer :: i
! .. Intrinsic Procedures ..
Intrinsic :: exp, sin
! .. Executable Statements ..
pi = x01aaf(pi)
Do i = 1, npts
u(1,i) = exp(x(i))
u(2,i) = x(i)**2 + sin(two*pi*x(i)**2)
End Do
! There are no coupled ODEs in this problem (nv = 0):
v(:) = 0._nag_wp
Return
End Subroutine uvinit
Subroutine pdedef(npde,t,x,u,udot,ux,nv,v,vdot,res,ires)
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: t, x
Integer, Intent (Inout) :: ires
Integer, Intent (In) :: npde, nv
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: res(npde)
Real (Kind=nag_wp), Intent (In) :: u(npde), udot(npde), ux(npde), &
v(nv), vdot(nv)
! .. Executable Statements ..
If (ires==-1) Then
res(1) = udot(1)
res(2) = udot(2)
Else
res(1) = udot(1) + ux(1) + ux(2)
res(2) = udot(2) + 4.0_nag_wp*ux(1) + ux(2)
End If
Return
End Subroutine pdedef
Subroutine bndary(npde,t,ibnd,nobc,u,udot,nv,v,vdot,res,ires)
! .. Use Statements ..
Use nag_library, Only: x01aaf
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: t
Integer, Intent (In) :: ibnd, nobc, npde, nv
Integer, Intent (Inout) :: ires
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: res(nobc)
Real (Kind=nag_wp), Intent (In) :: u(npde), udot(npde), v(nv), &
vdot(nv)
! .. Local Scalars ..
Real (Kind=nag_wp) :: pp, ppt1, ppt3, t1, t3
! .. Intrinsic Procedures ..
Intrinsic :: exp, sin
! .. Executable Statements ..
If (ires==-1) Then
res(1) = 0.0_nag_wp
Else
pp = two*x01aaf(pp)
t1 = t
t3 = -3.0_nag_wp*t
If (ibnd==0) Then
ppt3 = sin(pp*t3**2)
ppt1 = sin(pp*t1**2)
res(1) = u(1) - half*(exp(t3)+exp(t1)+half*(ppt3-ppt1))
res(1) = res(1) - 2.0_nag_wp*t**2
Else
t3 = t3 + 1.0_nag_wp
t1 = t1 + 1.0_nag_wp
ppt3 = sin(pp*t3**2)
ppt1 = sin(pp*t1**2)
res(1) = u(2) - (exp(t3)-exp(t1)+half*(ppt3+ppt1))
res(1) = res(1) - (1.0_nag_wp+5.0_nag_wp*t**2-2.0_nag_wp*t)
End If
End If
Return
End Subroutine bndary
Subroutine monitf(t,npts,npde,x,u,fmon)
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: t
Integer, Intent (In) :: npde, npts
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: fmon(npts)
Real (Kind=nag_wp), Intent (In) :: u(npde,npts), x(npts)
! .. Local Scalars ..
Real (Kind=nag_wp) :: d2x1, d2x2, h1, h2, h3
Integer :: i
! .. Intrinsic Procedures ..
Intrinsic :: abs, max
! .. Executable Statements ..
Do i = 2, npts - 1
h1 = x(i) - x(i-1)
h2 = x(i+1) - x(i)
h3 = half*(x(i+1)-x(i-1))
! Second derivatives ..
d2x1 = abs(((u(1,i+1)-u(1,i))/h2-(u(1,i)-u(1,i-1))/h1)/h3)
d2x2 = abs(((u(2,i+1)-u(2,i))/h2-(u(2,i)-u(2,i-1))/h1)/h3)
fmon(i) = max(d2x1,d2x2)
End Do
fmon(1) = fmon(2)
fmon(npts) = fmon(npts-1)
Return
End Subroutine monitf
Subroutine exact(t,npde,npts,x,u)
! Exact solution (for comparison purposes)
! .. Use Statements ..
Use nag_library, Only: x01aaf
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: t
Integer, Intent (In) :: npde, npts
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: u(npde,npts)
Real (Kind=nag_wp), Intent (In) :: x(npts)
! .. Local Scalars ..
Real (Kind=nag_wp) :: pp, ppt1, ppt3, x1, x3
Integer :: i
! .. Intrinsic Procedures ..
Intrinsic :: exp, sin
! .. Executable Statements ..
pp = 2.0_nag_wp*x01aaf(pp)
Do i = 1, npts
x1 = x(i) + t
x3 = x(i) - 3.0_nag_wp*t
ppt3 = sin(pp*x3**2)
ppt1 = sin(pp*x1**2)
u(1,i) = half*(exp(x3)+exp(x1)+half*(ppt3-ppt1)) - two*x(i)*t + &
two*t**2
u(2,i) = (exp(x3)-exp(x1)+half*(ppt3+ppt1)) - two*x(i)*t + x(i)**2 + &
5.0_nag_wp*t**2
End Do
Return
End Subroutine exact
End Module d03prfe_mod
Program d03prfe
! D03PRF Example Main Program
! .. Use Statements ..
Use d03prfe_mod, Only: bndary, exact, itrace, monitf, nin, nleft, nout, &
npde, nv, nxfix, nxi, pdedef, uvinit
Use nag_library, Only: d03pek, d03prf, d03pzf, nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Local Scalars ..
Real (Kind=nag_wp) :: con, dxmesh, tout, trmesh, ts, &
xratio
Integer :: i, ifail, ind, intpts, ipminf, it, &
itask, itol, itype, lenode, lisave, &
lrsave, neqn, npts, nrmesh, nwkres
Logical :: remesh, theta
Character (1) :: laopt, norm
! .. Local Arrays ..
Real (Kind=nag_wp) :: algopt(30), atol(1), rtol(1), &
xfix(nxfix), xi(nxi)
Real (Kind=nag_wp), Allocatable :: rsave(:), u(:), ue(:,:), &
uout(:,:,:), x(:), xout(:)
Integer, Allocatable :: isave(:)
! .. Intrinsic Procedures ..
Intrinsic :: real
! .. Executable Statements ..
Write (nout,*) 'D03PRF Example Program Results'
! Skip heading in data file
Read (nin,*)
Read (nin,*) npts, intpts, itype
lisave = 25 + nxfix
neqn = npde*npts + nv
nwkres = npde*(npts+21+3*npde) + 7*npts + nxfix + 3
lenode = 11*neqn + 50
lrsave = neqn*neqn + neqn + nwkres + lenode
Allocate (rsave(lrsave),u(npde*npts+nv),ue(npde,npts), &
uout(npde,intpts,itype),x(npts),xout(intpts),isave(lisave))
Read (nin,*) itol
Read (nin,*) atol(1), rtol(1)
! Set remesh parameters
remesh = .True.
nrmesh = 3
dxmesh = 0.0_nag_wp
con = 5.0_nag_wp/real(npts-1,kind=nag_wp)
xratio = 1.2_nag_wp
ipminf = 0
! Initialize mesh
Do i = 1, npts
x(i) = real(i-1,kind=nag_wp)/real(npts-1,kind=nag_wp)
End Do
Read (nin,*) xout(1:intpts)
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
algopt(6) = 2.0_nag_wp
algopt(7) = 1.0_nag_wp
End If
! Loop over output value of t
ts = 0.0_nag_wp
tout = 0.0_nag_wp
Do it = 1, 5
tout = 0.05_nag_wp*real(it,kind=nag_wp)
! ifail: behaviour on error exit
! =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
ifail = 0
Call d03prf(npde,ts,tout,pdedef,bndary,uvinit,u,npts,x,nleft,nv, &
d03pek,nxi,xi,neqn,rtol,atol,itol,norm,laopt,algopt,remesh,nxfix, &
xfix,nrmesh,dxmesh,trmesh,ipminf,xratio,con,monitf,rsave,lrsave, &
isave,lisave,itask,itrace,ind,ifail)
If (it==1) Then
Write (nout,99996) atol, npts
Write (nout,99999) nrmesh
Write (nout,99998) xout(1:intpts)
End If
! Interpolate at output points ..
ifail = 0
Call d03pzf(npde,0,u,npts,x,xout,intpts,itype,uout,ifail)
! Check against exact solution ..
Call exact(ts,npde,intpts,xout,ue)
Write (nout,99997) ts
Write (nout,99994) uout(1,1:intpts,1)
Write (nout,99993) ue(1,1:intpts)
Write (nout,99992) uout(2,1:intpts,1)
Write (nout,99991) ue(2,1:intpts)
End Do
Write (nout,99995) isave(1), isave(2), isave(3), isave(5)
99999 Format (' Remeshing every ',I3,' time steps',/)
99998 Format (' X ',5F10.4,/)
99997 Format (' T = ',F6.3)
99996 Format (/,/,' Accuracy requirement =',E10.3,' Number of points = ',I3, &
/)
99995 Format (' Number of integration steps in time = ',I6,/,' Number o', &
'f function evaluations = ',I6,/,' Number of Jacobian eval', &
'uations =',I6,/,' Number of iterations = ',I6)
99994 Format (' Approx U1',5F10.4)
99993 Format (' Exact U1',5F10.4)
99992 Format (' Approx U2',5F10.4)
99991 Format (' Exact U2',5F10.4,/)
End Program d03prfe