!=======================================================================
!
!  SOFTWARE NAME : PHASE ($Revision: 409 $)
!
!  MODULE: m_Phonon
!
!  AUTHOR(S): T. Yamamoto   May/01/2004
!
!  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.
!
!
module m_Phonon
! $Id: m_Phonon.F90 409 2014-10-27 09:24:52Z jkoga $
use m_Const_parameters,   only : DP, ON, OFF, NOCONV, FMAXVALLEN, PAI, PAI2, PAI4 &
                         &     , PHONON_GAMMA, PHONON_BAND, PHONON_DOS &
                         &     , LOWER, CARTS, UNIT_PIEZO_CONST &
                         &     , CRDTYP, FILE, FERMI_DIRAC
use m_Control_Parameters, only : sw_phonon, sw_calc_force, sw_calc_force_all &
                         &     , sw_vibrational_modes, sw_lo_to_splitting &
                         &     , sw_lattice_dielectric_tensor &
                         &     , sw_dielectric_function &
                         &     , sw_correct_force_constants &
                         &     , sw_polynomial_fit, norder &
                         &     , sw_int_strain_piezo_tensor, sw_phonon_oneshot &
                         &     , phonon_method, num_phonon_calc_mode &
                         &     , ipriphonon, printable, way_of_smearing, width, width_tetra
use m_Crystal_Structure,  only : altv,rltv,altv_super,rltv_super,nlpnt,lpnt,nbztyp_spg
use m_Ionic_System,       only : num_force_data, phonon_atom &
                              &, phonon_displacement &
                              &,displaced_atom, displacement &
                              &,input_coordinate_system,u &
                              &,natm,ionic_mass,speciesname,ityp,ntyp &
                              &,istart_phonon,iend_phonon &
                              &,natm_prim,natm_super &
                              &,pos,cps
use m_BP_Properties,      only : zeff
use m_Files,              only : nfout,nfkpoint,nfmatbp,m_Files_open_kpoint_files
use m_Parallelization,    only : mype,npes,ierr, mpi_comm_group

! === KT_add === 13.1R
use m_Control_Parameters,  only : sw_phonon_with_epsilon
use m_Raman,               only : m_Raman_read_nfinp, m_Raman_initialize, &
     &                            m_Raman_print_param, m_Raman_calc_susceptibility, &
     &                            dielectric_read_from_file => dielectric
! ============== 13.1R

implicit none
include 'mpif.h'

real(kind=DP),allocatable,dimension(:,:,:) :: force_data ! dim(natm_super,3,num_force_data)
real(kind=DP),allocatable,dimension(:,:,:) :: forces ! dim(natm_super*3,natm_prim*3,norder*2)
real(kind=DP),allocatable,dimension(:) :: force0 ! dim(natm_super*3)
real(kind=DP) :: dielectric(3,3) = 0.d0
real(kind=DP) :: kvec_dir(3) = 0.d0
character(len=3), allocatable, dimension(:) :: point_group ! dim(nqvec)
character(len=3) :: pg_gamma = ''
integer :: nlat(3) ! lattice size
real(kind=DP),allocatable,dimension(:,:) :: qvec ! dim(nqvec,3)
real(kind=DP),allocatable,dimension(:,:) :: qvin ! dim(nqvec,3)
real(kind=DP),allocatable,dimension(:)   :: wght ! dim(nqvec)
real(kind=DP),allocatable,dimension(:,:) :: qdir ! dim(nqvec,3)
integer :: nsp = 1
real(kind=DP),allocatable,dimension(:,:) :: spcpnt ! dim(nsp,3)
character(len=3), allocatable, dimension(:)  :: pg_spcpnt ! dim(nsp)
integer :: nsl = 1
integer,allocatable,dimension(:,:) :: symln  ! dim(nsl,2)
integer,allocatable,dimension(:) :: ndiv     ! dim(nsl)
character(len=3), allocatable, dimension(:)  :: pg_symln ! dim(nsl)
logical, allocatable, dimension(:,:) :: fksym ! dim(48,nqvec)
real(kind=DP) :: rho_loto = 1.4d0
! strain force coupling const.
real(kind=DP),allocatable         :: strfrc(:,:,:)   !d(3,natm,6)
real(kind=DP) :: piezoelectric(3,6) = 0.d0

! energy range for dielectric function
real(kind=DP), private :: max_energy = 0.01d0
real(kind=DP), private :: min_energy = 0.d0
integer, private :: num_division = 100
real(kind=DP), private :: damping_factor = 1.d-2

! Phonon DOS
integer, private :: phonon_dos_mesh(3)
integer                           :: np0,np1,np2
integer,allocatable, dimension(:) :: ip20,ip10,ip02,ip12
integer,allocatable, dimension(:) :: ip01,ip21,iu21,iv21,iwt,ip2cub
integer, dimension(3)             :: nxyz_tetra
real(kind=DP)                     :: DeltaE_dos = 1.d-5


! calculated
integer :: nmodes ! = 3*natm
integer :: nqvec = 1
integer :: qvec_from_file = ON
real(kind=DP), allocatable,dimension(:,:,:) :: dynmat  ! dim(3*natm,3*natm,nlpnt)
complex(kind=DP), allocatable,dimension(:,:,:) :: dynmatq ! dim(3*natm,3*natm,nqvec)
real(kind=DP), allocatable,dimension(:,:)   :: omega   ! dim(3*natm,nqvec)
complex(kind=DP), allocatable,dimension(:,:,:) :: modes   ! dim(3*natm,3*natm,nqvec)
character(len=3), allocatable,dimension(:,:) :: mode_irr_rep ! dim(3*natm,nqvec)
character(len=4), allocatable,dimension(:,:) :: mode_active  ! dim(3*natm,nqvec)
real(kind=DP), allocatable,dimension(:)   :: msqinv     ! dim(3*natm)
real(kind=DP), allocatable,dimension(:,:) :: zeff_mode  ! dim(3,nmodes)
real(kind=DP) :: static_dielectric(3,3) ! static dielectric tensor 
real(kind=DP) :: lattice_dielectric(3,3) ! lattice dielectric tensor 
real(kind=DP), allocatable,dimension(:,:) :: strphcpl  ! dim(6,nmodes)

! Ewald sum
real(kind=DP) :: deteps ! Det(epsilon)
real(kind=DP), dimension(3,3) :: epsinv ! (epsilon)^-1

! Tags
character(len("phonon")),private,parameter :: tag_phonon = "phonon"
character(len("sw_phonon")),private,parameter :: tag_sw_phonon = "sw_phonon"
character(len("sw_calc_force")),private,parameter :: tag_sw_calc_force = "sw_calc_force"
character(len("sw_calc_force_all")),private,parameter :: tag_sw_calc_force_all = "sw_calc_force_all"
character(len("sw_polynomial_fit")),private,parameter :: tag_sw_polynomial_fit = "sw_polynomial_fit"
character(len("sw_phonon_oneshot")),private,parameter :: tag_sw_phonon_oneshot = "sw_phonon_oneshot"
character(len("num_phonon_calc_mode")),private,parameter :: tag_num_phonon_calc_mode = "num_phonon_calc_mode"
character(len("norder")),private,parameter :: tag_norder = "norder"
character(len("displacement")),private,parameter :: tag_displacement = "displacement"
character(len("force_calc")),private,parameter :: tag_force_calc = "force_calc"
character(len("start")),private,parameter :: tag_start = "start"
character(len("end")),private,parameter :: tag_end = "end"

character(len("sw_vibrational_modes")),private,parameter :: tag_sw_vibrational_modes = "sw_vibrational_modes"
character(len("sw_correct_force_constants")),private,parameter :: tag_sw_correct_force_constants = "sw_correct_force_constants"
character(len("point_group")),private,parameter :: tag_point_group = "point_group"
character(len("sw_lo_to_splitting")),private,parameter :: tag_sw_lo_to_splitting = "sw_lo_to_splitting"
character(len("electronic_dielectric_constant")),private,parameter :: &
 & tag_electronic_dielectric_cnst = "electronic_dielectric_constant"
character(len("exx")),private,parameter :: tag_exx = "exx"
character(len("eyy")),private,parameter :: tag_eyy = "eyy"
character(len("ezz")),private,parameter :: tag_ezz = "ezz"
character(len("exy")),private,parameter :: tag_exy = "exy"
character(len("eyz")),private,parameter :: tag_eyz = "eyz"
character(len("ezx")),private,parameter :: tag_ezx = "ezx"
character(len("k_vector")),private,parameter :: tag_k_vector = "k_vector"
character(len("kx")),private,parameter :: tag_kx = "kx"
character(len("ky")),private,parameter :: tag_ky = "ky"
character(len("kz")),private,parameter :: tag_kz = "kz"

character(len("sw_lattice_dielectric_tensor")),private,parameter :: & 
 & tag_sw_lattice_dielec_tensor = "sw_lattice_dielectric_tensor"
character(len("sw_internal_strain_piezoelectric_tensor")),private,parameter :: & 
 & tag_sw_int_strain_piezo_tensor = "sw_internal_strain_piezoelectric_tensor"

character(len("sw_dielectric_function")),private,parameter :: tag_sw_dielectric_function = "sw_dielectric_function"
character(len("energy_range")),private,parameter :: tag_energy_range = "energy_range"
character(len("min_energy")),private,parameter :: tag_min_energy = "min_energy"
character(len("max_energy")),private,parameter :: tag_max_energy = "max_energy"
character(len("division_number")),private,parameter :: tag_division_number = "division_number"
character(len("damping_factor")),private,parameter :: tag_damping_factor = "damping_factor"


character(len("lattice")),private,parameter :: tag_lattice = "lattice"
character(len("l1")),private,parameter :: tag_l1 = "l1"
character(len("l2")),private,parameter :: tag_l2 = "l2"
character(len("l3")),private,parameter :: tag_l3 = "l3"

character(len("no")),private,parameter :: tag_no = "no"
character(len("id")),private,parameter :: tag_id = "id"
character(len("special_points")),private,parameter :: tag_special_points = "special_points"
character(len("symmetry_lines")),private,parameter :: tag_symmetry_lines = "symmetry_lines"
character(len("k1")),private,parameter :: tag_k1 = "k1"
character(len("k2")),private,parameter :: tag_k2 = "k2"
character(len("k3")),private,parameter :: tag_k3 = "k3"
character(len("num_division")),private,parameter :: tag_num_division = "num_division"

character(len("method")),private,parameter :: tag_method = "method"
character(len("calc_type")),private,parameter :: tag_calc_type = "calc_type"
character(len("gamma")),private,parameter  :: tag_gamma  = "gamma"
character(len("zone_center")),private,parameter :: tag_zone_center = "zone_center"
character(len("band")),private,parameter   :: tag_band   = "band"
character(len("dispersion")),private,parameter :: tag_dispersion = "dispersion"
character(len("dos")),private,parameter    :: tag_dos    = "dos"

character(len("mesh")),private,parameter   :: tag_mesh   = "mesh"
character(len("nx")),private,parameter     :: tag_nx     = "nx"
character(len("ny")),private,parameter     :: tag_ny     = "ny"
character(len("nz")),private,parameter     :: tag_nz     = "nz"
character(len("deltae")),private,parameter :: tag_deltae = "deltae"

character(len("rho")),private,parameter :: tag_rho = "rho"

character(len("qvec_from_file")),private, parameter :: tag_qvec_from_file = "qvec_from_file"

contains

subroutine m_Phonon_rd_param(nfout)

integer, intent(in) :: nfout

integer :: iret, f_selectBlock, f_getIntValue, f_getRealValue, f_getStringValue
integer :: f_selectParentBlock, f_selectTop
real(kind=DP) :: dret
character(len=FMAXVALLEN) :: cret
real(kind=DP) :: dnorm

