module misc
  use types
  use omp_lib

  implicit none

  interface minmax
     subroutine minmax_r(array, min, max)
       real(kind=8), intent(in), dimension(:) :: array
       real(kind=8), intent(out) :: min, max
     end subroutine minmax_r

     subroutine minmax_i (array, min, max)
       integer, intent(in), dimension(:) :: array

       integer, intent(out) :: min, max
     end subroutine minmax_i
  end interface minmax

  interface meanval
     subroutine mean_1(array, mean, n)
       integer, intent(in) :: n
       real(kind=8), intent(in), dimension(n) :: array
       real(kind=8), intent(out) :: mean
     end subroutine mean_1
     subroutine mean_2(array, mean, n, m)
       integer, intent(in) :: n, m
       real(kind=8), intent(in), dimension(n, m) :: array
       real(kind=8), intent(out), dimension(n)   :: mean
     end subroutine mean_2
  end interface meanval

  interface stddev
     subroutine stddev_1(array, std, n)
       integer, intent(in) :: n
       real(kind=8), intent(in), dimension(n) :: array
       real(kind=8), intent(out) :: std
     end subroutine stddev_1
     subroutine stddev_2(array, std, n, m)
       integer, intent(in) :: n, m
       real(kind=8), intent(in), dimension(n,m) :: array
       real(kind=8), intent(out), dimension(n)  :: std
     end subroutine stddev_2
  end interface stddev
