PROGRAM SORTAV
C
C ROBERT H. BLESSING
C HAUPTMAN-WOODWARD INSTITUTE                                
C 73 HIGH STREET                                       
C BUFFALO, NEW YORK 14203, USA
C TELEPHONE:  (716) 856-9600, EXTENSION 335
C ELECTRONIC MAIL:  Blessing@HWI.Buffalo.Edu
C
C FEBRUARY 1999
C
C A MULTIPLE-PURPOSE PROGRAM FOR TREATING MULTIPLE EQUIVALENT
C MEASUREMENTS:
C
C - SORTS DIFFRACTION DATA ON MILLER INDICES HKL (H CHANGES SLOWEST AND
C   L FASTEST).
C
C - CALCULATES RELATIVE SCALE FACTORS FOR SUBSETS OF THE DATA SET BY
C   LEAST-SQUARES FIT.
C
C - CALCULATES AN EMPIRICAL CORRECTION FOR ABSORPTION ANISOTROPY BASED
C   ON A LEAST-SQUARES FIT OF REAL SPHERICAL HARMONIC FUNCTIONS TO THE
C   EMPIRICAL TRANSMISSION SURFACE AS SAMPLED BY MULTIPLE SYMMETRY-
C   EQUIVALENT AND/OR AZIMUTH ROTATION-EQUIVALENT REFLECTION
C   MEASUREMENTS.
C
C - AVERAGES REPLICATE AND EQUIVALENT MEASUREMENTS.
C
C - PERFORMS AN ANALYSIS OF VARIANCE TO IMPROVE EXPERIMENTAL ERROR
C   ESTIMATES.
C
C
C PROGRAM LIMITS:
C
C - NMAX AND KMAX ARE SPECIFIED IN PARAMETER STATEMENTS IN SEVERAL
C   ----     ----
C   SUBPROGRAMS.
C
C - AT MOST NMAX/2 TOTAL MEASUREMENTS FOR SORTING.
C           ------
C
C - AT MOST NMAX/20 REPLICATE OR EQUIVALENT MEASUREMENTS OF A GIVEN
C           -------
C   UNIQUE REFLECTION FOR AVERAGING.
C
C - AT MOST KMAX SCALE FACTORS FOR SUBSETS OF THE DATA SET (I.E., FRAMES
C           ----
C   OR LAYERS OR SHELLS OF DATA, DATA FROM DIFFERENT SPECIMEN CRYSTALS,
C   DATA AT DIFFERENT WAVELENGTHS OR INCIDENT BEAM INTENSITIES, ETC.).
C
C - AT MOST NFILE = 10 INPUT DATA FILES.
C           ----------
C
      CALL INPUT
      CALL DATAIN
      CALL YSCALE
      CALL ABSORB
      CALL YMERGE
      CALL OUTPUT
      STOP 'PROGRAM SORTAV FINIS'
      END
C-----------------------------------------------------------------------
      BLOCK DATA
C
C DECLARE COMMON BLOCKS AND INITIALIZE COMMON VARIABLES.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
C
C CRYSTAL DATA VARIABLES
C
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
C
C ABSORB VARIABLES
C
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
C
C YSCALE VARIABLES
C
      PARAMETER (KMAX=600)
      COMMON /BLOCKS/ NSCALE,SCALEK(KMAX),IFIXED,QMIN,ZMAX
C
C YMERGE VARIABLES
C
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,IPRINT,JPRINT,JPATH,
     & QLIMIT,ZLIMIT,QPRINT
C
C DATA LIMITS
C
      COMMON /BLOCK3/ IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,SMIN,SMAX
C
C AGREEMENT STATISTICS VARIABLES
C
      PARAMETER (M1=17,M2=15,M3=20,M4=16+M1+M2+M2+M3)
      COMMON /BLOCK4/ X1(M1),X2(M2),X3(M3)
      COMMON /BLOCKR/ NTERM(M4),NMEAN(M4),R1NUM(M4),R1DEN(M4),R2NUM(M4),
     & R2DEN(M4),RWNUM(M4),RWDEN(M4),ZNUM(M4),ZDEN(M4),VNUM(M4),VDEN(M4)
      DOUBLE PRECISION R1NUM,R1DEN,R2NUM,R2DEN,RWNUM,RWDEN,ZNUM,ZDEN,
     & VNUM,VDEN
C
C /BLOCK0/ DATA SORTING ARRAYS
C
      DATA DATA /NMAX*0/
C
C /BLOCKS/ INITIAL INTER-SUBSET SCALE FACTORS
C
      DATA NSCALE,SCALEK /KMAX, KMAX*1/
C
C /BLOCK3/ INITIAL MIN AND MAX VALUES
C
      DATA IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,SMIN,SMAX
     & /+499, -499, +499, -499, +499, -499, 9, 0/
C
C /BLOCK4/ VARIABLES FOR AGREEMENT STATISTICS:
C
C FIXED RANGES OF Y/SIGMA(Y)
C
      DATA X1
     & /-4, -3, -2, -1, 0, 1, 2, 3, 4, 6, 8, 10, 20, 30, 50, 100, 9E9/
C
C FIXED RANGES OF S = SIN(THETA)/LAMBDA = 1/(2*D)
C
C D = 10, 8, 6, 4, 3.5, 3, 2.5, 2, 1.5, 1, 0.75, 0.5, 0.4, 0.35, 0.
C
C S = 0.05, 0.0625, 0.08333333, 0.125, 0.1428571, 0.1666666, 0.2, 0.25,
C     0.3333333, 0.5, 0.6666666, 1, 1.25, 1.428571, 9E9.
C
      DATA X2
     & /0.05, 0.0625, 0.08333333, 0.125, 0.1428571, 0.1666666, 0.2,
     & 0.25, 0.3333333, 0.5, 0.6666666, 1, 1.25, 1.428571, 9E9/
C
C /BLOCKR/ AGREEMENT INDEX SUMS
C
      DATA NTERM,NMEAN,R1NUM,R1DEN,R2NUM,R2DEN,RWNUM,RWDEN,ZNUM,ZDEN,
     & VNUM,VDEN
     & /M4*0,M4*0,M4*0,M4*0,M4*0,M4*0,M4*0,M4*0,M4*0,M4*0,M4*0,M4*0/
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      IF (L0MAX.EQ.0.AND.L1MAX.EQ.0) RETURN
      CALL ABSORB0
      CALL ABSORB1
      CALL ABSORB2
      CALL ABSORB3
      CALL ABSORB4
      CALL ABSORB5
      CALL ABSORB6
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB0
C
C PREPARE DATA FOR FIT OF EMPIRICAL ABSORPTION SURFACE.
C
      REAL MEDIAN
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      DIMENSION YI(NMAX/20),SIGYI(NMAX/20),WI(NMAX/20),A(4,NMAX/20),
     & ANG(4),X(3),Y(3),Z(3),U0(3),U1(3),YLM0(80),YLM1(80)
      EQUIVALENCE (YI(1),DATA(1+NMAX/20)),(SIGYI(1),DATA(1+2*NMAX/20)),
     & (WI(1),DATA(1+3*NMAX/20)),(A(1,1),DATA(1+4*NMAX/20))
C
C PREPARE A WORKING FILE OF MULTIPLE EQUIVALENT DATA.
C
      NHKL=0
      NOBS=0
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED')
      REWIND IO1
 1    READ (IO1,END=9) N
      IF (N.EQ.1) THEN
        READ (IO1)
        GO TO 1
      END IF
      I=0
      DO J=1,N
        READ (IO1) II,IH,IK,IL,YJ,SIGYJ,ISCALE,ANG
C
C SKIP REPEATED MEASUREMENTS OF STANDARD REFERENCE REFLECTIONS FLAGGED
C BY NEGATIVE SERIAL NUMBERS.
C
        IF (II.GT.0) THEN
          I=I+1
          YI(I)=YJ
          SIGYI(I)=SIGYJ
          A(1,I)=ANG(1)
          A(2,I)=ANG(2)
          A(3,I)=ANG(3)
          A(4,I)=ANG(4)
        END IF
      END DO
      N=I
      IF (N.LT.2) GO TO 1
C
C ELIMINATE MEASUREMENTS OUTSIDE GIVEN SIN(THETA)/LAMBDA LIMITS.
C
      S=SINTHL(IH,IK,IL,GINV)
      IF (S.LT.STLMIN.OR.S.GT.STLMAX) GO TO 1
C
C ELIMINATE MEASUREMENTS TOO WEAK TO BE SIGNIFICANT OR TOO STRONG TO BE
C EXTINCTION-FREE.
C
      DO I=1,N
        IF (YI(I)/SIGYI(I).LT.FSQMIN.OR.YI(I).GT.FSQMAX) GO TO 1
      END DO
C
C ELIMINATE MEASUREMENTS THAT ARE PHYSICALLY UNREASONABLE, EXTREME
C OUTLIERS FROM THE SAMPLE MEDIAN.
C
      YMEDIAN=MEDIAN(N,YI)
      NDATA=0
      SUMW=0
      DO I=1,N
        AI=YI(I)/YMEDIAN
        IF (AI.LT.AIMIN.OR.AI.GT.AIMAX) THEN
          WI(I)=0
        ELSE
          WI(I)=1/(SIGYI(I)**2+(PP*YMEDIAN)**2)
          SUMW=SUMW+WI(I)
          NDATA=NDATA+1
        END IF
      END DO
      IF (NDATA.LT.2) GO TO 1
      NHKL=NHKL+1
      NOBS=NOBS+NDATA
C
C WRITE DATA FILE FOR LEAST SQUARES FIT.
C
      WRITE (IO2) NDATA,SUMW
      DO I=1,N
        IF (WI(I).GT.0) THEN
C
C GET REVERSE-INCIDENT AND DIFFRACTED BEAM DIRECTION VECTORS FROM
C DIFFRACTOMETER SETTING ANGLES.
C
          CALL AXYZ (IDIFF,A(1,I),X,Y,Z)
          THETA=ASIN(S*FLAMBDA)
          CALL U0U1 (THETA,X,Y,U0,U1)
          WRITE (IO2) U0,U1,WI(I),YI(I)
        END IF
      END DO
      GO TO 1
 9    ENDFILE IO2
      WRITE (ILP,9001) ATIME,ADATE,TITLE
 9001 FORMAT ('1'/1X,'PROGRAM SORTAV/ABSORB.  ',A,', ',A,
     &'.  ',A)
      WRITE (ILP,9002) STLMIN,STLMAX,FSQMIN,FSQMAX,AIMIN,AIMAX,NOBS,NHKL
 9002 FORMAT (//1X,'REFLECTION DATA SELECTION FOR EMPIRICAL ABSORP',
     &'TION FITTING:'/1X,'--------------------------------------------',
     &'---------------'//1X,'MINIMUM PERMITTED SIN(THETA)/LAMBDA     ',
     &'    = ',E10.3,' ANGSTROM**-1'/1X,'MAXIMUM PERMITTED SIN(THET',
     &'A)/LAMBDA         = ',E10.3,' ANGSTROM**-1'//1X,'MINIMUM PERMI',
     &'TTED FSQ/SIGMA(FSQ)            = ',E10.3/1X,'MAXIMUM PERMITTED ',
     &'FSQ                       = ',E10.3//1X,'MINIMUM PERMITTED FSQ(',
     &'I)/FSQ(SAMPLE MEDIAN) = ',E10.3/1X,'MAXIMUM PERMITTED FSQ(I)/FS',
     &'Q(SAMPLE MEDIAN) = ',E10.3//1X,'NOBS = ',I10,' REFLECTION MEASU',
     &'REMENTS SELECTED'/1X,'NHKL = ',I10,' UNIQUE REFLECTIONS REPRESE',
     &'NTED')
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB1
C
C FIT REAL SPHERICAL HARMONICS, YLM, TO EMPIRICAL ABSORPTION SURFACE AS
C SAMPLED BY MULTIPLE EQUIVALENT MEASUREMENTS.
C
C   CHISQ = SUM(H) SUM(I=1,N) [WHI*(YHI*AHI - <YHI*AHI>)**2
C             + WA*(AHI - 1)**2]
C
C   CHISQ = SUM(H) SUM(I=1,N) [WHI*(YHI*AHI
C             - SUM(J=1,N) WHJ*YHJ*AHJ/SUM(J=1,N) WHJ)**2
C                 + WA*(AHI - 1)**2]
C
C WHERE HERE THE A VALUES ARE ABSORPTION ANISOTROPY CORRECTION FACTORS,
C I.E., RECIPROCAL TRANSMISSION FACTORS, WHICH ARE RESTRAINED TOWARD AN
C AVERAGE VALUE OF UNITY.
C
C   FSQ(CORR) = FSQ(MEAS)*A
C
C   A = 0.5*(A(-U0) + A(U1))
C
C   A(U) = 1 + SUM(L=1,LMAX) SUM(M=-L,+L) ALM*YLM(U)
C
C   YLM(U) = YLM(X, Y, Z)
C
C WHERE X, Y, AND Z ARE THE COMPONENTS OF UNIT VECTORS ALONG THE REVERSE
C INCIDENT BEAM, -U0, AND THE DIFFRACTED BEAM, U1, REFERRED TO A SET OF
C CRYSTAL-FIXED CARTESIAN (I.E., ORTHONORMAL) AXES.  IN OTHER WORDS, THE
C COMPONENTS X, Y, AND Z ARE THE DIRECTION COSINES OF THE BEAM DIRECTION
C VECTORS, -U0 AND U1.
C
C NOTE THAT THERE ARE TWO TERMS IN THE RESIDUAL,
C
C   CHISQ = CHISQ(Y) + WA*CHISQ(A).
C
C THE FIRST TERM,
C
C   CHISQ(Y) = SUM(H) SUM(I=1,N) WHI*(YHI*AHI - <YHI*AHI>)**2,
C
C IS THE FIT RESIDUAL FOR THE PARAMETERS OF THE AHI, AND IN THE SECOND
C TERM,
C
C   CHISQ(A) = SUM(H) SUM(I=1,N) (AHI - 1)**2,
C
C IS A RESTRAINT RESIDUAL, WHICH ACTS TO RESTRAIN THE AVERAGE OF THE AHI
C TOWARD A VALUE OF UNITY.
C
C IF THE DIFFERENCES AMONG THE YHI ARE DUE MAINLY TO THE DIFFERENT AHI,
C EXPECT NORMALIZED MEAN-SQUARE DEVIATIONS
C
C   CHISQ(A)/SUM AHI**2 = SUM WHI*(YHI - <YHI>)**2/SUM WHI*YHI**2
C
C                       = RW**2.
C
C FOR <AHI> = 1, SUM AHI**2 = NOBS, AND
C
C   CHISQ(A) = NOBS*RW**2.
C
C THUS, TO HAVE A STANDARDIZED MEAN-SQUARE DEVIATION
C
C   WA*CHISQ(A)/NOBS = 1,
C
C CHOOSE
C
C   WA = 1/RW**2.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      DIMENSION U0(3,NMAX/20),U1(3,NMAX/20),W(NMAX/20),Y(NMAX/20)
      DIMENSION YLM0(80),YLM1(80),QI(80),XI(80),A(80,80),B(80),
     & U(80),V(80,80),VA(80,80)
      DOUBLE PRECISION A,B,U,V,VA
      DIMENSION CORR(80,80)
      EQUIVALENCE (U0(1,1),DATA(1)),(U1(1,1),DATA(1+3*NMAX/20)),
     & (W(1),DATA(1+6*NMAX/20)),(Y(1),DATA(1+7*NMAX/20)),
     & (CORR(1,1),DATA(1))
C
C CALCULATE AGREEMENT STATISTICS FOR A = 1.
C
      NHKL=0
      NOBS=0
      CHISQ=0
      SUMSQ=0
      REWIND IO2
 11   READ (IO2,END=19) N,SUMW
      DO I=1,N
        READ (IO2) X,X,X,X,X,X,W(I),Y(I)
      END DO
      NHKL=NHKL+1
      NOBS=NOBS+N
      DO I=1,N
        DI=0
        DO J=1,N
          YJ=-W(J)*Y(J)/SUMW
          IF (J.EQ.I) YJ=YJ+Y(J)
          DI=DI+YJ
        END DO
        CHISQ=CHISQ+W(I)*DI**2
        SUMSQ=SUMSQ+W(I)*Y(I)**2
      END DO
      GO TO 11
 19   CONTINUE
      R1=SQRT(CHISQ/SUMSQ)
      Z1=SQRT(CHISQ/(NOBS-NHKL))
      WQ=WA/R1**2
C
C CALCULATE THE NUMBER OF PARAMETERS.
C
      NPAR=0
      LMAX=MAX(L0MAX,L1MAX)
      DO L=1,LMAX
        IF ((MOD(L,2).EQ.0.AND.L.LE.L0MAX).OR.
     &      (MOD(L,2).EQ.1.AND.L.LE.L1MAX)) NPAR=NPAR+2*L+1
      END DO
 15   IF (NOBS/NPAR.LT.10) THEN
        NPAR=NPAR-(2*LMAX+1)
        IF (NPAR.LE.0) STOP 'TOO FEW DATA TO FIT TRANSMISSION SURFACE'
        LMAX=LMAX-1
        IF (L0MAX.GT.LMAX) L0MAX=L0MAX-2
        IF (L1MAX.GT.LMAX) L1MAX=L1MAX-2
        GO TO 15
      END IF
C
C ZERO THE NORMAL MATRIX AND VECTOR.
C
      DO I=1,NPAR
        B(I)=0
      DO J=I,NPAR
        A(I,J)=0
      END DO
      END DO
C
C ACCUMULATE NORMAL MATRIX AND VECTOR.
C
      REWIND IO2
 1    READ (IO2,END=9) N,SUMW
      DO I=1,N
        READ (IO2) (U0(J,I),J=1,3),(U1(J,I),J=1,3),W(I),Y(I)
      END DO
      DO I=1,N
C
C EVALUATE THE RESTRAINT DERIVATIVES.
C
        CALL FYLM (YLM0,U0(1,I),L0MAX,L1MAX)
        CALL FYLM (YLM1,U1(1,I),L0MAX,L1MAX)
        DO K=1,NPAR
          QI(K)=0.5*(YLM0(K)+YLM1(K))
        END DO
C
C EVALUATE YCALC AND THE FIT DERIVATIVES.
C
        YI=0
        DO K=1,NPAR
          XI(K)=0
        END DO
        DO J=1,N
          YJ=-W(J)*Y(J)/SUMW
          IF (J.EQ.I) YJ=YJ+Y(J)
          YI=YI+YJ
          CALL FYLM (YLM0,U0(1,J),L0MAX,L1MAX)
          CALL FYLM (YLM1,U1(1,J),L0MAX,L1MAX)
          DO K=1,NPAR
            XI(K)=XI(K)+YJ*0.5*(YLM0(K)+YLM1(K))
          END DO
        END DO
C
C SUM THE NORMAL MATRIX AND VECTOR ELEMENTS.
C
        DO K=1,NPAR
          B(K)=B(K)-W(I)*YI*XI(K)
        DO L=K,NPAR
          A(K,L)=A(K,L)+WQ*QI(K)*QI(L)+W(I)*XI(K)*XI(L)
        END DO
        END DO
      END DO
      GO TO 1
 9    CONTINUE
      DO I=1,NPAR-1
      DO J=I+1,NPAR
        A(J,I)=A(I,J)
      END DO
      END DO
C
C INVERT THE NORMAL MATRIX VIA DIAGONALIZATION AND EIGENVALUE FILTERING.
C
      CALL JACOBI (NPAR,80,A,U,V,NROT)
      UMAX=0
      DO I=1,NPAR
        UMAX=MAX(UMAX,SNGL(ABS(U(I))))
      END DO
      NZERO=0
      T=UMIN*UMAX
      DO I=1,NPAR
        IF (ABS(U(I)).LT.T) THEN
          U(I)=0
          NZERO=NZERO+1
        ELSE
          U(I)=1/U(I)
        END IF
      END DO
      DO I=1,NPAR
      DO J=1,NPAR
        A(I,J)=0
      END DO
        A(I,I)=U(I)
      END DO
      CALL MMD (NPAR,80,V,A,VA)
      DO I=1,NPAR-1
      DO J=I+1,NPAR
        T=V(I,J)
        V(I,J)=V(J,I)
        V(J,I)=T
      END DO
      END DO
      CALL MMD (NPAR,80,VA,V,A)
C
C CALCULATE THE PARAMETER VALUES.
C
      DO I=1,NPAR
        ALM(I)=0
      DO J=1,NPAR
        ALM(I)=ALM(I)+A(I,J)*B(J)
      END DO
      END DO
C
C CALCULATE STATISTICS OF FIT.
C
      CHISQ=0
      SUMSQ=0
      AIMIN=1E10
      AIMAX=0
      SUMA=0
      SUMASQ=0
      CHISQA=0
      REWIND IO2
 41   READ (IO2,END=49) N,SUMW
      DO I=1,N
        READ (IO2) (U0(J,I),J=1,3),(U1(J,I),J=1,3),W(I),Y(I)
        CALL FYLM (YLM0,U0(1,I),L0MAX,L1MAX)
        CALL FYLM (YLM1,U1(1,I),L0MAX,L1MAX)
        AI=1
        DO K=1,NPAR
          AI=AI+ALM(K)*0.5*(YLM0(K)+YLM1(K))
        END DO
        Y(I)=Y(I)*AI
        AIMIN=MIN(AIMIN,AI)
        AIMAX=MAX(AIMAX,AI)
        SUMA=SUMA+AI
        SUMASQ=SUMASQ+AI**2
        CHISQA=CHISQA+(AI-1)**2
      END DO
      DO I=1,N
        DI=0
        DO J=1,N
          YJ=-W(J)*Y(J)/SUMW
          IF (J.EQ.I) YJ=YJ+Y(J)
          DI=DI+YJ
        END DO
        CHISQ=CHISQ+W(I)*DI**2
        SUMSQ=SUMSQ+W(I)*Y(I)**2
      END DO
      GO TO 41
 49   CONTINUE
      CLOSE (UNIT=IO2,STATUS='DELETE')
      AMEAN=SUMA/NOBS
      RMSDA=SQRT((FLOAT(NOBS)/(NOBS-1))*((SUMASQ/NOBS)-AMEAN**2))
      ZY=SQRT(CHISQ/(NOBS-NHKL-(NPAR-NZERO)))
      RY=SQRT(CHISQ/SUMSQ)
      ZA=SQRT(WQ*CHISQA/(NOBS-NHKL))
      RA=SQRT(CHISQA/SUMASQ)
