!   D02TVF Example Program Text
!   Mark 24 Release. NAG Copyright 2012.

    Module d02tvfe_mod

!     D02TVF 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
      Real (Kind=nag_wp), Parameter        :: two = 2.0_nag_wp
      Real (Kind=nag_wp), Parameter        :: zero = 0.0_nag_wp
      Integer, Parameter                   :: mmax = 1, neq = 6, nin = 5,      &
                                              nlbc = 3, nout = 6, nrbc = 3
!     .. Local Scalars ..
      Real (Kind=nag_wp)                   :: beta0, eta, lambda, mu
!     .. Local Arrays ..
      Integer                              :: m(neq) = (/1,1,1,1,1,1/)
    Contains
      Subroutine ffun(x,y,neq,m,f)

!       .. Use Statements ..
        Use nag_library, Only: x01aaf
!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In)      :: x
        Integer, Intent (In)                 :: neq
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out)     :: f(neq)
        Real (Kind=nag_wp), Intent (In)      :: y(neq,0:*)
        Integer, Intent (In)                 :: m(neq)
!       .. Local Scalars ..
        Real (Kind=nag_wp)                   :: beta
!       .. Intrinsic Procedures ..
        Intrinsic                            :: cos
!       .. Executable Statements ..
        beta = beta0*(one+cos(two*x01aaf(beta)*x))
        f(1) = mu - beta*y(1,0)*y(3,0)
        f(2) = beta*y(1,0)*y(3,0) - y(2,0)/lambda
        f(3) = y(2,0)/lambda - y(3,0)/eta
        f(4:6) = zero
        Return
      End Subroutine ffun
      Subroutine fjac(x,y,neq,m,dfdy)

!       .. Use Statements ..
        Use nag_library, Only: x01aaf
!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In)      :: x
        Integer, Intent (In)                 :: neq
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout)   :: dfdy(neq,neq,0:*)
        Real (Kind=nag_wp), Intent (In)      :: y(neq,0:*)
        Integer, Intent (In)                 :: m(neq)
!       .. Local Scalars ..
        Real (Kind=nag_wp)                   :: beta
!       .. Intrinsic Procedures ..
        Intrinsic                            :: cos
!       .. Executable Statements ..
        beta = beta0*(one+cos(two*x01aaf(beta)*x))
        dfdy(1,1,0) = -beta*y(3,0)
        dfdy(1,3,0) = -beta*y(1,0)
        dfdy(2,1,0) = beta*y(3,0)
        dfdy(2,2,0) = -one/lambda
        dfdy(2,3,0) = beta*y(1,0)
        dfdy(3,2,0) = one/lambda
        dfdy(3,3,0) = -one/eta
        Return
      End Subroutine fjac
      Subroutine gafun(ya,neq,m,nlbc,ga)

!       .. Scalar Arguments ..
        Integer, Intent (In)                 :: neq, nlbc
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out)     :: ga(nlbc)
        Real (Kind=nag_wp), Intent (In)      :: ya(neq,0:*)
        Integer, Intent (In)                 :: m(neq)
!       .. Executable Statements ..
        ga(1) = ya(1,0) - ya(4,0)
        ga(2) = ya(2,0) - ya(5,0)
        ga(3) = ya(3,0) - ya(6,0)
        Return
      End Subroutine gafun
      Subroutine gbfun(yb,neq,m,nrbc,gb)

!       .. Scalar Arguments ..
        Integer, Intent (In)                 :: neq, nrbc
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out)     :: gb(nrbc)
        Real (Kind=nag_wp), Intent (In)      :: yb(neq,0:*)
        Integer, Intent (In)                 :: m(neq)
!       .. Executable Statements ..
        gb(1) = yb(1,0) - yb(4,0)
        gb(2) = yb(2,0) - yb(5,0)
        gb(3) = yb(3,0) - yb(6,0)
        Return
      End Subroutine gbfun
      Subroutine gajac(ya,neq,m,nlbc,dgady)

!       .. Scalar Arguments ..
        Integer, Intent (In)                 :: neq, nlbc
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout)   :: dgady(nlbc,neq,0:*)
        Real (Kind=nag_wp), Intent (In)      :: ya(neq,0:*)
        Integer, Intent (In)                 :: m(neq)
!       .. Executable Statements ..
        dgady(1,1,0) = one
        dgady(1,4,0) = -one
        dgady(2,2,0) = one
        dgady(2,5,0) = -one
        dgady(3,3,0) = one
        dgady(3,6,0) = -one
        Return
      End Subroutine gajac
      Subroutine gbjac(yb,neq,m,nrbc,dgbdy)

