C*********************************************************************
C
C LEAST SQUARES UNIT CELL REFINEMENT INCLUDING INDEXING IN FORTRAN 77
C
C  ORIGINALY FROM THE GEOLOGICAL SURVEY BY APPLEMAN, HANDWERKER AND
C  EVANS
C
C  MODIFIED AT NBS BY
C
C  C. R. HUBBARD AND S. LEDDERMAN     SUMMER 1982
C
C************************************************************************
      PARAMETER (MAXOBS=200, MAXGEN=1000)
C      MAXOBS=200
C      MAXGEN=1000
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/ALL/N,NUMCYC,FAC
      COMMON /ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NEXTN,IOPKS
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/JA
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CBLKG/IHEAD
      COMMON/BLKJ/TOLMN , TOLMX, SEMULT
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CCONTR/ ID0
      COMMON/SWFG/R
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/EDITR/IED1(6)
      COMMON/UNQ/ IFA,IFB,IFC,IRH
      COMMON/LSQRD/CARD,ITEST
      COMMON/CCREAD/ICRYST
      COMMON/RDGOOD/RGOOD,SYSEXT
      COMMON/IERRS/ IWARN,IERR
          COMMON/CRYDAT/CELL(6),SDCELL(6)
      COMMON/CRYDA1/CRSYS,SPGRP
      COMMON/PEAKS/NPKS,NPKMX,NPFLG(6,250),PKPRM( 3,250),NPKSQ(250),
     * IHKLPF(3,250)
          COMMON/PKFIL/NAME,TITLE
C
          CHARACTER* 1 CRSYS
          CHARACTER* 8 SPGRP
      CHARACTER* 6 NAME
      CHARACTER*80 TITLE
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF,ITEST, IALF12, JA,ICOND(10)
      CHARACTER*5 CSC,ICRYST
      CHARACTER*3 ICLASS(10)
      CHARACTER*68 IHEAD
      CHARACTER*80 CARD
      CHARACTER*8 ISGC
      CHARACTER*1 IED1,IBLANK,ICENT
      DIMENSION JCLASS(27),JCOND(27),XO(3)
      LOGICAL GOOD,RGOOD,SYSEXT,DONE
      REAL TEMP(3)
      DATA (ICLASS(L),L=1,10)/'HKL','HHL','0KL','H0L','HK0','HH0','H00',
     * '0K0','00L','HLL'/,(ICOND(L),L=1,10)/'   H+K','   H+L','   K+L',
     * ' H+K+L','-H+K+L','     H','     K','     L','  2H+L','  H+2L'/,
     * (JCLASS(L),L=1,27)/6*1,4*2,3*3,3*4,3*5,6,7,8,9,4*10/,(JCOND(L),
     * L=1,27)/1,2,3,0,4,5,6,8,2,9,7,8,3,6,8,2,6,7,1,6,6,7,8,6,8,2,10/
      DATA IBLANK/' '/
	DATA IALF/'TITLE ','PARAM ','SYSEXT','D     ','FINISH',
     1 '2-    ','      ',' R    ','xxxxxx','DEMAND','PKFILE','yyyyyy',
     2 'zzzzzz'/
	DATA CSC/'CUBIC','TETRA','ORTHO','MONOC','RHOMB','TRICL',
     1  'HEXAG','HEXAR'/
	DATA NTIN,NTOUT,NEXTN,IOPKS/5,6,20,30/
	DATA ITCRS/'A','M','O','T','H','R','C',' '/
	DATA ITSG /'P','A','B','C','F','I','R'/
	DATA ITED /' ','a','b','c'/
	DATA ITIH /'d','e','f','g','h','i','j'/
	DATA IFI/12*0,1,0,1,0,1,0,1,0,4,0,4,0,4,0,5,0,5,0,5,0,6,0,6,0,6,0,
     1 1,6,5,6,4,6,4,5,2,0,2,0,2,0,2,0/
	DATA IFJ/1,0,0,2,0,0,3,0,0,1,2,3,4,0,0,5,0,0,6,0,0,8,0,0,2,0,0,
     1           9,0,0,7,0,0,8,0,0,3,0,0,6,0,0,8,0,0,2,0,0,6,0,0,7,0,0,
     1           1,0,0,6,0,0,6,0,0,7,0,0,8,0,0,6,0,0,8,0,0,2,0,0,10,0,0/
	DATA IHKL/1,0,1,1,0,0,-1,1,0,0,1,0,0,-1,-1,0,0,1/
	DATA JHKL/1,1,0,1,-1,1,0,0,2,1,1,0,3*1,0,1,4*0,4*1,0,0,1,1,2/
