!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SLEPc - Scalable Library for Eigenvalue Problem Computations
!  Copyright (c) 2002-, Universitat Politecnica de Valencia, Spain
!
!  This file is part of SLEPc.
!  SLEPc is distributed under a 2-clause BSD license (see LICENSE).
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!  Program usage: mpiexec -n <np> ./ex23f [-help] [-t <t>] [-m <m>] [SLEPc opts]
!
!  Description: Computes exp(t*A)*v for a matrix from a Markov model.
!  This is the Fortran90 equivalent to ex23.c
!
!  The command line options are:
!    -t <t>, where <t> = time parameter (multiplies the matrix)
!    -m <m>, where <m> = number of grid subdivisions in each dimension
!
! ----------------------------------------------------------------------
!
#include <slepc/finclude/slepcmfn.h>
program ex23f
  use slepcmfn
  implicit none

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Declarations
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  Mat                :: A      ! problem matrix
  MFN                :: mfn    ! matrix function solver context
  FN                 :: f
  PetscReal          :: tol, norm, cst, pd, pu
  PetscScalar        :: t, z
  Vec                :: v, y
  PetscInt           :: N, m, ncv, maxit, its, ii, jj
  PetscInt           :: i, j, jmax, ix, Istart, Iend
  PetscMPIInt        :: rank
  PetscErrorCode     :: ierr
  PetscBool          :: flg
  MFNConvergedReason :: reason
  PetscScalar, parameter :: one = 1.0

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Beginning of program
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  PetscCallA(SlepcInitialize(PETSC_NULL_CHARACTER, ierr))
  PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr))
  m = 15
  PetscCallA(PetscOptionsGetInt(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-m', m, flg, ierr))
  t = 2.0
  PetscCallA(PetscOptionsGetScalar(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-t', t, flg, ierr))
  N = m*(m + 1)/2
  if (rank == 0) then
    write (*, '(/a,i6,a,i4,a)') 'Markov y=exp(t*A)*e_1, N=', N, ' (m=', m, ')'
  end if

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Compute the transition probability matrix, A
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  PetscCallA(MatCreate(PETSC_COMM_WORLD, A, ierr))
  PetscCallA(MatSetSizes(A, PETSC_DECIDE, PETSC_DECIDE, N, N, ierr))
  PetscCallA(MatSetFromOptions(A, ierr))
  PetscCallA(MatGetOwnershipRange(A, Istart, Iend, ierr))
  ix = 0
  cst = 0.5/real(m - 1, PETSC_REAL_KIND)
  do i = 1, m
    jmax = m - i + 1
    do j = 1, jmax
      ix = ix + 1
      ii = ix - 1
      if (ix - 1 >= Istart .and. ix <= Iend) then
        if (j /= jmax) then
          pd = cst*(i + j - 1)
          !** north
          if (i == 1) then
            z = 2.0*pd
          else
            z = pd
          end if
          PetscCallA(MatSetValue(A, ii, ix, z, INSERT_VALUES, ierr))
          !** east
          if (j == 1) then
            z = 2.0*pd
          else
            z = pd
          end if
          jj = ix + jmax - 1
          PetscCallA(MatSetValue(A, ii, jj, z, INSERT_VALUES, ierr))
        end if

        !** south
        pu = 0.5 - cst*(i + j - 3)
        z = pu
        if (j > 1) then
          jj = ix - 2
          PetscCallA(MatSetValue(A, ii, jj, z, INSERT_VALUES, ierr))
        end if
        !** west
        if (i > 1) then
          jj = ix - jmax - 2
          PetscCallA(MatSetValue(A, ii, jj, z, INSERT_VALUES, ierr))
        end if
      end if
    end do
  end do
  PetscCallA(MatAssemblyBegin(A, MAT_FINAL_ASSEMBLY, ierr))
  PetscCallA(MatAssemblyEnd(A, MAT_FINAL_ASSEMBLY, ierr))

! ** Set v = e_1
  PetscCallA(MatCreateVecs(A, y, v, ierr))
  ii = 0
  z = 1.0
  PetscCallA(VecSetValue(v, ii, z, INSERT_VALUES, ierr))
  PetscCallA(VecAssemblyBegin(v, ierr))
  PetscCallA(VecAssemblyEnd(v, ierr))

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Create the solver and set various options
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

! ** Create matrix function solver context
  PetscCallA(MFNCreate(PETSC_COMM_WORLD, mfn, ierr))

! ** Set operator matrix, the function to compute, and other options
  PetscCallA(MFNSetOperator(mfn, A, ierr))
  PetscCallA(MFNGetFN(mfn, f, ierr))
  PetscCallA(FNSetType(f, FNEXP, ierr))
  PetscCallA(FNSetScale(f, t, one, ierr))
  tol = 0.0000001
  PetscCallA(MFNSetTolerances(mfn, tol, PETSC_CURRENT_INTEGER, ierr))

! ** Set solver parameters at runtime
  PetscCallA(MFNSetFromOptions(mfn, ierr))

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Solve the problem, y=exp(t*A)*v
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  PetscCallA(MFNSolve(mfn, v, y, ierr))
  PetscCallA(MFNGetConvergedReason(mfn, reason, ierr))
  PetscCheckA(reason%v >= 0, PETSC_COMM_WORLD, PETSC_ERR_NOT_CONVERGED, 'Solver did not converge')
  PetscCallA(VecNorm(y, NORM_2, norm, ierr))

! ** Optional: Get some information from the solver and display it
  PetscCallA(MFNGetIterationNumber(mfn, its, ierr))
  if (rank == 0) then
    write (*, '(a,i4)') ' Number of iterations of the method: ', its
  end if
  PetscCallA(MFNGetDimensions(mfn, ncv, ierr))
  if (rank == 0) then
    write (*, '(a,i4)') ' Subspace dimension:', ncv
  end if
  PetscCallA(MFNGetTolerances(mfn, tol, maxit, ierr))
  if (rank == 0) then
    write (*, '(a,f10.7,a,i4)') ' Stopping condition: tol=', tol, ' maxit=', maxit
  end if

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Display solution and clean up
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  if (rank == 0) then
    write (*, '(a,f4.1,a,f8.5)') ' Computed vector at time t=', PetscRealPart(t), ' has norm ', norm
  end if

  PetscCallA(MFNDestroy(mfn, ierr))
  PetscCallA(MatDestroy(A, ierr))
  PetscCallA(VecDestroy(v, ierr))
  PetscCallA(VecDestroy(y, ierr))
  PetscCallA(SlepcFinalize(ierr))
end program ex23f

!/*TEST
!
!   test:
!      suffix: 1
!      args: -mfn_ncv 6
!
!TEST*/
