!============================================================================
!
! Routines:
!
! (1) checkgriduniformity()  Originally by JRD  Last Modified: 3/16/2011 (das)
!
!   To obtain the correct result for integrals in reciprocal space, the k+G
!   sampling should be similar in each direction. This routine determines the
!   sampling and writes a warning if it is too non-uniform.
!
!   gsm: xgrid = sig%qgrid in Sigma/main.f90, kp%kgrid in BSE/intkernel.f90
!
!   Truncation:
!   icutv = 0, none        : 0D truncation, compare x, y, and z
!   icutv = 2, spherical   : 3D truncation, no relevant directions
!   icutv = 4, cell_wire   : 2D truncation, z is uniform by itself automatically
!   icutv = 5, cell_box    : 3D truncation, no relevant directions
!   icutv = 6, cell_slab   : 1D truncation, compare x and y
!
!============================================================================

#include "f_defs.h"

module checkgriduniformity_m

  use global_m
  implicit none

  private

  public :: checkgriduniformity

contains

subroutine checkgriduniformity(xgrid, crys, icutv)
  integer, intent(in) :: xgrid(3)
  type(crystal), intent(in) :: crys
  integer, intent(in) :: icutv !< code for type of truncation

  real(DP), parameter :: TOL_Ratio = 2.0d0

  integer :: maxdir
  integer :: ii, jj, order(3)
  real(DP) :: bb(3, 3), blen(3)
  real(DP) :: cc(3, 3), clen(3)
  character(len=80) :: tmpstr
  character(len=12) :: fmt

  PUSH_SUB(checkgriduniformity)

  if(icutv == 0) then    
    maxdir = 3
  else if(icutv == 6) then
    maxdir = 2
  else
    write(6,'(a)') "No k+G sampling uniformity to check, given selected truncation scheme."
    POP_SUB(checkgriduniformity)
    return
  endif

  ! compute minicell lattice vectors
  do jj = 1, 3
    bb(:, jj) = crys%bvec(:, jj) / dble(xgrid(jj))
    blen(jj) = sqrt(sum(bb(1:3, jj)**2))
  enddo

  ! determine which vector is shortest, middle, and longest
  order(1)      = minloc(blen(1:maxdir), 1)
  order(maxdir) = maxloc(blen(1:maxdir), 1)
  if(order(maxdir) == order(1)) then
    ! all vectors must be of the same length
    ! just make an arbitrary choice, the order(:) elements must all be different
    order(1) = 1
    order(maxdir) = maxdir
  endif
  if(maxdir > 2) then
    do ii = 1, 3
      if(ii /= order(1) .and. ii /= order(3)) order(2) = ii
    enddo
  endif

  ! Gram-Schmidt orthogonalization
  ! go from shortest to longest, since orthogonalization always shortens
  cc(1:3, 1) = bb(1:3, order(1))
  if(maxdir > 2) then
    cc(1:3, 2) = bb(1:3, order(2)) - cc(1:3, 1) * sum(cc(1:3, 1) * bb(1:3, order(2))) / sum(cc(1:3, 1)**2)
  endif
  cc(1:3, maxdir) = bb(1:3, order(maxdir)) - &
    cc(1:3, maxdir - 1) * sum(cc(1:3, maxdir - 1) * bb(1:3, order(maxdir))) / sum(cc(1:3, maxdir - 1)**2)

  do jj = 1, maxdir
    clen(jj) = sqrt(sum(cc(1:3, jj)**2))
  enddo

  write(fmt,'(a,i1,a)') "(a,", maxdir, "f10.6,a)"
  write(tmpstr, fmt) "k+G sampling: ", clen(1:maxdir), " (reciprocal lattice units)"

  if (maxval(clen(1:maxdir)) / minval(clen(1:maxdir)) .gt. TOL_Ratio) then
    write(0,'(a)') TRUNC(tmpstr)
    write(0,'(a)') "WARNING: detected non-uniform k+G sampling, may cause strange results."
    write(0,'(a)') "You should verify your answer with different cell-averaging cutoffs."
  else
    write(6,'(1x,a)') TRUNC(tmpstr)
  endif

  ! Note: for a cell with a small angle between two equivalent lattice vectors, it will
  ! be impossible to satisfy this criterion without using a different k-grid in those
  ! two equivalent directions, breaking crystal symmetry and possibly causing other problems.
  ! It is unclear what should be done in such a case. --DAS

  POP_SUB(checkgriduniformity)

  return

end subroutine checkgriduniformity

end module checkgriduniformity_m
