NAG Library Manual, Mark 30.2
Interfaces:  FL   CL   CPP   AD 

NAG FL Interface Introduction
Example description
!   D03PSF Example Program Text
!   Mark 30.2 Release. NAG Copyright 2024.

    Module d03psfe_mod

!     D03PSF 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                           :: bndry1, bndry2, exact, monit1,       &
                                          monit2, nmflx1, nmflx2, pdef1,       &
                                          pdef2, uvin1, uvin2
!     .. Parameters ..
      Real (Kind=nag_wp), Parameter    :: half = 0.5_nag_wp
      Real (Kind=nag_wp), Parameter, Public :: one = 1.0_nag_wp
      Real (Kind=nag_wp), Parameter, Public :: zero = 0.0_nag_wp
      Integer, Parameter, Public       :: itrace = 0, nin = 5, nout = 6,       &
                                          npde = 1, nv = 0, nxfix = 0, nxi = 0
    Contains
      Subroutine exact(t,u,x,npts)
!       Exact solution (for comparison and b.c. purposes)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: t
        Integer, Intent (In)           :: npts
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: u(1,npts)
        Real (Kind=nag_wp), Intent (In) :: x(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: del, psi, rm, rn, s
        Integer                        :: i
!       .. Executable Statements ..
        s = 0.1_nag_wp
        del = 0.01_nag_wp
        rm = -one/del
        rn = one + s/del
        Do i = 1, npts
          psi = x(i) - t
          If (psi<s) Then
            u(1,i) = one
          Else If (psi>(del+s)) Then
            u(1,i) = zero
          Else
            u(1,i) = rm*psi + rn
          End If
        End Do
        Return
      End Subroutine exact
      Subroutine uvin1(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, tmp
        Integer                        :: i
!       .. Intrinsic Procedures ..
        Intrinsic                      :: sin
!       .. Executable Statements ..
        tmp = zero
        pi = x01aaf(tmp)
        Do i = 1, npts
          If (x(i)>0.2_nag_wp .And. x(i)<=0.4_nag_wp) Then
            tmp = pi*(5.0_nag_wp*x(i)-one)
            u(1,i) = sin(tmp)
          Else
            u(1,i) = zero
          End If
        End Do
!       There are no coupled ODEs in this problem (nv = 0):
        v(:) = 0._nag_wp
        Return
      End Subroutine uvin1
      Subroutine pdef1(npde,t,x,u,ux,nv,v,vdot,p,c,d,s,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) :: c(npde), d(npde), p(npde,npde),    &
                                          s(npde)
        Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde), v(nv), vdot(nv)
!       .. Executable Statements ..
        p(1,1) = one
        c(1) = 0.002_nag_wp
        d(1) = ux(1)
        s(1) = zero
        Return
      End Subroutine pdef1
      Subroutine bndry1(npde,npts,t,x,u,nv,v,vdot,ibnd,g,ires)

!       Zero solution at both boundaries

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: t
        Integer, Intent (In)           :: ibnd, npde, npts, nv
        Integer, Intent (Inout)        :: ires
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: g(npde)
        Real (Kind=nag_wp), Intent (In) :: u(npde,npts), v(nv), vdot(nv),      &
                                          x(npts)
!       .. Executable Statements ..
        If (ibnd==0) Then
          g(1) = u(1,1)
        Else
          g(1) = u(1,npts)
        End If
        Return
      End Subroutine bndry1
      Subroutine monit1(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)             :: h1, h2, h3
        Integer                        :: i
!       .. Intrinsic Procedures ..
        Intrinsic                      :: abs
!       .. 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 ..
          fmon(i) = abs(((u(1,i+1)-u(1,i))/h2-(u(1,i)-u(1,i-1))/h1)/h3)
        End Do
        fmon(1) = fmon(2)
        fmon(npts) = fmon(npts-1)
        Return
      End Subroutine monit1
      Subroutine nmflx1(npde,t,x,nv,v,uleft,uright,flux,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) :: flux(npde)
        Real (Kind=nag_wp), Intent (In) :: uleft(npde), uright(npde), v(nv)
!       .. Executable Statements ..
        flux(1) = uleft(1)
        Return
      End Subroutine nmflx1
      Subroutine uvin2(npde,npts,nxi,x,xi,u,nv,v)

!       .. 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)             :: t
!       .. Executable Statements ..
        t = zero
        Call exact(t,u,x,npts)
!       There are no coupled ODEs in this problem (nv = 0):
        v(:) = 0._nag_wp
        Return
      End Subroutine uvin2
      Subroutine pdef2(npde,t,x,u,ux,nv,v,vdot,p,c,d,s,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) :: c(npde), d(npde), p(npde,npde),    &
                                          s(npde)
        Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde), v(nv), vdot(nv)
!       .. Executable Statements ..
        p(1,1) = one
        c(1) = zero
        d(1) = zero
        s(1) = -100.0_nag_wp*u(1)*(u(1)-one)*(u(1)-half)
        Return
      End Subroutine pdef2
      Subroutine bndry2(npde,npts,t,x,u,nv,v,vdot,ibnd,g,ires)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: t
        Integer, Intent (In)           :: ibnd, npde, npts, nv
        Integer, Intent (Inout)        :: ires
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: g(npde)
        Real (Kind=nag_wp), Intent (In) :: u(npde,npts), v(nv), vdot(nv),      &
                                          x(npts)
