!+This file contains routines for parallel random number generation and a basic
!+sparse array implementation
module utilities
    !+ Utilities for parallel random number generation and sparse arrays
#ifdef _OMP
  use omp_lib
#endif

use iso_c_binding
implicit none
private
public :: ind2sub, sub2ind, time, cumsum
public :: rng_type, rng_init, rng_seed, get_rng, rng, randind_cdf
public :: rng_uniform, rng_normal, randu, randn, randind
public :: SparseArray, get_value, sparse
public :: deriv
public :: InterpolCoeffs1D, InterpolCoeffs2D, InterpolCoeffs3D
public :: interpol, interpol_coeff
#ifdef _DEF_INTR
public :: norm2
#endif

!============================================================================
!------------------------------- Parameters ---------------------------------
!============================================================================

integer, parameter :: Int32 = 4
integer, parameter :: Int64 = kind(int8(1))
integer, parameter :: Float32 = kind(1.e0)
integer, parameter :: Float64 = kind(1.d0)

integer(Int32), parameter :: IA = 16807
integer(Int32), parameter :: IM = 2147483647
integer(Int32), parameter :: IQ = 127773
integer(Int32), parameter :: IR = 2836

integer, parameter :: ns = 2

!============================================================================
!---------------------------------- Types -----------------------------------
!============================================================================

type :: rng_type
    !+ Random Number Generator Derived Type
    integer(Int32) :: seed
    integer(Int32), dimension(ns) :: state
end type rng_type

type(rng_type), dimension(:), allocatable :: rng

type SparseArray
    integer :: nnz = 0
        !+ Number of non-zero elements
    integer :: nd = 0
        !+ Number of dimensions
    integer, dimension(:), allocatable :: dims
        !+ Dimensions of array
    integer, dimension(:), allocatable :: inds
        !+ Linear index of non-zero elements
    real(Float64), dimension(:), allocatable :: vals
        !+ Array values
end type SparseArray

type InterpolCoeffs1D
    !+ Linear Interpolation Coefficients and indices
    integer :: i = 0
        !+ Index of position right before `xout`
    real(Float64) :: b1 = 0.d0
        !+ Coefficient for y(i) term
    real(Float64) :: b2 = 0.d0
        !+ Coefficient for y(i+1) term
end type InterpolCoeffs1D

type InterpolCoeffs2D
    !+ 2D Linear Interpolation Coefficients and indices
    integer :: i = 0
        !+ Index of abscissa before `xout`
    integer :: j = 0
        !+ Index of ordinate before `yout`
    real(Float64) :: b11 = 0.d0
        !+ Coefficient for z(i,j) term
    real(Float64) :: b12 = 0.d0
        !+ Coefficient for z(i,j+1) term
    real(Float64) :: b21 = 0.d0
        !+ Coefficient for z(i+1,j) term
    real(Float64) :: b22 = 0.d0
        !+ Coefficient for z(i+1,j+1) term
end type InterpolCoeffs2D

type InterpolCoeffs3D
    !+ 3D Cylindrical Interpolation Coefficients and indices
    integer :: i = 0
        !+ Index of R before `rout`
    integer :: j = 0
        !+ Index of Z before `zout`
    integer :: k = 0
        !+ Index of Phi before `phiout`
    real(Float64) :: b111 = 0.d0
        !+ Coefficient for z(i,j,k) term
    real(Float64) :: b121 = 0.d0
        !+ Coefficient for z(i,j+1,k) term
    real(Float64) :: b112 = 0.d0
        !+ Coefficient for z(i,j,k+1) term
    real(Float64) :: b122 = 0.d0
        !+ Coefficient for z(i,j+1,k+1) term
    real(Float64) :: b211 = 0.d0
        !+ Coefficient for z(i+1,j,k) term
    real(Float64) :: b212 = 0.d0
        !+ Coefficient for z(i+1,j,k+1) term
    real(Float64) :: b221 = 0.d0
        !+ Coefficient for z(i+1,j+1,k) term
    real(Float64) :: b222 = 0.d0
        !+ Coefficient for z(i+1,j+1,k+1) term
end type InterpolCoeffs3D

!============================================================================
!-------------------------------- Interfaces --------------------------------
!============================================================================

interface randu
    module procedure randu_arr
    module procedure randu_r_arr
end interface

interface randn
    module procedure randn_arr
    module procedure randn_r_arr
end interface

interface randind_cdf
    !+ Procedure for generating a random array index/subscripts
    module procedure randind_r_cdf_1
    module procedure randind_cdf_1
end interface

interface randind
    !+ Procedure for generating a random array index/subscripts
    module procedure randind_n
    module procedure randind_w_1
    module procedure randind_w_2
    module procedure randind_w_3
    module procedure randind_w_4
    module procedure randind_w_5
    module procedure randind_r_n
    module procedure randind_r_w_1
    module procedure randind_r_w_2
    module procedure randind_r_w_3
    module procedure randind_r_w_4
    module procedure randind_r_w_5
end interface

interface search_sorted_first
    !+ Function for searching a sorted array
    module procedure search_sorted_first_integer
    module procedure search_sorted_first_float64
end interface

interface sparse
    !+ Creates a sparse array from a dense array
    module procedure sparse_1
    module procedure sparse_2
    module procedure sparse_3
    module procedure sparse_4
end interface

interface deriv
    !+ Procedure for finding derivatives from an array
    module procedure deriv_1d
    module procedure deriv_2d
    module procedure deriv_3d
end interface

interface interpol_coeff
    !+ Calculates interpolation coefficients
    module procedure interpol1D_coeff, interpol1D_coeff_arr
    module procedure interpol2D_coeff, interpol2D_coeff_arr
    module procedure cyl_interpol3D_coeff, cyl_interpol3D_coeff_arr
end interface

interface interpol
    !+ Performs linear/bilinear/cylindrical interpolation
    module procedure interpol1D_arr
    module procedure interpol2D_arr, interpol2D_2D_arr
    module procedure interpol3D_arr, interpol3D_2D_arr
end interface

contains

!============================================================================
!---------------------------Array Indexing Routines--------------------------
!============================================================================
subroutine ind2sub(dims,ind,subs)
    !+ Calculate the subscripts `subs` into an array with dimensions `dims`
    !+ given the corresponding linear index `ind`
    integer, dimension(:), intent(in)  :: dims
        !+ Dimensions of array
    integer, intent(in)                :: ind
        !+ Linear index
    integer, dimension(:), intent(out) :: subs
        !+ Subscripts corresponding to the linear index

    integer :: i, ndims, ind1, ind2

    ind1=ind
    ndims = size(dims)
    do i=1,ndims-1
        ind2 = (ind1-1)/dims(i) + 1
        subs(i) = ind1 - dims(i)*(ind2-1)
        ind1 = ind2
    enddo
    subs(ndims) = ind1

end subroutine ind2sub

function sub2ind(dims, subs) result (ind)
    !+ Calculates the linear index of an array with dimensions `dims` and
    !+ subcripts `subs`
    integer, dimension(:), intent(in) :: dims
        !+ Dimension of Array
    integer, dimension(:), intent(in) :: subs
        !+ Subscripts to convert
    integer :: ind
        !+ Linear index

    integer :: k, l, p

    ind = subs(1)
    do k=2,size(dims)
        p = dims(1)
        do l=2, k-1
            p = p*dims(l)
        enddo
        ind = ind + p*(subs(k)-1)
    enddo

end function sub2ind

!============================================================================
!-------------------------------Search Routines------------------------------
!============================================================================
function search_sorted_first_integer(x, v) result(hi)
    !+ Returns the index of the first value in `x` greater or equal to `v`.
    !+ Returns `length(x)+1` if `v` is greater then all values in `x`.
    integer, dimension(:), intent(in) :: x
        !+ Monotonically increasing array
    integer, intent(in)               :: v
        !+ Value to search

    integer :: hi, lo, m

    lo = 0
    hi = size(x)+1

    do while (lo.lt.(hi-1))
        m = rshift(lo+hi,1)
        if(x(m).lt.v) then
            lo = m
        else
            hi = m
        endif
    enddo

end function search_sorted_first_integer

function search_sorted_first_float64(x, v) result(hi)
    !+ Returns the index of the first value in `x` greater or equal to `v`.
    !+ Returns `length(x)+1` if `v` is greater then all values in `x`.
    real(Float64), dimension(:), intent(in) :: x
        !+ Monotonically increasing array
    real(Float64), intent(in)               :: v
        !+ Value to search

    integer :: hi, lo, m

    lo = 0
    hi = size(x)+1

    do while (lo.lt.(hi-1))
        m = rshift(lo+hi,1)
        if(x(m).lt.v) then
            lo = m
        else
            hi = m
        endif
    enddo

end function search_sorted_first_float64

!============================================================================
!-----------------------Parallel Random Number Routines----------------------
!============================================================================
function rng_seed() result (seed)
    !+ Generates random 32-bit integer seed from `/dev/urandom`
    integer(Int32) :: seed
        !+ Seed value

    open(89, file="/dev/urandom", access="stream", form="unformatted", action="read", status="old")
    read(89) seed
    close(89)
    seed = abs(seed)

end function rng_seed

subroutine rng_init(self, seed)
#ifdef _MPI
    use mpi_utils
#endif

    !+ Procedure to initialize a random number generator with a seed.
    !+ If seed is negative then random seed is used
    type(rng_type), intent(inout) :: self
        !+ Random Number Generator
    integer(Int32), intent(in)    :: seed
        !+ Initial Seed Value

    integer(Int32) :: s

    if(seed.lt.0) then
        s = rng_seed()
    else
#ifdef _MPI
        s = seed + my_rank()
#else
        s = seed
#endif
    endif

    self%seed = s
    self%state(1) = ieor(777755555,abs(s))
    self%state(2) = ior(ieor(888889999,abs(s)),1)

end subroutine rng_init

function get_rng() result(r)
    type(rng_type) :: r
    integer :: thread_id

#ifdef _OMP
    thread_id = OMP_get_thread_num() + 1
#else
    thread_id = 1
#endif

    r = rng(thread_id)

end function get_rng

subroutine update_rng(r)
    type(rng_type), intent(in) :: r
    integer :: thread_id

#ifdef _OMP
    thread_id = OMP_get_thread_num() + 1
#else
    thread_id = 1
#endif

    rng(thread_id) = r

end subroutine update_rng

function rng_uniform(self) result(u)
    !+ Generate a uniformally-distributed random number in the range [0,1)
    type(rng_type), intent(inout) :: self
        !+ Random Number Generator
    real(Float64)                 :: u
        !+ Uniform random deviate

    integer(Int32) :: ix,iy,k
    real(Float64) :: am

    ix = self%state(1)
    iy = self%state(2)

    ix = ieor(ix,ishft(ix,13))
    ix = ieor(ix,ishft(ix,-17))
    ix = ieor(ix,ishft(ix,5))
    k=iy/IQ
    iy=IA*(iy - k*IQ) - IR*k
    if(iy.lt.0) iy = iy + IM
    self%state(1) = ix
    self%state(2) = iy

    am = nearest(1.0,-1.0)/IM
    u = am*ior(iand(IM,ieor(ix,iy)),1)

end function rng_uniform

function rng_normal(self) result(n)
    !+ Generate a normally-distributed random number with mean 0 and standard deviation 1
    type(rng_type), intent(inout) :: self
        !+ Random Number Generator
    real(Float64)                 :: n
        !+ Normal random deviate

    real(Float64), parameter :: s = 0.449871d0
    real(Float64), parameter :: t = 0.386595d0
    real(Float64), parameter :: a = 0.196000d0
    real(Float64), parameter :: b = 0.254720d0
    real(Float64), parameter :: r1 = 0.27597d0
    real(Float64), parameter :: r2 = 0.27846d0
    real(Float64) :: u, v, x, y, q

    do
        u = rng_uniform(self)
        v = rng_uniform(self)
        v = 1.7156d0 * (v - 0.5d0)

        x = u - s
        y = abs(v) + t
        q = x**2 + y*(a*y - b*x)

        if (q.lt.r1) exit
        if (q.gt.r2) cycle
        if((v**2).lt.(-4.0*log(u)*u**2)) exit
    enddo

    n = v/u

end function rng_normal

subroutine randu_r_arr(r, randomu)
    !+ Generate an array of uniformally-distributed random deviates
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:), intent(out) :: randomu
        !+ Array of uniform random deviates

    integer :: i

    randomu = 0.d0
    do i=1,size(randomu)
        randomu(i) = rng_uniform(r)
    enddo

end subroutine randu_r_arr

subroutine randu_arr(randomu)
    !+ Generate an array of uniformally-distributed random deviates
    real(Float64), dimension(:), intent(out) :: randomu
        !+ Array of uniform random deviates

    type(rng_type) ::r

    r = get_rng()
    call randu_r_arr(r, randomu)
    call update_rng(r)

end subroutine randu_arr

