module m_CS_NonCollinear
! $Id: m_CS_NonCollinear.f90 409 2014-10-27 09:24:52Z jkoga $
  use m_Const_Parameters,   only : DP, BUCS, CARTS, CRDTYP, DELTA10, &
       &                           oh=>oh_symbol, d6h=>d6h_symbol, ON, DELTA07, &
       &                           CMPLDP, zi, PAI

  use m_Crystal_Structure,      only : nopr, op, ig01, tau, m_CS_op_in_PUCD, &
       &                               pg_symbol_system, ngen, igen, jgen, &
       &                               alloc_igen_jgen, dealloc_igen_jgen, &
       &                               sw_reduce_sym_by_magmom, &
       &                               sw_reduce_sym_by_orbital, sw_neglect_magmom

  use m_Ionic_System,       only : natm, ntyp, ityp, mag_direction0_atomtyp, &
       &                           natm2, pos, iwei, magmom_local_now, &
       &                           has_partially_filled_lcore

  use m_Files,                 only : nfout

! == KT_add === 2014/08/14
  use m_Ionic_System,  only :   lattice_system_from_m_CS_SG
! ============= 2014/08/14

  implicit none

  include 'mpif.h'
  integer istatus(mpi_status_size)

! ---------------------------
  integer :: nopr_before_sym_reduction
  real(kind=DP), allocatable :: op_before_sym_reduction(:,:,:)
  real(kind=DP) :: invop(48)
! -------------------------

! == KT_add === 2014/08/14
  integer, allocatable :: magmom_dir_inversion_opr_flag(:)
! ============= 2014/08/14

contains

! ------------------------------------------------------------------------
!!
!!!   Removing sym. operations by considering magnetic moment
!!
! ------------------------------------------------------------------------
  subroutine m_CS_set_Magnetic_Sym

    real(kind=DP) :: mag_loc(natm2,3)
    real(kind=DP) :: pos2(natm2,3)

    integer :: nsym_with_magmom

    call set_val_pos2( pos2 )
    call set_val_mag_loc( mag_loc )

    if ( .not. allocated( op_before_sym_reduction ) ) then
       allocate( op_before_sym_reduction(3,3,nopr) )
    endif

    nopr_before_sym_reduction = nopr
    op_before_sym_reduction = op

! == KT_add === 2014/08/14
    if ( .not. allocated( magmom_dir_inversion_opr_flag ) ) then
       allocate( magmom_dir_inversion_opr_flag( nopr ) )
    endif
! ============= 2014/08/14

! ==== KT_add === 2014/09/26
    if ( sw_neglect_magmom == ON ) then
       magmom_dir_inversion_opr_flag = 1
       return
    endif
! =============== 2014/09/26

    call set_magnetic_symm( natm2, pos2, nopr, ig01, op, tau, mag_loc, &
         &                  nsym_with_magmom, magmom_dir_inversion_opr_flag )

    call resize_matrix_size( nopr, nsym_with_magmom )

    call set_magnetic_tspace_gnerators( nopr, ig01, op, tau )

  contains

    subroutine set_val_pos2( pos2 )
      real(kind=DP), intent(out) :: pos2(natm2,3)
      integer :: i, ia

      pos2(1:natm,1:3) = pos(1:natm,1:3)

      i = natm
      do ia=1,natm
         if (iwei(ia)/=1) then
            i = i+1
            pos2(i,1:3) = -pos(ia,1:3)
         end if
      end do
    end subroutine set_val_pos2

    subroutine set_val_mag_loc( mag_loc )
      real(kind=DP), intent(out) :: mag_loc(natm2,3)
      integer :: i, ia

      i = natm
      mag_loc(1:natm,:) = magmom_local_now(1:natm,:)
      do ia=1,natm
         if (iwei(ia)/=1) then
            i = i+1
            mag_loc(i,1:3) = magmom_local_now(ia,1:3)
         end if
      end do

    end subroutine set_val_mag_loc

    subroutine set_magnetic_symm( natom, apos, nsym, nopr, rot, tau, mag_loc, &
         &                        nsym_with_mag, magmom_dir_inversion_opr_flag )
      integer, intent(in) :: natom
      integer, intent(inout) :: nsym
      integer, intent(out) :: nopr(48), nsym_with_mag
      integer, intent(inout) :: magmom_dir_inversion_opr_flag(nsym)