contains
  subroutine hilbert3D(x, y, z, order, bit_length, npoint)
    implicit none

    integer       , INTENT(IN)                       :: bit_length, npoint
    integer       , INTENT(IN) , dimension(1:npoint) :: x, y, z
    real(kind = 8), INTENT(OUT), dimension(1:npoint) :: order

    logical, dimension(0:3*bit_length-1)           :: i_bit_mask
    logical, dimension(0:1*bit_length-1)           :: x_bit_mask, y_bit_mask, z_bit_mask
    integer, dimension(0:7, 0:1, 0:11)             :: state_diagram
    integer                                        :: i, ip, cstate, nstate, b0, b1, b2
    integer                                        :: sdigit, hdigit

    if (bit_length>bit_size(bit_length)) then
       write(*, *)'Maximum bit length=', bit_size(bit_length)
       write(*, *)'stop in hilbert3d'
       stop
    endif

    state_diagram = RESHAPE( (/   1, 2, 3, 2, 4, 5, 3, 5, &
         &   0, 1, 3, 2, 7, 6, 4, 5, &
         &   2, 6, 0, 7, 8, 8, 0, 7, &
         &   0, 7, 1, 6, 3, 4, 2, 5, &
         &   0, 9,10, 9, 1, 1,11,11, &
         &   0, 3, 7, 4, 1, 2, 6, 5, &
         &   6, 0, 6,11, 9, 0, 9, 8, &
         &   2, 3, 1, 0, 5, 4, 6, 7, &
         &  11,11, 0, 7, 5, 9, 0, 7, &
         &   4, 3, 5, 2, 7, 0, 6, 1, &
         &   4, 4, 8, 8, 0, 6,10, 6, &
         &   6, 5, 1, 2, 7, 4, 0, 3, &
         &   5, 7, 5, 3, 1, 1,11,11, &
         &   4, 7, 3, 0, 5, 6, 2, 1, &
         &   6, 1, 6,10, 9, 4, 9,10, &
         &   6, 7, 5, 4, 1, 0, 2, 3, &
         &  10, 3, 1, 1,10, 3, 5, 9, &
         &   2, 5, 3, 4, 1, 6, 0, 7, &
         &   4, 4, 8, 8, 2, 7, 2, 3, &
         &   2, 1, 5, 6, 3, 0, 4, 7, &
         &   7, 2,11, 2, 7, 5, 8, 5, &
         &   4, 5, 7, 6, 3, 2, 0, 1, &
         &  10, 3, 2, 6,10, 3, 4, 4, &
         &   6, 1, 7, 0, 5, 2, 4, 3 /), &
         & (/8 ,2, 12 /) )

    do ip = 1, npoint

       ! convert to binary
       do i = 0, bit_length-1
          x_bit_mask(i) = btest(x(ip), i)
          y_bit_mask(i) = btest(y(ip), i)
          z_bit_mask(i) = btest(z(ip), i)
       enddo

       ! interleave bits
       do i = 0, bit_length-1
          i_bit_mask(3*i+2) = x_bit_mask(i)
          i_bit_mask(3*i+1) = y_bit_mask(i)
          i_bit_mask(3*i  ) = z_bit_mask(i)
       end do

       ! build Hilbert ordering using state diagram
       cstate = 0
       do i = bit_length-1, 0,-1
          b2 = 0 ; if (i_bit_mask(3*i+2)) b2 = 1
          b1 = 0 ; if (i_bit_mask(3*i+1)) b1 = 1
          b0 = 0 ; if (i_bit_mask(3*i  )) b0 = 1
          sdigit = b2*4+b1*2+b0
          nstate = state_diagram(sdigit, 0,cstate)
          hdigit = state_diagram(sdigit, 1,cstate)
          i_bit_mask(3*i+2) = btest(hdigit, 2)
          i_bit_mask(3*i+1) = btest(hdigit, 1)
          i_bit_mask(3*i  ) = btest(hdigit, 0)
          cstate = nstate
       enddo

       ! save Hilbert key as double precision real
       order(ip) = 0.
       do i = 0, 3*bit_length-1
          b0 = 0 ; if (i_bit_mask(i)) b0 = 1
          order(ip) = order(ip)+dble(b0)*dble(2)**i
       end do

    end do

  end subroutine hilbert3D

  subroutine quick_sort(list, order)
    ! quick sort routine from:
    ! brainerd, w.s., goldberg, c.h. & adams, j.c. (1990) "programmer's guide to
    ! fortran 90", mcgraw-hill  isbn 0-07-000248-7, pages 149-150.
    ! modified by alan miller to include an associated integer array which gives
    ! the positions of the elements in the original order.
    integer, parameter :: i8b = 8

    integer, dimension (:), intent(inout)        :: list
    integer, dimension (size(list)), intent(out) :: order

    integer :: n
    ! local variable
    integer :: i

    n = size(list)
    do i = 1, n
       order(i) = i
    end do

    call quick_sort_1(1, n)

  contains
    recursive subroutine quick_sort_1(left_end, right_end)

      integer, intent(in) :: left_end, right_end

      !     local variables
      integer             :: i, j, itemp
      integer(i8b)        :: reference, temp
      integer, parameter  :: max_simple_sort_size = 6

      if (right_end < left_end + max_simple_sort_size) then
         ! use interchange sort for small lists
         call interchange_sort(left_end, right_end)

      else
         ! use partition ("quick") sort
         reference = list((left_end + right_end)/2)
         i = left_end - 1; j = right_end + 1

         do
            ! scan list from left end until element >= reference is found
            do
               i = i + 1
               if (list(i) >= reference) exit
            end do
            ! scan list from right end until element <= reference is found
            do
               j = j - 1
               if (list(j) <= reference) exit
            end do

            if (i < j) then
               ! swap two out-of-order elements
               temp = list(i); list(i) = list(j); list(j) = temp
               itemp = order(i); order(i) = order(j); order(j) = itemp
            else if (i == j) then
               i = i + 1
               exit
            else
               exit
            end if
         end do

         if (left_end < j) call quick_sort_1(left_end, j)
         if (i < right_end) call quick_sort_1(i, right_end)
      end if

    end subroutine quick_sort_1

    subroutine interchange_sort(left_end, right_end)

      integer, intent(in) :: left_end, right_end

      !     local variables
      integer             :: i, j, itemp
      integer(i8b)        :: temp

      do i = left_end, right_end - 1
         do j = i+1, right_end
            if (list(i) > list(j)) then
               temp = list(i); list(i) = list(j); list(j) = temp
               itemp = order(i); order(i) = order(j); order(j) = itemp
            end if
         end do
      end do

    end subroutine interchange_sort
  end subroutine quick_sort

  recursive subroutine rquick_sort(A)
    real, intent(in out), dimension(:) :: A
    integer :: iq

    if(size(A) > 1) then
       call Partition(A, iq)
       call rquick_sort(A(:iq-1))
       call rquick_sort(A(iq:))
    endif

  contains
    subroutine Partition(A, marker)
      real, intent(in out), dimension(:) :: A
      integer, intent(out) :: marker
      integer :: i, j
      real :: temp
      real :: x      ! pivot point
      x = A(1)
      i= 0
      j= size(A) + 1

      do
         j = j-1
         do
            if (A(j) <= x) exit
            j = j-1
         end do
         i = i+1
         do
            if (A(i) >= x) exit
            i = i+1
         end do
         if (i < j) then
            ! exchange A(i) and A(j)
            temp = A(i)
            A(i) = A(j)
            A(j) = temp
         elseif (i == j) then
            marker = i+1
            return
         else
            marker = i
            return
         endif
      end do

    end subroutine Partition

  end subroutine rquick_sort

  subroutine get_cpu_list(X0, X1, levelmax, bound_key, cpu_list, ncpu, ndim)
    integer, intent(in)                          :: ncpu, ndim, levelmax
    real(kind = 8), dimension(1:ndim), intent(in):: X0, X1
    real(kind = 8), dimension(0:ncpu), intent(in):: bound_key
    integer, dimension(ncpu), intent(out)        :: cpu_list

    logical, dimension(ncpu)                     :: cpu_read
    integer :: ncpu_read

    real(kind = 8), dimension(1:ndim) :: X0_tmp, X1_tmp
    real(kind=8), dimension(3, 2, 2)  :: bounds
    integer :: i, j, k

    cpu_list = 0
    ncpu_read = 0
    bounds = 0
    cpu_read = .false.

    do i = 1, ndim
       if (X0(i) < 0 .and. X1(i) < 0) then
          bounds(i, 1, 1) = X0(i) + 1d0
          bounds(i, 1, 2) = X1(i) + 1d0

          bounds(i, 2, 1) = -1.
          bounds(i, 2, 2) = -1.
       else if (X0(i) < 0) then
          bounds(i, 1, 1) = X0(i) + 1d0
          bounds(i, 1, 2) = 1d0

          bounds(i, 2, 1) = 0d0
          bounds(i, 2, 2) = X1(i)
       else if (X0(i) > 1. .and. X1(i) > 1.) then
          bounds(i, 1, 1) = X0(i) - 1d0
          bounds(i, 1, 2) = X1(i) - 1d0
       else if (X1(i) > 1.) then
          bounds(i, 1, 1) = X0(i)
          bounds(i, 1, 2) = 1d0

          bounds(i, 2, 1) = 0d0
          bounds(i, 2, 2) = X1(i) - 1d0
       else
          bounds(i, 1, 1) = X0(i)
          bounds(i, 1, 2) = X1(i)

          bounds(i, 2, 1) = -1.
          bounds(i, 2, 2) = -1.
       end if
    end do

    do i = 1, 2
       do j = 1, 2
          do k = 1, 2
             X0_tmp(1) = bounds(1, i, 1)
             X1_tmp(1) = bounds(1, i, 2)
             X0_tmp(2) = bounds(2, j, 1)
             X1_tmp(2) = bounds(2, j, 2)
             X0_tmp(3) = bounds(3, k, 1)
             X1_tmp(3) = bounds(3, k, 2)
             ! print*, '------------------------'
             ! print*, X0_tmp, X1_tmp
             call get_it(cpu_list, ncpu_read, cpu_read)
          end do
       end do
    end do

  contains

    subroutine get_it(cpu_list, ncpu_read, cpu_read)
      integer, dimension(ncpu), intent(inout)      :: cpu_list
      logical, dimension(ncpu), intent(inout)      :: cpu_read
      integer, intent(inout)                       :: ncpu_read

      real(kind = 8)                 :: xmin, xmax, ymin, ymax, zmin, zmax
      integer                        :: imin, imax, jmin, jmax, kmin, kmax, lmin
      integer                        :: ilevel, bit_length, maxdom
      real(kind = 8), dimension(1:8) :: bounding_min, bounding_max
      real(kind = 8)                 :: dkey, dmax, deltax
      real(kind = 8), dimension(1:1) :: order_min
      integer, dimension(1:8)        :: idom, jdom, kdom, cpu_min, cpu_max

      integer :: ndom, i, impi, j
      xmin = X0_tmp(1); xmax = X1_tmp(1)
      ymin = X0_tmp(2); ymax = X1_tmp(2)
      zmin = X0_tmp(3); zmax = X1_tmp(3)

      dmax = max(xmax-xmin, ymax-ymin, zmax-zmin)
      do ilevel = 1, levelmax
         deltax = 0.5d0**ilevel
         if (deltax.lt.dmax) exit
      end do
      lmin = ilevel
      bit_length = lmin-1
      maxdom = 2**bit_length
      imin = 0; imax = 0; jmin = 0; jmax = 0; kmin = 0; kmax = 0
      if (bit_length>0) then
         imin = int(xmin*dble(maxdom))
         imax = imin+1
         jmin = int(ymin*dble(maxdom))
         jmax = jmin+1
         kmin = int(zmin*dble(maxdom))
         kmax = kmin+1
      endif

      dkey = (dble(2**(levelmax+1)/dble(maxdom)))**ndim
      ndom = 1
      if (bit_length>0) ndom = 8
      idom(1) = imin; idom(2) = imax
      idom(3) = imin; idom(4) = imax
      idom(5) = imin; idom(6) = imax
      idom(7) = imin; idom(8) = imax
      jdom(1) = jmin; jdom(2) = jmin
      jdom(3) = jmax; jdom(4) = jmax
      jdom(5) = jmin; jdom(6) = jmin
      jdom(7) = jmax; jdom(8) = jmax
      kdom(1) = kmin; kdom(2) = kmin
      kdom(3) = kmin; kdom(4) = kmin
      kdom(5) = kmax; kdom(6) = kmax
      kdom(7) = kmax; kdom(8) = kmax

      do i = 1, ndom
         if (bit_length>0) then
            call hilbert3D(idom(i), jdom(i), kdom(i), order_min, bit_length, 1)
         else
            order_min = 0.0d0
         endif
         bounding_min(i) = (order_min(1))*dkey
         bounding_max(i) = (order_min(1)+1.0D0)*dkey
      end do

      cpu_min = 0; cpu_max = 0
      do impi = 1, ncpu
         do i = 1, ndom
            if (   bound_key(impi-1) <= bounding_min(i).and.&
                 & bound_key(impi  ) > bounding_min(i)) then
               cpu_min(i) = impi
            endif
            if (   bound_key(impi-1) < bounding_max(i).and.&
                 & bound_key(impi  ) >= bounding_max(i)) then
               cpu_max(i) = impi
            endif
         end do
      end do

      do i = 1, ndom
         do j = cpu_min(i), cpu_max(i)
            if (.not. cpu_read(j)) then
               ncpu_read = ncpu_read+1
               cpu_list(ncpu_read) = j
               cpu_read(j) = .true.
            endif
         enddo
      enddo

      ! deallocate(cpu_read)
    end subroutine get_it
  end subroutine get_cpu_list

  function indexOf(element, array)
    ! Please note that array has to be sorted
    integer :: indexOf
    integer, intent(in) :: element
    integer, intent(in), dimension(:) :: array

    integer :: left, right, middle
    left = lbound(array, 1)
    right = ubound(array, 1)
    middle = (left + right) / 2

    indexOf = -1

    if (array(left) > element .or. array(right) < element) then
       return
    end if
    do while (element /= array(middle))
       if (left > right) then
          return
       end if

       if (element > array(middle)) then
          left = middle + 1
       else if (element < array(middle)) then
          right = middle - 1
       end if
       middle = (left + right) / 2

    end do

    indexOf = middle

  end function indexOf

  subroutine max_index (array, imax)
    real(sp), intent(in), dimension(:) :: array
    integer, intent(out) :: imax
    real :: maxval
    integer :: i
    imax = lbound(array, 1)
    maxval = array(imax)
    do i = lbound(array, 1), ubound(array, 1)
       if (array(i) > maxval) then
          imax = i
          maxval = array(i)
       end if
    end do
  end subroutine max_index

  function median (A, n, m)
    integer, intent(in) :: n, m
    real, dimension(n, m), intent(in) :: A

    real, dimension(m) :: A_copy

    integer :: i
    real, dimension(n) :: median

    do i = 1, n
       A_copy = A(i, :)
       call rquick_sort(A_copy)

       median(i) = A_copy(m/ 2)
    end do
  end function median

  ! Return an array containing unique data from array
  subroutine unique (array, u_array)
    integer, intent(in), dimension(:) :: array
    integer, intent(out), dimension(size(array)) :: u_array

    integer, dimension(size(array)) :: order, tmp_array
    integer :: ptr, i

    tmp_array = array
    call quick_sort(tmp_array, order)

    u_array = 0
    u_array(1) = tmp_array(1)

    ptr = 1 ! pointer on unique array
    do i = 1, size(array)
       if (u_array(ptr) /= tmp_array(i)) then
          ptr = ptr + 1
          u_array(ptr) = tmp_array(i)
       end if
    end do

  end subroutine unique

  subroutine parse_params (cli)
    use flap, only : command_line_interface

    type(command_line_interface), intent(out) :: cli

    call cli%init(progname='compute_halo_fft')
    call cli%add(switch='--min-mass', switch_ab='-minm', help='Minimum mass', act='store',&
         def='0')
    call cli%add(switch='--max-mass', switch_ab='-maxm', help='Maximum mass', act='store',&
         def='1e99')
    call cli%add(switch='--gal-list', help='List of galaxies', act='store', &
         def='lists/list_kingal_00782.dat')
    call cli%add(switch='--halo-list', help='List of dark matter halo', act='store', &
         def='lists/list_halo.dat.bin')
    call cli%add(switch='--association-list', help='List of association between galaxy and halo', &
         act='store', def='lists/associated_halogal_782.dat.bin')
    call cli%add(switch='--info-file', help='Information file about simulation', &
         act='store', def='/data52/Horizon-AGN/OUTPUT_DIR/output_00782/info_00782.txt')
    call cli%add(switch='--output-end', help='Path for latest output of simulation', &
         act='store', def='/data52/Horizon-AGN/OUTPUT_DIR/output_00782/')
    call cli%add(switch='--output-start', help='Path for first output of simulation', &
         act='store', def='/data52/Horizon-AGN/OUTPUT_DIR/output_00002/')
    call cli%add(switch='--brick', help='Path for brick file that contains the halos', &
         act='store', def='/data52/Horizon-AGN/TREE_DM_celldx2kpc_SC0.9r/tree_bricks782')
    call cli%add(switch='--cpu-from', help='First cpu to use', &
         act='store', def='1')
    call cli%add(switch='--cpu-to', help='Last cpu to use', &
         act='store', def='4096')
    call cli%add(switch='--halo-to-cpu', help='Halo to cpu list, binary', &
         act='store', def='lists/halo_to_cpu.00002.m<1e12.dat.bin')
    call cli%add(switch='--percent-probe-particle', help='When using random particles, percent of random particle to pick.', &
         act='store', def='5')
    call cli%add(switch='--output-path', help='Path of the output', &
         act='store', def='/data52/Horizon-AGN/OUTPUT_DIR')
    call cli%add(switch='--output-number', help='Number of the output', &
         act='store', def='2', nargs='+')
    call cli%add(switch='--output', switch_ab='-o', help='Name of the output file', &
         act='store', def='data.out')
    call cli%add(switch='--verbose', help='Verbosity', &
         act='store', def='0')
    call cli%add(switch='--halo-i', help='Halo number', &
         act='store', def='-1')
    call cli%add(switch='--halo-to-treat', help='Halo to treat', &
         act='store', nargs='*', def='-1')

  end subroutine parse_params

  ! Fill an array using val. If the value if found in array, or the array
  ! has already been filled do nothing, else add the value and increment the
  ! counter
  subroutine fill(array, val, counter)

    integer, intent(in) :: val
    integer, intent(inout), dimension(:) :: array

    integer, intent(out) :: counter
    integer :: i

    do i = 1, size(array)
       if (array(i) == val) then
          exit
       else if (array(i)  == 0) then
          counter = counter + 1
          array(i) = val
          exit
       end if
    end do

  end subroutine fill

  !> Filter the region around center, with size width
  !! inputs:
  !! -----------
  !!   - center: the center, in ramses units
  !!   - width: the width, in ramses units
  !!   - idsins: the ids of the particles
  !!   - in : the position of the particles
  !!   - order, optional: the order of the ids
  !! outputs:
  !! --------
  !!   - idsout: the ids of the particles found
  !!   - out: the position of the particles
  !!   - parts_in_region: number of particles in the region
  subroutine filter_region(center, width, idsin, in, idsout, out, parts_in_region, &
       order)
    real(dp), dimension(3), intent(in)                         :: center, width
    real(dp), dimension(:, :), intent(in)                      :: in
    integer, dimension(:), intent(in)                          :: idsin
    integer, dimension(:), intent(in), optional                :: order ! if the idsin have been sorted
    real(dp), dimension(size(in, 1), size(in, 2)), intent(out) :: out
    integer, intent(out), optional                             :: parts_in_region
    integer, dimension(:), intent(out)                         :: idsout

    integer :: i, dim, iout, tmp_iout

    real(dp), dimension(3) :: maxis, minis, dist, correction
    logical :: ok

    real(dp) :: start
    integer :: nthreads, thread, from, to, step, nfound_shared, nfound, part_i
    ! integer, allocatable, dimension(:) :: tmp_ids

    iout = 0

    start = OMP_GET_WTIME()
    nthreads = OMP_GET_MAX_THREADS()
    step = ceiling(1d0 * size(idsin, 1) / nthreads)

    nfound_shared = 0

    !$OMP PARALLEL DEFAULT(none)                                       &
    !$OMP PRIVATE(thread, from, to, ok, dist, correction, dim, part_i) &
    !$OMP PRIVATE(nfound)                                              &
    !$OMP FIRSTPRIVATE(nthreads, step, center, width)                  &
    !$OMP SHARED(idsin, nfound_shared, order, in, idsout, out)

    thread = OMP_GET_THREAD_NUM()
    from = step * thread + 1
    to   = min(step * (thread + 1), size(idsin, 1))
    nfound = 0

    !  allocate(tmp_ids(to-from+1))

    print*, width

    do part_i = from, to
       dist = in(:, part_i) - center

       ! correct the distance with boundary conditions (cannot exceed 0.5)
       do dim = 1, 3
          if (dist(dim) > 0.5) then
             dist(dim) = abs(dist(dim) - 1d0)
             correction(dim) = -1d0
          else if (dist(dim) < -0.5) then
             dist(dim) = abs(dist(dim) + 1d0)
             correction(dim) = 1d0
          else
             dist(dim) = abs(dist(dim))
             correction(dim) = 0d0
          end if
       end do

       ok = all(dist < width)

       if (ok) then
          !nfound = nfound + 1
          !tmp_ids(nfound) = part_i ! tmp_ids(i) contains the index

          ! TODO: actually apply the correction...
          !$OMP CRITICAL
          nfound_shared = nfound_shared + 1
          if (present(order)) then
             idsout(nfound_shared) = idsin(order(part_i))
          else
             idsout(nfound_shared) = idsin(part_i)
          end if

          out(:, nfound_shared) = in(:, part_i) + correction(:)
          !$OMP END CRITICAL
       end if
    end do
    !$OMP END PARALLEL

    ! copy the result in the shared array
    ! !$OMP CRITICAL
    ! do i = 1, nfound
    !    nfound_shared = nfound_shared + 1

    !    part_i = tmp_ids(i)
    !    ! write(*, '(i4,*(a,i9))') thread, ': part_i ', part_i, 'i', i

    !    if (present(order)) then
    !       idsout(nfound_shared) = idsin(order(part_i))
    !    else
    !       idsout(nfound_shared) = idsin(part_i)
    !    end if

    !    out(:, nfound_shared) = in(:, part_i)
    ! end do
    ! !$OMP END CRITICAL
    ! deallocate(tmp_ids)

    write(*, *) 'Took', OMP_GET_WTIME() - start

    parts_in_region = nfound_shared
  end subroutine filter_region

   !> Filter the region around center, with size width
  !! inputs:
  !! -----------
  !!   - center: the center, in ramses units
  !!   - width: the width, in ramses units
  !!   - idsins: the ids of the particles
  !!   - in : the position of the particles
  !!   - order, optional: the order of the ids
  !! outputs:
  !! --------
  !!   - idsout: the ids of the particles found
  !!   - out: the position of the particles
  !!   - parts_in_region: number of particles in the region
  subroutine filter_region_no_omp(center, width, idsin, in, idsout, out, parts_in_region, &
       order)
    real(dp), dimension(3), intent(in)                         :: center, width
    real(dp), dimension(:, :), intent(in)                      :: in
    integer, dimension(:), intent(in)                          :: idsin
    integer, dimension(:), intent(in), optional                :: order ! if the idsin have been sorted
    real(dp), dimension(size(in, 1), size(in, 2)), intent(out) :: out
    integer, intent(out), optional                             :: parts_in_region
    integer, dimension(:), intent(out)                         :: idsout

    integer :: i, dim, iout

    real(dp), dimension(3) :: maxis, minis, dist, correction
    logical :: ok

    iout = 0
    ! loop over each positions given in input

    !$nOMP PARALLEL DO default(none)                   &
    !$nOMP SHARED(idsin, idsout, out, order, iout, in) &
    !$nOMP FIRSTPRIVATE(center, width)                 &
    !$nOMP PRIVATE(ok, dist, correction)               &
    !$nOMP SCHEDULE(DYNAMIC, 1000000)
    do i = 1, size(idsin, 1)
       ok = .true.
       dist = in(:, i) - center
       correction = 0

       ! correct the distance with boundary conditions (cannot exceed 0.5)
       do dim = 1, 3
          if (dist(dim) > 0.5) then
             dist(dim) = dist(dim) - 1
             correction(dim) = -1
          else if (dist(dim) < -0.5) then
             dist(dim) = dist(dim) + 1
             correction(dim) = 1
          end if

          dist(dim) = abs(dist(dim))

          if (dist(dim) > width(dim)) then
             ok = .false.
             exit
          end if
       end do

       if (ok) then
          !$OMP CRITICAL

          iout = iout + 1
          if (present(order)) then
             ! get the real id using order array
             idsout(iout) = idsin(order(i))
          else
             idsout(iout) = idsin(i)
          end if

          out(:, iout) = in(:, i) + correction(:)
          !$OMP END CRITICAL
       end if
    end do

    parts_in_region = iout
  end subroutine filter_region_no_omp

  !! Finds the indexes of B in A when both arrays are sorted
  !! The subroutine finds the position of B's leftmost and rightmost values
  !! into A. All the remaining values are within left[B], right[B]
  !! and therefore within A[index(left[B]), index(right[B])]
  !! this is then repeated until all elements of B are exhausted
  subroutine indexOfArr(B, A, indexArr)
    integer, intent(in), dimension(:) :: A, B
    integer, intent(out), dimension(size(B))&
                                      :: indexArr

    integer :: left, right, i, j
    left  = 1
    right = size(A)

    i = 1
    j = size(B)

    do while (i <= j)
       ! Look left one in subset of A
       indexArr(i) = indexOf(B(i), A(left:right))
       if (indexArr(i) > 0) then
          indexArr(i) = indexArr(i) + left - 1
          left = indexArr(i)
       end if

       if (j == i) exit
       i = i + 1

       ! Look right one in subset of A
       indexArr(j) = indexOf(B(j), A(left:right))
       if (indexArr(j) > 0) then
          indexArr(j) = indexArr(j) + left - 1
          right = indexArr(j)
       end if

       j = j - 1
    end do

  end subroutine indexOfArr

