! ! Copyright (C) 2006 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !----------------------------------------------------------------------------- SUBROUTINE divide_class_so(code_group,nrot,smat,d_spin,has_e,nclass, & nelem,elem, which_irr) !----------------------------------------------------------------------------- ! ! This subroutine receives as input a set of nrot 3x3 matrices smat, ! and nrot complex 2x2 matrices d_spin, which are assumed to be the ! operations of the point group given by code_group. Only the operations ! that do not contain the 2\pi rotation (-E) are given in input. ! smat are in cartesian coordinates. ! This routine divides the double group in classes and find: ! ! nclass the number of classes of the double group ! nelem(iclass) for each class, the number of elements of the class ! elem(i,iclass) 10) ax_save(:,which_irr(iclass))=ax(:) ELSEIF (ts==2) THEN IF (has_e(1,iclass)==-1) THEN which_irr(iclass)=7 ELSE which_irr(iclass)=6 END IF END IF END DO ! ! Otherwise choose the first free axis ! DO iclass=2,nclass IF (which_irr(iclass)==0) THEN ts=tipo_sym(smat(1,1,elem(1,iclass))) IF (ts==4) THEN DO i=1,3 IF (done_ax(i)) THEN which_irr(iclass)=i+2 done_ax(i)=.FALSE. GOTO 100 END IF END DO 100 CONTINUE CALL versor(smat(1,1,elem(1,iclass)),ax) ax_save(:,which_irr(iclass))=ax(:) END IF END IF END DO ! ! Finally consider the mirror planes ! DO iclass=2,nclass IF (which_irr(iclass)==0) THEN ts=tipo_sym(smat(1,1,elem(1,iclass))) IF (ts==5) THEN CALL mirror_axis(smat(1,1,elem(1,iclass)),ax) DO i=3,5 IF (is_parallel(ax,ax_save(:,i))) which_irr(iclass)=i+5 END DO END IF END IF IF (which_irr(iclass)==0) CALL errore('divide_class_so',& 'something wrong D_2h',1) ENDDO ELSEIF (code_group==21) THEN ! ! D_3h ! DO iclass=2,nclass ts=tipo_sym(smat(1,1,elem(1,iclass))) IF (ts==1) THEN which_irr(iclass)=2 ELSE IF (ts==3) THEN which_irr(iclass)=set_e(has_e(1,iclass),3) ELSE IF (ts==4) THEN which_irr(iclass)=5 ELSE IF (ts==5) THEN IF (nelem(iclass)>1) THEN which_irr(iclass)=9 ELSE which_irr(iclass)=6 END IF ELSE IF (ts==6) THEN which_irr(iclass)=set_e(has_e(1,iclass),7) END IF END DO ELSEIF (code_group==22) THEN ! ! D_4h ! ! First search the order 4 axis ! DO iclass=2,nclass ts=tipo_sym(smat(1,1,elem(1,iclass))) IF (ts==3) THEN which_irr(iclass)=set_e(has_e(1,iclass),3) CALL versor(smat(1,1,elem(1,iclass)),ax) axis=0 DO ipol=1,3 IF (is_axis(ax,ipol)) axis=ipol ENDDO IF (axis==0) call errore('divide_class_so','unknown D_4h axis ',1) ENDIF END DO first=.TRUE. first1=.TRUE. DO iclass=2,nclass ts=tipo_sym(smat(1,1,elem(1,iclass))) IF (ts==1) THEN which_irr(iclass)=2 ELSE IF (ts==4) THEN CALL versor(smat(1,1,elem(1,iclass)),ax) IF (is_axis(ax,axis)) THEN which_irr(iclass)=5 ELSE IF (first) THEN which_irr(iclass)=6 first=.FALSE. ELSE which_irr(iclass)=7 END IF END IF ELSEIF (ts==2) THEN which_irr(iclass)=set_e(has_e(1,iclass),8) ELSEIF (ts==5) THEN CALL mirror_axis(smat(1,1,elem(1,iclass)),ax) IF (is_axis(ax,axis)) THEN which_irr(iclass)=12 ELSE IF (first1) THEN which_irr(iclass)=13 first1=.FALSE. ELSE which_irr(iclass)=14 END IF END IF ELSEIF (ts==6) THEN which_irr(iclass)=set_e(has_e(1,iclass),10) END IF END DO ELSEIF (code_group==23) THEN ! ! D_6h ! first=.TRUE. first1=.TRUE. DO iclass=2,nclass ts=tipo_sym(smat(1,1,elem(1,iclass))) IF (ts==1) THEN which_irr(iclass)=2 ELSE IF (ts==3) THEN ars=angle_rot(smat(1,1,elem(1,iclass))) IF ((ABS(ars-60.d0) 32 ) CALL errore('is_complex', & 'code is out of range',1) is_complex_so= complex_aux(code) RETURN END FUNCTION is_complex_so ! !---------------------------------------------------------------------------- SUBROUTINE write_group_info(flag) !---------------------------------------------------------------------------- ! ! This routine writes on output the main information on the point group ! If flag is .false. writes only the character table. If flag is .true. ! writes also the elements of each class. ! ! USE rap_point_group, ONLY : code_group, nclass, nelem, elem, which_irr, & char_mat, name_rap, name_class, gname USE rap_point_group_so, ONLY : nrap, nelem_so, elem_so, has_e, & which_irr_so, char_mat_so, name_rap_so, & name_class_so, d_spin, name_class_so1 USE rap_point_group_is, ONLY : code_group_is, gname_is USE spin_orb, ONLY : domag USE noncollin_module, ONLY : noncolin USE io_global, ONLY : stdout IMPLICIT NONE INTEGER :: iclass, irot, i, idx LOGICAL :: is_complex, is_complex_so, flag IF (noncolin) THEN IF (domag) THEN WRITE(stdout,'(/,5x,"the magnetic double point group is ", & & a11," [",a11,"]")') & gname, gname_is WRITE(stdout,'(5x,"using the double point group ",a11)') & gname_is ELSE WRITE(stdout,'(/,5x,"double point group ",a11)') gname END IF WRITE(stdout,'(5x, "there are", i3," classes and",i3, & & " irreducible representations")') nclass, nrap ELSE WRITE(stdout,'(/,5x,"point group ",a11)') gname WRITE(stdout,'(5x, "there are", i3," classes")') nclass ENDIF WRITE(stdout,'(5x, "the character table:")') IF (noncolin) THEN WRITE(stdout,'(/,7x,12(a5,1x))') (name_class_so(irot), & irot=1,MIN(12,nclass)) WRITE(stdout,'(7x,12(a5,1x))') (name_class_so1(irot), & irot=1,MIN(12,nclass)) DO iclass=1,nrap WRITE(stdout,'(a5,12f6.2)') name_rap_so(iclass), & (REAL(char_mat_so(iclass,irot)), irot=1,MIN(nclass,12)) END DO IF (nclass > 12 ) THEN WRITE(stdout,'(/,7x,12(a5,1x))') (name_class_so(irot), & irot=13,nclass) WRITE(stdout,'(7x,12(a5,1x))') (name_class_so1(irot), & irot=13,nclass) DO iclass=1,nrap WRITE(stdout,'(a5,12f6.2)') name_rap_so(iclass), & (REAL(char_mat_so(iclass,irot)), irot=13,nclass) END DO END IF idx=code_group IF (noncolin.and.domag) idx=code_group_is IF (is_complex_so(idx)) THEN WRITE(stdout,'(/,5x,"imaginary part")') WRITE(stdout,'(/,7x,12(a5,1x))') (name_class_so(irot), & irot=1,MIN(12,nclass)) WRITE(stdout,'(7x,12(a5,1x))') (name_class_so1(irot), & irot=1,MIN(12,nclass)) DO iclass=1,nrap WRITE(stdout,'(a5,12f6.2)') name_rap_so(iclass), & (AIMAG(char_mat_so(iclass,irot)),irot=1, MIN(nclass,12)) END DO IF (nclass > 12 ) THEN WRITE(stdout,'(/,7x,12(a5,1x))') (name_class_so(irot), & irot=13,nclass) WRITE(stdout,'(7x,12(a5,1x))') (name_class_so1(irot), & irot=13,nclass) DO iclass=1,nrap WRITE(stdout,'(a5,12f6.2)') name_rap_so(iclass), & (AIMAG(char_mat_so(iclass,irot)),irot=13, nclass) END DO END IF END IF IF (flag) THEN WRITE(stdout,'(/5x, "the symmetry operations in each class:")') DO iclass=1,nclass WRITE(stdout,'(5x,2a5,12i5)') & name_class_so(which_irr_so(iclass)), & name_class_so1(which_irr_so(iclass)), & (elem_so(i,iclass)*has_e(i,iclass), i=1,nelem_so(iclass)) ENDDO ENDIF ELSE WRITE(stdout,'(/,7x,12(a5,1x))') (name_class(irot),irot=1,nclass) DO iclass=1,nclass WRITE(stdout,'(a5,12f6.2)') name_rap(iclass), & (REAL(char_mat(iclass,irot)),irot=1,nclass) ENDDO idx=code_group IF (noncolin.and.domag) idx=code_group_is IF (is_complex(idx)) THEN WRITE(stdout,'(5x,"imaginary part")') DO iclass=1,nclass WRITE(stdout,'(a5,12f6.2)') name_rap(iclass), & (AIMAG(char_mat(iclass,irot)),irot=1,nclass) ENDDO ENDIF IF (flag) THEN WRITE(stdout,'(/5x, "the symmetry operations in each class:")') DO iclass=1,nclass WRITE(stdout,'(5x,a5,12i5)') name_class(which_irr(iclass)), & (elem(i,iclass), i=1,nelem(iclass)) ENDDO END IF END IF RETURN END SUBROUTINE write_group_info !--------------------------------------------------------------------------- SUBROUTINE find_u(s,u) !--------------------------------------------------------------------------- ! ! This subroutine receives as input a 3x3 rotation matrix s, and gives ! as output the matrix u which represents the same rotation in the spin ! space. Only one of the two u matrices is given. See below for the ! definition of the sign. ! USE kinds, ONLY : DP USE constants, ONLY : pi IMPLICIT NONE REAL(DP) :: s(3,3) COMPLEX(DP) :: u(2,2) REAL(DP), PARAMETER :: eps=1.d-8 REAL(DP) :: det, saux(3,3), ax(3), angle, cosa, sina, angle_rot ! ! For consistency check uncomment here ! !COMPLEX(DP) :: a, as, b, bs !REAL(DP) :: r(3,3), r1(3,3), diff det = s(1,1) * ( s(2,2) * s(3,3) - s(3,2) * s(2,3) )- & s(1,2) * ( s(2,1) * s(3,3) - s(3,1) * s(2,3) )+ & s(1,3) * ( s(2,1) * s(3,2) - s(3,1) * s(2,2) ) ! ! inversion has no effect in spin space, so improper rotations are ! multiplied by inversion ! IF (ABS(det+1.d0) < eps) THEN saux=-s ELSE saux=s ENDIF ! ! Check for identity or inversion ! IF ((ABS(saux(1,1)-1.d0) < eps).AND. & (ABS(saux(2,2)-1.d0) < eps).AND. & (ABS(saux(3,3)-1.d0) < eps).AND. & (ABS(saux(1,2)) < eps).AND.(ABS(saux(2,1)) < eps) & .AND.(ABS(saux(2,3)) < eps).AND. & (ABS(saux(3,2)) < eps).AND.(ABS(saux(1,3)) < eps) & .AND.(ABS(saux(3,1)) < eps)) THEN u(1,1)=(1.d0,0.d0) u(1,2)=(0.d0,0.d0) u(2,1)=(0.d0,0.d0) u(2,2)=(1.d0,0.d0) RETURN ENDIF ! ! Find the rotation axis and the rotation angle ! CALL versor(saux,ax) angle=angle_rot(saux) !write(6,'(3f12.5,5x,f12.5)') ax(1), ax(2), ax(3), angle angle=0.5d0*angle*pi/180.d0 cosa=COS(angle) sina=SIN(angle) !write(6,'(2f12.5)') cosa, sina ! ! set the spin space rotation matrix elements ! u(1,1)=CMPLX(cosa,-ax(3)*sina,kind=DP) u(1,2)=CMPLX(-ax(2)*sina, -ax(1)*sina,kind=DP) u(2,1)=-CONJG(u(1,2)) u(2,2)=CONJG(u(1,1)) ! ! To each 3x3 rotation one can associate two 2x2 rotation matrices in spin ! space. This function returns the U matrix with positive cosa term ! IF (cosa < -eps ) u=-u IF (ABS(cosa) < eps) THEN ! ! Special case when cosa=0. For this rotation we must take the negative sign. ! IF (ax(1)*ax(3) < -eps) u=-u ENDIF ! ! Here compute the 3x3 rotation matrix starting form the axis, angle ! or from the rotation in spin space for consistency check. ! !angle=angle*2.d0 !cosa=COS(angle) !sina=SIN(angle) !r1(1,1)=1.d0+(1.d0-cosa)*(ax(1)**2-1) !r1(1,2)=-ax(3)*sina+(1.d0-cosa)*ax(1)*ax(2) !r1(1,3)=ax(2)*sina+(1.d0-cosa)*ax(1)*ax(3) !r1(2,1)=ax(3)*sina+(1.d0-cosa)*ax(1)*ax(2) !r1(2,2)=1.d0+(1.d0-cosa)*(ax(2)**2-1) !r1(2,3)=-ax(1)*sina+(1.d0-cosa)*ax(2)*ax(3) !r1(3,1)=-ax(2)*sina+(1.d0-cosa)*ax(1)*ax(3) !r1(3,2)=ax(1)*sina+(1.d0-cosa)*ax(2)*ax(3) !r1(3,3)=1.d0+(1.d0-cosa)*(ax(3)**2-1) !a=u(1,1) !as=u(2,2) !b=u(1,2) !bs=-u(2,1) !r(1,1)=0.5d0*(a**2+as**2-b**2-bs**2) !r(1,2)=0.5d0*(0.d0,1.d0)*(as**2+bs**2-a**2-b**2) !r(1,3)=-(a*b+as*bs) !r(2,1)=-0.5d0*(0.d0,1.d0)*(as**2-a**2+b**2-bs**2) !r(2,2)=0.5d0*(a**2+b**2+as**2+bs**2) !r(2,3)=(0.d0,1.d0)*(as*bs-a*b) !r(3,1)=(bs*a+as*b) !r(3,2)=(0.d0,1.d0)*(as*b-bs*a) !r(3,3)=(a*as-b*bs) !diff=ABS(r(1,1)-saux(1,1))+ & ! ABS(r(1,2)-saux(1,2))+ & ! ABS(r(1,3)-saux(1,3))+ & ! ABS(r(2,1)-saux(2,1))+ & ! ABS(r(2,2)-saux(2,2))+ & ! ABS(r(2,3)-saux(2,3))+ & ! ABS(r(3,1)-saux(3,1))+ & ! ABS(r(3,2)-saux(3,2))+ & ! ABS(r(3,3)-saux(3,3)) !write(6,*) diff !write(6,'(3f15.5)') r1(1,1),r1(1,2),r1(1,3) !write(6,'(3f15.5)') r1(2,1),r1(2,2),r1(2,3) !write(6,'(3f15.5)') r1(3,1),r1(3,2),r1(3,3) !write(6,*) !write(6,'(3f15.5)') r(1,1),r(1,2),r(1,3) !write(6,'(3f15.5)') r(2,1),r(2,2),r(2,3) !write(6,'(3f15.5)') r(3,1),r(3,2),r(3,3) !write(6,*) !write(6,'(4f15.5)') u(1,1),u(1,2) !write(6,'(4f15.5)') u(2,1),u(2,2) ! RETURN END SUBROUTINE find_u !----------------------------------------------------------------------------- FUNCTION set_e(hase,ind) !----------------------------------------------------------------------------- IMPLICIT NONE INTEGER :: set_e, hase, ind IF (hase==-1) THEN set_e=ind+1 ELSE set_e=ind ENDIF RETURN END FUNCTION set_e !----------------------------------------------------------------------------- SUBROUTINE check_tgroup(nsym,a,b) !----------------------------------------------------------------------------- ! ! This subroutine receives a set of 2x2 and 3x3 rotation matrices and ! checks if they are a group. ! USE kinds, ONLY : DP IMPLICIT NONE COMPLEX(DP) :: a(2,2,48), c(2,2), a1(2,2), a2(2,2), a3(2,2) REAL(DP) :: b(3,3,48), d(3,3), b1(3,3), b2(3,3), b3(3,3) INTEGER :: nsym, done LOGICAL :: compare_mat_so INTEGER :: i, j, k DO i=1,nsym a1(:,:)=a(:,:,i) b1(:,:)=b(:,:,i) DO j=1,nsym a2(:,:)=a(:,:,j) b2(:,:)=b(:,:,j) c=MATMUL(a1,a2) d=MATMUL(b1,b2) done=0 do k=1,nsym a3(:,:)=a(:,:,k) b3(:,:)=b(:,:,k) IF (compare_mat_so(d,c,b3,a3)) THEN done=done+1 ENDIF ENDDO IF (done.ne.1) write(6,*) 'problem, i,j',i,j END DO END DO RETURN END SUBROUTINE check_tgroup