subroutine randn_r_arr(r, randomn)
    !+ Generate an array of normally-distributed random deviates
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:), intent(out) :: randomn
        !+ Array of normal random deviates

    integer :: i

    randomn = 0.d0
    do i=1,size(randomn)
        randomn(i) = rng_normal(r)
    enddo

end subroutine randn_r_arr

subroutine randn_arr(randomn)
    !+ Generate an array of normally-distributed random deviates
    real(Float64), dimension(:), intent(out) :: randomn
        !+ Array of normal random deviates

    type(rng_type) :: r

    r = get_rng()
    call randn_r_arr(r,randomn)
    call update_rng(r)

end subroutine randn_arr

subroutine randind_r_n(r, n, randomi)
    !+ Generate a array of uniformally-distributed random integers in the range [1, n]
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    integer, intent(in)                :: n
        !+ Largest possible value
    integer, dimension(:), intent(out) :: randomi
        !+ Array of uniform deviates

    integer :: i
    real(Float64), dimension(1) :: randomu

    randomi = 0
    do i=1,size(randomi)
        call randu_r_arr(r, randomu)
        randomi(i) = ceiling(randomu(1)*n)
    enddo

end subroutine randind_r_n

subroutine randind_n(n, randomi)
    !+ Generate a array of uniformally-distributed random integers in the range [1, n]
    integer, intent(in)                :: n
        !+ Largest possible value
    integer, dimension(:), intent(out) :: randomi
        !+ Array of uniform deviates

    type(rng_type) :: r

    r = get_rng()
    call randind_r_n(r, n, randomi)
    call update_rng(r)

end subroutine randind_n

subroutine randind_r_cdf_1(r, cdf, randomi)
    !+ Generate an array of random indices of an 1D array distributed according to `cdf`
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:), intent(in) :: cdf
        !+ 1D array of index weights
    integer, dimension(:), intent(out)      :: randomi
        !+ Random indices

    integer :: i, n
    real(Float64) :: cdf_val
    real(Float64), dimension(1) :: randomu

    n = size(cdf)

    randomi = 0
    do i=1,size(randomi)
        call randu_r_arr(r,randomu)
        cdf_val = randomu(1)*cdf(n)
        randomi(i) = min(search_sorted_first(cdf,cdf_val),n)
    enddo

end subroutine randind_r_cdf_1

subroutine randind_cdf_1(cdf, randomi)
    !+ Generate an array of random indices of an 1D array distributed according to `cdf`
    real(Float64), dimension(:), intent(in) :: cdf
        !+ 1D array of index weights
    integer, dimension(:), intent(out)      :: randomi
        !+ Random indices

    type(rng_type) :: r

    r = get_rng()
    call randind_r_cdf_1(r, cdf, randomi)
    call update_rng(r)

end subroutine randind_cdf_1

subroutine cumsum(x, cs)
    !+ Calculate cumulative sum
    real(Float64), dimension(:), intent(in)  :: x
        !+ Array to sum
    real(Float64), dimension(:), intent(out) :: cs
        !+ Cumulative sum of `x`

    integer :: i, n
    real(Float64) :: cdf_val, t

    n = size(x)
    t = 0.d0
    do i=1, n
        cs(i) = t + x(i)
        t = cs(i)
    enddo

end subroutine cumsum

subroutine randind_r_w_1(r, w, randomi)
    !+ Generate an array of random indices of an 1D array distributed according to `w`
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:), intent(in) :: w
        !+ 1D array of index weights
    integer, dimension(:), intent(out)      :: randomi
        !+ Random indices

    real(Float64), dimension(size(w)) :: cdf

    call cumsum(w, cdf)
    call randind_r_cdf_1(r, cdf, randomi)

end subroutine randind_r_w_1

subroutine randind_w_1(w, randomi)
    !+ Generate an array of random indices of an 1D array distributed according to `w`
    real(Float64), dimension(:), intent(in) :: w
        !+ 1D array of index weights
    integer, dimension(:), intent(out)      :: randomi
        !+ Random indices

    type(rng_type) :: r

    r = get_rng()
    call randind_r_w_1(r, w, randomi)
    call update_rng(r)

end subroutine randind_w_1

subroutine randind_r_w_2(r, w, randomi)
    !+ Generate an array of random subscripts of an 2D array distributed according to `w`
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:,:), target, intent(in) :: w
        !+ 2D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    integer :: i,nw
    integer, dimension(2) :: subs
    integer, dimension(size(randomi,2)) :: randi
    real(Float64), pointer :: w_ptr(:)

    randomi = 0
    nw = size(w)

    call c_f_pointer(c_loc(w), w_ptr, [nw])
    call randind_r_w_1(r, w_ptr,randi)
    do i=1,size(randomi,2)
        call ind2sub(shape(w),randi(i),subs)
        randomi(:,i) = subs
    enddo

end subroutine randind_r_w_2

subroutine randind_w_2(w, randomi)
    !+ Generate an array of random subscripts of an 2D array distributed according to `w`
    real(Float64), dimension(:,:), intent(in) :: w
        !+ 2D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    type(rng_type) :: r

    r = get_rng()
    call randind_r_w_2(r, w, randomi)
    call update_rng(r)

end subroutine randind_w_2

subroutine randind_r_w_3(r, w, randomi)
    !+ Generate an array of random subscripts of an 3D array distributed according to `w`
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:,:,:), target, intent(in) :: w
        !+ 3D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    integer :: i,nw
    integer, dimension(3) :: subs
    integer, dimension(size(randomi,2)) :: randi
    real(Float64), pointer :: w_ptr(:)

    randomi = 0
    nw = size(w)

    call c_f_pointer(c_loc(w), w_ptr, [nw])
    call randind_r_w_1(r, w_ptr, randi)
    do i=1,size(randomi,2)
        call ind2sub(shape(w),randi(i),subs)
        randomi(:,i) = subs
    enddo

end subroutine randind_r_w_3

subroutine randind_w_3(w, randomi)
    !+ Generate an array of random subscripts of an 3D array distributed according to `w`
    real(Float64), dimension(:,:,:), intent(in) :: w
        !+ 3D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    type(rng_type) :: r

    r = get_rng()
    call randind_r_w_3(r, w, randomi)
    call update_rng(r)

end subroutine randind_w_3

subroutine randind_r_w_4(r, w, randomi)
    !+ Generate an array of random subscripts of an 4D array distributed according to `w`
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:,:,:,:), target, intent(in) :: w
        !+ 4D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    integer :: i,nw
    integer, dimension(4) :: subs
    integer, dimension(size(randomi,2)) :: randi
    real(Float64), pointer :: w_ptr(:)

    randomi = 0
    nw = size(w)

    call c_f_pointer(c_loc(w), w_ptr, [nw])
    call randind_r_w_1(r, w_ptr, randi)
    do i=1,size(randomi,2)
        call ind2sub(shape(w),randi(i),subs)
        randomi(:,i) = subs
    enddo

end subroutine randind_r_w_4

subroutine randind_w_4(w, randomi)
    !+ Generate an array of random subscripts of an 4D array distributed according to `w`
    real(Float64), dimension(:,:,:,:), intent(in) :: w
        !+ 4D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    type(rng_type) :: r

    r = get_rng()
    call randind_r_w_4(r, w, randomi)
    call update_rng(r)

end subroutine randind_w_4

subroutine randind_r_w_5(r, w, randomi)
    !+ Generate an array of random subscripts of an 5D array distributed according to `w`
    type(rng_type), intent(inout) :: r
        !+ Random Number Generator
    real(Float64), dimension(:,:,:,:,:), target, intent(in) :: w
        !+ 5D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    integer :: i,nw
    integer, dimension(5) :: subs
    integer, dimension(size(randomi,2)) :: randi
    real(Float64), pointer :: w_ptr(:)

    randomi = 0
    nw = size(w)

    call c_f_pointer(c_loc(w), w_ptr, [nw])
    call randind_r_w_1(r, w_ptr, randi)
    do i=1,size(randomi,2)
        call ind2sub(shape(w),randi(i),subs)
        randomi(:,i) = subs
    enddo

end subroutine randind_r_w_5

subroutine randind_w_5(w, randomi)
    !+ Generate an array of random subscripts of an 5D array distributed according to `w`
    real(Float64), dimension(:,:,:,:,:), intent(in) :: w
        !+ 5D array of subscript weights
    integer, dimension(:,:), intent(out)      :: randomi
        !+ A 2D (ndim, :) array of random subscripts

    type(rng_type) :: r

    r = get_rng()
    call randind_r_w_5(r, w, randomi)
    call update_rng(r)

end subroutine randind_w_5

!============================================================================
!------------------------------Sparse Routines-------------------------------
!============================================================================
subroutine sparse_1(A,SA)
    !+ Routine to create a 1D sparse array from a 1D dense array
    real(Float64), dimension(:), intent(in) :: A
        !+ Dense Array
    type(SparseArray), intent(out) :: SA
        !+ Sparse Array

    integer :: n,i,c

    SA%nd = 1
    allocate(SA%dims(SA%nd))
    SA%dims = shape(A)

    SA%nnz = count(A.ne.0.d0)
    if(SA%nnz.eq.0) return
    allocate(SA%vals(SA%nnz),SA%inds(SA%nnz))

    n = size(A)
    c = 1
    do i=1,n
        if(A(i).ne.0.d0)then
            SA%inds(c) = i
            SA%vals(c) = A(i)
            c = c + 1
        endif
        if(c.gt.SA%nnz) exit
    enddo

end subroutine sparse_1

subroutine sparse_2(A,SA)
    !+ Routine to create a 2D sparse array from a 2D dense array
    real(Float64), dimension(:,:), intent(in) :: A
        !+ Dense Array
    type(SparseArray), intent(out) :: SA
        !+ Sparse Array

    integer :: subs(2)
    integer :: n,i,c

    SA%nd = 2
    allocate(SA%dims(SA%nd))
    SA%dims = shape(A)

    SA%nnz = count(A.ne.0.d0)
    if(SA%nnz.eq.0) return
    allocate(SA%vals(SA%nnz),SA%inds(SA%nnz))

    n = size(A)
    c = 1
    do i=1,n
        call ind2sub(SA%dims,i,subs)
        if(A(subs(1),subs(2)).ne.0.d0)then
            SA%inds(c) = i
            SA%vals(c) = A(subs(1),subs(2))
            c = c + 1
        endif
        if(c.gt.SA%nnz) exit
    enddo

end subroutine sparse_2

subroutine sparse_3(A,SA)
    !+ Routine to create a 3D sparse array from a 3D dense array
    real(Float64), dimension(:,:,:), intent(in) :: A
        !+ Dense Array
    type(SparseArray), intent(out) :: SA
        !+ Sparse Array

    integer :: subs(3)
    integer :: n,i,c

    SA%nd = 3
    allocate(SA%dims(SA%nd))
    SA%dims = shape(A)

    SA%nnz = count(A.ne.0.d0)
    if(SA%nnz.eq.0) return
    allocate(SA%vals(SA%nnz),SA%inds(SA%nnz))

    n = size(A)
    c = 1
    do i=1,n
        call ind2sub(SA%dims,i,subs)
        if(A(subs(1),subs(2),subs(3)).ne.0.d0)then
            SA%inds(c) = i
            SA%vals(c) = A(subs(1),subs(2),subs(3))
            c = c + 1
        endif
        if(c.gt.SA%nnz) exit
    enddo

end subroutine sparse_3

subroutine sparse_4(A,SA)
    !+ Routine to create a 4D sparse array from a 4D dense array
    real(Float64), dimension(:,:,:,:), intent(in) :: A
        !+ Dense Array
    type(SparseArray), intent(out) :: SA
        !+ Sparse Array

    integer :: subs(4)
    integer :: n,i,c

    SA%nd = 4
    allocate(SA%dims(SA%nd))
    SA%dims = shape(A)

    SA%nnz = count(A.ne.0.d0)
    if(SA%nnz.eq.0) return
    allocate(SA%vals(SA%nnz),SA%inds(SA%nnz))

    n = size(A)
    c = 1
    do i=1,n
        call ind2sub(SA%dims,i,subs)
        if(A(subs(1),subs(2),subs(3),subs(4)).ne.0.d0)then
            SA%inds(c) = i
            SA%vals(c) = A(subs(1),subs(2),subs(3),subs(4))
            c = c + 1
        endif
        if(c.gt.SA%nnz) exit
    enddo

end subroutine sparse_4

function get_value(SA, subs) result (val)
    !+ Gets value of sparse array `SA` at the subscripts `subs`
    type(SparseArray), intent(in)     :: SA
        !+ Sparse Array
    integer, dimension(:), intent(in) :: subs
        !+ Subscripts of Sparse Array
    real(Float64) :: val
        !+ Value of `SA` at `subs`

    integer :: ind, cind

    val = 0.d0
    if(SA%nnz.eq.0) return

    ind = sub2ind(SA%dims, subs)
    cind = search_sorted_first(SA%inds, ind)
    if(ind.eq.SA%inds(cind))then
        val = SA%vals(cind)
    endif

end function get_value

!============================================================================
!--------------------------------Deriv Routines------------------------------
!============================================================================

