                         SUBROUTINE AVERA3
     &      (IO,NMAX,IHKL,LT,F,SF,TBAR,ST,NUMOR,ICV)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C +                                                                    +
C + SUBROUTINE SORTS THE HKL-CARDS WRITTEN ON A FILE BY THE SUBROUTINE +
C + AVERA2 FOR INCREASING VALUES OF SIN(THETA)/LAMBDA                  +
C + WRITTEN BY EGBERT PERENTHALER MPI-FKF (DEZEMBER 1980)              +
C +                                                                    +
C + THIS PROGRAMME IS CALLED BY THE SUBROUTINE AVERAG                  +
C +                                                                    +
C + THIS PROGRAMME CALLS THE SUBROUTINES  REZREA, UMKEHR, QSORTI,      +
C + IPACK, AND DEPAK                                                   +
C +                                                                    +
C + IN CASE OF AN OVERLAY STRUCTURE IT IS THE MAIN PROGRAMME OF THE    +
C + OVERLAY  AVER3                                                     +
C +                                                                    +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C---- TYPE STATEMENTS
C     ---------------
C
      INTEGER H,SC
C
C---- DIMENSION STATEMENTS
C     --------------------
C
C    - RECELL
C    - IH
C
      DIMENSION RECELL(6),IH(3)
      DIMENSION IHKL(NMAX),LT(NMAX),F(NMAX),SF(NMAX),TBAR(NMAX),ST(NMAX)
     &,NUMOR(NMAX)
C
C---- COMMON DECLARATIONS
C     -------------------
C
      COMMON /CONT/LABEL(2),IOUNIT,TITEL(18),IKART,ISYS,ISST,MODU,IREJEC
     &,NOR,NULL,IABSO,IPSO,ILIST,SYSDEV,REJE,MU,SIGLT,OFLOW,ISOR,CELL(6)
C
      COMMON /BD/ ICHAR(18),IRMT(21)
C
C---- PRINT THAT DATA ARE SORTED
C
      WRITE (IO,15)
   15 FORMAT(5(/),1X,46HDATA AVERAGED FOR INCREASING SIN(THETA)/LAMBDA/
     &1X,46(1H-)/1H0)
C
C---- CALCULATING THE RECIPROCEL CELL
C
      CALL REZREA (CELL,RECELL)
C
C---- INITIALISE (IN A LATER VERSION THIS VALUE WILL BE TRANSMITTED FROM
C----             SUBROUTINE AVERA2)
      ITBAR = 1
C
C---- REWIND DATA FILE
      REWIND IOUNIT
C
C---- READ IN THE WHOLE DATA-FILE
C
      IF (ITBAR .EQ. 1) GO TO 121
      DO 01 I = 1,NMAX
      READ (IOUNIT,10,END=05)H,K,L,LT(I),SC,F(I),SF(I)
   10 FORMAT (13X,3I3,3X,2I3,F9.0,9X,F5.0)
   01 IHKL(I) = IPACK (H,K,L)
      GO TO 05
  121 DO 03 I = 1,NMAX
      READ (IOUNIT,11,END=05)H,K,L,LT(I),SC,F(I),TBAR(I),SF(I)
   11 FORMAT(13X,3I3,3X,2I3,F9.0,F9.5,F6.0)
   03 IHKL(I) = IPACK (H,K,L)
C
   05 REWIND IOUNIT
C
C---- CALCULATE ST(J)=SIN(THETAT)/LAMBDA
C
      I = I - 1
      DO 04 J = 1,I
      CALL DEPAK (IHKL(J),IH(1),IH(2),IH(3))
   04 ST (J) = THETA(RECELL,IH)
C
C***  SORT THE NUMBERS 'NR' FOR INCREASING 'ST'
C
      CALL QSORTI (1,I,ST,IHKL,LT,F,SF,TBAR,NUMOR)
