      SUBROUTINE OUTPUT(DONE)
C     PARAMETER (MAXOBS=200)
      common/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp
      COMMON/RECP/Z(10),Q,AR(3),X(4),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/A(54),UO(3),B(9),bb(9,9)
      COMMON/BLKB/CR(9)
      COMMON/SIGMA/SERCE(6),SEDCE(6),VCME(9,9),FACTR,seqm(3)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/CONTR/IXPD,IJOB,IPHKL,IDOLSQ
      COMMON/CCONTR/ ID0
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/BLKC/THCMP,D,CONST,SWT,DIFF,DOBS,THTSE,THOBS,
     * RSDMAX,IRSD,SUM,MMN,prthtse
      COMMON/OUTHLD/TCR(3)
      DIMENSION V(6)
      CHARACTER*7 ID0
      CHARACTER*1 IHED,INTED
      REAL TEMP(3)
      LOGICAL DONE, qmodul
      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, A80, 4X,/ A2, 'theta tolerance = ',
     * F9.5)
      RM=RSDMAX
      TSE=THTSE
*      IF (ITHT.NE.0) GO TO 9
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,10) RM,TSE,MMN
   10 FORMAT(' ',/' Largest residual reduced to unit weight',F13.10/
     * ' Standard error unit wt obs',F13.10/
     * ' Degrees of freedom',I4)
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,122)
  122 FORMAT(1H0/1h0,23X,1Ha,9X,1Hb,9X,1Hc,10X,5Halpha,6X,4Hbeta,5X,
     * 5Hgamma)
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE(NTOUT,12) (X(I),I=1,3),
     * (ar(I),I=1,3)
   12 FORMAT(18H Reciprocal cell  ,3f10.6,3x,3F10.4)
*      DO 50 I = 1, 3, 1
*        TEMP(I) = SERCE(I+3) 
* 50   CONTINUE
      IF (DONE) WRITE(NTOUT,86) (SERCE(I),I=1,6) !,(serce(I),I=4,6)
   86 FORMAT(16H r c stndrd errs,2X,3f10.6,3x,3F10.4)
      IF ((IPHKL .NE.2) .OR. (DONE)) WRITE(NTOUT,14) (TCR(J),J=1,3),
     * (uo(J),J=1,3)
   14 FORMAT(16H r c corrections,2X,3f10.6,3x,3F10.4)
      IF ((IPHKL .NE. 2) .OR. (DONE)) WRITE (NTOUT,24) (AD(I),I=1,3),
     * (als(I),I=1,3)
 24   FORMAT (' ',/' Direct cell',6X,3F10.6,3x,3F10.4)
      IF(DONE) WRITE (NTOUT,500) (SEDCE(I), I = 1, 6)
 500  FORMAT (' ','d c stndrd errs',2X,3F10.6,3x,3F10.4)
      DO 26 I = 1, 3, 1
        TEMP(I) = AD(I) - AO(I)
        UO(I) = ALS(I) - ALO(I)
 26   CONTINUE
      IF((IPHKL.NE.2) .OR. (DONE)) WRITE(NTOUT,30) (TEMP(I),I=1,3),
     * (uo(I),I=1,3)
   30 FORMAT(16H d c corrections,2X,3F10.6,3x,3F10.4)
      if(qmodul)write(ntout,44)(qj(j),j=1,3)
      if(qmodul.and.done)write(ntout,43)(seqm(j),j=1,3)
      if(qmodul)write(ntout,45)(cr(k),k=7,9)
 44    format(' ',/' Modulation coefficients:    r         s    '
     * ,'     t'/ 25x, 3f10.6)
 43    format(' Standard errors         ',3f10.6)
 45    format(' Corrections             ',3f10.6)
      IF (DONE) WRITE(NTOUT,132)
  132 FORMAT(' ',/' Variance-covariance matrix of refinement')
      DO 150 I = 1, 6, 1
      IF (DONE) WRITE(NTOUT,142) (VCME(I,L),L=1,6)
  142 FORMAT(6e13.6)
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) then
        WRITE(NTOUT,160)
  160    FORMAT(' ',/' Correlation matrix of the refinement')
        DO I = 1,6,1
          DO J = 1,6,1
            VCME(I,J) = VCME(I,J)/(V(I)*V(J))
          enddo
          WRITE(NTOUT,172) (VCME(I,L),L=1,6)
 172       FORMAT(6e13.6)
        enddo
      endif
      RETURN
      END

      SUBROUTINE FNLST(done)
