                          SUBROUTINE AVERA1
     &        (IN,IO,MAXLIN,IDIM,NUMMER,ILT,ISORT,IP,IU,ICV,
     &            IHKL,IRHKL,F,SF,TBAR,CKOF,NUMOR,FINTCU)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C +                                                                    +
C + SUBROUTINE WHICH READS THE PARAMETER AND DATA INPUT AND PRESORTS   +
C + THE DATA FOR THE AVERAGING PROCESS IN AVERA2                       +
C + WRITTEN BY EGBERT PERENTHALER MPI-FKF (1978)                       +
C + CONSIDERABLY UPGRADED BY 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,        +
C + REDUC, TRANS, QSORT, AND DUMMY                                     +
C +                                                                    +
C + IN CASE OF AN OVERLAY STRUCTURE IT IS THE MAIN PROGRAMME OF THE    +
C + OVERLAY  AVER1                                                     +
C +                                                                    +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C---- TYPE STATEMENTS
C     ---------------
C
      REAL MU
	CHARACTER*80 FILENAME
C
C---- INTEGER VARIABLES
C    - SUBRU        NUMBER FOR THE SELECTED LAUE CLASS
C    - H            FIRST MILLER INDEX
C    - AEH,AEK,AEL  TRANSFORMED MILLER INDICES
C    - SC           SCALE GROUP READ IN
C    - KENNZ        USED WHEN PRODUCING PRINTED OUTPUT
C    - DUMM         USED TEMPERARILY FOR DIFFERENT THINGS
C    -IN,IOUT       Nummern der PAR und LIS files (9,7)
C    -INUNIT,IOUNIT Nummern der Eingabe- und Ausgabe DAT files (31,20)
C
      INTEGER SUBRU,H,AEH,AEK,AEL,SC,ASC,KENNZ,DUMM
C
C---- DIMENSION STATEMENTS
C     --------------------
C
C    - STACKL,STACKR  STACK REGISTERS FOR THE SUBROUTINE QSORT
C                     DIMENSION AT LEAST (1/6)*IDIM
C    - FBUFF,IBUFF    NEEDED TO READ THE FOURIER FILE
C                     (IBUFF IS USED TO READ THE PARAMETER CARDS)
C    - LABFO          FOR READING THE LABEL OF THE FOURIER FILE
C    - ICLAS          NAMES OF LAUE AND CRYSTAL CLASSES
C    - ISIP           FLAGS FOR THE SEQUENCE OF THE PARAMETER CARDS
C    - ICARD          LABELS OF THE PARAMETER CARDS
C    - IPFOR          INPUT FORMAT
C    - IFOR           FOR CHECKING THE OUTPUT FORMAT
C    - TRAFO          TRANSFORMATION MATRIX
C
      DIMENSION STACKL(4001),STACKR(4001),FBUFF(500),IBUFF(500),LABFO(3)
     &,ICLAS(21),ISIP(7),ICARD(8),IPFOR(17),IFOR(10),TRAFO(3,3),
     &SCLFAK(9),ipsout(2)
C
      DIMENSION IHKL(IDIM),IRHKL(IDIM),F(IDIM),SF(IDIM),TBAR(IDIM),
     &CKOF(IDIM),NUMOR(IDIM)
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)
C
C---- EQUIVALENCE STATEMENTS
C     ----------------------
C
C---- FOR UNFORMATED READING OF A MIXTURE OF REAL AND INTEGER VALUES
	EQUIVALENCE (FBUFF,IBUFF)
C
C---- TO SAVE CORE (THE ARRAYS ARE NEVER USED THE SAME TIME)
	EQUIVALENCE (STACKL(1),FBUFF)

C
C---- DATA STATEMENTS
C     ---------------
C
      DATA ICLAS/4H    ,4H-1  ,4H2/MZ,4H2/MY,4HMMM ,4H4/M ,4H4/MM,4H-3RH
     &,4H-3M ,4H-3HE,4H-3M1,4H-31M,4H6/M ,4H6/MM,4HM3  ,4HM3M ,4HDUMM,1H
     &A,1HB,1HC,1HD/
      DATA ICARD/4HCNTR,4HPARA,4HFORI,4HFORO,4HSCAL,4HMATR,4HCELL,
     &4HEND /
      DATA IFOR/1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/
      data ipsout /1h,,4hF7.2/
C
C
C---- INITIALISE
C     ----------
C
      NUMMER = 0
      ILT = 0
      DIGN1 = 0.
      DIGN2 = 0.
      SYSDEV = 0.
      REJE = 0.
      MU = 0.
      SIGLT = 3.
      OFLOW = 0.
      INFORM = 0
      IOFORM = 0
      NSCALE = 0
      IMAT = 0
      ISOR = 0
      TBAR(1) = 0.
      CKOF(1) = 0.
C
C---- START OF PROGRAMME
C     ------------------
C
C---- READING OF THE INPUT CARDS
C     --------------------------
C
C---- FIRST CARD
C    - INUNIT   LOGICAL NUMBER OF THE DATA INPUT UNIT
C  
C
      READ (IN,3010) LABEL,ICV
 3010 FORMAT(A4,A2,1X,I1)
      INUNIT = 31
      IOUNIT = 20
