module distr
  ! use util
  implicit none
  ! add any new type of distribution data,
  ! or modify old distribution data in this module.
  ! Each subroutine corresponds to one type of distribution function.

  contains

!----------------------------------------------------------------------
  subroutine force_free(fv, nvxf, nvyf, fgk, np)
    implicit none
    integer, intent(in) :: nvxf, nvyf, np
    real, dimension(nvxf, nvyf), intent(inout) :: fv
    real, intent(inout) :: fgk

    ! local data
    real, parameter :: vt = 1.0, a = 1.0, b = 2.0
    real, parameter :: beta = vt**(-2), ux = 2.0**0.5 * vt, uy = 2.0**0.5 * vt
    real, parameter :: Ax = 0.0, Ay = 0.0
    real, parameter :: vxmax = 5.0, vymax = 5.0, betah = 0.5 * beta
    real, dimension(nvxf) :: vx
    real, dimension(nvyf) :: vy
    real, dimension(nvxf, nvyf) :: wgt
    integer :: j

    ! distribution data
    vx = linspace(-vxmax, vxmax, nvxf)
    vy = linspace(-vymax, vymax, nvyf)
    do j = 1, nvyf
      fv(:, j) = exp(-betah * (vx**2 + vy(j)**2))&
        & * (exp(beta * uy * (vy(j) + Ay)) + a * cos(beta * ux * (vx + Ax)) + b)
    enddo

    ! density normalization factor
    wgt = 1.0
    wgt(1, :) = 0.5
    wgt(nvxf, :) = 0.5
    wgt(:, 1) = 0.5
    wgt(:, nvyf) = 0.5
    wgt(1, 1) = 0.25
    wgt(nvxf, 1) = 0.25
    wgt(1, nvyf) = 0.25
    wgt(nvxf, nvyf) = 0.25
    fgk = sum(wgt * fv) / real(np)
    return
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine power_maxwellian(fv, nvperf, nvparf, fgk, np)
    implicit none
    integer, intent(in) :: nvperf, nvparf, np
    real, dimension(nvperf, nvparf), intent(inout) :: fv
    real, intent(inout) :: fgk

    ! local data
    real, parameter :: kappa = 0.2
    real, parameter :: vtmpar = 1.0, vtmper = vtmpar * 2.0**0.5
    real, parameter :: vtpper = vtmper * (3.0 / 800.0)**0.5
    real, parameter :: vtppar = vtpper * 2.0**0.5
    real, parameter :: vpermax = 4.0, vparmax = 4.0
    real, dimension(nvperf) :: vper
    real, dimension(nvparf) :: vpar
    real, dimension(nvperf, nvparf) :: wgt
    integer :: j
    real :: rkappah

    ! distribution data
    vper = linspace(0.0, vpermax, nvperf)
    vpar = linspace(-vparmax, vparmax, nvparf)
    rkappah = 0.5 / kappa
    do j = 1, nvparf
      ! factor (2 * pi * vper) is due to the cylindrical coordinate.
      fv(:, j) = (1.0 + rkappah * ((vper/vtpper)**2&
        & + (vpar(j)/vtppar)**2))**(-kappa - 1.0)&
        & * exp(-0.5 * ((vper/vtmper)**2 + (vpar(j)/vtmpar)**2))&
        & * (6.28318530717959 * vper)
    enddo

    ! density normalization factor
    wgt = 1.0
    wgt(1, :) = 0.5
    wgt(nvperf, :) = 0.5
    wgt(:, 1) = 0.5
    wgt(:, nvparf) = 0.5
    wgt(1, 1) = 0.25
    wgt(nvperf, 1) = 0.25
    wgt(1, nvparf) = 0.25
    wgt(nvperf, nvparf) = 0.25
    fgk = sum(wgt * fv) / real(np)
    return
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine halo(fv, nvperf, nvparf, fgk, np)
    implicit none
    integer, intent(in) :: nvperf, nvparf, np
    real, dimension(nvperf, nvparf), intent(inout) :: fv
    real, intent(inout) :: fgk

    ! local data
    real, parameter :: kappa = 3.0
    real, parameter :: vthpar = 1.0, vthper = 1.0 / 2.0**0.5
    real, parameter :: vtcpar = 0.3, vtcper = 0.3
    real, parameter :: delta = 3.0 * vtcpar, p = 10.0, q = 1.0
    real, parameter :: vpermax = 5.0, vparmax = 5.0
    real, dimension(nvperf) :: vper
    real, dimension(nvparf) :: vpar
    real, dimension(nvperf, nvparf) :: fvflat, wgt
    integer :: j

    ! distribution data
    vper = linspace(0.0, vpermax, nvperf)
    vpar = linspace(-vparmax, vparmax, nvparf)
    do j = 1, nvparf
      ! factor (2 * pi * vper) is due to the cylindrical coordinate.
      fv(:, j) = (1.0 + ((vper/vthper)**2 + (vpar(j)/vthpar)**2)&
        & / (2.0 * kappa - 3.0))**(-kappa - 1.0) * (6.28318530717959 * vper)

      fvflat(:, j) = (1.0 + (((vper/vtcper)**2 + (vpar(j)/vtcpar)**2)&
        & / (2.0 * delta))**p)**(-q)
    enddo
    fv = (1.0 - fvflat) * fv

    ! density normalization factor
    wgt = 1.0
    wgt(1, :) = 0.5
    wgt(nvperf, :) = 0.5
    wgt(:, 1) = 0.5
    wgt(:, nvparf) = 0.5
    wgt(1, 1) = 0.25
    wgt(nvperf, 1) = 0.25
    wgt(1, nvparf) = 0.25
    wgt(nvperf, nvparf) = 0.25
    fgk = sum(wgt * fv) / real(np)
    return
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine lembege_pellat(fxy, nxv, nyv, fgk, np)
    implicit none
    integer, intent(in) :: nxv, nyv, np
    real, dimension(nxv, nyv), intent(inout) :: fxy
    real, intent(inout) :: fgk

    ! local data
    real, parameter :: epsln = 0.04, ascl = 2.0
    real, parameter :: Lx = 16.0, Ly = 32.0
    real, dimension(nxv) :: x
    real, dimension(nyv) :: y
    real, dimension(nxv, nyv) :: wgt
    integer :: j
    real :: Fy

    ! distribution data
    x = linspace(-Lx/2.0, Lx/2.0, nxv)
    y = linspace(-Ly, 0.0, nyv)
    do j = 1, nyv
      Fy = exp(-epsln * y(j) / ascl)
      fxy(:, j) = 1.0 / (cosh(x / (ascl * Fy)) * Fy)**2
    enddo

    ! density normalization factor
    wgt = 1.0
    wgt(1, :) = 0.5
    wgt(nxv, :) = 0.5
    wgt(:, 1) = 0.5
    wgt(:, nyv) = 0.5
    wgt(1, 1) = 0.25
    wgt(nxv, 1) = 0.25
    wgt(1, nyv) = 0.25
    wgt(nxv, nyv) = 0.25
    fgk = sum(wgt * fxy) / real(np)
    return
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine butterfly(fxy, nxv, nyv, fgk, np)
    implicit none
    integer, intent(in) :: nxv, nyv, np
    real, dimension(nxv, nyv), intent(inout) :: fxy
    real, intent(inout) :: fgk

    ! local data
    real, dimension(nxv) :: x
    real, dimension(nyv) :: y
    real, dimension(nxv, nyv) :: wgt
    integer :: j

    ! distribution data
    x = linspace(-3.0, 3.0, nxv)
    y = linspace(-3.0, 3.0, nyv)
    do j = 1, nyv
      fxy(:, j) = exp(-x**2 - 2.0*y(j)**2) / cosh(5.0d0 * x * y(j)) &
        & * (x - y(j))**2
    enddo

    ! density normalization factor
    wgt = 1.0
    wgt(1, :) = 0.5
    wgt(nxv, :) = 0.5
    wgt(:, 1) = 0.5
    wgt(:, nyv) = 0.5
    wgt(1, 1) = 0.25
    wgt(nxv, 1) = 0.25
    wgt(1, nyv) = 0.25
    wgt(nxv, nyv) = 0.25
    fgk = sum(wgt * fxy) / real(np)
    return
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine charged_LP_ics(fxy, nxv, nyv, fgk, np)
    implicit none
    integer, intent(in) :: nxv, nyv, np
    real, dimension(nxv, nyv), intent(inout) :: fxy
    real, intent(inout) :: fgk

    ! local data
    real, parameter :: vDi = 1.0/3.0, vDe = -4.0/3.0
    real, parameter :: Te0 = 0.5/6.0, Ti0 = 0.5 - Te0
    real, parameter :: Tib = Ti0, Teb = Te0, nb = 0.2
    real, parameter :: epsln = 0.04
    real, parameter :: Lx = 16.0, Ly = 32.0
    real, dimension(nxv) :: x
    real, dimension(nyv) :: y
    real, dimension(nxv, nyv) :: pot, Az, wgt

    ! grid
    x = linspace(-Lx/2.0, Lx/2.0, nxv)
    y = linspace(-Ly, 0.0, nyv)
    ! get potential and vector potential
    call sol_ampere_poisson(pot, Az, x, y, nxv, nyv, &
      &vDi, Ti0, Tib, vDe, Te0, Teb, nb, epsln)

    ! distribution data
    fxy = exp((-pot + vDi * Az) / Ti0)

    ! density normalization factor
    wgt = 1.0
    wgt(1, :) = 0.5
    wgt(nxv, :) = 0.5
    wgt(:, 1) = 0.5
    wgt(:, nyv) = 0.5
    wgt(1, 1) = 0.25
    wgt(nxv, 1) = 0.25
    wgt(1, nyv) = 0.25
    wgt(nxv, nyv) = 0.25
    fgk = sum(wgt * fxy) / real(np)
    return
  end subroutine

!----------------------------------------------------------------------
  subroutine charged_LP_ecs(fxy, nxv, nyv, fgk, np)
    implicit none
    integer, intent(in) :: nxv, nyv, np
    real, dimension(nxv, nyv), intent(inout) :: fxy
    real, intent(inout) :: fgk

    ! local data
    real, parameter :: vDi = 1.0/3.0, vDe = -4.0/3.0
    real, parameter :: Te0 = 0.5/6.0, Ti0 = 0.5 - Te0
    real, parameter :: Tib = Ti0, Teb = Te0, nb = 0.2
    real, parameter :: epsln = 0.04
    real, parameter :: Lx = 16.0, Ly = 32.0
    real, dimension(nxv) :: x
    real, dimension(nyv) :: y
    real, dimension(nxv, nyv) :: pot, Az, wgt

    ! grid
    x = linspace(-Lx/2.0, Lx/2.0, nxv)
    y = linspace(-Ly, 0.0, nyv)
    ! get potential and vector potential
    call sol_ampere_poisson(pot, Az, x, y, nxv, nyv, &
      &vDi, Ti0, Tib, vDe, Te0, Teb, nb, epsln)

    ! distribution data
    fxy = exp((pot - vDe * Az) / Te0)

    ! density normalization factor
    wgt = 1.0
    wgt(1, :) = 0.5
    wgt(nxv, :) = 0.5
    wgt(:, 1) = 0.5
    wgt(:, nyv) = 0.5
    wgt(1, 1) = 0.25
    wgt(nxv, 1) = 0.25
    wgt(1, nyv) = 0.25
    wgt(nxv, nyv) = 0.25
    fgk = sum(wgt * fxy) / real(np)
    return
  end subroutine