! --------------------- kDEBUG --------------------------------- 20121020
!      real(kind=DP), intent(inout) :: rot(3,3,48), tau(3,48,CRDTYP)
      real(kind=DP), intent(inout) :: rot(3,3,nsym), tau(3,nsym,CRDTYP)
! --------------------- kDEBUG --------------------------------- 20121020

      real(kind=DP), intent(in) :: apos(natom,3)
      real(kind=DP), intent(in) :: mag_loc(natom,3)

      logical :: mag_sym_flag(nsym)
      integer :: isym, count
! ----
!      write(*,*) 'sw_reduce_ = ',  sw_reduce_sym_by_magmom
      if ( sw_reduce_sym_by_magmom==ON ) then
         call check_if_op_has_sym_for_magmom( natom, apos, nsym, rot, tau, &
              &                               mag_loc, mag_sym_flag, &
              &                               magmom_dir_inversion_opr_flag )
      else
         mag_sym_flag = .true.
      endif

      if ( sw_reduce_sym_by_orbital==ON ) then
         call check_if_op_has_sym_for_orb( natom, nsym, rot, mag_loc, mag_sym_flag )
      endif
! -----
      count = 0
      Do isym=1, nsym
         if ( mag_sym_flag(isym) ) then
            count = count + 1
            nopr(count) = nopr(isym)
            rot(:,:,count) = rot(:,:,isym)
            tau(:,count,:) = tau(:,isym,:)
            magmom_dir_inversion_opr_flag(count) = magmom_dir_inversion_opr_flag(isym)
         endif
      End do

      nsym_with_mag = count

    end subroutine set_magnetic_symm

    subroutine check_if_op_has_sym_for_orb( natom, nsym, rot, &
         &                                  mag_loc, mag_sym_flag )
      integer, intent(in) :: natom, nsym
      logical, intent(inout) :: mag_sym_flag(48)
      real(kind=DP), intent(inout) :: rot(3,3,nsym)
      real(kind=DP), intent(in) :: mag_loc(natom,3)

      integer :: isym, it, ia
      real(kind=DP) :: c1, c2
      real(kind=DP) :: vec1(3), vec_tmp(3), dvec_m(3), dvec_p(3)
      real(kind=DP), parameter :: criterion = 1.0D-5

      Do isym=1, nsym
         if ( .not. mag_sym_flag(isym) ) cycle

         Do it=1, ntyp
            if ( has_partially_filled_lcore(it) == 0 ) cycle

            Do ia=1, natom
               if ( ityp(ia) /=it ) cycle
               
               call calc_normal_vector( mag_loc(ia,1:3), vec1(1:3) )
               vec_tmp(1:3) = matmul( rot(:,:,isym), vec1(1:3) )
!
               dvec_m(1:3) = vec_tmp(1:3) - vec1(1:3)
               dvec_p(1:3) = vec_tmp(1:3) + vec1(1:3)
!
               c1 = abs( dvec_m(1) ) +abs( dvec_m(2) ) +abs( dvec_m(3) )
               c2 = abs( dvec_p(1) ) +abs( dvec_p(2) ) +abs( dvec_p(3) )
!
               if ( c1 < criterion .or. c2 < criterion ) then
                  mag_sym_flag(isym) = .true.
               else
                  mag_sym_flag(isym) = .false.
               endif

               exit
            End do
         End Do

      End Do
!
    end subroutine check_if_op_has_sym_for_orb

    subroutine calc_normal_vector( vec_in, vec_out )
      real(kind=DP), intent(in)  :: vec_in(3)
      real(kind=DP), intent(out) :: vec_out(3)
!
      integer :: k
      real(kind=DP) :: c1, cnorm, vec_tmp(3)
      real(kind=DP), parameter :: criterion = 1.0D-5

! --- trial 1 --
      vec_tmp(1) = 1.0;  vec_tmp(2) = 2.0;    vec_tmp(3) = 3.0