subroutine deriv_1d(x,y,yp)
    !+ Uses 3 point lagrangian method to calculate the derivative of an array
    real(Float64), dimension(:),intent(in)  :: x
        !+ X Values
    real(Float64), dimension(:),intent(in)  :: y
        !+ Y Values
    real(Float64), dimension(:),intent(out) :: yp
        !+ Derivative of Y w.r.t. X

    integer :: i,n
        !! temporary values for loops
    real(Float64) :: p1,p2,p3
        !! intermeadiate values for 3 point lagrangian

    n = size(x)-1
    do i = 2,n
        p1 = x(i-1)
        p2 = x(i)
        p3 = x(i+1)
        yp(i) = (y(i-1)*(p2-p3)/((p1-p2)*(p1-p3))) + &
                (y(i)*((1/(p2-p3))-(1/(p1-p2)))) -   &
                (y(i+1)*(p1-p2)/((p1-p3)*(p2-p3)))
    enddo

    yp(1) = (y(1)*((x(1)-x(2))+(x(1)-x(3)))/((x(1)-x(2))*(x(1)-x(3)))) - &
            (y(2)*(x(1)-x(3))/((x(1)-x(2))*(x(2)-x(3)))) +               &
            (y(3)*(x(1)-x(2))/((x(1)-x(3))*(x(2)-x(3))))
    yp(n+1) = -(y(n-1)*(x(n)-x(n+1))/((x(n-1)-x(n))*(x(n-1)-x(n+1)))) +   &
              (y(n)*(x(n-1)-x(n+1))/((x(n-1)-x(n))*(x(n)-x(n+1)))) -     &
              (y(n+1)*((x(n-1)-x(n+1))+(x(n)-x(n+1)))/((x(n-1)-x(n+1)) * &
              (x(n)-x(n+1))))

end subroutine deriv_1d

subroutine deriv_2d(x,y,z,zxp,zyp)
    !+ Uses 3 point lagrangian method to calculate the partial derivative
    !+ of an array Z w.r.t X and Y
    real(Float64), dimension(:), intent(in)  :: x
        !+ X Values
    real(Float64), dimension(:), intent(in)  :: y
        !+ Y Values
    real(Float64), dimension(:,:), intent(in)  :: z
        !+ Z Values
    real(Float64), dimension(:,:), intent(out) :: zxp
        !+ Derivative of Z w.r.t. X
    real(Float64), dimension(:,:), intent(out) :: zyp
        !+ Derivative of Z w.r.t. Y

    integer :: i,n
        !! temporary values for loops

    n = size(y)
    do i = 1,n
        call deriv_1d(x,z(:,i),zxp(:,i))
    enddo

    n = size(x)
    do i = 1,n
        call deriv_1d(y,z(i,:),zyp(i,:))
    enddo

end subroutine deriv_2d

subroutine deriv_3d(r,z,phi,f,frp,fzp,fphip)
    !+ Uses 3 point lagrangian method to calculate the partial derivative
    !+ of an array F w.r.t R, Z and Phi
    real(Float64), dimension(:), intent(in)  :: r
        !+ R Values
    real(Float64), dimension(:), intent(in)  :: z
        !+ Z Values
    real(Float64), dimension(:), intent(in)  :: phi
        !+ Phi Values
    real(Float64), dimension(:,:,:), intent(in)  :: f
        !+ F Values
    real(Float64), dimension(:,:,:), intent(out) :: frp
        !+ Derivative of F w.r.t. R
    real(Float64), dimension(:,:,:), intent(out) :: fzp
        !+ Derivative of F w.r.t. Z
    real(Float64), dimension(:,:,:), intent(out) :: fphip
        !+ Derivative of F w.r.t. Phi

    integer :: i,n
        !! temporary values for loops
    if (size(phi) .gt. 1) then

        n = size(phi)
        do i = 1,n
            call deriv_2d(r,z,f(:,:,i),frp(:,:,i),fzp(:,:,i))
        enddo

        n = size(z)
        do i = 1,n
            call deriv_2d(r,phi,f(:,i,:),frp(:,i,:),fphip(:,i,:))
        enddo

        n = size(r)
        do i = 1,n
            call deriv_2d(z,phi,f(i,:,:),fzp(i,:,:),fphip(i,:,:))
        enddo
    else
        fphip = 0.0d0
        call deriv_2d(r,z,f(:,:,1),frp(:,:,1),fzp(:,:,1))

    endif

end subroutine deriv_3d

!============================================================================
!---------------------------Interpolation Routines---------------------------
!============================================================================
subroutine interpol1D_coeff(xmin,dx,nx,xout,c,err)
    !+ Linear interpolation coefficients and index for a 1D grid y(x)
    real(Float64), intent(in)           :: xmin
        !+ Minimum abscissa value
    real(Float64), intent(in)           :: dx
        !+ Absissa spacing
    integer, intent(in)                 :: nx
        !+ Number of abscissa
    real(Float64), intent(in)           :: xout
        !+ Abscissa value to interpolate
    type(InterpolCoeffs1D), intent(out) :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional      :: err
        !+ Error code

    real(Float64) :: x1, xp, b1, b2
    integer :: i, err_status

    err_status = 1
    xp = max(xout,xmin)
    i = floor((xp - xmin)/dx)+1

    if ((i.gt.0).and.(i.le.(nx-1))) then
        x1 = xmin + (i-1)*dx

        b2 = (xp - x1)/dx
        b1 = (1.0 - b2)

        c%i = i
        c%b1 = b1
        c%b2 = b2
        err_status = 0
    endif

    if(present(err)) err = err_status

end subroutine interpol1D_coeff

subroutine interpol1D_coeff_arr(x,xout,c,err)
    !+ Linear interpolation coefficients and index for a 1D grid y(x)
    real(Float64), dimension(:), intent(in) :: x
        !+ Abscissa values
    real(Float64), intent(in)               :: xout
        !+ Abscissa value to interpolate
    type(InterpolCoeffs1D), intent(out)     :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional          :: err
        !+ Error code

    real(Float64) :: xmin, dx
    integer :: sx,err_status

    err_status = 1
    sx = size(x)
    xmin = x(1)
    dx = abs(x(2)-x(1))

    call interpol1D_coeff(xmin, dx, sx, xout, c, err_status)

    if(present(err)) err = err_status

end subroutine interpol1D_coeff_arr

subroutine interpol2D_coeff(xmin,dx,nx,ymin,dy,ny,xout,yout,c,err)
    !+ Bilinear interpolation coefficients and indicies for a 2D grid z(x,y)
    real(Float64), intent(in)           :: xmin
        !+ Minimum abscissa
    real(Float64), intent(in)           :: dx
        !+ Abscissa spacing
    integer, intent(in)                 :: nx
        !+ Number of abscissa
    real(Float64), intent(in)           :: ymin
        !+ Minimum ordinate
    real(Float64), intent(in)           :: dy
        !+ Ordinate spacing
    integer, intent(in)                 :: ny
        !+ Number of ordinates points
    real(Float64), intent(in)           :: xout
        !+ Abscissa value to interpolate
    real(Float64), intent(in)           :: yout
        !+ Ordinate value to interpolate
    type(InterpolCoeffs2D), intent(out) :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional      :: err
        !+ Error code

    real(Float64) :: x1, x2, y1, y2, xp, yp
    integer :: i, j, err_status

    err_status = 1
    xp = max(xout,xmin)
    yp = max(yout,ymin)
    i = floor((xp-xmin)/dx)+1
    j = floor((yp-ymin)/dy)+1

    if (((i.gt.0).and.(i.le.(nx-1))).and.((j.gt.0).and.(j.le.(ny-1)))) then
        x1 = xmin + (i-1)*dx
        x2 = x1 + dx
        y1 = ymin + (j-1)*dy
        y2 = y1 + dy

        c%b11 = ((x2 - xp) * (y2 - yp))/(dx*dy)
        c%b21 = ((xp - x1) * (y2 - yp))/(dx*dy)
        c%b12 = ((x2 - xp) * (yp - y1))/(dx*dy)
        c%b22 = ((xp - x1) * (yp - y1))/(dx*dy)
        c%i = i
        c%j = j
        err_status = 0
    endif

    if(present(err)) err = err_status

end subroutine interpol2D_coeff

subroutine interpol2D_coeff_arr(x,y,xout,yout,c,err)
    !!Bilinear interpolation coefficients and indicies for a 2D grid z(x,y)
    real(Float64), dimension(:), intent(in) :: x
        !+ Abscissa values
    real(Float64), dimension(:), intent(in) :: y
        !+ Ordinate values
    real(Float64), intent(in)               :: xout
        !+ Abscissa value to interpolate
    real(Float64), intent(in)               :: yout
        !+ Ordinate value to interpolate
    type(InterpolCoeffs2D), intent(out)     :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional          :: err
        !+ Error code

    real(Float64) :: xmin, ymin, dx, dy
    integer :: sx, sy, err_status

    err_status = 1
    sx = size(x)
    sy = size(y)
    xmin = x(1)
    ymin = y(1)
    dx = abs(x(2)-x(1))
    dy = abs(y(2)-y(1))

    call interpol2D_coeff(xmin, dx, sx, ymin, dy, sy, xout, yout, c, err_status)

    if(present(err)) err = err_status

end subroutine interpol2D_coeff_arr

subroutine cyl_interpol3D_coeff(rmin,dr,nr,zmin,dz,nz,phimin,dphi,nphi,rout,zout,phiout,c,err)
    !+ Cylindrical interpolation coefficients and indicies for a 3D grid
    real(Float64), intent(in)           :: rmin
        !+ Minimum R
    real(Float64), intent(in)           :: dr
        !+ R spacing
    integer, intent(in)                 :: nr
        !+ Number of R points
    real(Float64), intent(in)           :: zmin
        !+ Minimum Z
    real(Float64), intent(in)           :: dz
        !+ Z spacing
    integer, intent(in)                 :: nz
        !+ Number of Z points
    real(Float64), intent(in)           :: phimin
        !+ Minimum phi
    real(Float64), intent(in)           :: dphi
        !+ Phi spacing
    integer, intent(in)                 :: nphi
        !+ Number of phi points
    real(Float64), intent(in)           :: rout
        !+ R value to interpolate
    real(Float64), intent(in)           :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)           :: phiout
        !+ Phi value to interpolate
    type(InterpolCoeffs3D), intent(out) :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional      :: err
        !+ Error code

    type(InterpolCoeffs2D) :: b
    real(Float64) :: r1, r2, phi1, phi2, z1, z2, rp, phip, zp, dV
    real(Float64) :: phi
    integer :: i, j, k, err_status

    err_status = 1

    rp = max(rout,rmin)
    zp = max(zout,zmin)
    phip = max(phiout,phimin)
    i = floor((rp-rmin)/dr)+1
    j = floor((zp-zmin)/dz)+1
    k = floor((phip-phimin)/dphi)+1

    if (nphi .eq. 1) then
        if (((i.gt.0).and.(i.le.(nr-1))).and.((j.gt.0).and.(j.le.(nz-1)))) then
            call interpol2D_coeff(rmin, dr, nr, zmin, dz, nz, rout, zout, b, err_status)
            c%b111 = b%b11
            c%b121 = b%b12
            c%b221 = b%b22
            c%b211 = b%b21
            c%b212 = 0
            c%b222 = 0
            c%b122 = 0
            c%b112 = 0
            c%i = b%i
            c%j = b%j
            c%k = 1
            err_status = 0
        endif
    else
        if ((((i.gt.0).and.(i.le.(nr-1))).and.((j.gt.0).and.(j.le.(nz-1)))).and.((k.gt.0).and.(k.le.(nphi-1)))) then
            r1 = rmin + (i-1)*dr
            r2 = r1 + dr
            z1 = zmin + (j-1)*dz
            z2 = z1 + dz
            phi1 = phimin + (k-1)*dphi
            phi2 = phi1 + dphi
            dV = ((r2**2 - r1**2) * (phi2 - phi1) * (z2 - z1))

            !! Both volume elements have a factor of 1/2 that cancels out
            c%b111 = ((r2**2 - rp**2) * (phi2 - phip) * (z2 - zp)) / dV
            c%b121 = ((r2**2 - rp**2) * (phi2 - phip) * (zp - z1)) / dV
            c%b221 = ((rp**2 - r1**2) * (phi2 - phip) * (zp - z1)) / dV
            c%b211 = ((rp**2 - r1**2) * (phi2 - phip) * (z2 - zp)) / dV
            c%b212 = ((rp**2 - r1**2) * (phip - phi1) * (z2 - zp)) / dV
            c%b222 = ((rp**2 - r1**2) * (phip - phi1) * (zp - z1)) / dV
            c%b122 = ((r2**2 - rp**2) * (phip - phi1) * (zp - z1)) / dV
            c%b112 = ((r2**2 - rp**2) * (phip - phi1) * (z2 - zp)) / dV
            c%i = i
            c%j = j
            c%k = k
            err_status = 0
        endif
    endif

    if(present(err)) err = err_status

