! SPDX-License-Identifier: AGPL-3.0-or-later
! Copyright 2024-2025 Max-Planck-Institut für Nachhaltige Materialien GmbH
! Copyright 2011-2024 Max-Planck-Institut für Eisenforschung GmbH
!
! DAMASK is free software: you can redistribute it and/or modify
! it under the terms of the GNU Affero General Public License as
! published by the Free Software Foundation, either version 3 of the
! License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU Affero General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License
! along with this program.  If not, see <https://www.gnu.org/licenses/>.
!--------------------------------------------------------------------------------------------------
!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @brief FEM PETSc solver
!--------------------------------------------------------------------------------------------------
#include <petsc/finclude/petscdmplex.h>
#include <petsc/finclude/petscdm.h>
#include <petsc/finclude/petsc.h>
module mesh_mechanical_FEM
  use PETScSNES
  use PETScDM
  use PETScDMplex
#if PETSC_VERSION_MINOR<23
  use PETScDT
#endif
#ifndef PETSC_EXPOSES_MPI
  use MPI_f08
#endif

  use prec
  use FEM_utilities
  use discretization
  use discretization_mesh
  use homogenization
  use math
  use constants

#ifndef PETSC_EXPOSES_MPIF90
  implicit none(type,external)
#else
  implicit none
#endif
  private

!--------------------------------------------------------------------------------------------------
! derived types
  type tSolutionParams
    type(tMechBC),allocatable, dimension(:)  :: mechBC
    real(pREAL)    :: Delta_t
  end type tSolutionParams

  type(tSolutionParams)  :: params

  type, private :: tNumerics
    PetscInt :: &
      p_i, &                                                                                        !< integration order (quadrature rule)
      itmax
  end type tNumerics

  type(tNumerics), private :: num
!--------------------------------------------------------------------------------------------------
! PETSc data
  SNES                           :: mechanical_snes
  Vec                            :: u, u_local, u_rate, &
                                    u_aim, u_aim_rate, u_aim_prev, &
                                    f_ext, f_aim_rate, f_ext_prev, &
                                    x_local
  PetscInt                       :: dimPlex, cellDof, nBasis
  PetscInt                       :: nQuadrature
  PetscReal, allocatable, dimension(:) :: qWeights
  MatNullSpace                   :: matnull

!--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc.
  character(len=pSTRLEN) :: incInfo
  real(pREAL), dimension(3,3) :: &
    P_av = 0.0_pREAL
  logical :: ForwardData
  integer(kind(STATUS_OK)) :: status
  real(pREAL), parameter :: eps = 1.0e-18_pREAL

#if PETSC_VERSION_MINOR<23
  external :: &                                                                                     ! ToDo: write interfaces
#if PETSC_VERSION_MINOR<22
    DMAddField, &
    SNESConvergedDefault, &
#endif
    PetscSectionGetNumFields, &
    PetscFESetQuadrature, &
    PetscFEGetDimension, &
    PetscFEDestroy, &
    PetscSectionGetDof, &
    PetscFEGetDualSpace, &
    PetscDualSpaceGetFunctional
#endif

  public :: &
    FEM_mechanical_init, &
    FEM_mechanical_solution, &
    FEM_mechanical_forward, &
    FEM_mechanical_assembleFext, &
    FEM_mechanical_assembleU, &
    FEM_mechanical_updateCoords

contains

!--------------------------------------------------------------------------------------------------
!> @brief allocates all neccessary fields and fills them with data
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_init(mechBC,num_mesh)

  type(tMechBC), dimension(:), intent(in) :: mechBC
  type(tDict),   pointer,      intent(in) :: num_mesh

  DM       :: mechanical_mesh
  IS       :: label_points_IS                                                                       ! IS of points in a stratum of a label
  DMLabel  :: dm_label                                                                              ! mesh labels
  PetscFE  :: mechFE
  PetscDS  :: mechDS
  PetscInt :: n_displacement_BC, nc, &
              component, boundary, topologDim, &
              cellStart, cellEnd, &
              nCoords, d
  PetscBool       :: has_label, is_simplex
  PetscSection    :: section
  PetscQuadrature :: mechQuad
  PetscDualSpace  :: mechDualSpace
#if PETSC_VERSION_MINOR>22
  PetscObject     :: obj
#endif
  PetscErrorCode  :: err_PETSc
#if PETSC_VERSION_MINOR<23
  DMLabel,   dimension(:), pointer     :: PETSC_NULL_DMLABEL_ARRAY => NULL()
  PetscReal, dimension(:), pointer     :: PETSC_NULL_REAL_POINTER => NULL()
#endif
  IS,        dimension(:), pointer     :: BC_comps_IS, BC_points_IS
  PetscInt,  dimension(:), pointer     :: n_comp, n_dof, BC_field, label_points
  PetscInt,  dimension(:), allocatable :: idx
  PetscReal, dimension(:), pointer     :: qWeightsP
  real(pREAL), dimension(:), allocatable :: nodeCoords

  integer                     :: n
  character(len=*), parameter :: prefix = 'mechanical_'
  character(len=pSTRLEN)      :: BC_label

  real(pREAL), dimension(3,3) :: devNull
  type(tDict), pointer        :: num_mech

  print'(/,1x,a)', '<<<+-  FEM_mech init  -+>>>'; flush(IO_STDOUT)

!-----------------------------------------------------------------------------
! read numerical parametes and do sanity checks
  num_mech => num_mesh%get_dict('mechanical', defaultVal=emptyDict)

  num%p_i   = int(num_mesh%get_asInt('p_i',defaultVal=2),pPETSCINT)
  num%itmax = int(num_mech%get_asInt('N_iter_max',defaultVal=250),pPETSCINT)

  if (num%itmax <= 1_pPETSCINT) call IO_error(301,ext_msg='N_iter_max')