C
C COMPUTE VAR-COV MATRIX.
C
      DO I=1,NPAR
        SIGALM(I)=ZY*SQRT(A(I,I))
      END DO
      DO I=1,NPAR
      DO J=I,NPAR
        IF (A(I,I)*A(J,J).GT.0) THEN
          IF (I.EQ.J) THEN
            T=1
          ELSE
            T=A(I,J)/SQRT(A(I,I)*A(J,J))
          END IF
        ELSE
          T=0
        END IF
        CORR(I,J)=T
        CORR(J,I)=T
      END DO
      END DO
      IF (NPAR.LT.80) THEN
        DO I=NPAR+1,80
          ALM(I)=0
          SIGALM(I)=0
        DO J=1,80
          CORR(I,J)=0
          CORR(J,I)=0
        END DO
        END DO
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB2
C
C PRINT THE FITTED A(L,M) COEFFICIENTS AND STATISTICS OF FIT.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      DIMENSION CORR(80,80)
      EQUIVALENCE (CORR(1,1),DATA(1))
      CHARACTER FL(80)*1,FM(80)*2
      DATA FL /'1',' ',' ','2',' ',' ',' ',' ','3',' ',' ',' ',' ',' ',
     &' ','4',' ',' ',' ',' ',' ',' ',' ',' ','5',' ',' ',' ',' ',' ',
     &' ',' ',' ',' ',' ','6',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
     &' ',' ','7',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
     &' ','8',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
     &' ',' '/
      DATA FM /' 0','+1','-1',' 0','+1','-1','+2','-2',' 0','+1','-1',
     &'+2','-2','+3','-3',' 0','+1','-1','+2','-2','+3','-3','+4','-4',
     &' 0','+1','-1','+2','-2','+3','-3','+4','-4','+5','-5',' 0','+1',
     &'-1','+2','-2','+3','-3','+4','-4','+5','-5','+6','-6',' 0','+1',
     &'-1','+2','-2','+3','-3','+4','-4','+5','-5','+6','-6','+7','-7',
     &' 0','+1','-1','+2','-2','+3','-3','+4','-4','+5','-5','+6','-6',
     &'+7','-7','+8','-8'/
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,2000)
      I=0
      N=0
      DO L=1,MAX(L0MAX,L1MAX)
      DO M=-L,+L
        I=I+1
        IF ((MOD(L,2).EQ.0.AND.L.LE.L0MAX).OR.
     &      (MOD(L,2).EQ.1.AND.L.LE.L1MAX)) THEN
          N=N+1
          IF (SIGALM(N).GT.0) THEN
            Q=ABS(ALM(N))/SIGALM(N)
          ELSE
            Q=0
          END IF
          WRITE (ILP,1001) N,FL(I),FM(I),ALM(N),Q
        END IF
      END DO
      END DO
      NPAR=N
      SUMQ=0
      N=0
      N1=0
      N2=0
      N3=0
      DO I=1,NPAR
        IF (SIGALM(I).GT.0) THEN
          Q=ABS(ALM(I))/SIGALM(I)
          SUMQ=SUMQ+Q
          N=N+1
        ELSE
          Q=0
        END IF
        IF (Q.GE.1) N1=N1+1
        IF (Q.GE.2) N2=N2+1
        IF (Q.GE.3) N3=N3+1
      END DO
      IF (N.GT.0) THEN
        Q=SUMQ/N
      ELSE
        Q=0
      END IF
      WRITE (ILP,1002) N1,N2,N3,Q,NZERO,UMIN
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1003)
      DO I=1,NPAR
        WRITE (ILP,1004) I,(NINT(100*CORR(I,J)),J=1,I)
      END DO
      WRITE (ILP,1005)
      DO I=1,NPAR
      DO J=I,NPAR
        IF (J.GT.I.AND.ABS(CORR(I,J)).GE.0.75)
     &  WRITE (ILP,1006) I,J,CORR(I,J)
      END DO
      END DO
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1007)
      WRITE (ILP,1008) WA,NOBS,NHKL,NPAR,NZERO,Z1,R1,ZY,RY,ZA,RA
      WRITE (ILP,1009) AIMIN,AIMAX,AMEAN,RMSDA
 1000 FORMAT ('1'/1X,'PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A)
 2000 FORMAT (//1X,'FITTED ABSORPTION ANISOTROPY EXPANSION COEFFICIENT',
     &'S A(L,M)'/1X,'---------------------------------------------------
     &-------'//1X,'FSQ(CORR) = FSQ(MEAS)/A'//1X,'A = A(0)/(1 + SUM(L=1,
     &LMAX) SUM(M=-L,+L) A(L,M)*{0.5*[Y(L,M)(-U0) + Y(L,M)(U1)]})'//1X,
     &'A(0) = A(SPHERE)(MU*R, THETA)'//1X,'Y(L,M)(U) = Y(L,M)(X, Y, Z)'/
     &/1X,'WHERE X, Y, AND Z ARE COMPONENTS OF UNIT VECTORS ALONG THE RE
     &VERSE'/1X,'INCIDENT BEAM, -U0, OR THE DIFFRACTED BEAM, U1, REFERRE
     &D TO CRYSTAL-'/1X,'FIXED CARTESIAN (I.E., ORTHONORMAL) AXES.  IN O
     &THER WORDS, X, Y, AND, Z'/1X,'ARE DIRECTION COSINES OF THE BEAM DI
     &RECTION VECTORS.'//1X,
     &' I    L  M   A(L,M)     ABS(A)/SIGMA(A)'/1X,
     &' -    -  -   ------     ---------------'/1X,
     &' 0    0  0   1.0')
 1001 FORMAT (1X,I2,4X,A1,1X,A2,2X,E10.3,E10.2)
 1002 FORMAT (//1X,
     &'N1    = ',I3,'  A(L,M) WITH ABS(A)/SIGMA(A) .GE. 1'/1X,
     &'N2    = ',I3,'    "      "        "         .GE. 2'/1X,
     &'N3    = ',I3,'    "      "        "         .GE. 3'//1X,
     &'<ABS(A)/SIGMA(A)> = ',E9.2,//1X,
     &'NZERO = ',I3,8X,
     &'  PSEUDOPARAMETERS ZEROED BY EIGENVALUE FILTERING'/1X,
     &'UMIN  = ',E11.3,'  MINIMUM PERMITTED EIGENVALUE MAGNITUDE EXPRESS
     &ED AS FRACTION OF THE MAXIMUM EIGENVALUE MAGNITUDE')
 1003 FORMAT (//1X,'CORRELATION MATRIX (100*CORR(I,J)):'//1X,
     &'        1   2   3   4   5   6   7   8   9   0   1   2   3   4   5
     &   6   7   8   9   0   1   2   3   4   5   6   7   8   9   0')
 1004 FORMAT (1X,I3,2X,5(30I4/6X))
 1005 FORMAT (//1X,'CORRELATION COEFFICIENTS WITH ABS(CORR) .GE. 0.75:'/
     &/1X,'  I  J  CORR(I,J)'/1X,'  -  -  ---------')
 1006 FORMAT (1X,2I3,2X,F6.3)
 1007 FORMAT (//1X,'STATISTICS-OF-FIT FOR THE A(L,M) EXPANSION COEFFICIE
     &NTS:'/1X,'--------------------------------------------------------
     &'//1X,'TOTAL RESIDUAL        CHISQ    = CHISQ(Y) + CHISQ(A)'/1X,'F
     &IT RESIDUAL          CHISQ(Y) = SUM(H) SUM(I=1,N) WHI*(YHI*AHI - <
     &YHI*AHI>)**2'/1X,'                               = SUM(H) SUM(I=1,
     &N) WHI*(YHI*AHI - SUM(J=1,N) WHJ*YHJ*AHJ/SUM(J=1,N) WHJ)**2'/1X,'R
     &ESTRAINT RESIDUAL    CHISQ(A) = SUM(H) SUM(I=1,N) W*(AHI - 1)**2'/
     &/1X,
     &'WHERE HERE THE AHI ARE ABSORPTION ANISOTROPY CORRECTION FACTORS',
     &', I.E., RECIPROCAL TRANSMISSION FACTORS,'/1X,'    FSQ(CORR) = FSQ
     &(MEAS)*A'/1X,'    A = 0.5*(A(-U0) + A(U1))'/1X,'    A(U) = 1 + SUM
     &(L=1,LMAX) SUM(M=-L,+L) A(L,M)*Y(L,M)(U).'/1X,'THE TERMS IN THE FI
     &T RESIDUAL ARE WEIGHTED BY'/1X,'    WHI = 1/SIGMA(YHI)**2,'/1X,'AN
     &D THE RESTRAINT RESIDUAL HAS A CONSTANT WEIGHTING FACTOR'/1X,
     &'    W = WA/(<WHI*(YHI - <YHI>)**2>/<WHI*YHI**2>),'/1X,'WHICH SERV
     &ES TO ADJUST THE RESTRAINT RESIDUAL TO A SCALE COMPARABLE TO THE F
     &IT RESIDUAL.'//1X,'STANDARDIZED ROOT-MEAN-SQUARE ERROR-OF-FIT   ',
     &'     Z  = SQRT(CHISQ(Y)/(NOBS - NHKL - (NPAR - NZERO)))'/1X,'NORM
     &ALIZED ROOT-MEAN-SQUARE ERROR-OF-FIT          RW = SQRT(CHISQ(Y)/S
     &UM(WHI*(YHI*AHI)**2))'//1X,'STANDARDIZED ROOT-MEAN-SQUARE RESTRAIN
     &T RESIDUAL  ZA = SQRT(CHISQ(A)/(NOBS - NHKL))'/1X,'NORMALIZED ROOT
     &-MEAN-SQUARE RESTRAINT RESIDUAL    RA = SQRT(SUM((AHI - 1)**2)/SUM
     &(AHI**2))')
 1008 FORMAT (//1X,'RESTRAINT RESIDUAL WEIGHT MULTIPLIER'/1X,'WA = ',
     &E10.3//1X,'NUMERICAL STATISTICS-OF-FIT:'/1X,
     &'NOBS  = ',I6,'  MEASUREMENTS'/1X,
     &'NHKL  = ',I6,'  UNIQUE REFLECTIONS'/1X,
     &'NPAR  = ',I6,'  FITTED COEFFICIENTS A(L,M)'/1X,
     &'NZERO = ',I6,'  PSEUDOPARAMETERS ZEROED BY EIGENVALUE FILTERING'
     &//1X,
     &'Z  = ',F6.3,'    RW = ',F7.4,'    FOR ALL AHI = 1 (NPAR = 0)'
     &//1X,
     &'Z  = ',F6.3,'    RW = ',F7.4,'    FOR THE AHI FROM THE FITTED A(L
     &,M)'/1X,
     &'ZA = ',F6.3,'    RA = ',F7.4)
 1009 FORMAT (//1X,
     &'STATISTICS OF FITTED ANISOTROPY CORRECTION FACTORS, AHI:'/1X,
     &'AMIN                          = ',E10.3/1X,
     &'AMAX                          = ',E10.3/1X,
     &'AMEAN                         = ',E10.3/1X,
     &'RMSDA = <(A - AMEAN)**2>**1/2 = ',E10.3)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB3
C
C TABULATE AND PLOT SPHERICAL CRYSTAL TRANSMISSION FACTOR.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      CHARACTER P*1
      DIMENSION P(0:100,0:50)
C
C IF MU = 0, RETURN A = 1.
C
      IF (FMU.EQ.0) THEN
        DO I=1,7
          ASPH(I)=1
        END DO
        RETURN
      END IF
      IF (RADIUS.EQ.0) THEN
C
C TRANSFER TMIN, THE ESTIMATED MINIMUM CRYSTAL THICKNESS, AND AMAX, THE
C MAXIMUM TRANSMISSION ANISOTROPY FACTOR FROM THE FITTED YLM, VIA THE
C ARRAY ASPH.
C
        AMAX=1/AIMIN
        ASPH(1)=TMIN
        ASPH(2)=AMAX
      END IF
      CALL ATABLE (FMU,RADIUS,ASPH)
      PI=ACOS(-1.0)
      AMIN=FA0(ASPH,0.0)
      AMAX=FA0(ASPH,PI/2)
      DO I=0,100
      DO J=0,50
        P(I,J)=' '
        IF (I.EQ.0.OR.I.EQ.100) THEN
          P(I,J)='.'
          IF (MOD(J,10).EQ.0) P(I,J)='+'
        END IF
        IF (J.EQ.0.OR.J.EQ.50) THEN
          P(I,J)='.'
          IF (MOD(I,10).EQ.0) P(I,J)='+'
        END IF
      END DO
      END DO
      DO I=0,100
        T=ASIN(SQRT(0.01*I))
        A=FA0(ASPH,T)
        J=NINT(50*(A-AMIN)/(AMAX-AMIN))
        P(I,J)='*'
      END DO
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      DO J=50,0,-1
        IF (MOD(J,10).EQ.0) THEN
          WRITE (ILP,1001) AMIN+(J/50.0)*(AMAX-AMIN),(P(I,J),I=0,100)
        ELSE
          WRITE (ILP,1002) (P(I,J),I=0,100)
        END IF
      END DO
      WRITE (ILP,1003) (0.1*I,I=0,10)
      WRITE (ILP,1004) FMU,RADIUS,AMIN,AMAX
 1000 FORMAT ('1'/'0PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A/)
 1001 FORMAT (' ',F10.8,101A1)
 1002 FORMAT (' ',10X,101A1)
 1003 FORMAT (' ',1X,11F10.1)
 1004 FORMAT ('0SPHERICAL CRYSTAL TRANSMISSION FACTOR:'/'0Y = A(MU*R, TH
     &ETA) VERSUS X = (SIN(THETA))**2 FOR MU = ',E10.3,' MM**-1 AND R ',
     &'= ',E10.3,' MM'/'0AMIN = ',F10.8,', AMAX = ',F10.8)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB4
C
C LEAST-SQUARES FIT OF DIFFRACTOMETER ORIENTATION MATRIX, U, AS DEFINED
C BY WALTER HAMILTON, INTERNATIONAL TABLES FOR X-RAY CRYSTALLOGRAPHY,
C VOL. IV, 1974, PP. 273-284.
C
C H*U = X, WHERE H IS A ROW VECTOR OF MILLER INDICES AND X IS A ROW
C VECTOR OF CRYSTAL-FIXED ORTHONORMAL COORDINATES.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      DIMENSION H(3),ANG(4),X(3),Y(3),Z(3)
      DIMENSION A1(3,3),B1(3),A2(3,3),B2(3),A3(3,3),B3(3)
      DIMENSION U1(3),U2(3),U3(3)
      DOUBLE PRECISION A1,A2,A3,B1,B2,B3,U1,U2,U3
C
C ZERO NORMAL MATRICES AND VECTORS.
C
      DO I=1,3
      DO J=I,3
        A1(I,J)=0
        A2(I,J)=0
        A3(I,J)=0
      END DO
        B1(I)=0
        B2(I)=0
        B3(I)=0
      END DO
C
C LOOP THROUGH DATA FILE TO BUILD NORMAL EQUATIONS.
C
      REWIND IO1
    1 READ (IO1,END=9) N,IH,IK,IL
      DSTAR=2*SINTHL(IH,IK,IL,GINV)
      DO WHILE (N.GT.0)
        N=N-1
        READ (IO1) I,IH,IK,IL,F,F,I,ANG
        H(1)=IH
        H(2)=IK
        H(3)=IL
        CALL AXYZ (IDIFF,ANG,X,Y,Z)
        DO I=1,3
        DO J=I,3
          A1(I,J)=A1(I,J)+H(I)*H(J)
          A2(I,J)=A2(I,J)+H(I)*H(J)
          A3(I,J)=A3(I,J)+H(I)*H(J)
        END DO
          B1(I)=B1(I)+H(I)*DSTAR*Y(1)
          B2(I)=B2(I)+H(I)*DSTAR*Y(2)
          B3(I)=B3(I)+H(I)*DSTAR*Y(3)
        END DO
      END DO
      GO TO 1
    9 CONTINUE
      DO I=1,3-1
      DO J=I+1,3
        A1(J,I)=A1(I,J)
        A2(J,I)=A2(I,J)
        A3(J,I)=A3(I,J)
      END DO
      END DO
C
C SOLVE NORMAL EQUATIONS.
C
      CALL MATINV (3,3,A1,DET1)
      CALL MATINV (3,3,A2,DET2)
      CALL MATINV (3,3,A3,DET3)
      IF (DET1.EQ.0.OR.DET2.EQ.0.OR.DET3.EQ.0) STOP 'SINGULAR NORMAL MAT
     &RIX FOR ORIENTATION MATRIX FIT'
      CALL MVD (3,A1,B1,U1)
      CALL MVD (3,A2,B2,U2)
      CALL MVD (3,A3,B3,U3)
      DO I=1,3
        UB(I,1)=U1(I)
        UB(I,2)=U2(I)
        UB(I,3)=U3(I)
      END DO
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1001) ((UB(I,J),J=1,3),I=1,3)
 1000 FORMAT ('1'/'0PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A)
 1001 FORMAT ('0DIFFRACTOMETER ORIENTATION MATRIX:'/
     &'0UB11 UB12 UB13   ',3E11.4/
     &' UB21 UB22 UB23 = ',3E11.4/
     &' UB31 UB32 UB33   ',3E11.4/
     &'0FOR DIFFRACTOMETER AXES AS DEFINED BY HAMILTON (INT. TAB., VOL',
     &'. IV, PP. 273-284, 1974).')
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB5
C
C PLOT SECTIONS OF TRANSMISSION SURFACE.
C
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      IF (IPLOT.LT.1) RETURN
      CALL APLOT ( 1, 0, 0)
      CALL APLOT ( 0, 1, 0)
      CALL APLOT ( 0, 0, 1)
      IF (IPLOT.LT.2) RETURN
      CALL APLOT ( 1, 1, 0)
      CALL APLOT (-1, 1, 0)
      CALL APLOT ( 1, 0, 1)
      CALL APLOT (-1, 0, 1)
      CALL APLOT ( 0, 1, 1)
      CALL APLOT ( 0,-1, 1)
      IF (IPLOT.LT.3) RETURN
      CALL APLOT ( 1, 1, 1)
      CALL APLOT (-1, 1, 1)
      CALL APLOT (-1,-1, 1)
      CALL APLOT ( 1,-1, 1)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB6
C
C APPLY ABSORPTION CORRECTION.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      DIMENSION CORR(80,80)
      EQUIVALENCE (CORR(1,1),DATA(1))
      DIMENSION ANG(4),X(3),Y(3),Z(3),U0(3),U1(3),YLM0(80),YLM1(80),
     & S0(3),S1(3)
      DIMENSION II(NMAX/20),IH(NMAX/20),IK(NMAX/20),IL(NMAX/20),
     & YI(NMAX/20),SI(NMAX/20),AI(NMAX/20),SA(NMAX/20),TI(NMAX/20),
     & X0(NMAX/20,3),X1(NMAX/20,3),INDEX(NMAX/20)
      EQUIVALENCE (II(1),DATA(6401)),(IH(1),DATA(6401+NMAX/20)),
     & (IK(1),DATA(6401+2*NMAX/20)),(IL(1),DATA(6401+3*NMAX/20)),
     & (YI(1),DATA(6401+4*NMAX/20)),(SI(1),DATA(6401+5*NMAX/20)),
     & (AI(1),DATA(6401+6*NMAX/20)),(SA(1),DATA(6401+7*NMAX/20)),
     & (TI(1),DATA(6401+8*NMAX/20)),(X0(1,1),DATA(6401+9*NMAX/20)),
     & (X1(1,1),DATA(6401+12*NMAX/20)),(INDEX(1),DATA(6401+15*NMAX/20))
      DIMENSION FMIN(100,15),FMAX(100,15)
      EQUIVALENCE (FMIN(1,1),DATA(6401+16*NMAX/20)),
     & (FMAX(1,1),DATA(1500+6401+16*NMAX/20))
      DO I=1,100
      DO J=1,15
        FMIN(I,J)=1E10
        FMAX(I,J)=0
      END DO
      END DO
      WRITE (ILP,1000) ATIME,ADATE,TITLE
 1000 FORMAT ('1'/'0PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A/'0     ',
     &'I    H  K  L         Y       Y/A SIGMA(Y/A)      A SIGMA(A)   TBA
     &R  K0- AND K-VECTOR COMPONENTS PARALLEL TO CRYSTAL AXES'/'      ',
     &'-    -  -  -         -       --- ----------      - --------   ---
     &-')
 1001 FORMAT (' ',I6,2X,3I3,3F10.2,2F8.4,F8.3,2(1X,3F6.3))
C
C LOOP THROUGH DATA SET.
C
      TBAR=0
      AMIN=1E10
      AMAX=0
      SUMN=0
      SUMA=0
      SUMASQ=0
      SUMV=0
      SUMT=0
      SUMTSQ=0
      REWIND IO1
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED')
 1    READ  (IO1,END=9) N,JH,JK,JL
      WRITE (IO2)       N,JH,JK,JL
C
C DECIDE WHETHER OR NOT TO PRINT.
C
      IF ((JH.EQ.0.AND.JK.EQ.0).OR.
     &    (JK.EQ.0.AND.JL.EQ.0).OR.
     &    (JL.EQ.0.AND.JH.EQ.0).OR.
     &    (JH.EQ.0.AND.ABS(JK).EQ.ABS(JL)).OR.
     &    (JK.EQ.0.AND.ABS(JL).EQ.ABS(JH)).OR.
     &    (JL.EQ.0.AND.ABS(JH).EQ.ABS(JK)).OR.
     &    (ABS(JH).EQ.ABS(JK).AND.ABS(JK).EQ.ABS(JL))) THEN
        PRINT=1
      ELSE
        PRINT=0
      END IF
      THETA=ASIN(SINTHL(JH,JK,JL,GINV)*FLAMBDA)
      DO I=1,N
        READ (IO1) JJ,JH,JK,JL,YJ,SIGYJ,JSCALE,ANG
        CALL AXYZ (IDIFF,ANG,X,Y,Z)
        CALL U0U1 (THETA,X,Y,U0,U1)
        CALL FYLM (YLM0,U0,L0MAX,L1MAX)
        CALL FYLM (YLM1,U1,L0MAX,L1MAX)
        A=1
        DO J=1,NPAR
          A=A+ALM(J)*0.5*(YLM0(J)+YLM1(J))
        END DO
C
C LIMIT THE ABSORPTION ANISOTROPY CORRECTION TO THE RANGE OF THE FITTED
C VALUES.
C
        A=MAX(A,AIMIN)
        A=MIN(A,AIMAX)
        V=0
        DO J=1,NPAR
          YLMJ=0.5*(YLM0(J)+YLM1(J))
        DO K=1,NPAR
          YLMK=0.5*(YLM0(K)+YLM1(K))
          V=V+CORR(J,K)*SIGALM(J)*SIGALM(K)*YLMJ*YLMK
        END DO
        END DO
        A0=FA0(ASPH,THETA)
        V0=(ERRMUT*LOG(1/A0))**2
        V=(A0/A)**2*(V0/A0**2+V/A**2)
        SIGA=SQRT(V)
        A=A0/A
        YJ=YJ/A
        SIGYJ=SQRT(SIGYJ**2+YJ**2*V)/A
        IF (FMU.NE.0) TBAR=LOG(1/A)/FMU
        CALL S0S1 (IDIFF,ANG,UB,G,GINV,S0,S1)
        IF (IPATH.NE.0) THEN
          WRITE (IO2) JJ,JH,JK,JL,YJ,SIGYJ,JSCALE,ANG,TBAR,S0,S1
        ELSE
          WRITE (IO2) JJ,JH,JK,JL,YJ,SIGYJ,JSCALE,ANG,(0.0,J=1,7)
        END IF
        CALL TABLEA (JJ,JH,JK,JL,YJ,SIGYJ,A,SIGA,TBAR,S0,S1,FMIN,FMAX)
        IF (A.LT.AMIN) THEN
          AMIN=A
          SIGAMN=SIGA
        END IF
        IF (A.GT.AMAX) THEN
          AMAX=A
          SIGAMX=SIGA
        END IF
        SUMN=SUMN+1
        SUMA=SUMA+A
        SUMASQ=SUMASQ+A**2
        SUMV=SUMV+V
        SUMT=SUMT+TBAR
        SUMTSQ=SUMTSQ+TBAR**2
        IF (PRINT.EQ.1) THEN
          II(I)=JJ
          IH(I)=JH
          IK(I)=JK
          IL(I)=JL
          YI(I)=YJ*A
          SI(I)=SIGYJ
          AI(I)=A
          SA(I)=SIGA
          TI(I)=TBAR
          DO J=1,3
            X0(I,J)=S0(J)
            X1(I,J)=S1(J)
          END DO
        END IF
      END DO
      IF (PRINT.EQ.1) THEN
        IF (N.GE.2) THEN
          CALL SORT (N,YI,INDEX)
        ELSE
          INDEX(1)=1
        END IF
        WRITE (ILP,1001)
        DO I=1,N
          J=INDEX(I)
          IF (II(J).GT.0) WRITE (ILP,1001) II(J),IH(J),IK(J),IL(J),
     &    YI(J),YI(J)/AI(J),SI(J),AI(J),SA(J),TI(J),
     &    (X0(J,K),K=1,3),(X1(J,K),K=1,3)
        END DO
      END IF
      GO TO 1
 9    CLOSE (UNIT=IO1,STATUS='DELETE')
      I=IO1
      IO1=IO2
      IO2=I
C
C PRINT DATA SET ABSORPTION STATISTICS.
C
      WRITE (ILP,1010) ATIME,ADATE,TITLE
      WRITE (ILP,1011)
      WRITE (ILP,1002) (INT(FMIN(I,1)),INT(FMIN(I,2)),INT(FMIN(I,3)),
     & INT(FMIN(I,4)),(FMIN(I,J),J=5,15),I=1,MIN(100,INT(SUMN)))
      WRITE (ILP,1010) ATIME,ADATE,TITLE
      WRITE (ILP,1012)
      WRITE (ILP,1002) (INT(FMAX(I,1)),INT(FMAX(I,2)),INT(FMAX(I,3)),
     & INT(FMAX(I,4)),(FMAX(I,J),J=5,15),I=1,MIN(100,INT(SUMN)))
 1010 FORMAT ('1'/'0PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A)
 1011 FORMAT ('0MEASUREMENTS WITH SMALLEST TRANSMISSION FACTORS, A = FSQ
     &(MEAS)/FSQ(CORR).')
 1012 FORMAT ('0MEASUREMENTS WITH LARGEST TRANSMISSION FACTORS, A = FSQ(
     &MEAS)/FSQ(CORR).')
 1002 FORMAT ('0     I    H  K  L                 Y/A SIGMA(Y/A)      ',
     &'A SIGMA(A)   TBAR  K0- AND K-VECTOR COMPONENTS PARALLEL TO CRYSTA
     &L AXES'/'      -    -  -  -                 --- ----------      ',
     &'- --------   ----'//(' ',I6,2X,3I3,10X,2F10.2,2F8.4,F8.3,2(1X,
     &3F6.3)))
      IF (FMU.NE.0) THEN
        TMAX=-LOG(AMIN)/FMU
        TMIN=-LOG(AMAX)/FMU
        SIGTMX=SIGAMN/(FMU*AMIN)
        SIGTMN=SIGAMX/(FMU*AMAX)
      ELSE
        TMAX=0
        TMIN=0
        SIGTMX=0
        SIGTMN=0
      END IF
      AMEAN=SUMA/SUMN
      RMSDA=SQRT(SUMASQ/SUMN-AMEAN**2)
      RMSSA=SQRT(SUMV/SUMN)
      TMEAN=SUMT/SUMN
      RMSDT=SQRT(ABS(SUMTSQ/SUMN-TMEAN**2))
      WRITE (ILP,1010) ATIME,ADATE,TITLE
      WRITE (ILP,1003) FMU,AMIN,SIGAMN,TMAX,SIGTMX,AMAX,SIGAMX,TMIN,
     & SIGTMN,AMEAN,RMSDA,RMSSA,TMEAN,RMSDT
 1003 FORMAT ('0OVERALL DATA SET STATISTICS ON TRANSMISSION FACTORS, A:'
     &/
     &'0MU                            = ',E10.3,' MM**-1'/
     &'0A(MIN) = EXP (-MU*TBAR(MAX))  = ',E10.3/
     &' SIGMA(A(MIN))                 = ',E10.3/
     &' TBAR(MAX) = -LOG(A(MIN))/MU   = ',E10.3,' MM'/
     &' SIGMA(TBAR(MAX))              = ',E10.3,' MM'/
     &'0A(MAX) = EXP (-MU*TBAR(MIN))  = ',E10.3/
     &' SIGMA(A(MAX))                 = ',E10.3/
     &' TBAR(MIN) = -LOG(A(MAX))/MU   = ',E10.3,' MM'/
     &' SIGMA(TBAR(MIN))              = ',E10.3,' MM'/
     &'0AMEAN                         = ',E10.3/
     &' RMSDA = <(A - AMEAN)**2>**1/2 = ',E10.3/
     &' RMSSA = <SIGMA(A)**2>**1/2    = ',E10.3/
     &' TMEAN = <TBAR>                = ',E10.3,' MM'/
     &' RMSDT = <(T - TMEAN)**2>**1/2 = ',E10.3,' MM')
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE APLOT (IH,IK,IL)
C
C PLOT A PSI-SCAN SECTION THROUGH THE TRANSMISSION SURFACE.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      DIMENSION A(0:359)
      CHARACTER P*2
      DIMENSION P(-25:+25,-25:+25)
      DATA RAD /0.0174533/
      CALL APSI (IH,IK,IL,TWOTH,OMEGA,CHI,PHI,A0,A)
      AMIN=+1E10
      AMAX=-1E10
      DO I=0,359
        AMIN=MIN(AMIN,A(I))
        AMAX=MAX(AMAX,A(I))
      END DO
C
C LIMIT THE ABSORPTION ANISOTROPY CORRECTIONS TO THE RANGE OF THE FITTED
C VALUES.
C
      AMIN=MAX(AMIN,AIMIN)
      AMAX=MIN(AMAX,AIMAX)
C
C EXPRESS THE A'S AS TRANSMISSION FACTORS.
C
      DO I=0,359
        A(I)=A0/A(I)
      END DO
      TMIN=A0/AMAX
      TMAX=A0/AMIN
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1001) IH,IK,IL,TWOTH,OMEGA,CHI,PHI,A0,AMIN,AMAX
 1000 FORMAT ('1'/'0PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A)
 1001 FORMAT ('0PSI-SCAN SECTION THROUGH FITTED TRANSMISSION SURFACE, ',
     &'A = A(H, K, L, PSI).  HAMILTON (1974) DIFFRACTOMETER ANGLES'/
     &'   H  K  L     PSI   TWOTH   OMEGA     CHI     PHI   ASPHERE  ANI
     &SOMIN  ANISOMAX'/1X,3I3,'    0.00',4F8.2,3E10.3)
C
C POLAR PLOT WITH RADIUS 25 PIXELS
C
      SCALEX=25
      SCALEY=25
C
C PRINT PIXELS OF TWO CHARACTERS HORIZONTAL (X) BY ONE CHARACTER
C VERTICAL (Y)
C
      SCALEX=SCALEX/2
C
C TEN CHARACTERS PER HORIZONTAL INCH, AND SIX CHARACTERS PER VERTICAL
C INCH
C
      SCALEX=SCALEX*10/6
C
C CLEAR PRINT PIXEL ARRAY.
C
      DO I=-25,+25
      DO J=-25,+25
        P(I,J)='  '
      END DO
      END DO
C
C X- AND Y-AXES
C
      DO I=-25,+25
        P(I,0)=' .'
        P(0,I)=' .'
      END DO
C
C UNIT CIRCLE 
C
      DO I=0,359
        PSI=I*RAD
        IX=NINT(SCALEX*COS(PSI))
        IY=NINT(SCALEY*SIN(PSI))
        P(IX,IY)=' .'
      END DO
C
C SCALE FACTORS
C
      SCALEX=SCALEX/TMAX
      SCALEY=SCALEY/TMAX
C
C TRANSMISSION FIGURE, A = A(PSI)
C
      DO I=0,359
        IF (TMIN.LE.A(I).AND.A(I).LE.TMAX) THEN
          PSI=I*RAD
          IX=NINT(SCALEX*A(I)*COS(PSI))
          IY=NINT(SCALEY*A(I)*SIN(PSI))
          P(IX,IY)=' *'
        END IF
      END DO
      WRITE (ILP,1002)
      DO IY=+25,-25,-1
        IF (IY.EQ.0) THEN
          WRITE (ILP,1003) (P(IX,IY),IX=-25,+25)
        ELSE
          WRITE (ILP,1004) (P(IX,IY),IX=-25,+25)
        END IF
      END DO
 1002 FORMAT ('0',50X,' PSI = PI/2')
 1003 FORMAT (' ',51A2,' PSI = 0')
 1004 FORMAT (' ',51A2)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE APSI (IH,IK,IL,TWOTH,OMEGA,CHI,PHI,A0,A)
C
C CALCULATE AN AZIMUTH-SCAN SECTION THROUGH THE FITTED TRANSMISSION
C SURFACE.
C
C A = A(0)/(1 + SUM(L=1,LMAX) SUM(M=-L,+L) ALM*(YLM(-U0) + YLM(U1))/2)
C
C WHERE -U0 AND U1 ARE UNIT DIRECTION VECTORS, U = U(PSI), REFERRED TO
C CRYSTAL-FIXED ORTHONORMAL AXES (I.E., DIRECTION COSINES) FOR THE
C REVERSE INCIDENT BEAM AND THE DIFFRACTED BEAM.
C
C R = R(PHI)*R(CHI)*R(OMEGA)*R(PSI) = R0*R(PSI)
C
C      ( X0(1) Y0(1) Z0(1) )
C R0 = ( X0(2) Y0(2) Z0(2) )
C      ( X0(3) Y0(3) Z0(3) )
C
C          ( COS(PSI) 0  SIN(PSI) )
C R(PSI) = (    0     1     0     )
C          (-SIN(PSI) 0  COS(PSI) )
C
C FOR RIGHT-HANDED PSI ROTATION ABOUT DSTAR.
C
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      DIMENSION ANG(4),R0(3,3),RPSI(3,3),R(3,3),U0(3),U1(3),YLM0(80),
     & YLM1(80),A(0:359)
      DATA RPSI /1,0,0,0,1,0,0,0,1/
      DATA RAD /0.0174533/
      CALL SETANG (IH,IK,IL,UB,GINV,FLAMBDA,TWOTH,OMEGA,CHI,PHI)
C
C SPHERICAL TRANSMISSION FACTOR, A0
C
      THETA=0.5*TWOTH*RAD
      A0=FA0(ASPH,THETA)
C
C ANISOTROPY CORRECTION FACTORS, A(I)
C
      ANG(1)=TWOTH
      ANG(2)=OMEGA
      ANG(3)=CHI
      ANG(4)=PHI
      CALL AXYZ (1,ANG,R0(1,1),R0(1,2),R0(1,3))
      DO I=0,359
        PSI=I*RAD
        IF (TWOTH.LT.0) PSI=-PSI
        C=COS(PSI)
        S=SIN(PSI)
        RPSI(1,1)=C
        RPSI(3,3)=C
        RPSI(1,3)=+S
        RPSI(3,1)=-S
        CALL MM (3,R0,RPSI,R)
        CALL U0U1 (THETA,R(1,1),R(1,2),U0,U1)
        CALL FYLM (YLM0,U0,L0MAX,L1MAX)
        CALL FYLM (YLM1,U1,L0MAX,L1MAX)
        A(I)=1
        DO J=1,NPAR
          A(I)=A(I)+ALM(J)*0.5*(YLM0(J)+YLM1(J))
        END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ATABLE (FMU,R,ASPH)
C
C SPHERICAL CRYSTAL TRANSMISSION FACTORS.  W. L. BOND, INTERNATIONAL
C TABLES FOR X-RAY CRYSTALLOGRAPHY, VOL. II, TABLE 5.3.6A, PP. 299-300,
C 1967.
C
      DIMENSION TH(7),FMUR(12),A(7,12),ASPH(7)
      DATA TH /0, 15, 30, 45, 60, 75, 90/
      DATA FMUR /0, 0.5, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10/
C
C A = A(MU*R, THETA)
C
C ACROSS:  THETA = 0, 15, 30, 45, 60, 75, 90 DEGREES
C
C DOWN:    MU*R  = 0, 0.5, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10
C
      DATA A/
     & 1.0,      1.0,      1.0,     1.0,     1.0,     1.0,     1.0,
     & 0.48181,  0.48432,  0.49166, 0.50249, 0.51424, 0.52359, 0.52725,
     & 0.24249,  0.24812,  0.26372, 0.28532, 0.30775, 0.32541, 0.33242,
     & 0.07142,  0.07941,  0.09967, 0.12562, 0.15183, 0.17289, 0.18166,
     & 0.02606,  0.03350,  0.05125, 0.07343, 0.09610, 0.11498, 0.12326,
     & 0.01156,  0.01785,  0.03228, 0.05039, 0.06932, 0.08557, 0.09302,
     & 0.005983, 0.01122,  0.02297, 0.03795, 0.05393, 0.06796, 0.07462,
     & 0.003470, 0.007865, 0.01762, 0.03029, 0.04403, 0.05630, 0.06228,
     & 0.002186, 0.005924, 0.01420, 0.02513, 0.03715, 0.04801, 0.05343,
     & 0.001465, 0.004691, 0.01185, 0.02145, 0.03211, 0.04184, 0.04678,
     & 0.001029, 0.003851, 0.01014, 0.01869, 0.02826, 0.03706, 0.04160,
     & 0.000750, 0.003249, 0.00885, 0.01654, 0.02563, 0.03326, 0.03745/
C
C IF R = 0, THEN FIND R FROM EXPECTED MAXIMUM TRANSMISSION FACTOR.
C
      IF (R.EQ.0) THEN
C
C RETRIEVE TMIN, THE ESTIMATED MINIMUM CRYSTAL THICKNESS, AND AMAX, THE
C MAXIMUM TRANSMISSION ANISOTROPY FACTOR FROM THE FITTED YLM, FROM THE
C ARRAY ASPH.
C
        TMIN=ASPH(1)
        AMAX=ASPH(2)
        IF (TMIN.LE.0.OR.AMAX.LE.0) GO TO 9
        ASPHERE=EXP(-FMU*TMIN)/AMAX
        IF (ASPHERE.GE.1) GO TO 9
C 
C INTERPOLATE ON LOG(A) AT THETA = 0 IN THE BOND TABLE TO FIND MU*R AND
C THE EQUIVALENT SPHERE RADIUS.
C
        IF (ASPHERE.LT.A(1,12)) ASPHERE=A(1,12)
        DO J=2,12
          IF (ASPHERE.GE.A(1,J)) GO TO 1
        END DO
 1      CONTINUE
        X=(LOG(A(1,J))-LOG(ASPHERE))/(LOG(A(1,J))-LOG(A(1,J-1)))
        R=(FMUR(J)-X*(FMUR(J)-FMUR(J-1)))/FMU
      END IF
C
C INTERPOLATE LOG(A) ON MU*R TO OBTAIN TABLE OF A VERSUS THETA.
C
      X=FMU*R
      IF (X.LT.0)  X=0
      IF (X.GT.10) X=10
      DO J=2,12
        IF (X.LE.FMUR(J)) GO TO 2
      END DO
 2    CONTINUE
      X=(FMUR(J)-X)/(FMUR(J)-FMUR(J-1))
      DO I=1,7
        ASPH(I)=EXP(LOG(A(I,J))-X*(LOG(A(I,J))-LOG(A(I,J-1))))
      END DO
      RETURN
 9    CONTINUE
C
C FOR ERROR CONDITIONS, RETURN MU = 0 AND A = 1.
C
      FMU=0
      DO I=1,7
        ASPH(I)=1
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE AXYZ (IDIFF,ANGLES,X,Y,Z)
C
C GET THE COMPONENTS ALONG CRYSTAL-FIXED CARTESIAN AXES OF UNIT VECTORS:
C
C   Z, NORMAL TO THE EQUATORIAL PLANE OF THE INCIDENT AND DIFFRACTED
C   BEAM VECTORS;
C
C   Y, PARALLEL TO THE RECIPROCAL LATTICE VECTOR, DSTAR, IN THE
C   DIFFRACTING CONDITION; AND 
C
C   X = Z "CROSS" Y.
C
C THESE UNIT VECTORS X, Y, AND Z ARE THE COLUMNS OF THE ROTATION MATRIX,
C
C                                ( X1 Y1 Z1 )
C   R = R(PHI)*R(CHI)*R(OMEGA) = ( X2 Y2 Z2 ),
C                                ( X3 Y3 Z3 )
C
C FOR AXES AS DEFINED BY WALTER HAMILTON, INTERNATIONAL TABLES FOR X-RAY
C CRYSTALLOGRAPHY, VOL. IV, 1974, PP. 273-284.
C
      DIMENSION ANGLES(4),X(3),Y(3),Z(3)
      DATA RAD /0.0174533/
      CALL GEOM (IDIFF,ANGLES,TWOTH,OMEGA,CHI,PHI)
      COSPH=COS(PHI*RAD)
      SINPH=SIN(PHI*RAD)
      COSCH=COS(CHI*RAD)
      SINCH=SIN(CHI*RAD)
      COSOM=COS(OMEGA*RAD)
      SINOM=SIN(OMEGA*RAD)
      X(1)= COSPH*COSOM-SINPH*SINOM*COSCH
      X(2)=-SINPH*COSOM-COSPH*SINOM*COSCH
      X(3)= SINCH*SINOM
      Y(1)= COSPH*SINOM+SINPH*COSCH*COSOM
      Y(2)=-SINPH*SINOM+COSPH*COSCH*COSOM
      Y(3)=-SINCH*COSOM
      Z(1)= SINPH*SINCH
      Z(2)= COSPH*SINCH
      Z(3)= COSCH
      IF (TWOTH.LT.0) THEN
        Y(1)=-Y(1)
        Y(2)=-Y(2)
        Y(3)=-Y(3)
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
      FUNCTION FA0(A,T)
C
C LINEAR INTERPOLATION OF A = A(THETA) ON SIN(THETA)**2
C
      DIMENSION A(7),SINSQ(7)
C
C SIN(THETA)**2 FOR THETA = 0, 15, 30, 45, 60, 75, 90 DEGREES
C
      DATA SINSQ /0, 0.0669873, 0.25, 0.5, 0.75, 0.933013, 1/
      X=SIN(T)**2
      DO I=2,6
        IF (X.LE.SINSQ(I)) GO TO 1
      END DO
      I=7
 1    CONTINUE
      X=(SINSQ(I)-X)/(SINSQ(I)-SINSQ(I-1))
      FA0=A(I)-X*(A(I)-A(I-1))
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE FYLM (YLM,XYZ,L0MAX,L1MAX)
C
C UN-NORMALIZED REAL SPHERICAL HARMONIC FUNCTIONS
C
C A. PATURLE AND P. COPPENS (1988).  ACTA CRYST. A44, 6-7.
C
      DIMENSION XYZ(3),YLM(80)
      DO I=1,80
        YLM(I)=0
      END DO
C
C MONOPOLE:  L = M = 0.
C
      IF (L0MAX.EQ.0.AND.L1MAX.EQ.0) RETURN
      X=XYZ(1)
      Y=XYZ(2)
      Z=XYZ(3)
C
C DIPOLES:  L = 1; M = 0, +1, -1.
C
      IF (L1MAX.GE.1) THEN
        YLM(1)=Z
        YLM(2)=X
        YLM(3)=Y
      END IF
C
C QUADRUPOLES:  L = 2; M = 0, +1, -1, +2, -2.
C
      IF (L0MAX.GE.2) THEN
        YLM(4)=3*Z**2-1
        YLM(5)=Z*X
        YLM(6)=Z*Y
        YLM(7)=X**2-Y**2
        YLM(8)=2*X*Y
      END IF
C
C OCTUPOLES:  L = 3; M = 0, +1, -1, +2, -2, +3, -3.
C
      IF (L1MAX.GE.3) THEN
        YLM(9)=5*Z**3-3*Z
        YLM(10)=(5*Z**2-1)*X
        YLM(11)=(5*Z**2-1)*Y
        YLM(12)=Z*(X**2-Y**2)
        YLM(13)=2*X*Y*Z
        YLM(14)=X**3-3*X*Y**2
        YLM(15)=3*X**2*Y-Y**3
      END IF
C
C HEXADECAPOLES:  L = 4; M = 0, +1, -1, +2, -2, +3, -3, +4, -4.
C
      IF (L0MAX.GE.4) THEN
        YLM(16)=35*Z**4-30*Z**2+3
        YLM(17)=(7*Z**3-3*Z)*X
        YLM(18)=(7*Z**3-3*Z)*Y
        YLM(19)=(7*Z**2-1)*(X**2-Y**2)
        YLM(20)=2*X*Y*(7*Z**2-1)
        YLM(21)=Z*(X**3-3*X*Y**2)
        YLM(22)=Z*(3*X**2*Y-Y**3)
        YLM(23)=X**4-6*X**2*Y**2+Y**4
        YLM(24)=4*X**3*Y-4*X*Y**3
      END IF
C
C 2**5 = 32-POLES:  L = 5; M = 0, +1, -1, +2, -2,..., +5, -5.
C
      IF (L1MAX.GE.5) THEN
        YLM(25)=63*Z**5-70*Z**3+15*Z
        YLM(26)=(21*Z**4-14*Z**2+1)*X
        YLM(27)=(21*Z**4-14*Z**2+1)*Y
        YLM(28)=(3*Z**3-Z)*(X**2-Y**2)
        YLM(29)=2*X*Y*(3*Z**3-Z)
        YLM(30)=(9*Z**2-1)*(X**3-3*X*Y**2)
        YLM(31)=(9*Z**2-1)*(3*X**2*Y-Y**3)
        YLM(32)=Z*(X**4-6*X**2*Y**2+Y**4)
        YLM(33)=Z*(4*X**3*Y-4*X*Y**3)
        YLM(34)=X**5-10*X**3*Y**2+5*X*Y**4
        YLM(35)=5*X**4*Y-10*X**2*Y**3+Y**5
      END IF
C
C 2**6 = 64-POLES:  L = 6; M = 0, +1, -1, +2, -2,..., +6, -6.
C
      IF (L0MAX.GE.6) THEN
        YLM(36)=231*Z**6-315*Z**4+105*Z**2-5
        YLM(37)=(33*Z**5-30*Z**3+5*Z)*X
        YLM(38)=(33*Z**5-30*Z**3+5*Z)*Y
        YLM(39)=(33*Z**4-18*Z**2+1)*(X**2-Y**2)
        YLM(40)=2*X*Y*(33*Z**4-18*Z**2+1)
        YLM(41)=(11*Z**3-3*Z)*(X**3-3*X*Y**2)
        YLM(42)=(11*Z**3-3*Z)*(3*X**2*Y-Y**3)
        YLM(43)=(11*Z**2-1)*(X**4-6*X**2*Y**2+Y**4)
        YLM(44)=(11*Z**2-1)*(4*X**3*Y-4*X*Y**3)
        YLM(45)=Z*(X**5-10*X**3*Y**2+5*X*Y**4)
        YLM(46)=Z*(5*X**4*Y-10*X**2*Y**3+Y**5)
        YLM(47)=X**6-15*X**4*Y**2+15*X**2*Y**4-Y**6
        YLM(48)=6*X**5*Y-20*X**3*Y**3+6*X*Y**5
      END IF
C
C 2**7 = 128-POLES:  L = 7; M = 0, +1, -1, +2, -2,..., +7, -7.
C
      IF (L1MAX.GE.7) THEN
        YLM(49)=429*Z**7-639*Z**5+315*Z**3-35*Z
        YLM(50)=(429*Z**6-495*Z**4+135*Z**2-5)*X
        YLM(51)=(429*Z**6-495*Z**4+135*Z**2-5)*Y
        YLM(52)=(143*Z**5-110*Z**3+15*Z)*(X**2-Y**2)
        YLM(53)=2*X*Y*(143*Z**5-110*Z**3+15*Z)
        YLM(54)=(143*Z**4-66*Z**2+3)*(X**3-3*X*Y**2)
        YLM(55)=(143*Z**4-66*Z**2+3)*(3*X**2*Y-Y**3)
        YLM(56)=(13*Z**3-3*Z)*(X**4-6*X**2*Y**2+Y**4)
        YLM(57)=(13*Z**3-3*Z)*(4*X**3*Y-4*X*Y**3)
        YLM(58)=(13*Z**2-1)*(X**5-10*X**3*Y**2+5*X*Y**4)
        YLM(59)=(13*Z**2-1)*(5*X**4*Y-10*X**2*Y**3+Y**5)
        YLM(60)=Z*(X**6-15*X**4*Y**2+15*X**2*Y**4-Y**6)
        YLM(61)=Z*(6*X**5*Y-20*X**3*Y**3+6*X*Y**5)
        YLM(62)=X**7-21*X**5*Y**2+35*X**3*Y**4-7*X*Y**6
        YLM(63)=7*X**6*Y-35*X**4*Y**3+21*X**2*Y**5-Y**7
      END IF
C
C 2**8 = 256-POLES:  L = 8; M = 0, +1, -1, +2, -2,..., +8, -8.
C
      IF (L0MAX.GE.8) THEN
        YLM(64)=6435*Z**8-12012*Z**6+6930*Z**4-1260*Z**2+35
        YLM(65)=(715*Z**7-1001*Z**5+385*Z**3-35*Z)*X
        YLM(66)=(715*Z**7-1001*Z**5+385*Z**3-35*Z)*Y
        YLM(67)=(143*Z**6-143*Z**4+33*Z**2-1)*(X**2-Y**2)
        YLM(68)=2*X*Y*(143*Z**6-143*Z**4+33*Z**2-1)
        YLM(69)=(39*Z**5-26*Z**3+3*Z)*(X**3-3*X*Y**2)
        YLM(70)=(39*Z**5-26*Z**3+3*Z)*(3*X**2*Y-Y**3)
        YLM(71)=(65*Z**4-26*Z**2+1)*(X**4-6*X**2*Y**2+Y**4)
        YLM(72)=(65*Z**4-26*Z**2+1)*(4*X**3*Y-4*X*Y**3)
        YLM(73)=(5*Z**3-Z)*(X**5-10*X**3*Y**2+5*X*Y**4)
        YLM(74)=(5*Z**3-Z)*(5*X**4*Y-10*X**2*Y**3+Y**5)
        YLM(75)=(15*Z**2-1)*(X**6-15*X**4*Y**2+15*X**2*Y**4-Y**6)
        YLM(76)=(15*Z**2-1)*(6*X**5*Y-20*X**3*Y**3+6*X*Y**5)
        YLM(77)=Z*(X**7-21*X**5*Y**2+35*X**3*Y**4-7*X*Y**6)
        YLM(78)=Z*(7*X**6*Y-35*X**4*Y**3+21*X**2*Y**5-Y**7)
        YLM(79)=X**8-28*X**6*Y**2+70*X**4*Y**4-28*X**2*Y**6+Y**8
        YLM(80)=8*X**7*Y-56*X**5*Y**3+56*X**3*Y**5-8*X*Y**7
      END IF
      CALL NCYLM (YLM,L0MAX,L1MAX,1)
      CALL YPICK (YLM,L0MAX,L1MAX,N)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE NCYLM (YLM,L0MAX,L1MAX,INORM)
C
C SCALE AND NORMALIZATION FACTORS FOR REAL SPHERICAL HARMONIC FUNCTIONS
C
C C(L,ABS(M)), N(L,ABS(M)); L=0,1,2,...,LMAX; ABS(M)=0,1,2,...,L.
C
C THE C(L,ABS(M)) SCALE THE CARTESIAN YLM(X,Y,Z) TO GIVE THE ASSOCIATED
C LEGENDRE FUNCTIONS P(L,M)(COS(THETA))*COS,SIN(M*PHI).
C
C THE N(L,ABS(M)) NORMALIZE TO 2 - DELTA(0,L).
C
C A. PATURLE AND P. COPPENS (1988).  ACTA CRYST. A44, 6-7.
C
      DIMENSION YLM(1),FCLM(0:44),FNLM(0:44)
      DATA FCLM /
     & 1,
     & 1, 1,
     & 0.5, 3, 3,
     & 0.5, 1.5, 15, 15,
     & 0.125, 2.5, 7.5, 105, 105,
     & 0.125, 1.875, 52.5, 52.5, 945, 945,
     & 0.0625, 2.625, 13.125, 157.5, 472.5, 10395, 10395,
     & 0.0625, 0.4375, 7.875, 39.375, 1732.5, 5197.5, 135135, 135135,
     & 0.0078125, 0.5625, 19.6875, 433.125, 1299.375, 67567.5, 67567.5,
     & 2027025, 2027025/
      DATA FNLM /
     & 0.0795774,
     & 0.3183099, 0.3183099,
     & 0.2067483, 0.7500000, 0.3750000,
     & 0.2448538, 0.3203331, 1.0000000, 0.4244132,
     & 0.0694175, 0.4740025, 0.3305913, 1.2500000, 0.4687500,
     & 0.0767395, 0.3229812, 1.6875000, 0.3451455, 1.5000000, 0.5092958,
     & 0.0417084, 0.4172129, 0.3261107, 0.6513219, 0.3610405, 1.7500000,
     & 0.5468750,
     & 0.0447979, 0.0648780, 0.1573192, 0.1109240, 0.7404370, 0.3772319,
     & 2.0000000, 0.5820523,
     & 0.0059609, 0.0784858, 0.3253786, 0.8780415, 0.3411683, 2.4892756,
     & 0.3933012, 2.2500000, 0.6152344/
      I=0
      J=0
      DO L=1,MAX(L0MAX,L1MAX)
      DO M=0,L
        I=I+1
        F=FCLM(I)
        IF (INORM.NE.0) F=F*FNLM(I)
        DO P=0,MIN(M,1)
          J=J+1
          YLM(J)=F*YLM(J)
        END DO
      END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE YPICK (YLM,L0MAX,L1MAX,N)
      DIMENSION YLM(1)
      I=0
      N=0
      DO L=1,MAX(L0MAX,L1MAX)
      DO M=-L,+L
        I=I+1
        IF ((MOD(L,2).EQ.0.AND.L.LE.L0MAX).OR.
     &      (MOD(L,2).EQ.1.AND.L.LE.L1MAX)) THEN
          N=N+1
          YLM(N)=YLM(I)
        END IF
      END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE GEOM (IDIFF,ANGLES,TWOTH,OMEGA,CHI,PHI)
C
C     DIFFRACTOMETER GEOMETRIES
C
      DIMENSION ANGLES(4)
      REAL KAPPA
C
C     KAPPA AXIS INCLINATION ANGLE
C
C     ALPHA = PI/3.6 = 50 DEGREES
C
      DATA SINA, COSA /0.766044, 0.642788/
      DATA DEG, RAD /57.2957795, 0.017453293/
      GO TO (1, 2, 3, 4) IDIFF
    1 CONTINUE
C
C     IDIFF = 1  HAMILTON'S DIFFRACTOMETER AXES
C
C     WALTER C. HAMILTON (1974).  INTERNATIONAL TABLES FOR X-RAY
C     CRYSTALLOGRAPHY, VOL. IV, PP. 273-284.
C
      TWOTH = ANGLES(1)
      OMEGA = ANGLES(2)
      CHI   = ANGLES(3)
      PHI   = ANGLES(4)
      GO TO 9
    2 CONTINUE
C
C     IDIFF = 2  BUSING'S AND LEVY'S DIFFRACTOMETER AXES
C
C     W. R. BUSING AND H. A. LEVY (1967).  ACTA CRYST. 22, 457-464.
C
      TWOTH = ANGLES(1)
      OMEGA = ANGLES(2)
      CHI   = ANGLES(3)
      PHI   = ANGLES(4)
C
C     TRANSFORM TO SETTING ANGLES AS DEFINED BY HAMILTON.
C
      OMEGA = -OMEGA
      CHI   = -CHI
      PHI   = -PHI
      GO TO 9
    3 CONTINUE
C
C     IDIFF = 3  SIEMENS (NEE NICOLET, NEE SYNTEX) P3 DIFFRACTOMETER
C
      TWOTH = ANGLES(1)
      OMEGA = ANGLES(2)
      PHI   = ANGLES(3)
      CHI   = ANGLES(4)
C
C     TRANSFORM TO SETTING ANGLES AS DEFINED BY HAMILTON.
C
      THETA =  TWOTH/2
      OMEGA =  OMEGA - THETA
      OMEGA = -OMEGA
      GO TO 9
    4 CONTINUE
C
C     IDIFF = 4  ENRAF-NONIUS CAD4 DIFFRACTOMETER KAPPA ANGLES
C
      THETA = ANGLES(1)
      PHI   = ANGLES(2)
      OMEGA = ANGLES(3)
      KAPPA = ANGLES(4)
C
C     TRANSFORM FROM KAPPA TO EULERIAN SETTING ANGLES.
C
      KAPPA = KAPPA*RAD
      SINX  = SINA*SIN(KAPPA/2)
      COSX  = SQRT(COSA**2 + SINA**2*COS(KAPPA/2)**2)
      CHI   = 2*ARCTAN(SINX,COSX)
C
C     KAPPA IS MECHANICALLY LIMITED TO THE RANGE 0 TO 180 DEGREES.  WITH
C     ALPHA = 50 DEGREES, THIS LIMITS CHI TO THE RANGE -100 TO +100
C     DEGREES.
C
      SINX  = COSA*SIN(KAPPA/2)/COS(CHI/2)
      COSX  = COS(KAPPA/2)/COS(CHI/2)
      DELTA = ARCTAN(SINX,COSX)*DEG
      OMEGA = OMEGA + DELTA
      PHI   = PHI   + DELTA
      CHI   = CHI*DEG
C
C     TRANSFORM TO SETTING ANGLES AS DEFINED BY HAMILTON.
C
      TWOTH =  2*THETA
      OMEGA =  OMEGA - THETA
      OMEGA = -OMEGA
      CHI   = -CHI
      PHI   = -PHI
    9 CONTINUE
C
C     RETURN ANGLES -180 .LE. A .LE. +180.
C
      TWOTH = A180(TWOTH)
      OMEGA = A180(OMEGA)
      PHI   = A180(PHI)
      CHI   = A180(CHI)
      RETURN
      END
C-----------------------------------------------------------------------
      FUNCTION ARCTAN(SINX,COSX)
      IF (SINX.LT.-1) SINX=-1
      IF (SINX.GT.+1) SINX=+1
      IF (COSX.LT.-1) COSX=-1
      IF (COSX.GT.+1) COSX=+1
      ARCTAN=ATAN2(SINX,COSX)
      RETURN
      END
C-----------------------------------------------------------------------
      FUNCTION A180(A)
      A=MOD(A,360.0)
      IF (A.LE.-180) A=A+360
      IF (A.GT.+180) A=A-360
      A180=A
      RETURN
      END
C-----------------------------------------------------------------------
      FUNCTION A360(A)
      A=MOD(A,360.0)
      IF (A.LT.0) A=A+360
      A360=A
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE MM (N,A,B,C)
C
C SQUARE MATRIX-MATRIX MULTIPLICATION
C
C A(I,K)*B(K,J) = C(I,J)
C
      DIMENSION A(N,N),B(N,N),C(N,N)
      DO I=1,N
      DO J=1,N
        C(I,J)=0
      DO K=1,N
        C(I,J)=C(I,J)+A(I,K)*B(K,J)
      END DO
      END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE MMD (N,M,A,B,C)
C
C SQUARE MATRIX-MATRIX MULTIPLICATION IN DOUBLE PRECISION
C
C A(I,K)*B(K,J) = C(I,J)
C
      DIMENSION A(M,M),B(M,M),C(M,M)
      DOUBLE PRECISION A,B,C
      DO I=1,N
      DO J=1,N
        C(I,J)=0
      DO K=1,N
        C(I,J)=C(I,J)+A(I,K)*B(K,J)
      END DO
      END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE MV (N,A,B,C)
C
C SQUARE MATRIX-COLUMN VECTOR MULTIPLICATION
C
C A(I,J)*B(J) = C(I)
C
      DIMENSION A(N,N),B(N),C(N)
      DO I=1,N
        C(I)=0
      DO J=1,N
        C(I)=C(I)+A(I,J)*B(J)
      END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE MVD (N,A,B,C)
C
C SQUARE MATRIX-COLUMN VECTOR MULTIPLICATION IN DOUBLE PRECISION
C
C A(I,J)*B(J) = C(I)
C
      DIMENSION A(N,N),B(N),C(N)
      DOUBLE PRECISION A,B,C
      DO I=1,N
        C(I)=0
      DO J=1,N
        C(I)=C(I)+A(I,J)*B(J)
      END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE NORM (X,G)
C
C NORMALIZE VECTOR X REFERRED TO AXES WITH METRIC G.
C
      DIMENSION X(3),G(3,3)
      Q=0
      DO I=1,3
      DO J=1,3
        Q=Q+X(I)*G(I,J)*X(J)
      END DO
      END DO
      Q=SQRT(Q)
      DO I=1,3
        X(I)=X(I)*SQRT(G(I,I))/Q
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE S0S1 (IDIFF,ANG,U,G,GINV,S0,S1)
C
C COMPONENTS ALONG DIMENSIONLESS UNIT AXES PARALLEL TO THE A,B,C CRYSTAL
C AXES OF DIRECTION VECTORS S0 FOR THE INCIDENT BEAM AND S1 FOR THE
C DIFFRACTED BEAM
C
      DIMENSION ANG(4),S0(3),S1(3),U(3,3),R(3,3),G(3,3),UR(3,3),
     & URG(3,3),H(3),GINV(3,3)
      DATA RAD /0.0174533/
      CALL AXYZ (IDIFF,ANG,R(1,1),R(1,2),R(1,3))
      CALL MM (3,U,R,UR)
      CALL MM (3,UR,G,URG)
      CALL GEOM (IDIFF,ANG,TWOTH,OMEGA,CHI,PHI)
      THETA=0.5*TWOTH*RAD
      C=COS(THETA)
      S=SIN(THETA)
      S0(1)=-C
      S0(2)=-S
      S0(3)=0
      CALL MV (3,URG,S0,H)
      CALL MV (3,GINV,H,S0)
      CALL NORM (S0,G)
      S1(1)=-C
      S1(2)=+S
      S1(3)=0
      CALL MV (3,URG,S1,H)
      CALL MV (3,GINV,H,S1)
      CALL NORM (S1,G)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE SETANG (IH,IK,IL,U,GINV,FLAMBDA,TWOTH,OMEGA,CHI,PHI)
C
C SETTING ANGLES FOR HAMILTON (1974) INTERNATIONAL TABLES DIFFRACTOMETER
C AXES IN BISECTING POSITION, PSI = OMEGA = 0, AT POSITIVE TWO-THETA
C
      DIMENSION H(3),U(3,3),Y(3),GINV(3,3)
      DATA PI,DEG /3.141593, 57.29578/
      H(1)=IH
      H(2)=IK
      H(3)=IL
      CALL VM (3,H,U,Y)
      DSTAR=2*SINTHL(IH,IK,IL,GINV)
      DO I=1,3
        Y(I)=Y(I)/DSTAR
        IF (Y(I).LT.-1) Y(I)=-1
        IF (Y(I).GT.+1) Y(I)=+1
      END DO
      TWOTH=2*ASIN(0.5*DSTAR*FLAMBDA)
      OMEGA=0
      CHI=ASIN(-Y(3))
C
C CHOOSE CHI IN THE INTERVAL -PI/2 .LE. CHI .LE. + PI/2.
C
      CHI=MOD(CHI,2*PI)
      IF (CHI.LT.-PI) CHI=CHI+2*PI
      IF (CHI.GT.+PI) CHI=CHI-2*PI
      IF (CHI.LT.-PI/2) CHI=-PI-CHI
      IF (CHI.GT.+PI/2) CHI=+PI-CHI
      COSCHI=COS(CHI)
      COSPHI=Y(2)/COSCHI
      SINPHI=Y(1)/COSCHI
      PHI=ATAN2(SINPHI,COSPHI)
      TWOTH=TWOTH*DEG
      OMEGA=OMEGA*DEG
      PHI=PHI*DEG
      CHI=CHI*DEG
      TWOTH=A180(TWOTH)
      OMEGA=A180(OMEGA)
      PHI=A180(PHI)
      CHI=A180(CHI)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE TABLEA (JJ,JH,JK,JL,Y,SIGY,A,SIGA,TBAR,U0,U1,AMIN,AMAX)
      DIMENSION U0(3),U1(3),AMIN(100,15),AMAX(100,15)
      DATA N,J /100, 7/
      IF (A.LE.AMIN(N,J)) THEN
        DO I=1,N
          IF (A.LE.AMIN(I,J)) GO TO 1
        END DO
 1      CALL TABLEB (I,JJ,JH,JK,JL,Y,SIGY,A,SIGA,TBAR,U0,U1,AMIN)
      END IF
      IF (A.GE.AMAX(N,J)) THEN
        DO I=1,N
          IF (A.GE.AMAX(I,J)) GO TO 2
        END DO
 2      CALL TABLEB (I,JJ,JH,JK,JL,Y,SIGY,A,SIGA,TBAR,U0,U1,AMAX)
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE TABLEB (I,JJ,JH,JK,JL,Y,SIGY,A,SIGA,TBAR,U0,U1,TABLE)
      DIMENSION U0(3),U1(3),TABLE(100,15)
      DATA N /100/
      IF (I.LT.N) THEN
        DO J=N,I+1,-1
        DO K=1,15
          TABLE(J,K)=TABLE(J-1,K)
        END DO
        END DO
      END IF
      TABLE(I,1)=JJ
      TABLE(I,2)=JH
      TABLE(I,3)=JK
      TABLE(I,4)=JL
      TABLE(I,5)=Y
      TABLE(I,6)=SIGY
      TABLE(I,7)=A
      TABLE(I,8)=SIGA
      TABLE(I,9)=TBAR
      TABLE(I,10)=U0(1)
      TABLE(I,11)=U0(2)
      TABLE(I,12)=U0(3)
      TABLE(I,13)=U1(1)
      TABLE(I,14)=U1(2)
      TABLE(I,15)=U1(3)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE U0U1 (THETA,X,Y,U0,U1)
C
C COMPONENTS ALONG CRYSTAL-FIXED ORTHONORMAL AXES OF DIRECTION VECTORS
C U0 FOR THE INCIDENT BEAM AND U1 FOR THE DIFFRACTED BEAM FROM DSTAR AND
C ITS NORMAL IN THE EQUATORIAL PLANE
C
C P. COPPENS, L. LEISEROWITZ, AND D. RABINOVICH (1965).  ACTA CRYST. 18,
C 1035-1038.
C
C U1 + U0 = T        U1 = (T + D)/2
C U1 - U0 = D        U0 = (T - D)/2
C
C ABS(U0) = ABS(U1) = 1/LAMBDA
C
C ABS(D) = 2*SIN(THETA)/LAMBDA        D = +Y*ABS(D)
C ABS(T) = 2*COS(THETA)/LAMBDA        T = -X*ABS(T)
C
C FOR DIFFRACTOMETER X- AND Y-AXES AS DEFINED BY W. HAMILTON (1974).
C INT. TAB., VOL. IV.
C
      DIMENSION X(3),Y(3),U0(3),U1(3)
      C=COS(THETA)
      S=SIN(THETA)
      DO I=1,3
        T=-X(I)*C
        D=+Y(I)*S
        U0(I)=T-D
        U1(I)=T+D
      END DO
C
C RETURN REVERSE INCIDENT BEAM DIRECTION.
C        -------
C
      U0(1)=-U0(1)
      U0(2)=-U0(2)
      U0(3)=-U0(3)
      RETURN
      END      
C-----------------------------------------------------------------------
      SUBROUTINE VM (N,A,B,C)
C
C ROW VECTOR-SQUARE MATRIX MULTIPLICATION
C
C A(I)*B(I,J) = C(J)
C
      DIMENSION A(N),B(N,N),C(N)
      DO J=1,N
        C(J)=0
      DO I=1,N
        C(J)=C(J)+A(I)*B(I,J)
      END DO
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ANOVA
C
C BIVARIATE ANALYSIS OF VARIANCE
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,IPRINT,JPRINT,JPATH,
     & QLIMIT,ZLIMIT,QPRINT
      DIMENSION INDEX(NMAX/2)
      EQUIVALENCE (INDEX(1),DATA(1+NMAX/2))
      DIMENSION YMAXI(15),SMAXJ(10)
      DIMENSION QIJ(15,10),WIJ(15,10),EIJ(15,10),YIJ(15,10),SIJ(15,10),
     & NIJ(15,10)
      DIMENSION QI(15),WI(15),EI(15),YI(15),SI(15),NI(15)
      DIMENSION QJ(10),WJ(10),EJ(10),YJ(10),SJ(10),NJ(10)
      DIMENSION X(6),AA(6,6),BB(6)
      DOUBLE PRECISION AA
      DATA QIJ,WIJ,EIJ,YIJ,SIJ,NIJ,QI,WI,EI,YI,SI,NI,QJ,WJ,EJ,YJ,SJ,NJ
     & /1050*0/
      DATA AA,BB /42*0/
      DIMENSION U0(3),U1(3)
      DATA TBAR,U0,U1 /7*0/
C
C PREPARE SCRATCH FILES IO2 AND IO3 SORTED ON DECREASING Y AND
C INCREASING S, RESPECTIVELY.
C
      CALL YSSORT (NTOTAL)
C
C SET UP Y-INTERVALS (AT MOST 15) WITH AN EQUAL NUMBER OF DATA (AT LEAST
C 50) PER INTERVAL.
C
      NYINT=NTOTAL/50+1
      NYINT=MIN(NYINT,15)
      NLOCAL=NTOTAL/NYINT+1
      REWIND IO2
      DO 11 I=1,NYINT
        YMAXI(I)=0
      DO 11 N=1,NLOCAL
        READ (IO2,END=91) S,Y
        YMAXI(I)=MAX(YMAXI(I),Y)
   11 CONTINUE
   91 CONTINUE
C
C SET UP S-INTERVALS (AT MOST 10) WITH AN EQUAL NUMBER OF DATA (AT LEAST
C 50) PER INTERVAL.
C
      NSINT=NTOTAL/50+1
      NSINT=MIN(NSINT,10)
      NLOCAL=NTOTAL/NSINT+1
      REWIND IO3
      DO 12 J=1,NSINT
        SMAXJ(J)=0
      DO 12 N=1,NLOCAL
        READ (IO3,END=92) S
        SMAXJ(J)=MAX(SMAXJ(J),S)
   12 CONTINUE
   92 CONTINUE
C
C SET UP TABLE FUNCTION Q(Y, S) = RMSD/ESD
C
      YMIN0=+1E9
      YMAX0=-1E9
      SMIN0=+1E9
      SMAX0=-1E9
      YMIN1=+1E9
      YMAX1=-1E9
      SMIN1=+1E9
      SMAX1=-1E9
      Y0=0
      S0=0
      Q0=0
      N=0
      SUMW=0
      REWIND IO2
      DO 10 M=1,NTOTAL
        READ (IO2) S,Y,ESD,RMSD,NMEAS
        YMIN0=MIN(YMIN0,Y)
        YMAX0=MAX(YMAX0,Y)
        SMIN0=MIN(SMIN0,S)
        SMAX0=MAX(SMAX0,S)
        IF (NMEAS.LT.2.OR.ESD.LE.0.OR.RMSD.LE.0) GO TO 10
        YMIN1=MIN(YMIN1,Y)
        YMAX1=MAX(YMAX1,Y)
        SMIN1=MIN(SMIN1,S)
        SMAX1=MAX(SMAX1,S)
        N=N+1
        W=NMEAS-1
        SUMW=SUMW+W
        Q=RMSD/ESD
        Q=W*Q
        Q0=Q0+Q
        Y0=Y0+Y
        S0=S0+S
        E=ESD
        DO 21 I=NYINT,1,-1
          IF (Y.LE.YMAXI(I)) GO TO 31
   21   CONTINUE
   31   DO 22 J=1,NSINT,+1
          IF (S.LE.SMAXJ(J)) GO TO 32
   22   CONTINUE
   32   QIJ(I,J)=QIJ(I,J)+Q
        WIJ(I,J)=WIJ(I,J)+W
        EIJ(I,J)=EIJ(I,J)+E
        YIJ(I,J)=YIJ(I,J)+Y
        SIJ(I,J)=SIJ(I,J)+S
        NIJ(I,J)=NIJ(I,J)+1
        QI(I)=QI(I)+Q
        WI(I)=WI(I)+W
        EI(I)=EI(I)+E
        YI(I)=YI(I)+Y
        SI(I)=SI(I)+S
        NI(I)=NI(I)+1
        QJ(J)=QJ(J)+Q
        WJ(J)=WJ(J)+W
        EJ(J)=EJ(J)+E
        YJ(J)=YJ(J)+Y
        SJ(J)=SJ(J)+S
        NJ(J)=NJ(J)+1
   10 CONTINUE
      IF (N.EQ.0) RETURN
      Y0=Y0/N
      S0=S0/N
      Q0=Q0/SUMW
      DO 50 I=1,NYINT
      DO 50 J=1,NSINT
        IF (NIJ(I,J).EQ.0) GO TO 50
        QIJ(I,J)=QIJ(I,J)/WIJ(I,J)
        EIJ(I,J)=EIJ(I,J)/NIJ(I,J)
        YIJ(I,J)=YIJ(I,J)/NIJ(I,J)
        SIJ(I,J)=SIJ(I,J)/NIJ(I,J)
   50 CONTINUE
      DO 51 I=1,NYINT
        IF (NI(I).EQ.0) GO TO 51
        QI(I)=QI(I)/WI(I)
        EI(I)=EI(I)/NI(I)
        YI(I)=YI(I)/NI(I)
        SI(I)=SI(I)/NI(I)
   51 CONTINUE
      DO 52 J=1,NSINT
        IF (NJ(J).EQ.0) GO TO 52
        QJ(J)=QJ(J)/WJ(J)
        EJ(J)=EJ(J)/NJ(J)
        YJ(J)=YJ(J)/NJ(J)
        SJ(J)=SJ(J)/NJ(J)
   52 CONTINUE
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1001) (SMAXJ(J),J=1,10)
      DO 55 I=1,15
        WRITE (ILP,1002) YMAXI(I),(QIJ(I,J),J=1,10),QI(I)
        WRITE (ILP,1003)          (EIJ(I,J),J=1,10),EI(I)
        WRITE (ILP,1004)          (YIJ(I,J),J=1,10),YI(I)
        WRITE (ILP,1005)          (SIJ(I,J),J=1,10),SI(I)
        WRITE (ILP,1006)          (NIJ(I,J),J=1,10),NI(I)
   55 CONTINUE
      WRITE (ILP,1007) (QJ(J),J=1,10)
      WRITE (ILP,1008) (EJ(J),J=1,10)
      WRITE (ILP,1009) (YJ(J),J=1,10)
      WRITE (ILP,1010) (SJ(J),J=1,10)
      WRITE (ILP,1011) (NJ(J),J=1,10)
 1000 FORMAT ('1'/'0PROGRAM SORTAV/ANOVA.  ',A,1X,A,'.  ',A)
 1001 FORMAT ('0BIVARIATE ANALYSIS OF VARIANCE TABLE.  Q = Q(Y, S)'/'0TA
     &BLE ENTRIES LIST:'/'0  <Q>, Q = RMSD(Y)/ESD(Y)'/'   <E>, E = ESD(Y
     &)'/'   <Y>, Y = F OR FSQ'/'   <S>, S = SIN(THETA)/LAMBDA'/'     N,
     & N = NUMBER OF UNIQUE DATA'/'0SMAX(J) ACROSS',10(F10.3),'    TOTAL
     &S'/'         ------'/' YMAX(I) DOWN'/'         ----')
 1002 FORMAT (/E10.3,5X,11F10.2)
 1003 FORMAT (15X,11E10.3)
 1004 FORMAT (15X,11E10.3)
 1005 FORMAT (15X,11F10.3)
 1006 FORMAT (15X,11I10)
 1007 FORMAT (/'    TOTALS',5X,10F10.2)
 1008 FORMAT (15X,10E10.3)
 1009 FORMAT (15X,10E10.3)
 1010 FORMAT (15X,10F10.3)
 1011 FORMAT (15X,10I10)
C
C PRINT DATA SET STATISTICS.
C
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1020) YMIN0,SMIN0,YMAX0,SMAX0,YMIN1,SMIN1,YMAX1,SMAX1
 1020 FORMAT ('0DATA SET STATISTICS:'/'0OVERALL RANGE OF UNIQUE DATA:'/'
     &0YMIN  = ',E10.3,'    SMIN  = ',F6.3/' YMAX  = ',E10.3,'    SMAX',
     &'  = ',F6.3/'0RANGE OF MULTIPLY MEASURED DATA:'/'0YMIN  = ',E10.3,
     &'    SMIN  = ',F6.3/' YMAX  = ',E10.3,'    SMAX  = ',F6.3)
C
C COMPILE AND PRINT DISTRIBUTION STATISTICS FOR Q = RMSD/ESD.
C
      M=0
      QMIN=+9E9
      QMAX=-9E9
      Q2=0
      Q3=0
      Q4=0
      REWIND IO2
      DO I=1,NTOTAL
        READ (IO2) S,Y,ESD,RMSD,NMEAS
        IF (NMEAS.GE.2.AND.ESD.GT.0.AND.RMSD.GT.0) THEN
          M=M+NMEAS
          W=NMEAS-1
          Q=RMSD/ESD
          QMIN=MIN(QMIN,Q)
          QMAX=MAX(QMAX,Q)
          D=Q-Q0
          Q2=Q2+W*D**2
          Q3=Q3+W*D**3
          Q4=Q4+W*D**4
        END IF
      END DO
      Q2=Q2/SUMW
      Q3=Q3/SUMW
      Q4=Q4/SUMW
      RMSDQ=SQRT(Q2)
      Q3=Q3/RMSDQ**3
      Q4=Q4/RMSDQ**4
      Q4=Q4-3
      WRITE (ILP,9003) N,FLOAT(M)/N,QMIN,QMAX,Q0,RMSDQ,Q3,Q4
 9003 FORMAT (/1X,'DISTRIBUTION STATISTICS FOR ESTIMATED ERROR RAT',
     &'IOS, Q = RMSD(Y)/ESD(Y),'/1X,'FOR MEASUREMENT SAMPLES WITH N = ',
     &'NMEAS - NREJ .GE. 2:'//1X,
     &'    NSAMPLES = ',I7/1X,
     &'    <N>      = ',F7.1/1X,
     &'    QMIN  = ',E10.3/1X,'    QMAX  = ',E10.3/1X,
     &'    QMEAN = ',E10.3/1X,'    RMSDQ = ',E10.3/1X,
     &'    MOMENT COEFFICIENT OF SKEWNESS, C3     = ',E10.3/1X,
     &'    MOMENT COEFFICIENT OF KURTOSIS, C4 - 3 = ',E10.3/1X,
     &'    C3 = <(Q - <Q>)**3>/[<(Q - <Q>)**2>**(1/2)]**3'/1X,
     &'    C4 = <(Q - <Q>)**4>/[<(Q - <Q>)**2>**(1/2)]**4')
C
C COMPILE AND PRINT Q-SORTED LIST OF REFLECTION SAMPLES WITH
C NMEAS .GT. 2 AND SIGNIFICANTLY LARGER THAN AVERAGE Q.
C
      OPEN (UNIT=IO4,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=5)
      CUTOFF=Q0+QLIMIT*RMSDQ
      ITYPE=JPATH
      REWIND IO1
      N=0
      DO I=1,NTOTAL
        CALL READ2 (IO1,ITYPE,IEND,IH,IK,IL,Y,ESD,RMSD,NMEAS,TBAR,U0,U1)
        IF (NMEAS.GT.2) THEN
          Q=RMSD/ESD
          IF (Q.GT.CUTOFF) THEN
            N=N+1
            WRITE (IO4,REC=N) IH,IK,IL,Q,NMEAS
            DATA(N)=Q
          END IF
        END IF
      END DO
      IF (N.GT.0) THEN
        WRITE (ILP,9004)
 9004 FORMAT (/1X,'REFLECTION SAMPLES WITH N .GT. 2 AND SIGNIFIC',
     &'ANTLY LARGER THAN AVERAGE Q'//1X,'   H   K   L       Q     N'/
     &1X,'   -   -   -       -     -')
        CALL SORT (N,DATA,INDEX)
        DO I=N,1,-1
          READ (IO4,REC=INDEX(I))        IH,IK,IL,Q,NMEAS
          WRITE (ILP,'(1X,3I4,F8.1,I6)') IH,IK,IL,Q,NMEAS
        END DO
      END IF
      CLOSE (UNIT=IO4,STATUS='DELETE')
C
C ACCUMULATE NORMAL MATRIX AND VECTOR TO FIT Q = Q(Y, S).
C
C Q = ( Y S 1 ) ( A11 A12 A13 ) ( Y )
C               ( A21 A22 A23 ) ( S )
C               ( A31 A32 A33 ) ( 1 )
C
C Q = A11*Y**2 + A22*S**2 + A33 + 2*A12*Y*S + 2*A13*Y + 2*A23*S
C
      NOBS=0
      NPAR=6
      REWIND IO2
      DO M=1,NTOTAL
        READ (IO2) S,Y,ESD,RMSD,NMEAS
        IF (NMEAS.GE.2.AND.ESD.GT.0.AND.RMSD.GT.0) THEN
C
C SHIFT ORIGIN TO (Y - YMEAN, S - SMEAN, Q - QMEAN) IN ORDER TO REDUCE
C CORRELATIONS BETWEEN LEAST-SQUARES PARAMETERS.
C
          Y=Y-Y0
          S=S-S0
          X(1)=Y**2
          X(2)=S**2
          X(3)=1
          X(4)=2*Y*S
          X(5)=2*Y
          X(6)=2*S
          Q=RMSD/ESD
          Y=Q-Q0
          W=NMEAS-1
          NOBS=NOBS+1
          DO I=1,NPAR
          DO J=I,NPAR
            AA(I,J)=AA(I,J)+W*X(I)*X(J)
          END DO
            BB(I)=BB(I)+W*X(I)*Y
          END DO
        END IF
      END DO
      DO I=1,NPAR-1
      DO J=I+1,NPAR
        AA(J,I)=AA(I,J)
      END DO
      END DO
      IF (NOBS.LE.NPAR) THEN
        WRITE (ILP,350) NOBS
        GO TO 49
      END IF
 350  FORMAT ('0NOBS = ',I1,' .LE. NPAR = 6.  TOO FEW DATA TO FIT A QUAT
     &RATIC SURFACE.')
C
C INVERT NORMAL MATRIX.
C
      CALL MATINV (6,6,AA,DET)
      IF (DET.EQ.0) THEN
        WRITE (ILP,450)
        GO TO 49
      END IF
 450  FORMAT ('0SINGULAR NORMAL MATRIX FOR FIT OF QUADRATIC SURFACE IN S
     &UBROUTINE ANOVA.')
C
C     CALCULATE COEFFICIENTS OF QUADRATIC SURFACE.
C
      DO I=1,NPAR
        X(I)=0
      DO J=1,NPAR
        X(I)=X(I)+AA(I,J)*BB(J)
      END DO
      END DO
      A11=X(1)
      A22=X(2)
      A33=X(3)
      A12=X(4)
      A13=X(5)
      A23=X(6)
C
C CORRECT FOR SHIFT OF ORIGIN.
C
      A33=A11*Y0**2+A22*S0**2+A33+2*A12*Y0*S0-2*A13*Y0-2*A23*S0+Q0
      A23=-A12*Y0-A22*S0+A23
      A13=-A11*Y0-A12*S0+A13
C
C CALCULATE STATISTICS OF FIT.
C
      SUMW=0
      CHISQ=0
      SUMSQ=0
      QMIN=+9E9
      QMAX=-9E9
      REWIND IO2
      DO N=1,NTOTAL
        READ (IO2) S,Y,ESD,RMSD,NMEAS
        IF (NMEAS.GE.2.AND.ESD.GT.0.AND.RMSD.GT.0) THEN
          W=NMEAS-1
          Q=RMSD/ESD
          QCALC=A11*Y**2+A22*S**2+A33+2*A12*Y*S+2*A13*Y+2*A23*S
          SUMW=SUMW+W
          CHISQ=CHISQ+W*(Q-QCALC)**2
          SUMSQ=SUMSQ+W*Q**2
          QMIN=MIN(QMIN,QCALC)
          QMAX=MAX(QMAX,QCALC)
        END IF
      END DO
      Z=SQRT((CHISQ/SUMW)*NOBS/(NOBS-NPAR))
      R=SQRT(CHISQ/SUMSQ)
      IF (Z.GT.RMSDQ) THEN
        IANOVA=1
      ELSE
        IANOVA=2
      END IF
      WRITE (ILP,110) A11,A22,A33,A12,A13,A23,Z,R,QMIN,QMAX
 110  FORMAT ('0FITTED QUADRATIC SURFACE Q = Q(Y,S):'/'0Q = (Y S 1) (A11
     & A12 A13) (Y)'/'             (A21 A22 A23) (S)'/'             (A31
     & A32 A33) (1)'/'0Q = A11*Y**2 + A22*S**2 + A33 + 2*A12*Y*S + 2*A13
     &*Y + 2*A23*S'/'0A11 = ',E10.3/' A22 = ',E10.3/' A33 = ',E10.3/' A1
     &2 = ',E10.3/' A13 = ',E10.3/' A23 = ',E10.3/'0STATISTICS OF FIT:'/
     &'0CHISQ = SUM(WI*(QI - Q(YI,SI))**2)'/' WI    = NI - 1'/' WHERE NI
     & IS THE NUMBER OF EQUIVALENT MEASUREMENTS OF THE I-TH UNIQUE REFLE
     &CTION'/' Z = SQRT((CHISQ/SUM(WI))*NOBS/(NOBS - NPAR)) = ',E10.3/
     &' R = SQRT(CHISQ/SUM(WI*QI**2))                = ',E10.3/'0RANGE O
     &F QCALC:'/'0QMIN  = ',E10.3/' QMAX  = ',E10.3)
 49   CONTINUE
      CLOSE (UNIT=IO2,STATUS='DELETE')
      CLOSE (UNIT=IO3,STATUS='DELETE')
C
C REVISE ESTIMATES OF STANDARD DEVIATION.
C
      ITYPE=JPATH
      REWIND IO1
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED')
      DO N=1,NTOTAL
        CALL READ2 (IO1,ITYPE,IEND,IH,IK,IL,Y,ESD,RMSD,NMEAS,TBAR,U0,U1)
        CALL WRITE1 (IO2,IH,IK,IL,Y,ESD,RMSD,NMEAS,TBAR,U0,U1)
      END DO
      QMIN=+9E9
      QMAX=-9E9
      REWIND IO2
      REWIND IO1
      DO 20 N=1,NTOTAL
        CALL READ2 (IO2,ITYPE,IEND,IH,IK,IL,Y,ESD,RMSD,NMEAS,TBAR,U0,U1)
        S=SINTHL(IH,IK,IL,GINV)
        IF (IANOVA.EQ.1) THEN
C
C REVISED ESTIMATE FROM TABLE LOOK-UP.
C
          DO 121 I=NYINT,1,-1
            IF (Y.LE.YMAXI(I)) GO TO 131
 121      CONTINUE
 131      DO 122 J=1,NSINT,+1
            IF (S.LE.SMAXJ(J)) GO TO 132
 122      CONTINUE
 132      IF (NIJ(I,J).GE.2) THEN
            Q=QIJ(I,J)
          ELSE IF (NI(I).GE.2.AND.NJ(J).GE.2) THEN
            Q=(NI(I)*QI(I)+NJ(J)*QJ(J))/(NI(I)+NJ(J))
          ELSE IF (NI(I).GE.2) THEN
            Q=QI(I)
          ELSE IF (NJ(J).GE.2) THEN
            Q=QJ(J)
          ELSE
            Q=Q0
          END IF
        ELSE
C
C REVISED ESTIMATE FROM FITTED QUADRATIC SURFACE.
C
          Q=A11*Y**2+A22*S**2+A33+2*A12*Y*S+2*A13*Y+2*A23*S
        END IF
        Q=MAX(1.0,Q,RMSD/ESD)
        QMIN=MIN(QMIN,Q)
        QMAX=MAX(QMAX,Q)
        CALL WRITE1 (IO1,IH,IK,IL,Y,Q*ESD,RMSD,NMEAS,TBAR,U0,U1)
 20   CONTINUE
      ENDFILE IO1
      CLOSE (UNIT=IO2,STATUS='DELETE')
      IF (IANOVA.EQ.1) WRITE (ILP,111)
      IF (IANOVA.EQ.2) WRITE (ILP,211)
      WRITE (ILP,112) QMIN,QMAX
 111  FORMAT ('0REVISED ESD''S BASED ON TABLE FUNCTION.')
 211  FORMAT ('0REVISED ESD''S BASED ON FITTED QUADRATIC SURFACE.')
 112  FORMAT ('0REVISED ESD = MAX(ESD, Q*ESD, RMSD).'/
     &'0RANGE OF APPLIED VALUES OF Q:'/'0QMIN  = ',E10.3/' QMAX  = ',
     &E10.3)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE AVEQ (N,Y,SIGY,P,Q,R,C1,C2,C3,C4,IW,JW,ZMAX,W,YMEAN,
     & ESD,RMSD)
C
C AVERAGE EQUIVALENT MEASUREMENTS.
C
      REAL MEDIAN
      DOUBLE PRECISION SUMW,SUMY,SUMYSQ,SUMSSQ
      PARAMETER (NMAX=1000)
      DIMENSION Y(N),SIGY(N),W(N),DATA(NMAX)
C
C INITIALIZE TO UNIT WEIGHTS.
C
      DO I=1,N
        W(I)=1
      END DO
      IF (N.EQ.1) THEN
        YMEAN=Y(1)
        ESD=SIGY(1)
        RMSD=SIGY(1)
        RETURN
      END IF
      NREJ=0
      IF (MAX(P,Q)*R.GT.0) THEN
C
C REJECT ABNORMALLY LOW OUTLIERS FROM YMAX.
C
        YMAX=Y(1)
        SIGMA=SIGY(1)
        DO I=2,N
          IF (Y(I).GT.YMAX) THEN
            YMAX=Y(I)
            SIGMA=SIGY(I)
          END IF
        END DO
        T=YMAX-2*R*SQRT((Q*SIGMA)**2+(P*YMAX)**2)
        DO I=1,N
          IF (Y(I).LT.T) THEN
C
C ASSIGN ZERO WEIGHT TO REJECTED MEASUREMENTS.
C
            W(I)=0
            NREJ=NREJ+1
          END IF
        END DO
        IF (N-NREJ.LT.2) THEN
          YMEAN=YMAX
          ESD=SIGMA
          RMSD=SIGMA
          RETURN
        END IF
      END IF
      IF (MAX(FLOAT(IW),FLOAT(JW),C1,C2,C3,C4).GT.0) THEN
C
C TAKE MEDIAN YI AS INITIAL ESTIMATE OF MEAN.
C
        NDATA=0
        DO I=1,N
          IF (W(I).GT.0) THEN
            NDATA=NDATA+1
            DATA(NDATA)=Y(I)
          END IF
        END DO
        YMEAN=MEDIAN(NDATA,DATA)
C
C TAKE MEDIAN SIGMA(YI) AS INITIAL ESTIMATE OF ESD.
C
        NDATA=0
        DO I=1,N
          IF (W(I).GT.0) THEN
            NDATA=NDATA+1
            DATA(NDATA)=SIGY(I)
          END IF
        END DO
        ESD=MEDIAN(NDATA,DATA)
C
C TAKE 1.25*MEDIAN ABS(YI - YMEDIAN) AS INITIAL ESTIMATE OF RMSD.
C
C FOR A NORMAL DISTRIBUTION, N(X,MU,SIGMA),
C
C SIGMA = <(X - MU)**2>**(1/2) = 1.25*<ABS(X - MU)>.
C
        NDATA=0
        DO I=1,N
          IF (W(I).GT.0) THEN
            NDATA=NDATA+1
            DATA(NDATA)=ABS(Y(I)-YMEAN)
          END IF
        END DO
        RMSD=1.25*MEDIAN(NDATA,DATA)*SQRT(FLOAT(NDATA)/(NDATA-1))
      END IF
      SIGMA=MAX(ESD,RMSD)
      IF (MAX(C1,C2,C3,C4).GT.0) THEN
C
C REJECT ABNORMAL OUTLIERS FROM MEDIAN.
C
        T=MAX(C1*YMEAN,C2*ESD,C3*RMSD,C4*ZCRIT(NDATA)*SIGMA)
        DO I=1,N
          IF (W(I).GT.0.AND.ABS(Y(I)-YMEAN).GT.T) THEN
            W(I)=0
            NREJ=NREJ+1
          END IF
        END DO
      END IF
      IF (N-NREJ.LT.2) RETURN
C
C CALCULATE AVERAGING WEIGHTS, W = WI*WJ.
C
C IW = 0, UNIT WEIGHTS
C IW = 1, EXPERIMENTAL WEIGHTS
C
C JW = 0, UNIT WEIGHTS
C JW = 1, RELATIVE NORMAL PROBABILITY WEIGHTS
C JW = 2, ROBUST/RESISTANT TUKEY BIWEIGHTS
C
      DO I=1,N
        IF (W(I).GT.0) THEN
          IF (IW.EQ.0) WI=1
          IF (IW.EQ.1) WI=1/(SIGY(I)**2+(P*YMEAN)**2)
          IF (JW.EQ.0) WJ=1
          IF (JW.GT.0) THEN
            IF (IW.EQ.0) Z=(Y(I)-YMEAN)/SIGMA
            IF (IW.EQ.1) Z=(Y(I)-YMEAN)/SIGY(I)
            IF (JW.EQ.1) WJ=EXP(-0.5*Z**2)
            IF (JW.EQ.2) WJ=(1-MIN(1.0,(Z/ZMAX)**2))**2
          END IF
          WI=WI*WJ
          IF (WI.GT.0) THEN
            W(I)=WI
          ELSE
            W(I)=0
            NREJ=NREJ+1
          END IF
        END IF
      END DO
      IF (N-NREJ.LT.2) RETURN
C 
C CALCULATE AVERAGES.
C
      SUMW=0
      SUMY=0
      SUMYSQ=0
      SUMSSQ=0
      DO I=1,N
        IF (W(I).GT.0) THEN
          SUMW=SUMW+W(I)
          SUMY=SUMY+W(I)*Y(I)
          SUMYSQ=SUMYSQ+W(I)*Y(I)**2
          SUMSSQ=SUMSSQ+W(I)*SIGY(I)**2
        END IF
      END DO
      YMEAN=SUMY/SUMW
      ESD=SQRT(SUMSSQ/SUMW)
      RMSD=SQRT(ABS((SUMYSQ/SUMW)-YMEAN**2)*(N-NREJ)/(N-NREJ-1))
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE DATAIN
C
C READ INPUT REFLECTION DATA FILE(S) AND FORM A FILE SORTED ON HKL.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      PARAMETER (KMAX=600)
      COMMON /BLOCKS/ NSCALE,SCALEK(KMAX),IFIXED,QMIN,ZMAX
      COMMON /BLOCK3/ IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,SMIN,SMAX
      PARAMETER (M1=17,M2=15,M3=20)
      COMMON /BLOCK4/ X1(M1),X2(M2),X3(M3)
      PARAMETER (JMAX=NMAX/5)
      DIMENSION JI(JMAX),JH(JMAX),JK(JMAX),JL(JMAX)
      EQUIVALENCE (JN,DATA(1)),(JI(1),DATA(2)),(JH(1),DATA(3+JMAX)),
     & (JK(1),DATA(3+2*JMAX)),(JL(1),DATA(3+3*JMAX)),
     & (SMIN1,DATA(3+4*JMAX)),(SMAX1,DATA(4+4*JMAX))
      DIMENSION INDEX(NMAX/2)
      EQUIVALENCE (INDEX(1),DATA(1+NMAX/2))
C
C THE ARRAY A(11) CONTAINS THE DIFFRACTOMETER SETTING ANGLES, ANGLES(4),
C IN A(1) THROUGH A(4) AND THE ABSORPTION-WEIGHTED MEAN PATH LENGTH AND
C INCIDENT AND DIFFRACTED BEAM DIRECTION VECTORS, TBAR, S0(3), AND
C S1(3), IN A(5) THROUGH A(11).
C
      DIMENSION A(11)
      DATA A /11*0/
C
C CHECK WHETHER OR NOT AN ORIENTATION MATRIX WAS SUPPLIED.
C
      IORIENT=0
      DO I=1,3
      DO J=1,3
        IF (UB(I,J).NE.0) IORIENT=1
      END DO
      END DO
C
C INITIALIZE MEASUREMENT INDEX LIMITS.
C
      DATA JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX 
     & /+499, -499, +499, -499, +499, -499/
C
C LOOP TO READ IN REFLECTION DATA AND WRITE FILE FOR SORTING.
C
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=18)
      M=0
      N=0
      N1REJ=0
      N2REJ=0
      N3REJ=0
      N4REJ=0
      N5REJ=0
      N6REJ=0
      N7REJ=0
      N8REJ=0
      IEND=0
 1    CALL READF (IO1,IEND,NFILE,FILE1,II,IH,IK,IL,Y,SIGY,ISCALE,A)
      IF (IEND.NE.0) GO TO 5
      M=M+1
C
C CHECK AGAINST LIST OF MEASUREMENTS TO BE REJECTED.
C
      IF (JN.GT.0) THEN
        DO J=1,JN
          IF (II.EQ.JI(J).AND.
     &        IH.EQ.JH(J).AND.IK.EQ.JK(J).AND.IL.EQ.JL(J)) THEN
            N1REJ=N1REJ+1
            GO TO 1
          END IF
        END DO
      END IF
C
C CHECK SPACE GROUP CONDITIONS LIMITING POSSIBLE REFLECTIONS.
C
      CALL HKLTEST (IH,IK,IL,NCOND,ICOND,IABSENT)
      IF (IABSENT.NE.0) THEN
        N2REJ=N2REJ+1
        GO TO 1
      END IF
C
C CHECK S = SIN(THETA)/LAMBDA SHELL LIMITS.
C
      S=SINTHL(IH,IK,IL,GINV)
      IF (S.LT.SMIN1.OR.S.GT.SMAX1) THEN
        N3REJ=N3REJ+1
        GO TO 1
      END IF
C
C CHECK INDEX MAGNITUDE LIMITS.
C
      IF (IH.EQ.0.AND.IK.EQ.0.AND.IL.EQ.0) THEN
        N4REJ=N4REJ+1
        GO TO 1
      END IF
      IF (ABS(IH).GE.500.OR.ABS(IK).GE.500.OR.ABS(IL).GE.500) THEN
        N5REJ=N5REJ+1
        GO TO 1
      END IF
C
C CHECK FOR POSITIVE ERROR ESTIMATE.
C
      IF (SIGY.LE.0) THEN
        N6REJ=N6REJ+1
        GO TO 1
      END IF
C
C CHECK FOR ABNORMALLY NEGATIVE DATA.
C
      IF (Y.LT.-4*SIGY) THEN
        N7REJ=N7REJ+1
        GO TO 1
      END IF
C
C CHECK THAT SUBSET SCALE FACTOR IS KNOWN.
C
      IF (NSCALE.GT.1.AND.(ISCALE.LT.1.OR.ISCALE.GT.NSCALE)) THEN
        N8REJ=N8REJ+1
        GO TO 1
      END IF
C
C TABULATE INDEX AND SIN(THETA)/LAMBDA LIMITS FOR THE MEASUREMENTS.
C
      JHMIN=MIN(JHMIN,IH)
      JHMAX=MAX(JHMAX,IH)
      JKMIN=MIN(JKMIN,IK)
      JKMAX=MAX(JKMAX,IK)
      JLMIN=MIN(JLMIN,IL)
      JLMAX=MAX(JLMAX,IL)
      SMIN=MIN(SMIN,S)
      SMAX=MAX(SMAX,S)
C
C TABULATE UNIQUE INDEX LIMITS.
C
      J=IH
      K=IK
      L=IL
      CALL EQUIV (IPTGP,J,K,L)
      IHMIN=MIN(IHMIN,J)
      IHMAX=MAX(IHMAX,J)
      IKMIN=MIN(IKMIN,K)
      IKMAX=MAX(IKMAX,K)
      ILMIN=MIN(ILMIN,L)
      ILMAX=MAX(ILMAX,L)
C
C GET DIFFRACTOMETER SETTING ANGLES.
C
      IF (IORIENT.NE.0) THEN
        CALL SETANG (IH,IK,IL,UB,GINV,FLAMBDA,TWOTH,OMEGA,CHI,PHI)
        A(1)=TWOTH
        A(2)=OMEGA
        A(3)=CHI
        A(4)=PHI
      END IF
C
C WRITE DATA TO FILE TO BE SORTED.
C
      N=N+1
      WRITE (IO2,REC=N) II,IH,IK,IL,Y,SIGY,ISCALE,A
C
C LOOP BACK TO READ NEXT REFLECTION.
C
      GO TO 1
 5    CONTINUE
C
C END LOOP TO READ REFLECTION DATA.
C
      CLOSE (UNIT=IO1,STATUS='KEEP')
C
C PRINT SOME DATA SET STATISTICS.
C
      WRITE (ILP,501) ATIME,ADATE,TITLE
 501  FORMAT ('1'/'0PROGRAM SORTAV/DATAIN.  ',A,1X,A,'.  ',A)
      WRITE (ILP,507) M,N
 507  FORMAT('0M = ',I6,' MEASUREMENTS READ FROM THE INPUT REFLECTION DA
     &TA FILE'/'0N = ',I6,' ACCEPTED MEASUREMENTS WILL BE SORTED AND AVE
     &RAGED')
      WRITE (ILP,9005)  N1REJ,N2REJ,N3REJ,SMIN1,SMAX1,N4REJ,
     & N5REJ,N6REJ,N7REJ,N8REJ
 9005 FORMAT (/1X,
     &'N1 = ',I5,' MEASUREMENTS REJECTED BECAUSE THEY APPEAR IN THE I',
     &'NPUT REJECTION LIST'/1X,
     &'N2 = ',I5,' ADDITIONAL MEASUREMENTS REJECTED BECAUSE SYMMET',
     &'RY FORBIDDEN'/1X,
     &'N3 = ',I5,'      "           "          "       "    SIN(TH)/L',
     &' .LT. SMIN1 = ',F5.3,' OR .GT. SMAX1 = ',F5.3/1X,
     &'N4 = ',I5,'      "           "          "       "    IH = IK =',
     &' IL = 0'/1X,
     &'N5 = ',I5,'      "           "          "       "    ABS(IH',
     &'), ABS(IK), OR ABS(IL) .GT. 500'/1X,
     &'N6 = ',I5,'      "           "          "       "    SIGMA(YME',
     &'AS) .LE. 0'/1X,
     &'N7 = ',I5,'      "           "          "       "    YMEAS .LT',
     &'. -4*SIGMA(YMEAS)'/1X,
     &'N8 = ',I5,'      "           "          "       "    ISCALE .L',
     &'T. 1 OR .GT. NSCALE')
      WRITE (ILP,508) JHMIN,JKMIN,JLMIN,JHMAX,JKMAX,JLMAX
 508  FORMAT('0MILLER INDEX LIMITS OF THE ACCEPTED MEASUREMENTS:'/'0HMIN
     & KMIN LMIN'/3I5/'0HMAX KMAX LMAX'/3I5)
      WRITE (ILP,509) IHMIN,IKMIN,ILMIN,IHMAX,IKMAX,ILMAX,SMIN,SMAX,
     & 1/(2*SMIN),1/(2*SMAX)
 509  FORMAT('0MILLER INDEX AND SIN(THETA)/LAMBDA LIMITS OF THE UNIQUE D
     &ATA:'/'0HMIN KMIN LMIN'/3I5/'0HMAX KMAX LMAX'/3I5/'0SMIN = ',F7.3/
     &' SMAX = ',F7.3,' RECIPROCAL ANGSTROMS'/'0DATA RESOLUTION LIMITS:'
     &/'0DMAX = 1/(2*SMIN) = ',F6.2,' ANGSTROMS'/' DMIN = 1/(2*SMAX) = '
     &,F6.2,' ANGSTROMS')
C
C CALCULATE VARIABLE RANGES OF SIN(THETA)/LAMBDA FOR STATISTICS IN
C EQUAL-VOLUME SHELLS.
C
      DO I=1,M3
        X3(I)=(FLOAT(I)/M3)**(1/3.0)*SMAX
      END DO
C
C PACK AND SORT ON THE UNIQUE EQUIVALENT INDICES.
C
      NL=ILMAX-ILMIN+1
      NK=IKMAX-IKMIN+1
      DO I=1,N
        READ (IO2,REC=I) II,IH,IK,IL
        CALL EQUIV (IPTGP,IH,IK,IL)
        DATA(I)=(IH-IHMIN)*NK*NL+(IK-IKMIN)*NL+(IL-ILMIN)
      END DO
      CALL SORT (N,DATA,INDEX)
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=18)
      DO I=1,N
        READ  (IO2,REC=INDEX(I)) II,IH,IK,IL,Y,SIGY,ISCALE,A
        WRITE (IO3,REC=I)        II,IH,IK,IL,Y,SIGY,ISCALE,A
      END DO
      CLOSE (UNIT=IO2,STATUS='DELETE')
C
C REWRITE THE HKL-SORTED DATA FILE IN BLOCKS OF MULTIPLE EQUIVALENT
C MEASUREMENTS.
C
      OPEN (UNIT=IO1,STATUS='SCRATCH',FORM='UNFORMATTED')
      IHKL=DATA(INDEX(1))
      NMEAS=1
      DO I=2,N
        IF (DATA(INDEX(I)).EQ.IHKL) THEN
          NMEAS=NMEAS+1
        ELSE
          IH=IHKL/(NK*NL)
          IK=(IHKL-IH*NK*NL)/NL
          IL=IHKL-IH*NK*NL-IK*NL
          IH=IH+IHMIN
          IK=IK+IKMIN
          IL=IL+ILMIN
          WRITE (IO1) NMEAS,IH,IK,IL
          DO J=1,NMEAS
            IREC=I-J
            READ  (IO3,REC=IREC) II,IH,IK,IL,Y,SIGY,ISCALE,A
            WRITE (IO1)          II,IH,IK,IL,Y,SIGY,ISCALE,A
          END DO
          IHKL=DATA(INDEX(I))
          NMEAS=1
        END IF
      END DO
      IH=IHKL/(NK*NL)
      IK=(IHKL-IH*NK*NL)/NL
      IL=IHKL-IH*NK*NL-IK*NL
      IH=IH+IHMIN
      IK=IK+IKMIN
      IL=IL+ILMIN
      WRITE (IO1) NMEAS,IH,IK,IL
      DO I=1,NMEAS
        IREC=N-I+1
        READ  (IO3,REC=IREC) II,IH,IK,IL,Y,SIGY,ISCALE,A
        WRITE (IO1)          II,IH,IK,IL,Y,SIGY,ISCALE,A
      END DO
      ENDFILE IO1
      CLOSE (UNIT=IO3,STATUS='DELETE')
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE DECODE (PTGP,IPTGP)
C
C POINT GROUP SYMBOLS
C
C A TOTAL OF 42 CASES IS TABULATED BECAUSE THERE ARE TEN CASES OF
C ALTERNATIVE AXES FOR SEVEN OF THE 32 CRYSTALLOGRAPHIC POINT GROUPS.
C
      CHARACTER*5 PTGP,SYMBOL(42)
      DATA SYMBOL
     &/'1    ','-1   ',
     & '2    ','M    ','2/M  ',
     & '222  ','MM2  ','MMM  ',
     & '4    ','-4   ','4/M  ',
     & '422  ','4MM  ','-42M ','-4M2 ','4/MMM',
     & '3    ','-3   ',
     & '312  ','321  ','31M  ','3M1  ','-31M ','-3M1 ',
     & '6    ','-6   ','6/M  ',
     & '622  ','6MM  ','-6M2 ','-62M ','6/MMM',
     & 'R3   ','R-3  ',
     & 'R32  ','R3M  ','R-3M ',
     & '23   ','M3   ',
     & '432  ','-43M ','M3M  '/
      DO IPTGP=1,42
        IF (PTGP.EQ.SYMBOL(IPTGP)) RETURN
      END DO
      STOP 'ERROR IN POINT GROUP SYMBOL'
      END
C-----------------------------------------------------------------------
      FUNCTION DELTA(I,J)
C
C KRONECKER DELTA
C
      IF (I.EQ.J) THEN
        DELTA=1
      ELSE
        DELTA=0
      END IF
      END
C-----------------------------------------------------------------------
      SUBROUTINE DPRINT (IPRINT,JPRINT,IH,IK,IL,ESD,RMSD,QLIMIT,NMEAS,W,
     & NPRINT)
C
C DECIDE TO PRINT OR NOT.
C
C IPRINT .EQ. -1  DO NOT LIST ANY REFLECTIONS.
C        .EQ.  0  LIST DISCORDANT MEASUREMENT SAMPLES WITH
C                 ONE OR MORE REJECTED MEASUREMENTS AND/OR
C                 RMSD/ESD > QLIMIT AND/OR
C                 ONE OR MORE STATISTICAL OUTLIERS.
C        .EQ. +1  ALSO LIST SPECIAL AXIAL REFLECTIONS
C                 H00, 0K0, 00L, HH0, H0H, 0KK, AND HHH.
C        .EQ. +2  ALSO LIST SPECIAL ZONAL REFLECTIONS
C                 HK0, H0L, 0KL, HKK, HKH, AND HHL.
C
C JPRINT .GT.  0  ALSO LIST EVERY N-TH REFLECTION WHERE N = JPRINT.
C
C NPRINT = 0  DO NOT,
C        = 1  DO PRINT THE GIVEN REFLECIOTN.
C
      DIMENSION W(NMEAS)
      DATA N /0/
      SAVE N
      NPRINT=0
      IF (IPRINT.LT.0) RETURN
      IF (IPRINT.GE.0) THEN
        IF (RMSD/ESD.GT.QLIMIT) GO TO 1
        DO I=1,NMEAS
          IF (W(I).EQ.0) GO TO 1
        END DO
      END IF
      IF (IPRINT.GE.1) THEN
        J=ABS(IH)
        K=ABS(IK)
        L=ABS(IL)
        IF (J.EQ.0.AND.K.EQ.0) GO TO 1
        IF (J.EQ.0.AND.L.EQ.0) GO TO 1
        IF (K.EQ.0.AND.L.EQ.0) GO TO 1
        IF (J.EQ.K.AND.L.EQ.0) GO TO 1
        IF (J.EQ.L.AND.K.EQ.0) GO TO 1
        IF (K.EQ.L.AND.J.EQ.0) GO TO 1
        IF (J.EQ.K.AND.K.EQ.L) GO TO 1
      END IF
      IF (IPRINT.EQ.2) THEN
        IF (J.EQ.0.OR.K.EQ.0.OR.L.EQ.0) GO TO 1
        IF (J.EQ.K.OR.K.EQ.L.OR.L.EQ.J) GO TO 1
      END IF
      IF (JPRINT.GT.0) THEN
        N=N+1
        IF (MOD(N,JPRINT).EQ.0) GO TO 1
      END IF
      RETURN
 1    NPRINT=1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE EQUIV (PTGP,H,K,L)
C
C EQUIVALENT, UNIQUE REFLECTION INDICES FOR THE CRYSTALLOGRAPHIC POINT
C GROUPS
C
C TRICL. MONOCL. ORTHO.  TETRAG.    TRIG.     RHOMB.    CUB.
C
C (1) 1  (3) 2   (6) 222  (9) 4     (17)  3   (33) R3   (38) 23
C (2) -1 (4) M   (7) MM2 (10) -4    (18)  -3  (34) R-3  (39) M3
C        (5) 2/M (8) MMM (11) 4/M
C                                   (19) 312  (35) R32  (40) 432
C                        (12) 422   (20) 321  (36) R3M  (41) -43M
C                        (13) 4MM   (21) 31M  (37) R-3M (42) M3M
C                        (14) -42M  (22) 3M1
C                        (15) -4M2  (23) -31M
C                        (16) 4/MMM (24) -3M1
C
C                                   HEXAG.
C
C                                   (25) 6
C                                   (26) -6
C                                   (27) 6/M
C
C                                   (28) 622
C                                   (29) 6MM
C                                   (30) -6M2
C                                   (31) -62M
C                                   (32) 6/MMM
C
C SEE INTERNATIONAL TABLES FOR CRYSTALLOGRAPHY (1983).  VOLUME A, PP.
C 750-770.
C
C A TOTAL OF 42 CASES IS TABULATED BECAUSE THERE ARE TEN CASES OF
C ALTERNATIVE AXES FOR SEVEN OF THE 32 CRYSTALLOGRAPHIC POINT GROUPS:
C
C -42M  -4M2
C 3     R3
C -3    R-3
C 312   321   R32
C 31M   3M1   R3M
C -31M  -3M1  R-3M
C -62M  -6M2
C
      INTEGER PTGP,H,X,Y,Z
      IF (H.EQ.0.AND.K.EQ.0.AND.L.EQ.0) RETURN
      GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,
     & 23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42) PTGP
C
C     1
C
    1 RETURN
C
C     -1
C
    2 IF (L.GT.0) RETURN
      H=-H
      K=-K
      L=-L
      IF (L.GT.0) RETURN
      IF (K.GT.0) RETURN
      H=-H
      K=-K
      IF (K.GT.0) RETURN
      IF (H.GE.0) RETURN
      H=-H
      RETURN
C
C     2
C
    3 IF (L.GT.0) RETURN
      H=-H
      L=-L
      IF (L.GT.0) RETURN
      IF (H.GE.0) RETURN
      H=-H
      RETURN
C
C     M
C
    4 K=ABS(K)
      RETURN
C
C     2/M
C
    5 K=ABS(K)
      GO TO 3
C
C     222
C
    6 IF (H.EQ.0.OR.K.EQ.0.OR.L.EQ.0) THEN
        H=ABS(H)
        K=ABS(K)
        L=ABS(L)
        RETURN
      END IF
      IF (H.GE.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      Z=L
      H=-X
      K=-Y
      L=Z
      IF (H.GE.0.AND.K.GE.0) RETURN
      H=-X
      K=Y
      L=-Z
      IF (H.GE.0.AND.K.GE.0) RETURN
      H=X
      K=-Y
      L=-Z
      RETURN
C
C     MM2
C
    7 H=ABS(H)
      K=ABS(K)
      RETURN
C
C     MMM
C
    8 L=ABS(L)
      GO TO 7
C
C     4
C
    9 IF (H.EQ.0.AND.K.EQ.0) RETURN
      IF (H.GT.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      H=-Y
      K=X
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=-X
      K=-Y
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=Y
      K=-X
      RETURN
C
C     -4
C
   10 IF (H.EQ.0.AND.K.EQ.0) THEN
        L=ABS(L)
        RETURN
      END IF
      IF (H.GT.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      H=-X
      K=-Y
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=Y
      K=-X
      L=-L
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=-Y
      K=X
      RETURN
C
C     4/M
C
   11 L=ABS(L)
      GO TO 9
C
C     422
C
   12 IF (H.EQ.0.OR.K.EQ.0.OR.ABS(H).EQ.ABS(K)) L=ABS(L)
  512 IF (H.GE.K.AND.K.GE.0) RETURN
      X=H
      Y=K
      H=-X
      K=-Y
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-Y
      K=X
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=Y
      K=-X
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-X
      K=Y
      L=-L
      GO TO 512
C
C     4MM
C
   13 H=ABS(H)
      K=ABS(K)
      IF (H.GE.K) RETURN
      X=H
      H=K
      K=X
      RETURN
C
C     -42M
C
   14 IF (H.EQ.0.OR.K.EQ.0) L=ABS(L)
  514 IF (H.GE.K.AND.K.GE.0) RETURN
      X=H
      Y=K
      H=-X
      K=-Y
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=Y
      K=-X
      L=-L
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-Y
      K=X
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-X
      K=Y
      GO TO 514
C
C     -4M2
C
   15 H=ABS(H)
      K=ABS(K)
      IF (H.EQ.K) L=ABS(L)
      IF (H.GE.K) RETURN
      X=H
      H=K
      K=X
      L=-L
      RETURN
C
C     4/MMM
C
   16 L=ABS(L)
      GO TO 13
C
C     3
C
   17 IF (H.EQ.0.AND.K.EQ.0) RETURN
      IF (H.LT.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.LT.0.AND.K.GE.0) RETURN
      H=Y
      K=I
      RETURN
C
C     -3
C
   18 IF (H.EQ.0.AND.K.EQ.0) THEN
        L=ABS(L)
        RETURN
      END IF
  518 IF (H.LT.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.LT.-K))) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.LT.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.LT.-K))) RETURN
      H=Y
      K=I
      IF (H.LT.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.LT.-K))) RETURN
      H=-X
      K=-Y
      L=-L
      GO TO 518
C
C     312
C
   19 IF (H.EQ.0.OR.K.EQ.0.OR.-H.EQ.K) L=ABS(L)
  519 IF (H.GE.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.0.AND.K.GE.0) RETURN
      H=Y
      K=I
      IF (H.GE.0.AND.K.GE.0) RETURN
      H=-Y
      K=-X
      L=-L
      GO TO 519
C
C     321
C
   20 IF (H.EQ.K.OR.-2*H.EQ.K.OR.-H.EQ.2*K) L=ABS(L)
  520 IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K) RETURN
      H=Y
      K=I
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K) RETURN
      H=Y
      K=X
      L=-L
      GO TO 520