!
      c1 = 0.0d0; cnorm = 0.0d0
      Do k=1, 3
         c1 = c1 + vec_tmp(k)*vec_in(k)
      End do
      vec_tmp(:) = vec_tmp(:) - c1*vec_in(:)
      Do k=1, 3
         cnorm = cnorm + vec_tmp(k)**2
      End do
      cnorm = sqrt(cnorm)
!
      if ( cnorm > criterion ) then
         vec_out(:) = vec_tmp(:) / cnorm
!         write(*,*) 'vec_out = ', vec_out
         return
      endif

! --- trial 2 --
      vec_tmp(1) = 3.0;  vec_tmp(2) = 2.0;    vec_tmp(3) = 1.0
!
      c1 = 0.0d0; cnorm = 0.0d0
      Do k=1, 3
         c1 = c1 + vec_tmp(k)*vec_in(k)
      End do
      vec_tmp(:) = vec_tmp(:) - c1*vec_in(:)
      Do k=1, 3
         cnorm = cnorm + vec_tmp(k)**2
      End do
      cnorm = sqrt(cnorm)
!
      if ( cnorm > criterion ) then
         vec_out(:) = vec_tmp(:) / cnorm
      endif

    end subroutine calc_normal_vector

    subroutine check_if_op_has_sym_for_magmom( natom, apos, nsym, rot, &
         &                                     tau, mag_loc, mag_sym_flag, &
         &                                     magmom_dir_inversion_opr_flag )
      integer, intent(in) :: natom, nsym
      logical, intent(inout) :: mag_sym_flag(nsym)
      integer, intent(inout) :: magmom_dir_inversion_opr_flag(nsym)
      real(kind=DP), intent(in) :: apos(natom,3), mag_loc(natom,3)

! --------------------- kDEBUG --------------------------------- 20121020
!      real(kind=DP), intent(inout) :: rot(3,3,48), tau(3,48,CRDTYP)
      real(kind=DP), intent(inout) :: rot(3,3,nsym), tau(3,nsym,CRDTYP)
! --------------------- kDEBUG --------------------------------- 20121020

      real(kind=DP), parameter :: criterion = 1.0D-5
      real(kind=DP), allocatable :: apos_t(:,:)

      integer :: i, ia, ja, ja_found, it, isym, count
      real(kind=DP) :: coord_tmp(3), dcoord(3), dist
      real(kind=DP) :: mag_tmp(3), dmag_p(3), dmag_m(3)
      real(kind=DP) :: c1, c2
!
      real(kind=DP) :: rot_pr(3,3,nsym)
!
! -- init --
      call m_CS_op_in_PUCD( nfout, rot_pr, nsym, .true., &
           &                '***** Before considering magnetic symmetry ****** ')

      allocate(apos_t(natom,3))
      apos_t(1:natm,1:3) = apos(1:natom,1:3)
      do ia = 1, natom
         do i = 1, 3
            apos_t(ia,i) = apos_t(ia,i) - floor(apos_t(ia,i))
         end do
      end do

      mag_sym_flag = .false.

      magmom_dir_inversion_opr_flag = 1

! -- begin --
      Do isym=1, nsym

! ================== KT_add ======= 2014/08/14
         if ( lattice_system_from_m_CS_SG == "cubic" ) then
            if ( ig01(isym) > 24 ) cycle
         else if ( lattice_system_from_m_CS_SG == "hexagonal" ) then
            if ( ig01(isym) > 12 ) cycle
         endif
! ================================= 2014/08/14

         Do it=1, ntyp
            Do ia=1, natom
               if ( ityp(ia) /=it ) cycle

               coord_tmp(1:3) = matmul( rot_pr(:,:,isym), apos_t(ia,1:3) ) &
                    &         + tau(1:3,isym,BUCS)
               coord_tmp(1:3) = coord_tmp(1:3) - floor(coord_tmp(1:3))

               ja_found = 0
               Do ja=1, natom
                  dcoord(:) = apos_t(ja,1:3) - coord_tmp(:)

                  dist = dcoord(1)**2 + dcoord(2)**2 + dcoord(3)**2
                  dist = sqrt(dist)

                  dist = dist - floor( dist +DELTA10 )

                  if ( dist < criterion ) then
                     ja_found = ja
                     !  goto 100
                     exit
                  endif
               End do

