!=======================================================================
!
!  PROGRAM  PHASE/0 2019.02 ($Rev: 570 $)
!
!  SUBROUINE:  crngabc4, setglist4, zf_list_s, calc_phase2, calc_phase
!              substitute_il3
!
!  AUTHOR(S): T. Yamasaki   August/20/2003
!  
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
!=======================================================================
!
!     The original version of this set of the computer programs "PHASE"
!  was developed by the members of the Theory Group of Joint Research
!  Center for Atom Technology (JRCAT), based in Tsukuba, in the period
!  1993-2001.
!
!     Since 2002, this set has been tuned and new functions have been
!  added to it as a part of the national project "Frontier Simulation 
!  Software for Industrial Science (FSIS)",  which is supported by
!  the IT program of the Ministry of Education, Culture, Sports,
!  Science and Technology (MEXT) of Japan. 
!     Since 2006, this program set has been developed as a part of the
!  national project "Revolutionary Simulation Software (RSS21)", which
!  is supported by the next-generation IT program of MEXT of Japan.
!   Since 2013, this program set has been further developed centering on PHASE System
!  Consortium.
!   The activity of development of this program set has been supervised by Takahisa Ohno.
!
! $Id: b_Electronic_Structure.F90 570 2017-04-21 20:34:50Z yamasaki $
subroutine substitute_il3(n,il3)
  implicit none
  integer, intent(in)               :: n
  integer, intent(out), dimension(n) :: il3

  integer i, l
  l = 0
  do i = 1, n
     if(i > (l+1)**2) l = l + 1
     il3(i) = l
  end do
end subroutine substitute_il3

subroutine calc_phase(ia,natm,pos,kgp,ibaik,ngabc,kg1,nbase,kd,zfcos,zfsin)
  use m_Const_Parameters, only : PAI2, DP
  implicit none
  integer, intent(in)                          :: ia   ! #atom
  integer, intent(in)                          :: natm ! 1st dim. of pos
  real(kind=DP), intent(in), dimension(natm,3) :: pos  ! positions of atoms
  integer, intent(in)                          :: kgp  ! 1st dim. of ngabc
  integer, intent(in)                          :: ibaik! range of operation
  integer, intent(in), dimension(kgp,3)        :: ngabc! g-vectors
  integer, intent(in)                          :: kg1  ! 1st dim. of nbase
  integer, intent(in), dimension(kg1)          :: nbase! pointer to a G-vector set
  integer, intent(in)                          :: kd   ! dim. of zfcos, zfsin
  real(kind=DP), intent(out), dimension(kd)    :: zfcos, zfsin ! phase

  integer       :: i, nb
  real(kind=DP) ::  fx, fy, fz, ph
  fx = pos(ia,1)*PAI2
  fy = pos(ia,2)*PAI2
  fz = pos(ia,3)*PAI2
#ifdef NEC_TUNE_SMP
!CDIR INNER
#endif
  do i = 1,ibaik
     nb = nbase(i)
     ph = ngabc(nb,1)*fx+ngabc(nb,2)*fy+ngabc(nb,3)*fz
     zfcos(i) = dcos(ph)
     zfsin(i) = dsin(ph)
  end do
end subroutine calc_phase

!$$#ifdef PARA3D
subroutine calc_phasek_b_3D(natm,pos,n_ialist0,ia_list,kgp,ist,ien,ngabc,kg1,nbase,kd_adj,zfcos_x,zfsin_x)
  use m_Const_Parameters, only : PAI2, DP
  implicit none
  integer, intent(in)                          :: natm       ! 1st dim. of pos
  real(kind=DP), intent(in), dimension(natm,3) :: pos        ! positions of atoms
  integer, intent(in)                          :: n_ialist0  ! #atom
  integer, intent(in), dimension(n_ialist0)    :: ia_list
  integer, intent(in)                          :: kgp        ! 1st dim. of ngabc
  integer, intent(in)                          :: ist, ien   ! range of operation
  integer, intent(in), dimension(kgp,3)        :: ngabc      ! g-vectors
  integer, intent(in)                          :: kg1        ! 1st dim. of nbase
  integer, intent(in), dimension(kg1)          :: nbase      ! pointer to a G-vector set
  integer, intent(in)                          :: kd_adj     ! dim. of zfcos, zfsin
  real(kind=DP), intent(out), dimension(kd_adj,n_ialist0)   :: zfcos_x, zfsin_x ! phase

  integer       :: i, nb, ia,iap, iadd
  real(kind=DP) ::  fx, fy, fz, ph

