program simann

use iso_fortran_env, only: output_unit
use simulated_annealing_module, only: simulated_annealing_type, dp, print_vector

implicit none

integer, parameter :: n = 2, neps = 4

real (dp)   :: lb(n), ub(n), x(n), xopt(n), c(n), vm(n), t, eps, rt, fopt, vms
integer     :: ns, nt, nfcnev, ier, iseed1, iseed2, i, maxevl, iprint,  &
               nacc, nobds, step_mode, iunit
logical     :: max

type(simulated_annealing_type) :: sa

!  set input parameters.
max = .false.
eps = 1.0e-6_dp
rt = .5_dp
iseed1 = 1
iseed2 = 2
ns = 20
nt = 5
maxevl = 100000
iprint = 1
do i = 1, n
  lb(i) = -1.0e25_dp
  ub(i) =  1.0e25_dp
  c(i) = 2.0_dp
end do

nobds = 0 ! JW : no longer used

!  note start at local, but not global, optima of the judge function.
x(1) =  2.354471_dp
x(2) = -0.319186_dp

!  set input values of the input/output parameters.
t = 5.0_dp
vm(1:n) = 1.0_dp

! others:
step_mode = 1
vms = 0.1_dp
iunit = output_unit

write(output_unit,&
        '(A,//A,I3,/,A,L5,/A,G9.2,/A,G9.2,/A,G9.2,/A,I4,/A,I4,/A,I4,/A,I10,/A,I4,/A,I4,/A,I4)') &
        ' simulated annealing example',&
        '   number of parameters: ', n, &
        '   maximization:         ', max, &
        '   initial temp:         ', t, &
        '   rt:                   ', rt, &
        '   eps:                  ', eps, &
        '   ns:                   ', ns, &
        '   nt:                   ', nt, &
        '   neps:                 ', neps, &
        '   maxevl:               ', maxevl, &
        '   iprint:               ', iprint, &
        '   iseed1:               ', iseed1, &
        '   iseed2:               ', iseed2

call print_vector(output_unit,x, n, 'starting values')
call print_vector(output_unit,vm, n, 'initial step length')
call print_vector(output_unit,lb, n, 'lower bound')
call print_vector(output_unit,ub, n, 'upper bound')
call print_vector(output_unit,c, n, 'c vector')
write(output_unit, '(A)') '  ****   end of driver routine output   ****'
write(output_unit, '(A)') '  ****   before call to sa.             ****'

call sa%initialize(fcn,n,lb,ub,c,&
                   max,eps,ns,nt,neps,maxevl,&
                   iprint,iseed1,iseed2,step_mode,vms,iunit)

call sa%optimize(x, rt, t, vm, xopt, fopt, nacc, nfcnev, ier)

write(output_unit, '(A)') '  ****   results after sa   ****   '
call print_vector(output_unit,xopt, n, 'solution')
call print_vector(output_unit,vm, n, 'final step length')
write(output_unit,'(/A,G20.13,/A,I10,/A,I10,/A,I10,/A,G20.13,/A,I3/)') &
      ' optimal function value: ', fopt, &
      ' number of function evaluations:     ', nfcnev,&
      ' number of accepted evaluations:     ', nacc, &
      ' number of out of bound evaluations: ', nobds, &
      ' final temp: ', t, &
      '  ier: ', ier

contains

    subroutine fcn(me, theta, h, istat)
    !!  this subroutine is from the example in judge et al., the theory and
    !!  practice of econometrics, 2nd ed., pp. 956-7. there are two optima:
    !!  f(.864,1.23) = 16.0817 (the global minumum) and f(2.35,-.319) = 20.9805.

    implicit none

    class(simulated_annealing_type),intent(inout) :: me
    real (dp), dimension(:), intent(in)  :: theta
    real (dp), intent(out) :: h
    integer,intent(out) :: istat

    integer,parameter :: n = 20 !! size of arrays

    integer :: i !! counter
    real(dp),dimension(n),parameter :: y = [4.284_dp, &
                                            4.149_dp, &
                                            3.877_dp, &
                                            0.533_dp, &
                                            2.211_dp, &
                                            2.389_dp, &
                                            2.145_dp, &
                                            3.231_dp, &
                                            1.998_dp, &
                                            1.379_dp, &
                                            2.106_dp, &
                                            1.428_dp, &
                                            1.011_dp, &
                                            2.179_dp, &
                                            2.858_dp, &
                                            1.388_dp, &
                                            1.651_dp, &
                                            1.593_dp, &
                                            1.046_dp, &
                                            2.152_dp ]
    real(dp),dimension(n),parameter :: x2 = [.286_dp, &
                                             .973_dp, &
                                             .384_dp, &
                                             .276_dp, &
                                             .973_dp, &
                                             .543_dp, &
                                             .957_dp, &
                                             .948_dp, &
                                             .543_dp, &
                                             .797_dp, &
                                             .936_dp, &
                                             .889_dp, &
                                             .006_dp, &
                                             .828_dp, &
                                             .399_dp, &
                                             .617_dp, &
                                             .939_dp, &
                                             .784_dp, &
                                             .072_dp, &
                                             .889_dp ]

    real(dp),dimension(n),parameter :: x3 = [.645_dp, &
                                             .585_dp, &
                                             .310_dp, &
                                             .058_dp, &
                                             .455_dp, &
                                             .779_dp, &
                                             .259_dp, &
                                             .202_dp, &
                                             .028_dp, &
                                             .099_dp, &
                                             .142_dp, &
                                             .296_dp, &
                                             .175_dp, &
                                             .180_dp, &
                                             .842_dp, &
                                             .039_dp, &
                                             .103_dp, &
                                             .620_dp, &
                                             .158_dp, &
                                             .704_dp ]

    h = 0.0_dp
    do i = 1, n
        h = (theta(1) + theta(2)*x2(i) + (theta(2)**2)*x3(i) - y(i))**2 + h
    end do

    istat = 0

    end subroutine fcn

end program simann


!
!     (c) 2019-2020 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
!     contract # NRC-HQ-60-17-C-0007
!
module adi_mod
  implicit none

  integer ,parameter :: digits=8  ! num. digits of kind
  integer ,parameter :: decades=9 ! num. representable decades
  integer ,parameter :: rkind = selected_real_kind(digits)
  integer ,parameter :: ikind = selected_int_kind(decades)

  type grid_block
    real(rkind), dimension(8,3) :: v
    real(rkind), dimension(8) :: T, ddx2, ddy2, ddz2
  end type grid_block

  type(grid_block)  ,dimension(:,:,:) ,allocatable  :: global_grid_block
  integer(ikind)  :: i,j,k
  integer(ikind) ,parameter :: nx=21, ny=21, nz=21

contains

  impure function position_vectors(nx,ny,nz) result(vector_field)
    integer(ikind), intent(in) :: nx, ny, nz
    integer(ikind), parameter :: components=3
    real(rkind), parameter :: dx=0.75/(5.0), dy=0.75/(5.0)
    real(rkind), parameter :: dx_s=0.25/5.0, dy_s=0.25/5.0
    real(rkind), dimension(:,:,:,:) ,allocatable  :: vector_field

    allocate( vector_field(nx,ny,nz,components) )

    associate( dz=>10.0/(nz-1) )
      do concurrent( i=1:nx, j=1:ny, k=1:nz )
        vector_field(i,j,k,1) = merge(-0.75+(i-6)*dx, merge( -1.0+(i-1)*dx_s, 0.75+(i-16)*dx_s, i<6), i>=6 .and. i<=16)
        vector_field(i,j,k,2) = merge(-0.75+(j-6)*dy, merge( -1.0+(j-1)*dy_s, 0.75+(j-16)*dy_s, j<6), j>=6 .and. j<=16)
        vector_field(i,j,k,3) = (k-1)*dz
      end do
    end associate
  end function

  subroutine write_component(grid_blocks, component, file_unit, string)
    type(grid_block), intent(in), dimension(:,:,:) :: grid_blocks
    character(len=*), intent(in) :: component
    character(len=*), intent(in), optional :: string
    integer, intent(in) :: file_unit
    integer(ikind) :: i, j, k, nv, ndimension
    associate( n=>shape(grid_blocks) )
    do k=1, n(3)
      do j=1, n(2)
        do i=1, n(1)
          do nv=1,merge(1,8,component=="string")
            select case(component)
              case("T")
                write (file_unit,*) grid_blocks(i,j,k)%T(nv)
              case("v")
                write(file_unit, *) (grid_blocks(i,j,k)%v(nv,ndimension), ndimension=1,3)
              case("ddx2")
                write (file_unit,*) grid_blocks(i,j,k)%ddx2(nv)
              case("string")
                write (file_unit,*) string
              case default
                error stop "write_component: unrecognized component"
            end select
          end do
        end do
      end do
    end do
    end associate
  end subroutine

  subroutine output_result(grid_blocks)
    type(grid_block), intent(in), dimension(:,:,:) :: grid_blocks
    integer file_unit

    open(newunit=file_unit, file="spatial-derivatives.vtk")
    write(file_unit, '(a)') '# vtk DataFile Version 3.0'
    write(file_unit, '(a)') '3d-htc voxels'
    write(file_unit, '(a)') 'ASCII'
    write(file_unit, '(a)') 'DATASET UNSTRUCTURED_GRID'
    write(file_unit, '(a,i5,a)') "POINTS ", 8*(nx-1)*(ny-1)*(nz-1), " double"
    call write_component( grid_blocks, "v", file_unit)

    block
      integer i, j, k, nv
      write(file_unit,'(a,i5,3x,i5)') "CELLS ", (nx-1)*(ny-1)*(nz-1), 9*(nx-1)*(ny-1)*(nz-1)
      associate( n=>shape(grid_blocks) )
        do k=1, n(3)
          do j=1, n(2)
            do i=1, n(1)
              associate( grid_block_id => 8*(i+(j-1)*n(1)+(k-1)*n(1)*n(2)-1) )
                write(file_unit,*) "8", (grid_block_id+nv-1, nv=1,8)
              end associate
            end do
          end do
        end do
      end associate
    end block

    write(file_unit,'(a,I5)') "CELL_TYPES ", (nx-1)*(ny-1)*(nz-1)
    call write_component( grid_blocks, "string", file_unit, string="11")

    write(file_unit,'(a, I5)') 'POINT_DATA ', 8*(nx-1)*(ny-1)*(nz-1)
    write(file_unit,'(a)') 'SCALARS Temperature double 1'
    write(file_unit,'(a)') 'LOOKUP_TABLE default'
    call write_component( grid_blocks, "T", file_unit)

    write(file_unit,'(a)') 'SCALARS ddx2_Temperature double 1'
    write(file_unit,'(a)') 'LOOKUP_TABLE default'
    call write_component( grid_blocks, "ddx2", file_unit)

    close(file_unit)

    block
      integer i, error_file_unit
      open(newunit=error_file_unit, file="error-order.dat")
      do i=2, nx-2
        write(error_file_unit, *) &
          (grid_blocks(i,2,2)%v(1,1)-grid_blocks(i-1,2,2)%v(1,1))**2, grid_blocks(i,2,2)%ddx2(1)-2.0*grid_blocks(i,2,2)%v(1,2)
      end do
      close(error_file_unit)
    end block
  end subroutine output_result