C
C---- WAS THE OUTPUT UNIT CHOSEN TO BE THE STANDARD INPUT UNIT
      IF (IOUNIT .NE. IN) GO TO 3019
      WRITE (IO,3011) IOUNIT
 3011 FORMAT(1H0,5(1H*),13HERROR MESSAGE,5(1H*)//1X,61HYOU HAVE CHOSEN T
     &HE OUPUT UNIT TO BE THE STANDARD INPUT UNIT,I3//1X,24HTHIS WOULD C
     &AUSE ERRORS.//1X,32HI AM SORRY. I HAVE TO CALL EXIT.)
      CALL EXIT
C
C---- TITEL CARD
 3019 READ (IN,3020)TITEL
 3020 FORMAT(20A4)
C
C---- COPY THE PARAMETER CARDS ONTO THE OUTPUT UNIT
C
      REWIND IOUNIT
      DUMM = 1
 3030 READ (IN,3020) (IBUFF(I),I=1,20)
C
C---- CHECK THE SEQUENCE OF THE CARDS
      DO 3040 I = 1,8
      IF (IBUFF(1) .NE. ICARD(I)) GO TO 3040
      IF (I .EQ. 8) GO TO 3050
      ISIP(DUMM) = I
C
C---- WRITE THE CARD ONTO THE OUTPUT UNIT
      WRITE (IOUNIT,3020) (IBUFF(J),J=1,20)
C
C---- CONTINUE WITH THE NEXT CARD
      DUMM = DUMM + 1
      GO TO 3030
 3040 CONTINUE
C
C---- SAVE THE FIRST HKL-CARD JUST READ (IF INUNIT EQ IN)
      NUMMER = 1
      WRITE (IOUNIT,3020) (IBUFF(I),I=1,20)
C
C---- FINISH COPIING
 3050 REWIND IOUNIT
C
C---- FORMATED READING OF THE PARAMETER CARDS FROM IOUNIT
C
      DO 3130 I = 1,DUMM-1
      GO TO (3060,3070,3080,3090,3100,3110,3120),ISIP(I)
C
C---- CONTROL CARD
 3060 READ (IOUNIT,3061) ICHAR(5),ICHAR(6),IKART,IFHKL,IGNO,ISYS,ISST,
     &MODU,IREJEC,NOR,NULL,IABSO,IPSO,ILIST,ISCGR
 3061 FORMAT(5X,A4,A1,13I3)
      if(ikart.eq.0)
     &open(unit=31,access='sequential',status='old')
CX      if(ikart.ne.0)
CX     &open(unit=31,access='sequential',recordtype='segmented',
CX     &form='unformatted',status='old')
      if(ikart.ne.0)
     &open(unit=31,access='sequential',status='old')
      J = 0
      IF(ILIST.EQ.0) J=2
      IF(ILIST.EQ.2) ILIST=0
      IF(J.EQ.2) ILIST=2
      GO TO 3130
C
C---- PARAMETER VALUE CARD
 3070 READ (IOUNIT,3071)DIGN1,DIGN2,SYSDEV,REJE,MU,SIGLT,OFLOW,FINTCU
 3071 FORMAT(5X,8F8.3)
      IF (SIGLT .LT. .0001) SIGLT = 3.
      IF (ABS(FINTCU).LT.0.00001) FINTCU = 1.E12
      GO TO 3130
C
C---- INPUT FORMAT CARD
 3080 READ (IOUNIT,3081)IPFOR
 3081 FORMAT(5X,16A4,A3)
      INFORM = 1
      GO TO 3130
C
C---- OUTPUT FORMAT CARD
 3090 READ (IOUNIT,3091)(IRMT(J),J=9,12),(IRMT(J),J=16,19)
 3091 FORMAT(5X,4A1,1X,4A1)
      IOFORM = 1
      GO TO 3130
C
C---- SCALE FACTOR CARD
 3100 READ (IOUNIT,3101)SCLFAK
 3101 FORMAT(5X,9F)
      DO 3102 J = 1,9
      NSACLE = J - 1
      IF (SCLFAK(J)) 3102,3103,3102
 3102 CONTINUE
 3103 GO TO 3130
C
C---- MATRIX CARD
 3110 READ (IOUNIT,3111)((TRAFO(M,J),J=1,3),M=1,3)
 3111 FORMAT(5X,9F8.1)
      IMAT = 1
      GO TO 3130
C
C---- CELL CARD
 3120 READ (IOUNIT,3121)CELL
 3121 FORMAT(5X,6F)
      ISOR = 1
C
 3130 CONTINUE
C
C---- READ THE LABEL OF THE FOURIER FILE
      IF (IKART .EQ. 0) GO TO 3140
      IF (INUNIT .EQ. 0) INUNIT = 13
      REWIND INUNIT
      READ (INUNIT) LABFO
C
C---- PRINT OUT THE PARAMETER INPUT
C     -----------------------------
C
C---- TITEL AND STARTING TIME
C
      IF (INUNIT .EQ. 0) INUNIT = IN
 3140 WRITE (IO,3150) TITEL
C+++++ILL-SPECIFIC+++++++++ CHANGE IN 3150 FORMAT 1H  TO 1H1++++++++++++
 3150 FORMAT(1H /1X,22HTITEL OF THE PROGRAMME/1X,22(1H-)//1X,18A4///1X,
     &17HTIME OF EXECUTION/1X,17(1H-)/1H )
      CALL ANFANG (1)
C
C---- IN- AND OUTPUT UNIT
C
      WRITE (IO,3160)
 3160 FORMAT(2(/),1X,24HLOGICAL UNIT DECLARATION/1X,24(1H-)/1H )
	INQUIRE(UNIT=IN,NAME=FILENAME)
	WRITE(IO,3170)FILENAME
3170	FORMAT (1X,' PARAMETER INPUT    : ',A)
	INQUIRE(UNIT=INUNIT,NAME=FILENAME)
	WRITE(IO,3171)FILENAME
3171	FORMAT (1X,' DATA INPUT FILE    : ',A)
	INQUIRE(UNIT=IOUNIT,NAME=FILENAME)
	WRITE(IO,3172)FILENAME
3172	FORMAT (1X,' DATA OUTPUT FILE   : ',A)
	INQUIRE(UNIT=IO,NAME=FILENAME)
	WRITE(IO,3173)FILENAME
3173	FORMAT (1X,' LINEPRINTER OUTPUT : ',A,/,/,/)

C      IF (IKART .NE. 0) WRITE (IO,3170) INUNIT
C 3170 FORMAT(1X,27HUNIT NUMBER OF FOURIER FILE,4X,I2/1H )
C      IF (IKART .EQ. 0) WRITE (IO,3180) INUNIT
C 3180 FORMAT(1X,24HINPUT UNIT  OF HKL-CARDS,7X,I2/1H )
C      WRITE (IO,3190) IOUNIT
C 3190 FORMAT(1X,24HOUTPUT UNIT OF HKL-CARDS,7X,I2/1H0)
C
C---- LABEL FOR THE OUTPUT CARDS (AND OF THE FOURIER FILE)
C
      IF (IKART .NE. 0) WRITE (IO,3200) LABFO
 3200 FORMAT(1X,25HLABEL OF THE FOURIER FILE/1X,25(1H-)/1H0,3A4/1H0)
      WRITE (IO,3210) LABEL
 3210 FORMAT(1X,25HLABEL OF THE OUTPUT CARDS/1X,25(1H-)/1H0,A4,A2/1H0)
C
C---- CONTROL PARAMETERS
C
      WRITE (IO,3215)
 3215 FORMAT(1X,18HCONTROL PARAMETERS/1X,18(1H-)/1H0)
C
C---- CRYSTAL CLASS
      IF (ICHAR(5) .EQ. ICHAR(7)) GO TO 3221
      WRITE (IO,3220) ICHAR(5),ICHAR(6)
 3220 FORMAT(1X,13HCRYSTAL CLASS,48X,A4,A1/1H0)
      GO TO 3239
 3221 WRITE (IO,3230)
 3230 FORMAT(1X,13HCRYSTAL CLASS,48X,21HIDENTICAL REFLECTIONS/1H0)
      MODU = 0
C
C---- INFORMATION ON THE HKL-CARDS
 3239 WRITE (IO,3240) IFHKL
 3240 FORMAT(1X,27HVERSION NUMBER OF HKL-CARDS,33X,I2/1H0)
C
C---- CHANGE OF THE IGNORANCE FACTOR
      IF (IGNO .EQ. 0) WRITE (IO,3250)
 3250 FORMAT(1X,30HCHANGE OF THE IGNORANCE FACTOR,31X,2HNO/1H0)
      IF (IGNO .NE. 0) WRITE (IO,3260) DIGN1,DIGN2
 3260 FORMAT(1X,36HCHANGE OF THE IGNORANCE FACTOR FROM ,23X,F7.3,4H TO ,
     &F7.3/1H0)
C
C---- ESTIMATED SYSTEMATIC ERROR
      WRITE (IO,3270) SYSDEV
 3270 FORMAT(1X,26HESTIMATED SYSTEMATIC ERROR,33X,F7.3,8H PERCENT/1H0)
C
C---- SELECTION OF THE ERROR CALCULATION
      WRITE (IO,3280) ISST
 3280 FORMAT (1X,26HSWITCH FOR ERROR SELECTION,34X,I2/1H0)
C++++NEXT LINE ILL-SPECIFIC++++++++++++++++++++++++++++++++++++++++++++
      IF(IKART.NE.0.AND.MAXLIN.LT.60) WRITE(IO,3291)
C
C---- SELECTION OF PREAVERAGING
      WRITE (IO,3290) MODU
 3290 FORMAT(1X,23HSWITCH FOR PREAVERAGING,37X,I2/1H0)
C
C---- NEW PAGE
      IF (IKART.EQ.0.AND.MAXLIN .LT. 57) WRITE (IO,3291)
 3291 FORMAT(1H1//1X,23HMORE CONTROL PARAMETERS/1X,23(1H-)//1H0)
C
C---- REJECT PARAMETER
C+++++ILL-SPECIFIC++++++++++++++++++++++++++++++++++++++++++++++++++++++
      IF(MAXLIN.GE.57.AND.MAXLIN.LT.60.AND.IKART.EQ.0) WRITE(IO,3291)
C+++++ILL-SPECIFIC++++++++++++++++++++++++++++++++++++++++++++++++++++++
      IF (IREJEC) 3300,3310,3320
 3300 WRITE (IO,3305) REJE
 3305 FORMAT(1X,48HREFLECTION IS REJECTED IF INTENSITY IS MORE THAN,
     &11X,F7.3,42H SIGMA LESS THAN MAXIMUM INTENSIY OF GROUP/1H0)
      GO TO 3330
 3310 WRITE (IO,3315)
 3315 FORMAT(1X,25HREJECT PARAMETER SELECTED,36X,2HNO/1H0)
      GO TO 3330
 3320 WRITE (IO,3325) REJE
 3325 FORMAT(1X,55HREFLECTION IS REJECTED IF INTENSITY DEVIATES MORE THA
     &N ,4X,F7.3,26H SIGMA FROM THE MEAN VALUE/1H0)
C
C---- NEW PAGE
C+++++ILL-SPECIFIC++++CHANGE 60 BACK TO 57 AND 63 BACK TO 60++++++++++++
 3330 IF (MAXLIN .GE. 60 .AND. MAXLIN .LT. 63) WRITE (IO,3291)
C
      IF (MODU .EQ. 0) GO TO 3370
      IF (IABS (IREJEC) - 2) 3340,3350,3360
 3340 WRITE (IO,3345)
 3345 FORMAT(1X,28HTHE REJECT PARAMETER IS USED,33X,16HIN ALL AVERAGING,
     &6H STEPS/1H0)
      GO TO 3370
 3350 WRITE (IO,3355)
 3355 FORMAT(1X,28HTHE REJECT PARAMETER IS USED,33X,16HONLY FOR PREAVER,
     &5HAGING/1H0)
      GO TO 3370
 3360 WRITE (IO,3365)
 3365 FORMAT(1X,23HTHE REJECT PARAMETER IS,38X,21HNOT USED FOR PREAVERA,
     &4HGING/1H0)
C
C---- NEW PAGE
 3370 IF (MAXLIN .GE. 60 .AND. MAXLIN .LT. 63) WRITE (IO,3291)
C
C---- WHAT ABOUT ONLY ONE REMAINING REFLECTION
      WRITE (IO,3380) NOR
 3380 FORMAT(1X,56HSWITCH FOR THE CASE THAT ALL BUT ONE REFLECTION REJEC
     &TED,2X,I4/1H0)
C
C---- NEW PAGE
 3400 IF (MAXLIN .GE. 63 .AND. MAXLIN .LT. 66) WRITE (IO,3291)
C
C---- WHAT ABOUT NEGATIVE INTENSITIES
      WRITE (IO,3410)
 3410 FORMAT(1X,36HNEGATIVE INTENSITIES ARE SET TO ZERO)
      IF (NULL .NE. 0) WRITE (IO,3420)
 3420 FORMAT(1H+,61X,2HNO/1H0)
      IF (NULL .EQ. 0) WRITE (IO,3430)
 3430 FORMAT(1H+,61X,3HYES/1H0)
C
C---- NEW PAGE
      IF (MAXLIN .GE. 66 .AND. MAXLIN .LT. 69) WRITE (IO,3291)
C
C---- ABSORPTION CORRECTION
      WRITE (IO,3440)
 3440 FORMAT(1X,40HINTENSITIES ARE CORRECTED FOR ABSORPTION)
      IF (IABSO .EQ. 0) WRITE (IO,3420)
      IF (IABSO .GT. 0) WRITE (IO,3430)
      IF (IABSO .LT. 0) WRITE (IO,3425)
3425	FORMAT(1H+,61X,'NO  but You have * P S I - D A T A * '/,1H0)
C
C---- NEW PAGE
      IF (MAXLIN .GE. 69 .AND. MAXLIN .LT. 72) WRITE (IO,3291)
C
C---- CALCULATION OF TBAR
      IF (MU .GT. .0001) WRITE (IO,3460) MU
 3460 FORMAT(1X,50HTBAR IS CALCULATED WITH THE ABSORPTION COEFFICIENT,
     &10X,F7.3,5H 1/CM/1H0)
C
C---- NEW PAGE
      IF (MAXLIN .GE. 72 .AND. MAXLIN .LT. 75) WRITE (IO,3291)
C
C---- AVERAGING OR ONLY SORTING
      WRITE (IO,3475)
 3475 FORMAT(1X,18HPRESORTING ALLOWED)
      IF (IPSO .EQ. 1 .OR. IPSO .EQ. 3) WRITE (IO,3420)
      IF (IPSO .EQ. 0 .OR. IPSO .EQ. 2) WRITE (IO,3430)
C
C---- NEW PAGE
      IF (MAXLIN .GE. 75 .AND. MAXLIN .LT. 78) WRITE (IO,3291)
      WRITE (IO,3490)
 3490 FORMAT(1X,41HNO AVERAGING BUT ONLY SORTING OF THE DATA)
      IF (IPSO .LT. 2) WRITE (IO,3420)
      IF (IPSO .GT. 1) WRITE (IO,3430)
C
C---- NEW PAGE
      IF (MAXLIN .GE. 78) WRITE (IO,3291)
C
C---- LESS THAN MARKING
      WRITE (IO,3510) SIGLT
 3510 FORMAT(1X,44HINTENSITY MARKED AS  LESS THAN  IF LESS THAN,15X,F7.3
     &,9H SIGMA(I),/1H0)
C
C---- OVERALL SCALE
      EINS = 1.
      IF(OFLOW .LT. .00001) WRITE (IO,3520) EINS
      IF(OFLOW .GT. 0.) WRITE (IO,3520) OFLOW
 3520 FORMAT(1X,29HINTENSITIES ARE MULTIPLIED BY,27X,F10.3,/1H0)
C
C---- AVERAGING ONLY WEAK REFLECTIONS
      IF(ABS(FINTCU-1.E12).GT.0.001) WRITE(IO,3535) FINTCU
 3535 FORMAT(1X,42HAVERAGING ONLY REFLECTIONS WITH I SMALLER ,
     &17X,F7.3,11H * SIGMA(I) ,/,1H0)
C
C---- INPUT FORMAT
      IF (INFORM .NE. 0) WRITE (IO,3530) IPFOR
 3530 FORMAT(1X,14HINPUT  FORMAT ,16A4,A3/1H0)
C
C---- OUTPUT FORMAT
      if(iabso.lt.0) irmt(19) = ipsout(1)
      if(iabso.lt.0) irmt(20) = ipsout(2)
      WRITE (IO,3540) IRMT
 3540 FORMAT(1X,14HOUTPUT FORMAT ,A4,A1,3A4,A3,A4,6A1,A4,A2,5A1,A4/1H0)
C
C---- SCALE FACTORS
      IF (NSCALE .NE. 0) WRITE (IO,3550) (SCLFAK(I),I=1,NSCALE)
 3550 FORMAT(1X,13HSCALE FACTORS,10(3X,F7.2),/,1H0)
C
C---- TRANSFORMATION MATRIX
      IF (IMAT) 3580,3580,3560
 3560 WRITE (IO,3570) ((TRAFO(I,J),J=1,3),I=1,3)
 3570 FORMAT(1X,44HTRANSFORMATION MATRIX FOR THE MILLER INDICES,6X,3(F8.
     &5,3X),2(/51X,3(F8.5,3X))/1H0)
C
C---- CELL PARAMETERS
 3580 IF (ISOR) 3610,3610,3590
 3590 WRITE (IO,3600) CELL
 3600 FORMAT(1X,15HCELL PARAMETERS,3X,4HA = ,F8.5,3X,4HB = ,F8.5,3X,4HC
     &= ,F8.5,5X,8HALPHA = ,F8.5,3X,7HBETA = ,F8.5,3X,8HGAMMA = ,F8.5)
C
C---- READING OF THE FIRST HKL-CARD FOR PARAMETER CONTROLL
C
 3610 IF (IKART) 3900,3611,3900
C
C---- NUMBER OF HKL-CARD VERSION READ
 3611 IF (IFHKL) 3615,3612,3615
 3612 WRITE (*,3613)
      WRITE (IO,3613)
 3613 FORMAT(1H1,5(1H*),13HERROR MESSAGE,5(1H*)//78HYOU HAVE NOT WRITTEN
     &THE VERSION NUMBER OF THE HKL-CARDS ON THE  CONTROL  CARD.//
     &33HI AM SORRY.  I HAVE TO CALL EXIT.)
      CALL EXIT
 3615 IF (NUMMER) 3620,3620,3630
 3620 DUMM = INUNIT
      GO TO 3640
 3630 DUMM = IOUNIT
 3640 IHKLF = IABS (IFHKL)
      IF(ICV.EQ.0) IHKLF=9
      NUMMER = 0
      IF (INFORM) 3800,3650,3800
 3650 GO TO (3660,3670,3680,3690,3700,3710,3716,3720,3722),IHKLF
 3660 READ (DUMM,3665,ERR=3726) IWN,H,K,L,LT,F(1),SF(1)
 3665 FORMAT(A3,10X,3I3,3X,I3,F9.0,9X,F5.0)
      GO TO 6
 3670 READ (DUMM,3675,ERR=3726) IWN,H,K,L,LT,F(1),TBAR(1),SF(1)
 3675 FORMAT(A3,10X,3I3,3X,I3,3X,F9.0,F9.5,F5.0)
      GO TO 6
 3680 READ (DUMM,3685,ERR=3726) IWN,H,K,L,LT,ASC,F(1),SF(1)
 3685 FORMAT(A3,10X,3I3,3X,2I3,F9.0,9X,F5.0)
      GO TO 6
 3690 READ (DUMM,3695,ERR=3726) IWN,H,K,L,LT,ASC,F(1),TBAR(1),SF(1)
 3695 FORMAT(A3,10X,3I3,3X,2I3,F9.0,F9.5,F5.0)
      GO TO 6
 3700 READ (DUMM,3705,ERR=3726) IWN,H,K,L,LT,F(1),SF(1),CKOF(1)
 3705 FORMAT(A3,10X,3I3,3X,I3,3X,F9.0,9X,F5.0,7X,F8.4)
      GO TO 6
 3710 READ (DUMM,3715,ERR=3726) IWN,H,K,L,LT,F(1),TBAR(1),SF(1),CKOF(1)
 3715 FORMAT(A3,10X,3I3,3X,I3,3X,F9.0,F9.5,F5.0,7X,F8.4)
      GO TO 6
 3716 READ (DUMM,3717,ERR=3726) IWN,H,K,L,LT,ASC,F(1),SF(1),CKOF(1)
 3717 FORMAT(A3,10X,3I3,3X,2I3,F9.0,9X,F5.0,7X,F8.4)
      GO TO 6
 3720 READ (DUMM,3725,ERR=3726) IWN,H,K,L,LT,ASC,F(1),TBAR(1),SF(1),
     &CKOF(1)
 3725 FORMAT(A3,10X,3I3,3X,2I3,F9.0,F9.5,F5.0,7X,F8.4)
C+++++ILL-SPECIFIC++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3722 READ(DUMM,3724,ERR=3726)NUM1
 3724 FORMAT(I6)
      READ(DUMM,3724,ERR=3726)NUM2
      READ(DUMM,3724,ERR=3726)NUM3
      READ(DUMM,3724,ERR=3726)NUM4
      INCD=1
      IF(NUM1.EQ.NUM2) INCD=2
      IF(NUM1.EQ.NUM3) INCD=3
      IF(NUM1.EQ.NUM4) INCD=4
      REWIND DUMM
	IF(IABSO.LT.0)THEN
	  READ(DUMM,'(70X,F7.0)',IOSTAT=IERROR) CKOF(1)
	  IF(IERROR.EQ.0)THEN
	    WRITE(*,*) ' PSI FOUND ON FIRST HKL-CARD' 
	  ELSE
	    WRITE(*,*) ' NO PSI-VALUE FOUND ON FIRST HKL-CARD '
	    GOTO 3726
	  ENDIF
	  REWIND DUMM
	ENDIF
      IF(INCD.EQ.4)
     &READ(DUMM,3728,ERR=3726)NUMOR(1),H,K,L,F(1),SF(1)
 3728 FORMAT(I6,3I4,2F10.2,/////)
      IF(INCD.EQ.3)
     &READ(DUMM,3723,ERR=3726)NUMOR(1),H,K,L,F(1),SF(1),TBAR(1)
 3723 FORMAT(I6,3I4,2F10.2,//,15X,F8.4)
      IF(INCD.EQ.2)
     &READ(DUMM,3731,ERR=3726)NUMOR(1),H,K,L,F(1),SF(1)
 3731 FORMAT(I6,3I4,2F10.2,/,15X)
      IF(INCD.EQ.1)
     &READ(DUMM,3732,ERR=3726)NUMOR(1),H,K,L,F(1),SF(1)
 3732 FORMAT(I6,3I4,2F10.2)
C+++++ILL-SPECIFIC++++++++++++++++++++++++++++++++++++++++++++++++++++++
      GO TO 6
C
C---- ERROR MESSAGE
C
 3726 WRITE (*,3727)
      WRITE (IO,3727)
 3727 FORMAT(1H1,5(1H*),13HERROR MESSAGE,5(1H*)//1X,46HERROR OCCURED WHE
     &N READING THE FIRST HKL-CARD.//1X,97HTHE REASON CAN BE THAT YOUR H
     &KL-CARDS ARE NOT STANDARD FORMAT OR YOU WANT TO READ A FOURIER FIL
     &E.//33HI AM SORRY.  I HAVE TO CALL EXIT.)
      CALL EXIT
C
 3800 GO TO (3810,3820,3830,3840,3850,3860,3866,3870),IHKLF
 3810 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,F(1),SF(1)
      GO TO 6
 3820 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,F(1),TBAR(1),SF(1)
      GO TO 6
 3830 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,ASC,F(1),SF(1)
      GO TO 6
 3840 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,ASC,F(1),TBAR(1),SF(1)
      GO TO 6
 3850 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,F(1),SF(1),CKOF(1)
      GO TO 6
 3860 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,F(1),TBAR(1),SF(1),CKOF(1)
      GO TO 6
 3866 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,ASC,F(1),SF(1),CKOF(1)
      GO TO 6
 3870 READ (DUMM,IPFOR,ERR=3875) IWN,H,K,L,LT,ASC,F(1),TBAR(1),SF(1),
     &CKOF(1)
      GO TO 6
C
C---- ERROR MESSAGE
C
 3875 WRITE(*,3876)
      WRITE(IO,3876)
 3876 FORMAT(1H1,5(1H*),13HERROR MESSAGE,5(1H*)//1X,46HERROR OCCURED WHE
     &N READING THE FIRST HKL-CARD.//111HTHE REASON CAN BE THAT YOUR INP
     &UT FORMAT ON THE  FORI  CARD DO NOT CORRESPOND WITH THE FORMAT OF
     &YOUR HKL-CARDS//1X,34HOR YOU WANT TO READ A FOURIE FILE.//1X,
     &33HI AM SORRY.  I HAVE TO CALL EXIT.)
      CALL EXIT
C
C---- F OR I ON CARDS
    6 IF (IFHKL) 3880,7,7
 3880 SF(1) = SF(1) * F(1) * 2.
      F(1) = F(1) * F(1)
      GO TO 7
C
C---- READ SECOND RECORD OF THE FOURIER FILE
 3900 READ (INUNIT) N
C
C---- REWIND OUTPUT FILE
    7 REWIND IOUNIT
C
C---- WHICH CRYSTAL CLASS WAS SELECTED
C
      IZEN = 0
      DO 8 I = 1,4
    8 IF (ICHAR (6) .EQ. ICLAS (17+I)) IZEN = I
      IF (IZEN .NE. 0 .AND. MODU .GT. 1) WRITE (IO,9)
    9 FORMAT(3(/),1X,86H****WARNING****   YOU AVERAGE FIRST FRIEDEL-REFL
     &ECTIONS, BUT THEN AN ACENTRIC SYMMETRY)
      DO 10 I = 1,17
      IF (ICLAS (I) .EQ. ICHAR (5)) GO TO 20
   10 CONTINUE
      WRITE (6,21) ICHAR(5),ICHAR(6)
   21 FORMAT (3(/),'****WRONG INPUT****   THE SYMBOL  ',A4,A1,
     &' IS NO PROGRAMM CONVENIENT NOTATION OF A CRYSTAL CLASS.')
      CALL EXIT
   20 SUBRU = I
C
C---- ERROR MESSAGES
C
C---- IGNORACNCE FACTOR
      IF (IGNO) 4000,4010,4000
 4000 IF(DIGN1+DIGN2) 4010,4005,4010
 4005 WRITE (IO,4006)
 4006 FORMAT(5(/),1X,13H***WARNING***,5X,89HYOU WANT TO CHANGE THE IGNOR
     &ANCE FACTOR BUT HAVE NOT WRITTEN THE VALUES ON THE PARA CARD.)
C
C---- SYSTEMATIC ERROR
 4010 IF (ISYS) 4020,4030,4020
 4020 IF (SYSDEV) 4030,4025,4030
 4025 WRITE (IO,4026)
 4026 FORMAT(5(/),1X,13H***WARNING***,5X,92HYOU WANT TO CALCULATE A SYST
     &EMATIC ERROR BUT HAVE NOT WRITTEN A PERCENTAGE ON THE PARA CARD.)
C
C---- REJECT PARAMETER
 4030 IF (IREJEC) 4040,4050,4040
 4040 IF (REJE) 4050,4045,4050
 4045 REJE = 5.0
      WRITE (IO,4046)
 4046 FORMAT(5(/),1X,13H***WARNING***,5X,80HYOU WANT TO USE A REJECT PRA
     &METER BUT HAVE NOT WRITTEN A LIMIT ON THE PARA CARD./1X,26HA DEFAU
     &LT VALUE OF REJE = ,F5.1,8HIS USED.)
C
C---- ABSORPTION CORRECTION
 4050 IF (IABSO) 5000,5000,4060
 4060 IF (IKART) 4065,4070,4065
 4065 IABSO = 0
      GO TO 5000
 4070 IF (CKOF(1)) 4080,4075,4080
 4075 WRITE (6,4076)
 4076 FORMAT(5(/),1X,5(1H*),13HERROR MESSAGE,5(1H*)//1X,99HYOU WANT TO M
     &AKE AN ABSORPTION CORRECTION BUT DO NOT READ THE CORRECTION FACTOR
     & FROM THE HKL-CARDS.//1X,33HI AM SORRY.  I HAVE TO CALL EXIT.)
      CALL EXIT
C
C---- CACULATION OF TBAR
 4080 IF (TBAR(1)) 5000,4090,5000
 4090 IF (MU) 5000,4100,5000
 4100 WRITE (IO,4105)
 4105 FORMAT(5(/),1X,13H***WARNING***,5X,103HYOU DO NOT READ TBAR FROM T
     &HE HKL-CARDS BUT YOU HAVE NOT WRITTEN MU ON THE PARA CARD TO CALCU
     &LATE TBAR.)
C
C
 5000 IF (IOFORM) 32,31,32
   31 IP = 8
      IU = 4
      GO TO 23
   32 DO 2 I = 1,9
      IF (IRMT (9) .EQ. IFOR (I)) IP = I
    2 IF (IRMT (16) .EQ. IFOR (I)) IU = I
      IF (IP .GT. 1) GO TO 4
      DO 3 I = 1,9
    3 IF (IRMT (10) .EQ. IFOR (I)) IP = 10 * IP + I
      IF (IRMT (10) .EQ. IFOR (10)) IP = 10 * IP
    4 IF (IU .GT. 1) GO TO 22
      DO 5 I = 1,9
    5 IF (IRMT (17) .EQ. IFOR (I)) IU = 10 * IU + I
      IF (IRMT (17) .EQ. IFOR (10)) IU = 10 * IU
   22 IP = IP - 1
      IU = IU - 1
C
C---- INITIALISIE SOME VARIABLES FOR READING AND PRINTING THE DATA
C
   23 IRZA = 49
      ISCAL = 13
      KENNZ = 7
      IEND = 7
      SC = ASC
      ISORT = 0
      IF (ILIST) 24,24,50
   24 IF (IKART .NE. 0) KENNZ = 3
      IF (IKART .NE. 0) ISCAL = 7
      IF (IFHKL .GT. 4) KENNZ = 1
      IF (IFHKL .GT. 4 .OR. IKART .NE. 0) IEND = 15
C
C---- HEADLINE OF THE REFLECTION LISTING
      WRITE (IO,25)
   25 FORMAT (1H1,22HLIST OF THE DATA INPUT,/,1X,22(1H=)/)
      ISEIT = 0
C
C---- HEADLINE FOR EACH PAGE OF THE REFLECTION LISTING
C
   30 IF (ILIST) 33,33,50
   33 WRITE (IO,40)ISEIT,ICHAR(ISCAL),ICHAR(KENNZ),ICHAR(IEND)
   40 FORMAT (I1,11H  H   K   L,7X,12HHKL-ASYMMETR,3X,5H LT  ,A2,9X,
     &1HI,5X,8HSIGMA(I),5X,A3,A4,/)
      ILINE = 2
      IF (ISEIT .EQ. 0) ILINE = 5
      ISEIT = 1
C
C---- READ DATA FROM FOURIER FILE
C
   50 IF (IKART) 41,52,41
   41 IF (IRZA .LT. 49) GO TO 51
      READ (INUNIT) FBUFF
      IRZA = -1
   51 IRZA = IRZA + 1
      DUMM = IRZA * 10
      IF (IBUFF (DUMM + 1) .EQ. 99) GO TO 1000
      H = IBUFF (DUMM + 1)
      K = IBUFF (DUMM + 2)
      L = IBUFF (DUMM + 3)
      LT = IBUFF (DUMM + 8)
      IF (IKART .EQ. 1) F (NUMMER + 1) = FBUFF (DUMM + 4) ** 2
      IF (IKART .LT. 0) F (NUMMER + 1) = FBUFF (DUMM + 5) ** 2
      SFF = 4.*FBUFF(DUMM+9)**2
      IF(SFF.LT.F(NUMMER+1)) SFF=2.*FBUFF(DUMM+9) * FBUFF(DUMM+4)
      SF(NUMMER+1) = SFF
      CKOF (NUMMER + 1) = FBUFF (DUMM + 10)
      GO TO 100
C
C---- READ A HKL-CARD
C
   52 IF (NUMMER) 53,100,53
   53 I = NUMMER + 1
      IF (INFORM) 80,65,80
   65 GO TO (66,67,68,69,70,71,72,73,74),IHKLF
   66 READ (INUNIT,3665,END=1000) IWN,H,K,L,LT,F(I),SF(I)
      GO TO 90
   67 READ (INUNIT,3675,END=1000) IWN,H,K,L,LT,F(I),TBAR(I),SF(I)
      GO TO 90
   68 READ (INUNIT,3685,END=1000) IWN,H,K,L,LT,SC,F(I),SF(I)
      GO TO 90
   69 READ (INUNIT,3695,END=1000) IWN,H,K,L,LT,SC,F(I),TBAR(I),SF(I)
      GO TO 90
   70 READ (INUNIT,3705,END=1000) IWN,H,K,L,LT,F(I),SF(I),CKOF(I)
      GO TO 90
   71 READ (INUNIT,3715,END=1000) IWN,H,K,L,LT,F(I),TBAR(I),SF(I),
     &CKOF(I)
      GO TO 90
   72 READ (INUNIT,3717,END=1000) IWN,H,K,L,LT,SC,F(I),SF(I),CKOF(I)
      GO TO 90
   73 READ (INUNIT,3725,END=1000) IWN,H,K,L,LT,SC,F(I),TBAR(I),SF(I),
     &CKOF(I)
C++++ILL-SPECIFIC+++++++++++++++++++++++++++++++++++++++++++++++++++++++
   74 	IF(IABSO.GE.0)THEN
 	  IF(INCD.EQ.1)THEN
	    READ(INUNIT,3732,END=1000)NUMOR(I),H,K,L,F(I),SF(I)
	  ELSEIF(INCD.EQ.2)THEN
	    READ(INUNIT,3731,END=1000)NUMOR(I),H,K,L,F(I),SF(I)
	  ELSEIF(INCD.EQ.3)THEN
	    READ(INUNIT,3723,END=1000)NUMOR(I),H,K,L,F(I),SF(I),TBAR(I)
	  ELSEIF(INCD.EQ.4)THEN
	    READ(INUNIT,3728,END=1000)NUMOR(I),H,K,L,F(I),SF(I)
	  ELSE
	    WRITE(*,*)'ERROR: WRONG INCD'
	  ENDIF
	ELSE
 	  IF(INCD.EQ.1)THEN
	    READ(INUNIT,8100,END=1000)NUMOR(I),H,K,L,F(I),SF(I),CKOF(I)
8100	    FORMAT(I6,3I4,2F10.2,33X,F7.2)
	  ELSEIF(INCD.EQ.2)THEN
	    READ(INUNIT,8110,END=1000)NUMOR(I),H,K,L,F(I),SF(I),CKOF(I)
     &                               
8110	    FORMAT(I6,3I4,2F10.2,33X,F7.2,/,15X)
	  ELSEIF(INCD.EQ.3)THEN
	    READ(INUNIT,8120,END=1000)NUMOR(I),H,K,L,F(I),SF(I),CKOF(I),
     &                                TBAR(I)
8120	    FORMAT(I6,3I4,2F10.2,33X,F7.2,//,15X,F8.4)
	  ELSEIF(INCD.EQ.4)THEN
	    READ(INUNIT,8130,END=1000)NUMOR(I),H,K,L,F(I),SF(I),CKOF(I)
8130	     FORMAT(I6,3I4,2F10.2,33X,F7.2/////)
	  ELSE
	    WRITE(*,*)'ERROR: WRONG INCD'
	  ENDIF
	ENDIF
      LT = 1
      IF(F(I).LT.SIGLT*SF(I)) LT = 2
C+++++ILL-SPECIFIC++++++++++++++++++++++++++++++++++++++++++++++++++++++
      GO TO 90
   80 GO TO (81,82,83,84,85,86,87,88),IHKLF
   81 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,F(I),SF(I)
      GO TO 90
   82 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,F(I),TBAR(I),SF(I)
      GO TO 90
   83 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,SC,F(I),SF(I)
      GO TO 90
   84 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,SC,F(I),TBAR(I),SF(I)
      GO TO 90
   85 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,F(I),SF(I),CKOF(I)
      GO TO 90
   86 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,F(I),TBAR(I),SF(I),
     &CKOF(I)
      GO TO 90
   87 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,SC,F(I),SF(I),CKOF(I)
      GO TO 90
   88 READ (INUNIT,IPFOR,END=1000) IWN,H,K,L,LT,SC,F(I),TBAR(I),SF(I),
     &CKOF(I)
C
C---- WAS THIS THE  END CARD
   90 IF (IWN .EQ. ICHAR(9)) GO TO 1000
C
C---- NEGATIVE SIGMAS DO NOT MAKE SENSE...
      SF(I)=ABS(SF(I))
C
C---- F OR I ON CARDS
      IF (IFHKL) 91,100,100
   91 SFF = 4. * SF(I)**2
      F(I) = F(I) * F(I)
      IF(SFF.LT.F(I)) SFF = 2. * SF(I) * SQRT(F(I))
      SF(I) = SFF
C
C---- CALL THE INDEX TRANSFORMATION
  100 IF (IMAT) 102,102,99
   99 CALL TRANS(TRAFO,H,K,L,IGZ)
      IF (IGZ) 102,102,101
  101 WRITE (IO,111) H,K,L
  111 FORMAT(1X,11HREFLECTION ,3I4,22HCANNOT BE TRANSFORMED.)
      GO TO 50
C
C---- COUNT THE REFLECTIONS
  102 NUMMER = NUMMER + 1
      IF (NUMMER .GT. IDIM) CALL ZUVIEL (IO,NUMMER-1,1)
      IF (LT .EQ. 2) ILT = ILT + 1
C
C---- COUNT THE PRINTED LINES
      ILINE = ILINE + 1
C---- SKIP THE AVERAGING FOR STRONG REFLECTIONS (TO ALLOW FOR A
C     MORE ECONOMIC ANISOTROPIC EXTINCTION CORRECTION
C
      IF(F(NUMMER).LE.FINTCU*SF(NUMMER)) GOTO 1200
      AEH = H
      AEK = K
      AEL = L
      GOTO 1210
C
C---- CALCULATE HKL IN THE ASSYMMETRIC UNIT
 1200 IF (SUBRU .LT. 17) CALL REDUC (SUBRU,IZEN,H,K,L,AEH,AEK,AEL)
      IF (SUBRU .EQ. 17) CALL DUMMY (IO,IZEN,H,K,L,AEH,AEK,AEL)
C---- SET SCALE TO A DECENT NUMBER
C
 1210 IF(SC.EQ.0) SC=1
      IF (ILIST) 120,120,131
C
C---- PRINT THE REFLECTION JUST READ
  120 LK = 7
      IF (LT .EQ. 2) LK = 12
      IF (IKART .EQ. 0) GO TO 125
      WRITE (IO,121) H,K,L,AEH,AEK,AEL,ICHAR(LK),F(NUMMER),SF(NUMMER),
     &CKOF(NUMMER)
  121 FORMAT (3I4,6X,3I4,5X,A2,7X,2F9.0,4X,E10.4)
      GO TO 131
  125 IF (IFHKL .GT. 4) WRITE (IO,130) H,K,L,AEH,AEK,AEL,ICHAR(LK),SC,
     &F(NUMMER),SF(NUMMER),CKOF(NUMMER)
      IF (IFHKL .LT. 5) WRITE (IO,130) H,K,L,AEH,AEK,AEL,ICHAR(LK),
     &SC,F(NUMMER),SF(NUMMER)
  130 FORMAT (3I4,6X,3I4,5X,A2,I4,3X,2F9.0,4X,F9.3)
C
C---- STORE H,K AND L ON ONE INTEGER VARIABLE
  131 IHKL (NUMMER) = IPACK (H,K,L)
      IRHKL(NUMMER) = IPACK (AEH,AEK,AEL)
      IF (NUMMER .EQ. 1) GO TO 134
      IF (IRHKL(NUMMER) .LT. IRHKL(NUMMER-1))ISORT = 1
C
C---- CHANGE OF THE IGNORANCE FACTOR
C
  134 IF (IGNO) 132,133,132
  132 SF (NUMMER) = SQRT (SF(NUMMER)**2 + (DIGN1*DIGN1 - DIGN2*DIGN2) *
     &F(NUMMER)**2)
C
C---- EXTINCTION CORRECTION
C
  133 IF (IKART .EQ. 0) GO TO 137
      F (NUMMER) = F (NUMMER) / CKOF (NUMMER)
      SF (NUMMER) = SF (NUMMER) / CKOF (NUMMER)
      GO TO 150
C
C***  ABSORPTIONSKORREKTUR
C
  137 IF (IABSO) 140,140,138
  138 F (NUMMER) = F (NUMMER) * CKOF (NUMMER)
      SF (NUMMER) = SF (NUMMER) * CKOF (NUMMER)
      IF (MU) 140,140,139
  139 TBAR(NUMMER) = ALOG (CKOF(NUMMER)) / MU
C
C---- SCALE GROUPS
C
  140 IF (NSCLF) 150,150,141
  141 IF (SC .GT. NSCLF) CALL ZUVIEL(IO,NSCLF,4)
      IF (SC .EQ. ASC) GO TO 150
      F (NUMMER) = F (NUMMER) * SCLFAK (ASC) / SCLFAK (SC)
      SF (NUMMER) = SF (NUMMER) * SCLFAK (ASC) / SCLFAK (SC)
C
C---- MULTIPLICATION WITH THE OVERAL SCALE  OFLOW
C
  150 IF (OFLOW) 152,152,151
  151 F (NUMMER) = F (NUMMER) * OFLOW
      SF (NUMMER) = SF (NUMMER) * OFLOW
  152 IF (ILINE .NE. MAXLIN) GO TO 50
      GO TO 30
C
C---- READING OF THE DATA IS FINISHED
C
 1000 IF (IPSO .EQ. 1 .OR. IPSO .EQ. 3) RETURN
C
C---- CALL QSORT FOR PRESORTING
C
      IF (ISORT .EQ. 1) CALL QSORT(1,NUMMER,IRHKL,IHKL,F,SF,CKOF,
     &                       TBAR,NUMOR,STACKL,STACKR)
      ISORT = 0
      RETURN
      END
                       SUBROUTINE REDUC
     &           (SUBRU,IZEN,H,K,L,RH,RK,RL)
C
C***  SUBROUTINE DIE FUER ALLE LAUEKLASSEN DEN ZU H,K,L GEHOERIGEN
C***  REFLEX RH,RK,RL IN DER ASSYMMETRISCHEN EINHEIT BERECHNET.
C***  ZU BEGINN DER TRANSFORMATION FUER JEDE LAUEKLASSE SIND AUFGEFUEHRT
C***  STRUKTUR  /  LAUEKLASSE  /  EINGABE AUF DER "STEUER"-KARTE
C***
C***  ES WERDEN KEINE ANDEREN SUBROUTINEN AUFGERUFEN
C
C     WRITTEN BY EGBERT PERENTHALER AND ROLF BACHMANN
C     MAX PLANCK INSTITUT, STUTTGART
C     LAST UPDATE JUNI 1983
C
      INTEGER H,RH,RK,RL,SUBRU
C
C***  WERTUEBERGABE FUER DIE MITTELUNG IDENTISCHER REFLEXE
C
      RH = H
      RK = K
      RL = L
      IF (SUBRU .EQ. 1) RETURN
      I = SUBRU - 1
   10 GO TO (101,102,103,104,105,106,107,108,110,110,110,112,113,114,114
     &), I
C
C***  TRIKLIN  /  1QUER  /  -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
C***  MONOKLIN  (C-ACHSE SENKRECHT)  /  2/M  /  2/MZ
C
  102 IF (IZEN .EQ. 0) GO TO 200
      IF (IZEN .EQ. 2) GO TO 205
      IF (RK .LE. 0) GO TO 210
      RETURN
  205 RL = IABS (RL)
      RETURN
  200 IF (RK .GE. 0 .AND. RL .GE. 0) GO TO 295
      IF (RK .LT. 0 .AND. RL .LT. 0) GO TO 220
      IF (RL .LT. 0 .AND. RK .GE. 0) GO TO 230
  210 RH = -RH
      RK = -RK
      GO TO 295
  220 RH = -H
      RK = -K
  230 RL = -L
  295 IF (RK .EQ. 0) RH = IABS (RH)
      RETURN
C
C***  MONOKLIN (B-ACHSE SENKRECHT)  /  2/M  /  2/MY
C
  103 IF (IZEN .EQ. 0) GO TO 300
      IF (IZEN .EQ. 2) GO TO 305
      IF (RL .LE. 0) GO TO 310
      RETURN
  305 RK = IABS (RK)
      RETURN
  300 IF (RK .GE. 0 .AND. RL .GE. 0) GO TO 395
      IF (RK .LT. 0 .AND. RL .LT. 0) GO TO 320
      IF (RK .LT. 0 .AND. RL .GE. 0) GO TO 330
  310 RH = -RH
      RL = -RL
      GO TO 395
  320 RH = -RH
      RL = -RL
  330 RK = -RK
  395 IF (RL .EQ. 0) RH = IABS (RH)
      RETURN
C
C***  ORTHORHOMBISCH  /  MMM  /  MMM
C
  104 IF (IZEN .EQ. 0) GO TO 420
      IF (IZEN .EQ. 2) GO TO 430
      IF (RH * RK * RL .EQ. 0) GO TO 420
      IF (RL .LT. 0) GO TO 400
      IF (RK .GT. 0) RETURN
      RH = -RH
      RK = -RK
      RETURN
  400 IF (RK .GT. 0) GO TO 410
      RK = -RK
      RL = -RL
      RETURN
  410 RH = -RH
      RL = -RL
      RETURN
  420 RL = IABS (RL)
  430 RH = IABS (RH)
      RK = IABS (RK)
      RETURN
C
C***  TETRAGONAL  /  4/M  /  4/M
C
  105 IF (IZEN .EQ. 0) GO TO 550
      IF (IZEN .EQ. 2) GO TO 530
  500 IF (RH * RK .EQ. 0) GO TO 520
      IF (RH * RK .LT. 0) GO TO 510
      RH = IABS (RH)
      RK = IABS (RK)
      RETURN
  510 RH = IABS (K)
      RK = IABS (H)
      RETURN
  520 RH = MAX0 (IABS (RH) , IABS (RK))
      RK = 0
      RETURN
  530 IF (RL .EQ. 0) GO TO 500
      IF (RL .GT. 0) GO TO 540
      RH = K
      RK = -H
      RL = -RL
  540 IF (RK .GT. 0) RETURN
      IF (RK .EQ. 0) GO TO 545
      RH = -RH
      RK = -RK
      RETURN
  545 RH = IABS (RH)
      RETURN
  550 RH = IABS (H)
      RK = IABS (K)
      RL = IABS (L)
      IF (RK .EQ. 0) RETURN
      IF (RH .GT. 0) GO TO 560
      RH = RK
      RK = 0
      RETURN
  560 I = 0
      IF (H .LT. 0) I = I + 1
      IF (K .LT. 0) I = I + 1
      IF (I .NE. 1) RETURN
      KA = RK
      RK = RH
      RH = KA
      RETURN
C
C***  TETRAGONAL  /  4/MMM  /  4/MMM
C
  106 IF (IZEN .EQ. 0 .OR. IZEN .EQ. 2 .OR. RL .EQ. 0) GO TO 680
      IF (IZEN .EQ. 4) GO TO 660
      IF (RL .GT. 0) GO TO 600
      RK = -RK
      RL = -RL
  600 IF (RK * RL .EQ. 0) GO TO 620
      IF (IZEN .EQ. 3) GO TO 630
      IF (RH * RK .GT. 0) GO TO 610
      RH = IABS (K)
      RK = IABS (H)
      RETURN
  610 RH = IABS (RH)
      RK = IABS (RK)
      RETURN
  620 RH = MAX0 (IABS (RH) ,IABS (RK))
      RK = 0
      RETURN
  630 KB = 1
      IF (RH * RK .LT. 0) KB = -1
      RH = IABS (RH)
      RK = IABS (RK)
      KA = MAX0 (RH , RK)
      RK = MIN0 (RH , RK)
      RH = KA * KB
      RETURN
  660 IF (RL .GT. 0) GO TO 670
      RH = K
      RK = H
      RL = -RL
  670 RH = IABS (RH)
      RK = IABS (RK)
      RETURN
  680 RH = IABS (H)
      RK = IABS (K)
      RL = IABS (L)
      IF (RK .LE. RH) GO TO 690
      KA = RH
      RH = RK
      RK = KA
  690 IF (IZEN .EQ. 2) RL = L
      RETURN
C
C***  TRIGONAL (RHOMBOEDRISCH)  /  3QUER  /  -3RHO
C
  107 IF (IABS(RL).LE.IABS(RK)) GOTO 700
      IF (IABS(RK).GT.IABS(RH)) GOTO 710
      KA=RH
      RH=RL
      RL=RK
      RK=KA
  700 IF (IABS(RL).LE.IABS(RH)) GOTO 720
  710 KA=RH
      RH=RK
      RK=RL
      RL=KA
  720 IF(IABS(RH).EQ.IABS(RL).AND.RH.NE.RK) GOTO 710
      IF(IZEN.EQ.1)RETURN
      IF(RL)730,750,740
  730 RL=-RL
      RK=-RK
      RH=-RH
  740 RETURN
  750 IF(RK)730,760,740
  760 RH=IABS(RH)
      RETURN
C
C***  TRIGONAL (RHOMBOEDRISCH)  /  3QUER M  /  -3M
C
  108 IF (IZEN .EQ. 1) GO TO 811
      IF (RL.GE.RK) GOTO 810
      KA=RK
      RK=RL
      RL=KA
  810 IF (RK.GE.RH) GOTO 820
      KA=RK
      RK=RH
      RH=KA
  820 IF (RL.GT.RK) GOTO 830
      KA=RK
      RK=RL
      RL=KA
  830 IF (IZEN.EQ.2) RETURN
      IF (RK) 840,860,850
  840 KA=RL
      RL=-RH
      RK=-RK
      RH=-KA
  850 RETURN
  860 IF (-RH.GT.RL .OR. RL.EQ.0) GOTO 840
      RETURN
  811 IF (IABS(RH).LE.IABS(RK)) GOTO 821
      IF (IABS(RK).GT.IABS(RL)) GOTO 822
      KA=RH
      RH=RK
      RK=RL
      RL=KA
  821 IF (IABS(RH).LE.IABS(RL)) GOTO 831
  822 KA=RH
      RH=RL
      RL=RK
      RK=KA
  831 IF (RH)841,861,851
  841 RH=-RH
      KA=RK
      RK=-RL
      RL=-KA
  851 IF (RH.NE.IABS(RK) .AND. RH.NE.IABS(RL) .OR. RH.EQ.RK) RETURN
      IF (IABS(RK).EQ.IABS(RL)) GOTO 852
      IF (RH.EQ.-RK) RL=IABS(RL)
      IF (RH.EQ.-RL) RK=IABS(RK)
      IF (RH.EQ.RL) GOTO 853
      RETURN
  852 RK=RH
      RL=-RH
      RETURN
  853 KA=RL
      RL=RK
      RK=KA
      RETURN
  861 IF (IABS(RK)-IABS(RL))881,891,871
  871 KA=RK
      RK=-RL
      RL=-KA
  881 IF(RK.EQ.0)RL=IABS(RL)
  882 RETURN
  891 IF (RK) 871,882,882
C
C***  TRIGONAL (HEXEGONAL)  /  3QUER     /  -3HEX
C***  TRIGONAL (HEXEGONAL)  /  3QUER 1M  /  -31M
C***  TRIGONAL (HEXAGONAL)  /  3QUER M1  /  -3M1
C
  110 IF (IABS(RH+RK).GE.IABS(RK)) GOTO 1900
      IF (IABS(RK).LT.IABS(RH)) GOTO 1910
      KA=RH
      RH=-RH-RK
      RK=KA
 1900 IF (IABS(RH+RK).GE.IABS(RH)) GOTO 1920
 1910 KA=RK
      RK=-RK-RH
      RH=KA
 1920 IF(IABS(RH+RK).EQ.IABS(RH).AND.RH.NE.0) GOTO 1910
      IF (I.EQ.9) GOTO 1921
      J=1
      IF ((I.EQ.10.AND.IZEN.EQ.1) .OR. (I.EQ.11.AND.IZEN.NE.1)) J=-1
 1020 IF(IABS(RH+RK).NE.IABS(RK)) GOTO 1021
      IF (RH.EQ.0) GOTO 1022
      IF(J.EQ.1.AND.(IZEN.NE.1.OR.RL.GE.0)) GOTO 1021
      IF(J.NE.1.AND.RH.LT.0) GOTO 1021
      GOTO 1023
 1022 IF(J.NE.1.AND.RL.LT.0) GOTO 1023
      IF(J.NE.1.OR.RK.LT.0) GOTO 1021
 1023 IF(IZEN.EQ.1)RL=-RL
      RK=-J*(RH+RK)
      RH=J*RH
 1021 IF(IABS(RH)-IABS(RK)) 1040,1030,1031
 1030 IF(IZEN.EQ.1.AND.(J.EQ.1.OR.RH.EQ.0))RL=IABS(RL)
      IF(J.EQ.1.OR.RH.LE.0) GOTO 1040
 1031 KA=RH
      RH=J*RK
      RK=J*KA
      IF(IZEN.EQ.1)RL=-RL
 1040 IF(IZEN.NE.0)RETURN
      IF(RL)1110,1120,1130
 1110 RL=-RL
      RH=-RH
      RK=-RK
      GOTO 1020
 1120 IF(RH.LT.0.OR.(RH.EQ.0.AND.RK.LT.0))GOTO 1121
      RH=-RH
      RK=-RK
 1121 IF (IABS(RH+RK).NE.IABS(RK).OR.(-RH-RK.GT.RK))RETURN
      RK=-RK-RH
 1130 RETURN
 1921 IF(IZEN.EQ.1)RETURN
      IF(RL)1930,1950,1940
 1930 RL=-RL
      RK=-RK
      RH=-RH
 1940 RETURN
 1950 IF(RH.LT.0.OR.(RH.EQ.0.AND.RK.LT.0))RETURN
      RK=-RK
      RH=-RH
      RETURN
C
C***  HEXAGONAL  /  6/M  /  6/M
C
  112 IF (IZEN .EQ. 2) GO TO 1240
      IF (IZEN .EQ. 0) RL = IABS (RL)
      IF (RH * RK .EQ. 0) GO TO 1230
      IF (RH .GT. 0 .AND. RK .GT. 0) RETURN
      IF (RH .GT. 0) GO TO 1210
      RH = -RH
      RK = -RK
      IF (RK .GT. 0) RETURN
 1210 IF (RH .LT. IABS (RK)) GO TO 1220
      KA = RK
      RK = RH + RK
      RH = -KA
      RETURN
 1220 KA = RH
      RH = -RH -RK
      RK = KA
      RETURN
 1230 RH = MAX0 (IABS (RH), IABS (RK))
      RK = 0
      RETURN
 1240 RL = IABS (RL)
      IF (RH .GE. 0 .AND. RK .GE. 0) RETURN
      IF (RH .GE. 0 .AND. RK .LT. 0) GO TO 1250
      IF (RK .GT. 0 .AND. IABS (RH) .LT. RK) RETURN
      KA = RH
      RH = RK
      RK = -KA -RK
      RETURN
 1250 KA = RK
      RK = RH
      RH = -RH -KA
      RETURN
C
C***  HEXAGONAL  /  6/MMM  /  6/MMM
C
  113 J=1
      IF(IZEN.EQ.2.OR.IZEN.EQ.3)J=-1
      IF(IABS(RH+RK).GE.IABS(RH)) GOTO 1300
      RH=-J*(RH+RK)
      RK=J*RK
      IF(IZEN.EQ.1)RL=-RL
 1300 IF(IABS(RH+RK).GE.IABS(RK)) GOTO 1310
      RK=-J*(RH+RK)
      RK=J*RK
      IF(IZEN.EQ.1)RL=-RL
 1310 IF(IZEN-1)1380,1320,1380
 1320 IF(RL)1330,1380,1340
 1330 RL=-RL
      KA=RH
      RH=RK
      RK=KA
 1340 IF(RK)1350,1360,1370
 1360 RH=IABS(RH)
      RETURN
 1350 RH=-RH
      RK=-RK
 1370 RETURN
 1380 IF(IZEN.EQ.0.OR.IZEN.GE.3)RL=IABS(RL)
      IF(IABS(RH).GE.IABS(RK)) GOTO 1390
 1381 KA=RH
      RH=RK*J
      RK=KA*J
 1390 IF (IZEN.EQ.3.AND.RH.LT.0) GOTO 1381
      IF (IZEN.GE.3) RETURN
      IF (RK) 1350,1360,1370
C
C***  KUBISCH  /  M3  /  M3
C***  KUBISCH  /  M3M  /  M3M
C
  114 J=1
      IF (RH*RK*RL.LT.0)J=-1
      RH=IABS(RH)
      RK=IABS(RK)
      RL=IABS(RL)
      IF (RL.LT.RK) GOTO 1400
      IF (RH.LT.RK) GOTO 1410
      KA=RH
      RH=RL
      RL=RK
      RK=KA
 1400 IF (RL.LT.RH) GOTO 1420
 1410 KA=RH
      RH=RK
      RK=RL
      RL=KA
 1420 IF (RH.EQ.RL.AND.RK.NE.RL) GOTO 1410
      IF (IZEN.GE.1) RH=J*RH
      IF (I.EQ.14) RETURN
      IF (IZEN-1) 1430,1440,1450
 1430 IF (RH.GE.RK) RETURN
      KA=RH
      RH=RK
      RK=KA
      RETURN
 1440 IF (RL.EQ.0.OR.RL.EQ.RK)RH=IABS(RH)
      IF (RL.EQ.0.) GOTO 1430
      IF (RH.GT.0) RETURN
      KA=RH
      RH=RK
      RK=-KA
      RETURN
 1450 IF (RH.GE.0) GOTO 1430
      IF (-RH.GE.RK) RETURN
      KA=RH
      RH=-RK
      RK=-KA
      RETURN
C***********************************************************************
      END
      SUBROUTINE TRANS(TMAT,H,K,L,IGZ)
C
C     ****************
C     SUBROUTINE TRANS
C     ****************
C
C***  DIE ROUTINE "TRANS" MULTIPLIZIERT DEN HKL-VEKTOR MIT DER
C***  MATRIX TMAT
C
C     (EGBERT PERENTHALER MPI/FKF STUTTGART)
C
C
      DIMENSION TMAT(3,3),H1(3),H2(3)
      INTEGER H
      H1(1) = FLOAT(H)
      H1(2) = FLOAT(K)
      H1(3) = FLOAT(L)
      DO 10 I = 1,3
   10 H2(I) = 0.
      DO 20 I = 1,3
      DO 20 J = 1,3
   20 H2(I) = H2(I) + TMAT(I,J) * H1(J)
      IGZ = 0
      DO 30 I = 1,2
   30 IF (ABS (AINT (H2(I)) - H2(I)) .GT. 0.1) IGZ = 1
      IF (IGZ .EQ. 1) RETURN
      H = IFIX (H2(1))
      K = IFIX (H2(2))
      L = IFIX (H2(3))
      RETURN
C***********************************************************************
      END
      SUBROUTINE QSORT(IMIN,IMAX,IRHKL,IHKL,F,SF,CKOF,TBAR,NUMOR,
     &           STACKL,STACKR)
C
C     ********************
C     * SUBROUTINE QSORT *
C     ********************
C
C     DIE DERZEIT SCHNELLSTE SORTIERROUTINE DER WELT, UEBERSETZT
C     AUS EINEM PASCAL-PROGRAMM VON
C     SIE SORTIERT DIE EINGELESENEN DATENFELDER SO, DASS GESCHLOSSENE
C     GRUPPEN SYMMETRIEAEQUIVALENTER REFLEXE ENTSTEHEN.
C
C     (EGBERT PERENTHALER MPI/FKF STUTTGART 14.03.1980)
C
      DIMENSION STACKL(1),STACKR(1),IRHKL(1),IHKL(1),F(1),SF(1),CKOF(1)
     &         ,TBAR(1),NUMOR(1)
      INTEGER R,S,STACKL,STACKR
      S = 1
      STACKL(1) = IMIN
      STACKR(1) = IMAX
    5 L = STACKL(S)
      R = STACKR(S)
      S = S-1
   10 I = L
      J = R
      IX = IRHKL((L+R) / 2)
   20 IF (IRHKL(I) - IX) 30,40,40
   30 I = I + 1
      GO TO 20
   40 IF (IX - IRHKL(J)) 50,60,60
   50 J = J - 1
      GO TO 40
   60 IF (I .GT. J) GO TO 70
      IW = IRHKL(I)
      IRHKL(I) = IRHKL(J)
      IRHKL(J) = IW
      IW = IHKL(I)
      IHKL(I) = IHKL(J)
      IHKL(J) = IW
      W = F(I)
      F(I) = F(J)
      F(J) = W
      W = SF(I)
      SF(I) = SF(J)
      SF(J) = W
C
C---- NOTE THAT CKOF DEALS no longer WITH NUMORS AS WELL
C
      w = numor(i)
      numor(i) = numor(j)
      numor(j) = w
      W = CKOF(I)
      CKOF(I) = CKOF(J)
      CKOF(J) = W
      W = TBAR(I)
      TBAR(I) = TBAR(J)
      TBAR(J) = W
      I = I + 1
      J = J - 1
      IF (I .LE. J) GO TO 20
   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
                        SUBROUTINE DUMMY
     &                (IO,I,H,K,L,RH,RK,RL)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C +                                                                    +
C + SUBROUTINE TO BE WRITTEN BY THE USER TO TRANSFORM H,K, AND L TO    +
C + THE ASSYMMETRIC UNIT OF A NON STANDARD SETTING                     +
C +                                                                    +
C + THE VALUES OF H,K, AND L SHOULD NOT BE CHANGED. RH, RK, AND RL     +
C + SHOULD BE THE TRANSFORMED INDICES.                                 +
C +                                                                    +
C + THIS PROGRAMME IS CALLED BY THE SUBROUTINE AVERA1                  +
C +                                                                    +
C + THIS PROGRAMME DO NOT CALL ANY OTHER SUBROUTINE                    +
C +                                                                    +
C + IN CASE OF AN OVERLAY STRUCTURE IT IS PART OF THE OVERLAY  AVER1   +
C +                                                                    +
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C---- TYPE STATEMENTS
C     ---------------
C
      INTEGER H
C
C---- WRITE ERROR MESSAGE IF DUMMY IS CALLED BUT THE USER HAS NOT
C---- WRITTEN A ROUTINE
C
      WRITE (IO,20)
   20 FORMAT(1X,47H***** THE ROUTINE DUMMY WAS CALLED TO USE A NON,
     &16HSTANDARD SETTING/44H0THIS ROUTINE HAS TO BE WRITTEN BY THE USER
     &.)
C
      CALL EXIT
      RETURN
      END
