! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       PROGRAM  ASCOT 2014.440 (ver.4.40)                       @@ !
! @@     "Abinitio Simulation Code for Quantum Transport"           @@ !
! @@                                                                @@ !
! @@                                                                @@ !
! @@  AUTHOR(S): Naoki WATANABE, Nobutaka NISHIKAWA (Mizuho I.R.)   @@ !
! @@             Hisashi KONDO (Univ. Tokyo)                        @@ !
! @@                                                09/May/2014     @@ !
! @@                                                                @@ !
! @@  Contact address: Phase System Consortium                      @@ !
! @@                                                                @@ !
! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !

subroutine DOS__calc( vdos, vE, n_npao )
  use ac_misc_module

  implicit none
  integer, intent(in) :: n_npao
  real(8), intent(out) :: vdos(Param%DOS%Ne)
  real(8), intent(in)  :: vE(Param%DOS%Nka, Param%DOS%Nkb, Param%DOS%Nkc, n_npao )
  integer :: b

  vdos(:) = 0.d0

  select case( Param%DOS%method )
  case('boxes','histogram')
     call DOS__calc_Histogram  ( vdos, vE, n_npao )
  case('gaussian')
     call DOS__calc_Gaussian   ( vdos, vE, n_npao )
  case('tetrahedron')
     call DOS__calc_Tetrahedron( vdos, vE, n_npao )
  end select

  vdos(:) = vdos(:) * 1.0/Param%DOS%nK

  return
end subroutine DOS__calc

subroutine DOS__calc_Histogram( vdos, vE, n_npao )
  use ac_misc_module
  implicit none
  integer, intent(in) :: n_npao
  real(8), intent(out) :: vdos(Param%DOS%Ne)
  real(8), intent(in)  :: vE(Param%DOS%Nka, Param%DOS%Nkb, Param%DOS%Nkc, n_npao )

  integer :: ika, ikb, ikc, m, b
  real(8) :: E
  real(8) :: dos,pdbe_t

  do m=1, n_npao
     do ikc=1, Param%DOS%Nkc
        do ikb=1, Param%DOS%Nkb
           do ika=1, Param%DOS%Nka
              E = vE(ika,ikb,ikc,m)
              call Param__DOS__binIndex(b,E)

              if( 0<b .and. b<=Param%DOS%Ne ) then
                 call Param__DOS__binEnergy(pdbe_t,b)
                 call DOS__histogram( dos, pdbe_t, E, Param%DOS%dE )
                 vdos(b) = vdos(b) + dos
              end if
           end do
        end do
     end do
  end do

  return
end subroutine DOS__calc_Histogram

subroutine DOS__calc_Gaussian( vdos, vE, n_npao )
  use ac_misc_module
  implicit none
  integer, intent(in) :: n_npao
  real(8), intent(out) :: vdos(Param%DOS%Ne)
  real(8), intent(in)  :: vE(Param%DOS%Nka, Param%DOS%Nkb, Param%DOS%Nkc, n_npao)

  integer :: ika, ikb, ikc, m, b, bs, be
  real(8) :: E
  real(8) :: dos,pdbe_t

  do m=1, n_npao
     do ikc=1, Param%DOS%Nkc
        do ikb=1, Param%DOS%Nkb
           do ika=1, Param%DOS%Nka
              E = vE(ika,ikb,ikc,m)
              do b=1, Param%DOS%Ne
                 if( 0<b .and. b<=Param%DOS%Ne ) then
                    call Param__DOS__binEnergy(pdbe_t,b)
                    call DOS__gaussian( dos, pdbe_t, E, Param%DOS%GB )
                    vdos(b) = vdos(b) + dos
                 end if
              end do
           end do
        end do
     end do
  end do

  return
end subroutine DOS__calc_Gaussian