end module adi_mod

program main
  use adi_mod
  implicit none

  real(rkind), dimension(8) :: dx_m, dy_m, dz_m
  real(rkind), dimension(8) :: dx_f, dy_f, dz_f
  real(rkind), dimension(8) :: dx_b, dy_b, dz_b
  real(rkind)               :: avg_err, minimum_dx
  integer(ikind)            :: nv

  associate( p => position_vectors(nx,ny,nz) )

    allocate(global_grid_block(nx-1,ny-1,nz-1))

    associate( x=>(p(:,:,:,1)), y=>(p(:,:,:,2)), z=>(p(:,:,:,3)) )
      do concurrent(k=1:nz-1, j=1:ny-1, i=1:nx-1)
        associate( v=>global_grid_block(i,j,k)%v )
          v(1,:) = [x(i,j,k)      , y(i,j,k)      , z(i,j,k)      ]
          v(2,:) = [x(i+1,j,k)    , y(i+1,j,k)    , z(i+1,j,k)    ]
          v(3,:) = [x(i,j+1,k)    , y(i,j+1,k)    , z(i,j+1,k)    ]
          v(4,:) = [x(i+1,j+1,k)  , y(i+1,j+1,k)  , z(i+1,j+1,k)  ]
          v(5,:) = [x(i,j,k+1)    , y(i,j,k+1)    , z(i,j,k+1)    ]
          v(6,:) = [x(i+1,j,k+1)  , y(i+1,j,k+1)  , z(i+1,j,k+1)  ]
          v(7,:) = [x(i,j+1,k+1)  , y(i,j+1,k+1)  , z(i,j+1,k+1)  ]
          v(8,:) = [x(i+1,j+1,k+1), y(i+1,j+1,k+1), z(i+1,j+1,k+1)]
          associate(T=>global_grid_block(i,j,k)%T, ddx2=>global_grid_block(i,j,k)%ddx2 )
            T(:) = v(:,1)**2 * v(:,2) ! T=x^2*y => d^2T/dx^2=y
            ddx2(:) = 0.0
          end associate
        end associate
      end do
    end associate
  end associate

!  compute_derivatives: block
!    real(rkind), dimension(8) :: dx_m, dy_m, dz_m
!    real(rkind), dimension(8) :: dx_f, dy_f, dz_f
!    real(rkind), dimension(8) :: dx_b, dy_b, dz_b

    do concurrent( k=2:nz-2, j=2:ny-2, i=2:nx-2)

      !calculate ddx2
      associate(v=>global_grid_block(i,j,k)%v , ddx2=>global_grid_block(i,j,k)%ddx2, &
        T=>global_grid_block(i,j,k)%T,  ddy2=>global_grid_block(i,j,k)%ddy2, ddz2=>global_grid_block(i,j,k)%ddz2 )

        associate(nv=>[1,3,5,7])
          dx_m(nv) = 0.5*(v(nv+1,1) - global_grid_block(i-1,j,k)%v(nv,1))
          dx_f(nv) =      v(nv+1,1) - v(nv,1)
          dx_b(nv) =      v(nv,1)   - global_grid_block(i-1,j,k)%v(nv,1)
          ddx2(nv) = (T(nv+1) - T(nv)  )/(dx_f(nv)*dx_m(nv)) - &
          &          (T(nv)   - global_grid_block(i-1,j,k)%T(nv))/(dx_b(nv)*dx_m(nv))
        end associate
        associate(nv=>[2,4,6,8])
          dx_m(nv) = 0.5*(global_grid_block(i+1,j,k)%v(nv,1) - v(nv-1,1))
          dx_f(nv) =      global_grid_block(i+1,j,k)%v(nv,1) - v(nv,1)
          dx_b(nv) =      global_grid_block(i,j,k)%v(nv,1)   - v(nv-1,1)
          ddx2(nv) = ( global_grid_block(i+1,j,k)%T(nv) - T(nv) )/(dx_f(nv)*dx_m(nv)) - (T(nv) - T(nv-1))/(dx_b(nv)*dx_m(nv))
        end associate

        !calculate ddy2
        associate(nv=>[1,2,5,6])
          dy_m(nv)=0.5*(v(nv+2,2) - global_grid_block(i,j-1,k)%v(nv,2))
          dy_f(nv)=v(nv+2,2) - v(nv,2)
          dy_b(nv)=v(nv,2) - global_grid_block(i,j-1,k)%v(nv,2)
          ddy2(nv)=(T(nv+2)-T(nv))/(dy_f(nv)*dy_m(nv)) - (T(nv)-global_grid_block(i,j-1,k)%T(nv))/(dy_b(nv)*dy_m(nv))
        end associate

        associate(nv=>[3,4,7,8])
          dy_m(nv) =0.5*(global_grid_block(i,j+1,k)%v(nv,2) - v(nv-2,2))
          dy_f(nv) =global_grid_block(i,j+1,k)%v(nv,2) - v(nv,2)
          dy_b(nv) = v(nv,2) - v(nv-2,2)
          ddy2(nv) = (global_grid_block(i,j+1,k)%T(nv) - T(nv))/(dy_f(nv)*dy_m(nv))- (T(nv) - T(nv-2))/(dy_b(nv)*dy_m(nv))
        end associate

        !calculate ddz2
        associate(nv=>[1,2,3,4])
          dz_m(nv)=0.5*(v(nv+4,3) - global_grid_block(i,j,k-1)%v(nv,3))
          dz_f(nv)=v(nv+4,3) - v(nv,3)
          dz_b(nv)=v(nv,3) - global_grid_block(i,j,k-1)%v(nv,3)
          ddz2(nv)=(T(nv+4)- T(nv))/(dz_f(nv)*dz_m(nv)) - (T(nv) - global_grid_block(i,j,k-1)%T(nv))/(dz_b(nv)*dz_m(nv))
        end associate

        associate(nv=>[5,6,7,8])
          dz_m(nv)=0.5*(global_grid_block(i,j,k+1)%v(nv,3)-v(nv-4,3))
          dz_f(nv)=global_grid_block(i,j,k+1)%v(nv,3)-v(nv,3)
          dz_b(nv)=v(nv,3)-v(nv-4,3)
          ddz2(nv)=(global_grid_block(i,j,k+1)%T(nv)-T(nv))/(dz_f(nv)*dz_m(nv))- (T(nv)-T(nv-4))/(dz_b(nv)*dz_m(nv))
        end associate
      end associate
    end do
!  end block compute_derivatives

!  error_calculation: block
!    real(rkind)            :: avg_err, minimum_dx
!    integer(ikind)         :: nv
    minimum_dx=0.25/5.0
    avg_err=0.0
    do concurrent(k=2:nz-2,j=2:ny-2,i=2:nx-2,nv=1:8)
      avg_err=avg_err+abs(global_grid_block(i,j,k)%ddx2(nv)-2.0*global_grid_block(i,j,k)%v(nv,2))
    end do
    avg_err=avg_err/((nz-3)*(ny-3)*(nx-3)*8)
    if (avg_err <= minimum_dx**2) print *, "Test passed."
!  end block error_calculation

  call output_result(global_grid_block)

end program main


module RandomClass
    use, intrinsic :: iso_fortran_env
    use MathClass
    implicit none

    type::Random_
        integer(int32) :: random_int
        integer(int32),allocatable  :: random_int_seed(:)
        integer(int32),allocatable :: random_int_vec(:)
        real(real64) :: random_real
        real(real64),allocatable :: random_real_vec(:)
    contains
        procedure :: init       => initRandom
        procedure :: random     => getRandom
        procedure :: randint    => getRandomInt
        procedure :: name    => nameRandom
        procedure :: choiceInt  => choiceRandomInt
        procedure :: choiceReal => choiceRandomReal
        procedure :: uniform    => uniformRandom
        procedure :: gauss    => gaussRandom
        procedure :: ChiSquared => ChiSquaredRandom
        procedure :: Chauchy => ChauchyRandom
        procedure :: Lognormal => LognormalRandom
        procedure :: InverseGauss => InverseGaussRandom
        procedure :: save       => saveRandom

        procedure,pass :: randnRandomVector
        procedure,pass :: randnRandomArray
        generic :: randn => randnRandomArray,randnRandomvector

        procedure :: fill       => fillRandom
        procedure :: histogram      => histogramRandom
        procedure :: scalar          => scalarRandom
        procedure :: vector          => vectorRandom
        procedure :: matrix          => matrixRandom
        procedure :: cube            => cubeRandom
        !procedure :: choiceString => choiceRandomString
    end type

    interface randi
        module procedure :: randi_range_rank2,randi_imax,randi_imax_n
    end interface

    interface rand
        module procedure :: rand_n,rand_sz2,rand_sz3
    end interface
contains

!##########################################
subroutine initRandom(obj)
    class(Random_),intent(inout)::obj
    !integer(int32),optional,intent(in)::SeedSize
    integer(int32)::SeedSize

    call random_seed(size=SeedSize)
    if(.not.allocated(obj%random_int_seed) )then
        allocate(obj%random_int_seed(SeedSize) )
    endif
    !call random_seed(get=obj%random_real_vec)
    call random_seed(get=obj%random_int_seed)

end subroutine
!##########################################

!##########################################
function getRandom(obj,distribution) result(x)
    class(Random_)::obj
    character(*),optional,intent(in)::distribution
    real(real64) :: x,val,y
    integer(int32) :: i

    if(trim(distribution)=="Binomial" .or. trim(distribution)=="binomial")then
        val=0.0d0
        do i=1,20
            call random_number(y)
            val=val+y
        enddo
        x=val-10.0d0
        return
    endif

    call random_number(x)

