562 lines
22 KiB
Fortran
562 lines
22 KiB
Fortran
C-----------------------------------------------------------------------
|
||
C Main Routine for the Space Group Symbol Interpreter
|
||
C
|
||
C Adapted from the LASL routine by Allen C. Larson
|
||
C-----------------------------------------------------------------------
|
||
SUBROUTINE SGROUP (SPG,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,JRT,
|
||
$ CEN,NCV,LPT,LPTX,RT)
|
||
C-----------------------------------------------------------------------
|
||
C This subroutine interprets the Hermann-Mauguin space group symbol.
|
||
C
|
||
C Data in the calling sequence are
|
||
C SGP Input. Ten words containing the space group symbol 10A1
|
||
C **NOTE** Vol. A of Int Tab uses different symbols for cubic
|
||
C 2-July-87 space groups with -3 axes,
|
||
C i.e. P n -3 n instead of P n 3 n.
|
||
C The routine changes the symbol to the old form for
|
||
C interpretation, but prints the new form.
|
||
C LAUENO Output. The Laue group number
|
||
C 1 = 1bar, 2 = 2/m, 3 = mmm, 4 = 4/m, 5 = 4/mm,
|
||
C 6 = R3R, 7 = R3mR, 8 = 3, 9 = 31m, 10 = 3m1,
|
||
C 11 = 6/m, 12 = 6/mmm, 13 = m3, 14 = m3m
|
||
C NAXIS Output. Unique axis in monoclinic space groups.
|
||
C Set to 4 on error exits
|
||
C NCENT Output. 1bar flag (0/1) for (acentric/centric)
|
||
C LCENT Output. Lattice centering number
|
||
C 1=P, 2=A, 3=B, 4=C, 5=I, 6=F and 7=R
|
||
C NSYM Output. The number of matrices generated (24 max),
|
||
C NCV*(NCENT+1)*NSYM = 192 (max)
|
||
C JRT Output. The NSYM (3,4,NSYM) matrices
|
||
C CEN Output. The lattice centering vectors
|
||
C NCV Output. The number of lattice centering vectors
|
||
C LPT Output listing device for normal output.
|
||
C If .lt. 0 no listing will be produced
|
||
C LPTX Output listing device for error listings
|
||
C If .lt. 0 no listing will be produced
|
||
C RT scratch array of 500 words needed by SGROUP
|
||
C-----------------------------------------------------------------------
|
||
DIMENSION SPG(10),JRT(3,4,24),CEN(3,4)
|
||
DIMENSION RT(5,4,25),D(3,3),L(4,4),LCEN(7)
|
||
CHARACTER*1 CHR(25),CHAR
|
||
CHARACTER*10 CSPG
|
||
C-----------------------------------------------------------------------
|
||
C C B A P F I R
|
||
C-----------------------------------------------------------------------
|
||
DATA LCEN/4,3,2,1,6,5,7/
|
||
C-----------------------------------------------------------------------
|
||
C 1 2 3 4 5 6 7 8 9 10 11 12 13 14
|
||
C 15 16 17 18 19 20 21
|
||
C-----------------------------------------------------------------------
|
||
DATA CHR/' ','C','B','A','P','F','I','R','M','N','D','1','2','3',
|
||
$ '4','5','6','-','/','H','.','0','0','0','0'/
|
||
DO 100 I = 1,4
|
||
DO 100 J = 1,4
|
||
L(J,I) = 0
|
||
100 CONTINUE
|
||
WRITE (CSPG,10000) SPG
|
||
C-----------------------------------------------------------------------
|
||
C Check that there are blanks in the symbol, so that it has at least a
|
||
C sporting chance of being interpreted correctly
|
||
C-----------------------------------------------------------------------
|
||
DO 1012 I = 1,10
|
||
J = 11 - I
|
||
IF (CSPG(J:J) .NE. ' ') THEN
|
||
DO 1010 K = 2,J
|
||
IF (CSPG(K:K) .EQ. ' ') GO TO 1014
|
||
1010 CONTINUE
|
||
ENDIF
|
||
1012 CONTINUE
|
||
IER = 24
|
||
GO TO 710
|
||
C-----------------------------------------------------------------------
|
||
C Change the symbol for the cubic cases. EJG 2-July-87
|
||
C If the -3 symbol is preceded by a second kind symmetry element,
|
||
C m, n, a, b, c or d then change -3 to 3
|
||
C-----------------------------------------------------------------------
|
||
1014 DO 104 J = 1,9
|
||
IF (CSPG(J:J + 1) .EQ. '-3') THEN
|
||
DO 102 JJ = 1,J - 1
|
||
K = J - JJ
|
||
CHAR = CSPG(K:K)
|
||
IF (CHAR .EQ. ' ') GO TO 102
|
||
IF (CHAR .EQ. 'M' .OR. CHAR .EQ. 'N' .OR.
|
||
$ CHAR .EQ. 'D' .OR. CHAR .EQ. 'A' .OR.
|
||
$ CHAR .EQ. 'B' .OR. CHAR .EQ. 'C') THEN
|
||
CSPG(J:9) = CSPG(J + 1:10)
|
||
CSPG(10:10) = ' '
|
||
GO TO 106
|
||
ENDIF
|
||
102 CONTINUE
|
||
ENDIF
|
||
104 CONTINUE
|
||
106 K = 0
|
||
M = 0
|
||
IER = 0
|
||
NCENT = 0
|
||
LAUENO = 0
|
||
NAXIS = 0
|
||
IERX = 0
|
||
N = 0
|
||
C-----------------------------------------------------------------------
|
||
C Break the space group symbol into the 4 fields as numerical values
|
||
C for manipulation
|
||
C-----------------------------------------------------------------------
|
||
DO 140 J = 1,10
|
||
DO 110 I = 1,21
|
||
IF (CSPG(J:J) .EQ. CHR(I)) GO TO 120
|
||
110 CONTINUE
|
||
GO TO 140
|
||
120 IF (K + M + I .EQ. 1) GO TO 140
|
||
IF (I .EQ. 1) GO TO 130
|
||
IF (M .EQ. 0) K = K + 1
|
||
M = M + 1
|
||
L(M,K) = I
|
||
IF (I .LT. 12) GO TO 130
|
||
IF (M - 4) 140,130,130
|
||
130 CONTINUE
|
||
M = 0
|
||
IF (K .GT. 3) GO TO 150
|
||
140 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C If only 1 field was found, there is an error. Go to 710
|
||
C-----------------------------------------------------------------------
|
||
150 IF (K .LE. 1) IER = 1
|
||
IF (IER .GT. 0) GO TO 710
|
||
C-----------------------------------------------------------------------
|
||
C If the first character was not P, A, B, C, F, I or R Error.
|
||
C-----------------------------------------------------------------------
|
||
IF (L(1,1) .GT. 8) IER = 2
|
||
IF (IER .GT. 0) GO TO 710
|
||
C-----------------------------------------------------------------------
|
||
C Convert the -n notation to the nb(ar) notation
|
||
C-----------------------------------------------------------------------
|
||
IF (L(1,2) .EQ. 18) CALL SGLPAK (L(1,2),IER)
|
||
IF (IER .GT. 0) GO TO 710
|
||
IF (L(1,3) .EQ. 18) CALL SGLPAK (L(1,3),IER)
|
||
IF (IER .GT. 0) GO TO 710
|
||
IF (L(1,4) .EQ. 18) CALL SGLPAK (L(1,4),IER)
|
||
IF (IER .GT. 0) GO TO 710
|
||
C-----------------------------------------------------------------------
|
||
C Set the matrix count N to 2
|
||
C-----------------------------------------------------------------------
|
||
N = 2
|
||
C-----------------------------------------------------------------------
|
||
C Set the translation flags
|
||
C-----------------------------------------------------------------------
|
||
D(1,1) = 0.0
|
||
D(1,2) = 0.0
|
||
D(1,3) = 0.0
|
||
D(2,1) = 0.0
|
||
D(2,2) = 0.0
|
||
D(2,3) = 0.0
|
||
D(3,1) = 0.0
|
||
D(3,2) = 0.0
|
||
D(3,3) = 0.0
|
||
C-----------------------------------------------------------------------
|
||
C Set the lattice centering flag. 1=P, 2=A, 3=B, 4=C, 5=I, 6=F, 7=R
|
||
C-----------------------------------------------------------------------
|
||
LCENT = L(1,1) - 1
|
||
LCENT = LCEN(LCENT)
|
||
IF (LCENT .NE. 7) GO TO 170
|
||
C-----------------------------------------------------------------------
|
||
C Rhombohedral lattice. Make sure that there is a 3-axis.
|
||
C-----------------------------------------------------------------------
|
||
IF (L(1,2) .NE. 14) IER = 3
|
||
IF (IER .GT. 0) GO TO 710
|
||
IF (L(1,K) .EQ. 8) GO TO 160
|
||
C-----------------------------------------------------------------------
|
||
C Hexagonal axes. Retain R centering and set LAUENO to 8 or 9
|
||
C-----------------------------------------------------------------------
|
||
IF (L(1,K) .EQ. 20) K = K - 1
|
||
LAUENO = K + 6
|
||
GO TO 190
|
||
160 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Rhombohedral axes. Delete R centering and set LAUENO to 6 or 7
|
||
C-----------------------------------------------------------------------
|
||
LCENT = 1
|
||
K = K - 1
|
||
LAUENO = K + 4
|
||
GO TO 180
|
||
170 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Call SGLATC to determine LAUENO and some preliminary data
|
||
C-----------------------------------------------------------------------
|
||
IER = 0
|
||
I209 = 0
|
||
CALL SGLATC (K,L,D,LCENT,NCENT,LAUENO,NAXIS,LPT,IER,I209,ID)
|
||
IF (IER .GT. 0) GO TO 710
|
||
IF (I209 .EQ. 0) GO TO 190
|
||
180 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Cubic or rhombohedral cell. Insert the 3-fold axis
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,2),0,1,0,0,0,1,1,0,0)
|
||
CALL SGRMAT (RT(1,1,3),0,0,1,1,0,0,0,1,0)
|
||
N = 4
|
||
190 CONTINUE
|
||
CALL SGRMAT (RT,1,0,0,0,1,0,0,0,1)
|
||
C-----------------------------------------------------------------------
|
||
C Decode the last 3 fields of the symbol
|
||
C-----------------------------------------------------------------------
|
||
DO 680 M = 2,K
|
||
IF (L(1,M) .EQ. 0) IER = 6
|
||
IF (IER .GT. 0) GO TO 710
|
||
I = IABS(L(1,M) - 5)
|
||
200 IF (I .LE. 0 .OR. I .GT. 15) IER = 7
|
||
IF (IER .GT. 0) GO TO 710
|
||
NXI = N
|
||
C-----------------------------------------------------------------------
|
||
C A B C M N D 1 2 3 4 5 6 - /
|
||
C H
|
||
C-----------------------------------------------------------------------
|
||
GO TO (210,210,210,210,210,330,390,400,500,520,710,540,560,560,
|
||
$ 560),I
|
||
210 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C A mirror is needed
|
||
C A B C axis
|
||
C-----------------------------------------------------------------------
|
||
GO TO (710,220,240,260),M
|
||
220 CONTINUE
|
||
IF (LAUENO .GT. 3) GO TO 270
|
||
IF (K .EQ. 2) GO TO 250
|
||
230 CONTINUE
|
||
IF (I .EQ. 1) IER = 8
|
||
IF (IER .GT. 0) GO TO 710
|
||
C-----------------------------------------------------------------------
|
||
C An A-axis mirror
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),-1,0,0,0,1,0,0,0,1)
|
||
RT(1,4,N) = D(1,1)
|
||
IF (I .EQ. 2 .OR. I .EQ. 5) RT(2,4,N) = 0.5
|
||
IF (I .EQ. 3 .OR. I .EQ. 5) RT(3,4,N) = 0.5
|
||
GO TO 560
|
||
240 IF (L(1,2) .EQ. 14 .OR. L(1,2) .EQ. 17) GO TO 310
|
||
C-----------------------------------------------------------------------
|
||
C It is not trigonal or hexagonal
|
||
C-----------------------------------------------------------------------
|
||
IF (L(1,2) .EQ. 15) GO TO 230
|
||
C-----------------------------------------------------------------------
|
||
C It is not tetragonal
|
||
C-----------------------------------------------------------------------
|
||
250 CONTINUE
|
||
IF (I .EQ. 2) IER = 9
|
||
IF (IER .GT. 0) GO TO 710
|
||
C-----------------------------------------------------------------------
|
||
C A B-axis mirror
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),1,0,0,0,-1,0,0,0,1)
|
||
RT(2,4,N) = D(2,2)
|
||
IF (I .EQ. 1 .OR. I .EQ. 5) RT(1,4,N) = 0.5
|
||
IF (I .EQ. 3 .OR. I .EQ. 5) RT(3,4,N) = 0.5
|
||
GO TO 560
|
||
260 IF (L(1,3) .EQ. 14 .OR. L(1,2) .EQ. 15) GO TO 280
|
||
C-----------------------------------------------------------------------
|
||
C It is not cubic or tetragonal
|
||
C-----------------------------------------------------------------------
|
||
IF (L(1,2) .EQ. 14 .OR. L(1,2) .EQ. 17) GO TO 280
|
||
C-----------------------------------------------------------------------
|
||
C It is not trigonal or hexagonal
|
||
C-----------------------------------------------------------------------
|
||
270 CONTINUE
|
||
IF (I .EQ. 3) IER = 10
|
||
IF (IER .GT. 0) GO TO 710
|
||
C-----------------------------------------------------------------------
|
||
C A C-axis mirror
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),1,0,0,0,1,0,0,0,-1)
|
||
RT(3,4,N) = D(3,3)
|
||
IF (I .EQ. 1 .OR. I .EQ. 5) RT(1,4,N) = 0.5
|
||
IF (I .EQ. 2 .OR. I .EQ. 5) RT(2,4,N) = 0.5
|
||
IF (M .NE. 2 .OR. L(1,2) .NE. 17) GO TO 560
|
||
C-----------------------------------------------------------------------
|
||
C If this is a 63-axis, the mirror is at 1/4
|
||
C-----------------------------------------------------------------------
|
||
IF (L(2,2) .EQ. 14) RT(3,4,N) = 0.5
|
||
GO TO 560
|
||
280 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C A diagonal mirrror perpendicular to -110
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),0,1,0,1,0,0,0,0,1)
|
||
RT(1,4,N) = D(2,2)
|
||
RT(2,4,N) = -D(2,2)
|
||
IF (I .EQ. 3 .OR. I .EQ. 5) RT(3,4,N) = 0.5
|
||
IF (LAUENO .EQ. 7 .AND. I .EQ. 3) GO TO 290
|
||
IF (I .EQ. 3 .OR. I .EQ. 4) GO TO 560
|
||
290 CONTINUE
|
||
IF (LCENT .EQ. 6 .OR. LCENT .EQ. 4) GO TO 300
|
||
RT(1,4,N) = 0.5 + RT(1,4,N)
|
||
RT(2,4,N) = 0.5 + RT(2,4,N)
|
||
GO TO 560
|
||
300 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Either F- or C-centered tetragonal. Glides are 1/4,1/4
|
||
C-----------------------------------------------------------------------
|
||
RT(1,4,N) = 0.25 + RT(1,4,N)
|
||
RT(2,4,N) = 0.25 + RT(2,4,N)
|
||
GO TO 560
|
||
310 CONTINUE
|
||
IF (LAUENO .EQ. 7) GO TO 280
|
||
C-----------------------------------------------------------------------
|
||
C Mirror normal to (1000) in hex cell
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),-1,1,0,0,1,0,0,0,1)
|
||
IF (I .EQ. 3) RT(3,4,N) = 0.5
|
||
320 CONTINUE
|
||
GO TO 560
|
||
C-----------------------------------------------------------------------
|
||
C D type mirror
|
||
C-----------------------------------------------------------------------
|
||
330 CONTINUE
|
||
IF (LCENT .LE. 1) IER = 11
|
||
IF (IER .GT. 0) GO TO 710
|
||
GO TO (710,340,350,360),M
|
||
340 IF (LAUENO .GT. 3) GO TO 370
|
||
IF (K .EQ. 2) GO TO 350
|
||
CALL SGRMAT (RT(1,1,N),-1,0,0,0,1,0,0,0,1)
|
||
IF (ID .EQ. 2) RT(1,4,N) = 0.25
|
||
RT(2,4,N) = 0.25
|
||
RT(3,4,N) = 0.25
|
||
GO TO 560
|
||
350 CONTINUE
|
||
CALL SGRMAT (RT(1,1,N),1,0,0,0,-1,0,0,0,1)
|
||
RT(1,4,N) = 0.25
|
||
IF (ID .EQ. 2) RT(2,4,N) = 0.25
|
||
IF (LAUENO .EQ. 5) RT(2,4,N) = D(2,1)
|
||
RT(3,4,N) = 0.25
|
||
GO TO 560
|
||
360 IF (L(1,2) .EQ. 15 .OR. L(1,3) .EQ. 14) GO TO 380
|
||
C-----------------------------------------------------------------------
|
||
C It is not tetragonal or cubic
|
||
C-----------------------------------------------------------------------
|
||
370 CONTINUE
|
||
CALL SGRMAT (RT(1,1,N),1,0,0,0,1,0,0,0,-1)
|
||
RT(1,4,N) = 0.25
|
||
RT(2,4,N) = 0.25
|
||
IF (ID .EQ. 2) RT(3,4,N) = 0.25
|
||
GO TO 560
|
||
380 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Cubic or tetragonal. D-glide along diagonal
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),0,1,0,1,0,0,0,0,1)
|
||
RT(1,4,N) = 0.25
|
||
RT(2,4,N) = 0.25
|
||
RT(3,4,N) = 0.25
|
||
IF (L(1,3) .NE. 13) GO TO 320
|
||
RT(1,4,N) = 0.0
|
||
RT(2,4,N) = 0.5
|
||
GO TO 560
|
||
C-----------------------------------------------------------------------
|
||
C 1 fold rotation
|
||
C-----------------------------------------------------------------------
|
||
390 IF (L(2,M) .NE. 3) GO TO 680
|
||
C-----------------------------------------------------------------------
|
||
C A center of symmetry
|
||
C-----------------------------------------------------------------------
|
||
NCENT = 1
|
||
GO TO 680
|
||
C-----------------------------------------------------------------------
|
||
C 2 fold rotation axis
|
||
C-----------------------------------------------------------------------
|
||
400 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Do not allow a -2 axis.
|
||
C-----------------------------------------------------------------------
|
||
IF (L(2,M) .EQ. 3) IER = 19
|
||
IF (IER .GT. 0) GO TO 710
|
||
GO TO (710,410,420,440),M
|
||
410 IF (K .EQ. 2) GO TO 430
|
||
CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Rotation about the a-axis. (orthogonal cell)
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),1,0,0,0,-1,0,0,0,-1)
|
||
RT(2,4,N) = D(2,1)
|
||
RT(3,4,N) = D(3,1)
|
||
IF (IABS(L(2,M) - 13) .EQ. 1) RT(1,4,N) = 0.5
|
||
GO TO 560
|
||
420 CONTINUE
|
||
IF (L(1,2) .EQ. 14) GO TO 460
|
||
IF (L(1,2) .EQ. 17) GO TO 450
|
||
C-----------------------------------------------------------------------
|
||
C It is not a hexagonal or trigonal space group
|
||
C-----------------------------------------------------------------------
|
||
430 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C Rotation about the b-axis
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),-1,0,0,0,1,0,0,0,-1)
|
||
RT(1,4,N) = D(1,2)
|
||
RT(3,4,N) = D(3,2)
|
||
IF (L(2,M) .EQ. 12) RT(2,4,N) = 0.5
|
||
GO TO 560
|
||
440 IF (L(1,2) .GE. 14) GO TO 490
|
||
IF (L(1,3) .EQ. 14) GO TO 490
|
||
CONTINUE
|
||
CALL SGRMAT (RT(1,1,N),-1,0,0,0,-1,0,0,0,1)
|
||
RT(1,4,N) = D(1,3)
|
||
RT(2,4,N) = D(2,3)
|
||
IF (IABS(L(2,M) - 13) .EQ. 1) RT(3,4,N) = 0.5
|
||
IF (L(2,M) .EQ. 16) RT(3,4,N) = 0.5
|
||
GO TO 560
|
||
450 CONTINUE
|
||
IF (L(1,4) .EQ. 12) GO TO 460
|
||
C-----------------------------------------------------------------------
|
||
C 2-axis normal to (-2110). Used for the P 6n22 groups
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),1,-1,0,0,-1,0,0,0,-1)
|
||
GO TO 560
|
||
460 CONTINUE
|
||
IF (LAUENO .EQ. 7) GO TO 480
|
||
470 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C 2-axis along to (11-20) trigonal and (110) tetragonal
|
||
C Used for the P 3n21 groups
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),0,1,0,1,0,0,0,0,-1)
|
||
RT(1,4,N) = D(2,1)
|
||
IF (L(2,M) .EQ. 12) RT(1,4,N) = RT(1,4,N) + 0.5
|
||
RT(2,4,N) = -D(2,1)
|
||
RT(3,4,N) = D(3,1)
|
||
GO TO 560
|
||
480 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C 2-axis normal to (110)
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),0,-1,0,-1,0,0,0,0,-1)
|
||
GO TO 560
|
||
490 CONTINUE
|
||
IF (L(1,2) .EQ. 15) GO TO 470
|
||
C-----------------------------------------------------------------------
|
||
C 2-axis normal to (10-10)
|
||
C-----------------------------------------------------------------------
|
||
CALL SGRMAT (RT(1,1,N),1,0,0,1,-1,0,0,0,-1)
|
||
GO TO 560
|
||
C-----------------------------------------------------------------------
|
||
C 3 fold rotation
|
||
C-----------------------------------------------------------------------
|
||
500 GO TO (710,510,390,710),M
|
||
510 CONTINUE
|
||
IF (LAUENO .LE. 7) GO TO 390
|
||
CALL SGRMAT (RT(1,1,N),0,-1,0,1,-1,0,0,0,1)
|
||
IF (L(2,M) .EQ. 12) RT(3,4,N) = 0.33333333
|
||
IF (L(2,M) .EQ. 13) RT(3,4,N) = 0.66666667
|
||
IF (L(2,2) .EQ. 3) NCENT = 1
|
||
GO TO 560
|
||
520 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C 4 fold axis
|
||
C-----------------------------------------------------------------------
|
||
IF (M .NE. 2) IER = 12
|
||
IF (IER .GT. 0) GO TO 710
|
||
IF (L(2,2) .EQ. 3) GO TO 530
|
||
CALL SGRMAT (RT(1,1,N),0,-1,0,1,0,0,0,0,1)
|
||
RT(1,4,N) = D(1,3)
|
||
RT(2,4,N) = D(2,3)
|
||
IF (L(2,2) .EQ. 12) RT(3,4,N) = 0.25
|
||
IF (L(2,2) .EQ. 13) RT(3,4,N) = 0.5
|
||
IF (L(2,2) .EQ. 14) RT(3,4,N) = 0.75
|
||
GO TO 560
|
||
530 CONTINUE
|
||
CALL SGRMAT (RT(1,1,N),0,1,0,-1,0,0,0,0,-1)
|
||
RT(1,4,N) = D(1,3)
|
||
RT(2,4,N) = D(2,3)
|
||
RT(3,4,N) = D(3,3)
|
||
GO TO 560
|
||
540 CONTINUE
|
||
C-----------------------------------------------------------------------
|
||
C 6-axis
|
||
C-----------------------------------------------------------------------
|
||
IF (M .NE. 2) IER = 13
|
||
IF (IER .GT. 0) GO TO 710
|
||
IF (L(2,2) .EQ. 3) GO TO 550
|
||
CALL SGRMAT (RT(1,1,N),1,-1,0,1,0,0,0,0,1)
|
||
IF (L(2,2) .GT. 11 .AND. L(2,2) .LT. 18)
|
||
$ RT(3,4,N) = (L(2,2) - 11)/6.0
|
||
GO TO 560
|
||
550 CONTINUE
|
||
CALL SGRMAT (RT(1,1,N),-1,1,0,-1,0,0,0,0,-1)
|
||
IF (L(1,3) .EQ. 2 .OR. L(1,4) .EQ. 2) RT(3,4,N) = 0.5
|
||
560 CONTINUE
|
||
RT(1,4,N) = AMOD(RT(1,4,N) + 5.0,1.0)
|
||
RT(2,4,N) = AMOD(RT(2,4,N) + 5.0,1.0)
|
||
RT(3,4,N) = AMOD(RT(3,4,N) + 5.0,1.0)
|
||
RT(5,2,N) = 1728*RT(1,4,N) + 144*RT(2,4,N) + 12*RT(3,4,N)
|
||
DO 580 M2 = 1,N - 1
|
||
IF (RT(5,1,M2) .EQ. RT(5,1,N)) GO TO 570
|
||
IF (RT(5,1,M2) .NE. -RT(5,1,N)) GO TO 580
|
||
NCENT = 1
|
||
570 CONTINUE
|
||
IF (RT(5,2,N) .NE. RT(5,2,M2)) GO TO 670
|
||
GO TO 680
|
||
580 CONTINUE
|
||
N = N + 1
|
||
IF (N .GT. 25) IER = 14
|
||
IF (IER .GT. 0) GO TO 710
|
||
590 CONTINUE
|
||
IDENT = 0
|
||
NXL = N - 1
|
||
IF (NXL .LT. NXI) GO TO 640
|
||
DO 630 NX = NXI,NXL
|
||
DO 620 M1 = 2,NX
|
||
CALL SGMTML (RT,M1,RT,NX,RT,N)
|
||
DO 610 M2 = 1,N - 1
|
||
IF ( RT(5,1,N) .EQ. RT(5,1,M2)) GO TO 600
|
||
IF (-RT(5,1,N) .NE. RT(5,1,M2)) GO TO 610
|
||
NCENT = 1
|
||
600 CONTINUE
|
||
GO TO 620
|
||
610 CONTINUE
|
||
N = N + 1
|
||
IF (N .GT. 25) IER = 15
|
||
IF (IER .GT. 0) GO TO 710
|
||
620 CONTINUE
|
||
IF (N - 1 .EQ. NXL) GO TO 640
|
||
630 CONTINUE
|
||
NXI = NXL + 1
|
||
GO TO 590
|
||
640 CONTINUE
|
||
IF (L(1,M) .LT. 12) GO TO 680
|
||
C-----------------------------------------------------------------------
|
||
C Search for a / to indicate a mirror perpendicular to this axis
|
||
C-----------------------------------------------------------------------
|
||
IF (L(2,M) .EQ. 3) GO TO 680
|
||
DO 650 I = 2,3
|
||
IF (L(I,M) .EQ. 0) GO TO 680
|
||
IF (L(I,M) .EQ. 19) GO TO 660
|
||
IF (L(I,M) .LT. 12) IER = 16
|
||
IF (IER .GT. 0) GO TO 710
|
||
650 CONTINUE
|
||
GO TO 680
|
||
660 IF (L(I + 1,M) .LE. 1) IER = 17
|
||
IF (IER .GT. 0) GO TO 710
|
||
I = IABS(L(I + 1,M) - 5)
|
||
GO TO 200
|
||
670 CONTINUE
|
||
CALL SGTRCF (M,RT,N,M2,LCENT,LAUENO,IER,LPTX)
|
||
IF (IER .GT. 0) IERX = IER
|
||
IER = 0
|
||
680 CONTINUE
|
||
NSYM = N - 1
|
||
DO 700 I = 1,3
|
||
DO 700 K = 1,NSYM
|
||
DO 690 J = 1,3
|
||
JRT(I,J,K) = RT(I,J,K)
|
||
690 CONTINUE
|
||
JRT(I,4,K) = 12*RT(I,4,K) + 144.1
|
||
JRT(I,4,K) = JRT(I,4,K) - 12*(JRT(I,4,K)/12)
|
||
700 CONTINUE
|
||
CALL SGPRNT (SPG,JRT,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,CEN,
|
||
$ NCV,LPT)
|
||
IF (IERX .EQ. 0) RETURN
|
||
IER = IERX
|
||
710 CONTINUE
|
||
IF (LPTX .GE. 0) CALL SGERRS (SPG,IER,LPTX)
|
||
NAXIS = 4
|
||
RETURN
|
||
10000 FORMAT (10A1)
|
||
END
|
||
|