#ifdef VPP
*vocl loop, unroll(4)
#endif
#ifdef HIUX
*poption parallel
#endif
#ifdef NEC_TUNE2
!CDIR OUTERUNROLL=4
#endif
#ifdef NEC_TUNE_SMP
!CDIR SELECT(CONCUR)
#endif
  do iap = 1, n_ialist0
     ia = ia_list(iap)
     fx = pos(ia,1)*PAI2
     fy = pos(ia,2)*PAI2
     fz = pos(ia,3)*PAI2
     do i = ist, ien
        iadd = i - ist + 1
        nb = nbase(i)
        ph = ngabc(nb,1)*fx+ngabc(nb,2)*fy+ngabc(nb,3)*fz
        zfcos_x(iadd,iap) = dcos(ph)
        zfsin_x(iadd,iap) = dsin(ph)
     end do
   end do
end subroutine calc_phasek_b_3D
!$$#endif

subroutine calc_phase2(natm,pos,ia,kgp,ngabc,ista_kngp,iend_kngp,zfcos,zfsin)
  use m_Const_Parameters, only : PAI2, DP
  implicit none
  integer, intent(in)                          :: natm ! 1st dim. of pos
  real(kind=DP), intent(in), dimension(natm,3) :: pos  ! positions of atoms
  integer, intent(in)                          :: ia   ! #atom
  integer, intent(in)                          :: kgp  ! range of operation
!  integer, intent(in), dimension(kgp,3)        :: ngabc! g-vectors
  integer, intent(in), dimension(ista_kngp:iend_kngp,3)        :: ngabc! g-vectors
  integer, intent(in)                          :: ista_kngp, iend_kngp
  real(kind=DP),intent(out),dimension(ista_kngp:iend_kngp) :: zfcos, zfsin ! phase

  integer       ::  i
  real(kind=DP) :: fx, fy, fz, ph
  integer       ::  iend  !mpi
  fx = pos(ia,1)*PAI2
  fy = pos(ia,2)*PAI2
  fz = pos(ia,3)*PAI2
  iend = iend_kngp
  if( iend_kngp > kgp ) iend = kgp
  if( ista_kngp <= iend ) then
#ifdef NEC_TUNE_SMP
!CDIR INNER
#endif
     do i = ista_kngp, iend  !for mp
        ph = ngabc(i,1)*fx+ngabc(i,2)*fy+ngabc(i,3)*fz
        zfcos(i) = dcos(ph)
        zfsin(i) = dsin(ph)
     end do
  endif
!xocl end spread
end subroutine calc_phase2