end subroutine cyl_interpol3D_coeff

subroutine cyl_interpol3D_coeff_arr(r,z,phi,rout,zout,phiout,c,err)
    !+ Cylindrical interpolation coefficients and indicies for a 3D grid
    real(Float64), dimension(:), intent(in) :: r
        !+ R values
    real(Float64), dimension(:), intent(in) :: z
        !+ Z values
    real(Float64), dimension(:), intent(in) :: phi
        !+ Phi values
    real(Float64), intent(in)               :: rout
        !+ R value to interpolate
    real(Float64), intent(in)               :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)               :: phiout
        !+ Phi value to interpolate
    type(InterpolCoeffs3D), intent(out)     :: c
        !+ Interpolation Coefficients
    integer, intent(out), optional          :: err
        !+ Error code

    type(InterpolCoeffs2D) :: b
    real(Float64) :: rmin, phimin, zmin, dr, dphi, dz
    integer :: sr, sphi, sz, err_status

    err_status = 1
    sr = size(r)
    sphi = size(phi)
    sz = size(z)

    rmin = r(1)
    zmin = z(1)
    dr = abs(r(2)-r(1))
    dz = abs(z(2)-z(1))

    if (sphi .eq. 1) then
        call interpol2D_coeff(rmin, dr, sr, zmin, dz, sz, rout, zout, b, err_status)
        c%b111 = b%b11
        c%b121 = b%b12
        c%b221 = b%b22
        c%b211 = b%b21
        c%b212 = 0
        c%b222 = 0
        c%b122 = 0
        c%b112 = 0
        c%i = b%i
        c%j = b%j
        c%k = 1
    else
        phimin = phi(1)
        dphi = abs(phi(2)-phi(1))
        call cyl_interpol3D_coeff(rmin, dr, sr, zmin, dz, sz, phimin, dphi, sphi, rout, zout, phiout, c, err_status)
    endif

    if(present(err)) err = err_status

end subroutine cyl_interpol3D_coeff_arr

subroutine interpol1D_arr(x, y, xout, yout, err, coeffs)
    !+ Performs linear interpolation on a uniform 1D grid y(x)
    real(Float64), dimension(:), intent(in)      :: x
        !+ The abscissa values of `y`
    real(Float64), dimension(:), intent(in)      :: y
        !+ Values at abscissa values `x`: y(x)
    real(Float64), intent(in)                    :: xout
        !+ Abscissa value to interpolate
    real(Float64), intent(out)                   :: yout
        !+ Interpolant: y(xout)
    integer, intent(out), optional               :: err
        !+ Error code
    type(InterpolCoeffs1D), intent(in), optional :: coeffs
        !+ Precomputed Linear Interpolation Coefficients

    type(InterpolCoeffs1D) :: c
    integer :: i, err_status

    err_status = 1
    if(present(coeffs)) then
        c = coeffs
        err_status = 0
    else
        call interpol_coeff(x,xout,c,err_status)
    endif

    if(err_status.eq.0) then
        i = c%i
        yout = c%b1*y(i) + c%b2*y(i+1)
    else
        yout = 0.d0
    endif

    if(present(err)) err = err_status

end subroutine interpol1D_arr

subroutine interpol2D_arr(x, y, z, xout, yout, zout, err, coeffs)
    !+ Performs bilinear interpolation on a 2D grid z(x,y)
    real(Float64), dimension(:), intent(in)   :: x
        !+ The abscissa values of `z`
    real(Float64), dimension(:), intent(in)   :: y
        !+ The ordinate values of `z`
    real(Float64), dimension(:,:), intent(in) :: z
        !+ Values at the abscissa/ordinates: z(x,y)
    real(Float64), intent(in)                 :: xout
        !+ The abscissa value to interpolate
    real(Float64), intent(in)                 :: yout
        !+ The ordinate value to interpolate
    real(Float64), intent(out)                :: zout
        !+ Interpolant: z(xout,yout)
    integer, intent(out), optional            :: err
        !+ Error code
    type(InterpolCoeffs2D), intent(in), optional :: coeffs
        !+ Precomputed Linear Interpolation Coefficients

    type(InterpolCoeffs2D) :: c
    integer :: i, j, err_status

    err_status = 1
    if(present(coeffs)) then
        c = coeffs
        err_status = 0
    else
        call interpol_coeff(x,y,xout,yout,c,err_status)
    endif

    if(err_status.eq.0) then
        i = c%i
        j = c%j
        zout = c%b11*z(i,j) + c%b12*z(i,j+1) + c%b21*z(i+1,j) + c%b22*z(i+1,j+1)
    else
        zout = 0.d0
    endif

    if(present(err)) err = err_status

end subroutine interpol2D_arr

subroutine interpol2D_2D_arr(x, y, z, xout, yout, zout, err, coeffs)
    !+ Performs bilinear interpolation on a 2D grid of 2D arrays z(:,:,x,y)
    real(Float64), dimension(:), intent(in)       :: x
        !+ The abscissa values of `z`
    real(Float64), dimension(:), intent(in)       :: y
        !+ The ordinate values of `z`
    real(Float64), dimension(:,:,:,:), intent(in) :: z
        !+ Values at the abscissa/ordinates: z(:,:,x,y)
    real(Float64), intent(in)                     :: xout
        !+ The abscissa value to interpolate
    real(Float64), intent(in)                     :: yout
        !+ The ordinate value to interpolate
    real(Float64), dimension(:,:), intent(out)    :: zout
        !+ Interpolant: z(:,:,xout,yout)
    integer, intent(out), optional                :: err
        !+ Error code
    type(InterpolCoeffs2D), intent(in), optional :: coeffs
        !+ Precomputed Linear Interpolation Coefficients

    type(InterpolCoeffs2D) :: c
    integer :: i, j, err_status

    err_status = 1
    if(present(coeffs)) then
        c = coeffs
        err_status = 0
    else
        call interpol_coeff(x,y,xout,yout,c,err_status)
    endif

    if(err_status.eq.0) then
        i = c%i
        j = c%j
        zout = c%b11*z(:,:,i,j) + c%b12*z(:,:,i,j+1) + c%b21*z(:,:,i+1,j) + c%b22*z(:,:,i+1,j+1)
    else
        zout = 0.0
    endif

    if(present(err)) err = err_status

end subroutine interpol2D_2D_arr

subroutine interpol3D_arr(r, z, phi, d, rout, zout, phiout, dout, err, coeffs)
    !+ Performs cylindrical interpolation on a 3D grid f(r,z,phi)
    real(Float64), dimension(:), intent(in) :: r
        !+ R values
    real(Float64), dimension(:), intent(in) :: z
        !+ Z values
    real(Float64), dimension(:), intent(in) :: phi
        !+ Phi values
    real(Float64), dimension(:,:,:), intent(in) :: d
        !+ Values at r,z,phi: d(r,z,phi)
    real(Float64), intent(in)               :: rout
        !+ R value to interpolate
    real(Float64), intent(in)               :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)               :: phiout
        !+ Phi value to interpolate
    real(Float64), intent(out)                :: dout
        !+ Interpolant: d(rout,zout,phiout)
    integer, intent(out), optional          :: err
        !+ Error code
    type(InterpolCoeffs3D), intent(in), optional :: coeffs
        !+ Precomputed Interpolation Coefficients

    type(InterpolCoeffs3D) :: b
    integer :: i, j, k, k2, err_status
    integer :: nphi

    err_status = 1

    nphi = size(phi)

    if(present(coeffs)) then
        b = coeffs
        if(nphi .eq. 1) then
            b%b212 = 0
            b%b222 = 0
            b%b122 = 0
            b%b112 = 0
            b%k = 1
        endif
        err_status = 0
    else
        call interpol_coeff(r,z,phi,rout,zout,phiout,b,err_status)
    endif

    if(err_status.eq.0) then
        i = b%i
        j = b%j
        k = b%k
        if(nphi .eq. 1) then
            k2 = min(k+1,nphi)
        else
            k2 = k+1
        endif

        dout = b%b111*d(i,j,k)    + b%b121*d(i,j+1,k) +   &
               b%b112*d(i,j,k2)   + b%b122*d(i,j+1,k2) +  &
               b%b211*d(i+1,j,k)  + b%b221*d(i+1,j+1,k) + &
               b%b212*d(i+1,j,k2) + b%b222*d(i+1,j+1,k2)
    else
        dout = 0.d0
    endif

    if(present(err)) err = err_status

end subroutine interpol3D_arr

subroutine interpol3D_2D_arr(r, z, phi, f, rout, zout, phiout, fout, err, coeffs)
    !+ Performs cylindrical interpolation on a 3D grid of 2D arrays
    !+ f(:,:,r,z,phi)
    real(Float64), dimension(:), intent(in) :: r
        !+ R values
    real(Float64), dimension(:), intent(in) :: z
        !+ Z values
    real(Float64), dimension(:), intent(in) :: phi
        !+ Phi values
    real(Float64), dimension(:,:,:,:,:), intent(in) :: f
        !+ Values at r,z,phi: f(:,:,r,z,phi)
    real(Float64), intent(in)               :: rout
        !+ R value to interpolate
    real(Float64), intent(in)               :: zout
        !+ Z value to interpolate
    real(Float64), intent(in)               :: phiout
        !+ Phi value to interpolate
    real(Float64), dimension(:,:), intent(out)    :: fout
        !+ Interpolant: f(:,:,rout,zout,phiout)
    integer, intent(out), optional          :: err
        !+ Error code
    type(InterpolCoeffs3D), intent(in), optional :: coeffs
        !+ Precomputed Interpolation Coefficients

    type(InterpolCoeffs3D) :: b
    integer :: i, j, k, k2, err_status
    integer :: nphi

    err_status = 1

    nphi = size(phi)

    if(present(coeffs)) then
        b = coeffs
        if(nphi .eq. 1) then
            b%b212 = 0
            b%b222 = 0
            b%b122 = 0
            b%b112 = 0
            b%k = 1
        endif
        err_status = 0
    else
        call interpol_coeff(r,z,phi,rout,zout,phiout,b,err_status)
    endif

    if(err_status.eq.0) then
        i = b%i
        j = b%j
        k = b%k
        if(nphi .eq. 1) then
            k2 = min(k+1,nphi)
        else
            k2 = k+1
        endif
        fout = b%b111*f(:,:,i,j,k)    + b%b121*f(:,:,i,j+1,k) +   &
               b%b112*f(:,:,i,j,k2)   + b%b122*f(:,:,i,j+1,k2) +  &
               b%b211*f(:,:,i+1,j,k)  + b%b221*f(:,:,i+1,j+1,k) + &
               b%b212*f(:,:,i+1,j,k2) + b%b222*f(:,:,i+1,j+1,k2)
    else
        fout = 0.0
    endif

    if(present(err)) err = err_status

end subroutine interpol3D_2D_arr

!============================================================================
!------------------------------ Misc. Routines ------------------------------
!============================================================================
function time(time_start) result (time_str)
    !+ Returns time string
    integer, dimension(8), intent(in), optional :: time_start
        !+ Optional start time
    character(30) :: time_str
        !+ Time string

    integer :: ts(8), ta(8), hour, minu, sec

    ts = 0
    if(present(time_start)) then
        ts = time_start
    endif

    call date_and_time(values=ta)
    hour = ta(5) - ts(5)
    minu = ta(6) - ts(6)
    sec  = ta(7) - ts(7)
    if (minu.lt.0.) then
        minu = minu + 60
        hour = hour - 1
    endif
    if (sec.lt.0.) then
        sec  = sec + 60
        minu = minu - 1
    endif

    if(present(time_start)) then
        write(time_str,'(I2,":",I2.2,":",I2.2," --- elapsed:",I2,":",I2.2,":",I2.2)') &
            ta(5),ta(6),ta(7), hour,minu,sec
    else
        write(time_str,'(I2,":",I2.2,":",I2.2)') &
            ta(5),ta(6),ta(7)
    endif

end function time

#ifdef _DEF_INTR
! define missing intrinsics

function norm2( in ) result ( res )
  implicit none
  real(Float64),dimension(:) :: in
  real(Float64) :: res
  res = sqrt(sum( in(:)**2 ))
end function norm2

#endif

end module utilities


!*robodoc*u* tests/test_hxir
!  NAME
!    test_hxir
!  SYNOPSIS

!$Id: test_hxir.f90 526 2018-03-25 23:44:51Z mexas $

program test_hxir

!  PURPOSE
!    Test cgca_hxir, a halo exchange subroutine with random order of
!    remote calls.
!  DESCRIPTION
!    Two separate solidifications are performed, which should result
!    in bit-by-bit idendical microstructures.
!    Both solidification runs use m3sld_hc/cgca_sld_h, a routine
!    that offers a choice of different halo exchange routines.
!    One solidification is using cgca_hxi, a halo exchange routine with
!    ordered, predictable sequence of remote calls, the same
!    on all images.
!    Another solidification is using cgca_hxir, a halo exchange
!    routine with random order of remote calls.
!    MPI/IO is used for speed.
!  NOTE
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  USES
!    cgca testaux
!  USED BY
!    Part of CGPACK test suite
!  SOURCE