end module misc
!-------------------------------------
! To interface
!-------------------------------------
subroutine minmax_r (array, min, max)
  implicit none

  real(kind=8), intent(in), dimension(:) :: array

  real(kind=8), intent(out) :: min, max
  integer :: i

  do i = 1, size(array)
     if (array(i) > min) min = array(i)
     if (array(i) < max) max = array(i)
  end do
end subroutine minmax_r

subroutine minmax_i (array, min, max)
  implicit none

  integer, intent(in), dimension(:) :: array

  integer, intent(out) :: min, max
  integer :: i

  do i = 1, size(array)
     if (array(i) > min) min = array(i)
     if (array(i) < max) max = array(i)
  end do
end subroutine minmax_i

subroutine mean_1 (array, mean, n)
  integer, intent(in) :: n
  real(kind=8), intent(in), dimension(n) :: array
  real(kind=8), intent(out)              :: mean

  mean = sum(array) / size(array)
end subroutine mean_1

subroutine mean_2 (array, mean, n, m)
  integer, intent(in) :: n, m
  real(kind=8), intent(in), dimension(n, m) :: array
  real(kind=8), intent(out), dimension(n)   :: mean
  real(kind=8), dimension(m)   :: tmp_arr
  integer :: i

  do i = 1, n
     tmp_arr = array(i, :)
     call mean_1(tmp_arr, mean(i), m)
  end do
end subroutine mean_2

subroutine stddev_1 (array, std, n)
  integer, intent(in) :: n
  real(kind=8), intent(in), dimension(n) :: array
  real(kind=8), intent(out)              :: std

  real(kind=8), dimension(n) :: tmp_array
  real(kind=8) :: mean

  call mean_1(array, mean, n)
  tmp_array = (array - mean)**2
  call mean_1(tmp_array, std, n)
  std = sqrt(std)
end subroutine stddev_1

subroutine stddev_2 (array, std, n, m)
  integer, intent(in) :: n, m
  real(kind=8), intent(in), dimension(n, m) :: array
  real(kind=8), intent(out), dimension(n)   :: std
  real(kind=8), dimension(m)   :: tmp_arr
  integer :: i

  do i = 1, n
     tmp_arr = array(i, :)
     call stddev_1(tmp_arr, std(i), m)
  end do
end subroutine stddev_2


!
MODULE IntrinsicTypesModule
  !
  !  ***  Description:
  !
  !  KIND specifications for intrinsic types.
  !
  !  INTEGERS:
  !  --------
  !
  !  Typically, there are 1-byte, 2-byte, 4-byte and 8-byte
  !  integers with 4-byte being the default and having 9 digits
  !  of precision.  Here, we only use short and long (4-byte
  !  and 8-byte).
  !
  !  Public Parameters
  !  -----------------
  !
  !  INTEGER_KIND_S : short integer kind (at least 9 digits)
  !  INTEGER_KIND_L : long integer kind (at least 15 digits)
  !
  !  INTEGER_KIND   : default integer kind for this module (short)
  !
  !  *** End:
  !
  INTEGER, PUBLIC, PARAMETER :: &
       &  INTEGER_KIND_S = SELECTED_INT_KIND(9),&
       &  INTEGER_KIND_L = SELECTED_INT_KIND(15)
  !
  INTEGER, PUBLIC, PARAMETER :: &
       &  INTEGER_KIND   = INTEGER_KIND_S
  !
  !  ***  Description:
  !
  !  REALS:
  !  -----
  !
  !  The real kinds are specified using the PRECISION and RANGE
  !  arguments to SELECTED_REAL_KIND; on seahag (alpha/linux),
  !  the preicison is 6 for single and 15 for double, and the
  !  ranges are 37 for single and 307 for double.  Quadruple
  !  precision is also available on many compilers.
  !
  !  Public Parameters
  !  -----------------
  !
  !  REAL_KIND_S : single precision
  !  REAL_KIND_D : double precision
  !  REAL_KIND_Q : quadruple precision
  !
  !  REAL_KIND   : default precision for this module (double)
  !
  !  *** End:
  !
  INTEGER, PUBLIC, PARAMETER :: &
       &  REAL_KIND_S = SELECTED_REAL_KIND( 5,  30),&
       &  REAL_KIND_D = SELECTED_REAL_KIND(15, 307),&
       &  REAL_KIND_Q = SELECTED_REAL_KIND(25, 200)
  !
  INTEGER, PUBLIC, PARAMETER :: REAL_KIND = REAL_KIND_D
  !
  !  ***  Description:
  !
  !  LOGICALS:
  !  --------
  !
  !  Usually, many logical kinds are available, 1-byte, 2-byte,
  !  4-byte and 8-byte; default is usually 4-byte.  There is no
  !  fortran function SELECTED_LOGICAL_KIND, so here we just
  !  stick with the system default logical kind.
  !
  !  Public Parameters:
  !  -----------------
  !
  !  LOGICAL_KIND_D : system default logical kind (KIND(.TRUE.))
  !
  !  LOGICAL_KIND   : default logical kind for this module
  !
  !  *** End:
  !
  INTEGER, PUBLIC, PARAMETER :: LOGICAL_KIND_D = KIND(.TRUE.)
  !
  INTEGER, PUBLIC, PARAMETER :: LOGICAL_KIND = LOGICAL_KIND_D
  !
  !  Other functions available regarding real numeric types are:
  !
  !  EPSILON, HUGE, MAXEXPONENT, MINEXPONENT, PRECISION,
  !  RADIX, RANGE and TINY
  !
  !