!       .. Local Arrays ..
        Real (Kind=nag_wp)             :: ue(1,1)
!       .. Executable Statements ..
!       Solution known to be constant at both boundaries
        If (ibnd==0) Then
          Call exact(t,ue,x(1),1)
          g(1) = ue(1,1) - u(1,1)
        Else
          Call exact(t,ue,x(npts),1)
          g(1) = ue(1,1) - u(1,npts)
        End If
        Return
      End Subroutine bndry2
      Subroutine nmflx2(npde,t,x,nv,v,uleft,uright,flux,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) :: flux(npde)
        Real (Kind=nag_wp), Intent (In) :: uleft(npde), uright(npde), v(nv)
!       .. Executable Statements ..
        flux(1) = uleft(1)
        Return
      End Subroutine nmflx2
      Subroutine monit2(t,npts,npde,x,u,fmon)

!       .. 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) :: fmon(npts)
        Real (Kind=nag_wp), Intent (In) :: u(npde,npts), x(npts)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: h1, pi, ux, uxmax, xa, xl, xmax, xr, &
                                          xx
        Integer                        :: i
!       .. Intrinsic Procedures ..
        Intrinsic                      :: abs, cos
!       .. Executable Statements ..
        xx = zero
        pi = x01aaf(xx)
!       Locate shock ..
        uxmax = zero
        xmax = zero
        Do i = 2, npts - 1
          h1 = x(i) - x(i-1)
          ux = abs((u(1,i)-u(1,i-1))/h1)
          If (ux>uxmax) Then
            uxmax = ux
            xmax = x(i)
          End If
        End Do

!       Desired width of nonzero region of monitor function
        xa = 7.0_nag_wp/60.0_nag_wp

        xl = xmax - xa
        xr = xmax + xa
!       Assign monitor function ..
        Do i = 1, npts
          If (x(i)>xl .And. x(i)<xr) Then
            fmon(i) = one + cos(pi*(x(i)-xmax)/xa)
          Else
            fmon(i) = zero
          End If
        End Do
        Return
      End Subroutine monit2
    End Module d03psfe_mod
    Program d03psfe

!     D03PSF Example Main Program

!     .. Use Statements ..
      Use d03psfe_mod, Only: nout
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Executable Statements ..
      Write (nout,*) 'D03PSF Example Program Results'

      Call ex1

      Call ex2

    Contains
      Subroutine ex1

!       .. Use Statements ..
        Use d03psfe_mod, Only: bndry1, itrace, monit1, nin, nmflx1, npde, nv,  &
                               nxfix, nxi, one, pdef1, uvin1, zero
        Use nag_library, Only: d03pek, d03psf, d03pzf
!       .. 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, m, mlu, neqn, npts, nrmesh,  &
                                          nwkres
        Logical                        :: remesh
        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(:,:), uout(:,:,:),      &
                                          x(:), xout(:)
        Integer, Allocatable           :: isave(:)
!       .. Intrinsic Procedures ..
        Intrinsic                      :: real
!       .. Executable Statements ..
        Write (nout,*)
        Write (nout,*)
        Write (nout,*) 'Example 1'
!       Skip heading in data file
        Read (nin,*)
        Read (nin,*) npts, intpts, itype
        nwkres = npde*(3*npts+3*npde+32) + 7*npts + 3
        mlu = 3*npde - 1
        neqn = npde*npts + nv
        lenode = 11*neqn + 50
        lisave = 25 + nxfix + neqn
        lrsave = (3*mlu+1)*neqn + nwkres + lenode

        Allocate (rsave(lrsave),u(npde,npts),uout(npde,intpts,itype),x(npts),  &
          xout(intpts),isave(lisave))
        Read (nin,*) xout(1:intpts)
        Read (nin,*) itol
        Read (nin,*) norm
        Read (nin,*) atol(1), rtol(1)

!       Initialize mesh
        Do i = 1, npts
          x(i) = real(i-1,kind=nag_wp)/real(npts-1,kind=nag_wp)
        End Do

!       Set remesh parameters
        remesh = .True.
        nrmesh = 3
        dxmesh = zero
        trmesh = zero
        con = 2.0_nag_wp/real(npts-1,kind=nag_wp)
        xratio = 1.5_nag_wp
        ipminf = 0

        laopt = 'B'
        ind = 0
        itask = 1

        algopt(1:30) = zero
!       b.d.f. integration
        algopt(1) = one
        algopt(13) = 0.005_nag_wp

!       Loop over output value of t

        ts = zero
        tout = zero
        Do it = 1, 3
          tout = real(it,kind=nag_wp)*0.1_nag_wp

