c
c
c     =====================================================
      subroutine rp1(maxm,meqn,mwaves,mbc,mx,ql,qr,auxl,auxr,
     &                  wave,s,amdq,apdq)
c     =====================================================
c
c     # begin_html
c       [www.clawpack.org CLAWPACK] Riemann solver
c       for constant coefficient acoustics in 1 space dimension.
c          \[   q_t + A q_x = 0.  \]
c       where
c          \[   q(x,t) = \vector{ p(x,t)\\ u(x,t)}           \]
c       and the coefficient matrix is
c          \[   A = \begin{matrix}
c                     0      & K\\
c                     1/\rho & 0
c                     \end{matrix}.
c          \]
c
c       The parameters $\rho = $ density and $K =$ bulk modulus
c       are set in [code: setprob.data] and the sound speed $c$
c       and impedance $Z$ are determined from these in [code: setprob.f].
c
c       On input:
c

c
 ql contains the state vector at the left edge of each cell,
c
 qr contains the state vector at the right edge of each cell,
c
 auxl, auxr are not used in this Riemann solver.
c

c
c
c       Note that the i'th Riemann problem has left state qr(i-1,:)
c                                          and right state ql(i,:).
c       From the basic clawpack routine step1, rp1 is called with ql = qr = q.

c       On output:
c

c
 wave contains the waves,
c
 s the speeds,
c
 amdq the  left-going flux difference  $\A^-\Delta Q$,
c
 apdq the right-going flux difference  $\A^+\Delta Q$
c

c
c
c       For additional documentation on Riemann solvers rp1, see
c       [claw/doc/rp1]
c
c       For details on solution of the Riemann problem for acoustics,
c       see Chapter 3 of [www.clawpack.org/book.html FVMHP].
c
c
c     # end_html
c
c
c
      implicit double precision (a-h,o-z)
c
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      dimension   ql(1-mbc:maxm+mbc, meqn)
      dimension   qr(1-mbc:maxm+mbc, meqn)
      dimension apdq(1-mbc:maxm+mbc, meqn)
      dimension amdq(1-mbc:maxm+mbc, meqn)
c
c     local arrays
c     ------------
      dimension delta(2)
c
c     # density, bulk modulus, and sound speed, and impedence of medium:
c     # (should be set in setprob.f)
      common /cparam/ rho,bulk,cc,zz
c
c
c     # begin_html
c       Split the jump in $Q$ at each interface into waves.
c       First find $\alpha^1$ and $\alpha^2$, the coefficients of the
c       2 eigenvectors:
c         \[ \delta = \alpha^1 \vector{ -Z \\ 1} +
c                     \alpha^2 \vector{  Z \\ 1}      \]
c
c       Note that the eigendecomposition of $A$ is
c       $A = R \Lambda R^{-1}$, with
c          \[   R = \begin{matrix}
c                        -Z & Z \\
c                         1 & 1
c                        \end{matrix}, \quad
c               \Lambda = \begin{matrix}
c                        -c & 0 \\
c                         0 & c
c                        \end{matrix}, \quad
c               R^{-1} = \frac{1}{2Z}
c                        \begin{matrix}
c                        -1 & Z \\
c                         1 & Z
c                        \end{matrix}, \quad
c          \]
c     # end_html
c
      do 20 i = 2-mbc, mx+mbc
         delta(1) = ql(i,1) - qr(i-1,1)
         delta(2) = ql(i,2) - qr(i-1,2)
         a1 = (-delta(1) + zz*delta(2)) / (2.d0*zz)
         a2 =  (delta(1) + zz*delta(2)) / (2.d0*zz)
c
c        # Compute the waves.
c
         wave(i,1,1) = -a1*zz
         wave(i,2,1) = a1
         s(i,1) = -cc
c
         wave(i,1,2) = a2*zz
         wave(i,2,2) = a2
         s(i,2) = cc
c
   20    continue
c
c
c     # begin_html
c       Compute the leftgoing and rightgoing fluctuations:
c
c       For this problem we always have $s^1 =-c \lt 0$ and $s^2 = c\gt 0$, so
c       \[
c          \A^-\Delta Q = s^1\W^1, \quad
c          \A^+\Delta Q = s^2\W^2.
c       \]
c     # end_html
c
      do 220 m=1,meqn
         do 220 i = 2-mbc, mx+mbc
            amdq(i,m) = s(i,1)*wave(i,m,1)
            apdq(i,m) = s(i,2)*wave(i,m,2)
  220       continue
c
      return
      end


!-----------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
!-----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2019, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
!-----------------------------------------------------------------
! Example problem:
!
! The following test simulates a brusselator problem from chemical
! kinetics.  This is a PDE system with 3 components, Y = [u,v,w],
! satisfying the equations,
!    du/dt = du*u_xx + a - (w+1)*u + v*u^2
!    dv/dt = dv*v_xx + w*u - v*u^2
!    dw/dt = dw*w_xx + (b-w)/ep - w*u
! for t in the interval [0, 10], x in [0, 10], with initial
! conditions
!    u(0,x) =  a  + 0.1*sin(pi*x),
!    v(0,x) = b/a + 0.1*sin(pi*x),
!    w(0,x) =  b  + 0.1*sin(pi*x),
! and with stationary boundary conditions, i.e.
!    u_t(t,0) = u_t(t,1) = 0,
!    v_t(t,0) = v_t(t,1) = 0,
!    w_t(t,0) = w_t(t,1) = 0.
!
! Here, we use a piecewise linear Galerkin finite element
! discretization in space, where all element-wise integrals are
! computed using 3-node Gaussian quadrature (since we will have
! quartic polynomials in the reaction terms for the u_t and v_t
! equations (including the test function)).  The time derivative
! terms in this system will include a mass matrix, giving rise to
! an ODE system of the form
!      M y_t = L y + R(y),
! where M is the 3x3 block mass matrix for each component, L is
! the 3x3 block Laplace operator for each component, and R(y) is
! comprised of the nonlinear reaction terms for each component.
! Since it it highly inefficient to rewrite this system as
!      y_t = M^{-1}(L y + R(y)),
! we solve this system using FARKODE, with a user-supplied mass
! matrix.  We therefore provide functions to evaluate the ODE RHS
!    f(t,y) = L y + R(y),
! its Jacobian
!    J(t,y) = L + dR/dy,
! and the mass matrix, M.
!
! We use N=201 spatial nodes, with parameters
!    a=0.6,  b=2.0,  du=0.025,  dv=0.025,  dw=0.025,  ep=1.d-5
!
! This program solves the problem with the DIRK method, using a
! Newton iteration with the SUNKLU sparse linear solvers for both
! the system and mass matrices.  These matrices are stored in
! compressed-sparse-row format.
!
! Output is printed 10 times throughout the defined time interval.
! Run statistics (optional outputs) are printed at the end.
!-----------------------------------------------------------------

! user data structure
module UserData
  implicit none
  include "sundials/sundials_fconfig.h"
  save

  integer*8 :: N                   ! number of intervals
  real*8, allocatable :: x(:)      ! mesh node locations
  real*8 :: a                      ! constant forcing on u
  real*8 :: b                      ! steady-state value of w
  real*8 :: du                     ! diffusion coeff for u
  real*8 :: dv                     ! diffusion coeff for v
  real*8 :: dw                     ! diffusion coeff for w
  real*8 :: ep                     ! stiffness parameter

contains

  ! function that maps 2D data into 1D address space
  ! (0-based since CSR matrix will be sent to C solver)
  integer(kind=8) function idx(ix,ivar)
    integer :: ivar, ix
    idx = 3*(ix-1) + ivar - 1
  end function idx

end module UserData

! finite element basis functions
module FEM

contains

  ! left/right basis functions
  double precision function ChiL(xl,xr,x)
    double precision :: xl, xr, x
    ChiL = (xr-x)/(xr-xl)
  end function ChiL

  double precision function ChiR(xl,xr,x)
    double precision :: xl, xr, x
    ChiR = (x-xl)/(xr-xl)
  end function ChiR

  ! derivatives of left/right basis functions
  double precision function ChiL_x(xl,xr)
    double precision :: xl, xr
    ChiL_x = 1.d0/(xl-xr)
  end function ChiL_X

  double precision function ChiR_x(xl,xr)
    double precision :: xl, xr
    ChiR_x = 1.d0/(xr-xl)
  end function ChiR_x

  ! FEM output evaluation routines: value and derivative
  double precision function Eval(ul,ur,xl,xr,x)
    double precision :: ul, ur, xl, xr, x
    Eval = ul*ChiL(xl,xr,x) + ur*ChiR(xl,xr,x)
  end function Eval

  double precision function Eval_x(ul,ur,xl,xr)
    double precision :: ul, ur, xl, xr
    Eval_x = ul*ChiL_x(xl,xr) + ur*ChiR_x(xl,xr)
  end function Eval_x

end module FEM

! quadrature data
module Quadrature

contains

  ! nodes
  double precision function X1(xl,xr)
    double precision :: xl, xr
    X1 = 0.5d0*(xl+xr) - 0.5d0*(xr-xl)*0.774596669241483377035853079956d0
  end function X1

  double precision function X2(xl,xr)
    double precision :: xl, xr
    X2 = 0.5d0*(xl+xr)
  end function X2

  double precision function X3(xl,xr)
    double precision :: xl, xr
    X3 = 0.5d0*(xl+xr) + 0.5d0*(xr-xl)*0.774596669241483377035853079956d0
  end function X3

  ! quadrature
  double precision function Quad(f1,f2,f3,xl,xr)
    real*8 :: f1, f2, f3, xl, xr
    real*8, parameter :: wt1=0.55555555555555555555555555555556d0
    real*8, parameter :: wt2=0.88888888888888888888888888888889d0
    real*8, parameter :: wt3=0.55555555555555555555555555555556d0
    Quad = 0.5d0*(xr-xl)*(wt1*f1 + wt2*f2 + wt3*f3)
  end function Quad

end module Quadrature
!-----------------------------------------------------------------

!-----------------------------------------------------------------
! Main driver program
!-----------------------------------------------------------------
program driver

  ! inclusions
  use UserData
  implicit none

  ! Declarations
  ! general problem variables
  real(kind=REALTYPE), parameter :: T0=0.d0, Tf=10.d0
  real(kind=REALTYPE) :: rtol, atol, rout(6), Tout, Tcur
  real*8    :: dTout, pi, h, z
  integer   :: i, it, Nt, ier, ordering, sparsetype, time_dep
  integer*8 :: iout(35), NEQ, nnz, Iinput
  real(kind=REALTYPE), allocatable :: y(:,:), umask(:,:)
  real(kind=REALTYPE), allocatable :: vmask(:,:), wmask(:,:)

  ! dummy real/integer parameters to pass through to supplied functions
  integer*8 :: ipar
  real(kind=REALTYPE) :: rpar

  !-----------------------

  ! set problem parameters (in UserData structure)
  N = 201                 ! number of intervals
  a = 0.6d0               ! constant forcing on u
  b = 2.d0                ! steady-state value of w
  du = 2.5d-2             ! diffusion coeff for u
  dv = 2.5d-2             ! diffusion coeff for v
  dw = 2.5d-2             ! diffusion coeff for w
  ep = 1.d-5              ! stiffness parameter

  ! set overall problem size, allocate solution/mask/temporary arrays
  NEQ = 3*N
  allocate(y(3,N), umask(3,N), vmask(3,N), wmask(3,N))

  ! allocate and set up spatial mesh; this [arbitrarily] clusters
  ! more intervals near the end points of the interval
  allocate(x(N))          ! mesh node locations
  pi = 4.d0*atan(1.d0)
  h = 10.d0/(N-1)
  do i=1,N
     z = -5.d0 + h*(i-1)
     x(i) = 0.5d0/atan(5.d0)*atan(z) + 0.5d0
  enddo

  ! output mesh to disk
  open(200, file='bruss_FEM_mesh.txt')
  do i=1,N
     write(200,*) x(i)
  enddo
  close(200)

  ! time-stepping information
  dTout = (Tf-T0)/10.d0
  Nt = Tf/dTout + 0.5

  ! set initial conditions
  do i=1,N
     y(1,i) =  a  + 0.1d0*sin(pi*x(i))   ! u0
     y(2,i) = b/a + 0.1d0*sin(pi*x(i))   ! v0
     y(3,i) =  b  + 0.1d0*sin(pi*x(i))   ! w0
  enddo

  ! set mask values for each solution component
  umask = 0.d0
  vmask = 0.d0
  wmask = 0.d0
  do i=1,N
     umask(1,i) = 1.d0
     vmask(2,i) = 1.d0
     wmask(3,i) = 1.d0
  enddo

  ! set tolerances according to problem specifications
  atol = 1.d-11
  rtol = 1.d-6

  ! initialize vector module
  call FNVInitS(4, NEQ, ier)

  ! initialize system and mass matrix modules
  nnz = 15*NEQ     ! integer number of nonzeros
  ordering = 0     ! AMD
  sparsetype = 1   ! CSR
  call FSunSparseMatInit(4, NEQ, NEQ, nnz, sparsetype, ier)
  call FSunSparseMassMatInit(NEQ, NEQ, nnz, sparsetype, ier)

  ! initialize KLU system and mass solvers
  call FSunKLUInit(4, ier)
  call FSunMassKLUInit(ier)

  ! initialize ARKode solver
  ipar = 0
  rpar = 0.0
  iout = 0
  rout = 0.0
  call FARKMalloc(T0, y, 0, 1, rtol, atol, &
                  iout, rout, ipar, rpar, ier)

  ! set optional inputs
  Iinput = 1
  call FARKSetIin('IMPLICIT', Iinput, ier)
  Iinput = 1000
  call FARKSetIin('MAX_NSTEPS', Iinput, ier)
  call FARKSetResTolerance(1, atol, ier)

  ! attach matrix and linear solver objects to ARKLs interfaces
  time_dep = 0
  call FARKLsInit(ier)
  call FARKSparseSetJac(ier)
  call FARKLsMassInit(time_dep, ier)
  call FARKSparseSetMass(ier)

  ! Open output stream for results
  open(501, file='bruss_FEM_u.txt')
  open(502, file='bruss_FEM_v.txt')
  open(503, file='bruss_FEM_w.txt')

  ! output initial condition to disk
  write(501,*) ( y(1,i), i=1,N )
  write(502,*) ( y(2,i), i=1,N )
  write(503,*) ( y(3,i), i=1,N )

  ! output solver parameters to screen
  call FARKWriteParameters(ier)

  ! loop over time outputs
  Tout = T0
  Tcur = T0
  print *, '        t         ||u||_rms    ||v||_rms    ||w||_rms'
  print *, '  ----------------------------------------------------'
  print '(3x,4(es12.5,1x))', Tcur, sqrt(sum(y*y*umask)/N), &
       sqrt(sum(y*y*vmask)/N), sqrt(sum(y*y*wmask)/N)
  do it = 1,Nt

     ! set next output time
     Tout = min(Tout + dTout, Tf)

     ! set next output time
     call FARKSetRin('STOP_TIME', Tout, ier)

     ! call solver
     call FARKode(Tout, Tcur, y, 1, ier)
     if (ier < 0) then
        write(0,*) 'Solver failure, stopping integration'
        stop
     end if

     ! output current solution information
     print '(3x,4(es12.5,1x))', Tcur, sqrt(sum(y*y*umask)/N), &
          sqrt(sum(y*y*vmask)/N), sqrt(sum(y*y*wmask)/N)

     ! output current results to disk
     write(501,*) ( y(1,i), i=1,N )
     write(502,*) ( y(2,i), i=1,N )
     write(503,*) ( y(3,i), i=1,N )

  end do
  print *, '  ----------------------------------------------------'

  ! close solution output files
  close(501)
  close(502)
  close(503)

  ! output solver statistics
  print *, '  '
  print *, 'Final Solver Statistics:'
  print *, '   Internal solver steps = ', iout(3),' (attempted =', iout(6), ')'
  print *, '   Total RHS evals:  Fe = ', iout(7),'  Fi = ', iout(8)
  print *, '   Total linear solver setups = ', iout(9)
  print *, '   Total RHS evals for setting up the linear system = ', iout(17)
  print *, '   Total number of Jacobian evaluations = ', iout(18)
  print *, '   Total number of nonlinear iterations = ', iout(11)
  print *, '   Total number of nonlinear solver convergence failures = ',iout(12)
  print *, '   Total number of error test failures = ', iout(10)
  print *, '   Total number of mass matrix evaluations = ', iout(28)
  print *, '  '

  ! clean up
  deallocate(y, umask, vmask, wmask, x)
  call FARKFree()