END MODULE IntrinsicTypesModule


!=============================================================================!
        subroutine lrhs3D(vl, rl, vml, xl, yl)
!
!  Computes the RK3 RHS for the linearized three-dimensional compressible
!  Navier-Stokes solver using Implicit time advancement.
!
!  Revised: 4-22-96
!=============================================================================!
        use global
        use local2d
        use local3d
        implicit none
!=============================================================================!
        complex :: vl(ndof,nx,ny), rl(ndof,nx,ny)
        real    :: vml(ndof,nx,ny)
        real    :: xl(nx,ny), yl(nx,ny)

!.... local variables

        integer :: i, j, idof, jdof

!.... mean flow variables

        real :: cm, um
        real :: a, d, kk
        complex :: c3

        character(80) :: name, code='lrhs3D$'
!=============================================================================!

!.... compute first derivatives

        call cgrad( ndof, nx, ny, vl, c1v, c2v, dxi, deta, optx, opty, &
                    xper, yper, lsym, rsym, bsym, tsym, carp )

!.... compute second derivatives

        call cgrad2( ndof, nx, ny, vl, c1v, c11v, c12v, c22v, dxi, deta, &
                     optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp )

!.... enforce adiabatic wall temperature boundary condition

        if (Navier) call cgradbc( c1v, c2v, c11v, c12v, c22v )

        !$omp parallel do private (i,cm,um,d,kk,a,c3)
        loop_j: do j = 1, ny
        loop_i: do i = 1, nx

!=============================================================================!
!.... form the RHS
!=============================================================================!

!.... U,xi term

        rl(1,i,j) =       + Ah(1,1,i,j) * c1v(1,i,j)    &
                          + Ah(1,2,i,j) * c1v(2,i,j)    &
                          + Ah(1,3,i,j) * c1v(3,i,j)    &
                          + Ah(1,4,i,j) * c1v(4,i,j)    &
                          + Ah(1,5,i,j) * c1v(5,i,j)

        rl(2,i,j) =       + Ah(2,1,i,j) * c1v(1,i,j)    &
                          + Ah(2,2,i,j) * c1v(2,i,j)    &
                          + Ah(2,3,i,j) * c1v(3,i,j)    &
                          + Ah(2,4,i,j) * c1v(4,i,j)    &
                          + Ah(2,5,i,j) * c1v(5,i,j)

        rl(3,i,j) =       + Ah(3,1,i,j) * c1v(1,i,j)    &
                          + Ah(3,2,i,j) * c1v(2,i,j)    &
                          + Ah(3,3,i,j) * c1v(3,i,j)    &
                          + Ah(3,4,i,j) * c1v(4,i,j)    &
                          + Ah(3,5,i,j) * c1v(5,i,j)

        rl(4,i,j) =       + Ah(4,1,i,j) * c1v(1,i,j)    &
                          + Ah(4,2,i,j) * c1v(2,i,j)    &
                          + Ah(4,3,i,j) * c1v(3,i,j)    &
                          + Ah(4,4,i,j) * c1v(4,i,j)    &
                          + Ah(4,5,i,j) * c1v(5,i,j)

        rl(5,i,j) =       + Ah(5,1,i,j) * c1v(1,i,j)    &
                          + Ah(5,2,i,j) * c1v(2,i,j)    &
                          + Ah(5,3,i,j) * c1v(3,i,j)    &
                          + Ah(5,4,i,j) * c1v(4,i,j)    &
                          + Ah(5,5,i,j) * c1v(5,i,j)

!.... U,eta term

        rl(1,i,j) = rl(1,i,j) + Bh(1,1,i,j) * c2v(1,i,j)        &
                          + Bh(1,2,i,j) * c2v(2,i,j)    &
                          + Bh(1,3,i,j) * c2v(3,i,j)    &
                          + Bh(1,4,i,j) * c2v(4,i,j)    &
                          + Bh(1,5,i,j) * c2v(5,i,j)

        rl(2,i,j) = rl(2,i,j) + Bh(2,1,i,j) * c2v(1,i,j)        &
                          + Bh(2,2,i,j) * c2v(2,i,j)    &
                          + Bh(2,3,i,j) * c2v(3,i,j)    &
                          + Bh(2,4,i,j) * c2v(4,i,j)    &
                          + Bh(2,5,i,j) * c2v(5,i,j)

        rl(3,i,j) = rl(3,i,j) + Bh(3,1,i,j) * c2v(1,i,j)        &
                          + Bh(3,2,i,j) * c2v(2,i,j)    &
                          + Bh(3,3,i,j) * c2v(3,i,j)    &
                          + Bh(3,4,i,j) * c2v(4,i,j)    &
                          + Bh(3,5,i,j) * c2v(5,i,j)

        rl(4,i,j) = rl(4,i,j) + Bh(4,1,i,j) * c2v(1,i,j)        &
                          + Bh(4,2,i,j) * c2v(2,i,j)    &
                          + Bh(4,3,i,j) * c2v(3,i,j)    &
                          + Bh(4,4,i,j) * c2v(4,i,j)    &
                          + Bh(4,5,i,j) * c2v(5,i,j)

        rl(5,i,j) = rl(5,i,j) + Bh(5,1,i,j) * c2v(1,i,j)        &
                          + Bh(5,2,i,j) * c2v(2,i,j)    &
                          + Bh(5,3,i,j) * c2v(3,i,j)    &
                          + Bh(5,4,i,j) * c2v(4,i,j)    &
                          + Bh(5,5,i,j) * c2v(5,i,j)

!.... U term

        rl(1,i,j) = rl(1,i,j) + Dh(1,1,i,j) * vl(1,i,j) &
                          + Dh(1,2,i,j) * vl(2,i,j)     &
                          + Dh(1,3,i,j) * vl(3,i,j)     &
                          + Dh(1,4,i,j) * vl(4,i,j)     &
                          + Dh(1,5,i,j) * vl(5,i,j)

        rl(2,i,j) = rl(2,i,j) + Dh(2,1,i,j) * vl(1,i,j) &
                          + Dh(2,2,i,j) * vl(2,i,j)     &
                          + Dh(2,3,i,j) * vl(3,i,j)     &
                          + Dh(2,4,i,j) * vl(4,i,j)     &
                          + Dh(2,5,i,j) * vl(5,i,j)

        rl(3,i,j) = rl(3,i,j) + Dh(3,1,i,j) * vl(1,i,j) &
                          + Dh(3,2,i,j) * vl(2,i,j)     &
                          + Dh(3,3,i,j) * vl(3,i,j)     &
                          + Dh(3,4,i,j) * vl(4,i,j)     &
                          + Dh(3,5,i,j) * vl(5,i,j)

        rl(4,i,j) = rl(4,i,j) + Dh(4,1,i,j) * vl(1,i,j) &
                          + Dh(4,2,i,j) * vl(2,i,j)     &
                          + Dh(4,3,i,j) * vl(3,i,j)     &
                          + Dh(4,4,i,j) * vl(4,i,j)     &
                          + Dh(4,5,i,j) * vl(5,i,j)

        rl(5,i,j) = rl(5,i,j) + Dh(5,1,i,j) * vl(1,i,j) &
                          + Dh(5,2,i,j) * vl(2,i,j)     &
                          + Dh(5,3,i,j) * vl(3,i,j)     &
                          + Dh(5,4,i,j) * vl(4,i,j)     &
                          + Dh(5,5,i,j) * vl(5,i,j)

!.... U,\xi\xi term

        rl(2,i,j) = rl(2,i,j) - Vh11(1,i,j) * c11v(2,i,j)       &
                              - Vh11(5,i,j) * c11v(3,i,j)
        rl(3,i,j) = rl(3,i,j) - Vh11(6,i,j) * c11v(2,i,j)       &
                              - Vh11(2,i,j) * c11v(3,i,j)
        rl(4,i,j) = rl(4,i,j) - Vh11(3,i,j) * c11v(4,i,j)
        rl(5,i,j) = rl(5,i,j) - Vh11(4,i,j) * c11v(5,i,j)

!.... U,\xi\eta term

        rl(2,i,j) = rl(2,i,j) - Vh12(1,i,j) * c12v(2,i,j)       &
                              - Vh12(5,i,j) * c12v(3,i,j)
        rl(3,i,j) = rl(3,i,j) - Vh12(6,i,j) * c12v(2,i,j)       &
                              - Vh12(2,i,j) * c12v(3,i,j)
        rl(4,i,j) = rl(4,i,j) - Vh12(3,i,j) * c12v(4,i,j)
        rl(5,i,j) = rl(5,i,j) - Vh12(4,i,j) * c12v(5,i,j)

!.... U,\eta\eta term

        rl(2,i,j) = rl(2,i,j) - Vh22(1,i,j) * c22v(2,i,j)       &
                              - Vh22(5,i,j) * c22v(3,i,j)
        rl(3,i,j) = rl(3,i,j) - Vh22(6,i,j) * c22v(2,i,j)       &
                              - Vh22(2,i,j) * c22v(3,i,j)
        rl(4,i,j) = rl(4,i,j) - Vh22(3,i,j) * c22v(4,i,j)
        rl(5,i,j) = rl(5,i,j) - Vh22(4,i,j) * c22v(5,i,j)

!.... 3D terms

