Commit 3af7ada3 authored by Gregor Michalicek's avatar Gregor Michalicek

Transform inpgen/closure into a free format source file

parent 76d6d06a
......@@ -46,7 +46,7 @@ set(inpgen_F77 ${inpgen_F77}
inpgen/element.f inpgen/atom_input.f inpgen/crystal.f inpgen/lattice2.f inpgen/setab.f inpgen/super_check.f
inpgen/atom_sym.f inpgen/generator.f inpgen/read_record.f inpgen/soc_or_ssdw.f inpgen/symproperties.f
inpgen/bravais_symm.f inpgen/set_atom_core.f inpgen/spg_gen.f global/triang.f
inpgen/closure.f inpgen/lapw_input.f inpgen/struct_input.f inpgen/write_struct.f
inpgen/lapw_input.f inpgen/struct_input.f inpgen/write_struct.f
io/calculator.f global/ss_sym.f global/soc_sym.f math/inv3.f io/rw_symfile.f
global/sort.f init/kptgen_hybrid.f init/od_kptsgen.f init/bravais.f init/divi.f init/brzone.f
init/kptmop.f init/kpttet.f init/bandstr1.F init/ordstar.f init/fulstar.f init/kprep.f
......@@ -56,7 +56,7 @@ init/tetcon.f init/kvecon.f init/boxdim.f math/ylm4.f global/radsra.f math/intgr
set(inpgen_F90 ${inpgen_F90} global/constants.f90 io/xsf_io.f90
eigen/vec_for_lo.f90 eigen/orthoglo.F90 juDFT/usage_data.F90
global/enpara.f90 global/chkmt.f90 inpgen/inpgen.f90 inpgen/set_inp.f90 inpgen/inpgen_help.f90 io/rw_inp.f90 juDFT/juDFT.F90 global/find_enpara.f90
global/enpara.f90 global/chkmt.f90 inpgen/inpgen.f90 inpgen/set_inp.f90 inpgen/inpgen_help.f90 io/rw_inp.f90 juDFT/juDFT.F90 global/find_enpara.f90 inpgen/closure.f90
juDFT/info.F90 juDFT/stop.F90 juDFT/args.F90 juDFT/time.F90 juDFT/init.F90 juDFT/sysinfo.F90 io/w_inpXML.f90 init/julia.f90 global/utility.F90
init/compile_descr.F90 init/kpoints.f90 io/xmlOutput.F90 init/brzone2.f90 cdn/slab_dim.f90 cdn/slabgeom.f90 dos/nstm3.f90 cdn/int_21.f90
cdn/int_21lo.f90 cdn_mt/rhomt21.f90 cdn_mt/rhonmt21.f90 force/force_a21.F90 force/force_a21_lo.f90 force/force_a21_U.f90 force/force_a12.f90
......
......@@ -2,7 +2,6 @@ set(fleur_F77 ${fleur_F77}
inpgen/atom_input.f
inpgen/atom_sym.f
inpgen/bravais_symm.f
inpgen/closure.f
inpgen/crystal.f
inpgen/element.f
inpgen/generator.f
......@@ -21,4 +20,5 @@ inpgen/write_struct.f
set(fleur_F90 ${fleur_F90}
inpgen/set_inp.f90
inpgen/inpgen_help.f90
inpgen/closure.f90
)
MODULE m_closure
use m_juDFT
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Contains 3 subroutines that more or less check the closure:
! closure : checks whether the space group operations close
! close_pt: checks that the point group of the bravais
! lattice closes
! check_close: additionally calculate the multiplication table,
! inverse operations and also determines the type
! of every operation mw99,gs00
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CONTAINS
SUBROUTINE closure(
> mops,mrot,tau,nops,index_op,
< lclose)
IMPLICIT NONE
INTEGER, INTENT (IN) :: mops ! number of operations of the bravais lattice
INTEGER, INTENT (IN) :: nops ! number of operations in space group
INTEGER, INTENT (IN) :: mrot(3,3,mops) ! refer to the operations of the
REAL, INTENT (IN) :: tau(3,mops) ! bravais lattice
INTEGER, INTENT (IN) :: index_op(nops) ! mapping function between space group
! op's and those of the bravais lattice
LOGICAL, INTENT (OUT) :: lclose
REAL ttau(3),eps7
INTEGER i,ii,j,jj,k,kk,mp(3,3),map(nops)
eps7 = 1.0e-7
!---> loop over all operations
DO jj=1,nops
j = index_op(jj)
map(1:nops) = 0
!---> multiply {R_j|t_j}{R_i|t_i}
DO ii=1,nops
i = index_op(ii)
mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
ttau = tau(:,j) + matmul( mrot(:,:,j) , tau(:,i) )
ttau = ttau - anint( ttau - eps7 )
!---> determine which operation this is
DO kk=1,nops
k = index_op(kk)
IF ( all( mp(:,:) == mrot(:,:,k) ) .AND.
& all( abs( ttau(:)-tau(:,k) ) < eps7 ) ) THEN
IF ( map(ii) .eq. 0 ) THEN
map(ii) = kk
ELSE
write(6,*)'ERROR Closure: Multiplying ', jj,' with '
& ,kk, ' and with ',map(ii)
write(6,*) 'yields the same matrix'
lclose = .false.
RETURN
ENDIF
ENDIF
ENDDO
IF (map(ii).eq.0) THEN
write(6,*)'ERROR Closure:',ii,' times',jj,' leaves group'
lclose = .false.
RETURN
ENDIF
ENDDO
ENDDO
lclose = .true.
END SUBROUTINE closure
!*********************************************************************
SUBROUTINE close_pt(
> nops,mrot,
< mtable)
IMPLICIT NONE
INTEGER, INTENT (IN) :: nops,mrot(3,3,nops)
INTEGER, INTENT (OUT) :: mtable(nops,nops) ! table(i,j) = {R_i|0}{R_j|0}
INTEGER :: i,j,k,mp(3,3),map(nops)
!---> loop over all operations
DO j=1,nops
map(1:nops) = 0
!---> multiply {R_j|0}{R_i|0}
DO i=1,nops
mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
!---> determine which operation this is
DO k = 1, nops
IF ( all( mp(:,:)==mrot(:,:,k) ) ) THEN
IF ( map(i) .eq. 0 ) THEN
map(i) = k
ELSE
WRITE (6,'(" Symmetry error : multiple ops")')
CALL juDFT_error("close_pt: Multiple ops (Bravais)"
+ ,calledby ="closure")
ENDIF
ENDIF
ENDDO
IF (map(i).eq.0) THEN
WRITE (6,'(" Group not closed (Bravais lattice)")')
WRITE (6,'(" operation j=",i2," map=",12i4,:/,
& (21x,12i4))') j, map(1:nops)
CALL juDFT_error("close_pt:Not closed",calledby="closure"
+ )
ENDIF
ENDDo
mtable(j,1:nops) = map(1:nops)
ENDDO
END SUBROUTINE close_pt
!*********************************************************************
SUBROUTINE check_close(
> nops,mrot,tau,
< multtab,inv_op,optype)
IMPLICIT NONE
!===> Arguments
INTEGER, INTENT (IN) :: nops
INTEGER, INTENT (IN) :: mrot(3,3,nops)
REAL, INTENT (IN) :: tau(3,nops)
INTEGER, INTENT (OUT) :: inv_op(nops)
INTEGER, INTENT (OUT) :: multtab(nops,nops)
INTEGER, INTENT (OUT) :: optype(nops)
!===> Local Variables
REAL ttau(3)
INTEGER i,j,n,k,mp(3,3),mdet,mtr
REAL, PARAMETER :: eps=1.0e-7
INTEGER, PARAMETER :: cops(-1:3)=(/ 2, 3, 4, 6, 1 /)
inv_op(1:nops) = 0
multtab = 0
!---> loop over all operations
DO j=1,nops
!---> multiply {R_j|t_j}{R_i|t_i}
DO i=1,nops
mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
ttau = tau(:,j) + matmul( mrot(:,:,j) , tau(:,i) )
ttau = ttau - anint( ttau - eps )
!---> determine which operation this is
DO k=1,nops
IF ( all( mp(:,:) == mrot(:,:,k) ) .and.
& all( abs( ttau(:)-tau(:,k) ) < eps ) ) THEN
IF ( multtab(j,i) .eq. 0 ) THEN
multtab(j,i) = k
IF (k .eq. 1) inv_op(j)=i
ELSE
WRITE(6,'(" Symmetry error: multiple ops")')
CALL juDFT_error("check_close: Multiple ops",
+ calledby ="closure")
ENDIF
ENDIF
ENDDO
IF (multtab(j,i).eq.0) THEN
WRITE (6,'(" Group not closed")')
WRITE (6,'(" j , i =",2i4)') j,i
CALL juDFT_error("check_close: Not closed",calledby
+ ="closure")
ENDIF
ENDDO
ENDDO
!---> determine the type of each operation
DO n = 1, nops
mtr = mrot(1,1,n) + mrot(2,2,n) + mrot(3,3,n)
mdet =
& mrot(1,1,n)*(mrot(2,2,n)*mrot(3,3,n)-mrot(3,2,n)*mrot(2,3,n))
& +mrot(1,2,n)*(mrot(3,1,n)*mrot(2,3,n)-mrot(2,1,n)*mrot(3,3,n))
& +mrot(1,3,n)*(mrot(2,1,n)*mrot(3,2,n)-mrot(3,1,n)*mrot(2,2,n))
optype(n) = mdet*cops(mdet*mtr)
ENDDO
END SUBROUTINE check_close
END MODULE m_closure
MODULE m_closure
use m_juDFT
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Contains 3 subroutines that more or less check the closure:
! closure : checks whether the space group operations close
! close_pt: checks that the point group of the bravais
! lattice closes
! check_close: additionally calculate the multiplication table,
! inverse operations and also determines the type
! of every operation mw99,gs00
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CONTAINS
SUBROUTINE closure(mops,mrot,tau,nops,index_op,lclose)
IMPLICIT NONE
INTEGER, INTENT (IN) :: mops ! number of operations of the bravais lattice
INTEGER, INTENT (IN) :: nops ! number of operations in space group
INTEGER, INTENT (IN) :: mrot(3,3,mops) ! refer to the operations of the
REAL, INTENT (IN) :: tau(3,mops) ! bravais lattice
INTEGER, INTENT (IN) :: index_op(nops) ! mapping function between space group
! op's and those of the bravais lattice
LOGICAL, INTENT (OUT) :: lclose
REAL ttau(3),eps7
INTEGER i,ii,j,jj,k,kk,mp(3,3),map(nops)
eps7 = 1.0e-7
! loop over all operations
DO jj = 1, nops
j = index_op(jj)
map(1:nops) = 0
! multiply {R_j|t_j}{R_i|t_i}
DO ii = 1, nops
i = index_op(ii)
mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
ttau = tau(:,j) + matmul( mrot(:,:,j) , tau(:,i) )
ttau = ttau - anint( ttau - eps7 )
! determine which operation this is
DO kk=1,nops
k = index_op(kk)
IF ( all( mp(:,:) == mrot(:,:,k) ) .AND. all( abs( ttau(:)-tau(:,k) ) < eps7 ) ) THEN
IF ( map(ii) .eq. 0 ) THEN
map(ii) = kk
ELSE
write(6,*)'ERROR Closure: Multiplying ', jj,' with ',kk, ' and with ',map(ii)
write(6,*) 'yields the same matrix'
lclose = .false.
RETURN
END IF
END IF
END DO
IF (map(ii).eq.0) THEN
write(6,*)'ERROR Closure:',ii,' times',jj,' leaves group'
lclose = .false.
RETURN
END IF
END DO
END DO
lclose = .true.
END SUBROUTINE closure
!*********************************************************************
SUBROUTINE close_pt(nops,mrot,mtable)
IMPLICIT NONE
INTEGER, INTENT (IN) :: nops,mrot(3,3,nops)
INTEGER, INTENT (OUT) :: mtable(nops,nops) ! table(i,j) = {R_i|0}{R_j|0}
INTEGER :: i,j,k,mp(3,3),map(nops)
! loop over all operations
DO j = 1, nops
map(1:nops) = 0
! multiply {R_j|0}{R_i|0}
DO i = 1, nops
mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
! determine which operation this is
DO k = 1, nops
IF ( all( mp(:,:)==mrot(:,:,k) ) ) THEN
IF ( map(i) .eq. 0 ) THEN
map(i) = k
ELSE
WRITE (6,'(" Symmetry error : multiple ops")')
CALL juDFT_error("close_pt: Multiple ops (Bravais)",calledby ="closure")
END IF
END IF
END DO
IF (map(i).eq.0) THEN
WRITE(6,*) 'Symmetry operations:'
DO k = 1, nops
WRITE(6,*) 'Matrix ', k, ':'
WRITE(6,'(3i7)') mrot(:,1,k)
WRITE(6,'(3i7)') mrot(:,2,k)
WRITE(6,'(3i7)') mrot(:,3,k)
WRITE(6,*) ''
END DO
WRITE (6,'(" Group not closed (Bravais lattice)")')
WRITE (6,'(" operation j=",i2," map=",12i4,:/,(21x,12i4))') j, map(1:nops)
WRITE(6,*) ''
WRITE(6,*) 'Expected product of operations ', j, ' and ', i, ':'
WRITE(6,'(3i7)') mp(:,1)
WRITE(6,'(3i7)') mp(:,2)
WRITE(6,'(3i7)') mp(:,3)
WRITE(6,*) ''
CALL juDFT_error("close_pt:Not closed",calledby="closure")
END IF
END DO
mtable(j,1:nops) = map(1:nops)
END DO
END SUBROUTINE close_pt
!*********************************************************************
SUBROUTINE check_close(nops,mrot,tau,multtab,inv_op,optype)
IMPLICIT NONE
INTEGER, INTENT (IN) :: nops
INTEGER, INTENT (IN) :: mrot(3,3,nops)
REAL, INTENT (IN) :: tau(3,nops)
INTEGER, INTENT (OUT) :: inv_op(nops)
INTEGER, INTENT (OUT) :: multtab(nops,nops)
INTEGER, INTENT (OUT) :: optype(nops)
REAL ttau(3)
INTEGER i,j,n,k,mp(3,3),mdet,mtr
REAL, PARAMETER :: eps=1.0e-7
INTEGER, PARAMETER :: cops(-1:3)=(/ 2, 3, 4, 6, 1 /)
inv_op(1:nops) = 0
multtab = 0
! loop over all operations
DO j = 1, nops
! multiply {R_j|t_j}{R_i|t_i}
DO i = 1, nops
mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
ttau = tau(:,j) + matmul( mrot(:,:,j) , tau(:,i) )
ttau = ttau - anint( ttau - eps )
! determine which operation this is
DO k=1,nops
IF ( all( mp(:,:) == mrot(:,:,k) ) .and. all( abs( ttau(:)-tau(:,k) ) < eps ) ) THEN
IF ( multtab(j,i) .eq. 0 ) THEN
multtab(j,i) = k
IF (k .eq. 1) inv_op(j)=i
ELSE
WRITE(6,'(" Symmetry error: multiple ops")')
CALL juDFT_error("check_close: Multiple ops",calledby ="closure")
END IF
END IF
END DO
IF (multtab(j,i).eq.0) THEN
WRITE (6,'(" Group not closed")')
WRITE (6,'(" j , i =",2i4)') j,i
CALL juDFT_error("check_close: Not closed",calledby="closure")
END IF
END DO
END DO
! determine the type of each operation
DO n = 1, nops
mtr = mrot(1,1,n) + mrot(2,2,n) + mrot(3,3,n)
mdet = mrot(1,1,n)*(mrot(2,2,n)*mrot(3,3,n)-mrot(3,2,n)*mrot(2,3,n)) +&
mrot(1,2,n)*(mrot(3,1,n)*mrot(2,3,n)-mrot(2,1,n)*mrot(3,3,n)) +&
mrot(1,3,n)*(mrot(2,1,n)*mrot(3,2,n)-mrot(3,1,n)*mrot(2,2,n))
optype(n) = mdet*cops(mdet*mtr)
END DO
END SUBROUTINE check_close
END MODULE m_closure
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment