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 SPRING 1980,..., FEBRUARY 2001
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, OR ABSORPTION-
C   LIKE, ANISOTROPY BASED ON A LEAST-SQUARES FIT OF REAL SPHERICAL
C   HARMONIC FUNCTIONS TO THE EMPIRICAL TRANSMISSION SURFACE AS SAMPLED
C   BY MULTIPLE SYMMETRY-EQUIVALENT AND/OR AZIMUTH-ROTATION-EQUIVALENT
C   REFLECTION 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 - AT MOST NFILE = 10 INPUT REFLECTION 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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
C
C REFLECTIONS FOR INPUT REJECTION
C
      COMMON /BLOCKJ/ SMINJ,SMAXJ,JN,JHKL
C
C REFLECTION DATA LIMITS
C
      COMMON /BLOCK3/ SMIN,SMAX,
     & IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,
     & JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX,
     & LHMIN,LHMAX,LKMIN,LKMAX,LLMIN,LLMAX
C
C YSCALE VARIABLES
C
      COMMON /BLOCKS/ NSCALE,KSCALE,IFIXED,QMIN,ZMAX
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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
C
C YMERGE VARIABLES
C
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,IPRINT,JPRINT,JPATH,QLIMIT,ZLIMIT,QPRINT
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 /BLOCK3/ INITIAL MIN AND MAX VALUES
C
      DATA SMIN,SMAX,
     & IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,
     & JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX,
     & LHMIN,LHMAX,LKMIN,LKMAX,LLMIN,LLMAX
     & /9, 0,
     & +499, -499, +499, -499, +499, -499,
     & +499, -499, +499, -499, +499, -499,
     & +499, -499, +499, -499, +499, -499/
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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      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 TRANSMISSION SURFACE.
C
      REAL MEDIAN
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,NMAX
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80,PTGP*4
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      DIMENSION ANGLES(4),U0(3),U1(3)
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      REAL, ALLOCATABLE::YI(:),SIGYI(:),WI(:),A(:,:)
      ALLOCATE (YI(NMAX),SIGYI(NMAX),WI(NMAX),A(10,NMAX))
C
C DATA EQUIVALENT UNDER (CENTROSYMMETRIC) LAUE POINT GROUP SYMMTERY ON
C UNIT IO1, OR (NONCENTROSYMMETRIC) CRYSTAL CLASS POINT GROUP SYMMETRY
C ON UNIT IO2?
C
      IF (IPTGPA.EQ.IXTAL) IUNIT=IO2
      IF (IPTGPA.EQ.ILAUE) IUNIT=IO1
C
C PREPARE A WORKING FILE OF MULTIPLE EQUIVALENT DATA.
C
      NHKL=0
      NOBS=0
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED')
      REWIND IUNIT
 1    READ (IUNIT,END=9) NMEAS,IH,IK,IL
      IF (NMEAS.EQ.1) THEN
C
C SKIP SINGLE MEASUREMENTS.
C
        READ (IUNIT)
        GO TO 1
      END IF
      S=SINTHL(IH,IK,IL,GINV)
      IF (S.LT.STLMIN.OR.S.GT.STLMAX) THEN
C
C SKIP MEASUREMENTS OUTSIDE GIVEN SIN(THETA)/LAMBDA LIMITS.
C
        DO I=1,NMEAS
          READ (IUNIT)
        END DO
        GO TO 1
      END IF
      N=0
      DO I=1,NMEAS
        READ (IUNIT) II,IH,IK,IL,YJ,SIGYJ,ISCALE,ANGLES,TBAR,U0,U1
        N=N+1
        YI(N)=YJ
        SIGYI(N)=SIGYJ
        DO J=1,4
          A(J,N)=ANGLES(J)
        END DO
        DO J=1,3
          A(4+J,N)=U0(J)
          A(7+J,N)=U1(J)
        END DO
      END DO
      IF (N.LT.2) GO TO 1
C
C OMIT MULTIPLE MEASUREMENT SAMPLES THAT CONTAIN MEASUREMENTS TOO WEAK
C TO BE SIGNIFICANT OR TOO STRONG TO BE 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 OMIT MULTIPLE MEASUREMENT SAMPLES THAT CONTAIN MEASUREMENTS THAT ARE
C PHYSICALLY UNREASONABLE, EXTREME 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 (IO3) NDATA,SUMW
      DO I=1,N
        IF (WI(I).GT.0) THEN
          DO J=1,3
            U0(J)=A(4+J,I)
            U1(J)=A(7+J,I)
          END DO
          WRITE (IO3) U0,U1,WI(I),YI(I)
        END IF
      END DO
      GO TO 1
 9    ENDFILE IO3
      DEALLOCATE (YI,SIGYI,WI,A)
      WRITE (ILP,'(/1H1,130(''-'')/1X,
     &''PROGRAM SORTAV/ABSORB.  '',A,'', '',A,''.  '',A)')
     & ATIME,ADATE,TITLE
      IF (IUNIT.EQ.IO1) PTGP='LAUE'
      IF (IUNIT.EQ.IO2) PTGP='XTAL'
      WRITE (ILP,'(//1X,
     &''REFLECTION DATA SELECTION FOR EMPIRICAL ANISOTROPY FITTING:''
     &/1X,
     &''-----------------------------------------------------------''
     &//1X,
     &''EQUIVALENT REFLECTIONS POINT GROUP          = '',A5//1X,
     &''MINIMUM PERMITTED SIN(THETA)/LAMBDA         = '',E10.3,
     &'' ANGSTROM**-1''/1X,
     &''MAXIMUM PERMITTED SIN(THETA)/LAMBDA         = '',E10.3,
     &'' ANGSTROM**-1''//1X,
     &''MINIMUM PERMITTED 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)/FSQ(SAMPLE MEDIAN) = '',E10.3//1X,
     &''NOBS = '',I10,'' REFLECTION MEASUREMENTS SELECTED''/1X,
     &''NHKL = '',I10,'' UNIQUE REFLECTIONS REPRESENTED'')')
     & PTGP,STLMIN,STLMAX,FSQMIN,FSQMAX,AIMIN,AIMAX,NOBS,NHKL
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB1
C
C FIT REAL SPHERICAL HARMONICS, YLM, TO EMPIRICAL TRANSMISSION SURFACE
C AS 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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,NMAX
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      DIMENSION YLM0(80),YLM1(80),QI(80),XI(80),A(80,80),B(80)
      DOUBLE PRECISION A,B
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      REAL, ALLOCATABLE::W(:),Y(:),U0(:,:),U1(:,:)
      ALLOCATE (W(NMAX),Y(NMAX),U0(3,NMAX),U1(3,NMAX))
