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

Last change on this file since 209 was 209, checked in by vondreele, 12 years ago

fortran fixes - new self contained libraries
had to change all INCLUDE copyright lines.

File size: 17.9 KB
Line 
1      SUBROUTINE SGLATC(K,L,D,LCENT,LAUENO,NAXIS,IER,I209,ID)
2
3!Purpose:      Determine Laue group and some other preliminary data
4
5      INCLUDE       'INCLDS/COPYRIGT.FOR' 
6
7!       This program was developed for
8!                    the Division of Chemistry
9!                               of
10!               The National Research Council of Canada
11!                               by
12!       Allen C. Larson, 14 Cerrado Loop, SANTA FE, NM 87505, USA
13
14!Calling sequence variables
15
16      INTEGER*4     K                   !Number of fields found in the space group symbol
17      INTEGER*4     L(4,4)              !Integer values for the characters in the symbol
18      REAL*4        D(3,3)              !Location of some key elements
19      INTEGER*4     LCENT               !Lattice centering flag
20      INTEGER*4     LAUENO              !Laue Group number
21      INTEGER*4     NAXIS               !Unique axis flag for monoclinic cells
22      INTEGER*4     IER                 !Error flag
23      INTEGER*4     I209                !Diagonal 3-axis flag
24      INTEGER*4     ID                  !Number of D-glides
25
26!Local variables:
27
28!Code:
29
30      ID = 0                                !Set no. of d-glides to zero
31                                          !Now let us determine the Laue group and unique axis if monoclinic
32      IF ( K.EQ.2 ) THEN                                    ! Only 2 fields were read
33        IF ( L(1,2).EQ.17 ) THEN
34          LAUENO = 11                                        !  6/M
35        ELSE IF ( L(1,2).EQ.14 ) THEN
36          LAUENO = 8                                          !  3Bar
37        ELSE IF ( L(1,2).EQ.15 ) THEN
38          LAUENO = 4                                          !  4/M
39          IF ( LCENT.GE.5 ) THEN                              !Is it I-centered or F-centered?
40            IF ( L(4,2).NE.4 .AND. L(4,2).NE.11 ) GO TO 1553      !Is there either an A-glide or a D-glide normal to C?
41            D(1,3) = 0.75                                    !Yes.
42            IF ( LCENT.EQ.5 ) D(2,3) = 0.25
43          ELSE IF ( LCENT.EQ.4 ) THEN                              !Is it C-centered?   C-centered 4/m tetragonal
44            IF ( L(3,2).NE.4 .AND. L(4,2).NE.4 ) GO TO 210            !If there is no A-glide normal to C we are through
45            D(1,3) = 0.25
46            D(2,3) = 0.25
47            IF ( L(4,2).EQ.4 ) D(2,3)=0.75
48          ELSE
49            IF ( L(3,2).EQ.10 ) THEN                        !No.  Is there a N-glide normal to C?
50              D(1,3) = 0.5                                    !  P 4n/n * *
51              GO TO 210
52            END IF
53            IF ( L(4,2).EQ.10 ) D(2,3)=0.5
54          END IF
55        ELSE IF ( L(1,2).EQ.12 ) THEN
56          LAUENO = 1                                        !1Bar
57        ELSE IF ( L(1,2).EQ.16 ) THEN
58          IER = 5                                            !bad 5-fold
59          GO TO 500
60        ELSE
61          IM = 2                                          !2/M, B-axis unique
62          GO TO 1419
63        END IF
64        GO TO 210
65      ELSE IF ( K.EQ.3 ) THEN                  !Only 3 Fields were read.  Must be M3 cubic. (R3r has been taken care of)
66        IF ( L(1,3).NE.14 ) THEN
67          IER = 20
68          GO TO 500
69        END IF
70        LAUENO = 13
71        IF ( L(2,2).EQ.12 ) D(2,1)=0.5                        !Set the B-axis flag if a 21 along A
72        IF ( L(1,2).EQ.3 .OR. L(1,2).EQ.4 ) D(3,3)=0.5            !Set the C-axis flag if an A-glide normal to C
73        GO TO 209
74      ELSE                                                !Four fields were read
75        IF ( L(1,3).EQ.14 ) THEN                              !It is m3m cubic
76          LAUENO = 14
77          IF ( L(1,2).EQ.3 .OR. L(1,2).EQ.4 ) D(3,3)=0.5            !Set the C-axis translation if an A or B normal to C
78          IF ( L(1,2).EQ.15 ) THEN                              !a 4n-axis specified
79            IF ( L(2,2).EQ.18 ) THEN                              !It is 4bar 3 *
80              IF ( L(1,4).NE.9 ) THEN                              !It is not 4bar 3 m
81                IF ( L(1,4).EQ.11 ) THEN                        !It is 4bar 3 d
82                  IF ( LCENT.NE.5 ) THEN                        ! I 4bar 3 d, we hope
83                    IER = 21
84                    GO TO 500
85                  END IF
86                  D(1,3) = 0.75
87                  D(2,3) = 0.25
88                  D(3,3) = 0.75
89                ELSE
90                  D(1,3) = 0.5
91                  D(2,3) = 0.5
92                  D(3,3) = 0.5
93                END IF
94              END IF
95            ELSE IF ( L(2,2).EQ.12 ) THEN                        !41-axis.
96              IF ( LCENT.EQ.6 ) THEN                              !  F 41 3 2
97                D(1,3) = 0.75
98                D(2,3) = 0.75
99                D(3,3) = 0.25
100              ELSE                                          !IT IS EITHER P 41 3 2 OR I 41 3 2
101                D(1,3) = 0.25
102                D(2,3) = 0.75
103                D(3,3) = 0.25
104              END IF
105            ELSE IF ( L(2,2).EQ.13 ) THEN                        !  P 42 3 2
106              D(1,3) = 0.5
107              D(2,3) = 0.5
108              D(3,3) = 0.5
109            ELSE IF ( L(2,2).EQ.14 ) THEN                        !It is 43 3 2
110              D(1,3) = 0.75
111              D(2,3) = 0.25
112              D(3,3) = 0.75
113            END IF
114            GO TO 209
115          END IF
116          GO TO 209
117        ELSE IF ( L(1,2).EQ.17 ) THEN                              !It is hexagonal
118          IF ( L(1,3).EQ.12 .AND. L(1,4).EQ.12 ) THEN                  !We have something like P 6n 1 *
119            LAUENO = 11                                  ! 6/M
120          ELSE
121            LAUENO = 12                                    ! 6/MMM
122          END IF
123          GO TO 210
124        ELSE IF ( L(1,2).EQ.14 ) THEN                              !It is trigonal
125          IF ( L(1,3).EQ.12 ) THEN                              ! P3**
126            IF ( L(1,4).EQ.12 ) THEN                              ! 31*
127              LAUENO = 8                                    ! 3BAR
128            ELSE
129              LAUENO = 10                                    ! 31m
130            END IF
131          ELSE IF ( L(1,4).NE.12 ) THEN
132            LAUENO = 12                                    ! 6/MMM
133          ELSE
134            LAUENO = 9                                    ! 3M1
135          END IF
136          GO TO 210
137        ELSE IF ( L(1,2).EQ.15 ) THEN                              !It is tetragonal 4/MMM
138          LAUENO = 5
139                                                      !If there is an N-glide normal to C place any
140          IF ( L(3,2).EQ.10 .OR. L(4,2).EQ.10 ) D(1,1)=0.5            ! mirror normal to A at 1/4
141                                                      !If there is an A-glide normal to C place any
142          IF ( L(3,2).EQ.4 .OR. L(4,2).EQ.4 ) D(2,2)=0.25            ! mirror normal to (110) at 1/4
143          IF ( L(1,3).EQ.13 .AND. L(2,3).EQ.12 ) D(1,2)=0.5            !If there is a 21 along B move place it at x=1/4
144                                                      !If there is a B- or N-glide normal to the A-axis
145          IF ( L(1,3).EQ.3 .OR. L(1,3).EQ.10 ) D(1,1)=D(1,1)+0.5      ! shift the mirror by 1/4 along the A-axis
146                                                      !If there is either a B- or N-glide normal to (110)
147          IF ( L(1,4).EQ.3 .OR. L(1,4).EQ.10 ) D(2,2)=D(2,2)+0.25      ! shift the mirror by 1/4 along the A-axis
148          IF ( LCENT.EQ.1 .AND.                              !If Primative
149     1      L(2,2).GT.11 .AND. L(2,2).LT.15 .AND.                  ! and this is a 41, 42 or 43
150     1      L(2,3).NE.12 )                                    ! and not 4n 21 2
151     1      D(3,1)=-(L(2,2)-11)/4.0                              ! Set the Z-location for 2-axes along (110)
152          IF ( L(1,4).EQ.13 .AND. L(2,4).EQ.12 .AND.                  !If fourth field is 21
153     1      L(2,2).GT.11 .AND. L(2,2).LT.15 )                  ! and this is a 41, 42 or 43
154     1      D(3,1)=(L(2,2)-11)/4.0
155          IF ( L(1,3).EQ.13 .AND. L(2,3).EQ.12 .AND.                  !Set the Z-translation for 21-axes along B
156     1      L(2,2).GT.11 .AND. L(2,2).LT.15 )
157     1      D(3,2)=(L(2,2)-11)/4.0
158          IF ( L(1,3)+L(3,2).EQ.11 .AND. LCENT.EQ.6 ) D(2,1)=0.75      !Place the D in F 4* D * at Y=7/8
159          IF ( L(1,4).EQ.2 .AND. LCENT.EQ.6 ) D(1,1)=0.5            !Set M in F 4** * * at X=1/8 If a C along (110)
160          IF ( L(2,2).EQ.18 ) GO TO 1556                        !Is this a 4bar?
161          IF ( LCENT.GT.1 ) GO TO 1553                        !Is the lattice primative?
162          IF ( L(3,2).EQ.10 .OR. L(4,2).EQ.10 ) GO TO 1552            !Yes.  Do we have a N-glide normal to C?
163          IF ( L(1,3).EQ.13 .AND. L(2,3).EQ.12 ) GO TO 1551          !No.  Do we have a 21 along B?
164          IF ( L(1,3).NE.10 ) GO TO 210                        !No. Do we have a N-glide normal to A?
165          IF ( L(2,2).LE.0 ) GO TO 210
166          IF ( L(2,2).GT.15 ) GO TO 210
1671551      CONTINUE
168          D(1,3) = 0.5
169          D(2,3) = 0.5
170          GO TO 210
1711552      CONTINUE
172          D(1,3) = 0.5                                    !  P 4n/n * *
173          GO TO 210
1741553      CONTINUE
175          IF ( LCENT.LT.5 ) GO TO 1555                        !Is the lattice I or F-centered?
176                                                !  YES.
177          IF ( L(1,4).EQ.2 ) D(2,1)=D(2,1)+0.5                  !If there is a C along (110) place the D at Y=1/4
178          IF ( L(4,2).NE.4 .AND. L(4,2).NE.11 ) GO TO 1554            !IS THIS I 41/A * * OR F 41/D * * ?
179                                                !  YES.
180          D(1,3) = 0.25
181          IF ( LCENT.EQ.5 ) D(2,3) = 0.75
182          GO TO 210
1831554      CONTINUE
184          IF ( L(2,2).NE.12 ) GO TO 210                        !Is there a 41 present?
185                                                !  YES.
186          IF ( LCENT.EQ.6 ) GO TO 1558                        !If F-centered go to 1558
187          D(2,3) = 0.5                                        !  SET THE B-AXIS TRANSLATION FLAGS FOR I 41 2 2
188          GO TO 1557
1891555      CONTINUE
190          IF ( LCENT.NE.4 ) IER=23                              !Is the lattice C-centered?
191          IF ( IER.GT.0 ) GO TO 500
192          IF ( L(3,2).EQ.4 .OR. L(4,2).EQ.4 ) GO TO 1559            !C-Centered.  an A normal to C
193!         IF ( L(3,2).EQ.0 ) D(1,1)=2.0*D(2,2)+D(1,1)
194          IF ( D(1,1).EQ.0.0 ) D(1,1)=2.0*D(2,2)
195          IF ( L(1,4).EQ.13 .AND. L(2,4).EQ.12 ) GO TO 1552            !Is there a 21 on the diagonal?
196          IF ( L(2,2).LE.0 ) GO TO 210
197          IF ( L(1,4).NE.10 ) GO TO 210                        !Is there a N-glide normal to (110)?
198          IF ( L(2,2).GT.15 ) GO TO 210
199          D(1,1) = D(1,1)-2.0*D(2,2)
200          GO TO 1552
2011556      CONTINUE
202                                          !  ACCOUNT FOR TRANSLATIONS DUE TO DIAGONAL SYMMETRY OPERATION
203          IF ( L(1,3).EQ.11 .AND. LCENT.EQ.6 ) D(3,1)=0.25            !  IF F 4B D 2 WE WANT THE 2 AT Z=1/8
204          IF ( L(1,4).EQ.13 .AND. L(2,4).EQ.12 ) D(1,1)=0.5            !  IF * 4B * 21 WE WANT THE MIRROR AT X=1/4
205          IF ( L(1,4).EQ.2 .OR. L(1,4).EQ.10 ) D(3,2)=0.5            !If a C- or a N-glide (110) set 2-axis at Z=1/4
206          IF ( L(1,4).EQ.3 .OR. L(1,4).EQ.10 ) D(1,2)=0.5            !If a B- or a N-glide (110) SET 2 AT X=1/4
207          IF ( L(1,4).NE.11 ) GO TO 210
2081557      CONTINUE
209          IF ( LCENT.EQ.5 ) D(1,2) = 0.5
210          D(3,2) = 0.75
211          GO TO 210
2121558      CONTINUE
213          D(1,3) = 0.25                                    !  F 41 * *
214          D(2,3) = 0.75
215          GO TO 210
2161559      CONTINUE
217          D(1,3) = 0.25                                    !  C 4*/A * *
218          D(2,3) = 0.25
219          IF ( L(1,4).EQ.3 .OR. L(1,4).EQ.10 ) D(1,1)=0.5
220          GO TO 210
221        ELSE IF ( L(1,2).EQ.12 ) THEN
222141       IF ( L(1,3).EQ.12 ) GO TO 143                     !  IT IS NOT C-AXIS UNIQUE MONOCLINIC
223          IF ( L(1,4).NE.12 ) GO TO 1399
224          IM = 3
2251419      CONTINUE
226          LAUENO = 2                                          !IT IS B-AXIS UNIQUE MONOCLINIC. (FULL SYMBOL USED)
227          NAXIS = 2
228          IA = 4
229          IC = 2
230          NA = 1
231          NB = 2
232          NC = 3
233          GO TO 1430
234        ELSE IF ( L(1,3).EQ.12 ) THEN
235142       IF ( L(1,4).NE.12 ) GO TO 1399                !  IT IS A-AXIS UNIQUE MONOCLINIC
236          LAUENO = 2
237          NAXIS = 1
238          IA = 3
239          IC = 2
240          NA = 2
241          NB = 1
242          NC = 3
243          IM = 2
244          GO TO 1430
245143       IF ( L(1,4).EQ.12 ) THEN
246            LAUENO = 1                                  !  1BAR
247          ELSE
248            LAUENO = 2                                    !  IT IS C-AXIS UNIQUE MONOCLINIC
249            NAXIS = 3
250            IA = 4
251            IC = 3
252            NA = 1
253            NB = 3
254            NC = 2
255            IM = 4
2561430        CONTINUE
257            IF ( L(2,IM).EQ.12 ) D(NB,NAXIS)=0.5
258            IF ( L(3,IM).EQ.IA .OR. L(3,IM).EQ.10 ) D(NA,NAXIS)=0.5
259            IF ( L(3,IM).EQ.IC .OR. L(3,IM).EQ.10 ) D(NC,NAXIS)=0.5
260            IF ( L(4,IM).EQ.IA .OR. L(4,IM).EQ.10 ) D(NA,NAXIS)=0.5
261            IF ( L(4,IM).EQ.IC .OR. L(4,IM).EQ.10 ) D(NC,NAXIS)=0.5
262          END IF
263          GO TO 210
264        ELSE
265                                                      !It may be orthorhombic
2661399      CONTINUE
267                                                      !It is orthorhombic
268          LAUENO = 3
269                                                      !Set up counts of the various types of mirrors.
270          IM = 0
271          IR = 0
272          IA = 0
273          IB = 0
274          IC = 0
275          ID = 0
276          I21 = 0
277          IF ( L(1,2).NE.13 ) GO TO 1400                        !Do we have a 2-axis along A
278          IF ( L(2,2).NE.12 ) GO TO 1401                      !Yes, is it a 21?
279          D(1,2) = 0.5
280          D(1,3) = 0.5
281          I21 = 4
282          GO TO 1401
2831400      CONTINUE
284          IR = 1
285          IF ( L(1,2).EQ.9 ) IM=4
286          IF ( L(1,2).EQ.3 ) IB=1
287          IF ( L(1,2).EQ.2 ) IC=1
288          IF ( L(1,2).EQ.11 ) ID=1
289          IF ( L(1,3).EQ.4 .OR. L(1,3).EQ.10 ) D(1,1)=0.5
290          IF ( L(1,4).EQ.4 .OR. L(1,4).EQ.10 ) D(1,1)=D(1,1)+0.5
291
2921401      CONTINUE
293          IF ( L(1,3).NE.13 ) GO TO 1402                        !Do we have a 2-axis along B
294          IF ( L(2,3).NE.12 ) GO TO 1403                        !Yes, is it a 21?
295          D(2,1) = 0.5                                    !Yes, it is a 21
296          D(2,3) = 0.5
297          I21 = I21+2
298          GO TO 1403
2991402      CONTINUE
300          IR = IR+1
301          IF ( L(1,3).EQ.9 ) IM=IM+2
302          IF ( L(1,3).EQ.4 ) IA=1
303          IF ( L(1,3).EQ.2 ) IC=IC+1
304          IF ( L(1,3).EQ.11 ) ID=ID+1
305          IF ( L(1,2).EQ.3 .OR. L(1,2).EQ.10 ) D(2,2)=0.5
306          IF ( L(1,4).EQ.3 .OR. L(1,4).EQ.10 ) D(2,2)=D(2,2)+0.5
307
3081403      CONTINUE
309          IF ( L(1,4).NE.13 ) GO TO 1404                        !Do we have a 2-axis along C
310          IF ( L(2,4).NE.12 ) GO TO 1405                        !Yes, is it a 21?
311          D(3,1) = 0.5
312          D(3,2) = 0.5
313          I21 = I21+1
314          GO TO 1405
315
3161404      CONTINUE
317          IR = IR+1
318          IF ( L(1,4).EQ.9 ) IM=IM+1
319          IF ( L(1,4).EQ.4 ) IA=IA+1
320          IF ( L(1,4).EQ.3 ) IB=IB+1
321!         IF ( L(1,4).EQ.2 ) GO TO 500
322          IF ( L(1,4).EQ.11 ) ID=ID+1
323          IF ( L(1,2).EQ.2 .OR. L(1,2).EQ.10 ) D(3,3)=0.5
324          IF ( L(1,3).EQ.2 .OR. L(1,3).EQ.10 ) D(3,3)=D(3,3)+0.5
3251405      CONTINUE
326                                                      !If there are 3 mirrors check for centering
327                                                      !     which may alter the origin location
328          IF ( IR.EQ.3 ) THEN                                    !  3 mirrors present.  Is the lattice centered?
329            IF ( LCENT.EQ.1 ) THEN                              !No
330                                                      !Yes.  Is it A-centered?
331            ELSE IF ( LCENT.EQ.2 ) THEN                        !An A-centered lattice.
332              IF ( IB+IC.EQ.1 .AND. IA.NE.2 ) THEN            !If only one B or C glide present relocate the mirrors by A
333                D(2,2) = D(2,2)+0.5
334                D(3,3) = D(3,3)+0.5
335              END IF
336            ELSE IF ( LCENT.EQ.3 ) THEN                        !A B-centered lattice
337              IF ( IA+IC.EQ.1 .AND. IB.NE.2 ) THEN
338                D(1,1) = D(1,1)+0.5
339                D(3,3) = D(3,3)+0.5
340              END IF
341            ELSE IF ( LCENT.EQ.4 ) THEN                        !A C-centered lattice
342              IF ( IA+IB.EQ.1 .AND. IC.NE.2 ) THEN
343                D(1,1) = D(1,1)+0.5
344                D(2,2) = D(2,2)+0.5
345            END IF
346            ELSE IF ( LCENT.EQ.5 ) THEN                        !It is I-centered
347              IF ( IA+IB+IC.EQ.1 ) THEN                        !Yes.  if only 1 glide plane shift the mirrors by I
348                D(1,1) = D(1,1)+0.5
349                D(2,2) = D(2,2)+0.5
350                D(3,3) = D(3,3)+0.5
351              END IF
352            END IF
353          ELSE                                          !Less than 3 mirrors. set up the 2-axes locations
354            IF ( I21.EQ.4 .OR. I21.EQ.5 .OR. I21.EQ.7 ) D(1,2)=0.0
355            IF ( I21.EQ.6 .OR. I21.EQ.7 ) D(1,3)=0.0
356            IF ( I21.EQ.3 ) D(2,1)=0.0
357            IF ( I21.EQ.2 .OR. I21.EQ.6 .OR. I21.EQ.7 ) D(2,3)=0.0
358            IF ( I21.EQ.1 .OR. I21.EQ.3 .OR. I21.EQ.7 ) D(3,1)=0.0
359            IF ( I21.EQ.5 ) D(3,2)=0.0
360            IF ( IM.LE.0 ) THEN
361            ELSE IF ( IM.EQ.1 .AND. (I21.EQ.4 .OR. I21.EQ.2)
362     1        .AND. D(3,3).NE.0.0 ) THEN
363              D(3,3) = 0.0
364              D(3,2) = D(3,2)+0.5
365            ELSE IF ( IM.EQ.2 .AND. (I21.EQ.4 .OR. I21.EQ.1)
366     1        .AND. D(2,2).NE.0.0 ) THEN
367              D(2,2) = 0.0
368              D(2,1) = D(2,1)+0.5
369            ELSE IF ( IM.EQ.4 .AND. (I21.EQ.2 .OR. I21.EQ.1)
370     1        .AND. D(1,1).NE.0.0 ) THEN
371              D(1,1) = 0.0
372              D(1,3) = D(1,3)+0.5
373            END IF
374          END IF
375          GO TO 210
376        END IF
377      END IF
378209   CONTINUE
379      I209 = 1
380210   CONTINUE
381      RETURN
382500   CONTINUE
383      IF ( IER.EQ.0 ) IER=5
384      RETURN
385      END
Note: See TracBrowser for help on using the repository browser.