subroutine calc_phase_b(natm,pos,ia_list,n_ialist,kgp,ngabc,ista_kngp,iend_kngp,ista_kngp_adj,iend_kngp_adj,zfcos_x,zfsin_x)
  use m_Const_Parameters, only : PAI2, DP
  implicit none
  integer, intent(in) ::                          natm ! 1st dim. of pos
  real(kind=DP), intent(in), dimension(natm,3) :: pos  ! positions of atoms
  integer, intent(in) ::                          n_ialist ! #atom
  integer, intent(in), dimension(n_ialist) ::     ia_list(n_ialist) ! list of #atom
  integer, intent(in) ::                          kgp  ! range of operation
  integer, intent(in), dimension(kgp,3)        :: ngabc! g-vectors
  integer, intent(in)                          :: ista_kngp, iend_kngp, ista_kngp_adj, iend_kngp_adj
  real(kind=DP),intent(out),dimension(ista_kngp_adj:iend_kngp_adj,n_ialist) :: zfcos_x, zfsin_x ! phase

  integer       ::  i, ia, ip, is
  real(kind=DP) :: fx_1, fy_1, fz_1, ph_1, fx_2, fy_2, fz_2, ph_2, fx_3, fy_3, fz_3, ph_3, fx_4, fy_4, fz_4, ph_4
  integer       ::  iend  !mpi
  if(n_ialist >= 1) then
     fx_1 = pos(ia_list(1),1)*PAI2
     fy_1 = pos(ia_list(1),2)*PAI2
     fz_1 = pos(ia_list(1),3)*PAI2
  end if
  if(n_ialist >= 2) then
     fx_2 = pos(ia_list(2),1)*PAI2
     fy_2 = pos(ia_list(2),2)*PAI2
     fz_2 = pos(ia_list(2),3)*PAI2
  end if
  if(n_ialist >= 3) then
     fx_3 = pos(ia_list(3),1)*PAI2
     fy_3 = pos(ia_list(3),2)*PAI2
     fz_3 = pos(ia_list(3),3)*PAI2
  end if
  if(n_ialist >= 4) then
     fx_4 = pos(ia_list(4),1)*PAI2
     fy_4 = pos(ia_list(4),2)*PAI2
     fz_4 = pos(ia_list(4),3)*PAI2
  end if

  iend = iend_kngp
  if( iend_kngp > kgp ) iend = kgp
  if( ista_kngp <= iend ) then
     is = ista_kngp_adj - ista_kngp
     if(n_ialist == 1) then
!cdir parallel do private(i,ph_1,ip)
        do i = ista_kngp, iend  !for mp
           ph_1 = ngabc(i,1)*fx_1+ngabc(i,2)*fy_1+ngabc(i,3)*fz_1
           ip = i + is
           zfcos_x(ip,1) = dcos(ph_1)
           zfsin_x(ip,1) = dsin(ph_1)
        end do
     else if(n_ialist == 2) then
!cdir parallel do private(i,ph_1,ph_2,ip)
        do i = ista_kngp, iend  !for mp
           ph_1 = ngabc(i,1)*fx_1+ngabc(i,2)*fy_1+ngabc(i,3)*fz_1
           ph_2 = ngabc(i,1)*fx_2+ngabc(i,2)*fy_2+ngabc(i,3)*fz_2
           ip = i + is
           zfcos_x(ip,1) = dcos(ph_1)
           zfsin_x(ip,1) = dsin(ph_1)
           zfcos_x(ip,2) = dcos(ph_2)
           zfsin_x(ip,2) = dsin(ph_2)
        end do
     else if(n_ialist == 3) then
!cdir parallel do private(i,ph_1,ph_2,ph_3,ip)
        do i = ista_kngp, iend  !for mp
           ph_1 = ngabc(i,1)*fx_1+ngabc(i,2)*fy_1+ngabc(i,3)*fz_1
           ph_2 = ngabc(i,1)*fx_2+ngabc(i,2)*fy_2+ngabc(i,3)*fz_2
           ph_3 = ngabc(i,1)*fx_3+ngabc(i,2)*fy_3+ngabc(i,3)*fz_3
           ip = i + is
           zfcos_x(ip,1) = dcos(ph_1)
           zfsin_x(ip,1) = dsin(ph_1)
           zfcos_x(ip,2) = dcos(ph_2)
           zfsin_x(ip,2) = dsin(ph_2)
           zfcos_x(ip,3) = dcos(ph_3)
           zfsin_x(ip,3) = dsin(ph_3)
        end do
     else if(n_ialist >= 4) then