subroutine DOS__calc_Tetrahedron( vdos, vE, n_npao )
  use ac_misc_module
  implicit none
  integer, intent(in) :: n_npao
  real(8), intent(out) :: vdos(Param%DOS%Ne)
  real(8), intent(in)  :: vE(Param%DOS%Nka, Param%DOS%Nkb, Param%DOS%Nkc, n_npao )

  integer :: ika, ikb, ikc, m, t, n, l
  integer :: jka, jkb, jkc, j
  integer :: b, bs, be

  real(8) :: E(4), work
  real(8) :: dos,pdbe_t

  integer       :: index(4,6)
  index(:,1) = (/ 0,2,1,5 /)
  index(:,2) = (/ 3,1,2,5 /)
  index(:,3) = (/ 0,4,2,5 /)
  index(:,4) = (/ 6,2,4,5 /)
  index(:,5) = (/ 3,2,7,5 /)
  index(:,6) = (/ 6,7,2,5 /)

  do m=1, n_npao
     do ikc=1, Param%DOS%Nkc
        do ikb=1, Param%DOS%Nkb
           do ika=1, Param%DOS%Nka
              do t=1, 6
                 do n=1, 4
                    j = index(n,t)
                    !!                    jka = mod(ika+mod(j/4,2),Param%DOS%Nka)
                    !!                    jkb = mod(ikb+mod(j/2,2),Param%DOS%Nkb)
                    !!                    jkc = mod(ikc+mod(j/1,2),Param%DOS%Nkc)
                    jka = modp(ika+mod(j/4,2),Param%DOS%Nka)
                    jkb = modp(ikb+mod(j/2,2),Param%DOS%Nkb)
                    jkc = modp(ikc+mod(j/1,2),Param%DOS%Nkc)

                    E(n)  = vE(jka,jkb,jkc,m)
                 end do

                 do n=1, 4
                    do l=n+1, 4
                       if( E(n) > E(l) ) then
                          work = E(n)
                          E(n) = E(l)
                          E(l) = work
                       end if
                    end do
                 end do

                 call Param__DOS__binIndex(bs,E(1))
                 call Param__DOS__binIndex(be,E(4))

                 do b=bs, be
                    if( 0<b .and. b<=Param%DOS%Ne ) then
                       call Param__DOS__binEnergy(pdbe_t,b)
                       call DOS__tetrahedron( dos, pdbe_t, E )
                       vdos(b) = vdos(b) + dos
                    end if
                 end do

              end do
           end do
        end do
     end do
  end do

  return
end subroutine DOS__calc_Tetrahedron

subroutine DOS__histogram( dos, E, E1, Esigma )
  use ac_misc_module

  implicit none
  real(8), intent(in) :: E, E1, Esigma
  real(8), intent(out) :: dos

  if( E1-0.5*Esigma/2<=E .and. E<E1+0.5*Esigma ) then
     dos = 1.0/Esigma
  else
     dos = 0.0
  end if

  return
end subroutine DOS__histogram

subroutine DOS__gaussian( dos, E, E1, Esigma )
  use ac_misc_module

  implicit none
  real(8), intent(in) :: E, E1, Esigma
  real(8), intent(out) :: dos

  dos = 0.5*M_SQRT1_2*M_2_SQRTPI/Esigma*exp(-0.5*(E-E1)**2/Esigma**2)

  return
end subroutine DOS__gaussian

subroutine DOS__tetrahedron( dos, E, vE )
  use ac_misc_module

  implicit none
  real(8), intent(in) :: E, vE(4)
  real(8), intent(out) :: dos

  if( E < vE(1) ) then
     dos = 0.d0
  else if( vE(1)<=E .and. E<vE(2) ) then
     dos = &
          + 0.5*(E-vE(1))*(E-vE(1))/((vE(2)-vE(1))*(vE(3)-vE(1)))/(vE(4)-vE(1))
  else if( vE(2)<=E .and. E<vE(3) ) then
     dos = &
          + 0.5*(E-vE(1))*(E-vE(1))/((vE(2)-vE(1))*(vE(3)-vE(1)))/(vE(4)-vE(1)) &
          - 0.5*(E-vE(2))*(E-vE(2))/((vE(2)-vE(1))*(vE(3)-vE(2)))/(vE(4)-vE(2))
  else if( vE(3)<=E .and. E<vE(4) ) then
     dos = &
          + 0.5*(E-vE(4))*(E-vE(4))/((vE(4)-vE(2))*(vE(4)-vE(3)))/(vE(4)-vE(1))
  else
     dos = 0.d0
  end if

  return
end subroutine DOS__tetrahedron