C
C CALCULATE AGREEMENT STATISTICS FOR A = 1.
C
      NHKL=0
      NOBS=0
      CHISQ=0
      SUMSQ=0
      REWIND IO3
 11   READ (IO3,END=19) N,SUMW
      DO I=1,N
        READ (IO3) 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 ' SORTAV/ABSORB1:  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 IO3
 1    READ (IO3,END=9) N,SUMW
      DO I=1,N
        READ (IO3) (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 SOLVE THE NORMAL EQUATIONS.
C
      CALL SOLVE (NPAR,80,A,B,UMIN,NZERO)
C
C STORE THE PARAMETER VALUES.
C
      DO I=1,NPAR
        ALM(I)=B(I)
      END DO
C
C CALCULATE STATISTICS OF FIT.
C
      CHISQ=0
      SUMSQ=0
      AIMIN=1E10
      AIMAX=0
      SUMA=0
      SUMASQ=0
      CHISQA=0
      REWIND IO3
 41   READ (IO3,END=49) N,SUMW
      DO I=1,N
        READ (IO3) (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
      DEALLOCATE (W,Y,U0,U1)
      CLOSE (UNIT=IO3,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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      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 (/1H1,130('-')/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 AL',
     &'ONG THE REVERSE'/1X,'INCIDENT BEAM, -U0, OR THE DIFFRACTED BEAM',
     &', U1, REFERRED TO CRYSTAL-'/1X,'FIXED CARTESIAN (I.E., ORTHONOR',
     &'MAL) AXES.  IN OTHER WORDS, X, Y, AND, Z'/1X,'ARE DIRECTION COS',
     &'INES OF THE BEAM DIRECTION 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 FILTERI',
     &'NG'/1X,
     &'UMIN  = ',E11.3,'  MINIMUM PERMITTED EIGENVALUE MAGNITUDE EXPRE',
     &'SSED 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 COEFFIC',
     &'IENTS:'/1X,'---------------------------------------------------',
     &'-----'//1X,'TOTAL RESIDUAL        CHISQ    = CHISQ(Y) + CHISQ(A)'
     &/1X,'FIT 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,'RESTRAINT RESIDUAL    CHISQ(A) = SUM(H) SUM(I=1,N)',
     &' W*(AHI - 1)**2'//1X'WHERE HERE THE AHI ARE ABSORPTION ANISOTRO',
     &'PY 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 FIT RESIDUAL ARE WEIGHTED BY'/1X,'    WHI =',
     &' 1/SIGMA(YHI)**2,'/1X,'AND THE RESTRAINT RESIDUAL HAS A CONSTAN',
     &'T WEIGHTING FACTOR'/1X,'    W = WA/(<WHI*(YHI - <YHI>)**2>/<WHI',
     &'*YHI**2>),'/1X,'WHICH SERVES TO ADJUST THE RESTRAINT RESIDUAL T',
     &'O A SCALE COMPARABLE TO THE FIT RESIDUAL.'//1X,'STANDARDIZED RO',
     &'OT-MEAN-SQUARE ERROR-OF-FIT        Z  = SQRT(CHISQ(Y)/(NOBS - N',
     &'HKL - (NPAR - NZERO)))'/1X,'NORMALIZED ROOT-MEAN-SQUARE ERROR-O',
     &'F-FIT          RW = SQRT(CHISQ(Y)/SUM(WHI*(YHI*AHI)**2))'//1X,
     &'STANDARDIZED ROOT-MEAN-SQUARE RESTRAINT RESIDUAL  ZA = SQRT(CHI',
     &'SQ(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  = ',I8,'  MEASUREMENTS'/1X,
     &'NHKL  = ',I8,'  UNIQUE REFLECTIONS'/1X,
     &'NPAR  = ',I8,'  FITTED COEFFICIENTS A(L,M)'/1X,
     &'NZERO = ',I8,'  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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      CHARACTER P*1
      DIMENSION P(0:100,0:50)
C
C IF  MU*R = 0  AND  MU*TMIN = 0 ,  RETURN  A = 1.
C
      IF (FMU*RADIUS.EQ.0.AND.FMU*TMIN.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 (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A/)
 1001 FORMAT (1X,F10.8,101A1)
 1002 FORMAT (1X,10X,101A1)
 1003 FORMAT (1X,1X,11F10.1)
 1004 FORMAT (/1X,'SPHERICAL CRYSTAL TRANSMISSION FACTOR:'//1X,'Y = A(',
     &'MU*R, THETA) VERSUS X = (SIN(THETA))**2 FOR MU = ',E10.3,' MM**',
     &'-1 AND R = ',E10.3,' MM'//1X,'AMIN = ',F10.8,', AMAX = ',F10.8)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE ABSORB4
C
C DIFFRACTOMETER ORIENTATION MATRIX, U, AS DEFINED BY WALTER HAMILTON,
C INTERNATIONAL TABLES FOR X-RAY CRYSTALLOGRAPHY, VOL. IV, 1974, PP.
C 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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      DIMENSION H(3),ANGLES(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 BRANCH ACCORDING TO ORIENTATION INFORMATION TYPE.
C
      IF (IORIENT.EQ.1.OR.IORIENT.EQ.2) THEN
C
C ORIENTATION MATRIX IS ALREADY AVAILABLE.
C
        GO TO 20
      ELSE IF (IORIENT.EQ.3) THEN
C
C EVALUATE ORIENTATION MATRIX FROM SETTING ANGLES FOR EACH REFLECTION.
C
        GO TO 30
      ELSE
C
C GENERATE A DUMMY ORIENTATION MATRIX FOR PREPARING PSI-SCAN PLOTS.
C
        GO TO 40
      END IF
 30   CONTINUE    
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 DATA EQUIVALENT UNDER (CENTROSYMMETRIC) LAUE POINT GROUP SYMMTERY ON
C UNIT IO1, OR (NONCENTROSYMMETRIC) CRYSTAL CLASS POINT GROUP SYMMETRY
C ON UNIT IO2?
C
      IF (IPTGP.EQ.IXTAL) IUNIT=IO2
      IF (IPTGP.EQ.ILAUE) IUNIT=IO1
C
C LOOP THROUGH DATA FILE TO BUILD NORMAL EQUATIONS.
C
      REWIND IUNIT
 1    READ (IUNIT,END=9) N,IH,IK,IL
      DSTAR=2*SINTHL(IH,IK,IL,GINV)
      DO WHILE (N.GT.0)
        N=N-1
        READ (IUNIT) I,IH,IK,IL,F,F,I,ANGLES
        H(1)=IH
        H(2)=IK
        H(3)=IL
        CALL AXYZ (IDIFF,ANGLES,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 ' SORTAV/ABSORB4:  SINGULAR NORMAL MATRIX FOR ORIENTATION'
      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
      GO TO 20
 40   CONTINUE
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   '
 20   CONTINUE
      WRITE (ILP,6000) ATIME,ADATE,TITLE
      WRITE (ILP,6001) ((UB(I,J),J=1,3),I=1,3)
 6000 FORMAT (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A)
 6001 FORMAT (/1X,'DIFFRACTOMETER ORIENTATION MATRIX:'//1X,
     &'UB11 UB12 UB13   ',3E11.4/1X,
     &'UB21 UB22 UB23 = ',3E11.4/1X,
     &'UB31 UB32 UB33   ',3E11.4//1X,
     &'FOR DIFFRACTOMETER AXES AS DEFINED BY HAMILTON (1974).  INT. TA',
     &'B., VOL. IV, PP. 273-284.')
      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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      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 THE FITTED CORRECTION FOR ABSORPTION OR ABSORPTION-LIKE
C ANISOTROPY.
C
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      DIMENSION ANGLES(4),X(3),Y(3),Z(3),U0(3),U1(3),YLM0(80),YLM1(80)
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      INTEGER, ALLOCATABLE::II(:),IH(:),IK(:),IL(:)
      REAL,    ALLOCATABLE::YI(:),SI(:),AI(:),SA(:),TI(:),
     & X0(:,:),X1(:,:)
      INTEGER, ALLOCATABLE::INDEX(:)
      REAL,    ALLOCATABLE::FMIN(:,:),FMAX(:,:)
      ALLOCATE (II(NMAX),IH(NMAX),IK(NMAX),IL(NMAX),
     & YI(NMAX),SI(NMAX),AI(NMAX),SA(NMAX),TI(NMAX),
     & X0(3,NMAX),X1(3,NMAX),INDEX(NMAX))
      ALLOCATE (FMIN(100,15),FMAX(100,15))
      DO I=1,100
      DO J=1,15
        FMIN(I,J)=1E10
        FMAX(I,J)=0
      END DO
      END DO
      TBAR=0
      AMIN=1E10
      AMAX=0
      SUMN=0
      SUMA=0
      SUMASQ=0
      SUMV=0
      SUMT=0
      SUMTSQ=0
      WRITE (ILP,1000) ATIME,ADATE,TITLE
 1000 FORMAT (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A//1X,
     &'       I     H   K   L           Y         Y/A  SIGMA(Y/A)     ',
     &' A SIGMA(A)    TBAR    -U0 AND U1 VECTOR COMPONENTS'/1X,
     &'       -     -   -   -           -         ---  ----------     ',
     &' - --------    ----    ALONG CRYSTAL-FIXED CARTESIAN AXES')
 1001 FORMAT (1X,I8,2X,3I4,3F12.2,2F8.4,F8.3,2(2X,3F7.3))
C
C UNIT IO1  (CENTROSYMMETRIC) LAUE POINT GROUP UNIQUE DATA
C UNIT IO2  (NONCENTROSYMMETRIC) CRYSTAL CLASS POINT GROUP UNIQUE DATA
C
      REWIND IO1
      REWIND IO2
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED')
      IUNIT=IO1
 1    READ (IUNIT,END=9) N,JH,JK,JL
      WRITE (IO3)        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 (IUNIT) JJ,JH,JK,JL,YJ,SIGYJ,JSCALE,ANGLES,TBAR,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 ANISOTROPY CORRECTION TO THE RANGE OF THE FITTED 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
        VA=(A0/A)**2*(V0/A0**2+V/A**2)
        SIGA=SQRT(VA)
        A=A0/A
        YJ=YJ/A
        SIGYJ=SQRT(SIGYJ**2+YJ**2*VA)/A
        IF (FMU*RADIUS.GT.0) THEN
          TBAR=LOG(1/A)/FMU
        ELSE
          TBAR=0
        END IF
        IF (IPATH.NE.0) THEN
          WRITE (IO3) JJ,JH,JK,JL,YJ,SIGYJ,JSCALE,ANGLES,TBAR,U0,U1
        ELSE
          WRITE (IO3) JJ,JH,JK,JL,YJ,SIGYJ,JSCALE,ANGLES,(0.0,J=1,7)
        END IF
        CALL TABLEA (JJ,JH,JK,JL,YJ,SIGYJ,A,SIGA,TBAR,U0,U1,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+VA
        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(J,I)=U0(J)
            X1(J,I)=U1(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(K,J),K=1,3),(X1(K,J),K=1,3)
        END DO
      END IF
      GO TO 1
 9    ENDFILE IO3
      IF (IUNIT.EQ.IO1) THEN
        I=IO1
        IO1=IO3
        IO3=I
        REWIND IO3
        IUNIT=IO2
        GO TO 1
      END IF
      IF (IUNIT.EQ.IO2) THEN
        I=IO2
        IO2=IO3
        IO3=I
      END IF
      CLOSE (UNIT=IO3,STATUS='DELETE')
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 (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A)
 1011 FORMAT (//1X,'MEASUREMENTS WITH SMALLEST TRANSMISSION FACTORS, A',
     &' = FSQ(MEAS)/FSQ(CORR).')
 1012 FORMAT (//1X,'MEASUREMENTS WITH LARGEST  TRANSMISSION FACTORS, A',
     &' = FSQ(MEAS)/FSQ(CORR).')
 1002 FORMAT (//1X,
     &'       I     H   K   L                     Y/A  SIGMA(Y/A)     ',
     &' A SIGMA(A)    TBAR    -U0 AND U1 VECTOR COMPONENTS'/1X,
     &'       -     -   -   -                     ---  ----------     ',
     &' - --------    ----    ALONG CRYSTAL-FIXED CARTESIAN AXES'//
     & (1X,I8,2X,3I4,12X,2F12.2,2F8.4,F8.3,2(2X,3F7.3)))
      IF (FMU*RADIUS.GT.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,RADIUS,AMIN,SIGAMN,TMAX,SIGTMX,AMAX,SIGAMX,
     & TMIN,SIGTMN,AMEAN,RMSDA,RMSSA,TMEAN,RMSDT
 1003 FORMAT (//1X,'OVERALL DATA SET STATISTICS ON TRANSMISSION FACTOR',
     &'S, A:'//1X,
     &'MU                            = ',E10.3,' MM**-1'/1X,
     &'RADIUS                        = ',E10.3,' MM'//1X,
     &'A(MIN) = EXP (-MU*TBAR(MAX))  = ',E10.3/1X,
     &'SIGMA(A(MIN))                 = ',E10.3/1X,
     &'TBAR(MAX) = -LOG(A(MIN))/MU   = ',E10.3,' MM'/1X,
     &'SIGMA(TBAR(MAX))              = ',E10.3,' MM'//1X,
     &'A(MAX) = EXP (-MU*TBAR(MIN))  = ',E10.3/1X,
     &'SIGMA(A(MAX))                 = ',E10.3/1X,
     &'TBAR(MIN) = -LOG(A(MAX))/MU   = ',E10.3,' MM'/1X,
     &'SIGMA(TBAR(MIN))              = ',E10.3,' MM'//1X,
     &'AMEAN                         = ',E10.3/1X,
     &'RMSDA = <(A - AMEAN)**2>**1/2 = ',E10.3/1X,
     &'RMSSA = <SIGMA(A)**2>**1/2    = ',E10.3/1X,
     &'TMEAN = <TBAR>                = ',E10.3,' MM'/1X,
     &'RMSDT = <(T - TMEAN)**2>**1/2 = ',E10.3,' MM')
      DEALLOCATE (II,IH,IK,IL,YI,SI,AI,SA,TI,X0,X1,INDEX,FMIN,FMAX)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE APLOT (IH,IK,IL)
C
C PLOT A PSI-SCAN SECTION THROUGH THE TRANSMISSION SURFACE.
C
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      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 (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/ABSORB.  ',A,', ',A,'.  ',A)
 1001 FORMAT (/1X,'PSI-SCAN SECTION THROUGH FITTED TRANSMISSION SURFAC',
     &'E, A = A(H, K, L, PSI).  HAMILTON (1974) DIFFRACTOMETER ANGLES'/
     &1X,'  H  K  L     PSI   TWOTH   OMEGA     CHI     PHI   ASPHERE ',
     &' ANISOMIN  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 (/1X,50X,' PSI = PI/2')
 1003 FORMAT (1X,51A2,' PSI = 0')
 1004 FORMAT (1X,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      DIMENSION ANGLES(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
      ANGLES(1)=TWOTH
      ANGLES(2)=OMEGA
      ANGLES(3)=CHI
      ANGLES(4)=PHI
      CALL AXYZ (1,ANGLES,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)
C
C REVERSE THE INCIDENT BEAM DIRECTION VECTOR.
C
        DO J=1,3
          U0(J)=-U0(J)
        END DO
        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/
      IF (IDIFF.LT.1.OR.IDIFF.GT.4)
     & STOP ' SORTAV/GEOM:  UNKNOWN DIFFRACTOMETER TYPE'
      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 TO UNIT LENGTH A 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,ANGLES,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 ANGLES(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,ANGLES,R(1,1),R(1,2),R(1,3))
      CALL MM (3,U,R,UR)
      CALL MM (3,UR,G,URG)
      CALL GEOM (IDIFF,ANGLES,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
      RETURN
      END      
C-----------------------------------------------------------------------
      SUBROUTINE UNITV (X)
C
C NORMALIZE TO UNIT LENGTH A VECTOR REFERRED TO CARTESIAN AXES.
C
      DIMENSION X(3)
      R=SQRT(X(1)**2+X(2)**2+X(3)**2)
      X(1)=X(1)/R
      X(2)=X(2)/R
      X(3)=X(3)/R
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE V0V1 (IFILE,NREC)
C
C GET UNIT DIRECTION VECTOR COMPONENTS ALONG CRYSTAL-FIXED ORTHONORMAL,
C CARTESIAN AXES FOR THE REVERSE-INCIDENT BEAM AND THE DIFFRACTED BEAM
C FOR EACH REFLECTION AS SPECIFIED BY IORIENT:
C
C IORIENT =   1  GENERATE SETTING ANGLES FOR BISECTING, EQUATORIAL
C                GEOMETRY FOR ORTHOGONALIZED RECIPROCAL SPACE AXES
C                ORIENTED PARALLEL TO THE GONIOSTAT CARTESIAN AXES
C                AT ZERO SETTING ANGLES.
C
C             2  GENERATE SETTING ANGLES FOR BISECTING, EQUATORIAL
C                GEOMETRY FROM GIVEN ORIENTATION MATRIX.
C
C             3  RECALL SETTING ANGLES READ WITH EACH REFLECTION.
C
C          +/-4  RECALL DIRECTION VECTOR COMPONENTS REFERRED TO
C                CRYSTALLOGRAPHIC DIRECT SPACE AXES.
C
C          +/-5  RECALL DIRECTION VECTOR COMPONENTS REFERRED TO
C                CRYSTALLOGRAPHIC RECIPROCAL SPACE AXES.
C
C          +/-6  RECALL DIRECTION VECTOR COMPONENTS REFERRED TO
C                CRYSTAL-FIXED ORTHONORMAL, CARTESIAN AXES.
C
C          +/-7  RECALL DIRECTION COSINES REFERRED TO
C                CRYSTALLOGRAPHIC DIRECT SPACE AXES.
C
C          +/-8  RECALL DIRECTION COSINES REFERRED TO
C                CRYSTALLOGRAPHIC RECIPROCAL SPACE AXES.
C
C IF IORIENT .LT. 0, THE REVERSE-INCIDENT BEAM IS SPECIFIED.
C
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(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),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      DIMENSION ANGLES(4),X(3),Y(3),Z(3),S0(3),S1(3),U0(3),U1(3)
      DIMENSION AA(3,3),BB(3,3),COS0(3),COS1(3),T0(3),T1(3)
C
C CRYSTAL SPACE ORTHOGONALIZATION MATRIX:
C X PARALLEL TO A,
C Z PARALLEL TO C-STAR,
C Y PARALLEL TO C-STAR "CROSS" A.
C
C PATTERSON, A.L. (1967).  FUNDAMENTAL MATHEMATICS.  IN INTERNATIONAL
C                                                       -------------
C TABLES FOR X-RAY CRYSTALLOGRAPHY, VOL. II, MATHEMATICAL TABLES, EDITED
C ------ --- ----- ---------------
C BY J.S. KASPER AND K. LONSDALE, P. 61.  BIRMINGHAM, ENGLAND:  KYNOCH
C PRESS.
C
      DET=VCELL**2
      AA(1,1)= SQRT(G(1,1))
      AA(1,2)= G(1,2)/SQRT(G(1,1))
      AA(1,3)= G(1,3)/SQRT(G(1,1))
      AA(2,1)= 0
      AA(2,2)= SQRT(DET*GINV(3,3)/G(1,1))
      AA(2,3)=-SQRT(DET)*GINV(2,3)/SQRT(G(1,1)*GINV(3,3))
      AA(3,1)= 0
      AA(3,2)= 0
      AA(3,3)= 1/SQRT(GINV(3,3))
C
C RECIPROCAL SPACE ORTHOGONALIZATION MATRIX:
C X PARALLEL TO A-STAR,
C Z PARALLEL TO C,
C Y PARALLEL TO C "CROSS" A-STAR.
C
      DET=1/DET
      BB(1,1)= SQRT(GINV(1,1))
      BB(1,2)= GINV(1,2)/SQRT(GINV(1,1))
      BB(1,3)= GINV(1,3)/SQRT(GINV(1,1))
      BB(2,1)= 0
      BB(2,2)= SQRT(DET*G(3,3)/GINV(1,1))
      BB(2,3)=-SQRT(DET)*G(2,3)/SQRT(GINV(1,1)*G(3,3))
      BB(3,1)= 0
      BB(3,2)= 0
      BB(3,3)= 1/SQRT(G(3,3))
C
C LOOP THROUGH REFLECTION DATA FILE.
C
      DO I=1,NREC
        READ (IFILE,REC=I) II,IH,IK,IL,YI,SIGYI,ISCALE,ANGLES,TBAR,S0,S1
        IF (ABS(IORIENT).LE.2) THEN
C
C GENERATE (DEFAULT) DIFFRACTOMETER SETTING ANGLES.
C
          CALL SETANG (IH,IK,IL,UB,GINV,FLAMBDA,TWOTH,OMEGA,CHI,PHI)
          ANGLES(1)=TWOTH
          ANGLES(2)=OMEGA
          ANGLES(3)=CHI
          ANGLES(4)=PHI
        END IF
        IF (ABS(IORIENT).LE.3) THEN
C
C CALCULATE BEAM DIRECTION VECTORS FROM SETTING ANGLES.
C
          CALL AXYZ (IDIFF,ANGLES,X,Y,Z)
          THETA=ASIN(SINTHL(IH,IK,IL,GINV)*FLAMBDA)
          CALL U0U1 (THETA,X,Y,U0,U1)
        ELSE IF (ABS(IORIENT).EQ.4) THEN
C
C CONVERT DIRECTION VECTORS
C FROM COMPONENTS REFERRED TO CRYSTALLOGRAPHIC DIRECT SPACE AXES
C TO COMPONENTS REFERRED TO ORTHONORMAL, CARTESIAN AXES.
C
          CALL MV (3,AA,S0,U0)
          CALL MV (3,AA,S1,U1)
        ELSE IF (ABS(IORIENT).EQ.5) THEN
C
C CONVERT DIRECTION VECTORS
C FROM COMPONENTS REFERRED TO CRYSTALLOGRAPHIC RECIPROCAL SPACE AXES
C TO COMPONENTS REFERRED TO ORTHONORMAL, CARTESIAN AXES.
C
          CALL MV (3,BB,S0,U0)
          CALL MV (3,BB,S1,U1)
        ELSE IF (ABS(IORIENT).EQ.6) THEN
C
C RECALL STORED DIRECTION VECTORS REFERRED TO CRYSTAL-FIXED ORTHONORMAL,
C CARTESIAN AXES.
C
          DO J=1,3
            U0(J)=S0(J)
            U1(J)=S1(J)
          END DO
        ELSE IF (ABS(IORIENT).EQ.7) THEN
C
C RECALL STORED DIRECTION COSINES REFERRED TO CRYSTALLOGRAPHIC DIRECT
C SPACE AXES.
C
          DO J=1,3
            COS0(J)=S0(J)
            COS1(J)=S1(J)
          END DO
C
C CONVERT FROM CRYSTALLOGRAPHIC DIRECTION COSINES TO DIRECTION VECTOR
C COMPONENTS.
C
          DO J=1,3
            T0(J)=SQRT(G(J,J))*COS0(J)
            T1(J)=SQRT(G(J,J))*COS1(J)
          END DO
          CALL MV (3,GINV,T0,S0)
          CALL MV (3,GINV,T1,S1)
C
C CONVERT FROM CRYSTALLOGRAPHIC TO CARTESIAN AXES.
C
          CALL MV (3,AA,S0,U0)
          CALL MV (3,AA,S1,U1)
        ELSE IF (ABS(IORIENT).EQ.8) THEN
C
C RECALL STORED DIRECTION COSINES REFERRED TO CRYSTALLOGRAPHIC
C RECIPROCAL SPACE AXES, AND CONVERT TO CARTESIAN DIRECTION VECTOR
C COMPONENTS.
C
          DO J=1,3
            COS0(J)=S0(J)
            COS1(J)=S1(J)
          END DO
          DO J=1,3
            T0(J)=SQRT(GINV(J,J))*COS0(J)
            T1(J)=SQRT(GINV(J,J))*COS1(J)
          END DO
          CALL MV (3,G,T0,S0)
          CALL MV (3,G,T1,S1)
          CALL MV (3,BB,S0,U0)
          CALL MV (3,BB,S1,U1)
        END IF
C
C NORMALIZE THE DIRECTION VECTORS.
C
        CALL UNITV (U0)
        CALL UNITV (U1)
        IF (IORIENT.GT.0) THEN
C
C REVERSE THE INCIDENT BEAM VECTOR.
C
          DO J=1,3
            U0(J)=-U0(J)
          END DO
        END IF
        WRITE (IFILE,REC=I) II,IH,IK,IL,YI,SIGYI,ISCALE,ANGLES,TBAR,
     &  U0,U1
      END DO
      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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,IPRINT,JPRINT,JPATH,QLIMIT,ZLIMIT,QPRINT
      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 FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      REAL,    ALLOCATABLE::DATA(:)
      INTEGER, ALLOCATABLE::INDEX(:)   
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
      NMIN1=+1E9
      NMAX1=-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)
        NMIN1=MIN(NMIN1,NMEAS)
        NMAX1=MAX(NMAX1,NMEAS)
        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)
        WIJ(I,J)=WIJ(I,J)/NIJ(I,J)+1
        SIJ(I,J)=1/(2*SIJ(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)
        WI(I)=WI(I)/NI(I)+1
        SI(I)=1/(2*SI(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)
        WJ(J)=WJ(J)/NJ(J)+1
        SJ(J)=1/(2*SJ(J))
   52 CONTINUE
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1001) (1/2*(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)          (WIJ(I,J),J=1,10),WI(I)
        WRITE (ILP,1007)          (NIJ(I,J),J=1,10),NI(I)
   55 CONTINUE
      WRITE (ILP,1008) (QJ(J),J=1,10)
      WRITE (ILP,1009) (EJ(J),J=1,10)
      WRITE (ILP,1010) (YJ(J),J=1,10)
      WRITE (ILP,1011) (SJ(J),J=1,10)
      WRITE (ILP,1012) (WJ(J),J=1,10)
      WRITE (ILP,1013) (NJ(J),J=1,10)
 1000 FORMAT (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/ANOVA.  ',A,', 'A,'.  ',A)
 1001 FORMAT (/1X,
     &'BIVARIATE ANALYSIS OF VARIANCE TABLE.  Q = Q(Y, S)'/1X,
     &'TABLE ENTRIES LIST:'//1X,
     &'  <Q>, Q = RMSD(Y)/ESD(Y)'/1X,
     &'  <E>, E = ESD(Y)'/1X,
     &'  <Y>, Y = F OR FSQ'/1X,
     &'  <D>, D = 1/[2*SIN(THETA)/LAMBDA]'/1X,
     &'  <M>, M = NUMBER OF MEASUREMENTS PER UNIQUE REFLECTION'/1X,
     &'    N, N = NUMBER OF UNIQUE REFLECTIONS'//1X,
     &'DMIN(J) ACROSS',10(F10.3),'    TOTALS'/1X,
     &'        ------'/1X,
     &'YMAX(I) DOWN'/1X,
     &'        ----')
 1002 FORMAT (/E10.3,5X,11F10.2)
 1003 FORMAT (15X,11E10.3)
 1004 FORMAT (15X,11E10.3)
 1005 FORMAT (15X,11F10.2)
 1006 FORMAT (15X,11F10.1)
 1007 FORMAT (15X,11I10)
 1008 FORMAT (/'    TOTALS',5X,10F10.2)
 1009 FORMAT (15X,10E10.3)
 1010 FORMAT (15X,10E10.3)
 1011 FORMAT (15X,10F10.2)
 1012 FORMAT (15X,10F10.1)
 1013 FORMAT (15X,10I10)
C
C PRINT DATA SET STATISTICS.
C
      WRITE (ILP,1000) ATIME,ADATE,TITLE
      WRITE (ILP,1020) YMIN0,SMIN0,1/(2*SMIN0),
     &                 YMAX0,SMAX0,1/(2*SMAX0),
     &                 YMIN1,SMIN1,1/(2*SMIN1),NMIN1,
     &                 YMAX1,SMAX1,1/(2*SMAX1),NMAX1
 1020 FORMAT (/1X,
     &'DATA SET STATISTICS:'//1X,
     &'OVERALL RANGE OF UNIQUE DATA:'//1X,
     &'YMIN  = ',E10.3,'    SMIN  = ',F6.3,'    DMAX  = ',F6.2/1X,
     &'YMAX  = ',E10.3,'    SMAX  = ',F6.3,'    DMIN  = ',F6.2//1X,
     &'RANGE OF MULTIPLY MEASURED DATA:'//1X,
     &'YMIN  = ',E10.3,'    SMIN  = ',F6.3,'    DMAX  = ',F6.2,
     &'    NMIN  = ',I6/1X,
     &'YMAX  = ',E10.3,'    SMAX  = ',F6.3,'    DMIN  = ',F6.2
     &'    NMAX  = ',I6)
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,'(/1X,''DISTRIBUTION STATISTICS FOR ESTIMATED ERROR '',
     &''RATIOS, Q = RMSD(Y)/ESD(Y),''/1X,''FOR MEASUREMENT SAMPLES WI'',
     &''TH 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'')')
     & N,FLOAT(M)/N,QMIN,QMAX,Q0,RMSDQ,Q3,Q4
C
C COMPILE AND PRINT Q-SORTED LIST OF REFLECTION SAMPLES WITH
C NMEAS .GT. 2 AND SIGNIFICANTLY LARGER THAN AVERAGE Q.
C
      ALLOCATE (DATA(NTOTAL),INDEX(NTOTAL))
      OPEN (UNIT=IO4,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=20)
      CUTOFF=Q0+QLIMIT*RMSDQ
      REWIND IO1
      N=0
      DO I=1,NTOTAL
        CALL READ2 (IO1,JPATH,IEND,IH,IK,IL,Y,SIGY,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,'(/1X,''REFLECTION SAMPLES WITH N .GT. 2 AND SIGNI'',
     &''FICANTLY 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')
      DEALLOCATE (DATA,INDEX)
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 (/1X,'NOBS = ',I1,' .LE. NPAR = 6.  TOO FEW DATA TO FIT A',
     &' QUATRATIC SURFACE.')
C
C INVERT NORMAL MATRIX.
C
      CALL MATINV (6,6,AA,DET)
      IF (DET.EQ.0) THEN
        WRITE (ILP,'(/1X,''SINGULAR NORMAL MATRIX FOR FIT OF QUADRATI'',
     &''C SURFACE IN SUBROUTINE ANOVA.'')')
        GO TO 49
      END IF
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 (/1X,'FITTED QUADRATIC SURFACE Q = Q(Y,S):'//1X,
     &'Q = (Y S 1) (A11 A12 A13) (Y)'/1X,
     &'            (A21 A22 A23) (S)'/1X,
     &'            (A31 A32 A33) (1)'//1X,
     &'Q = A11*Y**2 + A22*S**2 + A33 + 2*A12*Y*S + 2*A13*Y + 2*A23*S'//
     &1X,
     &'A11 = ',E10.3/1X,
     &'A22 = ',E10.3/1X,
     &'A33 = ',E10.3/1X,
     &'A12 = ',E10.3/1X,
     &'A13 = ',E10.3/1X,
     &'A23 = ',E10.3//1X,
     &'STATISTICS OF FIT:'//1X,
     &'CHISQ = SUM(WI*(QI - Q(YI,SI))**2)'/1X,
     &'WI    = NI - 1'/1X,
     &'WHERE NI IS THE NUMBER OF EQUIVALENT MEASUREMENTS OF THE I-TH U',
     &'NIQUE REFLECTION'/1X,
     &'Z = SQRT((CHISQ/SUM(WI))*NOBS/(NOBS - NPAR)) = ',E10.3/1X,
     &'R = SQRT(CHISQ/SUM(WI*QI**2))                = ',E10.3//1X,
     &'RANGE OF QCALC:'//1X,'QMIN  = ',E10.3/1X,'QMAX  = ',E10.3)
 49   CONTINUE
      CLOSE (UNIT=IO2,STATUS='DELETE')
      CLOSE (UNIT=IO3,STATUS='DELETE')
C
C REVISE ESTIMATES OF STANDARD DEVIATION.
C
      REWIND IO1
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='FORMATTED')
      DO N=1,NTOTAL
        CALL READ2  (IO1,JPATH,IEND,IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     &  TBAR,U0,U1)
        CALL WRITE1 (IO2,JPATH,     IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     &  TBAR,U0,U1)
      END DO
      QMIN=+9E9
      QMAX=-9E9
      REWIND IO2
      REWIND IO1
      DO 20 N=1,NTOTAL
        CALL READ2 (IO2,JPATH,IEND,IH,IK,IL,Y,SIGY,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(Q,RMSD/ESD)
        QMIN=MIN(QMIN,Q)
        QMAX=MAX(QMAX,Q)
        CALL WRITE1 (IO1,JPATH,IH,IK,IL,Y,Q*ESD,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 (/1X,'REVISED ESD''S BASED ON TABLE FUNCTION.')
 211  FORMAT (/1X,'REVISED ESD''S BASED ON FITTED QUADRATIC SURFACE.')
 112  FORMAT (/1X,'REVISED ESD = MAX(Q*ESD, RMSD).'//1X,
     &'RANGE OF APPLIED VALUES OF Q:'//1X,
     &'QMIN  = ',E10.3/1X,'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
      DIMENSION Y(N),SIGY(N),W(N)
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      REAL, ALLOCATABLE::DATA(:)
      ALLOCATE (DATA(N))
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=SQRT(SIGY(1)**2+(P*Y(1))**2)
        RMSD=ESD
        RETURN
      END IF
      NREJ=0
      IF (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=SQRT(SIGMA**2+(P*YMEAN)**2)
          RMSD=ESD
          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 ADJUST SIGMA(YI) VALUES BY ADDING A MEDIAN-PROPORTIONAL UNCERTAINTY.
C
        DO I=1,N
          SIGY(I)=SQRT(SIGY(I)**2+(P*YMEAN)**2)
        END DO
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
          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 SORT ON HKL.
C
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCKJ/ SMINJ,SMAXJ,JN,JHKL
      COMMON /BLOCK3/ SMIN,SMAX,
     & IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,
     & JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX,
     & LHMIN,LHMAX,LKMIN,LKMAX,LLMIN,LLMAX
      COMMON /BLOCKS/ NSCALE,KSCALE,IFIXED,QMIN,ZMAX
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION FOR SORTING ARRAYS
C
      INTEGER, ALLOCATABLE::JI(:),JH(:),JK(:),JL(:)
      REAL,    ALLOCATABLE::DATA(:)
      INTEGER, ALLOCATABLE::INDEX(:)
C
C THE ARRAY A(11) CAN CONTAIN THE DIFFRACTOMETER SETTING ANGLES, 
C ANGLES(4), IN A(1) THROUGH A(4) AND/OR THE ABSORPTION-WEIGHTED MEAN
C PATH LENGTH AND INCIDENT AND DIFFRACTED BEAM DIRECTION VECTORS, TBAR, 
C S0(3), AND S1(3), IN A(5) THROUGH A(11).
C
      DIMENSION A(11)
      DATA A /11*0/
C
C LOOP TO READ IN REFLECTION DATA AND WRITE FILE FOR SORTING.
C
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=72)
      M=0
      N=0
      N1REJ=0
      N2REJ=0
      N3REJ=0
      N4REJ=0
      N5REJ=0
      N6REJ=0
      N7REJ=0
      N8REJ=0
C
C READ REFLECTIONS FOR INPUT REJECTION.
C
      IF (JN.GT.0) THEN
        ALLOCATE (JI(JN),JH(JN),JK(JN),JL(JN))
        REWIND JHKL
        DO J=1,JN
          READ (JHKL) JI(J),JH(J),JK(J),JL(J)
        END DO
        CLOSE (UNIT=JHKL,STATUS='DELETE')
      END IF
      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.SMINJ.OR.S.GT.SMAXJ) 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
      IHMIN=MIN(IHMIN,IH)
      IHMAX=MAX(IHMAX,IH)
      IKMIN=MIN(IKMIN,IK)
      IKMAX=MAX(IKMAX,IK)
      ILMIN=MIN(ILMIN,IL)
      ILMAX=MAX(ILMAX,IL)
      SMIN=MIN(SMIN,S)
      SMAX=MAX(SMAX,S)
C
C TABULATE INDEX LIMITS UNIQUE UNDER THE CRYSTAL CLASS POINT GROUP
C SYMMETRY.
C
      J=IH
      K=IK
      L=IL
      CALL EQUIV (IXTAL,J,K,L)
      JHMIN=MIN(JHMIN,J)
      JHMAX=MAX(JHMAX,J)
      JKMIN=MIN(JKMIN,K)
      JKMAX=MAX(JKMAX,K)
      JLMIN=MIN(JLMIN,L)
      JLMAX=MAX(JLMAX,L)
C
C TABULATE INDEX LIMITS UNIQUE UNDER THE LAUE POINT GROUP SYMMETRY.
C
      J=IH
      K=IK
      L=IL
      CALL EQUIV (ILAUE,J,K,L)
      LHMIN=MIN(LHMIN,J)
      LHMAX=MAX(LHMAX,J)
      LKMIN=MIN(LKMIN,K)
      LKMAX=MAX(LKMAX,K)
      LLMIN=MIN(LLMIN,L)
      LLMAX=MAX(LLMAX,L)
C
C WRITE DATA TO FILE TO BE SORTED.
C
      N=N+1
      WRITE (IO3,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')
      ALLOCATE (DATA(N),INDEX(N))
C
C GET CARTESIAN COMPONENTS OF BEAM DIRECTION VECTORS FOR EMPIRICAL
C CORRECTION OF ABSORPTION OR ABSORPTION-LIKE ANISOTROPY.
C
      IF (L0MAX.GT.0.OR.L1MAX.GT.0) CALL V0V1 (IO3,N)
C
C SORT ON THE PACKED, UNIQUE, EQUIVALENT INDICES.
C
C STORE SORTED DATA EQUIVALENT UNDER THE (CENTROSYMMETRIC) LAUE POINT
C GROUP SYMMTERY ON UNIT IO1, AND SORTED DATA EQUIVALENT UNDER THE
C (NONCENTROSYMMETRIC) CRYSTAL CLASS POINT GROUP SYMMETRY ON UNIT IO2.
C
      NMAX=0
      OPEN (UNIT=IO4,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=72)
      OPEN (UNIT=IO1,STATUS='SCRATCH',FORM='UNFORMATTED')
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='UNFORMATTED')
      IUNIT=IO1
      ITEMP=IPTGP
      IPTGP=ILAUE
      IHMIN=LHMIN
      IHMAX=LHMAX
      IKMIN=LKMIN
      IKMAX=LKMAX
      ILMIN=LLMIN
      ILMAX=LLMAX
 51   NL=ILMAX-ILMIN+1
      NK=IKMAX-IKMIN+1
      DO I=1,N
        READ (IO3,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)
      DO I=1,N
        READ (IO3,REC=INDEX(I)) II,IH,IK,IL,Y,SIGY,ISCALE,A
        WRITE (IO4,REC=I)       II,IH,IK,IL,Y,SIGY,ISCALE,A
      END DO
C
C REWRITE THE HKL-SORTED DATA FILE IN BLOCKS OF MULTIPLE EQUIVALENT
C MEASUREMENTS.
C
      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 (IUNIT) NMEAS,IH,IK,IL
          DO J=1,NMEAS
            IREC=I-J
            READ (IO4,REC=IREC) II,IH,IK,IL,Y,SIGY,ISCALE,A
            WRITE (IUNIT)       II,IH,IK,IL,Y,SIGY,ISCALE,A
          END DO
          NMAX=MAX(NMAX,NMEAS)
          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 (IUNIT) NMEAS,IH,IK,IL
      DO I=1,NMEAS
        IREC=N-I+1
        READ (IO4,REC=IREC) II,IH,IK,IL,Y,SIGY,ISCALE,A
        WRITE (IUNIT)       II,IH,IK,IL,Y,SIGY,ISCALE,A
      END DO
      NMAX=MAX(NMAX,NMEAS)
      ENDFILE IUNIT
      IF (IUNIT.EQ.IO1.AND.IXTAL.NE.ILAUE) THEN
        IUNIT=IO2
        IPTGP=IXTAL
        IHMIN=JHMIN
        IHMAX=JHMAX
        IKMIN=JKMIN
        IKMAX=JKMAX
        ILMIN=JLMIN
        ILMAX=JLMAX
        GO TO 51
      END IF
      CLOSE (UNIT=IO3,STATUS='DELETE')
      CLOSE (UNIT=IO4,STATUS='DELETE')
      DEALLOCATE (DATA,INDEX)
      IPTGP=ITEMP
C
C PRINT SOME DATA SET STATISTICS.
C
      WRITE (ILP,'(/1H1,130(''-'')/1X,
     &''PROGRAM SORTAV/DATAIN.  '',A,'', '',A,''.  '',A)')
     & ATIME,ADATE,TITLE
      WRITE (ILP,'(/1X,
     &''M = '',I8,'' MEASUREMENTS READ FROM THE INPUT REFLECTION DATA'',
     &'' FILE''/1X,
     &''N = '',I8,'' ACCEPTED MEASUREMENTS WILL BE SORTED AND AVERAGE'',
     &''D'')') M,N
      WRITE (ILP,'(/1X,
     &''N1 = '',I7,'' MEASUREMENTS REJECTED BECAUSE THEY APPEAR IN TH'',
     &''E INPUT REJECTION LIST''/1X,
     &''N2 = '',I7,'' ADDITIONAL MEASUREMENTS REJECTED BECAUSE SYMMET'',
     &''RY FORBIDDEN''/1X,
     &''N3 = '',I7,''      "           "          "       "    SIN(TH'',
     &'')/L .LT. SMINJ = '',F5.3,'' OR .GT. SMAXJ = '',F5.3/1X,
     &''N4 = '',I7,''      "           "          "       "    IH = I'',
     &''K = IL = 0''/1X,
     &''N5 = '',I7,''      "           "          "       "    ABS(IH'',
     &''), ABS(IK), OR ABS(IL) .GT. 500''/1X,
     &''N6 = '',I7,''      "           "          "       "    SIGMA('',
     &''YMEAS) .LE. 0''/1X,
     &''N7 = '',I7,''      "           "          "       "    YMEAS '',
     &''.LT. -4*SIGMA(YMEAS)''/1X,
     &''N8 = '',I7,''      "           "          "       "    ISCALE'',
     &'' .LT. 1 OR .GT. NSCALE'')') N1REJ,N2REJ,N3REJ,SMINJ,SMAXJ,
     & N4REJ,N5REJ,N6REJ,N7REJ,N8REJ
      WRITE (ILP,'(//1X,
     &''MILLER INDEX LIMITS OF THE ACCEPTED MEASUREMENTS:''//1X,
     &'' HMIN KMIN LMIN''/1X,3I5//1X,
     &'' HMAX KMAX LMAX''/1X,3I5)') IHMIN,IKMIN,ILMIN,IHMAX,IKMAX,ILMAX
      WRITE (ILP,'(//1X,
     &''MILLER INDEX LIMITS OF THE DATA UNIQUE UNDER THE CRYSTAL CLAS'',
     &''S POINT GROUP SYMMETRY:''//1X,
     &'' HMIN KMIN LMIN''/1X,3I5//1X,
     &'' HMAX KMAX LMAX''/1X,3I5)') JHMIN,JKMIN,JLMIN,JHMAX,JKMAX,JLMAX
      WRITE (ILP,'(//1X,
     &''MILLER INDEX LIMITS OF THE DATA UNIQUE UNDER THE LAUE POINT G'',
     &''ROUP SYMMETRY:''//1X,
     &'' HMIN KMIN LMIN''/1X,3I5//1X,
     &'' HMAX KMAX LMAX''/1X,3I5///1X,
     &''DATA RESOLUTION LIMITS:''/1X,
     &''-----------------------''//1X,
     &''SMIN = '',F7.3/1X,
     &''SMAX = '',F7.3,'' RECIPROCAL ANGSTROMS''//1X,
     &''DMAX = 1/(2*SMIN) = '',F6.2,'' ANGSTROMS''/1X,
     &''DMIN = 1/(2*SMAX) = '',F6.2,'' ANGSTROMS'')')
     & LHMIN,LKMIN,LLMIN,LHMAX,LKMAX,LLMAX,
     & SMIN,SMAX,1/(2*SMIN),1/(2*SMAX)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE DECODE (XTAL,LAUE,IXTAL,ILAUE)
C
C CRYSTAL CLASS POINT GROUP AND LAUE POINT GROUP SYMBOLS
C
C THERE ARE TEN CASES OF ALTERNATIVE AXES FOR SEVEN OF THE 32
C CRYSTAL CLASS POINT GROUPS, THUS A TOTAL OF 42 CASES IS TABULATED.
C
C SIMILARLY, THERE ARE THREE CASES OF ALTERNATIVE AXES FOR TWO OF THE 11
C LAUE POINT GROUPS, SO 14 CASES ARE TABULATED.
C
      CHARACTER*5 XTAL,LAUE,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  '/
C
C CRYSTAL CLASS POINT GROUP
C
      DO I=1,42
        IF (XTAL.EQ.SYMBOL(I)) GO TO 1
      END DO
      STOP ' SORTAV/DECODE:  ERROR IN CRYSTAL CLASS POINT GROUP SYMBOL'
 1    IXTAL=I
C
C LAUE POINT GROUP
C
      IF (I.GE. 1) LAUE='-1   '
      IF (I.GE. 3) LAUE='2/M  '
      IF (I.GE. 6) LAUE='MMM  '
      IF (I.GE. 9) LAUE='4/M  '
      IF (I.GE.12) LAUE='4/MMM'
      IF (I.GE.17) LAUE='-3   '
      IF (I.GE.19) LAUE='-31M '
      IF (I.EQ.20.OR.I.EQ.22.OR.I.EQ.24) LAUE='-3M1 '
      IF (I.GE.25) LAUE='6/M  '
      IF (I.GE.28) LAUE='6/MMM'
      IF (I.GE.33) LAUE='R-3  '
      IF (I.GE.35) LAUE='R-3M '
      IF (I.GE.38) LAUE='M3   '
      IF (I.GE.40) LAUE='M3M  '
      DO I=1,42
        IF (LAUE.EQ.SYMBOL(I)) GO TO 2
      END DO
 2    ILAUE=I
      RETURN
      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 ' SORTAV/EQUIV:  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 ' SORTAV/HKLCOND:  INPUT 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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCK3/ SMIN,SMAX,
     & IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,
     & JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX,
     & LHMIN,LHMAX,LKMIN,LKMAX,LLMIN,LLMAX
 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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCKJ/ SMINJ,SMAXJ,JN,JHKL
      COMMON /BLOCK3/ SMIN,SMAX,
     & IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,
     & JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX,
     & LHMIN,LHMAX,LKMIN,LKMAX,LLMIN,LLMAX
      COMMON /BLOCKS/ NSCALE,KSCALE,IFIXED,QMIN,ZMAX
      COMMON /BLOCKA/ L0MAX,L1MAX,IDIFF,FLAMBDA,FMU,RADIUS,TMIN,TMAX,
     & ERRMUT,FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,IPATH,IPLOT,
     & ALM(80),SIGALM(80),NOBS,NHKL,NPAR,R1,Z1,RY,ZY,RA,ZA,WA,
     & UMIN,NZERO,AMEAN,RMSDA,ASPH(7),CORR(80,80)
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,IPRINT,JPRINT,JPATH,QLIMIT,ZLIMIT,QPRINT
      DIMENSION CELL(6)
      CHARACTER HCOND*18,XTAL*5,LAUE*5,PTGP*4,DIFF*4
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='NEW',FILE='sortav.lp')
C
C TIME, DATE, AND JOB TITLE
C
      CALL VTIME (ATIME)
      CALL VDATE (ADATE)
c      ATIME='hh:mm:ss'
c      ADATE='dd-mmm-yy'
      READ (IO1,'(A)') TITLE
      WRITE (ILP,600) ATIME,ADATE,TITLE
  600 FORMAT (/1H1,130('-')/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 CRYSTAL CLASS POINT GROUP
C
      READ (IO1,'(A)') XTAL
      CALL DECODE (XTAL,LAUE,IXTAL,ILAUE)
      WRITE (ILP,606) XTAL,LAUE
  606 FORMAT (/1X,
     &'CRYSTAL CLASS POINT GROUP:  ',A//1X,
     &'LAUE POINT GROUP:           ',A)
C
C LATTICE PARAMETERS
C
      READ (IO1,*) CELL
      WRITE (ILP,'(/1X,''LATTICE PARAMETERS:''//1X,
     &9X,''A'',9X,''B'',9X,''C'',5X,''ALPHA'',6X,''BETA'',5X,''GAMMA''/
     &1X,3F10.4,3F10.3)') CELL
C
C CALCULATE METRIC TENSORS.
C
      CALL METRIC (CELL,VCELL,G,GINV)
C
C PROPORTIONALITY FACTOR, PP, FOR SIGNAL-PROPORTIONAL UNCERTAINTY
C ESTIMATES FOR CALCULATING RECIPROCAL-VARIANCE WEIGHTS
C
C VAR(YI) = SIGMA(YI)**2 + (PP*YMEAN)**2
C
      PP=0
      READ (IO1,*,END=1) PP
 1    CONTINUE
      IF (PP.EQ.0) PP=0.01
      IF (PP.LT.0) PP=0
      WRITE (ILP,'(//1X,
     &''PROPORTIONALITY FACTOR, PP, FOR SIGNAL-PROPORTIONAL UNCERTAIN'',
     &''TY ESTIMATES''/1X,
     &''FOR CALCULATING RECIPROCAL-VARIANCE WEIGHTS FOR INTERFRAME SC'',
     &''ALING,''/1X,
     &''EMPIRICAL ABSORPTION ANISOTROPY CORRECTION, AND/OR EXPERIMENT'',
     &''ALLY WEIGHTED''/1X,
     &''DATA AVERAGING:''//1X,
     &''    VAR(YI) =  SIGMA(YI)**2 + (P*YMEAN)**2''/1X,
     &''    P       = '',E10.3)') PP
C
C INTER-SUBSET SCALE FACTORS
C
      NSCALE=1
      PTGP='    '
      ISTART=0
      IFIXED=0
      KSCALE=0
      QMIN=0
      ZMAX=0
      READ (IO1,*,END=2) NSCALE
      IF (NSCALE.GT.1) THEN
        READ (IO1,'(A)',END=2) PTGP
        READ (IO1,*,    END=2) ISTART,IFIXED,QMIN,ZMAX
      END IF
 2    CONTINUE
      IF (PTGP.NE.'XTAL') PTGP='LAUE'
      IF (PTGP.EQ.'LAUE') IPTGPS=ILAUE
      IF (PTGP.EQ.'XTAL') IPTGPS=IXTAL
      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,PTGP,QMIN,ZMAX
      IF (NSCALE.GT.1.AND.ISTART.NE.0) THEN
        KSCALE=71
        OPEN (UNIT=KSCALE,STATUS='SCRATCH',FORM='UNFORMATTED')
        DO I=1,NSCALE
          READ  (IO1,*)  J,SCALEKJ
          WRITE (KSCALE) J,SCALEKJ
        END DO
        ENDFILE KSCALE
        WRITE (ILP,621)
        REWIND KSCALE
        DO I=1,NSCALE
          READ  (KSCALE)  J,SCALEKJ
          WRITE (ILP,622) J,SCALEKJ
        END DO
      END IF
      IF (IFIXED.NE.0) WRITE (ILP,623) IFIXED
 620  FORMAT (//1X,
     &'INTER-SUBSET SCALING VARIABLES:'/1X,
     &'-------------------------------'//1X,
     &'    NSCALE = ',I4/1X,
     &'    PTGP   = ',3X,A4,'  POINT GROUP FOR EQUIVALENT REFLECTIONS ',
     &'FOR SCALE FACTOR FITTING'/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,
     &'OUTLIER 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 FACTORS FITTING.')
 621  FORMAT (/1X,
     &'INITIAL RELATIVE SCALE FACTORS FOR SUBSETS OF THE DATA SET:'//1X,
     &'    I   SCALEK(I)'/1X,
     &'    -   ---------')
 622  FORMAT (1X,I5,2X,F10.5)
 623  FORMAT (//1X,
     &'THE VALUE OF SCALE FACTOR NUMBER I = ',I2,' WILL BE HELD FIXED.'/
     &1X,
     &'                                 ------')
C
C ABSORPTION CORRECTION VARIABLES
C
      L0MAX=0
      L1MAX=0
      PTGP='    '
      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=3) L0MAX,L1MAX
      IF (L0MAX.LT.0) L0MAX=0
      IF (L1MAX.LT.0) L1MAX=0
      IF (L0MAX.EQ.0.AND.L1MAX.EQ.0) GO TO 3
      IF (L0MAX.GT.8) L0MAX=8
      IF (L1MAX.GT.7) L1MAX=7
      READ (IO1,'(A)',END=4) PTGP
      READ (IO1,'(A)',END=4) DIFF
      READ (IO1,*,END=4) IORIENT
      IF (IORIENT.EQ.0) IORIENT=1
      IF (IORIENT.EQ.2) READ (IO1,*) ((UB(I,J),J=1,3),I=1,3)
      READ (IO1,*,END=4) FLAMBDA,FMU,RADIUS,TMIN,TMAX,ERRMUT,WA,UMIN
      READ (IO1,*,END=4) FSQMIN,FSQMAX,STLMIN,STLMAX,AIMIN,AIMAX,
     & IPATH,IPLOT
 4    CONTINUE
      IF (PTGP.NE.'XTAL') PTGP='LAUE'
      IF (PTGP.EQ.'LAUE') IPTGPA=ILAUE
      IF (PTGP.EQ.'XTAL') IPTGPA=IXTAL
      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 (FLAMBDA.LE.0) STOP ' SORTAV/INPUT:  UNKNOWN WAVELENGTH'
      IF (WA.EQ.0) WA=1
      IF (WA.LT.0) WA=0
      IF (UMIN.EQ.0) UMIN=0.5E-15
      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,PTGP,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 (FMU.GT.0.AND.RADIUS.EQ.0.AND.TMIN.GT.0) THEN
        WRITE (ILP,615)
      END IF
      WRITE (ILP,'(/1X,
     &''    CRYSTAL ORIENTATION INFORMATION''/1X,
     &''    OR INCIDENT AND DIFFRACTED BEAM DIRECTIONS''/1X,
     &''    FOR EACH REFLECTION MEASUREMENT:''/1X,
     &''    IORIENT = '',I3)') IORIENT
      IF (IORIENT.EQ.1) THEN
        WRITE (ILP,'(1X,
     &''    GENERATE SETTING ANGLES FOR BISECTING, EQUATORIAL''/1X,
     &''    GEOMETRY FOR ORTHOGONALIZED RECIPROCAL SPACE AXES''/1X,
     &''    ORIENTED PARALLEL TO THE GONIOSTAT CARTESIAN AXES''/1X,
     &''    AT ZERO SETTING ANGLES.'')')
      ELSE IF (IORIENT.EQ.2) THEN
        WRITE (ILP,'(1X,
     &''    GENERATE SETTING ANGLES FOR BISECTING, EQUATORIAL''/1X,
     &''    GEOMETRY FROM GIVEN ORIENTATION MATRIX.'')')
      ELSE IF (IORIENT.EQ.3) THEN
        WRITE (ILP,'(1X,
     &''    READ SETTING ANGLES WITH EACH REFLECTION.'')')
      ELSE IF (ABS(IORIENT).EQ.4) THEN
        WRITE (ILP,'(1X,
     &''    READ DIRECTION VECTOR COMPONENTS REFERRED TO''/1X,
     &''    CRYSTALLOGRAPHIC DIRECT SPACE AXES.'')')
      ELSE IF (ABS(IORIENT).EQ.5) THEN
        WRITE (ILP,'(1X,
     &''    READ DIRECTION VECTOR COMPONENTS REFERRED TO''/1X,
     &''    CRYSTALLOGRAPHIC RECIPROCAL SPACE AXES.'')')
      ELSE IF (ABS(IORIENT).EQ.6) THEN
        WRITE (ILP,'(1X,
     &''    READ DIRECTION VECTOR COMPONENTS REFERRED TO''/1X,
     &''    CRYSTAL-FIXED ORTHONORMAL, CARTESIAN AXES.'')')
      ELSE IF (ABS(IORIENT).EQ.7) THEN
        WRITE (ILP,'(1X,
     &''    READ DIRECTION COSINES REFERRED TO''/1X,
     &''    CRYSTALLOGRAPHIC DIRECT SPACE AXES.'')')
      ELSE IF (ABS(IORIENT).EQ.8) THEN
        WRITE (ILP,'(1X,
     &''    READ DIRECTION COSINES REFERRED TO''/1X,
     &''    CRYSTALLOGRAPHIC RECIPROCAL SPACE AXES.'')')
      END IF
      WRITE (ILP,'(1X,
     &''    IF IORIENT .LT. 0, REVERSE-INCIDENT BEAM IS SPECIFIED.'')')
      IF (IORIENT.EQ.1) THEN
C
C BUILD A DEFAULT BUSING-LEVY ORIENTATION MATRIX FOR THE ORTHOGONALIZED
C RECIPROCAL LATTICE AXES PARALLEL TO THE GONIOSTAT CARTESIAN AXES AT
C ZERO SETTING ANGLES:
C
C X PARALLEL TO A-STAR,
C Z PARALLEL TO C,
C Y PARALLEL TO C "CROSS" A-STAR.
C
C BUSING, W.R., AND LEVY, H.A. (1967).  ANGLE CALCULATIONS FOR 3- AND 4-
C CIRCLE X-RAY AND NEUTRON DIFFRACTOMETERS.  ACTA CRYST. 22, 457-464.
C                                            ----------- ==
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
        IDIFF=1
        DIFF='H   '
      END IF
      IF (ABS(IORIENT).LE.2) THEN
        WRITE (ILP,619) DIFF,((UB(I,J),J=1,3),I=1,3)
        IF (DIFF.EQ.'BL  '.OR.DIFF.EQ.'P3  '.OR.DIFF.EQ.'CAD4') THEN
          CALL UDTOUH (DIFF,UB)
          IDIFF=1
          DIFF='H   '
          WRITE (ILP,619) DIFF,((UB(I,J),J=1,3),I=1,3)
        END IF
      END IF
 610  FORMAT (//1X,
     &'ABSORPTION ANISOTROPY CORRECTION VARIABLES:'/1X,
     &'-------------------------------------------'//1X,
     &'    L0MAX  = ',I2,10X,'             EVEN ORDER LIMIT OF SPHERIC',
     &'AL HARMONIC EXPANSION    Y(L,M); L = 0, LMAX; M = -L, +L'/1X,
     &'    L1MAX  = ',I2,10X,'             ODD ORDER LIMIT'/1X,
     &'    PTGP   =  ',A4,7X,'             POINT GROUP FOR EQUIVALENT ',
     &'REFLECTIONS FOR THE YLM FITTING'/1X,
     &'    DIFF   =  ',A4,7X,'             DIFFRACTOMETER TYPE'/1X,
     &'    LAMBDA = ',F8.5,' ANGSTROM        WAVELENGTH'/1X,
     &'    MU     = ',E10.3,' MM**-1        LINEAR ABSORPTION COEFFICI',
     &'ENT'/1X,
     &'    RADIUS = ',E10.3,' MM            ESTIMATED RADIUS OF "EQUIV',
     &'ALENT" SPHERICAL CRYSTAL'/1X,
     &'    TMIN   = ',E10.3,' MM            ESTIMATED MINIMUM CRYSTAL ',
     &'THICKNESS'/1X,
     &'    TMAX   = ',E10.3,' MM            ESTIMATED MAXIMUM CRYSTAL ',
     &'THICKNESS'/1X,
     &'    ERRMUT = ',E10.3,'               ESTIMATED FRACTIONAL ERROR',
     &' IN MU*TBAR'/1X,
     &'    WA     = ',E10.3,'               RELATIVE WEIGHTING FACTOR ',
     &'FOR THE  <AHI> = 1  ABSORPTION ANISOTROPY RESTRAINT RESIDUAL'/1X,
     &'    UMIN   = ',E10.3,'               EIGENVALUE FILTERING FACTOR'
     &)
 611  FORMAT (1X,
     &'    FSQMIN = ',E10.3,'               MINIMUM FSQ/SIGMA(FSQ) FOR',
     &' MEASUREMENTS USED FOR YLM FIT'/1X,
     &'    FSQMAX = ',E10.3,'               MAXIMUM FSQ FOR MEASUREMEN',
     &'TS USED FOR YLM FIT'/1X,
     &'    STLMIN = ',F5.2,' ANGSTROM**-1       MINIMUM SIN(THETA)/LAM',
     &'BDA FOR REFLECTIONS USED FOR YLM FIT'/1X,
     &'    STLMAX = ',F5.2,' ANGSTROM**-1       MAXIMUM SIN(THETA)/LAM',
     &'BDA FOR REFLECTIONS USED FOR YLM FIT'/1X,
     &'    AMIN   = ',E10.3,'               MINIMUM EXPECTED RELATIVE ',
     &'TRANSMISSION FACTOR'/1X,
     &'    AMAX   = ',E10.3,'               MAXIMUM EXPECTED RELATIVE ',
     &'TRANSMISSION FACTOR')
 612  FORMAT (1X,
     &'    IPATH  = ',I2/1X,
     &'    IPLOT  = ',I2//1X,
     &'    IF IPATH .EQ. 0, DO NOT;'/1X,
     &'    IF IPATH .EQ. 1, DO WRITE ESTIMATED TBAR AND BEAM DIRECTION',
     &' VECTORS TO THE OUTPUT REFLECTION FILE.'//1X,
     &'    IF IPLOT .EQ. 1, PLOT [100], [010], AND [001] PSI-SCAN SECT',
     &'IONS THROUGH FITTED TRANSMISSION SURFACE.'/1X,
     &'    IF IPLOT .EQ. 2, ALSO [110], [-110], [101], [-101], [011], ',
     &'AND [0-11].'/1X,
     &'    IF IPLOT .EQ. 3, ALSO [111], [-111], [-1-11], AND [1-11].')
 613  FORMAT (/1X,
     &'    FMU = 0.  ONLY TRANSMISSION ANISOTROPY FACTORS, 0 < A < AMA',
     &'X, AMEAN APPROXIMATELY 1, WILL BE CALCULATED.')
 614  FORMAT (/1X,
     &'    RADIUS = 0 AND TMIN = 0.  ONLY TRANSMISSION ANISOTROPY FACT',
     &'ORS, 1 - X < A < 1 + X, <A> = 1,  WILL BE CALCULATED.')
 615  FORMAT (/1X,
     &'    IF RADIUS .EQ. 0, AND TMIN .GT. 0, RADIUS WILL BE ESTIMATED',
     &' FROM'/1X,'    A(SPHERE) = A(LIMIT)/A(MAX),'/1X,
     &'    WHERE A(LIMIT) = EXP(-MU*TMIN),'/1X,
     &'    AND A(MAX) IS THE MAXIMUM TRANSMISSION ANISOTROPY FACTOR FR',
     &'OM 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,' )')
 3    CONTINUE
C
C DATA AVERAGING AND INPUT/OUTPUT CONTROL VARIABLES
C
      PTGP='    '
      IW=0
      JW=0
      ZZMAX=0
      QQ=0
      RR=0
      C1=0
      C2=0
      C3=0
      C4=0
      RIJ=0
      SISJ=0
      QLIMIT=0
      ZLIMIT=0
      IPRINT=0
      JPRINT=0
      JPATH=0
      QPRINT=0
      SMINJ=0
      SMAXJ=0
      JN=0
      JHKL=0
C
C DATA AVERAGING VARIABLES
C
      READ (IO1,'(A)',END=9) PTGP
      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) RIJ,SISJ
      READ (IO1,*,END=9) QLIMIT,ZLIMIT,IPRINT,JPRINT,JPATH,QPRINT
C
C INPUT CONTROL VARIABLES      
C
      READ (IO1,*,END=9) SMINJ,SMAXJ
C
C MEASUREMENTS TO BE REJECTED ON INPUT
C
      JHKL=72
      OPEN (UNIT=JHKL,STATUS='SCRATCH',FORM='UNFORMATTED')
      JN=0
      DO J=1,1E9
        READ  (IO1,*,END=8) JI,JH,JK,JL
        WRITE (JHKL)        JI,JH,JK,JL
        JN=JN+1
      END DO
 8    IF (JN.GT.0) THEN
        ENDFILE JHKL       
      ELSE
        CLOSE (UNIT=JHKL,STATUS='DELETE')
      END IF
 9    CLOSE (UNIT=IO1,STATUS='KEEP')
C
C SET DEFAULT VALUES AND ECHO DATA AVERAGING VARIABLES.
C
      IF (PTGP.NE.'XTAL') PTGP='LAUE'
      IF (PTGP.EQ.'LAUE') THEN
        IPTGP=ILAUE
        IPTGPM=ILAUE
        IPTGPA=ILAUE
        IPTGPS=ILAUE
      END IF
      IF (PTGP.EQ.'XTAL') THEN
        IPTGP=IXTAL
        IPTGPM=IXTAL
      END IF
      IF (IW.EQ.0) IW=1
      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) PTGP,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,
     &'  PTGP   = ',1X,A4,'  POINT GROUP FOR EQUIVALENT REFLECTIONS AV',
     &'ERAGING'/1X,
     &'    IW   = ',I2/1X,
     &'    JW   = ',I2/1X,
     &'    ZMAX = ',F4.1//1X,
     &'AVERAGING FORMULAE:'/1X,
     &'  YMEAN = SUM(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,
     &'WEIGHTS 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(MEDIAN[SIGMA(Y)], 1.25*MEDIAN{ABS[Y -',
     &' MEDIAN(Y)]}*SQRT[N/(N - 1)])'/1X,
     &'  IF IW = 1,  SIGMA = SIGMA(Y)')
 660  FORMAT (//1X,
     &'VARIABLES FOR REJECTING ABNORMAL OUTLIERS FROM THE SAMPLE MAXIM',
     &'UM:'/1X,
     &'---------------------------------------------------------------',
     &'---'//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 INTERVAL FROM'/1X,
     &'  YMIN = MU - Z*SIGMA'/1X,'TO'/1X,
     &'  YMAX = MU + Z*SIGMA'/1X,'INCLUDES MORE THAN 99.99% OF THE DIS',
     &'TRIBUTION IF Z = 4.')
 661  FORMAT (//1X,
     &'VARIABLES FOR REJECTING ABNORMAL OUTLIERS FROM THE SAMPLE MEDIA',
     &'N:'/1X,
     &'---------------------------------------------------------------',
     &'--'//1X,
     &'    C1 = ',F5.3/1X,
     &'    C2 = ',F5.3/1X,
     &'    C3 = ',F5.3/1X,
     &'    C4 = ',F5.3//1X,
     &'OUTLIER MEASUREMENTS YI WILL BE REJECTED BEFORE AVERAGING IF'/1X,
     &'  ABS(YI - MEDIAN(YI)) .GT. TEST,'/1X,
     &'WHERE'/1X,
     &'  TEST  = MAX(C1*MEDIAN(YI),'/1X,
     &'                C2*MEDIAN(SIGMA(YI)),'/1X,
     &'                  C3*1.25*MEDIAN(ABS(Y','I - MEDIAN(YI)))*SQRT(',
     &'N/(N - 1)),'/1X,
     &'                    C4*ZCRIT(N)*MAX(MEDIAN(SIGMA(YI)),'/1X,
     &'                      1.25*MEDIAN(ABS(YI - MEDIAN(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) THAT Z > ZCRIT.')
C
C ECHO OUTPUT CONTROL VARIABLES.
C
      IF (RIJ.LT.0.OR.SISJ.LT.0) THEN
        RIJ=-9
        SISJ=-9
      ELSE IF (RIJ.EQ.0.OR.SISJ.EQ.0) THEN
        RIJ=0
        SISJ=0
      ELSE IF (RIJ.GT.0.AND.SISJ.GT.0) THEN
        WRITE (ILP,641) RIJ,SISJ
      END IF
      IF (QLIMIT.LE.0) QLIMIT=4
      IF (ZLIMIT.LE.0) ZLIMIT=4
      WRITE (ILP,642) 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
 641  FORMAT (//1X,
     &'VARIABLES FOR ESTIMATING SIGMA(<Y>) FROM <SIGMA(Y)**2>**(1/2):'
     &/1X,
     &'--------------------------------------------------------------'
     &//1X,
     &'INPUT VALUES OF THE MEAN CORRELATION COEFFICIENT, RIJ,'/1X,
     &'BETWEEN (POSSIBLY IMPLICIT) SUBSET SCALE FACTORS'/1X,
     &'AND OF THE MEAN PRODUCT, SISJ, OF REALTIVE SCALE FACTOR UNCERTA',
     &'INTIES:'//1X,
     &'    RIJ  = <RHO(KI,KJ)>                  = ',E10.3/1X,
     &'    SISJ = <SIGMA(KI)*SIGMA(KJ)/(KI*KJ)> = ',E10.3)
 642  FORMAT (//1X,
     &'THRESHOLD VALUES FOR LISTING OUTLIER MEASUREMENTS:'/1X,
     &'--------------------------------------------------'//1X,
     &'    RMSD/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 U0 AND U1 COMPONENTS WILL BE WR',
     &'ITTEN 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 (SMINJ.GE.0.AND.SMAXJ.GT.SMIN1) WRITE (ILP,645) SMINJ,SMAXJ
 645  FORMAT(//1X,
     &'SIN(THETA)/LAMBDA INPUT REJECTION LIMITS:'/1X,
     &'-----------------------------------------'//1X,
     &'ONLY MEASUREMENTS WITH S = SIN(THETA)/LAMBDA VALUES BETWEEN THE',
     &' LIMITS,'/1X,'SMINJ AND SMAXJ, WILL BE PROCESSED.'//1X,
     &'    SMINJ   = ',F6.3/'     SMAXJ   = ',F6.3)
      IF (SMINJ.LT.0) SMINJ=0
      IF (SMAXJ.LE.0) SMAXJ=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)
        REWIND JHKL
        DO J=1,JN
          READ  (JHKL)    JI,JH,JK,JL
          WRITE (ILP,671) JI,JH,JK,JL
        END DO
      END IF
 670  FORMAT (//1X,
     &'MEASUREMENTS TO BE REJECTED FROM THE INPUT DATA:'/1X,
     &'------------------------------------------------'//1X,
     & ' SER.NO.   H   K   L    '/1X,
     & ' -------   -   -   -    ')
 671  FORMAT (1X,I8,3I4) 
      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,  N .LE. M .LE. NMAX
C D = DETERMINANT OF THE INPUT MATRIX
C
C RETURNS D = 0 TO FLAG A SINGULAR MATRIX.
C
      PARAMETER (NMAX=1000)
      DIMENSION A(M,M),Q(NMAX),IK(NMAX),JK(NMAX)
      DOUBLE PRECISION A,Q,AMAX,T
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 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,V,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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,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),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,IPRINT,JPRINT,JPATH,QLIMIT,ZLIMIT,QPRINT
      COMMON /BLOCK3/ SMIN,SMAX,
     & IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,
     & JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX,
     & LHMIN,LHMAX,LKMIN,LKMAX,LLMIN,LLMAX
      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 U0(3),U1(3)
      DATA TBAR,U0,U1 /7*0/
      DIMENSION NDATA(100),XDATA(100),YDATA(100),YPP(100)
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      REAL,    ALLOCATABLE::DATA(:)
      INTEGER, ALLOCATABLE::INDEX(:)
      CUTOFF=QPRINT
      NTOTAL=0
      NQ0=0
      NQ1=0
      NQ2=0
      NQ3=0
      NQ4=0
      NQ6=0
      REWIND IO1
      IEND=0
 11   CALL READ2 (IO1,JPATH,IEND,IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     & TBAR,U0,U1)
      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 (/1H1,130('-')/1X,'PROGRAM SORTAV.  ',A,', ',A,'.  ',A)
      WRITE (ILP,'(/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)')
     & NTOTAL,NQ0,NQ1,NQ2,NQ3,NQ4,NQ6
      WRITE (ILP,'(/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)')
     & (N1(I),Y1(I),I=1,17)
      WRITE (ILP,'(/1X,''RESOLUTION SHELLS  (SMIN .LT. S .LE. SMAX)  '',
     &''(DMAX .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)')
     & (N2(I),Y2(I),I=1,15)
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,'(/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)')
     & 1/(2*X3(1)),N3(1),Y3(1)
      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.2*H
      XXMIN=O-H
      XXMAX=O+H
      O=0.5*(YMIN+YMAX)
      H=0.5*(YMAX-YMIN)
      H=1.2*H
      YYMIN=O-H
      YYMAX=O+H
      WRITE (ILP,610) ATIME,ADATE,TITLE
 610  FORMAT (/1H1,130('-')/1X,10X,
     &'PROGRAM SORTAV.  ',A,', ',A,'.  ',A/)
      CALL PLOT (ILP,XXMIN,XXMAX,YYMIN,YYMAX,N,XDATA,YDATA,YPP)
      WRITE (ILP,'(/1X,10X,''LOG10(<SIGMA(Y)>) (VERTICAL) VERSUS LOG1'',
     &''0(<Y>) (HORIZONTAL)''//1X,10X,''CUBIC SPLINE INTERPOLATED CUR'',
     &''VE THROUGH M = '',I3,'' LOCALLY AVERAGED DATA POINTS WITH N ='',
     &'' '',I4,'' DATA PER LOCAL AVERAGE.'')') N,NLOCAL
C
C PRINT TABLE OF <SIGMA(Y)> VERSUS <Y>.
C
      WRITE (ILP,610) ATIME,ADATE,TITLE
      WRITE (ILP,'(/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.2*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,'(/1X,10X,''<Y> (VERTICAL) VERSUS <SIN(THETA)/LAMBDA'',
     &''> (HORIZONTAL).''//1X,10X,''CUBIC SPLINE INTERPOLATED CURVE T'',
     &''HROUGH M = '',I3, '' LOCALLY AVERAGED DATA POINTS WITH N = '',
     &I4,'' DATA PER LOCAL AVERAGE.'')') N,NLOCAL
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.2*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,'(/1X,10X,''<SIGMA(Y)> (VERTICAL) VERSUS <SIN(THETA)'',
     &''/LAMBDA> (HORIZONTAL).''//1X,10X,''CUBIC SPLINE INTERPOLATED '',
     &''CURVE THROUGH M = '',I3, '' LOCALLY AVERAGED DATA POINTS WITH'',
     &'' N = '',I4,'' DATA PER LOCAL AVERAGE.'')') N,NLOCAL
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.2*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,'(/1X,10X,''<Y/SIGMA(Y)> (VERTICAL) VERSUS <SIN(THET'',
     &''A)/LAMBDA> (HORIZONTAL).''//1X,10X,''CUBIC SPLINE INTERPOLATE'',
     &''D CURVE THROUGH M = '',I3, '' LOCALLY AVERAGED DATA POINTS WI'',
     &''TH N = '',I4,'' DATA PER LOCAL AVERAGE.'')') N,NLOCAL
C
C TABULATE EFFECTIVE RESOLUTION LIMITS.
C
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,'(/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,'(/1X,
     &''DATA SET AVERAGES IN EQUALLY POPULATED RANGES OF 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 > CUTOFF*SIGY, CUTOFF = '',F4.2/1X,
     &''                     ---         ---      ------  ---------- '',
     &''   --------  --------------------------------------------''/
     & (1X,16X,F8.4,5F12.2))')
     & NRANGE,NLOCAL,CUTOFF,(AS(I),AY(I),ASIGY(I),
     & AY(I)/MAX(ASIGY(I),1.0E-10),AYSIG(I),FSIG(I),I=1,NRANGE)
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,'(/1X,
     &''DATA SET AVERAGES IN EQUAL-VOLUME RESOLUTION SHELLS:''/1X,
     &''----------------------------------------------------''//1X,
     &''   SHELL   SHELL''/1X,
     &''   S-MAX   D-MIN     <S>         <Y>      <SIGY>  <Y>/<SIGY> '',
     &''   <Y/SIGY>  FRACTION WITH Y > CUTOFF*SIGY, CUTOFF = '',F4.2/1X,
     &''   -----   -----     ---         ---      ------  ---------- '',
     &''   --------  --------------------------------------------''/
     & (1X,F8.4,F8.3,F8.4,5F12.2))')
     & 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)
      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=16)
      N=0
      IEND=0
 91   CALL READ2 (IO1,JPATH,IEND,IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     & TBAR,U0,U1)
      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
        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
      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 (/1X,
     &'DATA RESOLUTION AND COMPLETENESS:'/1X,
     &'---------------------------------'//1X,
     &'OVERALL SMAX = SIN(THETA(MAX))/LAMBDA       = ',F6.3,' RECIPROC',
     &'AL ANGSTROMS'/1X,
     &'OVERALL DMIN = 1/(2*SIN(THETA(MAX))/LAMBDA) = ',F5.2,'  ANGSTRO',
     &'MS')
 641  FORMAT (/1X,
     &'N  = ',I8,' MEASURED UNIQUE HKL'/1X,
     &'M  = ',I8,' MISSING UNIQUE HKL WITH SIN(THETA)/LAMBDA .LE. SMAX',
     &'.'//1X,
     &'OVERALL COMPLETENESS = ',F5.1,'%')
 642  FORMAT (/1X,
     &'MISSING HKL ARE LISTED IN A "missing.hkl" OUTPUT FILE SORTED ON',
     &' SIN(THETA)/LAMBDA.')
C
C SAVE FILE OF MISSING REFLECTIONS SORTED ON SIN(THETA)/LAMBDA.
C
      ALLOCATE (DATA(N),INDEX(N))
      DO I=1,N
        READ (IO2,REC=I) J,J,J,DATA(I)
      END DO
      CALL SORT (N,DATA,INDEX)
      DEALLOCATE (DATA)
      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
      DEALLOCATE (INDEX)
      CLOSE (UNIT=IO2,STATUS='DELETE')
      WRITE (ILP,'(/1X,
     &''DISTRIBUTION OF MEASURED AND MISSING REFLECTIONS IN EQUAL-VOL'',
     &''UME 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))') (X3(I),1/(2*X3(I)),N3(I),INT(Y3(I)),
     & 100*N3(I)/MAX(1.0,N3(I)+Y3(I)),I=1, M3)
 99   WRITE (ILP,'(//1X,''JOB STARTED:   '',A,'', '',A)') ATIME,ADATE
      CALL VTIME (ATIME)
      CALL VDATE (ADATE)
      WRITE (ILP,'(  1X,''JOB FINISHED:  '',A,'', '',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*116
      DIMENSION ANGLES(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
        ANGLES(I)=E
      END DO
      SIGY=-E
      XTIME=-E
      READ (IUNIT,ERR=1,END=50) II,IH,IK,IL,ANGLES,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(ANGLES(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
        ANGLES(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,ANGLES,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(ANGLES(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 (OLD-STYLE, BINARY) OUTPUT FILE (14 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:  IH, IK, IL, 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 PROGRAM SORTAV (NEW-STYLE, ASCII) OUTPUT FILE:
C IH, IK, IL, Y, SIGMA(Y), ESD, RMSD, NMEAS, TBAR, S0(3), S1(3)
C (116 CHARACTERS 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 (RECORD,*,ERR=5,END=5) IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     & TBAR,S0,S1
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 5
      IF (SIGY.LE.0.OR.ESD.LT.0.OR.RMSD.LT.0.OR.NMEAS.LT.1.OR.TBAR.LT.0)
     & GO TO 5
      DO I=1,3
        IF (ABS(S0(I)).GT.1.OR.ABS(S1(I)).GT.1) GO TO 5
      END DO
      ITYPE=5
      RETURN
 5    CONTINUE
C
C ASCII FILE:  IH, IK, IL, Y, SIGMA(Y), ISCALE, S0(3), S1(3)
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      ISCALE=-E
      DO I=1,3
        S0(I)=E
        S1(I)=E
      END DO
      READ (RECORD,*,ERR=6,END=6) IH,IK,IL,Y,SIGY,ISCALE,S0,S1
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 6
      IF (SIGY.LE.0.OR.ISCALE.LE.0) GO TO 6
      DO I=1,3
        IF (ABS(S0(I)).GT.1.OR.ABS(S1(I)).GT.1) GO TO 6
      END DO
      ITYPE=6
      RETURN
 6    CONTINUE
C
C PROGRAM SORTAV (NEW-STYLE, ASCII) OUTPUT FILE:
C IH, IK, IL, Y, SIGMA(Y), ESD, RMSD, NMEAS
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      ESD=-E
      RMSD=-E
      NMEAS=-E
      READ (RECORD,*,ERR=7,END=7) IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 7
      IF (SIGY.LE.0.OR.ESD.LT.0.OR.RMSD.LT.0.OR.NMEAS.LT.1) GO TO 7
      ITYPE=7
      RETURN
 7    CONTINUE
C
C ASCII FILE:  IH, IK, IL, Y, SIGMA(Y), ISCALE
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      ISCALE=-E
      READ (RECORD,*,ERR=8,END=8) IH,IK,IL,Y,SIGY,ISCALE
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 8
      IF (SIGY.LE.0.OR.ISCALE.LE.0) GO TO 8
      ITYPE=8
      RETURN
 8    CONTINUE
C
C ASCII FILE:  IH, IK, IL, Y, SIGMA(Y)
C
      IH=E
      IK=E
      IL=E
      SIGY=-E
      READ (RECORD,*,ERR=9,END=9) IH,IK,IL,Y,SIGY
      IF (ABS(IH).GE.M.OR.ABS(IK).GE.M.OR.ABS(IL).GE.M) GO TO 9
      IF (SIGY.LE.0) GO TO 9
      ITYPE=9
      RETURN
 9    CONTINUE
 99   CONTINUE
C
C UNKNOWN FILE TYPE
C
      STOP ' SORTAV/READF:  UNKNOWN TYPE OF INPUT REFLECTION FILE'
      END
C-----------------------------------------------------------------------
      SUBROUTINE READ1 (IUNIT,ITYPE,IEND,II,IH,IK,IL,Y,SIGY,ISCALE,A)
      DIMENSION ANGLES(4),S0(3),S1(3),A(11)
      IF (ITYPE.EQ.1) THEN
        READ (IUNIT,END=9) II,IH,IK,IL,ANGLES,Y,SIGY,XTIME
        DO I=1,4
          A(I)=ANGLES(I)
        END DO
      ELSE IF (ITYPE.EQ.2) THEN
        READ (IUNIT,END=9) II,IH,IK,IL,ANGLES,Y,SIGY,XTIME,TBAR,S0,S1
        DO I=1,4
          A(I)=ANGLES(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,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,ESD,RMSD,NMEAS,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.6) THEN
        READ (IUNIT,*,END=9) IH,IK,IL,Y,SIGY,ISCALE,S0,S1
        II=II+1
        DO I=1,3
          A(5+I)=S0(I)
          A(8+I)=S1(I)
        END DO
      ELSE IF (ITYPE.EQ.7) THEN
        READ (IUNIT,*,END=9) IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS
        II=II+1
      ELSE IF (ITYPE.EQ.8) THEN
        READ (IUNIT,*,END=9) IH,IK,IL,Y,SIGY,ISCALE
        II=II+1
      ELSE IF (ITYPE.EQ.9) THEN
        READ (IUNIT,*,END=9) IH,IK,IL,Y,SIGY
        II=II+1
      ELSE
        STOP ' SORTAV/READ1:  UNKNOWN TYPE OF INPUT REFLECTION FILE'
      END IF
      RETURN
 9    IEND=1
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE READ2 (IUNIT,JPATH,IEND,IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     & TBAR,U0,U1)
C
C ANY CHANGE IN THE RECORD STRUCTURE OR FORMAT IN SUBROUTINE WRITE1 WILL
C REQUIRE CORRESPONDING CHANGES HERE.
C
      DIMENSION U0(3),U1(3)
      IF (JPATH.EQ.0) THEN
        READ (IUNIT,'(1X,
     &   3I5,E12.4,E10.2,2E11.3,I5)',END=9)
     &   IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS
      ELSE
        READ (IUNIT,'(1X,
     &   3I5,E12.4,E10.2,2E11.3,I5,F7.3,2(1X,3F7.3))',END=9)
     &   IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,TBAR,U0,U1
      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)
      IEND=0
      II=0
      ISCALE=IFILE
      DO I=1,11
        A(I)=0
      END DO
 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-----------------------------------------------------------------------
      SUBROUTINE SIGMEAN
C
C EVALUATE AND WRITE SIGMA(YMEAN) VALUES.
C
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,NMAX
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,IPRINT,JPRINT,JPATH,QLIMIT,ZLIMIT,QPRINT
      DIMENSION U0(3),U1(3)
      DOUBLE PRECISION SUMN,SUMR,SUMM,SUMF
C
C RIJ  = MEAN CORRELATION COEFFICIENT OF THE (POSSIBLY IMPLICIT) SUBSET
C        SCALE FACTORS
C SISJ = MEAN PRODUCT OF THE RELATIVE SCALE FACTOR UNCERTAINTIES
C
      IF (RIJ.EQ.0.OR.SISJ.EQ.0) THEN
        RIJ=0.5
        SISJ=0.01*0.01
      END IF
      IF (RIJ.LT.0.OR.SISJ.LT.0) THEN
        RIJ=0
        SISJ=0
      END IF
      Q=RIJ*SISJ
      MMAX=0
      SUMN=0
      RMAX=0
      SUMR=0
      SUMM=0
      FMIN=1
      SUMF=0
      IEND=0
      NTOTAL=0
      REWIND IO1
      OPEN (UNIT=IO2,STATUS='SCRATCH',FORM='FORMATTED')
 1    CALL READ2  (IO1,JPATH,IEND,IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     & TBAR,U0,U1)
      IF (IEND.NE.0) GO TO 9
      NTOTAL=NTOTAL+1
      IF (NMEAS.GT.1.AND.Y/SIGY.GT.0) THEN
        R=Q*(Y/SIGY)**2
        F=SQRT((1+(NMEAS-1)*R)/NMEAS)
        SIGY=F*SIGY
        MMAX=MAX(MMAX,NMEAS)
        SUMN=SUMN+NMEAS
        RMAX=MAX(RMAX,R)
        SUMR=SUMR+R
        SUMM=SUMM+1
        FMIN=MIN(FMIN,F)
        SUMF=SUMF+F
      ELSE
        SUMF=SUMF+1
        SUMN=SUMN+1
      END IF
      CALL WRITE1 (IO2,JPATH,     IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     & TBAR,U0,U1)
      GO TO 1
 9    CONTINUE
      ENDFILE IO2
      WRITE (ILP,'(/1H1,130(''-'')/1X,
     &''PROGRAM SORTAV/YMERGE.  '',A,'', '',A,''.  '',A)')
     & ATIME,ADATE,TITLE
      WRITE (ILP,'(/1X,
     &''ESTIMATES OF SIGMA(YMEAN) FROM ROOT-MEAN-SQUARE SIGMA(Y),''/1X,
     &''---------------------------------------------------------''/1X,
     &''I.E., SIGMA(<Y>) FROM <SIGMA(Y)**2>**(1/2):''/1X,
     &''-------------------------------------------''//1X,
     &''                 {<SIGMA(Y)**2>                              '',
     &''  }''/1X,
     &''SIGMA(<Y>) = SQRT{------------- *[1 + (NMEAS - 1)*<RHO(YI,YJ)'',
     &''>]}''/1X,
     &''                 {   NMEAS                                   '',
     &''  }''//1X,
     &''WHERE''//1X,
     &''                        SIGMA(KI) SIGMA(KJ)    YI        YJ''
     &/1X,
     &''RHO(YI,YJ) = RHO(KI,KJ)*---------*---------*---------*-------'',
     &''--''/1X,
     &''                           KI        KJ     SIGMA(YI) SIGMA(Y'',
     &''J)'',//1X,
     &''IN WHICH KI AND KJ REPRESENT (POSSIBLY IMPLICIT) SUBSET SCALE'',
     &'' FACTORS.''////1X,
     &''ESTIMATED <RHO(KI,KJ)>                  = '',E10.3/1X,
     &''ESTIMATED <SIGMA(KI)*SIGMA(KJ)/(KI*KJ)> = '',E10.3//1X,
     &''ESTIMATED <RHO(KI,KJ)>*<SIGMA(KI)*SIGMA(KJ)/(KI*KJ)> = '',E10.3
     &//1X,
     &''MAXIMUM ESTIMATED  <RHO(YI,YJ)> = '',E10.3/1X,
     &''MEAN    ESTIMATED  <RHO(YI,YJ)> = '',E10.3////1X,
     &''MAXIMUM NMEAS = '',F6.1/1X,
     &''MEAN    NMEAS = '',F6.1//1X,
     &''MINIMUM SIGMA(<Y>)/<SIGMA(Y)**2>**(1/2) = '',F6.3/1X,
     &''MEAN    SIGMA(<Y>)/<SIGMA(Y)**2>**(1/2) = '',F6.3//1X,
     &''1/MINIMUM**2  = '',F6.1/1X,
     &''1/MEAN**2     = '',F6.1)') RIJ,SISJ,Q,
     & RMAX,SUMR/SUMM,FLOAT(MMAX),SUMN/NTOTAL,FMIN,SUMF/NTOTAL,
     & 1/FMIN**2,1/(SUMF/NTOTAL)**2
C
C COPY RESULTS TO THE OUTPUT REFLECTION FILE NAMED "FILE2".
C
      REWIND IO1
      REWIND IO2
      DO I=1,NTOTAL
        CALL READ2  (IO2,JPATH,IEND,IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     &  TBAR,U0,U1)
        CALL WRITE1 (IO1,JPATH,     IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     &  TBAR,U0,U1)
      END DO
      CLOSE (UNIT=IO2,STATUS='DELETE')
      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 SOLVE (N,M,A,B,UMIN,NZERO)
C
C SOLVE THE NORMAL MATRIX EQUATION A*X=B, WHERE A IS A SYMMETRIC MATRIX,
C AND X AND B ARE COLUMN VECTORS.
C
C ON INPUT, A AND B ARE THE NORMAL MATRIX AND VECTOR.  ON OUTPUT, A IS
C THE INVERSE NORMAL MATRIX, AND B CONTAINS THE SOLUTION VECTOR X.
C
C N = ORDER OF MATRIX
C   = LOGICAL SIZE OF ARRAYS A AND B
C M = PHYSICAL SIZE OF ARRAYS A AND B
C
C MUST HAVE  N .LE. M .LE. NMAX.
C
      PARAMETER (NMAX=80)
      DIMENSION A(M,M),B(M),U(NMAX),V(NMAX,NMAX),VA(NMAX,NMAX)
      DOUBLE PRECISION A,B,U,V,VA
C
C INVERT THE NORMAL MATRIX VIA DIAGONALIZATION AND EIGENVALUE FILTERING.
C
      CALL JACOBI (N,M,A,U,V,NROT)
      UMAX=0
      DO I=1,N
        UMAX=MAX(UMAX,SNGL(U(I)))
      END DO
      NZERO=0
      T=UMIN*UMAX
      DO I=1,N
        IF (U(I).LT.T) THEN
          U(I)=0
          NZERO=NZERO+1
        ELSE
          U(I)=1/U(I)
        END IF
      END DO
      DO I=1,N
      DO J=1,N
        A(I,J)=0
      END DO
        A(I,I)=U(I)
      END DO
      CALL MMD (N,NMAX,V,A,VA)
      DO I=1,N-1
      DO J=I+1,N
        T=V(I,J)
        V(I,J)=V(J,I)
        V(J,I)=T
      END DO
      END DO
      CALL MMD (N,NMAX,VA,V,A)
C
C CALCULATE THE PARAMETER VALUES.
C
      DO I=1,N
        U(I)=0
      DO J=1,N
        U(I)=U(I)+A(I,J)*B(J)
      END DO
      END DO
      DO I=1,N
        B(I)=U(I)
      END DO
      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)
      CHARACTER DIFF*4
      DIMENSION U(3,3),V(3,3),W(3,3)
      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-----------------------------------------------------------------------
C=====================================================================
C Machine-dependent system-service routines (such as TIME and DATE)
C=====================================================================
      SUBROUTINE VFDATE(DAYTIME)
C
C This routine returns the date/time as a 20 charater string.
C Truncation occurs if the length of the input string is less than 20.
C The format of the returned string is "dd mmm yyyy hh:mm:ss".
C Note: this routine is Y2K compliant.
C
C +++++++++++++++++++++++++++++++++++++++
C Machine dependent intel/Win32 version.
C +++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C input/output
      CHARACTER*(*) DAYTIME
C local
      CHARACTER DATE*8, TIME*10, ZONE*5, MONTH(12)*3, TEMP*20
      INTEGER VALUES(8)
      
      DATA MONTH/'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
     &           'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
C
      CALL DATE_AND_TIME(DATE, TIME, ZONE, VALUES)
      TEMP = DATE(7:8) // ' ' // MONTH(VALUES(2)) // ' ' //
     &       DATE(1:4) // ' ' // TIME(1:2) // ':' // TIME(3:4) //
     &       ':' // TIME(5:6)
      DAYTIME = TEMP
      RETURN
      END
C=====================================================================
      SUBROUTINE VDATE(ADATE)
C
C This routine returns the date as a 9 charater string.  Truncation
C occurs if the length of the input string is less than 9.  The format
C of the returned string is "dd-mmm-yy".
C
C Note: this routine is not Y2K compliant.
C
C +++++++++++++++++++++++++++++++++++++++
C Machine dependent intel/Win32 version.
C +++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C input/output
      CHARACTER*(*) ADATE
C local
      CHARACTER TEMP*20
C
      CALL VFDATE(TEMP)
      ADATE = TEMP(1:2) // '-' // TEMP(4:6) // '-' // TEMP(10:11)     
      RETURN
      END
C=====================================================================
      SUBROUTINE VTIME(ATIME)
C
C This routine returns the time of day as an 8 character string.
C Truncation occurs if the length of the input string is less than 8.
C The format of the returned string is "hh:mm:ss".
C
C +++++++++++++++++++++++++++++++++++++++
C Machine dependent intel/Win32 version.
C +++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C input/output
      CHARACTER*(*) ATIME
C local
      CHARACTER TEMP*20
C
      CALL VFDATE(TEMP)
      ATIME = TEMP(13:20)
      RETURN
      END
C=====================================================================
      SUBROUTINE WRITE1 (IUNIT,JPATH,IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,
     &TBAR,U0,U1)
C
C IF THE OUTPUT RECORD STRUCTURE OR FORMAT IS CHANGED, CORRESPONDING
C CHANGES WILL BE REQUIRED IN SUBROUTINE READ2.
C
      DIMENSION U0(3),U1(3)
      IF (JPATH.NE.0) THEN
        WRITE (IUNIT,'(1X,
     &  3I5,E12.4,E10.2,2E11.3,I5,F7.3,2(1X,3F7.3))')
     &  IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS,TBAR,U0,U1
      ELSE
        WRITE (IUNIT,'(1X,
     &  3I5,E12.4,E10.2,2E11.3,I5)')
     &  IH,IK,IL,Y,SIGY,ESD,RMSD,NMEAS
      END IF
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE YMERGE
C
C AVERAGE REPLICATE AND EQUIVALENT MEASUREMENTS, AND COMPILE AGREEMENT
C STATISTICS.
C
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,NMAX
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80,FLAG*1,
     & PTGP*4
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCK3/ SMIN,SMAX,
     & IHMIN,IHMAX,IKMIN,IKMAX,ILMIN,ILMAX,
     & JHMIN,JHMAX,JKMIN,JKMAX,JLMIN,JLMAX,
     & LHMIN,LHMAX,LKMIN,LKMAX,LLMIN,LLMAX
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,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,SUMQ
      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 ANGLES(4),U0(3),U1(3),U0J(3),U1J(3)
      DATA ANGLES,TBAR,U0,U1 /11*0/
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      INTEGER, ALLOCATABLE::II(:),IH(:),IK(:),IL(:),ISCALE(:),INDEX(:)
      REAL,    ALLOCATABLE::YI(:),SIGYI(:),WI(:),PATH(:,:),DATA(:)
      ALLOCATE (II(NMAX),IH(NMAX),IK(NMAX),IL(NMAX),ISCALE(NMAX),
     & YI(NMAX),SIGYI(NMAX),WI(NMAX),PATH(7,NMAX),INDEX(NMAX))
C
C STORE VARIABLE SIN(THETA)/LAMBDA INTERVALS FOR DATA SET STATISTICS IN
C EQUAL-VOLUME SHELLS.
C
      DO I=1,M3
        X3(I)=(FLOAT(I)/M3)**(1/3.0)*SMAX
      END DO
C
C PRINTED OUTPUT FORMAT
C
      NLINE=0
      WRITE (ILP,1000) ATIME,ADATE,TITLE
 1000 FORMAT (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/YMERGE.  ',A,', ',A,'.  ',A//1X,
     &'  SER.NO.   H   K   L           Y    SIGMA(Y)                  ',
     &'     SINTHL ISCALE TBAR   -U0 AND U1 VECTOR COMPONENTS'/1X,
     &'                                          ESD     RMSD RMSD/ESD',
     &' NMEAS                    ALONG CRYSTAL-FIXED CARTESIAN AXES'/)
 1001 FORMAT (1X,A1,I8,3I4,2F12.2,29X,I4)
 2001 FORMAT (1X,A1,I8,3I4,2F12.2,29X,I4,F7.3,2(2X,3F7.3))
 1002 FORMAT (1X,1X,I8,3I4,3F12.2,F6.1,I4,F7.3,I4)
 2002 FORMAT (1X,1X,I8,3I4,3F12.2,F6.1,I2,F7.3,I4,F7.3,2(2X,3F7.3))
 1003 FORMAT (1X,'  AVERAGE',3I4,3F12.2,F6.1,I4,F7.3)
 2003 FORMAT (1X,'  AVERAGE',3I4,3F12.2,F6.1,I4,F7.3,4X,F7.3,2(2X,3F7.3)
     &)
C
C DATA EQUIVALENT UNDER (CENTROSYMMETRIC) LAUE POINT GROUP SYMMTERY ON
C UNIT IO1, OR (NONCENTROSYMMETRIC) CRYSTAL CLASS POINT GROUP SYMMETRY
C ON UNIT IO2?
C
      IF (IPTGPM.EQ.ILAUE) THEN
        IPTGP=ILAUE
        IHMIN=LHMIN
        IHMAX=LHMAX
        IKMIN=LKMIN
        IKMAX=LKMAX
        ILMIN=LLMIN
        ILMAX=LLMAX
      END IF
      IF (IPTGPM.EQ.IXTAL.AND.IXTAL.NE.ILAUE) THEN
        IPTGP=IXTAL
        IHMIN=JHMIN
        IHMAX=JHMAX
        IKMIN=JKMIN
        IKMAX=JKMAX
        ILMIN=JLMIN
        ILMAX=JLMAX
        I=IO1
        IO1=IO2
        IO2=I
      END IF
      REWIND IO1
      CLOSE(UNIT=IO2,STATUS='DELETE')
      OPEN (UNIT=IO2,STATUS='NEW',FILE=FILE2,FORM='FORMATTED')
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=68)
      OPEN (UNIT=IO4,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=40)
      OPEN (UNIT=IO5,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=40)
C
C LOOP THROUGH SORTED DATA FILE.
C
      NINDEP=0
      NTOTAL=0
      NMEAS1=0
      NMEAS2=0
      NMEAS3=0
      SUMQ=0
      NREJ=0
      NBAD=0
      NBAD2=0
      NBAD3=0
 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,U0,U1
        IF (JPATH.NE.0) THEN
          PATH(1,I)=TBAR
          DO J=1,3
            PATH(1+J,I)=U0(J)
            PATH(4+J,I)=U1(J)
          END DO
        END IF
      END DO
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 U0 AND U1 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
          U0(J)=0
          U1(J)=0
        END DO
        DO I=1,NMEAS
          TBAR=TBAR+PATH(1,I)
          DO J=1,3
            U0(J)=U0(J)+PATH(1+J,I)
            U1(J)=U1(J)+PATH(4+J,I)
          END DO
        END DO
        TBAR=TBAR/NMEAS
        DO J=1,3
          U0(J)=U0(J)/NMEAS
          U1(J)=U1(J)/NMEAS
        END DO
      END IF
C
C COUNT MEASUREMENTS.
C
      NTOTAL=NTOTAL+NMEAS
      NINDEP=NINDEP+1
C
C DISCOUNT REJECTED MEASUREMENTS.
C
      N=0
      DO I=1,NMEAS
        IF (WI(I).LE.0) N=N+1
      END DO
      IF (N.GT.0) THEN
        NBAD=NBAD+1
      END IF
      N=NMEAS-N
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,JPATH,NH,NK,NL,YMEAN,ESD,ESD,RMSD,N,TBAR,U0,U1)
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 DATA AND AGREEMENT STATISTICS.
C
      SUMQ=SUMQ+YMEAN/MAX(ESD,RMSD)
      S=SINTHL(NH,NK,NL,GINV)
      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
                NBAD3=NBAD3+1
                WRITE (IO4,REC=NBAD3) (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 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
            TBARJ=PATH(1,J)
            DO K=1,3
              U0J(K)=PATH(1+K,J)
              U1J(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,
     &      TBARJ,U0J,U1J
          END IF
          NLINE=NLINE+1
          IF (MOD(NLINE,50).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,U0,U1
        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,U0,U1
        END IF
      END IF
      NLINE=NLINE+1
      IF (MOD(NLINE,50).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
      DEALLOCATE (INDEX)
C
C WRITE FILE OF REJECTED MEASUREMENTS SORTED ON Z = (Y - YMEAN)/ESD.
C
      IF (NREJ.GT.0) THEN
        ALLOCATE (DATA(NREJ),INDEX(NREJ))
        DO I=1,NREJ
          READ (IO5,REC=I) ZI
          DATA(I)=ABS(ZI)
        END DO
        CALL SORT (NREJ,DATA,INDEX)
        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=INDEX(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')
        DEALLOCATE (DATA,INDEX)
      END IF
      CLOSE (UNIT=IO5,STATUS='DELETE')
 610  FORMAT (/1X,
     &'      JJ  JH  JK  JL JSCALE         YJ   SIGMA(YJ) NMEAS ESD (Y',
     &'J - YMEAN)/ESD'/1X,
     &'      --  --  --  -- ------         --   --------- ----- --- --',
     &'--------------')
 611  FORMAT (1X,I8,3I4,I6,2F12.2,I6,F12.2,F8.1)
C
C WRITE SORTED FILE OF DISCORDANT DUPLICATE MEASUREMENTS.
C
      IF (NBAD2.GT.0) THEN
        ALLOCATE (DATA(NBAD2),INDEX(NBAD2))
        DO I=1,NBAD2
          READ (IO3,REC=I) ZI
          DATA(I)=ABS(ZI)
        END DO
        CALL SORT (NBAD2,DATA,INDEX)
        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=INDEX(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')
        DEALLOCATE (DATA,INDEX)
      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 (NBAD3.GT.0) THEN
        ALLOCATE (DATA(NBAD3),INDEX(NBAD3))
        DO I=1,NBAD3
          READ (IO4,REC=I) ZI
          DATA(I)=ABS(ZI)
        END DO
        CALL SORT (NBAD3,DATA,INDEX)
        OPEN (UNIT=IO2,STATUS='NEW',FILE='outlier.dat')
        WRITE (IO2,600) ATIME,ADATE,TITLE
        WRITE (IO2,610)
        DO I=NBAD3,1,-1
          READ (IO4,REC=INDEX(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')
        DEALLOCATE (DATA,INDEX)
      END IF
      CLOSE (UNIT=IO4,STATUS='DELETE')
C
C PRINT DATA MERGING AND DISTRIBUTION STATISTICS.
C
      WRITE (ILP,600) ATIME,ADATE,TITLE
 600  FORMAT (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/YMERGE.  ',A,', ',A,'.  ',A)
C
C NUMBERS OF MEASUREMENTS
C
      WRITE (ILP,'(/1X,
     &''NTOTAL = '',I10,''  TOTAL MEASUREMENTS'')') NTOTAL
      IF (NREJ.GT.0) WRITE (ILP,'(/1X,
     &''NREJ   = '',I10,''  MEASUREMENTS REJECTED AS ABNORMAL OULIERS''
     &/1X,
     &''NACC   = '',I10,''  MEASUREMENTS ACCEPTED'')') NREJ,NTOTAL-NREJ
      IF (IPTGP.EQ.IXTAL) PTGP='XTAL'
      IF (IPTGP.EQ.ILAUE) PTGP='LAUE'
      WRITE (ILP,'(/1X,A4,
     &'' POINT GROUP FOR EQUIVALENT REFLECTIONS FOR DATA AVERAGING''/1X,
     &''----'')') PTGP
      WRITE (ILP,'(/1X,
     &''NMEAS1 = '',I10,''  UNIQUE DATA MEASURED ONLY ONCE''/1X,
     &''NMEAS2 = '',I10,''  UNIQUE DATA MEASURED TWICE''/1X,
     &''NMEAS3 = '',I10,''  UNIQUE DATA MEASURED THREE OR MORE TIMES''
     &//1X,
     &''NINDEP = '',I10,''  UNIQUE DATA''//1X,
     &''<N>    = '',F10.1,''  OVERALL AVERAGE MEASUREMENT MULTIPLICITY''
     &//1X,
     &''<Q>    = '',E10.3,''  OVERALL AVERAGE SIGNAL-TO-NOISE RATIO, '',
     &''<Q> = <YMEAN/MAX(ESD, RMSD)>'')')
     & NMEAS1,NMEAS2,NMEAS3,NINDEP,FLOAT(NTOTAL-NREJ)/NINDEP,SUMQ/NINDEP
      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,C4
      WRITE (ILP,622) IW,JW,ZZMAX
 624  FORMAT (//1X,
     &'ABNORMALLY LOW OUTLIERS REJECTED IF'/1X,
     &'  Y .LT. YMAX - 2*R*SQRT((Q*SIGMA(YMAX))**2 + (P*YMAX)**2)'/1X,
     &'WHERE'/1X,'  P = ',F5.3/1X,'  Q = ',F5.3/1X,'  R = ',F5.3)
 625  FORMAT (//1X,
     &'ABNORMAL OUTLIERS FROM MEDIAN(Y) REJECTED IF'/1X,
     &'  ABS(Y - MEDIAN(Y)) .GT. T,'/1X,
     &'WHERE'/1X,
     &'  T = MAX(C1*MEDIAN(Y),'/1X,
     &'            C2*MEDIAN(SIGMA(Y)),'/1X,
     &'              C3*1.25*MEDIAN(ABS(Y - MEDIAN(Y)))*SQRT(N/(N - 1)',
     &'),'/1X,
     &'                C4*ZCRIT(N)*MAX(MEDIAN(SIGMA(Y)),'/1X,
     &'                     1.25*MEDIAN(ABS(Y - MEDIAN(Y)))*SQRT(N/(N ',
     &'- 1)))),'/1X,
     &'  C1 = ',F5.2,', C2 = ',F5.2,'   C3 = ',F5.2,', C4 = ',F5.2,'.')
 622  FORMAT (//1X,
     &'AVERAGED DATA:'/1X,
     &'  YMEAN = SUM(W*Y)/SUM(W)'/1X,
     &'  ESD   = SQRT(SUM(W*SIGMA(Y)**2)/SUM(W))'/1X,
     &'  RMSD  = SQRT((SUM(W*(Y - YMEAN)**2)/SUM(W))*N/(N - 1))'//1X,
     &'WEIGHTS 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(MEDIAN(SIGMA(Y)), 1.25*MEDIAN(ABS(Y -',
     &' MEDIAN(Y)))*SQRT(N/(N - 1)))'/1X,
     &'  IF IW = 1,  SIGMA = SIGMA(Y)'//1X,
     &'  IW   = ',I2/1X,'  ---------'/1X,
     &'  JW   = ',I2/1X,'  ---------'/1X,
     &'  ZMAX = ',F4.1/1X,'  -----------')
C
C OUTLIER MEASUREMENTS
C
      IF (NBAD.GT.0) WRITE (ILP,6001) NREJ,NBAD2/2,NBAD3,NBAD,QLIMIT,
     & ZLIMIT
 6001 FORMAT (//1X,
     &'NREJ  = ',I6,' MEASUREMENTS REJECTED OR ZERO-WEIGHTED BEFORE AV',
     &'ERAGING'/1X,
     &'NBAD2 = ',I6,' PAIRS OF DISCORDANT DUPLICATE MEASUREMENTS'/1X,
     &'NBAD3 = ',I6,' STATISTICAL OUTLIER MEASUREMENTS IN SAMPLES WITH',
     &' THREE OR MORE MEASUREMENTS'/1X,
     &'NBAD  = ',I6,' MEANS WITH REJECTED, DISCORDANT DUPLICATE, OR ST',
     &'ATISTICAL OUTLIER MEASUREMENTS:'//1X,
     &'DISCORDANT MEASUREMENT SAMPLES ARE DEFINED AS THOSE WITH'/1X,
     &'  RMSD/ESD .GT.           QLIMIT'/1X,
     &'AND ONE OR MORE MEASUREMENTS WITH'/1X,
     &'  ABS(Y - YMEAN)/ESD .GT. ZLIMIT.'//1X,
     &'  QLIMIT = ',F5.2/1X,
     &'  ZLIMIT = ',F5.2//1X,
     &'REJECTED MEASUREMENTS ARE LISTED IN A "reject.dat" OUTPUT FILE.'/
     &/1X,
     &'DISCORDANT DUPLICATE MEASUREMENTS ARE LISTED IN A "twobad.dat" ',
     &'OUTPUT FILE.'//1X,
     &'STATISTICAL OUTLIERS IN SAMPLES OF THREE OR MORE MEASUREMENTS A',
     &'RE LISTED IN'/1X,
     &'AN "outlier.dat" OUTPUT FILE.'//1X,
     &'REJECTED, DISCORDANT DUPLICATE, AND STATISTICAL OUTLIER MEASURE',
     &'MENTS ARE'/1X,
     &'MARKED WITH AN ASTERISK IN THE PRINTED LIST OF EQUIVALENT MEASU',
     &'REMENTS.')
C
C DATA MERGING STATISTICS
C
      DO I=1,M4
        IF (R1DEN(I).GT.0) R1(I)=R1NUM(I)/R1DEN(I)
        IF (R2DEN(I).GT.0) R2(I)=SQRT(R2NUM(I)/R2DEN(I))
        IF (RWDEN(I).GT.0) RW(I)=SQRT(RWNUM(I)/RWDEN(I))
        IF (ZDEN(I).GT.0.AND.NTERM(I)-NMEAN(I).GT.0)
     &   Z(I)=SQRT((ZNUM(I)/ZDEN(I))*NTERM(I)/(NTERM(I)-NMEAN(I)))
        IF (VDEN(I).NE.0) V(I)=VNUM(I)/VDEN(I)
        IF (R1DEN(I).LE.0) R1(I)=0
        IF (R2DEN(I).LE.0) R2(I)=0
        IF (RWDEN(I).LE.0) RW(I)=0
        IF (ZDEN(I).LE.0.OR.NTERM(I)-NMEAN(I).LE.0) Z(I)=0
        IF (VDEN(I).EQ.0) V(I)=0
      END DO
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,'(/1X,
     &''DATA MERGING STATISTICS (ADJUSTED FOR MEASUREMENT MULTIPLICIT'',
     &''Y):''/1X,
     &''-------------------------------------------------------------'',
     &''---''/1X,
     &''  NORMALIZED MEAN ABSOLUTE DEVIATION''/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 DEVIATION''/1X,
     &''    RW = SQRT{<[N/(N - 1)]*[(Y - YMEAN)/SIGMA(Y)]**2>/<[Y/SIG'',
     &''MA(Y)]**2>}''/1X,
     &''       = SQRT{SUM(H) [N/(N - 1)]*SUM(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 COEFFICIEN'',
     &''T 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,
     &''  INTENSITY SIGNIFICANCE    Q = YMEAN/MAX(ESD, RMSD)''/1X,
     &''  DIFFRACTION RESOLUTION    D = 1/(2*S)  (ANGSTROM),    S = S'',
     &''IN(THETA)/LAMBDA  (ANGSTROM**-1)'')')
      WRITE (ILP,'(/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 FOLLO'',
     &''WING 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)')
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=1,14)
      WRITE (ILP,'(/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)')
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=15,16)
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,'(/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)')
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=17,33)
      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,'(/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)')
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=34,48)
      WRITE (ILP,'(/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)')
     & (NTERM(I),NMEAN(I),FLOAT(NTERM(I))/MAX(1,NMEAN(I)),
     & R1(I),R2(I),RW(I),Z(I),V(I),I=49,63)
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,'(/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)') 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)
      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
C
C SIGMA(YMEAN) VALUES FROM SIGMA(Y) VALUES
C
      CALL SIGMEAN
      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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,NMAX
      CHARACTER ATIME*8,ADATE*9,TITLE*80,FILE1(10)*80,FILE2*80,PTGP*4
      COMMON /BLOCK1/ ATIME,ADATE,TITLE,FILE1,FILE2
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCKS/ NSCALE,KSCALE,IFIXED,QMIN,ZMAX
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,IPRINT,JPRINT,JPATH,QLIMIT,ZLIMIT,QPRINT
      DIMENSION ANGLES(4),S0(3),S1(3)
C
C FORTRAN-90 STORAGE ALLOCATION
C
      REAL,    ALLOCATABLE::SCALEK(:)
      INTEGER, ALLOCATABLE::NDATA(:,:)
      REAL,    ALLOCATABLE::YI(:),SIGYI(:)
      INTEGER, ALLOCATABLE::ISCALE(:)
      REAL,    ALLOCATABLE::WW(:)
      REAL*8,  ALLOCATABLE::WK(:),WY(:),DYDK(:),AA(:,:),BB(:)
      REAL,    ALLOCATABLE::DELTAJ(:),SIGMAJ(:),SIGMAK(:)
      REAL,    ALLOCATABLE::XDATA(:),YDATA(:),YPP(:)
      REAL*8,  ALLOCATABLE::CHISQI(:),SUMSQI(:)
      INTEGER, ALLOCATABLE::NDATAI(:)
C
C INITIALIZE SCALE FACTORS.
C
      IF (NSCALE.EQ.1) RETURN
      ALLOCATE (SCALEK(NSCALE))
      IF (KSCALE.GT.1) THEN
C
C READ INPUT SCALE FACTORS.
C
        REWIND KSCALE
        DO I=1,NSCALE
          READ (KSCALE) J,SCALEK(J)
        END DO
        CLOSE (UNIT=KSCALE,STATUS='DELETE')
      ELSE
C
C INITIALIZE TO UNIT SCALE FACTORS.
C
        DO I=1,NSCALE
          SCALEK(I)=1
        END DO
      END IF
C
C ZERO SUBSET DATA POPULATION MATRIX.
C
      ALLOCATE (NDATA(NSCALE,NSCALE))
      DO I=1,NSCALE
      DO J=1,NSCALE
        NDATA(I,J)=0
      END DO
      END DO
C
C DATA EQUIVALENT UNDER (CENTROSYMMETRIC) LAUE POINT GROUP SYMMTERY ON
C UNIT IO1, OR (NONCENTROSYMMETRIC) CRYSTAL CLASS POINT GROUP SYMMETRY
C ON UNIT IO2?
C
      IF (IPTGPS.EQ.IXTAL) IUNIT=IO2
      IF (IPTGPS.EQ.ILAUE) IUNIT=IO1
C
C COUNT DATA.
C
      M=0
      N=0
      REWIND IUNIT
      DO I=1,1E9
        READ (IUNIT,END=5) NI
        DO J=1,NI
          READ (IUNIT)
        END DO
        M=MAX(M,NI)
        N=N+NI
      END DO
 5    CONTINUE
      ALLOCATE (YI(M),SIGYI(M),ISCALE(M))
      ALLOCATE (WW(N))
C
C WRITE A WORKING FILE OF DATA WITH MULTIPLE SIGNIFICANT MEASUREMENTS
C AND MULTIPLE SCALE FACTORS.
C
      OPEN (UNIT=IO3,STATUS='SCRATCH',FORM='UNFORMATTED')
      REWIND IUNIT
      II=0
      NH=0
      NHI=0
 1    READ (IUNIT,END=9) N
C
C OMIT SINGLE MEASUREMENTS.
C
      IF (N.EQ.1) THEN
        READ (IUNIT)
        GO TO 1
      END IF
C
C OMIT WEAK DATA.
C
      I=0
      DO J=1,N
        READ (IUNIT) 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 (IO3) N
      DO I=1,N
        WRITE (IO3) YI(I),SIGYI(I),ISCALE(I)
C
C INITIALIZE AND STORE 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 IO3
      NI=NSCALE
      NFREE=NHI-NH-(NI-1)
C
C PRINT SUBSET POPULATION MATRIX.
C
      WRITE (ILP,600) ATIME,ADATE,TITLE
 600  FORMAT (/1H1,130('-')/1X,
     &'PROGRAM SORTAV/YSCALE.  ',A,', ',A,'.  ',A)
      IF (IUNIT.EQ.IO1) PTGP='LAUE'
      IF (IUNIT.EQ.IO2) PTGP='XTAL'
      WRITE (ILP,'(/1X,
     &A4,'' POINT GROUP FOR EQUIVALENT REFLECTIONS FOR SCALE FACTORS '',
     &''FITTING''/1X,
     &''----'')') PTGP
      WRITE (ILP,'(/1X,
     &''SUBSET POPULATION MATRIX NDATA(ISCALE,JSCALE) FOR INTER-SUBSE'',
     &''T 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,100(20I5/7X))') I,(NDATA(I,J),J=1,I)
      END DO
      WRITE (ILP,'(/1X,
     &''REFLECTIONS WITH Y/SIGMA(Y) .LT. QMIN, WHERE''/1X,
     &''    QMIN = '',F5.2,'',''/1X,
     &''    ------------''/1X,
     &''ARE OMITTED FROM NDATA(ISCALE,JSCALE) AND FROM THE INTER-SUBS'',
     &''ET SCALING.'')') QMIN
      WRITE (ILP,'(//1X,
     &''BEFORE THE FIRST CYCLE:''/1X,
     &''NSCALE    = '',I8,'' = NI''/1X,
     &''NUNIQUE   = '',I8,'' = NH''/1X,
     &''NMULTIPLE = '',I8,'' = NHI = SUM(I) NDATA(I,I)''/1X,
     &''NFREE     = '',I8,'' = NHI - NH - (NI - 1)'')') NI,NH,NHI,NFREE
C
C TEST FOR A USER-SELECTED FIXED SCALE FACTOR.
C
      IF (IFIXED.LE.0) THEN
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
      END IF
      DEALLOCATE (NDATA)
C
C NORMALIZE ALL SCALE FACTORS TO THE FIXED SCALE FACTOR.
C
      DO I=1,NSCALE      
        SCALEK(I)=SCALEK(I)/SCALEK(IFIXED)
      END DO
      ALLOCATE (SIGMAK(NSCALE))
C
C ITERATE LEAST-SQUARES CYCLES UNTIL SHIFTS ARE SATISFACTORILY SMALL.
C
      NPAR=NSCALE-1
      N=NPAR
      ALLOCATE (WK(N),WY(N),DYDK(N),AA(N,N),BB(N),DELTAJ(N),SIGMAJ(N))
      WRITE (ILP,600) ATIME,ADATE,TITLE
      write (6,'(/1x,a/1x,
     &''    time      date ncycle nzero           Z              R''/1x,
     &''    ----      ---- ------ -----           -              -'')')
     & title
      call vtime (ztime)
      call vdate (zdate)
      write (6,'(1x,a,1x,a,i4)') ztime,zdate,0
      Z=1E10
      R=1E10
      NZERO=0
      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
      CHISQ=0
      SUMSQ=0
      ZMAXZ=ZMAX*MAX(Z,1.0)
C
C LOOP THROUGH WORKING DATA FILE TO BUILD NORMAL MATRIX AND VECTOR.
C
      II=0
      REWIND IO3
 10   READ (IO3,END=19) N
      DO I=1,N
        READ (IO3) YI(I),SIGYI(I),ISCALE(I)
      END DO
C
C ELIMINATE SAMPLES EXHAUSTED BY ZERO-WEIGHTING IN THE PRECEDING CYCLE.
C
      J=0
      K=0
      DO I=1,N
        II=II+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
        II=II-N
        DO I=1,N
          II=II+1
          IF (WW(II).NE.0) THEN
            WW(II)=0
            NHI=NHI-1
            NZERO=NZERO+1
          END IF
        END DO
        NH=NH-1
        GO TO 10
      END IF
C
C EVALUATE AVERAGE SCALED DATA 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) GO TO 50
        Y=YI(I)
        SCALE=SCALEK(ISCALE(I))
        DELY=Y-YMEAN/SCALE
        SIGY=SIGYI(I)
        IF (ABS(DELY)/SIGY.GT.ZMAXZ) THEN
C
C GIVE ZERO WEIGHT TO EXTREME OUTLIERS.
C
          WW(II)=0
          NHI=NHI-1
          NZERO=NZERO+1
          GO TO 50
        ELSE
C
C EVALUATE AND STORE WEIGHTS.
C
          WW(II)=1/(SIGY**2+(PP*YMEAN/SCALE)**2)
        END IF
        W=WW(II)
        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,NPAR,AA,DET)
      IF (DET.EQ.0) GO TO 99
C
C CALCULATE NORMALIZED AND STANDARDIZED ROOT-MEAN-SQUARE ERRORS OF FIT.
C
      NFREE=NHI-NH-(NI-1)
      T=R
      R=SQRT(CHISQ/SUMSQ)
      Z=SQRT(CHISQ/NFREE)
      call vtime (ztime)
      call vdate (zdate)
      write (6,'(1x,a,1x,a,i4,i6,2e15.7)') ztime,zdate,ncycle,nzero,z,r
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 NORMALIZED ROOT-MEAN-SQUARE ERROR OF FIT AND AVERAGE SHIFT-TO-
C ERROR RATIO.
C
        IF ((T-R)/R.LT.1E-3.OR.DAVG.LT.1E-2) 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
 609  FORMAT (/1X,
     &'FIT FAILED TO CONVERGE AFTER ',I2,' CYCLES.'//1X,
     &'SHIFTS IN FINAL CYCLE:'/1X,
     &'----------------------'/1X,
     &'(J = MOD((ISCALE - IFIXED + NSCALE), NSCALE), IFIXED = ',I4,
     &', NSCALE = ',I4,')'/1X,
     &'   J   DELTAK(J)'/1X,
     &'   -   ---------'/(1X,I4,F12.5))
 608  FORMAT (/1X,
     &'FIT CONVERGED OR DIVERGING:'//1X,
     &'NCYCLE        = ',I15/1X,
     &'R(NCYCLE)     = ',E15.7/1X,
     &'R(NCYCLE - 1) = ',E15.7)
 99   CONTINUE
      DEALLOCATE (WK,WY,DYDK,BB,DELTAJ,SIGMAJ)
C
C PRINT SCALE FACTORS AND STATISTICS OF FIT.
C
      WRITE (ILP,601) (I,SCALEK(I),SIGMAK(I),I=1,NSCALE)
      WRITE (ILP,602) Z,R,NCYCLE,NZERO,NI,NH,NHI,NFREE
      WRITE (ILP,603) (T-R)/R,DAVG,DMAX,NZERO,ZMAX
 601  FORMAT (/1X,
     &'FITTED RELATIVE SCALE FACTORS FOR SUBSETS OF THE DATA SET:'/1X,
     &'----------------------------------------------------------'/1X,
     &'   I   SCALEK(I)   SIGMAK(I)'/1X,
     &'   -   ---------   ---------'/(1X,I4,2F12.5))
 602  FORMAT (/1X,
     &'STATISTICS OF FIT:'/1X,
     &'------------------'/1X,
     &'CHISQ = SUM(H) SUM(I) WHI*(YHI - YH/KI)**2'/1X,
     &'WHI   = 1/SIGMA(YHI)**2'/1X,
     &'STANDARDIZED ROOT-MEAN-SQUARE ERROR-OF-FIT    Z  = SQRT(CHISQ/N',
     &'FREE)'/1X,
     &'NORMALIZED ROOT-MEAN-SQUARE ERROR-OF-FIT      R  = SQRT[CHISQ/S',
     &'UM(H) SUM(I) WHI*YHI**2]'//1X,
     &'Z = ',E11.4/1X,
     &'R = ',E11.4//1X,
     &'NCYCLES   = ',I8,' CYCLES'/1X,
     &'NZERO     = ',I8,' ZERO-WEIGHTED DATA IN THE FINAL CYCLE'/1X,
     &'NSCALE    = ',I8,' = NI'/1X,
     &'NUNIQUE   = ',I8,' = NH'/1X,
     &'NMULTIPLE = ',I8,' = NHI'/1X,
     &'NFREE     = ',I8,' = NHI - NH - (NI - 1)')
 603  FORMAT (/1X,
     &'CONVERGENCE TEST:  [R(N-1) - R(N)]/R(N) .LT. 1E-3  OR  <ABS[DEL',
     &'TAK(I)]/SIGMAK(I)> .LT. 1E-2'//1X,
     &'[R(N-1) - R(N)]/R(N) = ',E10.3//1X,
     &'FINAL CYCLE AVERAGE AND MAXIMUM ABS(DELTAK(I))/SIGMAK(I):'//1X,
     &'AVERAGE = ',E10.3/1X,'MAXIMUM = ',E10.3//1X,'NZERO = ',I10,' OU',
     &'TLIERS WITH ABS(YHI - YH/KI)/SIGMA(YHI) .GT. ZMAX*MAX(Z, 1.0) F',
     &'OR'/1X,
     &'ZMAX  = ',F10.2,' WERE GIVEN ZERO WEIGHT IN THE FINAL CYCLE.')
      IF (DET.EQ.0)
     & STOP ' SORTAV/YSCALE:  SINGULAR NORMAL MATRIX FOR SCALE FACTORS'
C
C PRINT CORRELATION MATRIX.
C
      WRITE (ILP,600) ATIME,ADATE,TITLE
      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
 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((JSCALE - 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,100(20I5/7X))
      IF (NPAR.GE.2) THEN
C
C EVALUATE MEAN CORRELATION COEFFICIENT AND MEAN-SQUARE FRACTIONAL
C ERROR.
C
        IF (RIJ.NE.0.AND.SISJ.NE.0) THEN
C
C STORE USER-INPUT VALUES.
C
          TRIJ=RIJ
          TSISJ=SISJ
        ELSE
          TRIJ=0
          TSISJ=0
        END IF
        RIJ=0
        SISJ=0
        DO I=1,NPAR-1
        DO J=I+1,NPAR
          RIJ=RIJ+AA(I,J)/SQRT(AA(I,I)*AA(J,J))
          SISJ=SISJ+SIGMAK(I)*SIGMAK(J)/(SCALEK(I)*SCALEK(J))
        END DO
        END DO
        RIJ=RIJ/(0.5*NPAR*(NPAR-1))
        SISJ=SISJ/(0.5*NPAR*(NPAR-1))
        WRITE (ILP,662) RIJ,SISJ
C
C RESET SMALL EMPIRICAL VALUES TO DEFAULT-MINIMUM VALUES.
C
        IF (RIJ.LT.0.25) RIJ=0.25
        IF (SISJ.LT.0.005*0.005) SISJ=0.005*0.005
C
C RESET TO USER-INPUT VALUES.
C
        IF (TRIJ.NE.0.AND.TSISJ.NE.0) THEN
          RIJ=TRIJ
          SISJ=TSISJ
        END IF
      END IF
 662  FORMAT (//1X,
     &'EMPIRICAL VALUES FOR CALCULATING SIGMA(<Y>) FROM <SIGMA(Y)**2>*',
     &'*(1/2):'/1X,
     &'---------------------------------------------------------------',
     &'-------'//1X,
     &'                 {<SIGMA(Y)**2>                                }'
     &/1X,
     &'SIGMA(<Y>) = SQRT{------------- *[1 + (NMEAS - 1)*<RHO(YI,YJ)>]}'
     &/1X,
     &'                 {   NMEAS                                     }'
     &//1X,
     &'WHERE'//1X,
     &'                        SIGMA(KI) SIGMA(KJ)    YI        YJ'
     &/1X,
     &'RHO(YI,YJ) = RHO(KI,KJ)*---------*---------*---------*---------'
     &/1X,
     &'                           KI        KJ     SIGMA(YI) SIGMA(YJ)'
     &//1X,
     &'AVERAGE  RHO(KI,KJ)                  = ',E10.3/1X,
     &'AVERAGE  SIGMA(KI)*SIGMA(KJ)/(KI*KJ) = ',E10.3)
      DEALLOCATE (AA)
C
C PLOT SCALE FACTORS.
C
      IF (NSCALE.GE.10) THEN
        ALLOCATE (XDATA(NSCALE),YDATA(NSCALE),YPP(NSCALE))
        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)
        O=0.5*(YMIN+YMAX)
        H=0.5*(YMAX-YMIN)
        H=1.2*H
        YMIN=O-H
        YMAX=O+H
        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)
        DEALLOCATE (XDATA,YDATA,YPP)
      END IF
 620  FORMAT (/1H1,130('-')/1X,10X,
     &'PROGRAM SORTAV/YSCALE.  ',A,', ',A,'.  ',A/)
 621  FORMAT (/1X,10X,
     &'SUBSET SCALE FACTOR (VERTICAL) VERSUS SUBSET SERIAL NUMBER (HOR',
     &'IZONTAL).')
C
C COMPILE AND PRINT SUBSET-BY-SUBSET STATISTICS OF FIT.
C
      ALLOCATE (CHISQI(NSCALE),SUMSQI(NSCALE),NDATAI(NSCALE))
      DO I=1,NSCALE
        CHISQI(I)=0
        SUMSQI(I)=0
        NDATAI(I)=0
      END DO
      II=0
      REWIND IO3
 70   READ (IO3,END=79) N
      DO I=1,N
        READ (IO3) YI(I),SIGYI(I),ISCALE(I)
      END DO
C
C EVALUATE AVERAGE SCALED DATA VALUE.
C
      SUMW=0
      SUMY=0
      DO I=1,N
C
C USE WEIGHTS FROM THE FINAL 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
      END DO
      IF (SUMW.EQ.0) GO TO 70
      YMEAN=SUMY/SUMW
C
C ACCUMULATE STATISTICS OF FIT.
C
      II=II-N
      DO I=1,N
        II=II+1
        W=WW(II)
        IF (W.GT.0) THEN
          Y=YI(I)
          SCALE=SCALEK(ISCALE(I))
          DELY=Y-YMEAN/SCALE
C
C ACCUMULATE SUBSET STATISTICS.
C
          CHISQI(ISCALE(I))=CHISQI(ISCALE(I))+W*DELY**2
          SUMSQI(ISCALE(I))=SUMSQI(ISCALE(I))+W*Y**2
          NDATAI(ISCALE(I))=NDATAI(ISCALE(I))+1
        END IF
      END DO
      GO TO 70
 79   CONTINUE
      WRITE (ILP,600) ATIME,ADATE,TITLE
      WRITE (ILP,670)
      F=FLOAT(NFREE)/NHI
      DO I=1,NSCALE
        R=0
        Z=0
        IF (SUMSQI(I).GT.0) R=SQRT(CHISQI(I)/SUMSQI(I))
        IF (NDATAI(I).GT.0) Z=SQRT(CHISQI(I)/(F*NDATAI(I)))
        WRITE (ILP,671) I,SCALEK(I),SIGMAK(I),R,Z,NDATAI(I)
      END DO
 670  FORMAT (/1X,
     &'SUBSET-BY-SUBSET STATISTICS OF FIT:'/1X,
     &'-----------------------------------'/1X,
     &'   I   SCALEK(I)   SIGMAK(I)        R(I)        Z(I)    NDATA(I',
     &')'/1X,
     &'   -   ---------   ---------        ----        ----    -------',
     &'-')
 671  FORMAT (1X,I4,2F12.5,F12.4,F12.3,I12)
      DEALLOCATE (WW,YI,SIGYI,ISCALE,CHISQI,SUMSQI,NDATAI)
C
C SCALE THE DATA SET(S).
C
C UNIT IO1  (CENTROSYMMETRIC) LAUE POINT GROUP UNIQUE DATA
C UNIT IO2  (NONCENTROSYMMETRIC) CRYSTAL CLASS POINT GROUP UNIQUE DATA
C
      REWIND IO1
      REWIND IO2
      REWIND IO3
      IUNIT=IO1
 81   READ (IUNIT,END=89) NMEAS,JH,JK,JL
      WRITE (IO3)         NMEAS,JH,JK,JL
      DO I=1,NMEAS
        READ (IUNIT) JJ,JH,JK,JL,Y,SIGY,JSCALE,ANGLES,TBAR,S0,S1
        SIGY=SQRT((SCALEK(JSCALE)*SIGY)**2+(Y*SIGMAK(JSCALE))**2)
        Y=SCALEK(JSCALE)*Y
        WRITE (IO3)  JJ,JH,JK,JL,Y,SIGY,JSCALE,ANGLES,TBAR,S0,S1
      END DO
      GO TO 81
 89   ENDFILE IO3
      IF (IUNIT.EQ.IO1) THEN
        I=IO1
        IO1=IO3
        IO3=I
        REWIND IO3
        IUNIT=IO2
        GO TO 81
      END IF
      IF (IUNIT.EQ.IO2) THEN
        I=IO2
        IO2=IO3
        IO3=I
      END IF
      CLOSE (UNIT=IO3,STATUS='DELETE')
      DEALLOCATE (SCALEK,SIGMAK)
      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
      COMMON /BLOCK0/ IO1,IO2,IO3,IO4,IO5,ILP,NMAX
      COMMON /BLOCK2/ NFILE,PP,NCOND,ICOND(38),IXTAL,ILAUE,IPTGP,
     & G(3,3),GINV(3,3),VCELL,IPTGPS,IPTGPA,IPTGPM,IORIENT,UB(3,3)
      COMMON /BLOCKM/ IW,JW,ZZMAX,QQ,RR,C1,C2,C3,C4,
     & RIJ,SISJ,IPRINT,JPRINT,JPATH,QLIMIT,ZLIMIT,QPRINT
      DIMENSION U0(3),U1(3)
      DATA TBAR,U0,U1 /7*0/
C
C FORTRAN-90 DYNAMIC MEMORY ALLOCATION
C
      REAL,    ALLOCATABLE::DATA(:)
      INTEGER, ALLOCATABLE::INDEX(:)
C
C READ DATA INTO SCRATCH FILE FOR SORTING.
C
      OPEN (UNIT=IO4,STATUS='SCRATCH',FORM='UNFORMATTED',
     & ACCESS='DIRECT',RECL=20)
      REWIND IO1
      IEND=0
      N=0
 1    CALL READ2 (IO1,JPATH,IEND,IH,IK,IL,Y,SIGY,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
      GO TO 1
 9    CONTINUE
      ALLOCATE (DATA(N),INDEX(N))
      DO I=1,N
        READ (IO4,REC=I) S,Y
        DATA(I)=Y
      END DO
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')
      DEALLOCATE (DATA,INDEX)
      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 ABS(Z) = ABS(DELTA)/SIGMA CORRESPONDING TO A
C NORMAL PROBABILITY P = 1/(2*NDATA) THAT ABS(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
      RETURN
      END
C-----------------------------------------------------------------------