use testaux

implicit none

real,parameter :: gigabyte=real(2**30)
logical( kind=ldef ), parameter :: yesdebug = .true., nodebug = .false.

real( kind=rdef ) ::   &
       qual,           & ! quality
       bsz0(3),        & ! the given "box" size
       bsz(3),         & ! updated "box" size
       dm,             & ! mean grain size, linear dim, phys units
       lres,           & ! linear resolution, cells per unit of length
       res               ! resolutions, cells per grain

real( kind=rdef ), allocatable :: grt(:,:,:)[:,:,:]

integer( kind=idef ) :: ir(3), nimgs, img, ng, i, ierr, funit, c(3)

integer( kind=iarr ), allocatable :: space(:,:,:,:)[:,:,:]

integer( kind=ilrg ) :: icells, mcells

logical( kind=ldef ) :: solid

character(len=5) :: fnum

double precision :: t0, t1, tdiff, fsizeb, fsizeg

!*********************************************************************72
! first executable statement

! physical dimensions of the box, assume mm
  bsz0 = (/ 1.0, 1.1, 0.9 /)

! mean grain size, linear dimension, e.g. mean grain diameter, also mm
  dm = 5.0e-1

! resolution
  res = 1.0e5

  img = this_image()
nimgs = num_images()

  ! do a check on image 1
  if ( img .eq. 1 ) then

     ! print a banner
     call banner("hxir")

     ! print the parameter values
     call cgca_pdmp

     write (*,'(a,i0,a)') "running on ", nimgs, " images in a 3D grid"

  end if

  ! I want pdmp output appear before the rest.
  ! This might help
  sync all

  ! each image calculates the coarray grid dimensions
  call cgca_gdim( nimgs, ir, qual )

  ! calculate the resolution and the actual phys dimensions
  ! of the box
  ! subroutine cgca_cadim( bsz, res, dm, ir, c, lres, ng )
  ! c - coarray sizes
  ! ir - coarray grid sizes
  bsz = bsz0
  call cgca_cadim( bsz, res, dm, ir, c, lres, ng )

  ! total number of cells in a coarray
  icells = int( c(1), kind=ilrg ) * int( c(2), kind=ilrg ) *           &
       int( c(3), kind=ilrg )

  ! total number of cells in the model
  mcells = icells * int( nimgs, kind=ilrg )

  if ( img .eq. 1 ) then
     write ( *, "(9(a,i0),tr1,g10.3,tr1,g10.3,3(a,g10.3),a)" )         &
          "img: ", img  , " nimgs: ", nimgs, " (", c(1) ,              &
          ","    , c(2) , ","       , c(3) , ")[", ir(1),              &
          ","    , ir(2), ","       , ir(3), "] ", ng   ,              &
          qual, lres,                                                  &
          " (", bsz(1), ",", bsz(2), ",", bsz(3), ")"
     write (*,'(a,i0,a)') "Each image has ",icells, " cells"
     write (*,'(a,i0,a)') "The model has ", mcells, " cells"
     write (*,*) "dataset sizes for ParaView", c*ir
  end if

  ! Total output file size, in B and in GB.
  fsizeb = real( mcells * storage_size( space, kind=ilrg ) / 8_ilrg )
  fsizeg = fsizeb / gigabyte

! allocate space coarray with a single layer
! implicit sync all
!subroutine cgca_as( l1, u1, l2, u2, l3, u3, col1, cou1, col2, cou2,   &
!                    col3, props, coarray )
call cgca_as(1, c(1), 1, c(2), 1, c(3), 1, ir(1), 1, ir(2), 1, 1, space)

! Start MPI
call MPI_Init( ierr )

! Do 2 solidifications
do i=1,2

  ! initialise the reproducible random number seed
  call cgca_ins( yesdebug )

  ! initialise space
  space = cgca_liquid_state
!  space = img

  ! allocate rotation tensors
  call cgca_art( 1, ng, 1, ir(1), 1, ir(2), 1, grt )

  ! assign rotation tensors, sync all inside
  call cgca_rt( grt )

  ! nuclei, sync all inside
  call cgca_nr( space, ng, yesdebug )

  ! Start timer
  t0 = cgca_benchtime()

  ! Solidify, implicit sync all inside
  !  module subroutine cgca_sld_h( coarray, hx, iter, heartbeat, solid )

  if      ( i .eq. 1 ) then
    call cgca_sld_h( space, cgca_hxi,  2, 1, solid )
  else if ( i .eq. 2 ) then
    call cgca_sld_h( space, cgca_hxir, 2, 1, solid )
  end if

  t1 = cgca_benchtime()

  if (img .eq. 1)  then
    tdiff = t1 - t0
    if      ( i .eq. 1 ) then
      write (*,*) "cgca_hxi  time: ", tdiff, "s"
    else if ( i .eq. 2 ) then
      write (*,*) "cgca_hxir time: ", tdiff, "s"
    end if
  end if

  sync all

  ! MPI/IO
  ! subroutine cgca_pswci2( coarray, stype, fname )
  if      ( i .eq. 1 ) then
    call cgca_pswci2( space, cgca_state_type_grain, "hxi.raw"  )
! Plain text output
write (fnum, '(i0)') img
open( newunit=funit, file="hxi_img" // fnum, status="replace" )
write (funit, *) space
close( funit )

  else if ( i .eq. 2 ) then
    call cgca_pswci2( space, cgca_state_type_grain, "hxir.raw" )
! Plain text output
write (fnum, '(i0)') img
open( newunit=funit, file="hxir_img" // fnum, status="replace" )
write (funit, *) space
close( funit )

  end if

  sync all

end do

! terminate MPI
call MPI_Finalize( ierr )

! deallocate all arrays
call cgca_ds( space )

end program test_hxir

!*roboend*


! { dg-do compile }
!
! PR fortran/56849
!
integer :: x(2,2),y(4)
y = reshape([1,2,3,4],[4])
x(:,1:1) = reshape(y(::2), [1,2], order=[1,2]) ! { dg-error "Different shape for array assignment at .1. on dimension 1 .2 and 1." }
print *, y
print *, x(:,1)
end


SUBROUTINE eom_iers (filename)

! ----------------------------------------------------------------------
! Subroutine:  eom_iers.f90
! ----------------------------------------------------------------------
! Purpose:
!  Read elements of the Earth Orientation Matrix (EOM) computed by the
!  web service of the IERS (International Earth Rotation Service and
!  Reference Systems) Earth Orientation Center (EOC)
! ----------------------------------------------------------------------
! Input arguments:
! - filename:		Data file name  e.g. 'eom_iers.dat'
!
! Output arguments:
! - wrtArray:		Allocatable array for storing the Earth Orientation
!					Matrix (EOM) elements per epoch
!   				eom = [MJD R11 R12 R13 R14 R21 R22 R23 R31 R32 R33]  Nx10 matrix
!   				MJD	:	MJD referred in TAI time scale
!   				R	:	EOM 3x3
! - mdl_wrte:		Module used for the 'wrtArray' allocatable array
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia               April 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_write
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      CHARACTER (LEN=512), INTENT(IN) :: filename
! OUT
!      REAL (KIND = prec_d), INTENT(OUT) :: eom(10)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int2) :: UNIT_IN, ios, ios_line, ios_data, AllocateStatus
      INTEGER (KIND = prec_int8) :: i, read_i, len_line
      CHARACTER (LEN=100) :: Format_eop
      CHARACTER (LEN=170) :: line_ith
      INTEGER (KIND = prec_int8) :: year, month, day, hour, minutes
      REAL (KIND = prec_d) :: mjd, sec, R11, R12, R13, R21, R22, R23, R31, R32, R33
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      UNIT_IN = 9
      !Format_eop = '(3(I4),I7,2(F11.6),2(F12.7),2(F11.6),2(F11.6),2(F11.7),2F12.6)'
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Open data file
      OPEN (UNIT = UNIT_IN, FILE = TRIM (filename), IOSTAT = ios)
      IF (ios /= 0) THEN
         PRINT *, "Error in opening file:", filename
         PRINT *, "OPEN IOSTAT=", ios
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Read file
! ----------------------------------------------------------------------
      i = 0
      DO
	     READ (UNIT=UNIT_IN,FMT='(A)',IOSTAT=ios_line) line_ith
         IF (ios_line < 0) THEN
!            PRINT *, "End of file, i=", i
            EXIT
         ELSE
       	    i = i + 1
         END IF
      END DO
! ----------------------------------------------------------------------
! Allocate arrays
      ALLOCATE ( wrtArray (i - 2,10) , STAT = AllocateStatus)
! ----------------------------------------------------------------------

      CLOSE (UNIT=UNIT_IN)

! ----------------------------------------------------------------------
! Open data file
      OPEN (UNIT = UNIT_IN, FILE = TRIM (filename), IOSTAT = ios)

! ----------------------------------------------------------------------
! Read data file
! ----------------------------------------------------------------------
! 1st line :	        TAI          //          Civil date UTC               // Matrix
	     READ (UNIT=UNIT_IN,FMT='(A)',IOSTAT=ios_line) line_ith
! 2nd line :	Modified Julian Date //  an  / mois / jour / hour / min / sec / R11 / R12 / R13 / R21 / R22 / R23 / R31 / R32 / R33
	     READ (UNIT=UNIT_IN,FMT='(A)',IOSTAT=ios_line) line_ith
! ----------------------------------------------------------------------
! Data loop
      i = 0
      DO
	     READ (UNIT=UNIT_IN,FMT='(A)',IOSTAT=ios_line) line_ith
	     i = i + 1

! ----------------------------------------------------------------------
! End of file
         IF (ios_line < 0) THEN
!            PRINT *, "End of file, i=", i
            EXIT
         END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Data
!57225.000428240739 2015  7 22  0    0 -0.0000002  0.488354145519  0.872644216245  0.001516709729 -0.872645184218  0.488354768847 -0.000046963944 -0.000781675243 -0.001300614404  0.999998848692
	     READ (line_ith, FMT =*, IOSTAT=ios_data) mjd, year, month, day, hour, minutes, sec, R11, R12, R13, R21, R22, R23, R31, R32, R33
         wrtArray(i,1) = mjd
         wrtArray(i,2) = R11
         wrtArray(i,3) = R12
         wrtArray(i,4) = R13
         wrtArray(i,5) = R21
         wrtArray(i,6) = R22
         wrtArray(i,7) = R23
         wrtArray(i,8) = R31
         wrtArray(i,9) = R32
         wrtArray(i,10) = R33
! ----------------------------------------------------------------------
      END DO
! ----------------------------------------------------------------------

      CLOSE (UNIT=UNIT_IN)

END


!
! F90 Tuned version
! Optimizations:
! - One 4D array allocated, other arrays are slices of this array.  This
!   arrangement interlaces the arrays in memory, improving data locality
! - Rather than copying arrays, the indices into the 4D array are copied
! - Rely on compiler for tiling.

SUBROUTINE acoustic3d_f90Tuned(N, niters, check)
  INTEGER, INTENT( IN ) :: N, niters
  REAL, INTENT( OUT ) :: check
  REAL, DIMENSION (N,N,N) :: P1, P2, P3, C
  INTEGER iter

  CALL acoustic3d_f90Tuned_setup(P1, P2, P3, c, N)

  IF (MODULO(niters,3) > 0) THEN
    PRINT *, 'Warning: In acoustic3d_f90Tuned: niters mod 3 != 0'
    PRINT *, 'Will do fewer iterations, benchmark result will be off'
  ENDIF

  DO iter=1, niters, 3
    CALL acoustic3d_f90Tuned_stencil(P1, P2, P3, C, N)
    CALL acoustic3d_f90Tuned_stencil(P2, P3, P1, C, N)
    CALL acoustic3d_f90Tuned_stencil(P3, P1, P2, C, N)
  END DO

  check = P1(N/2,N/2,N/2)

  RETURN
END

SUBROUTINE acoustic3d_f90Tuned_stencil(P1, P2, P3, C, N)
  INTEGER, INTENT( IN ) :: N
  REAL, DIMENSION (N,N,N), INTENT( IN ) :: P1, P2, C
  REAL, DIMENSION (N,N,N), INTENT( OUT ) :: P3

  P3(2:N-1,2:N-1,2:N-1) = (2-6*C(2:N-1,2:N-1,2:N-1)) &
        * P2(2:N-1,2:N-1,2:N-1) + C(2:N-1,2:N-1,2:N-1) &
        * (P2(1:N-2,2:N-1,2:N-1) + P2(3:N,2:N-1,2:N-1) &
        + P2(2:N-1,1:N-2,2:N-1) + P2(2:N-1,3:N,2:N-1) &
        + P2(2:N-1,2:N-1,1:N-2)+P2(2:N-1,2:N-1,3:N)) &
        - P1(2:N-1,2:N-1,2:N-1)
  RETURN
END

SUBROUTINE acoustic3d_f90Tuned_setup(P1, P2, P3, c, N)
  INTEGER, INTENT( IN ) :: N
  REAL, DIMENSION (N,N,N), INTENT( INOUT ) :: P1, P2, P3, c

  INTEGER cavityLeft, cavityRight, cavityFront, cavityBack, cavityTop, &
          cavityBottom, cavityTop2, cavityBottom2
  REAL ci, cj, ck, s2

! Set the velocity field

  c(1:N/2,:,:) = 0.05
  c(N/2+1:N,:,:) = 0.3;

  cavityLeft   = 3 * N / 7.0
  cavityRight  = 4 * N / 7.0
  cavityFront  = 3 * N / 7.0
  cavityBack   = 4 * N / 7.0
  cavityTop    = 5 * N / 7.0
  cavityBottom = 6 * N / 7.0
  cavityTop2   = 1 * N / 7.0
  cavityBottom2 = 2 * N / 7.0

  c(cavityTop:cavityBottom,cavityLeft:cavityRight, &
    cavityFront:cavityBack) = 0.02;
  c(cavityTop2:cavityBottom2,cavityLeft:cavityRight, &
    cavityFront:cavityBack) = 0.001;

! Initial pressure distribution
  P1 = 0.0
  P3 = 0.0

  ci = N/2.0
  cj = N/2.0
  ck = N/2.0
  s2 = 64.0 * 9.0 / ((N/2.0) ** 2)

  DO k=1,N
    DO j=1,N
      DO i=1,N
        P2(i,j,k) = exp(-((i-ci)**2+(j-cj)**2+(k-ck)**2) * s2)
      END DO
    END DO
  END DO

  CALL acoustic3d_f90Tuned_setup_check(P2, N)
  CALL acoustic3d_f90Tuned_setup_check(c, N)

  RETURN
END

SUBROUTINE acoustic3d_f90Tuned_setup_check(P, N)
  INTEGER, INTENT( IN ) :: N
  REAL, INTENT( IN ), DIMENSION(N,N,N) :: P

  INTEGER i, j, k
  REAL check

  check = 0.0
  DO k=1,N
    DO j=1,N
      DO i=1,N
        check = check + P(i,j,k) * (i+N*j+N*N*k)
      END DO
    END DO
  END DO

  PRINT *, 'Array check: ', check

  RETURN
END


      SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
     $                   T, LDT, C, LDC, WORK, LDWORK )
      IMPLICIT NONE
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*     Modified by R. Clint Whaley for inclusion in ATLAS Dec 2009.
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
     $        WORK( LDWORK, * )