C
C     31M
C
   21 IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K) RETURN
      H=Y
      K=I
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K) RETURN
      H=Y
      K=X
      GO TO 21
C
C     3M1
C
   22 IF (H.GE.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.0.AND.K.GE.0) RETURN
      H=Y
      K=I
      IF (H.GE.0.AND.K.GE.0) RETURN
      H=-Y
      K=-X
      GO TO 22
C
C     -31M
C
   23 IF (H.EQ.0.OR.K.EQ.0.OR.-H.EQ.K) L=ABS(L)
  523 IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K.AND.(L.GT.0.OR.(L.EQ.0.AND.
     & K.GE.0))) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K.AND.(L.GT.0.OR.(L.EQ.0.AND.
     & K.GE.0))) RETURN
      H=Y
      K=I
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K.AND.(L.GT.0.OR.(L.EQ.0.AND.
     & K.GE.0))) RETURN
      H=Y
      K=X
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K.AND.(L.GT.0.OR.(L.EQ.0.AND.
     & K.GE.0))) RETURN
      H=X
      K=I
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K.AND.(L.GT.0.OR.(L.EQ.0.AND.
     & K.GE.0))) RETURN
      H=I
      K=Y
      IF (H.GE.0.AND.H.GE.K.AND.H.GE.-2*K.AND.(L.GT.0.OR.(L.EQ.0.AND.
     & K.GE.0))) RETURN
      H=-X
      K=-Y
      L=-L
      GO TO 523
