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
|