Line data Source code
1 : MODULE m_localsym
2 : !*********************************************************************
3 : ! generate the lattice harmonics appropriate to the local symmetry
4 : ! of the atoms, given the space group operations, bravias lattice,
5 : ! and the atomic positions.
6 : !
7 : ! the coordinate system for vector and operations must be given.
8 : ! here it is assumed that vectors and operations are given in
9 : ! terms of INTERNAL coordinates, i.e., in terms of a1,a2,a3. this
10 : ! is the more complicated case; for everything in cartesian
11 : ! coordinates, the needed changes are rather obvious.
12 : !
13 : ! input:
14 : ! lmax max. l to calculate for each atom type
15 : ! lmaxd max. l (needed to set array sizes)
16 : ! a1,a2,a3 primitive translation vectors; CARTESIAN coord.
17 : !
18 : ! nops number of operations in space group
19 : ! mrot rotation matrices in INTERNAL coordinates:
20 : ! ( 1,1 1,2 1,3 )( t_1 ) ( t_1' )
21 : ! ( 2,1 2,2 2,3 )( t_2 ) = ( t_2' )
22 : ! ( 3,1 3,2 3,3 )( t_3 ) ( t_3' )
23 : ! tau non-primitive translations, in INTERNAL coord.
24 : !
25 : ! ntype number of atom types
26 : ! neq number of equivalent atoms of each type
27 : ! ntyrep representative atom for each type
28 : ! pos atomic positions in INTERNAL coord. (in fleur: taual)
29 : !
30 : ! the results for the lattice harmonics and local symmetry
31 : ! information is put into the module mod_harmonics which can then
32 : ! be use'd as needed.
33 : ! m. weinert 12-99
34 : !*********************************************************************
35 : CONTAINS
36 320 : SUBROUTINE local_sym(
37 320 : > l_write,lmaxd,lmax,nops,mrot,tau,
38 320 : > natd,ntype,neq,amat,bmat,pos,
39 : X nlhd,memd,ntypsd,l_dim,
40 320 : < nlhtyp,nlh,llh,nmem,mlh,clnu)
41 :
42 : USE m_ptsym
43 : USE m_lhcal
44 : USE m_constants
45 :
46 : IMPLICIT NONE
47 :
48 : !---> Arguments
49 : LOGICAL,INTENT(IN) :: l_write
50 : INTEGER, INTENT (IN) :: lmaxd,nops,ntype,natd
51 : INTEGER, INTENT (IN) :: neq(ntype),lmax(ntype),mrot(3,3,nops)
52 : REAL, INTENT (IN) :: tau(3,nops),pos(3,natd)
53 : REAL, INTENT (IN) :: amat(3,3),bmat(3,3)
54 : LOGICAL, INTENT (IN) :: l_dim
55 : INTEGER :: nlhd,memd,ntypsd
56 : INTEGER :: nlhtyp(ntype)
57 : INTEGER, INTENT(OUT) :: llh(0:nlhd,ntypsd),nmem(0:nlhd,ntypsd)
58 : INTEGER, INTENT(OUT) :: mlh(memd,0:nlhd,ntypsd),nlh(ntypsd)
59 : COMPLEX, INTENT(OUT) :: clnu(memd,0:nlhd,ntypsd)
60 :
61 : !---> Locals
62 : INTEGER :: lmax0,mem_maxd,nlhd_max
63 : INTEGER :: lh,lm0,m,n,nsym,na,nsymt,nn
64 320 : REAL :: orth(3,3,nops),amatinv(3,3)
65 320 : INTEGER :: nlhs(natd),locops(nops,natd),nrot(natd)
66 320 : INTEGER :: lnu((lmaxd+1)**2,natd)
67 320 : INTEGER :: mem((lmaxd+1)**2,natd)
68 320 : INTEGER :: lmnu(2*lmaxd+1,(lmaxd+1)**2,natd)
69 320 : COMPLEX :: c(2*lmaxd+1,(lmaxd+1)**2,natd)
70 :
71 320 : INTEGER, ALLOCATABLE :: typsym(:)
72 :
73 4160 : amatinv = bmat / ( 2 * pimach() )
74 320 : mem_maxd = 2*lmaxd+1
75 320 : nlhd_max = (lmaxd+1)**2
76 960 : ALLOCATE ( typsym(natd) )
77 :
78 320 : if (l_write) THEN
79 160 : WRITE (oUnit,'(//," Local symmetries:",/,1x,17("-"))')
80 : END IF
81 : !
82 : !===> determine the point group symmetries for each atom given
83 : !===> the space group operations and atomic positions
84 : !===> operations and positions are in internal (lattice) coordinates
85 : !
86 : CALL ptsym(
87 : > ntype,natd,neq,pos,nops,mrot,tau,lmax,
88 320 : < nsymt,typsym,nrot,locops)
89 :
90 320 : if (l_write) THEN
91 160 : WRITE (oUnit,'(" symmetry kinds =",i4)') nsymt
92 346 : DO nsym = 1, nsymt
93 : WRITE (oUnit,'(/," symmetry",i3,":",i4," operations in",
94 186 : + " local point group",/,8x,"atoms:")') nsym,nrot(nsym)
95 186 : na = 0
96 716 : DO n=1,ntype
97 1056 : DO nn = 1, neq(n)
98 500 : na = na + 1
99 870 : IF ( typsym(na) == nsym ) WRITE (oUnit,'(i14)') na
100 : ENDDO
101 : ENDDO
102 : ENDDO
103 : endif
104 : !
105 : !===> generate the lattice harmonics for each local symmetry
106 : !
107 692 : DO nsym = 1, nsymt
108 :
109 : !---> need to generate transformation matrices in cartesian
110 : !---> coordinates (rotations in real space)
111 5036 : DO n = 1, nrot(nsym)
112 : orth(:,:,n) = matmul( amat,
113 480764 : & matmul( real( mrot(:,:,locops(n,nsym))),amatinv ) )
114 : ENDDO
115 :
116 : !---> get max. l for this symmetry type
117 372 : lmax0 = 0
118 372 : na = 0
119 1112 : DO n=1,ntype
120 2112 : DO nn = 1, neq(n)
121 1000 : na = na + 1
122 1740 : IF (typsym(na).EQ.nsym) lmax0 = max(lmax0,lmax(n))
123 : ENDDO
124 : ENDDO
125 :
126 : !---> generate the lattice harmonics
127 : CALL lhcal(
128 : > mem_maxd,nlhd_max,lmax0,nrot(nsym),orth,
129 : < nlhs(nsym),lnu(1,nsym),mem(1,nsym),
130 692 : < lmnu(1,1,nsym),c(1,1,nsym))
131 :
132 : ENDDO
133 : !
134 : !====> allocate arrays in module mod_harmonics and store for later use
135 : !====> this part can be changed depending on program to interface to;
136 : !====> this version is consistent with fleur.
137 : !
138 320 : nlhd = 0
139 320 : memd = 0
140 692 : DO nsym = 1, nsymt
141 372 : nlhd = max(nlhd,nlhs(nsym))
142 15060 : DO lh=1,nlhs(nsym)
143 14740 : memd = max(memd,mem(lh,nsym))
144 : ENDDO
145 : ENDDO
146 320 : nlhd = nlhd - 1
147 :
148 320 : IF ( nsymt > ntypsd ) ntypsd = nsymt
149 320 : IF ( l_dim ) THEN
150 160 : DEALLOCATE ( typsym )
151 160 : RETURN
152 : ENDIF
153 24438 : clnu = cmplx( 0.0,0.0 )
154 24438 : mlh = 0
155 346 : DO nsym = 1,nsymt
156 186 : nlh(nsym) = nlhs(nsym)-1
157 7530 : DO lh = 1, nlhs(nsym)
158 7184 : llh(lh-1,nsym) = lnu(lh,nsym)
159 7184 : nmem(lh-1,nsym) = mem(lh,nsym)
160 7184 : lm0 = lnu(lh,nsym)*(lnu(lh,nsym)+1) + 1
161 21270 : DO m = 1, mem(lh,nsym)
162 13900 : mlh(m,lh-1,nsym) = lmnu(m,lh,nsym) - lm0
163 21084 : clnu(m,lh-1,nsym) = c(m,lh,nsym)
164 : ENDDO
165 : ENDDO
166 : ENDDO
167 :
168 24438 : WHERE ( abs(aimag(clnu)) < 1.e-13 ) clnu = cmplx( real(clnu),0.0)
169 24438 : WHERE ( abs( real(clnu)) < 1.e-13 ) clnu = cmplx(0.0,aimag(clnu))
170 : !
171 : !---> different atom types may have the same symmetry, but different
172 : !---> lmax. to deal with this possibility, define nlhtyp(ntype) to
173 : !---> give the number of harmonics for each atom type.
174 : !
175 160 : na = 0
176 434 : DO n = 1, ntype
177 274 : nlhtyp(n) = 0
178 796 : DO nn = 1,neq(n)
179 362 : na = na + 1
180 14280 : DO lh = 1, nlh( typsym(na) )
181 13644 : IF ( llh(lh,typsym(na)) .GT. lmax(n) ) EXIT
182 14006 : nlhtyp(n) = nlhtyp(n) + 1
183 : ENDDO
184 : ENDDO
185 : ENDDO
186 :
187 :
188 : !---> output results
189 160 : if (.not.l_write) return
190 173 : DO n = 1, nsymt
191 : WRITE (oUnit,'(/," --- Local symmetry",i3,":",i4,
192 93 : & " lattice harmonics ",30("-"))') n,nlh(n)+1
193 3765 : DO lh = 0,nlh(n)
194 : WRITE (oUnit,'(/,5x,"lattice harmonic",i4,": l=",i2,
195 3592 : & ",",i3," members:")') lh+1,llh(lh,n),nmem(lh,n)
196 3685 : IF ( mod(nmem(lh,n),2)==1 ) THEN
197 : WRITE (oUnit,'(5x,i5,2f14.8,5x,i5,2f14.8)')
198 652 : & mlh(1,lh,n),clnu(1,lh,n)
199 652 : IF ( nmem(lh,n) > 1 ) THEN
200 : WRITE (oUnit,'(5x,i5,2f14.8,5x,i5,2f14.8)')
201 322 : & (mlh(m,lh,n),clnu(m,lh,n),m=2,nmem(lh,n))
202 : ENDIF
203 : ELSE
204 : WRITE (oUnit,'(5x,i5,2f14.8,5x,i5,2f14.8)')
205 8994 : & (mlh(m,lh,n),clnu(m,lh,n),m=1,nmem(lh,n))
206 : ENDIF
207 : ENDDO
208 : ENDDO
209 :
210 80 : DEALLOCATE ( typsym )
211 80 : RETURN
212 640 : END SUBROUTINE local_sym
213 : END MODULE m_localsym
|
