      SUBROUTINE QCOMP(NH,Z,x,u,Q)
C COMPUTES RECIPROCAL OF SQUARE OF DISTANCE FROM ORIGIN FOR PLANE HKLM
      DIMENSION NH(4),Z(10),qh(3),x(3),u(3)
      common/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp, iq(3)
      q = 0.0
      do i=1,3
        qh(i) = nh(i) + nh(4)*qj(i)
      enddo
      do j=1,3
        k=mod(j,3) + 1
        l=mod(k,3) + 1
        temp=(qh(j)**2)*z(j) + 2*qh(j)*qh(k)*x(j)*x(k)*u(l)
        q = q + temp
      enddo
*      write(6,1)
* 1     format('   h  k  l  m       d*2')
*      write(6,2)(nh(j),j=1,4),q
* 2     format(1x,4(1x,i2),2x,f10.4)
      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,4),NH(4)
      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,4
      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 D-SPACINGS closer than the tolerance tol
C
C     PARAMETER (MAXGEN=1000)
      common/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp, iq(3)
      COMMON/IO/NTOUT,NTIN,NEXTN
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/IERRS/IWARN,IERR
      COMMON/HDGEN/IHG(1000,4),DCM(1000),NR,DMIN
      COMMON/UNQ/ IFA,IFB,IFC,IRH
      logical qmodul
      DIMENSION IH(4),JH(4)
      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,4
      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     !if true peaks are different
      J=J+1
      IF (J.GT.NR) GO TO 27
      IF ((DCM(I)-DCM(J)).GE.TOL) GO TO 27
      DO 25 K=1,4
   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,4
   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(4),JH(4),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 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/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp, iq(3)
      COMMON/CHAR/ITIH(7),ITCRS(8),ITSG(7),ITED(4)
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),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,prthtse
      CHARACTER*1 ITSG,ITCRS,ITED,ITIH
      CHARACTER*1 IHED,INTED
      LOGICAL HEADNG, qmodul
      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, 4), 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 HKLPR
C
C PRINTS H,K,L,CALCULATED AND OBSERVED D-S AND THETAS
C
C     PARAMETER (MAXOBS=200)
      common/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp, iq(3)
      COMMON/ALL/N,NUMCYC,ntot
      COMMON/SCRT/E(9),ee(9,9),NH(4),qh(3),f(9),ff(9,10)
      COMMON/PPDATA/OBSTH(200),DSP(200),IH(200,4),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,prthtse
      COMMON/CBLKC/JA
      logical qmodul
      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
      if(qmodul)then
        WRITE(NTOUT,16) NUMCYC,(NH(L),L=1,4),JA(1:2),TC,OB,TD
      else
        WRITE(NTOUT,15) NUMCYC,(NH(L),L=1,3),JA(1:2),TC,OB,TD
      endif
      RETURN
   15 FORMAT(1H ,I3,2x,3(2x,I2),A2,7x,3(3x,F12.5))
   16 FORMAT(1H ,I3,2x,4(2x,I2),A2,3x,3(3x,F12.5))
      END


      SUBROUTINE CMPNUP
C COMPUTES DIRECT CELL PARAMETERS FROM CORRECTED RECIPROCAL CELL
      common/qmod/qj(3), mmin, mmax, qmodul, qrefin, nq, iqtyp, iq(3)
      COMMON/PPCON/JTYP,ITYP,TOLTH,THEMX,RESOLV
      COMMON/CPPCON/IALF12
      COMMON/RECP/Z(10),Q,AR(3),X(4),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/A(54),UO(3),B(9),bb(9,9)
      COMMON/BLKB/CR(9)
      COMMON/OUTHLD/TCR(3)
      logical qmodul
      CHARACTER*6 IALF12
C
C-----STORE VALUE OF UO FOR LATER OUTPUT
C
      DO J=1,3
        UO(J)=AR(J)
        W(J)=SQRT(1.0-U(J)**2)
        AR(J)=57.29578*(1.5707963-ATAN2(U(J),W(J)))
        UO(J)=AR(J)-UO(J)
        TCR(J) = CR(J)
      enddo
      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)*X(3)
      DO 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)=57.29578*(1.5707963-ATAN2(CSA(I),SQRT(1.0-CSA(I)**2)))
      enddo
      VCO=VC
      VC=1.0/VR
      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
