LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-11-04 05:03:54 +01:00
Code Issues Releases Wiki Activity
7ebc2ac896
quantum_package/plugins/Symmetry/find_sym.irp.f
Anthony Scemama 7ebc2ac896
Fixed last merge (#217) 
* Fixes #211

* Removed debug print

* Revert input coordinates

* Fix MPI
2017-12-19 13:48:21 +01:00

471 lines
15 KiB
Fortran
Raw Blame History

BEGIN_PROVIDER [ logical, molecule_is_linear ]
implicit none
BEGIN_DOC
! True if the molecule is linear
END_DOC
molecule_is_linear = (minval(inertia_tensor_eigenvalues) < 1.d-5)
END_PROVIDER
BEGIN_PROVIDER [ logical, molecule_has_center_of_inversion ]
implicit none
BEGIN_DOC
! If true, there is a center of inversion in the WF
END_DOC
molecule_has_center_of_inversion = .True.
integer :: i,j,k
double precision :: point(3)
logical :: found
double precision, external :: u_dot_u
do i=1,nucl_num
found = .False.
do j=1,nucl_num
if (nucl_charge(i) /= nucl_charge(j)) cycle
point(:) = nucl_coord_sym_transp(:,i) + nucl_coord_sym_transp(:,j)
if (u_dot_u(point,3) < 1.d-5) then
found = .True.
exit
endif
enddo
if (.not.found) then
molecule_has_center_of_inversion = .False.
exit
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, sym_rotation_axis, (3) ]
implicit none
BEGIN_DOC
! Order of the rotation axis
END_DOC
include 'constants.include.F'
integer :: i,j,k
double precision :: point(3), point2(3)
logical :: found
double precision, external :: u_dot_u
integer :: iorder, iaxis
do iaxis=1,3
do iorder=12,2,-1
sym_rotation_axis(iaxis) = iorder
do i=1,nucl_num
found = .False.
call sym_apply_rotation(dble(iorder),iaxis,nucl_coord_sym_transp(1,i),point)
do j=1,nucl_num
if (nucl_charge(i) /= nucl_charge(j)) cycle
point2(:) = nucl_coord_sym_transp(:,j) - point(:)
if (u_dot_u(point2,3) < 1.d-5) then
found = .True.
exit
endif
enddo
if (.not.found) then
sym_rotation_axis(iaxis) = 1
exit
endif
enddo
if (sym_rotation_axis(iaxis) /= 1) then
exit
endif
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, molecule_principal_axis ]
&BEGIN_PROVIDER [ integer, molecule_secondary_axis ]
&BEGIN_PROVIDER [ integer, molecule_ternary_axis ]
&BEGIN_PROVIDER [ logical, molecule_has_secondary_c2_rotation ]
implicit none
BEGIN_DOC
! Which axis is the Z axis
END_DOC
molecule_principal_axis = maxloc(sym_rotation_axis,1)
if (molecule_principal_axis == 1) then
if (sym_rotation_axis(2) >= sym_rotation_axis(3)) then
molecule_secondary_axis = 2
molecule_ternary_axis = 3
else
molecule_secondary_axis = 3
molecule_ternary_axis = 2
endif
else if (molecule_principal_axis == 2) then
if (sym_rotation_axis(1) >= sym_rotation_axis(3)) then
molecule_secondary_axis = 1
molecule_ternary_axis = 3
else
molecule_secondary_axis = 3
molecule_ternary_axis = 1
endif
else if (molecule_principal_axis == 3) then
if (sym_rotation_axis(1) >= sym_rotation_axis(2)) then
molecule_secondary_axis = 1
molecule_ternary_axis = 2
else
molecule_secondary_axis = 2
molecule_ternary_axis = 1
endif
endif
if (molecule_principal_axis == 1) then
molecule_has_secondary_c2_rotation = (sym_rotation_axis(2)==2) .or. (sym_rotation_axis(3)==2)
else if (molecule_principal_axis == 2) then
molecule_has_secondary_c2_rotation = (sym_rotation_axis(1)==2) .or. (sym_rotation_axis(3)==2)
else if (molecule_principal_axis == 3) then
molecule_has_secondary_c2_rotation = (sym_rotation_axis(1)==2) .or. (sym_rotation_axis(2)==2)
endif
if (molecule_has_secondary_c2_rotation) then
integer :: swap
if ( (sym_rotation_axis(molecule_secondary_axis) /= 2).and. &
(sym_rotation_axis(molecule_ternary_axis) == 2) ) then
swap = molecule_secondary_axis
molecule_secondary_axis = molecule_ternary_axis
molecule_ternary_axis = swap
endif
endif
END_PROVIDER
BEGIN_PROVIDER [ logical, molecule_has_improper_rotation ]
implicit none
BEGIN_DOC
! Order of the rotation axis
END_DOC
include 'constants.include.F'
integer :: i,j,k
double precision :: point(3), point2(3)
logical :: found
double precision, external :: u_dot_u
integer :: iorder, iaxis
iaxis=molecule_principal_axis
iorder = 2*sym_rotation_axis(iaxis)
molecule_has_improper_rotation = .True.
do i=1,nucl_num
found = .False.
call sym_apply_improper_rotation(dble(iorder),iaxis,nucl_coord_sym_transp(1,i),point)
do j=1,nucl_num
if (nucl_charge(i) /= nucl_charge(j)) cycle
point2(:) = nucl_coord_sym_transp(:,j) - point(:)
if (u_dot_u(point2,3) < 1.d-5) then
found = .True.
exit
endif
enddo
if (.not.found) then
molecule_has_improper_rotation = .False.
exit
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ logical, molecule_has_center_of_inversion ]
implicit none
BEGIN_DOC
! If true, there is a center of inversion in the WF
END_DOC
molecule_has_center_of_inversion = .True.
integer :: i,j,k
double precision :: point(3)
logical :: found
double precision, external :: u_dot_u
do i=1,nucl_num
found = .False.
do j=1,nucl_num
if (nucl_charge(i) /= nucl_charge(j)) cycle
point(:) = nucl_coord_sym_transp(:,i) + nucl_coord_sym_transp(:,j)
if (u_dot_u(point,3) < 1.d-5) then
found = .True.
exit
endif
enddo
if (.not.found) then
molecule_has_center_of_inversion = .False.
exit
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ logical, molecule_has_sigma_plane, (3) ]
implicit none
BEGIN_DOC
! If true, there is a symmetry plane perpendicular to the main axis
END_DOC
integer :: i,j,k
double precision :: point(3), point2(3)
logical :: found
double precision, external :: u_dot_u
integer :: iaxis
do iaxis=1,3
molecule_has_sigma_plane(iaxis) = .True.
do i=1,nucl_num
found = .False.
point(:) = nucl_coord_sym_transp(:,i)
point(iaxis) = -point(iaxis)
do j=1,nucl_num
if (nucl_charge(i) /= nucl_charge(j)) cycle
point2(:) = nucl_coord_sym_transp(:,j) - point(:)
if (u_dot_u(point2,3) < 1.d-5) then
found = .True.
exit
endif
enddo
if (.not.found) then
molecule_has_sigma_plane(iaxis) = .False.
exit
endif
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ character*16, point_group ]
implicit none
BEGIN_DOC
! Point group of the molecule
END_DOC
character*2, save :: i_to_a(24) = (/ '1 ', '2 ', '3 ', '4 ', '5 ', '6 ', '7 ', '8 ', '9 ', &
'10', '11', '12', '13', '14', '15', '16', '17', '18', '19', '20', &
'21', '22', '23', '24' /)
point_group = 'C1'
if (molecule_is_linear) then
if (molecule_has_center_of_inversion) then
point_group = 'Dinfh'
else
point_group = 'Cinfv'
endif
else
if (maxval(sym_rotation_axis) == 1) then
if (molecule_has_sigma_plane(1).or.molecule_has_sigma_plane(2).or.&
molecule_has_sigma_plane(3) ) then
point_group = 'Cs'
else
if (molecule_has_center_of_inversion) then
point_group = 'Ci'
endif
endif
else
if (molecule_has_secondary_c2_rotation) then
if (molecule_has_sigma_plane(molecule_principal_axis)) then
point_group = 'D'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))//'h'
else
if (molecule_has_sigma_plane(molecule_secondary_axis)) then
point_group = 'D'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))//'d'
else
if (molecule_has_sigma_plane(molecule_ternary_axis)) then
point_group = 'D'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))//'d'
else
if ( (sym_rotation_axis(1) == 2).and. &
(sym_rotation_axis(2) == 2).and. &
(sym_rotation_axis(3) == 2).and. &
(inertia_tensor_eigenvalues(1) == inertia_tensor_eigenvalues(2)).and. &
(inertia_tensor_eigenvalues(1) == inertia_tensor_eigenvalues(3)) ) then
point_group = 'Td'
else
point_group = 'D'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))
endif
endif
endif
endif
else
if (molecule_has_sigma_plane(molecule_principal_axis)) then
point_group = 'C'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))//'h'
else
if (molecule_has_sigma_plane(molecule_secondary_axis)) then
point_group = 'C'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))//'v'
else
if (molecule_has_sigma_plane(molecule_ternary_axis)) then
point_group = 'C'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))//'v'
else
if (molecule_has_improper_rotation) then
point_group = 'S'//trim(i_to_a(2*sym_rotation_axis(molecule_principal_axis)))
else
point_group = 'C'//trim(i_to_a(sym_rotation_axis(molecule_principal_axis)))
endif
endif
endif
endif
endif
endif
endif
END_PROVIDER
BEGIN_PROVIDER [ character*8, mo_symmetry ]
implicit none
BEGIN_DOC
! Symmetry of the MOs
END_DOC
integer :: i,j
END_PROVIDER
BEGIN_PROVIDER [ integer, n_irrep ]
implicit none
BEGIN_DOC
! Number of Irreducible representations
END_DOC
integer :: iunit, n, i
character*(256) :: qproot, buffer
integer, external :: getUnitAndOpen
call getenv('QP_ROOT',qproot)
iunit = getUnitAndOpen(trim(qproot)//'/data/Symmetry/'//trim(point_group),'r')
read(iunit,*) ! 1st line
read(iunit,*) buffer, n_irrep
close(iunit)
END_PROVIDER
BEGIN_PROVIDER [ character*8, sym_irrep, (n_irrep) ]
&BEGIN_PROVIDER [ character*8, sym_operation, (n_irrep) ]
&BEGIN_PROVIDER [ double precision, character_table, (n_irrep,n_irrep) ]
implicit none
BEGIN_DOC
! Irreducible representation labels, labels of symmetry operations and
! Character table : columns are sym operations and lines are Irreps
END_DOC
integer :: iunit, n, i
character*(256) :: qproot, buffer
integer, external :: getUnitAndOpen
call getenv('QP_ROOT',qproot)
iunit = getUnitAndOpen(trim(qproot)//'/data/Symmetry/'//trim(point_group),'r')
buffer = ''
read(iunit,*) ! 1st line
read(iunit,*) buffer, n
read(iunit,*) ! empty line
read(iunit,*) ! Irred Operation
do i=1,n
read(iunit,*) buffer, sym_irrep(i), sym_operation(i)
enddo
read(iunit,*) ! empty line
read(iunit,*) ! Table
read(iunit,*) ! 1 2 3 ...
do i=1,n
read(iunit,*) buffer, character_table(i,1:n)
enddo
close(iunit)
END_PROVIDER
BEGIN_PROVIDER [ integer, mo_sym, (mo_tot_num) ]
implicit none
BEGIN_DOC
! Symmetry operations applied on MOs
END_DOC
double precision, allocatable :: sym_points(:,:), ref_points(:,:)
double precision, allocatable :: val(:,:,:)
integer :: iangle, n_sym_points
double precision :: angle
integer :: iop, imo, ipoint, l, i
double precision :: sym_operations_on_mos(mo_tot_num)
logical :: possible_irrep(n_irrep,mo_tot_num)
n_sym_points = 10000
allocate(val(n_sym_points,mo_tot_num,2), sym_points(3,n_sym_points), ref_points(3,n_sym_points))
call generate_sym_coord(n_sym_points,ref_points)
call compute_sym_mo_values(ref_points,n_sym_points,val(1,1,2))
do iop=1,n_irrep
if (sym_operation(iop) == 'E') then
cycle
endif
possible_irrep = .True.
if (sym_operation(iop) == 'i') then
do ipoint=1,n_sym_points
call sym_apply_inversion(ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else if (sym_operation(iop) == 'sh') then
do ipoint=1,n_sym_points
call sym_apply_reflexion(molecule_principal_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else if (sym_operation(iop) == 's') then
do ipoint=1,n_sym_points
call sym_apply_reflexion(molecule_principal_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else if (sym_operation(iop) == 'sv') then
do ipoint=1,n_sym_points
call sym_apply_reflexion(molecule_secondary_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else if (sym_operation(iop) == 'sd') then
do ipoint=1,n_sym_points
call sym_apply_diagonal_reflexion(molecule_principal_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else if (sym_operation(iop) == 'C2''') then
do ipoint=1,n_sym_points
call sym_apply_rotation(angle,molecule_secondary_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else if (sym_operation(iop) == 'C2"') then
do ipoint=1,n_sym_points
call sym_apply_rotation(angle,molecule_ternary_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else
do l=2,len(sym_operation(iop))
if (sym_operation(iop)(l:l) == '^') exit
enddo
read(sym_operation(iop)(2:l-1), *) iangle
l=1
read(sym_operation(iop)(l+1:), *, err=10, end=10) l
10 continue
angle = dble(iangle)/(dble(l))
if (sym_operation(iop)(1:1) == 'C') then
do ipoint=1,n_sym_points
call sym_apply_rotation(angle,molecule_principal_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
else if (sym_operation(iop)(1:1) == 'S') then
do ipoint=1,n_sym_points
call sym_apply_improper_rotation(angle,molecule_principal_axis,ref_points(1,ipoint),sym_points(1,ipoint))
enddo
endif
endif
call compute_sym_mo_values(sym_points,n_sym_points,val(1,1,1))
print *, sym_operation(iop)
do imo=1,mo_tot_num
sym_operations_on_mos(imo) = 0.d0
do ipoint=1,n_sym_points
double precision :: x
x = val(ipoint,imo,1)/val(ipoint,imo,2)
if (dabs(x) > 1.d0) then
x = 1.d0/x
endif
sym_operations_on_mos(imo) += x
enddo
sym_operations_on_mos(imo) *= 1.d0/n_sym_points
print *, iop, imo, sym_operations_on_mos(imo)
if (dabs(sym_operations_on_mos(imo)-1.d0) < 1.d-2) then
sym_operations_on_mos(imo)=1.d0
else if (dabs(sym_operations_on_mos(imo)+1.d0) < 1.d-2) then
sym_operations_on_mos(imo)=-1.d0
endif
do i=1,n_irrep
if (character_table(i,iop) /= sym_operations_on_mos(imo)) then
possible_irrep(i,imo) = .False.
endif
enddo
enddo
enddo
do imo=1,mo_tot_num
print *, imo
do i=1,n_irrep
if (possible_irrep(i,imo)) then
print *, sym_irrep(i)
endif
enddo
print *, ''
enddo
END_PROVIDER
Reference in New Issue View Git Blame Copy Permalink