! D03PHA Example Program Text
! Mark 30.0 Release. NAG Copyright 2024.
Module d03phae_mod
! D03PHA 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, odedef, pdedef, uvinit
! .. Parameters ..
Real (Kind=nag_wp), Parameter :: one = 1.0_nag_wp
Integer, Parameter, Public :: itrace = 0, nin = 5, nout = 6, &
npde = 1, nv = 1, nxi = 1
Logical, Parameter, Public :: print_stat = .False.
Contains
Subroutine uvinit(npde,npts,x,u,nv,neqn,iuser,ruser)
! Routine for PDE initial values
! .. Scalar Arguments ..
Integer, Intent (In) :: neqn, npde, npts, nv
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Real (Kind=nag_wp), Intent (Out) :: u(neqn)
Real (Kind=nag_wp), Intent (In) :: x(npts)
Integer, Intent (Inout) :: iuser(*)
! .. Local Scalars ..
Real (Kind=nag_wp) :: ts
Integer :: i
! .. Intrinsic Procedures ..
Intrinsic :: exp
! .. Executable Statements ..
ts = ruser(1)
Do i = 1, npts
u(i) = exp(ts*(one-x(i))) - one
End Do
u(neqn) = ts
Return
End Subroutine uvinit
Subroutine odedef(npde,t,nv,v,vdot,nxi,xi,ucp,ucpx,rcp,ucpt,ucptx,f, &
ires,iuser,ruser)
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: t
Integer, Intent (Inout) :: ires
Integer, Intent (In) :: npde, nv, nxi
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: f(nv)
Real (Kind=nag_wp), Intent (In) :: rcp(npde,nxi), ucp(npde,nxi), &
ucpt(npde,nxi), ucptx(npde,nxi), &
ucpx(npde,nxi), v(nv), vdot(nv), &
xi(nxi)
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Integer, Intent (Inout) :: iuser(*)
! .. 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,nv,v,vdot,p,q,r,ires,iuser,ruser)
! .. 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) :: p(npde,npde), q(npde), r(npde)
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde), v(nv), vdot(nv)
Integer, Intent (Inout) :: iuser(*)
! .. 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,nv,v,vdot,ibnd,beta,gamma,ires,iuser, &
ruser)
! .. Scalar Arguments ..
Real (Kind=nag_wp), Intent (In) :: t
Integer, Intent (In) :: ibnd, npde, nv
Integer, Intent (Inout) :: ires
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: beta(npde), gamma(npde)
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde), v(nv), vdot(nv)
Integer, Intent (Inout) :: iuser(*)
! .. 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
End Module d03phae_mod
Program d03phae
! D03PHA Example Main Program
! .. Use Statements ..
Use d03phae_mod, Only: bndary, itrace, nin, nout, npde, nv, nxi, odedef, &
pdedef, print_stat, uvinit
Use nag_library, Only: d03pha, nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Local Scalars ..
Real (Kind=nag_wp) :: tout, ts
Integer :: i, ifail, ind, it, itask, itol, &
latol, lenode, lrtol, m, neqn, niw, &
npts, nw, nwkres
Logical :: theta
Character (1) :: laopt, norm
! .. Local Arrays ..
Real (Kind=nag_wp) :: algopt(30), ruser(1), rwsav(1100), &
xi(nxi)
Real (Kind=nag_wp), Allocatable :: atol(:), rtol(:), u(:), w(:), x(:)
Integer :: iuser(1), iwsav(505)
Integer, Allocatable :: iw(:)
Logical :: lwsav(100)
Character (80) :: cwsav(10)
! .. Intrinsic Procedures ..
Intrinsic :: mod, real
! .. Executable Statements ..
Write (nout,*) 'D03PHA Example Program Results'
! Skip heading in data file
Read (nin,*)
Read (nin,*) m, npts
neqn = npde*npts + nv
nwkres = npde*(npts+6*nxi+3*npde+15) + nv + nxi + 7*npts + 2
lenode = 11*neqn + 50
nw = neqn*neqn + neqn + nwkres + lenode
niw = 25*neqn + 24
Allocate (u(neqn),w(nw),x(npts),iw(niw))
Read (nin,*) itol
latol = 1
lrtol = 1
If (itol>2) Then
latol = neqn
End If
If (mod(itol,2)==0) Then
lrtol = neqn
End If
Allocate (atol(latol),rtol(lrtol))
Read (nin,*) atol(1:latol), rtol(1:lrtol)
ts = 1.0E-4_nag_wp
! 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
ruser(1) = ts
Call uvinit(npde,npts,x,u,nv,neqn,iuser,ruser)
Write (nout,99998)
Write (nout,99997) atol
Write (nout,99996) npts
Write (nout,99999)
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 d03pha(npde,m,ruser(1),tout,pdedef,bndary,u,npts,x,nv,odedef,nxi, &
xi,neqn,rtol,atol,itol,norm,laopt,algopt,w,nw,iw,niw,itask,itrace, &
ind,iuser,ruser,cwsav,lwsav,iwsav,rwsav,ifail)
Write (nout,99995) ruser(1), u(1)
! Select next time to solve to for output.
tout = 2.0_nag_wp*tout
End Do
! Print integration statistics (reasonably rounded)
If (print_stat) Then
Write (nout,*)
Write (nout,99994) 'time steps', iw(1)
Write (nout,99994) 'function evaluations', iw(2)
Write (nout,99994) 'Jacobian evaluations', iw(3)
Write (nout,99994) 'iterations', iw(5)
End If
99999 Format (3X,'time',8X,'solution at x=0')
99998 Format (/,/,' Simple coupled PDE using BDF')
99997 Format (' Local Accuracy = ',1P,E12.3)
99996 Format (' Number of mesh points = ',I4,/)
99995 Format (1X,F6.1,14X,F6.2)
99994 Format (' Number of ',A20,' = ',I6)
End Program d03phae