source: trunk/spsubs/sgroupnp.for @ 57

Last change on this file since 57 was 57, checked in by toby, 12 years ago

fixup unit test for GSASIIspg.py; provide files & Makefile for pyspg.for

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) = 1728*RT(1,4,N)+144*RT(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+NPXYZ*NPYXZ)*(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
561500   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.