C*************************************************************************
C
C CALLED FROM MAIN
C LISTS THEORETICAL REFLECTIONS IN DESCENDING ORDER FOR D-SPACING
C
C***************************************************************************
C     PARAMETER (MAXOBS=200, MAXGEN=1000)
      common/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON /ADATA/IFI(2,27),IFJ(3,27),IHKL(6,3),JHKL(10,3)
      COMMON/CADATA/IALF(13),ialfl(13),CSC(8),cscl(8)
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/HDGEN/IHG(1000,4),DCM(1000),NR,DMIN
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),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,prthtse
      COMMON/CBLKC/JA
      COMMON/RECP/Z(10),Q,AR(3),X(4),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(4), JH(4), IAH(4)
      logical qmodul, done
      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, ialfl, IALF12, JA
      CHARACTER*68 IHEAD
      CHARACTER*5 CSC,cscl,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.and.done) WRITE (NTOUT, 9)
 9    FORMAT (//' !!!! Convergence has been achieved !!!!')
      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,29X,9H<authors>,4X,9H<program>,6X,3Hobs,6X,4Hcalc,
     * 5X,4Hdiff)
      if(qmodul)then
        IF(IXPD.EQ.0)WRITE(NTOUT,18)
      else
        IF(IXPD.EQ.0)WRITE(NTOUT,181)
      endif
   18 FORMAT(1H ,3H  n,3X,6Hd calc,4X,5Hd obs,2X,3Hint,3X,10Hh  k  l  m,
     * 3X,10Hh  k  l  m,3X,7H2-theta,2(2X,7H2-theta))
 181  FORMAT(1H ,3H  n,3X,6Hd calc,4X,5Hd obs,2X,3Hint,3X,10Hh  k  l   ,
     * 3X,10Hh  k  l   ,3X,7H2-theta,2(2X,7H2-theta))
   20 IF (IHP .LE. NR) GO TO 22
      IF (IGP .GT. NUMOBS) GO TO 99
      GO TO 40
   22 DO 24 L=1,4
   24 NH(L) = IHG(IHP,L)
      D=DCM(IHP)
      IF (IHP .EQ. I2) GO TO 40
      THCMP=THETA(0.5*PWL,D)
      THCMP=THCMP+THCMP
      if(qmodul)then
        IF(IXPD.EQ.0)WRITE(NTOUT,30)IHP,D,(NH(L),L=1,4),THCMP
      else
        IF(IXPD.EQ.0)WRITE(NTOUT,301)IHP,D,(NH(L),L=1,3),THCMP
      endif
   30 FORMAT(1H ,I3,F9.4,28X,4I3,10X,F9.4)
 301  FORMAT(1H ,I3,F9.4,28X,3I3,13X,F9.4)
   32 IHP=IHP+1
      GO TO 20
   40 DO 42 L=1,4
   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-----CALCULATE 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,4
46    IAH(I) = IH(IGP,I)
      CALL QCOMP(IAH,Z,x,u,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
      nh(4)=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)
      ih(igp,4) = nh(4)
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)
      jh(4)=nh(4)
      GOTO 70
