                         SUBROUTINE AVERA2
     &       (IO,MAXLIN,IDIM,NUMMER,ILT,ISORT,IP,IU,ICV,
     &            IHKL,IRHKL,F,SF,TBAR,CKOF,NUMOR,FINTCU)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C +                                                                    +
C + SUBROUTINE WHICH AVERAGES THE DATA PREPARED BY AVERA1, PRODUCES AN +
C + OUTPUT FILE AND DO SOME STATISTICS                                 +
C + WRITTEN BY EGBERT PERENTHALER MPI-FKF (1978)                       +
C + CONSIDERABLY UPGRADED W.F.KUHS ILL (1983)                          +
C +                                                                    +
C + (LAST UPDATES DEZEMBER 1980, APRIL 1987)                           +
C +                                                                    +
C + THIS PROGRAMME IS CALLED BY THE SUBROUTINE AVERAG                  +
C +                                                                    +
C + THIS PROGRAMME CALLS THE SUBROUTINES  IPACK, DEPAK, ZUVIEL, AND    +
C + IDENT                                                              +
C +                                                                    +
C + IN CASE OF AN OVERLAY STRUCTURE IT IS THE MAIN PROGRAMME OF THE    +
C + OVERLAY  AVER2                                                     +
C +                                                                    +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C---- TYPE STATEMENTS
C     ---------------
C
      REAL MU
C
C---- INTEGER VARIABLES
C    - ANUM         NUMBER TO SIGN THE BEGINNING OF THE UNAVERAGED
C                   REFLECTIONS
C    - AHKL         PACKED HKL VALUES  (SEE COMMON /C4/)
C
      INTEGER H,AEH,AEK,AEL,SC,KENNZ,DUMM,ANUM,AHKL
      CHARACTER*5 IPRFF,IPRF
C
C---- DIMENSION STATEMENTS
C     --------------------
C
C    - INTERV
C    - INTERQ
C    - IRINT
C    - IRINTO
C    - INTRQA
C
      DIMENSION INTERV(12),INTERQ(24),INTRQA(24),IRINT(12),IRINTO(12)
      DIMENSION IHKL(IDIM),IRHKL(IDIM),F(IDIM),SF(IDIM),TBAR(IDIM),
     &          CKOF(IDIM),NUMOR(IDIM)
      DIMENSION AHKL(1000),AF(1000),ASF(1000),SASF(1000),ATBAR(1000),
     &       ACKOF(1000),IFLAG(1000),NUMORA(1000),IPRFF(2)
C
C---- COMMON DECLARATIONS
C     -------------------
C
C---- /C4/ COMMON WITH THE SUBROUTINE IDENT
C
      COMMON /C4/ BU(100),IREF(36),IRZA,MULT,ILINE,KENNZ,IEND,LK
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)
     &,ISCGR
      COMMON /BD/ ICHAR(18),IRMT(21),IPRFF
C
C---- FORMAT STATEMENTS
C     -----------------
C
C
C---- INITIALISE
C     ----------
C
C***********************************************************************
C     VARIABLE ISMAX TO CHECK OVERFLOW OF THE SUBSCRIPTS OF THE ARRAYS
C     FOR THE SYMMETRY EQUIVALENT REFLECTIONS (SEE DIMENSION STATEMENTS)
C
      ISMAX = 1000
C
C***********************************************************************
C
C---- NEXT LINE IS SQRT(2/PI) FOR STATISTICAL R-FACTOR
      TWOP = .7978846
      IF(ISCGR.LE.0)ISCGR = 1
      SC = ISCGR
      DUMM = 1
      IF (IKART .NE. 0) DUMM = 3
      IF (ILIST .EQ. 1) GOTO 1003