end program driver
!-----------------------------------------------------------------

!-----------------------------------------------------------------
! User-supplied subroutines for FARKODE interface
!-----------------------------------------------------------------

subroutine FARKIFun(t, y, ydot, ipar, rpar, ier)
!-----------------------------------------------------------------
! Right-hand side of the ODE system
!-----------------------------------------------------------------
  use UserData
  use FEM
  use Quadrature

  ! Declarations
  implicit none

  ! Arguments
  real(kind=REALTYPE), intent(in)  :: t, rpar(1)
  integer*8, intent(in) :: ipar(1)
  integer, intent(out)  :: ier
  real(kind=REALTYPE), intent(in)  :: y(3,N)
  real(kind=REALTYPE), intent(out) :: ydot(3,N)

  ! Local data
  integer :: ix
  logical :: left, right
  real*8  :: ul, ur, vl, vr, wl, wr, xl, xr, u, v, w, f1, f2, f3

  ! clear out rhs
  ydot = 0.d0

  ! iterate over intervals, filling in rhs function
  do ix=1,N-1

     ! set booleans to determine whether equations exist on the left/right */
     left  = .true.
     right = .true.
     if (ix==1)      left  = .false.
     if (ix==(N-1))  right = .false.

     ! set nodal value shortcuts (interval index aligns with left node)
     ul = y(1,ix)
     vl = y(2,ix)
     wl = y(3,ix)
     ur = y(1,ix+1)
     vr = y(2,ix+1)
     wr = y(3,ix+1)

     ! set mesh shortcuts
     xl = x(ix)
     xr = x(ix+1)

     !    left test function
     if (left) then

        ! u -- reaction
        u = Eval(ul, ur, xl, xr, X1(xl,xr))
        v = Eval(vl, vr, xl, xr, X1(xl,xr))
        w = Eval(wl, wr, xl, xr, X1(xl,xr))
        f1 = (a - (w+1.d0)*u + v*u*u) * ChiL(xl,xr,X1(xl,xr))
        u = Eval(ul, ur, xl, xr, X2(xl,xr))
        v = Eval(vl, vr, xl, xr, X2(xl,xr))
        w = Eval(wl, wr, xl, xr, X2(xl,xr))
        f2 = (a - (w+1.d0)*u + v*u*u) * ChiL(xl,xr,X2(xl,xr))
        u = Eval(ul, ur, xl, xr, X3(xl,xr))
        v = Eval(vl, vr, xl, xr, X3(xl,xr))
        w = Eval(wl, wr, xl, xr, X3(xl,xr))
        f3 = (a - (w+1.d0)*u + v*u*u) * ChiL(xl,xr,X3(xl,xr))
        ydot(1,ix) = ydot(1,ix) + Quad(f1,f2,f3,xl,xr)

        ! u -- diffusion
        f1 = -du * Eval_x(ul,ur,xl,xr) * ChiL_x(xl,xr)
        ydot(1,ix) = ydot(1,ix) + Quad(f1,f1,f1,xl,xr)

        ! v -- reaction
        u = Eval(ul, ur, xl, xr, X1(xl,xr))
        v = Eval(vl, vr, xl, xr, X1(xl,xr))
        w = Eval(wl, wr, xl, xr, X1(xl,xr))
        f1 = (w*u - v*u*u) * ChiL(xl,xr,X1(xl,xr))
        u = Eval(ul, ur, xl, xr, X2(xl,xr))
        v = Eval(vl, vr, xl, xr, X2(xl,xr))
        w = Eval(wl, wr, xl, xr, X2(xl,xr))
        f2 = (w*u - v*u*u) * ChiL(xl,xr,X2(xl,xr))
        u = Eval(ul, ur, xl, xr, X3(xl,xr))
        v = Eval(vl, vr, xl, xr, X3(xl,xr))
        w = Eval(wl, wr, xl, xr, X3(xl,xr))
        f3 = (w*u - v*u*u) * ChiL(xl,xr,X3(xl,xr))
        ydot(2,ix) = ydot(2,ix) + Quad(f1,f2,f3,xl,xr)

        ! v -- diffusion
        f1 = -dv * Eval_x(vl,vr,xl,xr) * ChiL_x(xl,xr)
        ydot(2,ix) = ydot(2,ix) + Quad(f1,f1,f1,xl,xr)

        ! w -- reaction
        u = Eval(ul, ur, xl, xr, X1(xl,xr))
        v = Eval(vl, vr, xl, xr, X1(xl,xr))
        w = Eval(wl, wr, xl, xr, X1(xl,xr))
        f1 = ((b-w)/ep - w*u) * ChiL(xl,xr,X1(xl,xr))
        u = Eval(ul, ur, xl, xr, X2(xl,xr))
        v = Eval(vl, vr, xl, xr, X2(xl,xr))
        w = Eval(wl, wr, xl, xr, X2(xl,xr))
        f2 = ((b-w)/ep - w*u) * ChiL(xl,xr,X2(xl,xr))
        u = Eval(ul, ur, xl, xr, X3(xl,xr))
        v = Eval(vl, vr, xl, xr, X3(xl,xr))
        w = Eval(wl, wr, xl, xr, X3(xl,xr))
        f3 = ((b-w)/ep - w*u) * ChiL(xl,xr,X3(xl,xr))
        ydot(3,ix) = ydot(3,ix) + Quad(f1,f2,f3,xl,xr)

        ! w -- diffusion
        f1 = -dw * Eval_x(wl,wr,xl,xr) * ChiL_x(xl,xr)
        ydot(3,ix) = ydot(3,ix) + Quad(f1,f1,f1,xl,xr)

     end if

     !    right test function
     if (right) then

        ! u -- reaction
        u = Eval(ul, ur, xl, xr, X1(xl,xr))
        v = Eval(vl, vr, xl, xr, X1(xl,xr))
        w = Eval(wl, wr, xl, xr, X1(xl,xr))
        f1 = (a - (w+1.d0)*u + v*u*u) * ChiR(xl,xr,X1(xl,xr))
        u = Eval(ul, ur, xl, xr, X2(xl,xr))
        v = Eval(vl, vr, xl, xr, X2(xl,xr))
        w = Eval(wl, wr, xl, xr, X2(xl,xr))
        f2 = (a - (w+1.d0)*u + v*u*u) * ChiR(xl,xr,X2(xl,xr))
        u = Eval(ul, ur, xl, xr, X3(xl,xr))
        v = Eval(vl, vr, xl, xr, X3(xl,xr))
        w = Eval(wl, wr, xl, xr, X3(xl,xr))
        f3 = (a - (w+1.d0)*u + v*u*u) * ChiR(xl,xr,X3(xl,xr))
        ydot(1,ix+1) = ydot(1,ix+1) + Quad(f1,f2,f3,xl,xr)

        ! u -- diffusion
        f1 = -du * Eval_x(ul,ur,xl,xr) * ChiR_x(xl,xr)
        ydot(1,ix+1) = ydot(1,ix+1) + Quad(f1,f1,f1,xl,xr)

        ! v -- reaction
        u = Eval(ul, ur, xl, xr, X1(xl,xr))
        v = Eval(vl, vr, xl, xr, X1(xl,xr))
        w = Eval(wl, wr, xl, xr, X1(xl,xr))
        f1 = (w*u - v*u*u) * ChiR(xl,xr,X1(xl,xr))
        u = Eval(ul, ur, xl, xr, X2(xl,xr))
        v = Eval(vl, vr, xl, xr, X2(xl,xr))
        w = Eval(wl, wr, xl, xr, X2(xl,xr))
        f2 = (w*u - v*u*u) * ChiR(xl,xr,X2(xl,xr))
        u = Eval(ul, ur, xl, xr, X3(xl,xr))
        v = Eval(vl, vr, xl, xr, X3(xl,xr))
        w = Eval(wl, wr, xl, xr, X3(xl,xr))
        f3 = (w*u - v*u*u) * ChiR(xl,xr,X3(xl,xr))
        ydot(2,ix+1) = ydot(2,ix+1) + Quad(f1,f2,f3,xl,xr)

        ! v -- diffusion
        f1 = -dv * Eval_x(vl,vr,xl,xr) * ChiR_x(xl,xr)
        ydot(2,ix+1) = ydot(2,ix+1) + Quad(f1,f1,f1,xl,xr)

        ! w -- reaction
        u = Eval(ul, ur, xl, xr, X1(xl,xr))
        v = Eval(vl, vr, xl, xr, X1(xl,xr))
        w = Eval(wl, wr, xl, xr, X1(xl,xr))
        f1 = ((b-w)/ep - w*u) * ChiR(xl,xr,X1(xl,xr))
        u = Eval(ul, ur, xl, xr, X2(xl,xr))
        v = Eval(vl, vr, xl, xr, X2(xl,xr))
        w = Eval(wl, wr, xl, xr, X2(xl,xr))
        f2 = ((b-w)/ep - w*u) * ChiR(xl,xr,X2(xl,xr))
        u = Eval(ul, ur, xl, xr, X3(xl,xr))
        v = Eval(vl, vr, xl, xr, X3(xl,xr))
        w = Eval(wl, wr, xl, xr, X3(xl,xr))
        f3 = ((b-w)/ep - w*u) * ChiR(xl,xr,X3(xl,xr))
        ydot(3,ix+1) = ydot(3,ix+1) + Quad(f1,f2,f3,xl,xr)

        ! w -- diffusion
        f1 = -dw * Eval_x(wl,wr,xl,xr) * ChiR_x(xl,xr)
        ydot(3,ix+1) = ydot(3,ix+1) + Quad(f1,f1,f1,xl,xr)

     endif

  enddo
  ier = 0

  return

end subroutine farkifun
!-----------------------------------------------------------------

subroutine farkefun(t, y, ydot, ipar, rpar, ier)
!-----------------------------------------------------------------
! (unused) Explicit portion of the ODE right-hand function
!-----------------------------------------------------------------
  use UserData

  ! Declarations
  implicit none

  ! Arguments
  real(kind=REALTYPE), intent(in)  :: t, rpar(1)
  integer*8, intent(in) :: ipar(1)
  real(kind=REALTYPE), intent(in)  :: y(3,N)
  real(kind=REALTYPE), intent(out) :: ydot(3,N)
  integer, intent(out)  :: ier

  ! return with success (since fully implicit)
  ydot = 0.d0
  ier = 0

end subroutine farkefun
!-----------------------------------------------------------------

subroutine farkspjac(t, y, fy, neq, nnz, Jdata, Jcolvals, &
                     Jrowptrs, h, ipar, rpar, wk1, wk2, wk3, ier)