iret = f_selectTop()
if( f_selectBlock( tag_phonon) == 0) then
   if( f_getIntValue( tag_sw_phonon, iret) == 0) sw_phonon = iret
   if(sw_phonon == ON) then
      sw_calc_force = ON
      if( f_getStringValue( tag_method, cret,LOWER) == 0) then
         call set_phonon_method(cret) ! -> phonon_method
      else if( f_getStringValue( tag_calc_type, cret,LOWER) == 0) then
         call set_phonon_method(cret) ! -> phonon_method
      end if
      if( f_getIntValue( tag_sw_calc_force, iret) == 0) sw_calc_force = iret
      if( f_getIntValue( tag_sw_calc_force_all, iret) == 0) sw_calc_force_all = iret
      if( f_getIntValue( tag_sw_polynomial_fit, iret) == 0) sw_polynomial_fit = iret
      if( f_getIntValue( tag_norder, iret) == 0) norder = iret
      if( f_getRealValue( tag_displacement, dret, 'bohr') == 0) then
         u = dret   
      else
         u = 0.1d0 ! default value
      end if
      if( f_getRealValue( tag_damping_factor, dret, '') == 0) damping_factor = dret
      damping_factor = abs(damping_factor)
      if( f_getIntValue( tag_sw_vibrational_modes, iret) == 0) sw_vibrational_modes = iret
      if( f_getIntValue( tag_sw_correct_force_constants, iret) == 0) sw_correct_force_constants = iret
      if( f_getStringValue( tag_point_group, cret, NOCONV) == 0) then
         pg_gamma = cret(1:3)
      else
         pg_gamma = '' ! default value
      end if

      if( f_getIntValue( tag_sw_phonon_oneshot, iret)==0) sw_phonon_oneshot = iret
      if( f_getIntValue( tag_num_phonon_calc_mode,iret)==0) num_phonon_calc_mode = iret
 
! ==== KT_add ==== 13.1R
      call m_Raman_read_nfinp
! =============== 13.1R

      if( f_getIntValue( tag_sw_lattice_dielec_tensor, iret) == 0) & 
      &  sw_lattice_dielectric_tensor = iret
      if( f_getIntValue( tag_sw_int_strain_piezo_tensor, iret) == 0) & 
      &  sw_int_strain_piezo_tensor = iret

      if( f_getIntValue( tag_sw_dielectric_function, iret) == 0) sw_dielectric_function = iret

      if( f_getIntValue( tag_sw_lo_to_splitting, iret) == 0) sw_lo_to_splitting = iret
      if(sw_lo_to_splitting == ON) then
         if( f_getRealValue( tag_rho, dret, '') == 0) rho_loto = dret
      end if
      if( f_selectBlock( tag_force_calc) == 0) then
         if( f_getIntValue( tag_start, iret) == 0) istart_phonon = iret
         if( f_getIntValue( tag_end, iret) == 0) iend_phonon = iret
         iret = f_selectParentBlock()
      end if
      if( f_selectBlock( tag_electronic_dielectric_cnst) == 0) then
         if( f_getRealValue( tag_exx, dret, '') == 0) dielectric(1,1) = dret
         if( f_getRealValue( tag_eyy, dret, '') == 0) dielectric(2,2) = dret
         if( f_getRealValue( tag_ezz, dret, '') == 0) dielectric(3,3) = dret
         if( f_getRealValue( tag_exy, dret, '') == 0) dielectric(1,2) = dret
         dielectric(2,1) = dielectric(1,2)
         if( f_getRealValue( tag_eyz, dret, '') == 0) dielectric(2,3) = dret
         dielectric(3,2) = dielectric(2,3)
         if( f_getRealValue( tag_ezx, dret, '') == 0) dielectric(3,1) = dret
         dielectric(1,3) = dielectric(3,1)
         iret = f_selectParentBlock()
      end if
      if( f_selectBlock( tag_energy_range ) == 0) then
         if( f_getRealValue( tag_min_energy, dret, 'hartree') == 0) min_energy = dret
         if( f_getRealValue( tag_max_energy, dret, 'hartree') == 0) max_energy = dret
         if( f_getIntValue( tag_division_number, iret) == 0) num_division = iret
         iret = f_selectParentBlock()
      end if

      if( f_getIntValue(tag_qvec_from_file,iret)==0) qvec_from_file = iret

! ==== KT_add ====== 13.1R
      if( phonon_method == PHONON_GAMMA ) qvec_from_file = OFF
! ================== 13.1R

      if(qvec_from_file==OFF)then
         if( f_selectBlock( tag_k_vector) == 0) then
            if( f_getRealValue( tag_kx, dret, '') == 0) kvec_dir(1) = dret
            if( f_getRealValue( tag_ky, dret, '') == 0) kvec_dir(2) = dret
            if( f_getRealValue( tag_kz, dret, '') == 0) kvec_dir(3) = dret
            iret = f_selectParentBlock()
            dnorm = sqrt(sum(kvec_dir(1:3)**2))
            if(abs(dnorm) < 1.d-10) then
               kvec_dir(1:2)=0.d0
               kvec_dir(3)=1.d0
               dnorm = 1.d0
            end if
            kvec_dir(1:3) = kvec_dir(1:3)/dnorm
            iret = f_selectParentBlock()
         else
            kvec_dir(3) = 1.d0  ! default value
         end if
      endif

! === KT_add === 13.1R
      if ( sw_phonon_with_epsilon == ON ) then
         call m_Raman_initialize( kvec_dir )
         dielectric = dielectric_read_from_file
      endif
! ================ 13.1R

      if( phonon_method /= PHONON_GAMMA) then
         if( f_selectBlock( tag_lattice) == 0) then
            if( f_getIntValue( tag_l1, iret) == 0) nlat(1) = iret
            if( f_getIntValue( tag_l2, iret) == 0) nlat(2) = iret
            if( f_getIntValue( tag_l3, iret) == 0) nlat(3) = iret
            iret = f_selectParentBlock()
         else
            nlat(1:3) = 2
         end if
      else
         nlat(1:3) = 0
      end if

      if( phonon_method == PHONON_BAND) then
         call rd_spcpnt_and_symln()
      else if( phonon_method == PHONON_DOS) then
         phonon_dos_mesh(1:3) = 4 ! default values
         if( f_selectBlock( tag_dos) == 0) then
            if( f_selectBlock( tag_mesh) == 0) then
               if( f_getIntValue( tag_nx, iret) == 0) phonon_dos_mesh(1) = iret
               if( f_getIntValue( tag_ny, iret) == 0) phonon_dos_mesh(2) = iret
               if( f_getIntValue( tag_nz, iret) == 0) phonon_dos_mesh(3) = iret
               iret = f_selectParentBlock()
            end if
            if( f_getRealValue( tag_deltae, dret, '') == 0) DeltaE_dos = dret
            iret = f_selectParentBlock()
         end if
      end if

      iret = f_selectParentBlock()
   end if

   iret = f_selectParentBlock()
end if

if(sw_lattice_dielectric_tensor == ON) then
   phonon_method = PHONON_GAMMA
   sw_lo_to_splitting = OFF
end if

if(ipriphonon >= 1) then
   write(nfout,*) '!** sw_phonon = ',sw_phonon
   if(sw_phonon == ON) then
      write(nfout,*) '!** sw_calc_force = ',sw_calc_force
      write(nfout,*) '!** sw_calc_force_all = ',sw_calc_force_all
      write(nfout,*) '!** istart_phonon = ',istart_phonon
      write(nfout,*) '!** iend_phonon   = ',iend_phonon
      write(nfout,*) '!** displacement (Phonon) = ',u
      write(nfout,*) '!** sw_vibrational_modes = ',sw_vibrational_modes
      write(nfout,*) '!** sw_polynomial_fit = ',sw_polynomial_fit
      write(nfout,*) '!** norder = ',norder
      write(nfout,*) '!** nlat = ',nlat
      write(nfout,*) '!** sw_correct_force_constants = ',sw_correct_force_constants
      write(nfout,*) '!** point_group = ',pg_gamma
      write(nfout,*) '!** sw_lo_to_splitting = ',sw_lo_to_splitting
      write(nfout,'(" !**           [",3(1x,f10.5),1x,"]")') dielectric(1:3,1)
      write(nfout,'(" !** epsilon = [",3(1x,f10.5),1x,"]")') dielectric(1:3,2)
      write(nfout,'(" !**           [",3(1x,f10.5),1x,"]")') dielectric(1:3,3)
      write(nfout,'(" !** k_vector =",3(1x,f10.5))') kvec_dir(1:3)
      write(nfout,*) '!** sw_lattice_dielectric_tensor = ',sw_lattice_dielectric_tensor
      write(nfout,*) '!** sw_dielectric_function = ',sw_dielectric_function
      write(nfout,*) '!** energy_range = ',min_energy,max_energy,num_division
      write(nfout,*) '!** damping_factor = ',damping_factor
      write(nfout,*) '!** sw_internal_strain_piezoelectric_tensor = ',sw_int_strain_piezo_tensor
      if( phonon_method == PHONON_DOS) then
         write(nfout,*) '!** phonon_dos_mesh = ',phonon_dos_mesh(1:3)
      end if
      write(nfout,*) '!** sw_phonon_oneshot = ', sw_phonon_oneshot 
      if(sw_phonon_oneshot == ON) then
         write(nfout,*) '!** num_phonon_calc_mode = ',num_phonon_calc_mode
      end if
! ====== KT_add ==== 13.1R
      if ( sw_phonon_with_epsilon == ON ) call m_Raman_print_param
! ================== 13.1R
   end if
end if

contains
  subroutine rd_spcpnt_and_symln()
    integer :: num

    call read_spcpnt(.true.,nsp,num)  ! paramset = .true.  -> nsp
    nsp = num
    allocate(spcpnt(nsp,3))
    allocate(pg_spcpnt(nsp))
    call read_spcpnt(.false.,nsp,num) ! paramset = .false. -> spcpnt,pg_spcpnt

    call read_symln(.true.,nsl,num)  ! paramset = .true.  -> nsl
    nsl = num
    allocate(symln(nsl,3))
    allocate(ndiv(nsl))
    allocate(pg_symln(nsl))
    call read_symln(.false.,nsl,num) ! paramset = .false. -> symln,ndiv,pg_symln
  end subroutine rd_spcpnt_and_symln

  subroutine read_spcpnt(paramset,num,icounted)
    logical, intent(in) :: paramset
    integer, intent(in) ::  num
    integer, intent(out) :: icounted

    integer :: i, no, iret
    integer :: f_selectFirstTableLine,f_selectNextTableLine,f_getRealValue,f_getIntValue
    real(kind=dP) :: dret
    character(len=FMAXVALLEN) :: cret

    i = 1
    if( f_selectBlock( tag_special_points) == 0) then
       do
          if(i == 1) then
             if( f_selectFirstTableLine() /= 0 ) then
                exit
             end if
          else
             if( f_selectNextTableLine() /= 0 ) then
                exit
             end if
          end if
          if(.not.paramset) then
             if(i > num) exit
             no = i
             if(f_getIntValue(tag_no, iret) == 0) then
                no = iret
             else if(f_getIntValue(tag_id, iret) == 0) then
                no = iret
             end if
             if(no <= num) then
                if(f_getRealValue(tag_k1,dret,'') == 0) spcpnt(no,1) = dret
                if(f_getRealValue(tag_k2,dret,'') == 0) spcpnt(no,2) = dret
                if(f_getRealValue(tag_k3,dret,'') == 0) spcpnt(no,3) = dret
                if( f_getStringValue( tag_point_group, cret, NOCONV) == 0) then
                   pg_spcpnt(no) = cret(1:3)
                else
                   pg_spcpnt(no) = '' ! default value
                end if
             end if
          end if
          i = i+1
       end do
       iret = f_selectParentBlock()
    end if
    icounted = i - 1

  end subroutine read_spcpnt

  subroutine read_symln(paramset,num,icounted)
    logical, intent(in) :: paramset
    integer, intent(in) ::  num
    integer, intent(out) :: icounted

    integer :: i, no, iret
    integer :: f_selectFirstTableLine,f_selectNextTableLine,f_getRealValue,f_getIntValue
    character(len=FMAXVALLEN) :: cret

    i = 1
    if( f_selectBlock( tag_symmetry_lines) == 0) then
       do
          if(i == 1) then
             if( f_selectFirstTableLine() /= 0 ) then
                exit
             end if
          else
             if( f_selectNextTableLine() /= 0 ) then
                exit
             end if
          end if
          if(.not.paramset) then
             if(i > num) exit
             no = i
             if(f_getIntValue(tag_no, iret) == 0) then
                no = iret
             else if(f_getIntValue(tag_id, iret) == 0) then
                no = iret
             end if
             if(no <= num) then
                if(f_getIntValue(tag_k1,iret) == 0) symln(no,1) = iret
                if(f_getIntValue(tag_k2,iret) == 0) symln(no,2) = iret
                if( f_getStringValue( tag_point_group, cret, NOCONV) == 0) then
                   pg_symln(no) = cret(1:3)
                else
                   pg_symln(no) = '' ! default value
                end if
                if(f_getIntValue(tag_num_division,iret) == 0) ndiv(no) = iret
                if(iret <= 0) ndiv(no) = 1 
             end if
          end if
          i = i+1
       end do
       iret = f_selectParentBlock()
    end if
    icounted = i - 1

  end subroutine read_symln

  subroutine set_phonon_method(rstr)
    character(len=FMAXVALLEN),intent(in) :: rstr
    logical :: tf
    call strncmp2(rstr, FMAXVALLEN, tag_gamma, len(tag_gamma), tf)
    if(.not.tf) &
    & call strncmp2(rstr, FMAXVALLEN, tag_zone_center, len(tag_zone_center), tf)
    if(tf) then
       phonon_method = PHONON_GAMMA
       goto 1001
    end if
    call strncmp2(rstr, FMAXVALLEN, tag_band, len(tag_band), tf)
    if(.not.tf) &
    & call strncmp2(rstr, FMAXVALLEN, tag_dispersion, len(tag_dispersion), tf)
    if(tf) then
       phonon_method = PHONON_BAND
       goto 1001
    end if
    call strncmp2(rstr, FMAXVALLEN, tag_dos, len(tag_dos), tf)
    if(tf) then
       phonon_method = PHONON_DOS
       goto 1001
    end if
1001 continue
  end subroutine set_phonon_method
  
end subroutine m_Phonon_rd_param

subroutine m_Phonon_alloc_qvec()
  integer :: isl,ishf
  real(kind=DP),allocatable,dimension(:,:,:) :: vkxyz_t
  real(kind=DP),allocatable,dimension(:) :: qwgt_t
  integer :: qnv3
  if(phonon_method == PHONON_GAMMA) then
     nqvec = 1
  else if(phonon_method == PHONON_BAND) then
     if(qvec_from_file==OFF)then
        nqvec = 0
        do isl=1,nsl
           ishf = 0
           if(isl/=nsl.and.symln(isl,2)==symln(isl+1,1)) ishf = 1
           nqvec = nqvec + ndiv(isl) + 1 - ishf
        end do
     else
        allocate(vkxyz_t(1,1,1))
        allocate(qwgt_t(1))
        qnv3=0
        call m_Files_open_kpoint_files(FILE,nbztyp_spg)
        call readk0(.true.,nfout,ipriphonon,qnv3,rltv,nfkpoint,nfmatbp &
          & ,nqvec,vkxyz_t,qwgt_t)
        write(nfout,'(a,i5)') ' !** number of k-points for the phonon-band calculation : ',nqvec
        deallocate(vkxyz_t)
        deallocate(qwgt_t)
     endif
  else if(phonon_method == PHONON_DOS) then
     call make_qpoint_set(0,nqvec,.true.) ! ipri=0, paramset = .true.
     allocate(wght(nqvec))
  end if

  allocate(qvec(nqvec,3))
  allocate(qvin(nqvec,3))
  allocate(qdir(nqvec,3))
  allocate(point_group(nqvec)); point_group = ''
  allocate(fksym(48,nqvec)); fksym = .false.
end subroutine m_Phonon_alloc_qvec

subroutine m_Phonon_set_qvec(nfout)
  integer, intent(in) :: nfout

  call set_qvec(nfout)
  call set_qvec_point_group(nfout)
  call wd_qvec(nfout)
contains
  subroutine set_qvec(nfout)
    integer,intent(in) :: nfout

    integer :: k1,k2
    integer :: i,isl,ishf,iqvec
    real(kind=DP) :: q1(3),q2(3),dq(3)
    real(kind=DP), allocatable, dimension(:,:,:) :: qvec_t
    real(kind=DP), allocatable, dimension(:) :: qw_t
    if(phonon_method == PHONON_GAMMA) then
       nqvec = 1
       qvec(nqvec,1:3) = 0.d0
       qvin(nqvec,1:3) = 0.d0
       qdir(nqvec,1:3) = kvec_dir(1:3)
       point_group(nqvec) = pg_gamma
    else if(phonon_method == PHONON_BAND) then
       if(qvec_from_file==OFF)then
          nqvec = 0
          do isl=1,nsl
             k1 = symln(isl,1)
             k2 = symln(isl,2)
             q1(1:3) = rltv(1:3,1)*spcpnt(k1,1) &
                & + rltv(1:3,2)*spcpnt(k1,2) &
                & + rltv(1:3,3)*spcpnt(k1,3)
             q2(1:3) = rltv(1:3,1)*spcpnt(k2,1) &
                & + rltv(1:3,2)*spcpnt(k2,2) &
                & + rltv(1:3,3)*spcpnt(k2,3)
             dq(1:3) = (q2(1:3)-q1(1:3))/ndiv(isl)  
             ishf = 0
             if(isl/=nsl.and.symln(isl,2)==symln(isl+1,1)) ishf = 1
             iqvec = nqvec + 1
             do i=0,ndiv(isl)-ishf
                nqvec = nqvec + 1
                qvec(nqvec,1:3) = i*dq(1:3)+q1(1:3)
                qdir(nqvec,1:3) = dq(1:3)
                point_group(nqvec) = pg_symln(isl)
             end do
             point_group(iqvec) = pg_spcpnt(k1)
             if(ishf==0) point_group(nqvec) = pg_spcpnt(k2)
          end do
       else
          allocate(qvec_t(nqvec,3,CRDTYP));qvec_t=0.d0
          allocate(qw_t(nqvec));qw_t=1.d0
          call readk0(.false.,nfout,ipriphonon,nqvec,rltv,nfkpoint,nfmatbp &
          & , nqvec, qvec_t, qw_t)
          qdir=0.d0
          do i=1,nqvec
             qvec(i,1:3) = qvec_t(i,1:3,CARTS)
          enddo
          do i=1,nqvec-1
             qdir(i,1) = qvec(i+1,1)-qvec(i,1)
             qdir(i,2) = qvec(i+1,2)-qvec(i,2)
             qdir(i,3) = qvec(i+1,3)-qvec(i,3)
          enddo
          if(nqvec>1) qdir(nqvec,:) = qdir(nqvec-1,:)
       endif
       do iqvec=1,nqvec
          do i=1,3
             qvin(iqvec,i) = sum(altv(1:3,i)*qvec(iqvec,1:3))/PAI2
          end do
       end do
    else if(phonon_method == PHONON_DOS) then
       call make_qpoint_set(1,nqvec,.false.) ! ipri=1, paramset = .false.
       do iqvec=1,nqvec
          do i=1,3
             qvin(iqvec,i) = sum(altv(1:3,i)*qvec(iqvec,1:3))/PAI2
          end do
          qdir(iqvec,1:3) = rltv(1:3,1)+rltv(1:3,2)+rltv(1:3,3)
       end do
    end if
  end subroutine set_qvec

  subroutine set_qvec_point_group(nfout)
    use m_Const_Parameters,  only: AUTOMATIC
    use m_Crystal_Structure, only: nopr,op,ig01,il,symmetry_method
    use m_CS_SpaceGroup,     only: lattice_system, &
                                 & get_kpoint_symmetry,get_point_group_name
    integer,intent(in) :: nfout

    integer :: i,j
    integer :: nopro,ig01o(48)
    integer :: nopro2,ig01o2(48)
    real(kind=DP) :: kvec(3)
    character(len=3) :: pg_name
    character(len=5) :: pg_name_i
    character(len=9) :: system

    if(symmetry_method==AUTOMATIC) then
       system = lattice_system
    else
       if(il>0) then
          system = 'cubic'
       else
          system = 'hexagonal'
       end if
    end if 

    do i=1,nqvec
       if(point_group(i) == '') then
          kvec = qvec(i,1:3)
          call get_kpoint_symmetry(nopr,ig01,op,kvec,nopro,ig01o,nopro2,ig01o2)
          do j=1,nopro2
             fksym(ig01o2(j),i) = .true.
          end do
          call get_point_group_name(nfout,system,nopro,ig01o,pg_name,pg_name_i)
          point_group(i) = pg_name
       else
          fksym(1:nopr,i) = .true.
       end if
    end do
  end subroutine set_qvec_point_group

  subroutine wd_qvec(nfout)
    integer,intent(in) :: nfout

    integer :: i
    if(ipriphonon > 0) then
       write(nfout,'("=== q-vectors ===")')
       write(nfout,'("number of q-vecotrs = ",i5)') nqvec
       write(nfout,'(4x,"i",5x,"qvec(3)",26x,"qvin(3)",22x,"point_group")')
       do i=1,nqvec
          write(nfout,'(i5,3(1x,f10.5),3(1x,f10.5),1x,a3)') i,qvec(i,1:3),qvin(i,1:3),point_group(i)
       end do
    end if
  end subroutine wd_qvec

end subroutine m_Phonon_set_qvec

subroutine make_qpoint_set(ipri,nqvec,paramset)
  use m_Crystal_Structure, only: il,inv,ngen,igen,jgen,a,b,c,ca,cb,cc
  integer, intent(in) :: ipri
  integer, intent(inout) :: nqvec
  logical, intent(in) :: paramset

  integer :: nx1,ny1,nz1
  integer :: nx,ny,nz
  integer :: nxx,nyy,nzz
  integer :: nd, lmnp0, lmnp1, lmnp2
  real(kind=DP), pointer, dimension(:,:) :: pa0,pb0,pb 
  integer,       pointer, dimension(:,:) :: ka0,ka2
  integer,       pointer, dimension(:,:) :: ip2cub_wk
  integer,       pointer, dimension(:)   :: nstar2
  integer                                :: i
  real(kind=DP) :: nv(3),trmat(3,3)

  nx = phonon_dos_mesh(1)
  ny = phonon_dos_mesh(2)
  nz = phonon_dos_mesh(3)
  call nskma0(il,nx,ny,nz,nxx,nyy,nzz,nx1,ny1,nz1,nd)

  lmnp0=(nxx+1)*(nyy+1)*(nzz+1)
  lmnp1=lmnp0
  lmnp2=lmnp0

  nxyz_tetra = 0
  allocate(ip10(lmnp0))  ; ip10 = 0        
  if(paramset) allocate(ip20(lmnp0))
  ip20 = 0        
  allocate(ip01(lmnp1))    ; ip01 = 0
  allocate(ip02(lmnp2))    ; ip02 = 0
  allocate(ip21(lmnp1))    ; ip21 = 0
  allocate(ip12(lmnp2))    ; ip12 = 0
  allocate(iu21(lmnp1))    ; iu21 = 0
  allocate(iv21(lmnp1))    ; iv21 = 0
  allocate(nstar2(lmnp2))  ; nstar2 = 0
  allocate(pa0(3,lmnp0))  ; pa0 = 0
  allocate(pb0(3,lmnp0))  ; pb0 = 0
  allocate(pb(3,lmnp2))  ; pb = 0
  allocate(ka0(4,lmnp0))  ; ka0 = 0
!!$  allocate(ka2(4,lmnp2))  ; ka2 = 0

  call setkp0_default_n(il,ngen,inv,igen,jgen,a,b,c,ca,cb,cc &
       &               ,nx,ny,nz &
       &               ,np2,np1,np0,lmnp0,lmnp1,lmnp2 &
       &               ,nxyz_tetra(1),nxyz_tetra(2),nxyz_tetra(3)&
       &               ,ip10,ip20,ip01,ip02,ip21,ip12,iu21,iv21 &
       &               ,nstar2,pa0,pb0,pb,ka0 &
       &               ,ipri)

  if(.not.paramset) then
     call get_trmat1  !-(contained here) ->(trmat)
     do i=1,nqvec
        nv(1:3) = dble(ka0(1:3,ip02(i)))/dble(ka0(4,ip02(i)))
        qvec(i,1:3) = matmul(trmat,nv)
        wght(i)     = dble(nstar2(i))/dble(np1)
     end do
  else
     nqvec = np2
  end if

  deallocate(ip10)
  deallocate(ip01)
  deallocate(ip02)
  deallocate(ip21)
  deallocate(ip12)
  deallocate(iu21)
  deallocate(iv21)
  deallocate(nstar2)
  deallocate(pa0)
  deallocate(pb0)
  deallocate(pb)
  deallocate(ka0)