*     ..
*
*  Purpose
*  =======
*
*  SLARFB applies a real block reflector H or its transpose H' to a
*  real m by n matrix C, from either the left or the right.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply H or H**T from the Left
*          = 'R': apply H or H**T from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply H (No transpose)
*          = 'T': apply H**T (Transpose)
*
*  DIRECT  (input) CHARACTER*1
*          Indicates how H is formed from a product of elementary
*          reflectors
*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
*  STOREV  (input) CHARACTER*1
*          Indicates how the vectors which define the elementary
*          reflectors are stored:
*          = 'C': Columnwise
*          = 'R': Rowwise
*
*  M       (input) INTEGER
*          The number of rows of the matrix C.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C.
*
*  K       (input) INTEGER
*          The order of the matrix T (= the number of elementary
*          reflectors whose product defines the block reflector).
*
*  V       (input) REAL array, dimension
*                                (LDV,K) if STOREV = 'C'
*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
*          The matrix V. See further details.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V.
*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*          if STOREV = 'R', LDV >= K.
*
*  T       (input) REAL array, dimension (LDT,K)
*          The triangular k by k matrix T in the representation of the
*          block reflector.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= K.
*
*  C       (input/output) REAL array, dimension (LDC,N)
*          On entry, the m by n matrix C.
*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDC >= max(1,M).
*
*  WORK    (workspace) REAL array, dimension (LDWORK,K)
*
*  LDWORK  (input) INTEGER
*          The leading dimension of the array WORK.
*          If SIDE = 'L', LDWORK >= max(1,N);
*          if SIDE = 'R', LDWORK >= max(1,M).
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER ATLASROWMAJOR, ATLASCOLMAJOR
      PARAMETER (ATLASROWMAJOR=101, ATLASCOLMAJOR=102)
      INTEGER ATLASNOTRANS, ATLASTRANS, ATLASCONJTRANS
      PARAMETER (ATLASNOTRANS=111, ATLASTRANS=112, ATLASCONJTRANS=113)
      INTEGER ATLASUPPER, ATLASLOWER
      PARAMETER (ATLASUPPER=121, ATLASLOWER=122)
      INTEGER ATLASNONUNIT, ATLASUNIT
      PARAMETER (ATLASNONUNIT=131, ATLASUNIT=132)
      INTEGER ATLASLEFT, ATLASRIGHT
      PARAMETER (ATLASLEFT=141, ATLASRIGHT=142)
*     .. Local variables ..
      INTEGER ISIDE, ITRANS, IDIRECT, ISTORE
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
      IF (SIDE.EQ.'R' .OR. SIDE.EQ.'r') THEN
         ISIDE = ATLASRIGHT
      ELSE
         ISIDE = ATLASLEFT
      ENDIF
      IF (TRANS.EQ.'N' .OR. TRANS.EQ.'n') THEN
         ITRANS = ATLASNOTRANS
      ELSE
         ITRANS = ATLASTRANS
      ENDIF
      IF (DIRECT.EQ.'F' .OR. DIRECT.EQ.'f') THEN
         IDIRECT = 1
      ELSE
         IDIRECT = 2
      ENDIF
      IF (STOREV.EQ.'R' .OR. STOREV.EQ.'r') THEN
         ISTORE = 1
      ELSE
         ISTORE = 2
      ENDIF
*
      CALL ATL_F77WRAP_SLARFB(ISIDE, ITRANS, IDIRECT, ISTORE, M, N, K,
     $                        V, LDV, T, LDT, C, LDC, WORK, LDWORK)
*
*
      RETURN
*
*     End of SLARFB
*
      END


      PROGRAM TSYMMLQ2
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C   SOLVER : SYMMLQ
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C Compilation : nécessite SYMMLQ.OBJ, MATFUN.OBJ, LOADMAT.OBJ
C ~~~~~~~~~~~             SPARFUN2.OBJ + précondit.
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

C     -- Déclarations ---------------------------------------
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      parameter(N = 100, NELEM = 5000, iwk= 5000)

      DIMENSION A(NELEM), IA(N+1), JA(NELEM),
     #          ALU(iwk),JLU(iwk), JU(N),
     #          B(N),X(N),R1(N),R2(N),V(N),W(N),Y(N),
     #          DR(N),JI(N),xref(N)
      LOGICAL JT(N), JT2(N)
      ierr=0

C     -- Chargement de la matrice A et du vecteur b ---------
      CALL loadmat(A,IA,JA,b,xref,ierr)

C     -- Paramètres du SYMMLQ -------------------------------
      epsilon = 1.0D-8
      it_max  = 500
      iflag   = 1
      ierr    = 0
      WRITE(*,*)'precond ? (0 = non)'
      READ(*,*)iflag
      ierr= 0

      IF(iflag.NE.0) THEN
         ierr=0
         CALL IC0 (N,A,IA,JA,ALU,JU,JLU,JT,jt2,JI,DR,iwk,
     $             ierr)
         WRITE(*,*)'Precond calcule !'
         READ(*,*)
      ENDIF
C     -- Appel de la sous-routine SYMMLQ -------------------
C
      CALL SYMMLQ( N, A, IA, JA, ALU, JLU, JU,
     #                   B, R1, R2, V, W, X, Y,
     #                   IFLAG, it_max, epsilon, ierr)

C     -- Sauvegarde du résultat vers MATLAB ----------------

      OPEN (UNIT = 1, FILE = 's_gmres.m', STATUS='UNKNOWN')
      DO 100 i = 1, N
         WRITE(1,*)'x(',i,')=',x(i),';'
100   CONTINUE
      CLOSE (UNIT = 1)

C     -- Visualisation de la solution ----------------------

      WRITE(*,*)
      WRITE(*,*)' <ENTER> pour voir la solution'
      READ(*,*)
      CALL VectAff2(N, x, xref)

      END


subroutine correlate_files(filea, fileb, amp_max, t_max)
  implicit none
  character(len=*) filea, fileb
  real*4 :: amp_max, t_max
  real*4 :: a(10000), b(10000), ba,bb,dt,bc
  real*4 :: c(10000)
  integer :: nmax, nerr,na, nb, nc, i

  real*4 correlate_time_begin
  real*4 correlate_time
  integer correlate_max
  integer isclosef

  nmax = 10000

  c(:) = 0.0

  call rsac1(filea, a, na, ba, dt, nmax, nerr)
  call rsac1(fileb, b, nb, bb, dt, nmax, nerr)

  nc = na + nb - 1
  call correlate(a, na, b, nb, c, nc)

  bc = correlate_time_begin(dt, na, nb, ba, bb)

  i = correlate_max(c, nc)

  if(isclosef(correlate_time(dt, bc, i), t_max) .ne. 1) then
     write(*,*)'max timing mismatch', t_max, correlate_time(dt,bc,i)
  endif

  if(isclosef(c(i), amp_max) .ne. 1) then
     write(*,*)'max amplitude mismatch', amp_max, c(i)
  endif

end subroutine correlate_files

program correlate_ex
  implicit none
  call correlate_files("imp02.sac", "imp06.sac", 1.0, 0.4)
  call correlate_files("imp02.sac", "imp12.sac", 1.0,  1.0)
  call correlate_files("imp02.sac", "imp02n.sac",1.0, -1.0)
  call correlate_files("imp02n.sac", "imp06.sac",1.0,  1.4)
  call correlate_files("imp02n.sac", "imp12.sac",1.0,  2.0)

  call correlate_files("imp06.sac", "imp02.sac", 1.0, -0.4)
  call correlate_files("imp12.sac", "imp02.sac", 1.0, -1.0)
  call correlate_files("imp02n.sac", "imp02.sac",1.0,  1.0)
  call correlate_files("imp06.sac", "imp02n.sac",1.0, -1.4)
  call correlate_files("imp12.sac", "imp02n.sac",1.0, -2.0)

end program correlate_ex


	FUNCTION TRAPZ1(X,Y,N)
	REAL X(N),Y(N)
	TRAPZ1=0.
	IF (N.LE.1) RETURN
	DO J=2,N
	TRAPZ1= TRAPZ1 + ABS(X(J)-X(J-1))*(Y(J)+Y(J-1))/2.
	ENDDO
	RETURN
	END


module SSRFPACKInterfaceModule
!------------------------------------------------------------------------------
! Lagrangian Particle / Panel Method - Spherical Model
!------------------------------------------------------------------------------
!
!> @author
!> Peter Bosler, Department of Mathematics, University of Michigan
!
!> @defgroup SSRFPACKInterface SSRFPACK Interface Module
!> Provides and object-oriented interface into the ssrfpack.f module @cite SSRFPACK .
!
!
! DESCRIPTION:
!> @file
!> Provides and object-oriented interface into the ssrfpack.f module.
!
!------------------------------------------------------------------------------
use NumberKindsModule
use LoggerModule
use SphereGeomModule
use PanelsModule, only : GetNTracer
use STRIPACKInterfaceModule

implicit none
private
public SSRFPACKData
public New, Delete
public SetSourceLagrangianParameter
public SetSourceAbsVort, SetSourceRelVort
public SetSourceTracer
public SetSourceVelocity
public SetSourceKineticEnergy
public SetSourceGeneralScalar
public SetSigmaTol
public SIGMA_FLAG, GRAD_FLAG
public InterpolateVector, InterpolateScalar, InterpolateTracer, InterpScalarToLLGrid
public SetSourceH

!
!----------------
! Types and module constants
!----------------
!

type SSRFPACKData
	real(kreal), pointer :: data1(:) => null(), &	! Source data values
							data2(:) => null(), &	! Source data values
							data3(:) => null(), &	! Source data values
							grad1(:,:) => null(), &	! Estimated gradients of source data1
							grad2(:,:) => null(), & ! Estimated gradients of source data2
							grad3(:,:) => null(), & ! Estimated gradients of source data3
							sigma1(:) => null(), &	! Smoothing factors for source data1
							sigma2(:) => null(), &	! Smoothing factors for source data2
							sigma3(:) => null(), &		! Smoothing factors for source data3
							tracer(:,:) => null(), &	! tracer data values
							tracerGrad(:,:,:) => null(), & ! tracer gradient values
							sigmaTracer(:,:) => null() ! smoothing factors for tracers
	real(kreal) :: dSig1, &			! Maximum difference in smoothing factors for source data1
				   dSig2, &			! Maximum difference in smoothing factors for source data2
				   dSig3, &			! Maximum difference in smoothing factors for source data3
				   sigmaTol	= 0.01_kreal	! Tolerance for setting smoothing factors in SSRFPACK GETSIG subroutine
end type

integer(kint), parameter :: SIGMA_FLAG = 1,& ! Flag indicates smoothing parameters are pre-computed
						    GRAD_FLAG = 1	 ! Flag indicates gradient estimates are pre-computed
integer(kint), save :: startTriangle = 1	 ! Stores initial guesses for locating new points within a Delaunay triangulation.

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28) :: logKey = 'SSRFPACK'
integer(kint), parameter :: logLevel = TRACE_LOGGING_LEVEL
character(len=28) :: formatString
character(len=128) :: logString
!
!----------------
! Interfaces
!----------------
!
interface New
	module procedure NewPrivate
	module procedure NewPrivateTracer
end interface

interface Delete
	module procedure DeletePrivate
end interface

interface SetSourceVelocity
	module procedure SetSourceVelocityFromMeshData
	module procedure SetSourceVelocityFromArrays
end interface

interface SetSourceH
	module procedure SetSourceHFromArrays
end interface

contains
!
!----------------
! Standard methods : Constructor / Destructor
!----------------
!
subroutine NewPrivate(self,DelTri,interpVector)
!	Allocate memory for SSRFPACK interpolation source data associated with spherical Delaunay triangulation object DelTri.
	type(SSRFPACKData), intent(out) :: self
	type(STRIPACKData), intent(in) :: DelTri
	logical(klog), intent(in) :: interpVector
	integer(kint) :: n

	if ( .NOT. logInit ) call InitLogger(log,procRank)

	n = delTri%n

	if ( interpVector ) then
		allocate(self%data1(n))
		self%data1 = 0.0_kreal
		allocate(self%data2(n))
		self%data2 = 0.0_kreal
		allocate(self%data3(n))
		self%data3 = 0.0_kreal
		allocate(self%grad1(3,n))
		self%grad1 = 0.0_kreal
		allocate(self%grad2(3,n))
		self%grad2 = 0.0_kreal
		allocate(self%grad3(3,n))
		self%grad3 = 0.0_kreal
		allocate(self%sigma1(6*n-12))
		self%sigma1 = 0.0_kreal
		allocate(self%sigma2(6*n-12))
		self%sigma2 = 0.0_kreal
		allocate(self%sigma3(6*n-12))
		self%sigma3 = 0.0_kreal
		call LogMessage(log,DEBUG_LOGGING_LEVEL,logKey,' SSRFPACK allocated for vector interp.')
	else
		allocate(self%data1(n))
		self%data1 = 0.0_kreal
		allocate(self%grad1(3,n))
		self%grad1 = 0.0_kreal
		allocate(self%sigma1(6*n-12))
		self%sigma1 = 0.0_kreal
		call LogMessage(log,DEBUG_LOGGING_LEVEL,logKey,' SSRFPACK allocated for scalar interp.')
	endif

end subroutine

subroutine NewPrivateTracer(self,DelTri,nTracers)
!	Allocate memory for SSRFPACK interpolation source data associated with spherical Delaunay triangulation object DelTri.
	type(SSRFPACKData), intent(out) :: self
	type(STRIPACKData), intent(in) :: DelTri
	integer(kint), intent(in) :: nTracers
	integer(kint) :: n

	if ( .NOT. logInit ) call InitLogger(log,procRank)

	n = delTri%n

	allocate(self%tracer(n,nTracers))
	self%tracer = 0.0_kreal
	allocate(self%tracerGrad(3,n,nTracers))
	self%tracerGrad = 0.0_kreal
	allocate(self%sigmaTracer(6*n-12,nTracers))
	self%sigmaTracer = 0.0_kreal

	call LogMessage(log,DEBUG_LOGGING_LEVEL,logKey,' SSRFPACK allocated for tracer interp.')
end subroutine

subroutine DeletePrivate(self)
! 	Free memory associated with an instance of SSRFPACKData
	type(SSRFPACKData), intent(inout) :: self
	if (associated(self%data1)) then
		deallocate(self%data1)
		deallocate(self%sigma1)
		deallocate(self%grad1)
	endif
	if ( associated(self%data2) ) then
		deallocate(self%data2)
		deallocate(self%data3)
		deallocate(self%grad2)
		deallocate(self%grad3)
		deallocate(self%sigma2)
		deallocate(self%sigma3)
	endif
	if ( associated(self%tracer)) then
		deallocate(self%tracer)
		deallocate(self%tracerGrad)
		deallocate(self%sigmaTracer)
	endif
end subroutine

!
!----------------
! Public functions
!----------------
!
subroutine SetSigmaTol(self,newTol)
! Set tolerance for SSRFPACK smoothing parameter subroutines
	type(SSRFPACKData), intent(inout) :: self
	real(kreal), intent(in) :: newTol
	self%sigmaTol = newTol
end subroutine

subroutine SetSourceLagrangianParameter(self,delTri)
! Set the SSRFPACK source data for interpolation of Lagrangian parameter vectors.
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	integer(kint) :: j, nActive, nParticles, errCode

	nActive = delTri%activePanels%N_Active
	nParticles = delTri%particles%N

	! Record source data values from source mesh
	do j=1,nActive
		self%data1(j) = delTri%activePanels%x0(1,j)
		self%data2(j) = delTri%activePanels%x0(2,j)
		self%data3(j) = delTri%activePanels%x0(3,j)
	enddo
	do j=1,nParticles
		self%data1(nActive + j ) = delTri%particles%x0(1,j)
		self%data2(nActive + j ) = delTri%particles%x0(2,j)
		self%data3(nActive + j ) = delTri%particles%x0(3,j)
	enddo

	! Estimate gradients at nodes of Delaunay triangulation
	do j=1,delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data2,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad2(:,j),errCode)
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data3,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad3(:,j),errCode)
	enddo

	! Determine smoothing factors at each Delaunay node
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig x0 = ',self%dSig1)
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data2,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad2,self%sigmaTol,self%sigma2,self%dSig2,errCode)
	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig y0 = ',self%dSig2)
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data3,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad3,self%sigmaTol,self%sigma3,self%dSig3,errCode)
	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig z0 = ',self%dSig3)
end subroutine

subroutine SetSourceTracer(self,delTri)
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	!
	integer(kint) :: j, k, nActive, nParticles, errCode, nTracer

	nActive = delTri%activePanels%N_active
	nParticles = delTri%particles%N

	nTracer = GetNTracer(delTri%activePanels)

	! record source data values from source mesh
	do k=1,nTracer
		do j=1,nActive
			self%tracer(j,k) = delTri%activePanels%tracer(j,k)
		enddo
		do j=1,nParticles
			self%tracer(nActive+j,k) = delTri%particles%tracer(j,k)
		enddo
	enddo

	! estimate gradients at nodes of Delaunay graph
	do k=1,nTracer
		do j=1,delTri%n
			call GRADL(delTri%n, j, delTri%x, delTri%y, delTri%z, self%tracer(:,k), &
					   delTri%list, delTri%lptr, delTri%lend, self%tracerGrad(:,j,k), errCode)
		enddo
	enddo

	! find smoothing factors at each node of Delaunay graph
	do k=1, nTracer
		call GETSIG(delTri%n, delTri%x, delTri%y, delTri%z, self%tracer(:,k), &
				    delTri%list, delTri%lptr, delTri%lend, &
				    self%tracerGrad(:,:,k), self%sigmaTol, self%sigmaTracer(:,k), self%dSig1, errCode)
	enddo

end subroutine

subroutine SetSourceVelocityFromMeshData(self,delTri)
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	integer(kint) :: j, nActive, nParticles, errCode

	nActive = delTri%activePanels%N_Active
	nParticles = delTri%particles%N

	! record source data values from source mesh
	do j=1,nActive
		self%data1(j) = delTri%activePanels%u(1,j)
		self%data2(j) = delTri%activePanels%u(2,j)
		self%data3(j) = delTri%activePanels%u(3,j)
	enddo
	do j=1,nParticles
		self%data1(j) = delTri%particles%u(1,j)
		self%data2(j) = delTri%particles%u(2,j)
		self%data3(j) = delTri%particles%u(3,j)
	enddo

	! Estimate gradients at nodes of Delaunay triangulation
	do j=1,delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data2,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad2(:,j),errCode)
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data3,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad3(:,j),errCode)
	enddo

	! Determine smoothing factors at each Delaunay node
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig u = ',self%dSig1)
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data2,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad2,self%sigmaTol,self%sigma2,self%dSig2,errCode)
	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig v = ',self%dSig2)
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data3,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad3,self%sigmaTol,self%sigma3,self%dSig3,errCode)
	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig w = ',self%dSig3)
end subroutine

subroutine SetSourceVelocityFromArrays(self, delTri, particlesVelocity, nParticles, activePanelsVelocity, nActive)
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	real(kreal), intent(in) :: particlesVelocity(:,:), activePanelsVelocity(:,:)
	integer(kint), intent(in) :: nParticles, nActive
	!
	integer(kint) :: j, errCode

	call LogMessage(log,DEBUG_LOGGING_LEVEL,logkey,'entering SetSourceVelocityFromArrays...')

	do j=1, nActive
		self%data1(j) = activePanelsVelocity(1,j)
		self%data2(j) = activePanelsVelocity(2,j)
		self%data3(j) = activePanelsVelocity(3,j)
	enddo

	do j=1, nParticles
		self%data1(nActive + j) = particlesVelocity(1,j)
		self%data2(nActive + j) = particlesVelocity(2,j)
		self%data3(nActive + j) = particlesVelocity(3,j)
	enddo

	call LogMessage(log,DEBUG_LOGGING_LEVEL,logkey,'...velocity data copied. estimating gradients.')

	do j=1, delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data2,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad2(:,j),errCode)
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data3,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad3(:,j),errCode)
	enddo

	call LogMessage(log,DEBUG_LOGGING_LEVEL,logkey,'...gradients done.')

! Determine smoothing factors at each Delaunay node
!	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
!				delTri%list,delTri%lptr,delTri%lend,&
!			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
!	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig u = ',self%dSig1)
!	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data2,&
!				delTri%list,delTri%lptr,delTri%lend,&
!			    self%grad2,self%sigmaTol,self%sigma2,self%dSig2,errCode)
!	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig v = ',self%dSig2)
!	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data3,&
!				delTri%list,delTri%lptr,delTri%lend,&
!			    self%grad3,self%sigmaTol,self%sigma3,self%dSig3,errCode)
!	if ( procRank == 0 ) call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig w = ',self%dSig3)
end subroutine

subroutine SetSourceHFromArrays(self, delTri, particlesH, nParticles, activePanelsH, nActive)
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	real(kreal), intent(in) :: particlesH(:), activePanelsH(:)
	integer(kint), intent(in) :: nParticles, nActive
	!
	integer(kint) :: j, errCode

	call LogMessage(log,DEBUG_LOGGING_LEVEL,logkey,'entering SetSourceHFromArrays.')

	do j=1, nActive
		self%data1(j) = activePanelsH(j)
	enddo

	do j=1, nParticles
		self%data1(nActive + j) = particlesH(j)
	enddo
		call LogMessage(log,DEBUG_LOGGING_LEVEL,logkey,'...h data copied. estimating gradients.')
	do j=1, delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
	enddo
	call LogMessage(log,DEBUG_LOGGING_LEVEL,logkey,'...gradients done. finding smoothing factors.')
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
	call LogMessage(log,DEBUG_LOGGING_LEVEL,'SSRFPACK : dSig H = ',self%dSig1)
end subroutine

subroutine SetSourceAbsVort(self,delTri)
! Setup SSRFPACK to interpolate scalar absolute vorticity data
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	integer(kint) :: j, nActive, nParticles, errCode

	nActive = delTri%activePanels%N_Active
	nParticles = delTri%particles%N

	do j=1,nActive
		self%data1(j) = delTri%activePanels%absVort(j)
	enddo

	do j=1,nParticles
		self%data1(nActive + j ) = delTri%particles%absVort(j)
	enddo

	do j=1,delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
	enddo

	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
	call LogMessage(log,TRACE_LOGGING_LEVEL,'SSRFPACK : dSig absVort = ',self%dSig1)
end subroutine

subroutine SetSourceRelVort(self,delTri)
! Setup SSSRFPACK to interpolate scalar relative vorticity data
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	integer(kint) :: j, nActive, nParticles, errCode

	nActive = delTri%activePanels%N_Active
	nParticles = delTri%particles%N

	do j=1,nActive
		self%data1(j) = delTri%activePanels%relVort(j)
	enddo

	do j=1,nParticles
		self%data1(nActive + j ) = delTri%particles%relVort(j)
	enddo

	do j=1,delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
	enddo

	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
	!call LogMessage(log,TRACE_LOGGING_LEVEL,'SSRFPACK : dSig relVort = ',self%dSig1)
end subroutine