C
C---- COVER OF THE REFLECTION LISTING AFTER THE AVERAGING
C
      WRITE (IO,1001)
 1001 FORMAT(1H1,8(/),10X,32HLIST OF THE AVERAGED REFLECTIONS,/,10X,
     &32(1H=),5(/),10X,44HIN THE FOLLOWING LIST YOU FIND THE GROUPS OF,
     &32H SYMMETRY EQUIVALENT REFLECTIONS,//,10X,15HAND THEIR MEAN ,
     &7HVALUES.,5(/),10X,9HTHERE ARE,3(/),10X,11HI          ,
     &13H=   INTENSITY,//,10X,35HSIGMA(I)   =   TOTAL STANDARD DEVIA,
     &20HTION  =  COUNT + SYS,//,10X,31HCOUNT      =   ERROR FROM COUNT,
     &11H STATISTICS,//,10X,31HSYS        =   SYSTEMATIC ERROR,//,10X,
     &62HSTAT       =   ERROR CALCULATED USING THE DEVIATIONS FROM THE ,
     &10HMEAN VALUE,/,25X,35H(PRINTED WITH .***  IF SIGMA(I) IS ,
     &17HREPLACED BY STAT),//,10X,
     &37HQ          =   ( I - <I> ) / SIGMA(I),//,10X,13HP          = ,
     &62H  ( I - <I> ) / <I> * 100   RESP. INTERNAL R-VALUE IN THE LINE,
     &18H OF THE MEAN VALUE//10X,34HLT         =   MARK FOR  LESS THAN,
     &13H  REFLECTIONS//)
      IF (IREJEC .NE. 0) WRITE (IO,1002)
 1002 FORMAT(10X,34HREJ        =   REJECTED REFLECTION,
     &//,10X,47HONE        =   ALL REFLECTIONS BUT ONE REJECTED,//,
     &10X,53HNOR        =   LIKE  ONE  BUT MEAN VALUE REJECTED TOO/1H )
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1003
      WRITE (IO,1004) ICHAR(DUMM),ICHAR(DUMM+1),ICHAR(DUMM),ICHAR(DUMM+
     &1),ICHAR(DUMM),ICHAR(DUMM+1),ICHAR(DUMM),ICHAR(DUMM+1)
 1004 FORMAT(10X,33HIO         =   INTENSITY WITHOUT ,2A3,
     &15HTION CORRECTION,//,10X,23HQO         =   Q-VALUE ,
     &41H(IN THE MEAN VALUE LINE R-VALUE) WITHOUT ,2A3,
     &15HTION CORRECTION,//,10X,37HQ/QO       =   RATIO OF THE SUMS OVER
     &,43H THE ABSOLUTE VALUES OF Q WITH AND WITHOUT ,2A3,10HTION CORRE,
     &5HCTION,//,10X,39HBAD        =   Q/QO IS GREATER THAN ONE,
     &//,10X,19HGR         =   THE ,2A3,60HTION CORRECTION HAS INCREASED
     & THE R-VALUE OF THIS REFLECTION)
C
C---  INITIALISE PARAMETERS FOR STATISTICS
C
 1003 ILINE = MAXLIN
      IZAHL = 0
      ANUM = 1
      IRZA = 0
      RSTA1 = 0.
      RSTA2 = 0.
      RSTA3 = 0.
      RSTA4 = 0.
      DO 1006 I = 24,99
 1006 BU (I) = 0.
      BU(29) = 1000.
      DO 1005 I = 1,12
      INTERQ (I) = 0
      INTERQ (I + 12) = 0
      INTRQA (I) = 0
      INTRQA (I + 12) = 0
      IREF (I) = 0
      IREF (I + 12) = 0
      IREF (I + 24) = 0
 1005 INTERV (I) = 0
      BU (1) = -15.
      BU (2) = -10.
      BU (3) = -8.
      BU (4) = -6.
      BU (5) = -5.
      BU (6) = -4.
      BU (7) = -3.5
      BU (8) = -3.
      BU (9) = -2.5
      BU (10) = -2.
      BU (11) = -1.
      BU (12) = 0.
      BU (13) = 1.
      BU (14) = 2.
      BU (15) = 2.5
      BU (16) = 3.
      BU (17) = 3.5
      BU (18) = 4.
      BU (19) = 5.
      BU (20) = 6.
      BU (21) = 8.
      BU (22) = 10.
      BU (23) = 15.
C
C---- EXTRACT A GROUP OF SYMMETRY EQUIVALENT REFLECTIONS OUT OF THE
C---- DATA STET
C---- INITIALISE NUMBER OF SYMMETRY EQUIVALENT REFLECTIONS
 1010 MULT = 0
C
C---- ARE THE REFLECTIONS PRESORTED OR NOT
C
      IF(ISORT) 1020,1020,1200
C
C---- THE REFLECTIONS ARE PRESORTED
C
 1020 IAHKL = IRHKL(ANUM)
	APSI=CKOF(ANUM)
	IPSI=0
      DO 1500 I = ANUM,NUMMER
 1100 IF (IRHKL(I)  .NE. IAHKL) GO TO 1501
	IF(IABSO.LT.0)THEN
          IF(F(I).LT.SF(I)*FINTCU) CKOF(I)=APSI
	    IF(CKOF(I).NE.APSI)GOTO 1106
          ENDIF
      MULT = MULT + 1
      IZAHL = IZAHL + 1
      AHKL (MULT) = IHKL (I)
      IHKL (I) = 111
      AF (MULT) = F (I)
      ASF (MULT) = SF (I)
      NUMORA(MULT) = NUMOR(I)
      IF (ISYS) 1101,1102,1101
 1101 SASF (MULT) = ABS (F (I)) /100. * SYSDEV
 1102 IF (IKART) 1104,1103,1104
 1103 ATBAR (MULT) = TBAR (I)
      IF (IABSO) 1104,1105,1104
 1104 ACKOF (MULT) = CKOF (I)
 1105 IF (MULT .GT. ISMAX) CALL ZUVIEL (IO,ISMAX,2)
	GOTO 1107
 1106	IF((IABSO.LT.0).AND.(IPSI.EQ.0))THEN
	  INUMPSI=I
	  IPSI=IPSI+1
	ENDIF
1107	CONTINUE
 1500 CONTINUE
C
 1501 ANUM = I
	IF((IABSO.LT.0).AND.(IPSI.NE.0))THEN
	   ANUM=INUMPSI
	ENDIF
      GO TO 1502
C
C---- THE REFLECTIONS ARE NOT PRESORTED
C
 1200 DO 1300 I = ANUM,NUMMER
      IF (IHKL(I) .EQ. 111) GO TO 1300
      IBHKL = IRHKL(I)
	BPSI=CKOF(I)
      IF (MULT .NE. 0) GO TO 1210
      IAHKL = IBHKL
	APSI=BPSI
      ANUM = I + 1
 1210 IF (IBHKL .NE. IAHKL) GO TO 1300
        IF(F(I).LT.SF(I)*FINTCU)APSI=BPSI
	IF((IABSO.LT.0).AND.(BPSI.NE.APSI)) GOTO 1300
      MULT = MULT + 1
      IZAHL = IZAHL + 1
      AHKL(MULT) = IHKL(I)
      IHKL(I) = 111
      AF(MULT) = F(I)
      ASF(MULT) = SF(I)
      NUMORA(MULT) = NUMOR(I)
      IF (ISYS) 1211,1212,1211
 1211 SASF(MULT) = ABS (F(I)) / 100. * SYSDEV
 1212 IF (IKART) 1214,1213,1214
 1213 ATBAR(MULT) = TBAR(I)
      IF (IABSO) 1214,1215,1214
 1214 ACKOF(MULT) = CKOF(I)
 1215 IF (MULT .GT. ISMAX) CALL ZUVIEL (IO,ISMAX,2)
 1300 CONTINUE
C
C---- CALL SUBROUTINE IDENT FOR AVERAGING IDENTICAL REFLECTIONS
C
 1502 IF (MODU .NE. 0 .AND. MODU .NE. 3)
     &CALL IDENT (IO,MAXLIN,1,ISMAX,AHKL,AF,ASF,SASF,ATBAR,ACKOF,NUMORA,
     &IFLAG,ICV)
C
C---- CALL SUBROUTINE IDENT FOR AVERAGING FRIEDEL REFLECTIONS RESP.
C---- IDENTICAL PLUS FRIEDEL REFLECTIONS
      IF (MODU .GT. 1)
     &CALL IDENT (IO,MAXLIN,2,ISMAX,AHKL,AF,ASF,SASF,ATBAR,ACKOF,NUMORA,
     &IFLAG,ICV)
C
      IF(ILIST.EQ.3.AND.MULT.EQ.1) GOTO 1524
      IF (ILINE + MULT + 2 .LE. MAXLIN) GO TO 1520
C
C---- HEADLINE FOR A PAGE OF THE REFLECTION LIST
C
      IF (ILIST .EQ. 1) GO TO 1521
      ILINE = 3
      KENNZ = 7
      IEND = 7
      IF (IREJEC) 1508,1509,1508
 1508 KENNZ = 10
      IEND = 11
 1509 IF (IABSO .GT. 0 .OR. IKART .NE. 0) GO TO 1511
      IPRF = IPRFF(2)
      IF(ICV.EQ.0) IPRF = IPRFF(1)
      WRITE (IO,1510) IPRF,ICHAR(KENNZ),ICHAR(IEND)
 1510 FORMAT(1H1,A5,12H   H   K   L,7X,1HI,2X,8HSIGMA(I),1X,
     &5HCOUNT,2X,3HSYS,3X,4HSTAT,8X,1HQ,5X,1HP,3X,A3,4X,2HLT,5X,A3,//)
      GO TO 1520
 1511 ISCAL = 14
      IPRF = IPRFF(2)
      IF(ICV.EQ.0) IPRF = IPRFF(1)
      WRITE(IO,1512)IPRF,ICHAR(KENNZ),ICHAR(ISCAL),ICHAR(IEND),ICHAR(17)
 1512 FORMAT (1H1,A5,12H   H   K   L,7X,1HI,2X,8HSIGMA(I),1X,
     &5HCOUNT,2X,3HSYS,3X,4HSTAT,8X,1HQ,5X,1HP,2X,A3,7X,2HIO,7X,2HQO,
     &6X,4HQ/QO,2X,3HBAD,4X,A2,5X,2HLT,3X,A3,1H/,A3,//)
 1520 IF (IRZA .EQ. 0) GO TO 1521
C
C---- MARK THE AVERAGING OF THE CRYSTAL SYMMETRIE IN THE LIST
      WRITE (IO,1522)
 1522 FORMAT (1X,33HAVERAGING OF THE CRYSTAL SYMMETRY)
      IRZA = 0
C---- COUNT LINE AND INITIALISE  NOREF
      ILINE = ILINE + 1
 1521 ILINE = ILINE + MULT + 2
 1524 IF (MULT .EQ. 0) WRITE (IO,1523)
 1523 FORMAT(1H0/1X,49HDURING THE PREAVERAGING ALL REFLECTIONS WERE REJE
     &,37HCTED  *******************************,//)
      IF (MULT .EQ. 0 .AND. IZAHL .NE. NUMMER
     &.AND. ANUM .NE. NUMMER ) GO TO 1010
      NOREF = 0
      SSTAT = 0.
      P = 0.
C
C---- SUM UP THE DATA TO BE AVERAGED
C
      DO 1530 I = 1,MULT
 1530 IFLAG (I) = 0
 1540 I = 1
 1570 IF (IFLAG(I) .EQ. 0) GO TO 1550
      IF (I .EQ. MULT) GO TO 1560
      I = I + 1
      GO TO 1570
 1560 NOREF = 1
      GO TO 1640
C---- STORE THE VALUES OF THE FIRST REFLECTION
 1550 IBEI = 1
      AFS = AF (I)
      ASFS = ASF (I) ** 2
      SASFS = SASF (I)
      SFMAX = ASF (I)
      FMAX = AF (I)
	APSIS=ACKOF(I)
      IF (IKART) 1552,1551,1552
 1551 ATBARS = ATBAR (I)
      IF (IABSO) 1553,1553,1556
 1556 FALT = AF (I) / ACKOF (I)
      GO TO 1553
 1552 FALT = AF (I) * ACKOF (I)
 1553 IF (I .EQ. MULT) GO TO 1601
C
C---- ADD THE VALUES OF THE OTHER REFLECTIONS
      DO 1600 J = I + 1,MULT
      IF (IFLAG (J) .EQ. 1) GO TO 1600
      IBEI = IBEI + 1
      AFS = AFS + AF (J)
      ASFS = ASFS + ASF (J) ** 2
	APSIS=APSIS+ ACKOF(J)
      IF (ISYS) 1554,1555,1554
 1554 SASFS = SASFS + SASF (J)
 1555 IF (AF (J) .GT. FMAX) SFMAX = ASF (J)
      IF (AF (J) .GT. FMAX) FMAX = AF (J)
      IF (IKART) 1590,1579,1590
 1579 ATBARS = ATBARS + ATBAR(J)
      IF (IABSO) 1600,1600,1580
 1580 FALT = FALT + AF (J) / ACKOF (J)
	GOTO 1600				! TOLLER FEHLER
 1590 FALT =  FALT + AF (J) * ACKOF (J)
 1600 CONTINUE
C
C---- CALCULATE THE MEAN VALUES
C
 1601 AFS = AFS / FLOAT (IBEI)
      ASFS = SQRT (ASFS) / FLOAT (IBEI)
	APSIS=APSIS/FLOAT(IBEI)
      IF (ISYS) 1591,1592,1591
 1591 SASFS = SASFS / FLOAT (IBEI)
 1592 IF (IKART) 1594,1593,1594
 1593 ATBARS = ATBARS / FLOAT (IBEI)
      IF (IABSO) 1595,1595,1594
 1594 FALT = FALT / FLOAT (IBEI)
 1595 SFS = SASFS + ASFS
C
C---- CHECK FOR VALUES WHICH CAN CAUSE A DIVISION THROUGH ZERO
C
C      IF (ABS (AFS) .LT. 1.E-6) AFS = SFS / 1000.
      IF (ABS (AFS) .LT. 1.E-6)  AFS = 1.E-6
      IF (IKART) 1597,1596,1597
 1596 IF (IABSO) 1598,1598,1597
 1597 CONTINUE
C      IF (ABS (FALT) .LT. 1.E-6) FALT = SFS / 10000.
      IF (ABS (FALT) .LT. 1.E-6) FALT = 1.E-6
C
C---- MARK A NEGATIVE MEAN VALUE
 1598 IZF = 0
      IF (AFS .LT. 0.) IZF = 1
C
      IF (NULL) 1603,1602,1603
C
C---- SET NEGATIVE INTENSITIES TO ZERO
 1602 CONTINUE
C      IF (AFS .LT. 0.) AFS = SFS / 1000.
      IF (AFS .LT. 0.) AFS = 1.E-6
C      IF (FALT .LT. 0.) FALT = SFS / 10000.
      IF (FALT .LT. 0.) FALT = 1.E-6
 1603 IF (IREJEC) 1627,1640,1604
C
C---- CHECK IF ANY REFLECTION SHOULD BE REJECTED
C
 1604 P = 0.
      DO 1620 I = 1,MULT
      IF (IFLAG (I) .EQ. 1) GO TO 1620
      Q = ABS (AF (I) - AFS) / (ASF (I) + SASF (I))
      IF (Q .GT. P) ISETZ = I
      IF (Q .GT. P) P = Q
 1620 CONTINUE
      IF (P .LT. REJE) GO TO 1640
      IFLAG (ISETZ) = 1
      GO TO 1540
 1627 IF (P .GT. 1.) GO TO 1640
      DO 1628 I = 1,MULT
      IF (AF (I) .GT. FMAX - REJE * SFMAX ) GO TO 1628
      IFLAG (I) = 1
      P = 2.
 1628 CONTINUE
      IF (P .GT. 1) GO TO 1540
C
C---- IS THERE ONLY ONE REMAINING REFLECTION
 1640 IF (IBEI .EQ. 1 .AND. MULT .GT. 1) NOREF = 1
C
C---- COUNT NEGATIVE INTENSITIES
      IF (IZF .EQ. 1) IREF (25) = IREF (25) + 1
C
C---- COUNT THE REJECTED REFLECTIONS
      IREF (7) = IREF (7) + MULT - IBEI
C
C---- INITIALISE SOME VARIABLES
      BU(48) = 0.
      BU(49) = 0.
      LT = 1
      IF (AFS .LT. SIGLT * ASFS) LT = 2
      DO 1613 I = 54,57
 1613 BU (I) = 0.
C
C---- PREPARE THE OUTPUT OF THE GROUP OF REFLECTIONS AND MAKE SOME
C---- STATISTICAL CALCULATIONS
C
      DO 1700 I = 1,MULT
      Q = (AF (I) - AFS) / (ASF (I) + SASF (I))
      P = (AF (I) - AFS) / AFS * 100.
      IF (NOREF .EQ. 1 .OR. MULT .EQ. 1) GO TO 1614
C
C---- SUMS FOR THE INTERNAL R-VALUE OF THE GROUP OF REFLECTIONS
      IF(IFLAG(I).EQ.0)BU(54)=BU(54) + (AF(I)-AFS) * (AF(I)-AFS)
      IF(IFLAG(I).EQ.0)BU (55) = BU (55) + AF (I) * AF (I)
 1614 IF (IABSO) 1615,1615,1641
 1615 IF (IKART) 1616,1642,1616
C
C---- VALUES WITHOUT EXTINCTION CORRECTION
 1616 FON = AF (I) * ACKOF (I)
      QALT = (FON - FALT) / (ASF (I) + SASF (I)) / ACKOF (I)
      GO TO 1639
C
C---- VALUES WITHOUT ABSORPTION CORRECTION
 1641 FON = AF (I) / ACKOF (I)
      QALT = (FON - FALT) / (ASF (I) + SASF (I)) * ACKOF (I)
 1639 IF (NOREF .EQ. 1 .OR. MULT .EQ. 1) GO TO 1642
C
C---- SUMS FOR THE INTERNAL R-VALUE WITHOUT CORRECTION
C
      IF(IFLAG(I).EQ.0)BU(56)=BU(56) + (FON - FALT) * (FON - FALT)
      IF(IFLAG(I).EQ.0)BU(57) = BU (57) + FON * FON
C
C---- SEARCH FOR THE MAXIMUM Q-VALUE OF THE DATA SET AND SUM OVER
C---- THE ABSOLUTE VALUES
 1642 IF (LT .EQ. 1) GO TO 1650
      IF (ABS (Q) .LT. ABS (BU(31))) GO TO 1643
      BU(31) = Q
      IHQL = AHKL (I)
 1643 BU(33) = BU(33) + ABS (Q)
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1660
      IF (ABS (QALT) .LT. ABS (BU(36))) GO TO 1644
      BU(36) = QALT
      IHAQL = AHKL (I)
 1644 BU(37) = BU(37) + ABS (QALT)
      GO TO 1660
 1650 IF (ABS (Q) .LT. ABS (BU(30))) GO TO 1651
      BU(30) = Q
      IHQ = AHKL (I)
 1651 BU(32) = BU(32) + ABS (Q)
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1660
      IF (ABS (QALT) .LT. ABS (BU(34))) GO TO 1652
      BU(34) = QALT
      IHAQ = AHKL (I)
 1652 BU(35) = BU(35) + ABS (QALT)
C
C---- PREPARATIONS FOR THE PRINTED OUTPUT
 1660 CALL DEPAK (AHKL (I),H,K,L)
      IF (IFLAG (I) .EQ. 1) KENNZ = 10
      IF (IFLAG (I) .EQ. 0) KENNZ = 7
C
C---- DISTRIBUTION OF THE Q-VALUES
      IF (Q .LT. BU (1)) INTERQ (1) = INTERQ (1) + 1
      DO 1661 J = 2,23
 1661 IF(Q.GE.BU(J-1).AND.Q.LT.BU(J))INTERQ(J)=INTERQ(J) + 1
      IF (Q .GE. BU (23)) INTERQ (24) = INTERQ (24) + 1
C
C---- SUMS OVER THE SQUARES OF THE DEVIATIONS FROM THE MEAN VALUE
      IF (IFLAG (I) .EQ. 0) SSTAT = SSTAT + (AF(I) - AFS) ** 2
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1612
C
C---- SUMS OVER THE ABSOLUT VALUES OF THE Q-VALUES OF THE GROUP
      BU(48) = BU(48) + ABS (Q)
      BU(49) = BU(49) + ABS (QALT)
C
C---- DISTRIBUTION OF THE Q-VALUES WITHOUT CORRECTION
      IF (QALT .LT. BU (1)) INTRQA (1) = INTRQA (1) + 1
      DO 1662 J = 2,23
 1662 IF(QALT.GE.BU(J-1).AND.QALT.LT.BU(J))INTRQA(J)=INTRQA(J) + 1
      IF (QALT .GE. BU (23)) INTRQA (24) = INTRQA (24) + 1
      IF (ILIST .EQ. 1) GO TO 1700
      IF (ILIST.EQ.3.AND.MULT.EQ.1) GOTO 1700
C
C---- PRINT ONE REFLECTION
      WRI = ASF(I) + SASF(I)
      IF(ICV.EQ.1)WRITE(IO,1611)H,K,L,AF(I),WRI,ASF(I),SASF(I),Q,P,
     &ICHAR(KENNZ),FON,QALT
 1611 FORMAT(6X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2F6.0,1X,A3,
     &1X,2F9.0)
      IF(ICV.EQ.0)WRITE(IO,1617)NUMORA(I),H,K,L,AF(I),WRI,ASF(I),SASF(I)
     &,Q,P,ICHAR(KENNZ),FON,QALT
 1617 FORMAT(1X,I5,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2F6.0,1X,A3,
     &1X,2F9.0)
      GO TO 1700
 1612 IF (ILIST .EQ. 1) GO TO 1700
      IF(ILIST.EQ.3.AND.MULT.EQ.1) GOTO 1700
      WRI = ASF(I) + SASF(I)
      IF(P.LT.-9999.) P=-9999.
      IF(P.GT.99999.) P=99999.
      IF(ICV.EQ.1)WRITE(IO,1610)H,K,L,AF(I),WRI,ASF(I),SASF(I),Q,P,
     &ICHAR(KENNZ)
 1610 FORMAT(6X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2F6.0,2X,A3)
      IF(ICV.EQ.0)WRITE(IO,1618)NUMORA(I),H,K,L,AF(I),WRI,ASF(I),
     &SASF(I),Q,P,ICHAR(KENNZ)
 1618 FORMAT(1X,I5,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2F6.0,2X,A3)
 1700 CONTINUE
C
C---- PREPARE THE PRINTOUT OF THE MEAN VALUE AND SOME STATISTICS
C
C
C---- HKL OF THE MEAN VALUE
      CALL DEPAK (IAHKL,H,K,L)
C
C---- COUNT THE REFLECTIONS AFTER THE AVERAGING
      IREF(22) = IREF(22) + 1
      IF (LT .EQ. 2) IREF(23) = IREF(23) + 1
C
C---- PREPARE THE PRINTED OUTPUT
      LK = 7
      IF (LT .EQ. 2) LK = 12
      KENNZ = 7
      IF (NOREF) 1705,1706,1705
 1705 IREF (10) = IREF (10) + 1
      KENNZ = 11
      IF (NOR .EQ. 0 .OR. NOR .EQ. 2) KENNZ = 17
      ISCAL = 7
      BU (58) = 0.0
      BU (59) = 0.0
      GO TO 1626
C
C---- SUMS FOR THE INTERNAL R-VALUE
 1706 IF (LT .EQ. 2) GO TO 1707
      BU (24) = BU (24) + BU (54)
      BU (25) = BU (25) + BU (55)
      BU (84) = BU (84) + BU (56)
      BU (85) = BU (85) + BU (57)
      GO TO 1708
 1707 BU (26) = BU (26) + BU (54)
      BU (27) = BU (27) + BU (55)
      BU (86) = BU (86) + BU (56)
      BU (87) = BU (87) + BU (57)
C
C---- CALCULATE THE INTERNAL R-VALUE FOR THE GROUP OF REFLECTIONS
 1708 IF (BU (55) .LT. 1.E-6) BU (55) = 1.E-6
      IF (BU (57) .LT. 1.E-6) BU (57) = 1.E-6
      BU (58) = SQRT (BU (54) / BU (55))
      BU (59) = SQRT (BU (56) / BU (57))
C
C---- SEARCH FOR THE MAXIMUM R-VALUE OF THE GROUPS
      IF (LT .EQ. 2) GO TO 1709
      IF (BU (58) .LT. BU (66)) GO TO 1621
      BU (66) = BU (58)
      IREF (27) = IAHKL
 1621 IF (BU (59) .LT. BU (68)) GO TO 1623
      BU (68) = BU (59)
      IREF (29) = IAHKL
      GO TO 1623
 1709 IF (BU (58) .LT. BU (67)) GO TO 1622
      BU (67) = BU (58)
      IREF (28) = IAHKL
 1622 IF (BU (59) .LT. BU (69)) GO TO 1623
      BU (69) = BU (59)
      IREF (30) = IAHKL
C
C---- DISTRIBUTION OF THE R-VALUES
 1623 IF(BU(58)*100..LT.BU(13)) IRINT (1) = IRINT (1) + 1
      DO 1624 J = 2,11
 1624 IF(BU(58)*100..GE.BU(J+11).AND.BU(58)*100.LT.BU(J+12))
     &IRINT (J) = IRINT (J) + 1
      IF (BU (58)*100. .GT. BU (23)) IRINT (12) = IRINT (12) + 1
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1626
C
C---- DISTRIBUTION WITHOUT CORRECTION
      IF(BU(59)*100..LT.BU(13)) IRINTO (1) = IRINTO (1) + 1
      DO 1625 J = 2,11
 1625 IF(BU(59)*100..GE.BU(J+11).AND.BU(59)*100.LT.BU(J+12))
     &IRINTO (J) = IRINTO (J) + 1
      IF (BU (59)*100. .GT. BU (23)) IRINTO (12) = IRINTO (12) + 1
C
C---- HAS THE CORRECTION INCREASED THE R-VALUE
      ISCAL = 7
      IF (IBEI .EQ. 1) GO TO 1626
      if(abs(bu(59)).lt.1.e-6) bu(59)=1.0e-6
      if(abs(bu(58)).lt.1.e-6) bu(58)=1.0e-6
      IF (BU (59) / BU (58) .GT. .99999) GO TO 1626
      ISCAL = 14
      IF (LT .EQ. 1) IREF (26) = IREF (26) + 1
      IF (LT .EQ. 2) IREF (32) = IREF (32) + 1
C
C---- DISTRIBUTION OF INTENSITIES IN MULTIPLES OF SIGMA
 1626 Q = AFS / ASFS
      IF (Q .LT. BU (13)) INTERV (1) = INTERV (1) + 1
      DO 1702 J = 2,11
 1702 IF(Q.GE.BU(J+11).AND.Q.LT.BU(J+12))INTERV(J)=INTERV(J)+1
      IF (Q .GE. BU (23)) INTERV (12) = INTERV (12) + 1
C
C---- ERROR CALCULATION WITH THE DEVIATIONS FROM THE MEAN VALUE
      IF (IBEI .GE. 2) SSTAT =
     &SQRT (SSTAT / FLOAT (IBEI - 1) / FLOAT (IBEI))
      IF (IBEI .LT. 2) SSTAT = 0.
      IT = 7
      IF (ISST .GT. 1 .AND. IBEI .GE. ISST .AND. SSTAT .GT. SFS) IT = 8
      IF (ISST .LT. -1 .AND. IBEI .GE. -ISST) IT = 8
C
      IF (IKART) 1701,1805,1701
C
C---- EXTREM AND MEAN VALUES OF TBAR
 1805 IF (ATBARS) 1713,1713,1806
 1806 IF (ATBARS .LT. BU(38)) GO TO 1703
      BU(38) = ATBARS
      IHTMX = IAHKL
 1703 IF (ATBARS .GT. BU(29)) GO TO 1704
      BU(29) = ATBARS
      IHTMN = IAHKL
 1704 BU(39) = BU(39) + ATBARS
      IF (IABSO) 1713,1713,1701
C
C---- HAS THE CORRECTION INCREASED THE Q-VALUES
 1701 IBAD = 7
      IF (MULT .EQ. 1) BU(49) = 1.
      IF (MULT .EQ. 1) BU(48) = 1.
      IF (BU (49) .LT. 1.E -6) BU (49) = 1.E -6
      IF (BU (48) .LT. 1.E -6) BU (48) = 1.E -6
      IF (BU(48) / BU(49) .GE. 1.0001) IBAD = 16
C
C
C---- PRINT THE MEAN VALUE OF A GROUP OF REFLECTIONS
      IF (ILIST .EQ. 1) GO TO 1732
      IF (ILIST.EQ.3.AND.MULT.EQ.1) GOTO 1732
      WRI = BU(48)/BU(49)
      WRITE (IO,1711,IOSTAT=IDUMMY)H,K,L,AFS,SFS,ASFS,SASFS,
     &SSTAT,ICHAR(IT),BU(58),
     &FALT,BU(59),WRI,ICHAR(IBAD),ICHAR(ISCAL),ICHAR(LK),
     &ICHAR(KENNZ)
 1711 FORMAT (6H  MEAN,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,F7.0,A3,5X,
     &F6.4,5X,F9.0,3X,F6.4,3X,F6.2,2X,A3,4X,A2,5X,A2,5X,A3,/,2X,68(1H=))
 1732 IF (BU(48) /BU(49) .LT. 1.0001) GO TO 1712
      IF (LT .EQ. 1) IREF (24) = IREF (24) + 1
      IF (LT .EQ. 2) IREF (31) = IREF (31) + 1
      GO TO 1712
 1713 IF (ILIST .EQ. 1) GO TO 1712
      IF(ILIST.EQ.3.AND.MULT.EQ.1) GOTO 1712
      WRITE (IO,1710)H,K,L,AFS,SFS,ASFS,SASFS,SSTAT,ICHAR(IT),BU(58),
     &ICHAR(LK),ICHAR(KENNZ)
 1710 FORMAT (6H  MEAN,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,F7.0,A3,5X,
     &F6.4,9X,A2,5X,A3/,1X,68(1H=))
 1712 IF (NOREF .EQ. 1 .AND. NOR .EQ. 0 .OR. NOR .EQ. 2) GO TO 1725
C
C---- WOULD A VALUE BE ZERO WHEN WRITTEN ON THE FILE
      IF (ABS (AFS) .LT. 0.5) AFS = SIGN (1.,AFS)
C
C---- WHICH OF THE TWO STATISTICAL ERRORS SHOULD BE TAKEN
      IF(ISST.GT.1 .AND. IBEI.GE.ISST .AND. SSTAT.GT.SFS) SFS = SSTAT
      IF (ISST .LT. -1 .AND. IBEI .GE. -ISST) SFS = SSTAT
C
C---- CAN OVERFLOW OF THE OUTPUT FORMAT OCCUR
      IF (AFS .LT. 10. ** IP) GO TO 1715
      WRITE(*,1714) AFS,H,K,L,(IRMT(I),I=9,12)
      WRITE(IO,1714) AFS,H,K,L,(IRMT(I),I=9,12)
 1714 FORMAT(2(/),19H**** THE INTENSITY ,F12.0,14H OF REFLECTION, 3I4,
     &38H CAUSES OVERFLOW OF THE OUTPUT FORMAT ,4A1,/,5X,9HINCREASE ,
     &59HTHE FORMAT OR READ IN A VALUE FOR THE SCALE FACTOR  OFLOW .)
      CALL EXIT
 1715 IF (SFS .LT. 10. ** IU) GO TO 1717
      WRITE(*,1716) SFS,H,K,L,(IRMT(I),I=16,19)
      WRITE(IO,1716) SFS,H,K,L,(IRMT(I),I=16,19)
 1716 FORMAT(2(/),28H**** THE STANDARD DEVIATION ,F8.0,14H OF REFLECTION
     &,3I4,38H CAUSES OVERFLOW OF THE OUPUT FORMAT  ,4A1,/,5X,8HINCREASE
     &,59HTHE FORMAT OR READ IN A VALUE FOR THE SCALE FACTOR  OFLOW .)
      CALL EXIT
C
C---- WRITE A REFLECTION ONTO THE OUPUT UNIT
C
C---- THE NEXT LINE IS TO AVOID ZERO STANDARD DEVIATION
C
 1717 IF(SFS.LT.1.0) SFS = 1.
C---- CALCULATE CONTRIBUTIONS TO STATISTICAL R-FACTORS
      IF(LT.EQ.2) GOTO 1763
      RSTA1 = RSTA1 + SFS
      RSTA2 = RSTA2 + AFS
      GOTO 1762
 1763 RSTA3 = RSTA3 + SFS
      RSTA4 = RSTA4 + AFS
C
 1762 	IF(IABSO.GE.0)THEN
	  WRITE (IOUNIT,IRMT)ICHAR(18),LABEL,H,K,L,LT,SC,AFS,ATBARS,SFS
	ELSE
	  WRITE (IOUNIT,IRMT)ICHAR(18),LABEL,H,K,L,LT,SC,AFS,ATBARS,SFS
     &                      , APSIS
	ENDIF
C
 1725 IF (IZAHL .NE. NUMMER) GO TO 1010
C
C---- END OF THE AVERAGING PROCESS
C
C
C---- CALCULATE AND PRINT THE STATISTICS
C
C---- MEANVALUES OF THE ABSOLUTE Q-VALUES
      ILINE = NUMMER
      ISEIT = ILT
      IF (MODU .NE. 1) GO TO 1726
      ILINE = IREF (1)
      ISEIT = IREF (3)
 1726 IF (MODU .NE. 2) GO TO 1727
      ILINE = IREF (2)
      ISEIT = IREF (4)
 1727 BU (90) = (BU(32) + BU(33)) / FLOAT (ILINE)
      BU (92) = BU(32) / FLOAT (ILINE - ISEIT)
      IF (ISEIT .NE. 0) BU (94) = BU(33) / FLOAT (ISEIT)
C
C---- CALCULATE THE INTERNAL R-VALUE
      IF (BU(25)+BU(27) .GT. 0.)BU(73) = SQRT ((BU (24) + BU (26)) /
     &(BU (25) + BU (27)))
      IF (BU(25) .GT. 0.) BU (74) = SQRT (BU (24) / BU (25))
      IF (BU (27) .GT. 0.) BU (75) = SQRT (BU (26) / BU (27))
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1729
      IF (BU(85)+BU(87) .GT. 0.)BU (76) = SQRT ((BU (84) + BU (86)) /
     &(BU (85) + BU (87)))
      IF (BU (85) .GT. 0.) BU (77) = SQRT (BU (84) / BU (85))
      IF (BU (87) .GT. 0.) BU (78) = SQRT (BU (86) / BU (87))
C---- HKL FOR THE REFLECTIONS WITH THE HIGHES Q-VALUES
 1729 CALL DEPAK (IHQ,IFLAG(1),IFLAG(2),IFLAG(3))
      CALL DEPAK (IHQL,IFLAG(4),IFLAG(5),IFLAG(6))
C
      IWRI = NUMMER - ILT
      WRI = FLOAT(ILT)/FLOAT(NUMMER)*100.
CHB   PRINT 1730,TITEL,LABEL,NUMMER,IWRI,ILT,WRI
      WRITE(IO,1730)TITEL,LABEL,NUMMER,IWRI,ILT,WRI
 1730 FORMAT(1H1, 1X,19HS T A T I S T I C S/1X,19(1H=),4(/),1X,21HTITEL
     &OF THE PROGRAMM/1X,21(1H-)//1X,18A4///1X,25HLABEL OF THE OUTPUT CA
     &RDS,/1X,25(1H-)//1X,A4,A2,
     &4(/),1X,21HNUMBER OF REFLECTIONS/1X,21(1H-)//54X,5HTOTAL,6X,
     &13HNOT LESS THAN,4X,9HLESS THAN,4X,29HLESS THAN IN PERCENT OF TOTA
     &L///18X,7HREAD IN,28X,3(I5,10X),F6.2)
      IF(MODU.NE.0.AND.MODU.NE.3)IWRI=IREF(1)-IREF(3)
      IF(MODU.NE.0.AND.MODU.NE.3)WRI=FLOAT(IREF(3))/FLOAT(IREF(1))*100.
CHB   IF(MODU .NE. 0 .AND. MODU .NE. 3) PRINT 1740,IREF(1),
CHB  &IWRI,IREF(3),WRI
      IF(MODU .NE. 0 .AND. MODU .NE. 3) WRITE(IO,1740)IREF(1),
     &IWRI,IREF(3),WRI
 1740 FORMAT(1H0,17X,25HAFTER AVERAGING IDENTICAL/32X,11HREFLECTIONS,
     &10X,3(I5,10X),F6.2)
      IF(MODU.GT.1) IWRI = IREF(2)-IREF(4)
      IF(MODU.GT.1) WRI = FLOAT(IREF(4))/FLOAT(IREF(2))*100.
CHB   IF (MODU .GT. 1) PRINT 1750,IREF(2),IWRI,
CHB  &IREF(4),WRI
      IF (MODU.GT.1) WRITE(IO,1750)IREF(2),IWRI,IREF(4),WRI
 1750 FORMAT(1H0,17X,15HAFTER AVERAGING,/,24X,19HFRIEDEL-REFLECTIONS,
     &10X,3(I5,10X),F6.2)
      IWRI = IREF(22)-IREF(23)
      WRI = FLOAT(IREF(23))/FLOAT(IREF(22))*100.
CHB   PRINT 1760,IREF(22),IWRI,IREF(23),WRI
      WRITE(IO,1760)IREF(22),IWRI,IREF(23),WRI
 1760 FORMAT(2(/),18X,8HAVERAGED,27X,3(I5,10X),F6.2)
CHB   PRINT 1761,IREF(25),IREF(25)
      WRITE(IO,1761)IREF(25),IREF(25)
 1761 FORMAT(3(/),18X,20HNEGATIVE MEAN VALUES,15X,2(I5,25X))
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1800
C
C---- MEAN ABSOLUTE VALUE OF Q WITHOUT CORRECTION
      BU (91) = (BU(35) + BU(37)) / FLOAT (ILINE)
      BU (93) = BU(35) / FLOAT (ILINE - ISEIT)
      IF (ISEIT .NE. 0) BU (95) = BU(37) / FLOAT (ISEIT)
C
C---- HKL OF THE REFLECTIONS WITH GREATEST Q WITHOUT CORRECTION
      CALL DEPAK (IHAQ,IFLAG(7),IFLAG(8),IFLAG(9))
      CALL DEPAK (IHAQL,IFLAG(10),IFLAG(11),IFLAG(12))
C
CHB   PRINT 1770,ICHAR(DUMM),ICHAR(DUMM+1)
      WRITE(IO,1770)ICHAR(DUMM),ICHAR(DUMM+1)
 1770 FORMAT(5(/),1X,8HQ-VALUES/1X,8(1H-)//53X,5HWITH ,2A3,
     &15HTION CORRECTION,16X,18HWITHOUT CORRECTION/1H )
CHB   PRINT 1771,BU(30),(IFLAG(I),I=1,3),BU(34),(IFLAG(I),I=7,9),
CHB  &BU(31),(IFLAG(I),I=4,6),BU(36),(IFLAG(I),I=10,12),
CHB  &(BU(I),I=90,95)
      WRITE(IO,1771)BU(30),(IFLAG(I),I=1,3),BU(34),(IFLAG(I),I=7,9),
     &BU(31),(IFLAG(I),I=4,6),BU(36),(IFLAG(I),I=10,12),
     &(BU(I),I=90,95)
 1771 FORMAT(18X,9HMAXIMUM Q,9X,6HNOT LT,
     &8X,F10.2,4X,10HFOR HKL = ,3I4,9X,F10.2,4X,10HFOR HKL = ,3I4//
     &40X,2HLT,8X,F10.2,4X,10HFOR HKL = ,3I4,9X,F10.2,4X,10HFOR HKL = ,
     &3I4,2(/),18X,24HMEAN ABSOLUTE VALUE OF Q//37X,5HTOTAL,12X,
     &F6.2,32X,F10.2//36X,6HNOT LT,8X,F10.2,32X,F10.2//40X,2HLT,8X,
     &F10.2,32X,F10.2)
      IF (MODU .NE. 0) GO TO 1811
      IF (MODU .EQ. 0) GO TO 1776
C
C---- MEAN ABSOLUT VALUES OF Q WHEN AVERAGING FRIEDEL-REFLECTIONS
C---- WITHOUT CORRECTION
 1775 BU (61) = (BU (45) + BU (47)) / FLOAT (IREF (19))
      BU (63) = BU (45) / FLOAT (IREF (19) - IREF (21))
      IF (IREF (21) .NE. 0) BU (65) = BU (47) / FLOAT (IREF (21))
C
C---- HKL OF THE REFLECTIONS WITH MAXIMUM Q BEI WHEN AVERAGING FRIEDEL-
C---- REFLECTIONS WITHOUT CORRECTION
      CALL DEPAK (IREF (16),IFLAG(19),IFLAG(20),IFLAG(21))
      CALL DEPAK (IREF (17),IFLAG(22),IFLAG(23),IFLAG(24))
C
CHB   PRINT 1813,
      WRITE(IO,1813)
CHB   PRINT 1771,BU(40),(IFLAG(I),I=13,15),BU(44),(IFLAG(I),I=19,21),
CHB  &BU(41),(IFLAG(I),I=16,18),BU(46),(IFLAG(I),I=22,24),(BU(I),
CHB  &I=60,65)
      WRITE(IO,1771)BU(40),(IFLAG(I),I=13,15),BU(44),(IFLAG(I),I=19,21),
     &BU(41),(IFLAG(I),I=16,18),BU(46),(IFLAG(I),I=22,24),(BU(I),
     &I=60,65)
CHB76 PRINT 1780,BU(1),INTERQ(1),INTRQA(1),((BU(I-1),BU(I),
CHB  &INTERQ(I),INTRQA(I)),I=2,23),BU(23),INTERQ(24),INTRQA(24)
 1776 WRITE(IO,1780)BU(1),INTERQ(1),INTRQA(1),(BU(I-1),BU(I),
     &INTERQ(I),INTRQA(I),I=2,23),BU(23),INTERQ(24),INTRQA(24)
 1780 FORMAT(1H1,18X,44HDISTRIBUTION OF REFLECTIONS INTO Q-INTERVALS//
     &29X,10HQ-INTERVAL,21X,37HNUMBER OF REFLECTIONS IN THE INTERVAL//
     &25X,4HFROM,10X,2HTO//
     &24X,7HSMALLER,6X,F5.1,11X,I5,37X,I5,/,22(24X,F5.1,8X,
     &F5.1,11X,I5,37X,I5,/),24X,7HGREATER,6X,F5.1,11X,I5,37X,I5)
CHB   PRINT 1781,ICHAR(DUMM),ICHAR(DUMM+1)
      WRITE(IO,1781)ICHAR(DUMM),ICHAR(DUMM+1)
 1781 FORMAT(4(/),18X,36HNUMBER OF REFLECTIONS FOR WHICH THE ,2A3,
     &54HTION CORRECTION INCREASED THE SUM OF ABSOLUTE Q-VALUES//
     &54X,6HNOT LT,14X,2HLT/1H )
CHB   IF (MODU .GT. 1) PRINT 1930,IREF(11),IREF (33)
      IF (MODU .GT. 1) WRITE(IO,1930)IREF(11),IREF (33)
CHB   PRINT 1940,IREF(24),IREF(31)
      WRITE(IO,1940)IREF(24),IREF(31)
C---- CALCULATE STATISTICAL R-FACTORS
C
      RSTA = TWOP*(RSTA1+RSTA3)/(RSTA2+RSTA4)
      RSTAA = TWOP*RSTA1/RSTA2
      RSTAB = TWOP*RSTA3/RSTA4
      WRITE(IO,1849) RSTA,RSTAA
 1849 FORMAT(4(/),1X,19HSTATISTICAL R-VALUE,/,1X,19(1H-),//,18X,
     &15HALL REFLECTIONS ,21X,F6.4,//,18X,6HNOT LT,30X,F6.4,/)
CHB   PRINT 1850,ICHAR(DUMM),ICHAR(DUMM+1),BU(73),BU(76),BU(74),BU(77),
CHB  &BU(75),BU(78)
      WRITE(IO,1850)ICHAR(DUMM),ICHAR(DUMM+1),BU(73),BU(76),BU(74),
     &BU(77),BU(75),BU(78)
 1850 FORMAT(1H1,16HINTERNAL R-VALUE/1X,16(1H-)//54X,5HWITH ,2A3,
     &15HTION CORRECTION,16X,18HWITHOUT CORRECTION//18X,15HALL REFLECTIO
     &NS,21X,F6.4,36X,F6.4//18X,6HNOT LT,30X,F6.4,36X,F6.4//18X,
     &2HLT,34X,F6.4,36X,F6.4)
C
C---- HKL FOR THE REFLECTIONS WITH THE MAXIMUM R-VALUES
      CALL DEPAK (IREF(27),IFLAG(13),IFLAG(14),IFLAG(15))
      CALL DEPAK (IREF(28),IFLAG(16),IFLAG(17),IFLAG(18))
      CALL DEPAK (IREF(29),IFLAG(19),IFLAG(20),IFLAG(21))
      CALL DEPAK (IREF(30),IFLAG(22),IFLAG(23),IFLAG(24))
C
      DO 1865 I=12,23
 1865 BU(I) = BU(I)/100.
CHB   PRINT 1860,BU(66),(IFLAG(I),I=13,15),BU(68),(IFLAG(I),I=19,21),
CHB  &BU(67),(IFLAG(I),I=16,18),BU(69),(IFLAG(I),I=22,24)
      WRITE(IO,1860)BU(66),(IFLAG(I),I=13,15),BU(68),(IFLAG(I),I=19,21),
     &BU(67),(IFLAG(I),I=16,18),BU(69),(IFLAG(I),I=22,24)
 1860 FORMAT(3(/),18X,15HMAXIMUM R-VALUE,8X,6HNOT LT,7X,F6.4,4X,
     &10HFOR HKL = ,3I4,13X,F6.4,4X,10HFOR HKL = ,3I4//45X,2HLT,7X,
     &F6.4,4X,10HFOR HKL = ,3I4,13X,F6.4,4X,10HFOR HKL = ,3I4)
CHB   PRINT 1870,((BU(I),BU(I+1),IRINT(I-11),IRINTO(I-11)),
CHB  &I = 12,22),BU(23),IRINT(12),IRINTO(12)
      WRITE(IO,1870)(BU(I),BU(I+1),IRINT(I-11),IRINTO(I-11),
     &I = 12,22),BU(23),IRINT(12),IRINTO(12)
      DO 1866 I=12,23
 1866 BU(I)=BU(I)*100.
 1870 FORMAT(4(/),18X,44HDISTRIBUTION OF REFLECTIONS INTO R-INTERVALS//
     &28X,10HR-INTERVAL,22X,37HNUMBER OF REFLECTIONS IN THE INTERVAL//
     &23X,4HFROM,10X,2HTO//11(23X,F6.4,8X,F6.4,10X,I5,37X,I5/),23X,
     &7HGREATER,7X,F6.4,10X,I5,37X,I5)
CHB   PRINT 1880,ICHAR(DUMM),ICHAR(DUMM+1),IREF(26),IREF(32)
      WRITE(IO,1880)ICHAR(DUMM),ICHAR(DUMM+1),IREF(26),IREF(32)
 1880 FORMAT(4(/),18X,36HNUMBER OF REFLECTIONS FOR WHICH THE ,2A3,
     &37HTION CORRECTION INCREASED THE R-VALUE//18X,6HNOT LT,
     &29X,I5//18X,2HLT,33X,I5/1H )
      WRITE(IO,1882)
 1882 FORMAT(1H1)
      GO TO 1900
CHB00 PRINT 1809,
 1800 WRITE(IO,1809)
 1809 FORMAT(5(/),1X,8HQ-VALUES/1X,8(1H-)/1H )
CHB   PRINT 1810,BU(30),(IFLAG(I),I=1,3),BU(31),(IFLAG(I),I=4,6),
CHB  &(BU(I),I=90,94,2)
      WRITE(IO,1810)BU(30),(IFLAG(I),I=1,3),BU(31),(IFLAG(I),I=4,6),
     &(BU(I),I=90,94,2)
 1810 FORMAT(18X,9HMAXIMUM Q,9X,6HNOT LT,
     &8X,F10.2,4X,10HFOR HKL = ,3I4//40X,2HLT,8X,F10.2,4X,
     &10HFOR HKL = ,3I4,3(/),18X,24HMEAN ABSOLUTE VALUE OF Q//
     &37X,5HTOTAL,8X,F10.2//36X,6HNOT LT,8X,F10.2//40X,2HLT,8X,F10.2)
      IF (MODU .EQ. 0) GO TO 1819
 1811 IF (IREF (18) .EQ. 0) GO TO 1821
C
C---  HKL OF THE REFLECTIONS WITH THE MAXIMUM Q WHEN AVERAGING
C---- IDENTICAL REFLECTIONS
      CALL DEPAK (IREF(13),IFLAG(13),IFLAG(14),IFLAG(15))
      CALL DEPAK (IREF(15),IFLAG(16),IFLAG(17),IFLAG(18))
C
C---- MEAN ABSOLUSTE VALUES OF Q WHEN AVERAGING IDENTICAL REFLECTIONS
      BU (70) = (BU (52) + BU (53)) / FLOAT (IREF (18))
      BU (71) = BU (52) / FLOAT (IREF (18) - IREF (20))
      IF (IREF (20) .NE. 0) BU (72) = BU (53) / FLOAT (IREF (20))
C
CHB   PRINT 1812,
      WRITE(IO,1812)
 1812 FORMAT(3(/),18X,36HWHEN AVERAGING IDENTICAL REFLECTIONS/1H )
CHB   PRINT 1810,BU(50),(IFLAG(I),I=13,15),BU(51),(IFLAG(I),I=16,18),
CHB  &(BU(I),I=70,72)
      WRITE(IO,1810)BU(50),(IFLAG(I),I=13,15),BU(51),(IFLAG(I),I=16,18),
     &(BU(I),I=70,72)
 1821 IF (MODU .EQ. 1) GO TO 1819
      IF (IREF (19) .EQ. 0) GO TO 1819
C
C---- HKL FOR REFLECTIONS WITH MAXIMUM Q WHEN AVERAGING FRIEDEL REFL.
      CALL DEPAK (IREF(12),IFLAG(13),IFLAG(14),IFLAG(15))
      CALL DEPAK (IREF(14),IFLAG(16),IFLAG(17),IFLAG(18))
C
C---- MEAN ABSOLUTE Q-VALUES WHEN AVERAGING FRIEDEL REFLECTIONS
      BU (60) = (BU (42) + BU (43)) / FLOAT (IREF (19))
      BU (62) = BU (42) / FLOAT (IREF (19) - IREF (21))
      IF (IREF (21) .NE. 0) BU (64) = BU (43) / FLOAT (IREF (21))
      IF (IABSO .GT. 0 .OR. IKART .NE. 0) GO TO 1775
C
CHB   PRINT 1813,
      WRITE(IO,1813)
 1813 FORMAT(3(/),18X,30HWHEN AVERAGING FRIEDEL-REFLEXE/1H )
CHB   PRINT 1810,BU(40),(IFLAG(I),I=13,15),BU(41),(IFLAG(I),I=16,18),
CHB  &(BU(I),I=60,64,2)
      WRITE(IO,1810)BU(40),(IFLAG(I),I=13,15),BU(41),(IFLAG(I),I=16,18),
     &(BU(I),I=60,64,2)
 1819 IF (IABSO .GT. 0 .OR. IKART .NE. 0) GO TO 1776
CHB   PRINT 1820,BU(1),INTERQ(1),((BU(I-1),BU(I),INTERQ(I)),
CHB  &I=2,23),BU(23),INTERQ(24)
      WRITE(IO,1820)BU(1),INTERQ(1),(BU(I-1),BU(I),INTERQ(I),
     &I=2,23),BU(23),INTERQ(24)
 1820 FORMAT(1H1,18X,44HDISTRIBUTION OF REFLECTIONS INTO Q-INTERVALS//
     &59X,10HQ-INTERVAL,16X,37HNUMBER OF REFLECTIONS IN THE INTERVAL//
     &56X,4HFROM,8X,2HTO//54X,7HSMALLER,6X,F5.1,16X,I5/22(54X,F5.1,8X,
     &F5.1,16X,I5/),54X,7HGREATER,6X,F5.1,16X,I5)
C---- CALCULATE STATISTICAL R-FACTORS
C
      RSTA = TWOP*(RSTA1+RSTA3)/(RSTA2+RSTA4)
      RSTAA = TWOP*RSTA1/RSTA2
      RSTAB = TWOP*RSTA3/RSTA4
      WRITE(IO,1849) RSTA,RSTAA
CHB   PRINT 1822,(BU(I),I=73,75)
      WRITE(IO,1822)(BU(I),I=73,75)
 1822 FORMAT(3(/),1X,16HINTERNAL R-VALUE/1X,16(1H-)//18X,15HALL REFLECTI
     &ONS,22X,F6.4//18X,6HNOT LT,31X,F6.4//18X,2HLT,35X,F6.4)
C
C---- HKL FOR THE REFLECTIONS WITH THE MAXIMUM R-VALUE
      CALL DEPAK (IREF (27),IFLAG(13),IFLAG(14),IFLAG(15))
      CALL DEPAK (IREF (28),IFLAG(16),IFLAG(17),IFLAG(18))
C
CHB   PRINT 1823,BU(66),(IFLAG(I),I=13,15),BU(67),(IFLAG(I),I=16,18)
      WRITE(IO,1823)BU(66),(IFLAG(I),I=13,15),BU(67),(IFLAG(I),I=16,18)
 1823 FORMAT(3(/),18X,15HMAXIMUM R-VALUE,8X,6HNOT LT,8X,F6.4,4X,
     &10HFOR HKL = ,3I4//45X,2HLT,8X,F6.4,4X,10HFOR HKL = ,3I4)
      DO 1826 I=12,23
 1826 BU(I) = BU(I)/100.
CHB   PRINT 1824,((BU(I),BU(I+1),IRINT(I-11)),I=12,22),
CHB  &BU(23),IRINT(12)
      WRITE(IO,1824)(BU(I),BU(I+1),IRINT(I-11),I=12,22),
     &BU(23),IRINT(12)
      DO 1825 I=12,23
 1825 BU(I) = BU(I)*100.
 1824 FORMAT(1H1,18X,44HDISTRIBUTION OF REFLECTIONS INTO R-INTERVALS//
     &58X,10HR-INTERVAL,17X,37HNUMBER OF REFLECTIONS IN THE INTERVAL//
     &53X,4HFROM,10X,2HTO//
     &11(53X,F6.4,8X,F6.4,15X,I5/),54X,7HGREATER,6X,F6.4,15X,I5)
 1900 IF (IREJEC) 1901,1950,1901
 1901 IREJEC = IABS (IREJEC)
CHB   PRINT 1910,
      WRITE(IO,1910)
 1910 FORMAT(5(/),1X,36HNUMBER OF REJECTED REFLECTIONS (REJ)/1X,36(1H-)/
     &1H )
      IF (IREJEC .EQ. 3) GO TO 1921
CHB   IF (MODU .GT. 0 .AND. MODU .NE. 3) PRINT 1920,IREF(5)
      IF (MODU .GT. 0 .AND. MODU .NE. 3) WRITE(IO,1920)IREF(5)
 1920 FORMAT(18X,21HIDENTICAL REFLECTIONS,14X,I5/1H )
CHB   IF (MODU .GT. 1) PRINT 1930,IREF(6)
      IF (MODU .GT. 1) WRITE(IO,1930)IREF(6)
 1930 FORMAT(18X,19HFRIEDEL REFLECTIONS,16X,I5,13X,I5/1H )
CHB21 IF (IREJEC .NE. 2) PRINT 1940,IREF(7)
 1921 IF (IREJEC .NE. 2) WRITE(IO,1940)IREF(7)
 1940 FORMAT(18X,14HMAIN AVERAGING,21X,I5,13X,I5/1H )
CHB   PRINT 1949
      WRITE(IO,1949)
 1949 FORMAT(4(/),1X,48HNUMBER OF GROUPS OF WHICH ALL BUT ONE REFLECTION
     &,20H WERE REJECTED (ONE)/1X,68(1H-)/1H )
      IF (IREJEC .EQ. 3) GO TO 1948
CHB   IF (MODU .GT. 0 .AND. MODU .NE. 3) PRINT 1920,IREF(8)
      IF (MODU .GT. 0 .AND. MODU .NE. 3) WRITE(IO,1920)IREF(8)
CHB   IF (MODU .GT. 1) PRINT 1930,IREF(9)
      IF (MODU .GT. 1) WRITE(IO,1930)IREF(9)
CHB48 IF (IREJEC .NE. 2)PRINT 1940,IREF(10)
 1948 IF (IREJEC .NE. 2)WRITE(IO,1940)IREF(10)
      IF (NOR .EQ. 3) GO TO 1950
CHB   PRINT 1951,
      WRITE(IO,1951)
 1951 FORMAT(4(/),1X,36HNUMBER OF REJECTED MEAN VALUES (NOR)/1X,36(1H-)/
     &1H )
      IF (NOR .GT. 1 .OR. IREJEC .EQ. 3) GO TO 1952
CHB   IF (MODU .GT. 0 .AND. MODU .NE. 3) PRINT 1920,IREF(8)
      IF (MODU .GT. 0 .AND. MODU .NE. 3) WRITE(IO,1920)IREF(8)
CHB   IF (MODU .GT. 1) PRINT 1930,IREF(9)
      IF (MODU .GT. 1) WRITE(IO,1930)IREF(9)
CHB52 IF (NOR.EQ.0.OR. NOR .EQ. 2 .AND. IREJEC.NE.2)PRINT 1940,IREF(10)
 1952 IF (NOR.EQ.0.OR. NOR .EQ.2.AND. IREJEC.NE.2)WRITE(IO,1940)IREF(10)
CHB50 PRINT 1960,((BU(I),BU(I+1),INTERV(I-11)),I=12,22),
CHB  &BU(23),INTERV(12)
 1950 WRITE(IO,1960)(BU(I),BU(I+1),INTERV(I-11),I=12,22),
     &BU(23),INTERV(12)
 1960 FORMAT(5(/),1X,64HDISTRIBUTION OF REFLECTIONS INTO INTERVALS OF MU
     &LTIPLES OF SIGMA/1X,64(1H-)/1X,27H(ONLY AVERAGED REFLECTIONS)//
     &45X,34HINTERVALL (INTENSITY/SIGMA COUNT.),7X,16HNUMBER OF REFLEC,
     &21HTIONS IN THE INTERVAL//11(54X,F5.1,3X,3H TO,2X,
     &F5.1,16X,I5/),55X,7HGREATER,5X,F5.1,16X,I5)
C+++++ILL-SPECIFIC++++++++++++++++++++++++++++++++++++++++++++++++++++++
      WRITE(*,1962) RSTA,BU(73)
 1962 FORMAT(//,1X,'STATISTICAL R-VALUE  ',F6.4,/,
     &          1X,'INTERNAL R-VALUE     ',F6.4,//)
      write(iounit,1999)
 1999 format(3HEND)
	open(unit=3,status='new')
	write(3,1997)
1997	format('   ')
	write(3,1998)
1998	format('hier kommt der Titel hin!')
	write(3,1963) rsta,bu(73)
 1963 FORMAT(1X,'STATISTICAL R-VALUE  ',F6.4,/,
     &       1X,'INTERNAL R-VALUE     ',F6.4,/)
	close(3)
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      IF (BU(39)) 2000,2000,1965
C
C---- MEAN VALUE OF TBAR
 1965 BU(39) = BU(39) / FLOAT (IREF(22))
C
C---- HKL FOR THE REFLECTIONS WITH EXTREM VALUES OF TBAR
      CALL DEPAK (IHTMX,IFLAG(1),IFLAG(2),IFLAG(3))
      CALL DEPAK (IHTMN,IFLAG(4),IFLAG(5),IFLAG(6))
C
CHB   PRINT 1970,BU(38),(IFLAG(I),I=1,3),BU(29),(IFLAG(I),I=4,6),BU(39)
      WRITE(IO,1970)BU(38),(IFLAG(I),I=1,3),BU(29),(IFLAG(I),I=4,6),
     &BU(39)
 1970 FORMAT(5(/),1X,4HTBAR/1X,4(1H-),/,18X,13HMAXIMUM VALUE,4X,F9.5,5X,
     &10HFOR HKL = ,3I4/18X,13HMINIMUM VALUE,4X,F9.5,5X,10HFOR HKL = ,
     &3I4/18X,10HMEAN VALUE,7X,F9.5)
 2000 RETURN
      END
C
C
                       SUBROUTINE IDENT
     & (IO,MAXLIN,MODUS,ISMAX,AHKL,AF,ASF,SASF,ATBAR,ACKOF,NUMORA,
     & IFLAG,ICV)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C +                                                                    +
C + SUBROUTINE WHICH AVERAGES IDENTICAL OR FRIEDEL REFLECTIONS OR      +
C + IDENTICAL PLUS FRIEDEL REFLECTIONS                                 +
C + WRITTEN BY EGBERT PERENTHALER MPI-FKF (1978)                       +
C +                                                                    +
C + (LAST UPDATE  DEZEMBER 1980)                                       +
C +                                                                    +
C + THIS PROGRAMME IS CALLED BY THE SUBROUTINE  AVERA2                 +
C +                                                                    +
C + THIS PROGRAMME CALLS THE SUBROUTINES  IPACK, DEPACK, REDIF, AND    +
C + ZUVIEL                                                             +
C +                                                                    +
C + IN CASE OF AN OVERLAY STRUCTURE IT IS PART OF THE OVERLAY  AVER2   +
C +                                                                    +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C---- TYPE STATEMENTS
C     ---------------
C
      INTEGER H,ANUMI,AHKL,AEH,AEK,AEL
      CHARACTER*5  IPRFF,IPRF
C
C---- DIMENSION STATEMENTS
C     --------------------
C
      DIMENSION AHKL(ISMAX),AF(ISMAX),ASF(ISMAX),SASF(ISMAX),ATBAR(ISMAX
     &),ACKOF(ISMAX),NUMORA(ISMAX),IFLAG(ISMAX)
C
      DIMENSION AFI(500),ASFI(500),SASFI(500),ATBARI(500),
     &          ACKOFI(500),NUMORI(500),IHKL(500),IPRFF(2)
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)
     &,ISCGR
C
      COMMON /BD/ ICHAR(18),IRMT(21),IPRFF
C
      COMMON /C4/ BU(100),IREF(36),ILAG,MULT,ILINE,KENNZ,IEND,LK
C
C---- INITIALISE
C     ----------
C
C***********************************************************************
C     VARIABLE IFMAX TO CHECK THE OVERFLOW OF THE SUBSCRIPT OF THE
C     ARRAYS IN THE DIMENSION STATEMENT ABOVE
C
      IFMAX = 500
C
C***********************************************************************
C
C----  SOME VARIABLES TO COUNT REFLECTIONS
      MULNEU = 0
      ANUMI = 1
      IZAHLI = 0
   01 MULTI = 0
C
C---- EXTRACT IDENTICAL RESP. FRIEDEL REFLECTIONS
C
      DO 100 I = ANUMI,MULT
      IF (AHKL (I) .EQ. 111) GO TO 100
      IRHKL = AHKL (I)
      IF (MODUS .LT. 2) GO TO 5
      CALL DEPAK (AHKL(I),H,K,L)
      CALL REDIF (H,K,L,AEH,AEK,AEL)
      IRHKL = IPACK (AEH,AEK,AEL)
    5 IF (MULTI .NE. 0) GO TO 10
      IDHKL = IRHKL
      ANUMI = I + 1
      MULNEU = MULNEU + 1
   10 IF (IRHKL .NE. IDHKL) GO TO 100
      MULTI = MULTI + 1
      IZAHLI = IZAHLI + 1
      IHKL(MULTI) = AHKL (I)
      AHKL (I) = 111
      AFI (MULTI) = AF (I)
      ASFI (MULTI) = ASF (I)
      SASFI (MULTI) = SASF (I)
      ATBARI (MULTI) = ATBAR (I)
      ACKOFI (MULTI) = ACKOF (I)
      NUMORI(MULTI) = NUMORA(I)
      IF (MULTI .GT. IFMAX) CALL ZUVIEL (IO,IFMAX,3)
  100 CONTINUE
      IF (MULTI .GT. 1) GO TO 200
C
C***  UEBERGABE DER WERTE WENN NUR EIN REFLEX GEFUNDEN WURDE
      AHKL (MULNEU) = IDHKL
      AF (MULNEU) = AFI (1)
      ASF (MULNEU) = ASFI (1)
      SASF (MULNEU) = SASFI (1)
      ATBAR (MULNEU) = ATBARI (1)
      ACKOF (MULNEU) = ACKOFI (1)
      NUMORA(MULNEU) = NUMORI(1)
      IREF (MODUS) = IREF (MODUS) + 1
      IF (AFI (1) .LT. SIGLT * ASFI (1)) IREF (MODUS + 2) =
     &IREF (MODUS + 2) + 1
      IF (IZAHLI .EQ. MULT) GO TO 500
      GO TO 01
  200 IF (ILINE + MULTI + 6 .LE. MAXLIN) GO TO 220
C
C---- HEADLINE OF A PAGE OF THE REFLECTION LIST
      IF (ILIST .EQ. 1) GO TO 243
      ILINE = 2
      KENNZ = 7
      IEND = 7
      IPRF = IPRFF(2)
      IF(ICV.EQ.0) IPRF=IPRFF(1)
      IF (IREJEC) 201,202,201
  201 KENNZ = 10
      IEND = 11
  202 IF (IABSO .GT. 0 .OR. IKART .NE. 0) GO TO 210
      WRITE (IO,209) IPRF,ICHAR(KENNZ),ICHAR(IEND)
  209 FORMAT (1H1,A5,12H   H   K   L,7X,1HI,2X,8HSIGMA(I),1X,
     &5HCOUNT,2X,3HSYS,2X,4HSTAT,6X,1HQ,5X,1HP,3X,A3,4X,2HLT,5X,A3,//)
      GO TO 220
  210 WRITE (IO,211) IPRF,ICHAR(KENNZ),ICHAR(IEND),ICHAR(17)
  211 FORMAT (1H1,A5,12H   H   K   L,7X,1HI,2X,8HSIGMA(I),1X,
     &5HCOUNT,2X,3HSYS,2X,4HSTAT,6X,1HQ,5X,1HP,2X,A3,7X,2HIO,7X,2HQO,
     &6X,4HQ/QO,2X,3HBAD,4X,2HGR,5X,2HLT,3X,A3,1H/,A3,//)
  220 IF (MODU .EQ. 3) GO TO 251
C
C***  KENNZEICHNUNG DER MITTELUNG IDENTISCHER REFLEXE IM OUTPUT
      IF (ILAG .EQ. 1 .OR. MODUS .EQ. 2) GO TO 240
      WRITE (IO,230)
  230 FORMAT (1X,31HAVERAGING IDENTICAL REFLECTIONS)
      ILAG = 1
      ILINE = ILINE + 1
C
C***  KENNZEICHNUNG DER MITTELUNG VON FRIEDEL REFLEXEN
  240 IF (ILAG .EQ. 2 .OR. MODUS .NE. 2) GO TO 242
      WRITE (IO,241)
  241 FORMAT(1X,29HAVERAGING FRIEDEL REFLECTIONS)
      ILAG = 2
      ILINE = ILINE + 1
      GO TO 242
C
C***  KENNZEICHNUNG DER MITTELUNG VON IDENTISCHEN UND FRIEDEL-REFLEXEN
  251 IF (ILAG .EQ. 3) GO TO 242
      WRITE (IO,252)
  252 FORMAT(1X,47HAVERAGING OF IDENTICAL PLUS FRIEDEL REFLECTIONS)
      ILAG = 3
C
C***  ZEILENZAEHLEN
      ILINE = ILINE + 1
  242 ILINE = ILINE + MULTI + 2
C
C***  INITIALISIEREN VON PARAMETERN
  243 NOREF = 0
      P = 0.
      DO 250 I = 1,MULTI
  250 IFLAG (I) = 0
C
C***  AUFSUMMIEREN DER ZU MITTELNDEN REFLEXDATEN
C
  260 I = 1
  270 IF (IFLAG(I) .EQ. 0) GO TO 290
      IF (I .EQ. MULTI) GO TO 280
      I = I + 1
      GO TO 270
  280 NOREF = 1
      GO TO 350
C***  ABSPEICHERN DER WERTE DES ERSTEN REFLEXES
  290 IBEI = 1
      AFS = AFI (I)
      ASFS = ASFI (I) ** 2
      SASFS = SASFI (I)
      ATBARS = ATBARI (I)
      ATBRCS = ACKOFI (I)
      SFMAX = ASFI (I)
      FMAX = AFI (I)
      IF (IABSO .GT. 0) FALT = AFI (I) / ACKOFI (I)
      IF (IKART .NE. 0) FALT = AFI (I) * ACKOFI (I)
      IF (I .EQ. MULTI) GO TO 310
C***  ADDITION DER RESTLICHEN DATEN
      DO 300 J = I + 1,MULTI
      IF (IFLAG (J) .EQ. 1) GO TO 300
      IBEI = IBEI + 1
      AFS = AFS + AFI (J)
      ASFS = ASFS + ASFI (J) ** 2
      SASFS = SASFS + SASFI (J)
      ATBARS = ATBARS + ATBARI (J)
      ATBRCS = ATBRCS + ACKOFI (J)
      IF (AFI (I) .GT. FMAX) SFMAX = ASFI (I)
      IF (AFI (I) .GT. FMAX) FMAX = AFI (I)
      IF (IABSO .GT. 0) FALT = FALT + AFI (J) / ACKOFI (J)
      IF (IKART .NE. 0) FALT = FALT + AFI (J) * ACKOFI (J)
  300 CONTINUE
C
C***  BERECHNUNG DER MITTELWERTE
C
  310 AFS = AFS / FLOAT (IBEI)
      ASFS = SQRT (ASFS) / FLOAT (IBEI)
      SASFS = SASFS / FLOAT (IBEI)
      FALT = FALT / FLOAT (IBEI)
      ATBARS = ATBARS / FLOAT (IBEI)
      ATBRCS = ATBRCS / FLOAT (IBEI)
      SFS = SASFS + ASFS
      IF (IREJEC .EQ. 3) GO TO 350
C
C---- SHOULD A REFLECTION BE REJECTED
C
      IF (IREJEC) 331,350,329
  329 P = 0.
      DO 330 I = 1,MULTI
      IF (IFLAG (I) .EQ. 1) GO TO 330
      Q = ABS (AFI (I) - AFS) / (ASFI (I) + SASFI (I))
      IF (Q .GT. P) ISETZ = I
      IF (Q .GT. P) P = Q
  330 CONTINUE
      IF (P .LT. REJE) GO TO 350
      IFLAG (ISETZ) = 1
      GO TO 260
  331 IF (P .GT. 1) GO TO 350
      DO 332 I = 1,MULTI
      IF (AFI (I) .GT. FMAX - REJE * SFMAX) GO TO 332
      IFLAG (I) = 1
      P = 2.
  332 CONTINUE
      IF (P .GT. 1) GO TO 260
C
C---- WERE THERE ALL BUT ONE REJECTED
  350 IF (IBEI .EQ. 1 .AND. MULTI .GT. 1) NOREF = 1
C
C---- HOW MANY REFLECTIONS WERE REJECTED
      IF (MODUS .EQ. 1) IREF (5) = IREF (5) + MULTI - IBEI
      IF (MODUS .EQ. 2) IREF (6) = IREF (6) + MULTI - IBEI
C
C---- INITIALISE SOME VARABLES
      BU (48) = 0.
      BU (49) = 0.
      LT = 1
      IF (AFS .LT. SIGLT * ASFS) LT = 2
C
C---- PREPARE THE PRINTING OF A GROUP OF REFLECTIONS AND MAKE SOME
C---- STATISTICS
C
      DO 1700 I = 1,MULTI
C
C---- COUNT THE REFLECTIONS AFTER THE PREAVERAGING
      IREF (17 + MODUS) = IREF (17 + MODUS) + 1
      IF (AFI (I) .LT. SIGLT * ASFI (I)) IREF (19 + MODUS) =
     &IREF (19 + MODUS) + 1
C
      Q = (AFI (I) - AFS) / (ASFI (I) + SASFI (I))
      P = (AFI (I) - AFS) / AFS * 100.
      IF (MODUS .EQ. 1) GO TO 1642
      IF (IABSO .GT. 0) GO TO 1641
      IF (IKART .EQ. 0) GO TO 1642
C
C---- VALUES WITHOUT EXTINCTION CORRECTION
      FON = AFI (I) * ACKOFI (I)
      QALT = (FON - FALT) / (ASFI (I) + SASFI (I)) / ACKOFI (I)
      GO TO 1642
C
C---- VALUES WITHOUT ABSORPTION CORRECTION
 1641 FON = AFI (I) / ACKOFI (I)
      QALT = (FON - FALT) / (ASFI (I) + SASFI (I)) * ACKOFI (I)
C
C---- REFLECTIONS WITH THE MAXIMUM Q-VALUES DURING THE PREAVERAGING
C---- PROCESS AND SOME SUMS OVER ABSOLUTE VALUES OF Q
 1642 IF (LT .EQ. 1) GO TO 1650
      IF (ABS (Q) .LT. ABS (BU(61-10*MODUS))) GO TO 1643
      BU(61-10*MODUS) = Q
      IREF(16-MODUS) = IHKL (I)
 1643 BU(63-10*MODUS) = BU(63-10*MODUS) + ABS (Q)
      IF (MODUS .EQ. 1) GO TO 1660
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1660
      IF (ABS (QALT) .LT. ABS (BU(46))) GO TO 1644
      BU(46) = QALT
      IREF(17) = IHKL (I)
 1644 BU(47) = BU(47) + ABS (QALT)
      GO TO 1660
 1650 IF (ABS (Q) .LT. ABS (BU(60-10*MODUS))) GO TO 1651
      BU(60-10*MODUS) = Q
      IREF(14-MODUS) = IHKL (I)
 1651 BU(62-10*MODUS) = BU(62-10*MODUS) + ABS (Q)
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1660
      IF (ABS (QALT) .LT. ABS (BU(44))) GO TO 1652
      BU(44) = QALT
      IREF (16) = IHKL (I)
 1652 BU(45) = BU(45) + ABS (QALT)
C
C---- SOME PREPARATIONS FOR PRINTED OUTPUT
 1660 CALL DEPAK (IHKL (I),H,K,L)
      IF (IFLAG (I) .EQ. 1) KENNZ = 10
      IF (IFLAG (I) .EQ. 0) KENNZ = 7
      IF (MODUS .EQ. 1) GO TO 1612
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1612
C
C---- SUMS OVER ABSOLUTE VALUES OF Q FOR THE GROUP OF REFLECTIONS
      BU(48) = BU(48) + ABS (Q)
      BU(49) = BU(49) + ABS (QALT)
C
C---- PRINT ONE REFLECTION
      IF (ILIST .EQ. 1) GO TO 1700
      WRI = ASFI(I) + SASFI(I)
      IF(ICV.EQ.1)WRITE(IO,1611)H,K,L,AFI(I),WRI,ASFI(I),SASFI(I),Q,P,
     &ICHAR(KENNZ),FON,QALT
 1611 FORMAT (7X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2(1X,F5.0),1X,A3,1X,
     &2F9.0)
      IF(ICV.EQ.0)WRITE(IO,1613)NUMORI(I),H,K,L,AFI(I),WRI,ASFI(I),
     &SASFI(I),Q,P,ICHAR(KENNZ),FON,QALT
 1613 FORMAT (1X,I5,1X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2(1X,F5.0),1X,A3,
     &1X,2F9.0)
      GO TO 1700
 1612 IF (ILIST .EQ. 1) GO TO 1700
      WRI = ASFI(I)+SASFI(I)
      IF(ICV.EQ.1)WRITE(IO,1610)H,K,L,AFI(I),WRI,ASFI(I),SASFI(I),Q,P,
     &ICHAR(KENNZ)
 1610 FORMAT (7X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2(1X,F5.0),2X,A3)
      IF(ICV.EQ.0)WRITE(IO,1615)NUMORI(I),H,K,L,AFI(I),WRI,ASFI(I),
     &SASFI(I),Q,P,ICHAR(KENNZ)
 1615 FORMAT (1X,I5,1X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,9X,2(1X,F5.0),2X,A3)
 1700 CONTINUE
C
C---- PREPARE PRINTING OF A MEAN VALUE AND SOME MORE STATISTICS
C
C---- HKL FOR THE MEAN VALUE
      CALL DEPAK (IDHKL,H,K,L)
C
C---- PREPARATIONS FOR THE PRINTED OUTPUT
      LK = 7
      IF (LT .EQ. 2) LK = 12
      KENNZ = 7
      IF (NOREF .EQ. 1) KENNZ = 11
      IF(NOREF .EQ. 1 .AND. NOR .LT. 2) KENNZ = 17
      IF (MODUS .EQ. 1) GO TO 1713
      IF (IABSO .LE. 0 .AND. IKART .EQ. 0) GO TO 1713
      IBAD = 7
C
C---- HAS THE CORRECTION INCREASED THE Q-VALUES
      IF (BU (49) .LT. 1.E-6) BU (49) = 1.E-6
      IF (BU(48) / BU(49) .GT. 1.) IBAD = 16
      IF (BU(48) /BU(49) .LT. 1.0001) GO TO 1709
      IF (LT .EQ. 1) IREF (11) = IREF (11) + 1
      IF (LT .EQ. 2) IREF (33) = IREF (33) + 1
C
C---- PRINT A MEAN VALUE
 1709 IF (ILIST .EQ. 1) GO TO 1712
      WRI = BU(48)/BU(49)
      WRITE (IO,1711)H,K,L,AFS,SFS,ASFS,SASFS,FALT,WRI,
     &ICHAR(IBAD),ICHAR(LK),ICHAR(KENNZ)
 1711 FORMAT (6H  MEAN,1X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,26X,F9.0,12X,
     &F6.2,1X,A5,10X,A2,5X,A3,/)
      GO TO 1712
 1713 IF (ILIST .EQ. 1) GO TO 1712
      WRITE (IO,1710)H,K,L,AFS,SFS,ASFS,SASFS,ICHAR(LK),ICHAR(KENNZ)
 1710 FORMAT (6H  MEAN,1X,3I4,1X,F9.0,1X,F6.0,1X,2F6.0,30X,A2,6X,A3,/)
 1712 IF (NOREF .EQ. 0 .OR. NOR .GT. 1) GO TO 420
C---- REJECT A MEAN VALUE IF ALL BUT ONE REFLECTIONS WERE REJECTED
C---- BEFORE
      MULNEU = MULNEU - 1
      IREF (7 + MODUS) = IREF ( 7 + MODUS) + 1
      IF (IZAHLI .EQ. MULT) GO TO 500
      GO TO 01
C
C---- STORE THE MEAN VALUE FOR USE IN THE AVERAGING PROCESS OF THE
C---- SUBROUTINE AVERA2
C
  420 AHKL (MULNEU) = IDHKL
      AF (MULNEU) = AFS
      ASF (MULNEU) = ASFS
      SASF (MULNEU) = SASFS
      ATBAR (MULNEU) = ATBARS
      ACKOF (MULNEU) = ATBRCS
      IREF (MODUS) = IREF (MODUS) + 1
      IF (AFS .LT. SIGLT * ASFS) IREF (MODUS + 2) =
     &IREF (MODUS + 2) + 1
      IF (IZAHLI .LT. MULT) GO TO 01
C
C---- NUMBER OF SYMMETRY EQUIVALENT REFLECTIONS AFTER PREAVERAGING
C
  500 MULT = MULNEU
      RETURN
      END
                         SUBROUTINE REDIF
     &                   (H,K,L,RH,RK,RL)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C +                                                                    +
C + SUBROUTINE WHICH CALCULATES FOR GIVEN H,K, AND L THE CORRESPONDING +
C + VALUES IN THE ASSYMMETRIC UNIT OF THE LAUE CLASS -1 (FRIEDEL RE-   +
C + FLECTIONS)                                                         +
C + WRITTEN BY EGBERT PERENTHLER MPI-FKF (DEZEMBER 1980)               +
C +                                                                    +
C + THIS PROGRAMM IS CALLED BY THE SUBROUTINE IDENT                    +
C +                                                                    +
C + THIS PROGRAMM DO NOT CALL ANY OTHER SUBROUTINE                     +
C +                                                                    +
C + IN CASE OF AN OVERLAY STRUCTURE IT IS PART OF THE OVERLAY  AVER2   +
C +                                                                    +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C---- TYPE STATEMENTS
C
      INTEGER H,RH,RK,RL
C
C---- SAVE THE OLD VALUES
C
      RH = H
      RK = K
      RL = L
C
C---- TRICLINIC  /  1BAR  /  -1          (FRIEDEL-MITTELUNG)
C
  101 IF (RL .GT. 0) RETURN
      IF (RL .LT. 0) GO TO 120
      IF (RK .GT. 0) RETURN
      IF (RK .LT. 0) GO TO 130
      RH = IABS (RH)
      RETURN
  120 RL = -RL
  130 RK = -RK
      RH = -RH
      RETURN
C
      END