!!$  deallocate(ka2)

  if(paramset) return

  allocate(iwt(np2)) ; iwt = 0
  allocate(ip2cub(np1)) ; ip2cub = 0

  allocate(ip2cub_wk(9,nxyz_tetra(1)*nxyz_tetra(2)*nxyz_tetra(3))) 
  ip2cub_wk = 0.d0
  call wtetra &
    &  (nxyz_tetra(1),nxyz_tetra(2),nxyz_tetra(3),np0,np2,ip20 &
    &  ,iwt,ip2cub &
    &  ,ip2cub_wk)
  deallocate(ip2cub_wk)
contains
  subroutine get_trmat1
    real(kind=DP), dimension(3,3) :: trbp,trpb,mat1,mat2
!    make translation matrix  trpb (P -> B)

    call getspgtab(trbp)  ! spg+tetra

    call inver3n(3,trbp,trpb)

    mat1 = transpose(trpb)
    call inver3n(3,mat1,mat2)
    call matpr3(rltv,mat2,trmat)

  end subroutine get_trmat1
end subroutine make_qpoint_set

subroutine m_Phonon_write_forces()
use m_IterationNumbers, only : iteration_ionic, iteration_electronic
use m_Files, only : nfforce, m_Files_open_nfforce
use m_Ionic_system, only : natm,num_force_calc,iconf
use m_Control_Parameters, only : num_phonon_calc_mode
use m_Force, only : forc_l
#ifdef WINDOWS
use ifport
#endif

! local variables
integer :: i,ic

if(.not.allocated(force_data)) allocate(force_data(natm_super,3,num_force_data))
ic = iconf(iteration_ionic)
force_data(1:natm_super,1:3,ic) = forc_l(1:natm_super,1:3)

if(mype /= 0) return

if(iteration_ionic == 1) then
   call m_Files_open_nfforce(.false.)  ! new file (asms)
   if(istart_phonon == 1) then
      if(sw_phonon_oneshot == ON) then
         write(nfforce,'(4(1x,i7),"  : num_force_calc, norder, sw_polynomial_fit, num_phonon_calc_mode")') &
              & num_force_calc,  norder, sw_polynomial_fit, num_phonon_calc_mode
      else
         write(nfforce,'(3(1x,i7),"  : num_force_calc, norder, sw_polynomial_fit")') &
              & num_force_calc, norder, sw_polynomial_fit
      end if
   end if
else
   call m_Files_open_nfforce(.true.)  ! append (asms)
end if
write(nfforce,'(i4,3(1x,e25.12),2i6,"  : displaced_atom, displacement(1:3), iteration_ionic,iteration_electronic")') &
     & displaced_atom,displacement(1:3),iteration_ionic,iteration_electronic
do i=1,natm_super
   write(nfforce,'(i4,3(1x,e25.12))') i,forc_l(i,1:3)
end do
call flush(nfforce)

end subroutine m_Phonon_write_forces

! ==== KT_add == 13.1R
subroutine m_Phonon_print_Raman_susc
  call m_Raman_calc_susceptibility( nmodes, omega, modes, &
       &                            mode_active, mode_irr_rep )
end subroutine m_Phonon_print_Raman_susc
! =============== 13.1R

function m_Phonon_Check_iteration(iteration_ionic)
use m_Control_Parameters, only : skip_alloc_phonon
use m_Crystal_Structure, only : m_CS_phonon_symmetry
use m_Ionic_System, only : m_IS_phonon_equilibrium, m_IS_cps_to_pos &
                       & , istart_phonon, iend_phonon, num_force_calc &
                       & , iconf
logical :: m_Phonon_Check_iteration
integer, intent(in) :: iteration_ionic
integer :: id

if(ipriphonon>=1) then
   id = iteration_ionic+istart_phonon-1
   write(nfout,*) 'PHONON: num_force_calc  = ',num_force_calc
   write(nfout,*) 'PHONON: istart, iend = ',istart_phonon, iend_phonon
   write(nfout,*) 'PHONON: id = ',id
   write(nfout,*) 'PHONON: iconf = ',iconf(id)
   write(nfout,*) 'PHONON: iteration_ionic = ',iteration_ionic
end if

if(iteration_ionic >= iend_phonon-istart_phonon+1 ) then
  m_Phonon_Check_iteration = .true.
  call m_IS_phonon_equilibrium()
  call m_IS_cps_to_pos()
  call m_CS_phonon_symmetry(ON)
else 
  m_Phonon_Check_iteration = .false.
end if
skip_alloc_phonon = .true.

end function m_Phonon_Check_iteration

subroutine m_Phonon_read_forces()
use m_Files,        only : m_Files_open_nfforce, nfforce
use m_Ionic_System, only : num_force_calc, napt_phonon, iequconf &
    &                    , iopr_equconf, iconf
use m_Crystal_Structure, only : op
#ifdef WINDOWS
use ifport
#endif
implicit none

! local variables
integer :: n,i,ia,ja,ind,j,ic,iopr
integer :: istart,idummy
character(len=5) :: num

if(ipriphonon>=1) write(nfout,*) '<< m_Phonon_read_forces >>: Reading forces'
call flush(nfout)

nmodes = natm_prim*3
allocate(forces(3*natm_super,nmodes,norder*2))
allocate(force0(3*natm_super))

!if(sw_calc_force == OFF) then
!   if(ipriphonon>=2) write(nfout,'(" sw_calc_force = OFF")')

  num_force_data = nmodes*norder*2
  if(sw_polynomial_fit == ON) num_force_data = num_force_data + 1
  if(.not.allocated(force_data)) allocate(force_data(natm_super,3,num_force_data))

  if(mype == 0) then
    call m_Files_open_nfforce(.false.)
    rewind nfforce
    read(nfforce,*) num_force_calc, norder, sw_polynomial_fit
    do i=1,num_force_calc
      read(nfforce,*) displaced_atom,displacement(1:3)
      ic = iconf(i)
      do ia=1,natm_super
        read(nfforce,*) idummy,force_data(ia,1:3,ic)
      end do
    end do
  end if

!else
!   if(ipriphonon>=2) write(nfout,'(" sw_calc_force = ON")')
!end if

if(ipriphonon>=2) write(nfout,'(" num_force_data = ",i8)') num_force_data
do i=1,num_force_data
   ic = iequconf(i)
   if(ipriphonon>=2) write(nfout,'(" i, ic = ",2i8)') i, ic
   if(ic >= 0) cycle
   ic = abs(ic)
   iopr = iopr_equconf(i)
   if(ipriphonon>=2) write(nfout,'(" i, ic, iopr = ",3i8)') i, ic,iopr
   do ia=1,natm_super
      ja = napt_phonon(ia,i)
      do j=1,3
         force_data(ia,j,ic) = (force_data(ia,j,ic) + dot_product(op(1:3,j,iopr),force_data(ja,1:3,i)))*0.5d0
      end do
   end do
end do

if(ipriphonon>=2) write(nfout,'(" num_force_data = ",i8)') num_force_data
do i=1,num_force_data
   ic = iequconf(i)
   if(ic == 0) cycle
   ic = abs(ic)
   iopr = iopr_equconf(i)
   if(ipriphonon>=2) write(nfout,'(" i, ic, iopr = ",3i8)') i, ic,iopr
   do ia=1,natm_super
      ja = napt_phonon(ia,i)
      do j=1,3
         force_data(ja,j,i) =  dot_product(op(j,1:3,iopr),force_data(ia,1:3,ic))
      end do
   end do
end do

if(sw_polynomial_fit == ON) then
  ind=1
  do ia=1,natm_super
    istart = 3*(ia-1)+1
    force0(istart:istart+2) = force_data(ia,1:3,ind)
  end do
else
  ind=0
end if
do i=1,nmodes
  do n=1,norder*2
    ind = ind+1
    do ia=1,natm_super
      istart = 3*(ia-1)+1
      forces(istart:istart+2,i,n) = force_data(ia,1:3,ind)
    end do
  end do
end do

if(npes>1) then
  call mpi_bcast(forces,3*natm_super*nmodes*norder*2,mpi_double_precision,0,mpi_comm_group,ierr) ! MPI
  call mpi_bcast(force0,3*natm_super,mpi_double_precision,0,mpi_comm_group,ierr) ! MPI
end if

if(ipriphonon>=1) write(nfout,*) '<< m_Phonon_read_forces >>: Forces are read.'
call flush(nfout)

! check sum of force
!!if(ipriphonon>=0) then
if(ipriphonon>=2) then
   write(nfout,*) "check sum of force"
   do i=1,num_force_data
      do j=1,3
         write(nfout,*) i,j,sum(force_data(1:natm_super,j,i))
      end do
   end do
end if

return
end subroutine m_Phonon_read_forces


subroutine m_Phonon_calc_dynamical_matrix()
use m_Crystal_Structure, only : univol, altv
implicit none

! local variables
integer :: i,j,k
integer :: istart
real(kind=DP) :: mi,ui

real(kind=DP) :: coefna
complex(kind=DP), allocatable :: nadynmat(:,:,:) ! dim(nmodes,nmodes,nqvec)
complex(kind=DP), allocatable :: nafd(:,:,:) ! dim(3,3,natm)
real(kind=DP) :: sum_rule(nmodes,3)
integer :: na,ia,ja,ir,jr,ira,jra,n
real(kind=DP) :: ae,ai,amelem
integer :: icell,nre,jas
real(kind=DP) :: r(3),re(3,8)
real(kind=DP) :: ph,w
complex(kind=DP) :: expqr
integer :: ii,jj,iu,ju
integer :: iq
real(kind=DP) :: s(3)
integer :: ng,nr
real(kind=DP), allocatable :: gv(:,:),rv(:,:)
real(kind=DP) :: g2bz

real(kind=DP), parameter :: eps = 1.d-6

allocate(dynmat(nmodes,nmodes,nlpnt))
allocate(dynmatq(nmodes,nmodes,nqvec))
allocate(msqinv(nmodes))

call m_Phonon_force_constant_matrix(dynmat)

deallocate(forces)
deallocate(force0)

if(ipriphonon >=2) then
! output
   write(nfout,*) 'calculated force constants:'
   call write_dynmat(dynmat)
end if

! symmetrized force constants in Real space
call symmetrize_force_const_Real(dynmat)
if(ipriphonon >=2) then
! output
   write(nfout,*) 'symmetrized force constants:'
   call write_dynmat(dynmat)
end if

! check sum rule of force constants
if(ipriphonon >=2) &
  & write(nfout,*) 'j ir sum_of_force_constants'
do ia=1,natm_prim
   do ir=1,3
      i = (ia-1)*3+ir
      do jr=1,3
         sum_rule(i,jr)=0
         do n=1,nlpnt
            do ja=1,natm_prim
               j=(ja-1)*3+jr
               if(n==1.and.ia==ja) cycle
               sum_rule(i,jr) = sum_rule(i,jr) + dynmat(i,j,n) 
            end do
         end do
         if(ipriphonon >=2) then
            j=(ia-1)*3+jr
            write(nfout,*) i,jr,sum_rule(i,jr)+dynmat(i,j,1)
         end if
      end do
   end do 
end do
! correct force constants
if(sw_correct_force_constants == ON) then
   do i=1,nmodes
      ia = (i+2)/3
      do jr=1,3
         j=(ia-1)*3+jr
         dynmat(i,j,1) = - sum_rule(i,jr)
      end do
   end do
end if

! output
if(sw_correct_force_constants == ON) then
   if(printable) write(nfout,*) '*** Force constants were corrected. ***'
   if(ipriphonon >=2) then
      write(nfout,*) 'Corrected force constants:'
      call write_dynmat(dynmat)
   end if
else
   if(printable) write(nfout,*) '*** Force constants were NOT corrected. ***'
end if

