!   F02FKF Example Program Text
!   Mark 25 Release. NAG Copyright 2014.
    Module f02fkfe_mod

!     F02FKF 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                               :: mymonit, myoption
!     .. Parameters ..
      Integer, Parameter, Public           :: nin = 5, nout = 6
    Contains
      Subroutine myoption(icomm,comm,istat,iuser,ruser)

!       .. Use Statements ..
        Use nag_library, Only: f12fdf
!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (Inout)              :: istat
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout)   :: comm(*), ruser(*)
        Integer, Intent (Inout)              :: icomm(*), iuser(*)
!       .. Local Scalars ..
        Integer                              :: ifail1
        Character (25)                       :: rec
!       .. Intrinsic Procedures ..
        Intrinsic                            :: max
!       .. Executable Statements ..
        Continue

        istat = 0

        If (iuser(1)>0) Then
          Write (rec,99999) 'Print Level=', iuser(1)
          ifail1 = 1
          Call f12fdf(rec,icomm,comm,ifail1)
          istat = max(istat,ifail1)
        End If
        If (iuser(2)>100) Then
          Write (rec,99999) 'Iteration Limit=', iuser(2)
          ifail1 = 1
          Call f12fdf(rec,icomm,comm,ifail1)
          istat = max(istat,ifail1)
        End If
        If (iuser(3)>0) Then
          ifail1 = 1
          Call f12fdf('Shifted Inverse',icomm,comm,ifail1)
          istat = max(istat,ifail1)
        End If
99999   Format (A,I5)
      End Subroutine myoption

      Subroutine mymonit(ncv,niter,nconv,w,rzest,istat,iuser,ruser)

!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (Inout)              :: istat
        Integer, Intent (In)                 :: nconv, ncv, niter
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout)   :: ruser(*)
        Real (Kind=nag_wp), Intent (In)      :: rzest(ncv), w(ncv)
        Integer, Intent (Inout)              :: iuser(*)
!       .. Local Scalars ..
        Integer                              :: i
!       .. Executable Statements ..
        Continue

        If (iuser(4)>0) Then
          If (niter==1 .And. iuser(3)>0) Then
            Write (nout,99999) ' Arnoldi basis vectors used:', ncv
            Write (nout,*) &
              ' The following Ritz values (mu) are related to the'
            Write (nout,*) &
              ' true eigenvalues (lambda) by lambda = sigma + 1/mu'
          End If
          Write (nout,*)
          Write (nout,99999) ' Iteration number ', niter
          Write (nout,99998) ' Ritz values converged so far (', nconv, &
            ') and their Ritz estimates:'
          Do i = 1, nconv
            Write (nout,99997) i, w(i), rzest(i)
          End Do
          Write (nout,*) ' Next (unconverged) Ritz value:'
          Write (nout,99996) nconv + 1, w(nconv+1)
        End If
        istat = 0
99999   Format (1X,A,I4)
99998   Format (1X,A,I4,A)
99997   Format (1X,1X,I4,1X,E13.5,1X,E13.5)
99996   Format (1X,1X,I4,1X,E13.5)
      End Subroutine mymonit
    End Module f02fkfe_mod
    Program f02fkfe

!     Example problem for F02FKF.

!     .. Use Statements ..
      Use nag_library, Only: f02fkf, nag_wp, x04abf, x04caf
      Use f02fkfe_mod, Only: mymonit, myoption, nin, nout
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=nag_wp), Parameter        :: one = 1.0_nag_wp
      Integer, Parameter                   :: iset = 1
!     .. Local Scalars ..
      Real (Kind=nag_wp)                   :: h2, sigma
      Integer                              :: i, ifail, imon, j, k, ldv, lo,   &
                                              maxit, mode, n, nconv, ncv, nev, &
                                              nnz, nx, outchn, prtlvl
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable      :: a(:), d_print(:,:), resid(:),    &
                                              v(:,:), w(:)
      Real (Kind=nag_wp)                   :: ruser(1)
      Integer, Allocatable                 :: icol(:), irow(:)
      Integer                              :: iuser(4)
!     .. Intrinsic Procedures ..
      Intrinsic                            :: real
!     .. Executable Statements ..
      Write (nout,*) 'F02FKF Example Program Results'
      Write (nout,*)

!     Skip heading in data file
      Read (nin,*)

      Read (nin,*) nx
      Read (nin,*) nev
      Read (nin,*) ncv
      Read (nin,*) sigma

!     Construct the matrix A in sparse form and store in A.
!     The main diagonal of A is full and there are two subdiagonals of A:
!     the first and the nx-th.

      n = nx*nx
      nnz = 3*n - 2*nx
      Allocate (a(nnz),irow(nnz),icol(nnz))

!     Zero out A.

      a(1:nnz) = 0.0_nag_wp

!     Main diagonal of A.
      h2 = one/real((nx+1)*(nx+1),kind=nag_wp)
      a(1:n) = 4.0_nag_wp/h2
      Do i = 1, n
        irow(i) = i
        icol(i) = i
      End Do

!     First subdiagonal of A.
      k = n
      Do i = 1, nx
        lo = (i-1)*nx
        Do j = lo + 1, lo + nx - 1
          k = k + 1
          irow(k) = j + 1
          icol(k) = j
          a(k) = -one/h2
        End Do
      End Do

!     nx-th subdiagonal
      Do i = 1, nx - 1
        lo = (i-1)*nx
        Do j = lo + 1, lo + nx
          k = k + 1
          irow(k) = j + nx
          icol(k) = j
          a(k) = -one/h2
        End Do
      End Do

!     Set some options via iuser array and routine argument OPTION.
!     iuser(1) = print level, iuser(2) = iteration limit, 
!     iuser(3)>0 means shifted-invert mode
!     iuser(4)>0 means print monitoring info

      Read (nin,*) prtlvl
      Read (nin,*) maxit
      Read (nin,*) mode
      Read (nin,*) imon
      ruser(1) = one
      iuser(1) = prtlvl
      iuser(2) = maxit
      iuser(3) = mode
      iuser(4) = imon

!     Find eigenvalues of largest magnitude and the corresponding
!     eigenvectors.

      ldv = n
      Allocate (w(ncv),v(ldv,ncv),resid(n))

      ifail = -1
      Call f02fkf(n,nnz,a,irow,icol,nev,ncv,sigma,mymonit,myoption,nconv,w,v, &
        ldv,resid,iuser,ruser,ifail)

      If (ifail/=0) Then
        Go To 100
      End If

!     Print Eigenvalues and the residual norm  ||A*x - lambda*x||.

      Allocate (d_print(nconv,2))
      d_print(1:nconv,1) = w(1:nconv)
      d_print(1:nconv,2) = resid(1:nconv)

      Write (nout,*)
      Flush (nout)

      outchn = nout
      Call x04abf(iset,outchn)

      ifail = 0
      Call x04caf('G','N',nconv,2,d_print,nconv,' Ritz values and residuals', &
        ifail)

100   Continue
    End Program f02fkfe