! ************************************************************* 
!
!   This is a software package CIAO
!
!     developed as a part of the national project "Research and 
!     Development of Innovative Simulation software",which is   
!     supported by the next-generation IT program of MEXT of Japan
!
!   Version history: 
!
!     4.0:  2013/03/01
!           codes for spin-polarized pseudopotential generation are added
!     4.1:  2013/11/22 - 
!           Info of core wfns and energy contributions can be added to gncpp2
!     4.2:  2014/07/23 - 
!           gncpp2 can be geregated even when nmesh /= 1501
!
! ************************************************************* 
!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_fourier, write_fourier, write_fourier_patom
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine calc_fourier(ier)
!=====================================================================
!
!  Calculates Fourier transforms of ion potentials
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ig, ir, ips, ll, nmesh_cut
   real(8) :: r, g, dg, sum, &
              eps_g = 1.d-6
   ier = 0
   nmesh_cut = nmesh
   dg = (gmax_fourier - gmin_fourier) / dble(ng_fourier - 1)
   do ig = 1,ng_fourier
      gpos_ft(ig) = gmin_fourier + dble(ig-1) * dg
   end do
   !call set_open_weight_exp(ier,1,nmesh_cut,rpos,wt)
   call set_weight_exp(ier,1,nmesh_cut,rpos,wt)
   do ll = 0,lmax_core
   do ig = 1,ng_fourier
      g = gpos_ft(ig)
      if (abs(g) < eps_g) then
         gg_vion_ft(ig,ll) = - fatom
      else
         sum = 0.d0
         do ir = 1,nmesh_cut
            r = rpos(ir)
            sum = sum + sin(g*r) &
                      * (r*vion(ir,ll)+fatom) * wt(ir)
         end do
         gg_vion_ft(ig,ll) = g*sum - fatom
      end if
   end do
   end do
   if (is_pp_generated == YES) then
      do ig = 1,ng_fourier
         g = gpos_ft(ig)
         if (abs(g) < eps_g) then
! ================================================= modified by K. T. ========== 4.0
!            gg_vloc_ion_ft(ig) = - fval
            gg_vloc_ion_ft(ig,1) = - fval
! ============================================================================= 4.0
         else
            sum = 0.d0
            do ir = 1,nmesh_cut
               r = rpos(ir)
               sum = sum + sin(g*r) &
! ================================================= modified by K. T. ========== 4.0
!                         * (r*vloc_ion_us(ir)+fval) * wt(ir)
                         * (r*vloc_ion_us(ir,1)+fval) * wt(ir)
! ============================================================================== 4.0
            end do

! ================================================= modified by K. T. ========== 4.0
!            gg_vloc_ion_ft(ig) = g*sum - fval
            gg_vloc_ion_ft(ig,1) = g*sum - fval
! ============================================================================== 4.0
         end if
      end do
      do ips = 1,nps
      do ig = 1,ng_fourier
         g = gpos_ft(ig)
         if (abs(g) < eps_g) then
            gg_vion_ps_ft(ig,ips) = - fval
         else
            sum = 0.d0
            do ir = 1,nmesh_cut
               r = rpos(ir)
               sum = sum + sin(g*r) &
                         * (r*vion_ps(ir,ips,1)+fval) * wt(ir)
            end do
            gg_vion_ps_ft(ig,ips) = g*sum - fval
         end if
      end do
      end do
   end if
   end subroutine calc_fourier