C
C     -3M1
C
   24 IF (H.EQ.K.OR.-2*H.EQ.K.OR.-H.EQ.2*K) L=ABS(L)
  524 IF (H.GE.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.GE.K))) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.GE.K))) RETURN
      H=Y
      K=I
      IF (H.GE.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.GE.K))) RETURN
      H=Y
      K=X
      L=-L
      IF (H.GE.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.GE.K))) RETURN
      H=X
      K=I
      IF (H.GE.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.GE.K))) RETURN
      H=I
      K=Y
      IF (H.GE.0.AND.K.GE.0.AND.(L.GT.0.OR.(L.EQ.0.AND.H.GE.K))) RETURN
      H=-X
      K=-Y
      GO TO 524
C
C     6
C
   25 IF (H.EQ.0.AND.K.EQ.0) RETURN
      IF (H.GT.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=Y
      K=I
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=-X
      K=-Y
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=-I
      K=-X
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=-Y
      K=-I
      RETURN
C
C     -6
C
   26 L=ABS(L)
      GO TO 17
C
C     6/M
C
   27 L=ABS(L)
      GO TO 25
C
C     622
C
   28 IF (H.EQ.0.OR.K.EQ.0.OR.ABS(H).EQ.ABS(K).OR.ABS(2*H).EQ.ABS(K).OR.
     & ABS(H).EQ.ABS(2*K)) L=ABS(L)
  528 IF (H.GE.K.AND.K.GE.0) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=Y
      K=I
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-X
      K=-Y
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-I
      K=-X
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-Y
      K=-I
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=Y
      K=X
      L=-L
      GO TO 528
C
C     6MM
C
   29 IF (H.GE.K.AND.K.GE.0) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=Y
      K=I
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-X
      K=-Y
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-I
      K=-X
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=-Y
      K=-I
      IF (H.GE.K.AND.K.GE.0) RETURN
      H=Y
      K=X
      GO TO 29
C
C     -6M2
C
   30 L=ABS(L)
      IF (H.EQ.0.AND.K.EQ.0) RETURN
  530 IF (H.GT.0.AND.K.GE.0) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=Y
      K=I
      IF (H.GT.0.AND.K.GE.0) RETURN
      H=-Y
      K=-X
      GO TO 530
C
C     -62M
C
   31 L=ABS(L)
      IF (H.EQ.0.AND.K.EQ.0) RETURN
  531 IF (H.GT.0.AND.H.GE.K.AND.H.GT.-2*K) RETURN
      X=H
      Y=K
      I=-H-K
      H=I
      K=X
      IF (H.GT.0.AND.H.GE.K.AND.H.GT.-2*K) RETURN
      H=Y
      K=I
      IF (H.GT.0.AND.H.GE.K.AND.H.GT.-2*K) RETURN
      H=Y
      K=X
      GO TO 531
C
C     6/MMM
C
   32 L=ABS(L)
      GO TO 29
C
C     R3
C
   33 STOP 'RE-INDEX ON HEXAGONAL AXES'
C
C     R-3
C
   34 GO TO 33
C
C     R32
C
   35 GO TO 33
C
C     R3M
C
   36 GO TO 33
C
C     R-3M
C
   37 GO TO 33
C
C     23
C
   38 IF (ABS(H).EQ.ABS(K).AND.ABS(K).EQ.ABS(L)) THEN
        H=ABS(H)
        K=ABS(K)
        L=ABS(L)*(H*K*L)/ABS(H*K*L)
        RETURN
      END IF
  538 IF (H.GT.ABS(L).AND.K.GE.ABS(L)) RETURN
      X=H
      Y=K
      Z=L
      H=-X
      K=-Y
      L=Z
      IF (H.GT.ABS(L).AND.K.GE.ABS(L)) RETURN
      H=-X
      K=Y
      L=-Z
      IF (H.GT.ABS(L).AND.K.GE.ABS(L)) RETURN
      H=X
      K=-Y
      L=-Z
      IF (H.GT.ABS(L).AND.K.GE.ABS(L)) RETURN
      H=Z
      K=X
      L=Y
      GO TO 538
C
C     M3
C
   39 H=ABS(H)
      K=ABS(K)
      L=ABS(L)
      IF (H.EQ.K.AND.K.EQ.L) RETURN
  539 IF (H.GT.L.AND.K.GE.L) RETURN
      X=H
      Y=K
      Z=L
      H=Z
      K=X
      L=Y
      IF (H.GT.L.AND.K.GE.L) RETURN
      H=Y
      K=Z
      L=X
      GO TO 539
C
C     432
C
   40 IF (ABS(H).EQ.ABS(K).AND.ABS(K).EQ.ABS(L)) THEN
        H=ABS(H)
        K=ABS(K)
        L=ABS(L)
        RETURN
      END IF
  540 IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      X=H
      Y=K
      Z=L
      H=Z
      K=X
      L=Y
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=Y
      K=Z
      L=X
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=-X
      K=-Y
      L=Z
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=Z
      K=-X
      L=-Y
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=-Y
      K=Z
      L=-X
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=-X
      K=Y
      L=-Z
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=-Z
      K=-X
      L=Y
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=Y
      K=-Z
      L=-X
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=X
      K=-Y
      L=-Z
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=-Z
      K=X
      L=-Y
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=-Y
      K=-Z
      L=X
      IF (H.GT.L.AND.K.GE.L.AND.L.GE.0) RETURN
      H=Y
      K=X
      L=-Z
      GO TO 540
C
C     -43M
C
   41 IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      X=H
      Y=K
      Z=L
      H=Z
      K=X
      L=Y
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=Y
      K=Z
      L=X
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=-X
      K=-Y
      L=Z
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=Z
      K=-X
      L=-Y
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=-Y
      K=Z
      L=-X
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=-X
      K=Y
      L=-Z
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=-Z
      K=-X
      L=Y
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=Y
      K=-Z
      L=-X
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=X
      K=-Y
      L=-Z
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=-Z
      K=X
      L=-Y
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=-Y
      K=-Z
      L=X
      IF (H.GE.K.AND.K.GE.ABS(L)) RETURN
      H=Y
      K=X
      L=Z
      GO TO 41
C
C     M3M
C
   42 H=ABS(H)
      K=ABS(K)
      L=ABS(L)
      IF (H.GE.K.AND.K.GE.L) RETURN
      X=H
      Y=K
      Z=L
      H=Z
      K=X
      L=Y
      IF (H.GE.K.AND.K.GE.L) RETURN
      H=Y
      K=Z
      L=X
      IF (H.GE.K.AND.K.GE.L) RETURN
      H=Z
      K=Y
      L=X
      IF (H.GE.K.AND.K.GE.L) RETURN
      H=X
      K=Z
      L=Y
      IF (H.GE.K.AND.K.GE.L) RETURN
      H=Y
      K=X
      L=Z
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE HKLCOND (HCOND,ICOND)
C
C CONDITIONS LIMITING POSSIBLE REFLECTIONS
C
      CHARACTER*18 HCOND,A(38)
      DATA A
     &/'HKL,H+K=2N        ','HKL,K+L=2N        ','HKL,L+H=2N        ',
     & 'HKL,H+K,K+L=2N    ','HKL,H+K+L=2N      ','HKL,-H+K+L=3N     ',
     & 'HKL,H-K+L=3N      ','HKL,H-K=3N        ','HK0,H=2N          ',
     & 'HK0,K=2N          ','HK0,H+K=2N        ','HK0,H+K=4N        ',
     & '0KL,K=2N          ','0KL,L=2N          ','0KL,K+L=2N        ',
     & '0KL,K+L=4N        ','H0L,L=2N          ','H0L,H=2N          ',
     & 'H0L,L+H=2N        ','H0L,L+H=4N        ','HH(-2H)L,L=2N     ',
     & 'H(-H)0L,L=2N      ','HHL,L=2N(R-AXES)  ','HHL,L=2N          ',
     & 'HKH,K=2N          ','HKK,H=2N          ','HHL,2H+L=4N       ',
     & 'HKH,2H+K=4N       ','HKK,2K+H=4N       ','H00,H=2N          ',
     & 'H00,H=4N          ','0K0,K=2N          ','0K0,K=4N          ',
     & '00L,L=2N          ','00L,L=4N          ','000L,L=2N         ',
     & '000L,L=3N         ','000L,L=6N         '/
      DO ICOND=1,38
        IF (HCOND.EQ.A(ICOND)) RETURN
      END DO
      STOP 'INPUT ERROR.  HKL CONDITION IS NOT IN THE TABLE.'
      END
C-----------------------------------------------------------------------
      SUBROUTINE HKLGEN (IH,IK,IL,S)
C
C GENERATE UNIQUE HKL WITH S .LE. SMAX.
C
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCK3/ IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,SMIN,SMAX
 1    IL=IL+1
      IF (IL.LE.ILMAX) GO TO 2
      IL=ILMIN
      IK=IK+1
      IF (IK.LE.IKMAX) GO TO 2
      IL=ILMIN
      IK=IKMIN
      IH=IH+1
      IF (IH.LE.IHMAX) GO TO 2
      IH=999
      IK=999
      IL=999
      S=999
      RETURN
 2    S=SINTHL(IH,IK,IL,GINV)
      IF (S.GT.SMAX) GO TO 1
      CALL HKLTEST (IH,IK,IL,NCOND,ICOND,IABSENT)
      IF (IABSENT.NE.0) GO TO 1
      JH=IH
      JK=IK
      JL=IL
      CALL EQUIV (IPTGP,JH,JK,JL)
      IF (JH.NE.IH.OR.JK.NE.IK.OR.JL.NE.IL) GO TO 1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE HKLTEST (H,K,L,NCOND,ICOND,IABSENT)
C
C     CONDITIONS LIMITING POSSIBLE REFLECTIONS
C
C     ( 1) HKL,H+K=2N
C     ( 2) HKL,K+L=2N
C     ( 3) HKL,L+H=2N
C     ( 4) HKL,H+K,K+L=2N
C     ( 5) HKL,H+K+L=2N
C     ( 6) HKL,-H+K+L=3N
C     ( 7) HKL,H-K+L=3N
C     ( 8) HKL,H-K=3N
C     ( 9) HK0,H=2N
C     (10) HK0,K=2N
C     (11) HK0,H+K=2N
C     (12) HK0,H+K=4N
C     (13) 0KL,K=2N
C     (14) 0KL,L=2N
C     (15) 0KL,K+L=2N
C     (16) 0KL,K+L=4N
C     (17) H0L,L=2N
C     (18) H0L,H=2N
C     (19) H0L,L+H=2N
C     (20) H0L,L+H=4N
C     (21) HH(-2H)L,L=2N
C     (22) H(-H)0L,L=2N
C     (23) HHL,L=2N (RHOMBOHEDRAL AXES)
C     (24) HHL,L=2N
C     (25) HKH,K=2N
C     (26) HKK,H=2N
C     (27) HHL,2H+L=4N
C     (28) HKH,2H+K=4N
C     (29) HKK,2K+H=4N
C     (30) H00,H=2N
C     (31) H00,H=4N
C     (32) 0K0,K=2N
C     (33) 0K0,K=4N
C     (34) 00L,L=2N
C     (35) 00L,L=4N
C     (36) 000L,L=2N
C     (37) 000L,L=3N
C     (38) 000L,L=6N
C
C     SET IABSENT = 0 FOR AN ALLOWED REFLECTION,
C                   1 FOR A FORBIDDEN REFLECTION.
C
      INTEGER H
      DIMENSION ICOND(38)
      IABSENT=0
      IF (NCOND.EQ.0) RETURN
      DO 90 I=1,NCOND
      GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,
     & 23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38) ICOND(I)
    1 IF (MOD(H+K,2).NE.0) GO TO 91
      GO TO 90
    2 IF (MOD(K+L,2).NE.0) GO TO 91
      GO TO 90
    3 IF (MOD(L+H,2).NE.0) GO TO 91
      GO TO 90
    4 IF (MOD(H+K,2).NE.0.OR.MOD(K+L,2).NE.0) GO TO 91
      GO TO 90
    5 IF (MOD(H+K+L,2).NE.0) GO TO 91
      GO TO 90
    6 IF (MOD(-H+K+L,3).NE.0) GO TO 91
      GO TO 90
    7 IF (MOD(H-K+L,3).NE.0) GO TO 91
      GO TO 90
    8 IF (MOD(H-K,3).NE.0) GO TO 91
      GO TO 90
    9 IF (L.EQ.0.AND.MOD(H,2).NE.0) GO TO 91
      GO TO 90
   10 IF (L.EQ.0.AND.MOD(K,2).NE.0) GO TO 91
      GO TO 90
   11 IF (L.EQ.0.AND.MOD(H+K,2).NE.0) GO TO 91
      GO TO 90
   12 IF (L.EQ.0.AND.MOD(H+K,4).NE.0) GO TO 91
      GO TO 90
   13 IF (H.EQ.0.AND.MOD(K,2).NE.0) GO TO 91
      GO TO 90
   14 IF (H.EQ.0.AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   15 IF (H.EQ.0.AND.MOD(K+L,2).NE.0) GO TO 91
      GO TO 90
   16 IF (H.EQ.0.AND.MOD(K+L,4).NE.0) GO TO 91
      GO TO 90
   17 IF (K.EQ.0.AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   18 IF (K.EQ.0.AND.MOD(H,2).NE.0) GO TO 91
      GO TO 90
   19 IF (K.EQ.0.AND.MOD(L+H,2).NE.0) GO TO 91
      GO TO 90
   20 IF (K.EQ.0.AND.MOD(L+H,4).NE.0) GO TO 91
      GO TO 90
   21 IF (K.EQ.H.AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   22 IF (K.EQ.-H.AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   23 IF (K.EQ.H.AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   24 IF (ABS(K).EQ.ABS(H).AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   25 IF (ABS(L).EQ.ABS(H).AND.MOD(K,2).NE.0) GO TO 91
      GO TO 90
   26 IF (ABS(L).EQ.ABS(K).AND.MOD(H,2).NE.0) GO TO 91
      GO TO 90
   27 IF (ABS(K).EQ.ABS(H).AND.MOD(2*H+L,4).NE.0) GO TO 91
      GO TO 90
   28 IF (ABS(L).EQ.ABS(H).AND.MOD(2*H+K,4).NE.0) GO TO 91
      GO TO 90
   29 IF (ABS(L).EQ.ABS(K).AND.MOD(2*K+H,4).NE.0) GO TO 91
      GO TO 90
   30 IF (K.EQ.0.AND.L.EQ.0.AND.MOD(H,2).NE.0) GO TO 91
      GO TO 90
   31 IF (K.EQ.0.AND.L.EQ.0.AND.MOD(H,4).NE.0) GO TO 91
      GO TO 90
   32 IF (H.EQ.0.AND.L.EQ.0.AND.MOD(K,2).NE.0) GO TO 91
      GO TO 90
   33 IF (H.EQ.0.AND.L.EQ.0.AND.MOD(K,4).NE.0) GO TO 91
      GO TO 90
   34 IF (H.EQ.0.AND.K.EQ.0.AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   35 IF (H.EQ.0.AND.K.EQ.0.AND.MOD(L,4).NE.0) GO TO 91
      GO TO 90
   36 IF (H.EQ.0.AND.K.EQ.0.AND.MOD(L,2).NE.0) GO TO 91
      GO TO 90
   37 IF (H.EQ.0.AND.K.EQ.0.AND.MOD(L,3).NE.0) GO TO 91
      GO TO 90
   38 IF (H.EQ.0.AND.K.EQ.0.AND.MOD(L,6).NE.0) GO TO 91
   90 CONTINUE
      RETURN
   91 IABSENT=1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE INPUT
C
C READ PROGRAM CONTROL DATA.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),UB(3,3),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7)
      PARAMETER (KMAX=600)
      COMMON /BLOCKS/ NSCALE,SCALEK(KMAX),IFIXED,QMIN,ZMAX
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,IPRINT,JPRINT,JPATH,
     & QLIMIT,ZLIMIT,QPRINT
      COMMON /BLOCK3/ IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,SMIN,SMAX
      DIMENSION CELL(6)
      PARAMETER (JMAX=NMAX/5)
      DIMENSION JI(JMAX),JH(JMAX),JK(JMAX),JL(JMAX)
      EQUIVALENCE (JN,DATA(1)),(JI(1),DATA(2)),(JH(1),DATA(3+JMAX)),
     & (JK(1),DATA(3+2*JMAX)),(JL(1),DATA(3+3*JMAX)),
     & (SMIN1,DATA(3+4*JMAX)),(SMAX1,DATA(4+4*JMAX))
      CHARACTER DIFF*4,HCOND*18,PTGP*5
C
C I/O UNIT NUMBERS
C
      IO1=10
      IO2=20
      IO3=30
      IO4=40
      IO5=50
      ILP=60
      OPEN (UNIT=IO1,STATUS='OLD',FILE='sortav.dat')
      OPEN (UNIT=ILP,STATUS='UNKNOWN',FILE='sortav.lp')
C
C TIME, DATE, AND JOB TITLE
C
      CALL TIME (ATIME)
      CALL DATE (ADATE)
c      ATIME='hh:mm:ss'
c      ADATE='dd-mmm-yy'
      READ (IO1,'(A)') TITLE
      WRITE (ILP,600) ATIME,ADATE,TITLE
  600 FORMAT ('1'/1X,'PROGRAM SORTAV/INPUT.  ',A,', ',A,'.  ',A)
C
C INPUT AND OUTPUT REFLECTION DATA FILE NAMES
C
      READ (IO1,*) NFILE
      IF (NFILE.EQ.0) NFILE=1
      DO I=1,NFILE
        READ (IO1,'(A)') FILE1(I)
      END DO
      READ (IO1,'(A)') FILE2
      WRITE (ILP,601) (FILE1(I),I=1,NFILE)
      WRITE (ILP,602) FILE2
  601 FORMAT (/1X,'INPUT REFLECTION FILE(S):'/(/5X,A))
  602 FORMAT (/1X,'OUTPUT REFLECTION FILE:'//5X,A)
C
C CONDITIONS LIMITING POSSIBLE REFLECTIONS
C
      WRITE (ILP,603)
  603 FORMAT (/1X,'CONDITIONS LIMITING POSSIBLE REFLECTIONS:'/)
      READ (IO1,*) NCOND
      IF (NCOND.EQ.0) THEN
        WRITE (ILP,604)
      ELSE
        DO I=1,NCOND
          READ (IO1,'(A)') HCOND
          WRITE (ILP,605) HCOND
          CALL HKLCOND (HCOND,ICOND(I))
        END DO
      END IF
  604 FORMAT (5X,'NONE')
  605 FORMAT (5X,A)
C
C POINT GROUP
C
      READ (IO1,'(A)') PTGP
      WRITE (ILP,606) PTGP
  606 FORMAT (/1X,'POINT GROUP:'//5X,A)
      CALL DECODE (PTGP,IPTGP)
C
C LATTICE PARAMETERS
C
      READ (IO1,*) CELL
      WRITE (ILP,607) CELL
  607 FORMAT (/1X,'LATTICE PARAMETERS:'//1X,9X,'A',9X,'B',9X,'C',5X,'ALP
     &HA',6X,'BETA',5X,'GAMMA'/1X,3F10.4,3F10.3)
C
C CALCULATE METRIC TENSORS.
C
      CALL METRIC (CELL,G,GINV)
C
C INTENSITY-PROPORTIONAL UNCERTAINTY ESTIMATE, PP, FOR CALCULATING
C RECIPROCAL-VARIANCE WEIGHTS
C
C VAR(YI) = SIGMA(YI)**2 + (PP*YMEAN)**2
C
      PP=0
      READ (IO1,*,END=5) PP
 5    IF (PP.EQ.0) PP=0.01
      IF (PP.LT.0) PP=0
      WRITE (ILP,9006) PP
 9006 FORMAT (//1X,'INTENSITY-PROPORTIONAL UNCERTAINTY ESTIMATE, P, ',
     &'FOR CALCULATING'/1X,'RECIPROCAL-VARIANCE WEIGHTS FOR INTERFRAM',
     &'E SCALING, EMPIRICAL'/1X,'ABSORPTION ANISOTROPY CORRECTION, AND',
     &'/OR EXPERIMENTALLY WEIGHTED DATA'/1X,'AVERAGING:'//1X,'    VAR(',
     &'YI) =  SIGMA(YI)**2 + (P*YMEAN)**2'/1X,'    P       = ',E10.3)
C
C INTER-SUBSET SCALE FACTORS
C
      NSCALE=1
      ISTART=0
      IFIXED=0
      QMIN=0
      ZMAX=0
      READ (IO1,*,END=1) NSCALE,ISTART,IFIXED,QMIN,ZMAX
      IF (QMIN.EQ.0) QMIN=3
      IF (ZMAX.LE.0) ZMAX=4
      IF (NSCALE.LE.0) NSCALE=1
      IF (NSCALE.GT.1) WRITE (ILP,620) NSCALE,QMIN,ZMAX
      IF (ISTART.NE.0) THEN
        DO I=1,NSCALE
          READ (IO1,*) J,SCALEK(J)
        END DO
        WRITE (ILP,621) (I,SCALEK(I),I=1,NSCALE)
      END IF
      IF (IFIXED.NE.0) THEN
        SCALEK(IFIXED)=-SCALEK(IFIXED)
        WRITE (ILP,622) IFIXED
      END IF
 620  FORMAT (//1X,'INTER-SUBSET SCALING VARIABLES:'/1X,'---------------
     &----------------'//1X,'    NSCALE = ',I4/1X,'    QMIN   = ',F7.2/
     &1X,'    ZMAX   = ',F7.2//1X,'DATA WITH'/1X,'  Y/SIGMA(Y) .LT. QMIN
     &'/1X,'WILL BE OMITTED FROM THE SCALE FACTORS FITTING.'//1X,'OUTLIE
     &R MEASUREMENTS WITH'/1X,'  ABS(Y(H,I) - Y(H)/K(I))/SIGMA(Y(H,I)) .
     &GT. ZMAX*MAX(Z, 1.0)'/1X,'WILL BE GIVEN ZERO WEIGHT IN THE SCALE F
     &ACTORS FITTING.')
 621  FORMAT (/1X,'INITIAL RELATIVE SCALE FACTORS FOR SUBSETS OF THE DAT
     &A SET:'//1X,'    I   SCALEK(I)'/1X,'    -   ---------'/(1X,I5,2X,
     &F10.5))
 622  FORMAT (//1X,'THE VALUE OF SCALE FACTOR NUMBER I = ',I2,' WILL B',
     &'E HELD FIXED.'/1X,'                                 ------')
 1    CONTINUE
C
C ABSORPTION CORRECTION VARIABLES
C
      L0MAX=0
      L1MAX=0
      DIFF='    '
      IORIENT=0
      DO I=1,3
      DO J=1,3
        UB(I,J)=0
      END DO
      END DO
      FLAMBDA=0
      FMU=0
      RADIUS=0
      TMIN=0
      TMAX=0
      ERRMUT=0
      WA=0
      UMIN=0
      FSQMIN=0
      FSQMAX=0
      STLMIN=0
      STLMAX=0
      AIMIN=0
      AIMAX=0
      IPATH=0
      IPLOT=0
      READ (IO1,*,END=2) L0MAX,L1MAX
      IF (L0MAX.LT.0) L0MAX=0
      IF (L1MAX.LT.0) L1MAX=0
      IF (L0MAX.EQ.0.AND.L1MAX.EQ.0) GO TO 2
      IF (L0MAX.GT.8) L0MAX=8
      IF (L1MAX.GT.7) L1MAX=7
      READ (IO1,'(A)',END=3) DIFF
      READ (IO1,*,END=3) IORIENT
      IF (IORIENT.NE.0) THEN
        READ (IO1,*) ((UB(I,J),J=1,3),I=1,3)
        IF (UB(1,1).EQ.0) THEN
C
C FORM THE BUSING-LEVY RECIPROCAL SPACE ORTHOGONALIZATION MATRIX.
C
          UB(1,1)= SQRT(GINV(1,1))
          UB(1,2)= GINV(1,2)/SQRT(GINV(1,1))
          UB(1,3)= GINV(1,3)/SQRT(GINV(1,1))
          UB(2,1)= 0
          UB(2,2)= SQRT(GINV(2,2))*
     &              SIN(ACOS(GINV(1,2)/SQRT(GINV(1,1)*GINV(2,2))))
          UB(2,3)=-SQRT(GINV(3,3))*
     &              SIN(ACOS(GINV(1,3)/SQRT(GINV(1,1)*GINV(3,3))))*
     &                G(2,3)/SQRT(G(2,2)*G(3,3))
          UB(3,1)= 0
          UB(3,2)= 0
          UB(3,3)= 1/SQRT(G(3,3))
C
C TRANSPOSE TO FORM A HAMILTON ORIENTATION MATRIX.
C
          DO I=1,3-1
          DO J=I+1,3
            T=UB(I,J)
            UB(I,J)=UB(J,I)
            UB(J,I)=T
          END DO
          END DO
          DIFF='H   '
        END IF
      END IF
      READ (IO1,*,END=3) FLAMBDA,FMU,RADIUS,TMIN,TMAX,ERRMUT,WA,UMIN
      READ (IO1,*,END=3) FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,
     & IPATH,IPLOT
 3    IDIFF=0
      IF (DIFF.EQ.'H   ') IDIFF=1
      IF (DIFF.EQ.'BL  ') IDIFF=2
      IF (DIFF.EQ.'P3  ') IDIFF=3
      IF (DIFF.EQ.'CAD4') IDIFF=4
      IF (IDIFF.EQ.0) STOP 'UNKNOWN DIFFRACTOMETER TYPE'
      IF (FLAMBDA.LE.0) STOP 'UNKNOWN WAVELENGTH'
      IF (WA.EQ.0) WA=1
      IF (WA.LT.0) WA=0
      IF (UMIN.EQ.0) UMIN=0.5E-12
      IF (UMIN.LT.0) UMIN=0
      IF (FSQMIN.EQ.0) FSQMIN=3
      IF (FSQMAX.LE.0) FSQMAX=1E10
      IF (STLMIN.LT.0) STLMIN=0
      IF (STLMAX.LE.0) STLMAX=9
      IF (AIMIN.EQ.0.AND.AIMAX.EQ.0) THEN
        IF (FMU.GT.0.AND.TMIN.GT.0.AND.TMAX.GT.TMIN) THEN
          AIMIN=EXP(-FMU*TMAX)
          AIMAX=EXP(-FMU*TMIN)
        ELSE
          AIMIN=0.5
          AIMAX=1.5
        END IF
      END IF
      IF (AIMIN.GE.0.AND.AIMAX.GT.AIMIN) THEN
        AMEAN=0.5*(AIMIN+AIMAX)
        AIMIN=AIMIN/AMEAN
        AIMAX=AIMAX/AMEAN
      END IF
      IF (AIMIN.LT.0) AIMIN=0
      IF (AIMAX.LT.0) AIMAX=1E10
      IF (IPATH.LT.0) IPATH=0
      IF (IPATH.GT.1) IPATH=1
      IF (IPLOT.EQ.0) IPLOT=1
      IF (IPLOT.GT.3) IPLOT=3
      IF (IPLOT.LT.0) IPLOT=-1
      WRITE (ILP,610) L0MAX,L1MAX,DIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,WA,UMIN
      WRITE (ILP,611) FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX
      WRITE (ILP,612) IPATH,IPLOT
      IF (FMU.EQ.0) THEN
        WRITE (ILP,613)
      ELSE IF (RADIUS.EQ.0.AND.TMIN.EQ.0) THEN
        WRITE (ILP,614)
      ELSE IF (RADIUS.EQ.0.AND.TMIN.GT.0) THEN
        WRITE (ILP,615)
      END IF
      IF (IORIENT.NE.0) THEN
        IF (DIFF.NE.'H   ') THEN
          WRITE (ILP,619) DIFF,((UB(I,J),J=1,3),I=1,3)
          CALL UDTOUH (DIFF,UB)
          IDIFF=1
        END IF
        WRITE (ILP,619) DIFF,((UB(I,J),J=1,3),I=1,3)
      END IF
 610  FORMAT (/'0ABSORPTION CORRECTION VARIABLES:'/' -------------------
     &-------------'/'0    L0MAX  = ',I2,
     &10X,'             EVEN ORDER LIMIT OF SPHERICAL HARMONIC EXPANSION
     &     Y(L,M); L = 0, LMAX; M = -L, +L'/'     L1MAX  = ',I2,10X,
     &'             ODD ORDER LIMIT '/'     DIFF   =  ',A4,8X,
     &'            DIFFRACTOMETER TYPE'/'     LAMBDA = ',F8.5,' ANGSTROM
     &        WAVELENGTH'/'     MU     = ',E10.3,' MM**-1        LINEA',
     &'R ABSORPTION COEFFICIENT'/'     RADIUS = ',E10.3,' MM          ',
     &'  ESTIMATED RADIUS OF "EQUIVALENT" SPHERICAL CRYSTAL'/'     TMI',
     &'N   = ',E10.3,' MM            ESTIMATED MINIMUM CRYSTAL THICKNESS
     &'/'     TMAX   = ',E10.3,' MM            ESTIMATED MAXIMUM CRYSTAL
     & THICKNESS'/'     ERRMUT = ',E10.3,'               ESTIMATED FRACT
     &IONAL ERROR IN MU*TBAR'/'     WA     = ',E10.3,'               REL
     &ATIVE WEIGHTING FACTOR FOR THE  <AHI> = 1  ABSORPTION ANISOTROPY R
     &ESTRAINT RESIDUAL'/'     UMIN   = ',E10.3,'               EIGENVAL
     &UE FILTERING FACTOR')
 611  FORMAT ('     FSQMIN = ',F5.2,'                    MINIMUM FSQ/SIG
     &MA(FSQ) FOR MEASUREMENTS USED FOR YLM FIT'/'     FSQMAX = ',E10.3,
     &'               MAXIMUM FSQ FOR MEASUREMENTS USED FOR YLM FIT'/
     &'     STLMIN = ',F5.2,' ANGSTROM**-1       MINIMUM SIN(THETA)/LAMB
     &DA FOR REFLECTIONS USED FOR YLM FIT'/'     STLMAX = ',F5.2,' ANGST
     &ROM**-1       MAXIMUM SIN(THETA)/LAMBDA FOR REFLECTIONS USED FOR Y
     &LM FIT'/'     AMIN   = ',E10.3,'               MINIMUM EXPECTED RE
     &LATIVE TRANSMISSION FACTOR'/'     AMAX   = ',E10.3,
     &'               MAXIMUM EXPECTED RELATIVE TRANSMISSION FACTOR')
 612  FORMAT ('     IPATH  = ',I2/'     IPLOT  = ',I2/'0    IF IPATH .EQ
     &. 0, DO NOT;'/'     IF IPATH .EQ. 1, DO WRITE ESTIMATED TBAR AND B
     &EAM DIRECTION VECTORS TO THE OUTPUT REFLECTION FILE.'/'0    IF IPL
     &OT .EQ. 1, PLOT [100], [010], AND [001] PSI-SCAN SECTIONS THROUG',
     &'H FITTED TRANSMISSION SURFACE.'/'     IF IPLOT .EQ. 2, ALSO [110]
     &, [-110], [101], [-101], [011], AND [0-11].'/'     IF IPLOT .EQ. 3
     &, ALSO [111], [-111], [-1-11], AND [1-11].')
 613  FORMAT ('0    FMU = 0.  ONLY TRANSMISSION ANISOTROPY FACTORS, 0 ',
     &'< A < AMAX, AMEAN APPROXIMATELY 1, WILL BE CALCULATED.')
 614  FORMAT ('0    RADIUS = 0 AND TMIN = 0.  ONLY TRANSMISSION ANISOTRO
     &PY FACTORS, 1 - X < A < 1 + X, <A> = 1,  WILL BE CALCULATED.')
 615  FORMAT ('0    IF RADIUS .EQ. 0, AND TMIN .GT. 0, RADIUS WILL BE ES
     &TIMATED FROM'/'     A(SPHERE) = A(LIMIT)/A(MAX),'/'     WHERE A(LI
     &MIT) = EXP(-MU*TMIN),'/'     AND A(MAX) IS THE MAXIMUM TRANSMISSIO
     &N ANISOTROPY FACTOR FROM THE YLM FITTING.')
 619  FORMAT (/1X,
     &'    ORIENTATION MATRIX FOR DIFFRACTOMETER TYPE ',A/1X,
     &'    ( UB(1,1) UB(1,2) UB(1,3) )   (',3E12.4,' )'/1X,
     &'    ( UB(2,1) UB(2,2) UB(2,3) ) = (',3E12.4,' )'/1X,
     &'    ( UB(3,1) UB(3,2) UB(3,3) )   (',3E12.4,' )')
 2    CONTINUE
C
C DATA AVERAGING AND INPUT/OUTPUT CONTROL VARIABLES
C
      IW=0
      JW=0
      ZZMAX=0
      QQ=0
      RR=0
      C1=0
      C2=0
      C3=0
      C4=0
      QLIMIT=0
      ZLIMIT=0
      IPRINT=0
      JPRINT=0
      JPATH=0
      QPRINT=0
      SMIN1=0
      SMAX1=0
      JN=0
C
C DATA AVERAGING VARIABLES
C
      READ (IO1,*,END=9) IW,JW,ZZMAX
      READ (IO1,*,END=9) QQ,RR,C1,C2,C3,C4
C
C OUTPUT CONTROL VARIABLES
C
      READ (IO1,*,END=9) QLIMIT,ZLIMIT,IPRINT,JPRINT,JPATH,QPRINT
C
C INPUT CONTROL VARIABLES      
C
      READ (IO1,*,END=9) SMIN1,SMAX1
C
C MEASUREMENTS TO BE REJECTED ON INPUT
C
      DO J=1,JMAX
        READ (IO1,*,END=9) JI(J),JH(J),JK(J),JL(J)
        JN=JN+1
      END DO
 9    CLOSE (UNIT=IO1,STATUS='KEEP')
C
C SET DEFAULT VALUES AND ECHO DATA AVERAGING VARIABLES.
C
      IF (IW.LT.0) IW=0
      IF (IW.GT.1) IW=1
      IF (JW.EQ.0) JW=2
      IF (JW.LT.0) JW=0
      IF (JW.GT.2) JW=2
      IF (JW.NE.2) ZZMAX=0
      IF (JW.EQ.2.AND.ZZMAX.LE.0) ZZMAX=6
      WRITE (ILP,630) IW,JW,ZZMAX
      IF (QQ.LT.0) QQ=0
      IF (RR.LT.0) RR=0
      IF (PP.EQ.0.AND.QQ.EQ.0) RR=0
      IF (RR.GT.0) WRITE (ILP,660) PP,QQ,RR
      IF (C1.GT.0.OR.C2.GT.0.OR.C3.GT.0.OR.C4.GT.0) WRITE (ILP,661) C1,
     & C2,C3,C4
 630  FORMAT (//1X,'EQUIVALENT DATA AVERAGING VARIABLES:'/1X,'----------
     &--------------------------'//1X,'    IW   = ',I2/1X,'    JW   = ',
     &I2/1X,'    ZMAX = ',F4.1//1X,'AVERAGING FORMULAE:'/1X,'  YMEAN = S
     &UM(W*Y)/SUM(W)'/1X,'  ESD   = SQRT{SUM[W*SIGMA(Y)**2]/SUM(W)}'
     &/1X,'  RMSD  = SQRT{[N/(N - 1)]*SUM[W*(Y - YMEAN)]/SUM(W)}'/1X,'WE
     &IGHTS FOR AVERAGING:'/1X,'  W = WI*WJ'/1X,'WHERE'/1X,'  IF IW = 0,
     &  WI = 1'/1X,'  IF IW = 1,  WI = 1/SIGMA(Y)**2'/1X,'  IF JW = 0,',
     &'  WJ = 1'/1X,'  IF JW = 1,  WJ = EXP(-0.5*Z**2)'/1X,'  IF JW = 2,
     &  WJ = [1 - (Z/ZMAX)**2]**2,  IF ABS(Z) .LT. ZMAX'/1X,
     &'                 = 0,                     IF ABS(Z) .GE. ZMAX'/
     &1X,'  Z = [Y - MEDIAN(Y)]/SIGMA'/1X,'  IF IW = 0,  SIGMA = MAX(MED
     &IAN[SIGMA(Y)], MEDIAN{ABS[Y - MEDIAN(Y)]}*SQRT[N/(N - 1)])'/1X,
     &'  IF IW = 1,  SIGMA = SIGMA(Y)')
 660  FORMAT (//1X,'    P = ',F5.3/1X,'    Q = ',F5.3/1X,'    R = ',F5.3
     &//1X,'ABNORMALLY LOW OUTLIER MEASUREMENTS YI WILL BE REJECTED IF'/
     &1X,'  YI .LT. YMAX - 2*R*SQRT((Q*SIGMA(YMAX))**2 + (P*YMAX)**2),'/
     &1X,'WHERE YMAX = MAX(YI).'//1X,'FOR NORMALLY DISTRIBUTED YI, THE I
     &NTERVAL FROM'/1X,'  YMIN = MU - Z*SIGMA'/1X,'TO'/1X,'  YMAX = MU +
     & Z*SIGMA'/1X,'INCLUDES MORE THAN 99.99% OF THE DISTRIBUTION IF Z =
     & 4.')
 661  FORMAT (//1X,'    C1 = ',F5.3/1X,'    C2 = ',F5.3/1X,'    C3 = ',
     &F5.3/1X,'    C4 = ',F5.3//1X,'OUTLIER MEASUREMENTS YI WILL BE REJE
     &CTED BEFORE AVERAGING IF'/1X,'  ABS(YI - MEDIAN(YI)) .GT. TEST,'/
     &1X,'WHERE'/1X,'  TEST  = MAX(C1*MEDIAN(YI),'/1X,'                C
     &2*MEDIAN(SIGMA(YI)),'/1X,'                  C3*MEDIAN(ABS(YI - MED
     &IAN(YI)))*SQRT(N/(N - 1)),'/1X,'                    C4*ZCRIT(N)*MA
     &X(MEDIAN(SIGMA(YI)),'/1X,'                      MEDIAN(ABS(YI - ME
     &DIAN(YI)))*SQRT(N/(N - 1)))'/1X,'AND ZCRIT IS THE VALUE OF Z = ABS
     &(DELTA)/SIGMA CORRESPONDING TO A NORMAL PROBABILITY P = 1/(2*N) TH
     &AT Z > ZCRIT.')
C
C ECHO OUTPUT CONTROL VARIABLES.
C
      IF (QLIMIT.LE.0) QLIMIT=4
      IF (ZLIMIT.LE.0) ZLIMIT=4
      WRITE (ILP,645) QLIMIT,ZLIMIT
      WRITE (ILP,650)
      IF (IPRINT.LT.0) WRITE (ILP,651)
      IF (IPRINT.GE.0) WRITE (ILP,652)
      IF (IPRINT.GE.1) WRITE (ILP,653)
      IF (IPRINT.EQ.2) WRITE (ILP,654)
      IF (JPRINT.GT.0) WRITE (ILP,655) JPRINT
      IF (JPATH.EQ.0) JPATH=IPATH
      IF (JPATH.NE.0)  WRITE (ILP,656)
      IF (QPRINT.EQ.0) QPRINT=3
      WRITE (ILP,657) QPRINT
 645  FORMAT (//1X,'THRESHOLD VALUES FOR LISTING OUTLIER MEASUREMENTS:'/
     &1X,'--------------------------------------------------'/1X,'    RM
     &SD/ESD            .GT. QLIMIT = ',F5.2/1X,'    ABS(YI - YMEAN)/ESD
     & .GT. ZLIMIT = ',F5.2)
 650  FORMAT (//1X,'PRINTED REFLECTIONS LIST:'/1X,'---------------------
     &----')
 651  FORMAT (/1X,'NO REFLECTIONS LIST')
 652  FORMAT (/1X,'LIST DISCORDANT MEASUREMENT SAMPLES WITH:'/1X,
     &'(1) ONE OR MORE REJECTED MEASUREMENTS OR'/1X,
     &'(2) RMSD/ESD           .GT. QLIMIT'/1X,
     &'    AND ONE OR MORE MEASUREMENTS WITH'/1X,
     &'    ABS(Y - YMEAN)/ESD .GT. ZLIMIT.')
 653  FORMAT (/1X,'ALSO LIST SPECIAL AXIAL REFLECTIONS'/' H00, 0K0, 00L,
     & HH0, H0H, 0KK, AND HHH.')
 654  FORMAT (/1X,'ALSO LIST SPECIAL ZONAL REFLECTIONS'/' HK0, H0L, 0KL,
     & HKK, HKH, AND HHL.')
 655  FORMAT (/1X,'ALSO LIST EVERY N-TH REFLECTION, WHERE N = ',I6)
 656  FORMAT (/1X,'(AVERAGED) TBAR AND S0 AND S1 COMPONENTS WILL BE WRIT
     &TEN TO THE OUTPUT REFLECTION FILE.')
 657  FORMAT (/1X,'COMPILE SIN(THETA)/LAMBDA DISTRIBUTION STATISTICS FOR
     & VALUES OF'/1X,'    YMEAN/MAX(ESD, RMSD) .GE. QPRINT = ',F5.2)
C
C ECHO INPUT SIN(THETA)/LAMBDA LIMITS.
C
      IF (SMIN1.GE.0.AND.SMAX1.GT.SMIN1) WRITE (ILP,640) SMIN1,SMAX1
 640  FORMAT(//1X,'ONLY MEASUREMENTS WITH S = SIN(THETA)/LAMBDA VALUES B
     &ETWEEN THE LIMITS,'/1X,'SMIN1 AND SMAX1, WILL BE PROCESSED.'//1X,
     &'    SMIN1   = ',F6.3/'     SMAX1   = ',F6.3)
      IF (SMIN1.LT.0) SMIN1=0
      IF (SMAX1.LE.0) SMAX1=9
C
C ECHO MEASUREMENTS TO BE REJECTED ON INPUT.
C
      IF (JN.GT.0) THEN
        WRITE (ILP,600) ATIME,ADATE,TITLE
        WRITE (ILP,670)
        WRITE (ILP,671) (JI(J),JH(J),JK(J),JL(J),J=1,JN)
      END IF
 670  FORMAT (/1X,'MEASUREMENTS TO BE REJECTED FROM THE INPUT DATA:'//
     & 5(' SER.NO.   H   K   L    ')/5(' -------   -   -   -    '))
 671  FORMAT (5(I8,3I4,4X)) 
      RETURN
      END
C------------------------------------------------------------------------
      SUBROUTINE JACOBI (N,M,A,U,V,NROT)
C
C EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC MATRIX A OF LOGICAL
C SIZE A(N,N) STORED IN AN ARRAY OF PHYSICAL SIZE A(M,M), WHERE
C M .GE. N.
C
C ON OUTPUT:
C (1) ELEMENTS OF A ABOVE THE DIAGONAL ARE DESTROYED.
C (2) THE ARRAY U(M) RETURNS THE EIGENVALUES OF A(N,N) IN ITS FIRST N
C     ELEMENTS.
C (3) THE COLUMNS OF THE MATRIX V(N,N), STORED IN THE ARRAY V(M,M),
C     CONTAIN THE EIGENVECTORS OF A.
C (4) THE VARIABLE NROT RETURNS THE NUMBER OF ITERATIONS OF JACOBI
C     ROTATION THAT WERE REQUIRED TO ANNIHILATE THE OFF-DIAGONAL
C     ELEMENTS OF A(N,N) TO MACHINE PRECISION.
C
C FORTRAN CODE ADAPTED FROM WILLIAM H. PRESS, BRIAN P. FLANNERY, SAUL A.
C TEUKOLSKY, AND WILLIAM T. VETTERLING (1986).  NUMERICAL RECIPIES:  THE
C                                               --------- --------   ---
C ART OF SCIENTIFIC COMPUTING, PP. 335-349.  CAMBRIDGE, ENGLAND:
C --- -- ---------- ---------
C CAMBRIDGE UNIVERSITY PRESS.
C
      PARAMETER (NMAX=999)
      DIMENSION A(M,M),U(M),V(M,M),B(NMAX),Z(NMAX)
      DOUBLE PRECISION A,U,V,B,Z,T,THRESH,E,AII,AJJ,THETA,C,S,TAU,P,Q
C
C INITIALIZE EIGENVECTORS MATRIX TO AN IDENTITY MATRIX.
C
      DO I=1,N
      DO J=1,N
        V(I,J)=0
      END DO
        V(I,I)=1
      END DO
C
C INITIALIZE EIGENVALUES U AND WORK VECTOR B TO A(I,I) AND ZERO WORK
C VECTOR Z.
C
      DO I=1,N
        T=A(I,I)
        U(I)=T
        B(I)=T
        Z(I)=0
      END DO
C
C PERFORM UP TO 50 ITERATIONS OF UP TO N*(N - 1)/2 JACOBI ROTATIONS.
C
      NROT=0
      NCYCLE=1
      DO WHILE (NCYCLE.LE.50)
C
C TEST FOR NORMAL RETURN WHEN MAXIMUM MAGNITUDE OF AN OFF-DIAGONAL
C ELEMENT EQUALS ZERO TO MACHINE PRECISION.  THE TEST PRESUMES THAT
C ARITHMETIC UNDERFLOW VALUES ARE SET TO ZERO.
C
        T=0
        DO I=1,N-1
        DO J=I+1,N
          T=T+ABS(A(I,J))
        END DO
        END DO
        IF (T.EQ.0) RETURN
C
C SET OFF-DIAGONAL THRESHOLD.
C
        IF (NCYCLE.LT.4) THEN
          THRESH=T/(5*N**2)
        ELSE
          THRESH=0
        END IF
C
C ROTATE TO ANNIHILATE OFF-DIAGONAL ELEMENTS.
C
        DO I=1,N-1
        DO J=I+1,N
          T=ABS(A(I,J))
          E=100*T
          AII=ABS(U(I))
          AJJ=ABS(U(J))
          IF (NCYCLE.GT.4.AND.AII+E.EQ.AII.AND.AJJ+E.EQ.AJJ) THEN
C
C AFTER FOUR CYCLES, SKIP THE ROTATION IF ABS(A(I,J)) IS SMALL COMPARED
C TO BOTH ABS(A(I,I)) AND ABS(A(J,J)).
C
            A(I,J)=0
          ELSE IF (T.GT.THRESH) THEN
            T=ABS(AJJ-AII)
            IF (T+E.EQ.T) THEN
C
C EFFECTIVELY, SET T = 1/(2*THETA)
C
              T=A(I,J)/(AJJ-AII)
            ELSE
              THETA=(AJJ-AII)/(2*A(I,J))
              T=1/(ABS(THETA)+SQRT(1+THETA**2))
              IF (THETA.LT.0) T=-T
            END IF
            C=1/SQRT(1+T**2)
            S=T*C
            TAU=S/(1+C)
C
C ADJUST EIGENVALUES U AND WORK VECTOR Z.
C
            E=T*A(I,J)
            Z(I)=Z(I)-E
            Z(J)=Z(J)+E
            U(I)=U(I)-E
            U(J)=U(J)+E
            A(I,J)=0
C
C ROTATIONS  1 .LE. K .LT. I.
C
            DO K=1,I-1
              P=A(K,I)
              Q=A(K,J)
              A(K,I)=P-S*(Q+P*TAU)
              A(K,J)=Q+S*(P-Q*TAU)
            END DO
C
C ROTATIONS  I .LT. K .LT. J.
C
            DO K=I+1,J-1
              P=A(I,K)
              Q=A(K,J)
              A(I,K)=P-S*(Q+P*TAU)
              A(K,J)=Q+S*(P-Q*TAU)
            END DO
C
C ROTATIONS  J .LT. K .LE. N.
C
            DO K=J+1,N
              P=A(I,K)
              Q=A(J,K)
              A(I,K)=P-S*(Q+P*TAU)
              A(J,K)=Q+S*(P-Q*TAU)
            END DO
C
C COMPUTE AND STORE EIGENVECTORS.
C
            DO K=1,N
              P=V(K,I)
              Q=V(K,J)
              V(K,I)=P-S*(Q+P*TAU)
              V(K,J)=Q+S*(P-Q*TAU)
            END DO
            NROT=NROT+1
          END IF
        END DO
        END DO
C
C ADJUST EIGENVALUES AND WORK VECTORS.
C
        DO I=1,N
          B(I)=B(I)+Z(I)
          U(I)=B(I)
          Z(I)=0
        END DO
        NCYCLE=NCYCLE+1
      END DO
      STOP '50 CYCLES OF JACOBI ROTATIONS SHOULD NEVER BE NECESSARY.'
      END
C-----------------------------------------------------------------------
      SUBROUTINE LIMITS (IPTGP,SMAX,GINV,IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,
     & ILMAX)
      DIMENSION GINV(3,3)
      SLIMIT=SMAX/COS(3.141593/6)
      MH=0
      S=0
      DO WHILE (S.LE.SLIMIT)
        MH=MH+1
        S=SINTHL(MH,0,0,GINV)
      END DO
      MK=0
      S=0
      DO WHILE (S.LE.SLIMIT)
        MK=MK+1
        S=SINTHL(0,MK,0,GINV)
      END DO
      ML=0
      S=0
      DO WHILE (S.LE.SLIMIT)
        ML=ML+1
        S=SINTHL(0,0,ML,GINV)
      END DO
      IHMIN=0
      IKMIN=0
      ILMIN=0
      IHMAX=0
      IKMAX=0
      ILMAX=0
      DO J=-3,+3
      DO K=-3,+3
      DO L=-3,+3
        IH=J
        IK=K
        IL=L
        CALL EQUIV (IPTGP,IH,IK,IL)
        IHMIN=MIN(IHMIN,IH)
        IKMIN=MIN(IKMIN,IK)
        ILMIN=MIN(ILMIN,IL)
        IHMAX=MAX(IHMAX,IH)
        IKMAX=MAX(IKMAX,IK)
        ILMAX=MAX(ILMAX,IL)
      END DO
      END DO
      END DO
      IF (IHMIN.LT.0) IHMIN=-MH
      IF (IKMIN.LT.0) IKMIN=-MK
      IF (ILMIN.LT.0) ILMIN=-ML
      IF (IHMAX.GT.0) IHMAX=+MH
      IF (IKMAX.GT.0) IKMAX=+MK
      IF (ILMAX.GT.0) ILMAX=+ML
      RETURN
      END
C------------------------------------------------------------------------
      SUBROUTINE MATINV (N,M,A,D)
C
C INVERT A SQUARE MATRIX BY GAUSS-JORDAN ELIMINATION, AND CALCULATE ITS
C DETERMINANT.
C
C A - INPUT MATRIX, WHICH IS REPLACED BY ITS INVERSE
C N - ORDER OF MATRIX
C   - LOGICAL SIZE OF ARRAY A
C M - PHYSICAL SIZE OF ARRAY A, M .GE. N
C D - DETERMINANT OF THE INPUT MATRIX
C
C RETURNS D = 0 TO FLAG A SINGULAR MATRIX.
C
C MATRIX IS SCALED TO AVOID ARITHMETIC OVERFLOW OR UNDERFLOW DURING
C INVERSION.
C
C MATRIX SCALING USES A DIAGONAL MATRIX Q WITH
C
C Q(I,I) = 1/SQRT(ABS(A(I,I))).
C
C FORM B = Q*A*Q,
C
C B(I,J) = Q(I,I)*A(I,J)*Q(J,J),
C
C AND INVERT B TO OBTAIN B**(-1).  THEN,
C
C   B**(-1)   = (Q*A*Q)**(-1)
C             = (A*Q)**(-1)*Q**(-1)
C   B**(-1)*Q = Q**(-1)*A**(-1)
C Q*B**(-1)*Q = A**(-1)
C
C IN ADDITION,
C
C DET(A) = DET(B)/PROD(I=1,N) Q(I,I)**2
C
C IF N EXCEEDS MAXN, THE WORK VECTORS Q, IK, AND JK MUST BE RE-
C DIMENSIONED TO A LENGTH OF N.
C
      PARAMETER (MAXN=600)
      DIMENSION A(M,M),Q(MAXN),IK(MAXN),JK(MAXN)
      DOUBLE PRECISION A,Q,AMAX,T
C
C STORE RECIPROCAL SQUARE-ROOT DIAGONAL MAGNITUDES FOR SCALING.
C
      DO I=1,N
        T=SQRT(ABS(A(I,I)))
        IF (T.EQ.0) THEN
          D=0
          RETURN
        ELSE
          Q(I)=1/T
        END IF
      END DO
C
C SCALE MATRIX.
C
      DO I=1,N
      DO J=1,N
        A(I,J)=A(I,J)*Q(I)*Q(J)
      END DO
      END DO
C
C INVERT SCALED MATRIX AND CALCULATE ITS DETERMINANT.
C
      D=1
      DO K=1,N
C
C FIND LARGEST ELEMENT A(I,J) IN REST OF MATRIX.
C
        AMAX=0
        DO I=K,N
        DO J=K,N
          IF (ABS(A(I,J)).GT.ABS(AMAX)) THEN
            AMAX=A(I,J)
            IK(K)=I
            JK(K)=J
          END IF
        END DO
        END DO
        D=D*AMAX
        IF (D.EQ.0) RETURN
C
C INTERCHANGE ROWS AND COLUMNS TO PUT AMAX IN A(K,K).
C
        I=IK(K)
        IF (I.GT.K) THEN
          DO J=1,N
            T=A(K,J)
            A(K,J)=A(I,J)
            A(I,J)=-T
          END DO
        END IF
        J=JK(K)
        IF (J.GT.K) THEN
          DO I=1,N
            T=A(I,K)
            A(I,K)=A(I,J)
            A(I,J)=-T
          END DO
        END IF
C
C ACCUMULATE ELEMENTS OF INVERSE MATRIX.
C
        DO I=1,N
          IF (I.NE.K) A(I,K)=-A(I,K)/AMAX
        END DO
        DO I=1,N
        DO J=1,N
          IF (I.NE.K.AND.J.NE.K) A(I,J)=A(I,J)+A(I,K)*A(K,J)
        END DO
        END DO
        DO J=1,N
          IF (J.NE.K) A(K,J)=+A(K,J)/AMAX
        END DO
        A(K,K)=1/AMAX
      END DO
C
C RESTORE ORDERING OF MATRIX.
C
      DO K=N,1,-1
        J=IK(K)
        IF (J.GT.K) THEN
          DO I=1,N
            T=A(I,K)
            A(I,K)=-A(I,J)
            A(I,J)=T
          END DO
        END IF
        I=JK(K)
        IF (I.GT.K) THEN
          DO J=1,N
            T=A(K,J)
            A(K,J)=-A(I,J)
            A(I,J)=T
          END DO
        END IF
      END DO
C
C SCALE INVERSE MATRIX.
C
      DO I=1,N
      DO J=1,N
        A(I,J)=A(I,J)*Q(I)*Q(J)
      END DO
      END DO
C
C SCALE DETERMINANT, IF POSSIBLE.
C
      T=0
      DO I=1,N
        T=T+LOG(Q(I))
      END DO
      T=LOG(ABS(D))-2*T
C
C TEST AGAINST RANGE OF MACHINE ALLOWED MAGNITUDES.
C
C EIGHT-BIT EXPONENT HAS MAXIMUM MAGNITUDE 2**7 = 128.
C XMIN = 2**(-128)     = 0.29E-38      LOG(XMIN) = -88.7
C XMAX = (2**(+128))/2 = 1.70E+38      LOG(XMAX) = +88.0
C
      IF (-87.LT.T.AND.T.LT.+87) D=(D/ABS(D))*EXP(T)
      RETURN
      END
C-----------------------------------------------------------------------
      REAL FUNCTION MEDIAN(N,X)
      PARAMETER (NMAX=1000)
      DIMENSION X(N),INDEX(NMAX)
      CALL SORT (N,X,INDEX)
      M=N/2
      IF (MOD(N,2).EQ.0) THEN
        MEDIAN=0.5*(X(INDEX(M))+X(INDEX(M+1)))
      ELSE
        MEDIAN=X(INDEX(M+1))
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE METRIC (A,GA,GB)
C
C CALCULATE RECIPROCAL LATTICE PARAMETERS AND DIRECT AND RECIPROCAL
C LATTICE METRIC TENSORS FROM DIRECT LATTICE PARAMETERS.
C
      DIMENSION A(6),B(6),GA(3,3),GB(3,3)
      PI=ACOS(-1.0)
      RAD=PI/180
      DEG=180/PI
      CA=COS(A(4)*RAD)
      CB=COS(A(5)*RAD)
      CG=COS(A(6)*RAD)
      SA=SIN(A(4)*RAD)
      SB=SIN(A(5)*RAD)
      SG=SIN(A(6)*RAD)
      V=A(1)*A(2)*A(3)*SQRT(1-CA**2-CB**2-CG**2+2*CA*CB*CG)
      B(1)=A(2)*A(3)*SA/V
      B(2)=A(1)*A(3)*SB/V
      B(3)=A(1)*A(2)*SG/V
      B(4)=(CB*CG-CA)/(SB*SG)
      B(5)=(CA*CG-CB)/(SA*SG)
      B(6)=(CA*CB-CG)/(SA*SB)
      GA(1,1)=A(1)*A(1)
      GA(1,2)=A(1)*A(2)*CG
      GA(1,3)=A(1)*A(3)*CB
      GA(2,1)=GA(1,2)
      GA(2,2)=A(2)*A(2)
      GA(2,3)=A(2)*A(3)*CA
      GA(3,1)=GA(1,3)
      GA(3,2)=GA(2,3)
      GA(3,3)=A(3)*A(3)
      GB(1,1)=B(1)*B(1)
      GB(1,2)=B(1)*B(2)*B(6)
      GB(1,3)=B(1)*B(3)*B(5)
      GB(2,1)=GB(1,2)
      GB(2,2)=B(2)*B(2)
      GB(2,3)=B(2)*B(3)*B(4)
      GB(3,1)=GB(1,3)
      GB(3,2)=GB(2,3)
      GB(3,3)=B(3)*B(3)
      B(4)=ACOS(B(4))*DEG
      B(5)=ACOS(B(5))*DEG
      B(6)=ACOS(B(6))*DEG
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE OUTPUT
C
C COMPILE AND PRINT DISTRIBUTION STATISTICS FOR UNIQUE DATA IN CLASSES
C OF Q = Y/SIGMA(Y) AND S = SIN(THETA)/LAMBDA.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,IPRINT,JPRINT,JPATH,
     & QLIMIT,ZLIMIT,QPRINT
      COMMON /BLOCK3/ IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,SMIN,SMAX
      PARAMETER (M1=17,M2=15,M3=20)
      COMMON /BLOCK4/ X1(M1),X2(M2),X3(M3)
      DIMENSION       Y1(M1),Y2(M2),Y3(M3)
      DIMENSION       N1(M1),N2(M2),N3(M3)
      DATA Y1,Y2,Y3 /M1*0,M2*0,M3*0/
      DATA N1,N2,N3 /M1*0,M2*0,M3*0/
      DIMENSION NI(M3),AS(M3),AY(M3),ASIGY(M3),AYSIG(M3),FSIG(M3)
      DIMENSION S0(3),S1(3)
      DATA TBAR,S0,S1 /7*0/
      DIMENSION NDATA(100),XDATA(100),YDATA(100),YPP(100)
      EQUIVALENCE (NDATA(1),DATA(1)),(XDATA(1),DATA(101)),
     & (YDATA(1),DATA(201)),(YPP(1),DATA(301))
      DIMENSION INDEX(NMAX/2)
      EQUIVALENCE (INDEX(1),DATA(1+NMAX/2))
      CUTOFF=QPRINT
      NTOTAL=0
      NQ0=0
      NQ1=0
      NQ2=0
      NQ3=0
      NQ4=0
      NQ6=0
      ITYPE=JPATH
      REWIND IO1
      IEND=0
 11   CALL READ2 (IO1,ITYPE,IEND,IH,IK,IL,Y,SIGY,RMSD,NMEAS,TBAR,S0,S1)
      IF (IEND.NE.0) GO TO 19
      IF (SIGY.LE.0) GO TO 11
      NTOTAL=NTOTAL+1
      Q=Y/SIGY
      IF (Q.GE.0) NQ0=NQ0+1
      IF (Q.GE.1) NQ1=NQ1+1
      IF (Q.GE.2) NQ2=NQ2+1
      IF (Q.GE.3) NQ3=NQ3+1
      IF (Q.GE.4) NQ4=NQ4+1
      IF (Q.GE.6) NQ6=NQ6+1
C
C FIXED INTERVALS OF Q = Y/SIGMA(Y)
C
      DO I=1,M1-1
        IF (Q.LE.X1(I)) GO TO 1
      END DO
      I=M1
 1    N1(I)=N1(I)+1
      Y1(I)=Y1(I)+Q
C
C FIXED SHELLS OF S = SIN(THETA)/LAMBDA
C
      S=SINTHL(IH,IK,IL,GINV)
      DO I=1,M2-1
        IF (S.LE.X2(I)) GO TO 2
      END DO
      I=M2
 2    N2(I)=N2(I)+1
      Y2(I)=Y2(I)+Q
C
C EQUAL-VOLUME SHELLS OF S
C
      DO I=1,M3-1
        IF (S.LE.X3(I)) GO TO 3
      END DO
      I=M3
 3    N3(I)=N3(I)+1
      Y3(I)=Y3(I)+Q
      GO TO 11
 19   CONTINUE
C
C INTERVAL AND SHELL AVERAGES
C
      DO I=1,M1
        IF (N1(I).GT.0) Y1(I)=Y1(I)/N1(I)
      END DO
      DO I=1,M2
        IF (N2(I).GT.0) Y2(I)=Y2(I)/N2(I)
      END DO
      DO I=1,M3
        IF (N3(I).GT.0) Y3(I)=Y3(I)/N3(I)
      END DO
      WRITE (ILP,600) ATIME,ADATE,TITLE
 600  FORMAT ('1'/1X,'PROGRAM SORTAV.  ',A,1X,A,'.  ',A)
      WRITE (ILP,9006) NTOTAL,NQ0,NQ1,NQ2,NQ3,NQ4,NQ6
 9006 FORMAT (/1X,'UNIQUE DATA DISTRIBUTION STATISTICS:'/1X,
     &                 '------------------------------------'//1X,
     &'Q = Y/SIGMA(Y)         NDATA'/1X,
     &'--------------         -----'/1X,
     &'TOTAL UNIQUE DATA   ',I8/1X,
     &'         Q > 0      ',I8/1X,
     &'         Q > 1      ',I8/1X,
     &'         Q > 2      ',I8/1X,
     &'         Q > 3      ',I8/1X,
     &'         Q > 4      ',I8/1X,
     &'         Q > 6      ',I8)
      WRITE (ILP,9007) (N1(I),Y1(I),I=1,17)
 9007 FORMAT (/1X,'INTENSITY-SIGNIFICANCE INTERVALS  (QMIN .LT.',
     &' Q .LE. QMAX)'//1X,
     &'                       NDATA     <Q>'/1X,
     &'                       -----     ---'/1X,
     &'         Q <  -4    ',I8,F8.2/1X,
     &'    -4 < Q <  -3    ',I8,F8.2/1X,
     &'    -3 < Q <  -2    ',I8,F8.2/1X,
     &'    -2 < Q <  -1    ',I8,F8.2/1X,
     &'    -1 < Q <   0    ',I8,F8.2/1X,
     &'     0 < Q <   1    ',I8,F8.2/1X,
     &'     1 < Q <   2    ',I8,F8.2/1X,
     &'     2 < Q <   3    ',I8,F8.2/1X,
     &'     3 < Q <   4    ',I8,F8.2/1X,
     &'     4 < Q <   6    ',I8,F8.2/1X,
     &'     6 < Q <   8    ',I8,F8.2/1X,
     &'     8 < Q <  10    ',I8,F8.2/1X,
     &'    10 < Q <  20    ',I8,F8.2/1X,
     &'    20 < Q <  30    ',I8,F8.2/1X,
     &'    30 < Q <  50    ',I8,F8.2/1X,
     &'    50 < Q < 100    ',I8,F8.2/1X,
     &'   100 < Q          ',I8,F8.2)
      WRITE (ILP,9008) (N2(I),Y2(I),I=1,15)
 9008 FORMAT (/1X,'RESOLUTION SHELLS  (SMIN .LT. S .LE. SMAX)  (DM',
     &'AX .GT. D .GE. DMIN)'//1X,
     &'                       NDATA     <Q>'/1X,
     &'                       -----     ---'/1X,
     &'         D > 10     ',I8,F8.2/1X,
     &' 10    > D >  8     ',I8,F8.2/1X,
     &'  8    > D >  6     ',I8,F8.2/1X,
     &'  6    > D >  4     ',I8,F8.2/1X,
     &'  4    > D >  3.5   ',I8,F8.2/1X,
     &'  3.5  > D >  3     ',I8,F8.2/1X,
     &'  3    > D >  2.5   ',I8,F8.2/1X,
     &'  2.5  > D >  2     ',I8,F8.2/1X,
     &'  2    > D >  1.5   ',I8,F8.2/1X,
     &'  1.5  > D >  1     ',I8,F8.2/1X,
     &'  1    > D >  0.75  ',I8,F8.2/1X,
     &'  0.75 > D >  0.5   ',I8,F8.2/1X,
     &'  0.5  > D >  0.4   ',I8,F8.2/1X,
     &'  0.4  > D >  0.35  ',I8,F8.2/1X,
     &'  0.35 > D          ',I8,F8.2)
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,9009) 1/(2*X3(1)),N3(1),Y3(1)
 9009 FORMAT (/1X,'EQUAL-VOLUME RESOLUTION SHELLS (SMIN .LT. S .LE',
     &'. SMAX) (DMAX .GT. D .GE. DMIN)'//1X,
     &'                       NDATA     <Q>'/1X,
     &'                       -----     ---'/1X,
     &  6X,'   D > ',F6.3,1X,I8,F8.2)
      DO I=2,20
        WRITE (ILP,'(1X,F6.3,'' > D > '',F6.3,1X,I8,F8.2)')
     &  1/(2*X3(I-1)),1/(2*X3(I)),N3(I),Y3(I)
      END DO
C
C PREPARE SCRATCH FILES IO2 AND IO3 SORTED ON DECREASING Y AND
C INCREASING S, RESPECTIVELY.
C
      CALL YSSORT (NTOTAL)
C
C PLOT LOG10(<SIGMA(Y)>) VERSUS LOG10(<Y>).
C
      NN=100
      NLOCAL=MAX(50,NINT(FLOAT(NTOTAL)/NN))
      NN=MIN(NN,NINT(FLOAT(NTOTAL)/NLOCAL))
      REWIND IO2
      DO I=NN,1,-1
        XDATA(I)=0
        YDATA(I)=0
        NDATA(I)=0
        DO J=1,NLOCAL
          READ (IO2,END=20) S,Y,ESD,RMSD
          XDATA(I)=XDATA(I)+Y
          YDATA(I)=YDATA(I)+MAX(ESD,RMSD)
          NDATA(I)=NDATA(I)+1
        END DO
 20     IF (NDATA(I).GT.0) THEN
          XDATA(I)=XDATA(I)/NDATA(I)
          YDATA(I)=YDATA(I)/NDATA(I)
        END IF
      END DO
      XMIN=+1E10
      XMAX=-1E10
      YMIN=+1E10
      YMAX=-1E10
      N=0
      DO I=1,NN
        IF (NDATA(I).GT.0.AND.XDATA(I).GT.0.AND.YDATA(I).GT.0) THEN
          N=N+1
          XDATA(N)=LOG10(XDATA(I))
          YDATA(N)=LOG10(YDATA(I))
          XMIN=MIN(XMIN,XDATA(N))
          XMAX=MAX(XMAX,XDATA(N))
          YMIN=MIN(YMIN,YDATA(N))
          YMAX=MAX(YMAX,YDATA(N))
        END IF
      END DO
C
C ENSURE INCREASING XDATA VALUES FOR SPLINE INTERPOLATION.
C
      M=N
      N=1
      DO I=2,M
        IF (XDATA(I).GT.XDATA(I-1)) THEN
          N=N+1
          XDATA(N)=XDATA(I)
          YDATA(N)=YDATA(I)
        END IF
      END DO
      CALL SPLINE (N,XDATA,YDATA,YPP)
      O=0.5*(XMIN+XMAX)
      H=0.5*(XMAX-XMIN)
      H=1.1*H
      XXMIN=O-H
      XXMAX=O+H
      O=0.5*(YMIN+YMAX)
      H=0.5*(YMAX-YMIN)
      H=1.1*H
      YYMIN=O-H
      YYMAX=O+H
      WRITE (ILP,610) ATIME,ADATE,TITLE
 610  FORMAT ('1'/1X,10X,'PROGRAM SORTAV.  ',A,1X,A,'.  ',A/)
      CALL PLOT (ILP,XXMIN,XXMAX,YYMIN,YYMAX,N,XDATA,YDATA,YPP)
      WRITE (ILP,9010) N,NLOCAL
 9010 FORMAT (/1X,10X,'LOG10(<SIGMA(Y)>) (VERTICAL) VERSUS LOG10(<',
     &'Y>) (HORIZONTAL)'//1X,10X,'CUBIC SPLINE INTERPOLATED CURVE THRO',
     &'UGH M = ',I3, ' LOCALLY AVERAGED DATA POINTS WITH N = ',I4,' DA',
     &'TA PER LOCAL AVERAGE.')
C
C PRINT TABLE OF <SIGMA(Y)> VERSUS <Y>.
C
      WRITE (ILP,610) ATIME,ADATE,TITLE
      WRITE (ILP,9011)
 9011 FORMAT (/1X,10X,'     <Y> <SIGMA(Y)>'/1X,10X,
     &'     --- ----------')
      DO I=-10,+10
        IF (XMIN.LE.I.AND.I.LE.XMAX) THEN
          XI=I
          CALL SPLINT (N,XDATA,YDATA,YPP,XI,YI)
          WRITE (ILP,'(1X,10X,E8.1,1X,E9.2)') 10**XI,10**YI
          IF (I+1.LE.XMAX) THEN
            XI=I+LOG10(2.0)
            CALL SPLINT (N,XDATA,YDATA,YPP,XI,YI)
            WRITE (ILP,'(1X,10X,E8.1,1X,E9.2)') 10**XI,10**YI
            XI=I+LOG10(5.0)
            CALL SPLINT (N,XDATA,YDATA,YPP,XI,YI)
            WRITE (ILP,'(1X,10X,E8.1,1X,E9.2)') 10**XI,10**YI
          END IF
        END IF
      END DO
C
C PLOT <Y> VERSUS <SIN(THETA)/LAMBDA>.
C
      XMIN=0
      XMAX=0
      YMIN=+1E10
      YMAX=-1E10
      REWIND IO3
      N=0
      DO I=1,NN
        XDATA(I)=0
        YDATA(I)=0
        NDATA(I)=0
        DO J=1,NLOCAL
          READ (IO3,END=30) S,Y,ESD,RMSD
          XDATA(I)=XDATA(I)+S
          YDATA(I)=YDATA(I)+Y
          NDATA(I)=NDATA(I)+1
        END DO
 30     IF (NDATA(I).GT.0) THEN
          N=N+1
          XDATA(N)=XDATA(I)/NDATA(I)
          YDATA(N)=YDATA(I)/NDATA(I)
          XMAX=MAX(XMAX,XDATA(N))
          YMIN=MIN(YMIN,YDATA(N))
          YMAX=MAX(YMAX,YDATA(N))
        END IF
      END DO
      M=N
      N=1
      DO I=2,M
        IF (XDATA(I).GT.XDATA(I-1)) THEN
          N=N+1
          XDATA(N)=XDATA(I)
          YDATA(N)=YDATA(I)
        END IF
      END DO
      CALL SPLINE (N,XDATA,YDATA,YPP)
      O=0.5*(YMIN+YMAX)
      H=0.5*(YMAX-YMIN)
      H=1.1*H
      YMIN=O-H
      YMAX=O+H
      YMIN=MAX(YMIN,0.0)
      WRITE (ILP,610) ATIME,ADATE,TITLE
      CALL PLOT (ILP,XMIN,XMAX,YMIN,YMAX,N,XDATA,YDATA,YPP)
      WRITE (ILP,9012) N,NLOCAL
 9012 FORMAT (/1X,10X,'<Y> (VERTICAL) VERSUS <SIN(THETA)/LAMBDA> (',
     &'HORIZONTAL).'//1X,10X,'CUBIC SPLINE INTERPOLATED CURVE THROUGH ',
     &'M = ',I3, ' LOCALLY AVERAGED DATA POINTS WITH N = ',I4,' DATA P',
     &'ER LOCAL AVERAGE.')
C
C PLOT <SIGMA(Y)> VERSUS <SIN(THETA)/LAMBDA>.
C
      XMIN=0
      XMAX=0
      YMIN=+1E10
      YMAX=-1E10
      REWIND IO3
      N=0
      DO I=1,NN
        XDATA(I)=0
        YDATA(I)=0
        NDATA(I)=0
        DO J=1,NLOCAL
          READ (IO3,END=31) S,Y,ESD,RMSD
          XDATA(I)=XDATA(I)+S
          YDATA(I)=YDATA(I)+MAX(ESD,RMSD)
          NDATA(I)=NDATA(I)+1
        END DO
 31     IF (NDATA(I).GT.0) THEN
          N=N+1
          XDATA(N)=XDATA(I)/NDATA(I)
          YDATA(N)=YDATA(I)/NDATA(I)
          XMAX=MAX(XMAX,XDATA(N))
          YMIN=MIN(YMIN,YDATA(N))
          YMAX=MAX(YMAX,YDATA(N))
        END IF
      END DO
      M=N
      N=1
      DO I=2,M
        IF (XDATA(I).GT.XDATA(I-1)) THEN
          N=N+1
          XDATA(N)=XDATA(I)
          YDATA(N)=YDATA(I)
        END IF
      END DO
      CALL SPLINE (N,XDATA,YDATA,YPP)
      O=0.5*(YMIN+YMAX)
      H=0.5*(YMAX-YMIN)
      H=1.1*H
      YMIN=O-H
      YMAX=O+H
      YMIN=MAX(YMIN,0.0)
      WRITE (ILP,610) ATIME,ADATE,TITLE
      CALL PLOT (ILP,XMIN,XMAX,YMIN,YMAX,N,XDATA,YDATA,YPP)
      WRITE (ILP,9013) N,NLOCAL
 9013 FORMAT (/1X,10X,'<SIGMA(Y)> (VERTICAL) VERSUS <SIN(THETA)/LA',
     &'MBDA> (HORIZONTAL).'//1X,10X,'CUBIC SPLINE INTERPOLATED CURVE T',
     &'HROUGH M = ',I3, ' LOCALLY AVERAGED DATA POINTS WITH N = ',I4,
     &' DATA PER LOCAL AVERAGE.')
C
C PLOT <Y/SIGMA(Y)> VERSUS <SIN(THETA)/LAMBDA>.
C
      XMIN=0
      XMAX=0
      YMIN=+1E10
      YMAX=-1E10
      REWIND IO3
      N=0
      DO I=1,NN
        XDATA(I)=0
        YDATA(I)=0
        NDATA(I)=0
        DO J=1,NLOCAL
          READ (IO3,END=32) S,Y,ESD,RMSD
          XDATA(I)=XDATA(I)+S
          YDATA(I)=YDATA(I)+Y/MAX(ESD,RMSD)
          NDATA(I)=NDATA(I)+1
        END DO
 32     IF (NDATA(I).GT.0) THEN
          N=N+1
          XDATA(N)=XDATA(I)/NDATA(I)
          YDATA(N)=YDATA(I)/NDATA(I)
          XMAX=MAX(XMAX,XDATA(N))
          YMIN=MIN(YMIN,YDATA(N))
          YMAX=MAX(YMAX,YDATA(N))
        END IF
      END DO
      M=N
      N=1
      DO I=2,M
        IF (XDATA(I).GT.XDATA(I-1)) THEN
          N=N+1
          XDATA(N)=XDATA(I)
          YDATA(N)=YDATA(I)
        END IF
      END DO
      CALL SPLINE (N,XDATA,YDATA,YPP)
      O=0.5*(YMIN+YMAX)
      H=0.5*(YMAX-YMIN)
      H=1.1*H
      YMIN=O-H
      YMAX=O+H
      YMIN=MAX(YMIN,0.0)
      WRITE (ILP,610) ATIME,ADATE,TITLE
      CALL PLOT (ILP,XMIN,XMAX,YMIN,YMAX,N,XDATA,YDATA,YPP)
      WRITE (ILP,9014) N,NLOCAL
 9014 FORMAT (/1X,10X,'<Y/SIGMA(Y)> (VERTICAL) VERSUS <SIN(THETA)/',
     &'LAMBDA> (HORIZONTAL).'//1X,10X,'CUBIC SPLINE INTERPOLATED CUR',
     &'VE THROUGH M = ',I3, ' LOCALLY AVERAGED DATA POINTS WITH N = '
     &,I4,' DATA PER LOCAL AVERAGE.')
C
C TABULATE EFFECTIVE RESOLUTION LIMITS.
C
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,9015)
 9015 FORMAT (/1X,'EFFECTIVE RESOLUTION LIMITS AT WHICH THE LOC',
     &'AL AVERAGE VALUES <Q> = <Y/SIGMA(Y)> FIRST FALL BELOW QMIN.'//
     &1X,'QMIN  DMIN = 1/(2*SMAX)'/1X,'----  -----------------')
      R1=0
      R2=0
      R3=0
      R4=0
      R6=0
      DO I=1,NN
        IF (R1.EQ.0.AND.YDATA(I).LT.1) R1=XDATA(I)
        IF (R2.EQ.0.AND.YDATA(I).LT.2) R2=XDATA(I)
        IF (R3.EQ.0.AND.YDATA(I).LT.3) R3=XDATA(I)
        IF (R4.EQ.0.AND.YDATA(I).LT.4) R4=XDATA(I)
        IF (R6.EQ.0.AND.YDATA(I).LT.6) R6=XDATA(I)
      END DO
      IF (R1.GT.0) R1=1/(2*R1)
      IF (R2.GT.0) R2=1/(2*R2)
      IF (R3.GT.0) R3=1/(2*R3)
      IF (R4.GT.0) R4=1/(2*R4)
      IF (R6.GT.0) R6=1/(2*R6)
      WRITE (ILP,'(1X,''1'',F9.2)') R1
      WRITE (ILP,'(1X,''2'',F9.2)') R2
      WRITE (ILP,'(1X,''3'',F9.2)') R3
      WRITE (ILP,'(1X,''4'',F9.2)') R4
      WRITE (ILP,'(1X,''6'',F9.2)') R6
C
C COMPILE DISTRIBUTION STATISTICS IN EQUALLY POPULATED RANGES OF Y-
C MAGNITUDE AND EQUAL-VOLUME SHELLS OF S.
C
C SCRATCH FILES IO2 AND IO3 HAVE BEEN SORTED ON DECREASING Y AND
C INCREASING S, RESPECTIVELY.
C
      REWIND IO2
      REWIND IO3
C
C AVERAGES OVER RANGES OF Y
C
      NRANGE=M3
      NLOCAL=NTOTAL/NRANGE+1
      DO I=1,NRANGE
        NI(I)=0
        AS(I)=0
        AY(I)=0
        ASIGY(I)=0
        AYSIG(I)=0
        FSIG(I)=0
        DO N=1,NLOCAL
          READ (IO2,END=41) S,Y,ESD,RMSD
          SIGY=MAX(ESD,RMSD)
          IF (SIGY.GT.0) THEN
            NI(I)=NI(I)+1
            AS(I)=AS(I)+S
            AY(I)=AY(I)+Y
            ASIGY(I)=ASIGY(I)+SIGY
            AYSIG(I)=AYSIG(I)+Y/SIGY
            IF (Y.GE.CUTOFF*SIGY) FSIG(I)=FSIG(I)+1
          END IF
        END DO
 41     CONTINUE
        IF (NI(I).GT.0) THEN
          AS(I)=AS(I)/NI(I)
          AY(I)=AY(I)/NI(I)
          ASIGY(I)=ASIGY(I)/NI(I)
          AYSIG(I)=AYSIG(I)/NI(I)
          FSIG(I)=FSIG(I)/NI(I)
        END IF
      END DO
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,9016) NRANGE,NLOCAL,
     & CUTOFF,(AS(I),AY(I),ASIGY(I),AY(I)/MAX(ASIGY(I),1.0E-10),
     & AYSIG(I),FSIG(I),I=1,NRANGE)
 9016 FORMAT (/1X,'DATA SET AVERAGES IN EQUALLY POPULATED RANGES O',
     &'F Y-MAGNITUDE:'/1X,'------------------------------------------',
     &'-------------------'//1X,'M = ',I4,' RANGES'/1X,'N = ',I4,
     &' UNIQUE DATA PER RANGE'//1X,'                     <S>      ',
     &'   <Y>      <SIGY>  <Y>/<SIGY>    <Y/SIGY>  FRACTION WITH Y > C',
     &'UTOFF*SIGY, CUTOFF = ',F4.2/1X,'                     ---      ',
     &'   ---      ------  ----------    --------  ------------------',
     &'--------------------------'/(1X,16X,F8.4,5F12.2))
C
C AVERAGES OVER SHELLS OF S
C
      DO I=1,M3
        NI(I)=0
        AS(I)=0
        AY(I)=0
        ASIGY(I)=0
        AYSIG(I)=0
        FSIG(I)=0
      END DO
      DO N=1,NTOTAL
        READ (IO3) S,Y,ESD,RMSD
        SIGY=MAX(ESD,RMSD)
        IF (SIGY.GT.0) THEN
          DO I=1,M3
            IF (S.LE.X3(I)) GO TO 42
          END DO
          I=M3
 42       CONTINUE
          NI(I)=NI(I)+1
          AS(I)=AS(I)+S
          AY(I)=AY(I)+Y
          ASIGY(I)=ASIGY(I)+SIGY
          AYSIG(I)=AYSIG(I)+Y/SIGY
          IF (Y.GE.CUTOFF*SIGY) FSIG(I)=FSIG(I)+1
        END IF
      END DO
      DO I=1,M3
        IF (NI(I).GT.0) THEN
          AS(I)=AS(I)/NI(I)
          AY(I)=AY(I)/NI(I)
          ASIGY(I)=ASIGY(I)/NI(I)
          AYSIG(I)=AYSIG(I)/NI(I)
          FSIG(I)=FSIG(I)/NI(I)
        END IF
      END DO
      WRITE (ILP,9017) CUTOFF,(X3(I),
     & 1/(2*X3(I)),AS(I),AY(I),ASIGY(I),AY(I)/MAX(ASIGY(I),1.0E-10),
     & AYSIG(I),FSIG(I),I=1,M3)
 9017 FORMAT (/1X,'DATA SET AVERAGES IN EQUAL-VOLUME RESOLUTION SH',
     &'ELLS:'/1X,'----------------------------------------------------'
     &//1X,'   SHELL   SHELL'/1X,'   S-MAX   D-MIN     <S>       ',
     &'  <Y>      <SIGY>  <Y>/<SIGY>    <Y/SIGY>  FRACTION WITH Y > CU',
     &'TOFF*SIGY, CUTOFF = ',F4.2/1X,'   -----   -----     ---        ',
     &' ---      ------  ----------    --------  ---------------------',
     &'-----------------------'/(1X,F8.4,F8.3,F8.4,5F12.2))
      CLOSE (UNIT=IO2,STATUS='DELETE')
      CLOSE (UNIT=IO3,STATUS='DELETE')
C
C LOOP THROUGH THE GENERATION OF THE UNIQUE HKL TO CHECK FOR MISSING
C REFLECTIONS WITH S .LE. SMAX.
C
      CALL LIMITS (IPTGP,SMAX,GINV,IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX) 
      JH=IHMIN
      JK=IKMIN
      JL=ILMIN-1
      REWIND IO1
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=4)
      N=0
      IEND=0
 91   CALL READ2 (IO1,ITYPE,IEND,IH,IK,IL,Y,SIGY,RMSD,NMEAS,TBAR,S0,S1)
      IF (IEND.NE.0) GO TO 95
      CALL PACKH (IH,IK,IL,IHKL)
 92   CALL HKLGEN (JH,JK,JL,S)
      CALL PACKH (JH,JK,JL,JHKL)
      IF (JHKL.LT.IHKL) THEN
        N=N+1
        WRITE (IO2,REC=N) JH,JK,JL,S
        DATA(N)=S
        GO TO 92
      END IF
      GO TO 91
 95   CONTINUE
      DO WHILE (JH.LT.999)
        CALL HKLGEN (JH,JK,JL,S)
        N=N+1
        WRITE (IO2,REC=N) JH,JK,JL,S
        DATA(N)=S
      END DO
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,640) SMAX,1/(2*SMAX)
C
C SUBTRACT H,K,L, = 0,0,0 AND 999,999,999 FROM THE MISSING COUNT.
C
      M=N-2
      WRITE (ILP,641) NTOTAL,M,100*FLOAT(NTOTAL)/(NTOTAL+M-1)
      IF (M.GT.0) THEN
        WRITE (ILP,642)
      ELSE      
        CLOSE (UNIT=IO2,STATUS='DELETE')
        GO TO 99
      END IF
 640  FORMAT ('0DATA RESOLUTION AND COMPLETENESS:'/' -------------------
     &--------------'/'0OVERALL SMAX = SIN(THETA(MAX))/LAMBDA       = ',
     &F6.3,' RECIPROCAL ANGSTROMS'/' OVERALL DMIN = 1/(2*SIN(THETA(MAX))
     &/LAMBDA) = ',F5.2,'  ANGSTROMS')
 641  FORMAT('0N  = ',I6,' MEASURED UNIQUE HKL'/' M  = ',I6,' MISSING UN
     &IQUE HKL WITH SIN(THETA)/LAMBDA .LE. SMAX.'/'0OVERALL COMPLETENESS
     & = ',F5.1,'%')
 642  FORMAT ('0MISSING HKL ARE LISTED IN A "missing.hkl" OUTPUT FILE SO
     &RTED ON SIN(THETA)/LAMBDA.')
C
C SAVE FILE OF MISSING REFLECTIONS SORTED ON SIN(THETA)/LAMBDA.
C
      CALL SORT (N,DATA,INDEX)
      OPEN (UNIT=81,FILE='missing.hkl',STATUS='NEW',FORM='FORMATTED')
      WRITE (81,600) ATIME,ADATE,TITLE
      WRITE (81,8000)
      DO I=1,N
        READ (IO2,REC=INDEX(I)) IH,IK,IL,S
        WRITE (81,8001)         IH,IK,IL,S 
      END DO
      CLOSE (UNIT=81,STATUS='KEEP')
 8000 FORMAT (1X,'   H   K   L   SIN(THETA)/LAMBDA'/1X,'   -   -   -   -
     &----------------')
 8001 FORMAT (1X,3I4,F10.4)
C
C TABULATE DISTRIBUTION OF MISSING REFLECTIONS IN EQUAL-VOLUME SHELLS OF
C S = SIN(THETA)/LAMBDA.
C
C THE ARRAY X3(M3) CONTAINS THE SHELL-MAXIMUM S-VALUES; THE ARRAY N3(M3)
C CONTAINS THE NUMBER OF UNIQUE REFLECTIONS MEASURED IN EACH SHELL; AND
C THE ARRAY Y3(M3) IS RE-USED TO ACCUMULATE THE NUMBERS OF MISSING
c REFLECTIONS IN EACH SHELL.
C
      DO I=1,M3
        Y3(I)=0
      END DO
      DO I=1,N                                   
        READ (IO2,REC=INDEX(I)) IH,IK,IL,S
        DO J=1,M3
          IF (S.LE.X3(J)) THEN
            Y3(J)=Y3(J)+1
            GO TO 80
          END IF
        END DO
 80     CONTINUE
      END DO
      CLOSE (UNIT=IO2,STATUS='DELETE')
      WRITE (ILP,9018) (X3(I),1/(2*X3(I)),N3(I),INT(Y3(I)),
     & 100*N3(I)/MAX(1.0,N3(I)+Y3(I)),I=1, M3)
 9018 FORMAT (/1X,'DISTRIBUTION OF MEASURED AND MISSING REFLECTION',
     &'S IN EQUAL-VOLUME RESOLUTION SHELLS'//1X,
     &'   SHELL   SHELL      NHKL      NHKL      PERCENT'/1X,
     &'   S-MAX   D-MIN  MEASURED   MISSING COMPLETENESS'/1X,
     &'   -----   -----  --------   ------- ------------'/
     &(1X,F8.4,F8.3,2I10,F10.1))
 99   WRITE (ILP,'(//1X,''JOB STARTED:   '',A,1X,A)') ATIME,ADATE
      CALL TIME (ATIME)
      CALL DATE (ADATE)
      WRITE (ILP,'(  1X,''JOB FINISHED:  '',A,1X,A)') ATIME,ADATE
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE PACKH (IH,IK,IL,IHKL)
      IHKL=1000000*(IH+500)+1000*(IK+500)+IL+500
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE PLOT (ILP,XMIN,XMAX,YMIN,YMAX,N,X,Y,YPP)
      PARAMETER (NX=100,NY=50)
      CHARACTER AA*1
      DIMENSION AA(0:NX,0:NY),X(N),Y(N),YPP(N)
C
C BLANK OUT THE PLOT ARRAY.
C
      DO IX=0,NX
      DO IY=0,NY
        AA(IX,IY)=' '
      END DO
      END DO
C
C FILL IN THE GRID MARKS.
C
      DO IX=0,NX
        AA(IX, 0)='.'
        AA(IX,NY)='.'
      END DO
      DO IX=0,NX,10
        AA(IX, 0)='+'
        AA(IX,NY)='+'
      END DO
      DO IY=0,NY
        AA( 0,IY)='.'
        AA(NX,IY)='.'
      END DO
      DO IY=0,NY,10
        AA( 0,IY)='+'
        AA(NX,IY)='+'
      END DO
C
C FILL IN THE DATA POINTS.
C
      DX=(X(N)-X(1))/(5*NX)
      DO I=0,5*NX
        XI=X(1)+I*DX
        CALL SPLINT (N,X,Y,YPP,XI,YI)
        IX=NINT(NX*(XI-XMIN)/(XMAX-XMIN))
        IY=NINT(NY*(YMAX-YI)/(YMAX-YMIN))
        IF (IX.GE.0.AND.IX.LE.NX.AND.IY.GE.0.AND.IY.LE.NY) AA(IX,IY)='X'
      END DO
C
C PRINT THE PLOT ARRAY.
C
      DY=(YMAX-YMIN)/NY
      DO IY=0,NY
        IF (MOD(IY,10).EQ.0) THEN
          WRITE (ILP,100) YMAX-IY*DY,(AA(IX,IY),IX=0,NX)
        ELSE                        
          WRITE (ILP,101)            (AA(IX,IY),IX=0,NX)
        END IF
      END DO
      DX=(XMAX-XMIN)/10
      WRITE (ILP,102) (XMIN+IX*DX,IX=0,10)
 100  FORMAT (1X,E10.3,101A1)
 101  FORMAT (1X,10X,  101A1)
 102  FORMAT (1X,1X,11E10.3)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE PLOTK (ILP,XMIN,XMAX,YMIN,YMAX,N,X,Y,YPP)
      PARAMETER (NX=100,NY=50)
      CHARACTER AA*1
      DIMENSION AA(0:NX,0:NY),X(N),Y(N),YPP(N)
C
C BLANK OUT THE PLOT ARRAY.
C
      DO IX=0,NX
      DO IY=0,NY
        AA(IX,IY)=' '
      END DO
      END DO
C
C FILL IN THE GRID MARKS.
C
      DO IX=0,NX
        AA(IX, 0)='.'
        AA(IX,NY)='.'
      END DO
      DO IX=0,NX,10
        AA(IX, 0)='+'
        AA(IX,NY)='+'
      END DO
      DO IY=0,NY
        AA( 0,IY)='.'
        AA(NX,IY)='.'
      END DO
      DO IY=0,NY,10
        AA( 0,IY)='+'
        AA(NX,IY)='+'
      END DO
C
C FILL IN THE INTERPOLATED DATA CURVE.
C
      DX=(X(N)-X(1))/(5*NX)
      DO I=0,5*NX
        XI=X(1)+I*DX
        CALL SPLINT (N,X,Y,YPP,XI,YI)
        IX=NINT(NX*(XI-XMIN)/(XMAX-XMIN))
        IY=NINT(NY*(YMAX-YI)/(YMAX-YMIN))
        IF (IX.GE.0.AND.IX.LE.NX.AND.IY.GE.0.AND.IY.LE.NY) AA(IX,IY)='*'
      END DO
C
C FILL IN THE DATA POINTS.
C
      DO I=1,N
        IX=NINT(NX*(X(I)-XMIN)/(XMAX-XMIN))
        IY=NINT(NY*(YMAX-Y(I))/(YMAX-YMIN))
        IF (IX.GE.0.AND.IX.LE.NX.AND.IY.GE.0.AND.IY.LE.NY) AA(IX,IY)='O'
      END DO
C
C PRINT THE PLOT ARRAY.
C
      DY=(YMAX-YMIN)/NY
      DO IY=0,NY
        IF (MOD(IY,10).EQ.0) THEN
          WRITE (ILP,100) YMAX-IY*DY,(AA(IX,IY),IX=0,NX)
        ELSE                        
          WRITE (ILP,101)            (AA(IX,IY),IX=0,NX)
        END IF
      END DO
      DX=(XMAX-XMIN)/10
      WRITE (ILP,102) (XMIN+IX*DX,IX=0,10)
 100  FORMAT (1X,E10.3,101A1)
 101  FORMAT (1X,10X,  101A1)
 102  FORMAT (1X,1X,11E10.3)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE READ0 (IUNIT,FILE,ITYPE)
C
C DETERMINE FILE TYPE BY READ ERROR CHECKING.
C
      CHARACTER FILE*80,RECORD*80
      DIMENSION ANG(4),S0(3),S1(3)
      E=1E9
      M=199
      ITYPE=0
C
C UNFORMATTED FILES
C
      CLOSE (UNIT=IUNIT,STATUS='KEEP')
      OPEN (UNIT=IUNIT,FILE=FILE,STATUS='OLD',FORM='UNFORMATTED',ERR=50)
C
C PROGRAM TSCALE OUTPUT FILE (11 WORDS PER RECORD)
C
      IH=E
      IK=E
      IL=E
      DO I=1,4
        ANG(I)=E
      END DO
      SIGY=-E
      XTIME=-E
      READ (IUNIT,ERR=1,END=50) II,IH,IK,IL,ANG,Y,SIGY,XTIME
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 1
      DO I=1,4
        IF (ABS(ANG(I)).GT.360) GO TO 1
      END DO
      IF (SIGY.LE.0.OR.XTIME.LT.0) GO TO 1
      ITYPE=1
 1    REWIND IUNIT
C
C PROGRAM ABSORB OUTPUT FILE (18 WORDS PER RECORD)
C
      IH=E
      IK=E
      IL=E
      DO I=1,4
        ANG(I)=E
      END DO
      SIGY=-E
      XTIME=-E
      TBAR=-E
      DO I=1,3
        S0(I)=E
        S1(I)=E
      END DO
      READ (IUNIT,ERR=2) II,IH,IK,IL,ANG,Y,SIGY,XTIME,TBAR,S0,S1
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 2
      DO I=1,4
        IF (ABS(ANG(I)).GT.360) GO TO 2
      END DO
      IF (SIGY.LE.0.OR.XTIME.LT.0.OR.TBAR.LT.0) GO TO 2
      DO I=1,3
        IF (ABS(S0(I)).GT.1.OR.ABS(S1(I)).GT.1) GO TO 2
      END DO
      ITYPE=2
 2    REWIND IUNIT
C
C PROGRAM SORTAV OUTPUT FILE (15 WORDS PER RECORD)
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      NMEAS=-E
      TBAR=-E
      DO I=1,3
        S0(I)=E
        S1(I)=E
      END DO
      READ (IUNIT,ERR=3) IH,IK,IL,Y,SIGY,RMSD,NMEAS,TBAR,S0,S1
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 3
      IF (SIGY.LE.0.OR.NMEAS.LT.1.OR.TBAR.LT.0) GO TO 3
      DO I=1,3
        IF (ABS(S0(I)).GT.1.OR.ABS(S1(I)).GT.1) GO TO 3
      END DO
      ITYPE=3
 3    REWIND IUNIT
      IF (ITYPE.NE.0) RETURN
C
C BINARY FILE H, K, L, Y, SIGMA(Y)
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      READ (IUNIT,ERR=4) IH,IK,IL,Y,SIGY
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 4
      IF (SIGY.LE.0) GO TO 4
      ITYPE=4
 4    REWIND IUNIT
      IF (ITYPE.NE.0) RETURN
 50   CONTINUE
C
C FORMATTED FILES
C
      CLOSE (UNIT=IUNIT,STATUS='KEEP')
      OPEN (UNIT=IUNIT,FILE=FILE,STATUS='OLD',FORM='FORMATTED')
      READ (IUNIT,'(A)',ERR=99,END=99) RECORD
      REWIND IUNIT
C
C ASCII FILE H, K, L, Y, SIGMA(Y), ISCALE
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      ISCALE=-E
      READ (RECORD,*,ERR=5,END=5) IH,IK,IL,Y,SIGY,ISCALE
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 5
      IF (SIGY.LE.0.OR.ISCALE.LE.0) GO TO 5
      ITYPE=5
      RETURN
 5    CONTINUE
C
C ASCII FILE H, K, L, Y, SIGMA(Y)
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      READ (RECORD,*,ERR=6,END=6) IH,IK,IL,Y,SIGY
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 6
      IF (SIGY.LE.0) GO TO 6
      ITYPE=6
      RETURN
 6    CONTINUE
 99   CONTINUE
C
C UNKNOWN FILE TYPE
C
      STOP 'UNKNOWN TYPE OF INPUT REFLECTION FILE'
      END
C-----------------------------------------------------------------------
      SUBROUTINE READ1 (IUNIT,ITYPE,IEND,II,IH,IK,IL,Y,SIGY,ISCALE,A)
      DIMENSION ANG(4),S0(3),S1(3),A(11)
      IF (ITYPE.EQ.1) THEN
        READ (IUNIT,END=9) II,IH,IK,IL,ANG,Y,SIGY,XTIME
        DO I=1,4
          A(I)=ANG(I)
        END DO
      ELSE IF (ITYPE.EQ.2) THEN
        READ (IUNIT,END=9) II,IH,IK,IL,ANG,Y,SIGY,XTIME,TBAR,S0,S1
        DO I=1,4
          A(I)=ANG(I)
        END DO
          A(5)=TBAR
        DO I=1,3
          A(5+I)=S0(I)
          A(8+I)=S1(I)
        END DO
      ELSE IF (ITYPE.EQ.3) THEN
        READ (IUNIT,END=9) IH,IK,IL,Y,SIGY,RMSD,NMEAS,RATIO,TBAR,S0,S1
        II=II+1
        A(5)=TBAR
        DO I=1,3
          A(5+I)=S0(I)
          A(8+I)=S1(I)
        END DO
      ELSE IF (ITYPE.EQ.4) THEN
        READ (IUNIT,END=9) IH,IK,IL,Y,SIGY
        II=II+1
      ELSE IF (ITYPE.EQ.5) THEN
        READ (IUNIT,*,END=9) IH,IK,IL,Y,SIGY,ISCALE
        II=II+1
      ELSE IF (ITYPE.EQ.6) THEN
        READ (IUNIT,*,END=9) IH,IK,IL,Y,SIGY
        II=II+1
      ELSE
        STOP 'UNKNOWN TYPE OF INPUT REFLECTION FILE'
      END IF
      RETURN
 9    IEND=1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE READ2 (IUNIT,ITYPE,IEND,IH,IK,IL,YMEAN,ESD,RMSD,NMEAS,
     & TBAR,S0,S1)
C
C ANY CHANGE IN THE RECORD STRUCTURE IN SUBROUTINE WRITE1 WILL REQUIRE
C CORRESPONDING CHANGES HERE.
C
      DIMENSION S0(3),S1(3)
      IF (ITYPE.EQ.0) THEN
        READ (IUNIT,END=9) IH,IK,IL,YMEAN,ESD,RMSD,NMEAS
      ELSE
        READ (IUNIT,END=9) IH,IK,IL,YMEAN,ESD,RMSD,NMEAS,TBAR,S0,S1
      END IF
      RETURN
 9    IEND=1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE READF (IUNIT,IEND,NFILE,AFILE,II,IH,IK,IL,Y,SIGY,
     & ISCALE,A)
C
C CALLS SUBROUTINE READ0 TO OPEN INPUT FILE(S) OF REFLECTION DATA, AS
C NECESSARY, AND CALLS SUBROUTINE READ1 TO READ ONE REFLECTION RECORD.
C
      DIMENSION A(11)
      CHARACTER AFILE(NFILE)*80,FILE*80
      DATA IFILE /0/
      SAVE IFILE,ITYPE
      IF (IFILE.GT.0) GO TO 2
 1    IFILE=IFILE+1
      IF (IFILE.GT.NFILE) RETURN
      FILE=AFILE(IFILE)
      CALL READ0 (IUNIT,FILE,ITYPE)
      II=0
      ISCALE=IFILE
      DO I=1,11
        A(I)=0
      END DO
      IEND=0
 2    CALL READ1 (IUNIT,ITYPE,IEND,II,IH,IK,IL,Y,SIGY,ISCALE,A)
      IF (IEND.NE.0) GO TO 1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE RSUMI (IW,I,NMEAS,Y,SIGY,W,YMEAN)
      PARAMETER (M1=17,M2=15,M3=20,M4=16+M1+M2+M2+M3)
      COMMON /BLOCKR/ NTERM(M4),NMEAN(M4),R1NUM(M4),R1DEN(M4),R2NUM(M4),
     & R2DEN(M4),RWNUM(M4),RWDEN(M4),ZNUM(M4),ZDEN(M4),VNUM(M4),VDEN(M4)
      DOUBLE PRECISION R1NUM,R1DEN,R2NUM,R2DEN,RWNUM,RWDEN,ZNUM,ZDEN,
     & VNUM,VDEN
      DIMENSION Y(NMEAS),SIGY(NMEAS),W(NMEAS)
      DOUBLE PRECISION SUMD,SUMX,SUMDSQ,SUMXSQ,SUMWD,SUMWX,SUMWDSQ,
     & SUMWZSQ,SUMWXSQ,SUMW
      SUMD=0
      SUMX=0
      SUMDSQ=0
      SUMXSQ=0
      SUMWD=0
      SUMWX=0
      SUMWDSQ=0
      SUMWZSQ=0
      SUMWXSQ=0
      SUMW=0
      N=0
      NREJ=0
      DO 1 J=1,NMEAS
C
C IF IW = 0, DO NOT;
C IF IW = 1, DO DOWN-WEIGHT OR REJECT OUTLIERS.
C
        IF (IW.NE.0.AND.W(J).LE.0) GO TO 1
        N=N+1
        D=Y(J)-YMEAN
        X=Y(J)
        SUMD=SUMD+ABS(D)
        SUMX=SUMX+ABS(X)
        SUMDSQ=SUMDSQ+D**2
        SUMXSQ=SUMXSQ+X**2
        IF (IW.EQ.0) THEN
          WT=1
        ELSE
          WT=W(J)
        END IF
        IF (WT.LE.0) THEN
          NREJ=NREJ+1
        ELSE
          SUMWDSQ=SUMWDSQ+WT*D**2
          Z=D/SIGY(J)
          X=X/SIGY(J)
          SUMWZSQ=SUMWZSQ+WT*Z**2
          SUMWXSQ=SUMWXSQ+WT*X**2
          SUMW=SUMW+WT
        END IF
 1    CONTINUE
C
C ADJUST NUMERATORS FOR MULTIPLE MEASUREMENT SAMPLE SIZE.
C
      F=FLOAT(N)/(N-1)
      SUMD=SQRT(F)*SUMD
      SUMDSQ=F*SUMDSQ
      N=N-NREJ
      F=FLOAT(N)/(N-1)
      SUMWDSQ=F*SUMWDSQ
      SUMWZSQ=F*SUMWZSQ
C
C ACCUMULATE DATA-CLASS SUMS.
C
      R1NUM(I)=R1NUM(I)+SUMD
      R1DEN(I)=R1DEN(I)+SUMX
      R2NUM(I)=R2NUM(I)+SUMDSQ
      R2DEN(I)=R2DEN(I)+SUMXSQ
      RWNUM(I)=RWNUM(I)+SUMWZSQ
      RWDEN(I)=RWDEN(I)+SUMWXSQ
      ZNUM(I)=ZNUM(I)+SUMWZSQ
      ZDEN(I)=ZDEN(I)+SUMW
      VNUM(I)=VNUM(I)+SQRT(SUMWDSQ/SUMW)
      VDEN(I)=VDEN(I)+ABS(YMEAN)
      NTERM(I)=NTERM(I)+N
      NMEAN(I)=NMEAN(I)+1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE RSUMS (N,Y,SIGY,W,YMEAN,ESD,RMSD,S,IC)
C
C ACCUMULATE SUMS FOR R-FACTORS.
C
      PARAMETER (M1=17,M2=15,M3=20)
      COMMON /BLOCK4/ X1(M1),X2(M2),X3(M3)
      DIMENSION Y(N),SIGY(N),W(N)
      IF (N.EQ.1) RETURN
C
C I = 1.  ALL DATA
C
      I=1
      CALL RSUMI (0,I,N,Y,SIGY,W,YMEAN)
C
C CUMULATIVE SUBSETS WITH 0-, 1-, 2-, 3-, 4-, AND, 6-SIGMA MINIMUM
C CUTOFF VALUES, WHERE  SIGMA = MAX(ESD, RMSD).
C
      Q=YMEAN/MAX(ESD,RMSD)
C
C I = 2, 7.  NO DOWN-WEIGHTING OR REJECTION OF OUTLIERS
C
      DO J=1,6
        IF (J.EQ.6) THEN
          K=J
        ELSE
          K=J-1
        END IF
        IF (Q.GE.K) CALL RSUMI (0,1+J,N,Y,SIGY,W,YMEAN)
      END DO
C
C COUNT REJECTED MEASUREMENTS.
C
      NREJ=0
      DO I=1,N
        IF (W(I).LE.0) NREJ=NREJ+1
      END DO
      IF (N-NREJ.LT.2) RETURN
C
C I = 8, 14.  OUTLIERS DOWN-WEIGHTED OR REJECTED
C
      CALL RSUMI (1,8,N,Y,SIGY,W,YMEAN)
      DO J=1,6
        IF (J.EQ.6) THEN
          K=J
        ELSE
          K=J-1
        END IF
        IF (Q.GE.K) CALL RSUMI (1,8+J,N,Y,SIGY,W,YMEAN)
      END DO
C
C I = 15, 16.  ACENTRIC AND CENTRIC REFLECTIONS
C
      IF (IC.EQ.1) THEN
        I=16
      ELSE
        I=15
      END IF
      CALL RSUMI (1,I,N,Y,SIGY,W,YMEAN)
C
C I = 17, 33.  FIXED RANGES OF Q = YMEAN/MAX(ESD, RMSD)
C
      DO J=1,M1-1
        IF (Q.LE.X1(J)) GO TO 1
      END DO
      J=M1
 1    I=16+J
      CALL RSUMI (1,I,N,Y,SIGY,W,YMEAN)
C
C I = 34, 48.  CUMULATIVE SUBSETS OF INCREASING SIN(THETA)/LAMBDA
C
      DO J=1,M2
        IF (S.LE.X2(J)) THEN
          I=16+M1+J
          CALL RSUMI (1,I,N,Y,SIGY,W,YMEAN)
        END IF
      END DO
C
C I = 49, 63.  FIXED RANGES OF SIN(THETA)/LAMBDA
C
      DO J=1,M2-1
        IF (S.LE.X2(J)) GO TO 2
      END DO
      J=M3
 2    I=16+M1+M2+J
      CALL RSUMI (1,I,N,Y,SIGY,W,YMEAN)
C
C I = 64, 83.  VARIABLE RANGES OF SIN(THETA)/LAMBDA
C
      DO J=1,M3-1
        IF (S.LE.X3(J)) GO TO 3
      END DO
      J=M3
 3    I=16+M1+M2+M2+J
      CALL RSUMI (1,I,N,Y,SIGY,W,YMEAN)
      RETURN
      END
C-----------------------------------------------------------------------
      FUNCTION SINTHL(IH,IK,IL,GINV)
      DIMENSION H(3),GINV(3,3)
      H(1)=IH
      H(2)=IK
      H(3)=IL
      Q=0
      DO I=1,3
      DO J=1,3
        Q=Q+H(J)*GINV(I,J)*H(I)
      END DO
      END DO
      SINTHL=0.5*SQRT(Q)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE SORT (N,DATA,INDEX)
C
C INDEXES THE ARRAY DATA(N) AND RETURNS THE ARRAY INDEX(N) SORTED SUCH
C THAT THE VALUES DATA(INDEX(I)) ARE IN ASCENDING ORDER FOR I = 1, 2,
C ..., N.  THE INPUT VARIABLES N AND DATA(N) ARE NOT CHANGED.
C
C EMPLOYS THE "HEAPSORT" ALGORITHM.
C
C FORTRAN CODE ADAPTED FROM WILLIAM H. PRESS, BRIAN P. FLANNERY, SAUL A.
C TEUKOLSKY, AND WILLIAM T. VETTERLING (1986).  NUMERICAL RECIPIES:  THE
C                                               --------- --------   ---
C ART OF SCIENTIFIC COMPUTING, PP. 229-233.  CAMBRIDGE, ENGLAND:
C --- -- ---------- ---------
C CAMBRIDGE UNIVERSITY PRESS.
C
      REAL DATA,T
      DIMENSION DATA(N),INDEX(N)
      DO I=1,N
        INDEX(I)=I
      END DO
      IF (N.EQ.1) RETURN
      I=N/2+1
      J=N
 1    CONTINUE
      IF (I.GT.1) THEN
        I=I-1
        INEXT=INDEX(I)
        T=DATA(INEXT)
      ELSE
        INEXT=INDEX(J)
        T=DATA(INEXT)
        INDEX(J)=INDEX(1)
        J=J-1
        IF (J.EQ.1) THEN
          INDEX(1)=INEXT
          RETURN
        END IF
      END IF
      K=I
      L=I+I
      DO WHILE (L.LE.J)
        IF (L.LT.J) THEN
          IF (DATA(INDEX(L)).LT.DATA(INDEX(L+1))) L=L+1
        END IF
        IF (T.LT.DATA(INDEX(L))) THEN
          INDEX(K)=INDEX(L)
          K=L
          L=L+L
        ELSE
          L=J+1
        END IF
      END DO
      INDEX(K)=INEXT
      GO TO 1
      END
C-----------------------------------------------------------------------
      SUBROUTINE SPLINE (N,X,Y,YPP)
C
C NATURAL CUBIC SPLINE FIT TO A TABULATED FUNCTION Y(I) = Y(X(I)), I =
C 1, 2,..., N, WITH X(1) .LT. X(2) .LT. ... .LT. X(N).  RETURNS THE
C TABULATED SECOND DERIVATIVES y'' = d2y/dx2 = YPP(I), I = 1, 2,..., N,
C WITH YPP(1) = YPP(N) = 0.
C
C FORTRAN CODE ADAPTED FROM WILLIAM H. PRESS, BRIAN P. FLANNERY, SAUL A.
C TEUKOLSKY, AND WILLIAM T. VETTERLING (1986).  NUMERICAL RECIPIES:  THE
C ART OF SCIENTIFIC COMPUTING, PP. 86-89.  CAMBRIDGE, ENGLAND:
C CAMBRIDGE UNIVERSITY PRESS.
C
C MUST HAVE NMAX .GE. N.
C
      PARAMETER (NMAX=1000)
      DIMENSION X(N),Y(N),YPP(N),U(NMAX)
      YPP(1)=0
      YPP(N)=0
      U(1)=0
      U(N)=0
      DO I=2,N-1
        P=(X(I)-X(I-1))/(X(I+1)-X(I-1))
        Q=P*YPP(I-1)+2
        YPP(I)=(P-1)/Q
        U(I)=(6*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1))/
     &   (X(I)-X(I-1)))/(X(I+1)-X(I-1))-P*U(I-1))/Q
      END DO
      DO I=N-1,1,-1
        YPP(I)=YPP(I)*YPP(I+1)+U(I)
      END DO
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE SPLINT (N,X,Y,YPP,XI,YI)
C
C CUBIC SPLINE INTERPOLATION OF A TABULATED FUNCTION Y(I) = Y(X(I)), I =
C 1, 2,..., N, USING THE TABULATED SECOND DERIVATIVES YPP(I) FROM
C SUBROUTINE SPLINE.
C
C FORTRAN CODE ADAPTED FROM WILLIAM H. PRESS, BRIAN P. FLANNERY, SAUL A.
C TEUKOLSKY, AND WILLIAM T. VETTERLING (1986).  NUMERICAL RECIPIES:  THE
C ART OF SCIENTIFIC COMPUTING, PP. 86-89.  CAMBRIDGE, ENGLAND:
C CAMBRIDGE UNIVERSITY PRESS.
C
      DIMENSION X(N),Y(N),YPP(N)
      IF (XI.LE.X(1)) THEN
        YI=Y(1)
        RETURN
      END IF
      IF (XI.GE.X(N)) THEN
        YI=Y(N)
        RETURN
      END IF
      I1=1
      I2=N
 1    IF (I2-I1.GT.1) THEN
        I=(I2+I1)/2
        IF (X(I).GT.XI) THEN
          I2=I
        ELSE
          I1=I
        END IF
        GO TO 1
      END IF
      H=X(I2)-X(I1)
      A=(X(I2)-XI)/H
      B=(XI-X(I1))/H
      YI=A*Y(I1)+B*Y(I2)+((A**3-A)*YPP(I1)+(B**3-B)*YPP(I2))*H**2/6
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE UDTOUH (DIFF,U)
      DIMENSION U(3,3),V(3,3),W(3,3)
      CHARACTER DIFF*4
      IF (DIFF.EQ.'H   ') THEN
        RETURN
      ELSE
        DO I=1,3
        DO J=1,3
          V(I,J)=U(J,I)
          W(I,J)=0
        END DO
        END DO
      END IF
      IF (DIFF.EQ.'BL  ') THEN
        W(1,2)=-1
        W(2,1)=+1
        W(3,3)= 1
        CALL MM (3,W,V,U)
      ELSE IF (DIFF.EQ.'CAD4') THEN
        DO I=1,3
        DO J=1,3
          U(I,J)=V(I,J)
        END DO
        END DO
      ELSE IF (DIFF.EQ.'P3  ') THEN
        W(1,1)=-1
        W(2,2)=+1
        W(3,3)=-1
        CALL MM (3,W,V,U)
      END IF
      DIFF='H   '
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE UNPACKH (IHKL,IH,IK,IL)
C
C IHKL = 1000000*(IH + 500) + 1000*(IK + 500) + (IL + 500)
C
      IH=0.000001*IHKL
      IK=0.001*(IHKL-1000000*IH)
      IL=IHKL-1000000*IH-1000*IK
      IH=IH-500
      IK=IK-500
      IL=IL-500
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE WRITE1 (IUNIT,IH,IK,IL,YMEAN,ESD,RMSD,NMEAS,TBAR,S0,S1)
C
C IF THE OUTPUT RECORD STRUCTURE IS CHANGED, CORRESPONDING CHANGES IN
C SUBROUTINE READ2 WILL BE REQUIRED.
C
      DIMENSION S0(3),S1(3)
      IF (TBAR.NE.0) THEN
        WRITE (IUNIT) IH,IK,IL,YMEAN,ESD,RMSD,NMEAS,TBAR,S0,S1
      ELSE
        WRITE (IUNIT) IH,IK,IL,YMEAN,ESD,RMSD,NMEAS
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE YMERGE
C
C AVERAGE REPLICATE AND EQUIVALENT MEASUREMENTS, AND COMPILE AGREEMENT
C STATISTICS.
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80,FLAG*1
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCK3/ IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,SMIN,SMAX
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,IPRINT,JPRINT,JPATH,
     & QLIMIT,ZLIMIT,QPRINT
      PARAMETER (M1=17,M2=15,M3=20,M4=16+M1+M2+M2+M3)
      COMMON /BLOCK4/ X1(M1),X2(M2),X3(M3)
      COMMON /BLOCKR/ NTERM(M4),NMEAN(M4),R1NUM(M4),R1DEN(M4),R2NUM(M4),
     & R2DEN(M4),RWNUM(M4),RWDEN(M4),ZNUM(M4),ZDEN(M4),VNUM(M4),VDEN(M4)
      DOUBLE PRECISION R1NUM,R1DEN,R2NUM,R2DEN,RWNUM,RWDEN,ZNUM,ZDEN,
     & VNUM,VDEN
      DIMENSION R1(M4),R2(M4),RW(M4),Z(M4),V(M4)
      EQUIVALENCE (R1(1),R1NUM(1)),(R2(1),R2NUM(1)),(RW(1),RWNUM(1)),
     & (Z(1),ZNUM(1)),(V(1),VNUM(1))
      DIMENSION II(NMAX/20),IH(NMAX/20),IK(NMAX/20),IL(NMAX/20),
     & YI(NMAX/20),SIGYI(NMAX/20),WI(NMAX/20),ISCALE(NMAX/20),
     & PATH(7,NMAX/20),INDEX(NMAX/20)
      EQUIVALENCE (II(1),DATA(1)),(IH(1),DATA(1+NMAX/20)),
     & (IK(1),DATA(1+2*NMAX/20)),(IL(1),DATA(1+3*NMAX/20)),
     & (YI(1),DATA(1+4*NMAX/20)),(SIGYI(1),DATA(1+5*NMAX/20)),
     & (WI(1),DATA(1+6*NMAX/20)),(ISCALE(1),DATA(1+7*NMAX/20)),
     & (PATH(1,1),DATA(1+8*NMAX/20)),(INDEX(1),DATA(1+15*NMAX/20))
      DIMENSION ANGLES(4),S0(3),S1(3)
      DATA ANGLES,TBAR,S0,S1 /11*0/
      DIMENSION IREC(NMAX/2)
      EQUIVALENCE (IREC(1),DATA(1+NMAX/2))
C
C PRINTED OUTPUT FORMAT
C
      NLINE=0
      WRITE (ILP,1000) ATIME,ADATE,TITLE
 1000 FORMAT ('1'/'0PROGRAM SORTAV/YMERGE.  ',A,1X,A,'.  ',A/'0SER.NO.',
     &'   H   K   L           Y    SIGMA(Y)                       SINTHL
     & ISCALE TBAR   K0- AND K-VECTOR COMPONENTS'/'                   ',
     &'                      ESD     RMSD RMSD/ESD NMEAS              ',
     &'      ALONG UNIT-LENGTH CRYSTAL AXES'/)
 1001 FORMAT (' ',A1,I6,3I4,2F12.2,29X,I4)
 2001 FORMAT (' ',A1,I6,3I4,2F12.2,29X,I4,F7.3,2(2X,3F7.3))
 1002 FORMAT (' ',1X,I6,3I4,3F12.2,F6.1,I4,F7.3,I4)
 2002 FORMAT (' ',1X,I6,3I4,3F12.2,F6.1,I2,F7.3,I4,F7.3,2(2X,3F7.3))
 1003 FORMAT (' AVERAGE',3I4,3F12.2,F6.1,I4,F7.3)
 2003 FORMAT (' AVERAGE',3I4,3F12.2,F6.1,I4,F7.3,4X,F7.3,2(2X,3F7.3))
C
C LOOP THROUGH SORTED DATA FILE.
C
      NINDEP=0
      NTOTAL=0
      NMEAS1=0
      NMEAS2=0
      NMEAS3=0
      NREJ=0
      MBAD=0
      NBAD2=0
      NBADN=0
      REWIND IO1
      OPEN (UNIT=IO2,STATUS='NEW',FILE=FILE2,FORM='UNFORMATTED')
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=17)
      OPEN (UNIT=IO4,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=10)
      OPEN (UNIT=IO5,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=10)
 1    READ (IO1,END=9) NMEAS,NH,NK,NL
      DO I=1,NMEAS
        READ (IO1) II(I),IH(I),IK(I),IL(I),YI(I),SIGYI(I),ISCALE(I),
     &  ANGLES,TBAR,S0,S1
        IF (JPATH.NE.0) THEN
          PATH(1,I)=TBAR
          DO J=1,3
            PATH(1+J,I)=S0(J)
            PATH(4+J,I)=S1(J)
          END DO
        END IF
      END DO
      NTOTAL=NTOTAL+NMEAS
      NINDEP=NINDEP+1
C
C AVERAGE EQUIVALENT MEASUREMENTS AND ERROR ESTIMATES.
C
      CALL AVEQ (NMEAS,YI,SIGYI,PP,QQ,RR,C1,C2,C3,C4,IW,JW,ZZMAX,WI,
     & YMEAN,ESD,RMSD)
C
C IF JPATH .NE. 0, AVERAGE TBAR AND S0 AND S1 COMPONENTS.
C
C THIS MAKES SENSE FOR AVERAGING ONLY REPEATED MEASUREMENTS, NOT
C SYMMETRY EQUIVALENT OR AZIMUTH-ROTATION EQUIVALENT MEASUREMENTS.
C
      IF (JPATH.NE.0) THEN
        TBAR=0
        DO J=1,3
          S0(J)=0
          S1(J)=0
        END DO
        DO I=1,NMEAS
          TBAR=TBAR+PATH(1,I)
          DO J=1,3
            S0(J)=S0(J)+PATH(1+J,I)
            S1(J)=S1(J)+PATH(4+J,I)
          END DO
        END DO
        TBAR=TBAR/NMEAS
        DO J=1,3
          S0(J)=S0(J)/NMEAS
          S1(J)=S1(J)/NMEAS
        END DO
      END IF
C
C DISCOUNT REJECTED MEASUREMENTS.
C
      N=NMEAS
      DO I=1,NMEAS
        IF (WI(I).LE.0) N=N-1
      END DO
C
C COUNT ACCEPTED MEASUREMENTS.
C
      IF (N.EQ.1) NMEAS1=NMEAS1+1
      IF (N.EQ.2) NMEAS2=NMEAS2+1
      IF (N.GE.3) NMEAS3=NMEAS3+1
C
C OUTPUT UNIQUE DATA.
C
      CALL WRITE1 (IO2,NH,NK,NL,YMEAN,ESD,RMSD,N,TBAR,S0,S1)
      S=SINTHL(NH,NK,NL,GINV)
C
C IS THIS AN ACENTRIC OR CENTRIC REFLECTION?
C
      JH=-NH
      JK=-NK
      JL=-NL
      CALL EQUIV (IPTGP,JH,JK,JL)
      IF (JH.EQ.NH.AND.JK.EQ.NK.AND.JL.EQ.NL) THEN
        IC=1
      ELSE
        IC=0
      END IF
C
C ACCUMULATE AGREEMENT STATISTICS.
C
      CALL RSUMS (NMEAS,YI,SIGYI,WI,YMEAN,ESD,RMSD,S,IC)
C
C CATALOG REJECTED OR ZERO-WEIGHTED MEASUREMENTS.
C
      DO I=1,NMEAS
        IF (WI(I).LE.0) THEN
          NREJ=NREJ+1
          WRITE (IO5,REC=NREJ) (YI(I)-YMEAN)/ESD,ESD,NMEAS,
     &    II(I),IH(I),IK(I),IL(I),ISCALE(I),YI(I),SIGYI(I)
        END IF
      END DO
C
C CATALOG OUTLIERS.
C
      IF (NMEAS.GE.2) THEN
        IF (RMSD/ESD.GT.QLIMIT) THEN
          T=ZLIMIT*ESD
          IF (NMEAS.EQ.2) THEN
C
C DISCORDANT DUPLICATE MEASUREMENTS
C
            DO I=1,2
              IF (WI(I).GT.0.AND.ABS(YI(I)-YMEAN).GT.T) WI(I)=0
            END DO
            IF (WI(1).LE.0.OR.WI(2).LE.0) THEN
              YMEDIAN=0.5*(YI(1)+YI(2))
              DO I=1,2
                NBAD2=NBAD2+1
                WRITE (IO3,REC=NBAD2) (YI(I)-YMEDIAN)/ESD,ESD,NMEAS,
     &          II(I),IH(I),IK(I),IL(I),ISCALE(I),YI(I),SIGYI(I)
              END DO
            END IF
          ELSE
C
C DISCORDANT SAMPLES OF THREE OR MORE MEASUREMENTS
C
            DO I=1,NMEAS
              IF (WI(I).GT.0.AND.ABS(YI(I)-YMEAN).GT.T) THEN
                WI(I)=0
                NBADN=NBADN+1
                WRITE (IO4,REC=NBADN) (YI(I)-YMEAN)/ESD,ESD,NMEAS,
     &          II(I),IH(I),IK(I),IL(I),ISCALE(I),YI(I),SIGYI(I)
              END IF
            END DO
          END IF
        END IF
      END IF
C
C COUNT DISCORDANT MULTIPLE MEASUREMENT SAMPLES.
C
      DO I=1,NMEAS
        IF (WI(I).LE.0) THEN
          MBAD=MBAD+1
          GO TO 5
        END IF
      END DO
 5    CONTINUE
C
C PRINTED OUTPUT
C
      CALL DPRINT (IPRINT,JPRINT,NH,NK,NL,ESD,RMSD,QLIMIT,NMEAS,WI,
     & NPRINT)
      IF (NPRINT.EQ.0) GO TO 1
C
C PRINT MULTIPLE MEASUREMENTS.
C
      IF (NMEAS.GE.2) THEN
        CALL SORT (NMEAS,YI,INDEX)
        DO I=1,NMEAS
          J=INDEX(I)
          JJ=II(J)
          JH=IH(J)
          JK=IK(J)
          JL=IL(J)
          Y=YI(J)
          SIGY=SIGYI(J)
          JSCALE=ISCALE(J)
          IF (JPATH.NE.0) THEN
            TBAR=PATH(1,J)
            DO K=1,3
              S0(K)=PATH(1+K,J)
              S1(K)=PATH(4+K,J)
            END DO
          END IF
          IF (WI(J).LE.0) THEN
            FLAG='*'
          ELSE
            FLAG=' '
          END IF
          IF (JPATH.EQ.0) THEN
            WRITE (ILP,1001) FLAG,JJ,JH,JK,JL,Y,SIGY,JSCALE
          ELSE
            WRITE (ILP,2001) FLAG,JJ,JH,JK,JL,Y,SIGY,JSCALE,TBAR,S0,S1
          END IF
          NLINE=NLINE+1
          IF (MOD(NLINE,55).EQ.0) WRITE (ILP,1000) ATIME,ADATE,TITLE
        END DO
      END IF
C
C PRINT UNIQUE DATA.
C
      IF (NMEAS.EQ.1) THEN
        IF (JPATH.EQ.0) THEN
          WRITE (ILP,1002) II(1),NH,NK,NL,YMEAN,ESD,RMSD,RMSD/ESD,NMEAS,
     &    S,ISCALE(1)
        ELSE
          WRITE (ILP,2002) II(1),NH,NK,NL,YMEAN,ESD,RMSD,RMSD/ESD,NMEAS,
     &    S,ISCALE(1),TBAR,S0,S1
        END IF
      ELSE
        IF (JPATH.EQ.0) THEN
          WRITE (ILP,1003) NH,NK,NL,YMEAN,ESD,RMSD,RMSD/ESD,NMEAS,S
        ELSE
          WRITE (ILP,2003) NH,NK,NL,YMEAN,ESD,RMSD,RMSD/ESD,NMEAS,S,
     &    TBAR,S0,S1
        END IF
      END IF
      NLINE=NLINE+1
      IF (MOD(NLINE,55).EQ.0) WRITE (ILP,1000) ATIME,ADATE,TITLE
      GO TO 1
 9    CONTINUE
C
C END AVERAGING LOOP.
C
      CLOSE (UNIT=IO1,STATUS='DELETE')
      ENDFILE IO2
      I=IO1
      IO1=IO2
      IO2=I
C
C WRITE FILE OF REJECTED MEASUREMENTS SORTED ON Z = (Y - YMEAN)/ESD.
C
      IF (NREJ.GT.0) THEN
        DO I=1,NREJ
          READ (IO5,REC=I) ZI
          DATA(I)=ABS(ZI)
        END DO
        CALL SORT (NREJ,DATA,IREC)
        OPEN (UNIT=IO2,STATUS='NEW',FILE='reject.dat')
        WRITE (IO2,600) ATIME,ADATE,TITLE
        WRITE (IO2,610)
        DO I=NREJ,1,-1
          READ (IO5,REC=IREC(I)) ZI,ESD,NMEAS,JJ,JH,JK,JL,JSCALE,Y,SIGY
          WRITE (IO2,611)        JJ,JH,JK,JL,JSCALE,Y,SIGY,NMEAS,ESD,ZI
        END DO
        CLOSE (UNIT=IO2,STATUS='KEEP')
      END IF
      CLOSE (UNIT=IO5,STATUS='DELETE')
 610  FORMAT (/1X,'    JJ  JH  JK  JL JSCALE         YJ   SIGMA(YJ) NMEA
     &S ESD (YJ - YMEAN)/ESD'/1X,'    --  --  --  -- ------         --',
     &'   --------- ----- --- ----------------')
 611  FORMAT (1X,I6,3I4,I6,2F12.2,I6,F12.2,F8.1)
C
C WRITE SORTED FILE OF DISCORDANT DUPLICATE MEASUREMENTS.
C
      IF (NBAD2.GT.0) THEN
        DO I=1,NBAD2
          READ (IO3,REC=I) ZI
          DATA(I)=ABS(ZI)
        END DO
        CALL SORT (NBAD2,DATA,IREC)
        OPEN (UNIT=IO2,STATUS='NEW',FILE='twobad.dat')
        WRITE (IO2,600) ATIME,ADATE,TITLE
        WRITE (IO2,610)
        DO I=NBAD2,1,-1
          READ (IO3,REC=IREC(I)) ZI,ESD,NMEAS,JJ,JH,JK,JL,JSCALE,Y,SIGY
          WRITE (IO2,611)        JJ,JH,JK,JL,JSCALE,Y,SIGY,NMEAS,ESD,ZI
        END DO
        CLOSE (UNIT=IO2,STATUS='KEEP')
      END IF
      CLOSE (UNIT=IO3,STATUS='DELETE')
C
C WRITE SORTED FILE OF STATISTICAL OUTLIERS IN SAMPLES WITH THREE OR
C MORE MEASUREMENTS.
C
      IF (NBADN.GT.0) THEN
        DO I=1,NBADN
          READ (IO4,REC=I) ZI
          DATA(I)=ABS(ZI)
        END DO
        CALL SORT (NBADN,DATA,IREC)
        OPEN (UNIT=IO2,STATUS='NEW',FILE='outlier.dat')
        WRITE (IO2,600) ATIME,ADATE,TITLE
        WRITE (IO2,610)
        DO I=NBADN,1,-1
          READ (IO4,REC=IREC(I)) ZI,ESD,NMEAS,JJ,JH,JK,JL,JSCALE,Y,SIGY
          WRITE (IO2,611)        JJ,JH,JK,JL,JSCALE,Y,SIGY,NMEAS,ESD,ZI
        END DO
        CLOSE (UNIT=IO2,STATUS='KEEP')
      END IF
      CLOSE (UNIT=IO4,STATUS='DELETE')
C
C PRINT DATA MERGING AND DISTRIBUTION STATISTICS.
C
      WRITE (ILP,600) ATIME,ADATE,TITLE
 600  FORMAT ('1'//1X,'PROGRAM SORTAV/YMERGE.  ',A,1X,A,'.  ',A)
C
C NUMBERS OF MEASUREMENTS
C
      WRITE (ILP,'(/1X,''NTOTAL = '',I6,''  TOTAL MEASUREMENTS'')')
     & NTOTAL
      IF (NREJ.GT.0) WRITE (ILP,9019) NREJ,NTOTAL-NREJ
 9019 FORMAT (/1X,'NREJ   = ',I6,'  MEASUREMEN',
     &'TS REJECTED AS ABNORMAL OULIERS'/1X,'NACC   = ',I6,'  MEASUR',
     &'EMENTS ACCEPTED')
      WRITE (ILP,9020)
     & NMEAS1,NMEAS2,NMEAS3,NINDEP,FLOAT(NTOTAL-NREJ)/NINDEP
 9020 FORMAT (/1X,'NMEAS1 = ',I6,'  UNIQUE DATA MEASURED ONLY ONCE'
     &/1X,'NMEAS2 = ',I6,'  UNIQUE DATA MEASURED TWICE'/1X,
     &'NMEAS3 = ',I6,'  UNIQUE DATA MEASURED THREE OR MORE TIMES'//1X,
     &'NINDEP = ',I6,'  UNIQUE DATA'//1X,'<N>    = ',F6.1,'  OVERALL',
     &' AVERAGE MEASUREMENT MULTIPLICITY')
      IF (NMEAS2+NMEAS3.EQ.0) RETURN
C
C AVERAGING SCHEME
C
      IF (RR.GT.0) WRITE (ILP,624) PP,QQ,RR
      IF (C1.GT.0.OR.C2.GT.0.OR.C3.GT.0) WRITE (ILP,625) C1,C2,C3
      WRITE (ILP,622) IW,JW,ZZMAX
 624  FORMAT ('0ABNORMALLY LOW OUTLIERS REJECTED IF'/
     &'   Y .LT. YMAX - 2*R*SQRT((Q*SIGMA(YMAX))**2 + (P*YMAX)**2)'/
     &' WHERE'/'   P = ',F5.3/'   Q = ',F5.3/'   R = ',F5.3)
 625  FORMAT ('0ABNORMAL OUTLIERS FROM MEDIAN(Y) REJECTED IF'/'   IF ABS
     &(Y - MEDIAN(Y)) .GT. T,'/' WHERE'/'   T = MAX(C1*MEDIAN(Y),'/
     &'             C2*MEDIAN(SIGMA(Y)),'/
     &'               C3*1.25*MEDIAN(ABS(Y - MEDIAN(Y)))*',
     &'SQRT(N/(N - 1)),'/
     &'                 C4*ZCRIT(N)*MAX(MEDIAN(SIGMA(Y)),'/
     &'                      1.25*MEDIAN(ABS(Y - MEDIAN(Y)))*',
     &'SQRT(N/(N - 1)))',/
     &'   C1 = ',F5.2,', C2 = ',F5.2,'   C3 = ',F5.2,', C4 = ',F5.2,
     &'.')
 622  FORMAT ('0AVERAGED DATA:'/'   YMEAN = SUM(W*Y)/SUM(W)'/'   ESD   =
     & SQRT(SUM(W*SIGMA(Y)**2)/SUM(W))'/'   RMSD  = SQRT((SUM(W*(Y - YME
     &AN)**2)/SUM(W))*N/(N - 1))'/'0WEIGHTS FOR AVERAGING:'/'   W = WI*W
     &J'/' WHERE'/'   IF IW = 0,  WI = 1'/'   IF IW = 1,  WI = 1/SIGMA(Y
     &)**2'/'   IF JW = 0,  WJ = 1'/'   IF JW = 1,  WJ = EXP(-0.5*Z**2)'
     &/'   IF JW = 2,  WJ = (1 - (Z/ZMAX)**2)**2,  IF ABS(Z) .LT. ZMAX'/
     &'                  = 0,                     IF ABS(Z) .GE. ZMAX'/
     &'   Z = (Y - MEDIAN(Y))/SIGMA'/'   IF IW = 0,  SIGMA = MAX(MEDIAN(
     &SIGMA(Y)), 1.25*MEDIAN(ABS(Y - MEDIAN(Y)))*SQRT(N/(N - 1)))'/
     &'   IF I',
     &'W = 1,  SIGMA = SIGMA(Y)'/'0  IW   = ',I2/'   ---------'/'   JW',
     &'   = ',I2/'   ---------'/'   ZMAX = ',F4.1/'   -----------')
C
C OUTLIER MEASUREMENTS
C
      IF (MBAD.GT.0) WRITE (ILP,6001) NREJ,NBAD2/2,NBADN,MBAD,QLIMIT,
     & ZLIMIT
 6001 FORMAT ('0NREJ  = ',I6,' MEASUREMENTS REJECTED OR ZERO-WEIGHTED BE
     &FORE AVERAGING'/' NBAD2 = ',I6,' PAIRS OF DISCORDANT DUPLICATE MEA
     &SUREMENTS'/' NBADN = ',I6,' STATISTICAL OUTLIER MEASUREMENTS IN SA
     &MPLES WITH THREE OR MORE MEASUREMENTS'/' MBAD  = ',I6,' MEANS WITH
     & REJECTED, DISCORDANT DUPLICATE, OR STATISTICAL OUTLIER MEASUREMEN
     &TS:'/'0DISCORDANT MEASUREMENT SAMPLES ARE DEFINED AS THOSE WITH'/
     &'   RMSD/ESD .GT.           QLIMIT'/' AND ONE OR MORE MEASUREMENTS
     & WITH'/'   ABS(Y - YMEAN)/ESD .GT. ZLIMIT.'/'0  QLIMIT = ',F5.2/
     &'   ZLIMIT = ',F5.2/'0REJECTED MEASUREMENTS ARE LISTED IN A "rejec
     &t.dat" OUTPUT FILE.'/' DISCORDANT DUPLICATE MEASUREMENTS ARE LISTE
     &D IN A "twobad.dat" OUTPUT FILE.'/' STATISTICAL OUTLIERS IN SAMPLE
     &S OF THREE OR MORE MEASUREMENTS ARE LISTED IN'/' AN "outlier.dat',
     &'" OUTPUT FILE.'/'0REJECTED, DISCORDANT DUPLICATE, AND STATISTICAL
     & OUTLIER MEASUREMENTS ARE'/' MARKED WITH AN ASTERISK IN THE PRINTE
     &D LIST OF EQUIVALENT MEASUREMENTS.')
C
C DATA MERGING STATISTICS
C
      DO I=1,M4
        IF (NMEAN(I).GT.0) THEN
          R1(I)=R1NUM(I)/R1DEN(I)
          R2(I)=SQRT(R2NUM(I)/R2DEN(I))
          RW(I)=SQRT(RWNUM(I)/RWDEN(I))
          Z(I)=SQRT((ZNUM(I)/ZDEN(I))*NTERM(I)/(NTERM(I)-NMEAN(I)))
          V(I)=VNUM(I)/VDEN(I)
        ELSE
          R1(I)=0
          R2(I)=0
          RW(I)=0
          Z(I)=0
          V(I)=0
        END IF
      END DO
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,9021)
 9021 FORMAT (/1X,'DATA MERGING STATISTICS (ADJUSTED FOR MEASUREME',
     &'NT MULTIPLICITY):'/1X,'-----------------------------------------'
     &,'-----------------------'/1X,'  NORMALIZED MEAN ABSOLUTE DEVIAT',
     &'ION'/1X,'    R1 = <SQRT[N/(N - 1)]*ABS(Y - YMEAN)>/<Y>'/1X,
     &'       = SUM(H) SQRT[N/(N - 1)]*SUM(I) ABS(Y - YMEAN)/SUM(H) SUM'
     &,'(I) ABS(Y)'//1X,'  NORMALIZED ROOT-MEAN-SQUARE DEVIATION'/1X,
     &'    R2 = SQRT{<[N/(N - 1)]*(Y - YMEAN)**2>/<Y**2>}'/1X,
     &'       = SQRT{SUM(H) [N/(N - 1)]*SUM(I) [(Y - YMEAN)**2]/SUM(',
     &'H) SUM(I) Y**2}'//1X,'  NORMALIZED WEIGHTED ROOT-MEAN-SQUARE D',
     &'EVIATION'/1X,'    RW = SQRT{<[N/(N - 1)]*[(Y - YMEAN)/SIGMA(Y)]*'
     &,'*2>/<[Y/SIGMA(Y)]**2>}'/1X,'       = SQRT{SUM(H) [N/(N - 1)]*SU'
     &,'M(I) W*[(Y - YMEAN)/SIGMA(Y)]**2/SUM(H) SUM(I) W*[Y/SIGMA(Y)]',
     &'**2}'//1X,'  STANDARDIZED ROOT-MEAN-SQUARE DEVIATION'/1X,
     &'    Z  = SQRT[<CHISQ>*N/(N - M)],    ',
     &'<CHISQ> = SUM(H) [N/(N - 1)]*SUM(I) W*[Y - YMEAN)/SIGMA(Y)]',
     &'(**2/SUM(H) SUM(I) W'//1X,'  NORMALIZED ROOT',
     &'-MEAN-SQUARE DEVIATION, OR POOLED COEFFICIENT OF VARIATION'/1X,
     &'    V  = <RMSD>/<YMEAN>'/1X,'       = SUM(H) SQRT{[N/(N - 1)]*',
     &'SUM(I) W*(Y - YMEAN)**2/SUM(I) W}/SUM(H) YMEAN'//1X,'  WHERE ',
     &'   W = WI*WJ    WI = 1    OR          WJ = 1    OR'/1X,
     &'                        WI = 1/SIGMA(Y)**2    WJ = EXP(-0.5*Z**2'
     &,')    OR'/1X,'                                              WJ',
     &' = {1 - MIN[1, (Z/ZMAX)**2]}**2,    IN WHICH    Z = (Y - YMEAN)/'
     &,'SIGMA(Y)'//1X,'DATA CLASSES:'/1X,'-------------'/1X,'  INTEN',
     &'SITY SIGNIFICANCE    Q = YMEAN/MAX(ESD, RMSD)'/1X,'  DIFFRACTION'
     &,' RESOLUTION    D = 1/(2*S)  (ANGSTROM),    S = SIN(THETA)/LAMBD'
     &,'A  (ANGSTROM**-1)')
      WRITE (ILP,9022)
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=1,14)
 9022 FORMAT (/1X,
     &'CUMULATIVE INTENSITY-SIGNIFICANCE SUBSETS  (Q .GE. QMIN)'/1X,
     &'--------------------------------------------------------'/1X,
     &'NO OUTLIER REJECTION OR DOWN-WEIGHTING'/1X,
     &'                      NTERMS  NMEANS   <N>    R1      R2      RW'
     &,'       Z       V'/1X,
     &'                      ------  ------   ---  ------  ------  ----'
     &,'--   -----   -----'/1X,
     &'         ALL DATA   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 0      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 1      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 2      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 3      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 4      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 6      ',2I8,F6.1,3F8.4,2F8.3//1X,
     &'OUTLIERS DOWN-WEIGHTED OR REJECTED (HERE AND IN ALL THE FOLLOWIN'
     &,'G TABLES)'/1X,
     &'                      NTERMS  NMEANS   <N>    R1      R2      RW'
     &,'       Z       V'/1X,
     &'                      ------  ------   ---  ------  ------  ----'
     &,'--   -----   -----'/1X,
     &'         ALL DATA   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 0      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 1      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 2      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 3      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 4      ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         Q > 6      ',2I8,F6.1,3F8.4,2F8.3)
      WRITE (ILP,9023)
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=15,16)
 9023 FORMAT (/1X,
     &'ACENTRIC AND CENTRIC REFLECTION SUBSETS'/1X,
     &'---------------------------------------'/1X,
     &'                      NTERMS  NMEANS   <N>    R1      R2      RW'
     &,'       Z       V'/1X,
     &'                      ------  ------   ---  ------  ------  ----'
     &,'--   -----   -----'/1X,     
     &'    ACENTRIC HKL    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     CENTRIC HKL    ',2I8,F6.1,3F8.4,2F8.3)
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,9024)
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=17,33)
 9024 FORMAT (/1X,
     &'INTENSITY-SIGNIFICANCE INTERVALS  (QMIN .LT. Q .LE. QMAX)'/1X,
     &'---------------------------------------------------------'/1X,
     &'                      NTERMS  NMEANS   <N>    R1      R2      RW'
     &,'       Z       V'/1X,
     &'                      ------  ------   ---  ------  ------  ----'
     &,'--   -----   -----'/1X,
     &'         Q <  -4    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    -4 < Q <  -3    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    -3 < Q <  -2    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    -2 < Q <  -1    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    -1 < Q <   0    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     0 < Q <   1    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     1 < Q <   2    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     2 < Q <   3    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     3 < Q <   4    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     4 < Q <   6    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     6 < Q <   8    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'     8 < Q <  10    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    10 < Q <  20    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    20 < Q <  30    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    30 < Q <  50    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'    50 < Q < 100    ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'   100 < Q          ',2I8,F6.1,3F8.4,2F8.3)
      DO I=1,M2-1
        IF (X2(I).LT.SMAX) IMAX=I+1
      END DO
      DO I=1,M2
        IF (I.GT.IMAX) THEN
          J=I+33
          NTERM(J)=0
          NMEAN(J)=0
          R1(J)=0
          R2(J)=0
          RW(J)=0
          Z(J)=0
          V(J)=0
        END IF
      END DO
      WRITE (ILP,9025)
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=34,48)
 9025 FORMAT (/1X,
     &'CUMULATIVE RESOLUTION SUBSETS  (S .LE. SMAX)  (D .GE. DMIN)'/
     &1X,
     &'-----------------------------------------------------------'/
     &1X,
     &'                      NTERMS  NMEANS   <N>    R1      R2      RW'
     &,'       Z       V'/1X,
     &'                      ------  ------   ---  ------  ------  ----'
     &,'--   -----   -----'/1X,
     &'         D > 10     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  8     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  6     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  4     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  3.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  3     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  2.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  2     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  1.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  1     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  0.75  ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  0.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  0.4   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  0.35  ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'         D >  0     ',2I8,F6.1,3F8.4,2F8.3)
      WRITE (ILP,9026)
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=49,63)
 9026 FORMAT (/1X,
     &'RESOLUTION SHELLS  (SMIN .LT. S .LE. SMAX)  (DMAX .GT. D .GE. ',
     &'DMIN)'/1X,
     &'----------------------------------------------------------------'
     &,'---'/1X,
     &'                      NTERMS  NMEANS   <N>    R1      R2      RW'
     &,'       Z       V'/1X,
     &'                      ------  ------   ---  ------  ------  ----'
     &,'--   -----   -----'/1X,
     &'         D > 10     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &' 10    > D >  8     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  8    > D >  6     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  6    > D >  4     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  4    > D >  3.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  3.5  > D >  3     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  3    > D >  2.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  2.5  > D >  2     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  2    > D >  1.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  1.5  > D >  1     ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  1    > D >  0.75  ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  0.75 > D >  0.5   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  0.5  > D >  0.4   ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  0.4  > D >  0.35  ',2I8,F6.1,3F8.4,2F8.3/1X,
     &'  0.35 > D          ',2I8,F6.1,3F8.4,2F8.3)
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,9027) 1/(2*X3(1)),
     & NTERM(64),NMEAN(64),FLOAT(NTERM(64))/MAX(1,NMEAN(64)),
     & R1(64),R2(64),RW(64),Z(64),V(64)
 9027 FORMAT (/1X,
     &'EQUAL-VOLUME RESOLUTION SHELLS (SMIN .LT. S .LE. SMAX) (DMAX ',
     &'.GT. D .GE. DMIN)'/1X,
     &'----------------------------------------------------------------'
     &,'--------------'/1X,
     &'                      NTERMS  NMEANS   <N>    R1      R2      RW'
     &,'       Z       V'/1X,
     &'                      ------  ------   ---  ------  ------  ----'
     &,'--   -----   -----'/1X,
     &  6X,'   D > ',F6.3,1X,2I8,F6.1,3F8.4,2F8.3)
      DO I=2,20
        J=I+63
        WRITE (ILP,'(1X,F6.3,'' > D > '',F6.3,1X,2I8,F6.1,3F8.4,2F8.3)')
     &  1/(2*X3(I-1)),1/(2*X3(I)),NTERM(J),NMEAN(J),
     &  FLOAT(NTERM(J))/MAX(1,NMEAN(J)),R1(J),R2(J),RW(J),Z(J),V(J)
      END DO
C
C ANALYSIS OF VARIANCE
C
      CALL ANOVA
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE YSCALE
C
C FIT LEAST-SQUARES RELATIVE SCALE FACTORS FOR SUBSETS OF THE DATA.
C
C BASED ON THE METHOD DESCRIBED BY W. C. HAMILTON, J. S. ROLLETT, AND
C R. A. SPARKS (1965).  ACTA CRYST. 18, 129-130.
C
C   CHISQ = SUM(H) SUM(I) W(H,I)*(Y(H,I) - Y(H)/K(I))**2 ,
C
C WHERE
C
C   W(H,I) = 1/SIGMA(Y(H,I))**2
C
C AND, FROM THE CONDITION THAT THE DERIVATIVE (D CHISQ/D Y(H)) = 0 FOR
C MINIMUM CHISQ WITH GIVEN VALUES FOR THE K(I),
C
C   Y(H) = (SUM(I) W(H,I)*Y(H,I)/K(I))/(SUM(I) W(H,I)/K(I)**2) .
C
C THAT IS, Y(H) IS THE SCALED WEIGHTED AVERAGE OF THE SCALED Y(H,I),
C
C          SUM(I) (W(H,I)/K(I)**2)*K(I)*Y(H,I)
C   Y(H) = ----------------------------------- .
C                SUM(I) (W(H,I)/K(I)**2)
C
      character ztime*8,zdate*9
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      PARAMETER (KMAX=600)
      COMMON /BLOCKS/ NSCALE,SCALEK(KMAX),IFIXED,QMIN,ZMAX
      DIMENSION NDATA(KMAX,KMAX),WK(KMAX),WY(KMAX),DYDK(KMAX),
     & AA(KMAX,KMAX),BB(KMAX),DELTAJ(KMAX),SIGMAJ(KMAX),SIGMAK(KMAX)
      DOUBLE PRECISION AA,BB
      EQUIVALENCE (NDATA(1,1),AA(1,1))
      DIMENSION YI(NMAX/20),SIGYI(NMAX/20),ISCALE(NMAX/20)
      EQUIVALENCE (YI(1),DATA(1)),(SIGYI(1),DATA(1+NMAX/20)),
     & (ISCALE(1),DATA(1+2*NMAX/20))
      DIMENSION WW(NMAX/2)  
      EQUIVALENCE (WW(1),DATA(1+NMAX/2))
      DIMENSION ANG(4),S0(3),S1(3)
      DIMENSION XDATA(KMAX),YDATA(KMAX),YPP(KMAX)
      IF (NSCALE.EQ.1) RETURN
      WRITE (ILP,600) ATIME,ADATE,TITLE
 600  FORMAT ('1'/1X,'PROGRAM SORTAV/YSCALE.  ',A,', ',A,'.  ',A)
C
C ZERO SUBSET DATA POPULATION MATRIX.
C
      DO I=1,NSCALE
      DO J=1,NSCALE
        NDATA(I,J)=0
      END DO
      END DO
C
C WRITE A WORKING FILE OF DATA WITH MULTIPLE SIGNIFICANT MEASUREMENTS
C AND MULTIPLE SCALE FACTORS.
C
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED')
      REWIND IO1
      NH=0
      II=0
 1    READ (IO1,END=9) N
C
C OMIT SINGLE MEASUREMENTS.
C
      IF (N.EQ.1) THEN
        READ (IO1)
        GO TO 1
      END IF
C
C OMIT WEAK DATA.
C
      I=0
      DO J=1,N
        READ (IO1) JJ,JH,JK,JL,Y,SIGY,JSCALE
        IF (Y/SIGY.GE.QMIN) THEN
          I=I+1
          YI(I)=Y
          SIGYI(I)=SIGY
          ISCALE(I)=JSCALE
        END IF
      END DO
      N=I
      IF (N.LT.2) GO TO 1
C
C OMIT SAMPLES WITH ONLY ONE SCALE FACTOR.
C
      DO I=2,N
        IF (ISCALE(I).NE.ISCALE(1)) GO TO 2
      END DO
      GO TO 1
 2    CONTINUE
C
C WRITE WORKING FILE.
C
      WRITE (IO2) N
      DO I=1,N
        WRITE (IO2) YI(I),SIGYI(I),ISCALE(I)
C
C INITIALIZE WEIGHTS.
C
        II=II+1
        WW(II)=1/(SIGYI(I)**2+(PP*YI(I))**2)
      END DO
C
C COUNT UNIQUE AND MULTIPLE DATA.
C
      NH=NH+1
      NHI=NHI+N
C
C COUNT DATA IN SUBSETS.
C
      DO I=1,N
        K=ISCALE(I)
        NDATA(K,K)=NDATA(K,K)+1
      DO J=I,N
        L=ISCALE(J)
        IF (K.NE.L) THEN
          NDATA(K,L)=NDATA(K,L)+1
          NDATA(L,K)=NDATA(K,L)
        END IF
      END DO
      END DO
      GO TO 1
 9    ENDFILE IO2
C
C PRINT SUBSET POPULATION MATRIX.
C
      WRITE (ILP,9028)
 9028 FORMAT (/1X,'SUBSET POPULATION MATRIX NDATA(ISCALE,JSCALE) F',
     &'OR INTER-SUBSET SCALING:'/1X,'----------------------------------'
     &,'-------------------------------------'/1X,'   I      1    2    '
     &,'3    4    5    6    7    8    9    0    1    2    3    4    5 ',
     &'   6    7    8    9    0'/1X,'   -      -    -    -    -    -',
     &'    -    -    -    -    -    -    -    -    -    -    -    - ',
     &'   -    -    -')
      DO I=1,NSCALE
        WRITE (ILP,'(1X,I4,2X,25(20I5/7X))') I,(NDATA(I,J),J=1,I)
      END DO
      WRITE (ILP,9029) QMIN,NHI
 9029 FORMAT (/1X,'REFLECTIONS WITH Y/SIGMA(Y) .LT. QMIN, WHERE'/
     &1X,'    QMIN = ',F5.2,','/1X,'    ------------'/1X,'ARE OMI',
     &'TTED FROM NDATA(ISCALE,JSCALE) AND FROM THE INTER-SUBSET SCALIN',
     &'G.'//1X,'NTOTAL = SUM(I) NDATA(I,I) = ',I6)
C
C TEST FOR A USER-SELECTED FIXED SCALE FACTOR FLAGGED BY A NEGATIVE
C SIGN.
C
      DO I=1,NSCALE
        IF (SCALEK(I).LT.0) THEN
          SCALEK(I)=-SCALEK(I)
          IFIXED=I
          GO TO 15
        END IF
      END DO
C
C SELECT THE SCALE FACTOR FOR THE LARGEST SUBSET OF THE DATA TO BE THE
C FIXED SCALE FACTOR.
C
      N=NDATA(1,1)
      IFIXED=1
      DO I=2,NSCALE
        IF (NDATA(I,I).GT.N) THEN
          N=NDATA(I,I)
          IFIXED=I
        END IF
      END DO
 15   CONTINUE
C
C NORMALIZE ALL SCALE FACTORS TO THE FIXED SCALE FACTOR.
C
      DO I=1,NSCALE      
        SCALEK(I)=SCALEK(I)/SCALEK(IFIXED)
      END DO
      NI=NSCALE
      NPAR=NI-1
C
C ITERATE LEAST-SQUARES CYCLES UNTIL SHIFTS ARE SATISFACTORILY SMALL.
C
      write (6,9030)
 9030 format (/1x,
     &'    time      date ncycle nzero           R              Z'/1x,
     &'    ----      ---- ------ -----           -              -')
      R=1E10
      Z=1E10
      NCYCLE=0
 100  NCYCLE=NCYCLE+1
      DO I=1,NPAR
        BB(I)=0
      DO J=I,NPAR
        AA(J,I)=0
      END DO
      END DO
      NFREE=NHI-NH-NI-1
      CHISQ=0
      SUMSQ=0
      NZERO=0
      ZZMAX=ZMAX*MAX(Z,1.0)
C
C LOOP THROUGH WORKING DATA FILE TO BUILD NORMAL MATRIX AND VECTOR.
C
      II=0
      REWIND IO2
 10   READ (IO2,END=19) N
      DO I=1,N
        READ (IO2) YI(I),SIGYI(I),ISCALE(I)
      END DO
C
C ELIMINATE SAMPLES EXHAUSTED BY ZERO-WEIGHTING IN THE PRECEDING CYCLE.
C
      I=0
      J=0
      K=0
      DO WHILE (I.LT.N.AND.J.LT.2)
        II=II+1
        I=I+1
        IF (WW(II).NE.0.AND.ISCALE(I).NE.K) THEN
          J=J+1
          K=ISCALE(I)
        END IF
      END DO
      IF (J.LT.2) THEN
        NZERO=NZERO+N
        NFREE=NFREE-N
        GO TO 10
      END IF
C
C EVALUATE AVERAGE SCALED VALUE AND DERIVATIVES.
C
      SUMW=0
      SUMY=0
      DO J=1,NPAR
        WK(J)=0
        WY(J)=0
      END DO
      II=II-N
      DO I=1,N
C
C USE WEIGHTS FROM THE PRECEDING CYCLE.
C
        II=II+1
        W=WW(II)
        Y=YI(I)
        SCALE=SCALEK(ISCALE(I))
        SUMW=SUMW+W/SCALE**2
        SUMY=SUMY+W*Y/SCALE
        IF (ISCALE(I).NE.IFIXED) THEN
          J=ISCALE(I)-IFIXED
          IF (J.LT.0) J=J+NSCALE
          WK(J)=WK(J)+W/SCALE
          WY(J)=WY(J)+W*Y
        END IF
      END DO
      YMEAN=SUMY/SUMW
      DO I=1,NSCALE
        IF (I.NE.IFIXED) THEN
          J=I-IFIXED
          IF (J.LT.0) J=J+NSCALE
          DYDK(J)=(2*YMEAN*WK(J)-WY(J))/(SCALEK(I)**2*SUMW)
        END IF
      END DO
C
C ACCUMULATE COEFFICIENTS OF NORMAL EQUATIONS.
C
      II=II-N
      DO I=1,N
        II=II+1
        IF (WW(II).EQ.0) THEN
          NZERO=NZERO+1
          NFREE=NFREE-1
          GO TO 50
        END IF
        Y=YI(I)
        SCALE=SCALEK(ISCALE(I))
        DELY=Y-YMEAN/SCALE
        SIGY=SIGYI(I)
        IF (ABS(DELY)/SIGY.GT.ZZMAX) THEN
C
C GIVE ZERO WEIGHT TO EXTREME OUTLIERS.
C
          WW(II)=0
          NZERO=NZERO+1
          NFREE=NFREE-1
          GO TO 50
        ELSE
C
C EVALUATE AND STORE WEIGHTS.
C
          WW(II)=1/(SIGY**2+(PP*YMEAN/SCALE)**2)
          W=WW(II)
        END IF
        CHISQ=CHISQ+W*DELY**2
        SUMSQ=SUMSQ+W*Y**2
C
C DELTA(I,J) IS THE KRONECKER DELTA.
C
        J=ISCALE(I)-IFIXED
        IF (J.LT.0) J=J+NSCALE
        DO K=1,NPAR
          DK=(DYDK(K)-DELTA(J,K)*YMEAN/SCALE)/SCALE
          BB(K)=BB(K)+W*DK*DELY
        DO L=K,NPAR
          DL=(DYDK(L)-DELTA(J,L)*YMEAN/SCALE)/SCALE
          AA(L,K)=AA(L,K)+W*DK*DL
        END DO
        END DO
 50     CONTINUE
      END DO
      GO TO 10
 19   CONTINUE
      DO I=1,NPAR-1
      DO J=I+1,NPAR
        AA(I,J)=AA(J,I)
      END DO
      END DO
C
C INVERT NORMAL MATRIX.
C
      CALL MATINV (NPAR,KMAX,AA,DET)
      IF (DET.EQ.0) GO TO 99
C
C CALCULATE NORMALIZED AND STANDARDIZED ROOT-MEAN-SQUARE ERRORS OF FIT.
C
      T=R
      R=SQRT(CHISQ/SUMSQ)
      Z=SQRT(CHISQ/NFREE)
      call time (ztime)
      call date (zdate)
      write (6,'(1x,a,1x,a,i4,i6,2e15.7)') ztime,zdate,ncycle,nzero,r,z
C
C CALCULATE PARAMETER SHIFTS AND ESTIMATE ERRORS.
C
      DO I=1,NPAR
        DELTAJ(I)=0
      DO J=1,NPAR
        DELTAJ(I)=DELTAJ(I)+AA(I,J)*BB(J)
      END DO
        SIGMAJ(I)=Z*SQRT(AA(I,I))
      END DO
C
C TEST FOR CONVERGENCE.
C
      IF ((R-T)/T.LT.-1E-6) THEN
C
C FIT CONVERGING OR CONVERGED.  COMPILE SHIFT-TO-ERROR RATIOS, AND APPLY
C SHIFTS.
C
        DMAX=0
        DAVG=0
        DO I=1,NSCALE
          IF (I.NE.IFIXED) THEN
            J=I-IFIXED
            IF (J.LT.0) J=J+NSCALE
            D=ABS(DELTAJ(J))/SIGMAJ(J)
            DMAX=MAX(DMAX,D)
            DAVG=DAVG+D
C
C SCALE FACTORS MUST REMAIN POSITIVE.  PREVENT EXCESSIVE NEGATIVE
C SHIFTS.
C
            D=MAX(DELTAJ(J),-0.7*SCALEK(I))
            SCALEK(I)=SCALEK(I)+D
            SIGMAK(I)=SIGMAJ(J)
          END IF
        END DO
        SIGMAK(IFIXED)=0
        DAVG=DAVG/NPAR
C
C TEST SHIFT-TO-ERROR RATIOS.
C
        IF (DAVG.LT.1E-3) THEN
C
C FIT CONVERGED.
C
          GO TO 99
        ELSE
C
C FIT CONVERGING.
C
          IF (NCYCLE.LT.50) THEN
            GO TO 100
          ELSE
            WRITE (ILP,609) NCYCLE,IFIXED,NSCALE,(J,DELTAJ(J),J=1,NPAR)
            GO TO 99
          END IF
        END IF
      ELSE
C
C FIT CONVERGED OR DIVERGING.
C
        WRITE (ILP,608) NCYCLE,R,T
      END IF
 99   CONTINUE
      WRITE (ILP,601) (I,SCALEK(I),SIGMAK(I),I=1,NSCALE)
      WRITE (ILP,602) Z,R,NCYCLE,NZERO,NI,NH,NHI,NFREE,DAVG,DMAX,NZERO,
     & ZMAX
      IF (DET.EQ.0) STOP 'SINGULAR NORMAL MATRIX FOR SCALE FACTORS FIT'
C
C PRINT CORRELATION MATRIX.
C
      WRITE (ILP,610) IFIXED,NSCALE,NPAR
      DO I=1,NPAR
        WRITE (ILP,611) I,
     &  (NINT(100*REAL(AA(I,J)/SQRT(AA(I,I)*AA(J,J)))),J=1,I)
      END DO
 601  FORMAT ('0FITTED RELATIVE SCALE FACTORS FOR SUBSETS OF THE DATA SE
     &T'/'0   I   SCALEK(I)   SIGMAK(I)'/'    -   ---------   ---------'
     &/(1X,I4,2(2X,F10.5)))
 602  FORMAT ('0CONVERGENCE TEST:  [R(N) - R(N-1)]/R(N-1) .LT. -1E-6 AND
     & <ABS(DELTAK(I))/SIGMAK(I)> .LT. 1E-3'/'0STATISTICS OF FIT:'/'0CHI
     &SQ = SUM(H) SUM(I) WHI*(YHI - YH/KI)**2'/' WHI   = 1/SIGMA(YHI)**2
     &'/'0STANDARDIZED ROOT-MEAN-SQUARE ERROR-OF-FIT    Z  = SQRT(CHISQ/
     &NFREE)'/' NORMALIZED ROOT-MEAN-SQUARE ERROR-OF-FIT      R  = SQRT[
     &CHISQ/SUM(H) SUM(I) WHI*YHI**2]'/'0Z  = ',E10.3/' R  = ',E10.3/'0N
     &CYCLES   = ',I6,' CYCLES'/' NZERO     = ',I6,' ZERO-WEIGHTED DAT',
     &'A IN THE FINAL CYCLE'/' NSCALE    = ',I6,' = NI'/' NUNIQUE   = ',
     &I6,' = NH'/' NMULTIPLE = ',I6,' = NHI'/' NFREE     = ',I6,' = NH',
     &'I - NH - NI - 1 - NZERO'/'0FINAL CYCLE AVERAGE AND MAXIMUM ABS(DE
     &LTAK(I))/SIGMAK(I):'/'0AVERAGE = ',E10.3/' MAXIMUM = ',E10.3/'0NZE
     &RO = ',I10,' OUTLIERS WITH ABS(YHI - YH/KI)/SIGMA(YHI) .GT. ZMAX*M
     &AX(Z, 1.0) FOR'/' ZMAX  = ',F10.2,' WERE GIVEN ZERO WEIGHT IN TH',
     &'E FINAL CYCLE.')
 608  FORMAT ('0FIT CONVERGED OR DIVERGING:'/'0NCYCLE        = ',I15/
     &' R(NCYCLE)     = ',E15.7/' R(NCYCLE - 1) = ',E15.7)
 609  FORMAT ('0FIT FAILED TO CONVERGE AFTER ',I3,' CYCLES.'/'0SHIFTS IN
     & FINAL CYCLE:'/' (J = MOD((ISCALE - IFIXED + NSCALE), NSCALE), IFI
     &XED = ',I4,', NSCALE = ',I4,')'/'0   J   DELTAK(J)'/'    -   -----
     &----'/(1X,I4,2X,F10.5))
 610  FORMAT (/1X,'SCALE FACTORS CORRELATION MATRIX:'/1X,'--------------
     &-------------------'/1X,'100*COV(I,J)/SQRT(VAR(I)*VAR(J)),WHERE'/
     &1X,'I = MOD((ISCALE - IFIXED + NSCALE), NSCALE)'/1X,'J = MOD((JSCA
     &LE - IFIXED + NSCALE), NSCALE)'/1X,'IFIXED = ',I4/1X,'NSCALE = ',
     &I4/1X,'NPARAM = ',I4,' = NSCALE - 1'/1X,'   I      1    2    3  ',
     &'  4    5    6    7    8    9    0    1    2    3    4    5    6',
     &'    7    8    9    0'/1X,'   -      -    -    -    -    -    - ',
     &'   -    -    -    -    -    -    -    -    -    -    -    -    ',
     &'-    -')
 611  FORMAT (1X,I4,2X,25(20I5/7X))
C
C PLOT SCALE FACTORS.
C
      IF (NSCALE.GE.10) THEN
        XMIN=1
        XMAX=NSCALE
        YMIN=+9E9
        YMAX=-9E9
        DO I=1,NSCALE
          XDATA(I)=I
          YDATA(I)=SCALEK(I)
          YMIN=MIN(YMIN,YDATA(I))
          YMAX=MAX(YMAX,YDATA(I))
        END DO
        CALL SPLINE (NSCALE,XDATA,YDATA,YPP)
        Y0=0.5*(YMIN+YMAX)
        DY=YMAX-YMIN
        YMIN=Y0-DY
        YMAX=Y0+DY
        YMIN=MAX(YMIN,0.0)
        WRITE (ILP,620) ATIME,ADATE,TITLE
        CALL PLOTK (ILP,XMIN,XMAX,YMIN,YMAX,NSCALE,XDATA,YDATA,YPP)
        WRITE (ILP,621)
      END IF
 620  FORMAT ('1'/1X,10X,'PROGRAM SORTAV/YSCALE.  ',A,', ',A,'.  ',A/)
 621  FORMAT (/1X,10X,'SUBSET SCALE FACTOR (VERTICAL) VERSUS SUBSET SERI
     &AL NUMBER (HORIZONTAL).')
C
C SCALE DATA.
C
      REWIND IO1
      CLOSE (UNIT=IO2,STATUS='DELETE')
      OPEN  (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED')
 81   READ  (IO1,END=89) NMEAS,JH,JK,JL
      WRITE (IO2)        NMEAS,JH,JK,JL
      DO I=1,NMEAS
        READ  (IO1) JJ,JH,JK,JL,Y,SIGY,JSCALE,ANG,TBAR,S0,S1
        SIGY=SQRT((SCALEK(JSCALE)*SIGY)**2+(Y*SIGMAK(JSCALE))**2)
        Y=SCALEK(JSCALE)*Y
        WRITE (IO2) JJ,JH,JK,JL,Y,SIGY,JSCALE,ANG,TBAR,S0,S1
      END DO
      GO TO 81
 89   CLOSE (UNIT=IO1,STATUS='DELETE')
      ENDFILE IO2
      I=IO1
      IO1=IO2
      IO2=I
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE YSSORT (N)
C
C PREPARE Y- AND S-SORTED SCRATCH FILES OF THE UNIQUE DATA FOR THE
C ANALYSIS OF VARIANCE AND SUMMARY DISTRIBUTION STATISTICS.      
C
      PARAMETER (NMAX=999999)
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,DATA(NMAX)
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IPTGP,G(3,3),GINV(3,3)
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,IPRINT,JPRINT,JPATH,
     & QLIMIT,ZLIMIT,QPRINT
      DIMENSION U0(3),U1(3)
      DATA TBAR,U0,U1 /7*0/
      DIMENSION INDEX(NMAX/2)
      EQUIVALENCE (INDEX(1),DATA(1+NMAX/2))
C
C READ DATA INTO SCRATCH FILE FOR SORTING.
C
      OPEN (UNIT=IO4,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=5)
      ITYPE=JPATH
      REWIND IO1
      IEND=0
      N=0
 1    CALL READ2 (IO1,ITYPE,IEND,IH,IK,IL,Y,ESD,RMSD,NMEAS,TBAR,U0,U1)
      IF (IEND.NE.0) GO TO 9
      S=SINTHL(IH,IK,IL,GINV)
      N=N+1
      WRITE (IO4,REC=N) S,Y,ESD,RMSD,NMEAS
      DATA(N)=Y
      GO TO 1
 9    CONTINUE
C
C SORT ON DECREASING Y.
C
      CALL SORT (N,DATA,INDEX)
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED')
      DO I=0,N-1
        READ (IO4,REC=INDEX(N-I)) S,Y,ESD,RMSD,NMEAS
        WRITE (IO2)               S,Y,ESD,RMSD,NMEAS
      END DO
      ENDFILE IO2
C
C SORT ON INCREASING S.
C
      DO I=1,N
        READ (IO4,REC=I) S
        DATA(I)=S
      END DO
      CALL SORT (N,DATA,INDEX)
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED')
      DO I=1,N
        READ (IO4,REC=INDEX(I)) S,Y,ESD,RMSD,NMEAS
        WRITE (IO3)             S,Y,ESD,RMSD,NMEAS
      END DO
      ENDFILE IO3
      CLOSE (UNIT=IO4,STATUS='DELETE')
      RETURN
      END
C-----------------------------------------------------------------------
      FUNCTION ZCRIT(NDATA)
C
C TABLE OF CRITICAL VALUES FOR CHAUVENET'S CRITERION FOR DISCORDANT DATA
C
C ZCRIT IS THE VALUE OF Z = ABS(DELTA)/SIGMA CORRESPONDING TO A NORMAL
C PROBABILITY P = 1/(2*NDATA) THAT Z > ZCRIT.
C
C HUGH D. YOUNG (1969).  STATISTICAL TREATMENT OF EXPERIMENTAL DATA,
C PP. 78-79, 162.  NEW YORK:  MC GRAW-HILL BOOK CO.
C
      DIMENSION N(27),Z(27)
      DATA N /   2,    3,    4,    5,    6,    7,    8,    9,   10,
     &          12,   14,   16,   18,   20,   25,   30,   40,   50,
     &          60,   80,  100,  150,  200,  300,  400,  500, 1000/
      DATA Z /1.15, 1.38, 1.54, 1.65, 1.73, 1.81, 1.86, 1.91, 1.96,
     &        2.04, 2.10, 2.15, 2.20, 2.24, 2.33, 2.39, 2.49, 2.57,
     &        2.64, 2.74, 2.81, 2.93, 3.02, 3.14, 3.23, 3.29, 3.48/
      ZCRIT=1.0
C
C LIMITING ZCRIT VALUES
C
      IF (NDATA.LE.N(1)) THEN
        ZCRIT=Z(1)
        RETURN
      END IF
      IF (NDATA.GE.N(27)) THEN
        ZCRIT=Z(27)
        RETURN
      END IF
C
C ZCRIT FROM TABLE BY LINEAR INTERPOLATION
C
      DO I=2,27
        IF (NDATA.LE.N(I)) THEN
          IF (NDATA.EQ.N(I)) THEN
            ZCRIT=Z(I)
          ELSE
            ZCRIT=Z(I)-(N(I)-NDATA)*(Z(I)-Z(I-1))/(N(I)-N(I-1))
          END IF
          RETURN
        END IF
      END DO
C
C SHOULD NEVER GET HERE.
C
      ZCRIT=1.0
      END
C-----------------------------------------------------------------------