end function
!##########################################

!##########################################
subroutine saveRandom(obj)
    class(Random_),intent(inout)::obj

    call random_seed(put=obj%random_int_seed)
end subroutine
!##########################################

!##########################################
function uniformRandom(obj,From,To) result(x)
    class(Random_),intent(in)::obj
    real(real64) :: x,a,diff,val(2)
    real(real64),intent(in) :: From,To

    val(1)=From
    val(2)=To
    diff=abs(from-to)
    call random_number(a)
    x=a*diff+minval(val)

end function
!##########################################

!##########################################
function getRandomInt(obj,From,To) result(x)
    class(Random_),intent(in)::obj
    real(real64) :: xr,a,diff,val(2)
    integer(int32) :: x
    integer(int32),intent(in) :: From,To

    val(1)=From
    val(2)=To
    diff=abs(dble(from)- dble(to) )

    call random_number(a)
    xr=a*diff+minval(val)
    x=nint(xr)
    if(x==From-1)then
        x=From
    endif
    if(x==To+1)then
        x=To
    endif

end function
!##########################################

!##########################################
function choiceRandomInt(obj,Vector,Array) result(val)
    class(Random_),intent(in)::obj
    integer(int32),optional,intent(in) :: Vector(:)
    integer(int32),Optional,intent(in) :: Array(:,:)
    integer(int32) :: val,posi,posi2

    ! it should be over-rided
    if(present(Vector) )then
        posi=obj%randint(1,size(Vector) )
        val=Vector(posi)
        return
    endif

    if(present(Array ))then
        print *, size(Array,1)
        posi =obj%randint(1,size(Array,1) )
        posi2=obj%randint(1,size(Array,2) )
        val=Array(posi,posi2)
        return
    endif

    print *, "No list is imported."

end function
!##########################################

!##########################################
function choiceRandomReal(obj,Vector,Array) result(val)
    class(Random_),intent(in)::obj
    real(real64),Optional,intent(in) :: Vector(:)
    real(real64),Optional,intent(in) :: Array(:,:)
    real(real64) :: val
    integer(int32) :: posi,posi2

    ! it should be over-rided
    if(present(Vector) )then
        posi=obj%randint(1,size(Vector) )
        val=Vector(posi)
        return
    endif

    if(present(Array ))then
        print *, size(Array,1)
        posi =obj%randint(1,size(Array,1) )
        posi2=obj%randint(1,size(Array,2) )
        val=Array(posi,posi2)
        return
    endif

    print *, "No list is imported."

end function
!##########################################

!##########################################
function randnRandomArray(obj,d0,d1) result(array)
    class(Random_),intent(inout)::obj
    real(real64),allocatable :: array(:,:)
    integer(int32),intent(in) :: d0,d1
    integer(int32) :: n,m,i,j

    n=d0
    m=d1

    allocate(array(n,m) )

    call obj%init()

    do i=1,n
        do j=1,m
            array(i,j) = obj%random()
        enddo
    enddo

end function
!##########################################

!##########################################
function randnRandomVector(obj,d0) result(array)
    class(Random_),intent(inout)::obj
    real(real64),allocatable :: array(:)
    integer(int32),intent(in) :: d0
    integer(int32) :: n,m,i,j

    n=d0

    allocate(array(n) )

    call obj%init()

    do i=1,n
        array(i) = obj%random()
    enddo

end function
!##########################################

!##########################################
!function choiceRandomString(obj,Str) result(val)
!    class(Random_),intent(in) :: obj
!    character(*),  intent(in) :: Str
!    character(1) :: val
!    integer(int32) :: posi,length
!
!    length=len(Str)
!
!    ! it should be over-rided
!    posi=obj%randint(1,length )
!    val=Str(posi)
!
!
!end function
!##########################################

!##########################################
function histogramRandom(obj,list,division) result(histogram)
    class(Random_),intent(inout) :: obj
    real(real64),intent(in)  :: list(:) ! data-list
    real(real64),allocatable :: histogram(:,:)
    integer(int32),optional,intent(in) :: division
    integer(int32) :: i,j,n
    real(real64) :: maxv, minv,val,intval

    n=input(default=10,option=division)

    maxv=maxval(list)
    minv=minval(list)

    intval=(maxv-minv)/dble(n)

    allocate( histogram(n,2) )
    histogram(:,:)=0

    val = minv-0.00000010d0
    do i=1,size(histogram,1)
        histogram(i,1) = val
        val = val + intval
    enddo

    do i=1,size(list,1)
        val = minv-0.00000010d0
        do j=1, size(histogram,1)
            if(val < list(i) .and. list(i) <= val + intval  )then
                histogram(j,2) = histogram(j,2) + 1.0d0
                exit
            endif
            val = val + intval
        enddo
    enddo

end function
!##########################################

!##########################################
function nameRandom(obj) result(str)
    class(Random_),intent(inout) :: obj
    character(200) :: str
    integer(int32) :: n

    call obj%init()
    n=int(obj%random()*1000000)

    str="RandName"//fstring_int(n)
!##########################################

end function

! Reference: omitakahiro.github.io

!##########################################
function gaussRandom(obj,mu,sigma) result(ret)
    class(Random_),intent(inout) :: obj
    real(real64),intent(in) :: mu,sigma
    real(real64) :: ret
    real(real64) :: pi = 3.141592653d0

    ret = sqrt( -2.0d0 * log(obj%random() ) )*sin(2.0d0*pi*obj%random())
    ret = mu + sigma*ret

end function
!##########################################

!##########################################
function ChiSquaredRandom(obj,k) result(ret)
    class(Random_),intent(inout) :: obj
    real(real64),intent(in) :: k
    real(real64) :: ret,z,w
    real(real64) :: pi = 3.141592653d0
    integer(int32) :: i

    w=0.0d0
    z=0.0d0
    ret=0.0d0
    do i=1, int(k)
        z = sqrt( -2.0d0 * log(obj%random() ) )*sin(2.0d0*pi*obj%random())
        w = w + z*z
    enddo
    ret = w

end function
!##########################################

!##########################################
function ChauchyRandom(obj,mu,gamma) result(ret)
    class(Random_),intent(inout) :: obj
    real(real64),intent(in) :: mu,gamma
    real(real64) :: ret,z,w
    real(real64) :: pi = 3.141592653d0

    ret = mu + gamma*tan(pi*(obj%random()-0.50d0 ) )

end function
!##########################################

!##########################################
function LognormalRandom(obj,mu,sigma) result(ret)
    class(Random_),intent(inout) :: obj
    real(real64),intent(in) :: mu,sigma
    real(real64) :: ret,z,w
    real(real64) :: pi = 3.141592653d0

    ret = obj%gauss(mu=mu, sigma=sigma)
    ret = exp(ret)

end function
!##########################################

!##########################################
function InverseGaussRandom(obj,mu,lambda) result(ret)
    class(Random_),intent(inout) :: obj
    real(real64),intent(in) :: mu,lambda
    real(real64) :: ret,x,y,z,w
    real(real64) :: pi = 3.141592653d0

    x = obj%gauss(mu=0.0d0,sigma=1.0d0)
    y = x*x
    w = mu+0.50d0*y*mu*mu/lambda - (0.50d0*mu/lambda)*sqrt(4.0d0*mu*lambda*y+mu*mu*y*y)
    z = obj%random()

    if(z < mu/(mu+w))then
        ret=w
    else
        ret=mu*mu/w
    endif
end function
!##########################################

!##########################################
subroutine fillRandom(obj,array,vector)
    class(Random_),intent(inout) :: obj
    real(real64),optional,intent(inout)  :: array(:,:),vector(:)
    integer(int32) :: i,j

    call obj%init()
    if(present(array) )then
        do i=1,size(Array,2)
            do j=1,sizE(Array,1)
                array(j,i) = obj%random()
            enddo
        enddo
    endif
    if(present(vector) )then
        do i=1,size(vector,1)
            vector(i) = obj%random()
        enddo
    endif
end subroutine
!##########################################

!##########################################
function cubeRandom(obj,size1, size2, size3) result(ret)
    class(Random_) ,intent(inout) :: obj
    integer(int32),intent(in) :: size1, size2, size3
    real(real64),allocatable :: ret(:,:,:)
    integer(int32) :: i,j,k

    allocate( ret(size1,size2, size3) )
    do i=1,size3
        do j=1,size2
            do k=1,size1
                ret(k,j,i) = obj%random()
            enddo
        enddo
    enddo

end function
!##########################################

!##########################################
function matrixRandom(obj,size1, size2) result(ret)
    class(Random_) ,intent(inout) :: obj
    integer(int32),intent(in) :: size1, size2
    real(real64),allocatable :: ret(:,:)
    integer(int32) :: j,k

    allocate( ret(size1,size2) )
    do j=1,size2
        do k=1,size1
            ret(k,j) = obj%random()
        enddo
    enddo

end function
!##########################################

!##########################################
function vectorRandom(obj,size1) result(ret)
    class(Random_) ,intent(inout) :: obj
    integer(int32),intent(in) :: size1
    real(real64),allocatable :: ret(:)
    integer(int32) :: k

    allocate( ret(size1) )
    do k=1,size1
        ret(k) = obj%random()
    enddo

end function
!##########################################

!##########################################
function scalarRandom(obj,size1) result(ret)
    class(Random_) ,intent(inout) :: obj
    integer(int32),intent(in) :: size1
    real(real64),allocatable :: ret
    integer(int32) :: k

    ret = obj%random()

end function
!##########################################

!##########################################
function randi_range_rank2(valrange,size1,size2) result(ret)
    integer(int32),intent(in) :: valrange(2),size1, size2
    type(Random_) :: random
    integer(int32) :: i,j
    integer(int32),allocatable :: ret(:,:)

    allocate(ret(size1,size2) )
    do i=1,size2
        do j=1,size1
            ret(j,i) = nint(dble(valrange(2)-valrange(1))*random%random()*1.00050d0 + dble(valrange(1)) )
        enddo
    enddo

end function
!##########################################

!##########################################
function randi_imax(imax) result(ret)
    integer(int32),intent(in) :: imax
    type(Random_) :: random
    integer(int32) :: ret

    ret = nint(random%random()*dble(imax-1) + 1.0d0)

end function
!##########################################

!##########################################
function randi_imax_n(imax,n) result(ret)
    integer(int32),intent(in) :: imax, n
    type(Random_) :: random
    integer(int32) :: ret(n),i

    do i=1,n
        ret(i) = nint(random%random()*dble(imax-1) + 1.0d0)
    enddo
end function
!##########################################

!##########################################
function rand_n(n) result(ret)
    integer(int32),intent(in) :: n
    type(Random_) :: random
    real(real64) :: ret(n)
    integer(int32) :: i

    do i=1,n
        ret(i) = random%random()
    enddo

end function
!##########################################

!##########################################
function rand_sz2(sz1,sz2) result(ret)
    integer(int32),intent(in) :: sz1,sz2
    type(Random_) :: random
    real(real64) :: ret(sz1,sz2)
    integer(int32) :: i,j
    do j=1,sz2
        do i=1,sz1
            ret(i,j) = random%random()
        enddo
    enddo

end function
!##########################################

!##########################################
function rand_sz3(sz1,sz2,sz3) result(ret)
    integer(int32),intent(in) :: sz1,sz2,sz3
    type(Random_) :: random
    real(real64) :: ret(sz1,sz2,sz3)
    integer(int32) :: i,j,k
    do k=1,sz3
        do j=1,sz2
            do i=1,sz1
                ret(i,j,k) = random%random()
            enddo
        enddo
    enddo

end function
!##########################################

end module


      DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
C**********************************************************************
C
C     auxiliary function for two/three particle decay mode
C     (standard LAMBDA**(1/2) function)
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION X , xlam , Y , yz , Z
      SAVE
C
      yz = Y - Z
      xlam = X*X - 2.D0*X*(Y+Z) + yz*yz
      IF ( xlam.LT.0.D0 ) xlam = -xlam
      PHO_XLAM = SQRT(xlam)
      END FUNCTION


!
! Copyright (c) 2020 TECHNICAL UNIVERSITY OF MUNICH, DEPARTMENT OF MECHANICAL ENGINEERING, CHAIR OF APPLIED MECHANICS,
! BOLTZMANNSTRASSE 15, 85748 GARCHING/MUNICH, GERMANY, RIXEN@TUM.DE.
!
! Distributed under 3-Clause BSD license. See LICENSE file for more information.
!