!====================================== added by K. T. ================== 4.0
subroutine calc_fourier_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  
  integer :: ig, ir, ips, ll, nmesh_cut
  integer :: ispin
  real(8) :: r, g, dg, sum, &
       eps_g = 1.d-6

  ier = 0
  nmesh_cut = nmesh
  dg = (gmax_fourier - gmin_fourier) / dble(ng_fourier - 1)

  do ig = 1,ng_fourier
     gpos_ft(ig) = gmin_fourier + dble(ig-1) * dg
  end do
  !call set_open_weight_exp(ier,1,nmesh_cut,rpos,wt)
  
  call set_weight_exp(ier,1,nmesh_cut,rpos,wt)

  do ll = 0,lmax_core
     do ig = 1,ng_fourier
        g = gpos_ft(ig)
        if (abs(g) < eps_g) then
           gg_vion_ft(ig,ll) = - fatom
        else
           sum = 0.d0
           do ir = 1,nmesh_cut
              r = rpos(ir)
              sum = sum + sin(g*r) &
                   * (r*vion(ir,ll)+fatom) * wt(ir)
           end do
           gg_vion_ft(ig,ll) = g*sum - fatom
        end if
     end do
  end do

  if (is_pp_generated == YES) then
     
     do ig = 1,ng_fourier
        g = gpos_ft(ig)
        
        if (abs(g) < eps_g) then
           gg_vloc_ion_ft(ig,:) = - fval
           
        else
           
           Do ispin=1, nspin
              sum = 0.d0
              do ir = 1,nmesh_cut
                 r = rpos(ir)
                 sum = sum + sin(g*r) &
                      & * (r*vloc_ion_us(ir,ispin) +fval) * wt(ir)
              end do
              gg_vloc_ion_ft(ig,ispin) = g*sum - fval
           End Do
           
        end if
        
     end do
     
     do ips = 1,nps
        do ig = 1,ng_fourier
           g = gpos_ft(ig)
           if (abs(g) < eps_g) then
              gg_vion_ps_ft(ig,ips) = - fval
           else
              sum = 0.d0
              do ir = 1,nmesh_cut
                 r = rpos(ir)
                 sum = sum + sin(g*r) &
                      * (r*vion_ps(ir,ips,1)+fval) * wt(ir)
              end do
              gg_vion_ps_ft(ig,ips) = g*sum - fval
           end if
        end do
     end do

  end if

end subroutine calc_fourier_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine write_fourier(ier)
!=====================================================================
!
!  Outputs Fourier transforms into file (IFFT)
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, ishell, nn, ll, kk, jj2, ispin, ig, ll_core
   real(8) :: g
   character(1) :: fn_label_orbital
   character(2) :: ch_del, ch2
   character(4) :: ch4
   ier = 0
   ch_del = ','//' '
   open(IFFT,file=trim(ftfile),status='unknown')
   write(IFFT,*) 'Fourier transforms of Vion(r,l,t) and Vion_ps(r,l,t)'
   call write_file_header(IFFT)
   write(IFFT,23) ng_fourier,'ng_fourier'
   ch4(1:4) = '_loc'
   write(IFFT,*)
   write(IFFT,*) 'local potential [ion]'
   write(IFFT,*) 'gpos'//ch4//ch_del//'gg_vionk'//ch4
   do ig = 1,ng_fourier
      g = gpos_ft(ig)
! ============================================= modified by K. T. ================ 4.0
!      write(IFFT,10) g, gg_vloc_ion_ft(ig)
      write(IFFT,10) g, gg_vloc_ion_ft(ig,1)