!.... \hat{A}_i, \hat{B}_i terms

        rl(2,i,j) = rl(2,i,j) - im * ( ABhi(1,i,j) * c1v(4,i,j) + &
                                       ABhi(3,i,j) * c2v(4,i,j) )
        rl(3,i,j) = rl(3,i,j) - im * ( ABhi(2,i,j) * c1v(4,i,j) + &
                                       ABhi(4,i,j) * c2v(4,i,j) )
        rl(4,i,j) = rl(4,i,j) - im * ( ABhi(1,i,j) * c1v(2,i,j) + &
                                       ABhi(2,i,j) * c1v(3,i,j) + &
                    ABhi(3,i,j) * c2v(2,i,j) + ABhi(4,i,j) * c2v(3,i,j) )

!.... \hat{D}_i term

        rl(1,i,j) = rl(1,i,j) + im * ( Dhi(1,1,i,j) * vl(1,i,j) &
                                 + Dhi(1,2,i,j) * vl(2,i,j)     &
                                 + Dhi(1,3,i,j) * vl(3,i,j)     &
                                 + Dhi(1,4,i,j) * vl(4,i,j)     &
                                 + Dhi(1,5,i,j) * vl(5,i,j) )

        rl(2,i,j) = rl(2,i,j) + im * ( Dhi(2,1,i,j) * vl(1,i,j) &
                                 + Dhi(2,2,i,j) * vl(2,i,j)     &
                                 + Dhi(2,3,i,j) * vl(3,i,j)     &
                                 + Dhi(2,4,i,j) * vl(4,i,j)     &
                                 + Dhi(2,5,i,j) * vl(5,i,j) )

        rl(3,i,j) = rl(3,i,j) + im * ( Dhi(3,1,i,j) * vl(1,i,j) &
                                 + Dhi(3,2,i,j) * vl(2,i,j)     &
                                 + Dhi(3,3,i,j) * vl(3,i,j)     &
                                 + Dhi(3,4,i,j) * vl(4,i,j)     &
                                 + Dhi(3,5,i,j) * vl(5,i,j) )

        rl(4,i,j) = rl(4,i,j) + im * ( Dhi(4,1,i,j) * vl(1,i,j) &
                                 + Dhi(4,2,i,j) * vl(2,i,j)     &
                                 + Dhi(4,3,i,j) * vl(3,i,j)     &
                                 + Dhi(4,4,i,j) * vl(4,i,j)     &
                                 + Dhi(4,5,i,j) * vl(5,i,j) )

        rl(5,i,j) = rl(5,i,j) + im * ( Dhi(5,1,i,j) * vl(1,i,j) &
                                 + Dhi(5,2,i,j) * vl(2,i,j)     &
                                 + Dhi(5,3,i,j) * vl(3,i,j)     &
                                 + Dhi(5,4,i,j) * vl(4,i,j)     &
                                 + Dhi(5,5,i,j) * vl(5,i,j) )

!.... Sponge term

        if (ispg .eq. 1) then           !.... standard sponge

          rl(1,i,j) = rl(1,i,j) + spg(i,j) * vl(1,i,j)
          rl(2,i,j) = rl(2,i,j) + spg(i,j) * vl(2,i,j)
          rl(3,i,j) = rl(3,i,j) + spg(i,j) * vl(3,i,j)
          rl(4,i,j) = rl(4,i,j) + spg(i,j) * vl(4,i,j)
          rl(5,i,j) = rl(5,i,j) + spg(i,j) * vl(5,i,j)

        else if (ispg .eq. 2) then

          rl(1,i,j) = rl(1,i,j) + (spg(i,j) + spg2(i,j)) * vl(1,i,j)
          rl(2,i,j) = rl(2,i,j) + (spg(i,j) + spg2(i,j)) * vl(2,i,j)
          rl(3,i,j) = rl(3,i,j) + (spg(i,j) + spg2(i,j)) * vl(3,i,j)
          rl(4,i,j) = rl(4,i,j) + (spg(i,j) + spg2(i,j)) * vl(4,i,j)
          rl(5,i,j) = rl(5,i,j) + (spg(i,j) + spg2(i,j)) * vl(5,i,j)

        else if (ispg .eq. 3) then

!.... the outflow sponge

          rl(1,i,j) = rl(1,i,j) + spg(i,j) * vl(1,i,j)
          rl(2,i,j) = rl(2,i,j) + spg(i,j) * vl(2,i,j)
          rl(3,i,j) = rl(3,i,j) + spg(i,j) * vl(3,i,j)
          rl(4,i,j) = rl(4,i,j) + spg(i,j) * vl(4,i,j)
          rl(5,i,j) = rl(5,i,j) + spg(i,j) * vl(5,i,j)

!.... the inflow sponge

          cm = sqrt( vml(5,i,j) ) / Ma
          um = vml(2,i,j)

          d  = pt5 * ( onept33 + gamma1 / Pr ) / Re

          kk = omega / (cm+um)
          a  = omega**2 * d / (cm+um)**3
          c3 = exp( -a * (xl(i,j) - x0) ) * exp( im * kk * xl(i,j) )
!         c3 = wamp(i) * exp( im * kk * xl(i,j) )

          rl(1,i,j) = rl(1,i,j) + spg2(i,j) * ( vl(1,i,j) - &
                      pt5 * c3 / cm**2 )
          rl(2,i,j) = rl(2,i,j) + spg2(i,j) * ( vl(2,i,j) - &
                      c3 * pt5 / ( vml(1,i,j) * cm ) )
          rl(3,i,j) = rl(3,i,j) + spg2(i,j) * ( vl(3,i,j) )
          rl(4,i,j) = rl(4,i,j) + spg2(i,j) * ( vl(4,i,j) )
          rl(5,i,j) = rl(5,i,j) + spg2(i,j) * ( vl(5,i,j) - &
                      (gamma*Ma**2 * c3 * pt5 - &
                      vml(5,i,j) * pt5 * c3 / cm**2) / vml(1,i,j) )

        else if (ispg .eq. 4) then

          call error(code,'ispg = 4 is not working$')
          call cspg_it( rl, vl, spg, spg2 )

        end if

        end do loop_i
        end do loop_j

!.... explicit smoother

        if (eps_e .ne. zero) call smoother3D( rl, vl )

        return
        end


 SUBROUTINE nodnor( nelem,nnode,lnods,coord,eule0,euler)
 !******************************************************************************
 !
 !****this routine compute the position angles of the nodal coordinate systems
 !
 !     input:   nelem:         number of elements
 !              nnode:         number of nodes per element
 !              coord:         nodal coordinates
 !              lnods:         element conectivities
 !              euler:  /= 0   angles of the nodes. not modified
 !                      == 0   nodes where to compute euler angles
 !
 !     output:  euler:  angles of the nodes.
 !
 !******************************************************************************
 IMPLICIT NONE

 INTEGER (kind=4), PARAMETER :: nd = 3
 INTEGER (kind=4), INTENT(IN) :: nelem,nnode, lnods(:,:)
 REAL (kind=8), INTENT(IN) :: coord(:,:)
 REAL (kind=8), INTENT(IN OUT) :: eule0(:,:),euler(:,:)

 INTEGER (kind=4)ipoin,ielem,inode,npoin
 REAL (kind=8)  auxil,lbd(nd,nd),eltan(nd,nnode),                  &
                elcod(nd,nnode),elnor(nd,nnode),s(nnode),t(nnode), &
                deriv(nnode,2,nnode),shape(nnode,nnode)
 REAL (kind=8), ALLOCATABLE :: vecnx(:,:),vecnz(:,:)
 INTERFACE
   INCLUDE 'angeul.h'
 END INTERFACE
 !     initialize normal z' and x' vectors
 npoin = MAXVAL(lnods)
 ALLOCATE ( vecnx(nd,npoin), vecnz(nd,npoin) )
 vecnx = 0d0
 vecnz = 0d0

 !   assign local nodal coordinates
 SELECT CASE (nnode)
 CASE (3)
    s(1) = 0d0      !node 1
    t(1) = 0d0
    s(2) = 1d0      !node 2
    t(2) = 0d0
    s(3) = 0d0      !node 3
    t(3) = 1d0
 CASE (4)
    s(1) = -1d0     !node 1
    t(1) = -1d0
    s(2) =  1d0     !node 2
    t(2) = -1d0
    s(3) =  1d0     !node 3
    t(3) =  1d0
    s(4) = -1d0     !node 4
    t(4) =  1d0
 CASE (6)
    s(1) = 0d0      !node 1
    t(1) = 0d0
    s(2) = 1d0      !node 2
    t(2) = 0d0
    s(3) = 0d0      !node 3
    t(3) = 1d0
    s(4) = 0.5d0    !node 4
    t(4) = 0d0
    s(5) = 0.5d0    !node 5
    t(5) = 0.5d0
    s(6) = 0d0      !node 6
    t(6) = 0.5d0
 END SELECT
 DO inode=1,nnode
   !          compute shape functions and derivatives
   CALL shape2(deriv(1,1,inode),s(inode),t(inode),nnode,shape(1,inode))
 END DO
 !     summ elemental z' and x'

 DO ielem=1,nelem
   elcod(1:nd,1:nnode) = coord(1:nd,lnods(1:nnode,ielem))
   CALL norelm(nnode,elcod,elnor,eltan,deriv)
   CALL scater(elnor,nd,nnode,vecnz,nd,npoin,lnods(1,ielem))
   CALL scater(eltan,nd,nnode,vecnx,nd,npoin,lnods(1,ielem))
 END DO

 !     compute euler's angles asociated to nodal coordinate system

 DO ipoin=1,npoin
   !   check if Euler angles exist
   IF( .NOT.ALL( eule0(1:3,ipoin) == 0d0) ) CYCLE
   !   average normal vector
   lbd(1:nd,3) = vecnz(1:nd,ipoin)
   CALL vecuni(nd,lbd(1,3),auxil)
   !   if node have do NOT have associated elements
   IF(auxil == 0d0) CYCLE
   lbd(1:nd,1) = vecnx(1:nd,ipoin)
   CALL vecuni(nd,lbd(1,1),auxil)
   IF( ABS(auxil) > 1d-8 ) THEN
     ! IF it is a border node
     ! make surface normal perpendicular to direction X
     auxil = DOT_PRODUCT(lbd(1:3,1),lbd(1:3,3))
     lbd(1:nd,3) = lbd(1:nd,3) - auxil*lbd(1:nd,1)
     CALL vecuni(nd,lbd(1,3),auxil)
     CALL vecpro(lbd(1,3),lbd(1,1),lbd(1,2))
   ELSE
     ! IF it is an internal node
     !         SELECT local x=t1 in the global xy plane
     lbd(1:nd,1) = (/ -lbd(2,3), lbd(1,3) , 0d0 /)
     !         of course local y = t2 = t3 x t1
     lbd(1:nd,2) = (/ -lbd(1,3)*lbd(3,3), -lbd(2,3)*lbd(3,3), &
                      (lbd(1,3)*lbd(1,3) + lbd(2,3)*lbd(2,3)) /)
     !         IF t3 is just global Z
     IF(ABS(lbd(3,2)) < 1.0d-5) THEN
       lbd(1:nd,1) = (/  1d0, 0d0, 0d0 /)
       lbd(1:nd,2) = (/  0d0, 1d0, 0d0 /)
     ELSE
       !           normalizes t1 & t2
       CALL vecuni(nd,lbd(1,1),auxil)
       CALL vecuni(nd,lbd(1,2),auxil)
     END IF
   END IF
   CALL angeul(lbd,eule0(1:3,ipoin),.TRUE.)
   euler(1:3,ipoin) = eule0(1:3,ipoin)
 END DO
 DEALLOCATE ( vecnx, vecnz )

 RETURN
 END SUBROUTINE nodnor


program maths
  use omp_lib
  implicit none

  real(8) :: x = 2.0_8
  complex :: z = (1.0, 2.0)
  integer,parameter :: n = 4567
  integer :: i
  real :: f(n)

  x = sqrt(x)
  z = sqrt(z)

  do i = 1, n
    f(i) = i
  enddo

  !$OMP PARALLEL SHARED(f) PRIVATE(i)

  !$omp master
  print *, "number of threads:",  omp_get_num_threads()
  !$omp end master

  !$OMP DO
  do i = 1, n
    f(i) = sqrt(f(i))
  enddo
  !$OMP END DO NOWAIT
  !$OMP END PARALLEL

  print *, "sqrt(2):", f(2)
end program maths


c
c      TESTING SUITE FOR STOKES KERNELS:  June 18th, 2020
c
c
      implicit real *8 (a-h,o-z)
      real *8 ztrg(3),source(3,20),targ(3,20),targ2(3,20)
      real *8 errgrad(3,20), pert(3), dmu(3), dnu(3)

      real *8, allocatable :: pot(:,:), pre(:), grad(:,:,:)
      real *8, allocatable :: pot2(:,:), pre2(:), grad2(:,:,:)

      real *8, allocatable :: potl(:,:), gradl(:,:,:)

      real *8, allocatable :: stoklet(:,:), strslet(:,:)
      real *8, allocatable :: strsvec(:,:)
      real *8, allocatable :: charge(:,:), dipvec(:,:,:)

      integer ipass(5)
      complex *16 eye
c
      data eye/(0.0d0,1.0d0)/
c
      done=1
      pi=4.0*atan(done)
      call prini(6,13)
      write(*,*) "=========================================="
      write(*,*) "Testing suite for stokkernels"

      open(unit=33,file='print_testres.txt',access='append')

      ntest = 4
      do i=1,ntest
        ipass(i) = 0
      enddo

      ns = 10
      nt = 12

      allocate(stoklet(3,ns),strslet(3,ns),strsvec(3,ns))

      do i = 1,ns
         source(1,i) = cos(i*done)
         source(2,i) = cos(10*i*done)
         source(3,i) = cos(100*i*done)
         stoklet(1,i) = sin(2*i*done)
         stoklet(2,i) = sin(22*i*done)
         stoklet(3,i) = sin(222*i*done)
         strslet(1,i) = sin(4*i*done)
         strslet(2,i) = sin(44*i*done)
         strslet(3,i) = sin(444*i*done)
         strsvec(1,i) = sin(5*i*done)
         strsvec(2,i) = sin(55*i*done)
         strsvec(3,i) = sin(555*i*done)
      enddo

c      call prin2('src *',source,3*ns)
c      call prin2('stoklet *',stoklet,3*ns)
c      call prin2('strslet *',strslet,3*ns)
c      call prin2('strsvec *',strsvec,3*ns)
c

      h = 1d-5
      pert(1) = cos(1000*done)
      pert(2) = cos(2000*done)
      pert(3) = cos(3000*done)

      do i = 1,nt
         targ(1,i) = cos(12*i*done)
         targ(2,i) = cos(123*i*done)
         targ(3,i) = cos(1234*i*done)
         targ2(1,i) = targ(1,i) + h*pert(1)
         targ2(2,i) = targ(2,i) + h*pert(2)
         targ2(3,i) = targ(3,i) + h*pert(3)
      enddo

      allocate(pot(3,nt),pre(nt),grad(3,3,nt))
      allocate(pot2(3,nt),pre2(nt),grad2(3,3,nt))

c     test gradient of stokeslet formula

      thresh = 1d-15
      nd1 = 1

      do i = 1,nt
         pre(i) = 0
         pot(1,i) = 0
         pot(2,i) = 0
         pot(3,i) = 0
         grad(1,1,i) = 0
         grad(2,1,i) = 0
         grad(3,1,i) = 0
         grad(1,2,i) = 0
         grad(2,2,i) = 0
         grad(3,2,i) = 0
         grad(1,3,i) = 0
         grad(2,3,i) = 0
         grad(3,3,i) = 0
         pre2(i) = 0
         pot2(1,i) = 0
         pot2(2,i) = 0
         pot2(3,i) = 0
         grad2(1,1,i) = 0
         grad2(2,1,i) = 0
         grad2(3,1,i) = 0
         grad2(1,2,i) = 0
         grad2(2,2,i) = 0
         grad2(3,2,i) = 0
         grad2(1,3,i) = 0
         grad2(2,3,i) = 0
         grad2(3,3,i) = 0
      enddo

      errmax = 0

      call st3ddirectstokg(nd1,source,stoklet,
     1     ns,targ,nt,pot,pre,grad,thresh)
      call st3ddirectstokg(nd1,source,stoklet,
     1     ns,targ2,nt,pot2,pre2,grad2,thresh)

      do i = 1,nt
         df = pot2(1,i) - pot(1,i)
         gave1 = (grad(1,1,i) + grad2(1,1,i))/2.0d0
         gave2 = (grad(2,1,i) + grad2(2,1,i))/2.0d0
         gave3 = (grad(3,1,i) + grad2(3,1,i))/2.0d0
         errgrad(1,i) = abs(1.0d0 - h*(gave1*pert(1) + gave2*pert(2)
     1        + gave3*pert(3))/df)

         df = pot2(2,i) - pot(2,i)
         gave1 = (grad(1,2,i) + grad2(1,2,i))/2.0d0
         gave2 = (grad(2,2,i) + grad2(2,2,i))/2.0d0
         gave3 = (grad(3,2,i) + grad2(3,2,i))/2.0d0
         errgrad(2,i) = abs(1.0d0 - h*(gave1*pert(1) + gave2*pert(2)
     1        + gave3*pert(3))/df)

         df = pot2(3,i) - pot(3,i)
         gave1 = (grad(1,3,i) + grad2(1,3,i))/2.0d0
         gave2 = (grad(2,3,i) + grad2(2,3,i))/2.0d0
         gave3 = (grad(3,3,i) + grad2(3,3,i))/2.0d0
         errgrad(3,i) = abs(1.0d0 - h*(gave1*pert(1) + gave2*pert(2)
     1        + gave3*pert(3))/df)

         errmax = max(errmax,errgrad(1,i))
         errmax = max(errmax,errgrad(2,i))
         errmax = max(errmax,errgrad(3,i))

      enddo

c      call prin2('err grad (just stokeslet)*',errgrad,3*nt)

      if (errmax .lt. 1d-6) ipass(1) = 1

c     test gradient of stokeslet and stresslet type I formula

      do i = 1,nt
         pre(i) = 0
         pot(1,i) = 0
         pot(2,i) = 0
         pot(3,i) = 0
         grad(1,1,i) = 0
         grad(2,1,i) = 0
         grad(3,1,i) = 0
         grad(1,2,i) = 0
         grad(2,2,i) = 0
         grad(3,2,i) = 0
         grad(1,3,i) = 0
         grad(2,3,i) = 0
         grad(3,3,i) = 0
         pre2(i) = 0
         pot2(1,i) = 0
         pot2(2,i) = 0
         pot2(3,i) = 0
         grad2(1,1,i) = 0
         grad2(2,1,i) = 0
         grad2(3,1,i) = 0
         grad2(1,2,i) = 0
         grad2(2,2,i) = 0
         grad2(3,2,i) = 0
         grad2(1,3,i) = 0
         grad2(2,3,i) = 0
         grad2(3,3,i) = 0
      enddo

      errmax = 0

      istress = 1
      call st3ddirectstokstrsg(nd1,source,stoklet,istress,
     1     strslet,strsvec,ns,targ,nt,pot,pre,grad,thresh)
      call st3ddirectstokstrsg(nd1,source,stoklet,istress,
     1     strslet,strsvec,ns,targ2,nt,pot2,pre2,grad2,thresh)

      do i = 1,nt
         df = pot2(1,i) - pot(1,i)
         gave1 = (grad(1,1,i) + grad2(1,1,i))/2.0d0
         gave2 = (grad(2,1,i) + grad2(2,1,i))/2.0d0
         gave3 = (grad(3,1,i) + grad2(3,1,i))/2.0d0
         errgrad(1,i) = abs(1.0d0 - h*(gave1*pert(1) + gave2*pert(2)
     1        + gave3*pert(3))/df)

         df = pot2(2,i) - pot(2,i)
         gave1 = (grad(1,2,i) + grad2(1,2,i))/2.0d0
         gave2 = (grad(2,2,i) + grad2(2,2,i))/2.0d0
         gave3 = (grad(3,2,i) + grad2(3,2,i))/2.0d0
         errgrad(2,i) = abs(1.0d0 - h*(gave1*pert(1) + gave2*pert(2)
     1        + gave3*pert(3))/df)

         df = pot2(3,i) - pot(3,i)
         gave1 = (grad(1,3,i) + grad2(1,3,i))/2.0d0
         gave2 = (grad(2,3,i) + grad2(2,3,i))/2.0d0
         gave3 = (grad(3,3,i) + grad2(3,3,i))/2.0d0
         errgrad(3,i) = abs(1.0d0 - h*(gave1*pert(1) + gave2*pert(2)
     1        + gave3*pert(3))/df)

         errmax = max(errmax,errgrad(1,i))
         errmax = max(errmax,errgrad(2,i))
         errmax = max(errmax,errgrad(3,i))
      enddo

c      call prin2('err grad (stokeslet + type I stresslet)*',
c     1     errgrad,3*nt)

      if (errmax .lt. 1d-6) ipass(2) = 1

c
c     figure out Stokeslet - Laplace relations

      ndl = 4

      allocate(potl(ndl,nt),gradl(ndl,3,nt))
      allocate(charge(ndl,ns),dipvec(ndl,3,ns))