!cdir parallel do private(i,ph_1,ph_2,ph_3,ph_4,ip)
        do i = ista_kngp, iend  !for mp
           ph_1 = ngabc(i,1)*fx_1+ngabc(i,2)*fy_1+ngabc(i,3)*fz_1
           ph_2 = ngabc(i,1)*fx_2+ngabc(i,2)*fy_2+ngabc(i,3)*fz_2
           ph_3 = ngabc(i,1)*fx_3+ngabc(i,2)*fy_3+ngabc(i,3)*fz_3
           ph_4 = ngabc(i,1)*fx_4+ngabc(i,2)*fy_4+ngabc(i,3)*fz_4
           ip = i + is
           zfcos_x(ip,1) = dcos(ph_1)
           zfsin_x(ip,1) = dsin(ph_1)
           zfcos_x(ip,2) = dcos(ph_2)
           zfsin_x(ip,2) = dsin(ph_2)
           zfcos_x(ip,3) = dcos(ph_3)
           zfsin_x(ip,3) = dsin(ph_3)
           zfcos_x(ip,4) = dcos(ph_4)
           zfsin_x(ip,4) = dsin(ph_4)
        end do
     end if
     if(n_ialist > 4 ) then
        do ia = 5, n_ialist
           fx_1 = pos(ia_list(ia),1)*PAI2
           fy_1 = pos(ia_list(ia),2)*PAI2
           fz_1 = pos(ia_list(ia),3)*PAI2
!cdir parallel do private(i,ph_1,ip)
           do i = ista_kngp, iend   !MPI
              ph_1 = ngabc(i,1)*fx_1+ngabc(i,2)*fy_1+ngabc(i,3)*fz_1
              ip = i + is
              zfcos_x(ip,ia) = dcos(ph_1)
              zfsin_x(ip,ia) = dsin(ph_1)
           end do
        end do
     end if
  endif
!xocl end spread
end subroutine calc_phase_b

subroutine zf_list_s(n_min,n_max,matm,natm,f,ia,zfcos,zfsin)
  use m_Const_Parameters, only : DP
  implicit none
  integer, intent(in)      :: n_min,n_max,matm,natm
  real(kind=DP),intent(in) :: f
  integer, intent(in)      :: ia
  real(DP),intent(out),dimension(n_min:n_max,matm+1:natm)::zfcos,zfsin

  integer :: i
  do i = n_min, n_max
     zfcos(i,ia) = dcos(i*f)
     zfsin(i,ia) = dsin(i*f)
  end do
end subroutine zf_list_s

subroutine setglist4(n_min1,n_max1,n_min2,n_max2,n_min3,n_max3 &
     &     ,nbase,ngabc,kgp,iiba, nglist)
  implicit none
  integer,intent(in) :: n_min1,n_max1,n_min2,n_max2,n_min3,n_max3
  integer,intent(in) :: kgp,iiba,nbase(*),ngabc(kgp,3)
  integer,intent(out):: nglist(n_min1:n_max1,n_min2:n_max2,n_min3:n_max3)

  integer :: i, nb, nb1,nb2,nb3

  nglist = -1

  do i = 1, iiba
     nb = nbase(i)
     nb1 = ngabc(nb,1)
     nb2 = ngabc(nb,2)
     nb3 = ngabc(nb,3)
     nglist(nb1,nb2,nb3) = i
  enddo
end subroutine setglist4


subroutine crngabc4(n_min1,n_max1,n_min2,n_max2,n_min3,n_max3 &
     &     ,nglist,kg1,nngabc,newp)
  implicit none
  integer, intent(in) :: n_min1,n_max1,n_min2,n_max2,n_min3,n_max3 &
       &, nglist(n_min1:n_max1,n_min2:n_max2,n_min3:n_max3), kg1
  integer, intent(out) :: nngabc(kg1,3),newp(kg1)
  
  integer :: ngcount, jcount,kcount,jp,kp,ip

  ngcount = 0
  do jcount = n_min2, n_max2
     jp = jcount
     do kcount = n_min3, n_max3
        kp = kcount
        do ip = n_min1, n_max1
           if(nglist(ip,jp,kp) /= -1) then
              ngcount = ngcount + 1
              nngabc(ngcount,1) = ip
              nngabc(ngcount,2) = jp
              nngabc(ngcount,3) = kp
              newp(ngcount) = nglist(ip,jp,kp)
           endif
           jp = jp + 1
           if(jp.eq.n_max2+1) jp = n_min2
           kp = kp + 1
           if(kp.eq.n_max3+1) kp = n_min3
        enddo
     enddo
  enddo
end subroutine crngabc4