!----------------------------------------------------------------------
  subroutine sol_ampere_poisson(pot, Az, x, y, nxv, nyv, &
      &vDi, Ti0, Tib, vDe, Te0, Teb, nb, epsln)
    implicit none
    integer, intent(in) :: nxv, nyv
    real, dimension(nxv, nyv), intent(inout) :: pot, Az
    real, dimension(nxv), intent(in) :: x
    real, dimension(nyv), intent(in) :: y
    real, intent(in) :: vDi, Ti0, Tib, vDe, Te0, Teb, nb, epsln

    ! local data
    real, dimension(nyv) :: pot0, Az0
    real, dimension(3, (nxv-1)/2+1) :: u
    real, dimension(3) :: u0
    integer :: j, nxhd
    integer :: ierr

    ! Az at x = 0
    Az0 = epsln * y
    ! pot at x = 0
    call get_bnd_pot(pot0, Az0, nyv, ierr, vDi, Ti0, Tib, vDe, Te0, Teb, nb)
    if (ierr == 1) write(*, *) 'rho_deriv is too small'
    if (ierr == 2) write(*, *) 'Newton method did not converge'
    ! write(*, *) (pot0(j), j = 1, nyv)

    nxhd = size(u, 2)
    do j = 1, nyv
      ! initial data
      u0 = (/Az0(j), 0.0, pot0(j)/)
      ! solve IVP
      call RK4(u, u0, x, nxhd, vDi, Ti0, Tib, vDe, Te0, Teb, nb)
      ! store data
      Az(nxhd:, j) = u(1, :)
      pot(nxhd:, j) = u(3, :)
      Az(:nxhd-1, j) = u(1, nxhd:2:-1)
      pot(:nxhd-1, j) = u(3, nxhd:2:-1)
    enddo
  end subroutine

!----------------------------------------------------------------------
  subroutine RK4(u, u0, xv, nxhd, vDi, Ti0, Tib, vDe, Te0, Teb, nb)
    implicit none
    integer, intent(in) :: nxhd
    real, dimension(3, nxhd), intent(inout) :: u
    real, dimension(3), intent(in) :: u0
    real, dimension(nxhd), intent(in) :: xv
    real, intent(in) :: vDi, Ti0, Tib, vDe, Te0, Teb, nb

    ! local data
    real :: dx
    real, dimension(3) :: F0, F1, F2, F3
    integer :: j

    ! step size
    dx = xv(2) - xv(1)
    ! initial data
    u(:, 1) = u0

    do j = 1, nxhd-1
      F0 = ampere_poisson_deriv(u(:, j),&
        &vDi, Ti0, Tib, vDe, Te0, Teb, nb)
      F1 = ampere_poisson_deriv(u(:, j) + 0.5 * dx * F0,&
        &vDi, Ti0, Tib, vDe, Te0, Teb, nb)
      F2 = ampere_poisson_deriv(u(:, j) + 0.5 * dx * F1,&
        &vDi, Ti0, Tib, vDe, Te0, Teb, nb)
      F3 = ampere_poisson_deriv(u(:, j) + dx * F2,&
        &vDi, Ti0, Tib, vDe, Te0, Teb, nb)
      u(:, j+1) = u(:, j) + dx * (F0 + 2.0 * F1 + 2.0 * F2 + F3) / 6.0
    enddo
    return
  end subroutine

!----------------------------------------------------------------------
  function ampere_poisson_deriv(u, vDi, Ti0, Tib, vDe, Te0, Teb, nb) result(dudx)
    ! Az = u[1]; By = u[2]; pot = u[3]
    implicit none
    ! output
    real, dimension(3) :: dudx
    ! input
    real, dimension(3), intent(in) :: u
    real, intent(in) :: vDi, Ti0, Tib, vDe, Te0, Teb, nb

    ! local data
    real :: exp_i0, exp_e0, exp_ib, exp_eb

    exp_i0 = exp((-u(3) + vDi * u(1)) / Ti0)
    exp_e0 = exp((u(3) - vDe * u(1)) / Te0)
    exp_ib = exp(-u(3) / Tib)
    exp_eb = exp(u(3) / Teb)

    ! d/dx (Az)
    dudx(1) = -u(2)
    ! d/dx (By)
    dudx(2) = vDi * exp_i0 - vDe * exp_e0
    ! d/dx (pot)
    dudx(3) = -u(2) * (vDi / Ti0 * exp_i0 + vDe / Te0 * exp_e0) &
      &/ (exp_i0 / Ti0 + nb * exp_ib / Tib + exp_e0 / Te0 + nb * exp_eb / Teb)
    return
  end function

!----------------------------------------------------------------------
  subroutine get_bnd_pot(pot, Az, nyv, ierr, vDi, Ti0, Tib, vDe, Te0, Teb, nb)
    ! find potential at the boundary using Newton's method
    implicit none
    integer, intent(in) :: nyv
    real, dimension(nyv), intent(inout) :: pot
    real, dimension(nyv), intent(in) :: Az
    integer, intent(inout) :: ierr
    real, intent(in) :: vDi, Ti0, Tib, vDe, Te0, Teb, nb

    ! local data
    integer, parameter :: maxiter = 20
    integer :: j, k
    real :: potg, pot_new, rho, rho_deriv
    logical :: sol

    ierr = 0
    do j = 1, nyv
      ! initial guess
      potg = 0.0
      sol = .false.
      do k = 1, maxiter
        rho = charge_density(potg, Az(j), vDi, Ti0, Tib, vDe, Te0, Teb, nb)
        rho_deriv = charge_density_deriv(potg, Az(j), vDi, Ti0, Tib,&
          & vDe, Te0, Teb, nb)
        ! check if denominator is too small
        if (abs(rho_deriv) < 1e-15) then
          ierr = 1
          return
        endif
        ! update pot_new
        pot_new = potg - rho / rho_deriv
        ! break loop if solution reaches convergence
        if (abs(pot_new - potg) < 1e-3) then
          sol = .true.
          exit
        endif
        ! update potg to iterate
        potg = pot_new
      enddo
      if (sol) then
        ! store data
        pot(j) = pot_new
      else
        ! Newton method did not converge
        ierr = 2
        return
      endif
    enddo
    return
  end subroutine

!----------------------------------------------------------------------
  function charge_density(pot, Az, vDi, Ti0, Tib, vDe, Te0, Teb, nb) result(rho)
    ! total charge density in Lembege-Pellat current sheet
    implicit none
    ! output
    real :: rho
    ! input
    real, intent(in) :: pot, Az, vDi, Ti0, Tib, vDe, Te0, Teb, nb

    rho = exp((-pot + vDi * Az) / Ti0) + nb * exp(-pot / Tib)&
      & - exp((pot - vDe * Az) / Te0) - nb * exp(pot / Teb)
    return
  end function

!----------------------------------------------------------------------
  function charge_density_deriv(pot, Az, vDi, Ti0, Tib, vDe, Te0, Teb, nb) &
      &result (rho_deriv)
    ! derivative of total charge density with respect to potential
    implicit none
    ! output
    real :: rho_deriv
    ! input
    real, intent(in) :: pot, Az, vDi, Ti0, Tib, vDe, Te0, Teb, nb

    rho_deriv = -exp((-pot + vDi * Az) / Ti0) / Ti0&
      & - nb * exp(-pot / Tib) / Tib&
      & - exp((pot - vDe * Az) / Te0) / Te0&
      & - nb * exp(pot / Teb) / Teb
    return
  end function
!
!
!----------------------------------------------------------------------
  function linspace(start, end, num) result(samples)
    implicit none
    ! input
    real, intent(in) :: start, end
    integer, intent(in) :: num
    ! output
    real, dimension(num) :: samples
    ! local data
    real :: step
    integer :: j

    step = (end - start) / real(num - 1)

    samples = (/ (start + (j - 1) * step, j = 1, num) /)
  end function
!
!
end module


module Mod_plcd_BMatrix_TotalLargeStrains_3D
   use typre
   use Mod_plcd_BMatrix
   use Mod_Element
   use Mod_Memor
   implicit none
   private
   public BMatrix_LSIS3D

   integer(ip), parameter :: ndofn = 3, nVoigtComponents = 6

   type, extends(BMatrix) :: BMatrix_LSIS3D

      real(rp), allocatable :: B(:,:,:)
      real(rp), allocatable :: Beta(:,:)
      real(rp), allocatable :: DisplacementGradient(:,:)
      integer(ip) :: pnode
contains
      procedure :: Alloc => Allocate_LSIS3D
      procedure :: Dealloc => DeAllocate_LSIS3D
      procedure :: Setup => Setup_LSIS3D
      procedure :: B_Times_Vector => B_Times_Vector_LSIS3D
      procedure :: Vector_Times_B => Vector_Times_B_LSIS3D
      procedure :: Bt_Times_Vector => Bt_Times_Vector_LSIS3D
      procedure :: Bt_Times_Matrix_Times_B => Bt_Times_Matrix_Times_B_LSIS3D
      procedure :: Betat_Times_Vector_Times_Beta => Betat_Times_Vector_Times_Beta_LSIS3D
      procedure :: SetDisplacementGradient => SetDisplacementGradient_LSIS3D

   end type

contains

   subroutine Allocate_LSIS3D(a,e,Memor)
      class(BMatrix_LSIS3D) :: a
      class(FiniteElement) :: e
      type(MemoryMan) :: Memor

      call Memor%alloc(nVoigtComponents,ndofn,e%mnode,a%B,'B','Allocate_LSIS3D')
      call Memor%alloc(ndofn,e%mnode,a%Beta,'Beta','Allocate_LSIS3D')
      call Memor%alloc(ndofn,ndofn,a%DisplacementGradient,'DisplacementGradient','Allocate_LSIS3D')

   end subroutine

   subroutine DeAllocate_LSIS3D(a,e,Memor)
      class(BMatrix_LSIS3D) :: a
      class(FiniteElement) :: e
      type(MemoryMan) :: Memor

      call Memor%dealloc(nVoigtComponents,ndofn,e%mnode,a%B,'B','DeAllocate_LSIS3D')
      call Memor%dealloc(ndofn,e%mnode,a%Beta,'Beta','DeAllocate_LSIS3D')
      call Memor%dealloc(ndofn,ndofn,a%DisplacementGradient,'DisplacementGradient','DeAllocate_LSIS3D')

   end subroutine

   subroutine Setup_LSIS3D(a,e)
      class(BMatrix_LSIS3D) :: a
      class(FiniteElement) :: e

      real(rp) :: F_mat(ndofn,ndofn)

      integer(ip) :: inode, idime

      a%pnode = e%pnode

      F_mat = 0.0_rp
      F_mat = a%DisplacementGradient
      forall(idime = 1:ndofn) F_mat(idime,idime) = F_mat(idime,idime) + 1.0_rp

      do inode = 1,e%pnode
         !B matrix for Material Term
         a%B(1,1,inode) =e%cartd(1,inode)*F_mat(1,1)
         a%B(1,2,inode) =e%cartd(1,inode)*F_mat(2,1)
         a%B(1,3,inode) =e%cartd(1,inode)*F_mat(3,1)
         a%B(2,1,inode) =e%cartd(2,inode)*F_mat(1,2)
         a%B(2,2,inode) =e%cartd(2,inode)*F_mat(2,2)
         a%B(2,3,inode) =e%cartd(2,inode)*F_mat(3,2)
         a%B(3,1,inode) =e%cartd(3,inode)*F_mat(1,3)
         a%B(3,2,inode) =e%cartd(3,inode)*F_mat(2,3)
         a%B(3,3,inode) =e%cartd(3,inode)*F_mat(3,3)
         !xy
         a%B(4,1,inode) =e%cartd(1,inode)*F_mat(1,2)+e%cartd(2,inode)*F_mat(1,1)
         a%B(4,2,inode) =e%cartd(1,inode)*F_mat(2,2)+e%cartd(2,inode)*F_mat(2,1)
         a%B(4,3,inode) =e%cartd(1,inode)*F_mat(3,2)+e%cartd(2,inode)*F_mat(3,1)
         !xz
         a%B(5,1,inode) =e%cartd(1,inode)*F_mat(1,3)+e%cartd(3,inode)*F_mat(1,1)
         a%B(5,2,inode) =e%cartd(1,inode)*F_mat(2,3)+e%cartd(3,inode)*F_mat(2,1)
         a%B(5,3,inode) =e%cartd(1,inode)*F_mat(3,3)+e%cartd(3,inode)*F_mat(3,1)
         !yz
         a%B(6,1,inode) =e%cartd(2,inode)*F_mat(1,3)+e%cartd(3,inode)*F_mat(1,2)
         a%B(6,2,inode) =e%cartd(2,inode)*F_mat(2,3)+e%cartd(3,inode)*F_mat(2,2)
         a%B(6,3,inode) =e%cartd(2,inode)*F_mat(3,3)+e%cartd(3,inode)*F_mat(3,2)

         !Beta matrix
         a%Beta(1,inode) = e%cartd(1,inode)
         a%Beta(2,inode) = e%cartd(2,inode)
         a%Beta(3,inode) = e%cartd(3,inode)

      enddo

      a%DisplacementGradient = 0.0_rp

   end subroutine

   subroutine Bt_Times_Matrix_Times_B_LSIS3D(a,input,output)
      class(BMatrix_LSIS3D), target :: a
      real(rp), intent(in) :: input(:,:)
      real(rp), intent(out), target :: output(*)

      real(rp), pointer :: B2D(:,:)
      real(rp), pointer :: Output2D(:,:)

      !input(nVoigtComponents,nVoigtComponents)
      !output(ndofn*e%pnode,ndofn*e%pnode)
      call Pointer2D3D(nVoigtComponents,ndofn,a%pnode,a%B,B2D)
      !B2D(1:nVoigtComponents,1:ndofn*a%pnode) => a%B(:,:,1:a%pnode)
      Output2D(1:ndofn*a%pnode,1:ndofn*a%pnode) => output(1:ndofn*ndofn*a%pnode*a%pnode)

      Output2D = matmul(transpose(B2D),matmul(input,B2D))
   end subroutine

   subroutine Betat_Times_Vector_Times_Beta_LSIS3D(a,input,output)
      class(BMatrix_LSIS3D), target :: a
      real(rp), intent(in) :: input(:)
      real(rp), intent(out), target :: output(:,:)

      real(rp) :: inputMatrixform(ndofn,ndofn)
      !Input is in fact the stress vector

      inputMatrixform = 0.0_rp

      inputMatrixform =  reshape([input(1),input(4),input(5),input(4),input(2),input(6),input(5),input(6),input(3)],&
      [ndofn,ndofn])

      output = matmul(transpose(a%Beta),matmul(inputMatrixform,a%Beta))

   end subroutine

   subroutine B_Times_Vector_LSIS3D(a,input,output)
      class(BMatrix_LSIS3D) :: a
      real(rp), intent(in) :: input(:)
      real(rp) :: output(:)

      call runend('B_Times_Vector_LSIS3D not ready')
   end subroutine

   subroutine Vector_Times_B_LSIS3D(a,input,output)
      class(BMatrix_LSIS3D) :: a
      real(rp), intent(in) :: input(:)
      real(rp) :: output(:)

       call runend('Vector_Times_B_LSIS3D not ready')
   end subroutine

   subroutine Bt_Times_Vector_LSIS3D(a,input,output)
      class(BMatrix_LSIS3D), target :: a
      real(rp), intent(in) :: input(:)
      real(rp), intent(out), target :: output(*)

      real(rp), pointer :: B2D(:,:)
      real(rp), pointer :: Output2D(:)

      call Pointer2D3D(nVoigtComponents,ndofn,a%pnode,a%B,B2D)
      !B2D(1:nVoigtComponents,1:ndofn*a%pnode) => a%B(:,:,1:a%pnode)
      Output2D(1:ndofn*a%pnode) => output(1:ndofn*a%pnode)

      Output2D = matmul(transpose(B2D),input)

   end subroutine

   subroutine Pointer2D3D(sizeunk1,sizeunk2,sizeunk3,unk,ppointer)
      use typre
      implicit none
      real(rp), target :: unk(*)
      real(rp), pointer :: ppointer(:,:)
      integer(ip) :: sizeunk1,sizeunk2,sizeunk3

      ppointer(1:sizeunk1,1:sizeunk2*sizeunk3) => unk(1:sizeunk1*sizeunk2*sizeunk3)
   end subroutine

   subroutine SetDisplacementGradient_LSIS3D(a,DisplacementGradient)
      class(BMatrix_LSIS3D), target :: a
      real(rp),intent(in) :: DisplacementGradient(:,:)

      a%DisplacementGradient = DisplacementGradient

   end subroutine

end module


subroutine fcho_solve(A,y,x)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:), intent(in) :: y
    double precision, dimension(:), intent(inout) :: x

    integer :: info, na

    na = size(A, dim=1)

    call dpotrf("U", na, A, na, info)
    call dpotrs("U", na, 1, A, na, y, na, info)

    x(:na) = y(:na)

end subroutine fcho_solve


module Mod_ZZErrorEstimator
   use typre
   use Mod_Mesh
   use Mod_Memor
   use Mod_Element
   implicit none
   private
   public ZZErrorEstimator, GradientErrorEstimator

contains

   subroutine ZZErrorEstimator(Mesh,Memor,ndofn,unkno,error)
      implicit none
      class(FemMesh) :: Mesh
      type(MemoryMan) :: Memor
      integer(ip) :: ndofn
      real(rp) :: unkno(:,:), error(:)

      class(FiniteElement), pointer :: e => NULL()
      real(rp), allocatable,  target :: gradient(:,:,:), elunk(:,:),grunk(:,:),elgrunk(:,:,:),gpgrunk(:,:),GrunkDiff(:,:)
      real(rp) :: DiffNorm,GrNorm,DiffNorm2
      real(rp) :: dvol
      integer(ip) :: ielem,nelem,ndime,npoin,inode,igaus

      call Mesh%GetNelem(nelem)

      call Mesh%ElementAlloc(e,Memor,'ForceClosedRule','ZZErrorEstimator')
      call Mesh%GetNdime(ndime)
      call Mesh%GetNpoin(npoin)
      call Memor%alloc(ndofn,ndime,npoin,gradient,'gradient','ZZErrorEstimator')
      call Memor%alloc(ndofn,ndime,grunk,'grunk','ZZErrorEstimator')
      call Memor%alloc(ndofn,ndime,e%mnode,elgrunk,'elgrunk','ZZErrorEstimator')
      call Memor%alloc(ndofn,ndime,gpgrunk,'gpgrunk','ZZErrorEstimator')
      call Memor%alloc(ndofn,ndime,GrunkDiff,'GrunkDiff','ZZErrorEstimator')
      call Memor%alloc(ndofn,e%mnode,elunk,'elunk','ZZErrorEstimator')

      !First loop: compute and project the gradient
      do ielem = 1,nelem
         !Load Element
         call Mesh%ElementLoad(ielem,e)

         !Cartesian derivatives and Jacobian at center of gravity
         call e%elmdcg
         dvol = e%detjm

         call e%gather(ndofn,elunk,unkno)
         call e%gradient(ndofn,elunk,grunk)

         elgrunk = 0.0_rp

         !Gauss Point Loop
         gauss_points : do igaus=1,e%pgaus
            e%igaus = igaus

            dvol = e%weigp(e%igaus)*e%detjm

            do inode = 1,e%pnode
               elgrunk(:,:,inode) = elgrunk(:,:,inode) + e%shape(inode,e%igaus)*grunk*dvol
            enddo
         enddo gauss_points

         call Mesh%AssemblyToArray(e,ndofn*e%ndime,elgrunk,gradient)
      enddo

      !Project onto the nodes
      call Mesh%Smooth(ndofn*e%ndime,gradient)

      !Second loop: compute the difference between the gradient and the projected gradient
      error(1:nelem) = 0

      !First loop: compute and project the gradient
      do ielem = 1,nelem
         !Load Element
         call Mesh%ElementLoad(ielem,e)

         !Cartesian derivatives and Jacobian at center of gravity
         call e%elmdcg
         dvol = e%detjm

         call e%gather(ndofn,elunk(:,:),unkno)
         call e%gradient(ndofn,elunk,grunk)

         call e%gather(e%ndime*ndofn,elgrunk,gradient)
         call e%interpc(e%ndime*ndofn,elgrunk,gpGrunk)

         GrunkDiff = grunk - gpGrunk

         !call vecnor(GrunkDiff,e%ndime*ndofn,DiffNorm,2)
         !call vecnor(gpGrunk,e%ndime*ndofn,GrNorm,2)
         !error(ielem) = DiffNorm/GrNorm

         !call vecnor(GrunkDiff,e%ndime*ndofn,DiffNorm,2)
         !error(ielem) = DiffNorm*dvol

         call dot(GrunkDiff,GrunkDiff,e%ndime*ndofn,DiffNorm2)
         error(ielem) = DiffNorm2*dvol

      enddo

      call Memor%dealloc(ndofn,ndime,npoin,gradient,'gradient','ZZErrorEstimator')
      call Memor%dealloc(ndofn,ndime,grunk,'grunk','ZZErrorEstimator')
      call Memor%dealloc(ndofn,ndime,e%mnode,elgrunk,'elgrunk','ZZErrorEstimator')
      call Memor%dealloc(ndofn,ndime,gpgrunk,'gpgrunk','ZZErrorEstimator')
      call Memor%dealloc(ndofn,ndime,GrunkDiff,'GrunkDiff','ZZErrorEstimator')
      call Memor%dealloc(ndofn,e%mnode,elunk,'elunk','ZZErrorEstimator')

      call Mesh%ElementDeAlloc(e,Memor,'ForceClosedRule','ZZErrorEstimator')

   end subroutine

   subroutine GradientErrorEstimator(Mesh,Memor,ndofn,unkno,error)
      use typre
      use Mod_Memor
      use Mod_Mesh
      use Mod_Element
      implicit none
      class(FemMesh) :: Mesh
      type(MemoryMan) :: Memor
      integer(ip) :: ndofn
      real(rp) :: unkno(:,:), error(:)

      class(FiniteElement), pointer :: e => NULL()
      real(rp), allocatable,  target ::  elunk(:,:),grunk(:,:)
      real(rp) :: grunknorm
      real(rp) :: dvol
      integer(ip) :: ielem,nelem,ndime,npoin,inode,igaus

      call Mesh%GetNelem(nelem)

      call Mesh%ElementAlloc(e,Memor,'ForceClosedRule','ZZErrorEstimator')
      call Mesh%GetNdime(ndime)
      call Mesh%GetNpoin(npoin)
      call Memor%alloc(ndofn,ndime,grunk,'grunk','ZZErrorEstimator')
      call Memor%alloc(ndofn,e%mnode,elunk,'elunk','ZZErrorEstimator')

      !First loop: compute and project the gradient
      do ielem = 1,nelem
         !Load Element
         call Mesh%ElementLoad(ielem,e)

         !Cartesian derivatives and Jacobian at center of gravity
         call e%elmdcg
         dvol = e%detjm

         call e%elmlen

         call e%gather(ndofn,elunk,unkno)
         call e%gradient(ndofn,elunk,grunk)

         call vecnor(grunk,e%ndime*ndofn,grunknorm,2)

         error(ielem) = grunknorm*(e%hleng(1)**2)
      enddo

      call Mesh%GetNdime(ndime)
      call Mesh%GetNpoin(npoin)
      call Memor%dealloc(ndofn,ndime,grunk,'grunk','ZZErrorEstimator')
      call Memor%dealloc(ndofn,e%mnode,elunk,'elunk','ZZErrorEstimator')

      call Mesh%ElementDeAlloc(e,Memor,'ForceClosedRule','ZZErrorEstimator')

   end subroutine
end module


MODULE ilupc_mod
  !----------------------------------------------------------------------
  !                   ILU Preconditioners Module
  !----------------------------------------------------------------------
  !    adapted from Sparskit Version 8/13/96
  ! Contents:
  ! ILUT    : Incomplete LU factorization with truncation and fill limit
  ! ILUK    : level-k ILU
  ! QSPLIT  : quick split routine used by ilut to sort out the k largest
  !           elements in absolute value
  !----------------------------------------------------------------------
  IMPLICIT NONE
  PUBLIC :: ilut, iluk, fill_stor
  PRIVATE :: qsplit

CONTAINS

  SUBROUTINE ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,ierr)
    !                      *** ILUT preconditioner ***
    !      incomplete LU factorization with truncation mechanism
    ! ... Adapted from  Yousef Saad 5/90 &  revision 8/96
    !----------------------------------------------------------------------
    ! Notes:
    ! The diagonal elements of the A matrix must be nonzero
    !----------------------------------------------------------------------
    !  We recommend using a nonzero droptol
    ! (droptol=.005 or .001 usually gives good results) in ILUT. Use a large
    ! lfil whenever possible (e.g. lfil = 5 to 10). The higher lfil the
    ! more reliable the code is. Efficiency may also be much improved.
    !---- Dual drop strategy works as follows.
    ! ... 1) Threshold in L and U is set by droptol. Any element whose
    ! ...    magnitude is less than the tolerance, droptol (relative to the abs
    ! ...    value of diagonal element in u) is dropped.
    ! ... 2) Keep only the largest lfil elements in the each row of L
    ! ...    and U (excluding diagonal elements).
    ! ...
    ! Flexibility: one  can use  droptol=0  to get  a strategy  based on
    ! keeping  the largest lfil elements in  each row  of L  and U.   Taking
    ! droptol > 0 and lfil = n will give  the usual threshold drop strategy
    ! (however, fill-in is then unpredictable).
    ! Note that lfil = n and droptol = 0 will yield the same factors as
    ! Gaussian elimination without pivoting.
    !----------------------------------------------------------------------
    USE machine_constants, ONLY: kdp
    USE GLOBAL, ONLY: iout
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n    ! ... The row dimension of A
    DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: a     ! ... Matrix A in compressed
    INTEGER, DIMENSION(:), INTENT(IN) :: ja           ! ... sparse row format
    INTEGER, DIMENSION(:), INTENT(IN) :: ia
    INTEGER, INTENT(IN) :: lfil         ! ...  fill-in parameter. Each row of L and
                                        ! ...    of U will have a maximum of lfil elements
                                        ! ...    (excluding the diagonal element). must be >= 0.
    DOUBLE PRECISION, INTENT(IN) :: droptol     ! ... the threshold for dropping small terms in
                                              ! ...   the factorization. See below for details.
    DOUBLE PRECISION, DIMENSION(:), INTENT(OUT) :: alu     ! ...  LU matrix stored in Modified
                                                         ! ...    Sparse Row (MSR) format
                                                         ! ...  The diagonal (stored in alu(1:n))
                                                         ! ...   is inverted. alu(n+1) is unused.
    INTEGER, DIMENSION(:), INTENT(OUT) :: jlu    ! ... Each i-th row of alu,jlu matrices
                                                 ! ...   contains the i-th row of L (excluding
                                                 ! ...   the unit diagonal) followed by the i-th
                                                 ! ...   row of U.
    INTEGER, DIMENSION(:), INTENT(OUT) :: ju     ! ... The pointers to the beginning of each row
                                                 ! ...   of U in the matrices alu,jlu
    INTEGER, INTENT(OUT) :: ierr     ! ... Error message flag
                                     ! ... 0 : successful factorizaton
                                     !    +i : zero pivot encountered at factorization step i
                                     !    -1 : input matrix may be wrong. The factorization
                                     ! ...     process has generated a row in L or U whose
                                     ! ...     length is greater than n
                                     !    -2 : The matrix L overflows the array alu
                                     !    -3 : The matrix U overflows the array alu
                                     !    -4 : Illegal value for lfil
                                     !    -5 : zero row encountered during factorization
    !
    ! ... Patch since automatic arrays clash with Java using Visual Fortran90 v6.0
!!$    DOUBLE PRECISION, DIMENSION(n+1), TARGET :: w     ! ... work array
    DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, TARGET :: w     ! ... work array
!!$    INTEGER, DIMENSION(2*n), TARGET :: jw           ! ... work array
    INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: jw           ! ... work array
    ! ...     w, jw (1:n) store the working array [1:ii-1 = L-part, ii:n = U-part]
    ! ...     jw(n+1:2n)  stores indices of nonzero elements
    DOUBLE PRECISION, DIMENSION(:), POINTER :: wp
    INTEGER, DIMENSION(:), POINTER :: jwp
    INTEGER :: ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,len
    INTEGER :: a_err, da_err
    DOUBLE PRECISION :: fact, s, t, tnorm
    ! ... Set string for use with RCS ident command
    CHARACTER(LEN=80) :: ident_string='$RCSfile: ilupc_mod.f90,v $//$Revision: 6461 $'
    !     ------------------------------------------------------------------
    !...
    IF (lfil < 0) THEN         ! ... illegal lfil entered.
       ierr = -4
       RETURN
    END IF
    ! ... allocate work space
    ALLOCATE(w(n+1), jw(2*n),  &
         STAT=a_err)
    IF (a_err /= 0) THEN
       PRINT *, "Array allocation failed: ilupc-ilut"
       ierr = -6
       RETURN
    ENDIF
    ! ... initialize ju0 (points to next element to be added to alu,jlu)
    ! ... and pointer array.
    ju0 = n+2
    jlu(1) = ju0
    alu = 0._kdp          !*** possibly necessary
!!$    ju = 0                ! *** possibly necessary
    ! ... initialize nonzero indicator array.
    DO  j=1,n
       jw(n+j)  = 0
    END DO
    DO  ii = 1, n             ! ... beginning of main loop.
       j1 = ia(ii)
       j2 = ia(ii+1) - 1
       tnorm = 0.0_kdp
       DO  k=j1,j2
          tnorm = tnorm+ABS(a(k))
       END DO
       IF (tnorm == 0.0_kdp) THEN              ! ... zero row encountered
          ierr = -5
          RETURN
       END IF
       tnorm = tnorm/REAL(j2-j1+1)
       ! ... unpack L-part and U-part of row of A into arrays w,jw
       lenu = 1
       lenl = 0
       jw(ii) = ii
       w(ii) = 0.0_kdp
       jw(n+ii) = ii
       DO  j = j1, j2
          k = ja(j)
          t = a(j)
          IF (k < ii) THEN
             lenl = lenl+1
             jw(lenl) = k
             w(lenl) = t
             jw(n+k) = lenl
          ELSE IF (k == ii) THEN
             w(ii) = t
          ELSE            ! ... k > ii
             lenu = lenu+1
             jpos = ii+lenu-1
             jw(jpos) = k
             w(jpos) = t
             jw(n+k) = jpos
          END IF
       END DO
       jj = 0
       len = 0
       ! ... eliminate previous rows
       DO
          jj = jj+1
          IF (jj > lenl) EXIT
          ! ... in order to do the elimination in the correct order we must select
          ! ... the smallest column index among jw(k), k=jj+1, ..., lenl.
          jrow = jw(jj)
          k = jj
          ! ... find the smallest column index
          DO  j=jj+1,lenl
             IF (jw(j) < jrow) THEN
                jrow = jw(j)
                k = j
             END IF
          END DO
          IF (k /= jj) THEN
             ! ... exchange in jw
             j = jw(jj)
             jw(jj) = jw(k)
             jw(k) = j
             ! ... exchange in jw_pointers
             jw(n+jrow) = jj
             jw(n+j) = k
             ! ... exchange in w
             s = w(jj)
             w(jj) = w(k)
             w(k) = s
          END IF
          ! ... zero out element in row by setting jw(n+jrow) to zero.
          jw(n+jrow) = 0
          ! ... get the multiplier for row to be eliminated (jrow).
          fact = w(jj)*alu(jrow)
          IF (ABS(fact) <= droptol) CYCLE
          ! ... combine current row and row jrow
          DO  k = ju(jrow), jlu(jrow+1)-1
             s = fact*alu(k)
             j = jlu(k)
             jpos = jw(n+j)
             IF (j >= ii) THEN                  ! ... dealing with upper part.
                IF (jpos == 0) THEN
                   ! ... this is a fill-in element
                   lenu = lenu+1
                   IF (lenu > n) THEN    ! ... incomprehensible error. Matrix must be wrong.
                      ierr = -1
                      RETURN
                   END IF
                   i = ii+lenu-1
                   jw(i) = j
                   jw(n+j) = i
                   w(i) = -s
                ELSE
                   ! ... this is not a fill-in element
                   w(jpos) = w(jpos) - s
                END IF
             ELSE                  ! ... dealing  with lower part.
                IF (jpos == 0) THEN
                   ! ... this is a fill-in element
                   lenl = lenl+1
                   IF (lenl > n) THEN       ! ... incomprehensible error. Matrix must be wrong.
                      ierr = -1
                      RETURN
                   END IF
                   jw(lenl) = j
                   jw(n+j) = lenl
                   w(lenl) = -s
                ELSE
                   ! ... this is not a fill-in element
                   w(jpos) = w(jpos) - s
                END IF
             END IF
          END DO
          ! ... store this pivot element -- (from left to right -- no danger of
          ! ... overlap with the working elements in L (pivots).
          len = len+1
          w(len) = fact
          jw(len)  = jrow
       END DO
       ! ... Reset double-pointer to zero (U-part)
       DO  k=1, lenu
          jw(n+jw(ii+k-1)) = 0
       END DO
       ! ... update L-matrix
       lenl = len
       len = MIN(lenl,lfil)
       ! ... sort by quick-split
       CALL qsplit(w,jw,lenl,len)
       ! ... store L-part
       DO  k=1, len
          IF (ju0 > SIZE(jlu)) THEN      ! ... insufficient storage in L.
             ierr = -2
             RETURN
          END IF
          alu(ju0) = w(k)
          jlu(ju0) = jw(k)
          ju0 = ju0+1
       END DO
       ! ... save pointer to beginning of row ii of U
       ju(ii) = ju0
       ! ... update U-matrix -- first apply dropping strategy
       len = 0
       DO k=1, lenu-1
          IF (ABS(w(ii+k)) > droptol*tnorm) THEN
             len = len+1
             w(ii+len) = w(ii+k)
             jw(ii+len) = jw(ii+k)
          END IF
       END DO
       lenu = len+1
       len = MIN(lenu,lfil)
       wp => w(ii+1:)
       jwp => jw(ii+1:)
       CALL qsplit(wp,jwp,lenu-1,len)
       ! ... copy
       t = ABS(w(ii))
       IF (len + ju0 > SIZE(jlu)) THEN    ! ... insufficient storage in U.
          ierr = -3
          RETURN
       END IF
       DO  k=ii+1,ii+len-1
          jlu(ju0) = jw(k)
          alu(ju0) = w(k)
          t = t + ABS(w(k))
          ju0 = ju0+1
       END DO
       ! ... store inverse of diagonal element of u
       IF (w(ii) == 0.0_kdp) w(ii) = (0.0001_kdp + droptol)*tnorm
       alu(ii) = 1.0_kdp/w(ii)
       ! ... set pointer to beginning of next row of U.
       jlu(ii+1) = ju0
    END DO                ! ... end main loop
    ierr = 0
    DEALLOCATE(w, jw,  &
         STAT=da_err)
    IF (da_err /= 0) THEN
       PRINT *, "Array deallocation failed: ilupc-ilut"
       ierr = -7
    ENDIF
  END SUBROUTINE ilut

  SUBROUTINE iluk(n,a,ja,ia,lfil,alu,jlu,ju,ierr)
    ! ...                  *** ILUK preconditioner ***
    ! ...  incomplete LU factorization with level of fill in of K; ILU(k)
    !----------------------------------------------------------------------
    ! Notes/known bugs: Storage is not efficient.
    ! ...   For example: Only the part of the array levs associated with
    ! ...   the U-matrix is needed in the routine. So some storage can
    ! ...   be saved if needed. The levels of fills in the LU matrix are
    ! ...   output for information only -- they are not needed by LU-solve.
    !----------------------------------------------------------------------
    ! Notes:
    ! All the diagonal elements of the A matrix must be  nonzero.
    !----------------------------------------------------------------------
    USE machine_constants, ONLY: kdp
    USE global, only: iout
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n    ! ... The row dimension of A
    DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: a     ! ... Matrix A in compressed
    INTEGER, DIMENSION(:), INTENT(IN) :: ja           ! ... sparse row format
    INTEGER, DIMENSION(:), INTENT(IN) :: ia
    INTEGER, INTENT(IN) :: lfil         ! ...  fill-in parameter. Each row of L and
                                        ! ...    of U will have lfil levels of fill-in
                                        ! ...    (excluding the diagonal element). must be >= 0.
    DOUBLE PRECISION, DIMENSION(:), INTENT(OUT) :: alu     ! ...  LU matrix stored in Modified
                                                         ! ...    Sparse Row (MSR) format
                                                         ! ...  The diagonal (stored in alu(1:n))
                                                         ! ...   is inverted. alu(n+1) is unused.
    INTEGER, DIMENSION(:), INTENT(OUT) :: jlu    ! ... Each i-th row of alu,jlu matrices
                                                 ! ...   contains the i-th row of L (excluding
                                                 ! ...   the unit diagonal) followed by the i-th
                                                 ! ...   row of U.
    INTEGER, DIMENSION(:), INTENT(OUT) :: ju     ! ... The pointers to the beginning of each row
                                                 ! ...   of U in the matrices alu,jlu
    INTEGER, INTENT(OUT) :: ierr     ! ... Error message flag
                                     ! ... 0 : successful factorizaton
                                     !    +i : zero pivot encountered at factorization step i
                                     !    -1 : input matrix may be wrong. The factorization
                                     ! ...     process has generated a row in L or U whose
                                     ! ...     length is greater than n
                                     !    -2 : The matrix L overflows the array alu
                                     !    -3 : The matrix U overflows the array alu
                                     !    -4 : Illegal value for lfil
                                     !    -5 : zero row encountered during factorization
    !
    ! ... Patch since automatic arrays clash with Java using Visual Fortran90 v6.0
!!$    DOUBLE PRECISION, DIMENSION(n) :: w     ! ... work array
    DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: w     ! ... work array
!!$    INTEGER, DIMENSION(3*n) :: jw           ! ... work array
    INTEGER, DIMENSION(:), ALLOCATABLE :: jw           ! ... work array
    ! ...     w, jw (1:n) store the working array [1:ii-1 = L-part, ii:n = U-part]
    ! ...     jw(n+1:2n)  stores indices of nonzero elements
!!$    INTEGER, DIMENSION(SIZE(jlu)) :: levs   ! ... work array. Level of fill for elements
    INTEGER, DIMENSION(:), ALLOCATABLE :: levs   ! ... work array. Level of fill for elements
                                            ! ...   in alu, jlu; could be passed to caller
    INTEGER :: ju0, k, j1, j2, j, ii, i, lenl, lenu, jj, jrow, jpos, n2, jlev
    INTEGER :: a_err, da_err
    DOUBLE PRECISION :: t, s, fact
    ! ... Set string for use with RCS ident command
    CHARACTER(LEN=80) :: ident_string='$RCSfile: ilupc_mod.f90,v $//$Revision: 6461 $'
    ! ... ------------------------------------------------------------------
    !...
    IF (lfil < 0) THEN         ! ... illegal lfil entered
       ierr = -4
       RETURN
    END IF
    ! ... allocate work space
    ALLOCATE(w(n), jw(3*n), levs(SIZE(jlu)),  &
         STAT=a_err)
    IF (a_err /= 0) THEN
       PRINT *, "Array allocation failed: ilupc-iluk"
       ierr = -6
       RETURN
    ENDIF
    ! ... initialize ju0 (points to next element to be added to alu,jlu)
    ! ... and pointer array
    n2 = n+n
    ju0 = n+2
    jlu(1) = ju0
    alu = 0._kdp          !*** possibly necessary
    ju = 0                ! *** possibly necessary
    ! ... initialize nonzero indicator jw array and jw_levs subarray
    DO  j=1,2*n
       jw(j)  = 0
    END DO
    DO  ii = 1, n             ! ... beginning of main loop.
       j1 = ia(ii)
       j2 = ia(ii+1) - 1
       ! ... unpack L-part and U-part of row of A into arrays w,jw
       lenu = 1
       lenl = 0
       jw(ii) = ii
       w(ii) = 0.0_kdp
       jw(n+ii) = ii
       DO   j = j1, j2
          k = ja(j)
          t = a(j)
!!$          IF (t == 0.0_kdp) CYCLE
          IF (k < ii) THEN
             lenl = lenl+1
             jw(lenl) = k
             w(lenl) = t
             jw(n2+lenl) = 0
             jw(n+k) = lenl
          ELSE IF (k == ii) THEN
             w(ii) = t
             jw(n2+ii) = 0
          ELSE            ! ... k > ii
             lenu = lenu+1
             jpos = ii+lenu-1
             jw(jpos) = k
             w(jpos) = t
             jw(n2+jpos) = 0
             jw(n+k) = jpos
          END IF
       END DO
       jj = 0
       ! ... eliminate previous rows
       DO
          jj = jj+1
          IF (jj > lenl) EXIT
          ! ... in order to do the elimination in the correct order we must select
          ! ... the smallest column index among jw(k), k=jj+1, ..., lenl.
          jrow = jw(jj)
          k = jj
          ! ... determine smallest column index
          DO  j=jj+1,lenl
             IF (jw(j) < jrow) THEN
                jrow = jw(j)
                k = j
             END IF
          END DO
          IF (k /= jj) THEN
             ! ... exchange in jw
             j = jw(jj)
             jw(jj) = jw(k)
             jw(k) = j
             ! ... exchange in jw_pointers
             jw(n+jrow) = jj
             jw(n+j) = k
             ! ... exchange in jw_levels
             j = jw(n2+jj)
             jw(n2+jj)  = jw(n2+k)
             jw(n2+k) = j
             ! ... exchange in w
             s = w(jj)
             w(jj) = w(k)
             w(k) = s
          END IF
          ! ... zero out element in row by resetting jw(n+jrow) to zero.
          jw(n+jrow) = 0
          ! ... get the multiplier for row to be eliminated (jrow) and its level
          fact = w(jj)*alu(jrow)
          jlev = jw(n2+jj)
          IF (jlev > lfil) CYCLE
          ! ... combine current row and row jrow
          DO  k = ju(jrow), jlu(jrow+1)-1
             s = fact*alu(k)
             j = jlu(k)
             jpos = jw(n+j)
             IF (j >= ii) THEN                ! ... dealing with upper part.
                IF (jpos == 0) THEN
                   ! ... this is a fill-in element
                   lenu = lenu+1
                   IF (lenu > n) THEN    ! ... incomprehensible error. Matrix must be wrong.
                      ierr = -1
                      RETURN
                   END IF
                   i = ii+lenu-1
                   jw(i) = j
                   jw(n+j) = i
                   w(i) = -s
                   jw(n2+i) = jlev+levs(k)+1
                ELSE
                   ! ... this is not a fill-in element
                   w(jpos) = w(jpos) - s
                   jw(n2+jpos) = MIN(jw(n2+jpos),jlev+levs(k)+1)
                END IF
             ELSE                ! ... dealing with lower part.
                IF (jpos == 0) THEN
                   ! ... this is a fill-in element
                   lenl = lenl+1
                   IF (lenl > n) THEN       ! ... incomprehensible error. Matrix must be wrong.
                      ierr = -1
                      RETURN
                   END IF
                   jw(lenl) = j
                   jw(n+j) = lenl
                   w(lenl) = -s
                   jw(n2+lenl) = jlev+levs(k)+1
                ELSE
                   ! ... this is not a fill-in element
                   w(jpos) = w(jpos) - s
                   jw(n2+jpos) = MIN(jw(n2+jpos),jlev+levs(k)+1)
                END IF
             END IF
          END DO
          w(jj) = fact
          jw(jj) = jrow
       END DO
       ! ... Reset double-pointer to zero (U-part)
       DO  k=1, lenu
          jw(n+jw(ii+k-1)) = 0
       END DO
       ! ... update L-matrix
       DO  k=1, lenl
          IF (ju0 > SIZE(jlu)) THEN      ! ... insufficient storage in L.
             ierr = -2
             RETURN
          END IF
          IF (jw(n2+k) <= lfil) THEN
             alu(ju0) = w(k)
             jlu(ju0) = jw(k)
             ju0 = ju0+1
          END IF
       END DO
       ! ... save pointer to beginning of row ii of U
       ju(ii) = ju0
       ! ... update U-matrix
       DO  k=ii+1,ii+lenu-1
          IF (jw(n2+k) <= lfil) THEN
             jlu(ju0) = jw(k)
             alu(ju0) = w(k)
             levs(ju0) = jw(n2+k)
             ju0 = ju0+1
          END IF
       END DO
       ! ... store inverse of diagonal element of u
       IF (w(ii) == 0.0_kdp) THEN    ! ... zero row encountered in A or U.
          ierr = -5
          RETURN
       END IF
       alu(ii) = 1.0_kdp/w(ii)
       ! ... update pointer to beginning of next row of U.
       jlu(ii+1) = ju0
    END DO       ! ... end main loop
    ierr = 0
    DEALLOCATE(w, jw, levs,  &
         STAT=da_err)
    IF (da_err /= 0) THEN
       PRINT *, "Array deallocation failed: ilupc-iluk"
       ierr = -7
    ENDIF
  END SUBROUTINE iluk

  SUBROUTINE qsplit(a,ind,n,ncut)
    !-----------------------------------------------------------------------
    ! ... does a quick-sort split of a real array.
    ! ... on input a(1:n). is a real array
    ! ... on output a(1:n) is permuted such that its elements satisfy:

    ! ... abs(a(i)) >= abs(a(ncut)) for i < ncut and
    ! ... abs(a(i)) <= abs(a(ncut)) for i > ncut

    ! ... ind(1:n) is an integer array which permuted in the same way as a.
    !-----------------------------------------------------------------------
    USE machine_constants, ONLY: kdp
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n
    DOUBLE PRECISION, DIMENSION(:), INTENT(IN OUT) :: a
    INTEGER, DIMENSION(:), INTENT(IN OUT) :: ind
    INTEGER, INTENT(IN) :: ncut
    !
    INTEGER :: j, mid
    DOUBLE PRECISION :: tmp, abskey
    INTEGER :: itmp, first, last
    ! ... Set string for use with RCS ident command
    CHARACTER(LEN=80) :: ident_string='$RCSfile: ilupc_mod.f90,v $//$Revision: 6461 $'
    ! ... ------------------------------------------------------------------
    !...
    first = 1
    last = n
    IF (ncut < first .OR. ncut > last) RETURN
    ! ... outer loop -- while mid \= ncut do
    DO
       mid = first
       abskey = ABS(a(mid))
       DO  j=first+1, last
          IF (ABS(a(j)) > abskey) THEN
             mid = mid+1
             ! ... interchange
             tmp = a(mid)
             itmp = ind(mid)
             a(mid) = a(j)
             ind(mid) = ind(j)
             a(j)  = tmp
             ind(j) = itmp
          END IF
       END DO
       ! ... interchange
       tmp = a(mid)
       a(mid) = a(first)
       a(first)  = tmp
       itmp = ind(mid)
       ind(mid) = ind(first)
       ind(first) = itmp
       IF (mid == ncut) EXIT     ! ... normal exit
       IF (mid > ncut) THEN
          last = mid-1
       ELSE
          first = mid+1
       END IF
    END DO
  END SUBROUTINE qsplit

  SUBROUTINE fill_stor(n,ja,ia,levfill,nnz_fill)
    ! ... Compute the total ILU storage needed with the k-level of fill specified
    ! ... Uses diagonal storage of the ff array of fill indices
    ! ... Fill indices are integers such that the ILU with level k fill has
    ! ...    non-zero elements at positions corresponding to positions in ff
    ! ...    where ff <= k+1
    !-----------------------------------------------------------------
!!$    USE machine_constants, ONLY: kdp
!    USE control, ONLY: ierr   RGN commented this
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n       ! ... The row dimension of A
    INTEGER, DIMENSION(:), INTENT(IN) :: ja   ! ... Column index of A in CSR format
    INTEGER, DIMENSION(:), INTENT(IN) :: ia ! ... Row index of A in CSR format
    INTEGER, INTENT(IN) :: levfill            ! ... level of fill specified
    INTEGER, INTENT(OUT) :: nnz_fill          ! ... number of array elements needed
    ! ...   to store ILU in MSR format
    !
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: ff     ! ... work array of fill levels
    INTEGER :: a_err, da_err, bw, bwl, bwu, ffmin, i, j, jp, jpt, k, t, tp
    !
    ! ... Set string for use with RCS ident command
    CHARACTER(LEN=80) :: ident_string='$RCSfile: ilupc_mod.f90,v $//$Revision: 6461 $'
    ! ... ------------------------------------------------------------------
    !...
    ! ... Determine bandwidth and allocate ff array
    CALL bandwidth(n,ja,ia,bwl,bwu)
    bw = bwl           ! ... symmetric incidence matrix assumed
    ALLOCATE(ff(n,-bw:bw),  &
         STAT=a_err)
    IF (a_err /= 0) THEN
       PRINT *, "Array allocation failed: fill_stor"
!       ierr(199) = .TRUE.
       RETURN
    ENDIF
    ff = 0
    ! ... Load ff with the non-zero pattern of matrix a
    DO i=1,n
       DO k=ia(i),ia(i+1)-1
          ff(i,ja(k)-i) = 1
       END DO
    END DO
    ! ... Load ff with level of fill indices
    DO i=1,n
       DO j=MAX(i-bw,1),MIN(i+bw,n)
          jp = j-i
          IF((i == 1 .OR. j == 1) .AND. ff(i,jp) == 0) THEN
             ff(i,jp) = 1000     ! ... border elements not ever filled
          ELSEIF(jp == 0) THEN
             ff(i,jp) = 0     ! ... diagonal
          ELSEIF(ff(i,jp) ==1) THEN
             CYCLE            ! ... original incidence
          ELSE     ! ... find fill level
             ffmin = 2000
             DO t=MAX(i-bw,j-bw,1),MIN(i,j)-1
                tp = t-i
                jpt = j-t
                ffmin = MIN(ffmin,(ff(i,tp)+ff(t,jpt)))
             END DO
             ff(i,jp) = ffmin
          END IF
       END DO
    END DO
    ! ... Restore the original incidence flag of the main diagonal for counting
    DO i=1,n
       ff(i,0) = 1
    END DO
    ! ... Count the number of non-zero elements in ff
    nnz_fill = 0
    DO i=1,n
       DO jp=MAX(i-bw,1)-i,MIN(i+bw,n)-i      ! ... don't count outside triangles
          IF(ff(i,jp) > 0 .AND. ff(i,jp) <= levfill+1) nnz_fill = nnz_fill+1
       END DO
    END DO
    DEALLOCATE(ff,  &
         stat=da_err)
    IF (da_err /= 0) THEN
       PRINT *, "Array deallocation failed: fill_stor"
!       ierr(193) = .TRUE.
       RETURN
    ENDIF

  CONTAINS

    SUBROUTINE bandwidth(n,ja,ia,ml,mu)
      ! ... Computes the lower and upper bandwidths of matrix in CSR format
      ! ... adapted from Y.Saad Sparskit 7/2001
      !-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: n       ! ... The row dimension of A
      INTEGER, DIMENSION(:), INTENT(IN) :: ja           ! ... column index array
      INTEGER, DIMENSION(:), INTENT(IN) :: ia         ! ... row index array
                                                      ! ...  for sparse row format
      INTEGER, INTENT(OUT) :: ml, mu                ! ... bandwidths; lower, upper
      !
      INTEGER :: i, jminc, jmaxc, k
      ! ... ------------------------------------------------------------------
      ml = -n
      mu = -n
      DO  i=1,n
         jminc = n
         jmaxc = 1
         DO k=ia(i),ia(i+1)-1
            jminc = MIN(jminc,ja(k))
            jmaxc = MAX(ja(k),jmaxc)
         END DO
         ml = MAX(ml,i-jminc)
         mu = MAX(mu,jmaxc-i)
      END DO
    END SUBROUTINE bandwidth

  END SUBROUTINE fill_stor

END MODULE ilupc_mod


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!           Authors: Vitaliy Ogarko, Jeremie Giraud, Roland Martin.
!
!               (c) 2021 The University of Western Australia.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!================================================================================================
! A class to smooth the initial model.
! This is needed e.g. for cross-gradient joint inversion to have non-zero gradients.
!
! Vitaliy Ogarko, UWA, CET, Australia, 2015-2016.
!================================================================================================
module filter

  use global_typedefs
  use mpi_tools, only: exit_MPI
  use model

  implicit none

  private

  type, public :: t_filter
    private

  contains
    private

    procedure, public, nopass :: apply_Gaussian_filter => apply_Gaussian_filter

  end type t_filter

contains

!======================================================================================================
! Applies Gaussian filter to the model.
! sigma - standard deviation.
! lfgauss - size of the Gaussian window.
! type: 1 - arithmetic average, 2 - log-average (same as geometric mean).
!======================================================================================================
subroutine apply_Gaussian_filter(model, lfgauss, sigma, type, myrank)
  integer, intent(in) :: lfgauss
  real(kind=CUSTOM_REAL), intent(in) :: sigma
  integer, intent(in) :: type, myrank
  type(t_model), intent(inout) :: model

  integer :: i_line
  integer :: i_line_1
  integer :: i, j, k
  integer :: i1, j1, k1
  integer :: nbx, nby, nbz
  integer :: ierr
  real(kind=CUSTOM_REAL) :: lx, ly, lz, dx, dy, dz, avg_cell_size
  real(kind=CUSTOM_REAL) :: dx1_square, dy1_square, dz1_square
  real(kind=CUSTOM_REAL) :: gauss, gauss_const, scale

  real(kind=CUSTOM_REAL), allocatable :: model_temp(:)

  allocate(model_temp(model%nelements_total), source=0._CUSTOM_REAL, stat=ierr)

  if (ierr /= 0) call exit_MPI("Dynamic memory allocation error in apply_Gaussian_filter!", myrank, ierr)

  gauss_const = 1.d0 / (2.d0 * PI * sigma**2)

  dx = model%grid_full%get_hx()
  dy = model%grid_full%get_hy()
  dz = model%grid_full%get_hz()

  avg_cell_size = (dx + dy + dz) / 3.d0

  ! The distance is measured in the units of (average) cell size.
  ! Note: we assume same cell sizes along one dimension.
  lx = dx / avg_cell_size
  ly = dy / avg_cell_size
  lz = dz / avg_cell_size

  nbx = model%grid_full%nx
  nby = model%grid_full%ny
  nbz = model%grid_full%nz

  model_temp = 0.d0

  do k = 1, nbz
    do j = 1, nby
      do i = 1, nbx
        i_line = model%grid_full%ind(i, j, k)

        scale = 0.d0

        do k1 = max(k - lfgauss, 1), min(k + lfgauss, nbz)
          dz1_square = (dble(k1 - k) * lz)**2

          do j1 = max(j - lfgauss, 1), min(j + lfgauss, nby)
            dy1_square = (dble(j1 - j) * ly)**2

            do i1 = max(i - lfgauss, 1), min(i + lfgauss, nbx)
              dx1_square = (dble(i1 - i) * lx)**2

              gauss = gauss_const * exp(- (dx1_square + dy1_square + dz1_square) / (2.d0 * sigma**2))

              i_line_1 = model%grid_full%ind(i1, j1, k1)

              if (type == 1) then
              ! Arithmetic average.
                model_temp(i_line) = model_temp(i_line) + gauss * model%val_full(i_line_1)

              else if (type == 2) then
              ! Log-average.
                if (model%val_full(i_line_1) > 0.d0) then
                  model_temp(i_line) = model_temp(i_line) + gauss * log(model%val_full(i_line_1))
                else
                  print *, 'Bad log argument in apply_Gaussian_filter!'
                  stop
                endif
              endif

              scale = scale + gauss
            enddo
          enddo
        enddo

        model_temp(i_line) = model_temp(i_line) / scale

      enddo
    enddo
  enddo

  if (type == 1) then
    model%val_full = model_temp
  else if (type == 2) then
    model%val_full = exp(model_temp)
  endif

  deallocate(model_temp)

end subroutine apply_Gaussian_filter

end module filter


module mod_monolis_precond_diag_nn
  use mod_monolis_prm
  use mod_monolis_com
  use mod_monolis_mat

  implicit none

  private
  public :: monolis_precond_diag_nn_setup
  public :: monolis_precond_diag_nn_apply
  public :: monolis_precond_diag_nn_clear

contains

  subroutine monolis_precond_diag_nn_setup(monoMAT)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kint) :: i, ii, j, jS, jE, in, k, l, N, NDOF, NDOF2
    integer(kint), pointer :: index(:), item(:)
    real(kdouble), allocatable :: T(:), LU(:,:)
    real(kdouble), pointer :: A(:), ALU(:)

    N =  monoMAT%N
    NDOF  = monoMAT%NDOF
    NDOF2 = NDOF*NDOF
    A => monoMAT%A
    index => monoMAT%index
    item => monoMAT%item

    allocate(T(NDOF), source = 0.0d0)
    allocate(LU(NDOF,NDOF), source = 0.0d0)
    allocate(monoMAT%monoTree%D(NDOF2*N), source = 0.0d0)
    ALU => monoMAT%monoTree%D

    do i = 1, N
      jS = index(i-1) + 1
      jE = index(i)
      do ii = jS, jE
        in = item(ii)
        if(i == in)then
          do j = 1, NDOF
            do k = 1, NDOF
              LU(j,k) = A(NDOF2*(ii-1) + NDOF*(j-1) + k)
            enddo
          enddo

          do k = 1, NDOF
            if(LU(k,k) == 0.0d0) stop "** monolis error: zero diag in monolis_precond_diag_nn_setup"
            LU(k,k) = 1.0d0/LU(k,k)
            do l = k+1, NDOF
              LU(l,k) = LU(l,k)*LU(k,k)
              do j = k+1, NDOF
                T(j) = LU(l,j) - LU(l,k)*LU(k,j)
              enddo
              do j = k+1, NDOF
                LU(l,j) = T(j)
              enddo
            enddo
          enddo
          do j = 1, NDOF
            do k = 1, NDOF
              ALU(NDOF2*(i-1) + NDOF*(j-1) + k) = LU(j,k)
            enddo
          enddo
        endif
      enddo
    enddo

    deallocate(T)
    deallocate(LU)
  end subroutine monolis_precond_diag_nn_setup

  subroutine monolis_precond_diag_nn_apply(monoMAT, X, Y)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kint) :: i, j, k, N, NDOF, NDOF2
    real(kdouble) :: X(:), Y(:)
    real(kdouble), pointer :: ALU(:)
    real(kdouble), allocatable :: T(:)

    N     = monoMAT%N
    NDOF  = monoMAT%NDOF
    NDOF2 = NDOF*NDOF
    ALU => monoMAT%monoTree%D

    allocate(T(NDOF))
    T = 0.0d0

    do i = 1, N
      do j = 1, NDOF
        T(j) = X(NDOF*(i-1) + j)
      enddo
      do j = 2, NDOF
        do k = 1, j-1
          T(j) = T(j) - ALU(NDOF2*(i-1) + NDOF*(j-1) + k)*T(k)
        enddo
      enddo
      do j = NDOF, 1, -1
        do k = NDOF, j+1, -1
          T(j) = T(j) - ALU(NDOF2*(i-1) + NDOF*(j-1) + k)*T(k)
        enddo
        T(j) = ALU(NDOF2*(i-1) + (NDOF+1)*(j-1) + 1)*T(j)
      enddo
      do k = 1, NDOF
        Y(NDOF*(i-1) + k) = T(k)
      enddo
    enddo

    deallocate(T)
  end subroutine monolis_precond_diag_nn_apply

  subroutine monolis_precond_diag_nn_clear(monoMAT)
    implicit none
    type(monolis_mat) :: monoMAT
    deallocate(monoMAT%monoTree%D)
  end subroutine monolis_precond_diag_nn_clear