!       .. Scalar Arguments ..
        Integer, Intent (In)                 :: neq, nrbc
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout)   :: dgbdy(nrbc,neq,0:*)
        Real (Kind=nag_wp), Intent (In)      :: yb(neq,0:*)
        Integer, Intent (In)                 :: m(neq)
!       .. Executable Statements ..
        dgbdy(1,1,0) = one
        dgbdy(1,4,0) = -one
        dgbdy(2,2,0) = one
        dgbdy(2,5,0) = -one
        dgbdy(3,3,0) = one
        dgbdy(3,6,0) = -one
        Return
      End Subroutine gbjac
      Subroutine guess(x,neq,m,y,dym)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In)      :: x
        Integer, Intent (In)                 :: neq
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out)     :: dym(neq)
        Real (Kind=nag_wp), Intent (Inout)   :: y(neq,0:*)
        Integer, Intent (In)                 :: m(neq)
!       .. Executable Statements ..
        y(1:3,0) = one
        y(4,0) = y(1,0)
        y(5,0) = y(2,0)
        y(6,0) = y(3,0)
        dym(1:neq) = zero
        Return
      End Subroutine guess
    End Module d02tvfe_mod
    Program d02tvfe

!     D02TVF Example Main Program

!     .. Use Statements ..
      Use nag_library, Only: d02tkf, d02tvf, d02tyf, d02tzf, nag_wp
      Use d02tvfe_mod, Only: beta0, eta, ffun, fjac, gafun, gajac, gbfun,      &
                             gbjac, guess, lambda, m, mmax, mu, neq, nin,      &
                             nlbc, nout, nrbc, one
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=nag_wp)                   :: dx, ermx
      Integer                              :: i, iermx, ifail, ijermx, liwork, &
                                              lrwork, mxmesh, ncol, nmesh
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable      :: mesh(:), rwork(:), tols(:), y(:,:)
      Integer, Allocatable                 :: ipmesh(:), iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic                            :: real
!     .. Executable Statements ..
      Write (nout,*) 'D02TVF Example Program Results'
      Write (nout,*)
!     Skip heading in data file
      Read (nin,*)
      Read (nin,*) ncol, nmesh, mxmesh
      liwork = mxmesh*(11*neq+6)
      lrwork = mxmesh*(109*neq**2+78*neq+7)
      Allocate (mesh(mxmesh),tols(neq),rwork(lrwork),y(neq,0:mmax-1), &
        ipmesh(mxmesh),iwork(liwork))

      Read (nin,*) beta0, eta, lambda, mu
      Read (nin,*) tols(1:neq)

      dx = one/real(nmesh-1,kind=nag_wp)
      mesh(1) = 0.0_nag_wp
      Do i = 2, nmesh - 1
        mesh(i) = mesh(i-1) + dx
      End Do
      mesh(nmesh) = one

      ipmesh(1) = 1
      ipmesh(2:nmesh-1) = 2
      ipmesh(nmesh) = 1

!     Initialize
      ifail = 0
      Call d02tvf(neq,m,nlbc,nrbc,ncol,tols,mxmesh,nmesh,mesh,ipmesh,rwork, &
        lrwork,iwork,liwork,ifail)

!     Solve
      ifail = -1
      Call d02tkf(ffun,fjac,gafun,gbfun,gajac,gbjac,guess,rwork,iwork,ifail)

!     Extract mesh.
      ifail = -1
      Call d02tzf(mxmesh,nmesh,mesh,ipmesh,ermx,iermx,ijermx,rwork,iwork, &
        ifail)

      If (ifail/=1) Then
!       Print mesh statistics
        Write (nout,99999) nmesh, ermx, iermx, ijermx
        Write (nout,99998)(i,ipmesh(i),mesh(i),i=1,nmesh)

!       Print solution on mesh.
        Write (nout,99997)
        Do i = 1, nmesh

          ifail = 0
          Call d02tyf(mesh(i),y,neq,mmax,rwork,iwork,ifail)
          Write (nout,99996) mesh(i), y(1:3,0)

        End Do
      End If

99999 Format (/' Used a mesh of ',I4,' points'/' Maximum error = ',E10.2, &
        '  in interval ',I4,' for component ',I4/)
99998 Format (/' Mesh points:'/4(I4,'(',I1,')',F7.4))
99997 Format (/' Computed solution at mesh points'/'    x       y1   ', &
        '      y2         y3')
99996 Format (1X,F6.3,1X,3E11.3)
    End Program d02tvfe