100            continue
               !
               if ( ja_found ==0 ) then
                  write(*,*) 'kt: Not found symmetry', isym, ia
                  stop
               endif

               mag_tmp(1:3) = matmul( rot(:,:,isym), mag_loc(ia,1:3) )
!
               dmag_m(1:3) = mag_tmp(1:3) - mag_loc(ja_found,1:3)
               dmag_p(1:3) = mag_tmp(1:3) + mag_loc(ja_found,1:3)
!
               c1 = abs( dmag_m(1) ) +abs( dmag_m(2) ) +abs( dmag_m(3) )
               c2 = abs( dmag_p(1) ) +abs( dmag_p(2) ) +abs( dmag_p(3) )
!
! ====== KT_mod === 2014/08/14
!               if ( c1 < criterion ) then
!                  mag_sym_flag(isym) = .true.
!                  exit
!               endif
!               if ( mag_sym_flag(isym) ) then
!                  if ( c1 > criterion ) then
!                     mag_sym_flag(isym) = .false.
!                  endif
!               endif
! --
               if ( c1 < criterion ) then
                  mag_sym_flag(isym) = .true.
                  magmom_dir_inversion_opr_flag(isym) = 1
                  exit
               endif
               if ( c2 < criterion ) then
                  mag_sym_flag(isym) = .true.
                  magmom_dir_inversion_opr_flag(isym) = -1
                  exit
               endif
               if ( mag_sym_flag(isym) ) then
                  if ( c1 > criterion .and. c2 > criterion ) then
                     mag_sym_flag(isym) = .false.
                  endif
               endif
! =============== 2014/08/14
            End do
         End do
      End do

    end subroutine check_if_op_has_sym_for_magmom

    subroutine resize_matrix_size( nsym, nsym_with_mag )
      integer, intent(inout) :: nsym, nsym_with_mag
      real(kind=DP), allocatable :: rot_tmp(:,:,:), tau_tmp(:,:,:)
      integer, allocatable :: magmom_dir_inversion_opr_flag_tmp(:)
!
      allocate( rot_tmp(3,3,nsym) );      rot_tmp = 0.0d0
      allocate( tau_tmp(3,nsym,CRDTYP) ); tau_tmp = 0.0d0
!
      rot_tmp = op;  tau_tmp = tau
      deallocate( op );  deallocate( tau )
!
      allocate( op(3,3,nsym_with_mag ) );       op = 0.0d0
      allocate( tau(3,nsym_with_mag,CRDTYP ) ); tau = 0.0d0
!
      op(:,:,1:nsym_with_mag) = rot_tmp(:,:,1:nsym_with_mag)
      tau(:,1:nsym_with_mag,:) = tau_tmp(:,1:nsym_with_mag,:)
!
      deallocate( rot_tmp ); deallocate( tau_tmp )
!
! === KT_add === 2014/08/14
      allocate( magmom_dir_inversion_opr_flag_tmp( nsym ) )
      magmom_dir_inversion_opr_flag_tmp = 0

      magmom_dir_inversion_opr_flag_tmp = magmom_dir_inversion_opr_flag
      deallocate( magmom_dir_inversion_opr_flag )

      allocate( magmom_dir_inversion_opr_flag(nsym_with_mag) )
      magmom_dir_inversion_opr_flag = 0

      magmom_dir_inversion_opr_flag(1:nsym_with_mag) &
           &         = magmom_dir_inversion_opr_flag_tmp(1:nsym_with_mag)
      deallocate( magmom_dir_inversion_opr_flag_tmp )
! ============== 2014/08/14

      nsym = nsym_with_mag

    end subroutine resize_matrix_size

    subroutine set_magnetic_tspace_gnerators( nsym, nopr, rot, tau )
      integer, intent(in) :: nsym
      integer, intent(in) :: nopr(48)
      real(kind=DP), intent(in) :: rot(3,3,nsym), tau(3,nsym,CRDTYP)
      
      integer :: iptab(nsym,nsym)
      integer :: ng, ig(3)
      character(len=9) :: system

      system = pg_symbol_system

      call set_mini_product_table( nsym, rot, tau, iptab )
      call search_generators( nsym, iptab, ng, ig )
      call set_generators( ng, ig, nopr )
      call write_tspace_generators(system)

    end subroutine set_magnetic_tspace_gnerators