!         ifail: behaviour on error exit
!                =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
          ifail = 0
          Call d03psf(npde,ts,tout,pdef1,nmflx1,bndry1,uvin1,u,npts,x,nv,      &
            d03pek,nxi,xi,neqn,rtol,atol,itol,norm,laopt,algopt,remesh,nxfix,  &
            xfix,nrmesh,dxmesh,trmesh,ipminf,xratio,con,monit1,rsave,lrsave,   &
            isave,lisave,itask,itrace,ind,ifail)

          If (it==1) Then
            Write (nout,*)
            Write (nout,99998) npts, atol, rtol
          End If

          Write (nout,99999) ts
          Write (nout,99996) xout(1:intpts)
!         Interpolate at output points ..
          m = 0

          ifail = 0
          Call d03pzf(npde,m,u,npts,x,xout,intpts,itype,uout,ifail)

          Write (nout,99995) uout(1,1:intpts,1)
        End Do

        Write (nout,99997) isave(1), isave(2), isave(3), isave(5)

        Return

99999   Format (' T = ',F6.3)
99998   Format (/,'  NPTS = ',I4,' ATOL = ',E10.3,' RTOL = ',E10.3,/)
99997   Format (' Number of integration steps in time = ',I6,/,' Number ',     &
          'of function evaluations = ',I6,/,' Number of Jacobian ',            &
          'evaluations =',I6,/,' Number of iterations = ',I6)
99996   Format (1X,'X        ',7F9.4)
99995   Format (1X,'Approx U ',7F9.4,/)
      End Subroutine ex1
      Subroutine ex2

!       .. Use Statements ..
        Use d03psfe_mod, Only: bndry2, exact, itrace, monit2, nin, nmflx2,     &
                               npde, nv, nxfix, nxi, one, pdef2, uvin2, zero
        Use nag_library, Only: d03pek, d03psf, d03pzf
!       .. 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, m, mlu, neqn, npts, nrmesh,  &
                                          nwkres
        Logical                        :: remesh
        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,*)
        Write (nout,*)
        Write (nout,*) 'Example 2'
!       Skip heading in data file
        Read (nin,*)
        Read (nin,*) npts, intpts, itype
        nwkres = npde*(3*npts+3*npde+32) + 7*npts + 3
        mlu = 3*npde - 1
        neqn = npde*npts + nv
        lenode = 11*neqn + 50
        lisave = 25 + nxfix + neqn
        lrsave = (3*mlu+1)*neqn + nwkres + lenode

        Allocate (rsave(lrsave),u(neqn),ue(1,intpts),uout(1,intpts,itype),     &
          x(npts),xout(intpts),isave(lisave))

        Read (nin,*) xout(1:intpts)
        Read (nin,*) itol
        Read (nin,*) norm
        Read (nin,*) atol(1), rtol(1)

!       Initialize mesh
        Do i = 1, npts
          x(i) = real(i-1,kind=nag_wp)/real(npts-1,kind=nag_wp)
        End Do

!       Set remesh parameters
        remesh = .True.
        nrmesh = 5
        dxmesh = zero
        con = one/real(npts-1,kind=nag_wp)
        xratio = 1.5_nag_wp
        ipminf = 0

        laopt = 'B'
        ind = 0
        itask = 1

        algopt(1:30) = zero
!       Theta integration ..
        algopt(1) = 2.0_nag_wp
        algopt(6) = 2.0_nag_wp
        algopt(7) = 2.0_nag_wp
!       Max. time step ..
        algopt(13) = 2.5E-3_nag_wp

        ts = zero
        tout = zero
        Do it = 1, 2
          tout = real(it,kind=nag_wp)*0.2_nag_wp

          ifail = 0
          Call d03psf(npde,ts,tout,pdef2,nmflx2,bndry2,uvin2,u,npts,x,nv,      &
            d03pek,nxi,xi,neqn,rtol,atol,itol,norm,laopt,algopt,remesh,nxfix,  &
            xfix,nrmesh,dxmesh,trmesh,ipminf,xratio,con,monit2,rsave,lrsave,   &
            isave,lisave,itask,itrace,ind,ifail)

          If (it==1) Then
            Write (nout,*)
            Write (nout,99998) npts, atol, rtol
          End If

          Write (nout,99999) ts
          Write (nout,99996)
!         Interpolate at output points ..
          m = 0

          ifail = 0
          Call d03pzf(npde,m,u,npts,x,xout,intpts,itype,uout,ifail)

!         Check against exact solution ..
          Call exact(tout,ue,xout,intpts)
          Do i = 1, intpts
            Write (nout,99995) xout(i), uout(1,i,1), ue(1,i)
          End Do
        End Do

        Write (nout,99997) isave(1), isave(2), isave(3), isave(5)

        Return

99999   Format (' T = ',F6.3)
99998   Format (/,' NPTS = ',I4,' ATOL = ',E10.3,' RTOL = ',E10.3,/)
99997   Format (/,' Number of integration steps in time = ',I6,/,' Number ',   &
          'of function evaluations = ',I6,/,' Number of Jacobian ',            &
          'evaluations =',I6,/,' Number of iterations = ',I6)
99996   Format (8X,'X',8X,'Approx U',4X,'Exact U',/)
99995   Format (3(3X,F9.4))
      End Subroutine ex2
    End Program d03psfe