C
C-----OUTPUT NEXT GENERATED LINE WHICH DOES NOT INDEX ANY AUTHORS LINES
C
 60   if(qmodul)then
        IF(IXPD.EQ.0)WRITE(NTOUT,58)IHP,DF,DOBS,IHED(IGP),INT(IGP),
     * INTED(IGP),(NH(L),L=1,4),JA(1:2),THOBS,THCLC, DIFF
      else
        IF(IXPD.EQ.0)WRITE(NTOUT,581)IHP,DF,DOBS,IHED(IGP),INT(IGP),
     * INTED(IGP),(NH(L),L=1,3),JA(1:2),THOBS,THCLC, DIFF
      endif
   58 FORMAT(1H ,I3,2F9.4,A1,1x,I3,A1,13X,4I3,A2,f8.4,2F9.4)
 581  FORMAT(1H ,I3,2F9.4,A1,1x,I3,A1,13X,3I3,A2,3x,f8.4,2F9.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(qmodul)then
        IF(IXPD.EQ.0)WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INT(IGP),
     * INTED(IGP),(JH(L),L=1,4),JA(1:2),THOBS, THCLC, DIFF
      else
        IF(IXPD.EQ.0)WRITE(NTOUT,741)DF,DOBS,IHED(IGP),INT(IGP),
     * INTED(IGP),(JH(L),L=1,3),JA(1:2),THOBS, THCLC, DIFF
      endif
   74 FORMAT(1H ,3H***,2F9.4,A1,1x,I3,A1,4I3,13X,A2,F8.4,2f9.4)
 741  FORMAT(1H ,3H***,2F9.4,A1,1x,I3,A1,3I3,16X,A2,F8.4,2f9.4)
      GO TO 62
 75   IF (JH(1) .EQ. NH(1) .AND. JH(2) .EQ. NH(2) .AND.
     *JH(3) .EQ. NH(3) .and. jh(4) .eq. nh(4)) 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(qmodul)then
        IF(IXPD.EQ.0)WRITE(NTOUT,30)IHP,D,(NH(L),L=1,4),THCMP
      else
        IF(IXPD.EQ.0)WRITE(NTOUT,301)IHP,D,(NH(L),L=1,3),THCMP
      endif
      GO TO 73
 80   if(qmodul)then
        IF(IXPD.EQ.0)WRITE(NTOUT,74)DF,DOBS,IHED(IGP),INT(IGP),
     * INTED(IGP),(JH(L),L=1,4),JA(1:2),THOBS, THCLC, DIFF
        IF(IXPD.EQ.0)WRITE(NTOUT,30)IHP,D,(NH(L),L=1,4),THCMP
      else
        IF(IXPD.EQ.0)WRITE(NTOUT,741)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,301)IHP,D,(NH(L),L=1,3),THCMP
      endif
      GO TO 62
C
C-----PRINT BOTH AUTHORS AND GENERATED ON SAME LINE
C
 82   if(qmodul)then
        IF(IXPD.EQ.0)WRITE(NTOUT,84)IHP,DF,DOBS,IHED(IGP),
     *  INT(IGP),INTED(IGP),(JH(L),L=1,4),(NH(L),L=1,4),JA(1:2),
     *  THOBS,THCLC,DIFF
      else
        IF(IXPD.EQ.0)WRITE(NTOUT,841)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
      endif
 84   FORMAT (1H , I3, 2F9.4, A1,1x,I3,A1, 4I3, 1X, 4I3, A2
     *, F8.4, 2f9.4)
 841  FORMAT (1H , I3, 2F9.4, A1,1x,I3,A1, 3I3, 4X, 3I3, A2
     *, 3x, F8.4, 2f9.4)
      GO TO 62
* 99   if(qmodul)then
*        write(ntout,445),(qj(j),j=1,3)
*      endif
* 445    format(' The refined modulation vector is:'/
*     *' q* = ',f10.8,' a* + ',f10.8,' b* + ',f10.8,' c*')
 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/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp
      COMMON/SWFG/R
      COMMON/RECP/Z(10),Q,AR(3),X(4),VR,U(3),W(3),VRO
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),PWL,
     * NUMOBS,INT(200)
      COMMON/CPPDAT/ IHED(200),INTED(200)
      COMMON/HDGEN/IHG(1000,4),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(4)
      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,4
      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,4
      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,x,u,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
      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,10Hh  k  l  m,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,4),
     * THOBS,  THETAC, SDIFF
   25 FORMAT(1H ,3X,2F9.4,A1,I3,A1,2X,4I3,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,3X,2Hm(,I2,3H) =,F8.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,3X,
     1 2Hf(, I2,3H) =, F8.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/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp
      COMMON/RECP/Z(10),Q,AR(3),X(4),VR,U(3),W(3),VRO
      COMMON/SCRT/E(9),ee(9,9),NH(4),qh(3),f(9),ff(9,10)
      COMMON/HDGEN/IHG(1000,4),DCM(1000),NR,DMIN
      DO I=1,3
        Z(I)=X(I)**2
      enddo
      DO IC=1,NR
        DO J=1,4
          NH(J)=IHG(IC,J)
        enddo
        CALL QCOMP(NH,Z,x,u,Q)
        IF (Q .GT. 0.0) GO TO 16
        DCM(IC)=0.0
        GO TO 20
 16     DCM(IC)=1.0/SQRT(Q)
 20   enddo
      RETURN
      END
