Context Navigation

source: trunk/fsource/spsubs/sgroupnp.for @ 209

Last change on this file since 209 was 209, checked in by vondreele, 13 years ago
fortran fixes - new self contained libraries had to change all INCLUDE copyright lines.
File size: 26.2 KB

Line
1	SUBROUTINE SGROUPNP(SPG,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,JRT,
2	1 CEN,NCV,RT,IER)
3
4	!Purpose: S.R. which generates a space group from the symbol - no printing
5
6	INCLUDE 'INCLDS/COPYRIGT.FOR'
7
8	! This program was developed for
9	! The Division of Chemistry
10	! of
11	! The National Research Council of Canada
12	! by
13	! Allen C. Larson, 14 Cerrado Loop, Santa Fe, NM 87505, USA
14	!
15	!
16	! This SR interprets the space group symbol
17	! Data in the calling sequence are
18	! SPG Input 20 Characters containing the space group symbol
19	! LAUENO Output The Laue Group no. where
20	! 1=1BAR, 2=2/M, 3=MMM, 4=4/M, 5=4/MM, 6=R3R, 7=R3MR,
21	! 8=3, 9=3M1, 10=31M, 11=6/M, 12=6/MMM, 13=M3 AND 14=M3M
22	! NAXIS Output Unique axis in monoclinic space groups
23	! = 4 on error exits; = -1 for rhombahedral in hexagonal setting
24	! NCENT Output 1Bar flag (0/1) for (acentric/centric)
25	! LCENT Output Lattice centering no.
26	! 1=P, 2=A, 3=B, 4=C, 5=I, 6=F AND 7=R
27	! NSYM Output The no. of matrices generated
28	! NPOL Output The polar axis flag
29	! 1=x, 2=y, 3=x y, 4=z, 5=x z, 6=y z, 7=xyz, 8=111
30	! JRT Output The NSYM (3,5,NSYM) matrices
31	! CEN Output The lattice centering vectors
32	! NCV Output The no. of lattice centering vectors
33	! RT Scratch array of 500 words needed by sgroup
34	! IER Error flag no.
35
36	INTEGER*4 JRT(3,5,24) !Output matrices, with flags
37	CHARACTER*20 SPG !Input stribg to be parced
38	REAL*4 CEN(3,4) !Lattice centering vectors
39	REAL*4 RT(5,4,25) !Raw trial matrices with some flags
40	REAL*4 D(3,3) !Origin definition data
41	CHARACTER*33 CHR !List of characters which will be recognized
42	INTEGER*4 LCEN(7) !Latice centering flags
43	INTEGER*4 L(4,4) !First parcing output, Characters converted to numbers
44
45	! C B A P F I R
46	DATA LCEN/4,3,2,1,6,5,7/
47
48	! 111111111122222222223333
49	! 123456789012345678901234567890123
50	DATA CHR/' CBAPFIRMND123456-/H.cbapfirmndh '/
51	CHR(33:33) = CHAR(9) !Set to "tab"
52
53	IM = 0
54	DO I=1,20
55	IF ( SPG(I:I).EQ.CHAR(9) ) SPG(I:I) = ' ' !Remove tabs; set to ' '
56	IF ( SPG(I:I).NE.' ' ) IM = I
57	END DO
58	I = 1
59	DO WHILE ( I.LE.IM ) !Squeeze out extra spaces
60	IF ( I.LT.20 .AND. SPG(I:I+1).EQ.' ' ) THEN
61	DO J=I+1,IM
62	SPG(J:J) = SPG(J+1:J+1)
63	END DO
64	IM = IM-1
65	ELSE
66	I = I+1
67	END IF
68	END DO
69	DO I=1,4 !Clear the L-array
70	DO J=1,4
71	L(I,J) = 0
72	END DO
73	END DO
74	K = 1 !The number of operator fields
75	M = 0 !The number of elements in a single field
76	IER = 0 !General error flag
77	NCENT = 0 !Set the centric/acentric flag to acentric
78	LAUENO = 0 !Laue Group number
79	NAXIS = 0 !Unique axis
80	IERX = 0 !Error flag of type 2
81	N = 0 !Matrix count
82	J = 1
83	DO WHILE ( IER.EQ.0 .AND. J.LE.20 .AND. K.LE.4 ) !Break the space group symbol into the 4 fields
84	I = 1 !Code as numerical values for manipulation
85	DO WHILE ( I.LE.33 .AND. SPG(J:J).NE.CHR(I:I) ) !Search for this character among the legal chars
86	I = I+1
87	END DO
88	IF ( I.LE.33 ) THEN !If character was a legal one
89	IF ( I.EQ.32 ) THEN
90	I = 20 !Convert h to H
91	ELSE IF ( I.GT.21 .AND. I.LT.33 ) THEN
92	I = I-20 !Lower case letters are to be treated as u.c.
93	END IF
94	IF ( I.GT.1 .AND. I.LT.33 ) THEN !We ignore extra spaces
95	M = M+1
96	L(M,K) = I
97	IF ( I.LT.12 .OR. M.GE.4 ) M = 0
98	IF ( M.EQ.0 ) K=K+1
99	ELSE
100	IF ( M.GT.0 ) THEN
101	M = 0
102	K = K+1
103	END IF
104	END IF
105	ELSE
106	IER = 29
107	END IF
108	J = J+1 !Count the input characters
109	END DO
110	IF ( IER.EQ.0 ) THEN
111	K = K-1
112	IF ( K.LE.1 ) THEN
113	IER = 1 !If only 1 field was found. There is an error.
114	END IF
115
116	IF ( IER.EQ.0 ) THEN
117	IF ( L(1,1).GT.8 ) THEN
118	IER = 2 !If the first character was not a P, A, B, C,
119	END IF
120
121	IF ( IER.EQ.0 ) THEN
122	J = 1
123	DO WHILE ( J.LT.4 .AND. IER.EQ.0 )
124	J = J+1
125	IF ( L(1,J).EQ.18 ) CALL SGLPAK(L(1,J),IER) !Convert the -N notation to the Nb(ar) notation
126	END DO
127	END IF
128	END IF
129	END IF
130	IF ( IER.GT.0 ) GO TO 500
131
132	DO I=1,3
133	DO J=1,3
134	D(I,J) = 0.0 !Clear the origin definition translation flags
135	END DO
136	END DO
137
138	N = 2 !Set the matrix count N to 2
139	I209 = 0 !Clear the body diagonal 3-axis flag
140	LCENT = L(1,1)-1 !Set the lattice centering flag.
141	LCENT = LCEN(LCENT) ! 1=P, 2=A, 3=B, 4=C, 5=I, 6=F, 7=R
142	IF ( LCENT.NE.7 ) THEN
143	CALL SGLATC(K,L,D,LCENT,LAUENO,NAXIS,IER,I209,ID) !Call a S.R. to determine LAUENO and some
144	IF ( IER.GT.0 ) GO TO 500 ! preliminary data
145	ELSE
146	IF ( L(1,2).NE.14 ) THEN !Rhombohedral lattice.
147	IER = 3 !Make sure that there is a 3-axis.
148	GO TO 500
149	ELSE
150	IF ( L(1,K).NE.8 ) THEN
151	IF ( L(1,K).EQ.20 ) K=K-1 !Hexagonal axes. R centering. Set LAUENO to 8 or 9
152	LAUENO = K+6
153	ELSE !Rhombohedral axes.
154	LCENT = 1 !Delete R centering. Set LAUENO to 6 or 7
155	K = K-1
156	LAUENO = K+4
157	I209 = 1
158	END IF
159	END IF
160	END IF
161	CALL SGLCEN(LCENT,CEN,NCV) !Establish the list of lattice centering vectors
162
163	IOP = 0 !Set the matrix generator flag to 0
164	CALL SGRMAT(IOP,RT,1,1.,0.,0.,0.,1.,0.,0.,0.,1.) !Generate the Idenity operator
165
166	IF ( I209.GT.0 ) THEN
167	CALL SGRMAT(IOP,RT,2,0.,0.,1.,1.,0.,0.,0.,1.,0.) !Cubic or rhombohedral cell. Generate z,x,y
168	CALL SGRMAT(IOP,RT,3,0.,1.,0.,0.,0.,1.,1.,0.,0.) ! and y,z,x
169	N = 4
170	END IF
171
172	DO MF=2,K !Old 3000 loop !Decode the last 3 fields of the symbol
173	IF ( L(1,MF).EQ.0 ) THEN
174	IER = 6
175	GO TO 500
176	END IF
177	IFLD = 1
178	DO WHILE ( IFLD.LT.4 .AND. L(IFLD,MF).GT.0 )
179	IF ( IFLD.GT.1 ) THEN
180	DO WHILE ( IFLD.LE.3 .AND. L(IFLD,MF).NE.19 )
181	IF ( L(IFLD,MF).EQ.0 ) THEN
182	IFLD = 4
183	ELSE
184	IF ( L(IFLD,MF).LT.12 ) IER=16
185	IF ( IER.GT.0 ) GO TO 500
186	IFLD = IFLD+1
187	END IF
188	END DO
189	IFLD = IFLD+1
190	IF ( IFLD.LT.5 .AND. L(IFLD,MF).LE.1 ) IER=17
191	IF ( IER.GT.0 ) GO TO 500
192	END IF
193	IF ( IFLD.LT.5 ) THEN
194	I = ABS(L(IFLD,MF)-5)
195	IF ( I.LE.0 .OR. I.GT.15 ) THEN
196	IER = 7
197	GO TO 500
198	END IF
199	NDELT = 1
200	NXI = N !Set first matrix pointer
201	IF ( I.LE.5 ) THEN !Character was A, B, C, M or N
202	IF ( MF.EQ.2 .AND. LAUENO.LE.3 ) THEN
203	IF ( K.EQ.2 ) THEN !Monoclinic B-axis unique
204	IF ( I.EQ.2 ) IER=9
205	IF ( IER.GT.0 ) GO TO 500
206	IOP = 32+2
207	CALL SGRMAT(IOP,RT,N,1.,0.,0.,0.,-1.,0.,0.,0.,1.) !A B-axis mirror
208	RT(2,4,N) = D(2,2)
209	IF ( I.EQ.1 .OR. I.EQ.5 ) RT(1,4,N) = 0.5
210	IF ( I.EQ.3 .OR. I.EQ.5 ) RT(3,4,N) = 0.5
211	ELSE
212	IF ( I.EQ.1 ) IER=8
213	IF ( IER.GT.0 ) GO TO 500
214	IOP = 32+4
215	CALL SGRMAT(IOP,RT,N,-1.,0.,0.,0.,1.,0.,0.,0.,1.) !An A-axis mirror
216	RT(1,4,N) = D(1,1)
217	IF ( I.EQ.2 .OR. I.EQ.5 ) RT(2,4,N)=0.5
218	IF ( I.EQ.3 .OR. I.EQ.5 ) RT(3,4,N)=0.5
219	END IF
220	ELSE IF ( MF.EQ.3 .AND. LAUENO.NE.7 ) THEN !Third field and not a Rombohedral lattice
221	IF ( L(1,2).EQ.14 .OR. L(1,2).EQ.17 ) THEN
222	IOP = 32+4
223	CALL SGRMAT(IOP,RT,N,-1.,1.,0.,0.,1.,0.,0.,0.,1.) !Mirror normal to [100] in hex cell
224	IF ( I.EQ.3 ) RT(3,4,N)=0.5
225	ELSE
226	IF ( L(1,2).EQ.15 ) THEN !It is not trigonal or hexagonal
227	IF ( I.EQ.1 ) IER=8
228	IF ( IER.GT.0 ) GO TO 500
229	IOP = 32+4
230	CALL SGRMAT(IOP,RT,N,-1.,0.,0.,0.,1.,0.,0.,0.,1.) !An A-axis mirror
231	RT(1,4,N) = D(1,1)
232	IF ( I.EQ.2 .OR. I.EQ.5 ) RT(2,4,N)=0.5
233	IF ( I.EQ.3 .OR. I.EQ.5 ) RT(3,4,N)=0.5
234	ELSE
235	IF ( I.EQ.2 ) IER=9
236	IF ( IER.GT.0 ) GO TO 500
237	IOP = 32+2
238	CALL SGRMAT(IOP,RT,N,1.,0.,0.,0.,-1.,0.,0.,0.,1.) !A B-axis mirror
239	RT(2,4,N) = D(2,2)
240	IF ( I.EQ.1 .OR. I.EQ.5 ) RT(1,4,N) = 0.5
241	IF ( I.EQ.3 .OR. I.EQ.5 ) RT(3,4,N) = 0.5
242	END IF
243	END IF
244	ELSE IF ( MF.EQ.4 .OR. LAUENO.GT.3 ) THEN
245	IF ( (MF.EQ.4 .OR. LAUENO.EQ.7) .AND.
246	1 (L(1,3).EQ.14 .OR. L(1,2).EQ.15 .OR.
247	1 L(1,2).EQ.14 .OR. L(1,2).EQ.17) ) THEN !It is not cubic or tetragonal
248	IOP = 16+8 !Set the op flag to 24
249	CALL SGRMAT(IOP,RT,N,0.,1.,0.,1.,0.,0.,0.,0.,1.) !A diagonal mirrror normal to [-110]
250	RT(1,4,N) = D(2,2)
251	RT(2,4,N) = -D(2,2)
252	IF ( I.EQ.3 .OR. I.EQ.5 ) RT(3,4,N) = 0.5
253	IF ( (LAUENO.EQ.7 .AND. I.EQ.3) .OR.
254	1 (I.LT.3 .OR. I.GT.4) ) THEN
255	IF ( LCENT.EQ.6 .OR. LCENT.EQ.4 ) THEN
256	RT(1,4,N) = 0.25+RT(1,4,N) !Either F or C-centered tetragonal.
257	RT(2,4,N) = 0.25+RT(2,4,N) ! Glides are 1/4,1/4
258	ELSE
259	RT(1,4,N) = 0.5+RT(1,4,N)
260	RT(2,4,N) = 0.5+RT(2,4,N)
261	END IF
262	END IF
263	ELSE
264	IF ( I.EQ.3 ) IER=10
265	IF ( IER.GT.0 ) GO TO 500
266	IF ( LAUENO.GT.12 ) THEN
267	IOP = 32+4
268	ELSE
269	IOP = 1
270	END IF
271	CALL SGRMAT(IOP,RT,N,1.,0.,0.,0.,1.,0.,0.,0.,-1.) !A C-axis mirror
272	RT(3,4,N) = D(3,3)
273	IF ( I.EQ.1 .OR. I.EQ.5 ) RT(1,4,N) = 0.5
274	IF ( I.EQ.2 .OR. I.EQ.5 ) RT(2,4,N) = 0.5
275	IF ( MF.EQ.2 .AND. L(1,2).EQ.17 .AND. L(2,2).EQ.14 )
276	1 RT(3,4,N)=0.5 !If this a 63-axis the mirror is at 1/4
277	END IF
278	END IF
279	ELSE IF ( I.EQ.6 ) THEN !d glide type mirror
280	IF ( LCENT.LE.1 ) IER=11
281	IF ( IER.GT.0 ) GO TO 500
282	ICV = 2
283	IF ( MF.EQ.2 .AND. LAUENO.LE.3 ) THEN
284	IF ( K.EQ.2 ) THEN
285	IF ( NCV.EQ.4 ) ICV=3
286	IOP = 32+2
287	CALL SGRMAT(IOP,RT,N,1.,0.,0.,0.,-1.,0.,0.,0.,1.)
288	RT(1,4,N) = CEN(1,ICV)/2.0
289	! IF ( LAUENO.EQ.5 ) RT(2,4,N) = D(2,1)
290	RT(3,4,N) = CEN(3,ICV)/2.0
291	ELSE
292	IOP = 32+4
293	CALL SGRMAT(IOP,RT,N,-1.,0.,0.,0.,1.,0.,0.,0.,1.)
294	IF ( ID.EQ.2 ) RT(1,4,N)=0.25
295	RT(2,4,N) = CEN(2,ICV)/2.0
296	RT(3,4,N) = CEN(3,ICV)/2.0
297	END IF
298	ELSE IF ( MF.EQ.3 ) THEN
299	IF ( NCV.EQ.4 ) ICV=3
300	IOP = 32+2
301	CALL SGRMAT(IOP,RT,N,1.,0.,0.,0.,-1.,0.,0.,0.,1.)
302	RT(1,4,N) = CEN(1,ICV)/2.0
303	IF ( ID.EQ.2 ) RT(2,4,N)=0.25
304	IF ( LAUENO.EQ.5 ) RT(2,4,N) = D(2,1)
305	RT(3,4,N) = CEN(3,ICV)/2.0
306	ELSE IF ( MF.EQ.4 .OR. LAUENO.GT.3 ) THEN
307	IF ( MF.EQ.4 .AND. (L(1,2).EQ.15 .OR. L(1,3).EQ.14) )
308	1 THEN
309	IOP = 16+8 !Set the op flag to 24
310	CALL SGRMAT(IOP,RT,N,0.,1.,0.,1.,0.,0.,0.,0.,1.) !Cubic or tetragonal. D-glide along diagonal
311	IF ( L(1,3).EQ.13 ) THEN
312	RT(1,4,N) = 0.0
313	RT(2,4,N) = 0.5
314	ELSE
315	RT(1,4,N) = 0.25
316	RT(2,4,N) = 0.25
317	END IF
318	RT(3,4,N) = 0.25
319	ELSE
320	IF ( NCV.EQ.4 ) ICV=4
321	IF ( LAUENO.GT.12 ) THEN
322	IOP = 32+4
323	ELSE
324	IOP = 1
325	END IF
326	CALL SGRMAT(IOP,RT,N,1.,0.,0.,0.,1.,0.,0.,0.,-1.)
327	RT(1,4,N) = CEN(1,ICV)/2.0
328	RT(2,4,N) = CEN(2,ICV)/2.0
329	IF ( ID.EQ.2 ) RT(3,4,N)=0.25
330	END IF
331	END IF
332	ELSE IF ( I.EQ.7 ) THEN ! 1-fold axis
333	NDELT = 0
334	IF ( L(2,MF).EQ.18 ) THEN
335	NCENT = 1 !We have a center of symmetry
336	IFLD = IFLD+1
337	END IF
338	ELSE IF ( I.EQ.8 ) THEN !2 fold rotation axis
339	IF ( L(2,MF).EQ.18 ) IER=19 !We will not allow a -2 axis.
340	IF ( IER.GT.0 ) GO TO 500
341	IF ( MF.EQ.2 ) THEN !First rotation operator
342	IF ( K.EQ.2 ) THEN
343	IOP = 6
344	CALL SGRMAT(IOP,RT,N,-1.,0.,0.,0.,1.,0.,0.,0.,-1.) !Rotation about the B-axis
345	RT(1,4,N) = D(1,2)
346	RT(3,4,N) = D(3,2)
347	IF ( L(2,MF).EQ.12 ) RT(2,4,N)=0.5
348	ELSE
349	IOP = 32+3
350	CALL SGRMAT(IOP,RT,N,1.,0.,0.,0.,-1.,0.,0.,0.,-1.) !Rotation about the A-axis.
351	RT(2,4,N) = D(2,1)
352	RT(3,4,N) = D(3,1)
353	IF ( IABS(L(2,MF)-13).EQ.1 ) RT(1,4,N) = 0.5
354	END IF
355	ELSE IF ( MF.EQ.3 ) THEN !Second rotation operator
356	IF ( LAUENO.EQ.7 ) THEN
357	IOP = 16+1
358	CALL SGRMAT(IOP,RT,N,0.,-1.,0.,-1.,0.,0.,0.,0.,-1.) !2-axis along [1-10]
359	ELSE IF ( L(1,2).EQ.17 .AND. L(1,4).NE.12 ) THEN
360	IOP = 32+3
361	CALL SGRMAT(IOP,RT,N,1.,-1.,0.,0.,-1.,0.,0.,0.,-1.) !2-axis along [100] used for the P 6n22 groups
362	ELSE IF ( L(1,2).EQ.14 ) THEN
363	IOP = 16+1 !op flag will be 9
364	CALL SGRMAT(IOP,RT,N,0.,1.,0.,1.,0.,0.,0.,0.,-1.) !2-axis along [110] trig
365	RT(1,4,N) = D(2,1) ! Also used for the P 3n21 groups
366	IF ( L(2,MF).EQ.12 ) RT(1,4,N)=RT(1,4,N)+0.5
367	RT(2,4,N) = -D(2,1)
368	RT(3,4,N) = D(3,1)
369	ELSE !It is not a hexagonal or trigonal space group
370	IOP = 32+5
371	CALL SGRMAT(IOP,RT,N,-1.,0.,0.,0.,1.,0.,0.,0.,-1.) !Rotation about the B-axis
372	IF ( L(1,2).EQ.9 .AND. L(1,4).EQ.10 ) THEN
373	RT(1,4,N) = 0.5
374	ELSE
375	RT(1,4,N) = D(1,2)
376	END IF
377	RT(3,4,N) = D(3,2)
378	IF ( L(2,MF).EQ.12 ) RT(2,4,N)=0.5
379	END IF
380	ELSE IF ( MF.EQ.4 ) THEN
381	IF ( L(1,2).GE.14 .OR. L(1,3).EQ.14 ) THEN
382	IF ( L(1,2).EQ.15 ) THEN
383	IOP = 32+5 !op flag should be 37
384	CALL SGRMAT(IOP,RT,N,0.,1.,0.,1.,0.,0.,0.,0.,-1.) !2-axis along [110] tetrag
385	RT(1,4,N) = D(2,1)
386	IF ( L(2,MF).EQ.12 ) RT(1,4,N)=RT(1,4,N)+0.5
387	RT(2,4,N) = -D(2,1)
388	RT(3,4,N) = D(3,1)
389	ELSE
390	IOP = 16+1
391	CALL SGRMAT(IOP,RT,N,1.,0.,0.,1.,-1.,0.,0.,0.,-1.)!2-axis along [210]
392	END IF
393	ELSE
394	IOP = 6
395	CALL SGRMAT(IOP,RT,N,-1.,0.,0.,0.,-1.,0.,0.,0.,1.) !2-Fold rotation about the C-axis
396	RT(1,4,N) = D(1,3)
397	RT(2,4,N) = D(2,3)
398	IF ( IABS(L(2,MF)-13).EQ.1 ) RT(3,4,N) = 0.5
399	IF ( L(2,MF).EQ.16 ) RT(3,4,N) = 0.5
400	END IF
401	END IF
402	ELSE IF ( I.EQ.9 ) THEN !3-fold axis
403	IF ( MF.EQ.2 .AND. LAUENO.GT.7 ) THEN
404	IOP = 0
405	CALL SGRMAT(IOP,RT,N,0.,-1.,0.,1.,-1.,0.,0.,0.,1.)
406	IF ( L(2,MF).EQ.12 ) RT(3,4,N)=0.33333333
407	IF ( L(2,MF).EQ.13 ) RT(3,4,N)=0.66666667
408	IF ( L(2,MF).EQ.18 ) THEN
409	NCENT = 1
410	IFLD = IFLD+1
411	END IF
412	ELSE IF ( MF.EQ.3 .OR. LAUENO.LE.7 ) THEN
413	NDELT = 0
414	IF ( L(2,MF).EQ.18 ) THEN
415	NCENT=1
416	IFLD = IFLD+1
417	END IF
418	ELSE
419	IER = 25
420	GO TO 500
421	END IF
422	ELSE IF ( I.EQ.10 ) THEN
423	IF ( MF.NE.2 ) IER=12 !Four fold axis
424	IF ( IER.GT.0 ) GO TO 500
425	IF ( L(2,MF).EQ.18 ) THEN
426	IOP = 32+16+1
427	CALL SGRMAT(IOP,RT,N,0.,1.,0.,-1.,0.,0.,0.,0.,-1.) !4-bar axis
428	RT(1,4,N) = D(1,3)
429	RT(2,4,N) = D(2,3)
430	RT(3,4,N) = D(3,3)
431	IFLD = IFLD+1
432	ELSE
433	IOP = 32+16
434	CALL SGRMAT(IOP,RT,N,0.,-1.,0.,1.,0.,0.,0.,0.,1.) !4-axis
435	RT(1,4,N) = D(1,3)
436	RT(2,4,N) = D(2,3)
437	IF ( L(2,2).EQ.12 ) RT(3,4,N) = 0.25 !41 axis
438	IF ( L(2,2).EQ.13 ) RT(3,4,N) = 0.5 !42 axis
439	IF ( L(2,2).EQ.14 ) RT(3,4,N) = 0.75 !43 axis
440	END IF
441	ELSE IF ( I.EQ.12 ) THEN
442	IF ( MF.NE.2 ) IER=13 !6-axis
443	IF ( IER.GT.0 ) GO TO 500
444	IF ( L(2,MF).EQ.18 ) THEN
445	IOP = 32+16+1
446	CALL SGRMAT(IOP,RT,N,-1.,1.,0.,-1.,0.,0.,0.,0.,-1.) !6-bar operation
447	IF ( L(1,3).EQ.2 .OR. L(1,4).EQ.2 ) RT(3,4,N)=0.5
448	IFLD = IFLD+1
449	ELSE
450	IOP = 32+16
451	CALL SGRMAT(IOP,RT,N,1.,-1.,0.,1.,0.,0.,0.,0.,1.) !6 operation
452	IF ( L(2,2).GT.11 .AND. L(2,2).LT.17 )
453	1 RT(3,4,N)=(L(2,2)-11)/6.0
454	END IF
455	END IF
456	IF ( NDELT.EQ.1 ) THEN
457	RT(1,4,N) = MOD(RT(1,4,N)+7.0,1.0)
458	RT(2,4,N) = MOD(RT(2,4,N)+7.0,1.0)
459	RT(3,4,N) = MOD(RT(3,4,N)+7.0,1.0)
460	RT(5,2,N) = 1728RT(1,4,N)+144RT(2,4,N)+12*RT(3,4,N)
461	RT(5,2,N) = NINT(RT(5,2,N))
462	M2 = 1
463	IERZ = 0
464	DO WHILE ( M2.LT.N .AND. IERZ.EQ.0 )
465	IF ( RT(5,1,M2).EQ.RT(5,1,N) ) THEN
466	IERZ = 1 !Duplicate rotation matrices
467	IF ( RT(5,2,N).NE.RT(5,2,M2) ) THEN
468	CALL SGTRCF(MF,RT,N,M2,LCENT,LAUENO,IER) !Different translations
469	IF ( IER.GT.0 ) IERX = IER
470	IER = 0
471	END IF
472	ELSE IF ( RT(5,1,M2).EQ.-RT(5,1,N) ) THEN !New matrix defines a center of symmetry
473	IF ( RT(5,2,N).NE.RT(5,2,M2) ) THEN
474	CALL SGTRCF(MF,RT,N,M2,LCENT,LAUENO,IER) !Different translations
475	IF ( IER.GT.0 ) IERX = IER
476	IER = 0
477	END IF
478	IERZ = 1
479	NCENT = 1
480	END IF
481	M2 = M2+1
482	END DO
483	IF ( IERZ.EQ.0 ) THEN !Now if no error has been detected
484	N = N+1 !Increment the matrix count
485	IF ( N.GT.25 ) IER=14
486	IF ( IER.GT.0 ) GO TO 500 !Should never be more than 24
487	NXL = N-1 !Set NXL to the last currently defined matrix
488	DO WHILE ( NXI.LE.NXL ) !We will repeat this loop until no new matrices
489	DO NX=NXI,NXL
490	DO M1=2,NX
491	CALL SGMTML(RT,NX,M1,N) !Apply NX to M1 to generate matrix N
492	IERZ = 0
493	M2 = 1
494	DO WHILE ( M2.LT.N .AND. IERZ.EQ.0 ) !Check for duplication of previous matrix
495	IF ( RT(5,1,N).EQ.RT(5,1,M2) ) THEN
496	IERZ = 1 !A duplicate
497	IF ( RT(5,2,N).NE.RT(5,2,M2) ) THEN !Check the translation vectors
498	CALL SGTRCF(MF,RT,N,M2,LCENT,LAUENO,IER) !Different translations
499	IF ( IER.GT.0 ) IERX = IER
500	IER = 0
501	END IF
502	! PRINT '(a,4i3,a,2i3)',' Duplicate matrix.',NX,M1,N,M2,
503	! 1 ' Flags are',nint(RT(5,3,N)),nint(RT(5,3,M2))
504	ELSE IF ( RT(5,1,N).EQ.-RT(5,1,M2) ) THEN !Matrix N is related to M2 by 1bar
505	IERZ = 1
506	NCENT = 1
507	END IF
508	M2 = M2+1
509	END DO
510	IF ( IERZ.EQ.0 ) THEN !A new matrix
511	! PRINT '(3(a,i3))',' Matrix ',N,' is ',NX,' times ',M1
512	N = N+1 !Increment the NEW matrix pinter
513	IF ( N.GT.25 ) IER=14
514	IF ( IER.GT.0 ) GO TO 500 !This pointer should never be larger than 25
515	END IF
516	END DO
517	END DO
518	NXI = NXL+1 !Set first matrix to first new matrix
519	NXL = N-1 !Set last matrix
520	END DO
521	END IF
522	END IF
523	END IF
524	IFLD = IFLD+1
525	END DO
526	END DO !end of the old 3000 loop
527	NSYM = N-1
528	DO K=1,NSYM
529	DO I=1,3
530	DO J=1,3
531	JRT(I,J,K) = RT(I,J,K)
532	END DO
533	JRT(I,4,K) = 12*RT(I,4,K)+144.1
534	JRT(I,4,K) = JRT(I,4,K)-12*(JRT(I,4,K)/12)
535	JRT(I,5,K) = RT(5,I,K)
536	END DO
537	JRT(3,5,K) = SGOPRN(RT(5,1,K))
538	! IF ( JRT(3,5,K).LT.0 ) THEN
539	! PRINT '(A,I3)',' ***** ERROR in defining operation flags'
540	! 1 ,K
541	! END IF
542	END DO
543	NPX = 1 !Assume X is indeterminate
544	NPY = 2 !Assume Y is indeterminate
545	NPZ = 4 !Assume Z is indeterminate
546	NPXYZ = 0 !Assume no 3-axis along [1,1,1]
547	NPYXZ = 1 !Assume origin undefined along [1,1,1]
548	DO I=1,NSYM !Determine presence of indeterminate origin
549	IF ( JRT(1,1,I).LE.0 ) NPX=0 !Origin is defined along X
550	IF ( JRT(2,2,I).LE.0 ) NPY=0 !Origin is defined along Y
551	IF ( JRT(3,3,I).LE.0 ) NPZ=0 !Origin is defined along Z
552	IF ( JRT(1,3,I).GT.0 ) NPXYZ=8 !There is a 3-axis along [1,1,1]
553	IF ( JRT(1,3,I).LT.0 ) NPYXZ=0 !Origin is defined along [1,1,1]
554	END DO
555	NPOL = (NPX+NPY+NPZ+NPXYZNPYXZ)(1-NCENT) !Set the indeterminate origin flag
556	! CALL SGPRNT(SPG,JRT,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,CEN,
557	! 1 NCV,LPT)
558	IF ( LCENT.EQ.7 ) NAXIS = -1
559	IF ( IERX.EQ.0 ) RETURN
560	IER = IERX
561	500 CONTINUE
562	! IF ( LPTX.GT.0 ) CALL SGERRS(SPG,IER,LPTX)
563	NAXIS = 4
564	RETURN
565	END

Note: See TracBrowser for help on using the repository browser.

Download in other formats: