!
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  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> ./ex54f [-help] [-n <n>] [all SLEPc options]
!
!  Description: Illustrates use of shell matrices in callback interface from Fortran.
!  Similar to ex21.c. This one solves a simple diagonal linear eigenproblem as a NEP.
!
!  The command line options are:
!    -n <n>, where <n> = matrix dimension

#include <slepc/finclude/slepcnep.h>

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Modules needed to pass and get the context to/from the Mat
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

module shell_ctx
  use petscmat
  implicit none
  type :: MatCtx
    PetscScalar :: lambda
  end type MatCtx
end module shell_ctx

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Module used to implement the shell matrix operations
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

module ex54fmodule
  use slepcnep
  implicit none

contains
  ! --------------------------------------------------------------
  ! MyNEPFunction - Computes Function matrix  T(lambda)
  !
  subroutine MyNEPFunction(nep, lambda, T, P, ctx, ierr)
    use slepcnep
    use shell_ctx
    implicit none

    NEP                   :: nep
    PetscScalar           :: lambda
    Mat                   :: T, P
    PetscInt              :: ctx
    type(MatCtx), pointer :: ctxT
    PetscErrorCode, intent(out) :: ierr

    PetscCall(MatShellGetContext(T, ctxT, ierr))
    ctxT%lambda = lambda
  end subroutine MyNEPFunction

  ! --------------------------------------------------------------
  ! MyNEPJacobian - Computes Jacobian matrix  T'(lambda)
  !
  subroutine MyNEPJacobian(nep, lambda, T, ctx, ierr)
    use slepcnep
    use shell_ctx
    implicit none

    NEP                   :: nep
    PetscScalar           :: lambda
    Mat                   :: T
    PetscInt              :: ctx
    type(MatCtx), pointer :: ctxT
    PetscErrorCode, intent(out) :: ierr

    PetscCall(MatShellGetContext(T, ctxT, ierr))
    ctxT%lambda = lambda
  end subroutine MyNEPJacobian

  ! --------------------------------------------------------------
  ! MatMult_A - Shell matrix operation, multiples y=A*x
  ! Here A=(D-lambda*I) where D is a diagonal matrix
  !
  subroutine MatMult_A(A, x, y, ierr)
    use shell_ctx
    implicit none

    Mat                   :: A
    Vec                   :: x, y
    PetscInt              :: i, istart, iend
    PetscScalar           :: val
    type(MatCtx), pointer :: ctxA
    PetscErrorCode, intent(out) :: ierr
!
    PetscCall(VecGetOwnershipRange(x, istart, iend, ierr))
    do i = istart, iend - 1
      val = 1.0/real(i + 1, PETSC_REAL_KIND)
      PetscCall(VecSetValue(y, i, val, INSERT_VALUES, ierr))
    end do
    PetscCall(VecAssemblyBegin(y, ierr))
    PetscCall(VecAssemblyEnd(y, ierr))
    PetscCall(VecPointwiseMult(y, y, x, ierr))
    PetscCall(MatShellGetContext(A, ctxA, ierr))
    PetscCall(VecAXPY(y, -ctxA%lambda, x, ierr))
  end subroutine MatMult_A

  ! --------------------------------------------------------------
  ! MatDuplicate_A - Shell matrix operation, duplicates A
  !
  subroutine MatDuplicate_A(A, opt, M, ierr)
    use shell_ctx
    implicit none

    Mat                   :: A, M
    MatDuplicateOption    :: opt
    PetscInt              :: ml, nl
    type(MatCtx), pointer :: ctxM, ctxA
    PetscErrorCode, intent(out) :: ierr

    PetscCall(MatGetLocalSize(A, ml, nl, ierr))
    PetscCall(MatShellGetContext(A, ctxA, ierr))
    allocate (ctxM)
    ctxM%lambda = ctxA%lambda
    PetscCall(MatCreateShell(PETSC_COMM_WORLD, ml, nl, PETSC_DETERMINE, PETSC_DETERMINE, ctxM, M, ierr))
    PetscCall(MatShellSetOperation(M, MATOP_MULT, MatMult_A, ierr))
    PetscCall(MatShellSetOperation(M, MATOP_DESTROY, MatDestroy_A, ierr))
  end subroutine MatDuplicate_A

  ! --------------------------------------------------------------
  ! MatDestroy_A - Shell matrix operation, destroys A
  !
  subroutine MatDestroy_A(A, ierr)
    use shell_ctx
    implicit none

    Mat                   :: A
    type(MatCtx), pointer :: ctxA
    PetscErrorCode, intent(out) :: ierr

    PetscCall(MatShellGetContext(A, ctxA, ierr))
    deallocate (ctxA)
  end subroutine MatDestroy_A

  ! --------------------------------------------------------------
  ! MatMult_B - Shell matrix operation, multiples y=B*x
  ! Here B=-I
  !
  subroutine MatMult_B(B, x, y, ierr)
    use petscmat
    implicit none

    Mat            :: B
    Vec            :: x
    Vec            :: y
    PetscErrorCode, intent(out) :: ierr
    PetscScalar, parameter :: mone = -1.0

    PetscCall(VecCopy(x, y, ierr))
    PetscCall(VecScale(y, mone, ierr))
  end subroutine MatMult_B

