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

subroutine ac_phonon
  use ac_misc_module
  use ac_mpi_module

  implicit none
  integer im,ia,id,is
  integer i
  type(element_type),pointer :: elem

  call set_phonon_parameter

  if(MPI%root) open(unit=62,file='mode.dat')

  if(MPI%root) then
     write(62,'(a)') 'lattice vector:'
     write(62,'(3f15.10)') param%cell%la
     write(62,'(3f15.10)') param%cell%lb
     write(62,'(3f15.10)') param%cell%lc
     write(62,'(a,i5)') 'atom:', param%data%natom
     do ia = 1, param%data%natom
        elem => Param__Data__getElement(param%data%vatom(ia)%name)
        write(62,'(i5,2x,a5,3f15.10,f20.5)') ia,param%data%vatom(ia)%name,param%data%vatom(ia)%ro,elem%mass
     end do
     write(62,'(a,3i5)') 'mode:',0,0,0
     do i=1, param%phonon%num_atom
        write(62,'(i5,6f15.10)') i,param%data%vatom(i)%ro,param%data%vatom(i)%force
     end do
  end if

  do im = 1, param%phonon%num_mode

     ia = param%phonon%mode(im)%atom_id
     id = param%phonon%mode(im)%direction

     do is = 1, 2

        do i=1, param%phonon%num_atom
           param%data%vatom(i)%ro = param%phonon%atom(i)%ro
        end do
        param%data%vatom(ia)%ro(id) = param%data%vatom(ia)%ro(id) + (-1.0d0)**is*param%phonon%displacement

        !call Param__Structure__show
        call ac_solve
        call Force__calc
        !call Force__show

        ! set fp force
        do i=1, param%phonon%num_atom
           param%phonon%mode(im)%force(i,:,is) = param%data%vatom(i)%force
        end do

        if(MPI%root) then
           write(62,'(a,3i5)') 'mode:',im,ia,id
           do i=1, param%phonon%num_atom
              write(62,'(i5,6f15.10)') i,param%data%vatom(i)%ro,param%data%vatom(i)%force
           end do
        end if

     end do
  end do

  call force_constant_matrix
  call phonon

  close(62)

end subroutine ac_phonon

subroutine set_phonon_parameter
  use ac_misc_module

  implicit none
  integer im, ia, id, index

  param%phonon%num_atom = param%data%natom
  param%phonon%num_element = param%data%nelem

  param%phonon%num_mode = param%phonon%num_atom * 3
  param%phonon%num_order = 1

  allocate(param%phonon%mode(param%phonon%num_mode))
  allocate(param%phonon%atom(param%phonon%num_atom))

  index=0
  do ia = 1, param%phonon%num_atom
     do id = 1, 3
        index=index+1
        param%phonon%mode(index)%atom_id = ia
        param%phonon%mode(index)%direction = id        
     end do
     param%phonon%atom(ia)%ro = param%data%vatom(ia)%ro
  end do

  do im = 1, param%phonon%num_mode
     allocate(param%phonon%mode(im)%force(param%phonon%num_atom,3,param%phonon%num_order*2))
  end do

end subroutine set_phonon_parameter