! Fourier transform of force constants
dynmatq(:,:,:) = dcmplx(0.d0,0.d0)
do n=1,nqvec
   !!$write(nfout,*) 'qvin=',qvin(n,1:3)
   !!$write(nfout,*) 'qvec=',qvec(n,1:3)
   do icell=1,nlpnt
      do j=1,nmodes
         ja = (j-1)/3 + 1
         !!$ju = mod(j-1,3)
         jas = ja + (icell-1)*natm
         do i=1,nmodes
            ia = (i-1)/3 + 1
            !!$iu = mod(i-1,3)
            !!$r(1:3) = cps(jas,1:3)-cps(ia,1:3)
            r(1:3) = cps(ia,1:3)-cps(jas,1:3)
            call get_pos_in_extcell(r,nre,re)
            expqr = dcmplx(0.d0,0.d0)
            do k=1,nre
               ph = sum(qvec(n,1:3)*re(1:3,k))
               expqr = expqr + dcmplx(cos(ph),sin(ph))
            end do
            expqr = expqr/dble(nre)
            !!$write(nfout,*) 'ia,ja,i,j=',ia,ja,i,j
            !!$write(nfout,'("r =",3f10.5)') r(1:3)
            !!$do k=1,nre
            !!$   write(nfout,'("k,re =",i3,3f10.5)') k,re(1:3,k)
            !!$end do
            !!$write(nfout,*) 'ph,expqr=',ph,expqr

            dynmatq(i,j,n) = dynmatq(i,j,n)+dynmat(i,j,icell)*expqr
            !!$ii = (ja-1)*3 + iu + 1
            !!$jj = (ia-1)*3 + ju + 1
            !!$dynmatq(ii,jj,n) = dynmatq(ii,jj,n)+dynmat(i,j,icell)*expqr
         end do
      end do
   end do
end do
deallocate(dynmat)

if(ipriphonon >=2) then
! output
   write(nfout,*) 'Force constant matrix in Fourier space:'
   call write_dynmatq(dynmatq)
end if

! symmetrized force constants in Fourier space
call symmetrize_force_const_Fourier(dynmatq)

if(ipriphonon >=2) then
! output
   write(nfout,*) 'Symmetrized force constants Fourier space:'
   call write_dynmatq(dynmatq)
end if


if(ipriphonon >=2) then
! output
   write(nfout,*) 'Dynamical matrix in Fourier space:'
   call write_dynmatq(dynmatq)
end if

! non-analytic part
if(sw_lo_to_splitting == ON) then
   allocate(nadynmat(nmodes,nmodes,nqvec))
   call get_g2bz(g2bz)
   do iq=1,nqvec
      s = qvin(iq,1:3)
      call mod1(s)
      if(abs(sum(s(1:3)**2)) < eps) then
        ! Gamma point
         call calc_napart_gamma(iq,nadynmat(1,1,iq))
      else
         call calc_napart_parlinski(iq,nadynmat(1,1,iq),g2bz)
      end if
   end do

   if(ipriphonon >=2) then
   ! output
      write(nfout,*) 'Non-analytic part of force constant matrix in Fourier space:'
      call write_dynmatq(nadynmat)
   end if

   do iq=1,nqvec
      do j=1,nmodes
         do i=1,nmodes
            dynmatq(i,j,iq) = dynmatq(i,j,iq) + nadynmat(i,j,iq)
         end do
      end do
   end do

   if(ipriphonon >=2) then
   ! output
      write(nfout,*) 'Total force constant matrix in Fourier space:'
      call write_dynmatq(dynmatq)
   end if

   deallocate(nadynmat)

end if

! calculate 1/sqrt(mass)
do i=1,natm_prim
   istart=3*(i-1)+1
   mi = 1.d0/sqrt(ionic_mass(i))
   msqinv(istart) = mi
   msqinv(istart+1) = mi
   msqinv(istart+2) = mi
end do
if(ipriphonon > 1) then
   do i=1,nmodes
      write(nfout,*) 'debug: i= ',i,' msqinv = ',msqinv(i)
   end do
end if

! calculate dynamical matrix in Fourier space
do n=1,nqvec
   do j=1,nmodes
      do i=1,nmodes
         dynmatq(i,j,n) = dynmatq(i,j,n)*msqinv(i)*msqinv(j)
      end do
   end do
end do


do iq=1,nqvec
   !search the absolute maximum element
   amelem = abs(dynmatq(1,1,iq))
   do i=1,nmodes
      do j=i,nmodes
         ae = abs(dynmatq(i,j,iq))
         if(ae > amelem) amelem = ae
      end do
   end do
   if(ipriphonon >=2) then
      write(nfout,*) 'amelem = ',amelem
   end if
   do i=1,nmodes
      do j=1,nmodes
         ae = dble(dynmatq(i,j,iq))
         ai = dimag(dynmatq(i,j,iq))
         if(abs(ae) < amelem*1.d-14) ae = 0.d0
         if(abs(ai) < amelem*1.d-14) ai = 0.d0
         dynmatq(i,j,iq) = dcmplx(ae,ai)
      end do
   end do
end do
if(ipriphonon >=2) then
   ! output
   write(nfout,*) 'Dynamical matrix after removing small elements:'
   call write_dynmatq(dynmatq)
end if

return

contains
  subroutine get_pos_in_extcell(r,nre,re)
    real(kind=DP), intent(in) :: r(3)
    integer, intent(out) :: nre
    real(kind=DP), intent(out) :: re(3,8)

    integer :: i,j,k,n(3),l
    real(kind=DP) :: s(3),p(3)
    real(kind=DP) :: eps = 1.d-6

    do i=1,3
       s(i) = sum(rltv_super(1:3,i)*r(1:3))/PAI2
    end do
    call mod1(s)
    do i=1,3
       n(i) = 1
       if(abs(s(i)-0.5d0)<eps) n(i) = 2
    end do
    do i=1,3
       if(s(i)>0.5d0-eps) s(i) = s(i) - 1.d0
    end do
    nre = 0
    do k=1,n(3)
       do j=1,n(2)
          do i=1,n(1)
             nre = nre + 1
             p(1) = s(1)+i-1
             p(2) = s(2)+j-1
             p(3) = s(3)+k-1
             do l=1,3
                re(l,nre) = sum(altv_super(l,1:3)*p(1:3))
             end do
          end do
       end do
    end do
  end subroutine get_pos_in_extcell

  subroutine mod1(t)
    real(kind=DP), intent(inout) :: t(3)
    real(kind=DP), parameter :: eps = 1.d-6
    integer :: k
    t(1:3) = mod(t(1:3),1.d0)
    do k=1,3
       if(t(k) < -eps) t(k) = t(k) + 1.d0
       if(t(k) > 1.d0 - eps) t(k) = t(k) - 1.d0
    end do
  end subroutine mod1

  subroutine symmetrize_force_const_Real(fc)
  use m_Crystal_Structure, only : nopr,op,tau
  real(kind=DP), intent(inout) :: fc(nmodes,nmodes,nlpnt)
  ! local variables
  integer :: i,j,icell,jcell,kcell,irc,jrc
  integer :: nr(natm,nlpnt),l(3,nlpnt),lx(3),ll(3)
  integer :: lr(natm,nlpnt),llr(nlpnt,nlpnt)
!!$  real(kind=DP) :: nonsym_fc(nmodes,nmodes,nlpnt)
  real(kind=DP),allocatable,dimension(:,:,:) :: nonsym_fc
  real(kind=DP) :: tensor(3,3)
  real(kind=DP) :: x(3),y(3)
  real(kind=DP) :: aa(3,3)
  real(kind=DP) :: eps = 1.d-6
  allocate(nonsym_fc(nmodes,nmodes,nlpnt));nonsym_fc=0.d0
  nonsym_fc(1:nmodes,1:nmodes,1:nlpnt) = fc(1:nmodes,1:nmodes,1:nlpnt)
  fc(1:nmodes,1:nmodes,1:nlpnt) = 0.d0

  do icell=1,nlpnt
     l(1:3,icell) = nint(matmul(transpose(rltv),lpnt(icell,1:3))/PAI2)
  end do

  aa = matmul(transpose(rltv_super),altv)/PAI2
  do icell=1,nlpnt
     do jcell=1,nlpnt
        ll = l(1:3,jcell)-l(1:3,icell)
        do kcell=1,nlpnt
           x = matmul(aa,ll-l(1:3,kcell))
           if(sum(abs(x-nint(x)))<eps) then
             llr(icell,jcell) = kcell
             exit
           end if
        end do
     end do
  end do

  do n=1,nopr
     do icell=1,nlpnt
        ATOM: do i=1,natm
           x(1:3) = cps(i,1:3) + lpnt(icell,1:3)
           y = matmul(op(1:3,1:3,n),x) + tau(1:3,n,CARTS)
           do j=1,natm
              x = y-cps(j,1:3)
              x = matmul(transpose(rltv),x)/PAI2
              lx = nint(x(1:3))
              if(sum(abs(x-lx))<eps) then
                 nr(i,icell) = j
                 do jcell=1,nlpnt
                    ll = lx-l(1:3,jcell)
                    x = matmul(aa,ll)
                    if(sum(abs(x-nint(x)))<eps) then
                       lr(i,icell) = jcell
                       exit
                    end if
                 end do
                 cycle ATOM
              end if
           end do
           write(nfout,'("No equivalent atom for the atom ",i5," in the cell ",i5)') i,icell
           stop 'No equivalent atom'
        end do ATOM
     end do
     icell = 1
     do jcell=1,nlpnt
        do j=1,natm 
           ja=3*(j-1)+1
           jr=nr(j,jcell)
           jra=3*(jr-1)+1
           jrc = lr(j,jcell)
           do i=1,natm
              ia=3*(i-1)+1
              ir=nr(i,icell)
              ira=3*(ir-1)+1
              irc = lr(i,icell)
              kcell = llr(irc,jrc)
              tensor(1:3,1:3)=nonsym_fc(ia:ia+2,ja:ja+2,jcell)
              call rotate_tensor(tensor,n)
              fc(ira:ira+2,jra:jra+2,kcell)= &
                 & fc(ira:ira+2,jra:jra+2,kcell) + tensor(1:3,1:3)
           end do
        end do
     end do
  end do
  fc(1:nmodes,1:nmodes,1:nlpnt) = fc(1:nmodes,1:nmodes,1:nlpnt)/nopr
  deallocate(nonsym_fc)
  end subroutine symmetrize_force_const_Real

  subroutine rotate_tensor(tensor,n)
  use m_Crystal_Structure, only : op
  real(kind=DP), intent(inout) :: tensor(3,3)
  integer, intent(in) :: n ! index of rotation

  ! local variables
  integer :: i,j,k,l
  real(kind=DP) :: tnew(3,3)
 
  tnew(1:3,1:3)=0.d0

  do l=1,3
    do i=1,3
      do k=1,3
        do j=1,3
          !!$tnew(i,l)=tnew(i,l)+op(j,i,n)*tensor(j,k)*op(k,l,n)
          tnew(i,l)=tnew(i,l)+op(i,j,n)*tensor(j,k)*op(l,k,n)
        end do
      end do
    end do
  end do
  
  tensor(1:3,1:3)=tnew(1:3,1:3)
  end subroutine rotate_tensor

  subroutine symmetrize_force_const_Fourier(fcq)
  use m_Ionic_System, only : napt
  use m_Crystal_Structure, only : nopr,op
  complex(kind=DP), intent(inout) :: fcq(nmodes,nmodes,nqvec)
  ! local variables
  integer :: i,j,nop,iq
!!$  complex(kind=DP) :: nonsym_fcq(nmodes,nmodes,nqvec)
  complex(kind=DP),allocatable,dimension(:,:,:) :: nonsym_fcq
  complex(kind=DP) :: tensor(3,3)
  complex(kind=DP) :: expgr
  real(kind=DP) :: ph,g(3)

  allocate(nonsym_fcq(nmodes,nmodes,nqvec));nonsym_fcq=0.d0
  nonsym_fcq(1:nmodes,1:nmodes,1:nqvec) = fcq(1:nmodes,1:nmodes,1:nqvec)
  fcq(1:nmodes,1:nmodes,1:nqvec) = 0.d0

  do iq=1,nqvec
     nop = 0
     do n=1,nopr
        if(.not.fksym(n,iq)) cycle
        nop = nop + 1
        g = matmul(op(1:3,1:3,n),qvec(iq,1:3)) - qvec(iq,1:3)
        do j=1,natm
           ja=3*(j-1)+1
           jr=napt(j,n)
           jra=3*(jr-1)+1
           do i=1,natm
              ia=3*(i-1)+1
              ir=napt(i,n)
              ira=3*(ir-1)+1
              ph = dot_product(g,cps(j,1:3)-cps(i,1:3))
              expgr = dcmplx(cos(ph),sin(ph))
              tensor(1:3,1:3)=nonsym_fcq(ira:ira+2,jra:jra+2,iq)
              call rotate_complex_tensor(tensor,n)
              fcq(ia:ia+2,ja:ja+2,iq)= &
                 & fcq(ia:ia+2,ja:ja+2,iq) + tensor(1:3,1:3)*expgr
           end do
        end do
     end do
     fcq(1:nmodes,1:nmodes,iq) = fcq(1:nmodes,1:nmodes,iq)/nop
  end do
  deallocate(nonsym_fcq)
  do iq=1,nqvec
     do j=1,nmodes
        do i=1,j
           fcq(i,j,iq)=(fcq(i,j,iq)+dconjg(fcq(j,i,iq)))*0.5d0
           fcq(j,i,iq)=dconjg(fcq(i,j,iq))
        end do
     end do
  end do

  end subroutine symmetrize_force_const_Fourier


  subroutine rotate_complex_tensor(tensor,n)
  use m_Crystal_Structure, only : op
  complex(kind=DP), intent(inout) :: tensor(3,3)
  integer, intent(in) :: n ! index of rotation

  ! local variables
  integer :: i,j,k,l
  complex(kind=DP) :: tnew(3,3)
 
  tnew(1:3,1:3)=0.d0

  do l=1,3
    do i=1,3
      do k=1,3
        do j=1,3
          tnew(i,l)=tnew(i,l)+op(j,i,n)*tensor(j,k)*op(k,l,n)
        end do
      end do
    end do
  end do
  
  tensor(1:3,1:3)=tnew(1:3,1:3)
  end subroutine rotate_complex_tensor

  subroutine write_dynmat(dynmat)
    real(kind=DP), intent(in) :: dynmat(nmodes,nmodes,nlpnt)
    integer :: icell,l1,l2,l3,n
    do icell=1,nlpnt
       l1 = nint(sum(rltv(1:3,1)*lpnt(icell,1:3))/PAI2)
       l2 = nint(sum(rltv(1:3,2)*lpnt(icell,1:3))/PAI2)
       l3 = nint(sum(rltv(1:3,3)*lpnt(icell,1:3))/PAI2)
       write(nfout,'("icell=",i4," l1=",i3," l2=",i3," l3=",i3," lp=",3f10.5)') icell,l1,l2,l3,lpnt(icell,1:3)
       do n=1,nmodes
          write(nfout,'(50(1x,e12.5))') dynmat(n,1:nmodes,icell)
       end do
    end do
  end subroutine write_dynmat

  subroutine write_dynmatq(dynmatq)
    complex(kind=DP), intent(in) :: dynmatq(nmodes,nmodes,nqvec)
    integer :: iq
    do iq=1,nqvec
       write(nfout,'(i4," q=(",f8.3,",",f8.3,",",f8.3,")")') iq,qvin(iq,1:3)
       write(nfout,'("=== Real part ===")') 
       do n=1,nmodes
          write(nfout,'(50(1x,e12.5))') dble(dynmatq(n,1:nmodes,iq))
       end do
       write(nfout,'("=== Imag part ===")') 
       do n=1,nmodes
          write(nfout,'(50(1x,e12.5))') dimag(dynmatq(n,1:nmodes,iq))
       end do
    end do
  end subroutine write_dynmatq

  subroutine calc_napart_gamma(iq,nafc)
    integer, intent(in) :: iq
    complex(kind=DP), intent(out) :: nafc(nmodes,nmodes)

    real(kind=DP) :: coefna,kzeff(nmodes)
    integer :: i,j,na,ia

    coefna = 0.d0
    do j=1,3
       do i=1,3
          coefna = coefna + qdir(iq,i)*dielectric(i,j)*qdir(iq,j)
       end do
    end do
    coefna = PAI4/(univol*coefna)
    i=0
    do na=1,natm
       do ia=1,3
          i=i+1
          kzeff(i) = sum(qdir(iq,1:3)*zeff(1:3,ia,na))
       end do
    end do
    do j=1,nmodes
       do i=1,nmodes
          nafc(i,j) = coefna*kzeff(i)*kzeff(j)
       end do
    end do

  end subroutine calc_napart_gamma

  subroutine calc_napart_parlinski(iq,nafc,g2bz)
    integer, intent(in) :: iq
    complex(kind=DP), intent(out) :: nafc(nmodes,nmodes)
    real(kind=DP), intent(in) :: g2bz

    real(kind=DP) :: coefna,kzeff(nmodes)
    real(kind=DP) :: expk,rho2
    integer :: i,j,na,ia

    rho2 = rho_loto**2*g2bz*0.25d0

    coefna = 0.d0
    do j=1,3
       do i=1,3
          coefna = coefna + qvec(iq,i)*dielectric(i,j)*qvec(iq,j)
       end do
    end do
    coefna = PAI4/(univol*coefna)
    i=0
    do na=1,natm
       do ia=1,3
          i=i+1
          kzeff(i) = sum(qvec(iq,1:3)*zeff(1:3,ia,na))
       end do
    end do
    expk = exp(-PAI**2*sum(qvec(iq,1:3)**2)/rho2)
    do j=1,nmodes
       do i=1,nmodes
          nafc(i,j) = coefna*kzeff(i)*kzeff(j)*expk
       end do
    end do

  end subroutine calc_napart_parlinski

  subroutine get_g2bz(g2)
    real(kind=DP), intent(out) :: g2

    integer :: i,j,k
    real(kind=DP) :: g(3),gg

    g2 = dot_product(rltv(1:3,1),rltv(1:3,1))
    do i=-2,2
       do j=-2,2
          do k=-2,2
             g(1:3) = i*rltv(1:3,1)+j*rltv(1:3,2)+k*rltv(1:3,3)
             gg = dot_product(g,g)
             if(abs(gg) > eps .and. gg < g2) then
                g2 = gg
             end if
          end do
       end do
    end do
  end subroutine get_g2bz

end subroutine m_Phonon_calc_dynamical_matrix

subroutine m_Phonon_force_constant_matrix(force_const_mat)
implicit none

real(kind=DP), intent(out) :: force_const_mat(nmodes,nmodes,nlpnt)

! local variables
integer :: is,nc,ind,i,j,jj,ic,icell
real(kind=DP) :: ui,x
real(kind=DP), allocatable :: cmat(:,:) !dim(nc,nc)
real(kind=DP), allocatable :: fvec(:) !dim(nc)

if(sw_polynomial_fit == ON) then
  nc = norder*2+1
  allocate(cmat(nc,nc)); cmat = 0.d0
  allocate(fvec(nc))
  cmat(1:nc,1) = 1.d0
  ind = 1
  do is = -norder,norder
    if(is==0) cycle
    ind=ind+1
    x = u/dble(is)
    do i=2,nc
       cmat(ind,i) = x**(i-1)
    end do
  end do
  do ic=1,nlpnt
     do j=1,nmodes
        jj = nmodes*(ic-1)+j
        do i=1,nmodes
           fvec(1) = force0(jj)
           fvec(2:nc) = forces(jj,i,1:nc-1)
           force_const_mat(i,j,ic) = -polyfit_diff(nc,cmat,fvec)
        end do
     end do
  end do
else
  ui=dble(norder)/u
  if(printable .and. ipriphonon>=2) then
     write(nfout,*) 'u=',u
     write(nfout,*) 'ui= norder/u =',ui
  endif
  if(norder == 1) then
    ui = -0.5d0*ui
    do ic=1,nlpnt
       do j=1,nmodes
          jj = nmodes*(ic-1)+j
          do i=1,nmodes
             force_const_mat(i,j,ic) = (forces(jj,i,2)-forces(jj,i,1))*ui
          end do
       end do
    end do
  else if(norder == 2) then
    ui = -ui/12.d0
    do ic=1,nlpnt
       do j=1,nmodes
          jj = nmodes*(ic-1)+j
          do i=1,nmodes
             force_const_mat(i,j,ic) = (-8.d0*forces(jj,i,1)+forces(jj,i,2) &
                             &  -forces(jj,i,3)+8.d0*forces(jj,i,4))*ui
          end do
       end do
    end do
  else
    stop 'Your inputed norder is not supported for the differencial approximation.'
  end if
end if

contains

function polyfit_diff(nd,mat,vec)
implicit none

real(kind=DP) :: polyfit_diff

integer, intent(in) :: nd
real(kind=DP), intent(in) :: mat(nd,nd)
real(kind=DP), intent(in) :: vec(nd)

! local variables
integer :: ipiv(nd),info,i
real(kind=DP) :: a(nd,nd),b(nd)
real(kind=DP) :: x0,df
real(kind=DP) :: xold
real(kind=DP) :: eps = 1.d-10

real(kind=DP) :: ux

! debug
!  write(nfout,*) '<<polyfit_diff>>'
!  call flush(nfout)
! end debug

a = mat
b = vec

!debug
!do i=1,nd
!  write(nfout,*) 'a=',a(i,1:nd)
!end do
!do i=1,nd
!  write(nfout,*) 'b=',b(i)
!end do
!  call flush(nfout)
!end debug

call dgesv(nd,1,a,nd,ipiv,b,nd,info)
if(info .ne. 0 ) then
   if(printable) write(nfout,*) 'LAPACK routine DGETRS failure: info=',info
  stop 'LAPACK routine DGETRS failure'
end if
! debug
!  do i=1,nd
!    print *,'i=',i,' b=',b(i)
!  end do
!  write(nfout,'("ux="f10.5," f=",2(1x,f15.10))') ux,vec(1),polyfunc(nd,b,0.d0)
!  i=0
!  do is=-norder,norder
!    if(is==0) cycle
!    i=i+1
!    ux = u/dble(is) 
!    write(nfout,'("ux="f10.5," f=",2(1x,f15.10))') ux,vec(i+1),polyfunc(nd,b,ux)
!  end do
!  call flush(nfout)
! end debug

x0 = 0.d0
df = diff_polyfunc(nd,b,x0)
  ! debug
  !print *,'df=',df
  ! end debug
polyfit_diff = df

end function polyfit_diff

function polyfunc(nd,b,x)
implicit none

real(kind=DP) :: polyfunc

integer, intent(in) :: nd
real(kind=DP), intent(in) :: b(nd),x

integer :: i
real(kind=DP) :: f

f = b(1)
do i=2,nd
  f = f + b(i)*x**(i-1)
end do
polyfunc = f

end function polyfunc

function diff_polyfunc(nd,b,x)
implicit none

real(kind=DP) :: diff_polyfunc

integer, intent(in) :: nd
real(kind=DP), intent(in) :: b(nd),x

integer :: i
real(kind=DP) :: df

df = b(2)
do i=3,nd
  df = df + b(i)*dble(i-1)*x**(i-2)
end do
diff_polyfunc = df

end function diff_polyfunc

end subroutine m_Phonon_force_constant_matrix


subroutine m_Phonon_calc_vib_modes()
implicit none

! local variables
integer :: i,j
!!$real(DP) :: eps=1.d-8
real(DP) :: eps=1.d-16
real(DP) :: norm

allocate(omega(nmodes,nqvec),modes(nmodes,nmodes,nqvec))

write(nfout,*) 'calc_vib_modes is started.'

do j=1,nqvec
   write(nfout,'(i4," q=(",f8.3,",",f8.3,",",f8.3,")")') j,qvin(j,1:3)
   call solve_eigenproblem(dynmatq(1,1,j) ,omega(1,j),modes(1,1,j))
   do i=1,nmodes
      if(ipriphonon>=2) &
      & write(nfout,*) 'omega**2 = ',omega(i,j)  
      if(abs(omega(i,j)) < eps) omega(i,j)=0.d0
      if(omega(i,j) > 0.d0) then
         omega(i,j)=sqrt(omega(i,j))
      else
         omega(i,j)=-sqrt(abs(omega(i,j))) ! for the soft mode
      end if 
      if(ipriphonon >=2) &
       & write(nfout,*) '==> omega = ',omega(i,j)  
   end do
end do

deallocate(dynmatq)

contains
  subroutine solve_eigenproblem(dynmat,omega,modes)
    complex(kind=DP), intent(inout) :: dynmat(nmodes,nmodes)
    real(kind=DP), intent(out)      :: omega(nmodes)
    complex(kind=DP), intent(out)   :: modes(nmodes,nmodes)

    real(kind=DP) :: abstol
    integer :: lcwork,lrwork,liwork
    complex(kind=DP), allocatable :: cwork(:) ! dim(lcwork)
    real(kind=DP), allocatable :: rwork(:) ! dim(lrwork)
    integer, allocatable :: iwork(:) ! dim(liwork)
    integer, allocatable :: ifail(:) ! dim(nmodes)
    integer :: info
    integer :: m
    integer :: il,iu
    real(DP) :: vl,vu

    real(DP), external :: dlamch

    abstol=2*dlamch('S')
    !abstol=4.45014771701440D-308
    !print *,'abstol=',abstol
    !!$lwork=8*nmodes
    lcwork=4*nmodes
    lrwork=7*nmodes
    liwork=5*nmodes
    !!$allocate(work(lwork))
    allocate(cwork(lcwork))
    allocate(rwork(lrwork))
    allocate(iwork(liwork),ifail(nmodes))
    lcwork=-1
    call zheevx('V','A','U',nmodes,dynmat,nmodes,vl,vu,il,iu,abstol, &
     &      m,omega,modes,nmodes,cwork,lcwork,rwork,iwork,ifail,info)
    !!$call dsyevx('V','A','U',nmodes,dynmat,nmodes,vl,vu,il,iu, &
    !!$ &      abstol,m,omega,modes,nmodes,work,lwork,iwork, &
    !!$ &      ifail,info)
    lcwork = cwork(1)
    !print *,'lwork=',lwork
    !print *,'info=',info
    deallocate(cwork)
    allocate(cwork(lcwork))
    call zheevx('V','A','U',nmodes,dynmat,nmodes,vl,vu,il,iu,abstol, &
     &      m,omega,modes,nmodes,cwork,lcwork,rwork,iwork,ifail,info)
    !!$call dsyevx('V','A','U',nmodes,dynmat,nmodes,vl,vu,il,iu, &
    !!$ &      abstol,m,omega,modes,nmodes,work,lwork,iwork, &
    !!$ &      ifail,info)
    !print *,'info=',info
    !print *,'ifail=',ifail(1:nmodes)
    deallocate(cwork,rwork,iwork,ifail)
  end subroutine solve_eigenproblem
end subroutine m_Phonon_calc_vib_modes

subroutine m_Phonon_det_irr_rep()
use m_Representation, only : get_irr_rep
use m_Crystal_Structure, only : nopr
implicit none

! local variabes
integer :: i,j,ia,ja,ist,n
real(DP) :: norm
real(DP) :: eir(3),ejr(3),xir(1:nmodes)
real(DP) :: eii(3),eji(3),xii(1:nmodes)
integer :: nrep,nsym
integer :: rep(48,12)
character(len=3) :: symbol_irrep(12)
character(len=4) :: active_rep(12)
real(DP) :: eps = 1.d-1
integer :: iq

write(nfout,*) '** Representation **'

allocate(mode_irr_rep(nmodes,nqvec))
allocate(mode_active(nmodes,nqvec))
do iq=1,nqvec
   write(nfout,'(i4," q=(",f8.3,",",f8.3,",",f8.3,")")') iq,qvin(iq,1:3)
   call get_irr_rep(point_group(iq),nsym,nrep,rep,symbol_irrep,active_rep)

   if(printable)  then
      write(nfout,'("Character table:",a3)') point_group(iq)
      do j=1,nrep
         write(nfout,'(a3,1x,48i3)') symbol_irrep(j), rep(1:nsym,j)
      end do 
   end if
! debug
!write(nfout,'("Product table:",a3)') point_group
!do j=1,nrep
!  write(nfout,'(a3,1x,48i3)') symbol_irrep(j),(sum(rep(1:nopr,j)*rep(1:nopr,i)),i=1,nrep)
!end do
! end debug


   do i=1,nmodes
! debug
!        write(nfout,*) 'index of the mode =',i
!        write(nfout,*) 'norm =',sum(dble(modes(1:nmodes,i,iq))**2+dimag(modes(1:nmodes,i,iq))**2)
! end debug
      mode_irr_rep(i,iq)='NON'
      Representation: do j=1,nrep
         xir(1:nmodes)=0.d0
         xii(1:nmodes)=0.d0
         do n=1,nopr
            do ia=1,natm
               ist = 3*(ia-1)+1
               eir(1:3) = dble(modes(ist:ist+2,i,iq))
               eii(1:3) = dimag(modes(ist:ist+2,i,iq))
               call rotate_eigenvector(n,ia,ja,eir,ejr)
               call rotate_eigenvector(n,ia,ja,eii,eji)
               ist = 3*(ja-1)+1
               xir(ist:ist+2)=xir(ist:ist+2)+rep(n,j)*ejr(1:3)
               xii(ist:ist+2)=xii(ist:ist+2)+rep(n,j)*eji(1:3)
! debug
!        write(nfout,*) 'j =',j
!        write(nfout,*) 'n =',n
!        write(nfout,*) 'ia=',ia
!        write(nfout,*) 'eir=',eir(1:3)
!        write(nfout,*) 'eii=',eii(1:3)
!        write(nfout,*) 'ja=',ja
!        write(nfout,*) 'ejr=',ejr(1:3)
!        write(nfout,*) 'eji=',eji(1:3)
! end debug
            end do 
         end do
         !xi(1:nmodes) = xi(1:nmodes)/nopr 
         norm = sum(xir(1:nmodes)**2+xii(1:nmodes)**2)
         ! debug
         !write(nfout,*) 'j=',j,' norm=',norm
         ! end debug
         if(norm > eps) then
            mode_irr_rep(i,iq)= symbol_irrep(j)
            mode_active(i,iq) = active_rep(j)
            ! exit Representation
         end if
      end do Representation
      if(printable) write(nfout,'(1x,i5,1x,a3,1x,a4)') i,mode_irr_rep(i,iq),mode_active(i,iq)
   end do
end do ! q loop

contains

  subroutine rotate_eigenvector(n,ia,ja,ei,ej)
  use m_Ionic_System, only : napt
  use m_Crystal_Structure, only : op
  integer, intent(in) :: n, ia
  integer, intent(out) :: ja
  real(kind=DP), intent(in) :: ei(3)
  real(kind=DP), intent(out) :: ej(3)
  
  ! local variables
  integer :: i

  ja = napt(ia,n)
 
  do i=1,3
    ej(i) = sum(op(i,1:3,n)*ei(1:3))
  end do
 
  end subroutine rotate_eigenvector

end subroutine m_Phonon_det_irr_rep


subroutine m_Phonon_calc_static_dielectric()
use m_Crystal_Structure, only : univol
implicit none

! local variables
integer :: im,i,na,ia,j
real(DP) :: zsum
real(DP) :: coef

if(sw_lo_to_splitting == ON) return
if(nqvec/=1) return

allocate(zeff_mode(3,nmodes))
do im=1,nmodes
  do i=1,3
    zsum = 0.d0
    j=0
    do na=1,natm
      do ia=1,3
        j=j+1
        zsum = zsum + zeff(i,ia,na)*dble(modes(j,im,nqvec))*msqinv(j)
      end do
    end do
    zeff_mode(i,im) = zsum
  end do
end do 

coef = 16.d0*atan(1.d0)/univol
lattice_dielectric(1:3,1:3) = 0.d0
do im=1,nmodes
  if(omega(im,nqvec)>1.d-10) then
    do j=1,3
      do i=1,3
         lattice_dielectric(i,j) = lattice_dielectric(i,j) +  &
          & zeff_mode(i,im)*zeff_mode(j,im)/omega(im,nqvec)**2
      end do
    end do
    if(printable) write(nfout,'("im=",i4,1x,a3,1x,a4,2(1x,f25.10))')  &
         &  im,mode_irr_rep(im,nqvec),mode_active(im,nqvec) &
         & ,omega(im,nqvec)*27.211383411/1.23984185d-4 &
         & ,coef*sum(zeff_mode(1:3,im)**2)/omega(im,nqvec)**2
  end if
end do
lattice_dielectric(1:3,1:3) = coef*lattice_dielectric(1:3,1:3)

static_dielectric(1:3,1:3) =  &
  & lattice_dielectric(1:3,1:3) + dielectric(1:3,1:3)

end subroutine m_Phonon_calc_static_dielectric


subroutine m_Phonon_write_vib_modes()
use m_Files, only : m_Files_open_nfmode, nfmode
use m_Ionic_System, only : cps
use m_Crystal_Structure, only : altv
implicit none

! local variabes
real(DP), parameter :: amu = 1822.88847974 ! 1 amu = 1822.88847974 Me
real(DP), parameter :: ha2ev = 27.211383411 ! 1 Ha = 27.211383411 eV
real(DP), parameter :: ev2cminv = 1.d0/1.23984185d-4 ! 1 cm^-1 = 1.233984185e-4 eV
integer :: i,j,istart,iq
real(DP) :: omega_ev,omega_cm 
real(DP) :: zamu(3),znorm
real(DP) :: x,hbarW,free_e

call  m_Files_open_nfmode()

if(mype /= 0) return

write(nfmode,'(1x,"--- primitive lattice vectors ---")') 
do i=1,3
  write(nfmode,'(1x,3(f14.10,1x))') altv(1:3,i)
end do
write(nfmode,'(1x,"--- Equilibrium position and mass of each atom---")') 
write(nfmode,'(1x,"Natom=",i5)') natm
do i=1,natm
  write(nfmode,'(1x,i5,3(1x,f14.10),1x,f14.5,1x,a4)') &
  &                      i,cps(i,1:3),ionic_mass(i),speciesname(ityp(i))
end do
write(nfmode,'(1x,"--- Vibrational modes ---")') 
if(phonon_method == PHONON_GAMMA) then
   write(nfmode,'(1x,"Nmode=",i5," Natom=",i5)') nmodes,natm
else
   write(nfmode,'(1x,"Nmode=",i5," Natom=",i5," Nqvec",i5)') nmodes,natm,nqvec
end if
if(phonon_method==PHONON_DOS .and. way_of_smearing==FERMI_DIRAC) free_e=0.d0
do iq=1,nqvec
   if(phonon_method == PHONON_DOS) then
      write(nfmode,'(1x,"iq=",i5," q=(",f10.5,",",f10.5,",",f10.5,") (",f10.5,",",f10.5,",",f10.5,")",1x,f15.10)') &
    & iq,qvin(iq,1:3),qvec(iq,1:3),wght(iq)
   else if(phonon_method /= PHONON_GAMMA) then
      write(nfmode,'(1x,"iq=",i5," q=(",f10.5,",",f10.5,",",f10.5,") (",f10.5,",",f10.5,",",f10.5,")")') &
    & iq,qvin(iq,1:3),qvec(iq,1:3)
   end if
   do i=1,nmodes
      omega_ev = omega(i,iq)*ha2ev
      omega_cm = omega_ev*ev2cminv 
      write(nfmode,'(1x,"n= ",i5,1x,a3,1x,a4, &
   &                  /5x,"hbarW= ",e15.8," Ha = ",e15.8," eV; nu= ",e15.8," cm^-1")') &
   &                  i,mode_irr_rep(i,iq),mode_active(i,iq),omega(i,iq),omega_ev,omega_cm
      do j=1,natm
         istart = 3*(j-1)+1
         write(nfmode,'(1x,i5,1x,3f14.10)') j,dble(modes(istart:istart+2,i,iq))
      end do
      if(nqvec>1) then
         do j=1,natm
            istart = 3*(j-1)+1
            write(nfmode,'(1x,i5,1x,3f14.10)') j,dimag(modes(istart:istart+2,i,iq))
         end do
      end if
      if(phonon_method == PHONON_GAMMA.and.sw_lattice_dielectric_tensor == ON) then
         write(nfmode,'(3x,"Mode effective charge and its norm:")')
         zamu(1:3)=zeff_mode(1:3,i)*sqrt(amu)
         znorm = sqrt(sum(zamu(1:3)**2)) 
         write(nfmode,'(3x,"Z=",3(f14.10,1x),"Norm=",f14.10)') zamu(1:3),znorm
      end if
      if(phonon_method == PHONON_DOS.and.way_of_smearing==FERMI_DIRAC)then
          hbarW = omega(i,iq)
          x = hbarW/width
          if(x.gt.1.d-10) free_e = free_e + wght(iq)*(0.5d0*hbarW+width*log(1.d0-exp(-x)))
      endif
   end do
end do
if(phonon_method == PHONON_GAMMA.and.sw_lattice_dielectric_tensor == ON) then
  write(nfmode,'(1x,"--- Lattice and static dielectric tensors ---")') 
  do i=1,3
    write(nfmode,'(1x,"[",3(1x,f10.4)," ]",2x,"[",3(1x,f10.4)," ]")') &
      & lattice_dielectric(i,1:3), static_dielectric(i,1:3)
  end do
end if
if(way_of_smearing==FERMI_DIRAC.and.phonon_method==PHONON_DOS.and.printable)then
   write(nfout,'(a,f15.10,a)') '!** Free energy due to lattice vibration : ',free_e,' hartree/cell'
endif

return
end subroutine m_Phonon_write_vib_modes

subroutine m_Phonon_write_epsilon()
use m_Crystal_Structure, only : univol
use m_Files, only : m_Files_open_nfepsilon, nfepsilon
implicit none

! local variables
real(DP), parameter :: ha2ev = 27.211383411 ! 1 Ha = 27.211383411 eV
integer :: n,im,i,j
real(kind=DP) :: e,de,e2,e3,e4
real(kind=DP) :: coef
real(kind=DP) :: epsilon(3,3,2,0:num_division)

if(nqvec /= 1) return

coef = 16.d0*atan(1.d0)/univol
de = (max_energy-min_energy)/num_division

do n=0,num_division
  e = min_energy + de * n
  epsilon(1:3,1:3,1:2,n) = 0.d0
  do im=1,nmodes
    if(omega(im,nqvec)>1.d-5) then
      e2 = omega(im,nqvec)**2-e**2
      e3 = e*omega(im,nqvec)*damping_factor
      e4 = e2**2+e3**2
      if(abs(damping_factor) < 1.d-10) then
      if(abs(omega(im,nqvec)-e) < 1.d-10) then
        if(e2 > 0.d0) then
          e2 = 1.d-10   
        else
          e2 = -1.d-10
        end if
      end if
      do j=1,3
        do i=1,j
          epsilon(i,j,1,n) = epsilon(i,j,1,n) + zeff_mode(i,im)*zeff_mode(j,im)/e2
          epsilon(i,j,2,n) = 0.d0
        end do
      end do
      else
        do j=1,3
          do i=1,j
            epsilon(i,j,1,n) = epsilon(i,j,1,n) + zeff_mode(i,im)*zeff_mode(j,im)*e2/e4
            epsilon(i,j,2,n) = epsilon(i,j,2,n) + zeff_mode(i,im)*zeff_mode(j,im)*e3/e4
          end do
        end do
      end if
    end if
  end do
  epsilon(1:3,1:3,1,n)=dielectric(1:3,1:3)+coef*epsilon(1:3,1:3,1,n)
  epsilon(1:3,1:3,2,n)=coef*epsilon(1:3,1:3,2,n)
end do

call m_Files_open_nfepsilon()
if(mype /= 0) return
write(nfepsilon,'("Energy(eV) E1xx E1yy E1zz E1yz E1zx E1xy E2xx E2yy E2zz E2yz E2zx E2xy")')
do n=0,num_division
  e = (min_energy + de * n) * ha2ev
  write(nfepsilon,'(13(1x,e25.10))') &
  & e, ((epsilon(i,i,j,n),i=1,3),epsilon(2,3,j,n),epsilon(1,3,j,n),epsilon(1,2,j,n),j=1,2)
end do

end subroutine m_Phonon_write_epsilon

subroutine m_Phonon_set_supercell
  use m_Crystal_Structure, only: m_CS_supercell_on
  integer :: n1,n2,n3
  n1 = nlat(1)
  n2 = nlat(2)
  n3 = nlat(3)
  if(n1==0.and.n2==0.and.n3==0) then
     n1 = 1; n2 = 1; n3 = 1
     call m_CS_supercell_on(nfout,1,n1,n2,n3) ! 1: PRIMITIVE
  else
     call m_CS_supercell_on(nfout,0,n1,n2,n3) ! 0: BRAVAIS
  end if
end subroutine m_Phonon_set_supercell

subroutine m_Phonon_calc_dos()
  integer :: idim = 3
  integer :: iq,im,ie
  integer :: newin
  real(kind=DP) :: emin,emax
!  real(kind=DP), dimension(np2,nmodes) :: omega2
!  real(kind=DP), dimension(np0) :: eawk, cdwk, cswk
  real(kind=DP), allocatable, dimension(:,:) :: omega2 ! dim(np2,nmodes)            <ASMS>
  real(kind=DP), allocatable, dimension(:)   :: eawk, cdwk, cswk ! dim(np0)         <ASMS>
  real(kind=DP), allocatable, dimension(:,:,:) :: cdos,cind ! dim(np2,nmodes,0:newin)
  real(kind=DP), allocatable, dimension(:) :: e,dos,sumdos ! dim(0:newin)

  allocate(omega2(np2,nmodes))                     ! <ASMS>
  allocate(eawk(np0),cdwk(np0),cswk(np0))          ! <ASMS>
  eawk=0.d0
  cdwk=0.d0
  cswk=0.d0

  do iq=1,np2
     do im=1,nmodes 
        omega2(iq,im) = omega(im,iq) * 1.0d3
     end do
  end do

  emin = minval(omega2) - 0.0005 ! (mhartree)
  emax = maxval(omega2) + 0.0005 ! (mhartree)
  newin = (emax - emin)/(DeltaE_dos*1.0d3) + 1
  
  allocate(cdos(np2,nmodes,0:newin)); cdos = 0.d0
  allocate(cind(np2,nmodes,0:newin)); cind = 0.d0

  allocate(e(0:newin))
  allocate(dos(0:newin)); dos=0.d0
  allocate(sumdos(0:newin)); sumdos=0.d0
  e(0:newin) = (/(emin + (DeltaE_dos*1.0d3)*ie,ie=0,newin)/)

  call nstt3i(idim,newin,e,nxyz_tetra(1),nxyz_tetra(2),nxyz_tetra(3) &
          &  ,np2,np2,nmodes,omega2 &
          &  ,ip20,np0,eawk,cdwk,cswk,np2,nmodes,cdos,cind,width_tetra )

  do iq=1,np2
     do im=1,nmodes
        do ie=0,newin
           dos(ie)    = dos(ie)    + cdos(iq,im,ie)
           sumdos(ie) = sumdos(ie) + cind(iq,im,ie)
        end do
     end do
  end do
  deallocate(cdos)
  deallocate(cind)

  call write_dos(newin,e,dos,sumdos)

  deallocate(e)
  deallocate(dos)
  deallocate(sumdos)
contains

  subroutine write_dos(newin,e,dos,sumdos)
    use m_Files, only : m_Files_open_nfphdos, nfphdos
    integer, intent(in) :: newin
    real(kind=DP), intent(in) :: e(0:newin), dos(0:newin), sumdos(0:newin)
    integer :: ie
    real(DP), parameter :: ha2ev = 27.211383411 ! 1 Ha = 27.211383411 eV
    real(DP), parameter :: ev2cminv = 1.d0/1.23984185d-4 ! 1 cm^-1 = 1.233984185e-4 eV
    real(DP) :: eev, ecminv, dosev, doscminv

    if(mype /= 0) return
    call m_Files_open_nfphdos()

    write(nfphdos,'("# Index Omega(mHa) Omega(eV) Omega(cm-1) DOS(States/Ha) DOS(States/eV) DOS(States/cm-1) IntDOS(States)")') 
    do ie = 0, newin
       eev = e(ie)*ha2ev/1.0d3  ! Hartree
       ecminv = eev*ev2cminv
       dosev = dos(ie)/ha2ev*1.0d3 ! Hartree
       doscminv = dosev/ev2cminv
       write(nfphdos,'(i7,7(1x,f15.8))') ie,e(ie), eev, ecminv, dos(ie), dosev, doscminv, sumdos(ie)
    end do
  end subroutine write_dos
end subroutine m_Phonon_calc_dos

subroutine m_Phonon_read_strain_forces
  use m_Files, only : nfout, nfstrfrc, m_Files_open_nfstrfrc
  integer :: i, ia, num_force, istr, ipm
  real(kind=DP) :: str, force(3,natm,6,2), strain(6,2), eps(3,3)
  logical :: present(6)

  strain = 0.d0
  present = .false.

  allocate(strfrc(3,natm,6))
  strfrc = 0.d0

  call m_Files_open_nfstrfrc()
  read(nfstrfrc,*) num_force
  do i=1,num_force
     read(nfstrfrc,*) istr, str
     if(str>0.d0) then
	ipm = 1
     else
	ipm = 2
     end if
     strain(istr,ipm) = str
     do ia=1,natm
        read(nfstrfrc,*) force(1:3,ia,istr,ipm)
     end do
  end do
  
  do istr=1,6
     if(strain(istr,1) > 1.d-8 .and. strain(istr,2) < -1.d-8 &
       & .and. abs(abs(strain(istr,1))-abs(strain(istr,2))) < 1.d-10) then
	present(istr) = .true.
     end if
  end do

  write(nfout,*) 'present strain : ',present

  do istr=1,6
     if(.not.present(istr)) cycle
     str = strain(istr,1)-strain(istr,2)
     eps = 0.d0
     if(istr==1) then
       eps(1,1) = 0.5d0
     else if(istr==2) then
       eps(2,2) = 0.5d0
     else if(istr==3) then
       eps(3,3) = 0.5d0
     else if(istr==4) then
       eps(2,3) = 0.25d0
       eps(3,2) = 0.25d0
     else if(istr==5) then
       eps(3,1) = 0.25d0
       eps(1,3) = 0.25d0
     else if(istr==6) then
       eps(1,2) = 0.25d0
       eps(2,1) = 0.25d0
     end if
     do ia=1,natm
        strfrc(1:3,ia,istr) = (force(1:3,ia,istr,1)-force(1:3,ia,istr,2))/str &
                          & + matmul(eps,force(1:3,ia,istr,1)+force(1:3,ia,istr,2))
     end do
  end do

  write(nfout,*) '=== Strain-force coupling constants ==='
  do istr=1,6
     if(.not.present(istr)) cycle
     write(nfout,'("Strain : ",i1)') istr
     do ia=1,natm
	Write(nfout,'(i5,3(1x,f15.5))') ia,strfrc(1:3,ia,istr)
     end do
  end do

end subroutine m_Phonon_read_strain_forces


subroutine m_Phonon_calc_int_strain_piezo
use m_Crystal_Structure, only : univol
implicit none

! local variables
integer :: im,i,na,ia,j
real(DP) :: zsum,csum
real(DP) :: coef

if(sw_lo_to_splitting == ON) return
if(nqvec/=1) return

allocate(zeff_mode(3,nmodes))
allocate(strphcpl(6,nmodes))
do im=1,nmodes
  do i=1,3
    zsum = 0.d0
    j=0
    do na=1,natm
      do ia=1,3
        j=j+1
        zsum = zsum + zeff(i,ia,na)*dble(modes(j,im,nqvec))*msqinv(j)
      end do
    end do
    zeff_mode(i,im) = zsum
  end do
  do i=1,6
    csum = 0.d0
    j=0
    do na=1,natm
      do ia=1,3
        j=j+1
        csum = csum + strfrc(ia,na,i)*dble(modes(j,im,nqvec))*msqinv(j)
      end do
    end do
    strphcpl(i,im) = csum
  end do
end do 

coef = 1.d0/univol
piezoelectric(1:3,1:6) = 0.d0
do j=1,6
  do i=1,3
    write(nfout,'("Direction:",i1," Strain:",i1)') i,j
    do im=1,nmodes
      if(omega(im,nqvec)>1.d-10) then
         piezoelectric(i,j) = piezoelectric(i,j) +  &
          & zeff_mode(i,im)*strphcpl(j,im)/omega(im,nqvec)**2
         if(printable) write(nfout,'("im=",i4,1x,a3,1x,a4,3(1x,f25.10))')  &
         &  im,mode_irr_rep(im,nqvec),mode_active(im,nqvec) &
         & ,omega(im,nqvec)*27.211383411/1.23984185d-4 &
         & ,coef*zeff_mode(i,im)*strphcpl(j,im)/omega(im,nqvec)**2
      end if
    end do
  end do
end do
piezoelectric(1:3,1:6) = coef*piezoelectric(1:3,1:6)

if(printable) then
  write(nfout,*) '=== Internal-strain piezoelectric tensor (a.u.) ==='
  do j=1,6
    write(nfout,'(i5,3(1x,f18.10))') j, piezoelectric(1:3,j)
  end do
  write(nfout,*) '=== Internal-strain piezoelectric tensor (C/m^2) ==='
  do j=1,6
    write(nfout,'(i5,3(1x,f18.10))') j, piezoelectric(1:3,j)*UNIT_PIEZO_CONST
  end do
end if

end subroutine m_Phonon_calc_int_strain_piezo

end module m_Phonon