end module ex54fmodule

!=================================================================================================

program ex54f
  use slepcnep
  use shell_ctx
  use ex54fmodule
  implicit none

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

  NEP            :: nep
  Mat            :: A, B
  PetscInt       :: n = 400, nev = 3, nconv
  PetscErrorCode :: ierr
  PetscScalar    :: sigma
  PetscBool      :: flg, terse
  PetscMPIInt    :: rank
  type(MatCtx)   :: ctxA, ctxB

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

  PetscCallA(SlepcInitialize(PETSC_NULL_CHARACTER, ierr))
  PetscCallA(PetscOptionsGetInt(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-n', n, flg, ierr))
  PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr))
  if (rank == 0) then
    write (*, '(/a,i4)') 'Nonlinear eigenproblem with shell matrices, n =', n
  end if

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Create matrix-free operators for A and B corresponding to T and T'
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  ctxA%lambda = 0.0
  PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxA, A, ierr))
  PetscCallA(MatShellSetOperation(A, MATOP_MULT, MatMult_A, ierr))
  PetscCallA(MatShellSetOperation(A, MATOP_DUPLICATE, MatDuplicate_A, ierr))

  ctxB%lambda = 0.0   ! unused
  PetscCallA(MatCreateShell(PETSC_COMM_WORLD, PETSC_DECIDE, PETSC_DECIDE, n, n, ctxB, B, ierr))
  PetscCallA(MatShellSetOperation(B, MATOP_MULT, MatMult_B, ierr))

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

  PetscCallA(NEPCreate(PETSC_COMM_WORLD, nep, ierr))
  PetscCallA(NEPSetFunction(nep, A, A, MyNEPFunction, PETSC_NULL_INTEGER, ierr))
  PetscCallA(NEPSetJacobian(nep, B, MyNEPJacobian, PETSC_NULL_INTEGER, ierr))
  PetscCallA(NEPSetDimensions(nep, nev, PETSC_DETERMINE_INTEGER, PETSC_DETERMINE_INTEGER, ierr))
  sigma = 1.05
  PetscCallA(NEPSetTarget(nep, sigma, ierr))
  PetscCallA(NEPSetFromOptions(nep, ierr))

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Solve the eigensystem, display solution and clean up
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  PetscCallA(NEPSolve(nep, ierr))

  PetscCallA(NEPGetConverged(nep, nconv, ierr))
  if (rank == 0) then
    write (*, '(a,i2/)') ' Number of converged approximate eigenpairs:', nconv
  end if
!
! ** show detailed info unless -terse option is given by user
  PetscCallA(PetscOptionsHasName(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-terse', terse, ierr))
  if (terse) then
    PetscCallA(NEPErrorView(nep, NEP_ERROR_RELATIVE, PETSC_NULL_VIEWER, ierr))
  else
    PetscCallA(PetscViewerPushFormat(PETSC_VIEWER_STDOUT_WORLD, PETSC_VIEWER_ASCII_INFO_DETAIL, ierr))
    PetscCallA(NEPConvergedReasonView(nep, PETSC_VIEWER_STDOUT_WORLD, ierr))
    PetscCallA(NEPErrorView(nep, NEP_ERROR_RELATIVE, PETSC_VIEWER_STDOUT_WORLD, ierr))
    PetscCallA(PetscViewerPopFormat(PETSC_VIEWER_STDOUT_WORLD, ierr))
  end if

  PetscCallA(NEPDestroy(nep, ierr))
  PetscCallA(MatDestroy(A, ierr))
  PetscCallA(MatDestroy(B, ierr))
  PetscCallA(SlepcFinalize(ierr))

end program ex54f

!/*TEST
!
!   testset:
!      args: -terse
!      output_file: output/ex54f_1.out
!      filter: grep -v approximate | sed -e "s/[+-]0\.0*i//g"
!      test:
!         suffix: 1_slp
!         args: -nep_type slp -nep_slp_ksp_type gmres -nep_slp_pc_type none
!         requires: double
!      test:
!         suffix: 1_nleigs
!         args: -nep_type nleigs -rg_interval_endpoints 0.2,1.1 -nep_nleigs_ksp_type gmres -nep_nleigs_pc_type none
!         requires: !complex
!      test:
!         suffix: 1_nleigs_complex
!         args: -nep_type nleigs -rg_interval_endpoints 0.2,1.1,-.1,.1 -nep_nleigs_ksp_type gmres -nep_nleigs_pc_type none
!         requires: complex
!
!TEST*/