! --
    subroutine set_mini_product_table( nsym, rot, tau, iptab )
      integer, intent(in) :: nsym
      integer, intent(out) :: iptab(nsym,nsym)
      real(kind=DP), intent(in) :: rot(3,3,nsym), tau(3,nsym,CRDTYP)
      
      real(kind=DP) :: rot_pr(3,3,48)
      real(kind=DP) :: op_tmp(3,3), tau_tmp(3)
      real(kind=DP) :: c1, c2, cx, cy, cz
      real(kind=DP), parameter :: eps = 1.d-4

      integer :: isym, jsym, ksym
      integer :: ksym_found
      integer :: m1, m2, m3
      integer :: nx, ny, nz

      iptab = 0

      call m_CS_op_in_PUCD( nfout, rot_pr, nsym, .false. )

      Do jsym=1, nsym
         Do isym=1, nsym
            
            op_tmp = 0.0d0; tau_tmp = 0.0d0
            Do m1=1, 3
               Do m2=1, 3
                  Do m3=1, 3
                     op_tmp(m1,m2) = op_tmp(m1,m2) &
                          & + rot_pr(m1,m3,isym) *rot_pr(m3,m2,jsym) 
                  End do
               End Do
            End do
            Do m1=1, 3
               Do m2=1, 3
                  tau_tmp(m1) = tau_tmp(m1) &
                       &       + rot_pr(m1,m2,isym)*tau(m2,jsym,BUCS)
               End do
               tau_tmp(m1) = tau_tmp(m1) + tau(m1,isym,BUCS)
            End do
! ---------------------------------
            ksym_found = 0
! ---------------------------------

!            write(*,*) 'isym jsym ', isym, jsym
!            write(*,*) 'op_tmp ', op_tmp(1,1), op_tmp(1,2), op_tmp(1,3)
!            write(*,*) 'op_tmp ', op_tmp(2,1), op_tmp(2,2), op_tmp(2,3)
!            write(*,*) 'op_tmp ', op_tmp(3,1), op_tmp(3,2), op_tmp(3,3)
!            write(*,*) 'tau_tmp ', tau_tmp(1), tau_tmp(2), tau_tmp(3)


            Do ksym=1, nsym
               c1 = 0.0d0
               Do m1=1, 3
                  Do m2=1, 3
                     c1 = c1 + abs( op_tmp(m1,m2) - rot_pr(m1,m2,ksym) )
                  End do
               End do

               if ( c1 < eps ) then
                  Do nx=-1, 1
                     Do ny=-1, 1
                        Do nz=-1, 1
                           cx = tau_tmp(1) - tau(1,ksym,BUCS) +nx
                           cy = tau_tmp(2) - tau(2,ksym,BUCS) +ny
                           cz = tau_tmp(3) - tau(3,ksym,BUCS) +nz

                           c2 = abs(cx) + abs(cy) + abs(cz)

                           if ( c2 < eps ) then
                              ksym_found = ksym
                              goto 1000
                           endif
                        End Do
                     End Do
                  End Do
               endif
            End Do

1000        continue
            iptab(isym,jsym) = ksym_found
!            write(*,*) 'isym jsym ', isym, jsym, ksym_found
         End do
      End do

    end subroutine set_mini_product_table

    subroutine search_generators( nsym, iptab, ng, ig )
      integer, intent(in) :: nsym, iptab(nsym,nsym)
      integer, intent(out) :: ng, ig(3)
      
      integer :: i,j,k
      logical :: fexist(1:nsym)
      integer :: ii

! --------------
      ng = 1
      do i=1,nsym
         fexist(1:nsym) = .false.
         fexist(i) = .true.
         if (group_is_the_same(nsym,fexist,iptab)) then
            ig(ng) = i
            return
         end if
      end do
! --------------
      ng = 2
      do i=2,nsym
         do j=i+1,nsym
            fexist(1:nsym) = .false.
            fexist(i) = .true.
            fexist(j) = .true.
            if (group_is_the_same(nsym,fexist,iptab)) then
               ig(1)  = i
               ig(ng) = j
               return
            end if
         end do
      end do
