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

NAG FL Interface Introduction
Example description
!   D03PCA Example Program Text
!   Mark 30.1 Release. NAG Copyright 2024.

    Module d03pcae_mod

!     D03PCA 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, pdedef, uinit
!     .. Parameters ..
      Integer, Parameter, Public       :: nin = 5, nout = 6, npde = 2
    Contains
      Subroutine pdedef(npde,t,x,u,ux,p,q,r,ires,iuser,ruser)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: t, x
        Integer, Intent (Inout)        :: ires
        Integer, Intent (In)           :: npde
!       .. 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)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: alpha
!       .. Executable Statements ..
        alpha = ruser(1)
        q(1) = 4.0_nag_wp*alpha*(u(2)+x*ux(2))
        q(2) = 0.0_nag_wp
        r(1) = x*ux(1)
        r(2) = ux(2) - u(1)*u(2)
        p(1,1:2) = 0.0_nag_wp
        p(2,1) = 0.0_nag_wp
        p(2,2) = 1.0_nag_wp - x*x
        Return
      End Subroutine pdedef
      Subroutine bndary(npde,t,u,ux,ibnd,beta,gamma,ires,iuser,ruser)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: t
        Integer, Intent (In)           :: ibnd, npde
        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)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Executable Statements ..
        If (ibnd==0) Then
          beta(1) = 0.0_nag_wp
          beta(2) = 1.0_nag_wp
          gamma(1) = u(1)
          gamma(2) = -u(1)*u(2)
        Else
          beta(1) = 1.0_nag_wp
          beta(2) = 0.0_nag_wp
          gamma(1) = -u(1)
          gamma(2) = u(2)
        End If
        Return
      End Subroutine bndary
      Subroutine uinit(u,x,npts,iuser,ruser)
!       Routine for PDE initial conditon

!       .. Scalar Arguments ..
        Integer, Intent (In)           :: npts
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
        Real (Kind=nag_wp), Intent (Out) :: u(2,npts)
        Real (Kind=nag_wp), Intent (In) :: x(npts)
        Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: alpha
        Integer                        :: i
!       .. Executable Statements ..
        alpha = ruser(1)
        Do i = 1, npts
          u(1,i) = 2.0_nag_wp*alpha*x(i)
          u(2,i) = 1.0_nag_wp
        End Do
        Return
      End Subroutine uinit
    End Module d03pcae_mod
    Program d03pcae

!     D03PCA Example Main Program

!     .. Use Statements ..
      Use d03pcae_mod, Only: bndary, nin, nout, npde, pdedef, uinit
      Use nag_library, Only: d03pca, d03pzf, nag_wp, x01aaf
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: acc, alpha, hx, pi, piby2, tout, ts
      Integer                          :: i, ifail, ind, intpts, it, itask,    &
                                          itrace, itype, m, neqn, niw, npts,   &
                                          nw, nwk
!     .. Local Arrays ..
      Real (Kind=nag_wp)               :: ruser(1), rwsav(1100)
      Real (Kind=nag_wp), Allocatable  :: u(:,:), uout(:,:,:), w(:), x(:),     &
                                          xout(:)
      Integer                          :: iuser(1), iwsav(505)
      Integer, Allocatable             :: iw(:)
      Logical                          :: lwsav(100)
      Character (80)                   :: cwsav(10)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: real, sin
!     .. Executable Statements ..
      Write (nout,*) 'D03PCA Example Program Results'
!     Skip heading in data file
      Read (nin,*)
      Read (nin,*) intpts, npts, itype
      neqn = npde*npts
      niw = neqn + 24
      nwk = (10+6*npde)*neqn
      nw = nwk + (21+3*npde)*npde + 7*npts + 54

      Allocate (u(npde,npts),uout(npde,intpts,itype),w(nw),x(npts),            &
        xout(intpts),iw(niw))

      Read (nin,*) xout(1:intpts)
      Read (nin,*) acc, alpha
      Read (nin,*) m, itrace
      ruser(1) = alpha
      ind = 0
      itask = 1

!     Set spatial mesh points

      piby2 = 0.5_nag_wp*x01aaf(pi)
      hx = piby2/real(npts-1,kind=nag_wp)
      x(1) = 0.0_nag_wp
      x(npts) = 1.0_nag_wp
      Do i = 2, npts - 1
        x(i) = sin(hx*real(i-1,kind=nag_wp))
      End Do

!     Set initial conditions

      Read (nin,*) ts, tout

!     Set the initial values

      Call uinit(u,x,npts,iuser,ruser)
      Do it = 1, 5

        tout = 10.0_nag_wp*tout

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call d03pca(npde,m,ts,tout,pdedef,bndary,u,npts,x,acc,w,nw,iw,niw,     &
          itask,itrace,ind,iuser,ruser,cwsav,lwsav,iwsav,rwsav,ifail)

        If (it==1) Then
          Write (nout,99999) acc, alpha
          Write (nout,99998) xout(1:6)
        End If

!       Interpolate at required spatial points
        ifail = 0
        Call d03pzf(npde,m,u,npts,x,xout,intpts,itype,uout,ifail)

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

!     Print integration statistics

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

99999 Format (/,/,' Accuracy requirement  = ',E12.5,/,' Parameter ALPHA =',    &
        '       ',E12.3,/)
99998 Format ('   T  /  X   ',6F8.4,/)
99997 Format (' Number of integration steps in time                   ',I4,/,  &
        ' Number of residual evaluations of resulting ODE system',I4,/,        &
        ' Number of Jacobian evaluations                        ',I4,/,        &
        ' Number of iterations of nonlinear solver              ',I4)
99996 Format (1X,F7.4,' U(1)',6F8.4)
99995 Format (9X,'U(2)',6F8.4,/)
    End Program d03pcae