module integrand_structural3d_nonlinear_fun
    use, intrinsic:: iso_fortran_env, only: dp=>real64
    use tools
    use fields

    implicit none
    private

    public igstrc3dnl_fields, igstrc3dnl_no_of_dofs, igstrc3dnl_spatial_dimension, igstrc3dnl_f_int_and_jac, &
            igstrc3dnl_m_int, igstrc3dnl_no_of_fields

    contains

        subroutine igstrc3dnl_fields(fields)
            integer, intent(out) :: fields(:)
            fields = (/ UX, UY, UZ /)
        end subroutine igstrc3dnl_fields

        integer function igstrc3dnl_no_of_fields() result(no_of_fields)
            no_of_fields = 3
        end function igstrc3dnl_no_of_fields

        integer function igstrc3dnl_no_of_dofs(no_of_nodes)
            integer, intent(in) :: no_of_nodes
            igstrc3dnl_no_of_dofs = 3*no_of_nodes
        end function igstrc3dnl_no_of_dofs

        integer function igstrc3dnl_spatial_dimension()
            igstrc3dnl_spatial_dimension = 3
        end function igstrc3dnl_spatial_dimension

        subroutine igstrc3dnl_f_int_and_jac(n, dn_dxi, xn, d, dd, t, matfunc_3d, s0, t0, s1, f_int_k_dk_out, &
        no_of_fields, spatial_dimension, no_of_nodes, no_of_states)
            integer, intent(in) :: spatial_dimension
            integer, intent(in) :: no_of_nodes
            integer, intent(in) :: no_of_states
            integer, intent(in) :: no_of_fields
            real(dp), intent(in) :: n(no_of_nodes)
            real(dp), intent(in) :: dn_dxi(no_of_nodes,spatial_dimension)
            real(dp), intent(in) :: xn(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: d(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: dd(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: t
            interface
                subroutine sv_c_dc_3d(f, df, t, s0, t0, s1, sv_out, c_out, dc_out)
                    import :: dp
                    real(dp), intent(in) :: f(3,3)
                    real(dp), intent(in) :: df(3,3)
                    real(dp), intent(in) :: t
                    real(dp), intent(in) :: s0(:)
                    real(dp), intent(in) :: t0
                    real(dp), intent(out) :: s1(:)
                    real(dp), intent(out) :: sv_out(6)
                    real(dp), intent(out) :: c_out(6,6)
                    real(dp), intent(out) :: dc_out(6,6)
                end subroutine sv_c_dc_3d
            end interface
            procedure(sv_c_dc_3d) :: matfunc_3d
            real(dp), intent(in) :: s0(no_of_states)
            real(dp), intent(in) :: t0
            real(dp), intent(inout) :: s1(no_of_states)
            real(dp), intent(inout) :: f_int_k_dk_out(no_of_nodes*spatial_dimension,no_of_nodes*spatial_dimension*2+1)

            integer :: no_of_dofs
            real(dp) :: dn_dx(no_of_nodes,spatial_dimension)
            real(dp) :: du_dx(no_of_fields,spatial_dimension)
            real(dp) :: ddu_dx(no_of_fields,spatial_dimension)
            real(dp) :: detj(1)
            real(dp) :: fval(3,3)
            real(dp) :: dfval(3,3)
            real(dp) :: bval(6,spatial_dimension*no_of_nodes)
            real(dp) :: k_geo(no_of_nodes*spatial_dimension,no_of_nodes*spatial_dimension)
            real(dp) :: s_v(6)
            real(dp) :: c(6,6)
            real(dp) :: dc(6,6)

            no_of_dofs = no_of_nodes*spatial_dimension

            call f_material_gradients_structural_3d(n, dn_dxi, xn, d, dd, t, du_dx, ddu_dx, dn_dx, detj, &
            no_of_nodes, spatial_dimension, no_of_fields)

            call f_deformation_gradient_3d(du_dx, fval)
            call f_deformation_gradient_3d(ddu_dx, dfval)

            call matfunc_3d(fval,dfval,t,s0,t0,s1,s_v,c,dc)

            call f_b_l_3d(fval, dn_dx, bval, no_of_nodes, spatial_dimension)

            call f_f_int_and_jac_structural_3d(bval, s_v, c, dc, detj(1), dn_dx, f_int_k_dk_out, k_geo, no_of_nodes, &
                spatial_dimension, no_of_dofs)

        end subroutine igstrc3dnl_f_int_and_jac

        subroutine igstrc3dnl_m_int(n, dn_dxi, xn, d, dd, t, density, m_out, no_of_fields, &
        spatial_dimension, no_of_nodes)

            integer, intent(in) :: no_of_fields
            integer, intent(in) :: spatial_dimension
            integer, intent(in) :: no_of_nodes
            real(dp), intent(in) :: n(no_of_nodes)
            real(dp), intent(in) :: dn_dxi(no_of_nodes,spatial_dimension)
            real(dp), intent(in) :: xn(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: d(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: dd(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: t
            real(dp), intent(in) :: density
            real(dp), intent(inout) :: m_out(no_of_fields*no_of_nodes,no_of_fields*no_of_nodes)

            real(dp) :: x_mat(spatial_dimension, no_of_nodes)
            real(dp) :: j(spatial_dimension, spatial_dimension)
            real(dp) :: detj
            real(dp) :: m_small(no_of_nodes, no_of_nodes)
            integer :: k, m

            x_mat = reshape(xn, (/ spatial_dimension, no_of_nodes /))
            j = matmul(x_mat, dn_dxi)

            call f_determinant_3d(j, detj)

            do m=1,no_of_nodes
                do k=1,no_of_nodes
                    m_small(k,m) = n(k)*n(m)
                end do
            end do
            m_small = m_small * detJ * density

            call scatter_matrix(m_small, m_out, spatial_dimension, no_of_nodes, no_of_nodes)

        end subroutine igstrc3dnl_m_int

        subroutine f_material_gradients_structural_3d(n, dn_dxi, xn, d, dd, t, du_dx, ddu_dx, dn_dx, detj, &
        no_of_nodes, spatial_dimension, no_of_fields)
            integer, intent(in) :: no_of_nodes
            integer, intent(in) :: spatial_dimension
            integer, intent(in) :: no_of_fields
            real(dp), intent(in) :: n(no_of_nodes)
            real(dp), intent(in) :: dn_dxi(no_of_nodes, spatial_dimension)
            real(dp), intent(in) :: xn(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: d(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: dd(no_of_nodes*spatial_dimension)
            real(dp), intent(in) :: t
            real(dp), intent(inout) :: dn_dx(no_of_nodes, spatial_dimension)
            real(dp), intent(inout) :: du_dx(no_of_fields, spatial_dimension)
            real(dp), intent(inout) :: ddu_dx(no_of_fields, spatial_dimension)
            real(dp), intent(inout) :: detj(1)

            real(dp) :: jinv(spatial_dimension, spatial_dimension)
            real(dp) :: d_mat(no_of_fields, no_of_nodes)
            real(dp) :: dd_mat(no_of_fields, no_of_nodes)
            real(dp) :: x_mat(spatial_dimension, no_of_nodes)
            real(dp) :: j(spatial_dimension, spatial_dimension)
            real(dp) :: detjval

            x_mat = reshape(xn, (/ spatial_dimension, no_of_nodes /))
            j = matmul(x_mat, dn_dxi)
            call f_determinant_3d(j, detjval)
            detj(1) = detjval
            call f_inverse_matrix_3d(j, detjval, jinv)

            dn_dX = matmul(dn_dxi, jinv)

            d_mat = reshape(d, (/ no_of_fields, no_of_nodes /))
            dd_mat = reshape(dd, (/ no_of_fields, no_of_nodes /))

            du_dx = matmul(d_mat, dn_dx)
            ddu_dx = matmul(dd_mat, dn_dx)

        end subroutine

        subroutine f_f_int_and_jac_structural_3d(B_L, S_v, C, dC, detJval, dN_dX, f_int_K_dK_out, K_geo, no_of_nodes, &
        spatial_dimension, no_of_dofs)
            integer, intent(in) :: no_of_nodes
            integer, intent(in) :: no_of_dofs
            integer, intent(in) :: spatial_dimension
            real(dp), intent(in) :: B_L(6,no_of_dofs)
            real(dp), intent(in) :: dN_dX(no_of_nodes, spatial_dimension)
            real(dp), intent(in) :: S_v(6)
            real(dp), intent(in) :: detJval
            real(dp), intent(in) :: C(6,6)
            real(dp), intent(in) :: dC(6,6)
            real(dp), intent(inout) :: f_int_K_dK_out(no_of_dofs, 1+2*no_of_dofs)
            real(dp), intent(inout) :: K_geo(no_of_dofs, no_of_dofs)

            real(dp) :: S_mat(3,3)
            real(dp) :: K_mat(no_of_dofs, no_of_dofs)
            real(dp) :: K_mat_velocity(no_of_dofs, no_of_dofs)
            real(dp) :: K_geo_small(no_of_nodes, no_of_nodes)

            f_int_K_dK_out(:, 1) = matmul(transpose(B_L),  S_v) * detJval
            ! Compute Jacobian
            K_mat = matmul(matmul(transpose(B_L), C), B_L)
            K_mat_velocity = matmul(matmul(transpose(B_L), dC), B_L)
            S_mat(1, 1) = S_v(1)
            S_mat(2, 2) = S_v(2)
            S_mat(3, 3) = S_v(3)
            S_mat(2, 3) = S_v(4)
            S_mat(3, 2) = S_v(4)
            S_mat(1, 3) = S_v(5)
            S_mat(3, 1) = S_v(5)
            S_mat(1, 2) = S_v(6)
            S_mat(2, 1) = S_v(6)

            K_geo(:, :) = 0.0
            K_geo_small = matmul(matmul(dN_dX, S_mat), transpose(dN_dX))

            call scatter_matrix(K_geo_small, K_geo, spatial_dimension, no_of_nodes, no_of_nodes)

            f_int_K_dK_out(:, 2:no_of_dofs+2) = (K_geo + K_mat) * detJval
            f_int_K_dK_out(:, 2+no_of_dofs:2+2*no_of_dofs+1) = K_mat_velocity * detJval
        end subroutine

        subroutine f_b_l_3d(F, dN_dX, out, no_of_nodes, spatial_dimension)
            integer, intent(in) :: no_of_nodes
            integer, intent(in) :: spatial_dimension
            real(dp), intent(in) :: F(3,3)
            real(dp), intent(in) :: dN_dX(no_of_nodes, spatial_dimension)
            real(dp), intent(inout) :: out(6, spatial_dimension*no_of_nodes)

            integer :: a

            do a=0,no_of_nodes-1
                out(1, 3 * a + 1) = F(1, 1) * dN_dX(a+1, 1)
                out(1, 3 * a + 2) = F(2, 1) * dN_dX(a+1, 1)
                out(1, 3 * a + 3) = F(3, 1) * dN_dX(a+1, 1)
                out(2, 3 * a + 1) = F(1, 2) * dN_dX(a+1, 2)
                out(2, 3 * a + 2) = F(2, 2) * dN_dX(a+1, 2)
                out(2, 3 * a + 3) = F(3, 2) * dN_dX(a+1, 2)
                out(3, 3 * a + 1) = F(1, 3) * dN_dX(a+1, 3)
                out(3, 3 * a + 2) = F(2, 3) * dN_dX(a+1, 3)
                out(3, 3 * a + 3) = F(3, 3) * dN_dX(a+1, 3)
                out(4, 3 * a + 1) = F(1, 2) * dN_dX(a+1, 3) + F(1, 3) * dN_dX(a+1, 2)
                out(4, 3 * a + 2) = F(2, 2) * dN_dX(a+1, 3) + F(2, 3) * dN_dX(a+1, 2)
                out(4, 3 * a + 3) = F(3, 2) * dN_dX(a+1, 3) + F(3, 3) * dN_dX(a+1, 2)
                out(5, 3 * a + 1) = F(1, 3) * dN_dX(a+1, 1) + F(1, 1) * dN_dX(a+1, 3)
                out(5, 3 * a + 2) = F(2, 3) * dN_dX(a+1, 1) + F(2, 1) * dN_dX(a+1, 3)
                out(5, 3 * a + 3) = F(3, 3) * dN_dX(a+1, 1) + F(3, 1) * dN_dX(a+1, 3)
                out(6, 3 * a + 1) = F(1, 1) * dN_dX(a+1, 2) + F(1, 2) * dN_dX(a+1, 1)
                out(6, 3 * a + 2) = F(2, 1) * dN_dX(a+1, 2) + F(2, 2) * dN_dX(a+1, 1)
                out(6, 3 * a + 3) = F(3, 1) * dN_dX(a+1, 2) + F(3, 2) * dN_dX(a+1, 1)
            end do

        end subroutine

        subroutine f_determinant_3d(mat, det)
            real(dp), intent(in) :: mat(3, 3)
            real(dp), intent(out) :: det

            real(dp) :: a11, a12, a13, a21, a22, a23, a31, a32, a33

            a11 = mat(1,1)
            a12 = mat(1,2)
            a13 = mat(1,3)
            a21 = mat(2,1)
            a22 = mat(2,2)
            a23 = mat(2,3)
            a31 = mat(3,1)
            a32 = mat(3,2)
            a33 = mat(3,3)
            det = a11*a22*a33 - a11*a23*a32 - a12*a21*a33 + a12*a23*a31 + a13*a21*a32 - a13*a22*a31
        end subroutine

        subroutine f_inverse_matrix_3d(mat, det, matout)
            real(dp), intent(in) :: mat(3, 3)
            real(dp), intent(in) :: det
            real(dp), intent(inout) :: matout(3, 3)

            real(dp) :: a11, a12, a13, a21, a22, a23, a31, a32, a33
            a11 = mat(1,1)
            a12 = mat(1,2)
            a13 = mat(1,3)
            a21 = mat(2,1)
            a22 = mat(2,2)
            a23 = mat(2,3)
            a31 = mat(3,1)
            a32 = mat(3,2)
            a33 = mat(3,3)
            matout = reshape((/ a22*a33 - a23*a32, -a21*a33 + a23*a31, &
                               a21*a32 - a22*a31, -a12*a33 + a13*a32, &
                               a11*a33 - a13*a31, -a11*a32 + a12*a31, &
                               a12*a23 - a13*a22, -a11*a23 + a13*a21, &
                               a11*a22 - a12*a21 /), (/3,3/)) / det
        end subroutine

        subroutine f_deformation_gradient_3d(du_dX, Fout)
            real(dp), intent(in) :: du_dX(3,3)
            real(dp), intent(inout) :: Fout(3,3)

            Fout = du_dX
            Fout(1, 1) = Fout(1,1) + 1.0_dp
            Fout(2, 2) = Fout(2,2) + 1.0_dp
            Fout(3, 3) = Fout(3,3) + 1.0_dp

        end subroutine

end module integrand_structural3d_nonlinear_fun


      SUBROUTINE LSHARM(RHO,TH,PH,F,NDIM,PNM,AJ,C,S)
COMPUTES LINE OF SIGHT FORCE FROM SPHERICAL HARMONICS.
      DOUBLE PRECISION PNM(NDIM,NDIM),PPNM,F(3),STH,CTH,CO,R1
     1,CPH,SPH,CT2,C1,C2,C3,C4,C5,S2,S1,EN,RRN,EM,S3,S4,S5,S3M,S4M,S5M,
     2PM,SMP,CMP,RR,AJ(NDIM),C(NDIM,NDIM),S(NDIM,NDIM),C6,C7,C8
      DOUBLE PRECISION COM(1)
      DOUBLE PRECISION TH,PH,RC,RHO,U
      COMMON /PRAM/ NMAS, NPTS, NDISK
      COMMON RC,U,COM
C     DOUBLE PRECISION POUT(16)
      DATA CO /.1745329251994430D-1/
C     DEFINE AJ(I)=COM(I+IA)
C     DEFINE C(I,K)=COM(K*NPTS+I+IA)
C     DEFINE S(I,K)=COM(NPTS*NPTS+K*NPTS+I+IA)
      IA = 4*NMAS
      RR=RC/RHO
      R1=1.D0/(RHO*RHO)
      CTH=DCOS(TH*CO)
      STH=DSIN(TH*CO)
      CPH=DCOS(PH*CO)
      SPH=DSIN(PH*CO)
      CT2=CTH*CTH
      C1=STH*CTH*CPH*U/RHO**2
      C2=CTH*CPH*U/RHO**2
      C3=-C1
      C4=SPH*U/(RHO*RHO*CTH)
      C5=-C2
      C6=STH*CTH*SPH*(U/RHO**2)
      C7=CTH*SPH*(U/RHO**2)
      C8=(-CPH/CTH)*(U/RHO**2)
      S2=0.D0
      S1=0.D0
      PNM(1,1)=1.D0
      PNM(2,1)=STH
      NP=NPTS+1
      DO 1 N=3,NP
      EN=DBLE(FLOAT(N-1))
      PNM(N,1)=STH*(2.D0*EN-1.D0)*PNM(N-1,1)/EN-PNM(N-2,1)*(EN-1.D0)/EN
      RRN=RR**(N-1)
      PPNM=(EN*PNM(N-1,1)-EN*STH*PNM(N,1))/CT2
      S1=S1+AJ(N-1)*PPNM*RRN
    1 S2=S2+(EN+1.D0)*AJ(N-1)*PNM(N,1)*RRN
      DO 2 M=2,NP
      EM=DBLE(FLOAT(M-1))
      L=M+2
      PNM(M,M)=(2.D0*EM-1.D0)*CTH*PNM(M-1,M-1)
      IF(M.EQ.NP)GO TO 2
      PNM(M+1,M)=(2.D0*EM+1.D0)*STH*PNM(M,M)
      IF(L.GT.NP)GO TO 2
      DO 3 N=L,NP
      EN=DBLE(FLOAT(N-1))
      PNM(N,M)=((2.D0*EN-1.D0)*STH*PNM(N-1,M)-(EN-1.D0+EM)*PNM(N-2,M))/
     1(EN-EM)
    3 CONTINUE
    2 CONTINUE
      S3=0.D0
      S4=0.D0
      S5=0.D0
      DO 4 N=2,NPTS
      S3M=0.D0
      S4M=0.D0
      S5M=0.D0
      NN=N+1
      RRN=RR**N
      EN=DBLE(FLOAT(N))
      DO 5 M=1,N
      MM=M+1
      EM=DBLE(FLOAT(M))
      PM=DMOD(EM*PH,360.D0)
      SMP=DSIN(PM*CO)
      CMP=DCOS(PM*CO)
      PPNM=(-EN*STH*PNM(NN,MM)+PNM(NN-1,MM)*(EN+EM))/CT2
      S3M=S3M+PPNM*(C(N,M)*CMP+S(N,M)*SMP)*RRN
      S4M=S4M+EM*PNM(NN,MM)*(C(N,M)*SMP-S(N,M)*CMP)*RRN
      S5M=S5M+(EN+1.D0)*PNM(NN,MM)*(C(N,M)*CMP+SMP*S(N,M))*RRN
    5 CONTINUE
      S3=S3+S3M
      S4=S4+S4M
      S5=S5+S5M
    4 CONTINUE
C     WRITE(6,6) S1,S2,S3,S4,S5
C     WRITE(6,7) C1,C2,C3,C4,C5,C6,C7,C8
C     WRITE(6,8) SPH,CPH,CTH,STH,U,RHO,TH,PH
C   6 FORMAT(1H ,'S=',5D16.8)
C   7 FORMAT(1H ,'C=',8D15.8)
C   8 FORMAT(1H ,'SPH,CPH,CTH,STH,U,RHO,THETA,PHI=',8D11.5)
      F(1)=C1*S1+C2*S2+C3*S3+C4*S4+C5*S5
      F(2)=C6*(S1-S3)+C7*(S2-S5)+C8*S4
      F(3)=U*(CTH*CTH*(-S1+S3)+STH*(S2-S5))/(RHO*RHO)
C     WRITE(6,9) F(1),F(2),F(3)
C   9 FORMAT(1H ,'F(1,2,3)=',3D16.8)
C     DO 11 IOUT=1,NPTS
C     DO 10 IOUT2=1,NPTS
C     POUT(IOUT2)=PNM(IOUT,IOUT2)
C  10 CONTINUE
CC    WRITE(6,12) IOUT,(POUT(MM),MM=1,NPTS)
C  11 CONTINUE
C 12  FORMAT(1H ,' PNM(',I3,',1)=',4D16.8)
      RETURN
      END


!!The model here is V=lambda/4 (h^2 - v^2)^2 (default model in LatticeEasy and DEFROST, see hep-ph 9705347)

module model
  use define_fields
  implicit none

#include "configure.h"
!!*******************define the couplings etc. for your model *************
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!!the predefined constants that you can use: GeV, MPl (the reduced Planck Mass), PlanckMass (the Planck Mass), Mplsq (square of the reduced Planck Mass)
  real(dl):: lambda =1.d-14
  real(dl),parameter:: viv = 1.e-3_dl * PlanckMass
  real(dl),parameter:: v2 = viv**2

!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!!***************define macros here;************************
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
#define PHI f(1)
!! Note: PHI was used to denote the Higgs field h
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!!***************** define initial conditions ******************************
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!!HLattice always treat the first field as the inflaton \phi.
!!To be self consistent you may want to get the background \phi and \dot\phi by solving the background equations from inflation. HLattice will do that for you.
!!Just define where you want to start the background evolution. Note this is NOT where you start the lattice simulation, which is defined in a subroutine "start_box_simulation" in this file.
 !!initial field values
  real(dl),dimension(ns)::init_fields=(/ &
       3.5_dl *PlanckMass &
       /)

!!Initial field momenta
 !! if set to be greater than or equal to Mplsq (square of reduced Planck Mass), the initial field momenta will be determined by slow-roll inflationary attractor
  !! Note again these are NOT the initial field momenta where you start the lattice simulation, the are the initial values that HLattice take to evolve the inflaton.
  real(dl),dimension(ns):: init_momenta = Mplsq

!!put initial random Gaussian perturbations in the fields when you starts lattice simulation;
!!the amplitude of fluctuations are defined in subroutine model_Power
  logical,dimension(ns)::do_init = (/ .true. /)

!!Important note: init_fields and init_momenta will be changed after the initialization. After the subroutine init() is called, they will equal to the the fields and field momenta AT THE BEGINNING OF LATTICE SIMULATION. In addition, the Hubble parameter at the beginning of lattice simulation will be saved to a global variable "init_Hubble".
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

contains

!! the potential of the scalar fields
  function potential(f)
    real(dl) f(ns)
    real(dl) potential
    potential = (lambda/4.d0) * ( PHI**2 - v2)**2
  end function potential

!! the derivative of pential w.r.t. to the fields
!! return an array (dV/df1, dV/df2, ...)
  function dVdf(f)
    real(dl) f(ns)
    real(dl),dimension(ns):: dVdf
    dVdf = (/ &
         lambda*PHI*( PHI**2 - v2) &
         /)
  end function dVdf

!!d^2 V / d f_{fld}^2,, here fld can be 1,2,..., ns
  function mass_sq(f,fld)
    real(dl) f(ns)
    real(dl):: mass_sq
    integer fld
    select case(fld)
    case(1)
       mass_sq = lambda * (3.d0* PHI**2 -v2)
    case default
       stop "wrong argument fld in mass_sq"
    end select
  end function mass_sq

!!define the condition to start box simulation
!!here array f -> the background field values (\phi_1, \phi_2, ...)
!! array p-> the background field derivative, (d\phi_1/dt, d\phi_1/dt, ... )
  function start_box_simulation(f,p)
    logical start_box_simulation
    real(dl),dimension(ns)::f,p
!!LatticeEasy default, i.e. d \phi/dt + H phi = 0 (or equivalently d(a\phi)/dt =0
    start_box_simulation = (p(1) + sqrt((sum(p**2)/2.+potential(f))/3.)/Mpl*f(1) .lt. 0.)
!! If you want to start the lattice simualtion immediately
    !!start_box_simulation = .true.
!! If you want to use DEFROST starting point, the end of inflation, i.e. \ddot a =0
    !!start_box_simulation = (potential(f) .le. sum(p**2) )
  end function start_box_simulation

!!define the time step; you will get significant error if you use physical time and 2nd order integrator (the integrator is chosen in parameters.f90)
!!I strongly recommend you use conformal time for this model, for which a second order integrator will do ok (if metric perturbs are off)
  function model_dt_per_step()
    real(dl) model_dt_per_step
#if USE_CONFORMAL_TIME
    !!when metric backreaction is off, just use conformal time; Easy and very stable;
    model_dt_per_step = metric%dx/32._dl
#else
    !!when metric backreaction is on, a bit tricky for this model cz HLattice use synchronous gauge (and physical time t).
    !!Better not continuously change dt; Use step functions.
    model_dt_per_step = metric%dx/64._dl*ceiling(metric%a/5._dl)
#endif
  end function model_dt_per_step

!!return an array (|f_k|^2, |f'_k|^2) for fields initialization.
!!remember always set them to be zero for k=0.
  function model_Power(fld,k)
    real(dl),dimension(2):: model_Power
    real(dl) k,omega
    integer(IB) fld
    omega=k**2+mass_sq(init_fields,fld)
    if(n*k*metric%dx .lt. const_pi .or. omega.lt.0.) then
       model_Power =0._dl
       return
    endif
    omega=sqrt(omega)
    if(omega.gt.Init_Hubble)then
       !!put in 1/2 particle per phase space volume
       !!note this is just an approximation. If you care about time scale of one or two oscillations. The quantum->classical transition should be calculated analytically.
       model_Power(1) = 0.5_dl/omega
       return
    endif
    model_Power = 0._dl
    return
  end function model_Power

!!model outputs
  subroutine model_output(i)
    !! i = 1; called before initialization
    !! i = 2; called after initialization
    !! i = 3; called in output_to_screen()
    !! i = 4; called at the end of simulation
    integer(IB) i
    type(file_pointer) fp
    select case(i)
    case(1)
!!A check for lambda phi^4 model, for which conformal time is a better choice.
!!#if ! USE_CONFORMAL_TIME && ! METRIC_PERTURB
!!       stop "you may want to turn on USE_CONFORMAL_TIME in configure.h"
!!#endif
    case(2)
       fp = open_file("data/"//trim(run_name)//"_model.info", "w")
       write(fp%unit,*) "V = lambda/4 (h^2 - v^2)"
       write(fp%unit,*) "reduced Planck Mass M_p = ", Mpl
       write(fp%unit,*) "lambda = ",lambda
       write(fp%unit,*) "n = ",n
       write(fp%unit,*) "dx=",metric%dx
       write(fp%unit,*) "Initial fields values:", Init_fields
       write(fp%unit,*) "Initial momenta:", Init_momenta
       write(fp%unit,*) "effective k_min / Hubble = ", k_unit/metric%physdx/Init_Hubble
       write(fp%unit,*) "effective k_max / Hubble = ", fft_numk*k_unit/metric%physdx/Init_Hubble
       call close_file(fp)
       write(*,*) "effective k_min / Hubble = ", k_unit/metric%physdx/Init_Hubble
       write(*,*) "effective k_max / Hubble = ", fft_numk*k_unit/metric%physdx/Init_Hubble
    case(3)
    case(4)
    case default
       write(*,*) "Unknow option in model_output"
       stop
    end select
  end subroutine model_output

end module model


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of dk in forward (tangent) mode:
!   variations   of useful results: dk
!   with respect to varying inputs: *temp *head *propunit *tsal
!                *pres
!   Plus diff mem management of: temp:in head:in propunit:in tsal:in
!                pres:in
!>    @brief average effective diffusivities on cell faces in z direction
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] spec species
!>    @param[in] ismpl local sample index
!>    @return effective diffusivities (J/mK)
DOUBLE PRECISION FUNCTION g_DK(i, j, k, spec, ismpl, dk)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  IMPLICIT NONE
  INTEGER :: i, j, k
  INTEGER :: ismpl
  INTEGER :: spec
  DOUBLE PRECISION :: f1, f2, prod, summ, betx, bety, betz, bet
  DOUBLE PRECISION :: g_f1, g_f2, g_prod, g_summ, g_betx, &
& g_bety, g_betz, g_bet
  EXTERNAL POR, DISP, VZ, VY, VX
  EXTERNAL g_POR, g_DISP, g_VZ, g_VY, g_VX
  DOUBLE PRECISION :: POR, DISP, VZ, VY, &
& VX
  DOUBLE PRECISION :: g_POR, g_DISP, g_VZ, g_VY, g_VX
  INTRINSIC SQRT
  DOUBLE PRECISION :: result1
  DOUBLE PRECISION :: g_result1
  DOUBLE PRECISION :: result2
  DOUBLE PRECISION :: g_result2
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: dk
  dk = 0.d0
  betx = 0.d0
  bety = 0.d0
  betz = 0.d0
  IF (j0 .GT. 1 .AND. j .LT. j0) THEN
    g_bety = g_VY(i, j, k, ismpl, bety)
    g_bety = 2*bety*g_bety
    bety = bety*bety
  ELSE
    g_bety = 0.D0
  END IF
  IF (i0 .GT. 1 .AND. i .LT. i0) THEN
    g_betx = g_VX(i, j, k, ismpl, betx)
    g_betx = 2*betx*g_betx
    betx = betx*betx
  ELSE
    g_betx = 0.D0
  END IF
  IF (k0 .GT. 1 .AND. k .LT. k0) THEN
    g_betz = g_VZ(i, j, k, ismpl, betz)
    g_betz = 2*betz*g_betz
    betz = betz*betz
    temp0 = SQRT(betx + bety + betz)
    IF (betx + bety + betz .EQ. 0.0) THEN
      g_bet = 0.D0
    ELSE
      g_bet = (g_betx+g_bety+g_betz)/(2.0*temp0)
    END IF
    bet = temp0
    g_result1 = g_POR(i, j, k, ismpl, result1)
    g_result2 = g_DISP(i, j, k, ismpl, result2)
    g_f1 = diff_c(spec)*g_result1 + bet*g_result2 + result2*&
&     g_bet
    f1 = result1*diff_c(spec) + result2*bet
    g_result1 = g_POR(i, j, k + 1, ismpl, result1)
    g_result2 = g_DISP(i, j, k + 1, ismpl, result2)
    g_f2 = diff_c(spec)*g_result1 + bet*g_result2 + result2*&
&     g_bet
    f2 = result1*diff_c(spec) + result2*bet
    g_prod = f2*g_f1 + f1*g_f2
    prod = f1*f2
    g_summ = delz(k+1)*g_f1 + delz(k)*g_f2
    summ = f1*delz(k+1) + f2*delz(k)
    IF (summ .GT. 0.d0) THEN
      g_dk = 2.d0*(g_prod-prod*g_summ/summ)/summ
      dk = 2.d0*prod/summ
    ELSE
      g_dk = 0.D0
    END IF
  ELSE
    g_dk = 0.D0
  END IF
  RETURN
END FUNCTION g_DK


! calculate bulk's energy band using wannier TB method
  subroutine fermisurface

     use mpi
     use para

     implicit none

     integer :: ik, i, j
	  integer :: knv3
     integer :: nkx
     integer :: nky

     integer :: ierr
     real(dp) :: kz
     real(Dp) :: k(3)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     real(dp) :: kxmin, kxmax, kymin, kymax, omega
     real(dp) :: kxmin_shape, kxmax_shape, kymin_shape, kymax_shape

     real(dp), allocatable :: kxy(:,:)
     real(dp), allocatable :: kxy_shape(:,:)

     real(dp), allocatable :: dos(:)
     real(dp), allocatable :: dos_mpi(:)

     complex(dp), allocatable :: ones(:,:)

     nkx= Nk
     nky= Nk
     allocate( kxy(2, nkx*nky))
     allocate( kxy_shape(2, nkx*nky))
     kxy=0d0
     kxy_shape=0d0

     kymin=-0.20d0/1d0
     kymax= 0.20d0/1d0
     kxmin=-0.20d0/1d0
     kxmax= 0.20d0/1d0
     kz= 0d0
     ik =0
     do i= 1, nkx
     do j= 1, nky
        ik =ik +1
        kxy(1, ik)=kxmin+ (i-1)*(kxmax-kxmin)/dble(nkx-1)
        kxy(2, ik)=kymin+ (j-1)*(kymax-kymin)/dble(nky-1)
     enddo
     enddo

     knv3= nkx*nky
     allocate( dos    (knv3))
     allocate( dos_mpi(knv3))
     dos    = 0d0
     dos_mpi= 0d0

     allocate(ones(Num_wann, Num_wann))
     ones= 0d0
     do i=1, Num_wann
        ones(i, i)= 1d0
     enddo
     do ik= 1+cpuid, knv3, num_cpu
	     if (cpuid==0) print * , ik

        k(1) = kxy(1, ik)
        k(2) = kxy(2, ik)
        k(3) = kz

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk(k, Hamk_bulk)

        Hamk_bulk= (E_arc -zi* eta_arc)* ones - Hamk_bulk
        call inv(Num_wann, Hamk_bulk)
        do i=1, Num_wann
           dos(ik)= dos(ik)+ aimag(Hamk_bulk(i, i))/pi
        enddo

     enddo

     call mpi_allreduce(dos,dos_mpi,size(dos),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)

     if (cpuid==0)then
        open(unit=14, file='fs.dat')

        do ik=1, knv3
           write(14, '(3f16.8)')kxy(:, ik), log(dos_mpi(ik))
           if (mod(ik, nky)==0) write(14, *)' '
        enddo
        close(14)
     endif

     !> minimum and maximum value of energy bands

     !> write script for gnuplot
     if (cpuid==0) then
        open(unit=101, file='fs.gnu')
        write(101, '(a)')'#set terminal  postscript enhanced color'
        write(101, '(a)')"#set output 'fs.eps'"
        write(101, '(3a)')'set terminal  png truecolor enhanced', &
           ' transparent font Monaco giant size 1920, 1680'
        write(101, '(a)')"set output 'fs.png'"
        write(101,'(2a)') '#set palette defined ( -10 "green", ', &
           '0 "yellow", 10 "red" )'
        write(101, '(a)')'set palette rgbformulae 33,13,10'
        write(101, '(a)')'unset ztics'
        write(101, '(a)')'unset key'
        write(101, '(a)')'set pm3d'
        write(101, '(a)')'set view equal xyz'
        write(101, '(a)')'set view map'
        write(101, '(a)')'#set xtics font ",24"'
        write(101, '(a)')'#set ytics font ",24"'
        write(101, '(a)')'unset xtics'
        write(101, '(a)')'unset ytics'
        write(101, '(a)')'unset colorbox'
        write(101, '(a, f8.5, a, f8.5, a)')'set xrange [', kxmin, ':', kxmax, ']'
        write(101, '(a, f8.5, a, f8.5, a)')'set yrange [', kymin, ':', kymax, ']'
        write(101, '(a)')'set pm3d interpolate 2,2'
        write(101, '(2a)')"splot 'fs.dat' u 1:2:3 w pm3d"

     endif

   return
   end subroutine fermisurface


!-----------------------------------------------------------------------
! Fortran2003 with CUDA C GPU Tutorial: Reduction
! written by Viktor K. Decyk, UCLA
      program fcexample3
      use iso_c_binding
      use redux
      use gpulib2_c
      implicit none
! nx = size of array
! mx = data block size, nbx = number of blocks in array
      integer, parameter :: nx = 3000, mx = 128, nbx = (nx - 1)/mx + 1
      integer, parameter :: nbxs = (nbx - 1)/mx + 1
! nblock = block size on GPU
      integer :: nblock = 64
      integer :: j, k, irc
      real :: s, eps, epsmax
! timing data
      double precision :: dtime
      integer, dimension(4) :: itime
! data for Fortran Host
      real, dimension(1), target :: t
      real, dimension(nx), target :: a1
      real, dimension(nbx), target :: d1
! data for GPU
      type (c_ptr) :: g_a1 = c_null_ptr, g_d1 = c_null_ptr
      type (c_ptr) :: g_s = c_null_ptr
!
! set up GPU
      irc = 0
      call setgbsize(nblock)
      call init_cu(0,irc)
      if (irc /= 0) then
         write (*,*) 'CUDA initialization error!'
         stop
      endif
!
! allocate 1d data on GPU
      call gpu_fallocate(g_a1,nx,irc)
      call gpu_fallocate(g_d1,nbx,irc)
      call gpu_fallocate(g_s,2*nbxs,irc)
!
      if (irc /= 0) then
         write (*,*) 'GPU allocate error!'
         stop
      endif
!
! initialize 1d data on Host
      do j = 1, nx
         a1(j) = real(j)
      enddo
      d1 = 0.0
      s = 0.0; t = 0.0
! copy data to GPU
      call gpu_fcopyin(c_loc(d1),g_d1,nbx)
      call gpu_fcopyin(c_loc(a1),g_a1,nx)
!
! measure overhead time by running empty kernel
      call dtimer(dtime,itime,-1)
      call emptykernel()
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran empty kernel time=', real(dtime)
!
! segmented 1d sum on Host with block size mx
      call dtimer(dtime,itime,-1)
!     call sum0(a1,s)
!     call sum1(a1,s,mx)
      call sum2(a1,d1,mx)
      call sum1(d1,s,mx)
      call dtimer(dtime,itime,1)
      write (*,*) 'Fortran 1d sum time=', real(dtime)
!
! 1d sum on GPU with block size mx
      call dtimer(dtime,itime,-1)
!     call gpu_sum1(g_a1,g_s,mx,nx)
!     call gpu_sum2(g_a1,g_d1,mx,nx)
!     call gpu_sum1(g_d1,g_s,mx,nbx)
      call gpu_sum3(g_a1,g_d1,g_s,mx,nx)
      call dtimer(dtime,itime,1)
      write (*,*) 'GPU 1d sum time=', real(dtime)
!
! copy data from GPU
      call gpu_fcopyout(c_loc(a1),g_d1,nbx)
      call gpu_fcopyout(c_loc(t),g_s,1)
!
! Check for correctness: compare d1 and g_d1
      epsmax = 0.0
      do j = 1, nbx
         eps = abs(d1(j)-a1(j))
         if (eps > epsmax) epsmax = eps
      enddo
      write (*,*) '1d sum maximum difference = ', epsmax
      write (*,*) 's,t = ', s, t
!
! deallocate memory on GPU
      call gpu_deallocate(g_a1,irc)
      call gpu_deallocate(g_d1,irc)
      call gpu_deallocate(g_s,irc)
      if (irc /= 0) then
         write (*,*) 'GPU deallocate error!'
         stop
      endif
! close down GPU
      call end_cu()
!
      end program


!##############################################################################
!# ****************************************************************************
!# <name> adaptivecubature </name>
!# ****************************************************************************
!#
!# <purpose>
!#
!# This module provides routines for adaptive cubature. The very basic
!# implementation contains routines to support the summed cubature by
!# providing functions that automatically adapt a standard cubature
!# rule until the cubature error drops below a given tolerance.
!#
!# For some reference about adaptive cubature see e.g. here:
!#
!#  [Werner Vogt: Adaptive Verfahren zur numerischen Quadratur und Kubatur,
!#   Preprint, TU Ilmenau, 2006]
!#
!# The following subroutines can be found here:
!#
!# 1.) adcub_determineSummedCubature
!#     -> Analyses a function and determines an id for an adaptive cubature
!#        formula
!#
!# 2.) adcub_integrateFunction
!#     -> Integrate a function on a set of elements with a given cubature rule
!#
!# </purpose>
!##############################################################################

module adaptivecubature

!$ use omp_lib
  use basicgeometry
  use collection
  use cubature
  use element
  use elementpreprocessing
  use fsystem
  use genoutput
  use perfconfig
  use triangulation

  implicit none

  private

  public :: adcub_determineSummedCubature
  public :: adcub_integrateFunction

contains

  !****************************************************************************

!<subroutine>

  subroutine adcub_determineSummedCubature(ccubType,depsRel,depsAbs,rtriangulation,&
      Ielements,ffunctionRefSimple,rcollection,rperfconfig)

!<description>
  ! Determines an adaptive cubature formula which is accurate enough
  ! to integrate the function ffunctionReference on the elements Ielements
  ! of the mesh rtriangulation.
  !
  ! The cubature rule is determined in such a way, that the relative and
  ! absolute error is lower than depsRel / depsAbs.
!</description>

!<inputoutput>
  ! Cubature type identifier.
  ! On entry: Must be initialised with a basic cubature formula CCUB_xxxx
  ! that defines the underlying cubature rule (e.g. CUB_G2_2D for 2x2-gauss in 2D).
  ! On exit: Is replaced by a new cubature rule identifier that defines the
  ! adaptive cubature formula.
  integer(I32), intent(inout) :: ccubType
!</inputoutput>

!<input>
  ! Bound for the relative error in the integration.
  real(DP), intent(in) :: depsRel

  ! Bound for the absolute error in the integration.
  real(DP), intent(in) :: depsAbs

  ! Underlying mesh where ffunctionReference should be evaluated.
  type(t_triangulation), intent(in) :: rtriangulation

  ! List of elements where the integration should be carried out.
  ! All elements must be of the same type!!! (i.e. all must be triangles,
  ! quads, hexas or similar); it is not allowed to mix e.g. triangles and
  ! quads in this list.
  integer, dimension(:), intent(in) :: Ielements

  ! Reference function which should be tested for integration.
  include '../Postprocessing/intf_functionScSimple.inc'

  ! OPTIONAL: Collection structure to be passed to ffunctionReference.
  type(t_collection), intent(inout), optional :: rcollection

  ! OPTIONAL: local performance configuration. If not given, the
  ! global performance configuration is used.
  type(t_perfconfig), intent(in), optional :: rperfconfig
!</input>

!</subroutine>

    real(DP) :: dvalue, dvalue2, derror, dvalueinit
    integer(I32) :: ccurrentcubtype
    integer :: icubref

    ! The inital cubature rule is without refinement.
    icubref = 0
    ccurrentcubtype = cub_getStdCubType(ccubType)

    ! Determine the initial value of the integral.
    call adcub_integrateFunction(dvalueinit,ccurrentcubtype,rtriangulation,&
        Ielements,ffunctionRefSimple,rcollection,rperfconfig)
    dvalue = dvalueinit

    ! Now refine the integration until the error is small enough.
    do
      icubref = icubref + 1
      ccurrentcubtype = cub_getSummedCubType(ccubType,icubref)
      dvalue2 = dvalue
      call adcub_integrateFunction(dvalue,ccurrentcubtype,rtriangulation,&
          Ielements,ffunctionRefSimple,rcollection,rperfconfig)

      derror = (dvalue-dvalue2) / (2**icubref - 1)

      ! Stop if the error is small enough. Ok, this formula is actually
      ! slightly wrong, since we stop, if the error on the 'fine' mesh
      ! is small enough while we return the cubature formula of the coarse
      ! mesh, but anyway, this is only a rough approximation.
      ! If we do not do this, there would be always at least one refinement
      ! what prevents the unrefined cubature rule to be used.
      !
      ! And: At most 5 refinements!
      if ((derror .lt. depsAbs) .and. &
          (derror*dvalueinit .lt. depsRel) .or. &
          (icubref .gt. 5)) then
        ccubType = cub_getSummedCubType(ccubType,icubref-1)
        exit
      end if

    end do

  end subroutine

  !****************************************************************************

!<subroutine>

  subroutine adcub_integrateFunction(dvalue,ccubType,rtriangulation,Ielements,&
      ffunctionRefSimple,rcollection,rperfconfig)

!<description>
  ! Integrates a scalar function ffunctionReference on a set of elements
  ! Ielements of a given mesh rtriangulation with a cubature formula ccubType.
!</description>

!<input>
  ! Cubature type identifier of the cubature formula to use for integration.
  integer(I32), intent(in) :: ccubType

  ! Underlying mesh where ffunctionReference should be evaluated.
  type(t_triangulation), intent(in) :: rtriangulation

  ! List of elements where the integration should be carried out.
  ! All elements must be of the same type!!! (i.e. all must be triangles,
  ! quads, hexas or similar); it is not allowed to mix e.g. triangles and
  ! quads in this list.
  integer, dimension(:), intent(in), target :: Ielements

  ! Reference function which should be tested for integration.
  include '../Postprocessing/intf_functionScSimple.inc'

  ! OPTIONAL: Collection structure to be passed to ffunctionReference.
  type(t_collection), intent(inout), optional :: rcollection

  ! OPTIONAL: local performance configuration. If not given, the
  ! global performance configuration is used.
  type(t_perfconfig), intent(in), optional :: rperfconfig
!</input>

!<output>
  ! The value of the integral.
  real(DP), intent(out) :: dvalue
!</output>

!</subroutine>

    integer :: IELset, IELmax, iel, NEL, idim, icubp
    integer :: ncubp,nelementsPerBlock,nmaxelements
    integer(I32) :: cevaluationtag
    real(DP), dimension(:,:), allocatable :: DpointsRef
    real(DP), dimension(:), allocatable :: DomegaRef
    type(t_evalElementSet) :: revalElementSet
    integer(I32) :: ctrafoType
    real(DP), dimension(:,:), allocatable :: Dcoefficients
    real(DP), dimension(:,:), pointer :: p_Ddetj
    real(DP) :: om

    ! Get the cubature points on the reference element
    ncubp = cub_igetNumPts(ccubType)
    idim = cub_igetCoordDim(ccubType)
    allocate (DpointsRef(idim,ncubp))
    allocate (DomegaRef(ncubp))
    call cub_getCubature(ccubType, DpointsRef, DomegaRef)

    ! Number of elements
    NEL = size(Ielements)

    ! Determine the number of elements in each set in such a way,
    ! that the element blocks are not too large and that the
    ! number of simultaneous treated cubature points is not too large.
    ! We allow the treatment of at most 16x16x16 cubature points per element
    ! on a set of 1000 elements, resulting in at most 16x16x16x1000=4.096.000
    ! cubature points. So reduce the number of simultaneouly treated
    ! elements if necessary -- but treat at least one element.
    nmaxelements = max(1,min(ncubp*1000,16*16*16*1000)/ncubp)
    nelementsPerBlock = min(nmaxelements,NEL)

    ! Allocate memory for the coefficients
    allocate(Dcoefficients(ncubp,nelementsPerBlock))

    ! Initialisation of the element set.
    call elprep_init(revalElementSet)
    cevaluationtag = EL_EVLTAG_REALPOINTS + EL_EVLTAG_JAC + EL_EVLTAG_DETJ + &
        EL_EVLTAG_REFPOINTS + EL_EVLTAG_COORDS

    ! Get the transformation type from the basic P1/Q1 element in the
    ! current dimension
    ! Get the shape of the cubature id
    select case(cub_igetShape(ccubType))
    case(BGEOM_SHAPE_LINE)
      ! 1D line formula -> reference coordinates
      ctrafoType = elem_igetTrafoType(EL_P1_1D)
    case(BGEOM_SHAPE_TRIA)
      ! 2D triangle formula -> barycentric coordinates
      ctrafoType = elem_igetTrafoType(EL_P1_2D)
    case(BGEOM_SHAPE_QUAD)
      ! 2D quadrilateral formula -> reference coordinates
      ctrafoType = elem_igetTrafoType(EL_Q1_2D)
    case default
      ! unknown formula
      call output_line ('Unsupported element.', &
                        OU_CLASS_ERROR,OU_MODE_STD,'adcub_integrateFunction')
      call sys_halt()
    end select

    dvalue = 0.0_DP

    ! Loop throgh the elements in sets.
    do IELset = 1,NEL,nmaxelements

      ! Maximum element of the set
      IELmax = min(NEL, IELset-1+nmaxelements)

      ! Prepare the element set to calculate information of the transformation.
      call elprep_prepareSetForEvaluation (revalElementSet,&
          cevaluationTag, rtriangulation, Ielements(IELset:IELmax), &
          ctrafoType, DpointsRef(:,:), rperfconfig=rperfconfig)
      p_Ddetj => revalElementSet%p_Ddetj

      ! In the next loop, we do not have to evaluate the coordinates
      ! on the reference elements anymore.
      cevaluationTag = iand(cevaluationTag,not(EL_EVLTAG_REFPOINTS))

      ! Calculate the values in the cubature points.
      call ffunctionRefSimple (IELmax-IELset+1,ncubp,Ielements(IELset:IELmax),&
          revalElementSet%p_DpointsReal,Dcoefficients(:,1:IELmax-IELset+1),rcollection,&
          revalElementSet%p_DpointsRef,revalElementSet%p_Djac,revalElementSet%p_Ddetj)

      ! Sum up to the contribution of the integral.
      do IEL = 1, IELmax-IELset+1

        ! Loop over all cubature points on the current element
        do icubp = 1, ncubp

          ! calculate the current weighting factor in the cubature formula
          ! in that cubature point.
          !
          ! Take the absolut value of the determinant of the mapping.
          ! In 2D, the determinant is always positive, whereas in 3D,
          ! the determinant might be negative -- that is normal!

          OM = DomegaRef(icubp)*abs(p_Ddetj(icubp,IEL))

          dvalue = dvalue + OM * Dcoefficients(icubp,IEL)

        end do ! ICUBP

      end do ! iel

    end do

    ! Release memory, finish
    call elprep_releaseElementSet(revalElementSet)
    deallocate(DomegaRef)
    deallocate(DpointsRef)

  end subroutine

end module