C
C---- WRITE THE SORTED DATAS ONTO THE OUTPUT UNIT
C
  200 IF (ITBAR .EQ. 1) GO TO 300
      DO 220 J = 1,I
      CALL DEPAK (IHKL(J),H,K,L)
      IF (J .EQ. 1) WRITE (IO,209) H,K,L,F(J),SF(J),ST(J)
  209 FORMAT (20X,54HH   K   L      INTENSITY  SIGMA     SIN(THETA / LAM
     &BDA//,1X,16HFIRST REFLECTION,3I4,5X,F9.0,3X,F5.0,8X,F10.6)
      IF (J .EQ. I) WRITE (IO,211) H,K,L,F(J),SF(J),ST(J)
  211 FORMAT(1H0,16HLAST  REFLECTION,3I4,5X,F9.0,3X,F5.0,8X,F10.6)
      WRITE (IOUNIT,IRMT)ICHAR(18),LABEL,H,K,L,LT(J),SC,F(J),SF(J)
  220 CONTINUE
      GO TO 400
  300 DO 230 J = 1,I
      CALL DEPAK (IHKL(J),H,K,L)
      IF (J .EQ. 1) WRITE (IO,309) H,K,L,F(J),SF(J),ST(J)
  309 FORMAT (20X,54HH   K   L      INTENSITY  SIGMA     SIN(THETA / LAM
     &BDA//1X,16HFIRST REFLECTION,3I4,5X,F9.0,3X,F5.0,8X,F10.6)
      IF (J .EQ. I) WRITE (IO,311) H,K,L,F(J),SF(J),ST(J)
  311 FORMAT(1H0,16HLAST  REFLECTION,3I4,5X,F9.0,3X,F5.0,8X,F10.6)
  230 WRITE(IOUNIT,IRMT)ICHAR(18),LABEL,H,K,L,LT(J),SC,F(J),TBAR(J),
     &SF(J)
  400 RETURN
      END
      SUBROUTINE REZREA(CELL1,RECELL)
C
C     CALCULATION OF THE RECIPROCAL CELL.
C
C     BY UDO ZUCKER (JAN. 80)
C
      DIMENSION CELL1(6),CELL(6),RECELL(6)
C
      DATA PI/3.1415927/
C
      DO 150 I=1,6
  150 CELL(I)=CELL1(I)
      DO 160 I=4,6
      IF(ABS(CELL(I)-90.0)-0.001)154,155,155
  154 CELL(I)=0.0
      GO TO 160
  155 CELL(I)=COS(CELL(I)*PI/180.0)
  160 CONTINUE
      STORE=CELL(6)
      CELL(6)=CELL(2)*CELL(3)*CELL(4)
      CELL(5)=CELL(1)*CELL(3)*CELL(5)
      CELL(4)=CELL(1)*CELL(2)*STORE
      DO 170 I=1,3
  170 CELL(I)= CELL(I)**2
      CALL UMKEHR(CELL,RECELL)
      RECELL(1)=SQRT(RECELL(1))
      RECELL(2)=SQRT(RECELL(2))
      RECELL(3)=SQRT(RECELL(3))
      RECELL(4)=RECELL(4)/(RECELL(1)*RECELL(2))
      RECELL(5)=RECELL(5)/(RECELL(1)*RECELL(3))
      RECELL(6)=RECELL(6)/(RECELL(2)*RECELL(3))
C
      RETURN
      END
C
              SUBROUTINE UMKEHR(CELL,RECELL)
C
C             INVERSION OF THE METRIC-TENSORE.
C
C             BY U. ZUCKER           (JAN. 80)
C
C
      DIMENSION CELL(6),RECELL(6)
C
      RECELL(1)=CELL(2)*CELL(3)-CELL(6)**2
      RECELL(4)=-CELL(4)*CELL(3)+CELL(5)*CELL(6)
      RECELL(5)=CELL(4)*CELL(6)-CELL(5)*CELL(2)
      DET=CELL(1)*RECELL(1)+CELL(4)*RECELL(4)+CELL(5)*RECELL(5)
      RECELL(1)=RECELL(1)/DET
      RECELL(4)=RECELL(4)/DET
      RECELL(5)=RECELL(5)/DET
      RECELL(2)=(CELL(1)*CELL(3)-CELL(5)**2)/DET
      RECELL(6)=(-CELL(1)*CELL(6)+CELL(5)*CELL(4))/DET
      RECELL(3)=(CELL(1)*CELL(2)-CELL(4)**2)/DET
      RETURN
      END
C
      FUNCTION THETA(RECELL,IH)
C
C     CALCULATION OF THETA IN RADIAN OUT OF RECIPROCAL CELL COORDINATES.
C
      DIMENSION H(3),HK(3),IH(3),RECELL(6)
      RHO=0.0
      DO 20 K=1,3
      H(K)=FLOAT(IH(K))
      HK(K)=H(K)*RECELL(K)
   20 RHO=RHO+HK(K)**2
      RHO=(RHO+2.0*(HK(1)*HK(2)*RECELL(4)+HK(1)*HK(3)*RECELL(5)+HK(2)*HK
     & (3)*RECELL(6)))*0.25
      THETA=SQRT(RHO)

      RETURN
      END
                          SUBROUTINE QSORTI
     &      (IMIN,IMAX,FELD1,IFELD2,LT,F,SF,TBAR,NUMOR)
C
C **********************************************************************
C *                                                                    *
C *   "QSORT" IS A SUBROUTINE TO SORT THE ARRAYS 'FELD1' AND           *
C *   'FELD2' SO THAT THE VALUES OF FELD1 INCREASES FROM               *
C *   FELD1(IMIN) TO FELD1(IMAX). ELEMENTS WITH ARGUMENTS LESS         *
C *   THAN 'IMIN' OR LARGER THAN 'IMAX' ARE LEFT UNCHANGED.            *
C *                                                                    *
C *   THE PROGRAMM HAS BEEN TRANSLATED FROM THE PASCAL PROCEDURE       *
C *   "QUICKSORT" WRITTEN BY C.A.R. HOARE (WIRTH. N. ;                 *
C *   ALGORITHMEN UND DATENSTRUKTUREN, B.G.TEUBNER STUTTGART)          *
C *                                                                    *
C *   (EGBERT PERENTHALER, MPI/FKF STUTTGART, 03/14/1980)              *
C *                                                                    *
C **********************************************************************
C
C
C***  VARIABLE DEFINITIONS
C***  'STACKL' AND 'STACKR' ARE STACK ARRAYS TO STORE THE LIMITS
C***  OF THE PRESORTED REGIONS OF 'FELD1' AND 'IFELD2'. THEIR
C***  DIMENSION MUST BE AT LEAST 1/6TH OF (IMAX - IMIN).
C***  'FELD1' AND 'IFELD2' ARE THE ARRAYS TO BE SORTED PARALLELLY
C***  ACCORDING TO THE VALUES OF 'FELD1'.
C
      DIMENSION FELD1(1),IFELD2(1),LT(1),F(1),SF(1),TBAR(1),NUMOR(1)
      INTEGER R,S,STACKL,STACKR
C
      DIMENSION STACKL(4001),STACKR(4001)
C
C***  INITIALISE STACKPOINTER 'S' AND THE STACK ITSELF
C
      S = 1
      STACKL(1) = IMIN
      STACKR(1) = IMAX
C
C***  LIMITS OF THE REGION TO BE PRESORTED
C
    5 L = STACKL(S)
      R = STACKR(S)
C
C***  SET STACKPOINTER
C
      S = S-1
C
C***  INITIALISE THE ARGUMENTS FOR THE NEXT SORTING-CYCLE
C
   10 I = L
      J = R
C
C***  STORE THE VALUE OF THE ELEMENT IN THE MIDDLE OF THE REGION
C
      X = FELD1((L+R) / 2)
C
C***  SEARCH FOR AN ELEMENT SMALLER THAN X, STARTING FROM THE LEFT
C***  SIDE OF THE REGION
C
   20 IF (FELD1(I) - X) 30,40,40
   30 I = I + 1
      GO TO 20
C
C***  SEQRCH FOR AN ELEMENT LARGER THAN X, STARTING FROM THE RIGHT
C***  SIDE OF THE REGION
C
   40 IF (X - FELD1(J)) 50,60,60
   50 J = J - 1
      GO TO 40
C
C***  HAS THE WHOLE REGION BEEN CHECKED ?
C
   60 IF (I .GT. J) GO TO 70
C
C***  IF TWO VALUES WERE FOUND, SMALER AND LARGER THAN X
C***  RESPECTIVELY, EXCHANGE THE CORRESPONDING ARRAY ELEMENTS.
C
      W = FELD1(I)
      FELD1(I) = FELD1(J)
      FELD1(J) = W
      IW = IFELD2(I)
      IFELD2(I) = IFELD2(J)
      IFELD2(J) = IW
      IW = LT(I)
      LT(I) = LT(J)
      LT(J) = IW
      W = F(I)
      F(I) = F(J)
      F(J) = W
      W = SF(I)
      SF(I) = SF(J)
      SF(J) = W
      W = TBAR(I)
      TBAR(I) = TBAR(J)
      TBAR(J) = W
      W = NUMOR(I)
      NUMOR(I) = NUMOR(J)
      NUMOR(J) = W
C
C***  PREPARE THE ARGUMENTS TO CONTINUE WITH SORTING THE REGION
C
      I = I + 1
      J = J - 1
C
C***  IF THE CHECK OF THE REGION IS NOT FINISHED, CONTINUE|
C
      IF (I .LE. J) GO TO 20
C
C***  PREPARE STACKPOINTER AND STACK TO CONTINUE WITH SORTING
C
   70 IF (I .GE. R) GO TO 80
      S = S + 1
      STACKL(S) = I
      STACKR(S) = R
   80 R = J
      IF (L.LT.R) GO TO 10
      IF (S.GT.0) GO TO 5
      RETURN
      END