end module mod_monolis_precond_diag_nn


      subroutine addsgd4( dt, h, up, u, um, rho,
     *     dcx, dcy, dcz, strx, stry, strz, cox, coy, coz,
     *     ifirst, ilast, jfirst, jlast, kfirst, klast, beta )

***********************************************************************
*** Version with correct density scaling and supergrid stretching.
*** cox, coy, coz are corner factors that reduce the damping near edges and corners
***
***********************************************************************

	implicit none
	integer ifirst, ilast, jfirst, jlast, kfirst, klast
	real*8 dt, h
	real*8  u(3,ifirst:ilast,jfirst:jlast,kfirst:klast)
	real*8 um(3,ifirst:ilast,jfirst:jlast,kfirst:klast)
	real*8 up(3,ifirst:ilast,jfirst:jlast,kfirst:klast)
	real*8  rho(ifirst:ilast,jfirst:jlast,kfirst:klast)
	real*8 dcx(ifirst:ilast), strx(ifirst:ilast), cox(ifirst:ilast)
	real*8 dcy(jfirst:jlast), stry(jfirst:jlast), coy(jfirst:jlast)
	real*8 dcz(kfirst:klast), strz(kfirst:klast), coz(kfirst:klast)
	real*8 beta

c time stepping stability condition on beta?

c this routine uses un-divided differences in x and t
	real*8 coeff, irho

	integer i, j, k, c

	if( beta .eq. 0d0 ) return

	coeff = beta
c beta is the supergrid damping coefficient as entered in the input file
c
c add in the SG damping
c
c There are enough ghost points to always use the interior formula
c
c the corner tapering is applied by replacing
c strx -> strx*coy(j)*coz(k)
c stry -> stry*cox(i)*coz(k)
c strz -> strz*cox(i)*coy(j)
c
c approximately 375 a.o.
c
!$OMP PARALLEL PRIVATE(k,i,j,c,irho)
!$OMP DO
	do k=kfirst+2,klast-2
	  do j=jfirst+2,jlast-2
	    do i=ifirst+2, ilast-2
              irho = 1/rho(i,j,k)
	      do c=1,3
		 up(c,i,j,k) = up(c,i,j,k) - irho*coeff*(
c x-differences
     + strx(i)*coy(j)*coz(k)*(
     +  rho(i+1,j,k)*dcx(i+1)*
     *              ( u(c,i+2,j,k) -2*u(c,i+1,j,k)+ u(c,i,  j,k))
     + -2*rho(i,j,k)*dcx(i)  *
     *              ( u(c,i+1,j,k) -2*u(c,i,  j,k)+ u(c,i-1,j,k))
     + +rho(i-1,j,k)*dcx(i-1)*
     *              ( u(c,i,  j,k) -2*u(c,i-1,j,k)+ u(c,i-2,j,k))
     + -rho(i+1,j,k)*dcx(i+1)*
     *              (um(c,i+2,j,k)-2*um(c,i+1,j,k)+um(c,i,  j,k))
     + +2*rho(i,j,k)*dcx(i)  *
     *              (um(c,i+1,j,k)-2*um(c,i,  j,k)+um(c,i-1,j,k))
     + -rho(i-1,j,k)*dcx(i-1)*
     *              (um(c,i,  j,k)-2*um(c,i-1,j,k)+um(c,i-2,j,k)) ) +
c y-differences
     + stry(j)*cox(i)*coz(k)*(
     + +rho(i,j+1,k)*dcy(j+1)*
     *              ( u(c,i,j+2,k) -2*u(c,i,j+1,k)+ u(c,i,j,  k))
     + -2*rho(i,j,k)*dcy(j)  *
     *              ( u(c,i,j+1,k) -2*u(c,i,j,  k)+ u(c,i,j-1,k))
     + +rho(i,j-1,k)*dcy(j-1)*
     *              ( u(c,i,j,  k) -2*u(c,i,j-1,k)+ u(c,i,j-2,k))
     + -rho(i,j+1,k)*dcy(j+1)*
     *              (um(c,i,j+2,k)-2*um(c,i,j+1,k)+um(c,i,j,  k))
     + +2*rho(i,j,k)*dcy(j)  *
     *              (um(c,i,j+1,k)-2*um(c,i,j,  k)+um(c,i,j-1,k))
     + -rho(i,j-1,k)*dcy(j-1)*
     *              (um(c,i,j,  k)-2*um(c,i,j-1,k)+um(c,i,j-2,k)) ) +
     +  strz(k)*cox(i)*coy(j)*(
c z-differences
     + +rho(i,j,k+1)*dcz(k+1)*
     *            ( u(c,i,j,k+2) -2*u(c,i,j,k+1)+ u(c,i,j,k  ))
     + -2*rho(i,j,k)*dcz(k)  *
     *            ( u(c,i,j,k+1) -2*u(c,i,j,k  )+ u(c,i,j,k-1))
     + +rho(i,j,k-1)*dcz(k-1)*
     *            ( u(c,i,j,k  ) -2*u(c,i,j,k-1)+ u(c,i,j,k-2))
     + -rho(i,j,k+1)*dcz(k+1)*
     *            (um(c,i,j,k+2)-2*um(c,i,j,k+1)+um(c,i,j,k  ))
     + +2*rho(i,j,k)*dcz(k)  *
     *            (um(c,i,j,k+1)-2*um(c,i,j,k  )+um(c,i,j,k-1))
     + -rho(i,j,k-1)*dcz(k-1)*
     *            (um(c,i,j,k  )-2*um(c,i,j,k-1)+um(c,i,j,k-2)) )
     + )
*** TOTAL 125 ops for each component = 375 ops per grid point.
***       3x26  3D array accesses (u,um), 7 rho, gives = 85 elements of 3D arrays per grid point.
	      enddo
	    enddo
	  enddo
	enddo
!$OMP END DO
!$OMP END PARALLEL
	end


MODULE POISSON_PRO

USE MPI
USE BASIS
USE PARAM, ONLY: M, N

IMPLICIT NONE

CONTAINS

SUBROUTINE SOLVE_POISSON

    ! CREATE A NODAL GALERKIN CONSTRUCTOR-------------------------------
    CALL NODAL_POTENTIAL_CLASS
    !-------------------------------------------------------------------

END SUBROUTINE SOLVE_POISSON

SUBROUTINE NODAL_POTENTIAL_CLASS

    IMPLICIT NONE

    ! GET GAUSS_LOBBATO_LEGENDRE POINTS AND WEIGHTS---------------------
    CALL GLL(M) ! X
    CALL GLL(N) ! Y
    !-------------------------------------------------------------------

    ! GET FIRST DERIVATIVE MATRIX---------------------------------------
    CALL mth_Order_Polynomial_Derivative_Matrix(M,1)    ! X DIRECTION
    CALL mth_Order_Polynomial_Derivative_Matrix(N,1)    ! Y DIRECTION
    !-------------------------------------------------------------------

    ! GET G MATRIX (INV(MASS) * (STIFFNESS))----------------------------
    CALL CG_DERIVATIVE_MATRIX(M)    ! X
    CALL CG_DERIVATIVE_MATRIX(N)    ! Y
    !-------------------------------------------------------------------

END SUBROUTINE NODAL_POTENTIAL_CLASS

SUBROUTINE LAPLACE_ON_THE_SQUARE

 IMPLICIT NONE

 INTEGER :: I, J

END SUBROUTINE LAPLACE_ON_THE_SQUARE

END MODULE POISSON_PRO


      subroutine run_0000(k,l,DetGr,f,Gtwiddle,Gtt,
     . Shati00,Si00m,S0000,N0)
      implicit none
C------Fixes D0000 using 5.46
C-----knowing D00 with correction of order Delta D00ii
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,n,m
      double precision DetGr,Gtwiddle(3,3),Gtt(3,3,3,3),f(3)
      double complex Shati00(3,-2:0),S0000(-2:0),Si00m(3,3,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,3
      do m=1,3
      bit=bit
     . +Gtt(k,n,l,m)*(f(n)*Shati00(m,ep)-f(n)*f(m)*Dv(dd00+N0,ep))
      enddo
      enddo
      pole=czip
      if (ep .gt. -2) pole=-4d0*Gtwiddle(k,l)*Dv(dd0000+N0,ep-1)

      Dv(dd0000+N0,ep)=-(
     . +pole
     . +DetGr*Dv(dzzii(z2(k,l))+N0,ep)
     . -Gtwiddle(k,l)*S0000(ep)
     . -Gtwiddle(1,l)*Si00m(1,k,ep)
     . -Gtwiddle(2,l)*Si00m(2,k,ep)
     . -Gtwiddle(3,l)*Si00m(3,k,ep)
     . +Gtwiddle(k,l)*(Si00m(1,1,ep)+Si00m(2,2,ep)+Si00m(3,3,ep))
     . +bit)/(8d0*Gtwiddle(k,l))
      enddo

      return
      end


FUNCTION burydist(lay,burydistflg,lthick,ldepth,nlay)
!
! this routine returns the fraction of material buried in layer number
! lay given the burial distribution function type burydistflg and the
! layer thicknesses lthick and the total number of layers in which
! material will be buried nlay and the tillage depth, soil layer
! thicknesses, and the number of soil layers.  it returns the number
! of layers that will be considered to be within the tillage zone for
! this operation.
!
IMPLICIT NONE
!
INCLUDE 'p1werm.inc'
!
! PARAMETER definitions
!
REAL,PARAMETER :: c1exp = 0.5,c2exp = 0.3,c3e1 = 2.925,c3e2 = 1.575,            &
                & c3brk = 0.65,c3split = 0.5
!
! Function arguments
!
INTEGER :: burydistflg,lay,nlay
REAL :: burydist
REAL,DIMENSION(mnsz) :: ldepth,lthick
!
! Local variables
!
REAL :: lower,upper
!
!     the following subroutine arguments are not used: lthick jcaii  8/08/08
!

!     argument declarations

!     argument definitions
!     lay         - soil layer for which fraction is returned
!     tlay        - number of soil layers affected by tillage
!     burydistflg - distribution function to be used
!              0    o uniform distribution
!              1    o mixing+inversion burial distribution
!              2    o mixing burial distribution
!              3    o inversion burial distribution
!              4    o lifting, fracturing burial distribution
!              5    o compression
!     lthick      - thickness of soil layer
!     ldepth      - distance from surface to bottom of layer
!     nlay        - number of soil layers affected

!     local variable declarations

!     assign depth from surface to upper and lower layer bounds
IF (lay.EQ.1) THEN
  upper = 0.0
ELSE
  upper = ldepth(lay-1)/ldepth(nlay)
END IF
lower = ldepth(lay)/ldepth(nlay)

!     find fraction of material buried in layer lay
SELECT CASE (burydistflg)
CASE (1)
  burydist = lower**c1exp - upper**c1exp
CASE (2,5)      ! same for compression and mixing from nat. agron. manual, 508crevisionwstir 071106dtl
  burydist = lower**c2exp - upper**c2exp
CASE (3)
  IF (lower.LE.c3brk) THEN
     burydist = c3split*(lower/c3brk)**c3e1
  ELSE
     burydist = 1.0 - c3split*((1.0-lower)/(1.0-c3brk))**c3e2
  END IF
  IF (upper.LE.c3brk) THEN
     burydist = burydist - c3split*(upper/c3brk)**c3e1
  ELSE
     burydist = burydist - (1.0-c3split*((1.0-upper)/(1.0-c3brk))**c3e2)
  END IF
CASE (4)
  burydist = lower**c1exp - upper**c1exp
CASE DEFAULT         !uniform burial distribution
  burydist = lower - upper
END SELECT
!
END FUNCTION burydist

Project Documents/Source Code Original/Burydist.f90


      REAL FUNCTION  cozena( day, hour, dlat, dlon )
C+---------------------------------------------------------------------+
C!       Reference:    Woolf, H.M., NASA TM X-1646.                    !
C!                     On the computation of solar elevation           !
C!                     angles and the determination of sunrise         !
C!                     and sunset times.                               !
C+---------------------------------------------------------------------+
C!       D a t a               v a r i a b l e s:                      !
C+---------------------------------------------------------------------+
C!       epsiln   eccentricity of earth orbit                          !
C!       sinob    sine of obliquity of ecliptic                        !
C!       dpy      days per year (365.242)                              !
C!       dph      degrees per hour (360./24)                           !
C+---------------------------------------------------------------------+
C!       I n p u t             v a r i a b l e s:                      !
C+---------------------------------------------------------------------+
C!       day      days of year (jan. 1 is day 1)                       !
C!       hour     hours of greenwich time                              !
C!       dlon     degree longitude of grid point,                      !
C!                counted positive west of greenwich                   !
C!       dlat     degree latitude  of grid point,                      !
C!                counted positive northern hemisphere                 !
C+---------------------------------------------------------------------+
C!       O u t p u t           v a r i a b l e s:                      !
C+---------------------------------------------------------------------+
C!       cozena   cosine of zenith angle   ( reference -- eq. 1.1 )    !
C+---------------------------------------------------------------------+
C!       I n t e r n a l       v a r i a b l e s:                      !
C+---------------------------------------------------------------------+
C!       dpr      degree/radian (*57.29578)                            !
C!       rpd      radian/degree (*.01745329)                           !
C!       dang     angle measured from perihelion, in radians           !
C!                which is taken as midnight jan. 1                    !
C!       homp     hours of meridian passage or true solar noon         !
C!                ( reference -- eq. 1.6 )                             !
C!       hang     hour angle, a measure of the longitudinal distance   !
C!                to the sun from the point calculated  ( eq. 1.5 )    !
C!       sindlt   sine of declination angle  ( eq. 1.2 )               !
C!       cosdlt   cosine of declination angle                          !
C!       sigma    reference -- eq. 1.3a                                !
C!       ang      reference -- eq. 1.3b                                !
C+---------------------------------------------------------------------+
      REAL ang, cosdlt, dang, day, dlat,
     $     dlon, dph, dpy, epsiln,
     $     hang, homp, hour, pi, rpd, dpr, sigma, sindlt, sinob
      DATA   epsiln/.016733/, sinob/.3978/, dpy/365.242/,
     $       dph/15.0/, pi/3.1415926535898/
      rpd    = pi/180.0
      dpr    = 1.0/rpd
      dang   = 2.0*pi*(day - 1.0)/dpy
      homp   = 12.0 + 0.123570*SIN( dang )
     $     - 0.004289*COS( dang )
     $     + 0.153809*SIN( 2.0*dang )
     $     + 0.060783*COS( 2.0*dang )
      hang   = dph*( hour-homp ) - dlon
      ang    = 279.9348*rpd + dang
      sigma  = ( ang*dpr + 0.4087*SIN( ang )
     $     + 1.8724*COS( ang )
     $     - 0.0182*SIN( 2.0*ang )
     $     + 0.0083*COS( 2.0*ang ) )*rpd
      sindlt = sinob*SIN( sigma )
      cosdlt = SQRT( 1.0-sindlt**2 )
      cozena = sindlt*SIN( rpd*dlat ) +
     $         cosdlt*COS( rpd*dlat )*COS( rpd*hang )
      RETURN
      END


      DOUBLE PRECISION FUNCTION PHO_RNDGAM(Alam,Eta)
C********************************************************************
C
C     RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
C     F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION Alam , DT_RNDM , Eta , f , r , y , yyy , z
      INTEGER i , n , ncou
      SAVE
C
      ncou = 0
      n = Eta
      f = Eta - n
      IF ( f.EQ.0.D0 ) THEN
         y = 0.D0
      ELSE
 50      r = DT_RNDM(Eta)
         ncou = ncou + 1
         IF ( ncou.GE.11 ) THEN
            y = 0.D0
         ELSE
            IF ( r.LT.f/(f+2.71828D0) ) THEN
               y = 1.D0 - LOG(DT_RNDM(r)+1.0D-9)
               IF ( DT_RNDM(y).GT.y**(f-1.D0) ) GOTO 50
            ELSE
               yyy = LOG(DT_RNDM(f)+1.0D-9)/f
               IF ( ABS(yyy).GT.50.D0 ) THEN
                  y = 0.D0
                  GOTO 100
               ELSE
                  y = EXP(yyy)
                  IF ( LOG(DT_RNDM(y)+1.0D-9).GT.-y ) GOTO 50
               END IF
            END IF
            IF ( n.EQ.0 ) GOTO 200
         END IF
      END IF
 100  z = 1.D0
      DO i = 1 , n
         z = z*DT_RNDM(y)
      END DO
      y = y - LOG(z+1.0D-9)
 200  PHO_RNDGAM = y/Alam
      END FUNCTION


!--------------------------------------------------------------------------------
!
! An example to call opacfractal.f90
!
! The default parameter set is the same as the benchmark test used in Appendix A
! in Tazaki & Tanaka (2018), which is based on RCCA model.
!
!--------------------------------------------------------------------------------
program call_opacfractal
implicit none
integer, parameter                      :: dp = selected_real_kind(P=15)
real(kind=dp),parameter                 :: pi = 3.1415926535897932384_dp
integer                                 :: iqsca,iqcor,iqgeo,iquiet,i,nang,unit
complex(kind=dp)                        :: ref
real(kind=dp)                           :: lmd,R0,PN,DF,k0,ang,dang
real(kind=dp)                           :: Cext,Csca,Cabsp,Gsca,dphi
real(kind=dp),allocatable,dimension(:,:):: Smat
!--------------------------------------------------------------------------------
! SET INPUT PARAMETERS
!--------------------------------------------------------------------------------
iqsca  = 3                               ! a method to solve light scattering
iqcor  = 1                               ! correlation function
iqgeo  = 3                               ! geometric cross section
iquiet = 0                               ! stdout
R0     = 0.5_dp                          ! Monomer radius (micron)
PN     = 64.0_dp                         ! Number of monomers
nang   = 91                              ! Angle mesh
lmd    = 0.8_dp                          ! wavelength (micron)
k0     = 0.825_dp                        ! fractal prefactor
df     = 2.0_dp                          ! fractal dimension
ref    = cmplx(1.4_dp,0.0001_dp,kind=dp) ! complex refractive index

!--------------------------------------------------------------------------------
! RUN OPACFRACTAL
!--------------------------------------------------------------------------------
allocate(Smat(1:4,1:2*nang-1))
call meanscatt(lmd,R0,PN,Df,k0,ref,iqsca,iqcor,iqgeo,iquiet,nang,&
                Cext,Csca,Cabsp,Gsca,Smat,dphi)
!--------------------------------------------------------------------------------
! OUTPUT
!--------------------------------------------------------------------------------
unit = 10
DANG=0.5d0*PI/DBLE(NANG-1)
open(unit,file="out_smat.dat",status="unknown")
call out_headerinfo(unit,r0,lmd,PN,k0,df,ref,iqsca,iqcor,iqgeo)
write(unit,'("#",1PE18.8,A)') Cext," = Extinction cross-section (um^2)"
write(unit,'("#",1PE18.8,A)') Csca," = Scattering cross-section (um^2)"
write(unit,'("#",1PE18.8,A)') Cabsp," = Absorption cross-section (um^2)"
write(unit,'("#",1PE18.8,A)') gsca," = asymmetry parameter"
write(unit,'("#",A17,4A18)') "degree","S11","S12","S33","S34"
do i=1,2*nang-1
        ang = dang*dble(i-1)*(180.0/pi)
        write(unit,'(1P5E18.8)') ang,Smat(1,i),Smat(2,i),Smat(3,i),Smat(4,i)
enddo
deallocate(Smat)
!--------------------------------------------------------------------------------
print *, "finished!"

stop
end program call_opacfractal

!--------------------------------------------------------------------------------
!       output header information
!--------------------------------------------------------------------------------
subroutine out_headerinfo(unit,r0,lmd,PN,k0,df,ref,iqsca,iqcor,iqgeo)
use types
implicit none
integer::unit,iqsca,iqcor,iqgeo
real(kind=dp):: df,k0,r0,PN,rhod,lmd
complex(kind=dp)::ref

write(unit,'("# ================================================")')
write(unit,'("#              OPACFRACTAL v3.0                  ")')
write(unit,'("# ================================================")')
write(unit,'("# iqsca = ",I1," iqcor = ",I1," iqgeo = ",I1)') iqsca,iqcor,iqgeo
write(unit,'("# df           = ",1PE12.5)') df
write(unit,'("# k0           = ",1PE12.5)') k0
write(unit,'("# r0   [um]    = ",1PE12.5)') r0
write(unit,'("# N            = ",1PE12.5)') PN
write(unit,'("# lambda [um]  = ",1PE12.5)') lmd
write(unit,'("# Re(m) = ",1PE12.5," Im(m) = ",1PE12.5)') real(ref),aimag(ref)

return
end subroutine out_headerinfo


program eval

  use amrex_constants_module
  use amrex_fort_module, only : rt => amrex_real
  use network
  use eos_module
  use actual_burner_module
  use burn_type_module
  use microphysics_module
  use actual_network, only: short_spec_names
  use actual_rhs_module, only: actual_rhs

  implicit none

  real(rt) :: dens, temp
  real(rt), dimension(nspec) :: Xin
  type(burn_t) :: state_in
  integer :: n

  call microphysics_init()

  dens = 2.6e9_rt
  temp = 6.e8_rt

  Xin(ic12)  = 0.5_rt
  Xin(io16)  = 0.5_rt
  Xin(iash)  = 0.0_rt

  print *, 'calling the burner RHS ...'

  state_in % rho = dens
  state_in % T = temp
  state_in % e = ZERO
  state_in % xn(:) = Xin(:)

  call actual_rhs(state_in)

  do n = 1, nspec
     print *, short_spec_names(n), state_in % xn(n), state_in % ydot(n)
  enddo

  call microphysics_finalize()

end program eval


Program testPRNGstream

Use Kinds, Only: id,il
Use Global, Only: default_seed_x64
Use PRNGs, Only: MT19937x64_Type

Implicit None

Type(MT19937x64_Type) :: RNG_19937x64
Integer :: unit
Integer :: n_args
Character(15) :: arg_c
Character(3) :: str
Logical :: first32,all64
Integer(id) :: y

n_args = COMMAND_ARGUMENT_COUNT()
If (n_args .EQ. 1) Then
    Call GET_COMMAND_ARGUMENT(1,arg_c)
    Select Case (Trim(arg_c))
        Case ('first','m32')
            first32 = .TRUE.
            all64 = .FALSE.
        Case ('second','l32')
            first32 = .FALSE.
            all64 = .FALSE.
        Case ('split','s64')
            first32 = .TRUE.
            all64 = .TRUE.
        Case ('all','a64')
            first32 = .FALSE.
            all64 = .TRUE.
    End Select
Else
    first32 = .FALSE.
    all64 = .TRUE.
End If
!connect to the pipe
If (all64) Then
    If (first32) Then
        str = 's64'
    Else
        str = 'a64'
    End If
Else If (first32) Then
    str = 'm32'
Else If (.NOT. first32) Then
    str = 'l32'
End If
Open(NEWUNIT=unit,FILE='pipeMT19937x64-'//str//'.p',ACCESS='STREAM',STATUS='OLD')
!seed the generator
Call RNG_19937x64%seed(default_seed_x64)
!generate a continuous stream of integer values to the pipe
If (all64) Then
    If (first32) Then
        !generate a stream of random 64-bit integers, and write to the pipe as two 32-bit halves
        Do
            y = RNG_19937x64%i()
            Write(unit) INT( ISHFT(y,-32) , il ) !32 MSB
            Write(unit) INT( IAND(y,4294967295_id) , il ) !32 LSB
        End Do
    Else
        !generate and write a stream of random 64-bit integers to the pipe
        Do
            Write(unit) RNG_19937x64%i()
        End Do
    End If
Else
    !generate a stream of random 64-bit integers, and write the specified half to the pipe
    Do
        y = RNG_19937x64%i()
        If (first32) Then
            Write(unit) INT( ISHFT(y,-32) , il ) !32 MSB
        Else
            Write(unit) INT( IAND(y,4294967295_id) , il ) !32 LSB
        End If
    End Do
End If
!close the pipe
Close(unit)

End Program testPRNGstream


*
* $Id$
*
      program numbers
      implicit integer (a-z)
c
      maxdiff = 0
      do i = 7,2048
         n = i
         call fastj_optimize_n(n,'upperbound')
         if (abs(n-i) .gt. maxdiff) then
            maxdiff = abs(n-i)
            write(6,*) i, n, maxdiff
         endif
      enddo
c
      write(6,*) ' upperbound ', maxdiff
c
      maxdiff = 0
      do i = 7,2048
         n = i
         call fastj_optimize_n(n,'nearby')
         if (abs(n-i) .gt. maxdiff) then
            maxdiff = abs(n-i)
            write(6,*) i, n, maxdiff
         endif
      enddo
      write(6,*) ' nearby ', maxdiff
c
      end
      subroutine fastj_optimize_n(n, mode)
      implicit none
      integer n
      character*(*) mode
c
      integer n2, n3, n5, ii2, ii3, ii5, i2, i3, i5
      double precision test, diff
c
      n = n + 1                 ! Temporarily to force to power of radix
c
      n2 = log(dble(n))/log(2.0d0) + 1
      n3 = log(dble(n))/log(3.0d0) + 1
      n5 = log(dble(n))/log(5.0d0) + 1
      ii2 = 0
      ii3 = 0
      ii5 = 0
      diff = n
      do i2 = 0, n2
         do i3 = 0, n3
            do i5 = 0, n5
               test = (2.0d0**i2)*(3.0d0**i3)*(5.0d0**i5) + 1d-6
               if (test.ge.n .or. mode.ne.'upperbound') then
                  if (abs(test-n) .lt. diff) then
                     diff = abs(test - n)
                     ii2 = i2
                     ii3 = i3
                     ii5 = i5
                  endif
               endif
            enddo
         enddo
      enddo
c
      n = (2.0d0**ii2)*(3.0d0**ii3)*(5.0d0**ii5)  - 1
c
      end