c     clear output vars (these are all add type routines)

      do i = 1,nt
         pre(i) = 0
         pot(1,i) = 0
         pot(2,i) = 0
         pot(3,i) = 0
         grad(1,1,i) = 0
         grad(2,1,i) = 0
         grad(3,1,i) = 0
         grad(1,2,i) = 0
         grad(2,2,i) = 0
         grad(3,2,i) = 0
         grad(1,3,i) = 0
         grad(2,3,i) = 0
         grad(3,3,i) = 0
         pre2(i) = 0
         pot2(1,i) = 0
         pot2(2,i) = 0
         pot2(3,i) = 0
         grad2(1,1,i) = 0
         grad2(2,1,i) = 0
         grad2(3,1,i) = 0
         grad2(1,2,i) = 0
         grad2(2,2,i) = 0
         grad2(3,2,i) = 0
         grad2(1,3,i) = 0
         grad2(2,3,i) = 0
         grad2(3,3,i) = 0
         do j = 1,ndl
            potl(j,i) = 0
            gradl(j,1,i) = 0
            gradl(j,2,i) = 0
            gradl(j,3,i) = 0
         enddo
      enddo

c     convert to equivalent vector of laplace charges

      do i = 1,ns
         do l = 1,3
            charge(l,i) = stoklet(l,i)/2
         enddo
         l = 4
         pl = stoklet(1,i)*source(1,i) + stoklet(2,i)*source(2,i) +
     1        stoklet(3,i)*source(3,i)
         charge(l,i) = pl/2
      enddo

      call l3ddirectcg(ndl,source,charge,ns,targ,nt,potl,gradl,thresh)

c     unpack laplace to stokes

      do i = 1,nt

         do l = 1,3
            pot2(l,i) = pot2(l,i) + potl(l,i)

            pot2(1,i) = pot2(1,i) - targ(l,i)*gradl(l,1,i)
            pot2(2,i) = pot2(2,i) - targ(l,i)*gradl(l,2,i)
            pot2(3,i) = pot2(3,i) - targ(l,i)*gradl(l,3,i)

            pre(i) = pre(i) + 2*gradl(l,l,i)
         enddo

         l = 4
         pot2(1,i) = pot2(1,i) + gradl(l,1,i)
         pot2(2,i) = pot2(2,i) + gradl(l,2,i)
         pot2(3,i) = pot2(3,i) + gradl(l,3,i)

      enddo

c     get stokes directly again

      call st3ddirectstokg(nd1,source,stoklet,
     1     ns,targ,nt,pot,pre,grad,thresh)

      errmax = 0
      valmax = 0

      do i = 1,nt
         valmax = max(valmax,abs(pot(1,i)))
         valmax = max(valmax,abs(pot(2,i)))
         valmax = max(valmax,abs(pot(3,i)))

         errmax = max(errmax,abs(pot(1,i)-pot2(1,i)))
         errmax = max(errmax,abs(pot(2,i)-pot2(2,i)))
         errmax = max(errmax,abs(pot(3,i)-pot2(3,i)))
      enddo

c      call prin2('pot *',pot,3*nt)
c      call prin2('pot2 *',pot2,3*nt)

      if (errmax .lt. 1d-6*valmax) ipass(3) = 1

c
c     figure out stresslet (type I) - Laplace relations

      ndl = 4

c     clear output vars (these are all add type routines)

      do i = 1,nt
         pre(i) = 0
         pot(1,i) = 0
         pot(2,i) = 0
         pot(3,i) = 0
         grad(1,1,i) = 0
         grad(2,1,i) = 0
         grad(3,1,i) = 0
         grad(1,2,i) = 0
         grad(2,2,i) = 0
         grad(3,2,i) = 0
         grad(1,3,i) = 0
         grad(2,3,i) = 0
         grad(3,3,i) = 0
         pre2(i) = 0
         pot2(1,i) = 0
         pot2(2,i) = 0
         pot2(3,i) = 0
         grad2(1,1,i) = 0
         grad2(2,1,i) = 0
         grad2(3,1,i) = 0
         grad2(1,2,i) = 0
         grad2(2,2,i) = 0
         grad2(3,2,i) = 0
         grad2(1,3,i) = 0
         grad2(2,3,i) = 0
         grad2(3,3,i) = 0
         do j = 1,ndl
            potl(j,i) = 0
            gradl(j,1,i) = 0
            gradl(j,2,i) = 0
            gradl(j,3,i) = 0
         enddo
      enddo

c     convert to equivalent vector of laplace charges

      do i = 1,ns
         dmu(1) = strslet(1,i)
         dmu(2) = strslet(2,i)
         dmu(3) = strslet(3,i)
         dnu(1) = strsvec(1,i)
         dnu(2) = strsvec(2,i)
         dnu(3) = strsvec(3,i)
         do l = 1,3
            charge(l,i) = stoklet(l,i)/2
            dipvec(l,1,i) = -(dmu(l)*dnu(1) + dmu(1)*dnu(l))/2
            dipvec(l,2,i) = -(dmu(l)*dnu(2) + dmu(2)*dnu(l))/2
            dipvec(l,3,i) = -(dmu(l)*dnu(3) + dmu(3)*dnu(l))/2
         enddo
         l = 4
         pl = stoklet(1,i)*source(1,i) + stoklet(2,i)*source(2,i) +
     1        stoklet(3,i)*source(3,i)
         charge(l,i) = pl/2

         pl = (dmu(1)*source(1,i) + dmu(2)*source(2,i)
     1        + dmu(3)*source(3,i))
         pv = (dnu(1)*source(1,i) + dnu(2)*source(2,i)
     1        + dnu(3)*source(3,i))

         dipvec(l,1,i) = -(dmu(1)*pv + dnu(1)*pl)/2
         dipvec(l,2,i) = -(dmu(2)*pv + dnu(2)*pl)/2
         dipvec(l,3,i) = -(dmu(3)*pv + dnu(3)*pl)/2

      enddo

      call l3ddirectcdg(ndl,source,charge,dipvec,ns,targ,nt,potl,gradl,
     1     thresh)

c     unpack laplace to stokes

      do i = 1,nt

         do l = 1,3
            pot2(l,i) = pot2(l,i) + potl(l,i)

            pot2(1,i) = pot2(1,i) - targ(l,i)*gradl(l,1,i)
            pot2(2,i) = pot2(2,i) - targ(l,i)*gradl(l,2,i)
            pot2(3,i) = pot2(3,i) - targ(l,i)*gradl(l,3,i)

            pre(i) = pre(i) + 2*gradl(l,l,i)
         enddo

         l = 4
         pot2(1,i) = pot2(1,i) + gradl(l,1,i)
         pot2(2,i) = pot2(2,i) + gradl(l,2,i)
         pot2(3,i) = pot2(3,i) + gradl(l,3,i)

      enddo

c     get stokes directly again

      istress = 1
      nd1 = 1
      call st3ddirectstokstrsg(nd1,source,stoklet,istress,
     1     strslet,strsvec,ns,targ,nt,pot,pre,grad,thresh)

      errmax = 0
      valmax = 0

      do i = 1,nt
         valmax = max(valmax,abs(pot(1,i)))
         valmax = max(valmax,abs(pot(2,i)))
         valmax = max(valmax,abs(pot(3,i)))

         errmax = max(errmax,abs(pot(1,i)-pot2(1,i)))
         errmax = max(errmax,abs(pot(2,i)-pot2(2,i)))
         errmax = max(errmax,abs(pot(3,i)-pot2(3,i)))
      enddo

c      call prin2('pot *',pot,3*nt)
c      call prin2('pot2 *',pot2,3*nt)

      if (errmax .lt. 1d-6*valmax) ipass(4) = 1

      isum = 0
      do i=1,ntest
        isum = isum+ipass(i)
      enddo

      write(*,'(a,i1,a,i1,a)') 'Successfully completed ',isum,
     1   ' out of ',ntest,' tests in stokkernels testing suite'
      write(33,'(a,i1,a,i1,a)') 'Successfully completed ',isum,
     1   ' out of ',ntest,' tests in stokkernels testing suite'
      close(33)

      stop
      end
c
c
c
c
c
c
      subroutine errprint(pot,opot,fld,ofld,errs)
      implicit real *8 (a-h,o-z)
      real *8 pot,opot,fld(3),ofld(3)
      real *8 errs(2)
 1000  format(4D15.5)
      err = 0
      ddd = 0
      err = err + abs(fld(1)-ofld(1))**2
      err = err + abs(fld(2)-ofld(2))**2
      err = err + abs(fld(3)-ofld(3))**2
      ddd = ddd + abs(ofld(1))**2
      ddd = ddd + abs(ofld(2))**2
      ddd = ddd + abs(ofld(3))**2
      err = sqrt(err)
      ddd = sqrt(ddd)

      err1 = abs(pot-opot)/abs(opot)
      write(*,'(a,e11.4,a,e11.4)')
     1     'pot error=',err1,'   grad error=',err/ddd

      errs(1) = err1
      errs(2) = err/ddd

      return
      end
c


PROGRAM TestSolverFromFile
    !     Solve CME of the toggle switch
    USE StateSpace
    USE KrylovSolver
    IMPLICIT NONE

    INTERFACE
        DOUBLE PRECISION FUNCTION clock()
        END FUNCTION clock
    END INTERFACE

    DOUBLE PRECISION :: t = 1000.0d0, exp_tol = 1.0d-8, fsp_tol = 1.0d-6
    TYPE (cme_model) :: model
    TYPE (finite_state_projection) :: fsp_in, fsp
    DOUBLE PRECISION, DIMENSION(nmax) :: p0, p
    DOUBLE PRECISION :: tic
    INTEGER :: i

    CALL RANDOM_SEED()

    CALL model%load('toggle_model.input')

    ! initialize the attributes of the fsp based on the underlying model
    CALL fsp_in%CREATE(model)
    CALL fsp%CREATE(model)

    fsp_in%size = 1
    fsp_in%state(:, 1) = [0, 0]
    p0(1) = 1.0
    fsp_in%vector = p0
    CALL model%reset_parameters([1.0d0, 100.0d0, 1.0d0, 1.0d0, 100.0d0, 1.0d0])
    fsp = fsp_in
    tic = clock()

    CALL cme_solve(model, t, fsp_in, fsp, 1.0d-4, 1.0d-10, verbosity = 1)

    WRITE(*, fmt = 200) clock() - tic
200 FORMAT ('Elapsed time=', F10.2)

    CALL fsp%clear()
    CALL fsp_in%clear()
END PROGRAM TestSolverFromFile


Subroutine set_params(pa)

use parameters_site
use parameters_plant
implicit none
real :: pa(120) ! The length of pa() should be at least as high as the number of parameters

! Initial constants
LOG10CLVI  = pa(1)
LOG10CRESI = pa(2)
LOG10CRTI  = pa(3)
CSTI	   = pa(4)
LOG10LAII  = pa(5)
PHENI	   = pa(6)
TILTOTI	   = pa(7)
FRTILGI	   = pa(8)
LT50I      = pa(9)