! ============================================================================= 4.0
   end do
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      if (is_core == PATOM) then
         ll_core = ll
      else
         ll_core = lmax_core
      end if
      kk = k_qnum(ishell)
      jj2 = j2_qnum(ishell)
      ispin = (1-spin(ishell))/2 + 1
      ch2(1:2) = '_'//fn_label_orbital(ll)
      write(IFFT,*)
      write(IFFT,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
      write(IFFT,31) engy(ishell),'elevel'
      write(IFFT,31) rcut_tm(ll) ,'rcut  '
      write(IFFT,*)
      write(IFFT,*) 'gpos'//ch2//ch_del//'gg_vionk'//ch2//ch_del &
                    //'gg_vionk_ps'//ch2
      do ig = 1,ng_fourier
         g = gpos_ft(ig)
         write(IFFT,10) g, gg_vion_ft(ig,ll_core), &
                           gg_vion_ps_ft(ig,ips)
      end do
   end do
10 format(10(1pe20.10))
23 format(1x,i10,10x,5x,':',1x,a10)
30 format(1x,4i5,    5x,':',1x,a14)
31 format(1x,f20.10, 5x,':',1x,a6)
   close(IFFT)
   end subroutine write_fourier

!========================================== added by K. T. ================= 4.0
subroutine write_fourier_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier

  integer :: ips, ishell, nn, ll, kk, jj2, ispin, ig, ll_core

  real(8) :: g
  character(1) :: fn_label_orbital
  character(2) :: ch_del, ch2
  character(4) :: ch4

  ier = 0
  ch_del = ','//' '
  
  open(IFFT,file=trim(ftfile),status='unknown')

  if ( nspin == 1 ) then
     write(IFFT,*) 'Fourier transforms of Vion(r,l,t) and Vion_ps(r,l,t)'
  else if ( nspin == 2 ) then
     write(IFFT,*) 'Fourier transforms of Vion(r,l,t,s) and Vion_ps(r,l,t,s)'
  endif

  call write_file_header(IFFT)
  write(IFFT,23) ng_fourier,'ng_fourier'

  ch4(1:4) = '_loc'

  write(IFFT,*)
  write(IFFT,*) 'local potential [ion]'

  Do ispin=1, nspin

     if ( nspin == 2 ) then
        write(IFFT,*)
        if ( ispin == 1 ) then
           write(IFFT,'(a)') ' spin component : up'
        else if ( ispin == 2 ) then
           write(IFFT,'(a)') ' spin component : down'
        endif
        write(IFFT,*)
     endif

     write(IFFT,*) 'gpos'//ch4//ch_del//'gg_vionk'//ch4

     do ig = 1,ng_fourier
        g = gpos_ft(ig)
        write(IFFT,10) g, gg_vloc_ion_ft(ig,ispin)
     end do

  End do
  
  do ips = 1,nps
     ishell = ishell_ps(ips,1)
     nn = n_qnum(ishell)
     ll = l_qnum(ishell)

     if (is_core == PATOM) then
        ll_core = ll
     else
        ll_core = lmax_core
     end if

     kk = k_qnum(ishell)
     jj2 = j2_qnum(ishell)

     ispin = (1-spin(ishell))/2 + 1
     ch2(1:2) = '_'//fn_label_orbital(ll)

     write(IFFT,*)
     write(IFFT,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
     write(IFFT,31) engy(ishell),'elevel'
     write(IFFT,31) rcut_tm(ll) ,'rcut  '

     write(IFFT,*)
     write(IFFT,*) 'gpos'//ch2//ch_del//'gg_vionk'//ch2//ch_del &
          //'gg_vionk_ps'//ch2

     do ig = 1,ng_fourier
        g = gpos_ft(ig)
        write(IFFT,10) g, gg_vion_ft(ig,ll_core), gg_vion_ps_ft(ig,ips)
     end do
  end do

10 format(10(1pe20.10))
23 format(1x,i10,10x,5x,':',1x,a10)
30 format(1x,4i5,    5x,':',1x,a14)
31 format(1x,f20.10, 5x,':',1x,a6)

  close(IFFT)

end subroutine write_fourier_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine write_fourier_patom(ier)
!=====================================================================
!
!  Outputs Fourier transforms into file (IFFT)
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ishell, nn, ll, kk, jj2, ispin, ig, ll_core
   real(8) :: g
   character(1) :: fn_label_orbital
   character(2) :: ch_del, ch2
   character(4) :: ch4
   ier = 0
   ch_del = ','//' '
   open(IFFT,file=trim(ftfile),status='unknown')
   write(IFFT,*) 'Fourier transforms of pseudoatom ion-core potentials'
   call write_file_header(IFFT)   
   write(IFFT,23) ng_fourier,'ng_fourier'   
   ch4(1:4) = '_loc'
   write(IFFT,*)
   write(IFFT,*) 'local potential [ion]'
   write(IFFT,*) 'gpos'//ch4//ch_del//'gg_vionk'//ch4
   do ig = 1,ng_fourier
      g = gpos_ft(ig)
! ==================================================== modified by K. T. ========= 4.0
!      write(IFFT,10) g, gg_vloc_ion_ft(ig)
      write(IFFT,10) g, gg_vloc_ion_ft(ig,1)
! =============================================================================== 4.0
   end do
   do ishell = 1,nshell
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      ll_core = ll
      kk = k_qnum(ishell)
      jj2 = j2_qnum(ishell)
      ispin = (1-spin(ishell))/2 + 1
      ch2(1:2) = '_'//fn_label_orbital(ll)
      write(IFFT,*)
      write(IFFT,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
      write(IFFT,31) engy(ishell)  ,'elevel   '
      write(IFFT,31) rcut_core(ll) ,'rcut_core'
      write(IFFT,31) vcut_core(ll) ,'vcut_core'
      write(IFFT,*)
      write(IFFT,*) 'gpos'//ch2//ch_del//'gg_vionk'//ch2
      do ig = 1,ng_fourier
         g = gpos_ft(ig)
         write(IFFT,10) g, gg_vion_ft(ig,ll_core)
      end do
   end do
10 format(10(1pe20.10))
23 format(1x,i10,10x,5x,':',1x,a10)
30 format(1x,4i5,    5x,':',1x,a14)
31 format(1x,f20.10, 5x,':',1x,a9)
   close(IFFT)
   end subroutine write_fourier_patom

!=================================================== added by K. T. ========= 4.0
subroutine write_fourier_patom_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier

  integer :: ishell, nn, ll, kk, jj2, ispin, ig, ll_core
  real(8) :: g
  character(1) :: fn_label_orbital
  character(2) :: ch_del, ch2
  character(4) :: ch4

  ier = 0
  ch_del = ','//' '

  open(IFFT,file=trim(ftfile),status='unknown')
  write(IFFT,*) 'Fourier transforms of pseudoatom ion-core potentials'

  call write_file_header(IFFT)   

  write(IFFT,23) ng_fourier,'ng_fourier'   

  ch4(1:4) = '_loc'

  write(IFFT,*)
  write(IFFT,*) 'local potential [ion]'

  Do ispin=1, nspin

     if ( nspin == 2 ) then
        write(IFFT,*)
        if ( ispin == 1 ) then
           write(IFFT,'(a)') ' spin component : up'
        else if ( ispin == 2 ) then
           write(IFFT,'(a)') ' spin component : down'
        endif
        write(IFFT,*)
     endif

     write(IFFT,*) 'gpos'//ch4//ch_del//'gg_vionk'//ch4

     do ig = 1,ng_fourier
        g = gpos_ft(ig)
        write(IFFT,10) g, gg_vloc_ion_ft(ig,ispin)
     end do

  End Do

  do ishell = 1,nshell
     nn = n_qnum(ishell)
     ll = l_qnum(ishell)
     ll_core = ll

     kk = k_qnum(ishell)
     jj2 = j2_qnum(ishell)

     ispin = (1-spin(ishell))/2 + 1

     ch2(1:2) = '_'//fn_label_orbital(ll)

     write(IFFT,*)
     write(IFFT,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
     write(IFFT,31) engy(ishell)  ,'elevel   '
     write(IFFT,31) rcut_core(ll) ,'rcut_core'
     write(IFFT,31) vcut_core(ll) ,'vcut_core'
     write(IFFT,*)
     write(IFFT,*) 'gpos'//ch2//ch_del//'gg_vionk'//ch2

     do ig = 1,ng_fourier
        g = gpos_ft(ig)
        write(IFFT,10) g, gg_vion_ft(ig,ll_core)
     end do

  end do

10 format(10(1pe20.10))
23 format(1x,i10,10x,5x,':',1x,a10)
30 format(1x,4i5,    5x,':',1x,a14)
31 format(1x,f20.10, 5x,':',1x,a9)

  close(IFFT)

end subroutine write_fourier_patom_kt
! ======================================================================= 4.0