!--------------------------------------------------------------------------------------------------
! Setup FEM mech mesh
  call DMClone(geomMesh,mechanical_mesh,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetDimension(mechanical_mesh,dimPlex,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMSetFromOptions(mechanical_mesh,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMPlexIsSimplex(mechanical_mesh,is_simplex,err_PETSc)
  CHKERRQ(err_PETSc)

!--------------------------------------------------------------------------------------------------
! Setup FEM mech discretization
#if PETSC_VERSION_MINOR>=24
  if (is_simplex) then
    call PetscDTSimplexQuadrature(dimPlex,num%p_i,PETSCDTSIMPLEXQUAD_DEFAULT,mechQuad,err_PETSc)
  else
    num%p_i = num%p_i + 1_pPETSCINT                                                                 ! adjust for quad/hex (non-simplex)
    call PetscDTGaussTensorQuadrature(dimPlex,dimPlex,num%p_i,-1.0_pREAL,1.0_pREAL,mechQuad,err_PETSc)
  end if
#elif PETSC_VERSION_MINOR==23
  if (.not. is_simplex) call IO_error(800_pI16, 'mesh is not a simplex')
  call PetscDTSimplexQuadrature(dimPlex,num%p_i,PETSCDTSIMPLEXQUAD_DEFAULT,mechQuad,err_PETSc)
#else
  if (.not. is_simplex) call IO_error(800_pI16, 'mesh is not a simplex')
  call PetscDTSimplexQuadrature(dimPlex,num%p_i,-1,mechQuad,err_PETSc)
#endif
  CHKERRQ(err_PETSc)

#if PETSC_VERSION_MINOR>21
  call PetscQuadratureGetData(mechQuad,PETSC_NULL_INTEGER,PETSC_NULL_INTEGER, &
                              nQuadrature,PETSC_NULL_REAL_POINTER,qWeightsP,err_PETSc)
  CHKERRQ(err_PETSc)
  qWeights = qWeightsP
  call PetscQuadratureRestoreData(mechQuad,PETSC_NULL_INTEGER,PETSC_NULL_INTEGER, &
                                  PETSC_NULL_INTEGER,PETSC_NULL_REAL_POINTER,qWeightsP, &
                                  err_PETSc)
#else
  call PetscQuadratureGetData(mechQuad,PETSC_NULL_INTEGER(1),PETSC_NULL_INTEGER(1), &
                              nQuadrature,PETSC_NULL_REAL_POINTER,qWeightsP,err_PETSc)
  CHKERRQ(err_PETSc)
  qWeights = qWeightsP
  call PetscQuadratureRestoreData(mechQuad,PETSC_NULL_INTEGER(1),PETSC_NULL_INTEGER(1), &
                                  PETSC_NULL_INTEGER(1),PETSC_NULL_REAL_POINTER,qWeightsP, &
                                  err_PETSc)
#endif
  CHKERRQ(err_PETSc)

  if (.not. is_simplex) qWeights = qWeights(::dimPlex)                                              ! duplicates per component not needed
  nc = dimPlex
  call PetscFECreateDefault(PETSC_COMM_SELF,dimPlex,nc,is_simplex,prefix,num%p_i,mechFE,err_PETSc)
  CHKERRQ(err_PETSc)
  call PetscFESetQuadrature(mechFE,mechQuad,err_PETSc)
  CHKERRQ(err_PETSc)
  call PetscFEGetDimension(mechFE,nBasis,err_PETSc)
  CHKERRQ(err_PETSc)
  nBasis = nBasis/nc
#if PETSC_VERSION_MINOR>22
  call DMAddField(mechanical_mesh,PETSC_NULL_DMLABEL,PetscObjectCast(mechFE),err_PETSc)
#else
  call DMAddField(mechanical_mesh,PETSC_NULL_DMLABEL,mechFE,err_PETSc)
#endif
  CHKERRQ(err_PETSc)
  call DMCreateDS(mechanical_mesh,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetDS(mechanical_mesh,mechDS,err_PETSc)
  CHKERRQ(err_PETSc)
  call PetscDSGetTotalDimension(mechDS,cellDof,err_PETSc)
  CHKERRQ(err_PETSc)
  call PetscFEDestroy(mechFE,err_PETSc)
  CHKERRQ(err_PETSc)
  call PetscQuadratureDestroy(mechQuad,err_PETSc)
  CHKERRQ(err_PETSc)

!--------------------------------------------------------------------------------------------------
! Setup FEM mech boundary conditions
  do n = 1, size(PETSC_GENERIC_LABELS) - 1                                                          ! not needed for vertices
    call DMHasLabel(mechanical_mesh, PETSC_GENERIC_LABELS(n), has_label, err_PETSc)
    if (has_label) then
      call DMGetLabel(mechanical_mesh, PETSC_GENERIC_LABELS(n), dm_label, err_PETSc)
      CHKERRQ(err_PETSc)
      call DMPlexLabelComplete(mechanical_mesh, dm_label, err_PETSc)
      CHKERRQ(err_PETSc)
    end if
  end do

  call DMGetLocalSection(mechanical_mesh,section,err_PETSc)
  CHKERRQ(err_PETSc)
  allocate(n_comp(1), source=dimPlex)
  allocate(n_dof(0:dimPlex), source = 0_pPETSCINT)
  do topologDim = 0_pPETSCINT, dimPlex
    call DMPlexGetDepthStratum(mechanical_mesh, topologDim, cellStart, cellEnd, err_PETSc)
    CHKERRQ(err_PETSc)
    call PetscSectionGetDof(section, cellStart, n_dof(topologDim), err_PETSc)
    CHKERRQ(err_PETSc)
  end do
  n_displacement_BC = sum([(count(mechBC(boundary)%active == BC_TYPE_U_DOT .or. &
                                  mechBC(boundary)%active == BC_TYPE_U), boundary = 1, size(mechBC))])
  allocate(BC_field(n_displacement_BC), source = 0_pPETSCINT)
  allocate(BC_comps_IS(n_displacement_BC))
  allocate(BC_points_IS(n_displacement_BC))
  d = 0_pPETSCINT
  do boundary = 1_pPETSCINT, mesh_Nboundaries
    BC_label = PETSC_GENERIC_LABELS(mesh_boundariesIdx(boundary))
    do component = 1_pPETSCINT, dimPlex
      if (mechBC(boundary)%active(component) == BC_TYPE_U_DOT .or. &
          mechBC(boundary)%active(component) == BC_TYPE_U) then
        d = d + 1_pPETSCINT
        call ISCreateGeneral(PETSC_COMM_WORLD,1_pPETSCINT,[component-1_pPETSCINT],PETSC_COPY_VALUES, &
                             BC_comps_IS(d),err_PETSc)
        CHKERRQ(err_PETSc)
        call DMGetStratumIS(mechanical_mesh,BC_label,mesh_boundariesIS(boundary), &
                            label_points_IS,err_PETSc)
        CHKERRQ(err_PETSc)
        call ISGetIndices(label_points_IS,label_points,err_PETSc)
        CHKERRQ(err_PETSc)
        call ISCreateGeneral(PETSC_COMM_WORLD,int(size(label_points),pPETSCINT),label_points, &
                             PETSC_COPY_VALUES,BC_points_IS(d),err_PETSc)
        CHKERRQ(err_PETSc)
        call ISRestoreIndices(label_points_IS,label_points,err_PETSc)
        CHKERRQ(err_PETSc)
        call ISDestroy(label_points_IS,err_PETSc)
        CHKERRQ(err_PETSc)
      end if
    end do
  end do
  call DMPlexCreateSection(mechanical_mesh,PETSC_NULL_DMLABEL_ARRAY,n_comp,n_dof, &
                           n_displacement_BC,BC_field,BC_comps_IS,BC_points_IS,PETSC_NULL_IS,section,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMSetLocalSection(mechanical_mesh,section,err_PETSc)
  CHKERRQ(err_PETSc)
  do boundary = 1_pPETSCINT, n_displacement_BC
    call ISDestroy(BC_points_IS(boundary),err_PETSc)
    CHKERRQ(err_PETSc)
    call ISDestroy(BC_comps_IS(boundary),err_PETSc)
    CHKERRQ(err_PETSc)
  end do
  deallocate(BC_field)

!--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc
  call SNESCreate(PETSC_COMM_WORLD,mechanical_snes,err_PETSc)
  CHKERRQ(err_PETSc)
  call SNESSetOptionsPrefix(mechanical_snes,'mechanical_',err_PETSc)
  CHKERRQ(err_PETSc)
  call SNESSetDM(mechanical_snes,mechanical_mesh,err_PETSc)                                         ! set the mesh for non-linear solver
  CHKERRQ(err_PETSc)
  call SNESSetFromOptions(mechanical_snes,err_PETSc)
  CHKERRQ(err_PETSc)
  call SnesSetLagJacobian(mechanical_snes,10_pPETSCINT, err_PETSc)
  CHKERRQ(err_PETSc)
  call DMCreateGlobalVector(mechanical_mesh,u,err_PETSc)                                            ! global solution vector {u}
  CHKERRQ(err_PETSc)
  call DMCreateGlobalVector(mechanical_mesh,u_rate,err_PETSc)                                       ! locally owned velocity Dofs to guess solution at next load step
  CHKERRQ(err_PETSc)
  call DMCreateGlobalVector(mechanical_mesh,f_ext,err_PETSc)                                        ! global external forces vector (used as RHS in K u = f)
  CHKERRQ(err_PETSc)
  call DMCreateGlobalVector(mechanical_mesh,f_aim_rate,err_PETSc)                                   ! global (per step) force rate
  CHKERRQ(err_PETSc)
  call DMCreateGlobalVector(mechanical_mesh,f_ext_prev,err_PETSc)                                   ! previous step global {f_ext}
  CHKERRQ(err_PETSc)
  call DMCreateLocalVector(mechanical_mesh,u_aim,err_PETSc)                                         ! local displacement aim at end of step
  CHKERRQ(err_PETSc)
  call DMCreateLocalVector(mechanical_mesh,u_aim_rate,err_PETSc)                                    ! local (per step) displacement rate
  CHKERRQ(err_PETSc)
  call DMCreateLocalVector(mechanical_mesh,u_aim_prev,err_PETSc)                                    ! previous step {u_aim_rate}
  CHKERRQ(err_PETSc)
  call DMCreateLocalVector(mechanical_mesh,u_local,err_PETSc)                                       ! local solution vector {u}
  CHKERRQ(err_PETSc)
  call DMCreateLocalVector(mechanical_mesh,x_local,err_PETSc)                                       ! current coordinates (with latest solution update)
  CHKERRQ(err_PETSc)
  call DMSNESSetFunctionLocal(mechanical_mesh,FEM_mechanical_formResidual,PETSC_NULL_VEC,err_PETSc) ! function to evaluate residual forces
  CHKERRQ(err_PETSc)
  call DMSNESSetJacobianLocal(mechanical_mesh,FEM_mechanical_formJacobian,PETSC_NULL_VEC,err_PETSc) ! function to evaluate stiffness matrix
  CHKERRQ(err_PETSc)
  call SNESSetMaxLinearSolveFailures(mechanical_snes,huge(1_pPETSCINT),err_PETSc)                   ! ignore linear solve failures
  CHKERRQ(err_PETSc)
  call SNESSetConvergenceTest(mechanical_snes,FEM_mechanical_converged,PETSC_NULL_VEC, &            ! function to check for convergence
                              PETSC_NULL_FUNCTION,err_PETSc)
  CHKERRQ(err_PETSc)
  call SNESSetTolerances(mechanical_snes,1.0e-5_pREAL,1.0e-6_pREAL,1.0e-6_pREAL,num%itmax, &        ! tolerances (absolute/relative/update), max func evals, max iters
                         num%itmax,err_PETSc)
  CHKERRQ(err_PETSc)
  call SNESSetFromOptions(mechanical_snes,err_PETSc)                                                ! "PETSc_options" flags from numerics file
  CHKERRQ(err_PETSc)

!--------------------------------------------------------------------------------------------------
! init fields
  call VecZeroEntries(u,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecZeroEntries(u_rate,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecZeroEntries(f_ext,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecZeroEntries(f_aim_rate,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecZeroEntries(u_aim,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecZeroEntries(x_local,err_PETSc)
  CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
  call PetscDSGetDiscretization(mechDS,0_pPETSCINT,obj,err_PETSc)
  PetscObjectSpecificCast(mechFE,obj)
#else
  call PetscDSGetDiscretization(mechDS,0_pPETSCINT,mechFE,err_PETSc)
#endif
  CHKERRQ(err_PETSc)
  call PetscFEGetDualSpace(mechFE,mechDualSpace,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMPlexGetHeightStratum(mechanical_mesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
  CHKERRQ(err_PETSc)

  nCoords = size(x_n(1:dimPlex,:),kind=pPETSCINT)
  nodeCoords = pack(x_n(1:dimPlex,:), .true.)
  idx = [(nc, nc = 0_pPETSCINT, nCoords - 1_pPETSCINT)]
  call VecSetValuesLocal(u_local, nCoords, idx, nodeCoords, INSERT_VALUES, err_PETSc)               ! initial node coordinates (undeformed)
  CHKERRQ(err_PETSc)
  call VecAssemblyBegin(u_local, err_PETSc)
  CHKERRQ(err_PETSc)
  call VecAssemblyEnd(u_local, err_PETSc)
  CHKERRQ(err_PETSc)

  call utilities_constitutiveResponse(status,0.0_pREAL,devNull,.true.)

end subroutine FEM_mechanical_init


!--------------------------------------------------------------------------------------------------
!> @brief solution for the FEM load step
!--------------------------------------------------------------------------------------------------
  type(tSolutionState) function FEM_mechanical_solution( &
             incInfoIn,Delta_t,Delta_t_prev,mechBC)

!--------------------------------------------------------------------------------------------------
! input data for solution
  real(pREAL), intent(in) :: &
    Delta_t, &                                                                                      !< increment in time for current solution
    Delta_t_prev                                                                                    !< increment in time of last increment
  type(tMechBC), dimension(:),intent(in) :: &
    mechBC
  character(len=*), intent(in) :: &
    incInfoIn

  PetscErrorCode :: err_PETSc
  SNESConvergedReason :: reason

  incInfo = incInfoIn
  FEM_mechanical_solution%converged = .false.
!--------------------------------------------------------------------------------------------------
! set module wide availabe data
  params%Delta_t = Delta_t
  params%mechBC = mechBC

  call SNESSolve(mechanical_snes,f_ext,u,err_PETSc)                                                 ! solve mechanical_snes (RHS = f_ext, initial guess = u; result in u)
  CHKERRQ(err_PETSc)
  call SNESGetConvergedReason(mechanical_snes,reason,err_PETSc)                                     ! solution converged?
  CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
  if (reason%v <= SNES_CONVERGED_ITERATING%v) then
#else
  if (reason < 1) then                                                                              ! 0: still iterating (will not occur), negative -> convergence error
#endif
    FEM_mechanical_solution%converged = .false.
    FEM_mechanical_solution%iter_needed = num%itmax
  else                                                                                              ! >= 1 proper convergence (or broken)
    FEM_mechanical_solution%converged = .true.
    call SNESGetIterationNumber(mechanical_snes,FEM_mechanical_solution%iter_needed,err_PETSc)
    CHKERRQ(err_PETSc)
  end if

end function FEM_mechanical_solution


!--------------------------------------------------------------------------------------------------
!> @brief Form the FEM residual vector.
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_formResidual(dm_local,delta_u_local,f_internal_vec,dummy,err_PETSc)

  DM,          intent(in) :: dm_local                                                               !> DM
  Vec,         intent(in) :: delta_u_local                                                          !> latest displacement solution increment
  Vec                     :: f_internal_vec                                                         !> (local) internal forces vector
  PetscObject, intent(in) :: dummy
  PetscErrorCode          :: err_PETSc

  integer(MPI_INTEGER_KIND) :: err_MPI
  PetscDS         :: prob
  PetscSection    :: section
#if PETSC_VERSION_MINOR>=24
  PetscQuadrature :: quadrature
#endif
  real(pREAL), dimension(:), pointer      :: x_scal, pf_internal
  real(pREAL), dimension(cellDof), target :: f_internal
  PetscReal,   dimension(dimPlex,dimPlex) :: invCellJ
#if PETSC_VERSION_MINOR>=24
  PetscReal, dimension(:), pointer :: pCellJ, pInvCellJ, pDetJ                                      ! (pointer) cell / inverse / determinant jacobian
#else
  PetscReal, dimension(:), pointer :: pV0, pCellJ, pInvCellJ                                        ! cell first node / jacobian / inverse jacobian
  PetscReal                        :: detJ                                                          ! jacobian determinant
#endif
#if PETSC_VERSION_MINOR>22
  PetscTabulation, pointer :: tab(:)                                                                ! shape function tabulation
#else
  PetscReal, dimension(:), pointer :: basisFieldDer, &                                              ! shape functions first derivative
                                      dev_null
#endif
  PetscInt  :: cellStart, cellEnd, cell, &
               qPt, basis, comp, cidx, &
               numFields, m,i
  PetscReal, dimension(dimPlex*dimPlex,cellDof) :: BMat                                             ! strain-displacement [B] matrix
#if PETSC_VERSION_MINOR>=24
  PetscBool :: is_simplex


  allocate(pCellJ(nQuadrature*dimPlex**2))
  allocate(pInvCellJ(nQuadrature*dimPlex**2))
  allocate(pDetJ(nQuadrature))
#else
  allocate(pV0(dimPlex))
  allocate(pCellJ(dimPlex**2))
  allocate(pInvCellJ(dimPlex**2))
#endif
  allocate(x_scal(cellDof))

  call DMGetLocalSection(dm_local,section,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMPlexGetHeightStratum(dm_local,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
  CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>=24
  call DMPlexIsSimplex(dm_local,is_simplex,err_PETSc)
  CHKERRQ(err_PETSc)
#endif
  call VecWAXPY(x_local,1.0_pREAL,delta_u_local,u_local,err_PETSc)
  CHKERRQ(err_PETSc)
  call utilities_projectDisplacementBC(x_local,u_aim_rate,params%Delta_t)                           ! enforce displacement BC

!--------------------------------------------------------------------------------------------------
! evaluate field derivatives
  call DMGetDS(dm_local,prob,err_PETSc)
  CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
  call PetscDSGetTabulation(prob,tab,err_PETSc)
#else
  call PetscDSGetTabulation(prob,0_pPETSCINT,dev_null,basisFieldDer,err_PETSc)
#endif
  CHKERRQ(err_PETSc)

#if PETSC_VERSION_MINOR>=24
  if (is_simplex) then
    call PetscDTSimplexQuadrature(dimPlex,num%p_i,PETSCDTSIMPLEXQUAD_DEFAULT, &
                                  quadrature,err_PETSc)
  else
    call PetscDTGaussTensorQuadrature(dimPlex,dimPlex,num%p_i,-1.0_pREAL,1.0_pREAL, &
                                      quadrature,err_PETSc)
  end if
#endif
  CHKERRQ(err_PETSc)

  do cell = cellStart, cellEnd-1_pPETSCINT
    call PetscSectionGetNumFields(section,numFields,err_PETSc)
    CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
    call DMPlexVecGetClosure(dm_local,section,x_local,cell,PETSC_NULL_INTEGER,x_scal,err_PETSc)     ! get Dofs belonging to element
#else
    call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)                        ! get Dofs belonging to element
#endif
    CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>=24
    call DMPlexComputeCellGeometryFEM(dm_local,cell,quadrature,PETSC_NULL_REAL_ARRAY,pCellJ, &
                                      pInvCellJ,pDetJ,err_PETSc)
#else
    call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvCellJ,detJ,err_PETSc)
#endif
    CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR<24
    invCellJ = reshape(pInvCellJ, shape=[dimPlex,dimPlex])
#endif
    do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
      m = cell*nQuadrature + qPt+1_pPETSCINT
      BMat = 0.0_pREAL
#if PETSC_VERSION_MINOR>=24
      invCellJ = reshape(pInvCellJ(qPt*dimPlex**2+1_pPETSCINT:(qPt+1_pPETSCINT)*dimPlex**2), &
                         shape=[dimPlex,dimPlex])
#endif
      do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
        do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
          cidx = basis*dimPlex+comp
          i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
          BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
#if PETSC_VERSION_MINOR>22
            matmul(invCellJ,tab(1)%ptr%T(2)%ptr(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
#else
            matmul(invCellJ,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
#endif
        end do
      end do
      homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1])
    end do
#if PETSC_VERSION_MINOR>22
    call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,PETSC_NULL_INTEGER,x_scal,err_PETSc)
#else
    call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
#endif
    CHKERRQ(err_PETSc)
  end do

!--------------------------------------------------------------------------------------------------
! evaluate constitutive response
  call utilities_constitutiveResponse(status,params%Delta_t,P_av,ForwardData)
  call MPI_Allreduce(MPI_IN_PLACE,status,1_MPI_INTEGER_KIND,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,err_MPI)
  call parallelization_chkerr(err_MPI)
  ForwardData = .false.

!--------------------------------------------------------------------------------------------------
! integrating residual
  do cell = cellStart, cellEnd-1_pPETSCINT                                                          ! loop over all elements
#if PETSC_VERSION_MINOR>22
    call DMPlexVecGetClosure(dm_local,section,x_local,cell,PETSC_NULL_INTEGER,x_scal,err_PETSc)     ! get Dofs belonging to element
#else
    call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)                        ! get Dofs belonging to element
#endif
    CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>=24
    call DMPlexComputeCellGeometryFEM(dm_local,cell,quadrature,PETSC_NULL_REAL_ARRAY,pCellJ, &
                                      pInvCellJ,pDetJ,err_PETSc)
#else
    call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvCellJ,detJ,err_PETSc)
#endif
    CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR<24
    invCellJ = reshape(pInvCellJ, shape=[dimPlex,dimPlex])
#endif
    f_internal = 0.0_pREAL
    do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
      m = cell*nQuadrature + qPt+1_pPETSCINT
      BMat = 0.0_pREAL
#if PETSC_VERSION_MINOR>=24
      invCellJ = reshape(pInvCellJ(qPt*dimPlex**2+1_pPETSCINT:(qPt+1_pPETSCINT)*dimPlex**2), &
                         shape=[dimPlex,dimPlex])
#endif
      do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
        do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
          cidx = basis*dimPlex+comp
          i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
          BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
#if PETSC_VERSION_MINOR>22
            matmul(invCellJ,tab(1)%ptr%T(2)%ptr(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
#else
            matmul(invCellJ,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
#endif
        end do
      end do
#if PETSC_VERSION_MINOR>=24
      f_internal = f_internal + pDetJ(qPt+1_pPETSCINT) * qWeights(qPt+1_pPETSCINT) &
#else
      f_internal = f_internal + abs(detJ) * qWeights(qPt+1_pPETSCINT) &
#endif
            * matmul(transpose(BMat), &
                     reshape(transpose(homogenization_P(1:dimPlex,1:dimPlex,m)), &
                             shape=[dimPlex*dimPlex]))
    end do
    pf_internal => f_internal
    call DMPlexVecSetClosure(dm_local,section,f_internal_vec,cell,pf_internal,ADD_VALUES,err_PETSc)
    CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
    call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,PETSC_NULL_INTEGER,x_scal,err_PETSc)
#else
    call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
#endif
    CHKERRQ(err_PETSc)
  end do
#if PETSC_VERSION_MINOR>22
  call PetscDSRestoreTabulation(prob,tab,err_PETSc)
#else
  call PetscDSRestoreTabulation(prob,0_pPETSCINT,dev_null,basisFieldDer,err_PETSc)
#endif
  CHKERRQ(err_PETSc)

end subroutine FEM_mechanical_formResidual


!--------------------------------------------------------------------------------------------------
!> @brief Form the FEM stiffness matrix.
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_formJacobian(dm_local,delta_u_local,J,Jp,dummy,err_PETSc)

  DM                      :: dm_local                                                               !> DM
  Vec                     :: delta_u_local                                                          !> latest displacement solution increment
  Mat                     :: J, Jp                                                                  !> jacobian, preconditioner
  PetscObject, intent(in) :: dummy
  PetscErrorCode          :: err_PETSc


  PetscDS      :: prob
  PetscSection :: section, gSection
#if PETSC_VERSION_MINOR>=24
  PetscQuadrature :: quadrature
#endif

  PetscReal, dimension(1,         cellDof) :: MatB
  PetscReal, dimension(dimPlex**2,cellDof) :: BMat, &                                               ! strain-displacement [B] matrix
                                              MatA
#if PETSC_VERSION_MINOR>=24
  real(pREAL), dimension(:), pointer :: pCellJ, pInvCellJ, pDetJ                                    ! (pointer) cell / inverse / determinant jacobian
#else
  real(pREAL), dimension(:), pointer :: pV0, pCellJ, pInvCellJ                                      ! cell first node / jacobian / inverse jacobian
  PetscReal :: detJ                                                                                 ! jacobian determinant
#endif
#if PETSC_VERSION_MINOR>22
  PetscTabulation, pointer :: tab(:)                                                                ! shape function tabulation
#else
  PetscReal,   dimension(:), pointer :: basisFieldDer, &                                            ! shape functions first derivative
                                        dev_null
#endif
  real(pREAL), dimension(:), pointer :: pK_e                                                        ! (pointer) element tangent stiffness
  real(pREAL), dimension(cellDOF,cellDOF), target :: K_e                                            ! element tangent stiffness
  real(pREAL), dimension(dimPlex,dimPlex)         :: invCellJ                                       ! cell inverse jacobian

  PetscInt :: cellStart, cellEnd, cell, &
              qPt, basis, comp, cidx, ce, i
#if PETSC_VERSION_MINOR>=24
  PetscBool :: is_simplex
#endif

#if PETSC_VERSION_MINOR>=24
  allocate(pCellJ(nQuadrature*dimPlex**2))
  allocate(pInvcellJ(nQuadrature*dimPlex**2))
  allocate(pDetJ(nQuadrature))
#else
  allocate(pV0(dimPlex))
  allocate(pCellJ(dimPlex**2))
  allocate(pInvCellJ(dimPlex**2))
#endif

  call MatSetOption(Jp,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatSetOption(Jp,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatZeroEntries(Jp,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetDS(dm_local,prob,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetLocalSection(dm_local,section,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetGlobalSection(dm_local,gSection,err_PETSc)
  CHKERRQ(err_PETSc)

#if PETSC_VERSION_MINOR>22
  call PetscDSGetTabulation(prob,tab,err_PETSc)
#else
  call PetscDSGetTabulation(prob,0_pPETSCINT,dev_null,basisFieldDer,err_PETSc)
#endif
  CHKERRQ(err_PETSc)
  call DMPlexGetHeightStratum(dm_local,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
  CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>=24
  call DMPlexIsSimplex(dm_local,is_simplex,err_PETSc)
  CHKERRQ(err_PETSc)
  if (is_simplex) then
    call PetscDTSimplexQuadrature(dimPlex,num%p_i,PETSCDTSIMPLEXQUAD_DEFAULT, &
                                  quadrature,err_PETSc)
  else
    call PetscDTGaussTensorQuadrature(dimPlex,dimPlex,num%p_i,-1.0_pREAL,1.0_pREAL, &
                                      quadrature,err_PETSc)
  end if
  CHKERRQ(err_PETSc)
#endif
  do cell = cellStart, cellEnd-1_pPETSCINT
#if PETSC_VERSION_MINOR>=24
    call DMPlexComputeCellGeometryFEM(dm_local,cell,quadrature,PETSC_NULL_REAL_ARRAY,pCellJ, &
                                      pInvCellJ,pDetJ,err_PETSc)
#else
    call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvCellJ,detJ,err_PETSc)
#endif
    CHKERRQ(err_PETSc)
    K_e  =  0.0_pREAL
    MatB = 0.0_pREAL
#if PETSC_VERSION_MINOR<24
    invCellJ = reshape(pInvCellJ, shape=[dimPlex,dimPlex])
#endif
    do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
      ce = cell*nQuadrature + qPt + 1_pPETSCINT
      BMat = 0.0_pREAL
#if PETSC_VERSION_MINOR>=24
      invCellJ = reshape(pInvCellJ(qPt*dimPlex**2+1_pPETSCINT:(qPt+1_pPETSCINT)*dimPlex**2), &
                         shape=[dimPlex,dimPlex])
#endif
      do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
        do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
          cidx = basis*dimPlex+comp
          i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
          BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
#if PETSC_VERSION_MINOR>22
            matmul(invCellJ,tab(1)%ptr%T(2)%ptr(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
#else
            matmul(invCellJ,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
#endif
        end do
      end do
#if PETSC_VERSION_MINOR>=24
      MatA = qWeights(qPt+1_pPETSCINT) * pDetJ(qPt+1_pPETSCINT) &
#else
      MatA = qWeights(qPt+1_pPETSCINT) * abs(detJ) &
#endif
           * matmul(reshape(reshape(homogenization_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,ce), &
                                    shape=[dimPlex,dimPlex,dimPlex,dimPlex], order=[2,1,4,3]), &
                            shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)

      K_e = K_e + matmul(transpose(BMat),MatA)
    end do
    K_e = K_e + eps*math_eye(int(cellDof))
    pK_e(1:cellDOF**2) => K_e
    call DMPlexMatSetClosure(dm_local,section,gSection,Jp,cell,pK_e,ADD_VALUES,err_PETSc)
    CHKERRQ(err_PETSc)
  end do
  call MatAssemblyBegin(Jp,MAT_FINAL_ASSEMBLY,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatAssemblyEnd(Jp,MAT_FINAL_ASSEMBLY,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatAssemblyBegin(J,MAT_FINAL_ASSEMBLY,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatAssemblyEnd(J,MAT_FINAL_ASSEMBLY,err_PETSc)
  CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
  call PetscDSRestoreTabulation(prob,tab,err_PETSc)
#else
  call PetscDSRestoreTabulation(prob,0_pPETSCINT,dev_null,basisFieldDer,err_PETSc)
#endif
  CHKERRQ(err_PETSc)

!--------------------------------------------------------------------------------------------------
! apply boundary conditions
  call DMPlexCreateRigidBody(dm_local,0_pPETSCINT,matnull,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatSetNullSpace(Jp,matnull,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatSetNearNullSpace(Jp,matnull,err_PETSc)
  CHKERRQ(err_PETSc)
  call MatNullSpaceDestroy(matnull,err_PETSc)
  CHKERRQ(err_PETSc)

end subroutine FEM_mechanical_formJacobian


!--------------------------------------------------------------------------------------------------
!> @brief forwarding routine
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_forward(guess,Delta_t,Delta_t_prev)

  logical,     intent(in) :: &
    guess
  real(pREAL), intent(in) :: &
    Delta_t_prev, &
    Delta_t

  DM             :: dm_local
  PetscSection   :: section
  PetscErrorCode :: err_PETSc

!--------------------------------------------------------------------------------------------------
! forward last inc
  if (guess .and. .not. cutBack) then
    ForwardData = .True.
    call SNESGetDM(mechanical_snes,dm_local,err_PETSc)                                              ! retrieve mesh info from mechanical_snes into dm_local
    CHKERRQ(err_PETSc)
    call DMGetLocalSection(dm_local,section,err_PETSc)
    CHKERRQ(err_PETSc)
    call VecCopy(x_local, u_local, err_PETSc)                                                       ! update solution (used as starting point for next step)
    CHKERRQ(err_PETSc)
!--------------------------------------------------------------------------------------------------
! update rate and forward last inc
    call VecCopy(u,u_rate,err_PETSc)
    CHKERRQ(err_PETSc)
    call VecScale(u_rate,Delta_t_prev**(-1),err_PETSc)
    CHKERRQ(err_PETSc)
  end if

  if (cutback) then                                                                                 ! adjust (decrease) incremental load
    call VecAXPY(f_ext,-Delta_t_prev,f_aim_rate,err_PETSc)                                          ! back to previous time step value
    CHKERRQ(err_PETSc)
  end if

  call VecCopy(u_rate,u,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecScale(u,Delta_t,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecAXPY(f_ext,Delta_t,f_aim_rate,err_PETSc)                                                  ! f = f + dt * rate
  CHKERRQ(err_PETSc)

end subroutine FEM_mechanical_forward


!--------------------------------------------------------------------------------------------------
!> @brief Build external forces vector.
!> @details Build at the beginning of a load step. Compute the end-of-step aim forces
!> @details f_aim_(local), and the required rate to achieve them (f_aim_rate).
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_assembleFext(mechBC, Delta_t)

  type(tMechBC), dimension(:), intent(in) :: &
    mechBC                                                                                          !< loadcase boundary conditions data
  real(pREAL),                 intent(in) :: &
    Delta_t                                                                                         !< total load step time

  DM             :: dm_local
  Vec            :: f_aim_local                                                                     ! external forces (built from YAML, aim at end of step)
  PetscErrorCode :: err_PETSc


  call SNESGetDM(mechanical_snes,dm_local,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecCopy(f_ext, f_ext_prev, err_PETSc)                                                        ! previous f_ext needed for force rates
  CHKERRQ(err_PETSc)
  call DMGetLocalVector(dm_local, f_aim_local, err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGlobalToLocalBegin(dm_local,f_ext,INSERT_VALUES,f_aim_local,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGlobalToLocalEnd(dm_local,f_ext,INSERT_VALUES,f_aim_local,err_PETSc)
  CHKERRQ(err_PETSc)
  call utilities_assembleFext(f_aim_local, dm_local, mechBC, Delta_t)
  call DMLocalToGlobalBegin(dm_local,f_aim_local,INSERT_VALUES,f_aim_rate,err_PETSc)                ! build global f_aim (into f_aim_rate)
  CHKERRQ(err_PETSc)
  call DMLocalToGlobalEnd(dm_local,f_aim_local,INSERT_VALUES,f_aim_rate,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMRestoreLocalVector(dm_local, f_aim_local, err_PETSc)
  CHKERRQ(err_PETSc)
  call VecAXPY(f_aim_rate,-1.0_pREAL,f_ext_prev,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecScale(f_aim_rate,1.0_pREAL/Delta_t,err_PETSc)                                             ! f rate: f_aim_rate = (f_aim - f_prev) / dt
  CHKERRQ(err_PETSc)

end subroutine FEM_mechanical_assembleFext


!--------------------------------------------------------------------------------------------------
!> @brief Build displacement vector.
!> @details Build at the beginning of a load step. Compute the end-of-step aim displacements
!> @details u_aim, and the required rate to achieve them (u_aim_rate).
!> @details NOTE: All these vectors are local.
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_assembleU(mechBC, Delta_t)

  type(tMechBC), dimension(:), intent(in) :: &
    mechBC                                                                                          !< loadcase boundary conditions data
  real(pREAL),                 intent(in) :: &
    Delta_t                                                                                         !< total load step time

  DM             :: dm_local
  PetscErrorCode :: err_PETSc


  call SNESGetDM(mechanical_snes,dm_local,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecCopy(u_aim, u_aim_prev, err_PETSc)                                                        ! previous u_aim needed for force rates
  CHKERRQ(err_PETSc)
  call utilities_assembleU(u_aim, dm_local, mechBC, Delta_t)
  call VecWAXPY(u_aim_rate,-1.0_pREAL,u_aim_prev,u_aim,err_PETSc)
  CHKERRQ(err_PETSc)
  call VecScale(u_aim_rate,1.0_pREAL/Delta_t,err_PETSc)                                             ! u rate: u_aim_rate = (u_aim - u_prev) / dt
  CHKERRQ(err_PETSc)

end subroutine FEM_mechanical_assembleU


!--------------------------------------------------------------------------------------------------
!> @brief Report solver status: continue iterating, converged or diverged.
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_converged(snes,iter,x_norm,s_norm,f_norm,reason,dummy,err_PETSc)

  SNES :: snes                                                                                      !< (local) SNES
  PetscInt :: iter                                                                                  !< current iteration
  PetscReal :: x_norm, s_norm, f_norm                                                               !< solution / solution update / residual norms
  SNESConvergedReason :: reason                                                                     !< reason of convergence/divergence
  PetscObject :: dummy                                                                              !< PETSc context object (unused)
  PetscErrorCode :: err_PETSc

#if PETSC_VERSION_MINOR>22
  Vec         :: rhs_vec                                                                            ! current step RHS (f_external) vector
#endif
  PetscInt    :: n_f_evals, n_ls_its                                                                ! number of function evaluations/linear solve iterations
  real(pREAL) :: abs_tol, rel_tol, sol_tol, rhs_tol, &                                              ! absolute/relative/update/rhs tolerances
                 r_norm                                                                             ! RHS / ratio norm


  write(IO_STDOUT,'(/,1x,a,a,i0,a)',advance='no') trim(incInfo), ' @ Iteration ', iter

  if (status /= STATUS_OK) then                                                                     ! mechanics failed
    reason = SNES_DIVERGED_USER
    print '(4a,2/,3x,a)', ' ~ ',IO_color([224,0,0]), 'Diverged', IO_color(),  &
      'Divergence reason: evaluation of constitutive law for mechanics failed'
#if PETSC_VERSION_MINOR>22
  else if (reason%v < SNES_CONVERGED_ITERATING%v) then                                              ! diverged
#else
  else if (reason < 0) then                                                                         ! diverged
#endif
    write(IO_STDOUT, '(4a,2/,3x,a)',advance='no') &
      ' ~ ', IO_color([224,0,0]), 'Diverged', IO_color(), 'Divergence reason:'
    if (reason == SNES_DIVERGED_FUNCTION_DOMAIN) then
      print '(1x,a)', 'solution outside the domain of the function'
    else if (reason == SNES_DIVERGED_FUNCTION_COUNT) then
      print '(1x,a,i0,a)', 'function evaluations limit reached (', num%itmax, ')'
    else if (reason == SNES_DIVERGED_LINEAR_SOLVE) then
      print '(1x,a)', 'linear solver failed'
    else if (reason == SNES_DIVERGED_MAX_IT) then
      print '(1x,a,i0,a)', 'linear solver iterations limit reached (', num%itmax, ')'
    else if (reason == SNES_DIVERGED_LINE_SEARCH) then
      print '(1x,a)', 'line search failed'
    else if (reason == SNES_DIVERGED_INNER) then
      print '(1x,a)', 'inner solver failed'
    else if (reason == SNES_DIVERGED_LOCAL_MIN) then
      print '(1x,a)', 'solver stagnated at a non-zero local minimum'
    else if (reason == SNES_DIVERGED_DTOL) then
      call SNESGetDivergenceTolerance(snes, rhs_tol, err_PETSc)
      CHKERRQ(err_PETSc)
      print '(1x,a,es10.3e2)', 'relative residual norm ||r|| / ||r_0|| >', rhs_tol
    else if (reason == SNES_DIVERGED_JACOBIAN_DOMAIN) then
      print '(1x,a)', 'invalid jacobian'
    else if (reason == SNES_DIVERGED_USER) then
      print '(1x,a)', 'user-defined'
    else if (reason == SNES_DIVERGED_JACOBIAN_DOMAIN) then
      print '(1x,a)', "the jacobian evaluation ocurred outside the function's domain"
#if PETSC_VERSION_MINOR>24
    else if (reason == SNES_DIVERGED_FUNCTION_NANORINF) then
      print '(1x,a)', 'residual norm is NaN or Inf'
    else if (reason == SNES_DIVERGED_OBJECTIVE_DOMAIN) then
      print '(1x,a)', "the object function evaluation ocurred outside the function's domain"
#endif
    end if
  else                                                                                              ! converged
    call SNESConvergedDefault(snes, iter, x_norm, s_norm, f_norm, reason, dummy, err_PETSc)
    CHKERRQ(err_PETSc)
    call SNESGetTolerances(snes, abs_tol, rel_tol, sol_tol, PETSC_NULL_INTEGER, &
                           PETSC_NULL_INTEGER, err_PETSc)
    CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
    call SNESGetRhs(snes, rhs_vec, err_PETSc)
    CHKERRQ(err_PETSc)
    call VecNorm(rhs_vec, NORM_2, r_norm, err_PETSc)
    CHKERRQ(err_PETSc)
    rhs_tol = max(rel_tol * r_norm, abs_tol)
#else
    rhs_tol = abs_tol
#endif
    if (reason == SNES_CONVERGED_FNORM_RELATIVE) then                                               ! overwrite RELATIVE_FNORM convergence reason
      if (f_norm > rhs_tol) then
        if (s_norm < sol_tol * x_norm) then
          reason = SNES_CONVERGED_SNORM_RELATIVE
        else
          reason = SNES_CONVERGED_ITERATING
        end if
      end if
    end if
    if (iter > 0_pPETSCINT .and. s_norm < 1.0e-13_pREAL) reason = SNES_CONVERGED_USER
    if (reason == SNES_CONVERGED_ITERATING) then
      print '(2/,2(3x,3(a,es10.3e2),a))', &
        '- Residual       =', f_norm / rhs_tol, ' (||r||        =', f_norm, ', tol =', rhs_tol, ')'
      if (iter > 0_pPETSCINT) then
        r_norm = s_norm / x_norm
        print '(3x,3(a,es10.3e2),a))', &
          '- Solution ratio =', r_norm / sol_tol, ' (||Δu||/||u|| =', r_norm, ', tol =', sol_tol, ')'
      end if
    else                                                                                            ! convergence
      call SNESGetTolerances(snes, abs_tol, rel_tol, sol_tol, PETSC_NULL_INTEGER, &
                             PETSC_NULL_INTEGER, err_PETSc)
      CHKERRQ(err_PETSc)
      call SNESGetNumberFunctionEvals(snes, n_f_evals, err_PETSc)
      CHKERRQ(err_PETSc)
      call SNESGetLinearSolveIterations(snes, n_ls_its, err_PETSc)
      CHKERRQ(err_PETSc)
      write(IO_STDOUT, '(4a,2/,3x,a)',advance='no') &
        ' ~ ', IO_color([0,192,0]), 'Converged', IO_color(), 'Convergence reason:'
      if (reason == SNES_CONVERGED_FNORM_ABS) then
        print '(1x,a,es10.3e2)', 'residual norm ||r|| <', abs_tol
      else if (reason == SNES_CONVERGED_FNORM_RELATIVE) then
        print '(1x,a)', 'residual norm ||r|| < max(abs,rel*||RHS||)'
      else if (reason == SNES_CONVERGED_SNORM_RELATIVE) then
        print '(1x,a,es10.3e2)', 'ratio ||Δu||/||u|| <', sol_tol
      else if (reason == SNES_CONVERGED_USER) then
        print '(1x,a)', '(near) zero update norm ||Δu||'
      end if
      r_norm = s_norm / x_norm
      print '(/,2(3x,3(a,es10.3e2),a,/),/,2(3x,a,es10.3e2,/))', &
        '- Residual       =', f_norm / rhs_tol, ' (||r||        =', f_norm, ', tol =', rhs_tol, ')', &
        '- Solution ratio =', r_norm / sol_tol, ' (||Δu||/||u|| =', r_norm, ', tol =', sol_tol, ')', &
        '- Final residual ||r|| =', f_norm, &
        '- Final update  ||Δu|| =', s_norm
      print '(2(3x,a,i0,:,/))', &
        '- # function evaluations     = ', n_f_evals, &
        '- # linear solver iterations = ', n_ls_its
    end if
  end if
  flush(IO_STDOUT)

end subroutine FEM_mechanical_converged


!--------------------------------------------------------------------------------------------------
!> @brief Calculate current coordinates (both nodal and ip coordinates)
!--------------------------------------------------------------------------------------------------
subroutine FEM_mechanical_updateCoords()

  PetscReal, pointer, dimension(:,:) :: &
    nodeCoords                                                                                      !< nodal coordinates (3,nNodes)
  real(pREAL), pointer, dimension(:,:,:) :: &
    ipCoords                                                                                        !< ip coordinates (3,nQuadrature,mesh_nElems)

  integer :: &
    qPt, &
    comp, &
    qOffset, &
    nOffset

  DM  :: dm_local
  PetscErrorCode :: err_PETSc
  PetscInt :: nNodes, cellStart, cellEnd, q, c, n
  PetscSection :: section
  PetscDS :: mechDS
#if PETSC_VERSION_MINOR>22
  PetscTabulation, pointer :: tab(:)
#else
  PetscReal,   dimension(:), pointer :: basisField, &
                                        dev_null
#endif
  PetscReal,   dimension(:), pointer :: nodeCoordsDM                                                ! nodal coordinates read from DM (dimPlex*nNodes)
  real(pREAL), dimension(:), pointer :: x_scal

  call SNESGetDM(mechanical_snes,dm_local,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetDS(dm_local,mechDS,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetLocalSection(dm_local,section,err_PETSc)
  CHKERRQ(err_PETSc)
  call DMGetDimension(dm_local,dimPlex,err_PETSc)
  CHKERRQ(err_PETSc)

!--------------------------------------------------------------------------------------------------
! get current coordinates
  call VecGetArray(x_local,nodeCoordsDM,err_PETSc)
  CHKERRQ(err_PETSc)
  nNodes = size(nodeCoordsDM,kind=pPETSCINT)/dimPlex
  allocate(nodeCoords(3,nNodes),source=0.0_pREAL)
  nodeCoords(1:dimPlex,:) = reshape(nodeCoordsDM, [dimPlex, nNodes])
  call discretization_setNodeCoords(nodeCoords)
  call VecRestoreArray(x_local,nodeCoordsDM,err_PETSc)
  CHKERRQ(err_PETSc)

!--------------------------------------------------------------------------------------------------
! write IP displacements
  call DMPlexGetHeightStratum(dm_local,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
  CHKERRQ(err_PETSc)
#if PETSC_VERSION_MINOR>22
  call PetscDSGetTabulation(mechDS,tab,err_PETSc)
#else
  call PetscDSGetTabulation(mechDS,0_pPETSCINT,basisField,dev_null,err_PETSc)
#endif
  CHKERRQ(err_PETSc)
  allocate(ipCoords(3,nQuadrature,mesh_nElems),source=0.0_pREAL)
  do c = cellStart, cellEnd - 1_pPETSCINT
    qOffset=0
#if PETSC_VERSION_MINOR>22
    call DMPlexVecGetClosure(dm_local,section,x_local,c,PETSC_NULL_INTEGER,x_scal,err_PETSc)        ! get nodal coordinates of each element
#else
    call DMPlexVecGetClosure(dm_local,section,x_local,c,x_scal,err_PETSc)                           ! get nodal coordinates of each element
#endif
    CHKERRQ(err_PETSc)
    do qPt=0,nQuadrature-1
#if PETSC_VERSION_MINOR>22
      qOffset = qPt * (size(tab(1)%ptr%T(1)%ptr)/nQuadrature)
#else
      qOffset = qPt * (size(basisField)/nQuadrature)
#endif
      do comp=0,dimPlex-1                                                                           ! loop over components
        nOffset=0
        q = comp
        do n=0,nBasis-1
          ipCoords(comp+1,qPt+1,c+1)=ipCoords(comp+1,qPt+1,c+1)+&
#if PETSC_VERSION_MINOR>22
                                     sum(tab(1)%ptr%T(1)%ptr(qOffset+(q*dimPlex)+1:qOffset+(q*dimPlex)+dimPlex)*&
#else
                                     sum(basisField(qOffset+(q*dimPlex)+1:qOffset+(q*dimPlex)+dimPlex)*&
#endif
                                     x_scal(nOffset+1:nOffset+dimPlex))
          q = q+dimPlex
          nOffset = nOffset+dimPlex
        end do
      end do
    end do
#if PETSC_VERSION_MINOR>22
    call DMPlexVecRestoreClosure(dm_local,section,x_local,c,PETSC_NULL_INTEGER,x_scal,err_PETSc)
#else
    call DMPlexVecRestoreClosure(dm_local,section,x_local,c,x_scal,err_PETSc)
#endif
    CHKERRQ(err_PETSc)
  end do
  call discretization_setIPcoords(reshape(ipCoords,[3,int(mesh_nElems*nQuadrature)]))
#if PETSC_VERSION_MINOR>22
  call PetscDSRestoreTabulation(mechDS,tab,err_PETSc)
#else
  call PetscDSRestoreTabulation(mechDS,0_pPETSCINT,basisField,dev_null,err_PETSc)
#endif
  CHKERRQ(err_PETSc)

end subroutine FEM_mechanical_updateCoords

end module mesh_mechanical_FEM