! Process parameters
CLAIV     = pa(10)
COCRESMX  =	pa(11)
CSTAVM	  = pa(12)
DAYLB	  =	pa(13)
DAYLP	  =	pa(14)
DLMXGE	  = pa(15)
FSLAMIN   = pa(16)
FSMAX     = pa(17)
HAGERE    =	pa(18)
K         =	pa(19)
LAICR	  = pa(20)
LAIEFT    = pa(21)
LAITIL	  =	pa(22)
LFWIDG	  =	pa(23)
LFWIDV	  = pa(24)
NELLVM	  = pa(25)
PHENCR    = pa(26)
PHY	      =	pa(27)
RDRSCO	  =	pa(28)
RDRSMX	  = pa(29)
RDRTEM    = pa(30)
RGENMX	  =	pa(31)
ROOTDM	  =	pa(32)
RRDMAX	  = pa(33)
RUBISC    = pa(34)
SHAPE	  =	pa(35)
SIMAX1T	  =	pa(36)
SLAMAX    = pa(37)
TBASE     = pa(38)
TCRES     = pa(39)
TOPTGE	  =	pa(40)
TRANCO	  = pa(41)
YG        = pa(42)

LAT       = pa(43)
WCI       = pa(44)
FWCAD     = pa(45)
FWCWP     = pa(46)
FWCFC     = pa(47)
FWCWET    = pa(48)
WCST      = pa(49)
WpoolMax  = pa(50)

Dparam	     = pa(51)
FGAS	     = pa(52)
FO2MX	     = pa(53)
gamma	     = pa(54)
Hparam	     = pa(55)
KRDRANAER    = pa(56)
KRESPHARD    = pa(57)
KRSR3H	     = pa(58)
KRTOTAER     = pa(59)
KSNOW	     = pa(60)
LAMBDAsoil   = pa(61)
LDT50A	     = pa(62)
LDT50B	     = pa(63)
LT50MN	     = pa(64)
LT50MX	     = pa(65)
RATEDMX	     = pa(66)
reHardRedDay = pa(67)
RHOnewSnow	 = pa(68)
RHOpack	     = pa(69)
SWret	     = pa(70)
SWrf	     = pa(71)
THARDMX	     = pa(72)
TmeltFreeze	 = pa(73)
TrainSnow	 = pa(74)
TsurfDiff	 = pa(75)
KLUETILG	 = pa(76)
FRTILGG1I	 = pa(77)
DAYLG1G2     = pa(78)
RGRTG1G2     = pa(79)
RDRTMIN      = pa(80)
TVERN        = pa(81)

CLITT0    = pa( 82) ! (g C m-2)    Initial C in litter
CSOM0     = pa( 83) ! (g C m-2)    Initial C in OM
CNLITT0   = pa( 84) ! (g C g-1 N)  Initial C/N ratio of litter
CNSOMF0   = pa( 85) ! (g C g-1 N)  Initial C/N ratio of fast-decomposing OM
CNSOMS0   = pa( 86) ! (g C g-1 N)  Initial C/N ratio of slowly decomposing OM
FCSOMF0   = pa( 87) ! (-)          Initial C in fast-decomposing OM as a fraction of total OM
FLITTSOMF = pa( 88) ! (-)          Fraction of decomposing litter that becomes OM
FSOMFSOMS = pa( 89) ! (-)          Fraction of decomposing 'fast' OM that becomes slowly decomposing OM
RNLEACH   = pa( 90) ! (-)          Mineral N concentration of drainage water as a ratio of that in soil water
KNEMIT    = pa( 91) ! (d-1)        Max. relative emission rate of soil mineral N
NMIN0     = pa( 92) ! (g N m-2)    Initial mineral N
TCLITT    = pa( 93) ! (d)          Residence time of litter
TCSOMF    = pa( 94) ! (d)          Residence time of fast-decomposing OM
TCSOMS    = pa( 95) ! (d)          Residence time of slowly decomposing OM
TMAXF     = pa( 96) ! (degC)       Temperature at which soil decomposition (fTsoil) is max.
TSIGMAF   = pa( 97) ! (degC)       Tolerance of soil decomposition for suboptimal temperature
RFN2O     = pa( 98) ! (-)          Sensitivity of the N2O/NO emission ratio to extreme values of water-filled pore space
WFPS50N2O = pa( 99) ! (-)          Water-filled pore space at which the N2O and NO emission rates are equal

! Parameters for N-processes
NCSHMAX   = pa(100) ! (g N g-1 C)
NCR       = pa(101) ! (g N g-1 C)

! Senescence of roots and stubble
RDRROOT   = pa(102)
RDRSTUB   = pa(103)

! Parameter for sensitivity analysis of fertilisation
NFERTMULT = pa(104) ! Multiplication factor for changing fertlisation (default = 1)

! Additional parameters for N-processes
FNCGSHMIN = pa(105)
TCNSHMOB  = pa(106)
TCNUPT    = pa(107)

F_DIGEST_WALL_FMIN = pa(108)
F_DIGEST_WALL_MAX  = pa(109)
F_WALL_LV_FMIN     = pa(110)
F_WALL_LV_MAX      = pa(111)
F_WALL_ST_FMIN     = pa(112)
F_WALL_ST_MAX      = pa(113)

! Parameter transformations
CLVI  = 10**LOG10CLVI
CRESI = 10**LOG10CRESI
CRTI  = 10**LOG10CRTI
LAII  = 10**LOG10LAII

WCAD  = FWCAD  * WCST
WCWP  = FWCWP  * WCST
WCFC  = FWCFC  * WCST
WCWET = FWCWET * WCST

return
end


module mod_monolis_solver_PipeCG
  use mod_monolis_prm
  use mod_monolis_com
  use mod_monolis_mat
  use mod_monolis_precond
  use mod_monolis_matvec
  use mod_monolis_linalg
  use mod_monolis_linalg_util
  use mod_monolis_converge

  implicit none

contains

  subroutine monolis_solver_PipeCG(monoPRM, monoCOM, monoMAT)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kind=kint) :: N, NP, NDOF, NNDOF
    integer(kind=kint) :: i, iter, iter_RR
    !integer(kind=kint) :: requests(1)
    !integer(kind=kint) :: statuses(monolis_status_size,1)
    real(kind=kdouble) :: alpha, alpha1, beta, gamma, gamma1, delta
    real(kind=kdouble) :: buf(3), CG(3), B2, R2
    real(kind=kdouble), allocatable :: R(:), U(:), V(:), Q(:), P(:), Z(:), L(:), M(:), S(:)
    real(kind=kdouble), pointer :: B(:), X(:)
    logical :: is_converge

    N     = monoMAT%N
    NP    = monoMAT%NP
    NDOF  = monoMAT%NDOF
    NNDOF = N*NDOF
    X => monoMAT%X
    B => monoMAT%B
    iter_RR = 50

    if(monoPRM%is_init_x) X = 0.0d0

    allocate(R(NDOF*NP), source = 0.0d0)
    allocate(U(NDOF*NP), source = 0.0d0)
    allocate(V(NDOF*NP), source = 0.0d0)
    allocate(Q(NDOF*NP), source = 0.0d0)
    allocate(P(NDOF*NP), source = 0.0d0)
    allocate(Z(NDOF*NP), source = 0.0d0)
    allocate(L(NDOF*NP), source = 0.0d0)
    allocate(M(NDOF*NP), source = 0.0d0)
    allocate(S(NDOF*NP), source = 0.0d0)

    call monolis_set_converge(monoPRM, monoCOM, monoMAT, B, B2, is_converge, monoPRM%tdotp, monoPRM%tcomm_dotp)
    if(is_converge) return
    call monolis_residual(monoCOM, monoMAT, X, B, R, monoPRM%tspmv, monoPRM%tcomm_spmv)
    call monolis_inner_product_R(monoCOM, N, NDOF, B, B, B2, monoPRM%tdotp, monoPRM%tcomm_dotp)
    call monolis_precond_apply(monoPRM, monoCOM, monoMAT, R, U)
    call monolis_matvec(monoCOM, monoMAT, U, V, monoPRM%tspmv, monoPRM%tcomm_spmv)

    gamma = 1.0d0
    alpha = 1.0d0

    do iter = 1, monoPRM%maxiter
      call monolis_inner_product_R_local(monoCOM, N, NDOF, R, U, CG(1))
      call monolis_inner_product_R_local(monoCOM, N, NDOF, V, U, CG(2))
      call monolis_inner_product_R_local(monoCOM, N, NDOF, R, R, CG(3))
      call monolis_allreduce_R(3, CG, monolis_sum, monoCOM%comm)

      call monolis_precond_apply(monoPRM, monoCOM, monoMAT, V, M)
      call monolis_matvec(monoCOM, monoMAT, M, L, monoPRM%tspmv, monoPRM%tcomm_spmv)

      gamma1 = 1.0d0/gamma
      alpha1 = 1.0d0/alpha

      !call monolis_wait(requests, statuses)
      !gamma = buf(1)
      !delta = buf(2)
      !R2    = buf(3)
      gamma = CG(1)
      delta = CG(2)
      R2    = CG(3)

      call monolis_check_converge_2(monoPRM, monoCOM, monoMAT, R2, B2, iter, is_converge)
      if(is_converge) exit

      if(1 < iter)then
        beta  = gamma*gamma1
        alpha = gamma/(delta-beta*gamma*alpha1)
      else
        alpha = gamma/delta
        beta  = 0.0d0
      endif

      do i = 1, NNDOF
         Z(i) = L(i) + beta*Z(i)
         Q(i) = M(i) + beta*Q(i)
         S(i) = V(i) + beta*S(i)
         P(i) = U(i) + beta*P(i)
      enddo

      if(mod(iter, iter_RR) == 0)then
        call monolis_vec_AXPY(N, NDOF, alpha, P, X, X)
        call monolis_residual(monoCOM, monoMAT, X, B, R, monoPRM%tspmv, monoPRM%tcomm_spmv)
        call monolis_precond_apply(monoPRM, monoCOM, monoMAT, R, U)
        call monolis_matvec(monoCOM, monoMAT, U, V, monoPRM%tspmv, monoPRM%tcomm_spmv)
      else
        do i = 1, NNDOF
          R(i) = R(i) - alpha*S(i)
          U(i) = U(i) - alpha*Q(i)
          V(i) = V(i) - alpha*Z(i)
          X(i) = X(i) + alpha*P(i)
        enddo
      endif
    enddo

    call monolis_update_R(monoCOM, NDOF, X, monoPRM%tcomm_spmv)

    deallocate(R)
    deallocate(U)
    deallocate(V)
    deallocate(Q)
    deallocate(P)
    deallocate(Z)
    deallocate(L)
    deallocate(M)
    deallocate(S)
  end subroutine monolis_solver_PipeCG

end module mod_monolis_solver_PipeCG