C
C-----INITIALIZE
C
          INPK=0
      IDOLSQ = 1
      NERRT=0
      DO 8 I = 1, 200, 1
      INT(I) = 0
      INTED(I) = IBLANK
 8    CONTINUE
      R = 180.00/3.14154265
      DO 9 I = 1, 7, 1
      ERRI(I) = 0.0
 9    CONTINUE
      IJOB = 1
      ID0 = IBLANK
 10   CONTINUE
	NTOUT = 6
      WRITE(NTOUT,16)
   16 FORMAT(1H1,5X,'***NBS-JCPDS-Alfred version of Geological',
     *' Survey lattice',
     * ' parameter least squares**'/' ', 15x, 'Version for VAX', 10x,
     * '1 Jan 1984'//)
      WRITE (NTOUT, 11)
 11   FORMAT (' Determine input mode by typing one of the following:'/
     *' DEMAND for interactive execution'/
     *' TITLE for batch file input as set up by SULSQ'/
     *' PKFILE for input of a DIFFRAC d-I file (not yet implemented)'/
     *' FINISH to terminate the program  (USE CAPITALS ONLY)'//
     *'$Enter code (default = DEMAND): ')
 1100 CONTINUE
C
C-----INITIALIZE FOR EACH SET
C
      DO 1102 I = 1, 200, 1
      IHED(I) = IBLANK
 1102 CONTINUE
      IED1(2) = IBLANK
      SPGI = IBLANK
      SPGIN= IBLANK
      SPGIA= IBLANK
      IERR = 0
      IWARN= 0
C
C-----READ CARD INTO BUFFER
C
      READ (NTIN, 1105) ITEST, CARD
 1105 FORMAT (A6, A72)
	if(itest .eq. '      ')itest = 'DEMAND'
C
C-----CHECK IF DEMAND RUN
C
 1110 CONTINUE
      IF (ITEST .NE. IALF(10)) GO TO 1150
C
C-----DEMAND MODE RUN, CALL DMREAD
C
      CALL DMREAD
      GOTO 1500
C
C-----CHECK IF BATCH RUN
C
1150  IF (ITEST .NE. IALF(1)) GO TO 1200
C
C-----BATCH TYPE RUN
C
      CALL BHREAD
      GO TO 1500
C
C-----CHECK IF PKS RUN (NOT IMPLEMENTED)
C
1200  IF (ITEST .NE. IALF(11)) GO TO 1250
      CALL PKREAD
          INPK=1
      GO TO 1501
C
C-----CHECK IF FINISH
C
 1250 CONTINUE
      IF (ITEST .NE. IALF(5)) GO TO 1350
      WRITE (NTOUT, 1260)
 1260 FORMAT ('0', 'Job done')
      GO TO 990
C
C-----ILLEGAL CARD TO START SET
C
 1350 CONTINUE
      WRITE (NTOUT, 1360) IALF(1), IALF(10), IALF(11), ITEST
 1360 FORMAT (' ', '**ERROR** First card read of set should be ''',
     * A6, ''' or ''', A6, ''' or ''', A6, ''' not ''', A6, 1H')
C
C-----SEARCH FOR BATCH, DEMAND, PKS, OR END CARD
C
 1370 CONTINUE
      READ (NTIN, 1105) ITEST, CARD
      IF ((ITEST .EQ. IALF(1)) .OR. (ITEST .EQ. IALF(10))
     * .OR. (ITEST .EQ. IALF(11)) .OR. (ITEST .EQ. IALF(5))) GO TO 1110
      GO TO 1370
C
C-----START PROCESSING SET
C
 1500 CONTINUE
C
C-----CHECK IF DATA READ WAS GOOD, IF NOT START NEW SET
C
      IF (.NOT. (RGOOD)) GO TO 10
      WRITE (NTOUT, 455) IHEAD
 455   FORMAT ('0' / '0', 'Title of set: ', A68 //)
      WRITE (NTOUT, 475) ICRYST
 475  FORMAT (' ', 'Crystal system = ', A5 / )
      IF(.NOT.SYSEXT) WRITE (NTOUT, 465) SPGI
 465  FORMAT (' ', 'Space group = ', A8)
C
C-----OPEN NEXTN FILE IF NECESSARY
C
 1501 IF (.NOT. (SYSEXT)) OPEN (UNIT = NEXTN, ERR = 900,
     * FILE = 'POWD:[PUBLIC.EXE.LSQ]NBSLSQ.EXT', 
     1 STATUS = 'OLD',READONLY)
 25   IF (ICRYST .EQ. CSC(1)) ICRS = ITCRS(7)
      IF (ICRYST .EQ. CSC(2)) ICRS = ITCRS(4)
      IF (ICRYST .EQ. CSC(3)) ICRS = ITCRS(3)
      IF (ICRYST .EQ. CSC(4)) ICRS = ITCRS(2)
      IF (ICRYST .EQ. CSC(5)) THEN
         ICRS = ITCRS(6)
         IRH  = 0
      END IF
      IF (ICRYST .EQ. CSC(6)) ICRS = ITCRS(1)
      IF (ICRYST .EQ. CSC(7)) ICRS = ITCRS(5)
      IF (ICRYST .EQ. CSC(8)) THEN
         ICRS = ITCRS(6)
         IRH = 1
      END IF
      CALL PRMCHK(ICRS,N,ITYP,JTYP)
      IF (SYSEXT) GO TO 21
C
C-----IF RHOMBOHEDRAL SYSTEM ON RHOMBOHEDRAL AXES THEN EXTINCTIONS MUST
C-----BE INPUT EXPLICITLY WITH SYSEXT CARD
C
C     IF(ICRYST.EQ.CSC(5)) THEN
C        WRITE(NTOUT,26)
      IF(ICRYST.NE.CSC(5)) GO TO 5000
      IF(ICRYST.EQ.CSC(5)) WRITE(NTOUT,26)
26    FORMAT('0','**WARNING** Extinction conditions for rhombohedral',
     *   ' lattice not in file **WARNING**'/ ' ',11X,
     *   'you may wish to explicitly input them using SYSEXT card')
         GOTO 21
C     END IF
5000  CALL CHKSPG
      IPASS = 1
      ISGC = SPGI
      CALL SPG(ISGC, IPASS)
C
C-----TEST THAT THE INPUT SPACE GROUP WAS IN THE FILE FROM NBS*AIDS80
C
C     IF(SPGIN.EQ.'  0 ') THEN
C        WRITE(NTOUT,27) SPGI
      IF(SPGIN.EQ.'  0 ') WRITE(NTOUT,27)SPGI
27    FORMAT('0','**WARNING** Input space group "',A8,'" was not in'
     *   ' the file **WARNING**')
         IWARN=IWARN+1
C     END IF
      CALL FINDEX
 21   CONTINUE
      CALL OPSET
      CALL HKLES
 20   AI = AO(1)
      BI = AO(2)
      CI = AO(3)
      ALPHI = IDG(1) + FMN(1) / 60.0
      BETI = IDG(2) + FMN(2) / 60.0
      GAMI = IDG(3) + FMN(3) / 60.0
      CALL CELLCK(GOOD)
      IF (.NOT. GOOD) GO TO 10
C
C-----RESET ANY CHANGES MADE BY CELLCK
C
      AO(1) = AI
      AO(2) = BI
      AO(3) = CI
      IDG(1) = IFIX(ALPHI)
      FMN(1) = 60.0 * (ALPHI - IDG(1))
      IDG(2) = IFIX (BETI)
      FMN(2) = 60.0 * (BETI - IDG(2))
      IDG(3) = IFIX (GAMI)
      FMN(3) = 60.0 * (GAMI - IDG(3))
      SUM=0.0
      DO 35 L=1,3
      IF (AO(L).LE.0.0) GO TO 40
      ALO(L)=FLOAT(IDG(L))*60.0+FMN(L)
      IF (ALO(L).LE.0.0.OR.ALO(L).GE.10800.0) GO TO 40
   35 SUM=SUM+ALO(L)
      IF (SUM.LT.21600.0) GO TO 45
   40 WRITE(NTOUT,41) (AO(L),L=1,3),(IDG(L),FMN(L),L=1,3)
   41 FORMAT('0', '**ERROR** Given parameters in error',3F11.5,2X,3(I6,
     * F7.3), ' set skipped')
      GO TO 10
 45   IALF12=IALF(ITHT+6)
      IMN=((N+3)*N)/2
      DO 55 L=1,3
      AD(L)=AO(L)
      ALS(L)=ALO(L)
      ARAD=0.00029088821*ALO(L)
      CSA(L)=COS(ARAD)
   55 SNA(L)=SIN(ARAD)
      CALL RSCMP
      DO 60 L=1,3
      UO(L)=U(L)
   60 XO(L)=X(L)
      VRO=VR
      VCO=VC
      WRITE(NTOUT,122)
  122 FORMAT(1H0,24X,1Ha,15X,1Hb,15X,1Hc,13X,5Halpha,7X,4Hbeta,8X,
     * 5Hgamma,10X,6Hvolume)
      DO 6 I=1,3
      AR(I)=3437.7468*(1.5707963-ATAN2(U(I),SQRT(1.0-U(I)**2)))
      TEMP(I) = AR(I) / 60.0
 6    CONTINUE
      WRITE(NTOUT,64) (X(I),I=1,3),(TEMP(I),I=1,3),VR
   64 FORMAT(16H Reciprocal cell,1X,3E16.8,3X,3(F9.5,3X),3X,E13.6)
      DO 5  L=1,3
      TEMP(L) = ALS(L) / 60.0
 5    CONTINUE
      WRITE(NTOUT,7) (AD(L),L=1,3),(TEMP(L),L=1,3),VC
 7    FORMAT (' ', 'direct cell', 5X, 3(F11.6, 5X), 3X, 3(F9.5,3X),
     * 3X, E13.6)
      CALL SORT
      IF(NUMOBS.EQ.0) GOTO 42
C
C-----CALC THEMX AND DMIN
C-----ADD 0.5 DEG THETA TO OBSTH(MAX) TO ASSURE THAT ALL HKL ARE GENERAT
C
      THEMO =OBSTH(NUMOBS)+0.5
      THEMX =AMAX1(THEMX,THEMO)
   42 IF(THEMX.LT.0.01 .OR. THEMX.GT.90.0) THEMX=89.0
      DMIN = 0.5*PWL/SIN(THEMX/57.296)
C
C-----CALCULATE THE APPROXIMATE NUMBER OF REFLECTIONS TO BE GENERATED
C-----FOR THIS LATTICE AND CRYSTAL SYSTEM.
C-----# IN SPHERE = (4/3)*PI*VC/DMIN**3
C----- FUDGE FACTOR  IS USED TO COMPENSATE FOR ZONE REFLECTIONS
C-----MULTPL IS THE GENERAL REFLECTION MULTIPLICITY FOR THE CRYSTAL SYSTEM
C
C     ANORTHIC = TRICLINIC
       MULTPL = 2
C-----MONOCLINIC
      IF(ICRS.EQ.ITCRS(2)) MULTPL = 4
C-----ORTHORHOMBIC
      IF(ICRS.EQ.ITCRS(3)) MULTPL = 8
C-----TETRAGONAL
      IF(ICRS.EQ.ITCRS(4)) MULTPL = 16
C-----HEXAGONAL
      IF(ICRS.EQ.ITCRS(5)) MULTPL = 24
C-----RHOMBOHEDRAL
      IF(ICRS.EQ.ITCRS(6).AND.IRH.EQ.1) MULTPL = 24
      IF(ICRS.EQ.ITCRS(6).AND.IRH.EQ.0) MULTPL =  8
C-----CUBIC
      IF(ICRS.EQ.ITCRS(7)) MULTPL = 48
C-----MODIFY MULTPL FOR CENTERING
      ICENT=SPGI(1:1)
C-----A, B, C, I-CENTERING
      IF(ICENT.EQ.ITSG(2).OR.ICENT.EQ.ITSG(3).OR.ICENT.EQ.ITSG(4).OR.
     * ICENT.EQ.ITSG(6)) MULTPL = 2*MULTPL
C-----F CENTERING
      IF(ICENT.EQ.ITSG(5)) MULTPL = 4*MULTPL
      DLIM = (1.333*3.14156*VC/(MULTPL*MAXGEN))**0.333
      IF(DMIN.GT.DLIM) GOTO 344
      WRITE(NTOUT,343) MAXGEN
  343 FORMAT('0','**MESSAGE** d/hkl-generation limited to',I5,
     *' reflections - 2theta(max) decreased' )
      DMIN = DLIM
      THEMX = THETA(0.5*PWL,DLIM)
  344  ANGLE=THEMX+THEMX
      IF (IDOLSQ .EQ. 1) WRITE(NTOUT,76) THTMX,
     * NCYC,TOLMN,TOLMX,THEMX,DMIN
   76 FORMAT(24H01-theta angles  THTMX =,F6.1,8H  NCYC =,I2,9H  TOLMN =,
     * F7.4,9H  TOLMX =,F7.4,9H  THEMX =,F6.1,8H  DMIN =,F10.6)
      IF((IXPD.EQ.0) .AND. (IDOLSQ .EQ. 0)) WRITE(NTOUT,345) ANGLE,DMIN
  345 FORMAT(1H0,10X,13H2-theta(max)=,F6.2,4X,7Hd(min)=,F9.6)
      IF(IXPD.EQ.0) WRITE(NTOUT,346) NOPT
  346 FORMAT(1H0,10X,I2,' Conditions for non-extinction called for ',
     *'class condition(s)')
      IF(NOPT .LT. 1) GO TO 361
      DO 360  L=1,NOPT
      J= JOP(L)
      I= JCLASS(J)
      K= JCOND(J)
      IF(K.GE.1 .AND. K.LE.10) GOTO 350
      IF(IXPD.EQ.0) WRITE(NTOUT,348) IOP(J), IOP(J), IOP(J)
  348 FORMAT(1H ,21X,12Hhkl     h+k=,I1,6Hn,h+l=,I1,6Hn,k+l=,I1,1Hn)
      GOTO 360
  350 IF(IXPD.EQ.0) WRITE(NTOUT,352) ICLASS(I),ICOND(K),IOP(J)
  352 FORMAT(1H ,20X,A4,1X,A6,1H=,I1,1Hn)
 360   CONTINUE
 361  CONTINUE
 79   CALL HKLGEN
      CALL SORTD(NR,DCM,IHG)
      CALL SKWEZE
      TOL=TOLMX
      ICYCLE=0
      IF(IDOLSQ.EQ.0) GOTO 150
 80   CALL SLCR
      IF (NUMOBS .LT. N) GO TO 92
      MMN=NUMCYC-N
      IF (MMN) 90,99,94
 90   IF ((ICYCLE.GE.10).OR.(ICYCLE.GT.NCYC.AND.TOL.LE.TOLMN))GO TO 92
      TOL=0.5*TOL
      IF (TOL .LT. TOLMN) TOL=TOLMN
      NCYC=0
      GO TO 80
   92 WRITE(NTOUT,93)
   93 FORMAT(12H0No solution)
      GO TO 150
 94   J=N+1
      K=J
      DO 98 I=1,N
      AA(I)=A(K)
      J=J-1
 98   K=K+J
C
C-----SOLVE LS EQUATION
C
 99   CALL PDSQRT(A,N,B,IERR)
      IF (IERR .EQ. 0) GO TO 104
      WRITE(NTOUT,100) IERR
  100 FORMAT(38H0Singular normal equation matrix - row,I2,
     * 36H linearly dependent on previous rows)
      GO TO 90
C
C-----COMPUTE CORRECTIONS TO RECIPRICAL CELL PARAMETERS
C
  104 CALL COORD
      DO 120 J=1,3
      X(J)=X(J)+CR(J)
      U(J)=U(J)+CR(J+3)
      IF (X(J)) 106,106,109
  106 WRITE(NTOUT,108) J
  108 FORMAT(40H0Corrected value of reciprocal cell edge,I2,
     * 27H less than or equal to zero)
      GO TO 114
  109 IF (ABS(U(J))-1.0) 120,110,110
  110 WRITE(NTOUT,112) J
  112 FORMAT(42H0Corrected value of reciprocal cell cosine,I2,
     * 40H equals or exceeds 1.0 in absolute value)
  114 DO 116 K=1,J
      X(K)=X(K)-CR(K)
  116 U(K)=U(K)-CR(K+3)
      GO TO 90
  120 CONTINUE
C
C-----COMPUTE NEW CELL PARAMETERS
C
      CALL CMPNUP
      IF (MMN .GT. 0) GO TO 130
      TOL=0.5*TOL
      GO TO 140
  130 DO 134 I=1,N
  134 SUM=SUM-AA(I)*B(I)
      IF (SUM .LT. 0.0) SUM=0.0
      THTSE=SQRT(SUM/FLOAT(MMN))
      TOL=SEMULT*THTSE
  140 IF (TOL .LT. TOLMN) TOL=TOLMN
      IF (TOL .GT. TOLMX) TOL=TOLMX
      IF (ICYCLE .LE. NCYC) GO TO 160
      CRMAX=0.0
      DO 146 I=1,N
  146 IF (ABS( B(I)) .GT. CRMAX) CRMAX=ABS( B(I))
      IF (CRMAX .GE. 0.5E-6) GO TO 152
  149 IF (MMN .GT. 0) CALL SESUB
      DONE = .TRUE.
      CALL OUTPUT(DONE)
  150  IF( INPK .EQ. 0 ) CALL FNLST
       IF( INPK .EQ. 1 ) CALL FNINPK
      IF(IDOLSQ.EQ.1) CALL COMPAR
      WRITE(NTOUT,151) IWARN,IERR
151   FORMAT(1H0, '*****Total number of warnings=',I3, ' *****'/
     *       1H , '*****Total number of errors  =',I3, ' *****')
      IF(IERR.NE.0) NERRT = NERRT + 1
          IF( INPK .EQ. 1 ) GOTO 990
      GO TO 10
  152 IF (ICYCLE .LT. 10) GO TO 160
      WRITE(NTOUT,154)
  154 FORMAT(28H0Not convergent in 10 cycles, ' ',
     * '**MESSAGE** Final list uses cell parameters from cycle 9')
      GO TO 149
 160  CONTINUE
      DONE = .FALSE.
      CALL OUTPUT(DONE)
      CALL RCMPD
      CALL SORTD(NR,DCM,IHG)
      GO TO 80
C
C-----ERROR IN OPENING EXTENS FILE
C
 900  CONTINUE
      WRITE (NTOUT, 910) NEXTN
 910  FORMAT (' ', '**ERROR** Error occured in assigning extinction',
     * ' file to unit ', I3, ' execution stopped**')
C
C-----WRITE SUMMARY OF ENTIRE RUN IN TERMS OF DECKS WITH ERRORS
C
990   WRITE(NTOUT,991) NERRT
991   FORMAT(1H0,'##### Total decks with errors =',I3,' #####')
  999 STOP
      END
      SUBROUTINE BHREAD
C
C-----SUBROUTINE TO SIMULATE OLD BATCH READING OF LEAST SQUARE PROGRAM
C
C     PARAMETER (MAXOBS=200)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/LSQRD/CARD,ITEST
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/ALL/N,NUMCYC,FAC
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/RDGOOD/RGOOD,SYSEXT
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKG/IHEAD
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/BLKJ/TOLMN ,TOLMX, SEMULT
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      LOGICAL RGOOD,SYSEXT,HGOOD
      CHARACTER*6 ITEST,IALF
      CHARACTER*1 IHED,INTED
      CHARACTER*80 CARD
      CHARACTER*68 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
C
C-----INITIALIZE
C
	MAXOBS = 200
      RGOOD = .TRUE.
      NUMCRD = 2
      IDOLSQ = 0
C
C-----REMOVE HEADING FROM CARD, AND ECHO
C
      IHEAD = CARD(1:68)
C
C-----READ PARAM CARD
C
      READ (NTIN, 100) ITEST, CARD
 100  FORMAT (A6, A72)
C
C-----CHECK IF CELL ANGLES ENTERED IN DEGREES AND MINUTES
C
      IF (ITEST .EQ. IALF(2)) GO TO 200
C
C-----CHECK IF CELL ANGLES ENTERED IN DEGREES AND FRACTIONS
C
      IF (ITEST .EQ. IALF(9)) GO TO 250
C
C-----BAD CARD TYPE, WRITE ERROR MESSAGE AND LOOK FOR FINISH
C-----OR NEW TITLE CARD
C
      WRITE (NTOUT, 150) NUMCRD,IALF(2), IALF(9), ITEST
 150  FORMAT (' **ERROR** Bad card (#', I3, ') should be ''', A6,
     * ''' or ''', A6, ''' and not ''', A6, 1H')
 155  CONTINUE
      READ (NTIN, 100) ITEST, CARD
      IF ((ITEST .NE. IALF(1)) .AND. (ITEST .NE. IALF(5))) GO TO 155
C
C-----NEW TITLE CARD OR START OVER, SET READ FLAG BAD
C
      RGOOD = .FALSE.
      RETURN
C
C-----READ PARAM CARD IN DEG. AND MIN.
C
 200  CONTINUE
      READ (UNIT = CARD, FMT = 210, ERR = 900) (AO(I), I = 1,3),
     * (IDG(I), FMN(I), I = 1,3), ITHT, THTMX, NCYC, TOLMN, TOLMX, IPHKL
     * ,IXPD,RESOLV
 210  FORMAT (3F9.6, 3(I3, F5.3), I1, F3.0, I1, 2F5.4, I1, I1, F5.3)
      GO TO 300
C
C-----READ CARD WITH DEG AND FRACTIONS, AND CONVERT TO DEGREES AND MIN
C
 250  CONTINUE
      READ (UNIT = CARD, FMT = 260, ERR = 900) (AO(I), I = 1,3),
     * (ALO(I), I = 1,3), ITHT, THTMX, NCYC, TOLMN, TOLMX, IPHKL
     * ,IXPD,RESOLV
 260  FORMAT (3F9.6, 3F8.3, I1, F3.0, I1, 2F5.4, I1, I1, F5.3)
      DO 270 I = 1, 3
      IDG(I) = IFIX (ALO(I))
      FMN(I) = 60.0 * (ALO(I) - IDG(I))
 270  CONTINUE
C
C-----READ SYSEXT OR SPACEG CARD
C
 300  CONTINUE
      NUMCRD = NUMCRD + 1
      READ (NTIN, 100) ITEST, CARD
C
C-----SEE IF OLD TYPE SYSEXT CARD
C
      IF (ITEST .EQ. IALF(3)) GO TO 400
C
C-----SEE IF NEW SPACEG CARD
C
      IF (ITEST .EQ. IALF(12)) GO TO 450
C
C-----NOT EXPECTED CARD, FLAG AND SEARCH FOR FINISH OR TITLE CARD
C
      WRITE (NTOUT, 150) NUMCRD, IALF(3), IALF(12), ITEST
      GO TO 155
C
C-----OLD SYSEXT CARD, ADD DEFAULT FOR SPGI(1)
C
 400  CONTINUE
      READ (UNIT = CARD, FMT = 410, ERR = 900) ICRYST, THEMX, PWL,
     * (IOP(I), I = 1,27), PWL2, IWTYP, IWCYC, SEMULT
 410  FORMAT (A5, F3.0, F6.5, 27I1, 2X, F11.6, 2I2, 6X, F2.1)
      SYSEXT = .TRUE.
      SPGI(1:1) = ITSG(1)
      GO TO 470
C
C-----NEW SPACEG CARD, SET FLAG
C
 450  CONTINUE
      READ (UNIT = CARD, FMT = 460, ERR = 900) ICRYST, THEMX, PWL,
     * SPGI, PWL2, IWTYP, IWCYC, SEMULT
 460  FORMAT (A5, F3.0, F6.5, 2X, A8, 3X, 16X, F11.6,
     * 2I2, 6X, F2.1)
      SYSEXT = .FALSE.
C
C-----SEE IF NEED TO SET DEFAULT VALUE
C
 470  CONTINUE
      ITHT=MOD(ITHT,2)
      IF (ITHT.NE.0) GO TO 50
      THTMX=0.5*THTMX
      TOLMN=0.5*TOLMN
      RESOLV = 0.5 * RESOLV
      TOLMX=0.5*TOLMX
      THEMX=0.5*THEMX
 50   IF (THTMX.LE.0.0) THTMX=20.0
      IF (NCYC.LT.1) NCYC=2
      IF (TOLMN.LE.0.0) TOLMN=0.02
      IF (TOLMX.LE.TOLMN) TOLMX=5.0*TOLMN
C
C  REVISION 23 FEB 1982 CRH. ADDED 2ND FIELD FOR PWL INPUT
C                            TEST HERE IF NON ZERO
       IF(PWL2.GT.0.1) PWL=PWL2
      IF  (PWL.LE.0.0) PWL=1.5405981
      IF (SEMULT .LE. 0.0) SEMULT=2.0
C
C-----CHECK THAT ICRYST IS LEGAL
C
      DO 480 I = 1, 8, 1
      IF (ICRYST .EQ. CSC(I)) GO TO 500
 480  CONTINUE
C
C-----NOT LEGAL, FLAG AND SKIP GROUP
C
      WRITE (NTOUT, 490) ICRYST, NUMCRD
 490  FORMAT (' **ERROR** Crystal system = ''', A5, ''' on SYSEXT',
     * '(card # ', I2, ') is illegal, set skipped')
      RGOOD = .FALSE.
      RETURN
C
C-----READ REFLECTION CARDS
C
 500  CONTINUE
      NUMOBS = 0
 510  CONTINUE
      NUMCRD = NUMCRD + 1
      READ (NTIN, 100) ITEST, CARD
C
C-----CHECK IF HIT END CARD
C
      IF (ITEST .EQ. IALF(4)) GO TO 999
      IF ((ITEST .NE. IALF(7)) .AND. (ITEST .NE. IALF(13))) GO TO 985
      READ (UNIT = CARD,FMT = 520,ERR = 950,END = 970) (IHA(I),I = 1,3),
     * D, WLC, OBS, WT
 520  FORMAT (3I5, F9.6, F8.6, 2F9.5)
      CALL FRCHEK(NUMCRD)
C
C-----CHECK IF CARD WAS GOOD, SKIP IF NOT AND READ NEW CARD
C
      IF (.NOT. (HGOOD)) GO TO 510
C
C-----ROUTINE TO STORE AND DO COMPUTATIONS ON REFLECTION CARD
C
      CALL PRCHKL(NUMCRD)
C
C-----CHECK IF MAXOBS (OR GREATER) REFLECTIONS
C
      IF (NUMOBS .GE. MAXOBS) GO TO 600
      GO TO 510
C
C-----> 200 REFLECTIONS, PRINT MESSAGE AND READ TILL FIND
C-----END CARD (IE, FINISH THIS SET OF INPUT)
 600  CONTINUE
      WRITE(NTOUT,610) MAXOBS,MAXOBS
610   FORMAT('0','**WARNING** More than',I4,' reflection input.'
     * ' only the first',I4,' to be used')
      READ (NTIN, 620) ITEST
 620  FORMAT (A6)
      IF (ITEST .NE. IALF(4)) GO TO 600
      RETURN
C
C-----ERROR IN FOMAT OF CARD, SET NOT PROCESSED
C
 900  CONTINUE
      WRITE (NTOUT, 910) ITEST, NUMCRD, CARD
 910  FORMAT (' ', '**ERROR**''', A6, '''(card #', I3,
     * ') has a format error, set not processed, card read:' /
     * ' ', A72)
      RGOOD = .FALSE.
      RETURN
C
C-----ERROR IN FORMAT OF REFLECTION CARD, CARD SKIPPED
C-----BUT PROCESSING CONTINUES
C
 950  CONTINUE
      WRITE (NTOUT, 960) NUMCRD, CARD
 960  FORMAT (' ', '**ERROR**', 'CARD #', I3,
     * '-not used (reflection)  has a format error. card read:'
     * ' ', A72)
      GO TO 510
C
C-----EOF HIT WHILE READING HKL'S
C
 970  CONTINUE
      WRITE (NTOUT, 975)
 975  FORMAT (' **ERROR** End of file hit while reading reflection ',
     * 'cards, assumed end of data')
      GO TO 999
C
C-----BAD TITLE FOR REFLECTION CARD
C
 985  CONTINUE
      WRITE (NTOUT, 990) NUMCRD, IALF(7), IALF(13), ITEST
 990  FORMAT (' **ERROR** Card #', I3, '-not used (reflection) ',
     * 'should be ''', A6, ''' or ''', A6, ''' and not ''', A6, 1H')
      GO TO 510
 999  IF(NUMOBS.GT.0) IDOLSQ = 1
      RETURN
      END

      SUBROUTINE DMREAD
C
C-----INTERACTIVE MODE (DEMAND) INPUT OF REQUIRED PARAMETERS
C
C     PARAMETER (MAXOBS=200)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKG/IHEAD
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/BLKJ/TOLMN ,TOLMX, SEMULT
      COMMON/IERRS/ IWARN,IERR
      COMMON/RDGOOD/RGOOD,SYSEXT
      COMMON/PEAKS/NPKS,NPKMX,NPFLG(6,250),PKPRM( 3,250),NPKSQ(250),
     * IHKL(3,250)
      LOGICAL HGOOD,RGOOD,SYSEXT
      CHARACTER*6 IALF
      CHARACTER*68 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN, IT1
      CHARACTER*8 SPGI
      CHARACTER*1 YES
      CHARACTER*7 LABEL(3)
	CHARACTER*40 FILNAM
      DATA LABEL/'theta  ','2-theta','d-value'/
C
C-----INITIALIZE
C
	MAXOBS = 200
      SYSEXT = .FALSE.
      RGOOD  = .TRUE.
      ITHT = 2
      NUMOBS = 0
      PWL = 1.5405981
      SEMULT = 2.0
      OBS = 0.0
      D   = 0.0
      DO 2 I=1,3,1
      AO(I) = 0.0
      ALO(I)=0.0
2     CONTINUE
C
C-----ENTER HEADING FOR THIS PROBLEM
c  NO - get the title from the adr file!
C
c      WRITE(NTOUT,10)
c10    FORMAT('0','Enter heading (A68)')
c      READ(NTIN,20) IHEAD
C20    FORMAT(A68)
C
C-----CRYSTAL SYSTEM INPUT - CHARACTER*5 LABEL
C
28    WRITE(NTOUT,30) (CSC(I),I=1,8)
30    FORMAT('0','Enter crystal system code (A5):'/
     * ' ','   allowed codes:',8(A5,2X))
      READ(NTIN,34) ICRYST
34    FORMAT(A5)
      DO 40 I=1,8,1
      IF( ICRYST.NE.CSC(I)) GOTO 40
      WRITE(NTOUT,38) CSC(I)
38    FORMAT('0','Begin lattice parameter input for crystal system ',A5)
      GOTO 60
40    CONTINUE
      WRITE(NTOUT,50) ICRYST
50    FORMAT('0','Invalid code ',A5,' entered')
      GOTO 28
C
C-----ENTER LATTICE PARAMETERS AS REQUIRED BY CRYSTAL SYSTEM
C
60    WRITE(NTOUT,62)
62    FORMAT('0','Enter a')
      READ(NTIN,63) AO(1)
63	FORMAT(G)
C
C-----IF CUBIC THEN LATTICE PARAMETER INPUT IS COMPLETE
C
      IF(CSC(1).EQ.ICRYST) GOTO 400
C
C-----IF TETRAG, RHOMB HEXAG, OR HEXAR THEN B=A AND SKIP B INPUT
C
      IF(ICRYST.EQ.CSC(2)) GOTO 80
      IF(ICRYST.EQ.CSC(5)) GOTO 100
      IF(ICRYST.EQ.CSC(7)) GOTO 80
      IF(ICRYST.EQ.CSC(8)) GOTO 80
C
C-----INPUT OF B LATTICE PARAMETER
C
      WRITE(NTOUT,70) 
70    FORMAT('0','Enter b')
      READ(NTIN,63) AO(2)
C
C-----ENTER C LATTICE PARAMETER
C
80    WRITE(NTOUT,82)
82    FORMAT('0','Enter c')
      READ(NTIN,63) AO(3)
C
C-----IF TETRAGONAL, HEXAGONAL, RHOMBOHEDRAL ON H-AXES, OR ORTHORHOMBIC
C-----THEN ALL LATTICE PARMETERS HAVE BEEN INPUT
C
      IF(ICRYST.EQ.CSC(2)) GOTO 400
      IF(ICRYST.EQ.CSC(7)) GOTO 400
      IF(ICRYST.EQ.CSC(8)) GOTO 400
      IF(ICRYST.EQ.CSC(3)) GOTO 400
C
C-----IF MONOCLINIC THEN SKIP TO BETA INPUT
C
      IF(ICRYST.EQ.CSC(4)) GOTO 120
C
C-----ENTER ALPHA LATTICE PARAMETER
C
100   WRITE(NTOUT,102)
102   FORMAT('0','Enter alpha')
      READ(NTIN,63) ALO(1)
C
C-----TEST IF RHOMBOHERDAL, IF SO DONE WITH LATTICE PARAMETER INPUT
C
      IF(ICRYST.EQ.CSC(5)) GOTO 400
C
C-----ENTER BETA
C
120   WRITE(NTOUT,122)
122   FORMAT('0','Enter beta')
      READ(NTIN,63) ALO(2)
C
C-----IF MONOCLINIC B-UNIQUE THEN DONE WITH LATTICE PARAMETER INPUT
C
      IF(ICRYST.EQ.CSC(4)) GOTO 400
C
C-----ENTER GAMMA ANGLE
C
      WRITE(NTOUT,142)
142   FORMAT('0','Enter gamma')
      READ(NTIN,63) ALO(3)
C
C-----SET TO IDG AND FMN AS REQUIRED BY GEOLOGICAL SURVEY CODE
C
400   DO 410 I = 1,3,1
      IDG(I) = IFIX (ALO(I))
      FMN(I) = 60.0*(ALO(I) - IDG(I))
410   CONTINUE
C
C-----NOW TO REQUEST LEAST-SQUARES CONTROL PARAMETERS
C
500      WRITE(NTOUT,502)
502	FORMAT(/' Enter 0 - input d values and perform least squares'/
     *'       1 - just compute allowed d values from input parameters'/
     *'$Enter the function desired: ')
      READ(NTIN,504) II
504   FORMAT(I)
      IF(II .NE. 0) GO TO 5000
	WRITE(NTOUT,501)
501   FORMAT('0','Enter parameter input flag: 1=theta, 2=2-theta,'
     * ' 3=d-spacing'/' All subsequent control parameters refer to',
     *' the type of data selected here.'/'$Default = 2 :')
      READ(NTIN,*) ITHT
	if(itht .eq. 0) itht = 2
      IF(ITHT.LT.1 .OR. ITHT.GT.3) GOTO 500
      ITYPE=ITHT
      IF(ITYPE.EQ.3) ITHT = 2
         IDOLSQ=1
         WRITE(NTOUT,530)
530      FORMAT('0','Enter: NCYC, THTMX, TOLMN, TOLMX AND IPHKL'/
     *' Where: NCYC = The number of initial cycles using data with',
     *' angle below THTMX'/8x,'THTMX = The Theta or 2-Theta angle ',
     *'cut off for initial cycles of refinement'/
     *8X,'TOLMN = Minimum tolerance between observed and calculated',
     *'angles'/8x,'TOLMX = Maximum angular error allowed'//
     *' To accept defaults at any point in the input line enter a "/"'/
     *'0       Defaults are: 2, 40., 0.04, 0.20, 0'/
     *'$Enter values (or /):')
         READ(NTIN,*) NCYC,THTMX,TOLMN,TOLMX,RESOLV
         IF(THTMX.LT.0.01) THTMX=40.
         IF(TOLMN.LT.0.01) TOLMN=0.04
         IF(TOLMX.LT.0.01) TOLMX=0.20
         IF(RESOLV.LT.0.01) RESOLV=0.075
         IF(NCYC .EQ.0)   NCYC = 2
         WRITE(NTOUT,540)
540      FORMAT('0','Enter IWTYP,IWCYC Where:'/
     *'  IWTYP = Type of weighting used??'/
     *'  IWCYC = Total number of weighted least squares cycles??'/
     *' (defaults are 0,0 Enter a "/" to get defaults)')
         READ(NTIN,*) IWTYP,IWCYC
C     ELSE
      GO TO 5003
5000        IDOLSQ = 0
C     END IF
5003  CONTINUE
C
C-----ENTER D-GENERATION CONTROL PARAMETERS
C
      WRITE(NTOUT,602) LABEL(ITHT),LABEL(ITHT)
602   FORMAT('0','Enter: ',A7,'-MAX, IXPD, PWL2, Where:'/
     *1xA7,'-MAX = the maximum angle to be used in computation'/
     *'        IXPD = 0 - full output, = 1 limited output'/
     *'        PWL2 = The wavelength to use'/
     *'        Defaults are: 70.0, 0, 1.540598'/
     *'$Enter values (or /):')
      READ(NTIN,*) THEMX, IXPD, PWL2
      IF(THEMX.LE.0.01) THEMX=70.0
      IF(PWL2.GT.0.01) PWL = PWL2
C
C-----ENTER THE SPACE GROUP, ASPECT SYMBOL OR CENTERING SYMBOL
C
      WRITE(NTOUT,702)
702   FORMAT('0','Enter space group, aspect or centering symbol.',
     * ' first character capitol, others lower case (A8)')
      READ(NTIN,704) SPGI
704   FORMAT(A8)
C
C-----IF NOT LEAST SQUARES RUN THEN SKIP REFLECTION INPUT
C
      NUMCRD=0
      ITHT = MOD(ITHT,2)
      IF(IDOLSQ.EQ.0) GOTO 900
C
C  USE UNIT WEIGHTS AND SKIP ALTERNANE LAMBDA OPTION
C
	WT = 0.0
	WLC = 0.0
C
C  ALLOW DATA TO BE INPUT FROM A .CAL FILE
C
	WRITE(NTOUT,710)
710	FORMAT(/' Enter file name for the d-I data ',
     1 'file (if blank data will be typed')
	READ(NTIN,720)FILNAM
720	FORMAT(A40)
	IF(FILNAM(1:1).EQ.' ')GO TO 805
C
C  ALFRED OR SIEMENS FORMAT?
C
C  IF THE FILE NAME IS .CAL ASSUME IT IS IN DIFFRAC 11 FORMAT
C  IF .ADR IT CAM BE DIFFRAC 5 OR ALFRED ASCII FILE.
C       DO 721 JJ=1,40
C       IF(FILNAM(JJ:JJ) .EQ. '.')GO TO 722
C721	CONINUE
C
	WRITE(NTOUT,722)
722	FORMAT(/'$ENTER file type: <1>=Siemens <2>=',
     1 'Alfred, <3>=Diffrac 11, <4>=exit [Default=3]: ')
	READ(NTIN,724) IFMT
724	FORMAT(I)
C
C  SET JFLAG = 0 FILE INPUT , = 1 FOR KEYBOARD INPUT
C
	IF(IFMT .EQ. 0) IFMT = 3
	IF(IFMT .GE. 4)STOP 
	NTIN = 10
	IF(IFMT.EQ.3)OPEN ( UNIT=NTIN, NAME=FILNAM, TYPE='OLD', 
     +	  SHARED,READONLY, FORM='UNFORMATTED', ACCESS='DIRECT', 
     &    RECORDSIZE=1, ASSOCIATEVARIABLE=NEXT)
	IF(IFMT.NE.3)OPEN(UNIT=NTIN,NAME=FILNAM,TYPE='OLD',READONLY)
C
C-----GET HEADING FOR THIS PROBLEM FROM THE FILE
C
C  FOR DIFFRAC 11 FILE
	IF(IFMT .NE. 3) GO TO 9725
C  Read title, operator, time & date
9100	NEXT=1
	DO 9110,I=1,45,4
9110	READ(NTIN'NEXT) IHEAD(I:I+3)
	IHEAD(26:28)='   '
*	DO 9120,I=1,18
*	 IF(' '.LE.IHEAD(I:I) .AND. IHEAD(I:I).LE.'~') GOTO 9120
C  Non ascii garbage detected in first twelve
C  records so this is not Diffrac-11 format.
*	 WRITE(6,9101)
*9101	FORMAT(' FILE NOT IN DIFFRAC 11 FORMAT!')
*       CALL EXIT
*9120	CONTINUE
	READ(NTIN'19) PWL
C
C  Read number of peaks
	READ(NTIN'21) JPEAKS
	NEXT = 41
	GO TO 805
C
C  SKIP OFF THE FIRST SEVEN BLANK RECORDS
C
9725	DO 726 I=1,7
726	READ(NTIN,728)
728	FORMAT(1X)
C
C  READ HEADER RECORDS AND GET THE TITLE
C
	GO TO (730,732), IFMT
730	READ(NTIN,731,END=742) IHEAD
731	FORMAT(13X,A68)
	GO TO 734
732	READ(NTIN,733,END=742) IHEAD
733	FORMAT(14X,A68)
C
C  SKIP HEADER RECORDS
C  SEARCH FOR THE RECORD WITH "PEAK" STARTING IN COLUMN 1 OR 2
C
734	DO 741 I=1,50
	GO TO (735,737), IFMT
735	READ(NTIN,736,END=742) IT1
736	FORMAT(A4)
	GO TO 740
737	READ(NTIN,738,END=742) IT1
738	FORMAT(1X,A4)
740	IF(IT1.EQ.'PEAK')GO TO 744
741     CONTINUE
C
C **	FILE IN WRONG FORMAT
C
742	STOP ' ????? File in wrong format'
C
C  FILE IS IN CORRECT FORMAT
C
C
C-----ENTER OBSERVED 2-THETA OR D-VALUE, HKL, WEIGHT AND ALT LAMBDA
C
805   IF(FILNAM(1:1).NE.' ')GO TO 810
	WRITE(NTOUT,806) LABEL(ITYPE)
806   FORMAT('0','Enter ',A7,', Intensity (with decimal),',
     1' h,k,l (0.0=end)')
	NUMCRD = NUMCRD + 1
	READ(5,807) D, PKPRM(1,NUMCRD), (IHA(I),I=1,3)
807	format(2f10.0,3i5)
	if(d.eq.0.0)go to 900
        OBS = 0.0
	if(itype.eq.3)go to 5002
	obs = d
	d = 0.0
        GO TO 5002
810   NUMCRD = NUMCRD + 1
C
C  WE WILL TEMPORARILY USE THE PKPRM ARRAY TO STORE THE FLOATING PT.
C  INTENSITIES AND THE CONVERT THEM TO FIXED POINT
C
744	GO TO (746,748,9749),IFMT
746	READ(NTIN,747,END=900) V,dd,PKPRM(1,NUMCRD), (IHA(I),I=1,3)
747	FORMAT(5X,F9.5,f9.4,2XF7.6,3I3)
	GO TO 750
748	READ(NTIN,749,END=900) V,dd,PKPRM(1,NUMCRD), (IHA(I),I=1,3)
749	FORMAT(6X,F9.5,f9.4,2XF7.6,3I3)
	 GO TO 750
C
C  READ DIFFRAC 11 FORMAT
C
9749	IF(NUMCRD .GT. JPEAKS) GO TO 900
c  remove the ERR branch to see what Jim Clines problem is with D11 vs CAL file
c	READ(NTIN'NEXT,ERR=999) D
c	READ(NTIN'NEXT,ERR=999) PKPRM(1,NUMCRD)
	READ(NTIN'NEXT) D
	READ(NTIN'NEXT) PKPRM(1,NUMCRD)
	NEXT = NEXT + 4
        OBS = 0.0
        GO TO 5002
750      IF(V.LT.0.01) GOTO 900
      IF(ITYPE.EQ.3) GO TO 5001
         OBS = V
      GO TO 5002
C     ELSE
5001     D = dd
C     END IF
5002  CALL FRCHEK(NUMCRD)
      IF(.NOT. HGOOD) GOTO 805
      CALL PRCHKL(NUMCRD)
      IF(NUMOBS.LE.MAXOBS) GOTO 805
C
C-----MORE THAN MAXOBS REFLECTIONS
C
      WRITE(NTOUT,820) MAXOBS,MAXOBS
820   FORMAT('0','**WARNING** More than',I4,' reflections input.'
     * ' only the first',I4,' to be used')
      IWARN = IWARN + 1
C
C-----DMREAD INPUT COMPLETED
C
900   IF(ITHT.NE.0) GOTO 990
      THTMX = THTMX/2
      TOLMN = TOLMN/2
      RESOLV= RESOLV/2
      TOLMX = TOLMX/2
      THEMX = THEMX/2
990   WRITE(NTOUT,992) NUMOBS
992   FORMAT('0','Demand input completed.', I5,' reflections read')
	NTIN = 5
C
C  SCALE AND STORE THE INTENSITIES
C
	AMAX = 0.0
	DO 995 I=1,NUMOBS
	IF(PKPRM(1,I).GT.AMAX)AMAX = PKPRM(1,I)
995	CONTINUE
	if(amax.eq.0.)GO TO 997
	DO 996 I=1,NUMOBS
996	INT(I) = PKPRM(1,I) * 100. / AMAX
C
C  ALLOW OUTPUT TO GO TO A FILE
C
997      IF(IDOLSQ.EQ.0) GOTO 1930
C WE HAVE A FILE NAME CHANGE EXTENSION
	DO 1910 II=1,40
	IF( FILNAM(II:II) .EQ. '.')GO TO 1920
1910	CONTINUE
1920	FILNAM(II+1:II+3) = 'LSQ'
	GO TO 1950
C  WE ARE IN D CALC MODE - GENERATE A NAME
1930	FILNAM(1:10) = 'OUTPUT.LSQ'
1950	WRITE(NTOUT,1960) FILNAM
1960	FORMAT(/' ENTER 0 - OUTPUT TO TERMINAL'/
     1'       1 - OUTPUT TO FILE: ',A40/'$ENTER OUTPUT CODE: ')
	READ(NTIN,1970)II
1970	FORMAT(I)
	IF(II .EQ. 0)GO TO 999
	NTOUT = 40
	OPEN(UNIT=NTOUT,NAME=FILNAM,TYPE='UNKNOWN')
999	RETURN
      END

      SUBROUTINE PKREAD
C
C-----INTERACTIVE MODE (DEMAND) INPUT OF REQUIRED PARAMETERS
C
C     PARAMETER (MAXOBS=200)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/IO/NTOUT,NTIN,NEXTN,IOPKS
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/PPCON/JTYP,ITYP,TOL,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKG/IHEAD
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      COMMON/BLKJ/TOLMN ,TOLMX, SEMULT
      COMMON/IERRS/ IWARN,IERR
      COMMON/RDGOOD/RGOOD,SYSEXT
          COMMON/CRYDAT/CELL(6),SDCELL(6)
      COMMON/CRYDA1/CRSYS,SPGRP
      COMMON/PEAKS/NPKS,NPKMX,NPFLG(6,250),PKPRM( 3,250),NPKSQ(250),
     * IHKL(3,250)
          COMMON/PKFIL/NAME,TITLE
C
          CHARACTER* 1 CRSYS
          CHARACTER* 8 SPGRP
      LOGICAL HGOOD,RGOOD,SYSEXT
      CHARACTER*6 IALF
      CHARACTER*68 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*7 LABEL(3)
      CHARACTER*11 PCLNAM
      CHARACTER*8  CRS
      CHARACTER* 6 NAME
      CHARACTER*80 TITLE
          DATA CRS/'CTOMRAHX'/
      DATA LABEL/'theta  ','2-theta','d-value'/
C
C-------------------------------------------------------------
C
C-----INITIALIZE
C
	MAXOBS = 200
      SYSEXT = .FALSE.
      RGOOD  = .TRUE.
      ITHT = 2
      NUMOBS = 0
      PWL = 1.5405981
      SEMULT = 2.0
      OBS = 0.0
      D   = 0.0
      DO 2 I=1,3,1
      AO(I) = 0.0
      ALO(I)=0.0
2     CONTINUE
      WRITE(NTOUT,1010)
1010  FORMAT('$Enter file name (A6): ')
      READ(NTIN,1020)NAME
1020  FORMAT(A6)
C
C ASSIGN THE INPUT FILE PEAKS ** PKS**
C
      PCLNAM(1:6) = NAME
      PCLNAM(7:11) ='*PKS.'
      WRITE(NTOUT,1085) PCLNAM
 1085 FORMAT( 5X,' Peaks  file : ',A11 )
C
C     OPEN(IOPKS,IOSTAT=IOS,FILE=PCLNAM,STATUS='OLD',ACCESS='SEQUENTIAL'
C    * ,FORM='FORMATTED')
      IF(IOS.EQ.0) GOTO 390
      WRITE(NTOUT,1090) IOS
1090  FORMAT(1H0,'**File assignment error for peaks  file ,ier=',I5)
      IER = 1
          CALL EXIT
C
C READ FILE PEAKS
C
  390     CALL RDPKF6
C
C Store cell constants
C
          DO 380 I=1,3
          K=I+3
          AO(I)=CELL(I)
          ALO(I)=CELL(K)
  380 CONTINUE
C
C Store space group
C
          SPGI=SPGRP
C         Store Crystal system
C
          I=INDEX(CRS,CRSYS)
          ICRYST=CSC(I)
          IHEAD=TITLE(1:68)
C
C-----SET TO IDG AND FMN AS REQUIRED BY GEOLOGICAL SURVEY CODE
C
400   DO 410 I = 1,3,1
      IDG(I) = IFIX (ALO(I))
      FMN(I) = 60.0*(ALO(I) - IDG(I))
410   CONTINUE
C
C-----NOW TO REQUEST LEAST-SQUARES CONTROL PARAMETERS
C
         IF(THTMX.LT.0.01) THTMX=40.
         IF(TOLMN.LT.0.01) TOLMN=0.04
         IF(TOLMX.LT.0.01) TOLMX=0.20
         IF(RESOLV.LT.0.01) RESOLV=0.075
         IF(NCYC .EQ.0)   NCYC = 2
         WRITE(NTOUT,540)
540      FORMAT('0','ENTER IWTYP,IWCYC (DEFAULTS to 0,0) with a /',/,
     *' IWTYP : 0,1,2 Input,Unit,Hess weights ',/
     *' IWCYC : No. of cycles to use weights',/,
     *' ','IWTYP,IWCYC:')
         READ(NTIN,*) IWTYP,IWCYC
C
C-----ENTER D-GENERATION CONTROL PARAMETERS
C
      WRITE(NTOUT,602)
602   FORMAT('0','ENTER: ',/,
     *' THEMX: 2Theta maximum, for d generation  ',
     *'( default max. input 2th.)',/,
     *' IPHKL: Print HKL: 0 everything, 1 summery, 2 last cycle(Def.=2)'
     */,' WL   : Wavelength ( default Cu= 1.540598  )',/,
     *' Default with a / ',//' ','Enter:THEMX,IPHKL,WL',
     *' (Set printer(For H.P.press gold,f8,record)Return')
          IPHKL=2
      READ(NTIN,*) THEMX,IPHKL, PWL2
      IF(THEMX.LE.0.01) THEMX=179.9
      IF(PWL2.GT.0.01) PWL = PWL2
      ITHT = MOD(ITHT,2)
C
C Load the 2theta's
C
          K=0
          DO 620 I=1,NPKS
          IF(NPFLG(6,I) .EQ. 1) GOTO 620
          K=K+1
          OBS=PKPRM(1,I)
          CALL FRCHEK(K)
          IF(.NOT. HGOOD ) GO TO 620
      IF(NUMOBS.GE.MAXOBS) GOTO 820
          CALL PRCHKL(K)
          NPKSQ(K)=I
  620 CONTINUE
          IF(NUMOBS.EQ.0) GOTO 990
          IF(THEMX.GT.179.) THEMX=OBSTH(NUMOBS)+2.
          GO TO 990
C
C-----MORE THAN MAXOBS REFLECTIONS
C
  820 WRITE(NTOUT,1110) MAXOBS,MAXOBS
1110   FORMAT('0','**WARNING** More than',I4,' reflections input.'
     * ' only the first',I4,' to be used')
      IWARN = IWARN + 1
C
990   WRITE(NTOUT,992) NUMOBS
992   FORMAT('0','Pks input completed.', I5,' reflections read')
      RETURN
      END

      SUBROUTINE FRCHEK(NUMCRD)
C
C-----SUBROUTINE TO CHECK FOR ERRORS ON REFLECTION CARDS
C
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      LOGICAL HGOOD
C
C-----INITIALIZE FLAGS
C
      HGOOD = .TRUE.
C
C-----CHECK THAT d-SPACING, ALT. LAMBDA, 2-THETA, AND WEIGHT
C-----ARE NOT NEGATIVE
C
      IF ((D .GE. 0.0) .AND. (WLC .GE. 0.0) .AND. (OBS .GE. 0.0)
     * .AND. (WT .GE. 0.0)) GO TO 50
      WRITE (NTOUT, 30) NUMCRD, D, WLC, OBS, WT
 30   FORMAT (' ', '**ERROR** Card #',I3,'-not used (reflection) ',
     * ' has illegal negative value; none of following ',
     * 'should be negative:' /
     * ' ', 'd-spacing = ', F9.6, '  /  alternate lambda = ',
     * F8.5, '  /  2-theta = ', F9.5, '  /  weight = ', F9.5)
      HGOOD = .FALSE.
C
C-----CHECK THAT BOTH D-SPACING AND 2-THETA ARE NOT BOTH
C-----NON ZERO
C
 50   CONTINUE
      IF((D .LE. 0.0001) .OR. (OBS .LE. 0.0001)) GO TO 70
      WRITE (NTOUT, 60) NUMCRD, D, OBS
 60   FORMAT (' ', '**ERROR** Card #',I3,'-not used (reflection) ',
     * ' has a value for both the ',
     * 'd-spacing (= ', F9.6, ') and 2-theta (= ',
     * F9.5, ')')
      HGOOD = .FALSE.
 70   CONTINUE
C
C-----CHECK THAT BOTH D-SPACING AND 2-THETA ARE NOT BOTH ZERO
C
      IF ((D .GT. 0.0001) .OR. (OBS .GT. 0.0001)) GO TO 999
      WRITE (NTOUT, 85) NUMCRD, D, OBS
 85   FORMAT (' ', '**ERROR** Card #',I3,'-not used (reflection) ',
     * ' neither d-spacing (= ', F9.6,
     * ') nor 2-theta (= ', F9.5, ') is positive')
      HGOOD = .FALSE.
 999  RETURN
      END

      SUBROUTINE PRCHKL(NUMCRD)
C
C-----SUBROUTINE ASSUMES THAT EITHER D OR 2-THETA > 0
C
C     PARAMETER (MAXOBS=200)
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CHKREF/IHA(3),WLC,OBS,WT,HGOOD
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/BLKF/SW(200),WL(200)
      COMMON/IO/NTOUT,NTIN,NEXTN
      CHARACTER*1 IHED,INTED
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      LOGICAL HGOOD
      IF(WLC .LT. 0.001) WLC = PWL
      IF (WT.LE.0.0) WT=1.0
      IF (D.GT.0.0) GO TO 25
   20 THOBS=OBS
      IF (ITHT.EQ.0) THOBS=0.5*THOBS
      IF (THOBS.GE.90.0) GO TO 26
      DOBS=0.5*WLC/SIN(0.017453293*THOBS)
      GO TO 29
   25 CNST=0.5*WLC
      THOBS=THETA(CNST,D)
      IF (THOBS.GT.0.0.AND.THOBS.LT.90.0) GO TO 28
 26   WRITE (NTOUT, 27) NUMCRD, THOBS
 27   FORMAT (' ', '**ERROR** Card #-not used (reflection) ', I3,
     * ' had an ',
     * 'illegal calculated theta of = ', F6.2)
 28   CONTINUE
      DOBS=D
   29 NUMOBS=NUMOBS+1
      OBSTH(NUMOBS)=THOBS
      DSP(NUMOBS)=DOBS
      WL(NUMOBS)=WLC
      IF(IWTYP.EQ.1) WT=1.0
      IF(IWTYP.EQ.2) WT=1.0/SIN(2.0*THOBS/57.3)**2
      SW(NUMOBS)=SQRT(WT)
      DO 60 L=1,3
   60 IH(NUMOBS,L)=IHA(L)
C
C-----FLAG IF NOT READ SO COMPUTER WILL ASSIGN
C
      IHED(NUMOBS) = ITIH(1)
      IF ((IHA(1) .EQ. 0) .AND. (IHA(2) .EQ. 0) .AND.
     * (IHA(3) .EQ. 0)) IHED(NUMOBS) = ITIH(4)
 99   RETURN
      END

      SUBROUTINE PDSQRT(A,N,B,IERR)
C SOLUTION OF N LINEAR ALGEBRAIC EQUATIONS BY SQUARE ROOT METHOD.
C UPPER TRIANGLE OF GIVEN POSITIVE DEFINITE SYSTEM STORED SO THAT
C ELEMENT IN ROW I AND COLUMN J IS A((2*N+4-I)*(I-1)/2+J-I+1), WITH
C COLUMN N+1 CONTAINING RIGHT HAND SIDE EQUATION CONSTANTS.
C B() IS SOLUTION VECTOR. IERR=-1 IF N NOT A POSITIVE INTEGER OR IF N
C EXCEEDS PROGRAMMED LIMIT, IERR=0 IF SOLUTION CARRIED TO COMPLETION,
C ELSE IERR=ROW FOR WHICH FIRST NON-POSITIVE DIAGONAL PIVOT DETECTED.
      DIMENSION A(27),B(6)
      IF (N.GE.1.AND.N.LE.6) GO TO 1
      IERR=-1
      GO TO 999
C     THESE TWO CARDS ARE INSERTED TO MAINTAIN THE NUMBER SEQUENCE.
C     THERE ARE NO FORTRAN STATEMENTS MISSING.
    1 I2=N+1
      DO 35 I=1,N
      J=N
      K=I
      SUM=0.0
      IL=I-1
      IF (IL.LT.1) GO TO 15
      DO 12 L=1,IL
      FAC=A(K)
      SUM=SUM-FAC*FAC
      K=K+J
   12 J=J-1
   15 SUM=SUM+A(K)
      IF (SUM.GT.0.0) GO TO 20
      IERR=I
      GO TO 999
   20 FAC=1.0/SQRT(SUM)
      A(K)=FAC
      I1=I+1
      DO 35 J=I1,I2
      SUM=0.0
      K=N
      IJ=J
      II=I
      IF (IL.LT.1) GO TO 30
      DO 25 L=1,IL
      AI=A(II)
      SUM=SUM-AI*A(IJ)
      II=II+K
      IJ=IJ+K
   25 K=K-1
   30 SUM=SUM+A(IJ)
   35 A(IJ)=FAC*SUM
      J=((N+3)*N)/2
      I=N
   42 IF (I-1) 998,45,45
   45 SUM=A(J)
      J=J-1
      K=I+1
      L=N
   48 IF (L-K) 55,50,50
   50 SUM=SUM-A(J)*B(L)
      J=J-1
      L=L-1
      GO TO 48
   55 B(I)=A(J)*SUM
      J=J-1
      I=I-1
      GO TO 42
  998 IERR=0
 999  RETURN
      END
      SUBROUTINE COORD
C COMPUTES CORRECTIONS TO RECIPROCAL CELL ELEMENTS
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      CHARACTER*6 IALF12
      GO TO (10,20,30,40,50,60,70),ITYP
   10 DO 15 J=1,3
      CR(J)=B(1)
   15 CR(J+3)=0.0
      GO TO 80
   20 DO 25 J=1,2
   25 CR(J)=B(1)
      CR(3)=B(2)
      DO 28 J=4,6
   28 CR(J)=0.0
      GO TO 80
   30 DO 35 J=1,3
      CR(J)=B(J)
   35 CR(J+3)=0.0
      GO TO 80
   40 DO 45 J=1,3
   45 CR(J)=B(J)
      CR(4)=0.0
      CR(5)=B(4)
      CR(6)=0.0
      GO TO 80
   50 DO 52 J=1,2
   52 CR(J)=B(1)
      CR(3)=B(2)
      DO 55 J=4,6
   55 CR(J)=0.0
      GO TO 80
   60 DO 65 J=1,6
   65 CR(J)=B(J)
      GO TO 80
   70 DO 75 J=1,3
      CR(J)=B(1)
   75 CR(J+3)=B(2)
 80   RETURN
      END
      SUBROUTINE CMPNUP
C COMPUTES DIRECT CELL PARAMETERS FROM CORRECTED RECIPROCAL CELL
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      COMMON/OUTHLD/TCR(3)
      CHARACTER*6 IALF12
      DO 9 J=1,3
      UO(J)=AR(J)
      W(J)=SQRT(1.0-U(J)**2)
      AR(J)=3437.7468*(1.5707963-ATAN2(U(J),W(J)))
      UO(J)=AR(J)-UO(J)
C
C-----STORE VALUE OF UO FOR LATER OUTPUT
C
      TCR(J) = CR(J)
 9    CONTINUE
      VRO=VR
      VR=SQRT(1.0-U(1)**2-U(2)**2-U(3)**2+2.0*U(1)*U(2)*U(3))*X(1)*X(2)
     1*X(3)
      DO 20 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      AO(I)=AD(I)
      AD(I)=X(J)*X(K)*W(I)/VR
      ALO(I)=ALS(I)
      IF (ITYP .GT. 5) GO TO 18
      IF (I .EQ. 2 .AND. ITYP .EQ. 4) GO TO 18
      IF (I .EQ. 3 .AND. ITYP .EQ. 2) GO TO 18
      CSA(I)=0.0
      GO TO 19
   18 CSA(I)=(U(J)*U(K)-U(I))/(W(J)*W(K))
   19 ALS(I)=3437.7468*(1.5707963-ATAN2(CSA(I),SQRT(1.0-CSA(I)**2)))
 20   CONTINUE
      VCO=VC
      VC=1.0/VR
      RETURN
      END
      SUBROUTINE SESUB
C COMPUTES STANDARD ERRORS AND VARIANCE-COVARIANCE MATRIX
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/ALL/N,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/BLKB/CR(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/JA
      COMMON/SIGMA/SERCE(6),SEDCE(6),VCME(6,6),FACTR
      CHARACTER*6 IALF12, JA
      DIMENSION TT(6,6), ST(6,6),  DD(3), SS(21)
      DO 2 I=1,21
    2 SS(I)=0.0
      FACTR=THTSE*THTSE
      CALL PDNVRT(A,N,B)
      IEC=((N+1)*N)/2
      DO 8 I=1,IEC
    8 A(I)=A(I)*FACTR
      GO TO (10,20,30,40,50,60,70),ITYP
   10 DO 11 I=1,3
   11 SS(I)=A(1)
      SS(7)=A(1)
      SS(8)=A(1)
      SS(12)=A(1)
      GO TO 80
   20 SS(1)=A(1)
      SS(2)=A(1)
      SS(7)=A(1)
      SS(3)=A(2)
      SS(8)=A(2)
      SS(12)=A(3)
      GO TO 80
   30 DO 32 I=1,3
   32 SS(I)=A(I)
      DO 34 I=7,8
   34 SS(I)=A(I-3)
      SS(12)=A(6)
      GO TO 80
   40 DO 42 I=1,3
   42 SS(I)=A(I)
      SS(5)=A(4)
      DO 44 I=7,8
   44 SS(I)=A(I-2)
      DO 46 I=7,9
   46 SS(2*I-4)=A(I)
      SS(19)=A(10)
      GO TO 80
   50 GO TO 20
   60 DO 62 I=1,21
   62 SS(I)=A(I)
      GO TO 80
   70 DO 72 I=1,3
   72 SS(I)=A(1)
      SS(7)=A(1)
      SS(8)=A(1)
      SS(12)=A(1)
      DO 74 I=4,6
   74 SS(I)=A(2)
      DO 76 I=9,11
   76 SS(I)=A(2)
      DO 78 I=13,15
   78 SS(I)=A(2)
      DO 79 I=16,21
   79 SS(I)=A(3)
   80 II=1
      DO 82 I=1,3
      SERCE(I)=SQRT(SS(II))
   82 II=II+7-I
      DO 84 I=4,6
      SERCE(I)=3437.7468*SQRT(SS(II))/W(I-3)
   84 II=II+7-I
      DO 88  I=1,3
   88 SNA(I)=SQRT(1.0-CSA(I)**2)
      DO 995 I=1,3
      DO  95 J=1,3
      IF (I-J) 93,94,93
   93 TT(I,J)=0.0
      GO TO 95
   94 TT(I,J)=-AD(I)/X(I)
   95 CONTINUE
  995 CONTINUE
      DO 100 I=4,6
      DO 100 J=1,3
  100 TT(I,J)=0.0
      DO 105 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
  105 DD(I)=-AD(J)*AD(K)*X(J)*X(K)
      DO 915 I=1,3
      DO 115 J=4,6
      IF (I-J+3) 108,110,108
  108 TT(I,J)=DD(J-3)*AD(I)*CSA(J-3)
      GO TO 115
  110 K=MOD(J,3)+1
      L=MOD(K,3)+1
      TT(I,J)=DD(J-3)*AD(J-3)*CSA(K)*CSA(L)
  115 CONTINUE
  915 CONTINUE
      DO 120 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
  120 DD(I)=1.0/(W(J)*W(K))
      DO 925 I=4,6
      DO 125 J=4,6
      IF (I-J) 123,122,123
  122 TT(I,J)=DD(I-3)/SNA(J-3)
      GO TO 125
  123 IJ12=12-I-J
      TT(I,J)=DD(I-3)*CSA(IJ12)/SNA(J-3)
  125 CONTINUE
  925 CONTINUE
      DO 130 I=1,6
      DO 130 J=1,6
      SUM=0.0
      IJ=I
      DO 128 K=1,6
      SUM=SUM+SS(IJ)*TT(J,K)
      IF (I-K) 127,127,126
  126 IJ=IJ+6-K
      GO TO 128
  127 IJ=IJ+1
  128 CONTINUE
  130 ST(I,J)=SUM
      DO 140 I=1,6
      DO 138 J=1,6
      SUM=0.0
      DO 136 K=1,6
  136 SUM=SUM+TT(I,K)*ST(K,J)
  138 VCME(I,J)=SUM
 140  CONTINUE
      DO 145 I=1,6
  145 SEDCE(I)=SQRT(VCME(I,I))
      DO 148 I=4,6
 148  SEDCE (I) = (3437.7468*SEDCE (I))/60.
      FACTR=AD(1)*AD(2)*AD(3)
      FACTR=FACTR*FACTR/VC
      DO 150 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      CR(I)=VC/AD(I)
  150 CR(I+3)=FACTR*SNA(I)*(CSA(I)-CSA(J)*CSA(K))
      FACTR=0.0
      DO 152 I=1,6
      DO 152 J=1,6
  152 FACTR=FACTR+CR(I)*CR(J)*VCME(I,J)
      IF (FACTR) 154,154,156
  154 FACTR=0.0
      GO TO 999
  156 FACTR=SQRT(FACTR)
 999  RETURN
      END

      SUBROUTINE PDNVRT(A,N,B)
C COMPLETES THE INVERSION OF POSITIVE DEFINITE SYMMETRIC MATRIX OF
C ORDER N, STARTING WITH THE TRIANGULARIZED MATRIX RESULTING FROM
C PDSQRT, THE UPPER TRIANGLE OF THE INVERSE BEING STORED SO THAT ITS
C ITH ROW AND JTH COLUMN ELEMENT IS A((2*N-I)*(I-1)/2+I-J+1)
C WITH 1.LE.I.LE.J.LE.N.
      DIMENSION A(27),B(6)
      IE=0
      NP1=N+1
      NP2=N+2
      INM=((N+3)*N)/2-1
      II=1
      DO 395 I=1,N
      B(I)=A(II)
      J=I+1
  155 IF (J.GT.N) GO TO 200
      SUM=0.0
      IJ=II+J-I
      L=J-1
      DO 170 K=I,L
      SUM=SUM-A(IJ)*B(K)
  170 IJ=IJ+NP1-K
      B(J)=A(IJ)*SUM
      J=J+1
      GO TO 155
  200 J=N
      IJ=INM
  210 SUM=B(J)
      K=N
  220 IF (K.LE.J) GO TO 250
      SUM=SUM-A(IJ)*B(K)
      IJ=IJ-1
      K=K-1
      GO TO 220
  250 B(J)=A(IJ)*SUM
      J=J-1
      IF (J.LT.I) GO TO 300
      IJ=IJ-2
      GO TO 210
  300 DO 315 J=I,N
      IE=IE+1
  315 A(IE)=B(J)
  395 II=II+NP2-I
      RETURN
      END
      SUBROUTINE OUTPUT(DONE)
C     PARAMETER (MAXOBS=200)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/CPPCON/IALF12
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CBLKG/IHEAD
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKB/CR(6)
      COMMON/SIGMA/SERCE(6),SEDCE(6),VCME(6,6),FACTR
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CCONTR/ ID0
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/OUTHLD/TCR(3)
      DIMENSION V(6)
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED
      REAL TEMP(3)
      LOGICAL DONE
      CHARACTER*68 IHEAD
      CHARACTER*6 IALF12
      IF ((IPHKL .EQ. 2) .AND. (DONE)) WRITE (NTOUT, 430) ICYCLE,IHEAD,
     * IALF12,TOLTH
 430  FORMAT ('1', 'Cycle', I3, 4X, A68, 4X, A2, 'theta tolerance = ',
     * F9.5)
      RM=-RSDMAX
      TSE=THTSE
      IF (ITHT.NE.0) GO TO 9
      RM=RM+RM
      TSE=TSE+TSE
    9 IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,10) RM,IRSD,TSE,MMN
   10 FORMAT('0'/' ','largest residual reduced to unit weight',F8.5,3X,
     * 'obs',I4,3X,'standard error unit wt obs',F8.5,3X,
     * 'degrees of freedom',I4)
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,122)
  122 FORMAT(1H0,24X,1Ha,15X,1Hb,15X,1Hc,13X,5Halpha,7X,4Hbeta,8X,
     * 5Hgamma,12X,6Hvolume)
C
C-----CONVERT FROM MINUTES TO DEEGREES
C
      DO 15 I = 1, 3, 1
      TEMP(I) = AR(I) / 60.0
 15   CONTINUE
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,12) (X(I),I=1,3),
     * (TEMP(I),I=1,3),VR
   12 FORMAT(16H Reciprocal cell,1X,3E16.8,4X,3(F8.4,4X),3X,E13.6)
      DO 50 I = 1, 3, 1
      TEMP(I) = SERCE(I+3) / 60.0
 50   CONTINUE
      IF (DONE) WRITE(NTOUT,86) (SERCE(I),I=1,3), (TEMP(I), I = 1, 3)
   86 FORMAT(16H r c stndrd errs,1X,3E16.8,1X,3(F11.4,1X))
      DO 80 I = 1, 3, 1
      TEMP(I) = UO(I) / 60.0
 80   CONTINUE
      TEMP1 = VR - VRO
      IF ((IPHKL .NE.2) .OR. (DONE)) WRITE(NTOUT,14) (TCR(J),J=1,3),
     * (TEMP(J),J=1,3),TEMP1
   14 FORMAT(16H r c corrections,1X,3E16.8,4X,3(F8.4,4X),3X,E13.6)
      DO 22 I = 1, 3, 1
   22 TEMP(I) = (ALS(I))/60.0
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE (NTOUT,24) (AD(I),I=1,3),
     * (TEMP(I),I=1,3),VC
 24   FORMAT (' ','Direct cell',5X,3(F11.6,5X),4X,3(F8.4,4X),3X,F13.6)
      IF(DONE) WRITE (NTOUT,500) (SEDCE(I), I = 1, 6),
     * FACTR
 500  FORMAT (' ','d c stndrd errs',1X,3(F11.6,5X),4X, 3(F8.4, 4X),
     * 3X, F13.6)
      DO 26 I = 1, 3, 1
      TEMP(I) = AD(I) - AO(I)
      UO(I) = ALS(I) - ALO(I)
      FMN(I) = UO(I) / 60.0
 26   CONTINUE
      TEMP1 = VC - VCO
      IF((IPHKL.NE.2) .OR. (DONE)) WRITE(NTOUT,30) (TEMP(I),I=1,3),
     * (FMN(I),I=1,3),TEMP1
   30 FORMAT(16H d c corrections,1X,3(F11.6,5X),4X,3(F8.4,4X),3X,F13.6)
      IF (DONE) WRITE(NTOUT,132)
  132 FORMAT('0', 'Direct cell variance-covariance matrix',75X,3Hrow)
      DO 150 I = 1, 6, 1
      IF (DONE) WRITE(NTOUT,142) (VCME(I,L),L=1,6),I
  142 FORMAT(16X,6E16.8,I4)
C-----PREPARE FOR CALCULATION OF CORRELATION MATRIX
      V(I)=1.0
C-----1.0E-15 CHOOSEN TO AVOID DIVISION BY ZERO
      IF(VCME(I,I).GT.1.0E-15) V(I)=SQRT(VCME(I,I))
 150  CONTINUE
C
C-----OUTPUT CORRELATION MATRIX ON LAST CYCLE
C
      IF (DONE) WRITE(NTOUT,160)
  160 FORMAT('0', 'Direct cell    correlation      matrix',75X,3Hrow)
      DO 180 I = 1,6,1
      DO 170 J = 1,6,1
      VCME(I,J) = VCME(I,J)/(V(I)*V(J))
170   CONTINUE
      IF (DONE) WRITE(NTOUT,172) (VCME(I,L),L=1,6),I
  172 FORMAT(16X,6F16.8,I4)
180   CONTINUE
      RETURN
      END
      SUBROUTINE FNINPK
      RETURN
      END
      SUBROUTINE RDPKF6
      RETURN
      END
      SUBROUTINE PRMCHK(ICRS,N,ITYP,JTYP)
C-----SETS ITYP AND JTYP ACCORDING TO CRYSTAL SYSTEM
C-----SYMMETRY CONSTRAINTS HAVE ALREADY BEEN IMPOSED ON LATTICE (IN READ
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/UNQ/ IFA,IFB,IFC,IRH
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 ICRS
      ITYP=0
      IF (ICRS .NE. ITCRS(7)) GO TO 13
      JTYP=1
      ITYP=1
      N=1
      GO TO 55
 13   IF (ICRS .NE. ITCRS(5)) GO TO 21
      JTYP=2
   15 ITYP=2
      N=2
      GO TO 55
C-----RHOMBOHEDRAL AND HEXAGONAL AXES
 21   IF (ICRS .NE. ITCRS(6) .OR. IRH.NE.1) GO TO 24
      JTYP=8
      GO TO 15
 24   IF (ICRS .NE. ITCRS(3)) GO TO 30
      JTYP=3
      ITYP=3
      N=3
      GO TO 55
 30   IF (ICRS .NE. ITCRS(2)) GO TO 38
      JTYP=4
      ITYP=4
      N=4
      GO TO 55
 38   IF (ICRS .NE. ITCRS(4)) GO TO 42
      JTYP=5
      ITYP=5
      N=2
      GO TO 55
C-----RHOMBOHEDRAL ON TRIGONAL AXES
 42   IF (ICRS .NE. ITCRS(6)) GO TO 51
      JTYP=7
      ITYP=7
      N=2
      GO TO 55
 51   IF (ICRS .NE. ITCRS(1)) GO TO 55
      JTYP=6
      ITYP=6
      N=6
   55 RETURN
      END
      FUNCTION THETA(C,D)
C COMPUTES ARCSIN(C/D) PROVIDED C.LE.D. ELSE THETA SET TO 90.00
      FAC=D*D-C*C
      IF (FAC.GE.0.0 .AND. (D*D+C*C) .GT. 0.0) GO TO 7
      FAC=90.0
      GO TO 8
    7 FAC=57.29578*ATAN2(C,SQRT(FAC))
    8 THETA=FAC
      RETURN
      END
      SUBROUTINE CHKSPG
      COMMON/CCELLI/SPGI,SPGIA,SPGIN,ICRS
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/IERRS/ IWARN,IERR
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/UNQ/   IFA,IFB,IFC,IRH
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 L
C-----FOR RHOMBOHEDRAL IF ISG(1)=' ' THEN SET IT TO 'R'
      IF(SPGI(1:1).EQ.ITED(1).AND.ICRS.EQ.ITCRS(6)) SPGI(1:1)=ITSG(7)
C
C-----FIRST PHASE. IS ISG(1) AN ALLOWED SYMBOL?
C-----USE L=ISG(1) FOR LATTICE CENTERING
C
      L=SPGI(1:1)
      IF(L.EQ.ITED(1)) GOTO 20
      DO 10 I=1,7
      IF(ITSG(I).EQ.L) GOTO 20
   10 CONTINUE
      IERR=IERR+1
      WRITE(NTOUT,11) L
   11 FORMAT(' ',  '**ERROR** Space group centering symbol "',A1,
     * '" is not allowed' /' ',10X,   'Cell centering "P" assumed' )
      SPGI(1:1)=ITED(1)
C
C-----SECOND PHASE. IS ICRS AN ALLOWED SYMBOL?
C
   20 DO 30 I=1,7
      IF(ICRS.EQ.ITCRS(I)) GOTO 40
   30 CONTINUE
      IERR=IERR+1
      WRITE(NTOUT,31) ICRS
   31 FORMAT(' ','**ERROR** Crystal system "',A1,'" is not allowed'/
     * ' ',10x, 'anorthic system assumed' )
C-----SET TO ANORTHIC INORDER TO PERMIT TRIAL EXECUTION
      ICRS=ITCRS(1)
      I=1
C-----IF CENTERING IS ABSENT THEN NO FURTHER CHECKING IS POSSIBLE
   40 IF(L.EQ.ITED(1).AND.ICRS.NE.ITCRS(6)) GOTO 200
C
C-----THIRD PHASE. CHECK FOR CONSISTENT LATTICE CENTERING AND CRYSTAL
C-----SYSTEM
C
C-----BRANCH ON CODE FOR CRYSTAL SYSTEM
      GOTO(50,70,90,110,130,150,170),I
C-----ANORTHIC P,A,B,C,F,I ALLOWED
   50 IF(L.EQ.ITSG(7)) GOTO 190
      GOTO 200
C-----MONOCLINIC P,A,B,C,F,I ALLOWED
   70 IF(L.EQ.ITSG(7)) GOTO 190
      GOTO 200
C-----ORTHORHOMBIC P,A,B,C,F,I ALLOWED
   90 IF(L.EQ.ITSG(7)) GOTO 190
      GOTO 200
C-----TETRAGONAL P,C,F,I ALLOWED
  110 IF(L.EQ.ITSG(2).OR.L.EQ.ITSG(3).OR.L.EQ.ITSG(7)) GOTO 190
      IF(L.NE.ITSG(4).AND.L.NE.ITSG(5))  GOTO 200
      WRITE(NTOUT,111)
      IWARN=IWARN+1
  111 FORMAT(' ','**WARNING** Unusual tetragonal centering input - cd'
     *' space group not determined' )
      GOTO 200
C-----HEXAGONAL P ALLOWED
  130 IF(L.NE.ITSG(1)) GOTO 190
      GOTO 200
C-----RHOMBOHEDRAL  R-AXES R,F,I ALLOWED; H-AXES R ALLOWED
  150 IF(L.EQ.ITED(1)) SPGI(1:1)=ITSG(7)
      IF(IRH.EQ.1) GOTO 160
C-----R-AXES
      IF(L.EQ.ITSG(7)) GOTO 200
      IF(L.NE.ITSG(5).AND.L.NE.ITSG(6)) GOTO 190
      WRITE(NTOUT,151)
  151 FORMAT(' ','**WARNING** Unusual rhombohedral centering input - cd'
     * 'space group not determined' )
      IWARN=IWARN+1
      GOTO 200
C-----H-AXES
  160 IF(L.NE.ITSG(7)) GOTO 190
      GOTO 200
C-----CUBIC  P,F,I ALLOWED
  170 IF(L.NE.ITSG(1).AND.L.NE.ITSG(5).AND.L.NE.ITSG(6)) GOTO 190
      GOTO 200
C
C-----LATTICE CENTERING (ISG(1)) NOT ALLOWED IN SYSTEM ICRS
C
  190 IERR=IERR+1
      WRITE(NTOUT,192) L,ICRS
  192 FORMAT(' **ERROR** Input cell centering "',A1,'"  is not allowed',
     *' in crystal system "',A1,'"')
      SPGI(1:1)=ITSG(1)
      IF(ICRS.EQ.ITCRS(6)) SPGI(1:1)=ITSG(7)
      WRITE(NTOUT,194) SPGI(1:1)
  194 FORMAT(' ',9X,'ISG(1) set to "',A1,'"  to permit execution')
  200 RETURN
      END
      SUBROUTINE SPG(ISGC,IPASS)
C**********************************************************************
C
C-----ROUTINE TO ASSIGN THE SPACE GROUP NUMBER AND ORIENTATION CODE AND
C-----ASPECT CODE FOR THE SPACE GROUP ISGC
C
C-----IPASS = 1 FOR NORMAL ANALYSIS
C-----      = 2 FOR CRYSTAL DATA SPACE GROUP
C
C-----SPACE GROUP NUMBER AS GIVEN IN THE 'INTENATIONAL TABLES, VOL 1'
C-----STORED IN SPGI AS EIGHT CHARACTER STRING (IPASS=1)
C-----STORED IN SPGF AS EIGHT CHARACTER STRING (IPASS=2)
C
C-----ORIENTATION CODE IS AS FOLLOWS
C         (blank) OR A  -  STANDARD SETTING
C         B,C,D,E,F - ALTERNATE SETTING
C           STORED IN SPGIA AS A ONE CHARACTER STRING
C
C-----SPGIA -ASPECT CODE (A1)
C-----SPGIN -#, ORIENTATION CODE   (A4)
C
C*************************************************************************
      COMMON/CHAR/ITSG(7),ITCRS(8),ITED(4),ITIH(7)
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7),ZI
      COMMON/CCELLI/SPGI,SPGIA,SPGIN,ICRS
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/UNQ/ IFA,IFB,IFC,IRH
      COMMON/IERRS/IWARN,IERR
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 SPGIA,SPGTA,ICRS
      CHARACTER*4 SPGIN,SPGTN
      CHARACTER*8 SPGI,SPGT
      CHARACTER*4 NUMSP(416),NUMAS(130)
      CHARACTER*8  ILSG(416), IASP(130)
      CHARACTER*8 ISGC
      CHARACTER*1 IHC,IHD,IH1,IH3,IHM,IASPEC(2)
C-----ANORTHIC (TRICLINIC) STARTS HERE AT NUMBER 1
C-----P1        (1)
      DATA ILSG(1)/'P1      '/  ,NUMSP(  1)/'  1 '/
C-----P BAR 1   (2)
      DATA ILSG(2)/'P-1     '/  ,NUMSP(  2)/'  2 '/
C-----MONOCLINIC STARTS HERE AT NUMBER 3
C-----P2        (3)
      DATA ILSG(3)/'P2      '/  ,NUMSP(  3)/'  3 '/
C-----P21       (4)
      DATA ILSG(4)/'P21     '/  ,NUMSP(  4)/'  4 '/
C-----C2        (5A)
      DATA ILSG(5)/'C2      '/  ,NUMSP(  5)/'  5A'/
C-----A2        (5B)
      DATA ILSG(6)/'A2      '/  ,NUMSP(  6)/'  5B'/
C-----I2        (5C)
      DATA ILSG(7)/'I2      '/  ,NUMSP(  7)/'  5C'/
C-----PM        (6)
      DATA ILSG(8)/'Pm      '/  ,NUMSP(  8)/'  6 '/
C-----PC        (7A)
      DATA ILSG(9)/'Pc      '/  ,NUMSP(  9)/'  7A'/
C-----PA        (7B)
      DATA ILSG(10)/'Pa      '/ ,NUMSP( 10)/'  7B'/
C-----PN        (7C)
      DATA ILSG(11)/'Pn      '/ ,NUMSP( 11)/'  7C'/
C-----CM        (8A)
      DATA ILSG(12)/'Cm      '/ ,NUMSP( 12)/'  8A'/
C-----AM        (8B)
      DATA ILSG(13)/'Am      '/ ,NUMSP( 13)/'  8B'/
C-----IM        (8C)
      DATA ILSG(14)/'Im      '/ ,NUMSP( 14)/'  8C'/
C-----CC        (9A)
      DATA ILSG(15)/'Cc      '/ ,NUMSP( 15)/'  9A'/
C-----AA        (9B)
      DATA ILSG(16)/'Aa      '/ ,NUMSP( 16)/'  9B'/
C-----IA        (9C)
      DATA ILSG(17)/'Ia      '/ ,NUMSP( 17)/'  9C'/
C-----P2/M      (10)
      DATA ILSG(18)/'P2/m    '/ ,NUMSP( 18)/' 10 '/
C-----P21/M     (11)
      DATA ILSG(19)/'P21/m   '/ ,NUMSP( 19)/' 11 '/
C-----C2/M      (12A)
      DATA ILSG(20)/'C2/m    '/ ,NUMSP( 20)/' 12A'/
C-----A2/M      (12B)
      DATA ILSG(21)/'A2/m    '/ ,NUMSP( 21)/' 12B'/
C-----I2/M      (12C)
      DATA ILSG(22)/'I2/m    '/ ,NUMSP( 22)/' 12C'/
C-----P2/C      (13A)
      DATA ILSG(23)/'P2/c    '/ ,NUMSP( 23)/' 13A'/
C-----P2/A      (13B)
      DATA ILSG(24)/'P2/a    '/ ,NUMSP( 24)/' 13B'/
C-----P2/N       (13C)
      DATA ILSG(25)/'P2/n    '/ ,NUMSP( 25)/' 13C'/
C-----P21/C     (14A)
      DATA ILSG(26)/'P21/c   '/ ,NUMSP( 26)/' 14A'/
C-----P21/A     (14B)
      DATA ILSG(27)/'P21/a   '/ ,NUMSP( 27)/' 14B'/
C-----P21/N     (14C)
      DATA ILSG(28)/'P21/n   '/ ,NUMSP( 28)/' 14C'/
C-----C2/C      (15A)
      DATA ILSG(29)/'C2/c    '/ ,NUMSP( 29)/' 15A'/
C-----A2/A      (15B)
      DATA ILSG(30)/'A2/a    '/ ,NUMSP( 30)/' 15B'/
C-----I2/A      (15C)
      DATA ILSG(31)/'I2/a    '/ ,NUMSP( 31)/' 15C'/
C-----ORTHORHOMBIC STARTS HERE AT NUMBER 32
C-----P222      (16)
      DATA ILSG(32)/'P222    '/ ,NUMSP( 32)/' 16 '/
C-----P2221     (17A)
      DATA ILSG(33)/'P2221   '/ ,NUMSP( 33)/' 17A'/
C-----P2122     (17B)
      DATA ILSG(34)/'P2122   '/ ,NUMSP( 34)/' 17B'/
C-----P2212     (17C)
      DATA ILSG(35)/'P2212   '/ ,NUMSP( 35)/' 17C'/
C-----P21212    (18A)
      DATA ILSG(36)/'P21212  '/ ,NUMSP( 36)/' 18A'/
C-----P22121    (18B)
      DATA ILSG(37)/'P22121  '/ ,NUMSP( 37)/' 18B'/
C-----P21221    (18C)
      DATA ILSG(38)/'P21221  '/ ,NUMSP( 38)/' 18C'/
C-----P212121   (19)
      DATA ILSG(39)/'P212121 '/ ,NUMSP( 39)/' 19 '/
C-----C2221     (20A)
      DATA ILSG(40)/'C2221   '/ ,NUMSP( 40)/' 20A'/
C-----A2122     (20B)
      DATA ILSG(41)/'A2122   '/ ,NUMSP( 41)/' 20B'/
C-----B2212     (20C)
      DATA ILSG(42)/'B2212   '/ ,NUMSP( 42)/' 20C'/
C-----C222      (21A)
      DATA ILSG(43)/'C222    '/ ,NUMSP( 43)/' 21A'/
C-----B222      (21B)
      DATA ILSG(44)/'B222    '/ ,NUMSP( 44)/' 21B'/
C-----A222      (21C)
      DATA ILSG(45)/'A222    '/ ,NUMSP( 45)/' 21C'/
C-----F222      (22)
      DATA ILSG(46)/'F222    '/ ,NUMSP( 46)/' 22 '/
C-----I222      (23)
      DATA ILSG(47)/'I222    '/ ,NUMSP( 47)/' 23 '/
C-----I212121   (24)
      DATA ILSG(48)/'I212121 '/ ,NUMSP( 48)/' 24 '/
C-----PMM2      (25A)
      DATA ILSG(49)/'Pmm2    '/ ,NUMSP( 49)/' 25A'/
C-----PM2M      (25B)
      DATA ILSG(50)/'Pm2m    '/ ,NUMSP( 50)/' 25B'/
C-----P2MM      (25C)
      DATA ILSG(51)/'P2mm    '/ ,NUMSP( 51)/' 25C'/
C-----PMC21     (26A)
      DATA ILSG(52)/'Pmc21   '/ ,NUMSP( 52)/' 26A'/
C-----P21MA     (26B)
      DATA ILSG(53)/'P21ma   '/ ,NUMSP( 53)/' 26B'/
C-----P21AM     (26C)
      DATA ILSG(54)/'P21am   '/ ,NUMSP( 54)/' 26C'/
C-----PB21M     (26D)
      DATA ILSG(55)/'Pb21m   '/ ,NUMSP( 55)/' 26D'/
C-----PCM21     (26E)
      DATA ILSG(56)/'Pcm21   '/ ,NUMSP( 56)/' 26E'/
C-----PM21B     (26F)
      DATA ILSG(57)/'Pm21b   '/ ,NUMSP( 57)/' 26F'/
C-----PCC2      (27A)
      DATA ILSG(58)/'Pcc2    '/ ,NUMSP( 58)/' 27A'/
C-----PB2B      (27B)
      DATA ILSG(59)/'Pb2b    '/ ,NUMSP( 59)/' 27B'/
C-----P2AA      (27C)
      DATA ILSG(60)/'P2aa    '/ ,NUMSP( 60)/' 27C'/
C-----PMA2      (28A)
      DATA ILSG(61)/'Pma2    '/ ,NUMSP( 61)/' 28A'/
C-----P2CM      (28B)
      DATA ILSG(62)/'P2cm    '/ ,NUMSP( 62)/' 28B'/
C-----P2MB      (28C)
      DATA ILSG(63)/'P2mb    '/ ,NUMSP( 63)/' 28C'/
C-----PBM2      (28D)
      DATA ILSG(64)/'Pbm2    '/ ,NUMSP( 64)/' 28D'/
C-----PC2M      (28E)
      DATA ILSG(65)/'Pc2m    '/ ,NUMSP( 65)/' 28E'/
C-----PM2A      (28F)
      DATA ILSG(66)/'Pm2a    '/ ,NUMSP( 66)/' 28F'/
C-----PCA21     (29A)
      DATA ILSG(67)/'Pca21   '/ ,NUMSP( 67)/' 29A'/
C-----P21CA     (29B)
      DATA ILSG(68)/'P21ca   '/ ,NUMSP( 68)/' 29B'/
C-----PB21A     (29C)
      DATA ILSG(69)/'Pb21a   '/ ,NUMSP( 69)/' 29C'/
C-----P21AB     (29D)
      DATA ILSG(70)/'P21ab   '/ ,NUMSP( 70)/' 29D'/
C-----PC21B     (29E)
      DATA ILSG(71)/'Pc21b   '/ ,NUMSP( 71)/' 29E'/
C-----PBC21     (29F)
      DATA ILSG(72)/'Pbc21   '/ ,NUMSP( 72)/' 29F'/
C-----PNC2      (30A)
      DATA ILSG(73)/'Pnc2    '/ ,NUMSP( 73)/' 30A'/
C-----PCN2      (30B)
      DATA ILSG(74)/'Pcn2    '/ ,NUMSP( 74)/' 30B'/
C-----PN2B      (30C)
      DATA ILSG(75)/'Pn2b    '/ ,NUMSP( 75)/' 30C'/
C-----PB2N      (30D)
      DATA ILSG(76)/'Pb2n    '/ ,NUMSP( 76)/' 30D'/
C-----P2NA      (30E)
      DATA ILSG(77)/'P2na    '/ ,NUMSP( 77)/' 30E'/
C-----P2AN      (30F)
      DATA ILSG(78)/'P2an    '/ ,NUMSP( 78)/' 30F'/
C-----PMN21     (31A)
      DATA ILSG(79)/'Pmn21   '/ ,NUMSP( 79)/' 31A'/
C-----PNM21     (31B)
      DATA ILSG(80)/'Pnm21   '/ ,NUMSP( 80)/' 31B'/
C-----P21NM     (31C)
      DATA ILSG(81)/'P21nm   '/ ,NUMSP( 81)/' 31C'/
C-----PN21M     (31D)
      DATA ILSG(82)/'Pn21m   '/ ,NUMSP( 82)/' 31D'/
C-----PM21N     (31E)
      DATA ILSG(83)/'Pm21n   '/ ,NUMSP( 83)/' 31E'/
C-----P21MN     (31F)
      DATA ILSG(84)/'P21mn   '/ ,NUMSP( 84)/' 31F'/
C-----PBA2      (32A)
      DATA ILSG(85)/'Pba2    '/ ,NUMSP( 85)/' 32A'/
C-----P2CB      (32B)
      DATA ILSG(86)/'P2cb    '/ ,NUMSP( 86)/' 32B'/
C-----PC2A      (32C)
      DATA ILSG(87)/'Pc2a    '/ ,NUMSP( 87)/' 32C'/
C-----PNA21     (33A)
      DATA ILSG(88)/'Pna21   '/ ,NUMSP( 88)/' 33A'/
C-----PBN21     (33B)
      DATA ILSG(89)/'Pbn21   '/ ,NUMSP( 89)/' 33B'/
C-----P21CN     (33C)
      DATA ILSG(90)/'P21cn   '/ ,NUMSP( 90)/' 33C'/
C-----P21NB     (33D)
      DATA ILSG(91)/'P21nb   '/ ,NUMSP( 91)/' 33D'/
C-----PN21A     (33E)
      DATA ILSG(92)/'Pn21a   '/ ,NUMSP( 92)/' 33E'/
C-----PC21N     (33F)
      DATA ILSG(93)/'Pc21n   '/ ,NUMSP( 93)/' 33F'/
C-----PNN2      (34A)
      DATA ILSG(94)/'Pnn2    '/ ,NUMSP( 94)/' 34A'/
C-----PN2N      (34B)
      DATA ILSG(95)/'Pn2n    '/ ,NUMSP( 95)/' 34B'/
C-----P2NN      (34C)
      DATA ILSG(96)/'P2nn    '/ ,NUMSP( 96)/' 34C'/
C-----CMM2      (35A)
      DATA ILSG(97)/'Cmm2    '/ ,NUMSP( 97)/' 35A'/
C-----BM2M      (35B)
      DATA ILSG(98)/'Bm2m    '/ ,NUMSP( 98)/' 35B'/
C-----A2MM      (35C)
      DATA ILSG(99)/'A2mm    '/ ,NUMSP( 99)/' 35C'/
C-----CMC21     (36A)
      DATA ILSG(100)/'Cmc21   '/,NUMSP(100)/' 36A'/
C-----A21AM     (36B)
      DATA ILSG(101)/'A21am   '/,NUMSP(101)/' 36B'/
C-----A21MA     (36C)
      DATA ILSG(102)/'A21ma   '/,NUMSP(102)/' 36C'/
C-----BM21B     (36D)
      DATA ILSG(103)/'Bm21b   '/,NUMSP(103)/' 36D'/
C-----BB21M     (36E)
      DATA ILSG(104)/'Bb21m   '/,NUMSP(104)/' 36E'/
C-----CCM21     (36F)
      DATA ILSG(105)/'Ccm21   '/,NUMSP(105)/' 36F'/
C-----CCC2      (37A)
      DATA ILSG(106)/'Ccc2    '/,NUMSP(106)/' 37A'/
C-----A2AA      (37B)
      DATA ILSG(107)/'A2aa    '/,NUMSP(107)/' 37B'/
C-----BB2B      (37C)
      DATA ILSG(108)/'Bb2b    '/,NUMSP(108)/' 37C'/
C-----AMM2      (38A)
      DATA ILSG(109)/'Amm2    '/,NUMSP(109)/' 38A'/
C-----AM2M      (38B)
      DATA ILSG(110)/'Am2m    '/,NUMSP(110)/' 38B'/
C-----B2MM      (38C)
      DATA ILSG(111)/'B2mm    '/,NUMSP(111)/' 38C'/
C-----BMM2      (38E)
      DATA ILSG(113)/'Bmm2    '/,NUMSP(113)/' 38E'/
C-----C2MM      (38D)
      DATA ILSG(112)/'C2mm    '/,NUMSP(112)/' 38D'/
C-----CM2M      (38F)
      DATA ILSG(114)/'Cm2m    '/,NUMSP(114)/' 38F'/
C-----ABM2      (39A)
      DATA ILSG(115)/'Abm2    '/,NUMSP(115)/' 39A'/
C-----BMA2      (39B)
      DATA ILSG(116)/'Bma2    '/,NUMSP(116)/' 39B'/
C-----C2MA      (39C)
      DATA ILSG(117)/'C2ma    '/,NUMSP(117)/' 39C'/
C-----AB2M      (39D)
      DATA ILSG(118)/'Ab2m    '/,NUMSP(118)/' 39D'/
C-----CM2A      (39E)
      DATA ILSG(119)/'Cm2a    '/,NUMSP(119)/' 39E'/
C-----B2AM      (39F)
      DATA ILSG(120)/'B2am    '/,NUMSP(120)/' 39F'/
C-----AMA2      (40A)
      DATA ILSG(121)/'Ama2    '/,NUMSP(121)/' 40A'/
C-----C2CM      (40B)
      DATA ILSG(122)/'C2cm    '/,NUMSP(122)/' 40B'/
C-----BBM2      (40C)
      DATA ILSG(123)/'Bbm2    '/,NUMSP(123)/' 40C'/
C-----B2MB      (40D)
      DATA ILSG(124)/'B2mb    '/,NUMSP(124)/' 40D'/
C-----CC2M      (40E)
      DATA ILSG(125)/'Cc2m    '/,NUMSP(125)/' 40E'/
C-----AM2A      (40F)
      DATA ILSG(126)/'Am2a    '/,NUMSP(126)/' 40F'/
C-----ABA2      (41A)
      DATA ILSG(127)/'Aba2    '/,NUMSP(127)/' 41A'/
C-----AB2A      (41B)
      DATA ILSG(128)/'Ab2a    '/,NUMSP(128)/' 41B'/
C-----C2CA      (41C)
      DATA ILSG(129)/'C2ca    '/,NUMSP(129)/' 41C'/
C-----B2AB      (41D)
      DATA ILSG(130)/'B2ab    '/,NUMSP(130)/' 41D'/
C-----CC2A      (41E)
      DATA ILSG(131)/'Cc2a    '/,NUMSP(131)/' 41E'/
C-----BBA2      (41F)
      DATA ILSG(132)/'Bba2    '/,NUMSP(132)/' 41F'/
C-----FMM2      (42A)
      DATA ILSG(133)/'Fmm2    '/,NUMSP(133)/' 42A'/
C-----FM2M      (42B)
      DATA ILSG(134)/'Fm2m    '/,NUMSP(134)/' 42B'/
C-----F2MM      (42C)
      DATA ILSG(135)/'F2mm    '/,NUMSP(135)/' 42C'/
C-----FDD2      (43A)
      DATA ILSG(136)/'Fdd2    '/,NUMSP(136)/' 43A'/
C-----FD2D      (43B)
      DATA ILSG(137)/'Fd2d    '/,NUMSP(137)/' 43B'/
C-----F2DD      (43C)
      DATA ILSG(138)/'F2dd    '/,NUMSP(138)/' 43C'/
C-----IMM2      (44A)
      DATA ILSG(139)/'Imm2    '/,NUMSP(139)/' 44A'/
C-----IM2M      (44B)
      DATA ILSG(140)/'Im2m    '/,NUMSP(140)/' 44B'/
C-----I2MM      (44C)
      DATA ILSG(141)/'I2mm    '/,NUMSP(141)/' 44C'/
C-----IBA2      (45A)
      DATA ILSG(142)/'Iba2    '/,NUMSP(142)/' 45A'/
C-----IB2A      (45B)
      DATA ILSG(143)/'Ib2a    '/,NUMSP(143)/' 45B'/
C-----I2AA      (45C)
      DATA ILSG(144)/'I2aa    '/,NUMSP(144)/' 45C'/
C-----IMA2      (46A)
      DATA ILSG(145)/'Ima2    '/,NUMSP(145)/' 46A'/
C-----IM2A      (46B)
      DATA ILSG(146)/'Im2a    '/,NUMSP(146)/' 46B'/
C-----IBM2      (46C)
      DATA ILSG(147)/'Ibm2    '/,NUMSP(147)/' 46C'/
C-----I2AM      (46D)
      DATA ILSG(148)/'I2am    '/,NUMSP(148)/' 46D'/
C-----IB2M      (46E)
      DATA ILSG(149)/'Ib2m    '/,NUMSP(149)/' 46E'/
C-----I2MA      (46F)
      DATA ILSG(150)/'I2ma    '/,NUMSP(150)/' 46F'/
C-----PMMM      (47)
      DATA ILSG(151)/'Pmmm    '/,NUMSP(151)/' 47 '/
C-----PNNN      (48)
      DATA ILSG(152)/'Pnnn    '/,NUMSP(152)/' 48 '/
C-----PCCM      (49A)
      DATA ILSG(153)/'Pccm    '/,NUMSP(153)/' 49A'/
C-----PMAA      (49B)
      DATA ILSG(154)/'Pmaa    '/,NUMSP(154)/' 49B'/
C-----PBMB      (49C)
      DATA ILSG(155)/'Pbmb    '/,NUMSP(155)/' 49C'/
C-----PBAN      (50A)
      DATA ILSG(156)/'Pban    '/,NUMSP(156)/' 50A'/
C-----PNCB      (50B)
      DATA ILSG(157)/'Pncb    '/,NUMSP(157)/' 50B'/
C-----PCNA      (50C)
      DATA ILSG(158)/'Pcna    '/,NUMSP(158)/' 50C'/
C-----PMMA      (51A)
      DATA ILSG(159)/'Pmma    '/,NUMSP(159)/' 51A'/
C-----PMCM      (51B)
      DATA ILSG(160)/'Pmcm    '/,NUMSP(160)/' 51B'/
C-----PCMM      (51C)
      DATA ILSG(161)/'Pcmm    '/,NUMSP(161)/' 51C'/
C-----PMAM      (51D)
      DATA ILSG(162)/'Pmam    '/,NUMSP(162)/' 51D'/
C-----PBMM      (51E)
      DATA ILSG(163)/'Pbmm    '/,NUMSP(163)/' 51E'/
C-----PMMB      (51F)
      DATA ILSG(164)/'Pmmb    '/,NUMSP(164)/' 51F'/
C-----PNNA      (52A)
      DATA ILSG(165)/'Pnna    '/,NUMSP(165)/' 52A'/
C-----PNNB      (52B)
      DATA ILSG(166)/'Pnnb    '/,NUMSP(166)/' 52B'/
C-----PNAN      (52C)
      DATA ILSG(167)/'Pnan    '/,NUMSP(167)/' 52C'/
C-----PNCN      (52D)
      DATA ILSG(168)/'Pncn    '/,NUMSP(168)/' 52D'/
C-----PBNN      (52E)
      DATA ILSG(169)/'Pbnn    '/,NUMSP(169)/' 52E'/
C-----PCNN      (52F)
      DATA ILSG(170)/'Pcnn    '/,NUMSP(170)/' 52F'/
C-----PMNA      (53A)
      DATA ILSG(171)/'Pmna    '/,NUMSP(171)/' 53A'/
C-----PNCM      (53B)
      DATA ILSG(172)/'Pncm    '/,NUMSP(172)/' 53B'/
C-----PBMN      (53C)
      DATA ILSG(173)/'Pbmn    '/,NUMSP(173)/' 53C'/
C-----PMAN      (53D)
      DATA ILSG(174)/'Pman    '/,NUMSP(174)/' 53D'/
C-----PCNM      (53E)
      DATA ILSG(175)/'Pcnm    '/,NUMSP(175)/' 53E'/
C-----PNMB      (53F)
      DATA ILSG(176)/'Pnmb    '/,NUMSP(176)/' 53F'/
C-----PCCA      (54A)
      DATA ILSG(177)/'Pcca    '/,NUMSP(177)/' 54A'/
C-----PBAA      (54B)
      DATA ILSG(178)/'Pbaa    '/,NUMSP(178)/' 54B'/
C-----PBCB      (54C)
      DATA ILSG(179)/'Pbcb    '/,NUMSP(179)/' 54C'/
C-----PCCB      (54D)
      DATA ILSG(180)/'Pccb    '/,NUMSP(180)/' 54D'/
C-----PBAB      (54E)
      DATA ILSG(181)/'Pbab    '/,NUMSP(181)/' 54E'/
C-----PCAA      (54F)
      DATA ILSG(182)/'Pcaa    '/,NUMSP(182)/' 54F'/
C-----PBAM      (55A)
      DATA ILSG(183)/'Pbam    '/,NUMSP(183)/' 55A'/
C-----PCMA      (55B)
      DATA ILSG(184)/'Pcma    '/,NUMSP(184)/' 55B'/
C-----PMCB      (55C)
      DATA ILSG(185)/'Pmcb    '/,NUMSP(185)/' 55C'/
C-----PCCN      (56A)
      DATA ILSG(186)/'Pccn    '/,NUMSP(186)/' 56A'/
C-----PBNB      (56B)
      DATA ILSG(187)/'Pbnb    '/,NUMSP(187)/' 56B'/
C-----PNAA      (56C)
      DATA ILSG(188)/'Pnaa    '/,NUMSP(188)/' 56C'/
C-----PBCM      (57A)
      DATA ILSG(189)/'Pbcm    '/,NUMSP(189)/' 57A'/
C-----PCMB      (57B)
      DATA ILSG(190)/'Pcmb    '/,NUMSP(190)/' 57B'/
C-----PBMA      (57C)
      DATA ILSG(191)/'Pbma    '/,NUMSP(191)/' 57C'/
C-----PCAM      (57D)
      DATA ILSG(192)/'Pcam    '/,NUMSP(192)/' 57D'/
C-----PMAB      (57E)
      DATA ILSG(193)/'Pmab    '/,NUMSP(193)/' 57E'/
C-----PMCA      (57F)
      DATA ILSG(194)/'Pmca    '/,NUMSP(194)/' 57F'/
C-----PNNM      (58A)
      DATA ILSG(195)/'Pnnm    '/,NUMSP(195)/' 58A'/
C-----PNMN      (58B)
      DATA ILSG(196)/'Pnmn    '/,NUMSP(196)/' 58B'/
C-----PMNN      (58C)
      DATA ILSG(197)/'Pmnn    '/,NUMSP(197)/' 58C'/
C-----PMMN      (59A)
      DATA ILSG(198)/'Pmmn    '/,NUMSP(198)/' 59A'/
C-----PNMM      (59B)
      DATA ILSG(199)/'Pnmm    '/,NUMSP(199)/' 59B'/
C-----PMNM      (59C)
      DATA ILSG(200)/'Pmnm    '/,NUMSP(200)/' 59C'/
C-----PBCN      (60A)
      DATA ILSG(201)/'Pbcn    '/,NUMSP(201)/' 60A'/
C-----PNAB      (60B)
      DATA ILSG(202)/'Pnab    '/,NUMSP(202)/' 60B'/
C-----PNCA      (60C)
      DATA ILSG(203)/'Pnca    '/,NUMSP(203)/' 60C'/
C-----PBNA      (60D)
      DATA ILSG(204)/'Pbna    '/,NUMSP(204)/' 60D'/
C-----PCAN      (60E)
      DATA ILSG(205)/'Pcan    '/,NUMSP(205)/' 60E'/
C-----PCNB      (60F)
      DATA ILSG(206)/'Pcnb    '/,NUMSP(206)/' 60F'/
C-----PBCA      (61A)
      DATA ILSG(207)/'Pbca    '/,NUMSP(207)/' 61A'/
C-----PCAB      (61B)
      DATA ILSG(208)/'Pcab    '/,NUMSP(208)/' 61B'/
C-----PNMA      (62A)
      DATA ILSG(209)/'Pnma    '/,NUMSP(209)/' 62A'/
C-----PMNB      (62B)
      DATA ILSG(210)/'Pmnb    '/,NUMSP(210)/' 62B'/
C-----PBNM      (62C)
      DATA ILSG(211)/'Pbnm    '/,NUMSP(211)/' 62C'/
C-----PMCN      (62D)
      DATA ILSG(212)/'Pmcn    '/,NUMSP(212)/' 62D'/
C-----PCMN      (62E)
      DATA ILSG(213)/'Pcmn    '/,NUMSP(213)/' 62E'/
C-----PNAM      (62F)
      DATA ILSG(214)/'Pnam    '/,NUMSP(214)/' 62F'/
C-----CMCM      (63A)
      DATA ILSG(215)/'Cmcm    '/,NUMSP(215)/' 63A'/
C-----BBMM      (63B)
      DATA ILSG(216)/'Bbmm    '/,NUMSP(216)/' 63B'/
C-----AMAM      (63C)
      DATA ILSG(217)/'Amam    '/,NUMSP(217)/' 63C'/
C-----AMMA      (63D)
      DATA ILSG(218)/'Amma    '/,NUMSP(218)/' 63D'/
C-----CCMM      (63E)
      DATA ILSG(219)/'Ccmm    '/,NUMSP(219)/' 63E'/
C-----BMMB      (63F)
      DATA ILSG(220)/'Bmmb    '/,NUMSP(220)/' 63F'/
C-----CMCA      (64A)
      DATA ILSG(221)/'Cmca    '/,NUMSP(221)/' 64A'/
C-----ABAM      (64B)
      DATA ILSG(222)/'Abam    '/,NUMSP(222)/' 64B'/
C-----CCMA      (64C)
      DATA ILSG(223)/'Ccma    '/,NUMSP(223)/' 64C'/
C-----ABMA      (64D)
      DATA ILSG(224)/'Abma    '/,NUMSP(224)/' 64D'/
C-----BMAB      (64E)
      DATA ILSG(225)/'Bmab    '/,NUMSP(225)/' 64E'/
C-----BBAM      (64F)
      DATA ILSG(226)/'Bbam    '/,NUMSP(226)/' 64F'/
C-----CMMM      (65A)
      DATA ILSG(227)/'Cmmm    '/,NUMSP(227)/' 65A'/
C-----BMMM      (65B)
      DATA ILSG(228)/'Bmmm    '/,NUMSP(228)/' 65B'/
C-----AMMM      (65C)
      DATA ILSG(229)/'Ammm    '/,NUMSP(229)/' 65C'/
C-----CCCM      (66A)
      DATA ILSG(230)/'Cccm    '/,NUMSP(230)/' 66A'/
C-----AMAA      (66B)
      DATA ILSG(231)/'Amaa    '/,NUMSP(231)/' 66B'/
C-----BBMB      (66C)
      DATA ILSG(232)/'Bbmb    '/,NUMSP(232)/' 66C'/
C-----CMMA      (67A)
      DATA ILSG(233)/'Cmma    '/,NUMSP(233)/' 67A'/
C-----ABMM      (67B)
      DATA ILSG(234)/'Abmm    '/,NUMSP(234)/' 67B'/
C-----BMAM      (67C)
      DATA ILSG(235)/'Bmam    '/,NUMSP(235)/' 67C'/
C-----CCCA      (68A)
      DATA ILSG(236)/'Ccca    '/,NUMSP(236)/' 68A'/
C-----BBAB      (68B)
      DATA ILSG(237)/'Bbab    '/,NUMSP(237)/' 68B'/
C-----ABAA      (68C)
      DATA ILSG(238)/'Abaa    '/,NUMSP(238)/' 68C'/
C-----FMMM      (69)
      DATA ILSG(239)/'Fmmm    '/,NUMSP(239)/' 69 '/
C-----FDDD      (70)
      DATA ILSG(240)/'Fddd    '/,NUMSP(240)/' 70 '/
C-----IMMM      (71)
      DATA ILSG(241)/'Immm    '/,NUMSP(241)/' 71 '/
C-----IBAM      (72A)
      DATA ILSG(242)/'Ibam    '/,NUMSP(242)/' 72A'/
C-----IMAA      (72B)
      DATA ILSG(243)/'Imaa    '/,NUMSP(243)/' 72B'/
C-----IBMA      (72C)
      DATA ILSG(244)/'Ibma    '/,NUMSP(244)/' 72C'/
C-----IBCA      (73)
      DATA ILSG(245)/'Ibca    '/,NUMSP(245)/' 73 '/
C-----IMMA      (74A)
      DATA ILSG(246)/'Imma    '/,NUMSP(246)/' 74A'/
C-----IBMM      (74B)
      DATA ILSG(247)/'Ibmm    '/,NUMSP(247)/' 74B'/
C-----IMAM      (74C)
      DATA ILSG(248)/'Imam    '/,NUMSP(248)/' 74C'/
C-----TETRAGONAL STARTS HERE AT NUMBER 249
C-----P4        (75)
      DATA ILSG(249)/'P4      '/,NUMSP(249)/' 75 '/
C-----P41       (76)   AND P43
      DATA ILSG(250)/'P41     '/,NUMSP(250)/' 76 '/
C-----P41,3     (ASPECT 76)
      DATA ILSG(251)/'XXXXXXXX'/,NUMSP(251)/' 76B'/
C-----P42       (77)
      DATA ILSG(252)/'P42     '/,NUMSP(252)/' 77 '/
C-----P43       (78)    ASS. 76
      DATA ILSG(253)/'P43     '/,NUMSP(253)/' 78 '/
C-----I4        (79)
      DATA ILSG(254)/'I4      '/,NUMSP(254)/' 79 '/
C-----I41       (80)
      DATA ILSG(255)/'I41     '/,NUMSP(255)/' 80 '/
C-----P BAR 4   (81)
      DATA ILSG(256)/'P-4     '/,NUMSP(256)/' 81 '/
C-----I BAR 4   (82)
      DATA ILSG(257)/'I-4     '/,NUMSP(257)/' 82 '/
C-----P4/M      (83)
      DATA ILSG(258)/'P4/m    '/,NUMSP(258)/' 83 '/
C-----P42/M     (84)
      DATA ILSG(259)/'P42/m   '/,NUMSP(259)/' 84 '/
C-----P4/N      (85)
      DATA ILSG(260)/'P4/n    '/,NUMSP(260)/' 85 '/
C-----P42/N     (86)
      DATA ILSG(261)/'P42/n   '/,NUMSP(261)/' 86 '/
C-----I4/M      (87)
      DATA ILSG(262)/'I4/m    '/,NUMSP(262)/' 87 '/
C-----I41/A     (88)
      DATA ILSG(263)/'I41/a   '/,NUMSP(263)/' 88 '/
C-----P422      (89)
      DATA ILSG(264)/'P422    '/,NUMSP(264)/' 89 '/
C-----P4212     (90)
      DATA ILSG(265)/'P4212   '/,NUMSP(265)/' 90 '/
C-----P4122     (91)   AND P4322
      DATA ILSG(266)/'P4122   '/,NUMSP(266)/' 91 '/
C-----P41,322   (ASPECT 91)
      DATA ILSG(267)/'XXXXXXXX'/,NUMSP(267)/' 91B'/
C-----P41212    (92)   AND P43212
      DATA ILSG(268)/'P41212  '/,NUMSP(268)/' 92 '/
C-----P41,3212  (ASPECT 92)
      DATA ILSG(269)/'XXXXXXXX'/,NUMSP(269)/' 92B'/
C-----P4222     (93)
      DATA ILSG(270)/'P4222   '/,NUMSP(270)/' 93 '/
C-----P42212    (94)
      DATA ILSG(271)/'P42212  '/,NUMSP(271)/' 94 '/
C-----P4322     (95)    ASS. 91
      DATA ILSG(272)/'P4322   '/,NUMSP(272)/' 95 '/
C-----P43212    (96)    ASS. 92
      DATA ILSG(273)/'P43212  '/,NUMSP(273)/' 96 '/
C-----I422      (97)
      DATA ILSG(274)/'I422    '/,NUMSP(274)/' 97 '/
C-----I4122     (98)
      DATA ILSG(275)/'I4122   '/,NUMSP(275)/' 98 '/
C-----P4MM      (99)
      DATA ILSG(276)/'P4mm    '/,NUMSP(276)/' 99 '/
C-----P4BM      (100)
      DATA ILSG(277)/'P4bm    '/,NUMSP(277)/'100 '/
C-----P42CM     (101)
      DATA ILSG(278)/'P42cm   '/,NUMSP(278)/'101 '/
C-----P42NM     (102)
      DATA ILSG(279)/'P42nm   '/,NUMSP(279)/'102 '/
C-----P4CC      (103)
      DATA ILSG(280)/'P4cc    '/,NUMSP(280)/'103 '/
C-----P4NC      (104)
      DATA ILSG(281)/'P4nc    '/,NUMSP(281)/'104 '/
C-----P42MC     (105)
      DATA ILSG(282)/'P42mc   '/,NUMSP(282)/'105 '/
C-----P42BC     (106)
      DATA ILSG(283)/'P42bc   '/,NUMSP(283)/'106 '/
C-----I4MM      (107)
      DATA ILSG(284)/'I4mm    '/,NUMSP(284)/'107 '/
C-----I4CM      (108)
      DATA ILSG(285)/'I4cm    '/,NUMSP(285)/'108 '/
C-----I41MD     (109)
      DATA ILSG(286)/'I41md   '/,NUMSP(286)/'109 '/
C-----I41CD     (110)
      DATA ILSG(287)/'I41cd   '/,NUMSP(287)/'110 '/
C-----PBAR42M   (111)
      DATA ILSG(288)/'P-42m   '/,NUMSP(288)/'111 '/
C-----PBAR42C   (112)
      DATA ILSG(289)/'P-42c   '/,NUMSP(289)/'112 '/
C-----PBAR421M  (113)
      DATA ILSG(290)/'P-421m  '/,NUMSP(290)/'113 '/
C-----PBAR421C  (114)
      DATA ILSG(291)/'P-421c  '/,NUMSP(291)/'114 '/
C-----PBAR4M2   (115)
      DATA ILSG(292)/'P-4m2   '/,NUMSP(292)/'115 '/
C-----PBAR4C2   (116)
      DATA ILSG(293)/'P-4c2   '/,NUMSP(293)/'116 '/
C-----PBAR4B2   (117)
      DATA ILSG(294)/'P-4b2   '/,NUMSP(294)/'117 '/
C-----PBAR4N2   (118)
      DATA ILSG(295)/'P-4n2   '/,NUMSP(295)/'118 '/
C-----IBAR4M2   (119)
      DATA ILSG(296)/'I-4m2   '/,NUMSP(296)/'119 '/
C-----IBAR4C2   (120)
      DATA ILSG(297)/'I-4c2   '/,NUMSP(297)/'120 '/
C-----IBAR42M   (121)
      DATA ILSG(298)/'I-42m   '/,NUMSP(298)/'121 '/
C-----IBAR42D   (122)
      DATA ILSG(299)/'I-42d   '/,NUMSP(299)/'122 '/
C-----P4/MMM    (123)
      DATA ILSG(300)/'P4/mmm  '/,NUMSP(300)/'123 '/
C-----P4/MCC    (124)
      DATA ILSG(301)/'P4/mcc  '/,NUMSP(301)/'124 '/
C-----P4/NBM    (125)
      DATA ILSG(302)/'P4/nbm  '/,NUMSP(302)/'125 '/
C-----P4/NNC    (126)
      DATA ILSG(303)/'P4/nnc  '/,NUMSP(303)/'126 '/
C-----P4/MBM    (127)
      DATA ILSG(304)/'P4/mbm  '/,NUMSP(304)/'127 '/
C-----P4/MNC    (128)
      DATA ILSG(305)/'P4/mnc  '/,NUMSP(305)/'128 '/
C-----P4/NMM    (129)
      DATA ILSG(306)/'P4/nmm  '/,NUMSP(306)/'129 '/
C-----P4/NCC    (130)
      DATA ILSG(307)/'P4/ncc  '/,NUMSP(307)/'130 '/
C-----P42/MMC   (131)
      DATA ILSG(308)/'P42/mmc '/,NUMSP(308)/'131 '/
C-----P42/MCM   (132)
      DATA ILSG(309)/'P42/mcm '/,NUMSP(309)/'132 '/
C-----P42/NBC   (133)
      DATA ILSG(310)/'P42/nbc '/,NUMSP(310)/'133 '/
C-----P42/NNM   (134)
      DATA ILSG(311)/'P42/nnm '/,NUMSP(311)/'134 '/
C-----P42/MBC   (135)
      DATA ILSG(312)/'P42/mbc '/,NUMSP(312)/'135 '/
C-----P42/MNM   (136)
      DATA ILSG(313)/'P42/mnm '/,NUMSP(313)/'136 '/
C-----P42/NMC   (137)
      DATA ILSG(314)/'P42/nmc '/,NUMSP(314)/'137 '/
C-----P42/NCM   (138)
      DATA ILSG(315)/'P42/ncm '/,NUMSP(315)/'138 '/
C-----I4/MMM    (139)
      DATA ILSG(316)/'I4/mmm  '/,NUMSP(316)/'139 '/
C-----I4/MCM    (140)
      DATA ILSG(317)/'I4/mcm  '/,NUMSP(317)/'140 '/
C-----I41/AMD   (141)
      DATA ILSG(318)/'I41/amd '/,NUMSP(318)/'141 '/
C-----I41/ACD   (142)
      DATA ILSG(319)/'I41/acd '/,NUMSP(319)/'142 '/
C-----HEXAGONAL AND RHOMBOHEDRAL START HERE AT NUMBER 320
C-----P3        (143)
      DATA ILSG(320)/'P3      '/,NUMSP(320)/'143 '/
C-----P31       (144)  AND P32
      DATA ILSG(321)/'P31     '/,NUMSP(321)/'144 '/
C-----P31,2     (ASPECT 144)
      DATA ILSG(322)/'XXXXXXXX'/,NUMSP(322)/'144B'/
C-----P32       (145)   ASS. 144
      DATA ILSG(323)/'P32     '/,NUMSP(323)/'145 '/
C-----R3        (146)
      DATA ILSG(324)/'R3      '/,NUMSP(324)/'146 '/
C-----P BAR 3   (147)
      DATA ILSG(325)/'P-3     '/,NUMSP(325)/'147 '/
C-----R BAR 3   (148)
      DATA ILSG(326)/'R-3     '/,NUMSP(326)/'148 '/
C-----P312      (149)
      DATA ILSG(327)/'P312    '/,NUMSP(327)/'149 '/
C-----P321      (150)
      DATA ILSG(328)/'P321    '/,NUMSP(328)/'150 '/
C-----P3112     (151)  AND P3212
      DATA ILSG(329)/'P3112   '/,NUMSP(329)/'151 '/
C-----P31,212   (ASPECT 151)
      DATA ILSG(330)/'XXXXXXXX'/,NUMSP(330)/'151B'/
C-----P3121     (152)  AND P3221
      DATA ILSG(331)/'P3121   '/,NUMSP(331)/'152 '/
C-----P31,221   (ASPECT 152)
      DATA ILSG(332)/'XXXXXXXX'/,NUMSP(332)/'152B'/
C-----P3212     (153)   ASS. 151
      DATA ILSG(333)/'P3212   '/,NUMSP(333)/'153 '/
C-----P3221     (154)   ASS. 152
      DATA ILSG(334)/'P3221   '/,NUMSP(334)/'154 '/
C-----R32       (155)
      DATA ILSG(335)/'R32     '/,NUMSP(335)/'155 '/
C-----P3M1      (156)
      DATA ILSG(336)/'P3m1    '/,NUMSP(336)/'156 '/
C-----P31M      (157)
      DATA ILSG(337)/'P31m    '/,NUMSP(337)/'157 '/
C-----P3C1      (158)
      DATA ILSG(338)/'P3c1    '/,NUMSP(338)/'158 '/
C-----P31C      (159)
      DATA ILSG(339)/'P31c    '/,NUMSP(339)/'159 '/
C-----R3M       (160)
      DATA ILSG(340)/'R3m     '/,NUMSP(340)/'160 '/
C-----R3C       (161)
      DATA ILSG(341)/'R3c     '/,NUMSP(341)/'161 '/
C-----PBAR31M   (162)
      DATA ILSG(342)/'P-31m   '/,NUMSP(342)/'162 '/
C-----PBAR31C   (163)
      DATA ILSG(343)/'P-31c   '/,NUMSP(343)/'163 '/
C-----PBAR3M1   (164)
      DATA ILSG(344)/'P-3m1   '/,NUMSP(344)/'164 '/
C-----PBAR3C1   (165)
      DATA ILSG(345)/'P-3c1   '/,NUMSP(345)/'165 '/
C-----RBAR3M    (166)
      DATA ILSG(346)/'R-3m    '/,NUMSP(346)/'166 '/
C-----RBAR3C    (167)
      DATA ILSG(347)/'R-3c    '/,NUMSP(347)/'167 '/
C-----P6        (168)
      DATA ILSG(348)/'P6      '/,NUMSP(348)/'168 '/
C-----P61       (169)  AND P65
      DATA ILSG(349)/'P61     '/,NUMSP(349)/'169 '/
C-----P61,5     (ASPECT 169)
      DATA ILSG(350)/'XXXXXXXX'/,NUMSP(350)/'169B'/
C-----P65       (170)   ASS. 169
      DATA ILSG(351)/'P65     '/,NUMSP(351)/'170 '/
C-----P62       (171)  AND P64
      DATA ILSG(352)/'P62     '/,NUMSP(352)/'171 '/
C-----P62,4     (ASPECT 171)
      DATA ILSG(353)/'XXXXXXXX'/,NUMSP(353)/'171B'/
C-----P64       (172)   ASS. 171
      DATA ILSG(354)/'P64     '/,NUMSP(354)/'172 '/
C-----P63       (173)
      DATA ILSG(355)/'P63     '/,NUMSP(355)/'173 '/
C-----P-6       (174)
      DATA ILSG(356)/'P-6     '/,NUMSP(356)/'174 '/
C-----P6/M      (175)
      DATA ILSG(357)/'P6/m    '/,NUMSP(357)/'175 '/
C-----P63/M     (176)
      DATA ILSG(358)/'P63/m   '/,NUMSP(358)/'176 '/
C-----P622      (177)
      DATA ILSG(359)/'P622    '/,NUMSP(359)/'177 '/
C-----P6122     (178)  AND P6522
      DATA ILSG(360)/'P6122   '/,NUMSP(360)/'178 '/
C-----P61,522   (ASPECT 178)
      DATA ILSG(361)/'XXXXXXXX'/,NUMSP(361)/'178B'/
C-----P6522     (179)   ASS. 178
      DATA ILSG(362)/'P6522   '/,NUMSP(362)/'179 '/
C-----P6222     (180)  AND P6422
      DATA ILSG(363)/'P6222   '/,NUMSP(363)/'180 '/
C-----P62,422   (ASPECT 180)
      DATA ILSG(364)/'XXXXXXXX'/,NUMSP(364)/'180B'/
C-----P6422     (181)   ASS. 180
      DATA ILSG(365)/'P6422   '/,NUMSP(365)/'181 '/
C-----P6322     (182)
      DATA ILSG(366)/'P6322   '/,NUMSP(366)/'182 '/
C-----P6MM      (183)
      DATA ILSG(367)/'P6mm    '/,NUMSP(367)/'183 '/
C-----P6CC      (184)
      DATA ILSG(368)/'P6cc    '/,NUMSP(368)/'184 '/
C-----P63CM     (185)
      DATA ILSG(369)/'P63cm   '/,NUMSP(369)/'185 '/
C-----P63MC     (186)
      DATA ILSG(370)/'P63mc   '/,NUMSP(370)/'186 '/
C-----PBAR6M2   (187)
      DATA ILSG(371)/'P-6m2   '/,NUMSP(371)/'187 '/
C-----PBAR6C2   (188)
      DATA ILSG(372)/'P-6c2   '/,NUMSP(372)/'188 '/
C-----PBAR62M   (189)
      DATA ILSG(373)/'P-62m   '/,NUMSP(373)/'189 '/
C-----PBAR62C   (190)
      DATA ILSG(374)/'P-62c   '/,NUMSP(374)/'190 '/
C-----P6/MMM    (191)
      DATA ILSG(375)/'P6/mmm  '/,NUMSP(375)/'191 '/
C-----P6/MCC    (192)
      DATA ILSG(376)/'P6/mcc  '/,NUMSP(376)/'192 '/
C-----P63/MCM   (193)
      DATA ILSG(377)/'P63/mcm '/,NUMSP(377)/'193 '/
C-----P63/MMC   (194)
      DATA ILSG(378)/'P63/mmc '/,NUMSP(378)/'194 '/
C-----CUBIC STARTS HERE AT NUMBER 379
C-----P23       (195)
      DATA ILSG(379)/'P23     '/,NUMSP(379)/'195 '/
C-----F23       (196)
      DATA ILSG(380)/'F23     '/,NUMSP(380)/'196 '/
C-----I23       (197)
      DATA ILSG(381)/'I23     '/,NUMSP(381)/'197 '/
C-----P213      (198)
      DATA ILSG(382)/'P213    '/,NUMSP(382)/'198 '/
C-----I213      (199)
      DATA ILSG(383)/'I213    '/,NUMSP(383)/'199 '/
C-----PM3       (200)
      DATA ILSG(384)/'Pm3     '/,NUMSP(384)/'200 '/
C-----PN3       (201)
      DATA ILSG(385)/'Pn3     '/,NUMSP(385)/'201 '/
C-----FM3       (202)
      DATA ILSG(386)/'Fm3     '/,NUMSP(386)/'202 '/
C-----FD3       (203)
      DATA ILSG(387)/'Fd3     '/,NUMSP(387)/'203 '/
C-----IM3       (204)
      DATA ILSG(388)/'Im3     '/,NUMSP(388)/'204 '/
C-----PA3       (205)
      DATA ILSG(389)/'Pa3     '/,NUMSP(389)/'205 '/
C-----IA3       (206)
      DATA ILSG(390)/'Ia3     '/,NUMSP(390)/'206 '/
C-----P432      (207)
      DATA ILSG(391)/'P432    '/,NUMSP(391)/'207 '/
C-----P4232     (208)
      DATA ILSG(392)/'P4232   '/,NUMSP(392)/'208 '/
C-----F432      (209)
      DATA ILSG(393)/'F432    '/,NUMSP(393)/'209 '/
C-----F4132     (210)
      DATA ILSG(394)/'F4132   '/,NUMSP(394)/'210 '/
C-----I432      (211)
      DATA ILSG(395)/'I432    '/,NUMSP(395)/'211 '/
C-----P4332     (212)  AND P4132
      DATA ILSG(396)/'P4332   '/,NUMSP(396)/'212 '/
C-----P41,332   (ASPECT 212)
      DATA ILSG(397)/'XXXXXXXX'/,NUMSP(397)/'212B'/
C-----P4132     (213)   ASS. 212
      DATA ILSG(398)/'P4132   '/,NUMSP(398)/'213 '/
C-----I4132     (214)
      DATA ILSG(399)/'I4132   '/,NUMSP(399)/'214 '/
C-----PBAR43M   (215)
      DATA ILSG(400)/'P-43m   '/,NUMSP(400)/'215 '/
C-----FBAR43M   (216)
      DATA ILSG(401)/'F-43m   '/,NUMSP(401)/'216 '/
C-----IBAR43M   (217)
      DATA ILSG(402)/'I-43m   '/,NUMSP(402)/'217 '/
C-----PBAR43N   (218)
      DATA ILSG(403)/'P-43n   '/,NUMSP(403)/'218 '/
C-----FBAR43C   (219)
      DATA ILSG(404)/'F-43c   '/,NUMSP(404)/'219 '/
C-----IBAR43D   (220)
      DATA ILSG(405)/'I-43d   '/,NUMSP(405)/'220 '/
C-----PM3M      (221)
      DATA ILSG(406)/'Pm3m    '/,NUMSP(406)/'221 '/
C-----PN3N      (222)
      DATA ILSG(407)/'Pn3n    '/,NUMSP(407)/'222 '/
C-----PM3N      (223)
      DATA ILSG(408)/'Pm3n    '/,NUMSP(408)/'223 '/
C-----PN3M      (224)
      DATA ILSG(409)/'Pn3m    '/,NUMSP(409)/'224 '/
C-----FM3M      (225)
      DATA ILSG(410)/'Fm3m    '/,NUMSP(410)/'225 '/
C-----FM3C      (226)
      DATA ILSG(411)/'Fm3c    '/,NUMSP(411)/'226 '/
C-----FD3M      (227)
      DATA ILSG(412)/'Fd3m    '/,NUMSP(412)/'227 '/
C-----FD3C      (228)
      DATA ILSG(413)/'Fd3c    '/,NUMSP(413)/'228 '/
C-----IM3M      (229)
      DATA ILSG(414)/'Im3m    '/,NUMSP(414)/'229 '/
C-----IA3D      (230)
      DATA ILSG(415)/'Ia3d    '/,NUMSP(415)/'230 '/
      DATA NUMSP(416)/'  0 '/
C-----ASPECT TABLE
C
C-----ANORTHIC (TRICLINIC) STARTS HERE AT ASPECT NUMBER 1
C-----P*,-1 (2) P-1, P1
      DATA IASP(1)/'P*,-1   '/  ,NUMAS(  1)/'  2 '/
C-----MONOCLINIC STARTS HERE AT ASPECT NUMBER 2
C-----P*/* (10) P2/M, P2, PM
      DATA IASP(2)/'P*/*    '/  ,NUMAS(  2)/' 10 '/
C-----P21/* (11) P21/M, P21
      DATA IASP(3)/'P21/*   '/  ,NUMAS(  3)/' 11 '/
C-----C*/* (12A) C2/M, C2, CM
      DATA IASP(4)/'C*/*    '/  ,NUMAS(  4)/' 12A'/
C-----A*/* (12B) A2/M, A2, AM
      DATA IASP(5)/'A*/*    '/  ,NUMAS(  5)/' 12B'/
C-----I*/* (12C) I2/M, I2, IM
      DATA IASP(6)/'I*/*    '/  ,NUMAS(  6)/' 12C'/
C-----P*/C (13A) P2/C, PC
      DATA IASP(7)/'P*/c    '/  ,NUMAS(  7)/' 13A'/
C-----P*/A (13B) P2/A, PA
      DATA IASP(8)/'P*/a    '/  ,NUMAS(  8)/' 13B'/
C-----P*/N (13C) P2/N, PN
      DATA IASP(9)/'P*/n    '/  ,NUMAS(  9)/' 13C'/
C-----C*/C (15A) C2/C, CC
      DATA IASP(10)/'C*/c    '/ ,NUMAS( 10)/' 15A'/
C-----A*/A (15B) A2/A, AA
      DATA IASP(11)/'A*/a    '/ ,NUMAS( 11)/' 15B'/
C-----I*/A (15C) I2/A, IA
      DATA IASP(12)/'I*/a    '/ ,NUMAS( 12)/' 15C'/
C-----ORTHORHOMBIC STARTS HERE AT ASPECT NUMBER 13
C-----P*** (47) PMMM, P222, PMM2, PM2M, P2MM
      DATA IASP(13)/'P***    '/ ,NUMAS( 13)/' 47 '/
C-----PCC* (49A) PCCM, PCC2
      DATA IASP(14)/'Pcc*    '/ ,NUMAS( 14)/' 49A'/
C-----P*AA (49B) PMAA, P2AA
      DATA IASP(15)/'P*aa    '/ ,NUMAS( 15)/' 49B'/
C-----PB*B (49C) PBMB, PB2B
      DATA IASP(16)/'Pb*b    '/ ,NUMAS( 16)/' 49C'/
C-----P**A (51A) PMMA, P21MA, PM2A
      DATA IASP(17)/'P**a    '/ ,NUMAS( 17)/' 51A'/
C-----P*C* (51B) PMCM, PMC21, P2CM
      DATA IASP(18)/'P*c*    '/ ,NUMAS( 18)/' 51B'/
C-----PC** (51C) PCMM, PCM21, PC2M
      DATA IASP(19)/'Pc**    '/ ,NUMAS( 19)/' 51C'/
C-----P*A* (51D) PMAM, P21AM, PMA2
      DATA IASP(20)/'P*a*    '/ ,NUMAS( 20)/' 51D'/
C-----PB** (51E) PBMM, PB21M, PBM2
      DATA IASP(21)/'Pb**    '/ ,NUMAS( 21)/' 51E'/
C-----P**B (51F) PMMB, PM21B, P2MB
      DATA IASP(22)/'P**b    '/ ,NUMAS( 22)/' 51F'/
C-----P*NA (53A) PMNA, P2NA
      DATA IASP(23)/'P*na    '/ ,NUMAS( 23)/' 53A'/
C-----PNC* (53B) PNCM, PNC2
      DATA IASP(24)/'Pnc*    '/ ,NUMAS( 24)/' 53B'/
C-----PB*N (53C) PBMN, PB2N
      DATA IASP(25)/'Pb*n    '/ ,NUMAS( 25)/' 53C'/
C-----P*AN (53D) PMAN, P2AN
      DATA IASP(26)/'P*an    '/ ,NUMAS( 26)/' 53D'/
C-----PCN* (53E) PCNM, PCN2
      DATA IASP(27)/'Pcn*    '/ ,NUMAS( 27)/' 53E'/
C-----PN*B (53F) PNMB, PN2B
      DATA IASP(28)/'Pn*b    '/ ,NUMAS( 28)/' 53F'/
C-----PBA* (55A) PBAM, PBA2
      DATA IASP(29)/'Pba*    '/ ,NUMAS( 29)/' 55A'/
C-----PC*A (55B) PCMA, PC2A
      DATA IASP(30)/'Pc*a    '/ ,NUMAS( 30)/' 55B'/
C-----P*CB (55C) PMCB, P2CB
      DATA IASP(31)/'P*cb    '/ ,NUMAS( 31)/' 55C'/
C-----PBC* (57A) PBCM, PBC21
      DATA IASP(32)/'Pbc*    '/ ,NUMAS( 32)/' 57A'/
C-----PC*B (57B) PCMB, PC21B
      DATA IASP(33)/'Pc*b    '/ ,NUMAS( 33)/' 57B'/
C-----PB*A (57C) PBMA, PB21A
      DATA IASP(34)/'Pb*a    '/ ,NUMAS( 34)/' 57C'/
C-----PCA* (57D) PCAM, PCA21
      DATA IASP(35)/'Pca*    '/ ,NUMAS( 35)/' 57D'/
C-----P*AB (57E) PMAB, P21AB
      DATA IASP(36)/'P*ab    '/ ,NUMAS( 36)/' 57E'/
C-----P*CA (57F) PMCA, P21CA
      DATA IASP(37)/'P*ca    '/ ,NUMAS( 37)/' 57F'/
C-----PNN* (58A) PNNM, PNN2
      DATA IASP(38)/'Pnn*    '/ ,NUMAS( 38)/' 58A'/
C-----PN*N (58B) PNMN, PN2N
      DATA IASP(39)/'Pn*n    '/ ,NUMAS( 39)/' 58B'/
C-----P*NN (58C) PMNN, P2NN
      DATA IASP(40)/'P*nn    '/ ,NUMAS( 40)/' 58C'/
C-----P**N (59A) PMMN, PM21N, P21MN
      DATA IASP(41)/'P**n    '/ ,NUMAS( 41)/' 59A'/
C-----PN** (59B) PNMM, PNM21, PN21M
      DATA IASP(42)/'Pn**    '/ ,NUMAS( 42)/' 59B'/
C-----P*N* (59C) PMNM, PMN21, P21NM
      DATA IASP(43)/'P*n*    '/ ,NUMAS( 43)/' 59C'/
C-----PN*A (62A) PNMA, PN21A
      DATA IASP(44)/'Pn*a    '/ ,NUMAS( 44)/' 62A'/
C-----P*NB (62B) PMNB, P21NB
      DATA IASP(45)/'P*nb    '/ ,NUMAS( 45)/' 62B'/
C-----PBN* (62C) PBNM, PBN21
      DATA IASP(46)/'Pbn*    '/ ,NUMAS( 46)/' 62C'/
C-----P*CN (62D) PMCN, P21CN
      DATA IASP(47)/'P*cn    '/ ,NUMAS( 47)/' 62D'/
C-----PC*N (62E) PCMN, PC21N
      DATA IASP(48)/'Pc*n    '/ ,NUMAS( 48)/' 62E'/
C-----PNA* (62F) PNAM, PNA21
      DATA IASP(49)/'Pna*    '/ ,NUMAS( 49)/' 62F'/
C-----C*C* (63A) CMCM, CMC21, C2CM
      DATA IASP(50)/'C*c*    '/ ,NUMAS( 50)/' 63A'/
C-----BB** (63B) BBMM, BB21M, BBM2
      DATA IASP(51)/'Bb**    '/ ,NUMAS( 51)/' 63B'/
C-----A*A* (63C) AMAM, A21AM, AMA2
      DATA IASP(52)/'A*a*    '/ ,NUMAS( 52)/' 63C'/
C-----A**A (63D) AMMA, A21MA, AM2A
      DATA IASP(53)/'A**a    '/ ,NUMAS( 53)/' 63D'/
C-----CC** (63E) CCMM, CCM21, CC2M
      DATA IASP(54)/'Cc**    '/ ,NUMAS( 54)/' 63E'/
C-----B**B (63F) BMMB, BM21B, B2MB
      DATA IASP(55)/'B**b    '/ ,NUMAS( 55)/' 63F'/
C-----C*CA (64A) CMCA, C2CA
      DATA IASP(56)/'C*ca    '/ ,NUMAS( 56)/' 64A'/
C-----ABA* (64B) ABAM, ABA2
      DATA IASP(57)/'Aba*    '/ ,NUMAS( 57)/' 64B'/
C-----CC*A (64C) CCMA, CC2A
      DATA IASP(58)/'Cc*a    '/ ,NUMAS( 58)/' 64C'/
C-----AB*A (64D) ABMA, AB2A
      DATA IASP(59)/'Ab*a    '/ ,NUMAS( 59)/' 64D'/
C-----B*AB (64E) BMAB, B2AB
      DATA IASP(60)/'B*ab    '/ ,NUMAS( 60)/' 64E'/
C-----BBA* (64F) BBAM, BBA2
      DATA IASP(61)/'Bba*    '/ ,NUMAS( 61)/' 64F'/
C-----C*** (65A) CMMM, C222, CMM2, C2MM, CM2M
      DATA IASP(62)/'C***    '/ ,NUMAS( 62)/' 65A'/
C-----B*** (65B) BMMM, B222, BM2M, B2MM, BMM2
      DATA IASP(63)/'B***    '/ ,NUMAS( 63)/' 65B'/
C-----A*** (65C) AMMM, A222, A2MM, AMM2, AM2M
      DATA IASP(64)/'A***    '/ ,NUMAS( 64)/' 65C'/
C-----CCC* (66A) CCCM, CCC2
      DATA IASP(65)/'Ccc*    '/ ,NUMAS( 65)/' 66A'/
C-----A*AA (66B) AMAA, A2AA
      DATA IASP(66)/'A*aa    '/ ,NUMAS( 66)/' 66B'/
C-----BB*B (66C) BBMB, BB2B
      DATA IASP(67)/'Bb*b    '/ ,NUMAS( 67)/' 66C'/
C-----C**A (67A) CMMA, C2MA, CM2A
      DATA IASP(68)/'C**a    '/ ,NUMAS( 68)/' 67A'/
C-----AB** (67B) ABMM, ABM2, AB2M
      DATA IASP(69)/'Ab**    '/ ,NUMAS( 69)/' 67B'/
C-----B*A* (67C) BMAM, BMA2, B2AM
      DATA IASP(70)/'B*a*    '/ ,NUMAS( 70)/' 67C'/
C-----F*** (69) FMMM, F222, FMM2, FM2M, F2MM
      DATA IASP(71)/'F***    '/ ,NUMAS( 71)/' 69 '/
C-----I*** (71) IMMM, I212121, IMM2, IM2M, I2MM
      DATA IASP(72)/'I***    '/ ,NUMAS( 72)/' 71 '/
C-----IBA* (72A) IBAM, IBA2
      DATA IASP(73)/'Iba*    '/ ,NUMAS( 73)/' 72A'/
C-----I*AA (72B) IMAA, I2AA
      DATA IASP(74)/'I*aa    '/ ,NUMAS( 74)/' 72B'/
C-----IB*A (72C) IBMA, IB2A
      DATA IASP(75)/'Ib*a    '/ ,NUMAS( 75)/' 72C'/
C-----I**A (74A) IMMA, IM2A, I2MA
      DATA IASP(76)/'I**a    '/ ,NUMAS( 76)/' 74A'/
C-----IB** (74B) IBMM, IBM2, IB2M
      DATA IASP(77)/'Ib**    '/ ,NUMAS( 77)/' 74B'/
C-----I*A* (74C) IMAM, IMA2, I2AM
      DATA IASP(78)/'I*a*    '/ ,NUMAS( 78)/' 74C'/
C-----TETRAGONAL STARTS HERE AT ASPECT NUMBER 79
C-----P41,3 (76) P41, P43
      DATA IASP(79)/'P41,3   '/ ,NUMAS( 79)/' 76 '/
C-----P4/* (83) P4/M, P4, P-4
      DATA IASP(80)/'P4/*    '/ ,NUMAS( 80)/' 83 '/
C-----P42/* (84) P42/M, P42
      DATA IASP(81)/'P42/*   '/ ,NUMAS( 81)/' 84 '/
C-----I4/* (87) I4/M, I4, I-4
      DATA IASP(82)/'I4/*    '/ ,NUMAS( 82)/' 87 '/
C-----P41,322 (91) P4122, P4322
      DATA IASP(83)/'P41,322 '/ ,NUMAS( 83)/' 91 '/
C-----P41,3212 (92) P41212, P43212
      DATA IASP(84)/'P41,3212'/ ,NUMAS( 84)/' 92 '/
C-----P421* (113) P-421M, P4212
      DATA IASP(85)/'P421*   '/ ,NUMAS( 85)/'113 '/
C-----I4*D (122) I-42D, I41MD
      DATA IASP(86)/'I4*d    '/ ,NUMAS( 86)/'122 '/
C-----P4/*** (123) P4/MMM, P422, P4MM, P-42M, P-4M2
      DATA IASP(87)/'P4/***  '/ ,NUMAS( 87)/'123 '/
C-----P4/*CC (124) P4/MCC, P4CC
      DATA IASP(88)/'P4/*cc  '/ ,NUMAS( 88)/'124 '/
C-----P4/*B* (127) P4/MBM, P4BM, P-4B2
      DATA IASP(89)/'P4/*b*  '/ ,NUMAS( 89)/'127 '/
C-----P4/*NC (128) P4/MNC, P4NC
      DATA IASP(90)/'P4/*nc  '/ ,NUMAS( 90)/'128 '/
C-----P4/**C (131) P42/MMC, P42MC, P-42C
      DATA IASP(91)/'P4/**c  '/ ,NUMAS( 91)/'131 '/
C-----P4/*C* (132) P42/MCM, P42CM, P-4C2
      DATA IASP(92)/'P4/*c*  '/ ,NUMAS( 92)/'132 '/
C-----P4/*BC (135) P42/MBC, P42BC
      DATA IASP(93)/'P4/*bc  '/ ,NUMAS( 93)/'135 '/
C-----P4/*N* (136) P42/MNM, P42NM, P-4N2
      DATA IASP(94)/'P4/*n*  '/ ,NUMAS( 94)/'136 '/
C-----I4/*** (139) I4/MMM, I422, I4MM, I-4M2, I-42M
      DATA IASP(95)/'I4/***  '/ ,NUMAS( 95)/'139 '/
C-----I4/*C* (140) I4/MCM, I4CM, I-4C2
      DATA IASP(96)/'I4/*c*  '/ ,NUMAS( 96)/'140 '/
C-----HEXAGONAL STARTS HERE AT ASPECT NUMBER 97
C-----P31,2 (144) P31, P32
      DATA IASP(97)/'P31,2   '/ ,NUMAS( 97)/'144 '/
C-----P*,-3 (147) P-3, P3
      DATA IASP(98)/'P*,-3   '/ ,NUMAS( 98)/'147 '/
C-----R* (148) R-3, R3
      DATA IASP(99)/'R*      '/ ,NUMAS( 99)/'148 '/
C-----P31,212 (151) P3112, P3212
      DATA IASP(100)/'P31,212 '/,NUMAS(100)/'151 '/
C-----P31,221 (152) P3121, P3221
      DATA IASP(101)/'P31,221 '/,NUMAS(101)/'152 '/
C-----P31* (162) P-31M, P312, P31M
      DATA IASP(102)/'P31*    '/,NUMAS(102)/'162 '/
C-----P*1C,-3M (163) P-31C, P31C
      DATA IASP(103)/'P*1c,-3m'/,NUMAS(103)/'163 '/
C-----P3*1 (164) P-3M1, P321, P3M1
      DATA IASP(104)/'P3*1    '/,NUMAS(104)/'164 '/
C-----P*C1,-3M (165) P-3C1, P3C1
      DATA IASP(105)/'P*c1,-3m'/,NUMAS(105)/'165 '/
C-----R** (166) R-3M, R32, R3M
      DATA IASP(106)/'R**     '/,NUMAS(106)/'166 '/
C-----R*C (167) R-3C, R3C
      DATA IASP(107)/'R*c     '/,NUMAS(107)/'167 '/
C-----P61,5 (169) P61, P65
      DATA IASP(108)/'P61,5   '/,NUMAS(108)/'169 '/
C-----P62,4 (171) P62, P64
      DATA IASP(109)/'P62,4   '/,NUMAS(109)/'171 '/
C-----P6/* (175) P6/M, P6, P-6
      DATA IASP(110)/'P6/*    '/,NUMAS(110)/'175 '/
C-----P63/* (176) P63/M, P63
      DATA IASP(111)/'P63/*   '/,NUMAS(111)/'176 '/
C-----P61,522 (178) P6122, P6522
      DATA IASP(112)/'P61,522 '/,NUMAS(112)/'178 '/
C-----P62,422 (180) P6222, P6422
      DATA IASP(113)/'P62,422 '/,NUMAS(113)/'180 '/
C-----P6/*** (191) P6/MMM, P622, P6MM, P-6M2, P-62M
      DATA IASP(114)/'P6/***  '/,NUMAS(114)/'191 '/
C-----P6/*CC (192) P6/MCC, P6CC
      DATA IASP(115)/'P6/*cc  '/,NUMAS(115)/'192 '/
C-----P6/*C* (193) P63/MCM, P63CM, P-6C2
      DATA IASP(116)/'P6/*c*  '/,NUMAS(116)/'193 '/
C-----P6/**C (194) P63/MMC, P63MC, P-62C
      DATA IASP(117)/'P6/**c  '/,NUMAS(117)/'194 '/
C-----CUBIC STARTS HERE AT ASPECT NUMBER 118
C-----P*3 (200) PM3, P23
      DATA IASP(118)/'P*3     '/,NUMAS(118)/'200 '/
C-----F*3 (202) FM3, F23
      DATA IASP(119)/'F*3     '/,NUMAS(119)/'202 '/
C-----I*3 (204) IM3, I23, I213
      DATA IASP(120)/'I*3     '/,NUMAS(120)/'204 '/
C-----P41,332 (212) P4332, P4132
      DATA IASP(121)/'P41,332 '/,NUMAS(121)/'212 '/
C-----P*3* (221) PM3M, P432, P-43M
      DATA IASP(122)/'P*3*    '/,NUMAS(122)/'221 '/
C-----P*3N (223) PM3N, P-43N
      DATA IASP(123)/'P*3n    '/,NUMAS(123)/'223 '/
C-----F*3* (225) FM3M, F432, F-43M
      DATA IASP(124)/'F*3*    '/,NUMAS(124)/'225 '/
C-----F*3C (226) FM3C, F-43C
      DATA IASP(125)/'F*3c    '/,NUMAS(125)/'226 '/
C-----I*3* (229) IM3M, I432, I-43M
      DATA IASP(126)/'I*3*    '/,NUMAS(126)/'229 '/
C
C-----ALSO ACCEPT THE FOUR ASPECTS WITHOUT LAUE SYMMETRY
C-----P*,-1 (2)    ACCEPT P*
      DATA IASP(127)/'P*      '/,NUMAS(127)/'  2 '/
C-----P*,-3 (147)    ACCEPT P*
      DATA IASP(128)/'P*      '/,NUMAS(128)/'147 '/
C-----P*1C,-3M (163)    ACCEPT P*1C
      DATA IASP(129)/'P*1c    '/,NUMAS(129)/'163 '/
C-----P*C1,-3M (165)    ACCEPT P*C1
      DATA IASP(130)/'P*c1    '/,NUMAS(130)/'165 '/
      DATA IHC,IHD,IH1,IH3,IHM/',','-','1','3','m'/
      DATA IASPEC(1)/' '/, IASPEC(2)/'*'/
C-----BEGINING
 10   IOK=0
      IMATCH=0
      NASPEC=1
C
C-----TEST ICRS TO DETERMINE WHICH CRYSTAL SYSTEM
C
      IF(ICRS.EQ.ITCRS(1)) GO TO 100
      IF(ICRS.EQ.ITCRS(2)) GO TO 200
      IF(ICRS.EQ.ITCRS(3)) GO TO 300
      IF(ICRS.EQ.ITCRS(4)) GO TO 400
      IF(ICRS.EQ.ITCRS(5)) GO TO 500
      IF(ICRS.EQ.ITCRS(6)) GO TO 500
      IF(ICRS.EQ.ITCRS(7)) GO TO 600
      GO TO 700
C-----ANORTHIC REGION
100   DO 110  I= 1,2
      IF(ISGC.NE.ILSG(I))  GO TO 110
      IOK=1
      IMATCH=I
      GO TO 120
110   CONTINUE
      IF(ISGC.NE.IASP(1).AND.ISGC.NE.IASP(127)) GO TO 120
      IOK=1
      IMATCH=1
      IF(ISGC.EQ.IASP(127)) IMATCH=127
      NASPEC=2
120   CONTINUE
      GO TO 700
C-----MONOCLINIC REGION
C-----DO NOT ASSIGN NUMBER IF A-CENTERED, A-UNIQUE ETC
200   IF(IPASS.EQ.1.AND.SPGI(1:1).EQ.ITSG(2).AND.IFA.EQ.0)GO TO 700
      IF(IPASS.EQ.1.AND.SPGI(1:1).EQ.ITSG(3).AND.IFB.EQ.0)GO TO 700
      IF(IPASS.EQ.1.AND.SPGI(1:1).EQ.ITSG(4).AND.IFC.EQ.0)GO TO 700
      DO 210  I=3,31
      IF(ISGC.NE.ILSG(I)) GO TO 210
      IOK=1
      IMATCH=I
      GO TO 230
210   CONTINUE
      DO 220 I=2,12
      IF(ISGC.NE.IASP(I)) GO TO 220
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 230
220   CONTINUE
230   CONTINUE
      GO TO 700
C-----ORTHORHOMBIC REGION
300   DO 310  I=32,248
      IF(ISGC.NE.ILSG(I))  GO TO 310
      IOK=1
      IMATCH=I
      GO TO 330
310   CONTINUE
      DO 320 I=13,78
      IF(ISGC.NE.IASP(I)) GO TO 320
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 330
320   CONTINUE
330   CONTINUE
      GO TO 700
C-----TETRAGONAL REGION
400   DO 410 I=249,319
      IF(ISGC.NE.ILSG(I))  GO TO 410
      IOK=1
      IMATCH=I
      GO TO 430
410   CONTINUE
      DO 420 I=79,96
      IF(ISGC.NE.IASP(I)) GO TO 420
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 430
420   CONTINUE
430   CONTINUE
      GO TO 700
C-----HEXAGONAL AND RHOMBOHEDRAL REGION
500   DO 510  I=320,378
      IF(ISGC.NE.ILSG(I))  GO TO 510
      IOK=1
      IMATCH=I
      GO TO 530
510   CONTINUE
      DO 520 I=97,117
      IF(ISGC.NE.IASP(I)) GO TO 520
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 530
520   CONTINUE
      DO 525 I=128,130
      IF(ISGC.NE.IASP(I)) GO TO 525
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 530
525   CONTINUE
530   CONTINUE
      GO TO 700
C-----CUBIC REGION
600   DO 610  I=379,415
      IF(ISGC.NE.ILSG(I))  GO TO 610
      IOK=1
      IMATCH=I
      GO TO 630
610   CONTINUE
      DO 620 I=118,126
      IF(ISGC.NE.IASP(I)) GO TO 620
      IOK=1
      IMATCH=I
      NASPEC=2
      GO TO 630
620   CONTINUE
630   CONTINUE
C
C-----WAS SPGR# FOUND?
C
700   IF(IOK.EQ.1) GOTO 800
      IMATCH=416
C
C-----TEST IF FIRST OR SECOND PASS
C
800   IF(IPASS.EQ.2) GOTO 900
      SPGIA=IASPEC(NASPEC)
      IF(NASPEC.EQ.1) GO TO 810
      SPGIN=NUMAS(IMATCH)
      GO TO 820
810   SPGIN=NUMSP(IMATCH)
 820  CONTINUE
      GOTO 999
900   SPGTA=IASPEC(NASPEC)
      IF(NASPEC.EQ.1) GO TO 910
      SPGTN=NUMAS(IMATCH)
C
C-----CONVERT TO STANDARD ASPECTS FOR CD CELL
C-----P* TO P*,-1 OR P*,-3  P*c1 TO P*c1,-3m  P*1c TO P*1c,-3m
C
      IF(IMATCH.EQ.127)GO TO 901
      IF(IMATCH.EQ.128)GO TO 902
      IF(IMATCH.EQ.129.OR.IMATCH.EQ.130)GO TO 903
      GO TO 920
901   SPGT(3:3) = IHC
      SPGT(4:4) = IHD
      SPGT(5:5) = IH1
      GO TO 920
902   SPGT(3:3) = IHC
      SPGT(4:4) = IHD
      SPGT(5:5) = IH3
      GO TO 920
903   SPGT(5:5) = IHC
      SPGT(6:6) = IHD
      SPGT(7:7) = IH3
      SPGT(8:8) = IHM
      GO TO 920
910   SPGTN=NUMSP(IMATCH)
 920  CONTINUE
      IF(SPGT(2:2).EQ.ITED(1) .OR. IOK.EQ.1) GOTO 999
      IERR=IERR+1
      WRITE(NTOUT,930) SPGT
930   FORMAT(1H ,33H**ERROR** Crystal data space group,1X, A8,
     * 13H not in table)
999   RETURN
      END
      SUBROUTINE FINDEX
C**************************************************************************
C
C----THIS SUBROUTINE USES THE SPACE GROUP NUMBER AND ORIENTATION
C-----TO SET UP THE EXTINCTION CODES FOR HKL GENERATION
C
C-----A CENTERING SYMBOL BY ITSELF ALSO SETS UP THE APPROPRIATE EXT CODES
C
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/EDITR/IED1(6)
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/IERRS/IWARN,IERR
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*1 IED1
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*4 IHBB0B,NSG
      DIMENSION ITEMP(27)
      DATA IHBB0B/'  0 '/
      IF(SPGIN.EQ.IHBB0B) GOTO 219
      DO 10 I=1,27
10    IOP(I)=0
C-----READ FILE OF EXTINCTION CODES WITH SPACE GROUP # AND ORIENTATION
100   READ (NEXTN,110,END=200) (ITEMP(I),I=1,27),NSG
110   FORMAT (20X,27I1,29X,A4)
      IF (NSG .NE. SPGIN) GO TO 100
C-----LOCATED THE CORRECT SPACE GROUP AND ORIENTATION
C-----SAVE THE EXTINCTION CODES
      DO 120 I=1,27
120   IOP(I)=ITEMP(I)
      RETURN
C-----END OF FILE LOCATED WITHOUT FINDING SPACE GROUP
C------AND ORIENTATION OF AUTHORS
200   IERR=IERR+1
      WRITE (NTOUT,210) SPGIN
210   FORMAT(53H0**ERROR** No entry in extinction file for space group
     *, A4)
C
C-----CHECK IF MORE THAN A CENTERING SYMBOL WAS INPUT
C
219   IF(SPGI(2:2).EQ.ITED(1))GO TO 225
      IWARN=IWARN+1
      WRITE(NTOUT,222) SPGI
222   FORMAT(' **WARNING** You should input extinctions explicitly for',
     *' space group ',A8,'**WARNING**'/
     * ' ',11X,'Only conditions for lattice centering generated')
C
C-----SPACE GROUP SYMBOL IS NOT IN FILE.  IS THERE A CENTERING SYMBOL?
C-----(RHOMBOHEDRAL CENTERING ON HEXAGONAL CELL CODE IS SET
C----- IN SUBROUTINE OPSET)
C
225   IF(SPGI(1:1).EQ.ITSG(1)) GOTO 999
C
C-----SET UP CODE FOR 'A' CENTERING
C
      IF(SPGI(1:1).NE.ITSG(2)) GOTO 226
      IOP(3)=2
      GOTO 999
C
C
C-----SET UP CODE FOR 'B' CENTERING
226   IF(SPGI(1:1).NE.ITSG(3)) GOTO 230
      IOP(2)=2
      GOTO 999
C
C-----SET UP CODE FOR 'C' CENTERING
C
230   IF(SPGI(1:1).NE.ITSG(4)) GOTO 240
      IOP(1)=2
      GOTO 999
C
C-----SET UP CODE FOR 'F' CENTERING
C
240   IF(SPGI(1:1).NE.ITSG(5) .OR. IED1(2).EQ.ITCRS(6)) GOTO 250
      IOP(4)=2
      GOTO 999
C
C-----SET UP CODE FOR 'I' CENTERING
C
250   IF(SPGI(1:1).NE.ITSG(6) .OR. IED1(2).EQ.ITCRS(6)) GOTO 999
      IOP(5)=2
999   RETURN
      END
      SUBROUTINE OPSET
C DOES BOOKKEEPING FOR SETTING UP EXTINCTION RELATIONS TO USE
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      CHARACTER*6 IALF12
      NOPT=0
      IF (JTYP.EQ.8) IOP(6)=3
      DO 9 L=1,27
      IF (IOP(L).LT.2.OR.IOP(L).GT.6.OR.IOP(L).EQ.5) GO TO 9
      NOPT=NOPT+1
      JOP(NOPT)=L
    9 CONTINUE
      RETURN
      END
      SUBROUTINE HKLES
C*********************************************************************
C
C-----ROUTINE NOW ONLY CHECKS HKL VS. EXTINCTION CODES
C
C     PARAMETER (MAXOBS=200)
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/PPEXTN/ IOP(27), JOP(27), NOPT
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/IERRS/IWARN,IERR
      COMMON/IO/NTOUT,NTIN,NEXTN
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 IHED,INTED
      CHARACTER*1 IHN,IHS,IHU
      DATA IHN,IHS,IHU/'N','*','U'/
C-----BEGIN LOOP THROUGH INPUT REFLECTIONS FOR EXTINCTION CHECK
      IF(NOPT .LT. 1) GO TO 999
      DO 20  I=1,NUMOBS
C
C-----TEST IF THIS IS AN INDEXED REFLECTION.  DO NOT TEST THOSE
C-----MARKED WITH "*" OR "U".
C
      IF(IHED(I).EQ.IHS .OR. IHED(I).EQ.IHU) GOTO 20
      JH = IH(I,1)
      JK=IH(I,2)
      JL=IH(I,3)
      CALL CHKEXT(JH,JK,JL,JEXT)
      IF(JEXT .EQ.0) GO TO 20
C-----WRITE OUT ERROR MESSAGE FOR ANY FORBIDDEN INDICIES
 9    ANGLE = OBSTH(I)
      IF(ITHT.EQ.0) ANGLE=ANGLE+ANGLE
      IF(SPGIN.NE.'    ') WRITE(NTOUT,10) JH,JK,JL,ANGLE,DSP(I),SPGI
      IF(SPGIN.EQ.'    ') WRITE(NTOUT,11) JH,JK,JL,ANGLE,DSP(I)
      IERR=IERR+1
   10 FORMAT(1H ,20H**ERROR** Reflection,3I3,7H/angle=,F7.3,3H/d=,
     * F7.4,20H should be absent in,1X,A8)
   11 FORMAT(1H ,20H**ERROR** Reflection,3I3,7H/angle=,F7.3,3H/d=,
     * F7.4,  ' should be absent')
      IHED(I)=IHN
   20 CONTINUE
  999 RETURN
      END

      SUBROUTINE CHKEXT(IH,IK,IL,JEXT)
C CHECKS MILLER INDICES IH,IK,IL FOR EXTINCTIONS - JEXT SET TO 1
C IF CURRENT REFLECTION NOT ACCEPTABLE, JEXT SET TO 0 IF IT IS
      COMMON/ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      JEXT=0
      DO 22 I=1,NOPT
      L=JOP(I)
      IDIV=IOP(L)
      DO 10 J=1,2
      IFIJ=IFI(J,L)
      IF (IFIJ.LT.1.OR.IFIJ.GT.6) GO TO 12
      IANS=IH*IHKL(IFIJ,1)+IK*IHKL(IFIJ,2)+IL*IHKL(IFIJ,3)
      IF (IANS.NE.0) GO TO 22
   10 CONTINUE
   12 DO 20 K=1,3
      IFJK=IFJ(K,L)
      IF (IFJK.LT.1.OR.IFJK.GT.10) GO TO 22
      IARG=JHKL(IFJK,1)*IH+JHKL(IFJK,2)*IK+JHKL(IFJK,3)*IL
      IF (MOD(IARG,IDIV).EQ.0) GO TO 20
      JEXT=1
      GO TO 24
   20 CONTINUE
   22 CONTINUE
   24 RETURN
      END

      SUBROUTINE HKLGEN
C GENERATES MILLER INDICES CORRESPONDING TO PLANES AT DISTANCES FROM
C DMIN ON UP - MAXIMUM OF MAXGEN REFLECTIONS MAY BE GENERATED
C
C      PARAMETER (MAXGEN=1000)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      COMMON/SCRT/E(7),NH(3)
    9 QMAX=1.0/(DMIN*DMIN)
      NR=0
      E(1)=Z(1)
      E(2)=Z(2)
      E(3)=Z(4)
      TD=E(1)*E(2)-E(3)*E(3)
      IL=0
   15 NH(3)=IL
      E(4)=(Z(5)+Z(5))*NH(3)
      E(5)=(Z(6)+Z(6))*NH(3)
      E(6)=Z(3)*NH(3)*NH(3)-QMAX
      TN=E(3)*E(5)-E(1)*E(4)
      DSCRS=TN*TN-(4.0*E(1)*E(6)-E(5)*E(5))*TD
      IF (DSCRS.LT.0.0) GO TO 60
      CALL SKIP (DSCRM,DSCRS,TN,TD,IK,IK1,IK2,IL,GT,HT,QMAX,DEN,
     1           IH,IH1,IH2,JEXT,JSWT)
      GO TO (9,15),JSWT
   60 RETURN
      END

      SUBROUTINE SKIP
     1          (DSCRM,DSCRS,TN,TD,IK,IK1,IK2,IL,GT,HT,QMAX,DEN,
     2           IH,IH1,IH2,JEXT,JSWT)
C     PARAMETER (MAXGEN=1000)
      COMMON/PPEXTN/IOP(27),JOP(27),NOPT
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/IERRS/IWARN,IERR
      COMMON/SCRT/E(7),NH(3)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/UNQ/ IFA,IFB,IFC,IRH
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*6 IALF12
      CHARACTER*4 IH205
      DATA IH205/'205 '/, MAXGEN/1000/
      DSCRM=SQRT(DSCRS)
      IHKSW = 0
C-----LIMITS FOR K IN LAYER OF FIXED L
      IK1=IFIX((TN-DSCRM)*0.5/TD)
      IK2=IFIX((TN+DSCRM)*0.5/TD)
C-----IF A-UNIQUE MONOCLINIC: NO RESTRICTIONS ON K
      IF(JTYP.EQ.4 .AND. IFA.EQ.0) GO TO 29
      GO TO (25,27,27,27,27,29,29,27),JTYP
   25 IF (IK1.LT.   IL) IK1=   IL
      GO TO 29
   27 IF (IK1.LT.0) IK1=0
   29 IK=IK2
      IF (IK .LT. IK1) GO TO 58
C-----NEXT K, IS IT WITHIN LIMITS?
   31 NH(2)=IK
      GT=(E(3)+E(3))*NH(2)+E(5)
      HT=(Z(5)*NH(3)+Z(2)*NH(2))*NH(2)+(Z(5)*NH(2)+Z(3)*NH(3))*NH(3)-
     * QMAX
      CALL SKIP1(DSCRM,DSCRS,GT,HT,DEN,KSWT,Z)
      GO TO (57,577),KSWT
C-----LIMITS FOR H WITH K AND L FIXED
  577 IH1=IFIX(-(GT+DSCRM)/DEN)
      IH2=IFIX((DSCRM-GT)/DEN)
C-----IF A-UNIQUE MONOCLINIC: LIMIT H TO BE .GE.0
      IF(JTYP.EQ.4 .AND. IFA.EQ.0) GO TO 40
      GO TO (42,42,40,44,42,44,44,38),JTYP
   38 IF (MOD(IL,3).EQ.0) GO TO 42
   40 IF (IH1.LT.0) IH1=0
      GO TO 44
   42 IF (IH1.LT.IK) IH1=IK
   44 IH=IH2
      IF (IH .LT. IH1) GO TO 57
C-----NEXT H. IT IS WITHIN D-SPACING LIMITS.
   46 NH(1)=IH
C-----TEST HKL FOR SPACE GROUP EXTINCTIONS
C-----PATCH ADDED BY CRH TO PROPERLY HANDEL PA3 HKL GENERATION.
C-----CODE ORIGINALLY ASSUMED PERMUTABLE INDICIES-BUT THIS IS NOT
C-----ALLOWED IN PA3. FOR EXAMPLE, THE EXTINCT 320 WAS GENERATED
C-----BUT THE ALLOWED 230 WAS NOT.
      IF (NOPT.LT.1) GO TO 50
      IHKSW = 0
      IHT = IH
      IKT = IK
 48   CALL CHKEXT(IHT,IKT,IL,JEXT)
      IF (JEXT .EQ. 0) GO TO 50
C-----SPGIN = '205 ' IS TEST FOR SPACE GROUP Pa3
      IF(SPGIN.NE.IH205 .OR. IHKSW.EQ.1) GOTO 56
C-----SWITCH H AND K AND TEST AGAIN FOR PA3
      NH(1) = IK
      NH(2) = IH
      IHT = IK
      IKT = IH
      IHKSW = 1
      GO TO 48
 50   CALL QCOMP(NH,Z,Q)
      IF (Q.LE.0.0) GO TO 56
C-----TEST FOR MINIMUM D-VALUE
      DTEMP=1.0/SQRT(Q)
      IF(DTEMP.LT.DMIN) GOTO 56
      NR=NR+1
      DCM(NR)=DTEMP
C-----ASSIGN HKL TO ARRAY IHG OF COMMON/HDGEN/
      DO 52 J = 1, 3
 52   IHG(NR,J) = NH(J)
C-----HAVE WE REACHED ARRAY STORAGE CAPACITY?
      IF (NR.LT. MAXGEN) GO TO 56
      CALL SORTD(NR,DCM,IHG)
      CALL SKWEZE
      IF (NR.LT.MAXGEN) GO TO 56
      WRITE(NTOUT,54) MAXGEN,DMIN
C
C   FOR EQUALIVALANCE WITH AIDS
C
      IWARN = IWARN + 1
 54   FORMAT (' ','More than',I4,' reflections exist for dmin =',F10.6)
      DMIN=1.08*DMIN
      WRITE (NTOUT,61) DMIN
   61 FORMAT(31H0New dmin has been set equal to  F10.5/60H0And generatio
     1n of indices started again from the beginning.)
      JSWT = 1
      GO TO 599
56    IF(IHKSW.EQ.0) GOTO 5656
C-----SWITCH H(1) AND H(2)  Pa3 PATCH
      NH(1) = IKT
      NH(2) = IHT
 5656 IH=IH-1
      IF(IH-IH1)57,46,46
   57 IK=IK-1
      IF(IK-IK1)58,31,31
   58 IL=IL+1
      JSWT = 2
  599  RETURN
      END

      SUBROUTINE SKIP1(DSCRM,DSCRS,GT,HT,DEN,KSWT,Z)
      DIMENSION Z(6)
      DEN = Z(1)
      DEN = DEN + Z(1)
      DSCRS = 2.0 * DEN * HT
      DTMP = GT*GT
      DSCRS = DTMP - DSCRS
      IF (DSCRS.LT.0.0) GO TO 57
      DSCRM=SQRT(DSCRS)
      KSWT = 2
    1 RETURN
   57 KSWT = 1
      GO TO 1
      END

      SUBROUTINE QCOMP(NH,Z,Q)
C COMPUTES RECIPROCAL OF SQUARE OF DISTANCE FROM ORIGIN FOR PLANE HKL
      DIMENSION NH(3),Z(6)
      Q= (Z(1)*NH(1)+Z(4)*NH(2)+Z(6)*NH(3))*NH(1)
     1  +(Z(4)*NH(1)+Z(2)*NH(2)+Z(5)*NH(3))*NH(2)
     2  +(Z(6)*NH(1)+Z(5)*NH(2)+Z(3)*NH(3))*NH(3)
      RETURN
      END

      SUBROUTINE SORTD(N,D,IH)
C SORTS ARRAY D SO THAT ELEMENTS ARE IN DECREASING ORDER - MILLER
C INDICES IN ARRAY HH MADE TO CORRESPOND
C     PARAMETER (MAXGEN=1000)
      DIMENSION D(1000),IH(1000,3),NH(3)
      I=N
    2 I=I-1
      IF (I.LT.1) GO TO 12
      DO 10 J=1,I
      IF (D(J).GE.D(J+1)) GO TO 10
      FAC=D(J)
      D(J)=D(J+1)
      D(J+1)=FAC
      DO  9 K=1,3
      NH(K)=IH(J,K)
      IH(J,K)=IH(J+1,K)
    9 IH(J+1,K)=NH(K)
   10 CONTINUE
      GO TO 2
 12   RETURN
      END

      SUBROUTINE SKWEZE
C ELIMINATES REFLECTIONS WITH IDENTICAL D-SPACINGS
C
C     PARAMETER (MAXGEN=1000)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/IERRS/IWARN,IERR
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      COMMON/UNQ/ IFA,IFB,IFC,IRH
      DIMENSION IH(3),JH(3)
      CHARACTER*6 IALF12
      TOL=1.0E-5
      I=1
   12 J=I+1
      IF (J.GT.NR) GO TO 50
      IF ((DCM(I)-DCM(J)).GE.TOL) GO TO 40
      DO 15 K=1,3
      IH(K)=IHG(I,K)
   15 JH(K)=IHG(J,K)
C
C-----SWITCH TEMPORARY INDICIES IH AND JH TO B-UNIQUE SETTING FOR TEST
C     ONLY IF MONOCLINIC
C
   19 IF(ITYP.NE.4 .OR. IFB.EQ.0) GO TO 21
C
C-----IS IT C-UNIQUE
C
      IF(IFC.NE.0) GO TO 20
      IS   = IH(3)
      IH(3)= IH(2)
      IH(2)= IS
      IS   = JH(3)
      JH(3)= JH(2)
      JH(2)= IS
      GO TO 21
C-----BE SURE IT IS A-UNIQUE
   20 IF(IFA.NE.0) GO TO 60
      IS   = IH(2)
      IH(2)= IH(1)
      IH(1)= IS
      IS   = JH(2)
      JH(2)= JH(1)
      JH(1)=IS
C
C-----TEST HKL FOR EQUIVALENCE
C
   21 CALL TSTHKL(ITYP,IH,JH,IEQL)
      IF (IEQL.NE.0) GO TO 27
      J=J+1
      IF (J.GT.NR) GO TO 27
      IF ((DCM(I)-DCM(J)).GE.TOL) GO TO 27
      DO 25 K=1,3
   25 JH(K)=IHG(J,K)
      GO TO 19
   27 JMI=J-I-1
      J2=NR-JMI
      J1=I+1
      IF (J2 .LT. J1) GO TO 35
      DO 34 K=J1,J2
      K2= K+JMI
      DCM(K)=DCM(K2)
      DO 32 L=1,3
   32 IHG(K,L)=IHG(K2,L)
   34 CONTINUE
   35 NR=J2
   40 I=I+1
      GO TO 12
   50 RETURN
   60 WRITE(NTOUT,61)
C
C-----FOR EQUALIVALENCE WITH AIDS
C
      IERR = IERR + 1
   61 FORMAT(1H0,50H**ERROR** In subroutine skweze - monoclinic systems)
      NR=0
      RETURN
      END

      SUBROUTINE TSTHKL(ITYP,IH,JH,IEQL)
C TESTS FOR EXACT EQUALITY OF D-SPACINGS FOR TWO REFLECTIONS
      DIMENSION IH(3),JH(3),ITEST(6,7),IHKLC(6,10)
      DATA ITEST/8,5*0, 3,7,4*0, 1,2,3,3*0, 1,2,3,6,0,0, 3,10,4*0,
     *           1,2,3,4,5,6, 8,9,4*0/,
     * IHKLC/2*1,4*0, 2,2,4*0, 3,3,4*0, 1,2,4*0, 2,3,4*0, 3,1,4*0,
     *       3*1,3*2, 1,1,2,2,3,3, 1,2,2,3,3,1, 1,1,2,2,0,0/
      DO 30 I=1,6
      INTRY=ITEST(I,ITYP)
      IF (INTRY.LT.1.OR.INTRY.GT.10) GO TO 32
      ISUM=0
      J=1
    5 K=IHKLC(J,INTRY)
      IF (K.LT.1.OR.K.GT.3) GO TO 20
      L=IHKLC(J+1,INTRY)
      ISUM=ISUM+IH(K)*IH(L)-JH(K)*JH(L)
      J=J+2
      IF (J.LT.6) GO TO 5
   20 IF (ISUM.EQ.0) GO TO 30
      IEQL=1
      GO TO 34
   30 CONTINUE
   32 IEQL=0
   34 RETURN
      END

      SUBROUTINE SLCR
C
C-----ATTEMPTS TO INDEX REFLECTIONS NOT ALREADY INDEXED
C
C     PARAMETER (MAXOBS=200, MAXGEN=1000)
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/IO/ NTOUT,NTIN,NEXTN
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON /ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/SCRT/E(7),NH(3)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/JA
      COMMON/BLKF/SW(200),WL(200)
      COMMON/BLKG/ICYCLE,IMN,IWCYC,IWTYP
      COMMON/CBLKG/IHEAD
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/BLKJ/TOLMN
      COMMON/ALL/N,NUMCYC,FAC
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CCONTR/ ID0
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED,ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF, JA, IALF12
      CHARACTER*5  CSC
      CHARACTER*68 IHEAD
      ICYCLE=ICYCLE+1
      IF(NUMOBS .LT. 1) GO TO 999
C
C-----TEST IF WEIGHTS ARE TO BE CHANGED AFTER IWCYC CYCLES
C
      IF(IWCYC.EQ.0) GOTO 3
      IF(ICYCLE.LT.IWCYC) GOTO 3
      DO 1 L=1,NUMOBS
1     SW(L) = 1.0
 3    IRSD=0
      SUM=0.0
      RSDMAX=0.0
      TOLP = TOLTH
      IF (ITHT .EQ. 0) TOLP = TOLP + TOLP
      IF (IDOLSQ .EQ. 0) GO TO 7
      IF (IPHKL .NE. 2) WRITE(NTOUT,2) ICYCLE,IHEAD,IALF12,TOLP
    2 FORMAT(6H1cycle,I3,4X,A68,4X,A2,17HTheta tolerance =,F9.5)
C
C-----ROUTINE TO CHECK FOR BAD HKL'S
C
      NUM = 1
      IF ((NCYC + 1) .LE. ICYCLE) CALL BADHKL(NUMOBS,NUM)
      IF (IPHKL .EQ. 0) WRITE(NTOUT,8) IALF12,IALF12,IALF12
    8 FORMAT(4H0  n,4X,1Hh,4X,1Hk,4X,1Hl,5X,6Hd calc,8X,5Hd obs,7X,
     * 6Hlambda,5X,A2,10Htheta calc,4X,A2,9Htheta obs,4X,A2,
     * 10Htheta diff,7X,6Hweight)
 7    CONTINUE
      DO 10 L=1,IMN
   10 A(L)=0.0
      NUMCYC = 0
C
C-----BEGIN SEARCH FOR CLOSEST D-CALC TO D-OBS
C
      TOL  =TOLTH
      IHP=1
      DO 100 IGP=1,NUMOBS
      JA=IALF(7)
      SWT = SW(IGP)
      THOBS=OBSTH(IGP)
      DO 20 L=1,3
      NH(L)=IH(IGP,L)
   20 CONTINUE
      PWL = WL(IGP)
      DOBS=DSP(IGP)
      DMNDF=ABS(DCM(IHP)-DOBS)
      JHP=IHP+1
   28 IF (JHP .GT. NR) GO TO 32
      IF (ABS(DCM(JHP)-DOBS) .GT. DMNDF) GO TO 32
      DMNDF=ABS(DCM(JHP)-DOBS)
      JHP=JHP+1
      GO TO 28
   32 IHP=JHP-1
      IOC(IGP)=IHP
C
C------TEST IF INDEXED
C
      IF(IHED(IGP).EQ.ITIH(1) .OR. IHED(IGP).EQ.ITIH(2) .OR.
     * IHED(IGP).EQ.ITIH(3) .OR. IHED(IGP).EQ.ITIH(7)) GOTO 70
C-----UNINDEXED, SPACE GROUP EXTINCT OR A KNOWN IMPURITY
 33    CONTINUE
      D=DCM(IHP)
      DLST(IGP)=D
      CONST=0.5*PWL
      IF (D .LE. CONST) GO TO 99
      THCMP=THETA(CONST,D)
      IF (ABS((THOBS-THCMP)*SWT) .GT. TOL) GO TO 99
      J=IGP-1
      ASSIGN 50 TO JADRS
   40 IF (J .LT. 1 .OR. J .GT. NUMOBS) GO TO 48
      IF (ABS(OBSTH(J)-THOBS)*SWT .LT. TOLMN) GO TO 99
      CNST=0.5*PWL
      IF (D .LE. CNST) GO TO 48
      THTRY=THETA(CNST,D)
      IF(ABS((OBSTH(J)-THTRY)*SWT) .LE. TOL) GOTO 99
   48 GO TO JADRS,(50,56)
   50 J=IGP+1
      ASSIGN 56 TO JADRS
      GO TO 40
   56 K=IHP-1
      ASSIGN 66 TO KADRS
   60 IF (K .LT. 1 .OR. K .GT. NR) GO TO 64
      DB=DCM(K)
      IF (DB .LE. CONST) GO TO 64
      THTRY=THETA(CONST,DB)
      IF (ABS(THTRY-THCMP)*SWT .LT. TOLMN) GO TO 99
      IF (ABS(THTRY-THOBS)*SWT .LE. TOL) GO TO 99
   64 GO TO KADRS,(66,68)
   66 K=IHP+1
      ASSIGN 68 TO KADRS
      GO TO 60
   68 IF (THOBS .GT. THTMX .AND. ICYCLE .LE. NCYC) GO TO 100
      DO 69 L=1,3
 69   NH(L) =IHG(IHP,L)
      GO TO 90
C-----INDEXED REFLECTION - IH(IGP,4)= 'BLANK', 'M', '+' OR 'E'.
   70 CONST=0.5*PWL
      CALL QCOMP(NH,Z,Q)
      IF(Q.LT.0.00001) GOTO 99
      D=1.0/SQRT(Q)
      DLST(IGP)=D
      IF (CONST .GE. D) GO TO 99
      THCMP=THETA(CONST,D)
      IF (ABS((THCMP-THOBS)*SWT) .LE. TOL) GO TO 90
      JA = IALF(8)
      IF (IDOLSQ .EQ. 1) GO TO 90
      NUM = 1
      CALL BADHKL(NUM,IGP)
      GO TO 33
   90 DIFF=THCMP-THOBS
C
C-----IF WITHIN TOLERENCE AND CAN BE UNIQUELY INDEXED INCLUDE IN
C-----LEAST SQUARES EQUATION (IE, NOT 'R')
C
      IF(JA .EQ. IALF(8)) GOTO 98
      IF (IDOLSQ .EQ. 1) CALL OBSEQ
      IF ((IPHKL .EQ. 0) .AND. (IDOLSQ .EQ. 1)) CALL HKLPR
      CALL NORME
      GO TO 100
 98   IF ((IPHKL .EQ. 0) .AND. (IDOLSQ .EQ. 1)) CALL HKLPR
C
C-----NEGATIVE IOC INDICATE LINE REJECTED FROM LS
C
c$$$$  Here is a crowbar supression of all rejections
c   99 IOC(IGP)=-IOC(IGP)
99	continue
  100 CONTINUE
 999  RETURN
      END

      SUBROUTINE BADHKL(NUMDO, ISTART)
C
C-----CHECK IF DOBS-D CALC OF AUTHOR ASSIGNED HKL GREATER THAN 10*TOLTH
C-----AND IF SO LET PROGRAM REASSIGN HKL'S IF CAN
C
C     PARAMETER (MAXOBS=200)
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     1 NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/IERRS/IWARN,IERR
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 IHED,INTED
      LOGICAL HEADNG
      DATA HEADNG /.FALSE./
C
C-----LOOP FOR ALL HKL'S
C
      DO 200 I = ISTART, NUMDO + ISTART - 1, 1
C
C-----SKIP IF NOT MARKED INDEXED
C
      IF ((IHED(I) .NE. ITIH(1)) .AND. (IHED(I) .NE. ITIH(2)) .AND.
     * (IHED(I) .NE. ITIH(3)) .AND. (IHED(I) .NE. ITIH(7))) GO TO 200
C
C-----SKIP IF IOC >= 0
C
      IF (IOC(I) .GE. 0) GO TO 200
C
C-----SKIP IF DELTA THEAT > 10*TOLTH
C
      THCLC = THETA(CONST,DLST(I))
      DIFF = ABS (OBSTH(I) - THCLC)
      IF (DIFF .LE. (10.0 * TOLTH)) GO TO 200
C
C-----HKL'S POSSIBLY WRONG WRITE MESSAGE, FLAG, AND ZERO OUT HKL'S
C
      DIFF = DIFF * 2.0
      A = OBSTH(I) * 2.0
      IF(HEADNG) WRITE(NTOUT,49)
49    FORMAT('0','**WARNING** Delta 2-theta exceeds 10*tol.  line '
     * 'marked as unindexed**WARNING**')
      HEADNG = .FALSE.
      WRITE (NTOUT, 50) A, (IH(I,J), J = 1, 3), DIFF
 50   FORMAT (' ','2-theta = ',F7.3, ' author''s hkl = ',
     * 3I4 , 'delta 2-theta = ', F7.3)
      IWARN = IWARN + 1
      IHED(I) = ITIH(4)
      DO 100 J = 1, 3, 1
      IH(I,J) = 0
 100  CONTINUE
 200  CONTINUE
      RETURN
      END

      SUBROUTINE OBSEQ
C FORMS OBSERVATION EQUATION FOR ACCEPTED REFLECTIONS
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/ALL/N,NUMCYC,FAC
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/JA
      COMMON/SCRT/E(7),NH(3)
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      CHARACTER*6 IALF12, JA
      NUMCYC=NUMCYC+1
      DIV=COS(0.017453293*THCMP)
      IF (DIV) 5,5,8
    5 NUMCYC=NUMCYC-1
      RETURN
    8 FAC=(57.29578*D*CONST*SWT)/DIV
      EQCNS=SWT*DIFF
      CALL DLQOT
      E(N+1)=-EQCNS
      GO TO (10,20,30,40,50,60,70),ITYP
   10 E(1)=B(1)+B(2)+B(3)
      GO TO 80
   20 E(1)=B(1)+B(2)
      E(2)=B(3)
      GO TO 80
   30 DO 35 J=1,3
   35 E(J)=B(J)
      GO TO 80
   40 DO 45 J=1,3
   45 E(J)=B(J)
      E(4)=B(5)
      GO TO 80
   50 E(1)=B(1)+B(2)
      E(2)=B(3)
      GO TO 80
   60 DO 65 J=1,6
   65 E(J)=B(J)
      GO TO 80
   70 DO 75 J=1,2
   75 E(J)=B(3*J-2)+B(3*J-1)+B(3*J)
 80   RETURN
      END

      SUBROUTINE HKLPR
C
C PRINTS H,K,L,CALCULATED AND OBSERVED D-S AND THETAS
C
C     PARAMETER (MAXOBS=200)
      COMMON/ALL/N,NUMCYC,FAC
      COMMON/SCRT/E(7),NH(3)
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/JA
      CHARACTER*1 IHED,INTED
      CHARACTER*6 JA
      WT=SWT*SWT
      TC=THCMP
      OB=THOBS
      TD=DIFF
      IF (ITHT.NE.0) GO TO 12
      TC=TC+TC
      OB=OB+OB
      TD=TD+TD
 12   WRITE(NTOUT,15) NUMCYC,(NH(L),L=1,3),JA(1:2),D,DOBS,PWL,TC,OB,TD,
     * WT
      RETURN
   15 FORMAT(I4,3I5,A2,F11.6,F13.6,F12.7,F16.5,F15.5,F16.5,F14.5)
      END

      SUBROUTINE NORME
C ACCUMULATES NORMAL EQUATIONS AND SUM OF SQUARES
      COMMON/ALL/N,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/JA
      COMMON/SCRT/E(7),NH(3)
      CHARACTER*6 JA
      EQUIVALENCE (RSMX,RSDMAX),(IRSD,MAXM)
      L=0
      NP1=N+1
      DO 20 J=1,N
      DO 20 K=J,NP1
      L=L+1
   20 A(L)=A(L)+E(J)*E(K)
      SUM=SUM+E(NP1)**2
      IF (ABS(E(NP1)).LE.ABS(RSMX)) GO TO 30
      MAXM = NUMCYC
      RSMX=E(NP1)
 30   RETURN
      END

      SUBROUTINE FNLST
C*************************************************************************
C
C CALLED FROM SUBROUTINE SLCR
C LISTS THEORETICAL REFLECTIONS IN DESCENDING ORDER FOR D-SPACING
C
C***************************************************************************
C     PARAMETER (MAXOBS=200, MAXGEN=1000)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON /ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),CSC(8)
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKF/SW(200),WL(200)
      COMMON/CBLKG/IHEAD
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/CBLKC/JA
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CCONTR/ ID0
      COMMON/BLKH/NCYC,AA(7),DLST(200),IOC(200),THTMX
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CCREAD/ICRYST
      DIMENSION NH(3), JH(3), IAH(3)
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF, IALF12, JA
      CHARACTER*68 IHEAD
      CHARACTER*5 CSC,ICRYST
      CHARACTER*1 IHC
      DATA IHC/'C'/
      I2=0
      IFIRST=0
      IF(NUMOBS.LT.1) GOTO 10
      I2=IABS(IOC(1))
   10 IGP=1
C-----IHP IS ARRAY INDEX TO THE GENERATED HKL
C-----IGP IS ARRAY INDEX FOR AUTHORS HKL
      IHP=1
      IF (IXPD .EQ. 0) WRITE (NTOUT, 9)
 9    FORMAT ('1')
      IF ((IXPD .EQ. 0) .AND. (IDOLSQ .EQ. 1)) WRITE (NTOUT, 11) IHEAD,
     * WL(1),ICRYST,SPGI
 11   FORMAT (' ','Title of set: ',A68 / ' ', 'lambda = ',F10.7/
     * ' ','crystal system = ',A5,4X,'space group = ',A8)
      IF(IXPD.EQ.0) WRITE(NTOUT,16)
   16 FORMAT(1H0,30X,9H<authors>,4X,9H<program>,5X,3Hobs,5X,4Hcalc,
     * 4X,4Hdiff)
      IF(IXPD.EQ.0) WRITE(NTOUT,18) IALF12(1:2),IALF12(1:2),IALF12(1:2)
   18 FORMAT(1H ,3H  n,3X,6Hd calc,3X,5Hd obs,3X,3Hint,4X,9Hh   k   l,
     * 4X,9Hh   k   l,3X,A2,5Htheta,2(1X,A2,5Htheta))
   20 IF (IHP .LE. NR) GO TO 22
      IF (IGP .GT. NUMOBS) GO TO 99
      GO TO 40
   22 DO 24 L=1,3
   24 NH(L) = IHG(IHP,L)
      D=DCM(IHP)
      IF (IHP .EQ. I2) GO TO 40
      THCMP=THETA(0.5*PWL,D)
      IF (ITHT .EQ. 0) THCMP=THCMP+THCMP
      IF(IXPD.EQ.0) WRITE(NTOUT,30) IHP, D, (NH(L),L=1,3), THCMP
   30 FORMAT(1H ,I3,F9.4,28X,3I4, 9X,F9.4)
   32 IHP=IHP+1
      GO TO 20
   40 DO 42 L=1,3
   42 JH(L) = IH(IGP,L)
      DOBS=DSP(IGP)
      THOBS=OBSTH(IGP)
      DF=DLST(IGP)
C
C-----IS OBSERVED D-SPACING BEYOND THE LIMIT OF GENERATION. IF SO
C-----CALCULATED D-CALC DIRECTLY AS IT IS NOT STORED IN DLST( )
C
      IF(DOBS.GE.DMIN) GOTO 50
      IFIRST=IFIRST+1
      IF(IFIRST.EQ.1 .AND. IXPD.EQ.0) WRITE(NTOUT,44)
44    FORMAT(1H ,58H**begin listing input reflections beyond hkl/d-gen r
     *ange**)
C-----TEST IF UNINDEXED, KNOWN IMPURITY OR SPACE GROUP EXTINCT
      IF(IHED(IGP).EQ.ITIH(4).OR.IHED(IGP).EQ.ITIH(5).OR.
     * IHED(IGP).EQ.ITIH(6)) GOTO 48
      DO 46 I=1,3
46    IAH(I) = IH(IGP,I)
      CALL QCOMP(IAH,Z,Q)
      DF=1.0/SQRT(Q)
      GO TO 50
C-----UNINDEXED REFLECTION BEYOND GENERATION RANGE; SET THCLC, DIFF,
C-----ETC TO VERY LARGE NUMBERS SO THAT ASTERISKS ARE PRINTED
48    THCLC=1.0E+10
      DIFF=1.0E+10
      DF=1.0E+10
      NH(1)=99999
      NH(2)=99999
      NH(3)=99999
      IF(ITHT.EQ.0) THOBS=THOBS+THOBS
      GO TO 54
50    THCLC=THETA(0.5*PWL,DF)
      DIFF=THCLC-THOBS
      IF (ITHT .NE. 0) GO TO 54
      THCLC=THCLC+THCLC
      THOBS=THOBS+THOBS
      DIFF=DIFF+DIFF
   54 JA=IALF(7)
      IF (IOC(IGP) .LT. 0) JA=IALF(8)
C-----TEST IF INDEXED
      IF(IHED(IGP).NE.ITIH(4) .AND. IHED(IGP).NE.ITIH(5) .AND.
     * IHED(IGP).NE.ITIH(6)) GOTO 70
C-----UNINDEXED OBSERVATION OR SPACE GROUP EXTINCT OR KNOWN IMPURITY
      IF(IHED(IGP).EQ.ITIH(5)) GOTO 60
C
C-----STORE H,K,L(PROGRAM) OF NEAREST LINE AND MARK WITH EDITORIAL 'C'
C-----ONLY IF DIFF<0.30 DEG 2-THETA
C
      IF(ABS(DIFF).GT.0.30) GOTO 60
      IH(IGP,1) = NH(1)
      IH(IGP,2) = NH(2)
      IH(IGP,3) = NH(3)
C-----MARK REFLECTION AS COMPUTER ASSIGNED HKL (MARK IS 'C')
      IHED(IGP)=IHC
      JH(1)=NH(1)
      JH(2)=NH(2)
      JH(3)=NH(3)
      GOTO 70
C
C-----OUTPUT NEXT GENERATED LINE WHICH DOES NOT INDEX ANY AUTHORS LINES
C
   60 IF(IXPD.EQ.0) WRITE(NTOUT,58) IHP,DF,DOBS,IHED(IGP),INT(IGP),
     * INTED(IGP),(NH(L),L=1,3),JA(1:2),THOBS,THCLC, DIFF
   58 FORMAT(1H ,I3,2F9.4,A1,I3,A1,14X,3I4,A2,3F8.4)
   62 IGP=IGP+1
      IF (IGP-NUMOBS) 64,64,68
   64 IF (IABS(IOC(IGP)) .EQ. I2) GO TO 40
      I2=IABS(IOC(IGP))
      GO TO 32
   68 I2=0
      GO TO 32
C-----AUTHORS  OR EDITER INDEXED REFLECTION PRINTED HERE
   70 THCMP=THETA(0.5*PWL,D)
      IF (ITHT .EQ. 0) THCMP=THCMP+THCMP
      IF (IGP .LT. 2) GO TO 75
      IF (IABS(IOC(IGP-1)) .NE. I2) GO TO 75
   73 IF(IXPD.EQ.0)WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INT(IGP),INTED(IGP),
     *(JH(L),L=1,3),JA(1:2),THOBS, THCLC, DIFF
   74 FORMAT(1H ,3H***,2F9.4,A1,I3,A1,1X,3I4,13X,A2,3F8.4)
      GO TO 62
 75   IF (JH(1) .EQ. NH(1) .AND. JH(2) .EQ. NH(2) .AND.
     *JH(3) .EQ. NH(3)) GO TO 82
C
C-----IF HEX OR TET TEST IF THE H**2 + K**2 ARE EQUAL AND IF L'S ARE EQUAL
C
      IF ((ICRS .EQ. ITCRS(4) .OR. ICRS .EQ. ITCRS(5)) .AND.
     * (JH(1)*JH(1)+JH(2)*JH(2)) .EQ. (NH(1)*NH(1)+
     * NH(2)*NH(2)) .AND. JH(3) .EQ. NH(3)) GO TO 82
C
C-----IF CUBIC TEST IF THE H**2 + K**2 + L**2 ARE EQUAL
C
      IF (ICRS .EQ. ITCRS(7) .AND. (JH(1)*JH(1) + JH(2)*JH(2)
     * + JH(3)*JH(3)) .EQ. (NH(1)*NH(1) + NH(2)*NH(2) +
     * NH(3)*NH(3))) GO TO 82
C
C-----AUTHOR AND GENERATED HKL DO NOT MATCH PRINT THE
C-----ONE WITH LARGEST D FIRST
C
      IF (DLST(IGP)-D) 76,76,80
   76 IF(IXPD.EQ.0) WRITE(NTOUT,30) IHP, D, (NH(L),L=1,3), THCMP
      GO TO 73
   80 IF(IXPD.EQ.0)WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INT(IGP),INTED(IGP),
     * (JH(L),L=1,3),JA(1:2),THOBS, THCLC, DIFF
      IF(IXPD.EQ.0) WRITE(NTOUT,30) IHP, D, (NH(L),L=1,3), THCMP
      GO TO 62
C
C-----PRINT BOTH AUTHORS AND GENERATED ON SAME LINE
C
 82   IF (IXPD .EQ. 0) WRITE (NTOUT, 84) IHP, DF, DOBS, IHED(IGP),
     * INT(IGP),INTED(IGP),(JH(L),L = 1, 3), (NH(L), L = 1, 3), JA(1:2),
     *THOBS, THCLC, DIFF
 84   FORMAT (1H , I3, 2F9.4, A1,I3,A1, 1X, 3I4, 1X, 3I4, A2
     *, 3F8.4)
      GO TO 62
   99 RETURN
      END

      SUBROUTINE COMPAR
C*********************************************************************
C
C---COMPARES AUTHOR'S INDEXING WITH THEORETICAL VALUES FROM HIS CELL.ALL
C-----CALCULATIONS PERFORMED IN 2-THETA, BUT RESULTS ARE GIVEN IN THETA
C-----IF THETA WAS GIVEN AS INPUT. WARNING IF OBS. -  CALC. DIFFERENCE
C-----IN ANGLES IS ABOVE TOLERANCE. AVERAGE FIT IS ALSO PRINTED.
C
C-----SUBROUTINE COMPAR RECHECKS THIS AT END OF DO 40 LOOP.
C
C*********************************************************************
C     PARAMETER (MAXOBS=200, MAXGEN=1000)
      COMMON/SWFG/R
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/IERRS/IWARN,IERR
      COMMON/QUAL/SDELTA(200)
      DIMENSION NH(3)
      CHARACTER*1 IHED,INTED
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*6 IALF12
C
C-----TEST IF 2 LINES HAVE THE SAME HKL VALUES
C
      M1=NUMOBS-1
      DO 200 I=1,M1
C
C-----SKIP UNINDEXED LINES AND KNOWN IMPURITY LINES
C
      IF(IHED(I).EQ.ITIH(4) .OR. IHED(I).EQ.ITIH(5)) GOTO 200
      I1=I+1
      DO 98 J=I1,NUMOBS
      DO 90 K=1,3
      IF(IH(I,K).NE.IH(J,K)) GOTO 98
90    CONTINUE
      IERR=IERR+1
      WRITE(NTOUT,92) DSP(I),DSP(J)
92    FORMAT(1H ,31H**ERROR** Lines with d-spacing=, F8.4, 4H and, F8.4,
     *30H have identical hkl's**ERROR** )
98    CONTINUE
200   CONTINUE
C-----ARRAY OF SIGNED DELTA 2-THETAS
C-----REJECTION CRITERIA (DEGREES 2-THETA)
      TEST2T=0.2
C
C-----INITIALIZE THE OVERALL PATTERN QUALITY COUNTERS
C        NAVG = NUMBER OF SPACE GROUP ALLOWED INDEXED LINES
C        AVG  = AVERAGE ABS(DELTA 2-THETA)
C        NRES = # OF RESOLVABLE THEORETICAL LINES OUT TO THEMX
C        IHDG = USED TO CONTROL PRINTING OF HEADINGS
C        NUNIQU = # OF UNIQUE LINES OBSERVED
C        NPLUS = # OF DELTA(2-THETA) > +0.02
C        MINUS = # OF DELTA(2-THETA) < -0.02
C        SAVG  = SUM OF DELTA(2-THETA).  SHOULD BE APPROX. ZERO IF DATA
C                IS FREE FROM SYSTEMATIC ERRORS
      AVG=0.0
      NAVG = 0
      IHDG=0
      NRES = 0
      CONST = 0.5*PWL
      NUNIQU = 1
      NPLUS=0
      MINUS=0
      SAVG =0.0
C
C-----SET UP FOR FIGURE-OF-MERIT (M20) CALCULATION
C-----  SEE DEWOLF, J APPL CRYST (1968) 1,108.
C        NUM20= 20 OR # OF UNIQUE AND INDEXED LINES IN PATTERN IF <20
C        I20  = ARRAY INDEX FOR THE NUM20'TH LINE
C        DLIM = D-SPACING OF THE NUM20'TH LINE
C        ERRQ, ERRQR = SUM ABS(DELTA-Q))
C        NERRQ, NERRQR = # IN SUMS
C             MULTIPLY INDEXED LINES IN AVERAGES
C             SUFFIX R INDICATES OMMISION OF LINES WITH (DELTA 2-THETA)
C             >TEST2T
C        N20  = # OF THEORETICAL LINES OUT TO DLIM
C        NUM20R= NUM20- # OF REJECTED LINES(>TEST2T)
C
      ERRQ=0.0
      ERRQR=0.0
      I20 = 0
      NUM20 = 0
      NERRQ=0
      NERRQR=0
C
C-----SET UP FOR SMITH-SNYDER FIGURE OF MERIT
C        IFN,IFNR = 30 OR # OF UNIQUE AND INDEXED LINES IN  PATTERN <30
C        MFN  = ARRAY INDEX FOR THE IFN'TH LINE
C        FLIM = D-SPACING OF THE IFN'TH LINE
C        FAV, FAVR = SUM ABS(DELTA 2-THETA)
C        NFAV, NFAVR = # IN SUMS
C        NFN  = # OF THEORETICAL LINES OUT TO FLIM
C        FN2  = FAV/NFAV  (= AVERAGE MAGNITUDE OF DELTA 2-THETA)
C        FN1 = MERIT FUNCTION (=<DEL 2T>*IFN/NFN)
      IFN = 0
      FAV = 0.0
      FAVR = 0.0
      MFN = 0
      NFAV = 0
      NFAVR=0
C
C-----DETERMINE IFN,NFN AND NUM20,I20
C
      DO 40 I=1,NUMOBS
C-----SKIP OVER LINES NOT INDEXED, KNOWN IMPURITY OR SPACE GROUP EXT
      IF(IHED(I).EQ.ITIH(4).OR.IHED(I).EQ.ITIH(5).OR.IHED(I).EQ.ITIH(6))
     * GOTO 40
      IFN = IFN + 1
      NUM20 = NUM20 + 1
      IF(I.EQ.1) GOTO 40
      DLIM = DSP(I-1)
C-----TEST IF THIS IS A NEW LINE
      IF((DLIM-DSP(I)).GT.0.00001) GOTO 2
      NUM20=NUM20-1
      IFN = IFN -1
    2 IF(NUM20 .LE. 20) I20=I
      IF(IFN.LE.30) MFN=I
      IF(IFN.EQ.30) GOTO 41
   40 CONTINUE
      IF(I20.NE.0) GOTO 41
      WRITE(NTOUT,3)
3     FORMAT(71H **ERROR** Compar called, but there are no indexed ref
     *lections**ERROR** )
      RETURN
C-----SHIFT DLIM TO ALLOW FOR POTENTIAL MEASUREMENT ERROR
   41 TEMP=OBSTH(I20)+0.05
      DLIM=CONST/SIN(TEMP/R)
      TEMP=OBSTH(MFN)+0.05
      FLIM=CONST/SIN(TEMP/R)
      Q20 = 1.0/(DLIM*DLIM)
      IF(NUM20.GT.20) NUM20=20
      NUM20R=NUM20
      IFNR = IFN
C
C-----LOOP OVER THE THEORETICAL LINES TO DETERMINE
C----- THE THEORETICALLY POSSIBLE NUMBER OF LINES NFN AND N20
C        EXACT COINCIDENCE WAS ELIMINATED BY THE HKL GENERATION ROUTINE
C        IN MOST CASES. A KNOWN EXCEPTION IS SPGR PA3.
C
      IF (RESOLV .LT. 0.001) RESOLV = 1.5 * TOLTH
      THETAL=THETA(CONST,DCM(1))
      N20=1
      NFN = 1
      NRES=1
      DO 5 I=2,NR
      DCALC = DCM(I)
      THETAC = THETA(CONST,DCALC)
      IF((THETAC-THETAL).GT.RESOLV) NRES=NRES+1
      IF((THETAC-THETAL).LT.0.0001) GOTO 4
      IF(DCALC.GT.DLIM) N20=N20+1
      IF(DCALC .GT. FLIM) NFN = NFN + 1
    4 THETAL=THETAC
    5 CONTINUE
C
C-----SET TOL TO BE USERS INDICATED TOLERANCE FOR 2-THETA SCALE
C
      TOL = 2.0*TOLTH
C
C-----BEGIN LOOP OVER INDEXED REFLECTIONS
C-----FOR FIGURE OF MERRIT CALCULATIONS DETERMINE THE AVERAGE
C-----ERROR IN 2-THETA AND IN Q
C-----LIST REFLECTIONS(INDEXED) WHICH EXCEED A PRESET ERROR (TOLTH)
C-----SAVE THE SIGNED DIFFERENCES FOR A STATISTICAL TEST ON NON
C-----RANDOMNESS
C
      DLAST = 99.9999
      DO 50 I=1,NUMOBS
C-----SKIP UNINDEXED, KNOWN IMPURITY AND SPACE GROUP EXTINC LINES
      IF(IHED(I).EQ.ITIH(4).OR.IHED(I).EQ.ITIH(5).OR.IHED(I).EQ.ITIH(6))
     * GOTO 50
      DO 10  J=1,3
      NH(J)=IH(I,J)
   10 CONTINUE
C-----COUNT THE NUMBER OF UNIQUE OBSERVED LINES
      IF(I.EQ.1) GOTO 11
      IF((DLAST-DSP(I)).LT.0.00001) GOTO 11
      NUNIQU=NUNIQU+1
11    DLAST=DSP(I)
      CALL QCOMP(NH,Z,Q)
      DCALC= 1.0/SQRT(Q)
      QOBS=1.0/(DSP(I)*DSP(I))
      IF(I.GT.I20) GOTO 12
      ERRQ = ERRQ + ABS(Q-QOBS)
      NERRQ = NERRQ+1
   12 CONTINUE
C-----CALC THETAC.    (LAMBDA=PWL)
      THETAC=THETA(CONST,DCALC)
      THOBS=OBSTH(I)
C-----CONVERT FROM THETA TO 2-THETA
      THETAC=THETAC+THETAC
      THOBS=THOBS+THOBS
C
C-----CALCULATE THE DIFFERENCE IN 2-THETA AND MAGNITUDE OF DIFFERENCE
C
   20 SDIFF = THETAC-THOBS
      DIFF = ABS(SDIFF)
C-----SUM OF AVERAGE MAGNITUDE ERROR IN 2-THETA (ENTIRE PATTERN)
      AVG = AVG + DIFF
      NAVG=NAVG+1
C-----SUM OF ERRORS IN 2-THETA AND NUMBER OF '+' AND '-'
C-----DEVIATIONS GREATER THAN +0.02 OR LESS THAN -0.02
      SAVG=SAVG + SDIFF
      IF(SDIFF.GT.0.02) NPLUS=NPLUS+1
      IF(SDIFF.LT.-0.02)MINUS=MINUS+1
C-----STORE DELTA 2-THETA FOR LATER TEST FOR RANDOM DISTRIBUTION
      SDELTA(NAVG) = SDIFF
C-----NUM20R  IS NUMBER OF ACCEPTABLE OBSERVATIONS:(OBS-CALC).LT. 0.2DEG
      IF(I.GT.I20) GOTO 22
      IF(DIFF.GT.TEST2T) NUM20R = NUM20R-1
      IF(DIFF.GT.TEST2T) GOTO 22
      ERRQR=ERRQR + ABS(Q-QOBS)
      NERRQR=NERRQR+1
C-----SUM OF AVERAGE MAGNITUDE ERROR IN 2-THETA (I<MFN)
22    IF(I .GT. MFN) GO TO 30
      FAV = FAV + DIFF
      NFAV=NFAV+1
      IF(DIFF.GT.TEST2T) IFNR = IFNR-1
      IF(DIFF.GT.TEST2T) GOTO 30
      FAVR = FAVR + DIFF
      NFAVR = NFAVR + 1
 30   CONTINUE
C
C-----COMPARE ANGLES. LIST THOSE THAT DON'T SATISFY USER'S INPUT TOL.
C
      IF(DIFF.LT.TOL) GOTO 50
C---IF THE USER INDICATED THETA, PERFORM CONVERSION BACK AGAIN
      IF(ITHT .EQ. 0) GO TO 23
      TOL=TOL/2.0
      THOBS=THOBS/2.0
      THETAC=THETAC/2.0
      SDIFF=SDIFF/2.0
   23 IF(IHDG .EQ.1) GOTO 24
      WRITE(NTOUT,1) TOL,IALF12(1:2),IALF12(1:2)
    1 FORMAT(1H0,43HSummary of reflections exceeding tolerance=,F6.2/
     * 1H0,6X, 6Hd calc, 4X, 5Hd obs, 1X,3Hint,5X,9Hh   k   l,16X, A2,
     * 5Hthobs, 1X, A2, 5Hthclc, 4X,4Hdiff)
      IHDG=1
   24 WRITE(NTOUT,25)DCALC,DSP(I),IHED(I),INT(I),INTED(I),(NH(L),L=1,3),
     * THOBS,  THETAC, SDIFF
   25 FORMAT(1H ,3X,2F9.4,A1,I3,A1,1X,3I4,15X,3F8.3)
   50 CONTINUE
C
C-----SUMMARIZE COMPARISON
C
      AVG=AVG/FLOAT(NAVG)
      SAVG=SAVG/FLOAT(NAVG)
      NOIND =NUMOBS-NAVG
C
C-----TEST THE TABLE OF DELTA 2-THETA FOR PRESENCE OF NON-RANDOM
C-----VARIABILITY USING THE TEST OF L.C. YOUNG, "ON RANDOMNESS IN
C-----ORDERED SEQUENCES", ANNALS OF MATHETATICAL STATISTICS, VOL XII,
C-----NO. 3, SEPT 1941.
C
C-----NOTE: THEORETICALLY THE AVERAGE VALUE OF THE DEVIATION SHOULD
C-----BE ZERO.  THUS IN THE DENOMINATOR OF YOUNG'S EQUATION FOR C,
C-----X BAR IS TAKEN AS 0.0    THIS ENABLES DETECTION OF A CONSTANT
C-----SYSTEMATIC ERROR TO ALSO BE DETECTED BY C/SIGMA
C
      C = 0.0
      IF(NAVG.LT.8) GOTO 60
      XNUM = 0.0
      XDEN = 0.0
      C = 0.0
      DO 54 I=1,NAVG
      IF(I.EQ.1) GOTO 52
      DD = SDELTA(I) - SDELTA(I-1)
      XNUM = XNUM +DD*DD
52    DD = SDELTA(I)
      XDEN = XDEN + DD*DD
54    CONTINUE
C-----CALCULATE EXPECTED SIGMA OF DISTRIBUTION
      DD = FLOAT(NAVG-2)/FLOAT((NAVG-1)*(NAVG+1))
      DD = SQRT(DD)
C-----CALCULATE YOUNG'S C/SIGMA
      C = 1.0 - XNUM/(2.0*XDEN)
      C = C/DD
C-----CHANGE RESOLVE TO DEGREEES 2-THETA
60    RESOLV = 2.0*RESOLV
      WRITE(NTOUT,61) RESOLV, NR, NRES,NUNIQU, NUMOBS, NAVG, NOIND
61    FORMAT(1H0,38HReflection summary for entire pattern:/
     * 1H ,21HEstimated resolution=,F5.3,13H deg. 2-theta/
     * 1H0,5X,23HTheoretical # of lines=, I4/
     * 1H ,5X,23HTheoretical resolvable=,I4/
     * 1H ,5X,22HUnique observed lines=,I5/
     * 1H0,5X,18HTotal lines input=,I6/
     * 1H ,5X,17HNumber   indexed=,I7/
     * 1H ,5X,17HNumber unindexed=,I7)
      WRITE(NTOUT,62) SAVG,NPLUS,MINUS
62    FORMAT(1H0,33H********For indexed lines********/
     * 1H0, 5X, 27HAverage 2-theta difference=, F7.4/
     * 1H , 5X, 29H# with diff > +0.02(2-theta)=,I5/
     * 1H , 5X, 29H# with diff < -0.02(2-theta)=,I5)
C-----TEST FOR IMBALANCE IN THE NUMBER OF + AND - SIGNS
      NTEST=NAVG/5
      IF(NTEST.LT.5) NTEST=5
      IF(IABS(NPLUS-MINUS).LT.NTEST) GOTO 64
      IWARN=IWARN+1
      WRITE(NTOUT,63)
63    FORMAT(' **WARNING** Imbalance in number of + and - signs**war',
     *'ning**')
64    IF(NAVG.GE.8) WRITE(NTOUT,65) C
65    FORMAT(1H0, 5X, 32Hc/sigma (non-random error test)=,F5.2)
C
C-----TEST FOR NONRANDOMNESS AT 99% AND 95% CONFIDENCE LEVEL
C-----USING YOUNG'S STATISTICAL TEST
C
      IF(C .LT. 1.6447) GOTO 67
      IWARN = IWARN + 1
      ICONF = 95
      IF(C.GT.2.3262) ICONF = 99
      WRITE(NTOUT,66) ICONF
66    FORMAT(1H , 46H**WARNING** Systematic errors indicated at the, I3,
     *31H% significance level**WARNING**)
C
C-----CALCULATE AVERAGE ERROR IN Q AND THE FIGURE OF MERIT (M20)
C
67    ERRQ = ERRQ/FLOAT(NERRQ)
      XM20=Q20/(2.0*ERRQ*FLOAT(N20))
      WRITE(NTOUT,68) NUM20,XM20,DLIM,N20
68    FORMAT(1H0,5X,2Hm(,I2,3H) =,F6.2,13H   (dlimit = ,F6.4,
     * 14H, # possible = , I3, 1H) )
      IF(XM20.GT.10.0) GOTO 70
      IWARN=IWARN+1
      WRITE(NTOUT,69) NUM20
69    FORMAT(1H ,14H**WARNING** m(, I2, 52H) < 10 incicates that the cel
     *l is suspect**WARNING** )
C
C-----CALCULATE THE AVERAGE ABS(DELTA 2-THETA) AND F(N)
C
   70 FN2 = FAV/FLOAT(NFAV)
      FN1 = FLOAT(IFN) / (FN2 * FLOAT(NFN))
      WRITE(NTOUT,72)IFN,FN1,FN2,NFN
   72 FORMAT(1H0,5X,
     1 2Hf(, I2,3H) =, F6.2, 18H (delta 2 theta = ,F6.4,
     2 15H, # possible =  , I3, 1H)//)
      IF(NUM20R .EQ. NUM20) GOTO 80
      WRITE(NTOUT,76)
   76 FORMAT(1H0, 39HFigures-of-merit(rejecting diff.GT.0.2))
      ERRQR = ERRQR/FLOAT(NERRQR)
      XM20R = Q20/(2.0*ERRQR*FLOAT(N20))
      WRITE(NTOUT,68) NUM20R, XM20R, DLIM,N20
   80 IF(NFAVR.EQ.NFAV) GO TO 100
      IF(IHDG.EQ.0) WRITE(NTOUT,76)
      FN2R = FAVR/NFAVR
      FN1R = FLOAT(IFNR)/(FN2R*FLOAT(NFN))
      WRITE(NTOUT,72) IFNR, FN1R, FN2R, NFN
  100 RETURN
      END

      SUBROUTINE RCMPD
C COMPUTES D SPACING FOR GENERATED REFLECTIONS
C     PARAMETER (MAXGEN=1000)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/SCRT/E(7),NH(3)
      COMMON/HDGEN/IHG(1000,3),DCM(1000),NR,DMIN
      DO 5 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      Z(I)=X(I)**2
    5 Z(I+3)=X(I)*X(J)*U(K)
      DO 20 IC=1,NR
      DO 10 J=1,3
   10 NH(J)=IHG(IC,J)
      CALL QCOMP(NH,Z,Q)
      IF (Q .GT. 0.0) GO TO 16
      DCM(IC)=0.0
      GO TO 20
   16 DCM(IC)=1.0/SQRT(Q)
   20 CONTINUE
      RETURN
      END

      SUBROUTINE DLQOT
C COMPUTES PARTIAL DERIVATIVES OF RECIPROCAL OF D SQUARED
      COMMON/ALL/N,NUMCYC,FAC
      COMMON/BLKA/IDG(3),FMN(3),A(27),UO(3),B(6)
      COMMON/SCRT/E(7),NH(3)
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      DO 15 J=1,3
      K=MOD(J,3)+1
      L=MOD(K,3)+1
      B(J)=FAC*(X(J)*NH(J)**2+NH(J)*NH(L)*X(L)*U(K)+NH(J)*NH(K)*X(K)*
     * U(L))
   15 B(J+3)=FAC*NH(K)*NH(L)*X(K)*X(L)
      RETURN
      END
      SUBROUTINE CELLCK(GOOD)
C*************************************************************************
C
C REVISED  13 APRIL 1981 CRH  ADDED TEST FOR ANGLE>179.9 DEGREES
C
C************************************************************************
      COMMON/CELLI/AI,BI,CI,ALPHI,BETI,GAMI,VI,ERRI(7)
      COMMON/CCELLI/ SPGI,SPGIA,SPGIN,ICRS
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CCONTR/ ID0
      COMMON/SWFG/R
      COMMON/UNQ/ IFA,IFB,IFC,IRH
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/IERRS/ IWARN,IERR
      CHARACTER*7 ID0
      CHARACTER*1 SPGIA,ICRS
      CHARACTER*4 SPGIN
      CHARACTER*8 SPGI
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      LOGICAL GOOD
C
C-----INITIALIZE FLAGS
C
      IFA=0
      IFB=0
      IFC=0
      IRH=0
C
C-----COMPLETE CELL ANGLES, ERRORS
C-----SET FLAGS FOR ANGLES NOT INPUT. =0 FOR INPUT, =1 FOR ABSENT
C
      IF(ALPHI.GT. 0.1) GO TO 10
C-----ALPHA NOT INPUT. SET ALPHA TO 90.0 AND ERROR TO 0.0
      IFA=1
      ALPHI=90.0
      ERRI(4)=0
10    IF(BETI .GT. 0.1) GO TO 20
C-----BETA  NOT INPUT. SET BETA  TO 90.0 AND ERROR TO 0.0
      IFB=1
      BETI=90.0
      ERRI(5)=0
20    IF(GAMI .GT. 0.1) GO TO 22
C-----GAMMA NOT INPUT.  SET GAMMA TO 90.0 AND ERROR TO 0.0
      IFC=1
      GAMI=90.0
      ERRI(6)=0
C
C-----IFSUM WILL INDICATE THE NUMBER OF ANGLE ABSENT ON INPUT
C
22    IFSUM=IFA+IFB+IFC
C
C-----FOR RHOBOHEDRAL SYSTEM DETERMINE IF ON HEXAGONAL AXES (IRH=1)
C-----                            OR IF ON RHOMBOHEDRAL AXES (IRH=0)
C
      IF(ICRS.NE.ITCRS(6).OR. CI.LT.1.0) GOTO 23
      IF(BI.EQ.AI .AND. CI.EQ.AI) GOTO 23
C-----IT IS RHOMBOHEDRAL ON HEXAGONAL AXES. TEMPORARILY SET ICRS='H'
      ICRS =ITCRS(5)
      IRH=1
      GOTO 29
C
C-----TEST IF TRICLINIC. IF IT IS THEN 3 ANGLES MUST BE INPUT
C
23    IF(ICRS.NE.ITCRS(1)) GOTO 25
      IF(IFSUM.EQ.0) GOTO 32
      WRITE(NTOUT,24)
24    FORMAT(' **ERROR** All 3 angles must be entered in triclinic s',
     *'ystem' )
      IERR=IERR+1
      GOTO 32
C
C-----TEST IF MONOCLINIC. IF SO ONLY ONE ANGLE SHOULD BE INPUT
C
25    IF(ICRS.NE.ITCRS(2)) GOTO 27
      IF(IFSUM.EQ.2) GOTO 32
      WRITE(NTOUT,26)
26    FORMAT(1H ,'**ERROR** For monoclinic two angles must be '
     *'input as blanks.', ' program assuming B-unique')
      IFA=1
      IFB=0
      IFC=1
      IERR=IERR+1
      GOTO 32
C
C-----TEST IF RHOMBOHEDRAL ON R-AXES. IF SO ONLY ALPHA SHOULD BE INPUT
C
27    IF(ICRS.NE.ITCRS(6)) GOTO 29
      IF(IFSUM.EQ.2 .AND. IFA.EQ.0) GOTO 32
      IF(IJOB.NE.1.AND.IFA.EQ.0.AND.BETI.EQ.ALPHI.AND.GAMI.EQ.ALPHI)
     * GOTO 32
      WRITE(NTOUT,28)
28    FORMAT(' **ERROR** Only angle alpha should be input for rhoboh',
     *'edral system on r-axes')
      IERR=IERR+1
      GOTO 32
C
C-----MUST BE ORTHO, TETRAGONAL, HEXAGONAL, CUBIC OR RHOMB ON H-AXES
C-----TEST THAT NO ANGLE WAS INPUT
C
29    IF(IFSUM.EQ.3) GOTO 32
      IF(IJOB.NE.1.AND.ALPHI.EQ.90.0.AND.BETI.EQ.90.0.AND.
     + (GAMI.EQ.90.0.OR.GAMI.EQ.120.0)) GOTO 32
      WRITE(NTOUT,30) ICRS
30    FORMAT(' **ERROR** No angles should be input in crystal system ',
     * A1)
      IERR=IERR+1
C
C-----FOR TETRAGONAL, HEXAGONAL, RHOMBOREDRAL AND CUBIC  SET  BI=AI
C
32    IF(ICRS.NE.ITCRS(5) .AND. ICRS.NE.ITCRS(4) .AND. ICRS.NE.ITCRS(7)
     * .AND. ICRS.NE.ITCRS(6)) GOTO 48
      IF(BI.LT.0.1) GOTO 34
      IF(IJOB.NE.1 .AND. BI.EQ.AI) GOTO 35
      WRITE(NTOUT,33)
33    FORMAT(1H ,44H**ERROR** Cell parameter 'b' should be blank )
      IERR=IERR+1
34    BI=AI
35    ERRI(2)=ERRI(1)
C
C-----FOR CUBIC AND RHOMBOHERDRAL R-AXES SET CI = AI
C
      IF (ICRS.NE.ITCRS(6).AND.ICRS.NE.ITCRS(7)) GOTO 42
      IF(CI.LT.0.1) GOTO 38
      IF(IJOB.NE.1 .AND. CI.EQ.AI) GOTO 39
      WRITE(NTOUT,37)
37    FORMAT(1H ,44H**ERROR** Cell parameter 'c' should be blank )
      IERR=IERR+1
38    CI=AI
39    ERRI(3)=ERRI(1)
      GOTO 46
C
C-----IF HEXAGONAL SET GAMMA
C
42    IF (ICRS.NE.ITCRS(5)) GOTO 46
      GAMI=120.0
      ERRI(6)=0
      GOTO 48
C
C-----IF RHOMBOHEDRAL ON R-AXES THE SET EQUIVALENCES
C
46    IF(ICRS.NE.ITCRS(6)) GO TO 48
      BETI=ALPHI
      GAMI=ALPHI
      ERRI(5)=ERRI(4)
      ERRI(6)=ERRI(4)
C
C-----IF RHOMBOHEDRAL ON HEXAGONAL AXES THEN RESET ICRS TO 'R'
C
48    IF(IRH.EQ.1) ICRS=ITCRS(6)
C
C-----CHECK INITIAL CELL PARAMETERS FOR REASONABLE MAGNITUDES
C
      IF(AI.LE.30.0 .AND. BI.LE.30.0 .AND. CI.LE.30.0) GOTO 51
      WRITE(NTOUT,50)
50    FORMAT(1H ,32H**WARNING**ai,bi and/or ci > 30a )
      IWARN=IWARN+1
51    IF(AI.GE. 3.0 .AND. BI.GE. 3.0 .AND. CI.GE. 3.0)  GOTO 53
      WRITE(NTOUT,52)
52    FORMAT(1H ,32H**WARNING**ai,bi and/or ci <  3a )
      IWARN=IWARN+1
53    IF(ALPHI.LE.140.0 .AND. BETI.LE.140.0 .AND. GAMI.LE.140.0) GOTO 55
      WRITE(NTOUT,54)
54    FORMAT(1H ,43H**WARNING**alphi,beti and/or gami > 140 deg )
      IWARN=IWARN+1
55    IF(ALPHI.GE. 50.0 .AND. BETI.GE. 50.0 .AND. GAMI.GE. 50.0) GOTO 57
      WRITE(NTOUT,56)
      IWARN=IWARN+1
56    FORMAT(1H ,43H**WARNING**alphi,beti and/or gami <  50 deg )
57    IF(ALPHI.GT.179.9 .OR. BETI.GT.179.9 .OR. GAMI.GT.179.9) GOTO 60
C
C-----TEST FOR A VALID CELL - THAT IS THE THREE VECTORS ARE NOT COPLANAR
C
      GOOD=.TRUE.
      COS1 = COS(ALPHI/R)
      COS2 = COS(BETI/R)
      COS3 = COS(GAMI/R)
      TEM = (1.0-COS1**2-COS2**2-COS3**2+2.0*(COS1*COS2*COS3))
      IF(TEM.GT.0.0001) GOTO 80
60    WRITE(NTOUT,62) ID0
      IERR=IERR+1
62    FORMAT(' **ERROR** Cell parameters do not define a valid cell-',
     *'-entry: ', 1X, A7)
      GOOD = .FALSE.
      RETURN
C
C-----CALCULATE THE INITIAL CELL VOLUME
C
80    VI = AI*BI*CI*SQRT(TEM)
      IF(VI .LT. 1.0) GOTO 60
      RETURN
      END
      SUBROUTINE RSCMP
C COMPUTES RECIPROCAL CELL ELEMENTS FROM DIRECT CELL ELEMENTS
      COMMON/RECP/Z(6),Q,AR(3),X(3),VR,U(3),W(3),VRO
      COMMON/REAL/AO(3),ALO(3),VCO,AD(3),ALS(3),VC,CSA(3),SNA(3)
      DO 10 I=1,3
      J=MOD(I,3)+1
      K=MOD(J,3)+1
      U(I)=(CSA(J)*CSA(K)-CSA(I))/(SNA(J)*SNA(K))
      W(I)=SQRT(1.0-U(I)**2)
      X(J)=1.0/(AD(J)*W(I)*SNA(K))
   10 AR(I)=3437.7468*(1.5707963-ATAN2(U(I),W(I)))
      VR=X(1)*X(2)*X(3)*SNA(1)*W(2)*W(3)
      VC=1.0/VR
C-----CALCULATE (A*)**2,ETC.
      DO 20 I=1,3
      J = MOD(I,3)+1
      K = MOD(J,3)+1
      Z(I)=X(I)**2
      Z(I+3)=X(I)*X(J)*U(K)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE SORT
C     PARAMETER (MAXOBS=200)
      COMMON/PPDATA/ITHT,OBSTH(200),DSP(200),IH(200,3),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN
      COMMON/BLKF/SW(200),WL(200)
      CHARACTER*1 IHED,INTED
C SORT GIVEN REFLECTIONS SO AS TO BE IN DECREASING VALUE FOR D-SPACING
   64 I=NUMOBS
   65 I=I-1
      IF (I.LT.1) GO TO 99
      DO 80 J=1,I
      IF (DSP(J).GE.DSP(J+1)) GO TO 80
      DOBS=DSP(J)
      DSP(J)=DSP(J+1)
      DSP(J+1)=DOBS
      THOBS=OBSTH(J)
      OBSTH(J)=OBSTH(J+1)
      OBSTH(J+1)=THOBS
      WLC=WL(J)
      WL(J)=WL(J+1)
      WL(J+1)=WLC
      SWT=SW(J)
      SW(J)=SW(J+1)
      SW(J+1)=SWT
      DO 75 K=1,3
      ITEMP=IH(J,K)
      IH(J,K)=IH(J+1,K)
   75 IH(J+1,K)=ITEMP
   80 CONTINUE
      GO TO 65
   99 RETURN
      END