subroutine SetSourceGeneralScalar(self, delTri, scalarData)
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	real(kreal), intent(in) :: scalarData(:)
	!
	integer(kint) :: j, errCode

	do j = 1, delTri%n
		self%data1(j) = scalarData(j)
	enddo
	do j=1,delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
	enddo
	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
			delTri%list,delTri%lptr,delTri%lend,&
			self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
end subroutine

subroutine InterpScalarToLLGrid(llOutput , self, delTri, lon, lat, nlon, nlat)
	real(kreal), intent(out) :: llOutput(:,:)
	type(SSRFPACKData), intent(in) :: self
	type(STRIPACKData), intent(in) :: delTri
	real(kreal), intent(in) :: lon(:), lat(:)
	integer(kint), intent(in) :: nLon, nLat
	!
	integer(kint) :: errCode

	call UNIF(delTri%n, delTri%x, delTri%y, delTri%z, self%data1, &
		      delTri%list, delTri%lptr, delTri%lend, SIGMA_FLAG, self%sigma1, &
		      nLat, nLat, nLon, lat, lon, GRAD_FLAG, self%grad1, llOutput, errCode)
end subroutine

!subroutine SetSourceEnergy(self,delTri)
!	type(SSRFPACKData), intent(inout) :: self
!	type(STRIPACKData), intent(in) :: delTri
!	integer(kint) :: j, nActive, nParticles, errCode
!
!	if ( (.NOT. associated(delTri%activePanels%energy) ).OR. (.NOT. associated(delTri%particles%energy) ) ) then
!		call LogMessage(log,ERROR_LOGGING_LEVEL,trim(logKey),' SetSourceEnergy ERROR : energy not defined.')
!		return
!	endif
!
!	nActive = delTri%activePanels%N_Active
!	nParticles = delTri%particles%N
!
!	do j=1,nActive
!		self%data1(j) = delTri%activePanels%energy(j)
!	enddo
!
!	do j=1,nParticles
!		self%data1(nActive+j) = delTri%particles%energy(j)
!	enddo
!
!	do j=1,delTri%n
!		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
!				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
!	enddo
!
!	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
!				delTri%list,delTri%lptr,delTri%lend,&
!			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
!	call LogMessage(log,TRACE_LOGGING_LEVEL,'SSRFPACK : dSig relVort = ',self%dSig1)
!
!end subroutine

subroutine SetSourceKineticEnergy(self,delTri)
	type(SSRFPACKData), intent(inout) :: self
	type(STRIPACKData), intent(in) :: delTri
	integer(kint) :: j, nActive, nParticles, errCode

	if ( (.NOT. associated(delTri%activePanels%ke) ).OR. (.NOT. associated(delTri%particles%ke) ) ) then
		call LogMessage(log,ERROR_LOGGING_LEVEL,trim(logKey),' SetSourceKineticEnergy ERROR : KE not defined.')
		return
	endif

	nActive = delTri%activePanels%N_Active
	nParticles = delTri%particles%N

	do j=1,nActive
		self%data1(j) = delTri%activePanels%ke(j)
	enddo

	do j=1,nParticles
		self%data1(nActive+j) = delTri%particles%ke(j)
	enddo

	do j=1,delTri%n
		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
	enddo

	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
				delTri%list,delTri%lptr,delTri%lend,&
			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
	call LogMessage(log,TRACE_LOGGING_LEVEL,'SSRFPACK : dSig relVort = ',self%dSig1)

end subroutine

!subroutine SetSourceTracer(self,delTri,tracerNumber)
!! Setup SSRFPACK to interpolate scalar tracer data
!	type(SSRFPACKData), intent(inout) :: self
!	type(STRIPACKData), intent(in) :: delTri
!	integer(kint), intent(in) :: tracerNumber
!	integer(kint) :: j, nActive, nParticles, errCode
!
!	nActive = delTri%activePanels%N_Active
!	nParticles = delTri%particles%N
!
!	do j=1,nActive
!		self%data1(j) = delTri%activePanels%tracer(j,tracerNumber)
!	enddo
!
!	do j=1,nParticles
!		self%data1(nActive + j ) = delTri%particles%tracer(j,tracerNumber)
!	enddo
!
!	call LogMessage(log,DEBUG_LOGGING_LEVEL,'SetSourcTracer : ','data set. Estimating gradients.')
!
!	do j=1,delTri%n
!		call GRADL(delTri%n,j,delTri%x,delTri%y,delTri%z,self%data1,&
!				   delTri%list,delTri%lptr,delTri%lend,self%grad1(:,j),errCode)
!	enddo
!
!	call LogMessage(log,DEBUG_LOGGING_LEVEL,'SetSourcTracer : ','gradients done. Finding smoothing factors.')
!
!	call GETSIG(delTri%n,delTri%x,delTri%y,delTri%z,self%data1,&
!				delTri%list,delTri%lptr,delTri%lend,&
!			    self%grad1,self%sigmaTol,self%sigma1,self%dSig1,errCode)
!	write(logString,'(A,I1,A)') 'SSRFPACK : dSig Tracer',tracerNumber,' = '
!	call LogMessage(log,TRACE_LOGGING_LEVEL,trim(logString),self%dSig1)
!end subroutine

function InterpolateVector(xyz,self,delTri)
!	Interpolate (using SSRFPACK) vector source data from self and delTri to value
!	at destination point xyz.
!
	real(kreal) :: InterpolateVector(3)
	real(kreal), intent(in) :: xyz(3)
	type(SSRFPACKData), intent(in) :: self
	type(STRIPACKData), intent(in) :: delTri
	real(kreal) :: newLat, newLon, newVector(3)
	integer(kint) :: errCode

	newLat = Latitude(xyz)
	newLon = Longitude(xyz)
	startTriangle = 1
	call INTRC1(delTri%n,newLat,newLon,delTri%x,delTri%y,delTri%z,self%data1, &
			    delTri%list,delTri%lptr,delTri%lend, &
			    SIGMA_FLAG,self%sigma1,GRAD_FLAG,self%grad1,startTriangle,&
			    newVector(1),errCode)
	call INTRC1(delTri%n,newLat,newLon,delTri%x,delTri%y,delTri%z,self%data2, &
			delTri%list,delTri%lptr,delTri%lend, &
			SIGMA_FLAG,self%sigma2,GRAD_FLAG,self%grad2,startTriangle,&
			newVector(2),errCode)
	call INTRC1(delTri%n,newLat,newLon,delTri%x,delTri%y,delTri%z,self%data3, &
			delTri%list,delTri%lptr,delTri%lend, &
			SIGMA_FLAG,self%sigma3,GRAD_FLAG,self%grad3,startTriangle,&
			newVector(3),errCode)
	InterpolateVector = newVector
end function

function InterpolateScalar(xyz,self,delTri)
!	Interpolate (using SSRFPACK) scalar source data from self and delTri to value
!	at destination point xyz.
!
	real(kreal) :: InterpolateScalar
	real(kreal), intent(in) :: xyz(3)
	type(SSRFPACKData), intent(in) :: self
	type(STRIPACKData), intent(in) :: delTri
	real(kreal) :: newLat, newLon, newScalar
	integer(kint) :: errCode

	newLat = Latitude(xyz)
	newLon = Longitude(xyz)
	call INTRC1(delTri%n,newLat,newLon,delTri%x,delTri%y,delTri%z,self%data1,&
				delTri%list,delTri%lptr,delTri%lend, &
				SIGMA_FLAG,self%sigma1,GRAD_FLAG,self%grad1,startTriangle,&
				newScalar,errCode)
	InterpolateScalar = newScalar
end function

function InterpolateTracer(xyz,self,delTri, tracerID)
!	Interpolate (using SSRFPACK) scalar source data from self and delTri to value
!	at destination point xyz.
!
	real(kreal) :: InterpolateTracer
	real(kreal), intent(in) :: xyz(3)
	type(SSRFPACKData), intent(in) :: self
	type(STRIPACKData), intent(in) :: delTri
	integer(kint), intent(in) :: tracerID
	real(kreal) :: newLat, newLon, newScalar
	integer(kint) :: errCode

	newLat = Latitude(xyz)
	newLon = Longitude(xyz)
	call INTRC1(delTri%n,newLat,newLon,delTri%x,delTri%y,delTri%z,self%tracer(:,tracerID),&
				delTri%list,delTri%lptr,delTri%lend, &
				SIGMA_FLAG,self%sigmaTracer(:,tracerID),GRAD_FLAG,self%tracerGrad(:,:,tracerID),startTriangle,&
				newScalar,errCode)
	InterpolateTracer = newScalar
end function

!
!----------------
! Module methods : type-specific functions
!----------------
!
subroutine InitLogger(aLog,rank)
	type(Logger), intent(inout) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	call New(aLog,logLevel)
	logInit = .TRUE.
end subroutine

end module


      subroutine m2rk4(y,dydx,n,x,h,yout,derivs)
      parameter(nmax=2,big=1.00e+03,small=1.00e-03)
      dimension y(n),dydx(n),yout(n),yt(nmax),dyt(nmax),dym(nmax)
      hh=h*0.5
      h6=h/6.00
      xh=x+hh
      do 11 i=1,n
      yt(i)=y(i)+hh*dydx(i)
11    continue
      call m2derivs(xh,yt,dyt)
      do 12 i=1,n
      yt(i)=y(i)+hh*dyt(i)
12    continue
      call m2derivs(xh,yt,dym)
      do 13 i=1,n
      yt(i)=y(i)+h*dym(i)
      dym(i)=dyt(i)+dym(i)
13    continue
      call m2derivs(x+h,yt,dyt)
      do 14 i=1,n
      yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.00*dym(i))
14    continue
      return
      end


      double complex function A43phiAQggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A43phiAQggmpmp_unsym,A43phiAQggmppm_unsym
      integer j1,j2,j3,j4
      A43phiAQggmpmp=
     & +A43phiAQggmpmp_unsym(j1,j2,j3,j4,za,zb)
     & +A43phiAQggmppm_unsym(j1,j2,j4,j3,za,zb)
      return
      end

c--- The expression below corresponds to one half of A4;3:
c---   Aleft(a1,q2,g3-,g4+)+Aright(a1,q2,g3-,g4+)+Aleft(a1,g3-,q2,g4+)

c--- It is obtained by summing the expressions given in:
c---  L.~J.~Dixon and Y.~Sofianatos,
c---  %``Analytic one-loop amplitudes for a Higgs boson plus four partons,''
c---  arXiv:0906.0008 [hep-ph].
      double complex function A43phiAQggmpmp_unsym(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'scale.f'
      include 'epinv.f'
      double complex V5L,V6L,A0phiAQggmpmp,lnrat
      double complex l13,l34,l12,l24,Lsm1DS,Lsm1_2me
      double precision s3,mhsq,s123,s234,s341,s412
      integer j1,j2,j3,j4
      s3(j1,j2,j3)=s(j1,j2)+s(j1,j3)+s(j2,j3)

      s123=s3(j1,j2,j3)
      s234=s3(j2,j3,j4)
      s341=s3(j3,j4,j1)
      s412=s3(j4,j1,j2)
      mhsq=s(j1,j2)+s(j1,j3)+s(j1,j4)+s(j2,j3)+s(j2,j4)+s(j3,j4)
      l12=lnrat(musq,-s(j1,j2))
      l13=lnrat(musq,-s(j1,j3))
      l24=lnrat(musq,-s(j2,j4))
      l34=lnrat(musq,-s(j3,j4))

c--- This is the same function as in the mpmm amplitude
      V5L=
     & -epinv**2-epinv*l12-0.5d0*l12**2
     & -epinv**2-epinv*l34-0.5d0*l34**2
     & +epinv**2+epinv*l13+0.5d0*l13**2
     & +epinv**2+epinv*l24+0.5d0*l24**2

c--- These are additional boxes
      V6L=
     . +Lsm1_2me(s341,s123,s(j1,j3),mhsq)
     . +Lsm1_2me(s412,s234,s(j2,j4),mhsq)
     . -Lsm1_2me(s412,s123,s(j1,j2),mhsq)
     . -Lsm1_2me(s234,s341,s(j3,j4),mhsq)
     . +Lsm1DS(s(j2,j4),s(j4,j1),s412)
     . +Lsm1DS(s(j1,j3),s(j3,j2),s123)
     . +Lsm1DS(s(j2,j4),s(j2,j3),s234)
     . +Lsm1DS(s(j1,j3),s(j1,j4),s341)

      A43phiAQggmpmp_unsym=
     .  A0phiAQggmpmp(j1,j2,j3,j4,za,zb)
     .  *(V5L+V6L
     .   -Lsm1DS(s(j3,j4),s(j4,j1),s341)
     .   -Lsm1DS(s(j1,j2),s(j2,j3),s123))

     . +(za(j1,j4)**2*za(j2,j3)**3/(za(j1,j2)*za(j3,j4)*za(j2,j4)**3)
     .  +za(j1,j2)**2*za(j3,j4)**2/(za(j1,j4)*za(j2,j4)**3))
     .  *(Lsm1DS(s(j2,j3),s(j3,j4),s234)
     .   +Lsm1DS(s(j4,j1),s(j1,j2),s412))

      return
      end