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