!-----------------------------------------------------------------
! Jacobian computation routine -- CSR format
!-----------------------------------------------------------------
  use UserData
  use Quadrature
  use FEM

  ! Declarations
  implicit none

  ! Arguments
  real(kind=REALTYPE), intent(in)  :: t, h, rpar(1)
  real(kind=REALTYPE), intent(in), dimension(3,N) :: y, fy, wk1, wk2, wk3
  real(kind=REALTYPE), intent(out) :: Jdata(nnz)
  integer*8, intent(in)  :: ipar(1), neq, nnz
  integer(kind=SUNINDEXTYPE), intent(out) :: Jcolvals(nnz)
  integer(kind=SUNINDEXTYPE), intent(out) :: Jrowptrs(neq+1)
  integer,   intent(out) :: ier

  ! Local data
  integer :: ix, nz, Nint
  real*8  :: ul, uc, ur, vl, vc, vr, wl, wc, wr, xl, xc, xr
  real*8  :: u1, u2, u3, v1, v2, v3, w1, w2, w3
  real*8  :: f1, f2, f3, df1, df2, df3, dQdf1, dQdf2, dQdf3
  real*8  :: ChiL1, ChiL2, ChiL3, ChiR1, ChiR2, ChiR3
  real*8, dimension(3,-1:1) :: Ju, Jv, Jw

  ! check that vector/matrix dimensions match up
  if ((3*N /= neq) .or. (nnz < 27*(N-2))) then
     ier = 1
     return
  endif

  ! set integer*4 version of N for call to idx()
  Nint = N

  ! clear out Jacobian matrix data
  Jdata = 0.d0
  nz = 0

  ! Dirichlet boundary at left
  Jrowptrs(idx(1,1)+1) = nz
  Jrowptrs(idx(1,2)+1) = nz
  Jrowptrs(idx(1,3)+1) = nz

  ! iterate through nodes, filling in matrix by rows
  do ix=2,N-1

     ! set nodal value shortcuts (interval index aligns with left node)
     xl = x(ix-1)
     ul = y(1,ix-1)
     vl = y(2,ix-1)
     wl = y(3,ix-1)
     xc = x(ix)
     uc = y(1,ix)
     vc = y(2,ix)
     wc = y(3,ix)
     xr = x(ix+1)
     ur = y(1,ix+1)
     vr = y(2,ix+1)
     wr = y(3,ix+1)

     ! compute entries of all Jacobian rows at node ix
     Ju = 0.d0
     Jv = 0.d0
     Jw = 0.d0

     ! first compute dependence on values to left and center

     !    evaluate relevant variables in left subinterval
     u1 = Eval(ul, uc, xl, xc, X1(xl,xc))
     v1 = Eval(vl, vc, xl, xc, X1(xl,xc))
     w1 = Eval(wl, wc, xl, xc, X1(xl,xc))
     u2 = Eval(ul, uc, xl, xc, X2(xl,xc))
     v2 = Eval(vl, vc, xl, xc, X2(xl,xc))
     w2 = Eval(wl, wc, xl, xc, X2(xl,xc))
     u3 = Eval(ul, uc, xl, xc, X3(xl,xc))
     v3 = Eval(vl, vc, xl, xc, X3(xl,xc))
     w3 = Eval(wl, wc, xl, xc, X3(xl,xc))

     dQdf1 = Quad(1.d0, 0.d0, 0.d0, xl, xc)
     dQdf2 = Quad(0.d0, 1.d0, 0.d0, xl, xc)
     dQdf3 = Quad(0.d0, 0.d0, 1.d0, xl, xc)

     ChiL1 = ChiL(xl, xc, X1(xl,xc))
     ChiL2 = ChiL(xl, xc, X2(xl,xc))
     ChiL3 = ChiL(xl, xc, X3(xl,xc))
     ChiR1 = ChiR(xl, xc, X1(xl,xc))
     ChiR2 = ChiR(xl, xc, X2(xl,xc))
     ChiR3 = ChiR(xl, xc, X3(xl,xc))

     !    compute diffusion Jacobian components

     !    L_u = -du * u_x * ChiR_x
     !     dL_u/dul
     Ju(1,-1) = (-du) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiL_x(xl,xc) * ChiR_x(xl,xc)
     !     dL_u/duc
     Ju(1,0)  = (-du) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiR_x(xl,xc) * ChiR_x(xl,xc)

     !    L_v = -dv * v_x * ChiR_x
     !     dL_v/dvl
     Jv(2,-1) = (-dv) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiL_x(xl,xc) * ChiR_x(xl,xc)
     !     dL_v/dvc
     Jv(2,0)  = (-dv) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiR_x(xl,xc) * ChiR_x(xl,xc)

     !    L_w =  -dw * w_x * ChiR_x
     !     dL_w/dwl
     Jw(3,-1) = (-dw) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiL_x(xl,xc) * ChiR_x(xl,xc)
     !     dL_w/dwc
     Jw(3,0)  = (-dw) * Quad(1.d0,1.d0,1.d0,xl,xc) * ChiR_x(xl,xc) * ChiR_x(xl,xc)

     !    compute reaction Jacobian components

     !    R_u = (a - (w+1.d0)*u + v*u*u)
     !     dR_u/dul
     df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiL1 * ChiR1
     df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiL2 * ChiR2
     df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiL3 * ChiR3
     Ju(1,-1) = Ju(1,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/duc
     df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiR1 * ChiR1
     df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiR2 * ChiR2
     df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiR3 * ChiR3
     Ju(1,0) = Ju(1,0)+ dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dvl
     df1 = (u1*u1) * ChiL1 * ChiR1
     df2 = (u2*u2) * ChiL2 * ChiR2
     df3 = (u3*u3) * ChiL3 * ChiR3
     Ju(2,-1) = Ju(2,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dvc
     df1 = (u1*u1) * ChiR1 * ChiR1
     df2 = (u2*u2) * ChiR2 * ChiR2
     df3 = (u3*u3) * ChiR3 * ChiR3
     Ju(2,0) = Ju(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dwl
     df1 = (-u1) * ChiL1 * ChiR1
     df2 = (-u2) * ChiL2 * ChiR2
     df3 = (-u3) * ChiL3 * ChiR3
     Ju(3,-1) = Ju(3,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dwc
     df1 = (-u1) * ChiR1 * ChiR1
     df2 = (-u2) * ChiR2 * ChiR2
     df3 = (-u3) * ChiR3 * ChiR3
     Ju(3,0) = Ju(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !    R_v = (w*u - v*u*u)
     !     dR_v/dul
     df1 = (w1 - 2.d0*v1*u1) * ChiL1 * ChiR1
     df2 = (w2 - 2.d0*v2*u2) * ChiL2 * ChiR2
     df3 = (w3 - 2.d0*v3*u3) * ChiL3 * ChiR3
     Jv(1,-1) = Jv(1,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/duc
     df1 = (w1 - 2.d0*v1*u1) * ChiR1 * ChiR1
     df2 = (w2 - 2.d0*v2*u2) * ChiR2 * ChiR2
     df3 = (w3 - 2.d0*v3*u3) * ChiR3 * ChiR3
     Jv(1,0) = Jv(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dvl
     df1 = (-u1*u1) * ChiL1 * ChiR1
     df2 = (-u2*u2) * ChiL2 * ChiR2
     df3 = (-u3*u3) * ChiL3 * ChiR3
     Jv(2,-1) = Jv(2,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dvc
     df1 = (-u1*u1) * ChiR1 * ChiR1
     df2 = (-u2*u2) * ChiR2 * ChiR2
     df3 = (-u3*u3) * ChiR3 * ChiR3
     Jv(2,0) = Jv(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dwl
     df1 = (u1) * ChiL1 * ChiR1
     df2 = (u2) * ChiL2 * ChiR2
     df3 = (u3) * ChiL3 * ChiR3
     Jv(3,-1) = Jv(3,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dwc
     df1 = (u1) * ChiR1 * ChiR1
     df2 = (u2) * ChiR2 * ChiR2
     df3 = (u3) * ChiR3 * ChiR3
     Jv(3,0) = Jv(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !    R_w = ((b-w)/ep - w*u)
     !     dR_w/dul
     df1 = (-w1) * ChiL1 * ChiR1
     df2 = (-w2) * ChiL2 * ChiR2
     df3 = (-w3) * ChiL3 * ChiR3
     Jw(1,-1) = Jw(1,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_w/duc
     df1 = (-w1) * ChiR1 * ChiR1
     df2 = (-w2) * ChiR2 * ChiR2
     df3 = (-w3) * ChiR3 * ChiR3
     Jw(1,0) = Jw(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_w/dwl
     df1 = (-1.d0/ep - u1) * ChiL1 * ChiR1
     df2 = (-1.d0/ep - u2) * ChiL2 * ChiR2
     df3 = (-1.d0/ep - u3) * ChiL3 * ChiR3
     Jw(3,-1) = Jw(3,-1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_w/dwc
     df1 = (-1.d0/ep - u1) * ChiR1 * ChiR1
     df2 = (-1.d0/ep - u2) * ChiR2 * ChiR2
     df3 = (-1.d0/ep - u3) * ChiR3 * ChiR3
     Jw(3,0) = Jw(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     ! second compute dependence on values to center and right

     !    evaluate relevant variables in right subinterval
     u1 = Eval(uc, ur, xc, xr, X1(xc,xr))
     v1 = Eval(vc, vr, xc, xr, X1(xc,xr))
     w1 = Eval(wc, wr, xc, xr, X1(xc,xr))
     u2 = Eval(uc, ur, xc, xr, X2(xc,xr))
     v2 = Eval(vc, vr, xc, xr, X2(xc,xr))
     w2 = Eval(wc, wr, xc, xr, X2(xc,xr))
     u3 = Eval(uc, ur, xc, xr, X3(xc,xr))
     v3 = Eval(vc, vr, xc, xr, X3(xc,xr))
     w3 = Eval(wc, wr, xc, xr, X3(xc,xr))

     dQdf1 = Quad(1.d0, 0.d0, 0.d0, xc, xr)
     dQdf2 = Quad(0.d0, 1.d0, 0.d0, xc, xr)
     dQdf3 = Quad(0.d0, 0.d0, 1.d0, xc, xr)

     ChiL1 = ChiL(xc, xr, X1(xc,xr))
     ChiL2 = ChiL(xc, xr, X2(xc,xr))
     ChiL3 = ChiL(xc, xr, X3(xc,xr))
     ChiR1 = ChiR(xc, xr, X1(xc,xr))
     ChiR2 = ChiR(xc, xr, X2(xc,xr))
     ChiR3 = ChiR(xc, xr, X3(xc,xr))

     !    compute diffusion Jacobian components

     !    L_u = -du * u_x * ChiL_x
     !     dL_u/duc
     Ju(1,0) = Ju(1,0) + (-du) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiL_x(xc,xr)

     !     dL_u/dur
     Ju(1,1) = Ju(1,1) + (-du) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiR_x(xc,xr)

     !    L_v = -dv * v_x * ChiL_x
     !     dL_v/dvc
     Jv(2,0) = Jv(2,0) + (-dv) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiL_x(xc,xr)

     !     dL_v/dvr
     Jv(2,1) = Jv(2,1) + (-dv) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiR_x(xc,xr)

     !    L_w =  -dw * w_x * ChiL_x
     !     dL_w/dwc
     Jw(3,0) = Jw(3,0) + (-dw) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiL_x(xc,xr)

     !     dL_w/dwr
     Jw(3,1) = Jw(3,1) + (-dw) * Quad(1.d0,1.d0,1.d0,xc,xr) * ChiL_x(xc,xr) * ChiR_x(xc,xr)

     !    compute reaction Jacobian components

     !    R_u = (a - (w+1.d0)*u + v*u*u)
     !     dR_u/duc
     df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiL1 * ChiL1
     df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiL2 * ChiL2
     df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiL3 * ChiL3
     Ju(1,0) = Ju(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dur
     df1 = (-(w1+1.d0) + 2.d0*v1*u1) * ChiL1 * ChiR1
     df2 = (-(w2+1.d0) + 2.d0*v2*u2) * ChiL2 * ChiR2
     df3 = (-(w3+1.d0) + 2.d0*v3*u3) * ChiL3 * ChiR3
     Ju(1,1) = Ju(1,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dvc
     df1 = (u1*u1) * ChiL1 * ChiL1
     df2 = (u2*u2) * ChiL2 * ChiL2
     df3 = (u3*u3) * ChiL3 * ChiL3
     Ju(2,0) = Ju(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dvr
     df1 = (u1*u1) * ChiL1 * ChiR1
     df2 = (u2*u2) * ChiL2 * ChiR2
     df3 = (u3*u3) * ChiL3 * ChiR3
     Ju(2,1) = Ju(2,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dwc
     df1 = (-u1) * ChiL1 * ChiL1
     df2 = (-u2) * ChiL2 * ChiL2
     df3 = (-u3) * ChiL3 * ChiL3
     Ju(3,0) = Ju(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_u/dwr
     df1 = (-u1) * ChiL1 * ChiR1
     df2 = (-u2) * ChiL2 * ChiR2
     df3 = (-u3) * ChiL3 * ChiR3
     Ju(3,1) = Ju(3,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !    R_v = (w*u - v*u*u)
     !     dR_v/duc
     df1 = (w1 - 2.d0*v1*u1) * ChiL1 * ChiL1
     df2 = (w2 - 2.d0*v2*u2) * ChiL2 * ChiL2
     df3 = (w3 - 2.d0*v3*u3) * ChiL3 * ChiL3
     Jv(1,0) = Jv(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dur
     df1 = (w1 - 2.d0*v1*u1) * ChiL1 * ChiR1
     df2 = (w2 - 2.d0*v2*u2) * ChiL2 * ChiR2
     df3 = (w3 - 2.d0*v3*u3) * ChiL3 * ChiR3
     Jv(1,1) = Jv(1,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dvc
     df1 = (-u1*u1) * ChiL1 * ChiL1
     df2 = (-u2*u2) * ChiL2 * ChiL2
     df3 = (-u3*u3) * ChiL3 * ChiL3
     Jv(2,0) = Jv(2,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dvr
     df1 = (-u1*u1) * ChiL1 * ChiR1
     df2 = (-u2*u2) * ChiL2 * ChiR2
     df3 = (-u3*u3) * ChiL3 * ChiR3
     Jv(2,1) = Jv(2,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dwc
     df1 = (u1) * ChiL1 * ChiL1
     df2 = (u2) * ChiL2 * ChiL2
     df3 = (u3) * ChiL3 * ChiL3
     Jv(3,0) = Jv(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_v/dwr
     df1 = (u1) * ChiL1 * ChiR1
     df2 = (u2) * ChiL2 * ChiR2
     df3 = (u3) * ChiL3 * ChiR3
     Jv(3,1) = Jv(3,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !    R_w = ((b-w)/ep - w*u)
     !     dR_w/duc
     df1 = (-w1) * ChiL1 * ChiL1
     df2 = (-w2) * ChiL2 * ChiL2
     df3 = (-w3) * ChiL3 * ChiL3
     Jw(1,0) = Jw(1,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_w/dur
     df1 = (-w1) * ChiL1 * ChiR1
     df2 = (-w2) * ChiL2 * ChiR2
     df3 = (-w3) * ChiL3 * ChiR3
     Jw(1,1) = Jw(1,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_w/dwc
     df1 = (-1.d0/ep - u1) * ChiL1 * ChiL1
     df2 = (-1.d0/ep - u2) * ChiL2 * ChiL2
     df3 = (-1.d0/ep - u3) * ChiL3 * ChiL3
     Jw(3,0) = Jw(3,0) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     !     dR_w/dwr
     df1 = (-1.d0/ep - u1) * ChiL1 * ChiR1
     df2 = (-1.d0/ep - u2) * ChiL2 * ChiR2
     df3 = (-1.d0/ep - u3) * ChiL3 * ChiR3
     Jw(3,1) = Jw(3,1) + dQdf1*df1 + dQdf2*df2 + dQdf3*df3

     ! insert Jacobian entries into CSR matrix structure

     !   Ju row
     Jrowptrs(idx(ix,1)+1) = nz

     Jdata(nz+1:nz+3) = (/ Ju(1,-1), Ju(2,-1), Ju(3,-1) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix-1,1), idx(ix-1,2), idx(ix-1,3) /)
     nz = nz+3

     Jdata(nz+1:nz+3) = (/ Ju(1,0), Ju(2,0), Ju(3,0) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix,1), idx(ix,2), idx(ix,3) /)
     nz = nz+3

     Jdata(nz+1:nz+3) = (/ Ju(1,1), Ju(2,1), Ju(3,1) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix+1,1), idx(ix+1,2), idx(ix+1,3) /)
     nz = nz+3

     !   Jv row
     Jrowptrs(idx(ix,2)+1) = nz

     Jdata(nz+1:nz+3) = (/ Jv(1,-1), Jv(2,-1), Jv(3,-1) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix-1,1), idx(ix-1,2), idx(ix-1,3) /)
     nz = nz+3

     Jdata(nz+1:nz+3) = (/ Jv(1,0), Jv(2,0), Jv(3,0) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix,1), idx(ix,2), idx(ix,3) /)
     nz = nz+3

     Jdata(nz+1:nz+3) = (/ Jv(1,1), Jv(2,1), Jv(3,1) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix+1,1), idx(ix+1,2), idx(ix+1,3) /)
     nz = nz+3

     !   Jw row
     Jrowptrs(idx(ix,3)+1) = nz

     Jdata(nz+1:nz+3) = (/ Jw(1,-1), Jw(2,-1), Jw(3,-1) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix-1,1), idx(ix-1,2), idx(ix-1,3) /)
     nz = nz+3

     Jdata(nz+1:nz+3) = (/ Jw(1,0), Jw(2,0), Jw(3,0) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix,1), idx(ix,2), idx(ix,3) /)
     nz = nz+3

     Jdata(nz+1:nz+3) = (/ Jw(1,1), Jw(2,1), Jw(3,1) /)
     Jcolvals(nz+1:nz+3) = (/ idx(ix+1,1), idx(ix+1,2), idx(ix+1,3) /)
     nz = nz+3

  enddo

  ! Dirichlet boundary at right
  Jrowptrs(idx(Nint,1)+1) = nz
  Jrowptrs(idx(Nint,2)+1) = nz
  Jrowptrs(idx(Nint,3)+1) = nz

  ! signal end of data in CSR matrix
  Jrowptrs(idx(Nint,3)+2) = nz

  ier = 0
  return

end subroutine farkspjac
!-----------------------------------------------------------------

subroutine farkspmass(t, neq, nnz, Mdata, Mcolvals, Mrowptrs, &
                      ipar, rpar, wk1, wk2, wk3, ier)
!-----------------------------------------------------------------
! Mass matrix computation routine
!-----------------------------------------------------------------
  use UserData
  use Quadrature
  use FEM

  ! Declarations
  implicit none

  ! Arguments
  real(kind=REALTYPE), intent(in)  :: t, rpar(1)
  real(kind=REALTYPE), intent(in), dimension(3,N) :: wk1, wk2, wk3
  real(kind=REALTYPE), intent(out) :: Mdata(nnz)
  integer*8, intent(in) :: ipar(1), neq, nnz
  integer(kind=SUNINDEXTYPE), intent(out) :: Mcolvals(nnz)
  integer(kind=SUNINDEXTYPE), intent(out) :: Mrowptrs(neq+1)
  integer,  intent(out) :: ier

  ! Local data
  integer :: ix, nz, Nint
  real*8  :: xl, xc, xr, Ml, Mc, Mr, ChiL1, ChiL2, ChiL3, ChiR1, ChiR2, ChiR3
  logical :: left, right

  ! check that vector/matrix dimensions match up
  if ((3*N /= neq) .or. (nnz /= 15*neq)) then
     ier = 1
     return
  endif

  ! set integer*4 version of N for call to idx()
  Nint = N

  ! clear out Jacobian matrix data
  Mdata = 0.d0
  nz = 0

  ! iterate through nodes, filling in matrix by rows
  do ix=1,N

     ! set booleans to determine whether intervals exist on the left/right */
     left  = .true.
     right = .true.
     if (ix==1)  left  = .false.
     if (ix==N)  right = .false.

     ! set nodal value shortcuts (interval index aligns with left node)
     if (left) then
        xl = x(ix-1)
     endif
     xc = x(ix)
     if (right) then
        xr = x(ix+1)
     endif

     ! compute entries of all mass matrix rows at node ix
     Ml = 0.d0
     Mc = 0.d0
     Mr = 0.d0

     ! first compute dependence on values to left and center
     if (left) then

        ChiL1 = ChiL(xl, xc, X1(xl,xc))
        ChiL2 = ChiL(xl, xc, X2(xl,xc))
        ChiL3 = ChiL(xl, xc, X3(xl,xc))
        ChiR1 = ChiR(xl, xc, X1(xl,xc))
        ChiR2 = ChiR(xl, xc, X2(xl,xc))
        ChiR3 = ChiR(xl, xc, X3(xl,xc))

        Ml = Ml + Quad(ChiL1*ChiR1, ChiL2*ChiR2, ChiL3*ChiR3, xl, xc)
        Mc = Mc + Quad(ChiR1*ChiR1, ChiR2*ChiR2, ChiR3*ChiR3, xl, xc)

     endif

     ! second compute dependence on values to center and right
     if (right) then

        ChiL1 = ChiL(xc, xr, X1(xc,xr))
        ChiL2 = ChiL(xc, xr, X2(xc,xr))
        ChiL3 = ChiL(xc, xr, X3(xc,xr))
        ChiR1 = ChiR(xc, xr, X1(xc,xr))
        ChiR2 = ChiR(xc, xr, X2(xc,xr))
        ChiR3 = ChiR(xc, xr, X3(xc,xr))

        Mc = Mc + Quad(ChiL1*ChiL1, ChiL2*ChiL2, ChiL3*ChiL3, xc, xr)
        Mr = Mr + Quad(ChiL1*ChiR1, ChiL2*ChiR2, ChiL3*ChiR3, xc, xr)

     endif

     ! insert mass matrix entries into CSR matrix structure

     !   u row
     Mrowptrs(idx(ix,1)+1) = nz
     if (left) then
        nz = nz+1
        Mdata(nz) = Ml
        Mcolvals(nz) = idx(ix-1,1)
     endif
     nz = nz+1
     Mdata(nz) = Mc
     Mcolvals(nz) = idx(ix,1)
     if (right) then
        nz = nz+1
        Mdata(nz) = Mr
        Mcolvals(nz) = idx(ix+1,1)
     endif

     !   v row
     Mrowptrs(idx(ix,2)+1) = nz
     if (left) then
        nz = nz+1
        Mdata(nz) = Ml
        Mcolvals(nz) = idx(ix-1,2)
     endif
     nz = nz+1
     Mdata(nz) = Mc
     Mcolvals(nz) = idx(ix,2)
     if (right) then
        nz = nz+1
        Mdata(nz) = Mr
        Mcolvals(nz) = idx(ix+1,2)
     endif

     !   w row
     Mrowptrs(idx(ix,3)+1) = nz
     if (left) then
        nz = nz+1
        Mdata(nz) = Ml
        Mcolvals(nz) = idx(ix-1,3)
     endif
     nz = nz+1
     Mdata(nz) = Mc
     Mcolvals(nz) = idx(ix,3)
     if (right) then
        nz = nz+1
        Mdata(nz) = Mr
        Mcolvals(nz) = idx(ix+1,3)
     endif

  enddo

  ! signal end of data in CSR matrix
  Mrowptrs(idx(Nint,3)+2) = nz

  ier = 0
  return

end subroutine farkspmass
!-----------------------------------------------------------------


      DOUBLE PRECISION FUNCTION DBESY1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DBESY1 Krogh  Added external statement.
C>> 1995-11-03 DBESY1 Krogh  Changes to simplify C conversion.
C>> 1994-11-11 DBESY1 Krogh  Declared all vars.
C>> 1994-10-20 DBESY1 Krogh  Changes to use M77CON
C>> 1991-01-14 DBESY1 CLL Changed to generic name SIN.
C>> 1990-11-29 CLL
C>> 1985-08-02 DBESY1 Lawson  Initial code.
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--D replaces "?": ?BESY1, ?BESJ1, ?BMP1, ?INITS, ?CSEVL, ?ERM1
c     ------------------------------------------------------------------
      EXTERNAL D1MACH, DBESJ1, DCSEVL
      INTEGER NTY1
      DOUBLE PRECISION X, BY1CS(20), AMPL, THETA, TWODPI, XMIN, XSML,
     1  Y, D1MACH, DCSEVL, DBESJ1
C
C SERIES FOR BY1        ON THE INTERVAL  0.          TO  1.60000D+01
C                                        WITH WEIGHTED ERROR   8.65D-33
C                                         LOG WEIGHTED ERROR  32.06
C                               SIGNIFICANT FIGURES REQUIRED  32.17
C                                    DECIMAL PLACES REQUIRED  32.71
C
      SAVE NTY1, XMIN, XSML
C
      DATA BY1CS / +.320804710061190862932352018628015D-1,
     *  +.126270789743350044953431725999727D+1,
     *  +.649996189992317500097490637314144D-2,
     *  -.893616452886050411653144160009712D-1,
     *  +.132508812217570954512375510370043D-1,
     *  -.897905911964835237753039508298105D-3,
     *  +.364736148795830678242287368165349D-4,
     *  -.100137438166600055549075523845295D-5,
     *  +.199453965739017397031159372421243D-7,
     *  -.302306560180338167284799332520743D-9,
     *  +.360987815694781196116252914242474D-11,
     *  -.348748829728758242414552947409066D-13,
     *  +.278387897155917665813507698517333D-15,
     *  -.186787096861948768766825352533333D-17,
     *  +.106853153391168259757070336000000D-19,
     *  -.527472195668448228943872000000000D-22,
     *  +.227019940315566414370133333333333D-24,
     *  -.859539035394523108693333333333333D-27,
     *  +.288540437983379456000000000000000D-29,
     *  -.864754113893717333333333333333333D-32 /
C
      DATA TWODPI / 0.636619772367581343075535053490057D0 /
      DATA NTY1, XMIN, XSML / 0, 2*0.D0 /
C     ------------------------------------------------------------------
      IF (NTY1 .EQ. 0) then
      call DINITS (BY1CS, 20, 0.1D0*D1MACH(3), NTY1)
C
      XMIN = 1.571D0 * EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) +
     1  0.01D0)
      XSML = SQRT (4.0D0*D1MACH(3))
      endif
C
      IF (X .LE. 0.D0) THEN
        DBESY1 = 0.D0
        CALL DERM1 ('DBESY1',1,0,'X IS ZERO OR NEGATIVE','X',X,'.')
      ELSE IF (X .LE. XMIN) THEN
        DBESY1 = 0.D0
        CALL DERM1 ('DBESY1',2,0,'X SO SMALL Y1 OVERFLOWS','X',X,'.')
      ELSE IF (X .LE. 4.D0) THEN
        IF (X .LE. XSML) THEN
          Y = 0.D0
        ELSE
          Y = X * X
        END IF
        DBESY1 = TWODPI * LOG(0.5D0*X)*DBESJ1(X) + (0.5D0 +
     *           DCSEVL (.125D0*Y-1.D0, BY1CS, NTY1))/X
      ELSE
        CALL DBMP1 (X, AMPL, THETA)
        DBESY1 = AMPL * SIN(THETA)
      END IF
      RETURN
      END


      SUBROUTINE slTPVC (XI, ETA, V, V01, V02, N)
*+
*     - - - - - -
*      T P V C
*     - - - - - -
*
*  Given the tangent-plane coordinates of a star and its direction
*  cosines, determine the direction cosines of the tangent-point.
*
*  (single precision)
*
*  Given:
*     XI,ETA    r       tangent plane coordinates of star
*     V         r(3)    direction cosines of star
*
*  Returned:
*     V01       r(3)    direction cosines of tangent point, solution 1
*     V02       r(3)    direction cosines of tangent point, solution 2
*     N         i       number of solutions:
*                         0 = no solutions returned (note 2)
*                         1 = only the first solution is useful (note 3)
*                         2 = both solutions are useful (note 3)
*
*  Notes:
*
*  1  The vector V must be of unit length or the result will be wrong.
*
*  2  Cases where there is no solution can only arise near the poles.
*     For example, it is clearly impossible for a star at the pole
*     itself to have a non-zero XI value, and hence it is meaningless
*     to ask where the tangent point would have to be.
*
*  3  Also near the poles, cases can arise where there are two useful
*     solutions.  The argument N indicates whether the second of the
*     two solutions returned is useful.  N=1 indicates only one useful
*     solution, the usual case;  under these circumstances, the second
*     solution can be regarded as valid if the vector V02 is interpreted
*     as the "over-the-pole" case.
*
*  4  This routine is the Cartesian equivalent of the routine slTPSC.
*
*  P.T.Wallace   Starlink   5 June 1995
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 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 General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL XI,ETA,V(3),V01(3),V02(3)
      INTEGER N

      REAL X,Y,Z,RXY2,XI2,ETA2P1,SDF,R2,R,C

      X=V(1)
      Y=V(2)
      Z=V(3)
      RXY2=X*X+Y*Y
      XI2=XI*XI
      ETA2P1=ETA*ETA+1.0
      SDF=Z*SQRT(XI2+ETA2P1)
      R2=RXY2*ETA2P1-Z*Z*XI2
      IF (R2.GT.0.0) THEN
         R=SQRT(R2)
         C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2)))
         V01(1)=C*(X*R+Y*XI)
         V01(2)=C*(Y*R-X*XI)
         V01(3)=(SDF-ETA*R)/ETA2P1
         R=-R
         C=(SDF*ETA+R)/(ETA2P1*SQRT(RXY2*(R2+XI2)))
         V02(1)=C*(X*R+Y*XI)
         V02(2)=C*(Y*R-X*XI)
         V02(3)=(SDF-ETA*R)/ETA2P1
         IF (ABS(SDF).LT.1.0) THEN
            N=1
         ELSE
            N=2
         END IF
      ELSE
         N=0
      END IF

      END


      program statblock
c
c**********************************************************************
c
c     blocking method for estimating standard error of mean
c
c     (reference - Flyvbjerg and Petersen  JCP 91 (1989) 461)
c
c     copyright daresbury laboratory 1993
c     author - w. smith nov 1992
c
c**********************************************************************
c
      parameter (ndeg=13,mxrows=10000,mxcols=20)
      implicit real*8 (a-h,o-z)
      dimension list(mxcols),record(mxcols),d(mxrows,mxcols)
      dimension aver(mxcols),sigma(ndeg,mxcols)
      character*40 statfile
      write(*,*)'error estimation using blocking method'
      write(*,*)'maximum number of time points allowed =',mxrows
      write(*,*)'name of statistical data file (40 chars max)?'
      read(*,'(a40)')statfile
      write(*,*)'enter number of columns in data file (max 20)'
      read(*,*)mcols
      mcols=min(mcols,mxcols)
      write(*,*)'enter number of columns to be processed (max 20)'
      read(*,*)ncols
      ncols=min(ncols,mxcols)
      write(*,*)'identify columns to be processed'
      read(*,*)(list(j),j=1,ncols)
c
c     open the statistical data file

      open(7,file=statfile)

c
c     read in statistical data
      do i=1,mxrows
         read(7,'(a)',end=100)
         read(7,'(5e14.6)')(record(j),j=1,mcols)
         do k=1,ncols
            d(i,k)=record(list(k))
         enddo
      enddo
  100 m=min(i-1,mxrows)
      write(*,*)'number of data points read',m
c
c     calculate averages
      write(*,*)'calculated averages'
      do l=1,ncols
         aver(l)=0.d0
         do i=1,m
            aver(l)=aver(l)+d(i,l)
         enddo
         aver(l)=aver(l)/dble(m)
      enddo
      write(*,'(1p,20e12.4)')(aver(j),j=1,ncols)
c
c     calculate errors using blocking method
      write(*,*)'calculated standard errors'
      do l=1,ncols
         sigma(1,l)=0.d0
         do  i=1,m
            d(i,l)=d(i,l)-aver(l)
            sigma(1,l)=sigma(1,l)+d(i,l)**2
         enddo
         sigma(1,l)=sqrt(sigma(1,l)/(dble(m)*dble(m-1)))
         mmm=m
         do n=2,ndeg
            j=0
            mmm=mmm/2
            sigma(n,l)=0.d0
            do i=1,mmm
               j=j+2
               d(i,l)=0.5d0*(d(j-1,l)+d(j,l))
               sigma(n,l)=sigma(n,l)+d(i,l)**2
            enddo
            sigma(n,l)=sqrt(sigma(n,l)/(dble(mmm)*dble(mmm-1)))
            if(mmm.le.3)go to 200
         enddo
  200    continue
      enddo
      do  i=1,min(n,ndeg)
         write(*,'(1p,20e12.4)')(sigma(i,j),j=1,ncols)
      enddo
c
c     calculate uncertainties in errors
      write(*,*)'error of standard error'
      do l=1,ncols
         mmm=2*m
         do  n=1,ndeg
            j=0
            mmm=mmm/2
            sigma(n,l)=sigma(n,l)/sqrt(dble(2*(mmm-1)))
            if(mmm.le.3)go to 300
         enddo
  300    continue
      enddo
      do i=1,min(n,ndeg)
         write(*,'(1p,20e12.4)')(sigma(i,j),j=1,ncols)
      enddo
      stop
      end


        program main
        implicit none
	real*8 :: t,x,y,h11,h12,h22,m1,m2,en,ax,ay
     	real*8 :: kinetic_energy,potential,dv,dvdx,dvdy,dt,dt2,px,py,s
	integer Ntraj
! the initial conditions
	real, dimension(1:Ntraj) :: x,y,px,py ! N trajectories of x,y

	integer :: k,kmax
	common/pot_par/h11,h12,h22,m1,m2
        open(5,file='IN')
	read(5,*) Ntraj
        read(5,*) kmax,dt
        read(5,*) k1,k2 ! constants for potential energy
!	read(5,*) h12
	read(5,*) m1,m2 ! mass of different dimension
        close(5)
        write(*,*) 'Classical Trajectories'

! time step
        dt2=dt/2d0
        t=0d0

! x,px,y,py define the center of GWP
!       write(*,*) 'INITIAL GWP WIDTH and CENTER'
!	write(*,*) x,px
!	write(*,*) y,py
!	write(*,*) m1,m2

	call derivs(x,y,v,dvdx,dvdy)
	open(10,file='output')
        do k=1,kmax

! increase t by dt
	t=t+dt

! half-step increments of momenta
	do i=1,Ntraj
	call derivs(x[i],y[i],potential_energy,dvdx,dvdy)
        px[i]=px[i]-dvdx*dt2
        py[i]=py[i]-dvdy*dt2

! full step increment of positions
        x[i]=x[i]+px[i]*dt/m1
        y[i]=y[i]+py[i]*dt/m2

        call derivs(x,y,v,dvdx,dvdy)

! half-step increments of momenta
	px[i]=px[i]-dvdx*dt2
	py[i]=py[i]-dvdy*dt2
	end do

! update potential, kinetic, and total energy
        do i=1:Ntraj
	potential_energy=(k1*x[i]*x[i]+k2*y[i]*y[i])/2d0+potential_energy
	kinetic_energy+=px[i]*px[i]/(2d0*m1)+py[i]*py[i]/(2d0*m2)
	total_energy=potential_energy+kinetic_energy
	end do

! print out the results
	write(10,*) t,x,y,en,kinetic_energy,potential energy,px,py

	end do

	end program main

! determine (vector) a=dv/dt, given(vector) x

        subroutine derivs(x,y,potential_energy,dvdx,dvdy)
	implicit none
	real*8 :: x,y,m1,m2,potential_energy,dvdx,dvdy,h11,h12,h22
	common/pot_par/ h11,h12,h22,m1,m2
        potential_energy=(k1*x*x+k2*y*y)/2d0
        dvdx=k1*x
        dvdy=k2*y
        return

        end


c Convert calendar date & time to minutes

	integer function juliam(iyr, imo, idy, ihr, imn)

	implicit none

c	Parameters:
	integer	iyr, imo, idy, ihr, imn		! (input)
						! iyr < 4000 for 32-bit int

c	Local variables:
	integer	kl
	integer	kmo(12)
	integer	ky, km, kd
	integer	ky0
	integer	ky1
	integer	ky4
	integer	l
	integer	leap

	data kmo/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334/
	data leap/1/

      ky = iyr
      km = imo
      kd = idy
      if (km.le.0) km = 1
      juliam = 365*ky
      kd = kmo(km)+kd
      ky4 = ky/4
      ky1 = ky/100
      ky0 = ky/1000
      kl = leap*(ky4-ky1+ky0)
      l = 0
      if (ky4*4.eq.ky.and.(ky1*100.ne.ky.or.ky0*1000.eq.ky)) l = leap
      if (l.ne.0.and.km.lt.3) kl = kl-leap
      juliam = juliam+kd+kl
      juliam = juliam*24+ihr
      juliam = juliam*60+imn
      return
      end ! of integer function juliam


program main
 implicit none
 real(kind=16),allocatable :: orbiters(:,:),a(:,:),r(:,:),dr(:),v(:,:),m(:)
 real :: start,now
 integer :: N,t,dt,ios,i,interval,k

 call cpu_time(start)
 open(unit=1,file='input.dat',status='old',iostat=ios)

 !some basic error handling
 if(ios .ne. 0) then
  print*,"Error opening the input file."
  stop
 end if

 !read the input file, the first three lines are reserved for the parameters given in the assignment
 read(1,*) N
 read(1,*) interval
 read(1,*) k
 read(1,*) dt
 read(1,*) t
 print*,t
 allocate(orbiters(7,N),r(3,N),a(3,N),dr(3),v(3,N),m(N))
 do i=1,N
  read(1,*) orbiters(:,i)
 end do
 close(1)

 !converting units to [r]=m,[v]=m/s and [m]=kg
 r(1:3,:)=orbiters(1:3,:)*10**9
 v(1:3,:)=orbiters(4:6,:)*10**3
 m(:)=orbiters(7,:)*10**24

 !open the output file w/ more error handling
 open(unit=2,file='output.dat',status='old',iostat=ios)
 if(ios .ne. 0) then
  print*,"Error opening the output file."
  stop
 end if

 !use the subroutine defined in the end of the program file
 call verletint(t,dt,r,v,m,N,interval,k)
 close(2)

contains

 !the integrator takes in the positions, velocities and masses for N objects
 !the subroutine prints the info box in the stdout every interval and
 !writes the positions of the objects in the output file every kth iteration

subroutine verletint(t,dt,r,v,m,N,interval,k)
 integer,intent(in) :: N,k,t,dt
 real(kind=16),intent(inout) :: r(3,N),v(3,N),m(N)
 real(kind=16) :: dr(3),r_mag,a(3,N),anew(3,N),rnew(3,N),G=6.67e-11,m2AU
 integer :: counter,steps,i,j,p,interval
 steps=t/dt
 counter=0
 p=0
 m2AU=6.68458712e-12

 !the integrator computes the acceleration for each object at every time step by
 !adding each other object's gravitational effect to the acceleration-array

 !the counter goes through all the steps; steps=total_time/time_step
 a=0
 anew=0
 rnew=0

 do while(counter .le. steps)
  do i=1,N
   r(1:3,i)=r(1:3,i)+v(1:3,i)*dt+0.5*a(1:3,i)*dt**2
   !calculate the new acceleration of the object
   do j=1,N
    !the integrator skips one iteration, when it tries to compute the object's gravitational effect on itself
    if(i .eq. j) cycle
    dr(1:3)=r(1:3,j)-r(1:3,i)
    r_mag=sqrt(dr(1)**2+dr(2)**2+dr(3)**2)
    anew(1:3,i)=anew(1:3,i)+G*m(j)*dr(1:3)/r_mag**3
   end do
   v(1:3,i)=v(1:3,i)+0.5*(a(1:3,i)+anew(1:3,i))*dt
   a(1:3,i)=anew(1:3,i)
   anew=0

  end do

  !if statements to check whether to write or not to write
  if(mod(counter,interval) .eq. 0 .OR. counter .eq. 0 .OR. counter .eq. steps) then
   call cpu_time(now)
   if(mod(counter,k) .eq. 0) then
    do j=1,N
     write(2,*) r(:,j)*m2AU
    end do
    p=p+1
   end if

   !the info box to stdout
   print'(a,1x,f7.3,a)','Time:',now-start,' seconds'
   print 10,'# objects:',N
   print 10,'# steps:',counter
   print 10,'# positions written:',p
   print'(a)','The x,y-coordinates of each body in the Solar System in astronomical units'
   print 11,'Sun      :',r(1:2,1)*m2AU
   print 11,'Mercury  :',r(1:2,2)*m2AU
   print 11,'Venus    :',r(1:2,3)*m2AU
   print 11,'the Earth:',r(1:2,4)*m2AU
   print 11,'Mars     :',r(1:2,5)*m2AU
   print 11,'Jupiter  :',r(1:2,6)*m2AU
   print 11,'Saturnus :',r(1:2,7)*m2AU
   print 11,'Uranus   :',r(1:2,8)*m2AU
   print 11,'Neptunus :',r(1:2,9)*m2AU
   print'(/)',

   10 format (a,1x,i0)
   11 format (a,1x,f15.7,f15.7)
  end if
  counter=counter+1
 end do

end subroutine verletint
end program main


module matvec_mul_module

  use multifab_module
  use ml_layout_module

  implicit none

  private

  public :: matvec_mul

  contains

  subroutine matvec_mul(mla, x, A, nc) ! Computes x=A*x, where A is an nxn matrix and x is an nx1 vector

    type(ml_layout), intent(in  )  :: mla
    type(multifab),  intent(inout) :: x
    type(multifab),  intent(in)    :: A
    integer,         intent(in)    :: nc

    ! local variables
    real(kind=dp_t), pointer       :: xp(:,:,:,:)
    real(kind=dp_t), pointer       :: ap(:,:,:,:)
    integer                        :: lo(mla%dim), hi(mla%dim), i, dm

    type(mfiter) :: mfi
    type(box) :: tilebox
    integer :: tlo(mla%dim), thi(mla%dim)

    type(bl_prof_timer), save :: bpt

    call build(bpt,"matvec_mul")

    dm = mla%dim

    !$omp parallel private(mfi,i,tilebox,tlo,thi,xp,ap,lo,hi)

    call mfiter_build(mfi, A, tiling=.true.)

    do while(more_tile(mfi))
       i = get_fab_index(mfi)

       tilebox = get_tilebox(mfi)
       tlo = lwb(tilebox)
       thi = upb(tilebox)

!    do i=1,nfabs(x)
       xp  => dataptr(x, i)
       ap  => dataptr(A, i)
       lo(1) = lbound(ap,1)  ! this adjusts lo & hi ghost cells on nodes & faces,
       lo(2) = lbound(ap,2)  ! so in the subroutine loop from lo to hi without ng.
       hi(1) = ubound(ap,1)
       hi(2) = ubound(ap,2)

       select case (dm)
         case (2)
             call matvec_mul_2d(xp(:,:,1,:), ap(:,:,1,:), lo, hi, nc, tlo, thi)
         case (3)
             lo(3) = lbound(ap,3)
             hi(3) = ubound(ap,3)
             call matvec_mul_3d(xp(:,:,:,:), ap(:,:,:,:), lo, hi, nc, tlo, thi)
       end select
    end do
    !$omp end parallel

    call destroy(bpt)

  end subroutine matvec_mul

  subroutine matvec_mul_2d(xp, ap, lo, hi, nc, tlo, thi)

    integer                        :: lo(:), hi(:), tlo(:), thi(:)
    real(kind=dp_t), intent(inout) :: xp(lo(1):,lo(2):,:) ! last dimension for nc
    real(kind=dp_t), intent(in)    :: ap(lo(1):,lo(2):,:)
    integer                        :: i,j,nc

    !print*, lo(1:2), hi(1:2)
    do j=tlo(2),thi(2)
       do i=tlo(1),thi(1)
          call matvec_mul_comp(xp(i,j,:), ap(i,j,:))
          !if(i.eq.7 .and. j.eq.14) print*, 'x-flux / y-flux'
          !if(i.eq.7 .and. j.eq.14) print*, "flux1=",xp(i,j,1), "flux2=",xp(i,j,2),"flux1+flux2=",xp(i,j,1)+xp(i,j,2)
          !print*, i,j,"x-flux=",xp(i,j,1)!, "x-flux=",xp(i,j,2)
       end do
    end do
          !print*, ''
          !print*, "Now y-flux for 2-species"

    contains

    ! Use contained subroutine to do rank conversion and mat-vec mult
    subroutine matvec_mul_comp(xp_ij, ap_ij)

        real(kind=dp_t), dimension(nc),    intent(inout) :: xp_ij
        real(kind=dp_t), dimension(nc,nc), intent(in)    :: ap_ij

        xp_ij = matmul(ap_ij, xp_ij)

    end subroutine matvec_mul_comp

  end subroutine matvec_mul_2d

  subroutine matvec_mul_3d(xp, ap, lo, hi, nc, tlo, thi)

    integer                        :: lo(:), hi(:), tlo(:), thi(:)
    real(kind=dp_t), intent(inout) :: xp(lo(1):,lo(2):,lo(3):,:) ! last dimension for nc
    real(kind=dp_t), intent(in)    :: ap(lo(1):,lo(2):,lo(3):,:)
    integer                        :: i,j,k,nc

    !print*, lo(1:3), hi(1:3)
    do k=tlo(3),thi(3)
       do j=tlo(2),thi(2)
          do i=tlo(1),thi(1)
             call matvec_mul_comp(xp(i,j,k,:), ap(i,j,k,:))
             !if(i.eq.7 .and. j.eq.14) print*, 'x-flux / y-flux'
             !if(i.eq.7 .and. j.eq.14) print*, "flux1=",xp(i,j,1), "flux2=",xp(i,j,2),"flux1+flux2=",xp(i,j,1)+xp(i,j,2)
             !print*, i,j,"x-flux=",xp(i,j,1)!, "x-flux=",xp(i,j,2)
          end do
       end do
    end do
             !print*, ''
             !print*, "Now y-flux for 2-species"
    contains

    ! Use contained subroutine to do rank conversion and mat-vec mult
    subroutine matvec_mul_comp(xp_ij, ap_ij)

        real(kind=dp_t), dimension(nc),    intent(inout) :: xp_ij
        real(kind=dp_t), dimension(nc,nc), intent(in)    :: ap_ij

        xp_ij = matmul(ap_ij, xp_ij)

    end subroutine matvec_mul_comp

  end subroutine matvec_mul_3d

end module matvec_mul_module


! A ranom numner generator between and 1 and 100

program random
    implicit none
    REAL :: rand(1)
    INTEGER :: low = 1, high = 100

    CALL RANDOM_NUMBER(rand)
    PRINT "(i3)", low + FLOOR((high+1 - low)*rand)

end program random


MODULE arma_estimation
IMPLICIT NONE

! Code converted using TO_F90 by Alan Miller
! Date: 2000-12-27  Time: 21:46:40

!  ALGORITHM AS 154  APPL. STATIST. (1980) VOL.29, P.311
!  ALGORITHM AS 182  APPL. STATIST. (1982) VOL.31, NO.2

REAL, PARAMETER, PRIVATE  :: zero = 0.0, one = 1.0, two = 2.0

CONTAINS

SUBROUTINE starma(ip,iq,ir,np,phi,theta,a,p,v,thetab,xnext,xrow,  &
                  rbar,nrbar,ifault)

!  INVOKING THIS SUBROUTINE SETS THE VALUES OF V AND PHI, AND
!  OBTAINS THE INITIAL VALUES OF A AND P.
!  THIS ROUTINE IS NOT SUITABLE FOR USE WITH AN AR(1) PROCESS.
!  IN THIS CASE THE FOLLOWING INSTRUCTIONS SHOULD BE USED FOR INITIALISATION.
!  V(1) = 1.0
!  A(1) = 0.0
!  P(1) = 1.0 / (1.0 - PHI(1) * PHI(1))

INTEGER, INTENT(IN)   :: ip
INTEGER, INTENT(IN)   :: iq
INTEGER, INTENT(IN)   :: ir
INTEGER, INTENT(IN)   :: np
REAL, INTENT(OUT)     :: phi(:)
REAL, INTENT(IN)      :: theta(:)
REAL, INTENT(OUT)     :: a(:)
REAL, INTENT(OUT)     :: p(:)
REAL, INTENT(OUT)     :: v(:)
REAL, INTENT(OUT)     :: thetab(:)
REAL, INTENT(OUT)     :: xnext(:)
REAL, INTENT(OUT)     :: xrow(:)
REAL, INTENT(OUT)     :: rbar(:)
INTEGER, INTENT(IN)   :: nrbar
INTEGER, INTENT(OUT)  :: ifault

REAL     :: vj, phii, phij, ssqerr, recres, ynext
INTEGER  :: i, ifail, ind, ind1, ind2, indi, indj, indn, irank, j, k, npr, npr1

!        CHECK FOR FAILURE INDICATION.

ifault = 0
IF (ip < 0) ifault = 1
IF (iq < 0) ifault = ifault + 2
IF (ip == 0 .AND. iq == 0) ifault = 4
k = iq + 1
IF (k < ip) k = ip
IF (ir /= k) ifault = 5
IF (np /= ir*(ir+1)/2) ifault = 6
IF (nrbar /= np*(np-1)/2) ifault = 7
IF (ir == 1) ifault = 8
IF (ifault /= 0) RETURN

!        NOW SET A(0), V AND PHI.

DO  i = 2, ir
  a(i) = zero
  IF (i > ip) phi(i) = zero
  v(i) = zero
  IF (i <= iq+1) v(i) = theta(i-1)
END DO
a(1) = zero
IF (ip == 0) phi(1) = zero
v(1) = one
ind = ir
DO  j = 2, ir
  vj = v(j)
  DO  i = j, ir
    ind = ind + 1
    v(ind) = v(i) * vj
  END DO
END DO

!        NOW FIND P(0).

IF (ip /= 0) THEN

!   THE SET OF EQUATIONS S * VEC(P(0)) = VEC(V) IS SOLVED FOR VEC(P(0)).
!   S IS GENERATED ROW BY ROW IN THE ARRAY XNEXT.
!   THE ORDER OF ELEMENTS IN P IS CHANGED, SO AS TO
!   BRING MORE LEADING ZEROS INTO THE ROWS OF S,
!   HENCE ACHIEVING A REDUCTION OF COMPUTING TIME.

  irank = 0
  ssqerr = zero
  rbar(1:nrbar) = zero
  DO  i = 1, np
    p(i) = zero
    thetab(i) = zero
    xnext(i) = zero
  END DO
  ind = 0
  ind1 = 0
  npr = np - ir
  npr1 = npr + 1
  indj = npr1
  ind2 = npr
  DO  j = 1, ir
    phij = phi(j)
    xnext(indj) = zero
    indj = indj + 1
    indi = npr1 + j
    DO  i = j, ir
      ind = ind + 1
      ynext = v(ind)
      phii = phi(i)
      IF (j /= ir) THEN
        xnext(indj) = -phii
        IF (i /= ir) THEN
          xnext(indi) = xnext(indi) - phij
          ind1 = ind1 + 1
          xnext(ind1) = -one
        END IF
      END IF
      xnext(npr1) = -phii * phij
      ind2 = ind2 + 1
      IF (ind2 > np) ind2 = 1
      xnext(ind2) = xnext(ind2) + one
      CALL inclu2(np,one,xnext,xrow,ynext,p,rbar,thetab,  &
                  ssqerr,recres,irank,ifail)

!        NO NEED TO CHECK IFAIL AS WEIGHT = 1.0

      xnext(ind2) = zero
      IF (i /= ir) THEN
        xnext(indi) = zero
        indi = indi + 1
        xnext(ind1) = zero
      END IF
    END DO
  END DO
  CALL regres(np,nrbar,rbar,thetab,p)

!        NOW RE-ORDER P.

  ind = npr
  DO  i = 1, ir
    ind = ind + 1
    xnext(i) = p(ind)
  END DO
  ind = np
  ind1 = npr
  DO  i = 1, npr
    p(ind) = p(ind1)
    ind = ind - 1
    ind1 = ind1 - 1
  END DO
  p(1:ir) = xnext(1:ir)

  RETURN
END IF

!        P(0) IS OBTAINED BY BACKSUBSTITUTION FOR A MOVING AVERAGE PROCESS.

indn = np + 1
ind = np + 1
DO  i = 1, ir
  DO  j = 1, i
    ind = ind - 1
    p(ind) = v(ind)
    IF (j /= 1) THEN
      indn = indn - 1
      p(ind) = p(ind) + p(indn)
    END IF
  END DO
END DO

RETURN
END SUBROUTINE starma

SUBROUTINE karma(ip,iq,ir,phi,theta,a,p,v,n,w,resid,sumlog,ssq,  &
                 iupd,delta,e,nit)

! N.B. Argument NP has been removed.

!   ALGORITHM AS 154.1  APPL. STATIST. (1980) VOL.29, P.311

!   INVOKING THIS SUBROUTINE UPDATES A, P, SUMLOG AND SSQ BY
!   INCLUSION OF DATA VALUES W(1) TO W(N).  THE CORRESPONDING
!   VALUES OF RESID ARE ALSO OBTAINED.
!   WHEN FT IS LESS THAN (1 + DELTA), QUICK RECURSIONS ARE USED.

INTEGER, INTENT(IN)      :: ip
INTEGER, INTENT(IN)      :: iq
INTEGER, INTENT(IN)      :: ir
REAL, INTENT(IN)         :: phi(:)
REAL, INTENT(IN)         :: theta(:)
REAL, INTENT(IN OUT)     :: a(:)
REAL, INTENT(IN OUT)     :: p(:)
REAL, INTENT(IN)         :: v(:)
INTEGER, INTENT(IN)      :: n
REAL, INTENT(IN)         :: w(:)
REAL, INTENT(OUT)        :: resid(:)
REAL, INTENT(IN OUT)     :: sumlog
REAL, INTENT(IN OUT)     :: ssq
INTEGER, INTENT(IN)      :: iupd
REAL, INTENT(IN)         :: delta
REAL, INTENT(OUT)        :: e(:)
INTEGER, INTENT(IN OUT)  :: nit

REAL     :: wnext, a1, dt, et, ft, ut, g
INTEGER  :: i, ii, ind, inde, indn, indw, ir1, j, l

ir1 = ir - 1
e(1:ir) = zero
inde = 1

!        FOR NON-ZERO VALUES OF NIT, PERFORM QUICK RECURSIONS.

IF (nit == 0) THEN
  DO  i = 1, n
    wnext = w(i)

!        PREDICTION.

    IF (iupd /= 1 .OR. i /= 1) THEN

!        HERE DT = FT - 1.0

      dt = zero
      IF (ir /= 1) dt = p(ir+1)
      IF (dt < delta) GO TO 100
      a1 = a(1)
      IF (ir /= 1) THEN
        DO  j = 1, ir1
          a(j) = a(j+1)
        END DO
      END IF
      a(ir) = zero
      IF (ip /= 0) THEN
        DO  j = 1, ip
          a(j) = a(j) + phi(j) * a1
        END DO
      END IF
      ind = 0
      indn = ir
      DO  l = 1, ir
        DO  j = l, ir
          ind = ind + 1
          p(ind) = v(ind)
          IF (j /= ir) THEN
            indn = indn + 1
            p(ind) = p(ind) + p(indn)
          END IF
        END DO
      END DO
    END IF

!        UPDATING.

    ft = p(1)
    ut = wnext - a(1)
    IF (ir /= 1) THEN
      ind = ir
      DO  j = 2, ir
        g = p(j) / ft
        a(j) = a(j) + g * ut
        DO  l = j, ir
          ind = ind + 1
          p(ind) = p(ind) - g * p(l)
        END DO
      END DO
    END IF
    a(1) = wnext
    p(1:ir) = zero
    resid(i) = ut / sqrt(ft)
    e(inde) = resid(i)
    inde = inde + 1
    IF (inde > iq) inde = 1
    ssq = ssq + ut * ut / ft
    sumlog = sumlog + log(ft)
  END DO
  nit = n
  RETURN
END IF

!        QUICK RECURSIONS

i = 1
100 nit = i - 1
DO  ii = i, n
  et = w(ii)
  indw = ii
  IF (ip /= 0) THEN
    DO  j = 1, ip
      indw = indw - 1
      IF (indw < 1) EXIT
      et = et - phi(j) * w(indw)
    END DO
  END IF
  IF (iq /= 0) THEN
    DO  j = 1, iq
      inde = inde - 1
      IF (inde == 0) inde = iq
      et = et - theta(j) * e(inde)
    END DO
  END IF
  e(inde) = et
  resid(ii) = et
  ssq = ssq + et * et
  inde = inde + 1
  IF (inde > iq) inde = 1
END DO

RETURN
END SUBROUTINE karma

SUBROUTINE kalfor(m,ip,ir,np,phi,a,p,v)

! N.B. Argument WORK has been removed.

!  ALGORITHM AS 154.2  APPL. STATIST. (1980) VOL.29, P.311

!  INVOKING THIS SUBROUTINE OBTAINS PREDICTIONS OF A AND P, M STEPS AHEAD.

INTEGER, INTENT(IN)      :: m
INTEGER, INTENT(IN)      :: ip
INTEGER, INTENT(IN)      :: ir
INTEGER, INTENT(IN OUT)  :: np
REAL, INTENT(IN)         :: phi(:)
REAL, INTENT(IN OUT)     :: a(:)
REAL, INTENT(IN OUT)     :: p(:)
REAL, INTENT(IN)         :: v(:)

REAL     :: dt, a1, phii, phij, phijdt, work(ir)
INTEGER  :: i, ind, ind1, ir1, j, l

ir1 = ir - 1
DO  l = 1, m

!        PREDICT A.

  a1 = a(1)
  IF (ir /= 1) THEN
    DO  i = 1, ir1
      a(i) = a(i+1)
    END DO
  END IF
  a(ir) = zero
  IF (ip /= 0) THEN
    DO  j = 1, ip
      a(j) = a(j) + phi(j) * a1
    END DO
  END IF

!        PREDICT P.

  work(1:ir) = p(1:ir)
  ind = 0
  ind1 = ir
  dt = p(1)
  DO  j = 1, ir
    phij = phi(j)
    phijdt = phij * dt
    DO  i = j, ir
      ind = ind + 1
      phii = phi(i)
      p(ind) = v(ind) + phii * phijdt
      IF (j < ir) p(ind) = p(ind) + work(j+1) * phii
      IF (i /= ir) THEN
        ind1 = ind1 + 1
        p(ind) = p(ind) + work(i+1) * phij + p(ind1)
      END IF
    END DO
  END DO
END DO

RETURN
END SUBROUTINE kalfor

SUBROUTINE inclu2(np,weight,xnext,xrow,ynext,d,rbar,thetab,  &
                  ssqerr,recres,irank,ifault)

! N.B. Argument NRBAR has been removed.

!   ALGORITHM AS 154.3  APPL. STATIST. (1980) VOL.29, P.311

!   FORTRAN VERSION OF REVISED VERSION OF ALGORITHM AS 75.1
!   APPL. STATIST. (1974) VOL.23, P.448
!   SEE REMARK AS R17 APPL. STATIST. (1976) VOL.25, P.323

INTEGER, INTENT(IN)   :: np
REAL, INTENT(IN)      :: weight
REAL, INTENT(IN)      :: xnext(:)
REAL, INTENT(OUT)     :: xrow(:)
REAL, INTENT(IN)      :: ynext
REAL, INTENT(IN OUT)  :: d(:)
REAL, INTENT(IN OUT)  :: rbar(:)
REAL, INTENT(IN OUT)  :: thetab(:)
REAL, INTENT(OUT)     :: ssqerr
REAL, INTENT(OUT)     :: recres
INTEGER, INTENT(OUT)  :: irank
INTEGER, INTENT(OUT)  :: ifault

REAL     :: wt, y, di, dpi, xi, xk, cbar, sbar, rbthis
INTEGER  :: i, i1, ithisr, k

!   INVOKING THIS SUBROUTINE UPDATES D, RBAR, THETAB, SSQERR
!   AND IRANK BY THE INCLUSION OF XNEXT AND YNEXT WITH A
!   SPECIFIED WEIGHT. THE VALUES OF XNEXT, YNEXT AND WEIGHT WILL
!   BE CONSERVED.  THE CORRESPONDING VALUE OF RECRES IS CALCULATED.

y = ynext
wt = weight
xrow(1:np) = xnext(1:np)
recres = zero
ifault = 1
IF (wt <= zero) RETURN
ifault = 0

ithisr = 0
DO  i = 1, np
  IF (xrow(i) == zero) THEN
    ithisr = ithisr + np - i
  ELSE
    xi = xrow(i)
    di = d(i)
    dpi = di + wt * xi * xi
    d(i) = dpi
    cbar = di / dpi
    sbar = wt * xi / dpi
    wt = cbar * wt
    IF (i /= np) THEN
      i1 = i + 1
      DO  k = i1, np
        ithisr = ithisr + 1
        xk = xrow(k)
        rbthis = rbar(ithisr)
        xrow(k) = xk - xi * rbthis
        rbar(ithisr) = cbar * rbthis + sbar * xk
      END DO
    END IF
    xk = y
    y = xk - xi * thetab(i)
    thetab(i) = cbar * thetab(i) + sbar * xk
    IF (di == zero) GO TO 40
  END IF
END DO
ssqerr = ssqerr + wt * y * y
recres = y * sqrt(wt)
RETURN

40 irank = irank + 1
RETURN
END SUBROUTINE inclu2

SUBROUTINE regres(np,nrbar,rbar,thetab,beta)

!   ALGORITHM AS 154.4  APPL. STATIST. (1980) VOL.29, P.311

!   REVISED VERSION OF ALGORITHM AS 75.4
!   APPL. STATIST. (1974) VOL.23, P.448
!   INVOKING THIS SUBROUTINE OBTAINS BETA BY BACKSUBSTITUTION
!   IN THE TRIANGULAR SYSTEM RBAR AND THETAB.

INTEGER, INTENT(IN)  :: np
INTEGER, INTENT(IN)  :: nrbar
REAL, INTENT(IN)     :: rbar(:)
REAL, INTENT(IN)     :: thetab(:)
REAL, INTENT(OUT)    :: beta(:)

REAL     :: bi
INTEGER  :: i, i1, im, ithisr, j, jm

ithisr = nrbar
im = np
DO  i = 1, np
  bi = thetab(im)
  IF (im /= np) THEN
    i1 = i - 1
    jm = np
    DO  j = 1, i1
      bi = bi - rbar(ithisr) * beta(jm)
      ithisr = ithisr - 1
      jm = jm - 1
    END DO
  END IF
  beta(im) = bi
  im = im - 1
END DO

RETURN
END SUBROUTINE regres

SUBROUTINE forkal(ip, iq, ir, np, ird, irz, id, il, n, nrbar, phi, theta,  &
                  delta, w, y, amse, a, p, v, resid, e, xnext, xrow,  &
                  rbar, thetab, store, ifault)

!  ALGORITHM AS 182  APPL. STATIST. (1982) VOL.31, NO.2

!  Finite sample prediction from ARIMA processes.

INTEGER, INTENT(IN)   :: ip
INTEGER, INTENT(IN)   :: iq
INTEGER, INTENT(IN)   :: ir
INTEGER, INTENT(IN)   :: np
INTEGER, INTENT(IN)   :: ird
INTEGER, INTENT(IN)   :: irz
INTEGER, INTENT(IN)   :: id
INTEGER, INTENT(IN)   :: il
INTEGER, INTENT(IN)   :: n
INTEGER, INTENT(IN)   :: nrbar
REAL, INTENT(OUT)     :: phi(:)
REAL, INTENT(IN)      :: theta(:)
REAL, INTENT(IN)      :: delta(:)
REAL, INTENT(IN OUT)  :: w(:)
REAL, INTENT(OUT)     :: y(:)
REAL, INTENT(OUT)     :: amse(:)
REAL, INTENT(OUT)     :: a(:)
REAL, INTENT(OUT)     :: p(:)
REAL, INTENT(OUT)     :: v(:)
REAL, INTENT(OUT)     :: resid(:)
REAL, INTENT(OUT)     :: e(:)
REAL, INTENT(OUT)     :: xnext(:)
REAL, INTENT(OUT)     :: xrow(:)
REAL, INTENT(OUT)     :: rbar(:)
REAL, INTENT(OUT)     :: thetab(:)
REAL, INTENT(OUT)     :: store(:)
INTEGER, INTENT(OUT)  :: ifault

!     Invoking this routine will calculate the finite sample predictions
!     and their conditional mean square errors for any ARIMA process.

INTEGER  :: i, i45, ibc, id1, id2r, id2r1, id2r2, idd1, idd2, iddr, idrr1, &
            idk, iid, ind, ind1, ind2, iq1, ir1, ir2, iri, iri1, irj, iupd, &
            j, j1, jj, jkl, jkl1, jklj, jrj, jrk, k, k1, kk, kk1, kkk, l, &
            lk, lk1, ll, lli, nit, nj, nt
REAL     :: a1, aa, ams, del, dt, phii, phij, phijdt, sigma, ssq, sumlog

!     Check for input faults.

ifault = 0
IF (ip < 0) ifault = 1
IF (iq < 0) ifault = ifault + 2
IF (ip * ip + iq * iq == 0) ifault = 4
k = iq + 1
IF (k < ip) k = ip
IF (ir /= k) ifault = 5
IF (np /= ir * (ir + 1) / 2) ifault = 6
IF (nrbar /= np * (np - 1) / 2) ifault = 7
IF (id < 0) ifault = 8
IF (ird /= ir + id) ifault = 9
IF (irz /= ird * (ird + 1) / 2) ifault = 10
IF (il < 1) ifault = 11
IF (ifault /= 0) RETURN

!     Calculate initial conditions for Kalman filter

a(1) = zero
v(1) = one
IF (np == 1) GO TO 130
v(2:np) = zero
IF (iq == 0) GO TO 130
iq1 = iq + 1
DO  i = 2, iq1
  v(i) = theta(i-1)
END DO
DO  j = 1, iq
  ll = j * (2*ir + 1 - j) / 2
  DO  i = j, iq
    lli = ll + i
    v(lli) = theta(i) * theta(j)
  END DO
END DO

!     Find initial likelihood conditions.
!     IFAULT not tested on exit from STARMA as all possible errors
!     have been checked above.

130 IF (ir == 1) p(1) = one / (one - phi(1) * phi(1))
IF (ir /= 1) CALL starma(ip, iq, ir, np, phi, theta, a, p, v,  &
                         thetab, xnext, xrow, rbar, nrbar, ifault)

!     Calculate data transformations

nt = n - id
IF (id == 0) GO TO 170
DO  j = 1, id
  nj = n - j
  store(j) = w(nj)
END DO
DO  i = 1, nt
  aa = zero
  DO  k = 1, id
    idk = id + i - k
    aa = aa - delta(k) * w(idk)
  END DO
  iid = i + id
  w(i) = w(iid) + aa
END DO

!     Evaluate likelihood to obtain final KF conditions

170 sumlog = zero
ssq = zero
iupd = 1
del = - one
nit = 0
CALL karma(ip, iq, ir, phi, theta, a, p, v, nt, w, resid,  &
           sumlog, ssq, iupd, del, e, nit)

!     Calculate M.L.E. of sigma squared

sigma = zero
DO  j = 1, nt
  sigma = sigma + resid(j)**2
END DO
sigma = sigma / nt

!     Reset the initial A and P when differencing occurs

IF (id == 0) GO TO 250
DO  i = 1, np
  xrow(i) = p(i)
END DO
DO  i = 1, irz
  p(i) = zero
END DO
ind = 0
DO  j = 1, ir
  k = (j-1) * (id + ir + 1) - (j-1) * j / 2
  DO  i = j, ir
    ind = ind + 1
    k = k + 1
    p(k) = xrow(ind)
  END DO
END DO
DO  j = 1, id
  irj = ir + j
  a(irj) = store(j)
END DO

!     Set up constants

250 ir2 = ir + 1
ir1 = ir - 1
id1 = id - 1
id2r = 2 * ird
id2r1 = id2r - 1
idd1 = 2 * id + 1
idd2 = idd1 + 1
i45 = id2r + 1
idrr1 = ird + 1
iddr = 2 * id + ir
jkl = ir * (iddr + 1) / 2
jkl1 = jkl + 1
id2r2 = id2r + 2
ibc = ir * (i45 - ir) / 2
DO  l = 1, il

!     Predict A

  a1 = a(1)
  IF (ir == 1) GO TO 310
  DO  i = 1, ir1
    a(i) = a(i+1)
  END DO
  310 a(ir) = zero
  IF (ip == 0) GO TO 330
  DO  j = 1, ip
    a(j) = a(j) + phi(j) * a1
  END DO
  330 IF (id == 0) GO TO 360
  DO  j = 1, id
    irj = ir + j
    a1 = a1 + delta(j) * a(irj)
  END DO
  IF (id < 2) GO TO 360
  DO  i = 1, id1
    iri1 = ird - i
    a(iri1 + 1) = a(iri1)
  END DO
  360 a(ir2) = a1

!     Predict P

  IF (id == 0) GO TO 480
  DO  i = 1, id
    store(i) = zero
    DO  j = 1, id
      ll = MAX(i,j)
      k = MIN(i,j)
      jj = jkl + (ll - k) + 1 + (k-1) * (idd2 - k) / 2
      store(i) = store(i) + delta(j) * p(jj)
    END DO
  END DO

  DO  j = 1, id1
    jj = id - j
    lk = (jj-1) * (idd2 - jj) / 2 + jkl
    lk1 = jj * (idd1 - jj) / 2 + jkl
    DO  i = 1, j
      lk = lk + 1
      lk1 = lk1 + 1
      p(lk1) = p(lk)
    END DO
  END DO
  DO  j = 1, id1
    jklj = jkl1 + j
    irj = ir + j
    p(jklj) = store(j) + p(irj)
  END DO

  p(jkl1) = p(1)
  DO  i = 1, id
    iri = ir + i
    p(jkl1) = p(jkl1) + delta(i) * (store(i) + two * p(iri))
  END DO
  DO  i = 1, id
    iri = ir + i
    store(i) = p(iri)
  END DO
  DO  j = 1, ir
    kk1 = j * (id2r1 - j) / 2 + ir
    k1 = (j-1) * (id2r - j) / 2 + ir
    DO  i = 1, id
      kk = kk1 + i
      k = k1 + i
      p(k) = phi(j) * store(i)
      IF (j /= ir) p(k) = p(k) + p(kk)
    END DO
  END DO

  DO  j = 1, ir
    store(j) = zero
    kkk = j * (i45 - j) / 2 - id
    DO  i = 1, id
      kkk = kkk + 1
      store(j) = store(j) + delta(i) * p(kkk)
    END DO
  END DO
  IF (id == 1) GO TO 460
  DO  j = 1, ir
    k = j * idrr1 - j * (j+1) / 2 + 1
    DO  i = 1, id1
      k = k - 1
      p(k) = p(k-1)
    END DO
  END DO
  460 DO  j = 1, ir
    k = (j-1) * (id2r - j) / 2 + ir + 1
    p(k) = store(j) + phi(j) * p(1)
    IF (j < ir) p(k) = p(k) + p(j+1)
  END DO
  480 store(1:ir) = p(1:ir)

  ind = 0
  dt = p(1)
  DO  j = 1, ir
    phij = phi(j)
    phijdt = phij * dt
    ind2 = (j-1) * (id2r2 - j) / 2
    ind1 = j * (i45 - j) / 2
    DO  i = j, ir
      ind = ind + 1
      ind2 = ind2 + 1
      phii = phi(i)
      p(ind2) = v(ind) + phii * phijdt
      IF (j < ir) p(ind2) = p(ind2) + store(j+1) * phii
      IF (i == ir) CYCLE
      ind1 = ind1 + 1
      p(ind2) = p(ind2) + store(i+1) * phij + p(ind1)
    END DO
  END DO

!     Predict Y

  y(l) = a(1)
  IF (id == 0) GO TO 520
  DO  j = 1, id
    irj = ir + j
    y(l) = y(l) + a(irj) * delta(j)
  END DO

!     Calculate M.S.E. of Y

  520 ams = p(1)
  DO  j = 1, id
    jrj = ibc + (j-1) * (idd2 - j) / 2
    irj = ir + j
    ams = ams + two * delta(j) * p(irj) + p(jrj+1) * delta(j)**2
  END DO
  DO  j = 1, id1
    j1 = j + 1
    jrk = ibc + 1 + (j-1) * (idd2 - j) / 2
    DO  i = j1, id
      jrk = jrk + 1
      ams = ams + two * delta(i) * delta(j) * p(jrk)
    END DO
  END DO
  amse(l) = ams * sigma
END DO

RETURN
END SUBROUTINE forkal

END MODULE arma_estimation


! ================================================================================================ !
!  RANLUX
! ~~~~~~~~
!                                 default
!   Luxury Level    0     1     2   *3*    4
!    data ndskip    0    24    73   199   365
! Corresponds to p=24    48    97   223   389
!      time factor  1    2     3     6    10   on slow workstation
!                   1   1.5    2     3     5   on fast mainframe
!
! Reference:
! James, F. ‘RANLUX: A FORTRAN Implementation of the High Quality Pseudorandom Number Generator of
!     Luscher’. Comput.Phys.Commun. 79 (1994): 111–14. https://doi.org/10.1016/0010-4655(94)90233-X.
! ================================================================================================ !
module mod_ranlux

  use floatPrecision
  use numerical_constants

  implicit none

  private

  integer jseed,lp,i,k,inner,izip,izip2,ivec,isk,isd,ilx,iouter

  integer, parameter :: maxlev = 4
  integer, parameter :: lxdflt = 3
  integer, parameter :: igiga = 1000000000
  integer, parameter :: itwo24 = 2**24
  integer, parameter :: jsdflt = 314159265
  integer, parameter :: icons = 2147483563

  integer, save :: ndskip(0:maxlev) = [0, 24, 73, 199, 365]
  integer, save :: isdext(25)
  integer, save :: iseeds(24)
  integer, save :: next(24)

  real(kind=fPrec), parameter :: twop12 = 4096.0
  real(kind=fPrec), save :: seeds(24)
  real(kind=fPrec), save :: twom12
  real(kind=fPrec), save :: twom24
  real(kind=fPrec), save :: carry = zero
  real(kind=fPrec) :: uni

  integer, save :: luxlev = lxdflt
  logical, save :: notyet = .true.
  integer, save :: in24 = 0
  integer, save :: i24 = 24
  integer, save :: j24 = 10
  integer, save :: kount = 0
  integer, save :: mkount = 0
  integer, save :: inseed
  integer, save :: nskip

  public ranlux
  public rluxin
  public rluxut
  public rluxat
  public rluxgo
  public rndm4
  public rndm5
  public coll_rand
  public ran_gauss
  public ran_gauss2

contains

!         Subtract-and-borrow random number generator proposed by
!         Marsaglia and Zaman, implemented by F. James with the name
!         RCARRY in 1991, and later improved by Martin Luescher
!         in 1993 to produce "Luxury Pseudorandom Numbers".
!     Fortran 77 coded by F. James, 1993
!
!   LUXURY LEVELS.
!   ------ ------      The available luxury levels are:
!
!  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
!           and Zaman, very long period, but fails many tests.
!  level 1  (p=48): considerable improvement in quality over level 0,
!           now passes the gap test, but still fails spectral test.
!  level 2  (p=97): passes all known tests, but theoretically still
!           defective.
!  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
!           correlations have very small chance of being observed.
!  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
!
!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!!!  Calling sequences for RANLUX:                                  ++
!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
!!!                   32-bit random floating point numbers between  ++
!!!                   zero (not included) and one (also not incl.). ++
!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
!!!               which is integer between zero and MAXLEV, or if   ++
!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
!!!               should be set to zero unless restarting at a break++
!!!               point given by output of RLUXAT (see RLUXAT).     ++
!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
!!!               which can be used to restart the RANLUX generator ++
!!!               at the current point by calling RLUXGO.  K1 and K2++
!!!               specify how many numbers were generated since the ++
!!!               initialization with LUX and INT.  The restarting  ++
!!!               skips over  K1+K2*E9   numbers, so it can be long.++
!!!   A more efficient but less convenient way of restarting is by: ++
!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
!!!                 32-bit integer seeds, to be used for restarting ++
!!!      ISVEC must be dimensioned 25 in the calling program        ++
!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
subroutine ranlux(rvec,lenv)

  use crcoall

  integer,          intent(in)  :: lenv
  real(kind=fPrec), intent(out) :: rvec(lenv)

  ! NOTYET is .TRUE. if no initialization has been performed yet.
  !             Default Initialization by Multiplicative Congruential
  if(notyet) then
    notyet = .false.
    jseed = jsdflt
    inseed = jseed
    write(lout,"(a,i0)") "RANLUX> Default initialization: ",jseed
    luxlev = lxdflt
    nskip  = ndskip(luxlev)
    lp     = nskip + 24
    in24   = 0
    kount  = 0
    mkount = 0
    twom24 = 1.0
    do i=1,24
      twom24 = twom24 * 0.5
      k = jseed/53668
      jseed = 40014*(jseed-k*53668) -k*12211
      if(jseed < 0) jseed = jseed+icons
      iseeds(i) = mod(jseed,itwo24)
    end do
    twom12 = twom24 * twop12
    do i=1,24
      seeds(i) = real(iseeds(i))*twom24
      next(i) = i-1
    end do
    next(1) = 24
    i24     = 24
    j24     = 10
    carry   = 0.0
    if (seeds(24) == 0.0) carry = twom24
  end if

  ! The Generator proper: "Subtract-with-borrow",
  ! as proposed by Marsaglia and Zaman,
  ! Florida State University, March, 1989

  do ivec=1,lenv
    uni = seeds(j24) - seeds(i24) - carry
    if(uni < 0.0) then
      uni = uni + 1.0
      carry = twom24
    else
      carry = 0.0
    end if
    seeds(i24) = uni
    i24 = next(i24)
    j24 = next(j24)
    rvec(ivec) = uni

    ! small numbers (with less than 12 "significant" bits) are "padded".
    if(uni < twom12) then
      rvec(ivec) = rvec(ivec) + twom24*seeds(j24)
      ! and zero is forbidden in case someone takes a logarithm
      if(rvec(ivec) == 0.0) rvec(ivec) = twom24*twom24
    end if

    ! Skipping to luxury.  As proposed by Martin Luscher.
    in24 = in24 + 1
    if(in24 == 24) then
      in24 = 0
      kount = kount + nskip
      do isk=1,nskip
        uni = seeds(j24) - seeds(i24) - carry
        if(uni < 0.0) then
          uni = uni + 1.0
          carry = twom24
        else
          carry = 0.0
        end if
        seeds(i24) = uni
        i24 = next(i24)
        j24 = next(j24)
      end do
    end if
  end do

  kount = kount + lenv
  if(kount >= igiga) then
    mkount = mkount + 1
    kount = kount - igiga
  end if

end subroutine ranlux

! Entry to input and float integer seeds from previous run
subroutine rluxin(isdext_tmp)

  use crcoall

  integer, intent(in) :: isdext_tmp(25)

  isdext = isdext_tmp
  notyet = .false.
  twom24 = 1.0
  do i=1,24
    next(i) = i-1
    twom24 = twom24 * 0.5
  end do
  next(1) = 24
  twom12 = twom24 * twop12
  write(lout,"(a)")       "RANLUX> Full initialisation of ranlux with 25 integers: "
! write(lout,"(a,25i12)") "RANLUX> ",isdext
  do i=1,24
    seeds(i) = real(isdext(i))*twom24
  end do

  carry = 0.0
  if(isdext(25) < 0) carry = twom24
  isd = iabs(isdext(25))
  i24 = mod(isd,100)
  isd = isd/100
  j24 = mod(isd,100)
  isd = isd/100
  in24 = mod(isd,100)
  isd = isd/100
  luxlev = isd
  if(luxlev <= maxlev) then
    nskip = ndskip(luxlev)
    write(lout,"(a,i0)") "RANLUX> Luxury level set by rluxin to ",luxlev
  else if(luxlev >= 24) then
    nskip = luxlev - 24
    write(lout,"(a,i0)") "RANLUX> P-value set by rluxin to ",luxlev
  else
    nskip = ndskip(maxlev)
    write(lout,"(a,i0)") "RANLUX> Illegal luxury rluxin ",luxlev
    luxlev = maxlev
  end if
  inseed = -1

end subroutine rluxin

! Entry to ouput seeds as integers
subroutine rluxut(isdext_tmp)

  integer, intent(out) :: isdext_tmp(25)

  do i=1,24
    isdext_tmp(i) = int(seeds(i)*twop12*twop12)
  end do
  isdext_tmp(25) = i24 + 100*j24 + 10000*in24 + 1000000*luxlev
  if(carry > 0.0) isdext_tmp(25) = -isdext_tmp(25)

end subroutine rluxut

! Entry to output the "convenient" restart point
subroutine rluxat(lout2,inout,k1,k2)

  integer, intent(out) :: lout2,inout,k1,k2

  lout2 = luxlev
  inout = inseed
  k1    = kount
  k2    = mkount

end subroutine rluxat

! Entry to initialize from one or three integers
subroutine rluxgo(lux,ins,k1,k2)

  use crcoall

  integer, intent(in) :: lux,ins,k1,k2

  if(lux < 0) then
    luxlev = lxdflt
  elseif(lux <= maxlev) then
    luxlev = lux
  elseif(lux < 24 .or. lux > 2000) then
    luxlev = maxlev
    write(lout,"(a,i0)") "RANLUX> Illegal luxury rluxgo ",lux
  else
    luxlev = lux
    do ilx=0,maxlev
      if(lux == ndskip(ilx)+24) luxlev = ilx
    end do
  end if

  if(luxlev <= maxlev) then
    nskip = ndskip(luxlev)
!    write(lout,"(a,i0,a,i0)") "RANLUX> Luxury level set by rluxgo: ",luxlev," P = ",nskip+24
  else
    nskip = luxlev - 24
    write(lout,"(a,i0)") "RANLUX> P-value set by rluxgo to ",luxlev
  end if

  in24 = 0

  if(ins < 0) write(lout,"(a)") "RANLUX> Illegal initialisation by RLUXGO, negative input seed"
  if(ins > 0) then
    jseed = ins
!    write(lout,"(a,3(1x,i0))") "RANLUX> Initialised by rluxgo from seeds ",jseed,k1,k2
  else
    jseed = jsdflt
!    write(lout,"(a)") "RANLUX> Initialised by rluxgo from default seed"
  end if

  inseed = jseed
  notyet = .false.
  twom24 = 1.0
  do i=1,24
    twom24 = twom24 * 0.5
    k = jseed/53668
    jseed = 40014*(jseed-k*53668) - k*12211
    if(jseed < 0) jseed = jseed+icons
    iseeds(i) = mod(jseed,itwo24)
  end do

  twom12 = twom24 * twop12
  do i=1,24
    seeds(i) = real(iseeds(i))*twom24
    next(i) = i-1
  end do

  next(1) = 24
  i24     = 24
  j24     = 10
  carry   = 0.0
  if(seeds(24) == 0.0) carry = twom24

  ! If restarting at a break point, skip K1 + IGIGA*K2
  ! Note that this is the number of numbers delivered to
  ! the user PLUS the number skipped (if luxury .GT. 0).
  kount = k1
  mkount = k2
  if(k1+k2 /= 0) then
    do iouter=1,k2+1
      inner = igiga
      if(iouter == k2+1) inner = k1
      do isk=1,inner
        uni = seeds(j24) - seeds(i24) - carry
        if(uni < 0.) then
          uni = uni + 1.0
          carry = twom24
        else
          carry = 0.0
        end if
        seeds(i24) = uni
        i24 = next(i24)
        j24 = next(j24)
      end do
    end do

    ! Get the right value of IN24 by direct calculation
    in24 = mod(kount, nskip+24)
    if(mkount > 0) then
      izip = mod(igiga, nskip+24)
      izip2 = mkount*izip + in24
      in24 = mod(izip2, nskip+24)
    end if

    ! Now IN24 had better be between zero and 23 inclusive
    if(in24 > 23) then
      write(lerr,"(a)")               "RANLUX> ERROR RESTARTING with RLUXGO:"
      write(lerr,"(a,3(1x,i0),a,i0)") "RANLUX>       The values",ins,k1,k2," cannot occur at luxury level ",luxlev
      in24 = 0
    end if
  end if

end subroutine rluxgo

function rndm4()

  integer len, in
  real(kind=fPrec) rndm4, a

  save in,a

  parameter ( len =  30000 )
  dimension a(len)
  data in/1/

  if(in == 1) then
    call ranlux(a,len)
!    call ranecu(a,len,-1)
    rndm4=a(1)
    in=2
  else
    rndm4=a(in)
    in=in+1
    if(in == len+1)in=1
  endif

end function rndm4

!ccccccccccccccccccccccccccccccccccccccc
!-TW-01/2007
! function rndm5(irnd) , irnd = 1 will reset
! inn counter => enables reproducible set of
! random unmbers
!cccccccccccccccccccccccccccccccccc
!
function rndm5(irnd)

  use mathlib_bouncer

  implicit none

  integer len, inn, irnd
  real(kind=fPrec) rndm5,a
  save

  parameter( len =  30000 )
  dimension a(len)
  data inn/1/
!
! reset inn to 1 enable reproducible random numbers
  if(irnd == 1) inn = 1

  if(inn == 1) then
    call ranlux(a,len)
!     call ranecu(a,len,-1)
    rndm5=a(1)
    inn=2
  else
    rndm5=a(inn)
    inn=inn+1
    if(inn == len+1) inn=1
  end if

end function rndm5

!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! function coll_rand()
! to be used for the collimation code with CR enabled.
! we get a fresh random number every call, so no need to have a 30k buffer here.
! Therefore this is the same as rndm5 with an argument of 1 every time
!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
function coll_rand()

  use mathlib_bouncer

  implicit none

  integer len
  real(kind=fPrec) coll_rand,a
  save

  parameter( len =  1 )
  dimension a(len)

  call ranlux(a,len)
  coll_rand=a(1)

end function coll_rand

!*********************************************************************
!
! RAN_GAUSS - will generate a normal distribution from a uniform
!   distribution between [0,1].
!   See "Communications of the ACM", V. 15 (1972), p. 873.
!
! cut - real(kind=fPrec) - cut for distribution in units of sigma
!                the cut must be greater than 0.5
!
!*********************************************************************
real(kind=fPrec) function ran_gauss(cut)

  use mathlib_bouncer

  real(kind=fPrec), intent(in) :: cut

  logical :: flag = .true.
  real(kind=fPrec) :: x, u1, u2, r

  save

1 if (flag) then
    r  = rndm4()
    r  = max(r, half**32)
    r  = min(r, one-half**32)
    u1 = sqrt(-two*log_mb( r ))
    u2 = rndm4()
    x  = u1 * cos_mb(twopi*u2)
  else
    x  = u1 * sin_mb(twopi*u2)
  end if

  flag = .not. flag

  ! Cut the distribution if cut > 0.5
  if(cut > half .and. abs(x) > cut) goto 1

  ran_gauss = x

end function ran_gauss

!*********************************************************************
!
! ran_gauss2 - will generate a normal distribution from a uniform
!     distribution between [0,1].
!     See "Communications of the ACM", V. 15 (1972), p. 873.
!
!     cut - real(kind=fPrec) - cut for distribution in units of sigma
!     the cut must be greater than 0.5
!
!     changed rndm4 to rndm5(irnd) and defined flag as true
!
!*********************************************************************
real(kind=fPrec) function ran_gauss2(cut)

  use numerical_constants, only : twopi
  use mathlib_bouncer

  logical flag
  real(kind=fPrec) x, u1, u2, r,cut
  save

  flag = .true. !Does this initialize only once, or is it executed every pass?
                !See ran_gauss(cut)

1 if (flag) then
    r = real(rndm5(0),fPrec)
    r = max(r, half**32)
    r = min(r, one-half**32)
    u1 = sqrt(-two*log_mb( r ))
    u2 = real(rndm5(0),fPrec)
    x = u1 * cos_mb(twopi*u2)
  else
    x = u1 * sin_mb(twopi*u2)
  endif

  flag = .not. flag

  ! cut the distribution if cut > 0.5
  if(cut > half .and. abs(x) > cut) goto 1

  ran_gauss2 = x

end function ran_gauss2

end module mod_ranlux


SUBROUTINE compute_g(nz,natoms,nblocks,gdim,G,H,z,parent,taunew,block_start,block_dim)

  use parameters, only : dp, tpi
  use general, only : hdim, nkp, nspin, xk, wk, tau, block_atom

  implicit none

  INTEGER, INTENT(IN) :: nz, natoms, nblocks, gdim, parent(natoms), block_start(nblocks), block_dim(nblocks)
  COMPLEX(DP), INTENT(IN) :: H(hdim,hdim,nkp,nspin), z(nz)
  REAL(DP), INTENT(IN) :: taunew(3,natoms)
  COMPLEX(DP), INTENT(OUT) :: G(nz,natoms,natoms,gdim,gdim,nspin)

  INTEGER :: i,j,k, ia, ja, ik, ispin, iz, istart, jstart
  COMPLEX(DP) :: kphase
  COMPLEX(DP), ALLOCATABLE :: Gloc(:,:)

  G = cmplx(0.0,0.0,dp)

  allocate(Gloc(hdim,hdim))

  !$OMP PARALLEL PRIVATE(Gloc,kphase,istart,jstart)
  do ispin = 1, nspin
    DO ik = 1, nkp

      !$OMP DO
      DO iz = 1, nz

        CALL compute_gloc(Gloc,H(:,:,ik,ispin),z(iz))

        DO ia = 1, natoms
          DO ja = 1, natoms
            ! exp(i*k*(Ri-Rj))
            kphase = cdexp( 1.d0*DCMPLX(0.d0,1.d0)*tpi*&
                DOT_PRODUCT( xk(:,ik), &
                  ((taunew(:,ia)-tau(:,block_atom(parent(ia))))-(taunew(:,ja)-tau(:,block_atom(parent(ja)))) ) ))

            istart = block_start(parent(ia))-1
            jstart = block_start(parent(ja))-1

            DO i = 1, block_dim(parent(ia))
              DO j = 1, block_dim(parent(ja))
                  G(iz,ia,ja,i,j,ispin) = G(iz,ia,ja,i,j,ispin) + wk(ik)*Gloc(istart+i,jstart+j)*kphase
              END DO
            END DO

          END DO
        END DO

      END DO
      !$OMP END DO

    END DO
  end do
  !$OMP END PARALLEL

  deallocate(Gloc)

END SUBROUTINE compute_g

subroutine compute_gloc(Gloc,H,z)
  use parameters, only : dp
  use general, only: hdim, efermi, nkp

  implicit none

  complex(dp), intent(in) :: H(hdim,hdim), z
  complex(dp), intent(out) :: Gloc(hdim,hdim)

  complex(dp) ::  tmp(hdim,hdim)
  integer :: i, j

  Gloc = cmplx(0.0,0.0,dp)

  tmp(:,:) = -1.d0*H(:,:)

  do i=1, hdim
    tmp(i,i) = z + tmp(i,i) + cmplx(efermi,0.d0)
  end do

  call inverse_complex_matrix(hdim,tmp)

  Gloc(:,:) = tmp(:,:)

end subroutine compute_gloc