subroutine force_constant_matrix
  use ac_misc_module
  use ac_mpi_module

  implicit none
  integer im1,im2,ia,id
  real(8) ui
  integer ia1,ia2,id1,id2
  real(8),allocatable :: fsum(:,:)
  type(element_type),pointer :: elem

  allocate(param%phonon%force_const_matrix(param%phonon%num_mode,param%phonon%num_mode,1))

  ui = dble(param%phonon%num_order)/param%phonon%displacement
  select case(param%phonon%num_order)
  case(1)
     ui = -ui/2.0d0
  case(2)
     ui = -ui/12.0d0
  end select

  if(MPI%root) write(62,'(a)') 'forces'
  do im1 = 1, param%phonon%num_mode
     ia = param%phonon%mode(im1)%atom_id
     id = param%phonon%mode(im1)%direction
     do im2 = 1, param%phonon%num_mode
        if(MPI%root) write(62,'(2i5,6f15.10)') im1,im2,param%phonon%mode(im2)%force(ia,id,1),param%phonon%mode(im2)%force(ia,id,2)
        select case(param%phonon%num_order)
        case(1)
           param%phonon%force_const_matrix(im1,im2,1) &
                = (param%phonon%mode(im2)%force(ia,id,2) &
                - param%phonon%mode(im2)%force(ia,id,1))*ui
        case(2)
           param%phonon%force_const_matrix(im1,im2,1) &
                = (-8.0d0*param%phonon%mode(im2)%force(ia,id,1) &
                + param%phonon%mode(im2)%force(ia,id,2) &
                - param%phonon%mode(im2)%force(ia,id,3) &
                + 8.0d0*param%phonon%mode(im2)%force(ia,id,2))*ui
        end select
     end do
  end do

  if(MPI%root) then
     write(62,'(a)') 'force const mat'
     do im1 = 1, param%phonon%num_mode
        do im2 = 1, param%phonon%num_mode
           write(62,'(2i5,f20.12)') im1,im2,param%phonon%force_const_matrix(im1,im2,1)
        end do
     end do
  end if

  ! check sum
  allocate(fsum(param%phonon%num_mode,3))
  do ia1 = 1,param%phonon%num_atom
     do id1 = 1,3
        im1 = (ia1-1)*3+id1
        do id2 = 1,3
           fsum(im1,id2) = 0.0d0
           do ia2 = 1,param%phonon%num_atom
              im2 = (ia2-1)*3+id2
              if(ia1==ia2) cycle
              fsum(im1,id2) = fsum(im1,id2) + param%phonon%force_const_matrix(im1,im2,1);
           end do
        end do
     end do
  end do
  do im1 = 1,param%phonon%num_mode
     ia = param%phonon%mode(im1)%atom_id
     do id = 1,3
        im2 = (ia-1)*3+id
        param%phonon%force_const_matrix(im1,im2,1) = -fsum(im1,id)
     end do
  end do
  deallocate(fsum)

  if(MPI%root) then
     write(62,'(a)') 'force const mat (check sum)'
     do im1 = 1, param%phonon%num_mode
        do im2 = 1, param%phonon%num_mode
           write(62,'(2i5,f20.12)') im1,im2,param%phonon%force_const_matrix(im1,im2,1)
        end do
     end do
     if(param%phonon%output_force_constant_matrix) then
        open(63,file='force_constant_matrix.dat')
        write(63,'(a)') 'lattice vector:'
        write(63,'(3f15.10)') param%cell%la
        write(63,'(3f15.10)') param%cell%lb
        write(63,'(3f15.10)') param%cell%lc
        write(63,'(a,i5)') 'atom:', param%data%natom
        do ia = 1, param%data%natom
           elem => Param__Data__getElement(param%data%vatom(ia)%name)
           write(63,'(i5,2x,a5,3f15.10,f15.5)') ia,param%data%vatom(ia)%name,param%data%vatom(ia)%ro,elem%mass
        end do
        write(63,'(a,2i5)') 'force constant matrix:', param%phonon%num_mode, param%phonon%num_atom
        do im1 = 1, param%phonon%num_mode
           do im2 = 1, param%phonon%num_mode
              write(63,'(2i5,e20.12)') im1,im2,param%phonon%force_const_matrix(im1,im2,1)
           end do
        end do
        close(63)
     end if
  end if

end subroutine force_constant_matrix

subroutine phonon
  use ac_misc_module
  use ac_mpi_module

  implicit none
  integer im,im1,im2,ia1,ia2,ia
  real(8) mass1,mass2
  character(5) name
  type(element_type),pointer :: elem

  real(8), parameter :: ha2ev = 27.211383411 ! 1 Ha = 27.211383411 eV
  real(8), parameter :: ev2cminv = 1.d0/1.23984185d-4 ! 1 cm^-1 = 1.233984185e-4 eV

  allocate(param%phonon%dynamical_matrix(param%phonon%num_mode,param%phonon%num_mode,1))
  allocate(param%phonon%dynamical_matrix_g(param%phonon%num_mode,param%phonon%num_mode,1))

  !mass1 = 51577.5d0  ! si mass
  !mass2 = 51577.5d0

  do im1 = 1,param%phonon%num_mode
     ia1 = param%phonon%mode(im1)%atom_id
     elem => Param__Data__getElement(param%data%vatom(ia1)%name)
     mass1 = elem%mass

     do im2 = 1,param%phonon%num_mode
        ia2 = param%phonon%mode(im2)%atom_id
        elem => Param__Data__getElement(param%data%vatom(ia2)%name)
        mass2 = elem%mass

        param%phonon%dynamical_matrix_g(im1,im2,1) = dcmplx(param%phonon%force_const_matrix(im1,im2,1),0.0d0)/sqrt(mass1*mass2)
     end do
  end do

  if(MPI%root) then
     write(62,'(a)') 'dynamical mat'
     do im1 = 1, param%phonon%num_mode
        do im2 = 1, param%phonon%num_mode
           write(62,'(2i5,2e20.12)') im1,im2,param%phonon%dynamical_matrix_g(im1,im2,1)
        end do
     end do
     if(param%phonon%output_dynamical_matrix) then
        open(63,file='dynamical_matrix.dat')
        write(63,'(a)') 'lattice vector:'
        write(63,'(3f15.10)') param%cell%la
        write(63,'(3f15.10)') param%cell%lb
        write(63,'(3f15.10)') param%cell%lc
        write(63,'(a,i5)') 'atom:', param%data%natom
        do ia = 1, param%data%natom
           elem => Param__Data__getElement(param%data%vatom(ia)%name)
           write(63,'(i5,2x,a5,3f15.10,f15.5)') ia,param%data%vatom(ia)%name,param%data%vatom(ia)%ro,elem%mass
        end do
        write(63,'(a,2i5)') 'dynamical matrix', param%phonon%num_mode, param%phonon%num_atom
        do im1 = 1, param%phonon%num_mode
           do im2 = 1, param%phonon%num_mode
              write(63,'(2i5,2e20.12)') im1,im2,param%phonon%dynamical_matrix_g(im1,im2,1)
           end do
        end do
        close(63)
     end if
  end if

  allocate(param%phonon%omega(param%phonon%num_mode,1))
  allocate(param%phonon%modes(param%phonon%num_mode,param%phonon%num_mode,1))

  call diagonalize(param%phonon%num_mode,param%phonon%dynamical_matrix_g(:,:,1),param%phonon%omega(:,1),param%phonon%modes(:,:,1))

  if(MPI%root) write(62,*) 'omega'
  do im = 1, param%phonon%num_mode
     if(MPI%root) write(62,'(i5,e20.12)') im,param%phonon%omega(im,1)
     !if(abs(param%phonon%omega(im,1)) < 1.0d-16) param%phonon%omega(im,1) = 0.0d0
     if(abs(param%phonon%omega(im,1)) < 1.0d-10) param%phonon%omega(im,1) = 0.0d0
     if(param%phonon%omega(im,1) > 0.0d0) then
        param%phonon%omega(im,1) = sqrt(param%phonon%omega(im,1))
     else
        param%phonon%omega(im,1) = -sqrt(param%phonon%omega(im,1))  ! for soft mode
     end if
  end do

  if(MPI%root) then
     write(62,*) 'omega'
     do im1=1,param%phonon%num_mode
        write(62,'(i5,e20.12)') im1,param%phonon%omega(im1,1)
        do im2=1,param%phonon%num_mode
           write(62,'(2i5,2e20.12)') im1,im2,param%phonon%modes(im1,im2,1)
        end do
     end do

     write(62,*) 'mode: hbarW (Ha,ev),Freq(nu) (cm-1)'
     do im=1,param%phonon%num_mode
        write(62,'(i5,3e20.12)') im,param%phonon%omega(im,1),param%phonon%omega(im,1)*ha2ev,param%phonon%omega(im,1)*ha2ev*ev2cminv
     end do

     write(6,*) '-----'
     write(6,*) 'mode: hbarW (Ha,ev),Freq(nu) (cm-1)'
     do im=1,param%phonon%num_mode
        write(6,'(i5,3e20.12)') im,param%phonon%omega(im,1),param%phonon%omega(im,1)*ha2ev,param%phonon%omega(im,1)*ha2ev*ev2cminv
     end do
  end if

end subroutine phonon

subroutine diagonalize(n,h,e,x)

  implicit none
  integer n, lda, lwork, info
  complex(8) h(n,n), x(n,n), e(n)
  complex(8) a(n,n)
  real(8),allocatable :: rwork(:)
  complex(8),allocatable :: work(:)
  character(1) jobz, uplo

  jobz = 'v'
  uplo = 'u'
  lda = n
  lwork = 4*n
  allocate(work(lwork))
  allocate(rwork(4*n))
  work = 0.0d0
  rwork = 0.0d0

  a = h

  call zheev(jobz,uplo,n,a,lda,e,work,lwork,rwork,info)

  x = a

  deallocate(work)
  deallocate(rwork)

end subroutine diagonalize
