C  SAMPLE MAIN PROGRAM FOR CRYSET
      DIMENSION SPGGRP(20), IEXTS(27), XT(2), YT(2), ZT(2)
	I1BAR = 1
	ITRAN = 1
	ITEST = 0
5	WRITE(6,10)
10	FORMAT('$INPUT SPACE GROUP: ')
	READ(5,20) SPGGRP
20	FORMAT(20A1)
	CALL CRYSET(SPGGRP,I1BAR,ITRAN,IEXTS,ITEST,XT,YT,ZT)
	GO TO 5
30	CALL EXIT
	END
C ***  SUBROUTINE CRYSET
C *
C *  CODE FROM ALAN LARSON OF LOS ALMOS NATIONAL LAB.
C *  MODIFIED BY R. L. SNYDER AND B. OSGOOD TO COMPUTE THE EXTINCTION
C *  CODES FOR DEAN SMITH'S POWD10 1982
C *  AND APPLEMAN LEAST SQUARES 1/84
C *  CONVERTED TO A SUBROUTINE AND MADE INTERACTIVE BY R.L.S. and S.A.H. 2/84
C *  CODING MODIFICATIONS MADE BY S.A. HOWARD 6/82:
C *
C *  1  ALL COMMON BLOCKS LABLED AND THE VARIABLES GIVEN GLOBAL
C *     SYMBOL NAMES (I.E. SAME FROM ROUTINE TO ROUTINE).
C *
C *  2  CRYSET NOW EXISTS IN SUBROUTINE FORM.  ARGUMENTS PASSED
C *     VIA DUMMY ARGUMENTS AND LABLED COMMON.
C *
C *  3  * NOTE *  CHANGE THE ARRAYS OPR,LAUE AND XOPR TO REAL*8
C *     OR CHARACTER*8 DEPENDING ON YOUR COMPILER.  SPGGRP MAY
C *     HAVE TO BE CHANGED FROM ARRAY(20) TO CHARACTER*20.
C *
C ********************************************************************
C *
C ***  CALLING SEQUENCE:
C *
C *  CALL CRYSET(SPGGRP,I1BAR,ITRAN,IEXTS,ITEST,XT,YT,ZT)
C *
C *  WHERE:
C *
C **  SPGGRP - ARRAY(20) - SPACE GROUP SYMBOL
C *
C *  THE SPACE GROUP SYMBOL (IN 20A1 IN 20A1 FORMAT) TYPED WITH
C *  SPACES SEPERATING THE OPERATORS.
C *
C *  THE SPACE GROUP SYMBOL CONSISTS OF 4 OPERATOR FIELDS.
C *  THESE ARE THE LATTICE OPERATOR(P, A, B, C, F, I AND R) AND THE
C *  ROTATION AND TRANSLATION OPERATORS(1, 1BAR OR -1, 2, 21, 2/M,
C *  2/A, 2/B, 2/C, 2/N, 3, 3BAR OR -3, 31, 32, 4, 41, 42, 43, 4BAR OR
C *  -4, 4/M, 4/N, 6, 61, 62, 63, 64, 65, 6BAR OR -6, 6/M, 63/M,
C *  42/N, 42/M, A, B, C, D, M, ETC.) FOR R-TYPE LATTICES ANOTHER
C *  OPERATOR(R) IS PLACED AFTER THE SYMBOL TO DEFINE THE
C *  RHOMBOHEDRAL SETTING, OTHERWISE THE HEXAGONAL SETTING IS TAKEN BY
C *  DEFAULT. EACH OPERATOR FIELD IS TERMINATED WITH A SPACE.
C *
C *  SOME EXAMPLES ARE
C *      P N M A
C *      P 21/C               B-AXIS UNIQUE MONOCLINIC
C *      P 21/C 1 1           A-AXIS UNIQUE MONOCLINIC
C *      P 1 1 2/N            C-AXIS UNIQUE MONOCLINIC
C *      P 63/M M C
C *      R 3BAR M R           RHOMBOHEDRAL SETTING
C *      R 3BAR M             HEXAGONAL SETTING
C *
C **  I1BAR - SCALER - CENTER OF SYMMETRY LISTING FLAG
C *
C *  I1BAR = 0 -> ELIMINATE POINTS RELATED BY 1BAR SYMMETRY FROM
C *               THE PRINTED POSITION LIST
C *
C *  I1BAR = 1 -> PRINT POINTS RELATED BY 1BAR SYMMETRY
C *
C **  ITRAN - SCALER - LATTICE TRANSLATION LISTING FLAG
C *
C *  ITRAN = 0 -> ELIMINATE POINTS RELATED BY LATTICE TRANSLATION
C *               FROM THE PRINTED POSITION LIST
C *
C *  ITRAN = 1 -> PRINT POINTS RELATED BY LATTICE TRANSLATION
C *
C **  IEXTS - ARRAY(27) - EXTINCTION CODES IN AIDS*80 CODE
C *
C *  THESE SYMBOLS CORRESPOND TO THE EXTINCTION CODES LISTED IN
C *  THE NBS AIDS*80 USER MANUAL PG 18.  IEXTS(1:27) TRANSLATE
C *  INTO COLUMNS(21:47) ON CARD TYPE 'H'.
C *
C **  ITEST - SCALER - NUMBER OF UNIT CELL CITES TO TEST
C *
C *  ITEST = 0 -> NO SITES TO BE TESTED
C *
C *  ITEST = 1 -> 1 SITE WILL BE TESTED.  THIS SITE ISE
C *               SPECIFIED BY THE FRACTIONAL X,Y,Z PARAMETERS
C *               IN THE ARRAYS XT,YT,ZT RESPECTIVELY.
C *
C *  *NOTE*  THE SITE TESTED SHOULD BE IN THE FIRST ELEMENT
C *          OF THE XT,YT,ZT ARRAYS.  THE MULTIPLICITY OF THE
C *          SITE IS RETURN VIA DUMMY ITEST, AND THE EQUIVALENT
C *          SITES ON WHICH THE ATOM WILL APPEAR AFTER THE
C *          OPERATION OF THE SPACE GROUP ARE PERFORMED
C *          WILL BE RETURN IN SEQUENTIAL POSITIONS OF THE
C *          XT,YT,ZT ARRAYS.  SINCE THE LARGEST GENERAL
C *          MULTIPLICITY SHOULD NOT EXCEED 192, IT IS BEST
C *          IF THE POSITION ARRAYS ARE DIMENSIONED TO 192.
C *
C **  XT - ARRAY(192) - REFER TO ITEST DEFS
C *
C **  YT - ARRAY(192) - REFER TO ITEST DEFS
C *
C **  ZT - ARRAY(192) - REFER TO ITEST DEFS
C *
C ********************************************************************
C *
C *  OVERLAY SCHEME
C *
C *  IF THE USE OF THIS SUBROUTINE REQUIRES OVERLAYING, THIS IS
C *  THE SUGGESTED TREE:
C *
C *  FSCRY00 = CRYSET,EXTTST,EXOR
C *  FSCRY10 = SPGP
C *  FSCRY20 = OP1
C *  FSCRY30 = SMTRY2
C *  FSCRY40 = PRMTR,SYMOPR,CEL000,OPERTR,SYMNUM
C *
C *                         FSCRY00
C *                            /
C *     ----------------------------------------------------
C *     /             /               /                   /
C *  FSCRY10      FSCRY20          FSCRY30             FSCRY40
C *
C *
C ********************************************************************
C *
      SUBROUTINE CRYSET(SPGGRP,I1BAR,ITRAN,IEXTS,ITEST,XT,YT,ZT)
C *
      REAL*8  OPR(108),XOPR(3,192),LAUE(14)
      INTEGER EXOR
      COMMON/CRYDAT/ NJ(2),L,X(192,9),XCT,KXB,NCTR(192)
      COMMON/SPG/ SPGC(20),NSP(2),NCONT(10),NC,NPOL,MULT
      COMMON/CNTRLS/ JC(20)
      COMMON/HKLCTL/ KH(3,24),DHKL(24),KHCO(10,7),IC,N1,IER,HM
      COMMON/EXTINC/ IHKL(9,5,11),IEXTFG(13)
      DIMENSION SPGGRP(20), IEXTS(27), XT(2), YT(2), ZT(2)
      DIMENSION KD(24),IDH(3,24)
      DIMENSION HF(8),HFX(3,24)
      DIMENSION XC(2),CEN(2)
      DIMENSION IX1(192),IY1(192),IZ1(192)
      DIMENSION SYMB(20)
      DATA HF/4H  H,,4H  K,,4H -I,,4H  L,,4H -L,,4H  I,,4H -K,,4H -H,/
      DATA E/4HE   /
      DATA OPR/8HERROR   ,8H    Y-X,,8H      X,,8H      Y,,8H      Z,,
     18HERROR   ,8HERROR   ,8HERROR   ,8HERROR   ,8HERROR   ,8HERROR   ,
     28HERROR 11,8HERROR 12,8HERROR 13,8H  1/6-Z,,8HERROR 15,8HERROR 16,
     38HERROR 17,8HERROR 18,8HERORR 19,8HERROR 20,8HERROR 21,8H  1/6+Z,,
     48H  1/4-Z,,8H  1/4-Y,,8H  1/4-X,,8HERROR 26,8HERROR 27,8HERROR 28,
     58H  1/4+X,,8H  1/4+Y,,8H  1/4+Z,,8H  1/3-Z,,8H  1/3-Y,,8H  1/3-X,,
     68H1/3+X-Y,,8HERROR 36,8H1/3+Y-X,,8H  1/3+X,,8H  1/3+Y,,8H  1/3+Z,,
     78HERROR 41,8HERROR 42,8HERROR 43,8HERROR 44,8HERROR 45,8HERROR 46,
     88HERROR 47,8HERROR 48,8HERROR 49,8H  1/2-Z,,8H  1/2-Y,,8H  1/2-X,,
     98HERROR 53,8HERROR 54,8HERROR 55,8H  1/2+X,,8H  1/2+Y,,8H  1/2+Z,,
     A8HERROR 59,8HERROR 60,8HERROR 61,8HERROR 62,8HERROR 63,8HERROR 64,
     B8HERROR 65,8HERROR 66,8HERROR 67,8H  2/3-Z,,8H  2/3-Y,,8H  2/3-X,,
     C8H2/3+X-Y,,8HERROR 72,8H2/3+Y-X,,8H  2/3+X,,8H  2/3+Y,,8H  2/3+Z,,
     D8H  3/4-Z,,8H  3/4-Y,,8H  3/4-X,,8HERROR 80,8HERROR 81,8HERROR 82,
     E8H  3/4+X,,8H  3/4+Y,,8H  3/4+Z,,8H  5/6-Z,,8HERROR 87,8HERROR 88,
     F8HERROR 89,8HERROR 90,8HERROR 91,8HERROR 92,8HERROR 93,8H  5/6+Z,,
     G8HERROR 95,8HERROR 96,8HERROR 97,8HERROR 98,8HERROR 99,8HERROR100,
     H8HERROR101,8HERROR102,8HERROR103,8H     -Z,,8H     -Y,,8H     -X,,
     I8H    X-Y,/
      DATA BLK/4H    /
      DATA JC/20*0/
      DATA XC/1H ,1HA/
      DATA CEN/1HC,1HA/
      DATA LAUE/8H1BAR    ,8H2/M     ,8HMMM     ,8H4/M     ,
     18H4/MMM   ,8H3BAR R  ,8H3BAR M R,8H3BAR    ,8H3BAR M 1,
     28H3BAR 1 M,8H6/M     ,8H6/MMM   ,8HM3      ,8HM3M     /