! ------------
      ng = 3
      do i=2,nsym
         do j=i+1,nsym
            do k=j+1,nsym
               fexist(1:nsym) = .false.
               fexist(i) = .true.
               fexist(j) = .true.
               fexist(k) = .true.
               if (group_is_the_same(nsym,fexist,iptab)) then
                  ig(1)  = i
                  ig(2)  = j
                  ig(ng) = k
                  return
               end if
            end do
         end do
      end do

      stop 'Set of generators of the space group was not found.'

    end subroutine search_generators

    logical function group_is_the_same( nsym, fexist, iptab)
      integer, intent(in) :: nsym
      integer, intent(in) :: iptab(nsym,nsym)
      logical, intent(inout) :: fexist(nsym)

      integer :: i,j
      integer :: n,no
      logical :: flag(nsym)

      n=0
      no=-1 
      do while(n > no)
         flag(1:nsym) = .false.
         do j=1,nsym
            do i=1,nsym
               if(fexist(i).and.fexist(j)) flag(iptab(i,j)) = .true.
            end do
         end do
         do i=1,nsym
            if(flag(i)) fexist(i) = .true.
         end do
         no = n
         n = 0
         do i=1,nsym
            if(fexist(i)) n=n+1
         end do
      end do
      if(n==nsym) then
         group_is_the_same = .true.
      else
         group_is_the_same = .false.
      end if

    end function group_is_the_same

    subroutine set_generators( ng, ig, nopr )
      integer, intent(in) :: ng, ig(3)
      integer, intent(in) :: nopr(48)

      integer :: i,j,k,n
      real(kind=DP) :: t,r,tb(3)
      real(kind=DP), parameter :: eps = 1.d-4

      ngen = ng
      call dealloc_igen_jgen
      call alloc_igen_jgen

      do i=1,ngen
         igen(i) = nopr(ig(i))

         tb(:) = tau(:,ig(i),BUCS)

         do j=1,3
            t = tb(j)
            do k=1,20
               r=t*k
               if(abs(nint(r)-r)<eps) then
                  jgen(1,j,i) = nint(r)
                  jgen(2,j,i) = k
                  exit
               end if
            end do
         end do
      end do
      
    end subroutine set_generators

    subroutine set_translations_zero
      integer :: i,j
      do i=1,ngen
         do j=1,3
            jgen(1,j,i) = 0
            jgen(2,j,i) = 1
         end do
      end do
    end subroutine set_translations_zero

    subroutine write_tspace_generators(system)
      character(len=9), intent(in) :: system
      
      integer :: i
      
      write(nfout,*) '----------------------------------- '
      write(nfout,'("TSPACE Generators with Magnetic symmetry :")')
      
      if (system == 'cubic') then
         do i=1,ngen
            write(nfout,'("igen,jgen(2,3)=",i2,"(",a5,")",3(3x,i2,"/",i2))') igen(i),oh(igen(i)),jgen(:,:,i)
         end do
      else
         do i=1,ngen
            write(nfout,'("igen,jgen(2,3)=",i2,"(",a5,")",3(3x,i2,"/",i2))') igen(i),d6h(igen(i)),jgen(:,:,i)
         end do
      end if

    end subroutine write_tspace_generators

  end subroutine m_CS_set_Magnetic_Sym

! ---------------------------------------------------------------------------
  subroutine m_CS_set_inverse_operation
    integer :: iopr1, iopr2
    real(kind=DP) :: ss(3,3)

    do iopr1=1,nopr
       do iopr2=1,nopr
          ss = matmul(op(:,:,iopr1),op(:,:,iopr2))
          if(abs(ss(1,1)-1.d0)<DELTA07 .and. &
          & abs(ss(2,2)-1.d0)<DELTA07 .and. &
          & abs(ss(3,3)-1.d0)<DELTA07 .and. &
          & abs(ss(1,2))<DELTA07 .and. &
          & abs(ss(1,3))<DELTA07 .and. &
          & abs(ss(2,3))<DELTA07) then
             invop(iopr1) = iopr2
             exit
          end if
       end do
    end do

  end subroutine m_CS_set_inverse_operation

end module m_CS_NonCollinear