C
    1 FORMAT (20A1)
    2 FORMAT (16H0THE LATTICE IS A1,8HCENTRIC A1)
    3 FORMAT (27H0THE GENERAL POSITIONS ARE://(3(3A8)/))
    4 FORMAT (6HSYMTRY 5X3(1XA8))
    6 FORMAT (6HLATICE5X,1A1,10H    TYPE =1A1,30X20A1)
    7 FORMAT (10I4,10I2)
    8 FORMAT (41H0THE GENERAL POSITION SET MULTIPLICITY IS I4)
    9 FORMAT(52H0EQUIVALENT REFLECTIONS WITH THEIR PHASE SHIFTS ARE://
     1 (3(3A3,3I3,5X)))
   11 FORMAT (22H THE LAUE SYMMETRY IS A8)
12    FORMAT(/,12H A TOTAL OF ,I3,26H POSITIONS WILL BE PRINTED )
13    FORMAT(48H CRYSET - PRODUCES CRYSTALLOGRAPHIC SPACE GROUPS )
14    FORMAT(/,43H ELIMINATE POINTS RELATED BY 1BAR SYMMETRY?,
     +15H <0> YES <1> NO )
15    FORMAT(49H ELIMINATE POINTS RELATED BY LATTICE TRANSLATION?,
     +15H <0> YES <1> NO )
17    FORMAT(45H PRINT EXTINCTION INFORMATION? <0> NO <1> YES )
16    FORMAT(/,40H GIVE SPACE GROUP CODE (E TO END INPUT): )
C
C  GET THE JOB CONTROL SWITCHES
      WRITE(6,13)
C      WRITE(6,14)
C      READ(5,7) JC(1)
C      WRITE(6,15)
C      READ(5,7) JC(2)
C      WRITE(6,17)
C      READ(5,7) JC(5)
C
C  GET THE SPACE GROUP CODE
C100   WRITE(6,16)
C      READ (5,1) (SPGC(I),I=1,20)
C      IF ( SPGC(1).EQ.E ) STOP 5200
C
C  CALL SPGP TO GENERATE OPERATORS
      DO 105 I=1,20
	SPGC(I) = SPGGRP(I)
  105 SYMB(I) = SPGGRP(I)
      CALL SPGP
      IF ( NSP(2).EQ.4 ) GO TO 1000
      DO 110 I=1,20
      IF ( SPGC(I).NE.BLK ) GO TO 111
  110 CONTINUE
  111 SLAT = SPGC(I)
C
C  GIVE LATTICE TYPE AND SYMMETRY
      CALL OP1
      WRITE (6,2) XC(NC+1),SLAT
      NJX1 = NSP(1)
      WRITE (6,11) LAUE(NJX1)
C
C  EQUIVALENT REFLECTIONS AND PHASE SHIFTS
      DHKL(1) = 0.0
      KH(1,1) = 12
      KH(2,1) = 1200
      KH(3,1) = 120000
      CALL SMTRY2
      DO 50 J=1,IC
      DO 40 I=1,3
      IF ( IABS(KH(I,J)).EQ.12     ) K=MOD(ISIGN(1,KH(I,J))+9,9)
      IF ( IABS(KH(I,J)).EQ.1200   ) K=MOD(ISIGN(2,KH(I,J))+9,9)
      IF ( IABS(KH(I,J)).EQ.1212   ) K=MOD(ISIGN(3,KH(I,J))+9,9)
      IF ( IABS(KH(I,J)).EQ.120000 ) K=MOD(ISIGN(4,KH(I,J))+9,9)
   40 HFX(I,J) = HF(K)
      KD(J) = DHKL(J)+363636.1
      IDH(1,J) = MOD(MOD(KD(J),100),12)
      IDH(2,J) = MOD(MOD(KD(J)/100,100),12)
      IDH(3,J) = MOD(KD(J)/10000,12)
   50 CONTINUE
      WRITE (6,9) ((HFX(J,I),J=1,3),(IDH(J,I),J=1,3),I=1,IC)
C
C  CALL SYMOPR
      X(1,1) = 0.01852
      X(1,2) = 0.02778
      X(1,3) = 0.03704
      X(1,4) = 0.0
      X(1,5) = 0.0
      X(1,6) = 0.0
      X(1,7) = 0.0
      X(1,8) = 0.0
      X(1,9) = 0.0
      CALL SYMOPR
      WRITE (6,8) MULT
C
C  EVALUATE SITES AND ELIMINATE REDUNDANCIES
      IP = 0
      DO 200 I=1,MULT
      K = I-1
      IX = 108.0*X(I,1)+1.1
      IY = 108.0*X(I,2)+1.1
      IZ = 108.0*X(I,3)+1.1
      IX1(I) = MOD(IX,9)
      IY1(I) = MOD(IY,9)
      IZ1(I) = MOD(IZ,9)
      IF ( K.EQ.0 ) GO TO 180
C  REMOVE POSITIONS DUE TO 1BAR SYMMETRY
      IF ( I1BAR.GT.0 ) GO TO 160
      IF ( NC.GT.0 ) GO TO 160
      DO 150 J=1,K
      IF ( EXOR(NCTR(J),NCTR(I)).EQ.290 ) GO TO 200
  150 CONTINUE
  160 CONTINUE
C  REMOVE POSITIONS DUE TO LATTICE TRANSLATIONS
      IF ( ITRAN.GT.0 ) GO TO 180
      DO 170 J=1,K
      IF ( IABS(IX1(I)-IX1(J))+IABS(IY1(I)-IY1(J))+IABS(IZ1(I)-IZ1(J))
     1 .EQ.0 ) GO TO 200
  170 CONTINUE
  180 CONTINUE
C  RECORD THIS SET OF POSITIONS
      IP = IP+1
      XOPR(1,IP) = OPR(IX)
      XOPR(2,IP) = OPR(IY)
      XOPR(3,IP) = OPR(IZ)
  200 CONTINUE
      WRITE(6,12) IP
      WRITE (6,3) ((XOPR(I,J),I=1,3),J=1,IP)
      IU = NC+1
C
C  CALL PRMTR TO TEST SITE SYMMETRIES IF REQUESTED
      IF( ITEST .EQ. 1 )CALL PRMTR(ITEST,XT,YT,ZT)
C
C DETERMINE EXTINCTION CODES, FIRST LOOP TO FILL IHKL WITH
C FLAGS, INDEX INTO IHKL DETERMINES WHICH REFLECTION
      IHKL(1,1,1)=0
      DO 210  I=-4,4
      DO 210  J=0,4
      DO 210  K=-4,6
      IF(I.EQ.0.AND.J.EQ.0.AND.K.EQ.0)GO TO 210
      KH(1,1)=I
      KH(2,1)=J
      KH(3,1)=K
      CALL SMTRY2
C ADD 1 TO LOOP COUNTERS TO USE THEM AS POINTERS
      L=I+5
      M=J+1
      N=K+5
C IER IS FLAG BACK FROM SMTRY2  0 IF NOT EXTINCT (1 IF EXTINCT)
      IHKL(L,M,N)=IER
210   CONTINUE
C IHKL NOW HAS FLAGS FOR EXTINCTION FOR -4,0,-4 THROUGH 4,4,6
C REFLECTIONS.  CALL EXTTST TO DETERMINE 13 FLAGS FOR OUTSIDE
      CALL EXTTST( IEXTS )
1000  RETURN
      END

      SUBROUTINE EXTTST( IEXTS )
C *
C *  THIS ROUTINE SCANS THE IHKL ARRAY LOOKING AT REFLECTIONS
C *  FROM PARTICULAR ZONES.  DEPENDING WHICH REFLECTIONS ARE
C *  POSSIBLE, THE FLAGS IEXTFG WILL BE SET CORRESPONDING TO
C *  THE CODES IN USE B
C
      INTEGER H
      DIMENSION IFLG(9), IEXTS(27)
      COMMON/EXTINC/ IHKL(9,5,11),IEXTFG(13)
C IHKL HAS FLAGS SHOWING WHICH REFLECTIONS ARE EXTINCT
C IF IHKL(2,3,4)=1, REFLECTION 1 2 3 IS EXTINCT,
C IF -0, REFLECTION 1 2 3 IS POSSIBLE
C
C THIS ROUTINE SETS UP LOOPS THAT WILL SCAN IHKL LOOKING
C AT REFLECTIONS FROM PARTICULAR ZONES. DEPENDING ON
C WHICH REFLECTIONS ARE POSSIBLE, FLAGS ARE SET IN IFLG
C TO LATER BECOME THE EXTINCTION CODES.
C TEST TO SEE IF A REFLECTION EXISTS THAT BY AN EXTINCTION
C RULE MUST NOT, 1 VIOLATION DROPS THAT RULE
C DUMP IHKL ARRAY
C     WRITE(6,1)(L-5,((IHKL(H,K,L),K=1,5),H=1,9),L=1,11)
C1    FORMAT(2X'H=-4'3X'-3'3X'-2'3X'-1'3X'0'4X'1'4X'2'4X'3'4X'4'
C    &,/,'  K=',9('01234'),/,11(X,'L',I2,45I1,/),/)
C ZERO EXTINCTION CODE ARRAY IEXTFG
      DO 5 I=1,13
      IEXTFG(I)=0
    5 CONTINUE
      IHKL(1,1,1)=1
C SET 0,0,0 EXTINCT SO IT WONT VIOLATE ANY EXTINCTION RULES
C LATTICE TYPE FIRST
      DO 10 I=1,9
      IFLG(I)=0
   10 CONTINUE
      DO 20 I=1,9
      DO 20 J=1,5
      DO 20 M=1,11
      H=I-5
      K=J-1
      L=M-5
      IF(IHKL(I,J,M).EQ.1)GO TO 20
C HERE IF REFLECTION POSSIBLE
      IF(MOD(H+K+L,3).NE.0)IFLG(8)=1
      IF(MOD(H-K+L,3).NE.0)IFLG(7)=1
      IF(MOD(K-H+L,3).NE.0)IFLG(6)=1
      IF(MOD(H+K+L,2).NE.0)IFLG(5)=1
      IF(MOD(H+K,2).NE.0.OR.MOD(H+L,2).NE.0.OR.MOD(K+L,2).NE.0)IFLG(4)=1
      IF(MOD(H+K,2).NE.0)IFLG(3)=1
      IF(MOD(H+L,2).NE.0)IFLG(2)=1
      IF(MOD(K+L,2).NE.0)IFLG(1)=1
   20 CONTINUE
C IFLG NOW SET, TAKE HIGHEST ONE
      DO 25 I=1,8
      IF(IFLG(I).EQ.0)IEXTFG(1)=I
   25 CONTINUE
C NOW WORK ON H K 0 ZONE
      DO 30 I=1,4
      IFLG(I)=0
   30 CONTINUE
      DO 35 I=1,9
      DO 35 J=1,5
      H=I-5
      K=J-1
      L=0
      IF(IHKL(I,J,5).EQ.1)GO TO 35
C HERE IF REFLECTION POSSIBLE
      IF(MOD(H+K,4).NE.0.OR.MOD(H,2).NE.0.OR.MOD(K,2).NE.0)IFLG(4)=1
      IF(MOD(H+K,2).NE.0)IFLG(3)=1
      IF(MOD(K,2).NE.0)IFLG(2)=1
      IF(MOD(H,2).NE.0)IFLG(1)=1
   35 CONTINUE
C IFLG NOW SET FOR HK0 ZONE, TAKE HIGHEST
      DO 40 I=1,4
      IF(IFLG(I).EQ.0)IEXTFG(2)=I
   40 CONTINUE
C NOW WORK ON H 0 L ZONE
      DO 45 I=1,4
      IFLG(I)=0
   45 CONTINUE
      DO 50 I=1,9
      DO 50 M=1,11
      H=I-5
      K=0
      L=M-5
      IF(IHKL(I,1,M).EQ.1)GO TO 50
C HERE IF REFLECTION POSSIBLE
      IF(MOD(H+L,4).NE.0.OR.MOD(H,2).NE.0.OR.MOD(L,2).NE.0)IFLG(4)=1
      IF(MOD(H+L,2).NE.0)IFLG(3)=1
      IF(MOD(L,2).NE.0)IFLG(2)=1
      IF(MOD(H,2).NE.0)IFLG(1)=1
   50 CONTINUE
C IFLG NOW SET FOR H0L ZONE, TAKE HIGHEST
      DO 60 I=1,4
      IF(IFLG(I).EQ.0)IEXTFG(3)=I
   60 CONTINUE
C NOW WORK ON 0 K L ZONE
      DO 65 I=1,4
      IFLG(I)=0
   65 CONTINUE
      DO 70 J=1,5
      DO 70 M=1,11
      H=0
      K=J-1
      L=M-5
      IF(IHKL(5,J,M).EQ.1)GO TO 70
C HERE IF REFLECTION POSSIBLE
      IF(MOD(K+L,4).NE.0.OR.MOD(K,2).NE.0.OR.MOD(L,2).NE.0)IFLG(4)=1
      IF(MOD(K+L,2).NE.0)IFLG(3)=1
      IF(MOD(L,2).NE.0)IFLG(2)=1
      IF(MOD(K,2).NE.0)IFLG(1)=1
   70 CONTINUE
C IFLG NOW SET FOR 0KL ZONE, TAKE HIGHEST
      DO 80 I=1,4
      IF(IFLG(I).EQ.0)IEXTFG(4)=I
   80 CONTINUE
C NOW FOR H00 ZONE
      DO 85 I=1,3
      IFLG(I)=0
   85 CONTINUE
      DO 90 I=1,9
      H=I-5
      K=0
      L=0
      IF(IHKL(I,1,5).EQ.1)GO TO 90
C HERE IF REFLECTION POSSIBLE
      IF(MOD(H,2).NE.0)IFLG(1)=1
      IF(MOD(H,4).NE.0)IFLG(2)=1
   90 CONTINUE
C IFLG NOW SET FOR H00 ROW, TAKE HIGHEST
      IF(IFLG(1).EQ.0)IEXTFG(11)=1
      IF(IFLG(2).EQ.0)IEXTFG(11)=2
C NOW FOR 0K0 ZONE
      DO 95 I=1,3
      IFLG(I)=0
   95 CONTINUE
      DO 100 J=1,5
      H=0
      K=J-1
      L=0
      IF(IHKL(5,J,5).EQ.1)GO TO 100
C HERE IF REFLECTION POSSIBLE
      IF(MOD(K,2).NE.0)IFLG(1)=1
      IF(MOD(K,4).NE.0)IFLG(2)=1
  100 CONTINUE
C IFLG NOW SET FOR 0K0 ROW, TAKE HIGHEST
      IF(IFLG(1).EQ.0)IEXTFG(12)=1
      IF(IFLG(2).EQ.0)IEXTFG(12)=2
C NOW FOR 00L ZONE
      DO 105 I=1,4
      IFLG(I)=0
  105 CONTINUE
      DO 110 M=1,11
      H=0
      K=0
      L=M-5
      IF(IHKL(5,1,M).EQ.1)GO TO 110
C HERE IF REFLECTION POSSIBLE
      IF(MOD(L,2).NE.0)IFLG(1)=1
      IF(MOD(L,3).NE.0)IFLG(2)=1
      IF(MOD(L,4).NE.0)IFLG(3)=1
      IF(MOD(L,6).NE.0)IFLG(4)=1
  110 CONTINUE
C IFLG NOW SET FOR 00L ROW, TAKE HIGHEST
      IF(IFLG(1).EQ.0)IEXTFG(13)=1
      IF(IFLG(2).EQ.0)IEXTFG(13)=2
      IF(IFLG(3).EQ.0)IEXTFG(13)=3
      IF(IFLG(4).EQ.0)IEXTFG(13)=4
C NOW FOR HHL ZONE
      DO 115 I=1,4
      IFLG(I)=0
115   CONTINUE
      DO 120 I=6,9
      DO 120 M=1,11
      H=I-5
      K=H
      L=M-5
      J=I-4
      IF(IHKL(I,J,M).EQ.1)GO TO 120
C HERE IF REFLECTION POSSIBLE
      IF(MOD(H+H+L,4).NE.0)IFLG(2)=1
      IF(MOD(L,2).NE.0)IFLG(1)=1
      IF(MOD(L,3).NE.0)IFLG(3)=1
      IF(MOD(H+L,2).NE.0)IFLG(4)=1
120   CONTINUE
C IFLG NOW SET, TAKE HIGHEST ONE
      IF(IFLG(1).EQ.0)IEXTFG(5)=1
      IF(IFLG(3).EQ.0)IEXTFG(5)=3
      IF(IFLG(4).EQ.0)IEXTFG(5)=4
      IF(IFLG(2).EQ.0)IEXTFG(5)=2
C NOW FOR -HHL ZONE
      DO 130 I=1,4
      IFLG(I)=0
130   CONTINUE
      DO 140 J=2,5
      DO 140 M=1,11
      K=J-1
      H=-K
      L=M-5
      I=6-J
      IF(IHKL(I,J,M).EQ.1)GO TO 140
C HERE IF REFLECTION POSSIBLE
      IF(MOD(H+H+L,4).NE.0)IFLG(2)=1
      IF(MOD(L,2).NE.0)IFLG(1)=1
      IF(MOD(H+L,2).NE.0)IFLG(3)=1
      IF(MOD(H+L,3).NE.0)IFLG(4)=1
140   CONTINUE
      IF(IFLG(1).EQ.0)IEXTFG(6)=1
      IF(IFLG(3).EQ.0)IEXTFG(6)=3
      IF(IFLG(4).EQ.0)IEXTFG(6)=4
      IF(IFLG(2).EQ.0)IEXTFG(6)=1
C NOW FOR HKH ZONE
      DO 150 I=1,4
      IFLG(I)=0
150   CONTINUE
      DO 160 I=1,9
      DO 160 J=1,5
      H=I-5
      K=J-1
      L=H
      IF(IHKL(I,J,I).EQ.1)GO TO 160
      IF(MOD(H+H+K,4).NE.0)IFLG(2)=1
      IF(MOD(K,2).NE.0)IFLG(1)=1
      IF(MOD(H+K,2).NE.0)IFLG(3)=1
160   CONTINUE
      IF(IFLG(1).EQ.0)IEXTFG(7)=1
      IF(IFLG(3).EQ.0)IEXTFG(7)=3
      IF(IFLG(2).EQ.0)IEXTFG(7)=2
C NOW FOR HK-H ZONE
      DO 170 I=1,3
      IFLG(I)=0
170   CONTINUE
      DO 180 I=6,9
      DO 180 J=1,5
      H=I-5
      K=J-1
      L=-H
      M=10-I
      IF(IHKL(I,J,M).EQ.1)GO TO 180
C HERE IF POSSIBLE
      IF(MOD(H+H+K,4).NE.0)IFLG(2)=1
      IF(MOD(K,2).NE.0)IFLG(1)=1
      IF(MOD(H+K,2).NE.0)IFLG(3)=1
180   CONTINUE
      IF(IFLG(1).EQ.0)IEXTFG(8)=1
      IF(IFLG(3).EQ.0)IEXTFG(8)=3
      IF(IFLG(2).EQ.0)IEXTFG(8)=2
C NOW FOR HKK ZONE
      DO 190 I=1,3
      IFLG(I)=0
190   CONTINUE
      DO 200 I=1,9
      DO 200 J=1,5
      H=I-5
      K=J-1
      L=K
      M=J+4
      IF(IHKL(I,J,M).EQ.1)GO TO 200
C HERE IF POSSIBLE
      IF(MOD(K+K+H,4).NE.0)IFLG(2)=1
      IF(MOD(H,2).NE.0)IFLG(1)=1
      IF(MOD(H+K,2).NE.0)IFLG(3)=1
200   CONTINUE
      IF(IFLG(1).EQ.0)IEXTFG(9)=1
      IF(IFLG(3).EQ.0)IEXTFG(9)=3
      IF(IFLG(2).EQ.0)IEXTFG(9)=2
C NOW FOR HK-K ZONE
      DO 210 I=1,3
      IFLG(I)=0
210   CONTINUE
      DO 220 I=1,9
      DO 220 J=2,5
      H=I-5
      K=J-1
      L=-K
      M=6-J
      IF(IHKL(I,J,M).EQ.1)GO TO 220
      IF(MOD(K+K+H,4).NE.0)IFLG(2)=1
      IF(MOD(H,2).NE.0)IFLG(1)=1
      IF(MOD(H+K,2).NE.0)IFLG(3)=1
220   CONTINUE
      IF(IFLG(1).EQ.0)IEXTFG(10)=1
      IF(IFLG(3).EQ.0)IEXTFG(10)=3
      IF(IFLG(2).EQ.0)IEXTFG(10)=1
C END OF CHECKING ZONES
      WRITE(6,500)(I,I=1,13),(IEXTFG(I),I=1,13)
500   FORMAT(' EXTINCTION CODES:',/,X,13I3,/,X,13I3,/,/)
      RETURN
      END

      FUNCTION EXOR(I,J)
C
      INTEGER EXOR
C      EXOR  = IAND(IOR(I,J),ICOMPL(IAND(I,J)))
      EXOR  = IAND(IOR(I,J),NOT(IAND(I,J)))
      RETURN
      END

      SUBROUTINE SPGP
C
      INTEGER EXOR
      COMMON/SPG/ SPGC(20),NSP(2),NCONT(10),NC,NPOL,MULT
      DIMENSION CHR(21),L(4,4),ICO(6,15)
      DIMENSION NDAT(7)
      DATA NDAT/3,1,2,0,2,1,3/
      DATA CHR/1H ,1HC,1HB,1HA,1HP,1HF,1HI,1HR,1HM,
     1 1HN,1HD,1H1,1H2,1H3,1H4,1H5,1H6,1H-,1H/,1HH,1H./
      LODGDF(I,J) = IAND(EXOR(I,J),307)
C
    1 FORMAT (20H0THE SPACE GROUP IS 80A1)
    2 FORMAT (' DID YOU ENTER IT CORRECTLY?'/
     1 ' ERRORS OF SOME SORT WERE DETECTED.'/
     2 '0THE INPUT WAS READ AS: ', 80A1)
   24 FORMAT (34H0A CENTER IS PRESENT, NOT AT 0,0,0)
C
C      PRINT 1,SPGC
      DO 97 I=1,90
   97 ICO(I,1) = 0
      DO 98 I=1,16
   98 L(I,1) = 0
      K = 1
      M = 1
      NSP(1) = 0
      NSP(2) = 0
      N = 0
      DO 110 J=1,20
   99 DO 100 I=1,21
      IF ( SPGC(J).EQ.CHR(I) ) GO TO 101
  100 CONTINUE
      GO TO 110
  101 IF ( K+M+I.EQ.3 ) GO TO 110
      IF ( I.EQ.1 ) GO TO 108
      L(M,K) = I
      N = 0
      M = M+1
      IF ( M-4 ) 110,110,108
  108 IF ( N.EQ.1 ) GO TO 110
      N = 1
      M = 1
      K = K+1
      IF ( K.GT.4 ) GO TO 200
  110 CONTINUE
  200 IF ( K.LE.2 ) GO TO 500
      IF ( L(1,1).GT.8 ) GO TO 500
      J = 1
      I = L(1,1)-1
      GO TO (203,202,201,119,204,205,206),I
  201 NCONT(J) = 576
      GO TO 209
  202 NCONT(J) = 516
      GO TO 209
  203 NCONT(J) = 68
      GO TO 209
  204 NCONT(J) = 576
      J = J+1
      GO TO 202
  205 NCONT(J) = 580
      GO TO 209
  207 K = K-1
      NSP(1) = K+3
      GO TO 210
  206 IF ( L(1,3).EQ.8.OR.L(1,4).EQ.8 ) GO TO 207
      NCONT(J) = 8192
      IF ( L(1,K-1).EQ.20 ) K=K-1
      NSP(1) = K+5
      J = J+1
      GO TO 210
  209 J = J+1
  119 IF ( K-4 ) 120,130,140
  120 IF ( L(1,2).EQ.18 ) GO TO 121
      IF ( L(1,2).EQ.17 ) GO TO 122
      IF ( L(1,2).EQ.14 ) GO TO 123
      IF ( L(1,2).EQ.15 ) GO TO 124
      IF ( L(1,2).EQ.12 ) GO TO 125
      NSP(1) = 2
      NSP(2) = 2
      GO TO 210
  121 IF ( L(2,2).EQ.17 ) GO TO 122
      IF ( L(2,2).EQ.14 ) GO TO 123
      IF ( L(2,2).EQ.15 ) GO TO 124
      IF ( L(2,2).EQ.12 ) GO TO 125
      GO TO 500
  122 NSP(1) = 11
      GO TO 210
  123 NSP(1) = 8
      GO TO 210
  124 NSP(1) = 4
      GO TO 210
  125 NSP(1) = 1
      GO TO 210
  130 IF ( L(1,3).NE.14 ) GO TO 500
      NSP(1) = 13
      GO TO 210
  140 IF ( L(1,3).EQ.14 ) GO TO 151
      IF ( L(1,2).EQ.18 ) GO TO 152
      IF ( L(1,2).EQ.17 ) GO TO 153
      IF ( L(1,2).EQ.14 ) GO TO 154
      IF ( L(1,2).EQ.15 ) GO TO 155
      IF ( L(1,2).EQ.12 ) GO TO 141
      IF ( L(1,3).EQ.12 ) GO TO 142
      IF ( L(1,4).EQ.12 ) GO TO 500
      NSP(1) = 3
      GO TO 210
  141 IF ( L(1,3).EQ.12 ) GO TO 143
      IF ( L(1,4).NE.12 ) GO TO 500
      NSP(1) = 2
      NSP(2) = 2
      GO TO 210
  142 IF ( L(1,4).NE.12 ) GO TO 500
      NSP(1) = 2
      NSP(2) = 1
      GO TO 210
  143 IF ( L(1,4).EQ.12 ) GO TO 500
      NSP(1) = 2
      NSP(2) = 3
      GO TO 210
  151 NSP(1) = 14
      GO TO 210
  152 IF ( L(2,2).EQ.17 ) GO TO 153
      IF ( L(2,2).EQ.14 ) GO TO 154
      IF ( L(2,2).EQ.15 ) GO TO 155
      GO TO 500
  153 NSP(1) = 12
      GO TO 210
  154 IF ( L(1,3).EQ.12 ) GO TO 156
      IF ( L(1,4).NE.12 ) GO TO 500
      NSP(1) = 9
      GO TO 210
  155 NSP(1) = 5
      GO TO 210
  156 IF ( L(1,4).EQ.12 ) GO TO 123
      NSP(1) = 10
  210 K = K-1
      N = 1
      DO 300 M=2,K
      IF ( L(1,M).EQ.0 ) GO TO 500
  218 I = IABS(L(1,M)-5)
  219 IF ( I.LE.0.OR.I.GT.15 ) GO TO 500
      GO TO (220,220,220,220,220,245,250,255,260,265,500,270,275,300,
     1 300),I
  220 GO TO (500,221,222,223),M
  221 IF ( L(1,3).EQ.14 ) GO TO 2230
      IF ( L(1,2).EQ.15 ) GO TO 2230
      IF ( L(1,2).EQ.17 ) GO TO 2230
      IF ( K.EQ.2 ) GO TO 2220
 2210 ICO(1,N) = 2
      ICO(2,N) = 0
      ICO(3,N) = 0
      ICO(4,N) = 4
      IF ( I.EQ.2.OR.I.EQ.5 ) ICO(5,N) = 1
      IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
 2211 N = N+1
      IF ( L(1,2).NE.15 ) GO TO 300
      ICO(1,N) = ICO(2,N-1)
      ICO(2,N) = ICO(1,N-1)
      ICO(3,N) = ICO(3,N-1)
      ICO(4,N) = ICO(5,N-1)
      ICO(5,N) = ICO(4,N-1)
      ICO(6,N) = ICO(6,N-1)
      N= N+1
      GO TO 300
  222 IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 225
      IF ( L(1,2).EQ.15 ) GO TO 2210
 2220 ICO(1,N) = 0
      ICO(2,N) = 2
      ICO(3,N) = 0
      ICO(5,N) = 4
      IF ( I.EQ.1.OR.I.EQ.5 ) ICO(4,N) = 1
      IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
      N = N+1
      GO TO 300
  223 IF ( L(1,3).EQ.14.OR.L(1,2).EQ.15 ) GO TO 224
      IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 224
 2230 ICO(1,N) = 0
      ICO(2,N) = 0
      ICO(3,N) = 2
      ICO(6,N) = 4
      IF ( I.EQ.1.OR.I.EQ.5 ) ICO(4,N) = 1
      IF ( I.EQ.2.OR.I.EQ.5 ) ICO(5,N) = 1
      N = N+1
      IF ( M.EQ.2.AND.L(1,2).EQ.15.AND.I.EQ.5 ) ICO(4,N-3)=1
      IF ( M.NE. 2.OR.L(1,2).NE.17) GO TO 300
      IF ( L(1,3).EQ.2 ) ICO(6,N-1)=1
      IF ( L(1,4).EQ.2 ) ICO(6,N-1)=MOD(ICO(6,N-1)+1,2)
      GO TO 300
  224 ICO(1,N) = 1
      ICO(2,N) = 1
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
      IF ( NSP(1).EQ.7.AND.I.EQ.3 ) GO TO 2240
      IF ( I.NE.5 ) GO TO 226
 2240 ICO(4,N) = 5
      ICO(5,N) = 5
      N = N+1
      GO TO 300
  225 IF ( NSP(1).EQ.7 ) GO TO 224
      ICO(1,N) = 3
      ICO(2,N) = 3
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      IF ( I.EQ.3 ) ICO(6,N) = 1
  226 N = N+1
      GO TO 300
C    D TYPE MIRROR
  245 GO TO (500,246,247,248),M
  246 IF ( K.EQ.2 ) GO TO 247
      ICO(1,N) = 2
      ICO(2,N) = 0
      ICO(3,N) = 0
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      N = N+1
      GO TO 300
  247 ICO(1,N) = 0
      ICO(2,N) = 2
      ICO(3,N) = 0
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      N = N+1
      GO TO 300
  248 IF ( L(1,2).EQ.15.OR.L(1,3).EQ.14 ) GO TO 249
      ICO(1,N) = 0
      ICO(2,N) = 0
      ICO(3,N) = 2
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      N = N+1
      GO TO 300
  249 ICO(1,N) = 1
      ICO(2,N) = 1
      ICO(3,N) = 0
      ICO(4,N) = 6
      ICO(5,N) = 6
      ICO(6,N) = 6
      IF (L(1,3).NE.13) GO TO 226
      ICO(4,N) = 0
      ICO(5,N) = 1
      N = N+1
      GO TO 300
C    1 FOLD ROTATION
  250 IF ( L(2,M).NE.3 ) GO TO 300
      ICO(1,N) = 2
      ICO(2,N) = 2
      ICO(3,N) = 2
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 4
      N = N+1
      GO TO 300
  255 GO TO (500,256,257,258),M
C    2 FOLD ROTATION
  256 IF ( K.EQ.2 ) GO TO 2571
 2561 ICO(1,N) = 0
      ICO(2,N) = 2
      ICO(3,N) = 2
      ICO(4,N) = 0
      ICO(5,N) = 4
      ICO(6,N) = 4
      IF ( IABS(L(2,M)-13).EQ.1 ) ICO(4,N) = 1
 2560 N = N+1
      DO 2562 I=2,4
      IF ( L(I,M).EQ.19 ) GO TO 2563
 2562 CONTINUE
      GO TO 300
 2563 IF ( L(I+1,M).LE.1 ) GO TO 500
      I = IABS(L(I+1,M)-5)
      GO TO 219
  257 IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 259
 2571 ICO(1,N) = 2
      ICO(2,N) = 0
      ICO(3,N) = 2
      ICO(4,N) = 4
      ICO(5,N) = 0
      ICO(6,N) = 4
      IF ( L(2,M).EQ.12 ) ICO(5,N)=1
      IF ( L(1,2).EQ.15 ) GO TO 2211
      GO TO 2560
  258 IF ( L(1,2).GE.14   ) GO TO 2595
      IF ( L(1,3).EQ.14 ) GO TO 259
 2581 ICO(1,N) = 2
      ICO(2,N) = 2
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 0
      IF ( IABS(L(2,M)-13).EQ.1 ) ICO(6,N) = 1
      IF (      L(2,M).EQ.16    ) ICO(6,N) = 1
      GO TO 2560
  259 IF ( L(1,3).EQ.8.OR.L(1,4).EQ.8 ) GO TO 2595
      ICO(1,N) = 1
      ICO(2,N) = 1
      ICO(3,N) = 2
      ICO(4,N) = 0
      ICO(5,N) = 0
      ICO(6,N) = 4
      GO TO 2560
 2595 IF ( L(1,2).EQ.15)GO TO 259
      ICO(1,N) = 3
      ICO(2,N) = 3
      ICO(3,N) = 2
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 4
      GO TO 2560
C    3 FOLD ROTATION
  260 GO TO (500,261,262,500),M
  261 IF ( L(1,1).EQ.8.AND.J.EQ.1 ) GO TO 262
      IX = 0
      IF ( L(2,M).EQ.12 ) GO TO 2611
      IF ( L(2,M).EQ.13 ) GO TO 2612
 2610 NCONT(J) = 8196
      GO TO 2613
 2611 NCONT(J) = 8200
      IF ( L(1,4).NE.13 ) GO TO 2613
      J = J+1
      NCONT(J) = 2321
      IF ( L(1,2).EQ.14 ) NCONT(J)=4403
      L(1,3) = 12
      L(1,4) = 12
      GO TO 2613
 2612 NCONT(J) = 8204
      IF ( L(1,4).NE.13 ) GO TO 2613
      J = J+1
      NCONT(J) = 4369
      IF ( L(1,2).EQ.14 ) NCONT(J)=2355
      L(1,3) = 12
      L(1,4) = 12
 2613 J = J+1
      IF ( IX-1 ) 250,2581,2230
C    CUBIC OR RHOMBOHEDERAL
  262 NCONT(J) = 16384
      IF (L(2,M).NE.3 ) GO TO 2620
      J = J+1
      NCONT(J) = 290
 2620 J = J+1
      IF ( N.EQ.1 ) GO TO 300
      I = N-1
      IN1 = N
      IN2 = N+1
      ICO(1,IN1) = ICO(3,I)
      ICO(2,IN1) = ICO(1,I)
      ICO(3,IN1) = ICO(2,I)
      ICO(4,IN1) = ICO(6,I)
      ICO(5,IN1) = ICO(4,I)
      ICO(6,IN1) = ICO(5,I)
      ICO(1,IN2) = ICO(2,I)
      ICO(2,IN2) = ICO(3,I)
      ICO(3,IN2) = ICO(1,I)
      ICO(4,IN2) = ICO(5,I)
      ICO(5,IN2) = ICO(6,I)
  263 ICO(6,IN2) = ICO(4,I)
      N = IN2+1
      GO TO 300
  265 IF ( M.NE.2 ) GO TO 500
      ICO(1,N) = 3
      ICO(2,N) = 1
      ICO(3,N) = 0
      ICO(4,N) = 4
      ICO(5,N) = 4
      ICO(6,N) = 0
      IF ( L(2,2).EQ.12 ) ICO(6,N) = 2
      IF ( L(2,2).EQ.13 ) ICO(6,N) = 1
      IF ( L(2,2).EQ.14 ) ICO(6,N) = 3
      IF ( L(2,2).EQ. 3 ) ICO(3,N) = 2
      N = N+1
      IF ( L(2,2).EQ.3.AND.L(1,3).EQ.14.AND.L(1,4).EQ.11 ) GO TO 266
      IF ( L(1,3).EQ.14 ) GO TO 2561
      IF ( K.GT.2.OR.L(1,1).NE.7 ) GO TO 2581
      IF ( L(2,2)+L(3,2).NE.12 ) GO TO 2581
      L(2,2) = 0
      ICO(5,N-1) = 1
      GO TO 2581
  266 IF ( L(1,1).NE.7.OR.L(1,2).NE.15 ) GO TO 500
      NCONT(J  ) = 16384
      NCONT(J+1) = 356
      NCONT(J+2) = 834
      NCONT(J+3) = 1177
      J = J+3
      GO TO 410
  270 IF ( M.NE.2 ) GO TO 500
      IX = 1
      IF ( L(2,2).EQ.12 ) GO TO 2611
      IF ( L(2,2).EQ.13 ) GO TO 2612
      IF ( L(2,2).EQ.14 ) GO TO 2610
      IF ( L(2,2).EQ.15 ) GO TO 2611
      IF ( L(2,2).EQ.16 ) GO TO 2612
      IF ( L(2,2).EQ. 3 ) GO TO 271
      GO TO 2610
  271 IX = 2
      GO TO 2610
  275 IF ( M.NE.2 ) GO TO 500
      L(1,2) = L(2,2)
      L(2,2) = 3
      GO TO 218
  300 CONTINUE
      N = N-1
      IJ = J
      IF ( N.GT.0 ) GO TO 301
      J = J-1
      GO TO 410
  301 DO 305 I=1,N
      NCONT(J) = ICO(1,I)+16*ICO(2,I)+128*ICO(3,I)+4*MOD(ICO(4,I),4)
     1 +64*MOD(ICO(5,I),4)+ 512*MOD(ICO(6,I),4)
  305 J = J+1
  306 J = J-1
  310 DO 400 I=IJ,J
      NCI = I-IJ+1
      ICO4 = MOD(ICO(4,NCI),4)
      ICO5 = MOD(ICO(5,NCI),4)
      ICO6 = MOD(ICO(6,NCI),4)
      NI4 = NDAT(ICO4+4)
      NI5 = NDAT(ICO5+4)
      NI6 = NDAT(ICO6+4)
      KJ = I+1
      IF ( IAND(NCONT(I),307)-290 ) 320,315,320
  315 IF ( IAND(NCONT(I),7884) ) 316,318,316
C   A CENTER IS PRESENT, NOT AT 0,0,0
  316 CONTINUE
      WRITE(6,24)
      GO TO 320
C   A CENTER AT 0,0,0 IS PRESENT
  318 CONTINUE
  320 IF ( KJ.GT.J ) GO TO 400
      DO 390 K=KJ,J
      NCK = K-IJ+1
      KCO4 = MOD(ICO(4,NCK),4)
      KCO5 = MOD(ICO(5,NCK),4)
      KCO6 = MOD(ICO(6,NCK),4)
      NK4 = NDAT(KCO4+4)
      NK5 = NDAT(KCO5+4)
      NK6 = NDAT(KCO6+4)
      NXC = MOD( NI4+ NK4,4)
      NYC = MOD( NI5+ NK5,4)
      NZC = MOD( NI6+ NK6,4)
      MJ = K+1
      LOD = LODGDF(NCONT(K),NCONT(I))
      IF ( LOD.NE.290 ) GO TO 330
C   A CENTER IS GENERATED
      IF ( NXC+NYC+NZC.EQ.0 ) GO TO 330
      IF ( L(1,2).EQ.15.AND.I.EQ.IJ+1 ) GO TO 324
  321 IF ( NXC.EQ.0 ) GO TO 322
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
  322 IF ( NYC.EQ.0 ) GO TO 323
      IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
  323 IF ( NZC.EQ.0 ) GO TO 325
      IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
      GO TO 325
  324 L(1,2) = 30
      NIJ = ICO(6,1)
      NIJ = NDAT(NIJ+4)
      NJX = MOD(NIJ+NXC,4)
      NCONT(IJ) = IAND(NCONT(IJ),2035)+NDAT(NJX+4)*4
      NCONT(IJ) = IAND(NCONT(IJ),1855)+NDAT(NIJ+4)*64
      GO TO 321
  325 CONTINUE
      ICO(4,NCI) = 0
      ICO(4,NCK) = 0
      ICO(5,NCK) = 0
      ICO(5,NCI) = 0
      ICO(6,NCI) = 0
      ICO(6,NCK) = 0
  330 CONTINUE
      ICO4 = MOD(NCONT(I)/4  ,4)
      IKO4 = MOD(NCONT(K)/4  ,4)
      ICO5 = MOD(NCONT(I)/64 ,4)
      IKO5 = MOD(NCONT(K)/64 ,4)
      ICO6 = MOD(NCONT(I)/512,4)
      IKO6 = MOD(NCONT(K)/512,4)
      NI4 = NDAT(ICO4+4)
      NK4 = NDAT(IKO4+4)
      NI5 = NDAT(ICO5+4)
      NK5 = NDAT(IKO5+4)
      NI6 = NDAT(ICO6+4)
      NK6 = NDAT(IKO6+4)
      IF ( MJ.GT.J ) GO TO 390
      DO 380 M=MJ,J
      NCM = M-IJ+1
      MCO4 = MOD(ICO(4,NCM),4)
      MCO5 = MOD(ICO(5,NCM),4)
      MCO6 = MOD(ICO(6,NCM),4)
      NM4 = NDAT(MCO4+4)
      NM5 = NDAT(MCO5+4)
      NM6 = NDAT(MCO6+4)
      LOD1 = LODGDF(LOD,NCONT(M))
      NXC = MOD( NI4+NK4+NM4,4)
      NYC = MOD( NI5+NK5+NM5,4)
      NZC = MOD( NI6+NK6+NM6,4)
      IF ( LOD1.NE.290 ) GO TO 350
       IF  ( L(1,2).EQ.11 ) GO TO 334
      IF ( NXC+NYC+NZC.EQ.0 ) GO TO 380
      IF ( IJ.EQ.1 ) GO TO 331
      IF(NXC + NYC .EQ.0 )GO TO 333
      IF ( L(1,3).EQ.14 ) GO TO 331
      IF ( L(1,2).EQ.15 ) GO TO 331
      IF ( L(1,2).EQ.14 ) GO TO 331
      IF ( L(1,2).EQ.17 ) GO TO 331
      IF ( L(1,2)+L(1,3)+L(1,4).LT.18.AND.L(1,2).NE.9 ) GO TO 331
      NXC = MOD(NCONT(1)/2  +NXC,4)
      NYC = MOD(NCONT(1)/32 +NYC,4)
      NZC = MOD(NCONT(1)/256+NZC,4)
  331 CONTINUE
      IF ( NXC.EQ.0 ) GO TO 332
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
      IF ( ICO(4,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NXC)*4
  332 IF ( NYC.EQ.0 ) GO TO 333
      IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
      IF ( ICO(5,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NYC)*64
  333 IF ( NZC.EQ.0 ) GO TO 335
      IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
      IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
      GO TO 335
  334 NCONT(I) = IAND(NCONT(I),2035)
      NCONT(K) = IAND(NCONT(K),1855)
      NCONT(M) = IAND(NCONT(M),511)
  335 ICO(4,NCI) = 0
      ICO(5,NCI) = 0
      ICO(6,NCI) = 0
      ICO(4,NCK) = 0
      ICO(5,NCK) = 0
      ICO(6,NCK) = 0
      ICO(4,NCM) = 0
      ICO(5,NCM) = 0
      ICO(6,NCM) = 0
      GO TO 380
  350 IF ( LOD1.NE.0 ) GO TO 380
      IF ( NXC+NYC+NZC.EQ.0 ) GO TO 359
      IF ( L(1,2).EQ.30 ) GO TO 3500
      IF ( L(1,2).EQ.15 ) GO TO 355
      IF (  L (1,2).EQ.17 ) GO TO 359
      IF (  L (1,2).EQ.13 ) GO TO 351
      IF (  L (1,3).EQ.13 ) GO TO 352
      IF (  L (1,4).EQ.13 ) GO TO 353
      GO TO 500
 3500 IF ( NXC.EQ.0 ) GO TO 359
      IF ( L(4,2).EQ.4 ) GO TO 359
      IF ( NXC.EQ.NK4 ) GO TO 359
      NCONT(K) = IOR(NCONT(K),NDAT(NXC)*4)
      IF ( L(1,4).EQ.13.AND.L(2,4).EQ.0 ) GO TO 3580
      GO TO 359
  351 NYC = MOD( NK5+ NM5,4)
      NZC = MOD( NK6+ NM6,4)
      IF (  L (1,3).EQ.13 ) GO TO 354
      IF (  L (1,3).EQ.14 ) GO TO 354
      IF (  L (1,4).EQ.13 ) GO TO 354
      M2 = I+1
      IF(L(2,2).EQ.12.AND.(L(1,3).EQ.9 .OR.L(1,4).EQ.9))  GO TO 360
      IF ( NYC.LE.0 ) GO TO 3510
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
      IF ( ICO(5,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NYC)*64
 3510 IF ( NZC.LE.0 ) GO TO 360
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
      IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
      GO TO 360
  352 NXC = MOD( NI4+ NM4,4)
      NZC = MOD( NI6+ NM6,4)
      M2 = K+1
      IF(L(2,3).EQ.12 .AND.(L(1,2).EQ.9 .OR. L(1,4).EQ.9)) GO TO 360
      IF ( NXC.LE.0 ) GO TO 3520
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NXC)*4
 3520 IF ( NZC.LE.0 ) GO TO 360
      IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
      IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
      GO TO 360
  353 NXC = MOD( NI4+ NK4,4)
      NYC = MOD( NI5+ NK5,4)
      IF(L(2,4).EQ.12 .AND. ( L(1,2).EQ.9.OR.L(1,3).EQ.9)) GO TO 359
      IF ( NXC.LE.0 ) GO TO 3530
      IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
      IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
 3530 IF ( NYC.LE.0 ) GO TO 359
      IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
      IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
      GO TO 359
  354 IF ( NYC.LE.0 ) GO TO 3540
      IF ( IABS(L(2,2)-13).EQ.1 ) NCONT(I)=NCONT(I)+NDAT(NYC)*64
 3540 IF ( NZC.LE.0 ) GO TO 3541
      IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
 3541 IF ( NXC.LE.0 ) GO TO 359
      IF ( L(1,4).EQ.0.OR.L(1,3).EQ.14 ) GO TO 359
      IF ( L(2,4).NE.12 ) NCONT(K)=NCONT(K)+NDAT(NXC)*4
      GO TO 359
  355 L(1,2) = 30
      IF ( L(1,3).EQ.14 ) GO TO 370
      IF ( L(1,3).EQ.13.AND.L(2,3).EQ.12 ) GO TO 3561
      IF ( L(1,1).EQ. 7.AND.L(2,2).EQ.12 ) GO TO 357
      IF ( L(1,1).EQ. 7.AND.L(2,2).EQ.14 ) GO TO 357
      IF ( L(1,1).EQ. 6.AND.L(2,2).EQ.12 ) GO TO 358
      IF ( L(1,1).EQ. 6.AND.L(2,2).EQ.14 ) GO TO 358
      IF ( L(1,1).EQ.7.AND.L(1,3).EQ.13 ) GO TO 3581
      IF ( MOD(NCONT(I),1024).EQ.19 ) GO TO 350
      IF ( NXC+NYC.GT.0 ) GO TO 356
      IF ( NZC.NE.NM6 ) GO TO 359
      IF ( NZC.LE.0 ) GO TO 359
      NCONT(K) = NCONT(K)+NDAT(NZC)*512
      GO TO 359
  356 IF ( L(3,2).EQ.10.OR.L(4,2).EQ.10 ) GO TO 359
      IF ( L(1,3).NE.10 ) GO TO 359
 3561 IF ( L(2,2).EQ.3 ) GO TO 3560
      NCONT(I) = IOR(NCONT(I),68)
      GO TO 3580
 3560 IF ( L(1,4).EQ.2 ) NCONT(K)=IOR(NCONT(K),512)
      GO TO 359
  357 NCONT(I) = NCONT(I)+64
      IF ( L(3,2).NE.19 ) NCONT(I+1) = NCONT(I+1)-512
      IF ( L(1,4).EQ.11.AND.L(3,2).EQ.19 )NCONT(I) = NCONT(I)+588
      GO TO 3580
  358 NCONT(I) = NCONT(I)+136
 3580 IF ( L(1,3).NE.13 ) GO TO 359
 3581 M2 = K+1
      GO TO 360
  359 M2 = M+1
  360 CONTINUE
      IF ( M2.GT.J ) GO TO 306
      DO 365 M1=M2,J
      NCONT(M1-1) = NCONT(M1)
      DO 365 M3=1,6
  365 ICO(M3,M1-1) = ICO(M3,M1)
      GO TO 306
  370 IF ( L(1,4).GT.12 ) GO TO 371
      M2 = I+1
      GO TO 360
  371  CONTINUE
      L(1,2) = 13
      IF ( L(2,2).EQ.12.AND.L(1,1).EQ.5 ) NCONT(I) = NCONT(I)+200
      IF ( L(2,2).EQ.12.AND.L(1,1).EQ.6 ) NCONT(I) = NCONT(I)+136
      IF ( L(2,2).EQ.12.AND.L(1,1).EQ.7 ) NCONT(I) = NCONT(I)+652
      IF ( L(2,2).EQ.13 )                 NCONT(I) = NCONT(I)+68
      IF ( L(2,2).EQ.14 )                 NCONT(I) = NCONT(I)+140
      GO TO 359
  380 CONTINUE
  390 CONTINUE
  400 CONTINUE
      LD = 0
      DO 405 I=1,J
  405 LD = LODGDF(LD,NCONT(I))
      IF ( LD.NE.0 ) GO TO 410
      NCONT(J-1) = NCONT(J)
      J = J-1
  410 CONTINUE
      NCONT(J+1) = 0
  450 RETURN
  500 WRITE(6,2) SPGC
      NSP(2) = 4
      GO TO 450
      END

      SUBROUTINE OP1
C
      INTEGER EXOR
      COMMON/SPG/ SPGC(20),NSP(2),NCONT(10),NC,NPOL,MULT
      COMMON/CRYDAT/ JUNK(1733),NCTR(192)
      COMMON/HKLCTL/ KH(3,24),DHKL(24),KHCO(10,7),IC,N1,IER,HM
C
      K = 2
      NPOL = 7
      DO 40 I=1,7
   40 KHCO(1,I) = 0
      NCTR(1) = 0
      DO 100 I=1,8
      IF ( NCONT(I).LE.0 ) GO TO 101
      IF ( NCONT(I).LT.8192 ) GO TO 80
      IF ( NCONT(I).LE.08192 ) GO TO 60
      IF ( NCONT(I).EQ.16384 ) GO TO 70
      NPOL = 4
      KHCO(I,1) = 2
   50 DO 51 J=2,7
   51 KHCO(I,J) = 0
      KHCO(I,6) = MOD(NCONT(I)/4,32)
      GO TO 90
   60 KHCO (I,1) = 3
      NPOL = 1
      GO TO 50
   70 KHCO(I,1) = 1
      GO TO 50
   80 KHCO(I,1) = 0
      KHCO(I,2) = MOD(NCONT(I),4)
      KHCO(I,3) = MOD(NCONT(I)/4,4)
      KHCO(I,4) = MOD(NCONT(I)/16,4)
      KHCO(I,5) = MOD(NCONT(I)/64,4)
      KHCO(I,6) = MOD(NCONT(I)/256,2)
      KHCO(I,7) = MOD(NCONT(I)/512,16)
   90 CONTINUE
      L = K-1
      DO 100 J=1,L
      IF ( NCONT(I).EQ.8192 ) GO TO 95
      NCTR(K) = IAND(EXOR(NCONT(I),NCTR (J )),57651)
      IF (IAND(NCONT(I),17).EQ.0) GO TO 92
      IF (IAND(NCTR(J),34).EQ.0) GO TO 92
      IF (IAND(NCTR(J),34).EQ.34) GO TO 92
      NCTR(K)=EXOR(NCTR(K),34)
   92 CONTINUE
      K = K+1
      IF ( NCONT(I).LT.8192 ) GO TO 100
      NCTR(K) = NCTR(K-1)+32768
      K = K+1
      GO TO 100
   95 CONTINUE
      NCTR(K  ) = 0
      NCTR(K+1) = 0
      K = K+2
  100 CONTINUE
  101 MULT = K-1
      N1 = I-1
      IF ( N1.LT.2 ) GO TO 105
      DO 102 N2=2,N1
      IF ( KHCO(N2-1,1).EQ.1 ) GO TO 103
  102 CONTINUE
      GO TO 105
  103 DO 104 I=N2,N1
      DO 104 J=1,7
  104 KHCO(I-1,J) = KHCO(I,J)
      KHCO(N1,1) = 1
  105 CONTINUE
      NC = 1
      DO 200 I=1,MULT
      IF ( EXOR(NCTR(I),290).EQ.0 ) NC = 0
      IF ( IAND(NCTR(I),3).GT.0 ) NPOL = IAND(NPOL,6)
      IF ( IAND(NCTR(I),48).GT.0 ) NPOL = IAND(NPOL,5)
  200 IF ( IAND(NCTR(I),256).GT.0 ) NPOL = IAND(NPOL,3)
      RETURN
      END

      SUBROUTINE SMTRY2
C
      INTEGER EXOR
      COMMON/HKLCTL/ KH(3,24),DHKL(24),KHCO(10,7),IC,N1,IER,HM
      COMMON/SPG/ SPGC(20),NSP(2),NCONT(10),NC,NPOL,MULT
      COMMON /CNTRLS/ JC(20)
      DIMENSION KD(6),KE(3),KF(3)
      DIMENSION NCH(24),NCK(24),NCL(24)
      DIMENSION LD(3,24)
      INTEGER*4 IPH(24)
      DATA KD,KE,KF/0,6,3,9,4,8,0,4,8,0,8,4/
C
      IF ( NC.GT.0 ) GO TO 14
      IF ( KH(1,1) ) 11,9,14
    9 IF ( KH(2,1) ) 12,10,14
   10 IF ( KH(3,1) ) 13,14,14
   11 KH(1,1) = -KH(1,1)
   12 KH(2,1) = -KH(2,1)
   13 KH(3,1) = -KH(3,1)
   14 CONTINUE
      IPH(1) = KH(3,1)+512*(KH(2,1)+512*KH(1,1))
      CI = 1.0
      IC = 1
      DHKL(1) = 0.0
      LD(1,1) = 0
      LD(2,1) = 0
      LD(3,1) = 0
      NCH(1) = 0
      NCK(1) = 0
      NCL(1) = 1
      IF ( N1.EQ.0 ) GO TO 1000
      L = 2
      DO 900 I=1,N1
      CI = CI*2.0
      IF ( KHCO(I,1).GT.0 ) CI = CI*1.5
      DO 890 J=1,IC
      NCO = KHCO(I,1)+1
      GO TO (20,700,800,15),NCO
   15 IF(MOD(KH(1,1)-KH(2,1)-KH(3,1),3).NE.0 ) GO TO 1002
      GO TO 900
   20 NCH(L) = EXOR(NCH(J),KHCO(I,2))
      IF ( MOD(KHCO(I,2),2).NE.0 ) NCH(L)=EXOR(NCK(J),KHCO(I,2))
      M = 1+MOD(NCH(L),2)
      MS = 1-2*MOD(NCH(L)/2,2)
      N = IABS(NCL(J))
      KH(M,L) = KH(1,N)*MS
      M = 1+MOD(KHCO(I,2),2)
      MS = 1-2*MOD(KHCO(I,2)/2,2)
      NCX = KHCO(I,3)+1
      LD(1,L) = KD(NCX)+LD(M,J)*MS
      NCK(L) = EXOR(NCK(J),KHCO(I,4))
      IF ( MOD(KHCO(I,4),2).NE.0 ) NCK(L)=EXOR(NCH(J),KHCO(I,4))
      M = 2-MOD(NCK(L),2)
      MS = 1-2*MOD(NCK(L)/2,2)
      KH(M,L) = KH(2,N)*MS
      M = 2-MOD(KHCO(I,4),2)
      MS = 1-2*MOD(KHCO(I,4)/2,2)
      NCX = KHCO(I,5)+1
      LD(2,L) = KD(NCX)+LD(M,J)*MS
      MS = (1-2*KHCO(I,6))*ISIGN(1,NCL(J))
      NCL(L) = MS*NCL(N)
      KH(3,L) = KH(3,N)*MS
   70 NCO = KHCO(I,7)+1
      IF ( NCO.GT.5 ) NCO=6
      MS = 1-2*KHCO(I,6)
      IF ( N.GT.1.AND.NCK(J).GE.4.AND.M.EQ.1 ) MS=-MS
      LD(3,L) = KD(NCO)+LD(3,J)*MS
   80 IXIT = 0
   81 CONTINUE
      IPH(L) = KH(3,L)+512*(KH(2,L)+512*KH(1,L))
   87 LA = LD(1,L)*KH(1,1)+LD(2,L)*KH(2,1)+LD(3,L)*KH(3,1)
      DHKL(L) = FLOAT(LA)/12.0
      IF ( NC.NE.0 ) GO TO 89
      IF ( NSP(1).LT.12 ) GO TO 89
      IF ( KHCO(I,1).GT.0 ) GO TO 89
      IF ( MOD(KHCO(I,2),2).EQ.1 ) GO TO 89
      IF ( IPH(L).LE.0 ) GO TO 680
   89 CONTINUE
      DO 90 M=2,L
      IF ( IPH(M-1).EQ.IPH(L) ) GO TO 690
      IF ( NC.NE.0 ) GO TO 90
      IF ( IPH(M-1).EQ.-IPH(L) ) GO TO 690
   90 CONTINUE
      L = L+1
  680 IF ( IXIT-1 ) 890,750,850
  690 IF ( AMOD(ABS(DHKL(L)-DHKL(M-1)),1.).NE.0. ) GO TO 1002
      GO TO 680
  700 IXIT = 2
      JD = J
  750 IXIT = IXIT-1
      LD(1,L) = LD(1,JD)
      LD(2,L) = LD(2,JD)
      LD(3,L) = LD(3,JD)
      NCH(L) = 0
      NCK(L) = 0
      NCL(L) = L
      K1JD = KH(1,JD)
      KH(1,L) = KH(2,JD)
      KH(2,L) = KH(3,JD)
      KH(3,L) = K1JD
      JD = L
      GO TO 81
  800 IXIT = 4
      JD = J
      NCO = KHCO(I,6)
  850 IXIT = IXIT-2
      NCH(L) = 0
      NCK(L) = 4
      NCL(L) = L
      LD(1,L) = 0
      LD(2,L) = 0
      KH(1,L) = -KH(1,JD)-KH(2,JD)
      KH(2,L) = KH(1,JD)
      KH(3,L) = KH(3,JD)
      LD(3,L) = KF(NCO)+LD(3,JD)
      IF ( MOD(NCH(J),2).NE.0 ) LD(3,L)=KE(NCO)+LD(3,JD)
      JD = L
      GO TO 81
  890 CONTINUE
  900 IC = L-1
 1000 IER = 0
      HM = CI/FLOAT(IC)
      IF ( NC.NE.0 ) GO TO 1001
      DO 1003 M=2,IC
      IF ( IPH(M).GT.0 ) GO TO 1003
      KH(1,M) = -KH(1,M)
      KH(2,M) = -KH(2,M)
      KH(3,M) = -KH(3,M)
 1003 CONTINUE
 1001 RETURN
 1002 IER = 1
      GO TO 1001
      END

      SUBROUTINE PRMTR
C
      REAL*8 TAB
      COMMON /XB/N3P,X(11,100),IXB(100),IF(2,100),G,N12(100)
      COMMON/SYML/ ISYM(100)
      COMMON/CRYDAT/ N,NMAX, IJKLM,Y(192,9),XLT,KXB,NCTR(192)
      COMMON/SPG/ SPGC(20),NSP(2),NCONT(10),NC,NPOL,MULT
      COMMON /SYMTAB/TAB(62)
      DIMENSION IZB(10)
C
C   1 FORMAT (29H0POSITIONS GENERATED FOR ATOM I3,F10.4,I10,10I2/(9F10.5
C    Z,I6))
    1 FORMAT(21H0POSITIONS FOR ATOM: I2,21H, SITE MULTIPLICITY: I2)
    2 FORMAT(/,11H  ----X----,11H  ----Y----,11H  ----Z----,
     +2X,11H  ----X----,11H  ----Y----,11H  ----Z----,//,
     +(X,F10.6,X,F10.6,X,F10.6,3X,F10.6,X,F10.6,X,F10.6))
    4 FORMAT (20I4)
    6 FORMAT (21H0THE SITES TESTED ARE  /
     1 11H0 SEQ. MULT5X1HX9X1HY9X1HZ3X13HSITE SYMMETRY )
    7 FORMAT(2I5,3F10.6,3XA8)
    8 FORMAT (4F10.5)
    9 FORMAT(/,40H ENTER NUMBER OF SITES TO TEST? <0> NONE)
   10 FORMAT(/,26H ENTER X,Y,Z FOR TEST SITE )
   11 FORMAT(I)
C
C  GET NUMBER OF SITES TO EVALUATE
      I = 0
C      WRITE(6,9)
C      READ(5,11) N3P
      IF ( N3P.LE.0 ) GO TO 109
      N3 = N3P
C
C  GET THE TEST SITES
      DO 108 IXP=1,N3P
      I = I+1
C      WRITE(6,10)
C      READ(5,8) (X(L,I),L=1,3)
      BISO = 1.0
      DO 381 L=4,9
  381 X(L,I) = 0.0
  105 CONTINUE
      DO 106 L=1,9
  106 Y(1,L)=X(L,I)
      CALL SYMOPR
      CALL SYMNUM(I)
      IXB(I) = KXB
C
C  WRITE ATOM PLACEMENTS
C     IZB( 1) = MOD(IXB(I)/512    ,8)
C     IZB( 2) = MOD(IXB(I)/64     ,8)
C     IZB( 3) = MOD(IXB(I)/8      ,8)
C     IZB( 4) = MOD(IXB(I)        ,8)
C     IZB( 5) = MOD(IXB(I)/4096   ,8)
C     IZB( 6) = MOD(IXB(I)/32768  ,2)
C     IZB( 7) = MOD(IXB(I)/65536  ,2)
C     IZB( 8) = MOD(IXB(I)/131072 ,4)
C     IZB( 9) = MOD(IXB(I)/524288 ,4)
C     IZB(10) = MOD(IXB(I)/2097152,16)
C     PRINT 1,I,XLT,IXB(I),IZB,((Y(L,N),N=1,3),NCTR(L),L=1,MULT)
C
      X(11,I) = XLT
      DXL = AMOD(X(1,I)-Y(1,1)+10.0,1.0)
      DYL = AMOD(X(2,I)-Y(1,2)+10.0,1.0)
      DZL = AMOD(X(3,I)-Y(1,3)+10.0,1.0)
      IF ( DXL+DYL+DZL.LT..00001 ) GO TO 104
      DO 107 L=1,9
  107 X(L,I) = Y(1,L)
  104 IF ( N12(I).LE.0 ) X(4,I)=BISO
C
C  REMOVE REDUNDANCIES DUE TO SITE MULTIPLICITY
200   IF( MULT .LE. 1 )GO TO 250
      DO 205 ITMP0=2,MULT
      DO 210 ITMP1=1,ITMP0-1
      IF( Y(ITMP1,1) .EQ. 100.0 )GO TO 210
      IF( ABS(Y(ITMP0,1)-Y(ITMP1,1)) .GT. 0.0001 )GO TO 210
      IF( ABS(Y(ITMP0,2)-Y(ITMP1,2)) .GT. 0.0001 )GO TO 210
      IF( ABS(Y(ITMP0,3)-Y(ITMP1,3)) .GT. 0.0001 )GO TO 210
      Y(ITMP1,1) = 100.0
210   CONTINUE
205   CONTINUE
      ITMP0 = 0
      DO 215 ITMP1=1,MULT
      IF( Y(ITMP1,1) .EQ. 100.0 )GO TO 215
      ITMP0 = ITMP0 + 1
      Y(ITMP0,1) = Y(ITMP1,1)
      Y(ITMP0,2) = Y(ITMP1,2)
      Y(ITMP0,3) = Y(ITMP1,3)
215   CONTINUE
      GO TO 255
250   ITMP0 = MULT
255   ITMP=X(11,I)*FLOAT(MULT)+0.001
      WRITE(6,1) I,ITMP
      WRITE(6,2)((Y(L,N),N=1,3),L=1,ITMP0)
  108 CONTINUE
C
C  PRINT THE RESULTS OF THE TEST SITE SYMMETRY
      WRITE(6,6)
      DO 1061 I=1,N3
      I4 = X(11,I)*FLOAT(MULT)+0.001
      ITAB = ISYM(I)
C     WRITE(6,7) I,I4,(X(L,I),L=1,3),TAB(ITAB),IXB(I),IXB(I),ITAB
      WRITE(6,7) I,I4,(X(L,I),L=1,3),TAB(ITAB)
 1061 CONTINUE
  109 CONTINUE
      RETURN
      END
      SUBROUTINE SYMOPR
C
      COMMON/CRYDAT/ N(2),L,X(192),Y(192),Z(192),B11(192),B22(192),
     1 B33(192),B12(192),B13(192),B23(192),XLT,KXB,NCTR(192)
      COMMON/SPG/ SPGC(20),NSP(2),NCONT(10),NC,NPOL,MULT
C
      ISCK = 0
  103 L = 2
      ISRH = 0
      KXB = 0
      XLT = 1.0
      J = 1
      CALL CEL000
      L1=J
      DO 100 I=1,8
      IOP = 0
      IF ( NCONT(I).EQ.0 ) GO TO 104
    1 DO 99 L2=J,L1
      L3=L-1
      IF ( NCONT(I)-8192 ) 4,5,4
    5 X(L)=X(L2)+1.0/3.0
      Y(L)=Y(L2)+2.0/3.0
      Z(L)=Z(L2)+2.0/3.0
      X(L+1)=X(L2)+2.0/3.0
      Y(L+1)=Y(L2)+1.0/3.0
      Z(L+1)=Z(L2)+1.0/3.0
      B11(L)=B11(L2)
      B22(L)=B22(L2)
      B33(L)=B33(L2)
      B12(L)=B12(L2)
      B13(L)=B13(L2)
      B23(L)=B23(L2)
      B11(L+1)=B11(L2)
      B22(L+1)=B22(L2)
      B33(L+1)=B33(L2)
      B12(L+1)=B12(L2)
      B13(L+1)=B13(L2)
      B23(L+1)=B23(L2)
      L=L+1
      CALL CEL000
      L=L+1
      CALL CEL000
      GO TO 6
    4 CALL OPERTR(I,L2)
    6 L5=L
      L6=NCONT(I)
    7 L = L3+1
    8 L4 = 1
      IF ( ABS(X(L)-X(L4))-0.0001 ) 2,2,90
    2 IF ( ABS(Y(L)-Y(L4))-0.0001 ) 3,3,90
    3 IF ( ABS(Z(L)-Z(L4))-0.0001 ) 91,91,90
   91 CONTINUE
      IF ( NCTR(L)-8192 ) 92,94,93
   92 KX = MOD(NCTR(L),4)+1
      KY = MOD(NCTR(L)/16,4)+1
      KZ = MOD(NCTR(L)/256,2)
      IF ( IOP.EQ.0 ) XLT=XLT/2.0
      IOP = 1
      GO TO (920,930,940,950),KX
  920 GO TO (921,1000,922,1000),KY
  921 IF ( KZ.EQ.0 ) GO TO 1000
      KXB = IOR(KXB,2621450)
      GO TO 90
  922 CONTINUE
      IF ( KZ.EQ.0 ) KXB=IOR(KXB,2228292)
      IF ( KZ.EQ.1 ) KXB=IOR(KXB, 655432)
      GO TO 90
  930 KXB = IOR(KXB,32768)
      GO TO (1000,931,1000,932),KY
  931 CONTINUE
      IF ( KZ.EQ.0 ) KXB=IOR(KXB, 4194464)
      IF ( KZ.EQ.1 ) KXB=IOR(KXB,12583048)
      GO TO 90
  932 KXB = IOR(KXB,2753088)
      IF ( KZ.EQ.1 ) KXB = IOR(KXB,8)
      GO TO 90
  940 KXB = IOR(KXB,512)
      GO TO (941,1000,942,1000),KY
  941 KXB = IOR(KXB,131072)
      IF ( KZ.EQ.1 ) GO TO 943
      KXB = IOR(KXB,525312)
      GO TO 90
  942 KXB = IOR(KXB,64)
      IF ( KZ.EQ.1 ) GO TO 944
      KXB = IOR(KXB,2623488)
      GO TO 90
  943 KXB = IOR(KXB,2097152)
  944 KXB = IOR(KXB,8)
      GO TO 90
  950 KXB = IOR(KXB,32768)
      GO TO (1000,951,1000,952),KY
  951 KXB = IOR(KXB,2753088)
      IF ( KZ.EQ.1 ) KXB = IOR(KXB,8)
      GO TO 90
  952 IF ( KZ.EQ.0 ) KXB = IOR(KXB,8388864)
      IF ( KZ.EQ.1 ) KXB=IOR(KXB,4194568)
      GO TO 90
   93 CONTINUE
      IF ( MOD(NCTR(L),16384).EQ.0 ) GO TO 95
      ISRH = 1
      IF ( IAND(307,NCTR(L)-NCONT(I)).EQ.0 ) GO TO 92
      GO TO 90
   94 KXB = IOR(KXB,2916928)
      XLT = XLT/3.0
      GO TO 99
   95 KXB = IOR(KXB,17924240)
      XLT = XLT/3.0
      GO TO 99
   90 CONTINUE
      IF ( L6-8192 ) 99, 98,98
   98 L6=1
      L = L+1
       GO TO 8
   99 L=L5
  100 L1=L-1
  104 CONTINUE
      IF ( ISRH.EQ.0 ) GO TO 200
      IF ( ISCK.GT.1 ) GO TO 2000
      ISCK = ISCK+1
      DO 1010 J=1,I
      IF ( NCONT(J).EQ.16384 ) GO TO 1011
 1010 CONTINUE
      DO 101 L2 = 1,L1
      IF ( ABS(X(L2)-Y(L2)).LE.0.0001 ) GO TO 102
      IF ( ABS(X(L2)+Y(L2)-1.0).LE.0.0002 ) GO TO 102
  101 CONTINUE
      ISCK = 2
      WRITE(6,110) X(1),Y(1),Z(1),XLT
      GO TO 200
 1011 CONTINUE
      WRITE(6,111) X(1),Y(1),Z(1),Y(1),Z(1),X(1)
      IF ( ABS(X(1)-Y(1)).LT.0.0001 ) GO TO 120
      X3 = X(1)
      X(1) = Y(1)
      Y(1) = Z(1)
      Z(1) = X3
      X3 = B11(1)
      B11(1) = B22(1)
      B22(1) = B33(1)
      B33(1) = X3
      GO TO 103
  110 FORMAT (37H0NO X,X,Z OR X,-X,Z SET WAS FOUND FOR4F8.5)
  102 IF ( L2.EQ.1 ) GO TO 120
      WRITE(6,111) X(1),Y(1),Z(1),X(L2),Y(L2),Z(L2)
  111 FORMAT (12H0THE ATOM AT 3F8.5,11H WAS PUT AT3F8.5)
      X(1) = X(L2)
      Y(1) = Y(L2)
      Z(1) =Z(L2)
      B11(1) = B11(L2)
      B22(1) = B22(L2)
      B33(1) = B33(L2)
      B12(1) = B12(L2)
      B13(1) = B13(L2)
      B23(1) = B23(L2)
      GO TO 103
 1000 WRITE(6,112) NCTR(L)
  112 FORMAT (22H0THE SYMMETRY OPERATOR I10,9H IS WRONG)
      STOP 7701
 2000 CONTINUE
      WRITE(6,113) X(1),Y(1),Z(1)
  113 FORMAT (55H0THERE ARE UNRESOLVABLE PROBLEMS WITH THE POSITION SET
     1 3F8.5/59H  ATTEMPTS TO DEFINE THE TRUE SITE SYMMETRY WERE ABANDON
     2ED.)
  120 IF ( ABS(X(1)-Y(1))+ABS(X(1)-Z(1)).LE.0.0002 ) GO TO 200
      DO 130 L2=2,L1
      IF ( ABS(X(L2)-Y(L2))+ABS(X(L2)-Z(L2)).LE.0.0002 ) GO TO 102
  130 CONTINUE
  200 CONTINUE
      KXB = MAX0(IAND(KXB,18874367),IAND(KXB,16777215))
      IF ( IAND(KXB,384).EQ.384 ) KXB=IOR(KXB,512)
      RETURN
      END

      SUBROUTINE CEL000
C
      COMMON/CRYDAT/ N(2),L,X(192),Y(192),Z(192),B11(192),B22(192),
     1 B33(192),B12(192),B13(192),B23(192),XLT,KXB,NCTR(192)
C
      X(L-1) = AMOD(X(L-1)+8.0,1.0)
      IF ( X(L-1)-.99999 ) 2,1,1
    1 X(L-1) = 0.0
    2 Y(L-1) = AMOD(Y(L-1)+8.0,1.0)
      IF ( Y(L-1)-.99999 ) 4,3,3
    3 Y(L-1) = 0.0
    4 Z(L-1) = AMOD(Z(L-1)+8.0,1.0)
      IF ( Z(L-1)-.99999 ) 6,5,5
    5 Z(L-1) = 0.0
    6 RETURN
      END

      SUBROUTINE OPERTR(I,L2)
C
      COMMON/CRYDAT/ N(2),L,X(192),Y(192),Z(192),B11(192),B22(192),
     1 B33(192),B12(192),B13(192),B23(192),XLT,KXB,NCTR(192)
      COMMON/SPG/ SPGC(20),NSP(2),NCONT(10),NC,NPOL,MULT
C
      I1 = MOD(NCONT(I),4)+1
      I2 = MOD(NCONT(I)/4,4)+1
      I3 = MOD(NCONT(I)/16,4)+1
      I4 = MOD(NCONT(I)/64,4)+1
      I5 = MOD(NCONT(I)/256,2)
      I6 = MOD(NCONT(I)/512,4)+1
      I7 = MOD(NCONT(I)/2048,4)+1
      I8 = NCONT(I)/8192+1
      GO TO (100,200,300),I8
  100 GO TO (101,102,103,104),I1
  101 X(L) = X(L2)
      GO TO 1030
  102 X(L) = Y(L2)
      GO TO 1040
  103 X(L) = -X(L2)
 1030 B11(L) = B11(L2)
      B13(L) = B13(L2)*(ABS(FLOAT(I1+I5)-2.5)-1.0)*2.0
      GO TO 105
  104 X(L) = -Y(L2)
 1040 B11(L) = B22(L2)
      B13(L) = B23(L2)*(ABS(FLOAT(I1+I5)-3.5)-1.0)*2.0
  105 GO TO (110,107,108,106),I2
  106 X(L) = X(L)+0.25
  107 X(L) = X(L)+0.25
  108 X(L) = X(L)+0.25
  110 GO TO (111,112,113,114),I3
  111 Y(L) = Y(L2)
      GO TO 1130
  112 Y(L) = X(L2)
      GO TO 1140
  113 Y(L) = -Y(L2)
 1130 B22(L) = B22(L2)
      B12(L) = B12(L2)*FLOAT(MOD(I1+I3,4)-1)
      B23(L) = B23(L2)*(ABS(FLOAT(I3+I5)-2.5)-1.0)*2.0
      GO TO 115
  114 Y(L) = -X(L2)
 1140 B22(L) = B11(L2)
      B23(L) = B13(L2)*(ABS(FLOAT(I3+I5)-3.5)-1.0)*2.0
      B12(L) = B12(L2)*FLOAT(MOD(I1+I3-2,4)-1)
  115 GO TO (120,117,118,116),I4
  116 Y(L) = Y(L)+0.25
  117 Y(L) = Y(L)+0.25
  118 Y(L) = Y(L)+0.25
  120 Z(L) = Z(L2)*FLOAT(1-2*I5)
      B33(L) = B33(L2)
      GO TO (125,122,123,121),I6
  121 Z(L) = Z(L)+0.25
  122 Z(L) = Z(L)+0.25
  123 Z(L) = Z(L)+0.25
  125 GO TO (130,127,126),I7
  126 Z(L) = Z(L)+0.333333333
  127 Z(L) = Z(L)+0.333333333
  130 L = L+1
      CALL CEL000
      RETURN
  200 X(L) = -Y(L2)
      Y(L) = X(L2)-Y(L2)
      Z(L) = Z(L2)+0.333333333*FLOAT(I2-2)
      B11(L) = B22(L2)
      B22(L) = B11(L2)+B22(L2)-B12(L2)
      B33(L) = B33(L2)
      B12(L) = 2.0*B22(L2 )-B12(L2 )
      B13(L) = -B23(L2)
      B23(L) = B13(L2)-B23(L2)
      L = L+1
      CALL CEL000
      X(L) = -Y(L-1)
      Y(L) = -X(L2)
      Z(L) = Z(L2)-0.333333333*FLOAT(I2-2)
      B11(L) = B22(L-1)
      B22(L) = B11(L-1)+B22(L-1)-B12(L-1)
      B33(L) = B33(L-1)
      B12(L) = 2.0*B22(L-1)-B12(L-1)
      B13(L) = -B23(L-1)
      B23(L) = B13(L-1)-B23(L-1)
      GO TO 130
  300 I1 = L2
  301 X(L) = Z(I1)
      Y(L) = X(I1)
      Z(L) = Y(I1)
      B11(L) = B33(I1)
      B22(L) = B11(I1)
      B33(L) = B22(I1)
      B12(L) = B13(I1)
      B13(L) = B23(I1)
      B23(L) = B12(I1)
      IF ( I1-L2 ) 302,302,130
  302 I1 = L
      L = L+1
      CALL CEL000
      GO TO 301
      END

      SUBROUTINE SYMNUM(J)
C
      REAL*8 TAB
      COMMON /SYML/ ISYM(100)
      COMMON/CRYDAT/ NNMAX(3),Y(192,9),XLT,KXB,NCTR(192)
      COMMON /SYMTAB/TAB(62)
      DIMENSION K(62)
      DATA TAB/8H 1      ,8H 1BAR   ,8H 1 2 1  ,8H 2 1 1  ,8H 1 1 2  ,
     18H M 1 1  ,8H 1 1 M  ,8H 1 M 1  ,8H 1 2/M 1,8H 2/M 1 1,8H 1 1 2/M,
     28H 2 2 2  ,8H 2 M M  ,8H M 2 M  ,8H M M 2  ,8H M M M  ,8H 3BAR   ,
     38H 3 2    ,8H MMM(+-),8H 4BAR   ,8H 3      ,8H 2(-)   ,8H 2 3    ,
     48H 6/M    ,8H 6 2    ,8H 3 1 2  ,8H 6BAR   ,8H 6      ,8H 222(+-),
     58H 3      ,8H 2(+)   ,8H 6 2    ,8H 4B M 2 ,8H 2/M(+) ,8H M(+)   ,
     68H M(-)   ,8H MM2(+-),8H 4      ,8H 4B 2 M ,8H 4/M M M,8H 4 M M  ,
     78H 4 2 2  ,8H 4/M    ,8H 2/M(-) ,8H 3B M 1 ,8H 3 M 1  ,8H 3B 1 M ,
     88H 3 1 M  ,8H 3 2 1  ,8H 6/M M M,8H 6 M M  ,8H 6B M 2 ,8H 6B 2 M ,
     98H 3BAR   ,8H M 3 M  ,8H 4 3 2  ,8H 3 M    ,8H 3B M   ,8H M 3    ,
     A8H M2M(+) ,8H M2M(-) ,8H 4B 3 M /
      DATA K/ 0,     584, 2228744,  655432, 2624064,  656896, 2621450,
     1  2228292, 2228812,  656968, 2624074, 2755144, 2752590, 2754058,
     2  2756164, 2756174,17924824,17925016,15240170, 2787912,17924240,
     3  4227336,18582232, 2918986,15502280, 7111496, 2916938, 2918976,
     4 15240136, 2916928,12615816, 2919368,15372236,12616648, 4227232,
     5  8421632,15240160, 2787904,15371240,15372270,15372260,15371208,
     6  2787914, 4228072,15500232,11305792, 7111656, 7111392,15499976,
     7 15502314,15502304,15500106,15500010, 2916936,18583550,18582488,
     8 17924272,17925112,18583262,15237290,
     9 15237386,18582520/
C
      DO 100 I=1,62
      IF ( KXB.EQ.K(I) ) GO TO 110
  100 CONTINUE
      I = 65
  110 CONTINUE
      ISYM(J) = I
      RETURN
      END
