      PROGRAM DDMAIN
***************************************      DDMAIN FORTRAN = DDMAIN.FOR
***  prepare input files for FOUR, etc.        Last update: 11 Nov. 1999
***  includes MERBIN, FCALC, AUTOFR ...        Design:  SGG 1987 CS 1988
***************************************
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      EQUIVALENCE (LIS2, IFILE(8)), (ICRYS, IFILE(3))
      CALL KEPROG ('DDMAIN')
      WRITE (LIS2, FMT = '('' Last DDMAIN update: 11 Nov. 1999'')')
      KEYS(19) = 4
      CALL DDMINI (KEYD)
      IDDOKA = KEYS(10)
      IF (IDDOKA .EQ. 17) GOTO 999
      IF (KEYD .EQ. 9) GOTO 900
      CALL DICALC
      IF (KEYD .EQ. 2 .OR. KEYD .EQ. 3) CALL WISSEN
  900 CALL FILCLO (ICRYS, 'KEEP')
      CALL KEPROX
  999 CONTINUE
      WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)')
      STOP 99
      END
      SUBROUTINE DDMINI (KEYDQ)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1)), (IATOMS, IFILE(2))
      EQUIVALENCE (IDDS, IFILE(1)), (ICRYS,IFILE(3))
      EQUIVALENCE (ICON, IFILE(4)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IPR1, IFILE(6))
      EQUIVALENCE (IATOLD, IFILE(10))
      EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (NRECYR, KEYS(11)), (KEYWIL, KEYS(12))
      LOGICAL      SWPRI, EXPAND, SWRECY, NORECY, LSC98
      EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (SWRECY, SWITCH(17)), (NORECY, SWITCH(18))
      EQUIVALENCE (LSC98, SWITCH(19))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      DIMENSION BUFFOX(10)
      DIMENSION HCON(3)
      DIMENSION MHKL(3)
      DIMENSION R2CYC(20), R2CYCA(20)
      PARAMETER (LCMAX = 10)
      CHARACTER * 6 LCONDA(LCMAX)
      DATA LCONDA / 'DDMAIN', 'OPTION', 'DIRP1',  'PRINT',  'EXPAND',
     *              'SCALE' , 'BBB'   , 'STLMAX', 'WILSON', 'MAXHKL' /
      DATA SCALX, BPX, BRX, SCALAT / -1., -1., -1., -1. /
      DATA MHKL / 0, 0, 0 /
      DATA BPOLD / 0.0 / , NATL /0/
      CALL KERNZA (0.0, BUFFC, MAXBUF)
      IF (LIT(3).EQ.'NORECY' .OR. LIT(2).EQ.'NORECY') NORECY = .TRUE.
      NRECYR = 0
      CALL RDCRYS (ICRYS)
      DO 110 I=1,NTYPE
  110 BUFFO(I) = CELALL(I) / ZET
      I = NTYPE
      J = NINT(ZET)
      WRITE (LIS2, 114) J, (CELATY(K), BUFFO(K), K=1,I)
  114 FORMAT (' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) /
     *                           ( 8X, 6(2X,A2,F6.1)))
      CALL KERNZA (  9999., HCON, 3)
      CALL KERNZA (  0., HKLMAX, 3)
      STLCON = 9999.9
      STLMAX = 0.0
      BUFFFT(30) = 0.
      BUFFFT(31) = 0.
      KEYOK = 0
      BOV = 2.0
      BP = BOV
      BR = BOV
      SCALE = 1.
      KEYD = -1
      KEYWIL = 0
  120 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)
      GOTO (120, 2, 3, 120, 3, 6, 7, 8, 9, 10), KEND
      IF (KEND.EQ.0) GOTO 140
  122 CALL KERROR ('No option given or wrong data', 120, 'DDMINI')
  2   IF (NFNUM.LE.0) CALL KERROR
     *   ('No OPTION number given in CONDA file', 2, 'DDMINI')
      KEYD = NINT(FNUM(1))
      KEYDQ = KEYD
      IF (KEYD.GT.9 .OR. KEYD.LT.0) CALL KERROR ('Wrong option given',
     *                                            2, 'DDMINI')
      IF (KEYD .GE. 5) THEN
         WRITE (LIS1, FMT='('' DDMAIN input OPTION :'', I2)') KEYD
         ENDIF
      IF (KEYD .EQ. 1 .AND. LIT(3) .EQ. 'OK') KEYOK = 1
      KEYDS = NINT(FNUM(2))
      NRECY = NINT(FNUM(3))
      NATL = NINT(FNUM(4))
      IF (NRECY .LE. 0) GOTO 120
      SWRECY = .TRUE.
      NRECYR = NRECY / 10 + 1
      IF (KEYD.EQ.1 .OR. KEYD.EQ.3) WRITE (CHOUT, FMT=
     *   '(34X, '' prepare for PHASEX-/-Fourier cycle'', I3)') NRECYR
      CALL SHOUT
      KEYWIL = 4
      GOTO 120
  3   EXPAND = .TRUE.
      KEYWIL = 4
      WRITE (LIS2, 123)
  123 FORMAT (' EXPAND data to P1 symmetry (or centered equivalent)')
      GOTO 120
  6   IF (NFNUM.NE.1) CALL KERNER (6, 'DDMINI')
      IF (FNUM(1) .LT. 0.0001) GOTO 120
      SCALE = FNUM(1)
      WRITE (LIS2, 125) SCALE
  125 FORMAT (' Scale from CONDA file: Scale =', F9.5)
      KEYWIL = 4
      GOTO 120
  7   IF (NFNUM.LT.1) CALL KERNER (7, 'DDMINI')
      IF (FNUM(1).GT.0.0001) THEN
         BOV = FNUM(1)
         BP = BOV
         BR = BOV
         ENDIF
      IF (FNUM(2).GT.0.0001) BP = FNUM(2)
      IF (FNUM(3).GT.0.0001) BR = FNUM(3)
      WRITE (LIS1, 126) FNUM(1), FNUM(2), FNUM(3)
  126 FORMAT (' Temp. factors from CONDA: Bov=',
     *          F6.3, ' Bp =', F6.3, ' Br =', F6.3)
      WRITE (LIS1, 127) BOV, BP, BR
  127 FORMAT (' Temp. factors used      : Bov=',
     *          F6.3, ' Bp =', F6.3, ' Br =', F6.3)
      KEYWIL = 4
      GOTO 120
  8   IF (NFNUM.NE.1) CALL KERNER (8, 'DDMINI')
      STLMAX = FNUM(1)
      WRITE (LIS1, 128) STLMAX
      WRITE (LIS2, 128) STLMAX
  128 FORMAT (' Skip reflections if  sin(th)/lambda  >', F8.4)
      GOTO 120
  9   IF (NLIT.EQ.1) GOTO 120
      IF (NLIT.EQ.2 .AND. LIT(2).EQ.'NO') THEN
          KEYWIL = 4
          WRITE (LIS2, 130)
  130     FORMAT (' No WILSON-PARTHASARATY plot nor WILSON-BpBr-plot')
      ELSEIF (NLIT.EQ.2 .AND. LIT(2).EQ.'PARTHA') THEN
          KEYWIL = -2
          WRITE (LIS2, 133)
  133     FORMAT (' Only WILSON-PARTHASARATY plot, no WILSON-BpBr-plot')
      ELSEIF (NLIT.EQ.3 .AND. LIT(2).EQ.'FIX' .AND.
     *            LIT(3).EQ.'BP') THEN
          KEYWIL = 1
      ELSEIF (NLIT.EQ.3 .AND. LIT(2).EQ.'FIX' .AND.
     *            LIT(3).EQ.'BR') THEN
          KEYWIL = 2
      ELSEIF (NLIT.EQ.4 .AND. LIT(2).EQ.'FIX' .AND.
     *            (LIT(3).EQ.'BP' .OR. LIT(4).EQ.'BP') .AND.
     *            (LIT(4).EQ.'BR' .OR. LIT(3).EQ.'BR')) THEN
          KEYWIL = 3
      ELSE
          CALL KERNER (9, 'DDMINI')
          ENDIF
      GOTO 120
  10  IF (NFNUM.NE.3) CALL KERROR ('MAXHKL input error', 10, 'DDMINI')
      J = 0
      DO 137 I = 1, 3
      K = NINT(FNUM(I))
      IF (K .LT. 0) K = 0
      MHKL(I) = K
  137 CONTINUE
      IF (J .EQ. 0) GOTO 120
      WRITE (LIS1, 138) MHKL
  138 FORMAT (' Skip reflections if indices exceed MAXHKL =', 3I3)
      CALL KERI2F (MHKL, HKLMAX, 3)
      GOTO 120
  140 IF (KEYD .LT. 0) GOTO 122
      CALL FILCLO (ICON, 'KEEP')
      IF (NRECYR .GT. 0) GOTO 141
      CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'INPUT', KINQU)
      IF (KINQU.NE.0 .OR. KEYD.EQ.9) CALL MERBIN
      IF (KEYD .EQ. 9) RETURN
  141 CALL LOGRD (IDDL, 'MERBSC', KLOG)
      IF (KLOG .LT. 0 .OR. LIT(2) .NE. 'SCALE') THEN
         CHOUT=' MERBIN SCALE not found on DDLOG file: rerun MERBIN'
         CALL SHOUT
         CALL MERBIN
         GOTO 141
         ENDIF
      SCALE = FNUM(2)
      BOV = FNUM(3)
      BP = BOV
      BR = BOV
      WRITE (LIS2, 142) SCALE, BOV
  142 FORMAT (' Data from DDLOG: Scale =', F9.5, ' Bov:', F6.3)
      CALL LOGRD (IDDL, 'NREF', KLOG)
      IF (KLOG .LT. 0 .OR. FNUM(2) .LT. 0.9) THEN
         CHOUT=' Nr. of refl. not found on DDLOG file: what happened?'
         CALL SHOUT
         CALL KERROR ('You cleared too much, probably!', 114, 'DDMINI')
         ENDIF
      NREFL = NINT(FNUM(2))
      CALL LOGRD (IDDL, 'BP', KLOG)
      IF (KLOG.GT.0) THEN
         SCALX = FNUM(2)
         BPX = FNUM(3)
         BRX = FNUM(4)
         ENDIF
      CALL FILCLO (IDDL, 'KEEP')
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IF (STLMAX.LT.0.0001 .OR. STLMAX.GT.BUFFO(6)) STLMAX = BUFFO(6)
      CALL KERNAB (BUFFO(7), HKLMAX, 3)
      DO 7142 I = 1,3
      IF (MHKL(I) .LE. 0) GOTO 7142
      F123 = MHKL(I)
      IF (F123 .LT. HKLMAX(I) ) HKLMAX(I) = F123
 7142 CONTINUE
      CALL KERNAB (BUFFO(5), BUFFC(5), MAXBUF - 4)
      IF (KEYD .NE. 4) GOTO 143
      NAT  = 1
      KEYT = 1
      CALL KERNZA (0., ATXYZ, 10)
      IZAT(1) = 1
      ATNAME(1) = 'H'
      CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT)
      CALL KERNAB (BUFFO(5), BUFFFT(5), 23)
      BUFFFT(28) = 2.
      IF (KEYDS .EQ. 1) BUFFFT(28) = 6.
      GOTO 935
  143 CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found',
     *   143, 'DDMINI')
      CALL KERINA (IATOMS, LIT, 1, LEND)
      IF (LIT(1) .NE. 'ATOMS') CALL KERROR
     *   (' Incorrect header on ATOMS file', 143, 'DDMINI')
      REWIND IATOMS
      NSET = 0
      CALL ATIN7 (NSET)
      IF (NSET .NE. 1) CALL KERROR ('Kan niet', 143, 'DDMINI')
      IF (NFNUM .GT. 0) THEN
         IF (LIT(NLIT). EQ. 'SC=' .AND.
     *   FNUM(NFNUM) .GT. 0.0001) SCALAT = FNUM(NFNUM)
         ENDIF
      NATINP = NAT
      IF (KEYT .EQ. 3 .AND. EXPAND) CALL KERROR
     *  ('EXPAND with anisotropic temp.f. not permitted', 143, 'DDMINI')
      IF (KEYT .EQ. 2 .AND. EXPAND) THEN
         WRITE (LIS1, FMT='('' Ignore individual temp. factors'')')
         KEYT = 1
         DO 145 I = 1, NAT
  145    ATXYZ(5,I) = 0.0
         ENDIF
      IF (KEYD .EQ. 2 .OR. SWRECY) THEN
         KEYWIL = 4
         IF (SCALX .GT. 0.0) THEN
            SCALE = SCALX
            BP = BPX
            BR = BRX
            ENDIF
         ENDIF
         IF (SWITCH(1)) WRITE (LIS2, 147) SCALE, BP, BR
  147    FORMAT (' PTB TEMP: SCALE, BP, BR  =', F8.4, 2F6.3)
      IF (NRECYR .GE. 3 .AND. SCALAT .GT. 0.) THEN
         SCALE = SCALAT
         IF (SWITCH(1)) WRITE (LIS2, 148) SCALE
  148    FORMAT (' PTB TEMP: OLD SCALE (SCALAT) =', F8.4)
         ENDIF
      IF (KEYT .GE. 2) KEYWIL = 4
      IF (KEYD.EQ.2) THEN
         CALL FILINQ (IBINDU, 'BINDUA', 'UNFORMATTED', 'INPUT', KINQU)
         CALL FILINQ (IBINDI, 'BINDIF', 'UNFORMATTED', 'INPUT', KINQI)
         IF (KINQU.EQ.-1 .OR. KINQI.EQ.-1) CALL KERROR
     *      (' No BINDUA or BINDIF file found', 0, 'DDMAIN')
         CALL BINIFF (1,IBINDU,'BINDUA',FITDUA,NITDUA,BUFDUA,KENDUA)
         R2X = BUFDUA(7)
         WRITE (LIS2, FMT='('' R2X ='', F6.3)') R2X
         BUFFFT(30) = R2X
         CALL BINIFF (1,IBINDI,'BINDIF',FITDIF,NITDIF,BUFDIF,KENDIF)
         GOTO 255
         ENDIF
      SCALEO = SCALE
      IF (.NOT. SWRECY) CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT)
      CALL ATOMPR (LIS2, 7, ATXYZ, ATNAME, IZAT, NAT)
      IF (KEYT.EQ.1) WRITE (LIS2, 155)
  155 FORMAT (' Overall B or Bp used for struct.f. calculation')
      IF (KEYT.EQ.2) WRITE (LIS2, 156)
  156 FORMAT (' Individual isotropic temp.f. on file: ignore overall B')
      IF (KEYT.EQ.3) WRITE (LIS2, 157)
  157 FORMAT (' Mixed / anisotropic temp.factors used')
      BUFFC(16) = SCALE
      BUFFC(17) = BOV
      WRITE (LIS2, FMT='('' SCALE and temperature factors to'',
     *                   '' calculate structure factors Fp:'')')
      WRITE (LIS2, FMT='('' SCALE factor:'',22X,''SC ='', F8.3)') SCALE
      IF (KEYT .GT. 1) THEN
         WRITE (LIS2, 172)
  172    FORMAT (' Use individual temp.factors for known atoms')
         BPOLD = BP
         BP = 0.
         GOTO 175
         ENDIF
      WRITE (LIS2, 173) BP
  173 FORMAT (' Overall  temp.f. for  known atoms: Bp =', F8.3)
      IF (ABS(BP-BR).LT.0.001) GOTO 180
  175 WRITE (LIS2, 177) BR
  177 FORMAT (' Overall temp.f. for unknown atoms: Br =', F8.3)
  180 BUFFC(18) = SCALE
      BUFFC(19) = BP
      BUFFC(20) = BR
      BUFFC(21) = STLMAX
      CALL KERNAB (HKLMAX, BUFFC(22), 3)
      IF (KEYT.EQ.3 .AND. KEYD.GE.5) CALL KERROR
     *   ('Anisotr.t.f. not allowed for AUTOR2 TEST', 180, 'DDMINI')
      IF (NRECYR .LE. 2) GOTO 7167
      CALL KERNZI (0, IZTYPE, 10)
      DO 7157 J=1,NTYPE
      CALL ATOMIZ (CELATY(J), NLET, IZ)
      IZTYPE(J) = IZ
 7157 CONTINUE
      CALL KERNZA (0.0, CELPAR, NTYPE)
      AAMULT = FLOAT(IMULT)
      DO 7161 I=1,NAT
      DO 7160 J=1,NTYPE
      IF (IZAT(I).NE.IZTYPE(J)) GOTO 7160
      CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AAMULT
 7160 CONTINUE
 7161 CONTINUE
      IIII = 0
      DO 7162 J=1,NTYPE
      IF ( ( IZTYPE(J) .GE. 10 .AND. CELPAR(J) .GT. CELALL(J) ) .OR.
     *     (IZTYPE(J) .GE. 2 .AND. CELPAR(J) .GT. CELALL(J) .AND.
     *      NRECYR .GE. 7) ) THEN
         CELALL(J) = CELPAR(J)
         IIII = 1
         ENDIF
 7162 CONTINUE
      IF (IIII .EQ. 0) GOTO 7167
      DO 7165 I=1,NTYPE
 7165 BUFFOX(I) = CELALL(I) / ZET
      J = NINT(ZET)
      WRITE (LIS1, 7166) J, (CELATY(K), BUFFOX(K), K=1,NTYPE)
 7166 FORMAT (/' NOTE: Cell Contents reset [ output FOUR !! ] :'/
     *  ' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) /
     *                           ( 8X, 6(2X,A2,F6.1))/)
 7167 CONTINUE
      CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT)
      IF (EXPAND) GOTO 183
      IF (PSQ .LE. 1.0) THEN
         WRITE (CHOUT, FMT='('' Scattering fraction, p**2 = '',
     *      F7.3)') PSQ
         CALL SHOUT2
      ELSE
         IF (PSQ .LE. 1.3) THEN
            WRITE (CHOUT, FMT='(
     *         '' Warning scattering fraction, p**2 = '', F7.3)') PSQ
            IF (PSQ .LT. 1.1) THEN
               CALL SHOUT2
            ELSE
               CALL SHOUT
               WRITE(CHOUT,FMT='('' Note: this may cause errors'')')
               CALL SHOUT
               WRITE (CHOUT, FMT='('' Cell contents incorrect?'',
     *            '' Reset p**2 to 1.0'')')
               CALL SHOUT
               WRITE(CHOUT,FMT='('' Call CRYSDA to modify contents'')')
               CALL SHOUT
               ENDIF
            PSQ = 1.0
         ELSE
            WRITE (CHOUT, FMT='(
     *         ''0Scattering fraction, p**2 = '', F7.3)') PSQ
            CALL SHOUT
            WRITE (LIS1, 8183) CCODE
            WRITE (IPR1, 8183) CCODE
 8183 FORMAT (/' Too many atoms, or too many HEAVY atoms. '/
     * '                    --------------       Check your data:'/
     * ' if the cell contents are incorrect: call CRYSDA,   else:'/
     * ' modify the contents of the ATOMS file !' /
     * ' If a complete molecule lies on a symmetry element:' /
     * '      remove the symmetry-redundent part of it,      else:'/
     * ' if FOUR recycling led to too many HEAVY atoms:' /
     * '      rename some of the HEAVY atoms to lower its Z value!'/
     * ' Note:  p**2 up to 1.3 is acceptable but may cause scaling'/
     * '      errors.   You should make  p**2 = 1,  approximately,'/
     * '      and then  we suggest to you to continue  by calling:'/
     * '      DIRDIF ', A6, ' NOFREE'/
     * '                                                Good luck!'/)
            CALL KERROR ('Too many atoms input', 8183, 'DDMINI')
            ENDIF
         ENDIF
  183 CONTINUE
      IF (KEYT .GT. 1) BP = BPOLD
      BPAV = BP
      IF (KEYT .NE. 3 .AND. .NOT.EXPAND) CALL FCALII (NSET)
      CALL LOGRD(IDDL, 'NAT=', KLOG)
      NATS = 0
      IF (KLOG .GT. 0) NATS = NINT(FNUM(3))
      CALL FILCLO (IDDL, 'KEEP')
      BUFFC(25) = NAT
      BUFFC(26) = P1SQ
      BUFFC(27) = PSQ
      IF (KEYD.EQ.6 .OR. KEYD.GE.8) CALL KERROR ('?', 200, 'DDMINI')
      IF (KEYD .GE. 5) KEYWIL = 4
      IF (KEYWIL .EQ. 4) GOTO 190
      IF (SWRECY .OR. NAT .GT. 20 .OR. PSQ .GT. .90) KEYWIL = -2
      IZMAX = 1
      DO 186 I = 1, NAT
  186 IZMAX = MAX0 (IZMAX, IZAT(I))
      IF (IZMAX .LT. 50 .AND. PSQ .GT. .80) KEYWIL = -2
      IF (IZMAX .LT. 35 .AND. PSQ .GT. .70) KEYWIL = -2
      IF (IZMAX .LT. 20 .AND. PSQ .GT. .60) KEYWIL = -2
      IF (KEYWIL .EQ. 0) THEN
         IF (ABS (BP - BR) .GT. 0.001)
     *      WRITE (LIS1, FMT='('' TEMP PTB BP, BR.?? '')')
         BPINP = BOV
         BRINP = BOV
         BP = BOV
         BR = BOV
         ENDIF
  190 CONTINUE
      IF (ABS(BP - BR) .GT. .001) THEN
         WRITE (LIS2, 211) SCALE, BP, BR
  211    FORMAT (' Scale and B-values to be used: Scale =',
     *          F9.5, ' Bp =', F6.3, ' Br =', F6.3)
      ELSE
         WRITE (LIS2, 213) SCALE, BOV
  213    FORMAT (' Scale and overall temp.f. to be used: Scale =',
     *          F9.5, ' Bov:', F6.3)
         ENDIF
      IF (KEYD.EQ.0 .OR. KEYD.EQ.5 .OR. EXPAND .OR. NAT.EQ.1) THEN
         CALL FCALC (NSET)
      ELSEIF (KEYT .LT. 3) THEN
         CALL AUTOFR (NATS, NATL, NRECY, NSET)
         IDDOKA = KEYS(10)
         IF (IDDOKA .EQ. 17) RETURN
      ELSE
         CHOUT = ' AUTOFR is suppressed when using Anisotr.t.f. !'
         CALL SHOUT2
         CALL FCALC (NSET)
         ENDIF
      IF (KEYD .EQ. 0) THEN
         CALL FILCLO (IATOMS, 'KEEP')
         CALL FILCLO (IBINFO, 'KEEP')
         CALL FILCLO (IBINFC, 'KEEP')
         CALL KEPROX
         RETURN
         ENDIF
      IF (KEYD .GE. 5) THEN
         CALL FILCLO (IATOMS, 'KEEP')
         CALL FILCLO (IBINFO, 'KEEP')
         CALL KEPROX
         RETURN
         ENDIF
      IF (KEYT .GT. 1) BP = 0
      KEYS(17) = NAT
      KEYS(18) = NATL
      IF (.NOT.EXPAND .AND. .NOT.SWRECY) CALL SCALE7
      R2X = BUFFFT(30)
      IF (NRECYR .EQ. 3 .AND. PSQ .GT. 0.90 .AND. R2X .LT. 0.30) THEN
         SCALE = SQRT (SUMFP2 / SUMFO2)
         WRITE (LIS2, 258) SCALE
  258    FORMAT
     * (' $TE New scale = SQRT( (SUMFP2 + FF2R) / SUMFO2 ):', F11.5
     *      ,'   accepted!')
         BUFFFT(31) = SCALE
         SCALEO = SCALE
         ENDIF
      NRECYS = MOD (NRECY, 10)
      CALL LOGRD (IDDL, 'SCALEX', KLOG)
      CALL FILCLO (IDDL, 'KEEP')
      IF (KLOG .GT. 0) THEN
         IRUN = NINT (FNUM(2))
         IICY = NINT (FNUM(3))
         IF (IRUN .EQ. KEYS(13) .AND. IICY+1 .EQ. NRECYR) THEN
            SCALE = FNUM(4)
            WRITE (LIS2, 217) SCALE
  217       FORMAT (' $TE DDMAIN: Old scale from QPPQQ (FOUR):', F11.5
     *         ,'   accepted!')
            BUFFFT(31) = SCALE
            SCALEO = SCALE
            GOTO 219
            ENDIF
         ENDIF
      IF (NRECYS .GE. 6) THEN
         WRITE (LIS2,
     *      FMT='('' $TE Old scale retained: '', F11.5)') SCALE
         BUFFFT(31) = SCALE
      ELSEIF (LSC98) THEN
         SCALE = SQRT (SUMFP2 / SUMFO2)
         WRITE (LIS2, 218) SCALE
  218    FORMAT (' $TE New scale = SQRT( SUMFC2 / SUMFO2 ):', F11.5
     *      ,'   accepted!')
         BUFFFT(31) = SCALE
         SCALEO = SCALE
         ENDIF
  219 CONTINUE
      IF (NAT .GT. 499) GOTO 254
      IF (KEYT .GT. 1 .AND. ABS(SCALE-SCALEO) .LT. 0.00001) THEN
         IF (NAT .EQ. NATINP) GOTO 254
         GOTO 251
         ENDIF
      CHOUT = 'New scale supplied by DDMAIN'
      IF (KEYT .EQ. 1) THEN
         IF (.NOT. EXPAND .AND. KEYD.EQ.1) CALL SCASTA
         DO 233 I = 1, NAT
         ATXYZ(6,I) = 0.0
  233    ATXYZ(5,I) = BP
         CHOUT = 'B-isotr supplied by DDMAIN'
         ENDIF
  251 CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      IF (.NOT. EXPAND) CALL ATOMOC (2, ATXYZ, IZAT,  NAT)
      IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3))
      WRITE (CHOUT, 7102) CCODE, IT, KEYS(13), NRECYR, R2X, SCALE
 7102 FORMAT ('ATOMS ', A6, ' < DDMAIN dd', I7,
     *   ' RUN', I4, ' CY=', I3, '  R2=', F6.3, '  SC=', F10.6 )
      WRITE (IATOMS, FMT = '(A72)') CHOUT
      IF (NRECYR .GT. 1) WRITE (IATOMS, 799) NRECYR
  799 FORMAT ('REMARK DDMAIN, some atoms rejected, CYCLE', I3 )
      IF (NRECYR .EQ. 0 .AND. .NOT. NORECY) WRITE (IATOMS, FMT=
     *  '(''REMARK DDMAIN, input atoms, start CYCLE 1'' )')
      DO 252 NATR = 1, NAT
  252 CALL ATOMWB (IATOMS, ATXYZ, ATNAME, NATR)
      WRITE (LIS2, 253) NAT
  253 FORMAT (' Number of atoms written to ATOMS file:', I4)
      WRITE (IATOMS, FMT = '(''END'')')
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
  254 CALL FILCLO (IATOMS, 'KEEP')
      IF (NRECYR .LE. 5) GOTO 739
      CALL GETR2X (0, IATOLD, KEYS(13), R2CYC, KEND)
      WRITE (LIS2, FMT='('' TEMP99 KEND'', I3)') KEND
      IF (KEND .LE. 0) GOTO 739
      CALL KERNZA (-1.0, R2CYCA, 20)
      NCY = KEND+1
      R2CYC(NCY) = R2X
      R2MIN = 9.999
      NR2MIN = NCY
      DO 733 N = 3, NCY
      IF (R2CYC(N) .LT. R2MIN) THEN
         NR2MIN = N
         R2MIN = R2CYC(N)
         ENDIF
      IF( R2CYC(N-2).GT.0. .AND. R2CYC(N-1).GT.0. .AND. R2CYC(N).GT.0.)
     *    R2CYCA(N) = ( R2CYC(N-2) + R2CYC(N-1) + R2CYC(N) ) / 3.
  733 CONTINUE
      WRITE (LIS2, 734) (R2CYC(I), I=1,NCY)
  734 FORMAT (/' R2 values:  ', 20F6.3)
      WRITE (LIS2, 735) (R2CYCA(I), I=1,NCY)
  735 FORMAT ( ' Smoothed :  ', 20F6.3)
      IF (R2CYCA(NCY) .LT. R2CYCA(NCY-1)) GOTO 739
      IF (R2X .LT. 1.01 * R2MIN) GOTO 739
      IF (R2X .LT. R2CYCA(NCY-1)) GOTO 739
      IF (R2X .LT. 1.1 * R2CYCA(NCY-1) .AND. NRECYR .LE. 8 .AND.
     *    R2X .LT. 1.1 * R2CYCA(NCY-2)) GOTO 739
      CHOUT = ' The R2 value increases, the refinement is not stable '
      CALL SHOUT
      CALL GETR2X (NR2MIN, IATOLD, KEYS(13), R2CYC, KEND)
      IF (KEND .LE. 0) GOTO 739
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
  736 READ (IATOLD, FMT='(A80)', END= 737) CHIN
      WRITE (IATOMS, FMT='(A80)' ) CHIN
      IF (CHIN(1:4) .NE. 'END ') GOTO 736
  737 READ (IATOLD,  FMT='(A80)', END= 1737) CHIN
      IF (CHIN(1:6) .NE. 'ATOMS ') GOTO 737
      CALL KERINB (LIT, 1)
      IF (LIT(4) .NE. 'DDMAIN') GOTO 1737
      REWIND IATOMS
      WRITE (IATOMS, FMT='(A80)' ) CHIN
 2736 READ (IATOLD,  FMT='(A80)', END= 1737) CHIN
      WRITE (IATOMS, FMT='(A80)' ) CHIN
      IF (CHIN(1:4) .NE. 'END ') GOTO 2736
 1737 CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATOLD, 'KEEP')
      CHOUT = ' The atoms set with the lowest R2 value retrieved'
      CALL SHOUT
      IF (R2MIN .GT. .50) THEN
         CHOUT = ' The R2 value is too high anyhow: stop.'
         CALL SHOUT
         CALL KERROR (' Wrong model used ?', 1737, 'DDMINI')
         ENDIF
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KIDDS)
      WRITE (IDDS, FMT='(''DDMAIN''/ ''FOUR''/ ''NUTS''/ ''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      CHOUT = ' CALL DDMAINX NORECY NOFREE '
      CALL LOGWR (IDDL)
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'OUTPUT', KINQCO)
      WRITE (ICON, 630) CCODE, (ITIME(IT), IT=1,3)
  630 FORMAT ('CONDA ', A6, I7,2I4)
      WRITE (ICON, FMT='(''PROGRAM DDMAIN''/
     *    ''OPTION 3 FOUR ''/
     *    ''PROGRAM FOUR ''/ ''NORECY''/
     *    ''PROGRAM NUTS  AT2X'' / ''FINISH'')' )
      CALL FILCLO (ICON, 'KEEP')
      CALL KEPROX
      RETURN
  739 CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
  255 IF (.NOT. EXPAND) THEN
         CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      ELSE
         CALL BINIFF (1, IBINFC, 'BINFC2', FITFC2, NITFC, BUFFC,KENDFC)
         ENDIF
      CALL KERNAB (BUFFC(7), HKLMAX, 3)
      P1SQ = BUFFC(26)
      PSQ  = BUFFC(27)
      PSQX = PSQ
      IF (EXPAND) PSQX = P1SQ
      BPINP  = BUFFC(19)
      BRINP  = BUFFC(20)
      STLMAX = BUFFC(21)
      BUFFC(16) = SCALE
      BUFFC(17) = BOV
      IF (KEYD .EQ. 2) THEN
         CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT)
         ENDIF
      IF (KEYD .NE. 1) GOTO 270
      IF (IFIX (100.0 * PSQX) .LT. MAX0(79, 100- 3*NAT)
     *                           - MIN0(4, NAT/6) ) GOTO 270
      IF (KEYOK .EQ. 1) THEN
         WRITE (LIS1, FMT='(
     *      '' Warning: PHASEX requested with rather large PSQ'')')
         GOTO 270
         ENDIF
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR ('No DDSYST file found',0,'DDMAIN')
      LITFFT = 0
  261 READ (IDDS, FMT='(A6)') LIT(1)
      IF (LIT(1) .EQ. 'FOUR') LITFFT = 1
      IF (LIT(1) .NE. 'STOP') GOTO 261
      REWIND IDDS
      IF (LITFFT .EQ. 1) THEN
         IF (.NOT. SWRECY) WRITE (LIS1, 262)
         IF (.NOT. SWRECY) WRITE (LIS2, 262)
  262    FORMAT (/' The scattering power is too large',
     *                  ' therefore program PHASEX is not' /
     *          ' applied and program FOUR follows.'/)
         WRITE (IDDS, FMT='(''FOUR'' / ''NUTS'' )')
         ENDIF
      WRITE (IDDS, FMT='(''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      KEYD = 3
      KEYDS = 0
  270 IF (KEYT .GT. 1) BP = 0.0
      IF (KEYD.EQ.3 .AND. KEYDS.GE.3) GOTO 310
      IF (KEYD .EQ. 2) GOTO 310
      IF (.NOT.EXPAND) CALL FCALII (0)
      IF (KEYD .NE. 1) GOTO 310
      RDENR = 0
      RNUMR = 0
      DO 290 I=1,NTYPE
      RDENR = RDENR + (CELALL(I)-CELPAR(I))*IZTYPE(I)**2
  290 RNUMR = RNUMR + (CELALL(I)-CELPAR(I))*IZTYPE(I)**3
      E000R = (RDENR**1.5) / RNUMR / SQRT(ALATT)
      NITDUA = 7
      BUFDUA(5) = E000R
      BUFDUA(6) = PSQ
      IF (EXPAND) BUFDUA(6) = P1SQ
      BUFDUA(7) = R2X
      CALL BINOFF (7, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      RETURN
  310 IEF = 1
      IF (KEYD.EQ.3 .AND. KEYDS.EQ.5) IEF = -1
      BUFFC(18) = SCALE
      BUFFC(19) = BP
      BUFFC(20) = BR
      CALL KERNAB (BUFFC(5), BUFFFT(5), 23)
      BUFFFT(28) = 3.
      IF (IEF.EQ.-1) BUFFFT(28) = 4.
  935 IF (EXPAND) BUFFFT(28)= 1.
      BUFFFT(29) = KEYD * 10 + KEYDS
      WRITE (LIS2, FMT='('' $TEMP R2 = '', F6.3)') BUFFFT(30)
      NITFFT = 5
      IF (BUFFFT(30) .GT. 9.999) BUFFFT(30) = 9.999
      CALL BINOFF (31, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT,KENDFF)
      RETURN
      END
      SUBROUTINE ATIN7 (NSET)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IATOMS, IFILE(2))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      LOGICAL NIJM
      EQUIVALENCE (NIJM, SWITCH(1))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      CHARACTER CHIN2 *80
  110 CALL KERINA (IATOMS, LIT, 1, LEND)
      IF (LEND .NE. 0) THEN
         NSET  = -NSET
         RETURN
         ENDIF
      IF (LIT(1) .NE. 'ATOMS') GOTO 110
      CHIN2 = CHIN
      BACKSPACE IATOMS
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      NSET = NSET + 1
      NATQ = NAT
      NATH = 0
      N = 1
  143 CONTINUE
      IF (ATNAME(N)(1:1).EQ.'H' .AND. IZAT(N).EQ.1) NATH = NATH + 1
      IF (ATNAME(N)(1:1) .EQ. 'Q') THEN
         IF (N .EQ. NAT) GOTO 148
         DO 146 N1 = N, NAT - 1
         CALL KERNAB (ATXYZ(1,N1+1), ATXYZ(1,N1), 10)
         ATNAME(N1) = ATNAME(N1+1)
  146    IZAT(N1) = IZAT(N1+1)
  148    NAT = NAT - 1
         N = N - 1
         ENDIF
      N = N + 1
      IF (N .LE. NAT) GOTO 143
      IF (NAT.LT.NATQ) WRITE (LIS2, FMT=
     *  '('' Nr of Q-atoms (= peaks) rejected:'', I3)') NATQ-NAT
      IF (NATH.NE.0) WRITE (LIS1, FMT=
     *  '('' Number of H atoms included:'', I3)') NATH
      IF (NAT .LE. 0) CALL KERROR ('.... No atoms left!', 0, 'ATIN7')
      IF (NSET .GT. 1) CALL ATOMPR (LIS2, 2, ATXYZ, ATNAME, IZAT, NAT)
      IF (NSET .GT. 1) CALL ATOMOC (1, ATXYZ, ITAT, NAT)
      CHIN = CHIN2
      CALL KERINB (LIT, 1)
      RETURN
      END
      SUBROUTINE FCALII (NSET)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF),
     *            KLAD(MAXAT)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      DEEL=1.
      IF (NSET .EQ. 0) CALL ATOMOC (0, ATXYZ, KLAD, NAT)
      CALL KERNZA (0.0, CELPAR, NTYPE)
      DO 170 I = 1,NAT
      DO 170 J = 1,NTYPE
      IF (IZAT(I) .NE. IZTYPE(J)) GOTO 170
      ITAT(I) = J
      IF (NSET .EQ. 0) DEEL=KLAD(I)
      CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AMULT / DEEL
  170 CONTINUE
      SUMZP = 0.0
      SUMZA = 0.0
      DO 180 I = 1,NTYPE
      SUMZP = SUMZP + CELPAR(I) * FF(2,I) ** 2
  180 SUMZA = SUMZA + CELALL(I) * FF(2,I) ** 2
      PSQ = SUMZP / SUMZA
      P1SQ = PSQ / ( ICENT * NSYMM )
      IF (KEYD .GE. 5 .AND. KEYD .NE. 7)
     *   WRITE(LIS1,FMT='('' $$$ Atom set'', I3, ''  Nr of atoms:'',
     *      I3, '' Scatt.fr. p**2 '', F6.3)') NSET, NAT, PSQ
      BPAV = 0.
      IF (KEYT .GT. 1) THEN
         IZATT = 0
         DO 174 I = 1, NAT
         BPAV = BPAV + ATXYZ(5,I) * IZAT(I) **2
  174    IZATT = IZATT + IZAT(I) ** 2
         BPAV = BPAV / FLOAT(IZATT)
         IF (NSET .EQ. 1) WRITE (LIS2, 173) BPAV
  173    FORMAT (' Averaged value of temp.factors for known atoms:',
     *      ' Bp = ', F8.3)
         ENDIF
      IF (PSQ .GT. 1.1) THEN
         WRITE (CHOUT, FMT='('' Warning: P**2:'', F7.3)') PSQ
         IF (PSQ .LT. 1.20) THEN
            CALL SHOUT2
         ELSE
            CALL SHOUT
            ENDIF
         ENDIF
      IF (PSQ .GT. 1.00) PSQ = 1.00
      IF (NSET.EQ.1 .AND. KEYT.EQ.1) RETURN
      IF (KEYT .GE. 2) BP = 0.0
      BPX = BP
      IF (NSET.GT.0 .AND. KEYT.GT.1) BPX = BPAV
      ISMAX = IFIX (STLMAX * 400. + 0.0001) + 2
      IF (ISMAX .GT. 500) CALL KERROR ('STLMAX reset?', 270, 'FCALII')
      DO 282 IS=1,ISMAX
      STL = FLOAT(IS-1) * 0.0025
      STL2 = STL * STL
      SUMF2P(IS) = 0.0
      DO 260 I=1,NTYPE
  260 SUMF2P(IS) = SUMF2P(IS)+ FF(IS,I) * FF(IS,I) * CELPAR(I)
      IF (NSET .EQ. 0) EXPBR(IS) = EXP(-BR * STL2)
  282 EXPBP(IS) = EXP(-BPX * STL2)
      RETURN
      END
      SUBROUTINE FCALC (NSET)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12))
      EQUIVALENCE (KEYWIL, KEYS(12))
      LOGICAL SWRECY, EXPAND
      EQUIVALENCE (SWRECY, SWITCH(17)), (EXPAND, SWITCH(23))
      LOGICAL LTESTR
      EQUIVALENCE (LTESTR, SWITCH(27))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT  = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      EQUIVALENCE (R2X, BUFFFT(30))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      LOGICAL LBINFC, LCALR2
      LBINFC = .TRUE.
      LTESTR = .TRUE.
      LCALR2 = .FALSE.
      IF (KEYD .LT. 5) LTESTR = .FALSE.
      IF (KEYD .EQ. 0 .AND. KEYDS .EQ. -1) LCALR2 = .TRUE.
      IF (LCALR2) LTESTR = .TRUE.
      IF (LCALR2) KEYWIL = 4
      IF (LTESTR) LBINFC = .FALSE.
      IF (LBINFC) LTESTR = .FALSE.
      LIS1X=LIS1
      IF (LTESTR) LIS1X=LIS2
      R2MIN = 999.
      WRITE (LIS1, FMT='('' Calculate structure factors'')')
      IF (.NOT. LCALR2)
     *   WRITE (LIS2, FMT='('' Calculate structure factors, new'',
     *       '' temperature factors and new scale factor'')')
      FICENT = FLOAT (ICENT)
      IF (KEYD .GE. 5) THEN
         WRITE (LIS1, FMT='('' DDMAIN input OPTION :'', I2)') KEYD
         ENDIF
      GOTO 151
  100 CALL ATIN7 (NSET)
      IF (NSET .LE. 0) GOTO 910
      IF (KEYT .EQ. 3) CALL KERROR
     *   (' No anisotr. allowed in AUTOR2 TEST runs', 100, 'AUTOFR')
      CALL FCALII (NSET)
  151 CONTINUE
      IF (EXPAND) THEN
         WRITE (LIS1, 183) P1SQ
         WRITE (LIS2, 183) P1SQ
  183    FORMAT (' Scattering fraction of known part:'/
     *   '    excluding symmetry related molecules: P1**2 =', F6.3)
      ELSE
         IF (PSQ .LT. 0.99) THEN
            WRITE (LIS2, 184) PSQ
  184       FORMAT (' Scattering fraction of known part: P**2 =', F6.3)
            ENDIF
         ENDIF
      IF (.NOT. EXPAND) THEN
         NITFC = 2
         IF (LBINFC)
     *   CALL BINOFF (27, IBINFC,'BINFC', FITFC, NITFC, BUFFC, KENDFC)
      ELSE
         NITFC = 3 + 2 * NSYMM
         CALL BINOFF (27, IBINFC,'BINFC2', FITFC2, NITFC, BUFFC, KENDFC)
         ENDIF
      CALL RINI (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *          RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT)
      NREFL  = 0
      IREFL  = 0
      SUMNR2 = 0.
      SUMFO2 = 0.
      SUMFP2 = 0.
      SUMFF2 = 0.
      SUMFC2 = 0.
      SUMFO4 = 0.
      SUMFR4 = 0.
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      NITFO = 3
  200 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IF (KENDFO.LT.0) GOTO 220
      IREFL = IREFL + 1
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      IF (STL.GT.STLMAX .OR. HKLX(1,1).GT.HKLMAX(1) .OR.
     *    HKLX(2,1).GT.HKLMAX(2) .OR. HKLX(3,1).GT.HKLMAX(3)) THEN
         FITFC(1) = -999.
         FITFC2(1) = -999.
         GOTO 215
         ENDIF
      IF (.NOT. EXPAND) THEN
         CALL FCALC1 (KEYT, ATXYZ, ITAT, NAT)
         FP2F2R = FP**2 + (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2
         SUMFO2 = SUMFO2 + FOBS**2
         SUMFP2 = SUMFP2 + FP2F2R
         SUMFC2 = SUMFC2 + FP**2
         FOSC  = FOBS * SCALE
         SUMFR4 = SUMFR4 + (FP**2 - FOSC**2)**2
         SUMFO4 = SUMFO4 + FOSC**4
         CALL R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *        RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2)
         R2X = RNM2XZ
         IF (KEYWIL.NE.4) CALL WILSIN (KEYWIL)
      ELSE
         CALL FCALC2 (KEYT, ATXYZ, ITAT, NAT)
         SUMNR2 = SUMNR2 + ASYMM / EPSIL2
         SF2 = SUMF2 (ISS)
         SF2P= SUMF2P(ISS)
         SUMFF2 = SUMFF2 + (SF2 - SF2P*ASYMC) * EXPBR(ISS) / EPSIL2
         SUMFO2 = SUMFO2 + FOBS**2 / EPSIL2
         DO 210 I = 1, NSYMM
         IF (FPEXP(1,I).GT.0.0) SUMFP2 = SUMFP2 + FPEXP(1,I)**2
  210    CONTINUE
         ENDIF
      NREFL = NREFL + 1
  215 IF (.NOT. EXPAND) THEN
         IF (LBINFC)
     *   CALL BINOFF (0, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      ELSE
         CALL BINOFF (0, IBINFC, 'BINFC2',FITFC2, NITFC, BUFFC, KENDFC)
         ENDIF
      GOTO 200
  220 CONTINUE
      IF (.NOT. EXPAND) THEN
         IF (LBINFC)
     *   CALL BINOFF (-1, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      ELSE
         CALL BINOFF (-1, IBINFC, 'BINFC2',FITFC2, NITFC, BUFFC, KENDFC)
         ENDIF
      WRITE (LIS2, 240) IREFL
  240 FORMAT (' Number of reflections read from file BINFO:', I5)
      IF (IREFL.NE.NREFL) WRITE (LIS2, 242) NREFL
  242 FORMAT (' Note:', I6,' Reflections written to file BINFC(2) ')
      IF (.NOT. EXPAND) THEN
         CALL RPR (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *        RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,PSQ)
         R2X = RNM2XZ
         SC98 = SQRT (SUMFC2 / SUMFO2)
         R2FFFF = SUMFR4 / SUMFO4
         WRITE (LIS2, 249) SCALE, SC98, R2FFFF
  249    FORMAT (' $TE SCALE, NEW SC ? ,    R2(F2):', 2F8.4, F6.3)
         IF (LCALR2) GOTO 990
      IF (LTESTR) THEN
         IF (NSET .EQ. 1) THEN
            CHOUT = ' Structure factor calculation for all atom sets:'
            CALL SHOUT
            CHOUT = ' Set No.  Nr.atoms  p**2  expected R2  actual R2'
            CALL SHOUT
            ENDIF
         WRITE (CHOUT, 1254) NSET, NAT, PSQ, RNM2EZ, RNM2XZ
 1254    FORMAT (I7, I8, F9.3, F13.3, F11.3)
         CALL SHOUT
         IF (RNM2XZ .LT. R2MIN) THEN
            R2MIN = RNM2XZ
            NSETM = NSET
            ENDIF
         ENDIF
      ELSE
         WRITE (LIS2, 254) NINT(SUMNR2)
  254    FORMAT (' Number of reflections after expansion:', I10)
         SUMFP2 = SUMFP2 * FICENT  + SUMFF2
         ENDIF
      IF (LTESTR) GOTO 100
      GOTO 990
  910 CONTINUE
      CHOUT = ' Structure factor calc finished for all atom sets '
      CALL SHOUT2
      IF (R2MIN .LT. 998. .AND. NSETM .NE. 1) THEN
         WRITE (IPR1, 1255) R2MIN, NSETM
         WRITE (LIS1, 1255) R2MIN, NSETM
 1255    FORMAT(' Note: Lowest value of R2 =', F6.3, ' for set nr.', I3)
         ENDIF
  990 RETURN
      END
      SUBROUTINE FCALC1  (KEYT, ATXYZ, ITAT, NAT)
      DIMENSION ATXYZ(10,NAT), ITAT(NAT)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      DIMENSION FFF(10), ADTRIG(24)
      DATA  FFF, ADTRIG / 34*0.0 /
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      DO 110 J=1,NTYPE
      IF (CELPAR(J).LE.0.0) GOTO 110
      FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL
  110 CONTINUE
      CALL HKLEX1 (HKLX, HKLX)
      IF (NSYMM.EQ.1) GOTO 150
      DO 140 J=2,NSYMM
      IF (ITRS(J).EQ.0) GOTO 140
      ADTRIG(J) = HKLX(1,1)*TSYMM(1,J) + HKLX(2,1)*TSYMM(2,J) +
     *            HKLX(3,1)*TSYMM(3,J)
  140 CONTINUE
  150 FAP = 0.0
      FBP = 0.0
      IF (KEYT.EQ.1) GOTO 300
      DO 250 I=1,NAT
      A1 = 0.
      B1 = 0.
      A2 = 0.
      B2 = 0.
      DO 200 J=1,NSYMM
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      IF (ATXYZ(6,I) .GT. 0.0) GOTO 180
      A1 = A1 + SICO(ITRIG + 2500)
      B1 = B1 + SICO(ITRIG + 2500)
      IF (ICENT.EQ.2) GOTO 200
      A2 = A2 - SICO(ITRIG)
      B2 = B2 + SICO(ITRIG)
      GOTO 200
  180 X1 = HKLX(1,J) * ATXYZ (5,I)
     *   + HKLX(2,J) * ATXYZ(10,I)
     *   + HKLX(3,J) * ATXYZ (9,I)
      X2 = HKLX(2,J) * ATXYZ (6,I)
     *   + HKLX(3,J) * ATXYZ (8,I)
      X3 = HKLX(3,J) * ATXYZ (7,I)
      TF = EXP(-0.25 * ( X1*HKLX(1,J) + X2*HKLX(2,J) + X3*HKLX(3,J) ))
      A1 = A1 + SICO(ITRIG + 2500) * TF
      B1 = B1 + SICO(ITRIG + 2500) * TF
      IF (ICENT.EQ.2) GOTO 200
      A2 = A2 - SICO(ITRIG) * TF
      B2 = B2 + SICO(ITRIG) * TF
  200 CONTINUE
      IJ = ITAT(I)
      IF (ATXYZ(6,I).LT.0.0) THEN
         TF = ATXYZ(4,I) * EXP (-STL2 * ATXYZ(5,I))
         ELSE
         TF = ATXYZ(4,I)
         ENDIF
      FAP = FAP + A1 * FFF(IJ)     * TF
      FBP = FBP + B1 * SFAC(11,IJ) * TF
      IF (ICENT .EQ. 2) GOTO 250
      FAP = FAP + A2 * SFAC(11,IJ) * TF
      FBP = FBP + B2 * FFF(IJ)     * TF
  250 CONTINUE
      FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP)
      GOTO 500
  300 DO 450 I=1,NAT
      A1 = 0.
      B2 = 0.
      DO 400 J=1,NSYMM
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      A1 = A1 + SICO(ITRIG + 2500)
      IF (ICENT.EQ.2) GOTO 400
      B2 = B2 + SICO(ITRIG)
  400 CONTINUE
      IJ = ITAT(I)
      FAP = FAP + A1 * FFF(IJ) * ATXYZ(4,I)
      IF (ICENT .EQ. 2) GOTO 450
      FBP = FBP + B2 * FFF(IJ) * ATXYZ(4,I)
  450 CONTINUE
      FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP) * EXPBP(ISS)
  500 PHIP = 0.0
      IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925
      IF (PHIP.LT.0.0) PHIP = PHIP + 360.
      RETURN
      END
      SUBROUTINE FCALC2  (KEYT, ATXYZ, ITAT, NAT)
      DIMENSION ATXYZ(10,NAT), ITAT(NAT)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      DIMENSION FFF(10)
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      DO 110 J=1,NTYPE
      IF (CELPAR(J).LE.0.0) GOTO 110
      FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL
  110 CONTINUE
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = IEPS
      EPSIL2 = IEPS2
      DO 600 J=1,NSYMM
      IF (IDHKL(J).EQ.0) GOTO 200
      K = IABS(IDHKL(J))
      FPEXP(1,J) = -K
      FPEXP(2,J) = FPEXP(2,K)
      IF (FPEXP(2,J).LT.0.0001) FPEXP(2,J)=0.0001
      IF (IDHKL(J).LT.0) FPEXP(2,J)=-FPEXP(2,J)
      GOTO 600
  200 FAP = 0.0
      FBP = 0.0
      DO 400 I=1,NAT
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      IJ = ITAT(I)
      FAP = FAP + SICO(ITRIG + 2500) * FFF(IJ)
      FBP = FBP + SICO(ITRIG)        * FFF(IJ)
  400 CONTINUE
         FP = ALATT * SQRT (FAP*FAP + FBP*FBP) * EXPBP(ISS)
      PHIP = 0.0
      IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925
      IF (PHIP.LT.0.0) PHIP = PHIP + 360.
      FPEXP(1,J) = FP
      FPEXP(2,J) = PHIP
  600 CONTINUE
      RETURN
      END
      SUBROUTINE SCALE7
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1)), (LIS2, IFILE(8))
      EQUIVALENCE (KEYWIL, KEYS(12))
      LOGICAL SWRECY, EXPAND
      EQUIVALENCE (SWRECY, SWITCH(17)), (EXPAND, SWITCH(23))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      PARAMETER (MAXBUF = 198)
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      PARAMETER (PSQMAX = 0.90)
      WRITE (LIS2, FMT='('' Calculate new SCALE and B values'')')
      SC2 = SQRT (SUMFP2 / SUMFO2)
      WRITE (LIS2, 258) SC2
  258 FORMAT (' New scale = SQRT((SUMFP2 + FF2R) / SUMFO2):', F11.5)
      IF (PSQ .LT. PSQMAX) THEN
         WRITE (LIS2, FMT='(''+'', 56X, ''(not used)'')')
      ELSE
         WRITE (LIS2, FMT='(''+'', 56X, '' accepted!'')')
         SCALE = SC2
         KEYWIL = 4
         ENDIF
      IF (KEYWIL .NE. 4) CALL WILPAR (IWILP)
      IWILP = 1
      IF (KEYWIL.NE.4 .AND. KEYWIL.GE.0)
     *   CALL WIL2DI (NREFL, IWILP)
      IF (KEYT .GE. 2) BP = BPAV
      WRITE (CHOUT, 362) SCALE, BP, BR
  362 FORMAT ('SCALE ', F14.7, ' BP ', F11.5, ' BR ', F10.5)
      CALL LOGWR (IDDL)
      IF (KEYT .GE. 2)    BP = 0.0
      CALL FILCLO (IDDL, 'KEEP')
      RETURN
      END
      SUBROUTINE AUTOFR (NATS, NATL, NRECY, NSET)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (ICOND, IFILE(4)), (IDDL, IFILE(1)), (IDDS, IFILE(2))
      EQUIVALENCE (I1,IFILE(9)), (IBINFO,IFILE(11)),(IBINFC, IFILE(12))
      EQUIVALENCE (KEYWIL, KEYS(12))
      LOGICAL SWRECY, NORECY, LSC98, NIJM
      EQUIVALENCE (SWRECY, SWITCH(17)), (NORECY, SWITCH(18))
      EQUIVALENCE (LSC98, SWITCH(19))
      LOGICAL LTESTR
      EQUIVALENCE (NIJM, SWITCH(1)), (LTESTR, SWITCH(27))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      EQUIVALENCE (R2X, BUFFFT(30))
      CHARACTER*1 GWX
      CHARACTER*8 DDC
      CHARACTER*72 DDX
      DIMENSION FI2(30)
      DOUBLEPRECISION ATFP4(MAXAT), ATFPO(MAXAT), SFPS2, SFPS4, TERM2,
     * TERM3, RNUM2C, RDEN2C
      DOUBLEPRECISION ATTOT(MAXAT)
      LOGICAL LBINFC
      LBINFC = .TRUE.
      LTESTR = .TRUE.
      R2MIN =  999.9
      DDC = 'DDL'
      FI1 = 17.* VOLUM
      NSETM = 0
      IF (KEYD .LT.5) LTESTR = .FALSE.
      IF (LTESTR)     LBINFC = .FALSE.
      IF (LBINFC)     LTESTR = .FALSE.
      LIS1X=LIS1
      IF (LTESTR) LIS1X=LIS2
      NATNOW = 0
      NATEND = 0
      DO 103 IT = 1, NTYPE
      IF (IZTYPE(IT).NE.1) THEN
         NATEND = NATEND + CELALL(IT)
         NATNOW = NATNOW + CELPAR(IT)
         ENDIF
  103 CONTINUE
      NATEND = NATEND / IMULT
      NATNOW = NATNOW / IMULT
      NATRES = NATEND - NATNOW
      NATREX = NATEND - NAT
      IF (.NOT. LTESTR) THEN
         WRITE(LIS1,*)
     *   'Number of original input atoms (minus removed ones) =',NATS
         WRITE(LIS1,*)
     *   'Number of atoms fed into the last Fourier synthesis =',NATL
         WRITE(LIS1,*)
     *   'Number of atoms (peaks) taken from last Fourier map =',NAT
         IF (NIJM) WRITE(LIS1,*)
     *   ' NIJM:    atoms (peaks) missing at this very moment =',NATRES
         IF (NIJM .AND. NATRES.NE.NATREX) WRITE(LIS1,*)
     *   ' NIJM: WARNING: H-atoms? input non-H atoms counted: =',NATNOW
         IF (NATEND .NE. NAT) WRITE(LIS1,*)
     *   'Number of atoms  expected in the complete structure =',NATEND
         ENDIF
      CRTEST = 0.0
      NATFIX = 0
      NDELM  = NAT / 2
      I6  = NATEND / 6
      NDELM  = MIN0 (NDELM, NAT - I6)
      IF (NATL .LT. NATS) NATL = NATS
      ICYCL = NRECY / 10 + 1
      NRECYS = MOD (NRECY, 10)
      IF (ICYCL .LE. 3 .AND. NATS .LE. 3) NATFIX = NATS
      IF (ICYCL .LT. 2) GOTO 105
      IF( ICYCL .LE. 2 ) THEN
         NDELM = MAX(0, 1 + ( NAT - NATL ) / 2 )
      ELSE
         NDELM = MAX(0, 1 + 2 * ( NAT - NATL ) / 3 )
         ENDIF
      IF (NDELM .LE.2 .AND. ICYCL.LE.4) NDELM = NAT - NATL
      IF (ICYCL .EQ. 5) NDELM =  NAT / 4
      IF (ICYCL .EQ. 7) NDELM =  MAX0 (NAT / 5, NDELM)
      IF (NRECYS .GE. 8) NDELM = 0
  105 CONTINUE
      ISTART = MAX ( NATFIX + 1, NAT - 500)
      ISTORE = MAX ( 2, ISTART )
      ISTORM = ISTORE - 1
      FICENT = FLOAT (ICENT)
      GOTO 113
  109 CALL ATIN7 (NSET)
      IF (NSET .LE. 0) GOTO 910
      IF (LTESTR) WRITE (LIS2, FMT='('' Atom Set Nr.'', I3)') NSET
      IF (KEYT .EQ. 3) CALL KERROR
     *   (' No anisotr. allowed in AUTOR2 TEST runs', 100, 'AUTOFR')
      CALL FCALII (NSET)
  113 CONTINUE
      IF (LTESTR) NDELM = 1
      CALL KERNAB (BUFFC, BUFBUF, 27)
      NITFC = 2
      IF (LBINFC)
     *   CALL BINOFF (27, IBINFC,'BINFC', FITFC, NITFC, BUFFC, KENDFC)
      CALL RINI(RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *          RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT)
      DO 117 J = 1, MAXAT
      ATTOT(J) = 0.0
      ATFP4(J) = 0.0
  117 ATFPO(J) = 0.0
      NREFL = 0
      IREFL = 0
      SUMNR2 =0.
      SUMFO2 = 0.
      SUMFP2 = 0.
      SUMFF2 = 0.
      RNUM2C = 0.
      RDEN2C = 0.
      TERM2  = 0.
      TERM3  = 0.
      SUMFC2 = 0.
      SUMFO4 = 0.
      SUMFR4 = 0.
      SFPS2  = 0.
      SFPS4  = 0.
      SUME2 = 0.
      SUME1 = 0.
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      NITFO = 3
      IF (ICYCL .NE. 3) GOTO 200
      CALL XHELP (I1, LIS1, 411. )
      READ (I1, 137, END=7112)
      READ (I1, 137, END=7112) FI2
  137 FORMAT (3(10F7.1/))
  200 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IF (KENDFO.LT.0) GOTO 220
      IREFL = IREFL + 1
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      IF (STL.GT.STLMAX .OR. HKLX(1,1).GT.HKLMAX(1) .OR.
     *    HKLX(2,1).GT.HKLMAX(2) .OR. HKLX(3,1).GT.HKLMAX(3)) THEN
         FITFC(1)  = -999.
         FITFC2(1) = -999.
         GOTO 215
         ENDIF
      CALL FCALC7 (KEYT, ATXYZ, ITAT, NAT, ETAO2)
      FP2F2R = FP**2 + (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2
      SUMFO2 = SUMFO2 + FOBS**2
      SUMFP2 = SUMFP2 + FP2F2R
      SUMFC2 = SUMFC2 + FP**2
      FOSC  = FOBS * SCALE
      SUMFR4 = SUMFR4 + (FP**2 - FOSC**2)**2
      SUMFO4 = SUMFO4 + FOSC**4
      NREFL = NREFL + 1
      CALL R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *             RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2)
      R2X = RNM2XZ
      IF (KEYWIL.NE.4) CALL WILSIN (KEYWIL)
      FOSC   = FOBS * SCALE
      EOBS2  = ( FOSC * FOSC ) / ETAO2
      SUME2 = SUME2 + EOBS2
      SUME1 = SUME1 + ABS(EOBS2 - 1.)
      FPS2   = ( FP * FP ) / ETAO2
      IF (FPS2 .LT. 0.000001) FPS2 = 0.000001
      FPS4   = FPS2 * FPS2
      SFPS2  = SFPS2 + FPS2
      SFPS4  = SFPS4 + FPS4
      FAPM = FAP
      FBPM = FBP
      DO 205 I= 1, ISTORM
      FAPM = FAPM - ATXYZ(8,I)
      FBPM = FBPM - ATXYZ(9,I)
  205 CONTINUE
      FPM  = ASYMCL * SQRT(FAPM*FAPM+FBPM*FBPM)
      FPS2M  = ( FPM * FPM ) / ETAO2
      IF (FPS2M .LT. 0.000001) FPS2M = 0.000001
      FPS4M  = FPS2M * FPS2M
      ATFP4(ISTORM)=ATFP4(ISTORM) + FPS4M
      ATFPO(ISTORM)=ATFPO(ISTORM) - 2 * EOBS2 * FPS2M
      ATTOT(ISTORM)=ATTOT(ISTORM) + FPS4M - 2 * EOBS2 * FPS2M
      DO 210 I= ISTORE, NAT
      FAPM = FAP - ATXYZ(8,I)
      FBPM = FBP - ATXYZ(9,I)
      FPM  = ASYMCL * SQRT(FAPM*FAPM+FBPM*FBPM)
      FPS2M  = ( FPM * FPM ) / ETAO2
      IF (FPS2M .LT. 0.000001) FPS2M = 0.000001
      FPS4M  = FPS2M * FPS2M
      ATFP4(I)=ATFP4(I) + FPS4M
      ATFPO(I)=ATFPO(I) - 2 * EOBS2 * FPS2M
      ATTOT(I)=ATTOT(I) + FPS4M - 2 * EOBS2 * FPS2M
  210 CONTINUE
      TERM2  = TERM2 + FPS4
      TERM3  = TERM3  - 2 * EOBS2 * FPS2
      RNUM2C = RNUM2C + FPS4 - 2 * EOBS2 * FPS2
      RDEN2C = RDEN2C + EOBS2 * EOBS2
  215 CONTINUE
      IF (LBINFC)
     *   CALL BINOFF (0, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      GOTO 200
  220 CONTINUE
      IF (LBINFC)
     *   CALL BINOFF (-1, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      IF (NSET .EQ. 1) WRITE (LIS2, 240) IREFL
  240 FORMAT (' Number of reflections read from file BINFO:', I5)
      IF (IREFL.NE.NREFL .AND. NSET.EQ. 1) WRITE (LIS2, 242) NREFL
  242 FORMAT (' Note:', I6,' reflections accepted ')
      SUME2 = SUME2 / FLOAT(NREFL)
      SUME1 = SUME1 / FLOAT(NREFL)
      SUME1X= 0.986
      IF (ICENT .EQ. 1) SUME1X= 0.736
      WRITE (LIS1X, 1242) SUME2, SUME1, SUME1X
 1242 FORMAT (' Statistics: <E2> =', F6.3, '  <|E2-1|> =', F6.3/
     *        ' Expected  : <E2> = 1.000  <|E2-1|> =', F6.3)
      IF (SUME1 .LT. 0.65) WRITE (LIS1X, 1243)
 1243 FORMAT (' Beware of possible twinning !!!!!!!!!!!!!!!!!'/)
      CALL RPR (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *        RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,PSQ)
      R2X = RNM2XZ
      DDC(4:8) = 'IC   '
      SC98 = SQRT (SUMFC2 / SUMFO2)
      R2FFFF = SUMFR4 / SUMFO4
      XXX6 = 100. * ABS ( (1. - SCALE / SC98) )
      IF (XXX6 .GT. 1.00) THEN
         WRITE (LIS2, 249) SCALE, SC98, R2FFFF
  249    FORMAT (' $TE SCALE, New SCALE ? , R2(F2):', 2F8.4, F6.3)
         IF (NRECYS .GE. 6) WRITE (LIS2,
     *      FMT='('' $TE SCALE, new scale ignored ... '')')
         ENDIF
      IF (ICYCL .LT.4 .OR. R2X .GT. 0.30 .OR. NRECYS .GE. 6) GOTO 250
      XXX7 = 100. * FLOAT(NATEND - NATNOW) / FLOAT(NATEND)
      IF (ABS (XXX7) .GT. 20.) GOTO 250
      LSC98 = .TRUE.
      SCALE = SC98
      SUMFP2 = SUMFC2
      IF (XXX6 .LE. 1.00) GOTO 250
      WRITE (LIS2, FMT='('' $TE SCALE, New scale accepted ... '')')
  250 CONTINUE
      IF (ICYCL .NE. 3) GOTO 7250
      CALL FILINQ (ICOND, DDC, 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) THEN
         DDC(3:8) = 'CONFIG'
         CALL FILINQ (ICOND, DDC, 'FORMATTED', 'INPUT', KINQ)
         ENDIF
      IF (KINQ .NE. 0) GOTO 9111
      DO 2111 I=1,199
      READ (ICOND, FMT='(A72)', END=2112) DDX
      IF (DDX(1:9) .EQ. 'Licensee:') THEN
         III=0
         DO 3111 II=10,72
         CALL KERICH (111, DDX(II:II), K)
 3111    III = III + K
         III = III * 17
         GOTO 4111
         ENDIF
 2111 CONTINUE
 2112 CALL KERNER ( 0, 'MAIN')
 4111 READ (ICOND, FMT='(20X,I6, 1X, A1)', END=2112) IDDX, GWX
      READ (ICOND, FMT='(22X,I6)', END=2112) IDDX2
      CALL FILCLO (ICOND, 'KEEP')
      IDDXX = III - IDDX
      IDDXX2 = IDDX2 / 37
      IDDXX3 = IDDX2 - 37* IDDXX2
      IF (IDDXX .NE. 0) THEN
         GOTO 7112
         ENDIF
      IF (GWX .EQ. 'G' .AND. IDDXX3 .EQ. 0) GOTO 7250
      IF (GWX .EQ. 'X' .AND. IDDXX3 .EQ. 2) GOTO 7250
      IF (GWX .NE. 'W') GOTO 7112
      IF (IDDXX3 .NE. 1) GOTO 7112
 9111 CALL CONFI (0, KEND)
      IF (KEND .LT. 0) GOTO 7112
      IF (KEND .EQ. 0) GOTO 5112
      IF ( ABS(FI1-FI2(KEND)) .LT. 1.) GOTO 7250
      IF (FI2(KEND) .LT. 0.) GOTO 7250
      GOTO 7112
 5112 CALL CONFI (877, KEND)
      CALL KESTOP
      CALL KEPROX
      RETURN
 7112 CONTINUE
      CALL CONFI (777, KEND)
      CALL KESTOP
      CALL KEPROX
      RETURN
 7250 IF( NDELM.EQ.0 ) GOTO 857
      IF( NAT .EQ. 1 ) GOTO 857
      TERM2  = TERM2  / RDEN2C
      EXPRC = 36. * FLOAT(IMULT) / SUMF2(2)
      AVCR = 0.
      NAVCR = 0
      SDCR = 0.
      DO 251 IR = ISTORM, NAT
      ATXYZ(8,IR) = SFPS4 - ATFP4(IR)
      ATXYZ(8,IR) = ATXYZ(8,IR) / RDEN2C
      IF ((ATXYZ(8,IR)) .LT. 0.000001) ATXYZ(8,IR) = 0.000001
      ATXYZ(9,IR) = TERM3 - ATFPO(IR)
      ATXYZ(9,IR) = ATXYZ(9,IR) / RDEN2C
      ATXYZ(10,IR) = ATXYZ(8,IR) + ATXYZ(9,IR)
      ATXYZ(10,IR) = RNUM2C - ATTOT(IR)
      ATXYZ(10,IR) = ATXYZ(10,IR) / RDEN2C
      CR = 10000.
      IF ((ATXYZ(8,IR)) .LT. 0.0000001) CALL KERROR
     *   (' R2-TERM2 too low: impossible??', 244, 'AUTOFR')
      CR = ATXYZ(10,IR) * 36. / ( IZAT(IR)**2 * ATXYZ(4,IR) )
      CR = CR / EXPRC
      ATXYZ(7,IR) = CR
      AVCR = AVCR + CR
      NAVCR= NAVCR + 1
  251 CONTINUE
      IF ( NAVCR .LE. 0 ) THEN
         CHOUT= 'All atoms increase R2: wrong atom set?'
         NAVCR = 1
         CALL SHOUT
         ENDIF
      AVCR = AVCR / FLOAT(NAVCR)
      DO 254 IR = ISTORM, NAT
      CR = ATXYZ(7,IR)
      IF ( IR.GT.ISTORM .OR. NATFIX.LE.1 ) THEN
      SDCR = SDCR + (AVCR - CR)**2
      ENDIF
  254 CONTINUE
      SDCR = SQRT ( SDCR / FLOAT(NAVCR) )
      IF (.NOT. LTESTR) WRITE (LIS1, 1250) AVCR, SDCR, NAVCR
      WRITE (LIS2, 1250) AVCR, SDCR, NAVCR
 1250 FORMAT (' Averaged relative contribution:', F6.3,
     *  ' s.d.:', F6.3 , ' for ', I4, ' terms')
      AVSD2 = AVCR + 2. * SDCR
      IF ( PSQ.LT.0.95 .AND. ICYCL.LE.2 ) THEN
         CRTEST = AMIN1( 0.25, AVSD2)
         IF (AVCR.GT.0.0) CRTEST = AMIN1( 0.75, AVSD2)
      ELSE
         CRTEST = AMIN1 (0.5, AVSD2)
         IF (NATRES.LE.2) THEN
            IF (NAT.GT.100) THEN
               SDADD = 0.
               DO 257 IL = NAT-30,NAT
               SDADD = SDADD + SDCR * 0.04
               ATXYZ(7,IL) = ATXYZ(7,IL) + SDADD
  257          CONTINUE
               ENDIF
            ENDIF
         ENDIF
      AVSD1 = AVCR + SDCR
      BADR2 = R2X - RNM2EZ
      IF (R2X .GT. 0.2 .AND. BADR2 .GT. 0.09999)
     *   AVSD1 = AVCR + SDCR * 0.1 / BADR2
      CRTES1 = CRTEST
      IF (BADR2 .GT. 0.1) CRTES1 = AMIN1 (CRTEST, AVSD1)
      CRTEST = AMAX1( CRTEST, AVCR + 0.001)
      IF( CRTEST .LT. -0.5 ) CRTEST = -0.5
      IF (PSQ .GT. 0.90) CRTEST = AMAX1 (CRTEST, 0.5 * PSQ)
      IF (.NOT. LTESTR) WRITE (LIS2, 259) CRTES1, CRTEST
  259 FORMAT (' Acceptance criterion for R2-rejection =', F7.3, ' ???'/
     *        ' Acceptance criterion ( heavy atoms !) =', F7.3, ' ???'/
     1        ' Expected relative contribution to R2  = -1.000')
      NDELMC = 0
      DO 263 IR = ISTORM, NAT
      CR = ATXYZ(7,IR)
      IF (LTESTR) THEN
         WRITE(LIS2,261) NSET, IR,
     *      ATNAME(IR),ATXYZ(8,IR),ATXYZ(9,IR),ATXYZ(10,IR), CR
  261 FORMAT(' Set', I3,' Atom', I3, 1X, A6, ' contr. to R2 =', F6.5,
     *      F7.5, ' =', F7.5, ' Rel:', F7.3 )
      ELSE
         IF ((CR .GT. CRTEST .AND. IZAT(IR) .GT. 13) .OR.
     *       (CR .GT. CRTES1 .AND. IZAT(IR) .LE. 13))  THEN
            NDELMC = NDELMC + 1
            IF (NDELM .EQ. 0) WRITE(LIS1,262) IR, ATNAME(IR), CR
            IF (NDELM .NE. 0) WRITE(LIS2,262) IR, ATNAME(IR), CR
  262 FORMAT(' Atom', I3,1X, A6, ' Relative contribution to R2 =', F6.4)
            ENDIF
         ENDIF
  263 CONTINUE
      IF( NAT .GE. 10 .AND. ICYCL .LE. 7 )
     * NDELM = MAX0( NDELM, INT( FLOAT(NAT) *(RNM2XZ-RNM2EZ)/(PSQ*2.)))
      IF( NAT .GE. 20 .AND. ICYCL .LE. 7 .AND. PSQ .GT. 0.8)
     * NDELM = MAX0( NDELM, INT( FLOAT(NAT) *(RNM2XZ-RNM2EZ)/(PSQ)))
      NDELM = MIN0 (NDELM, NAT*2/3)
      IF (FLOAT(NDELM)/FLOAT(NAT).LT.0.01*FLOAT(ICYCL-3)) NDELM = 0
      NDELM = MIN0 ( NDELM, NDELMC )
      NDEL =0
      IF (NORECY) THEN
         WRITE (LIS2, FMT='(A)')
     *      ' No rejections if NORECY is given in automatic mode'
         GOTO 857
         ENDIF
      IF (LTESTR) GOTO 857
      IF( NDELM.EQ.0 ) GOTO 857
      IZAV = 0
      Z2TOT = 0.
      DO 267 I = 1, NAT
      Z2TOT = Z2TOT + FLOAT(IZAT(I))**2
  267 IZAV = IZAV + IZAT(I)
      IZ2TOT = NINT (Z2TOT * 0.90)
      ZAV = FLOAT(IZAV) / FLOAT(NAT)
      DO 277 ID = 1, NDELM
      CRMAX = -100.0
      IAD   =  0
      DO 273 IS = ISTART, NAT
      IF ( ATXYZ(8,IS). LT . 0.000001 ) GOTO 273
      IF ( ATXYZ(7,IS) .GT. CRMAX) THEN
         CRMAXT = ATXYZ(7,IS)
         FZAF = SQRT (FLOAT(IZAT(IS)) / ZAV)
         IF (CRMAXT .GT. 0. .AND. FZAF .GT. 1.2) CRMAXT = CRMAXT / FZAF
         IF (CRMAXT .LT. CRMAX) GOTO 273
         CRMAX = CRMAXT
         IAD = IS
         ENDIF
  273 CONTINUE
      IF(IAD.EQ.0) GOTO 309
      IZ2TOT = IZ2TOT - IZAT(IAD)**2
      IF (IZ2TOT .LT. 0) GOTO 309
      NDEL = NDEL + 1
      WRITE (LIS1,275) IAD, ATNAME(IAD), CRMAX
  275 FORMAT(' Atom', I4, ' = ' , A6,
     1 ' is deleted! (Rel. contribution to R2 =', F7.4, ')')
      TERM2  = TERM2  - ATXYZ(8,IAD)
      TERM3  = TERM3  - ATXYZ(9,IAD) * RDEN2C
      ATXYZ(8,IAD)  = 0.0
      ATXYZ(9,IAD)  = 0.0
      ATXYZ(10,IAD) = -999.
      ISMAX = IFIX (STLMAX * 400. +0.0001) + 2
      ITY = ITAT(IAD)
      DO 276 IS=1,ISMAX
  276 SUMF2P(IS) = SUMF2P(IS) - FF(IS,ITY) * FF(IS,ITY) * ICENT * NSYMM
      PSQ = SUMF2P(2)/SUMF2(2)
  277 CONTINUE
  309 CONTINUE
      IF( NDEL.LE.0 ) GOTO 801
      KEYS(1) = 99
      WRITE (IPR1, 333) NDEL
  333 FORMAT (' Nr of atoms deleted because of R2: ', I4)
      NATSN = 0
      IF (NATFIX.EQ.0) THEN
         DO 388 IR = 1 ,NATS
  388    IF (ATXYZ(10,IR).LT.-998.) NATSN = NATSN + 1
         ENDIF
      NSC   = NAT
      ISC   = 1
  390 IF (ATXYZ(10,ISC).LT.-998.) THEN
         NSC = NSC - 1
         DO 395 IS2 = ISC, NSC
         ATNAME(IS2) = ATNAME(IS2 + 1)
         IZAT(IS2)   = IZAT(IS2 + 1)
         ITAT(IS2)   = ITAT(IS2 + 1)
         DO 392 NE  = 1, 10
         ATXYZ(NE,IS2) = ATXYZ(NE, IS2 + 1)
  392    CONTINUE
  395    CONTINUE
      ELSE
         ISC = ISC + 1
         ENDIF
      IF ( ISC .LE. (NAT-NDEL) ) GOTO 390
      NAT = NAT - NDEL
      IF (NATSN .GT. 0) THEN
         NATS = NATS - NATSN
         IF (ICYCL .GT. 1) THEN
            CHOUT = ' One or more original atoms skipped !! '
            CALL SHOUT2
            ENDIF
         CALL LOGRD(IDDL, 'NAT=', KLOG)
         IRUN = 0
         IF (KLOG .GT. 0) IRUN = NINT(FNUM(2))
         IF (IRUN .NE. KEYS(13)) GOTO 411
         KPROG= NINT(FNUM(4))
         WRITE (CHOUT,FMT='(''RUN '',I3,'' NEW   NAT= '',I4,
     *       '' KPROG '', I3)') IRUN, NATS, KPROG
         CALL LOGWR (IDDL)
  411    CALL FILCLO (IDDL, 'KEEP')
         ENDIF
      CALL FCALII (NSET)
      DO 475 I = 1, NAT
      ATXYZ(8,I)  = -0.000001
      ATXYZ(9,I)  = 0.0
      ATXYZ(10,I) = 0.0
  475 CONTINUE
      BUFBUF(25) = NAT
      BUFBUF(26) = P1SQ
      BUFBUF(27) = PSQ
      CALL KERNAB (BUFBUF, BUFFC, 27)
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      CALL FCALC (NSET)
      IF (MOD(NRECY,10) .LT. 8) RETURN
      IF (ICYCL.LE.9) NRECY = NRECY - 1
      KEYD = 3
      CALL FILINQ (ICOND, 'CONDA', 'FORMATTED', 'OUTPUT', KINQ)
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ICOND,
     *   FMT = '(''CONDA  '', A6, '' generated by AUTOFR'' )') CCODE
      IF (TITLE .NE. ' ')
     *   WRITE (ICOND, FMT = '(''TITLE '', A64 )') TITLE
      WRITE (ICOND, FMT = '(''PROGRAM  FOUR  NRECY '', I3)') NRECY
      WRITE (ICOND, FMT = '(''PROGRAM  NUTS AT2X'')')
      WRITE (ICOND, FMT = '(''FINISH'')')
      WRITE (IDDS, FMT = '(''FOUR'' /  ''NUTS'' / ''STOP'')')
      CALL FILCLO (ICOND, 'KEEP')
      CALL FILCLO (IDDS, 'KEEP')
      RETURN
  801 CONTINUE
  857 CONTINUE
      IF (LTESTR) THEN
         IF (NSET .EQ. 1) THEN
            CHOUT = ' Structure factor calculation for all atom sets:'
            CALL SHOUT
            CHOUT = ' Set No.  Nr.atoms  p**2  expected R2  actual R2'
            CALL SHOUT
            ENDIF
         WRITE (CHOUT, 1254) NSET, NAT, PSQ, RNM2EZ, RNM2XZ
 1254    FORMAT (I7, I8, F9.3, F13.3, F11.3)
         CALL SHOUT
         IF (RNM2XZ .LT. R2MIN) THEN
            R2MIN = RNM2XZ
            NSETM = NSET
            ENDIF
         GOTO 109
         ENDIF
      CHOUT = ' AUTOFR finished: All input atoms accepted!'
      CALL SHOUT2
      RETURN
  910 CONTINUE
      CHOUT = ' AUTOFR finished for all atom sets '
      CALL SHOUT2
      IF (R2MIN .LT. 998. .AND. NSETM .NE. 1) THEN
         WRITE (IPR1, 1255) R2MIN, NSETM
         WRITE (LIS1, 1255) R2MIN, NSETM
 1255    FORMAT(' Note: Lowest value of R2 =', F6.3, ' for set nr.', I3)
         ENDIF
      RETURN
      END
      SUBROUTINE FCALC7 (KEYT, ATXYZ, ITAT, NAT, ETAO2)
      DIMENSION ATXYZ(10,NAT), ITAT(NAT)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      DIMENSION FFF(10), ADTRIG(24)
      DATA  FFF, ADTRIG / 34*0.0 /
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      DO 110 J=1,NTYPE
      IF (CELPAR(J).LE.0.0) GOTO 110
      FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL
  110 CONTINUE
      TBPOV = EXPBP (ISS)
      CALL HKLEX1 (HKLX, HKLX)
      IF (NSYMM.EQ.1) GOTO 150
      DO 140 J=2,NSYMM
      IF (ITRS(J).EQ.0) GOTO 140
      ADTRIG(J) = HKLX(1,1)*TSYMM(1,J) + HKLX(2,1)*TSYMM(2,J) +
     *            HKLX(3,1)*TSYMM(3,J)
  140 CONTINUE
  150 FAP = 0.0
      FBP = 0.0
      DO 250 I=1,NAT
      A1 = 0.
      B2 = 0.
      DO 200 J=1,NSYMM
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      A1 = A1 + SICO(ITRIG + 2500)
      IF (ICENT.NE.2) B2 = B2 + SICO(ITRIG)
  200 CONTINUE
      IF (KEYT .EQ. 1) THEN
         TF = ATXYZ(4,I) * TBPOV
      ELSE
         TF = ATXYZ(4,I) * EXP (-STL2 * ATXYZ(5,I))
         ENDIF
      IJ = ITAT(I)
      ATXYZ(8,I) = A1 * FFF(IJ) * TF
      FAP = FAP + ATXYZ(8,I)
      IF (ICENT.EQ.2) GOTO 250
      ATXYZ(9,I) = B2 * FFF(IJ) * TF
      FBP = FBP + ATXYZ(9,I)
  250 CONTINUE
      ETAO2 = SUMF2P(ISS) * ( EXPBP(ISS) * EXPBP(ISS) ) +
     *      ( SUMF2(ISS) - SUMF2P(ISS) ) * ( EXPBR(ISS) * EXPBR(ISS) )
      FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP)
      PHIP = 0.0
      IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925
      IF (PHIP.LT.0.0) PHIP = PHIP + 360.
      RETURN
      END
      SUBROUTINE RINI (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT)
      IF (ICENT.EQ.1) THEN
         C1 = 4
         C2 = 2
      ELSE
         C1 = 6
         C2 = 3
         ENDIF
      RNUM  = 0.
      RDEN  = 0.
      RNM2XF= 0.
      RDN2XF= 0.
      RNM2EF= 0.
      RDM2EF= 0.
      RNM2XZ= 0.
      RDN2XZ= 0.
      RNM2EZ= 0.
      RDN2EZ= 0.
      SR2NUM= 0.
      SR2DEN= 0.
      RETURN
      END
      SUBROUTINE R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12))
      EQUIVALENCE (KEYWIL, KEYS(12))
      LOGICAL SWRECY, EXPAND
      EQUIVALENCE (SWRECY, SWITCH(17)), (EXPAND, SWITCH(23))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      PARAMETER (MAXAT  = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      FOSC  = FOBS * SCALE
      FDEL  = ABS (FOSC-FP)
      RNUM  = RNUM  + FDEL
      RDEN  = RDEN  + FOSC
      ETAO2 = SUMF2P(ISS) * EXPBP(ISS)**2 +
     *        (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2
      ETAC2 = SUMF2P(ISS) * EXPBP(ISS)**2
      ETA2  = ETAC2 / ETAO2
      EOBS2 = FOSC **2 / ETAO2
      EOBS  = EOBS2 **0.5
      EOBS4 = EOBS2 **2
      ETAEP2 = FP**2 / ETAO2
      EP = FP / ETAC2 **0.5
      RNM2XF = RNM2XF + (EOBS2 - ETAEP2)**2
      RDN2XF = RDN2XF +  EOBS4
      ETA8   = ETA2 **4
      ETA4   = ETA2 **2
      ETA2M4 = ETA2 - ETA4
      RNM2EF = RNM2EF + EOBS4 * (ETA8 - 2*ETA4 + 1) +
     *                  EOBS2 * (C1 * ETA4 - 2) * ETA2M4 +
     *                  C2    * ETA2M4**2
      RDN2EF = RDN2XF
      ETA2  = SUMF2P(2) / SUMF2(2)
      RNM2XZ = RNM2XZ + (EOBS2 - ETA2 * EP**2)**2
      RDN2XZ = RDN2XZ +  EOBS4
      ETA8   = ETA2**4
      ETA4   = ETA2**2
      ETA2M4 = ETA2-ETA4
      RNM2EZ = RNM2EZ + EOBS4 * (ETA8 - 2*ETA4 + 1) +
     *                  EOBS2 * (C1 * ETA4 - 2) * ETA2M4 +
     *                  C2    * ETA2M4**2
      RDN2EZ = RDN2XF
      EOBS6  = EOBS2**3
      ETA6   = ETA2**3
      ETA8   = ETA4**2
      ETA10  = ETA2**5
      ETA12  = ETA4**3
      ETA14  = ETA2**7
      IF(ICENT.EQ.1) THEN
         SR2NUM = SR2NUM +
     *   EOBS6    *  (  8  * ETA14 -  16 * ETA10 +  8 * ETA6 ) *
     *                  ( 1 - ETA2 )    +
     *   EOBS4    *  (  52 * ETA12 -  48 * ETA8  +  4 * ETA4 ) *
     *                  ( 1 - ETA2 )**2 +
     *   EOBS2    *  (  80 * ETA10 -  16 * ETA6 )              *
     *                  ( 1 - ETA2 )**3 +
     *   20 * ETA8 *    ( 1 - ETA2 )**4
      ELSE
         SR2NUM = SR2NUM +
     *   EOBS6    *  ( 16  * ETA14 -  32 * ETA10 + 16 * ETA6 ) *
     *                  ( 1 - ETA2 )    +
     *   EOBS4    *  ( 168 * ETA12 - 144 * ETA8  +  8 * ETA4 ) *
     *                  ( 1 - ETA2 )**2 +
     *   EOBS2    *  ( 384 * ETA10 -  48 * ETA6 )              *
     *                  ( 1 - ETA2 )**3 +
     *   96 * ETA8 *    ( 1 - ETA2 )**4
         ENDIF
      SR2DEN = SR2DEN + EOBS4
      RETURN
      END
      SUBROUTINE RPR(RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *           RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,PSQ)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IPR1, IFILE(6))
      LOGICAL LTESTR
      EQUIVALENCE (LTESTR, SWITCH(27))
      RNUM   = RNUM   / RDEN
      RNM2XF = RNM2XF / RDN2XF
      RNM2XZ = RNM2XZ / RDN2XZ
      RNM2EF = RNM2EF / RDN2EF
      RNM2EZ = RNM2EZ / RDN2EZ
      RNM2EF = RNM2EF**2 + (1.0 - RNM2EF) * SQRT(RNM2EF**2 + 0.01)
      RNM2EZ = RNM2EZ**2 + (1.0 - RNM2EZ) * SQRT(RNM2EZ**2 + 0.01)
      IF ( RNM2XZ .LT. 0.10 ) RNM2EZ = RNM2XZ
      IF ( SR2NUM .LT. 0.0 ) SR2NUM = 0.0
      SR2NUM = SR2NUM**0.5
      SR2NUM = SR2NUM / SR2DEN
      IF (LTESTR) RETURN
      IF(PSQ.GT..50) WRITE (LIS1, 251) RNUM
  251 FORMAT (' Conventional R-factor =', F7.3)
      WRITE (LIS2, 250) RNM2XF,RNM2EF,RNM2XZ,RNM2EZ, RNM2XZ
  250 FORMAT (' R2 (fj) =', F6.3, ' (est.:', F5.3,
     *  ')  R2 (Zj) =', F6.3, ' (est.:', F5.3, ') =====>', F6.3,/)
      IF ( RNM2XZ .GE. 0.10 ) THEN
         WRITE (LIS1, 255) RNM2EZ, RNM2XZ
         WRITE (IPR1, 255) RNM2EZ, RNM2XZ
  255    FORMAT (31X,  'expected R2 :', F6.3, ' ==> actual R2 :', F6.3)
      ELSE
         WRITE (LIS1, 256) RNM2XZ
         WRITE (IPR1, 256) RNM2XZ
  256    FORMAT (49X, ' ===> actual R2 :', F6.3)
         ENDIF
      RETURN
      END
      SUBROUTINE SCASTA
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINFO, IFILE(11)),  (IBINFC, IFILE(12))
      EQUIVALENCE (IDDL, IFILE(1)),     (KEYWIL, KEYS(12))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      DIMENSION AVAL(100),BVAL(100),CVAL(200),
     * SCERR(21),IPGO(9,21,3),PGO1(9,21,3),PGO2(9,21,3),FPGOS(2,9,3),
     * FBEX(3),PGOS1(2,9,3),PGOS2(2,9,3),IREFST(2,9,3),SCTAB(2,9,3),
     * RSCTL(2,9,3),RSCNM(2,9,3),RSC(2,9,3),E2SUMT(2,9,3),BPVAR(10,3),
     * BRVAR(10,3),E2FOM(2,9,3)
      EQUIVALENCE (AVAL(1),CVAL(1)), (BVAL(1),CVAL(101))
      LOGICAL   SCOK1, SCOK2, WCHOSE
      PARAMETER (DELTAB = 0.05, DELTAS = 0.02, RAD = 57.29578)
      PARAMETER (BOVVAR = 0.2)
      DATA AVAL /
     * 0.05607, 0.05316, 0.10737, 0.43949, 0.38354, 0.94552, 0.78177,
     * 1.77778,-0.62897, 0.52696, 0.26794, 0.64104,-1.23707, 0.66410,
     * 0.17746, 0.48249,-0.40477,-0.20574, 1.01686,-1.02381,-0.49083,
     *-0.99899,-0.10605, 1.22243,-0.79348,-0.50365, 0.05771, 0.11873,
     *-0.38572,-0.48818, 0.51336,-1.72440, 0.29756, 0.62057,-1.10752,
     *-0.72877, 0.91284,-0.28598,-1.39700,-0.02802,-0.98413,-0.29812,
     * 0.14420,-0.03831, 0.77742,-0.97348, 0.24064, 0.88360,-0.00087,
     * 0.94690,-0.76506, 0.21406, 0.55916, 0.60612, 0.73216,-0.60812,
     *-0.68421, 0.26031,-0.51343,-0.56541,-0.59166, 0.13868, 1.21770,
     *-0.61774, 0.74481,-0.29790,-0.54401,-0.14904, 0.24532,-0.07146,
     *-1.18466,-0.11162, 0.01974, 0.40478,-0.11380, 0.18916,-0.65419,
     * 0.16521,-0.35749, 0.44576, 1.40299,-0.74702,-0.64231, 0.42047,
     * 0.10152,-0.42354,-0.98954,-0.03869,-0.02689,-0.32888,-0.49380,
     * 0.37292,-0.93195, 0.76896, 0.12626, 0.35347,-0.72071, 0.33275,
     *-0.34783, 0.03697 /
      DATA BVAL /
     *-0.03907,-1.75002,-0.06408, 1.12202,-0.24004,-0.66600,-0.11809,
     *-1.40804,-1.42002,-0.24606,-0.88801, 0.52319,-0.64014, 0.34116,
     * 0.29016,-0.28116,-0.14612, 0.24712, 0.47915,-0.28316,-0.48419,
     *-1.24918,-0.84426, 1.10029, 1.17727, 0.76122, 0.86424, 0.25520,
     * 0.52625,-0.99430, 0.06231,-0.58133, 0.29139, 1.01030,-0.79730,
     * 0.23834, 0.25831, 2.00439, 0.59242,-0.90149, 0.09043, 0.54341,
     * 0.45847, 0.93748,-0.03748,-0.07542, 0.47249, 0.61343,-0.26141,
     * 1.63743,-0.34850,-0.11253,-0.23654, 0.30458, 0.07050,-0.16750,
     *-1.13557,-0.26351, 0.87757,-0.58550, 0.24956,-0.64854, 0.24951,
     *-1.58359,-0.79956, 1.46555, 0.04664,-0.41467, 0.42766,-0.56565,
     *-0.86260,-0.74867, 0.30365, 0.22761, 0.68965,-0.06278, 0.70473,
     * 0.68972, 0.00874, 0.23871, 0.33476,-1.04381,-0.61488, 1.28188,
     * 1.22180, 1.09083,-0.28580,-0.59186,-1.14085, 0.73180, 0.87385,
     * 0.14382,-0.85487,-1.05181,-0.18495, 0.15194,-0.04698,-0.81092,
     *-0.98992, 0.16298 /
      DATA SCMIN1, BPMIN1, BRMIN1 / 0., 0., 0. /
      DATA SCMIN2, BPMIN2, BRMIN2 / 0., 0., 0. /
      DATA SCMIN3, BPMIN3, BRMIN3 / 0., 0., 0. /
      FKEYP2=PSQ/SQRT(FLOAT(NAT))
      FCRIT=0.23
      PSQCRT=0.3
      IF ((FKEYP2.LT.FCRIT).OR.(KEYWIL.EQ.4).OR.(PSQ.LT.PSQCRT)) THEN
         IF (KEYWIL.EQ.4) THEN
            WRITE (LIS2, 50)
  50        FORMAT(' Scale and/or temperature factors were found on',
     *        ' CONDA-file and will be used.')
         ELSE
            WRITE (LIS2, 55)
  55        FORMAT(' Known fragment is small: Smykalla-refinement',
     *         ' is not executed!')
            WRITE (LIS2, 56)PSQ,FKEYP2
  56        FORMAT(' (TEMP: p**2 and FPKEY2 are ',F5.2,' and ',F5.2,')')
            ENDIF
         RETURN
         ENDIF
      ITEST=0
      EGRENS=AMAX1(PSQ,0.5)
      WCHOSE=.TRUE.
      IUNOBS=0
      IREF=0
      ITAB1=0
      ITAB2=0
      ITAB3=0
      SQ2=SQRT(2.)
      ZRTMP=0.
      ZRTMPX=0.
      ZPTMPX=0.
      BRX=0.
      BPX=0.
      YX=0.
      FRY=0.
      FPY=0.
      CALL LOGRD (IDDL, 'MERBSC', KLOG)
      IF (KLOG .LT. 0 .OR. LIT(2) .NE. 'SCALE') THEN
         CHOUT=' MERBIN SCALE not found on DDLOG file: what happened?'
         CALL SHOUT
         CALL KERROR ('You cleared too much, probably!', 114, 'DDMINI')
         ENDIF
      SCAMER = FNUM(2)
      BOV = FNUM(3)
      DO 100 ISC=1,21
  100   SCERR(ISC)=SCAMER*(1.+FLOAT(ISC-11)*DELTAS)
      CALL KERNZI (0,IPGO,567)
      CALL KERNZA (0.,FPGOS,54)
      CALL KERNZI (0,IREFST,54)
      CALL KERNZA (0.,PGO1,567)
      CALL KERNZA (0.,PGO2,567)
      CALL KERNZA (0.,PGOS1,54)
      CALL KERNZA (0.,PGOS2,54)
      CALL KERNZA (0.,BRVAR,30)
      CALL KERNZA (0.,BPVAR,30)
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      BPINP=BUFFC(19)
      BOV = BUFFC(17)
      IEXS=1
      EXVAR1=0.
      EXVAR2=0.
      E2AVE=0.
      RSCAVE=0.
      E2SDIF=0.
      RSCDIF=0.
      IAVE=0
  130 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IF (KENDFO.LT.0) GOTO 210
      CALL BINIFF (0, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'SCASTA')
      IF (FP .LT. -990.) GOTO 130
      JCODE=1
      IF (FOBS.LT.5.*SIG) JCODE=2
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL*400. + 1.5)
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = IEPS
      SUMF2R=SUMF2(ISS)-SUMF2P(ISS)
      ZTMP = SQRT (SUMF2(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZPTMP= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZRTMP= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BOV*STL2)
      YBOV = FP * EXP((-BOV+BPINP)*STL2)
      Y    = FP * EXP((-BP+BPINP)*STL2)
      IF (ABS(Y) .LT. 0.0001) GOTO 130
      IF (ICENT.EQ.1) THEN
        IF (ITAB1.EQ.100) ITAB2=ITAB2+1
        ITAB1 = MOD(ITAB1,100)+1
        ITAB2 = MOD(ITAB2,100)+1
        ER = SQRT(AVAL(ITAB1)**2+BVAL(ITAB2)**2)
        PHIR = ATAN2(BVAL(ITAB2),AVAL(ITAB1))
      ELSE
        ITAB3= MOD(ITAB3,200)+1
        ER = 0.
        PHIR = 0.
      ENDIF
      EOB = (SCALE * FOBS) / ZTMP
      IF (EOB.GT.EGRENS) THEN
         IF (JCODE.EQ.2) IUNOBS = IUNOBS+1
         IREF=IREF+1
         ENDIF
      FBEX(1)=-1*BOVVAR
      FBEX(2)=0.
      FBEX(3)=BOVVAR
      IF (BOV.LT.BOVVAR*2) THEN
        FBEX(1)=AMIN1(BOV,BOVVAR)-BOV
        IF (ABS(FBEX(1)).LT.0.00001) IEXS=2
      ENDIF
      IF (BOV.GT.BOVVAR*10) THEN
        FBEX(1)=-0.1*BOV
        FBEX(3)=0.1*BOV
      ENDIF
      DO 140 IB=1,10
      DO 140 IEX=IEXS,3
      BOVCOR=EXP(-1*FBEX(IEX)*STL2)
      IF ((IB.EQ.10.AND.IEX.EQ.1).OR.(IB.EQ.10.AND.IEX.EQ.2)) GOTO 140
      IF (IB.LT.10) THEN
      IF (PSQ.GT.0.5) THEN
        BRVAR(IB,IEX) = (BOV+FBEX(IEX))*(FLOAT(IB-5)*DELTAB)
        BPVAR(IB,IEX) = (BRVAR(IB,IEX) * (PSQ-1))/PSQ
      ELSE
        BPVAR(IB,IEX) = (BOV+FBEX(IEX)) * (FLOAT(IB-5)*DELTAB)
        BRVAR(IB,IEX) = (BPVAR(IB,IEX)*PSQ)/(PSQ-1)
      ENDIF
        EXVAR1 = EXP(-BRVAR(IB,IEX)*STL2)
        EXVAR2 = EXP(-BPVAR(IB,IEX)*STL2)
      ENDIF
        IF (IB.EQ.10) THEN
          ZRTMPX= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2)
          ZPTMPX= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BP*STL2)
          YX=Y
        ELSE
          ZRTMPX = ZRTMP * EXVAR1 * BOVCOR
          ZPTMPX = ZPTMP * EXVAR2 * BOVCOR
          YX = YBOV * EXVAR2 * BOVCOR
        ENDIF
        FPX=0.
        IF (ICENT.EQ.1) THEN
          FPX= YX * COS(PHIP/RAD)
          FRSTAT=ER*ZRTMPX
          XO= FPX+(FRSTAT*COS(PHIR))
          YO= (YX*SIN(PHIP/RAD))+(FRSTAT*SIN(PHIR))
          FO= SQRT((XO**2)+(YO**2))
        ELSE
          FRX= CVAL(ITAB3)*ZRTMPX*SQ2
          FO= ABS(YX+FRX)
        ENDIF
        EO= FO/SQRT(ZPTMPX**2+ZRTMPX**2)
        IF (IB.LT.10) THEN
        DO 135 IEO=0,1
         EGR=EGRENS+(IEO*0.1)
         JEO=IEO+1
         IF (EO.GT.EGR) THEN
         IREFST(JEO,IB,IEX) = IREFST(JEO,IB,IEX)+1
         IF (ABS(YX).GT.FO) FPGOS(JEO,IB,IEX)=FPGOS(JEO,IB,IEX)+1.
           IF (WCHOSE) THEN
             PGOS1(JEO,IB,IEX)=PGOS1(JEO,IB,IEX)+
     *                           ((ABS(YX)-FO)/SQRT(SUMF2(ISS)))
             PGOS2(JEO,IB,IEX)=PGOS2(JEO,IB,IEX)+
     *                           (ABS(YX)/SQRT(SUMF2(ISS)))
           ELSE
             PGOS1(JEO,IB,IEX)=PGOS1(JEO,IB,IEX)+(ABS(YX)-FO)
             PGOS2(JEO,IB,IEX)=PGOS2(JEO,IB,IEX)+ABS(YX)
           ENDIF
         ENDIF
  135  CONTINUE
       ENDIF
       IF (IB.LT.10) THEN
       IF (EOB.GT.EGRENS) THEN
         DO 150 ISC=1,21
         FSC = FOBS * SCERR(ISC)
           IF (ABS(YX).GT.FSC) IPGO(IB,ISC,IEX)=IPGO(IB,ISC,IEX)+1
           IF (WCHOSE) THEN
             PGO1(IB,ISC,IEX)=PGO1(IB,ISC,IEX)+
     *                     ((ABS(YX)-FSC)/SQRT(SUMF2(ISS)))
             PGO2(IB,ISC,IEX)=PGO2(IB,ISC,IEX)+
     *                     (ABS(YX)/SQRT(SUMF2(ISS)))
           ELSE
             PGO1(IB,ISC,IEX)=PGO1(IB,ISC,IEX)+(ABS(YX)-FSC)
             PGO2(IB,ISC,IEX)=PGO2(IB,ISC,IEX)+ABS(YX)
           ENDIF
  150   CONTINUE
      ENDIF
      ENDIF
  140 CONTINUE
      GOTO 130
  210 DO 215 IB=1,9
      DO 215 IEX=IEXS,3
      FRFDIF=FLOAT(ABS(IREFST(1,IB,IEX)-IREFST(2,IB,IEX)))
      IF(FRFDIF.GT.0.001) THEN
        FINTPO=FLOAT(IREFST(2,IB,IEX)-IREF)/FRFDIF
      ELSE
        FINTPO = 0.0
      ENDIF
      FPGOSD=FPGOS(2,IB,IEX)-FPGOS(1,IB,IEX)
      PGOSD1=PGOS1(2,IB,IEX)-PGOS1(1,IB,IEX)
      PGOSD2=PGOS2(2,IB,IEX)-PGOS2(1,IB,IEX)
      FPGOS(1,IB,IEX)=FPGOS(2,IB,IEX)+FINTPO*FPGOSD
      PGOS1(1,IB,IEX)=PGOS1(2,IB,IEX)+FINTPO*PGOSD1
      PGOS2(1,IB,IEX)=PGOS2(2,IB,IEX)+FINTPO*PGOSD2
  215 CONTINUE
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      DO 230 IB=1,9
      DO 230 IEX=IEXS,3
      FOMOL1=0.
      FOMOL2=0.
      SCOKE1=0.
      SCOKE2=0.
      SCOK1=.FALSE.
      SCOK2=.FALSE.
      FOM1ST=FPGOS(1,IB,IEX)/FLOAT(IREF)
      FOM2S=PGOS1(1,IB,IEX)/PGOS2(1,IB,IEX)
      DO 220 ISC=1,21
      FOM1=(FLOAT(IPGO(IB,ISC,IEX))/FLOAT(IREF))-FOM1ST
      FOM2=(PGO1(IB,ISC,IEX)/PGO2(IB,ISC,IEX))-FOM2S
      IF (ISC.NE.1) THEN
        SCDIF=SCERR(ISC)-SCERR(ISC-1)
        IF (.NOT. SCOK1) THEN
          IF (FOM1.LE.0) THEN
            FOMDIF=ABS(FOM1-FOMOL1)
            SCOKE1=SCERR(ISC)+((FOM1/FOMDIF)*SCDIF)
            SCOK1=.TRUE.
          ELSE
            IF (ISC.EQ.21) SCOKE1=SCERR(ISC)
          ENDIF
        ENDIF
        IF (.NOT. SCOK2) THEN
          IF (FOM2.LE.0.) THEN
            FOMDIF=ABS(FOM2-FOMOL2)
            SCOKE2=SCERR(ISC)+((FOM2/FOMDIF)*SCDIF)
            SCOK2=.TRUE.
          ELSE
            IF (ISC.EQ.21) SCOKE2=SCERR(ISC)
          ENDIF
        ENDIF
      ELSE
        IF (FOM1.LE.0) THEN
          SCOKE1=SCERR(1)
          SCOK1=.TRUE.
        ENDIF
        IF (FOM2.LE.0) THEN
          SCOKE2=SCERR(1)
          SCOK2=.TRUE.
        ENDIF
      ENDIF
      FOMOL1=FOM1
      FOMOL2=FOM2
  220 CONTINUE
      SCTAB(1,IB,IEX)=SCOKE1
      SCTAB(2,IB,IEX)=SCOKE2
  230 CONTINUE
      WRITE(LIS2,243)
  243 FORMAT (' ')
      WRITE(LIS2,244)
      WRITE(LIS1,244)
  244 FORMAT (' New refinement of SCALE, Bp and Br:',
     *' (Israel et al., Z. f. Krist., 1995)')
      WRITE(LIS2,FMT='(''     Bp        Br       scale      Ra   '',
     * ''     DaRa      Rb        DbRb      FOM3'')')
      R2CALT = 0.
      BPINP=BUFFC(19)
      CALL KERNZA(0.,E2SUMT,54)
      CALL KERNZA(0.,E2FOM,54)
      CALL KERNZA(0.,RSCTL,54)
      CALL KERNZA(0.,RSCNM,54)
      CALL KERNZA(0.,RSC,54)
      RSCTL2=0.
      RSCNM2=0.
      E2SMT2=0.
      E2SMAX=-999.
      RSCMAX=-999.
      E2SMIN=999.
      RSCMIN=999.
      FOMMN1=999.
      FOMMN2=999.
      FOMMN3=999.
      ITPX = 0
  250 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IF (KENDFO.LT.0) GOTO 310
      CALL BINIFF (0, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'SCASTA')
      IF (FP .LT. -990.) GOTO 250
      JCODE=1
      IF (FOBS.LT.5.*SIG) JCODE=2
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL*400. + 1.5)
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      SUMF2R=SUMF2(ISS)-SUMF2P(ISS)
      ZTMP = SQRT (SUMF2(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZRTMP= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZPTMP= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      YBOV = FP * EXP((-BOV+BPINP)*STL2)
      Y    = FP * EXP((-BP+BPINP)*STL2)
      DO 280 IFOM=1,3
      M=3
      N=9
      IF (IFOM.EQ.3) THEN
        M=IEXS
        N=1
      ENDIF
      DO 280 IB=1,N
      DO 280 IEX=IEXS,M
      BOVCOR=EXP(-1*FBEX(IEX)*STL2)
      IF (IFOM.NE.3) THEN
        EXVAR1 = EXP(-BRVAR(IB,IEX)*STL2)
        EXVAR2 = EXP(-BPVAR(IB,IEX)*STL2)
        ZRTMPX = ZRTMP * EXVAR1 * BOVCOR
        ZPTMPX = ZPTMP * EXVAR2 * BOVCOR
        YX = YBOV * EXVAR2 * BOVCOR
        FSC=FOBS*SCTAB(IFOM,IB,IEX)
      ELSE
        ZRTMPX = SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2)
        YX = Y
        FSC=FOBS*SCALE
      ENDIF
      FONRM = (FSC*FSC)/SUMF2(ISS)
      FPNRM = (YX*YX)/SUMF2(ISS)
      FRNRM = (ZRTMPX*ZRTMPX)/SUMF2(ISS)
      IF (IFOM.NE.3) THEN
        RSCTL(IFOM,IB,IEX)=RSCTL(IFOM,IB,IEX)+(FONRM-FPNRM-FRNRM)**2
        RSCNM(IFOM,IB,IEX)=RSCNM(IFOM,IB,IEX)+FONRM**2
      ELSE
        RSCTL2=RSCTL2+(FONRM-FPNRM-FRNRM)**2
        RSCNM2=RSCNM2+FONRM**2
      ENDIF
      ITPX = IPHFIX(HKLX) - 1
      E1T = (FSC-YX) / ZRTMPX
      E1ST = ABS(E1T)
      IF (E1ST.GT.4.) E1ST = 4.
      IF (JCODE.LE.1) GOTO 270
      IF (E1T.GT.0.) GOTO 260
      E1T = (1.4*FSC - YX)/ZRTMPX
      IF (E1T.GT.0.) E1 = 0.0
      GOTO 270
  260 E1T = (0.7*FSC - YX)/ZRTMPX
      IF (E1T.LT.0.0) E1T = 0.0
  270 E2T = (FSC+YX) / ZRTMPX
      IF (JCODE.GT.1) E2T = AMAX1(YX/ZRTMPX, E1T)
      CALL W1PROB (ITPX, E1T, E2T, PT)
      EEX = E2EXP(ITPX, E1ST, E2T)
      IF (IFOM.NE.3) THEN
        E2SUMT(IFOM,IB,IEX) = E2SUMT(IFOM,IB,IEX) + EEX
      ELSE
        E2SMT2=E2SMT2+EEX
      ENDIF
  280 CONTINUE
      GOTO 250
  310 DO 320 IFOM=1,2
      DO 320 IB=1,9
      DO 320 IEX=IEXS,3
        E2SUMT(IFOM,IB,IEX)=E2SUMT(IFOM,IB,IEX)/FLOAT(NREFL)
        E2FOM(IFOM,IB,IEX)=0.
        IF (E2SUMT(IFOM,IB,IEX).LT.1.0)
     *           E2FOM(IFOM,IB,IEX)=2*ABS(1.0-E2SUMT(IFOM,IB,IEX))
        IF (E2SUMT(IFOM,IB,IEX).GT.1.1)
     *           E2FOM(IFOM,IB,IEX)=ABS(1.1-E2SUMT(IFOM,IB,IEX))
        E2AVE=E2AVE+E2FOM(IFOM,IB,IEX)
        RSC(IFOM,IB,IEX)=RSCTL(IFOM,IB,IEX)/RSCNM(IFOM,IB,IEX)
        RSCAVE=RSCAVE+RSC(IFOM,IB,IEX)
        IAVE=IAVE+1
  320 CONTINUE
      E2SMT2=E2SMT2/NREFL
      E2FOM2=0.
      IF (E2SMT2.LT.1.0) E2FOM2=2*ABS(1.0-E2SMT2)
      IF (E2SMT2.GT.1.1) E2FOM2=ABS(1.1-E2SMT2)
      IAVE=IAVE+1
      E2AVE=(E2AVE+E2FOM2)/FLOAT(IAVE)
      RSC2=RSCTL2/RSCNM2
      RSCAVE=(RSCAVE+RSC2)/FLOAT(IAVE)
      DO 321 IFOM=1,2
      DO 321 IB=1,9
      DO 321 IEX=IEXS,3
        ATERM=ABS(E2FOM(IFOM,IB,IEX)-E2AVE)
        BTERM=ABS(RSC(IFOM,IB,IEX)-RSCAVE)
        E2SDIF=E2SDIF+ATERM
        RSCDIF=RSCDIF+BTERM
  321 CONTINUE
      ATERM=ABS(E2FOM2-E2AVE)
      BTERM=ABS(RSC2-RSCAVE)
      E2SDIF=AMAX1((E2SDIF+ATERM)/FLOAT(IAVE),0.1)
      RSCDIF=AMAX1((RSCDIF+BTERM)/FLOAT(IAVE),0.01)
      FOM3P1=RSCDIF*E2FOM2
      FOM3P2=E2SDIF*RSC2
      FOM3=FOM3P1+FOM3P2
      WRITE(LIS2,FMT='(8F10.5)')BP,BR,SCALE,E2FOM2,FOM3P1,RSC2,FOM3P2,
     *    FOM3
      IF (FOM3.LT.FOMMN1) THEN
        FOMMN1=FOM3
        SCMIN1=SCALE
        BPMIN1=BP
        BRMIN1=BR
      ENDIF
      DO 330 IFOM=1,2
        WRITE(LIS2,FMT='('' FOM'',I1,''-------------------'')')IFOM
      DO 330 IB=1,9
      DO 330 IEX=IEXS,3
        BPX = (BOV+FBEX(IEX)) + BPVAR(IB,IEX)
        BRX = (BOV+FBEX(IEX)) + BRVAR(IB,IEX)
        FOM3P1=RSCDIF*E2FOM(IFOM,IB,IEX)
        FOM3P2=E2SDIF*RSC(IFOM,IB,IEX)
        FOM3=FOM3P1+FOM3P2
        IF (FOM3.LT.FOMMN1) THEN
          FOMMN3=FOMMN2
          BPMIN3=BPMIN2
          BRMIN3=BRMIN2
          SCMIN3=SCMIN2
          FOMMN2=FOMMN1
          BPMIN2=BPMIN1
          BRMIN2=BRMIN1
          SCMIN2=SCMIN1
          FOMMN1=FOM3
          BPMIN1=BPX
          BRMIN1=BRX
          SCMIN1=SCTAB(IFOM,IB,IEX)
          GOTO 329
        ENDIF
        IF ((FOM3.LT.FOMMN2).AND.(FOM3.GT.FOMMN1))THEN
          FOMMN3=FOMMN2
          BPMIN3=BPMIN2
          BRMIN3=BRMIN2
          SCMIN3=SCMIN2
          FOMMN2=FOM3
          BPMIN2=BPX
          BRMIN2=BRX
          SCMIN2=SCTAB(IFOM,IB,IEX)
          GOTO 329
        ENDIF
        IF ((FOM3.LT.FOMMN3).AND.(FOM3.GT.FOMMN2)) THEN
          FOMMN3=FOM3
          BPMIN3=BPX
          BRMIN3=BRX
          SCMIN3=SCTAB(IFOM,IB,IEX)
        ENDIF
  329   WRITE(LIS2,FMT='(8F10.5)')BPX,BRX,SCTAB(IFOM,IB,IEX),
     *  E2FOM(IFOM,IB,IEX),FOM3P1,RSC(IFOM,IB,IEX),FOM3P2,FOM3
  330 CONTINUE
      WRITE(LIS2,FMT='('' Best solutions: '')')
      WRITE(LIS2, 333) BPMIN1, BRMIN1, SCMIN1, FOMMN1
      WRITE(LIS2, 333) BPMIN2, BRMIN2, SCMIN2, FOMMN2
      WRITE(LIS2, 333) BPMIN3, BRMIN3, SCMIN3, FOMMN3
  333 FORMAT (' Bp ',F7.3, ' Br ', F7.3, ' Sc ',F7.3,' FOM3 ',F7.5)
      WRITE (LIS2, 334)
  334 FORMAT (' We selected the first solution for further',
     * ' calculations!')
      WRITE (LIS1, 335)
  335 FORMAT (' New values are:')
      SCALE=SCMIN1
      BP=BPMIN1
      BR=BRMIN1
      WRITE (LIS1, 336) BP, BR, SCALE
  336 FORMAT (' Bp = ', F6.3, '  Br = ', F6.3, '  Scale = ', F9.5)
      WRITE (CHOUT, 337) SCALE, BP, BR
  337 FORMAT ('SCALE ', F14.7, ' BP ', F11.5, ' BR ', F10.5)
      CALL LOGWR (IDDL)
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      END
      SUBROUTINE CONFI (KEY, KEND)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICONA, IFILE(1)), (ICONI, IFILE(2))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (IHELP, IFILE(9))
      DIMENSION KRICH(2,32)
      CHARACTER*1 LRICH(2,32)
      KEND = 0
      IF (KEY .GT. 0) GOTO 337
      IF (KEY .LT. 0) RETURN
      CALL XHELP (IHELP, LIS1, 875. )
      READ (IHELP, 404, END=600)
      KODE = 0
  103 READ (IHELP, 404, END=600) (KRICH(1,L), L=1,32)
      IF (KRICH(1,1) .GT. 77) RETURN
      READ (IHELP, 404, END=600) (KRICH(2,L), L=1,32)
      K=1
      DO 113 L = 32, 1, -1
      IF (KRICH(K,L) .NE. 0) GOTO 117
      KRICH(K,L) = 10
  113 CONTINUE
  117 CONTINUE
      DO 122 L = 1,32
      I = KRICH(K,L)
      CALL KERICH (I, LRICH(K,L), KEND)
  122 CONTINUE
      DO 143 L = 2, 26, 6
      M = L + 5
      N = 0
      KODE = KODE + 1
      DO 140 J = L, M
      N = N + 1
      IF (LRICH(K,J) .NE. CCODE(N:N)) GOTO 143
  140 CONTINUE
      KEND = KODE
      RETURN
  143 CONTINUE
      GOTO 103
  337 FFF = KEY
      CALL XHELP (IHELP, LIS1, FFF )
      READ (IHELP, 404, END=600)
  403 READ (IHELP, 404, END=600) (KRICH(1,L), L=1,32)
  404 FORMAT (32I2)
      IF (KRICH(1,1) .GT. 77) RETURN
      READ (IHELP, 404, END=600) (KRICH(2,L), L=1,32)
      DO 422 K=1,2
      DO 413 L = 32, 1, -1
      IF (KRICH(K,L) .NE. 0) GOTO 417
      KRICH(K,L) = 10
  413 CONTINUE
  417 CONTINUE
      DO 422 L = 1,32
      I = KRICH(K,L)
      CALL KERICH (I, LRICH(K,L), KEND)
  422 CONTINUE
      WRITE (LIS1, 424) ((LRICH(K,L), L=1,32), K=1,2)
      WRITE (IPR1, 424) ((LRICH(K,L), L=1,32), K=1,2)
  424 FORMAT (64A)
      GOTO 403
  600 KEND = -1
      CONTINUE
      RETURN
      END
      SUBROUTINE GETR2X (KEY, IATOLD, IRUN, R2CYC, KEND)
      DIMENSION R2CYC(20)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      KEND = 0
      IF (KEY .NE. 0) GOTO 813
      CALL KERNZA (-1.0, R2CYC, 20)
      NCYT = 0
      NCY = 0
      CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         CALL FILCLO (IATOLD, 'KEEP')
         RETURN
         ENDIF
  313 CALL KERINA (IATOLD,  LIT, 1, LEND)
      IF (LEND .EQ. 5) GOTO 713
      IF (LEND .LT. 0) GOTO 713
      IF (LIT(1) .NE. 'ATOMS') GOTO 313
      CALL KERING ('RUN', N)
      IF (N .LE. 0) GOTO 313
      NRUN = NINT (FNUM(N))
      IF (NRUN .NE. IRUN) GOTO 313
      CALL KERING ('CY=', N)
      IF (N .LE. 0) GOTO 313
      NCYT = NINT (FNUM(N))
      IF (NCYT .LE. 0 .OR. NCYT .GT. 20) GOTO 313
      CALL KERING ('R2X=', N)
      IF (N .LE. 0) GOTO 313
      R2X = FNUM(N)
      IF (R2X .LE. -0.001 .OR. R2X .GT. 9.999) GOTO 313
      NCY = NCYT
      R2CYC(NCY) = R2X
      GOTO 313
  713 CALL FILCLO (IATOLD, 'KEEP')
      KEND = NCY
      RETURN
  813 CONTINUE
      CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         CALL FILCLO (IATOLD, 'KEEP')
         RETURN
         ENDIF
      KEY1 = KEY - 1
  823 CALL KERINA (IATOLD,  LIT, 1, LEND)
      IF (LEND .EQ. 5) GOTO 893
      IF (LEND .LT. 0) GOTO 893
      IF (LIT(1) .NE. 'ATOMS') GOTO 823
      CALL KERING ('RUN', N)
      IF (N .LE. 0) GOTO 823
      NRUN = NINT (FNUM(N))
      IF (NRUN .NE. IRUN) GOTO 823
      CALL KERING ('CY=', N)
      IF (N .LE. 0) GOTO 823
      NCYT = NINT (FNUM(N))
      IF (NCYT .LT. KEY1) GOTO 823
      IF (NCYT .GT. KEY1) CALL KERROR (' ?? ', 823, 'GETR2X')
      CALL KERING ('R2X=', N)
      IF (N .LE. 0) GOTO 823
      KEND = 1
      BACKSPACE IATOLD
      RETURN
  893 CALL FILCLO (IATOLD, 'KEEP')
      RETURN
      END
      SUBROUTINE KERING (ALI, KEND)
      CHARACTER ALI *(*)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      CHARACTER * 6  ALIT
      ALIT = ALI
      IF (NLIT .LE. 0) GOTO 202
      DO 200 L = 1, NLIT
      IF (LIT(L) .NE. ALIT) GOTO 200
      LCOL = NCOLL(L)
      LCOL2 = 99
      IF (L .LT. NLIT) NCOL2 = NCOLL(L+1)
      IF (LCOL2 .LT. 0) LCOL2 = 99
      GOTO 250
  200 CONTINUE
  202 KEND = -1
      RETURN
  250 IF (NFNUM .LE. 0) GOTO 302
      DO 300 N = 1, NFNUM
      NCOL = NCOLN(N)
      IF (NCOL .LE. 0) GOTO 302
      IF (NCOL .LT. LCOL) GOTO 300
      IF (NCOL .GT. LCOL2) GOTO 302
      KEND = N
      RETURN
  300 CONTINUE
  302 KEND = -2
      RETURN
      END
      SUBROUTINE DICALC
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)),  (LIS2, IFILE(8))
      EQUIVALENCE (IBINFO, IFILE(11)),  (IBINFC, IFILE(12))
      LOGICAL EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      DIMENSION IHKL(3), HKLXX(3,24)
      KEYDX = KEYD
      KEYRET = 0
      IF (KEYD.EQ.1) WRITE (LIS2, FMT =
     *    '('' Prepare input for program PHASEX'')')
      IF (KEYD.EQ.2 .OR. KEYD.EQ.3) WRITE (LIS2, FMT =
     *    '('' Prepare input for program FOUR'')')
  200 IF (KEYD.NE.4) CALL DIDUAL (-1)
      IF (KEYD.EQ.2 .OR. KEYD.EQ.3) CALL DIFFT (-1)
      IF (KEYD.EQ.4) CALL DIPATT (-1)
      ITP = 0
      LOOPFP = 1
      IF (EXPAND) LOOPFP = NSYMM
      NR = 0
      EPSIL2 = 1.
  210 KEYDX = KEYD
      CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IF (KENDFO.LT.0) GOTO 230
      IF (KEYD.EQ.4) GOTO 215
      IF (.NOT. EXPAND) THEN
         CALL BINIFF (0, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      ELSE
         CALL BINIFF (0, IBINFC, 'BINFC2', FITFC2, NITFC, BUFFC,KENDFC)
         ENDIF
      IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'DICALC')
      IF (EXPAND) THEN
         IF (EPSIL2.LT.-990.) GOTO 210
      ELSE
         IF (FP.LT.-990.) GOTO 210
         ENDIF
  215 JCODE = 1
      IF (FOBS .LT. 5.*SIG) JCODE = 2
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL * 400. + 1.5)
      SUMF2R = SUMF2(ISS) - SUMF2P(ISS)
      IF (SUMF2R.LT.0.001) SUMF2R = 0.001
      X = FOBS * SCALE
      XSIG = SIG * SCALE
      IF (KEYD.EQ.4) THEN
         NR = NR + 1
         CALL DIPATT (0)
         GOTO 210
         ENDIF
      IF (EXPAND) CALL HKLEX1 (HKLX, HKLXX)
      DO 229 IFP=1,LOOPFP
      IF (EXPAND) THEN
          KEYDX = KEYD
          FP   = FPEXP(1,IFP)
          IF (FP .LT. 0.0) GOTO 229
          PHIP = FPEXP(2,IFP)
          HKLX(1,1) = HKLXX(1,IFP)
          HKLX(2,1) = HKLXX(2,IFP)
          HKLX(3,1) = HKLXX(3,IFP)
          CALL HKLC1 (HKLX, HCODE)
          ENDIF
      NR = NR + 1
      IF (KEYT.EQ.1) THEN
          Y = FP * EXP((-BP+BPINP)*STL2)
      ELSE
          Y = FP
          ENDIF
      IF (EXPAND) GOTO 221
      ITP = IPHFIX(HKLX) - 1
      IF (ITP .LT. -1) THEN
          CALL KERF2I (HKLX, IHKL, 3)
          WRITE (LIS1, 220) (IHKL(I), I=1,3)
  220     FORMAT (' Reflection ',3I3, ' gives impossible phase restr.')
          CALL KERNER (220, 'DICALC')
          ENDIF
  221 IF (KEYD.EQ.2) CALL DIFFT (0)
      IF (KEYD.EQ.3 .AND. KEYDS.GE.4) GOTO 228
      IF (KEYDX.NE.2) CALL DIDUAL (0)
  228 IF (KEYDX.EQ.3) CALL DIFFT (0)
  229 CONTINUE
      GOTO 210
  230 IF (KEYD .EQ. 2 .OR. KEYD .EQ. 3) CALL FILCLO (IBINFC, 'DELETE')
      IF (KEYD.EQ.2) THEN
         CALL DIFFT (1)
         RETURN
         ENDIF
      IF (KEYD.EQ.4) THEN
         CALL DIPATT (1)
         RETURN
         ENDIF
      IF (KEYD.EQ.3 .AND. KEYDS.GE.4) THEN
         CALL DIFFT (1)
         RETURN
         ENDIF
      CALL DIDUAL (1)
      IF (KEYRET.LT.10) GOTO 200
      IF (KEYD.EQ.3) CALL DIFFT (1)
      RETURN
      END
      SUBROUTINE DIDUAL (KEY)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      LOGICAL      SWPRI, EXPAND
      EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (IDDL, IFILE(1)), (LIS2, IFILE(8))
      EQUIVALENCE (IE100,  IFILE(10))
      EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINFF, IFILE(16))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXAT = 993)
      PARAMETER (MAXBUF = 198)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT,
     *            BUFFO(MAXBUF),  BUFFC(MAXBUF), BUFBUF(MAXBUF)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      EQUIVALENCE (FITDUA(4), ZSCATT), (FITDUA(5), P1), (FITDUA(6), P2),
     *            (FITDUA(7), W1)
      PARAMETER (PSQMIN = 0.15, E1MINP = 0.9)
      DIMENSION  DEG(8), IHKL(3), W1LIM(6), EPLIM(6)
      DIMENSION HKLM(3), HKLMA(3), HKLMI(3)
      CHARACTER * 7 RESTR(9)
      DATA ESUMMI /  .50  /
      DATA W1LIM  /  .001, .050, .200, .800,  .999,  1.000  /
      DATA EPLIM  /  .01,  .20,  .60, 1.00,  1.50,  10.000  /
      DATA DEG    / 0., 30., 45., 60., 90., 120., 135., 150. /
      DATA RESTR  / '   NONE', '  0/180', ' 30/210',
     *              ' 45/225', ' 60/240', ' 90/270',
     *              '120/300', '135/315', '150/330' /
      DATA PSQX, NGN, NSP, NR1, NPP, IEPS  / 0.0 , 0, 0, 0, 0, 0 /
      DATA HKMAX, NGNLE,NSPLE, E2CLE,E2ALE, NE1ALL /0., 0, 0, 0., 0., 0/
      DATA E1MIN / 0./
      IF (KEY) 200, 240, 380
  200 E2SUM = 0.
      E2ALE = 0.
      E2CLE = 0.
      NSP   = 0
      NGN   = 0
      NSPLE = 0
      NGNLE = 0
      SUMX  = 0.
      SUMX2 = 0.
      SUMY2 = 0.
      SUMXY = 0.
      CALL KERNZI (0, NUMW1,  6)
      CALL KERNZI (0, NUMEP,  6)
      CALL KERNZI (0, NUMEP2, 6)
      IF (NREFL .GT. 1000) THEN
         E1MIN = E1MINP
      ELSE
         IF (NREFL .GT. 500) THEN
            E1MIN = 0.7
         ELSE
            E1MIN = 0.5
            ENDIF
         WRITE(LIS2, FMT = '('' E1MIN reset to: '', F6.3)') E1MIN
         ENDIF
      EPSIL = 1.
      IEPS  = 1
      IF (KEYD.EQ.1) THEN
         CALL KERNZA (-9999., HKLM,  3)
         CALL KERNZA (-9999., HKLMA, 3)
         CALL KERNZA ( 9999., HKLMI, 3)
         HKMAX =  0.0
         ENDIF
      IF (SWPRI .AND. KEYD.NE.2) THEN
         NPP = MAX0(1,(NREFL/40))
         IF (KEYD.EQ.1) NPP = MAX0(1,(NREFL/160))
         WRITE (LIS2, FMT='(''0Print every '', I3,
     *                      ''th- reflection'')') NPP
         IF (KEYD .EQ. 1) WRITE (LIS2, FMT='(''+'', 31X,
     *                           ''(accepted for PHASEX)'')')
         IF (KEYD .EQ. 3) WRITE (LIS2, FMT='(''+'', 31X,
     *                           ''(accepted for FOUR)'')')
         WRITE (LIS2, 230)
  230    FORMAT ('   H   K   L  JC  EPS    FO*SC    FP(BP)   ',
     *   'PHASE REST.   PH      P1      P2      W1      E1      E2')
      ENDIF
      NR1 = 0
      NE1ALL = 0
      PSQX = PSQ
      IF (EXPAND) PSQX = P1SQ
      HMUL = 1.0
      IF (NREFL .GT. 5000) HMUL = 0.5
      HKLX(1,1) = HKLMAX(1) * HMUL
      HKLX(2,1) = HKLMAX(2) * HMUL
      HKLX(3,1) = HKLMAX(3) * HMUL
      IF (PSQX.LE.PSQMIN) THEN
         CALL E1WEAK (1, HKLX, ESUM)
         IF (NREFL.LT.4000) ESUMMI = 1.0
         ENDIF
      RETURN
  240 CONTINUE
      IF (EXPAND) GOTO 255
      IF (ITP.EQ.0) GOTO 250
      DIF = ABS(DEG(ITP) - PHIP)
      DIF = MIN1(DIF, 360.-DIF)
      PHIP = DEG(ITP)
      IF (DIF.GT.90.) PHIP = PHIP + 180.
  250 CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
  255 Z = SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2)
      IF (FOBS.LT.0.0001) THEN
         FOBS = 0.0001
         X = 0.0001 * SCALE
         ENDIF
      EOBS = X / Z
      SIGE = SIG*SCALE / Z
      ZSCATT = Z
      E1 = (X-Y) / Z
      SUMX  = SUMX  + X
      SUMX2 = SUMX2 + X*X
      SUMY2 = SUMY2 + Y*Y
      SUMXY = SUMXY + ABS(X-Y)
      E1STAT = ABS(E1)
      IF (E1STAT.GT.4.) E1STAT = 4.
      IF (JCODE.LE.1) GOTO 270
      IF (E1.GT.0.) GOTO 260
      E1 = (1.4*X - Y)/Z
      IF (E1.GT.0.) E1 = 0.0
      GOTO 270
  260 E1 = (0.7*X - Y)/Z
      IF (E1.LT.0.0) E1 = 0.0
  270 P1 = PHIP
      IF (E1.LT.0.0)  P1 = PHIP - 180.
      IF (P1.LT.-0.5) P1 = P1 + 360.
      E2 = (X+Y) / Z
      IF (JCODE.GT.1) E2 = AMAX1(Y/Z, E1)
      P2 = PHIP - 180.
      IF (P2.LT.-0.5) P2 = P2 + 360.
      CALL W1PROB (ITP, E1, E2, P)
      W1 = 4.0 * (P-0.5)**2
      IF (P.LT.0.5) W1 = 0.0
      EEX = E2EXP(ITP, E1STAT, E2)
      E2SUM = E2SUM + EEX
      CALL KERF2I (HKLX, IHKL, 3)
      IF (.NOT. SWPRI .OR.  KEYD.EQ.2) GOTO 300
      IF (KEYD.EQ.1 .AND. E1.LT.E1MIN) GOTO 300
      IF (NR / NPP*NPP .NE. NR ) GOTO 300
      IJ = ITP + 1
      WRITE (LIS2, 290) (IHKL(I),I=1,3), JCODE, IEPS, X, Y, RESTR(IJ),
     *                  PHIP, P1, P2, W1, E1, E2
  290 FORMAT (5I4, 2F10.3, 3X, A7, 2X, 3F8.0, 3F8.3)
  300 IF (ITP.GE.1) NSP = NSP + 1
      IF (ITP.EQ.0) NGN = NGN + 1
      EP = 0.0
      IF (SUMF2P(ISS).GT.0.000001)
     *    EP = Y / SQRT(EPSIL * ALATT * SUMF2P(ISS))
      DO 310 IEP=1,6
      IF (EP.LT.EPLIM(IEP)) GOTO 320
  310 CONTINUE
      IEP = 6
  320 NUMEP(IEP) = NUMEP(IEP) + 1
      IF (ABS(PHIP-P1) .LT. 90.) GOTO 330
      NUMEP2(IEP) = NUMEP2(IEP) + 1
      NUMW1(6) = NUMW1(6) + 1
      GOTO 360
  330 DO 340 I=1,5
      IW1 = I
      IF (W1.LT.W1LIM(I)) GOTO 350
  340 CONTINUE
      IW1 = 5
  350 NUMW1(IW1) = NUMW1(IW1) + 1
  360 CONTINUE
      IF (PSQX.GT.PSQMIN) GOTO 365
      IF (IEPS.NE.1) GOTO 365
      ESUM = E1 + EOBS + SIGE
      IF (ESUM.GT.ESUMMI) GOTO 365
      NE1ALL = NE1ALL + 1
      CALL E1WEAK (0, HKLX, ESUM)
  365 IF (E1.GE.E1MIN .OR. KEYD.NE.1) GOTO 370
      IF (ITP.EQ.0) THEN
          E2ALE = E2ALE + EEX
          NGNLE = NGNLE + 1
          ELSE
          E2CLE = E2CLE + EEX
          NSPLE = NSPLE + 1
          ENDIF
      RETURN
  370 NR1 = NR1 + 1
      IF (KEYD.NE.1) RETURN
      FITDUA(1) = HCODE
      FITDUA(2) = E1
      FITDUA(3) = E2
      CALL BINOFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      DO 375 I=1,3
      HKLMA(I) = AMAX1(HKLMA(I), HKLX(I,1))
  375 HKLMI(I) = AMIN1(HKLMI(I), HKLX(I,1))
      HKMAX   = AMAX1 (HKMAX, ABS(HKLX(1,1)-HKLX(2,1)) )
      RETURN
  380 KEYOLD = KEYRET
      CALL DIRESC (PSQX)
      IF (KEYOLD.EQ.KEYRET .OR. KEYRET.GT.2) GOTO 390
      IF (KEYD.NE.1 .OR. EXPAND) GOTO 390
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      CALL BINIFF (1, IBINDU, 'BINDUA', FITDUA,NITDUA,BUFDUA,KENDUA)
      CALL BINOFF (6, IBINDU, 'BINDUA', FITDUA,NITDUA,BUFDUA,KENDUA)
      RETURN
  390 IF (ICENT.EQ.1 .AND. .NOT.EXPAND) WRITE (LIS2, 400) NSP, NGN
  400 FORMAT ('0Number of special  reflections:', I6 /
     *        ' Number of general  reflections:', I6)
      IF (ICENT.EQ.2 .AND. .NOT. EXPAND ) WRITE (LIS2, 410) NSP
      IF (EXPAND) WRITE (LIS2, 410) NGN
  410 FORMAT (23H Number of reflections:, I6 )
      IF (KEYD.NE.1) GOTO 450
      CALL BINOFF (-1, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      WRITE (LIS2, 420) NR1, E1MIN
  420 FORMAT (' Number of accepted reflections:', I6,
     *        '  (E1 > ', F4.2, ', sent to PHASEX)')
      IF (ICENT.EQ.1 .AND. .NOT.EXPAND)
     *    WRITE (LIS2, 430) NSP-NSPLE, NGN-NGNLE
  430 FORMAT (' Number of accepted special reflections:', I6 /
     *        ' Number of accepted general reflections:', I6)
      DO 435 I=1,3
  435 HKLM(I) = AMAX1 (ABS(HKLMA(I)), ABS(HKLMI(I)) )
      IF (ISYST.LE.3 .OR. EXPAND) GOTO 436
      IF (ISYST.EQ.6 .OR. ISYST.EQ.7)
     *                HKLM(1) = AMAX1 (HKLM(1),HKMAX)
      IF (ISYST.EQ.5 .OR. ISYST.EQ.8)
     *                HKLM(1) = AMAX1 (HKLM(1),HKLM(3))
      HKLM(1) = AMAX1 (HKLM(1),HKLM(2))
      HKLM(2) = HKLM(1)
      IF (ISYST.EQ.5 .OR. ISYST.EQ.8) HKLM(3) = HKLM(1)
  436 CONTINUE
      CALL KERF2I (HKLM, IHKL, 3)
      WRITE (CHOUT, 440) NAT, PSQX, IHKL, NR1
  440 FORMAT ('PHASEX NAT',I4, ' PSQ',F6.3, ' MHKL',3I4, ' NREFL1',I7)
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      CALL FILINQ (IE100, 'E100', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IE100, 442) CCODE, NGN, NSP, E2ALE, E2CLE
  442 FORMAT ('E100   ', A6, 4X, 2I6, 2F7.0)
      IF (PSQX.LE.PSQMIN .AND. KEYD.EQ.1) THEN
          CALL E1WEAK (-1, HKLX, ESUM)
          WRITE (LIS2, 445) NREFL, NE1ALL, ESUMMI
  445     FORMAT (' Number of all reflections     : ', I6, /
     *            ' Number of possible weak refl. : ', I6, /
     *            ' (E1+Eobs+SIG(Eobs) < ', F4.2, ')')
          ELSE
          WRITE (IE100, FMT='(''END'')')
          ENDIF
  450 KEYRET = 10
      RETURN
      END
      SUBROUTINE E1WEAK (KEYE1, HKL, ESUM)
      DIMENSION HKL(3)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (IE100, IFILE(10))
      PARAMETER (MAXDAT = 100)
      DIMENSION DATE1(4, MAXDAT), HKLME1(3)
      DATA IE1 / 0 /
      IF (KEYE1.LE.0) GOTO 200
      IE1 = MAXDAT + 1
      CALL KERNZA (-1.,  DATE1, 4*MAXDAT)
      CALL KERNAB (HKL, HKLME1, 3)
      RETURN
  200 IF (KEYE1.LT.0) GOTO 300
      IF (ABS(HKL(1)).GT.HKLME1(1) .OR. ABS(HKL(2)).GT.HKLME1(2) .OR.
     *    ABS(HKL(3)).GT.HKLME1(3)) RETURN
      IE1 = IE1 - 1
      DO 210 J=MAXDAT,IE1+1,-1
      IF (ESUM.GE.DATE1(4,J)) GOTO 210
      JJ = J
      GOTO 220
  210 CONTINUE
      JJ = IE1
      IF (IE1.EQ.0) THEN
         IE1 = 1
         RETURN
         ENDIF
      GOTO 240
  220 IF (IE1.EQ.0) IE1 = 1
      DO 230 J=IE1+1,JJ
      DO 230 L=1,4
  230 DATE1(L,J-1) = DATE1(L,J)
  240 DO 250 L=1,3
  250 DATE1(L,JJ) = HKL(L)
      DATE1(4,JJ) = ESUM
      RETURN
  300 IE1 = MAXDAT + 1 - IE1
      I = MAXDAT - IE1 + 1
      ESUMMA = DATE1(4,I)
      ESUMMI = DATE1(4,MAXDAT)
      WRITE (IE100, 410) IE1, ESUMMI, ESUMMA
      WRITE (LIS2, 410) IE1, ESUMMI, ESUMMA
  410 FORMAT (' For ', I3, ' weakest reflections: E1+Eobs+SIG(Eobs) = ',
     *         F4.2, ' upto ', F4.2)
      DO 430 I=MAXDAT,MAXDAT-IE1+1,-1
      WRITE (IE100, 420) (NINT(DATE1(I1,I)), I1=1,3)
  420 FORMAT (3I4)
  430 CONTINUE
      WRITE (IE100, FMT='(''END'')')
      RETURN
      END
      SUBROUTINE DIFFT (KEY)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      LOGICAL      SWPRI, EXPAND
      EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (NRECYR, KEYS(11)), (NAT, KEYS(17)), (NATL, KEYS(18))
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXBUF = 198)
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      EQUIVALENCE (FITDUA(4), ZSCATT), (FITDUA(5), P1), (FITDUA(6), P2),
     *            (FITDUA(7), W1)
      EQUIVALENCE (FITDIF(1), HCODI), (FITDIF(2), EL), (FITDIF(3), PL),
     *            (FITDIF(4), WL)
      DIMENSION NNNN(3)
      PARAMETER (WMIN = 0.9, EFMIN = 0.5, RAD = 57.29578)
      LOGICAL LOGDUA, LOGDIF
      DATA LOGDUA, LOGDIF / .FALSE., .FALSE. /
      DATA WFIND, WF2, WF3, NPP, SHARP / 1.0, 0.0, 0.0, 0, 0.0 /
      IF (KEY) 200, 230, 420
  200 CALL KERNZI (0, NNNN,   3)
      SHARP = 0.0
      IF (STLMAX .LT. 0.5) THEN
         SHARP = BR * (0.55 - STLMAX) * 10.
         IF (SHARP .GT. 20.) SHARP = 20.
         WRITE (LIS1, 211) STLMAX, BR, SHARP
  211    FORMAT(' STLMAX=',F6.4,' BR=',F6.3,' Sharpening: SHARP =',F6.3)
         ENDIF
      WFIND = 1.0
      IF ((KEYD .EQ. 3 .AND. KEYDS .EQ. 0) .OR. KEYD .EQ. 2) THEN
         IF (PSQ .GT. .60) WFIND = AMAX1 ((0.90 - PSQ) / 0.30 , 0.)
         IF (WFIND .LT. .30) WFIND = 0.0
         WF3 = (1. - WFIND) * AMAX1 ((PSQ - 0.70) / 0.30, 0.0)
         WF2 = 1. - WFIND - WF3
         ENDIF
      IF (.NOT. SWPRI .OR. KEYD.EQ.3) RETURN
      CHOUT = '(5(F6.0, 2F4.0, F6.0, F5.0))'
      CALL LINPRI (LIS2, FITFFT, 25)
      NPP = MAX0 (1, (NREFL/200))
      WRITE (LIS2, FMT='(/'' DDMAIN listing for '', A6,
     *      '', OPTION: Prepare input for PROGRAM FOUR'')') CCODE
      WRITE (LIS2, FMT='(''0Print every '',I3,''th- reflection'',
     *       '' (accepted for FOUR)'', /,
     *       ''     H   K   L  AMPL PHASE'', /)') NPP
      RETURN
  230 CONTINUE
      D123 = AMIN1 (0.1 + (1.-PSQ)/4.,  0.2)
      X123 = AMIN1 (0.1 + (1.-PSQ)/0.8, 0.4)
      WXY= AMAX1 (AMIN1 ((Y /  AMAX1(X, 0.01) - D123) / X123, 1.0), 0.0)
      WX = AMAX1 (AMIN1 ((XSIG/AMAX1(X, 0.01) - 0.2) / 0.15 , 2.0), 0.0)
      WX = WX * AMIN1 (1.5 - PSQ, 1.0)
      WXDX = AMIN1 (WX * XSIG, X)
      WXDY = AMIN1 (WX * XSIG, ABS(X-Y))
      IF (X -Y .LT. 0.0) WXDY = - WXDY
      IF (KEYD.EQ.3 .AND. KEYDS.GE.4) GOTO 321
      IF (KEYDX.EQ.3 .OR. LOGDUA) GOTO 270
      CALL BINIFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      IF (KENDUA.LT.0) THEN
         LOGDUA = .TRUE.
         KEYDX = 3
         RETURN
         ENDIF
      HCODU = FITDUA(1)
      IF (HCODU-HCODE .GE. 0.99) THEN
         KEYDX = 3
         KENDUA = KENDUA - NITDUA
         RETURN
         ENDIF
      E1 = FITDUA(2)
      E2 = FITDUA(3)
      IF (LOGDIF) GOTO 270
      CALL BINIFF (0, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      IF (KENDIF.LT.0) THEN
         LOGDIF = .TRUE.
         GOTO 270
         ENDIF
      IF (HCODI-HCODE .GE. 0.99) THEN
         KENDIF = KENDIF - NITDIF
      NNNN(2) = NNNN(2) + 1
         GOTO 270
         ENDIF
      IF (WL.GE.WMIN .OR. WL.GT.5*W1) GOTO 260
      NNNN(1) = NNNN(1) + 1
      GOTO 270
  260 FL = EL * ZSCATT
      EF = FL * WL
      PLRAD = PL / RAD
      PHIRAD = PHIP / RAD
      FA = EF * COS(PLRAD) + Y * COS(PHIRAD)
      FB = EF * SIN(PLRAD) + Y * SIN(PHIRAD)
      EF = SQRT(FA*FA + FB*FB)
      PHAMP = ATAN2(FB,FA) * RAD
      IF (PHAMP.LT.-0.5) PHAMP = PHAMP + 360.
      GOTO 300
  270 EX1 = -0.5 * E1**2
      EX2 = -0.5 * E2**2
      IF (ITP .NE. 0) GOTO 280
      Q = EX1 - EX2
      EF = X * SIMW(Q)
      GOTO 290
  280 EX1 = EXP(EX1)
      EF = X * (2. * EX1 / (EX1+EXP(EX2)) -1.0)
  290 EF = WFIND * EF + WF2 * WXY * (X - WXDX + X - Y - WXDY)
     *                + WF3 * WXY * (X - WXDX)
      IF (PSQ .LE. .95) GOTO 296
      IF (KEYS(19) .NE. 4) GOTO 296
      IF ( (NAT .EQ. NATL .AND. NRECYR .GE. 4) .OR.
     *  ( NAT .LE. NATL+1 .AND. NRECYR .GE. 5) .OR. NRECYR .GE. 6) THEN
         XX4 = AMIN1 (X, 4.* Y)
         YY4 = AMIN1 (Y, 4.* X)
         EF = 2. * XX4 - YY4
         IF (2. * X .LT. XSIG) EF = 0.
         ENDIF
  296 PHAMP = PHIP
      IF (EF.GT.0.) GOTO 300
      EF = -EF
      PHAMP = PHAMP - 180.
      IF (PHAMP.LT.-0.5) PHAMP = PHAMP + 360.
  300 IF (EF.LT.EFMIN) RETURN
      NNNN(3) = NNNN(3) + 1
      CALL KERNAB (HKLX, FITFFT, 3)
      FITFFT(4) = EF * EXP (SHARP * STL2)
      FITFFT(5) = PHAMP
      IF (.NOT. SWPRI .OR. KEYD.NE.2) GOTO 310
      IF (NNNN(3) / NPP*NPP .NE. NNNN(3)) GOTO 310
      CALL LINPRI (0, FITFFT, 5)
  310 CALL BINOFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      RETURN
  321 EF = WXY * (X - WXDX)
      IF (KEYDS .EQ. 6) EF = EF + WXY * (X - Y - WXDY)
      IF (KEYDS .EQ. 5) EF = WXY * (X - Y - WXDY)
      IF (KEYDS .EQ. 9) EF = Y
      GOTO 296
  420 IF (KEYD.EQ.2) THEN
          IF (SWPRI) CALL LINPRI (-1, FITFFT, 5)
          WRITE (LIS2, 430) NNNN(2)
  430     FORMAT (/ I6, ' reflections skipped by PHASEX')
          WRITE (LIS2, 440) NNNN(1), WMIN
  440     FORMAT (I6, ' refined reflections with weight < ', F6.4,
     *            ' considered unrefined')
          ENDIF
      CALL BINOFF (-1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      NNNN(2) = NR - NNNN(3)
      WRITE (LIS2, 445) NNNN(2), EFMIN, NNNN(3)
  445 FORMAT (     I6, ' reflections with ampl. < ', F4.2, ', skipped',
     *         / , I6, ' reflections accepted (written to BINFFT file)')
      RETURN
      END
      SUBROUTINE W1PROB (ITYP, A, B, PROB)
      IF (B.GT.6.0) B = 6.0
      IF (A.GE.0.0) GOTO 100
      PROB = 1.0
      A = -A
      IF (A.GT.4.0) A = 4.0
      RETURN
  100 IF (A.LE.4.0) GOTO 110
      A = 4.0
      B = 4.0
      PROB = 0.5
      RETURN
  110 IF (ITYP.GE.1) GOTO 120
      R1 = A*EXP(-A*A)
      R2 = B*EXP(-B*B) +  R1
      GOTO 130
  120 R1 = EXP(-0.5*A*A)
      R2 = EXP(-0.5*B*B) + R1
  130 PROB = R1 / R2
      RETURN
      END
      SUBROUTINE DIRESC (PSQ)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      PARAMETER (MAXBUF = 198)
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      DIMENSION  W1LIM(6), EPLIM(6)
      DATA W1LIM /  .001, .050, .200, .800,  .999,  1.000  /
      DATA EPLIM /  .01,  .20,  .60, 1.00,  1.50,  10.000  /
      IF (SUMX2 .LT. 0.000001 .OR. SUMX .LT. 0.0001) THEN
         WRITE (LIS1, FMT='(/'' Emergency wayout: RESCALE bypassed'')')
         RETURN
         ENDIF
      PSQX  = SUMY2/SUMX2
      SUMXY = SUMXY/SUMX
      WRITE (LIS1, 200) NR, SUMXY
      WRITE (LIS2, 200) NR, SUMXY
  200 FORMAT (/' R-value on ', I6, ' reflections is  R =  ', F6.3 )
      DO 210 I=1,6
      IF (NUMEP(I).LE.0) EPPROC(I) = 0.
      IF (NUMEP(I).GT.0) EPPROC(I) =
     *                   100. * FLOAT(NUMEP2(I)) / FLOAT(NUMEP(I))
  210 CONTINUE
      W1PROC = 100. * FLOAT(NUMW1(6)) / NR
      IF (KEYD .EQ. 1) WRITE (LIS2, 220) (W1LIM(I), NUMW1(I),
     *   EPLIM(I), NUMEP(I), NUMEP2(I), EPPROC(I), I=1,6), W1PROC
  220 FORMAT (/' Distribution of reflections in ranges of weight W1',
     * ' and EP:' / '      W1-interval       EP-interval' /
     * '      W1-lim.  No       EP-lim.  No   No(*)  Perc(*)' /
     *        ' 0.000-',F5.3, I5, '   0.00-', F5.2, 2I5, F9.2,
     *   5 (/ 7X,F5.3, I5, F13.2, 2I5, F9.2) /9X,'  *    *'/
     *        9X, '  *=FP.gt.FO : percentage', F6.2 )
      WRITE (LIS2, 230) PSQX
  230 FORMAT (' Recalculated scattering power of the known part is',
     *        '  P(av)**2 = ', F6.3, ' (not used)')
      E2AV = E2SUM / NR
      RESC = SQRT(E2AV)
      IF (PSQ .GT. 0.98) RETURN
      IF (KEYD .NE. 1 ) GOTO 277
      IF (RESC.LT..88 .OR. RESC.GT.1.12 .OR. SWITCH(1))
     *   WRITE (LIS2, 246) E2AV
  246    FORMAT (' TEMP ... The average value of Er**2 is', F5.2 )
      IF (PSQ .GT. 0.95) GOTO 277
      IF (RESC.LT..80 .OR. RESC.GT.1.22) THEN
         WRITE (LIS1, 247) E2AV
  247    FORMAT (' The average value of Er**2 is', F5.2, ' (not used)')
         WRITE (LIS1, 270)
  270    FORMAT (20X, 'This is a rather large deviation'
     *            / 20X, 'Check your input data ...' //)
         ENDIF
  277 IF (RESC.LT..95 .OR. RESC.GT.1.10) GOTO 280
      RETURN
  280 CONTINUE
      RESCAL = SQRT (RESC**2  * (1. - PSQ) + PSQ )
      WRITE (LIS1, 291) RESCAL
      WRITE (LIS2, 291) RESCAL
  291 FORMAT (' The RESCALE factor to make avg. Er**2 = 1.0 is', F6.3,
     * ' (not used)' )
      RETURN
      END
      SUBROUTINE DIPATT (KEY)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      LOGICAL      SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE( 8))
      EQUIVALENCE (IBINFF, IFILE(16))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3), FITFC(2), FITFC2(51)
      EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1))
      PARAMETER (MAXBUF = 198)
      COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV,
     *                SUMX, SUMY,  SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2,
     *        NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF,
     *        KEYT,     KEYRET,   JCODE,     SUMF2R,    Y,     X, XSIG,
     *        ITP,      E1,       E2,        KEYDX,     KEYDS,
     *        NITFO,    NITFC,    NITDUA,    NITDIF,    NITFFT,
     *        KENDFO,   KENDFC,   KENDUA,    KENDIF,    KENDFF,
     *                            FITDUA(7), FITDIF(4), FITFFT(5),
     *                  BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF)
      DIMENSION NNNN(2), PATX(11)
      PARAMETER (EFMIN = 0.1, PI02 = 0.6283185)
      DATA SINGPK, NPP, DEL10  / 0.0, 0, 0.0/
      IF (KEY) 200, 230, 260
  200 CALL KERNZA (0.0, PATX, 11)
      CALL KERNZI (0,   NNNN,  2)
      SINGPK = 0.0
      WRITE (LIS1, FMT='('' Prepare input for sharpened Patterson'')')
      WRITE (LIS2, FMT='('' Prepare input for sharpened Patterson'')')
      IF (KEYDS .NE. 0 . AND. SWITCH(1))
     *  WRITE (LIS2, FMT='('' TEMP: PATTY without origin removal !'')')
      IF (.NOT. SWPRI) RETURN
      DEL10 = 10.0
      WRITE (LIS2, FMT='('' DDMAIN listing for '', A6,
     *      '', OPTION: Prepare input for PROGRAM ORIENT'')') CCODE
      NPP = MAX0 (1, (NREFL/200))
      WRITE (LIS2, FMT='('' Print every '',I3,''th- reflection'',
     *       '' (accepted for sharpened Patterson)'', /,
     *       ''     H   K   L  AMPL PHASE'')') NPP
      CHOUT = '(5(F6.0, 2F4.0, F6.0, F5.0))'
      CALL LINPRI (LIS2, FITFFT, 25)
      RETURN
  230 DDD = (0.2 + STL)**2 * EXP(BP * STL2)
      EFP = X**2 * DDD
      IF (KEYDS .EQ. 0) THEN
         EF  = EFP - EXP(-2. * BP * STL2) * SUMF2R * ALATT * DDD
      ELSE
         EF = EFP
         ENDIF
      SINGPK = SINGPK + EFP
      XH = 0.0
      DELXH = HKLX(1,1) * PI02 / CELL(1)
      DO 240 I=1,11
      PATX(I) = PATX(I) + EFP*COS(XH)
  240 XH = XH + DELXH
      IF (EF.GE.0.0) THEN
          PHAMP = 0.
          ELSE
          PHAMP = 180.
          EF = -EF
        ENDIF
      NNNN(2) = NNNN(2) + 1
      IF (EF.LT.EFMIN) RETURN
      IF (SWPRI .AND. NNNN(2).EQ.1) THEN
         IF (EF.GT.1000.) DEL10 = 100.
         WRITE (LIS2, FMT='(''+'',27X,''(AMPL/'',F4.0,'')'',/)') DEL10
         ENDIF
      CALL KERNAB (HKLX, FITFFT, 3)
      FITFFT(4) = EF
      FITFFT(5) = PHAMP
      CALL BINOFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      IF (.NOT. SWPRI) RETURN
      IF (NNNN(2)/NPP*NPP .NE. NNNN(2)) RETURN
      EF = EF / DEL10
      CALL LINPRI (0, FITFFT, 5)
      RETURN
  260 IF (SWPRI) CALL LINPRI (-1, FITFFT, 5)
      CALL BINOFF (-1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      SINGPK = SINGPK * 2. * ASYMM / VOLUM
      SUMAL = 0
      DO 265 I=1,NTYPE
      IF (CELATY(I) .NE. 'H ') SUMAL = SUMAL + CELALL(I)
  265 CONTINUE
      SINGPK = SINGPK / SUMAL
      PATX1 = PATX(1) * 2. * ASYMM / VOLUM
      WRITE (LIS1, 270) SCALE, BP
  270 FORMAT (' Origin removed sharpened PATTERSON function', /
     *        ' ((', F7.4, '*Fobs)**2 - ORIGIN) * (0.2+STL)**2 * exp(',
     *        F6.3, '*STL2)')
      WRITE (LIS2, 280)  PATX1, SINGPK
  280 FORMAT (' Output ORIENT parameters:'/
     *        ' Patterson origin peak height =', F9.2 /
     *        ' Averaged single peak maximum =', F9.2 )
      DO 290 I=2,11
      IF (PATX(I) .LT. 0.) PATX(I) = 0.
  290 PATX(I) = PATX(I) / PATX(1)
      PATX(1) = 1.0
      WRITE (LIS2, 300) PATX
  300 FORMAT (' Patterson peak shape' /
     *        '   xa = 0.0  0.1   0.2   0.3   0.4   0.5 ',
     *                 '  0.6   0.7   0.8   0.9   1.0 A' /
     *        ' P(xa)=', F5.2, 10F6.3 )
      NNNN(1) = NNNN(2) - NR
      NNNN(2) = NR
      WRITE (LIS2, 310) NNNN(1), EFMIN, NNNN(2)
  310 FORMAT (I8, ' Reflections with amplitude <', F5.2, ' skipped',
     *    /   I8, ' Reflections accepted (written to BINFFT file)')
      DO 320 I=2,7
  320 IF (PATX(I).LT.0.0) PATX(I) = 0.0
      CALL LOGPAT (SINGPK, PATX1, PATX)
      RETURN
      END
      SUBROUTINE LOGPAT (SINGPK, PATX1, PATX)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1))
      DIMENSION PATX(11)
      WRITE (CHOUT, 200) SINGPK, PATX1
  200 FORMAT ('SINGPK', F9.3, ' ORIGIN', F10.2)
      CALL LOGWR (IDDL)
      WRITE (CHOUT, 220) (PATX(I), I=2,9)
  220 FORMAT ('PK SHAPE', 8F6.3)
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      RETURN
      END
      SUBROUTINE WISSEN
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (IE100,  IFILE(10)), (IBINFC, IFILE(12))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15))
      CALL FILINQ (IBINDU, 'BINDUA', 'UNFORMATTED', 'INPUT', KINQU)
      IF (KINQU .NE. -1) THEN
         CALL FILCLO (IBINDU, 'DELETE')
         ENDIF
      CALL FILINQ (IBINDI, 'BINDIF', 'UNFORMATTED', 'INPUT', KINQI)
      IF (KINQI .NE. -1) THEN
         CALL FILCLO (IBINDI, 'DELETE')
         ENDIF
      CALL FILINQ (IE100,  'E100',   'FORMATTED',   'INPUT', KINIE)
      IF (KINIE .NE. -1) THEN
         CALL FILCLO (IE100,  'DELETE')
         ENDIF
      RETURN
      END
      SUBROUTINE WILSIN (KEY)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      PARAMETER (MAXAT = 993)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),  EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON / WILS / NOW(9),   NUW(9),   AW(9),   AAW(9),  BW(9),
     *                NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7),
     *                VS(7,7) , FHMN,     BPMAX,   BPMIN,   BRMAX,
     *                BRMIN,    BPINP,    BRINP,   KEYWIL,  PSQM,
     *                EPMAX,    EPMIN
      PARAMETER  (NRS = 9, NRF = 7)
      LOGICAL     SWIL
      DATA SWIL / .FALSE. /
      DATA FNRF1, STLM2, FNRS3 / 0.0, 0.0, 0.0/
      IF (SWIL) GOTO 180
      SWIL = .TRUE.
      KEYWIL = KEY
      EPMIN = 9999.
      EPMAX =-9999.
      CALL KERNZI (0 , NOW, NRS)
      CALL KERNZI (0 , NUW, NRS)
      CALL KERNZA (0.,  AW, NRS)
      CALL KERNZA (0., AAW, NRS)
      CALL KERNZA (0.,  BW, NRS)
      CALL KERNZI (0 , NOV, NRF * NRF)
      CALL KERNZI (0 , NUV, NRF * NRF)
      CALL KERNZA (0.,  VA, NRF * NRF)
      CALL KERNZA (0.,  VB, NRF * NRF)
      CALL KERNZA (0.,  VC, NRF * NRF)
      CALL KERNZA (0.,  VS, NRF * NRF)
      FHMN = 0.
      BPINP = BP
      BRINP = BR
      FNRF1  = FLOAT(NRF+1)
      FNRS3  = FLOAT(NRS+1)
      STLM2  = STLMAX**2
  180 CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      TUMF2 = SUMF2(ISS) * EPSIL * ALATT
      TUMF2P = SUMF2P(ISS) * EPSIL * ALATT
      TUMF2R = (TUMF2 - TUMF2P) * EXPBR(ISS)**2
      K = (STL2/STLM2) * (FNRS3) + 1.
      IF (K.GT.NRS) K = NRS
      IF (K.LT.1 .OR. K.GT.NRS)   GOTO 190
      NOW(K) = NOW(K) + 1
      IF (FOBS .LT. 5.*SIG)  NUW(K) = NUW(K) + 1
      AW(K)  = AW(K)  + FOBS**2 / TUMF2
      AAW(K) = AAW(K) + (FP**2 + TUMF2R) / TUMF2
      BW(K) = BW(K) + STL2
  190 IF (KEYWIL .EQ. -2) RETURN
      FPW = FP /  EXPBP(ISS)
      FHMN = FHMN + FPW**2 / TUMF2
      EP = FPW / SQRT(TUMF2P)
      EPMIN = AMIN1 (EPMIN, EP)
      EPMAX = AMAX1 (EPMAX, EP)
      IF (ABS(EP).GT.6.)  EP = 6.0
      K =  (STL2/STLM2)**1.5  * FNRF1
      L = (1.0 - EXP(-EP*EP)) * FNRF1
      IF (ICENT.EQ.2)  L = ERFU(EP/1.414) * FNRF1
      DO 220 IK=0,1
      I = K + IK
      IF (I.GT.NRF .OR. I.LT.1)  GOTO 220
      DO 210 IL=0,1
      J = L + IL
      IF (J.GT.NRF .OR. J.LT.1)  GOTO 210
      VA(I,J) = VA(I,J) + FOBS**2 / TUMF2
      VB(I,J) = VB(I,J) + FP**2 / TUMF2
      VC(I,J) = VC(I,J) + TUMF2R / TUMF2
      VS(I,J) = VS(I,J) + STL2
      NOV(I,J) = NOV(I,J) + 1
      IF (FOBS .LT. 5.*SIG)  NUV(I,J) = NUV(I,J) + 1
  210 CONTINUE
  220 CONTINUE
      RETURN
      END
      SUBROUTINE WIL2DI (NREFL, IWILP)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS2, IFILE(8))
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON / WILS / NOW(9),   NUW(9),   AW(9),   AAW(9),  BW(9),
     *                NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7),
     *                VS(7,7) , FHMN,     BPMAX,   BPMIN,   BRMAX,
     *                BRMIN,    BPINP,    BRINP,   KEYWIL,  PSQM,
     *                EPMAX,    EPMIN
      BMAXD = 1.0 - AMIN1 (1.0, PSQ)
      BDMAX = AMIN1 (1.00, 1.5 * BMAXD)
      CALL WIL2DC (NREFL, NRF, IWILP)
      WRITE (CHOUT, 200)
  200 FORMAT (' Parameters after two-dimensional refinement:')
      CALL SHOUT2
      IF (IWILP.EQ.1) WRITE (CHOUT, 210)
  210 FORMAT (' .... not acceptable (see LIS2). Use old parameters:')
      IF (IWILP.EQ.1) CALL SHOUT2
      WRITE (CHOUT, 220) BP, BR, SCALE
  220 FORMAT (' Bp = ', F6.3, '  Br = ', F6.3, '  Scale = ', F9.5)
      CALL SHOUT2
      IF (IWILP.EQ.1) RETURN
      BPMAX = BPINP + BMAXD
      BPMIN = AMAX1 (BPINP - BMAXD, 0.0)
      BRMAX = BRINP + BMAXD
      BRMIN = AMAX1 (BRINP - BMAXD, 0.0)
      IF (KEYWIL.NE.2 .AND. KEYWIL.NE.0) THEN
         BP = BPINP
         BPMAX = BP
         BPMIN = BP
         ENDIF
      IF (KEYWIL.NE.1 .AND. KEYWIL.NE.0) THEN
         BR = BRINP
         BRMAX = BR
         BRMIN = BR
         ENDIF
      IF (KEYWIL.EQ.0 .OR. KEYWIL.EQ.1) THEN
         BRMAX = AMIN1(BRMAX, BRINP+BDMAX)
         BRMIN = AMAX1(BRMIN, BRINP-BDMAX)
         ENDIF
      IF (KEYWIL.EQ.0 .OR. KEYWIL.EQ.2) THEN
         BPMAX = AMIN1(BPMAX, BPINP+BDMAX)
         BPMIN = AMAX1(BPMIN, BPINP-BDMAX)
         ENDIF
      BD = BP - BR
      SD = SIGN(1.0,BD)
      BD = ABS (BD)
      IF (BP.LE.BPMAX .AND. BP.GE.BPMIN .AND. BD.LE.BDMAX .AND.
     *    BR.LE.BRMAX .AND. BR.GE.BRMIN) RETURN
      BP = AMIN1(BP,BPMAX)
      BP = AMAX1(BP,BPMIN)
      BR = AMIN1(BR,BRMAX)
      BR = AMAX1(BR,BRMIN)
      IF (KEYWIL.GE.3) GOTO 230
      BD = BP - BR
      SD = SIGN(1.0,BD)
      BD = ABS (BD)
      IF (BD.LT.BDMAX) GOTO 230
      FHMN = FHMN / FLOAT(NREFL)
      IF (KEYWIL.EQ.1) FHMN = 1.
      IF (KEYWIL.EQ.2) FHMN = 0.
      BM = BP*FHMN + BR*(1.0-FHMN)
      BP = BM + SD*(1.0-FHMN)*BDMAX
      BR = BM - SD*FHMN*BDMAX
  230 SCNUM = 0.0
      SCDEN = 0.0
      DO 240 I=1,NRF
      DO 240 J=1,NRF
      IF (NOV(I,J).LT.10) GOTO 240
      SCDEN = SCDEN + VA(I,J)
      X = (BP-BPINP) * VS(I,J)
      Y = (BR-BRINP) * VS(I,J)
      IF (X.GT.50.) X = 50.
      IF (Y.GT.50.) Y = 50.
      SCNUM = SCNUM + VB(I,J)*EXP(-X) + VC(I,J)*EXP(-Y)
  240 CONTINUE
      SCALE = SQRT (SCNUM/SCDEN)
      WRITE (CHOUT, 250)
  250 FORMAT (' Resetting of scale and temperature factors required,',
     *        ' new values are:')
      CALL SHOUT2
      WRITE (CHOUT, 220) BP, BR, SCALE
      CALL SHOUT2
      RETURN
      END
      SUBROUTINE WIL2DC (NREFL, NRF, IWILP)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH, SWIPRI
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (SWIPRI, SWITCH(10))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON / WILS / NOW(9),   NUW(9),   AW(9),   AAW(9),  BW(9),
     *                NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7),
     *                VS(7,7) , FHMN,     BPMAX,   BPMIN,   BRMAX,
     *                BRMIN,    BPINP,    BRINP,   KEYWIL,  PSQM,
     *                EPMAX,    EPMIN
      DIMENSION IY(9), STLRAN(8), EPRAN1(2,7), EPRAN2(2,7), EPRANG(2,7)
      DIMENSION D(3,7,7), AMAT(3,3), AMATIN(3,3), V(3), SH(3),
     *         ERR(3), PA(3), AC(7,7)
      EQUIVALENCE (SC, PA(1))
      DIMENSION NPERCA(7), NPERCU(7), PERCU(7)
      CHARACTER *8  VARI(3)
      DATA VARI / '      K', 'delta BP', 'delta BR' /
      DATA EPRAN1 / 0.00, 0.53,  0.36, 0.68,  0.54, 0.83,  0.69, 0.99,
     *              0.84, 1.17,  1.00, 1.44,  1.18, 4.26 /
      DATA EPRAN2 / 0.00, 0.31,  0.15, 0.48,  0.32, 0.67,  0.49, 0.88,
     *              0.68, 1.15,  0.89, 1.53,  1.16, 3.50 /
      DATA PSC /0.0/
      NRF = 7
      IF (NREFL.GT.400) GOTO 190
      K = 0
      DO 170 I=1, (NRF-1), 2
      K = K + 1
      IJ = 0
      DO 170 J=1, (NRF-1), 2
      IJ = IJ + 1
      NOV(IJ,K) = NOV(J,I) + NOV(J+1,I) + NOV(J,I+1) + NOV(J+1,I+1)
      NUV(IJ,K) = NUV(J,I) + NUV(J+1,I) + NUV(J,I+1) + NUV(J+1,I+1)
      VA(IJ,K)  = VA(J,I)  + VA(J+1,I)  + VA(J,I+1)  + VA(J+1,I+1)
      VB(IJ,K)  = VB(J,I)  + VB(J+1,I)  + VB(J,I+1)  + VB(J+1,I+1)
      VC(IJ,K)  = VC(J,I)  + VC(J+1,I)  + VC(J,I+1)  + VC(J+1,I+1)
  170 VS(IJ,K)  = VS(J,I)  + VS(J+1,I)  + VS(J,I+1)  + VS(J+1,I+1)
      IJ = 0
      DO 180 I=1, (NRF-1), 2
      IJ = IJ + 1
      NOV(IJ,K) = NOV(IJ,K) + NOV(I,NRF) + NOV(I+1,NRF)
      NOV(K,IJ) = NOV(K,IJ) + NOV(NRF,I) + NOV(NRF,I+1)
      NUV(IJ,K) = NUV(IJ,K) + NUV(I,NRF) + NUV(I+1,NRF)
      NUV(K,IJ) = NUV(K,IJ) + NUV(NRF,I) + NUV(NRF,I+1)
      VA(IJ,K)  = VA(IJ,K)  + VA(I,NRF)  + VA(I+1,NRF)
      VA(K,IJ)  = VA(K,IJ)  + VA(NRF,I)  + VA(NRF,I+1)
      VB(IJ,K)  = VB(IJ,K)  + VB(I,NRF)  + VB(I+1,NRF)
      VB(K,IJ)  = VB(K,IJ)  + VB(NRF,I)  + VB(NRF,I+1)
      VC(IJ,K)  = VC(IJ,K)  + VC(I,NRF)  + VC(I+1,NRF)
      VC(K,IJ)  = VC(K,IJ)  + VC(NRF,I)  + VC(NRF,I+1)
      VS(IJ,K)  = VS(IJ,K)  + VS(I,NRF)  + VS(I+1,NRF)
  180 VS(K,IJ)  = VS(K,IJ)  + VS(NRF,I)  + VS(NRF,I+1)
      NOV(K,K)  = NOV(K,K)  + NOV(NRF,NRF)
      NUV(K,K)  = NUV(K,K)  + NUV(NRF,NRF)
      VA(K,K)   = VA(K,K)   + VA(NRF,NRF)
      VB(K,K)   = VB(K,K)   + VB(NRF,NRF)
      VC(K,K)   = VC(K,K)   + VC(NRF,NRF)
      VS(K,K)   = VS(K,K)   + VS(NRF,NRF)
      NRF = K
  190 WRITE (LIS2, 200)
  200 FORMAT ('0Two-dimensional refinement of BP and BR', /,
     *        ' Distribution of reflections (and unobs.) in array')
      FNRF1  = FLOAT(NRF+1)
      F13 = 1. / 3.
      DO 205 I=1,NRF
  205 STLRAN(I) = STLMAX * (FLOAT(I)/FNRF1)**F13
      STLRAN(NRF+1) = STLMAX
      CALL KERNZI (0, NPERCU, NRF)
      CALL KERNZI (1, NPERCA, NRF)
      DO 207 I = 1, NRF
      DO 207 J = 1, NRF
      NPERCA(I) = NPERCA(I) + NOV(I,J)
  207 NPERCU(I) = NPERCU(I) + NUV(I,J)
      PERCUM = 0.0
      DO 208 I = 1, NRF
      PERCU(I) = 100. * FLOAT(NPERCU(I)) / FLOAT(NPERCA(I))
      IF (PERCU(I) .GT. PERCUM) PERCUM = PERCU(I)
  208 CONTINUE
      IF (PERCUM .LE. 30.) GOTO 214
      WRITE (LIS1, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1)
      WRITE (LIS2, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1)
  210 FORMAT (/' sinTH/L range:  0.0-', F3.2, 6(1X, F3.2,'-', F3.2),
     *                                         1X, F3.2,'-', F4.2 )
      WRITE (LIS1, 212) (PERCU(I), I = 1, NRF)
      WRITE (LIS2, 212) (PERCU(I), I = 1, NRF)
  212 FORMAT (' Percentage unobs:', 7(F6.0,2X))
  214 WRITE (LIS2, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1)
      CALL KERNAB (EPRAN1, EPRANG, 14)
      IF (ICENT .EQ. 2) CALL KERNAB (EPRAN2, EPRANG, 14)
      EPRANG(1,1) = AMAX1 (EPRANG(1,1), EPMIN)
      EPRANG(2,NRF) = AMIN1 (EPRANG(2,NRF), EPMAX)
      WRITE (LIS2, 220)
  220 FORMAT (' Ep range=')
      DO 260 J=1,NRF
      WRITE (LIS2, 230) (EPRANG(I2,J),I2=1,2), (NOV(I,J), I=1,NRF)
  230 FORMAT ('0', F4.2, '-', F4.2, '  All ', 7I8)
      WRITE (LIS2, 240) (NUV(I,J), I=1,NRF)
  240 FORMAT (10X, 'Unobs ', 7I8)
      DO 260 I=1,NRF
      XN = NOV(I,J)
      IF (XN.LT.1.0) XN = 1.0
      IF (NOV(I,J).GT.10) GOTO 250
      NOV(I,J) = 0
      NUV(I,J) = 0
      VA(I,J) = 0.0
      AC(I,J) = 0.0
      VB(I,J) = 0.0
      VC(I,J) = 0.0
      VS(I,J) = 0.0
      GOTO 260
  250 VA(I,J) = VA(I,J) / XN
      VB(I,J) = VB(I,J) / XN
      VC(I,J) = VC(I,J) / XN
      VS(I,J) = VS(I,J) / XN * 2.0
  260 CONTINUE
      KEYNRS = 0
  270 KEYNRS = KEYNRS + 1
      SC = 1.0 / SCALE**2
      PA(2) = 0
      PA(3) = 0
      NY = 0
      IWILP = 0
      DO 290 J=1,NRF
      NX = 0
      IY(J) = 0
      DO 280 I=1,NRF
      NX = NX + NOV(I,J)
  280 CONTINUE
      IF (NX.EQ.0) GOTO 290
      NY = NY + 1
      IY(NY) = J
  290 CONTINUE
      IF (NY.GT.2) GOTO 330
      IF (NY.EQ.2) GOTO 320
  300 IWILP = 1
      WRITE (LIS2, 310)
  310 FORMAT (' Refining scale and temperature factors seperately' /
     *        ' is impossible for this problem: use old parameters.')
      RETURN
  320 IF ((IY(2)-IY(1)) .EQ. 1) GOTO 300
  330 SIG = 10000.0
      WRITE (LIS2, FMT='('' Input values for two-dimensional'',
     * '' refinement: scale = '', F9.5 ,/, 48X,'' Bp ='', F7.3,
     * '' Br ='', F7.3)') SCALE, BPINP, BRINP
      IF (SWIPRI) WRITE (LIS2, 340)
  340 FORMAT (' Note: K = 1/SCALE**2')
      NCYC = 10
      NP  = 3
      PCYMAX = 1.2
      DO 490 NC=1,NCYC
      SIGOLD = SIG
      SIG = 0.0
      CALL KERNZA (0., AMAT, 9)
      CALL KERNZA (0.,   V, 3)
      DO 370 I=1,NRF
      DO 370 J=1,NRF
      IF (NOV(I,J).EQ.0) GOTO 370
      P = EXP (-PA(2)*VS(I,J))
      Q = EXP (-PA(3)*VS(I,J))
      D(1,I,J) = VB(I,J)*P + VC(I,J)*Q
      D(2,I,J) = -VB(I,J) * VS(I,J) * P * SC
      D(3,I,J) = -VC(I,J) * VS(I,J) * Q * SC
      AC(I,J) = VA(I,J) - SC*D(1,I,J)
      XN = 100.0 / NOV(I,J)
      IF (XN.LT.1.0) XN = 1.0
      DO 360 K=1,NP
      DO 350 L=1,NP
  350 AMAT(K,L) = AMAT(K,L) + D(K,I,J)*D(L,I,J)/XN
      V(K) = V(K) + D(K,I,J)*AC(I,J)/XN
      SIG = SIG + AC(I,J)**2/XN
  360 CONTINUE
  370 CONTINUE
      SIG = SQRT (SIG / (NRF*NRF-NP))
      IF (SWIPRI) WRITE (LIS2, 380) NC, SIG
  380 FORMAT (' Cycle', I2, ' Sigma   =', G12.4)
      CALL MATINV (AMAT, AMATIN, DMAT, KEND)
      IF (DMAT .LT. 10.E-9) WRITE (LIS2, 381)
  381 FORMAT (' Warning: small determinant, results unreliable?')
      IF (KEND.EQ.-99) GOTO 545
      DO 390 I=1,NP
      SH(I) = 0.0
      ERR(I) = SQRT (AMATIN(I,I))
      DO 390 J=1,NP
  390 SH(I) = SH(I) + AMATIN(I,J)*V(J)
      DO 400 I=1,NP
      DO 400 J=1,NP
  400 AMATIN(I,J) = AMATIN(I,J) / (ERR(I) * ERR(J))
      DO 410 I=1,NP
  410 ERR(I) = ERR(I) * SIG
      IF (SWIPRI) WRITE (LIS2, 420)
  420 FORMAT (30X, ' Par', 5X, 'Old', 5X, 'Shift', 5X, 'New',5X,'Error')
      DO 470 J=1,3
      P = SH(J)
      IF (NC.LE.3) P = P * .9
      IF (J.EQ.1) GOTO 430
      IF (P.GT.PCYMAX) P = PCYMAX
      IF (P.LT.-PCYMAX) P = -PCYMAX
  430 X = PA(J) + P
      IF (J .EQ. 1) X = AMAX1 (X, PA(1) / 5.)
      IF (SWIPRI) WRITE (LIS2, 450) VARI(J), PA(J), SH(J), X, ERR(J)
  450 FORMAT (27X, A8, 4F9.4)
      PA(J) = X
      IF (J.GT.1) GOTO 470
      PSC = 1. / SQRT(ABS(X))
      IF (SWIPRI) WRITE (LIS2, 460) PSC
  460 FORMAT (1H+, 8X, 'SC(new) =', F7.4)
  470 CONTINUE
      IF (.NOT. SWIPRI)
     *    WRITE (LIS2, 480) NC, BPINP+PA(2), BRINP+PA(3), PSC
  480 FORMAT ('  Cycle', I2, '  New Bp =', F7.3, '  Bp =', F7.3,
     *           '  SCALE =', F10.5 )
      IF (NC.LT.4) GOTO 490
      IF (ABS(SIGOLD-SIG).LT.0.01*SIG) GOTO 590
      IF (SIG.GT.1.5*SIGOLD) GOTO 550
      IF ((PA(2)+BPINP).LT.-5. .OR. (PA(2)+BPINP).GT.30. .OR.
     *    (PA(3)+BRINP).LT.-5. .OR. (PA(3)+BRINP).GT.30.) GOTO 530
      IF (SC.LT.0.0000001) GOTO 530
  490 PCYMAX = PCYMAX + .15
      WRITE (LIS2, 500) NCYC
  500 FORMAT (' Series is still unconverged after', I3, ' cycles')
      GOTO 570
  530 WRITE (LIS2, 540)
  540 FORMAT (' Unreasonable results' )
      GOTO 570
  545 WRITE (LIS2, 546)
  546 FORMAT (' Determinant is zero: no 2-dimens. Bp Br Sc ref. plot ')
      GOTO 570
  550 WRITE (LIS2, 560)
  560 FORMAT (' Series is diverging seriously')
  570 IWILP = 1
      IF (KEYNRS.GT.1 .OR. NRF.LE.6) GOTO 610
      WRITE (LIS2, 580)
  580 FORMAT (' Try again; skip high order refl.')
      NRF = NRF-2
      GOTO 270
  590 WRITE (LIS2, 595) NC
  595 FORMAT (' Series has converged after', I3, ' cycles')
      IF (KEYNRS.GT.1 .OR. NRF.LE.6) GOTO 610
      IF (ABS(PA(2)) .LT. 2.5) GOTO 610
      WRITE (LIS2, 600)
  600 FORMAT (' A large change of BP, too large.')
      GOTO 570
  610 IF (IWILP.GT.0) RETURN
      IF (SWIPRI)
     * WRITE (LIS2, 620) VARI, (VARI(I), (AMATIN(I,J), J=1,NP), I=1,NP)
  620 FORMAT (' Correlation matrix',12X,A8,4X,A8,2X,A8 /(22X,A8,3F10.4))
      SCALE = 1.0 / SQRT(SC)
      BP = PA(2) + BPINP
      BR = PA(3) + BRINP
      RETURN
      END
      SUBROUTINE MERBIN
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1)), (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINFO, IFILE(11)), (IBINS,  IFILE(13))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON / WILS / NOW(9),   NUW(9),   AW(9),   AAW(9),  BW(9),
     *                NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7),
     *                VS(7,7) , FHMN,     BPMAX,   BPMIN,   BRMAX,
     *                BRMIN,    BPINP,    BRINP,   KEYWIL,  PSQM,
     *                EPMAX,    EPMIN
      DIMENSION FITFO(3)
      EQUIVALENCE (HCODE, FITFO(1))
      DIMENSION HKL(3)
      EQUIVALENCE (HKL(1), HKLX(1,1))
      PARAMETER (MAXAT = 993)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),   EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ (10, MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      DIMENSION HMAX(3), HMIN(3), HCON(3)
      PARAMETER (MAXBUF = 198)
      PARAMETER (MAXA = 10000, AMAX = 10000.)
      COMMON /BUFREF/ BUFS(MAXBUF), BUFFO(MAXBUF), AREF(4, MAXA)
      LOGICAL FRIE
      DIMENSION ITEMP(9)
      DATA FRIE /.TRUE./
      DATA IREF /0/
      WRITE (LIS1, FMT = '('' First MERBIN use as subroutine: 1997'')')
      CALL KERNZA (  9999., HCON, 3)
      CALL KERNZA (  9999., HMIN, 3)
      CALL KERNZA ( -9999., HMAX, 3)
      STLCON = 9999.9
      HKMAX =  0.0
      HCODMI = 4.0 * 256.**3
      HCODMA = - HCODMI
      IF (STLMAX .GT. 0.0001) STLCON = STLMAX
      DO 230 I=1,3
      IF (HKLMAX(I) .GT. 0.1) HCON(I) = HKLMAX(I)
  230 CONTINUE
      NIT = 3
      CALL BINOFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, KENDS)
      NREF = 0
      MREF = 0
      MREF99 = 0
  240 CALL MEREAD (HKL, JC, FOBS, SIG, IEND)
      IF (IEND .LT. 0) GOTO 270
      MREF = MREF + 1
      CALL HKLAXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 240
      CALL HKLEXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 240
      IF (ABS(HKL(1)).GT.HCON(1) .OR. ABS(HKL(2)).GT.HCON(2) .OR.
     *    ABS(HKL(3)).GT.HCON(3)) GOTO 240
      CALL HKLSTL (HKL, STL, STL2)
      IF (STL .GT. STLCON) GOTO 240
      MREF99 = MREF99 + 1
      IF (ABS (HKL(1)) .GT. 99. .OR. ABS (HKL(2)) .GT. 99. .OR.
     *    ABS (HKL(3)) .GT. 99. ) GOTO 240
      STLMAX = AMAX1 (STLMAX, STL)
      NREF = NREF + 1
      CALL HKLEXS (FRIE, HKL, HCODE)
      FOBS = AMAX1 (FOBS, 0.01)
      SIG  = AMAX1 (SIG, FOBS / 100. , 0.01)
      IF (JC .EQ. 2) SIG = AMAX1(FOBS/6.0, SIG)
      CALL WRPEAK(0, 0., HKLMAX)
      SIG = SIG * 2. * FOBS
      FOBS = FOBS ** 2
      HCODMI = AMIN1(HCODMI, HCODE)
      HCODMA = AMAX1(HCODMA, HCODE)
      CALL HKLC1U (HCODE, HKL)
      DO 260 I =1,3
      HMAX(I) = AMAX1 (HKL(I),HMAX(I))
  260 HMIN(I) = AMIN1 (HKL(I),HMIN(I))
      HKMAX  = AMAX1 (HKMAX, ABS(HKL(1)+HKL(2)) )
      CALL BINOFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, KENDS)
      GOTO 240
  270 CALL BINOFF (-1, IBINS, 'BINS', FITFO, NIT, BUFS, KENDS)
      CALL KERNZA (0., ATXYZ, 10)
      IZAT(1) = 1
      STLMAX = STLMAX + 0.00001
      CALL FCALCI (1, ATXYZ, IZAT, ITAT, 1)
      DO 280 I=1,3
  280 HKLMAX(I) = AMAX1 (ABS(HMAX(I)), ABS(HMIN(I)) )
      IF (ISYST.LE.3) GOTO 290
      IF (ISYST.EQ.6 .OR. ISYST.EQ.7)
     *                HKLMAX(1) = AMAX1 (HKLMAX(1), HKMAX)
      IF (ISYST.EQ.5 .OR. ISYST.EQ.8)
     *                HKLMAX(1) = AMAX1 (HKLMAX(1), HKLMAX(3))
      HKLMAX(1) = AMAX1 (HKLMAX(1),HKLMAX(2))
      HKLMAX(2) = HKLMAX(1)
      IF (ISYST.EQ.5 .OR. ISYST.EQ.8) HKLMAX(3) = HKLMAX(1)
  290 WRITE (LIS1, 292) MREF
      WRITE (LIS2, 292) MREF
  292 FORMAT (' Number of input reflections:    ', I17)
      IF (MREF-NREF .GT. 0) WRITE (LIS1, 294) NREF
      IF (MREF-NREF .GT. 0) WRITE (LIS2, 294) NREF
  294 FORMAT (' Number of relections accepted:  ', I17)
      MREF99 = MREF99 - NREF
      IF (MREF99 .GT. 0) WRITE (IPR1, 295) MREF99
      IF (MREF99 .GT. 0) WRITE (LIS1, 295) MREF99
  295 FORMAT (' Number of relections with hkl exceeding 99:  ', I7/
     *        ' WARNING: these reflections are not used in DIRDIF !'/)
      CALL KERF2I (HMAX, ITEMP, 3)
      CALL KERF2I (HMIN, ITEMP(4), 3)
      CALL KERF2I (HKLMAX, ITEMP(7), 3)
      WRITE (LIS1, 300) ITEMP, STLMAX
      WRITE (LIS2, 300) ITEMP, STLMAX
  300 FORMAT (10X, ' Maximum indices output: ', 3I5 /
     *        10X, ' Minimum indices output: ', 3I5 /
     *        10X, ' HKLmax  incl. symmetry: ', 3I5 /
     *        10X, ' Maximum sin(TH/LAMBDA): ', F15.5 )
      IF (KEYS(13) .LE. 0) KEYS(13) = 1
      FRIEDE = - KEYS(13)
      BUFFO(5) = FRIEDE
      BUFFO(6) = STLMAX
      CALL KERNAB (HKLMAX, BUFFO(7), 3)
      CALL KERNAB (HMAX,  BUFFO(10), 3)
      CALL KERNAB (HMIN,  BUFFO(13), 3)
      SUMRN1 = 0.
      SUMRN2 = 0.
      NSUMR  = 0
      CALL BINOFF (15, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO)
      CALL BINIFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI)
      CALL HKLC2I (HMIN, HMAX)
      CALL HKLC1U (HCODMI, HKL)
      CALL HKLC2  (HKL, ACODMI)
  310 AF = ACODMI - 1.1
      CALL HKLC2U (ACODMI + AMAX - 1., HKL)
      CALL HKLC1  (HKL, HCODEL)
      CALL KERNZA (0.0, AREF, 4 * MAXA)
  320 CALL BINIFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI)
      IF (NENDI.LT.0) GOTO 330
      IF (HCODE.LT.HCODMI .OR. HCODE.GT.HCODEL) GOTO 320
      CALL HKLC1U (HCODE, HKL)
      CALL HKLC2  (HKL, ACODE)
      IA = IFIX (ACODE - AF)
      AREF(1,IA) = AREF(1,IA) + 1.
      IF (NINT(AREF(1,IA)) .EQ. 2) THEN
         SUMRN1 = SUMRN1 + ABS(AREF(3,IA)-FOBS)
         SUMRN2 = SUMRN2 +     AREF(3,IA)+FOBS
         NSUMR = NSUMR + 1
         ENDIF
      AREF(2,IA) = HCODE
      AREF(3,IA) = AREF(3,IA) + FOBS
      AREF(4,IA) = AREF(4,IA) + SIG
      GOTO 320
  330 DO 340 I = 1,MAXA
      IF (AREF(1,I).LE.0.1) GOTO 340
      TOT = AREF(1,I)
      HCODE = AREF(2,I)
      FOBS  = AREF(3,I) / TOT
      SIG   = AREF(4,I) / TOT **1.5
      FOBS = SQRT(FOBS)
      SIG  = SIG / (2. * FOBS)
      CALL BINOFF (0, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO)
      IREF = IREF + 1
      CALL HKLC1U (HCODE, HKL)
      CALL HKLSTL (HKL, STL, STL2)
      CALL WILSIM
  340 CONTINUE
      IF (HCODEL.GE.HCODMA) GOTO 350
      ACODMI = ACODMI + AMAX
      CALL HKLC2U (ACODMI, HKL)
      CALL HKLC1 (HKL, HCODMI)
      CALL BINIFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI)
      GOTO 310
  350 CALL BINOFF (-1, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO)
      WRITE (CHOUT, 360) IREF
  360 FORMAT (' Number of reflections (merged) output: ' , I7)
      IF (IREF .LE. 0) CALL KERROR ('Number of refl. = 0',0,'MERBIN')
      CALL SHOUT
      IF (NSUMR .GT. 10) THEN
         SUMRN1 = SUMRN1 / SUMRN2
         WRITE (CHOUT, 401) NSUMR, SUMRN1
  401    FORMAT (' R-merge (on F**2) for',I5,' reflections is R=',F6.2)
         CALL SHOUT2
         ENDIF
      WRITE (LIS2,490)
  490 FORMAT (/' Least squares Wilson plot' /
     *   ' Range  Sin(Th/Lambda)**2   Number  <|Fobs|**2/F2>' )
      STLM2  = STLMAX**2 / 9.
      NOWT = 0
      DO 560 I=1,9
      NOWT = NOW(I) + NOWT
      STMIN= FLOAT(I-1)  * STLM2
      STMAX= FLOAT(I)    * STLM2
      AWNOW = 0.
      IF (NOW(I) .GT. 0) AWNOW = AW(I)/NOW(I)
      WRITE(LIS2,550) I, STMIN, STMAX, NOW(I), AWNOW
  550 FORMAT(I5,F10.4,' - ',F6.4,I10,F14.6)
  560 CONTINUE
      WRITE(LIS2,570) NOWT
  570 FORMAT(' Total number of reflections:', I5)
      CALL WILPAR (IWILP)
      CALL LOGMER (NREF, HMAX, HMIN, HKLMAX, STLMAX, SCALE, BP)
      IF (NREF .GT. 0) CALL WRPEAK(IREF, BP, HKLMAX)
      CALL FILCLO (IBINS, 'DELETE')
      CALL FILCLO (IDDL, 'KEEP')
      WRITE (LIS2, 603)
  603 FORMAT( /' ==== END OF SUB-PROGRAM MERBIN ==== '//)
      RETURN
      END
      SUBROUTINE MEREAD (HKL, JC, FOBS, SIG, IEND)
      DIMENSION HKL(3)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1)), (IPR1, IFILE(6)), (LIS1, IFILE(7))
      EQUIVALENCE (ICRIN,IFILE(4)), (IHKL,IFILE(11)), (ISHEL,IFILE(12))
      EQUIVALENCE (IBINS,  IFILE(13))
      DIMENSION HH(3,3), JJ(3), FF(3), SS(3), HT(3)
      CHARACTER IE *1
      CHARACTER *6 XHKL(9)
      CHARACTER *80 CHINA
      LOGICAL FIRST, F2, TRANS
      DATA FIRST, F2 , TRANS / .FALSE., .FALSE., .FALSE. /
      DATA XHKL / 'FREFB', 'FREFC', 'FREFA', 'FREF', 'CARD3',
     *            'SHELX', 'HKL'  , 'CIF'  , 'SHELXL'  /
      DATA ICARD / 3 /
      DATA IDNUM / 0 /
      IF (FIRST) GOTO 310
      FIRST = .TRUE.
      DO 110 ID = 1, 9
      CALL FILINQ (IHKL, XHKL(ID), 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. 0) GOTO 120
  110 CONTINUE
      CALL FILCLO (IBINS, 'DELETE')
      CALL KERROR ('No reflection file found', 0, 'MERBIN')
  119 CALL FILCLO (IBINS, 'DELETE')
      CALL KERROR(' Empty IHKL file', 119, 'MEREAD')
  120 IF (ID .EQ. 8) GOTO 180
      IDNUM = 1
      CHIN = ' '
      READ (IHKL, FMT='(A28)', END=119) CHIN(1:28)
      WRITE (LIS1, 140) XHKL(ID), CHIN(1:28)
  140 FORMAT (' Input data file: ', A6, ' Header: ', A28)
      CALL KERINB (LIT, 1)
      IF (ID .GE. 6) GOTO 145
      IF ( (ID .EQ. 5 .AND. LIT(1) .NE. 'CARD3' ) .OR.
     *     (ID .LE. 3 .AND. LIT(1)(1:4) .NE. 'FREF') ) THEN
         CALL FILCLO (IBINS, 'DELETE')
         CALL KERROR ('File name and header inconsistent' , 0, 'MERBIN')
         ENDIF
      IF (ID .NE. 4 .AND. LIT(2) .NE. CCODE) THEN
         CALL FILCLO (IBINS, 'DELETE')
         CALL KERROR ('Input file has incorrect CCODE', -6, 'MERBIN')
         ENDIF
      IF (ID .EQ. 5) IDNUM = 2
      GOTO 310
  145 IDNUM = 3
      INUM = 0
      IHKLF = 0
      CHINA = CHIN
      IF (LIT(1) .EQ. ' ') THEN
         BACKSPACE IHKL
         GOTO 148
      ELSE
         IF (CHIN(1:4) .NE. 'HKLF') THEN
            CALL FILCLO (IBINS, 'DELETE')
            CALL FILCLO (IHKL, 'KEEP')
            CALL KERROR ('Incorrect header record', 167, 'MEREAD')
            ENDIF
         ENDIF
      KINS = -1
      CALL KERINB (LIT, 1)
      INUM = NINT(FNUM(1))
      IHKLF = 1
      GOTO 152
  148 CONTINUE
      CALL FILINQ (ISHEL, 'INS', 'FORMATTED', 'INPUT', KINS)
      IF (KINS .EQ. 0) GOTO 151
      CALL FILINQ (ISHEL, 'RES', 'FORMATTED', 'INPUT', KINS)
      IF (KINS .NE. 0) GOTO 152
  151 READ (ISHEL, END = 1152, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'HKLF') THEN
         CALL FILCLO (ISHEL, 'KEEP')
         CALL KERINB (LIT, 1)
         INUM = NINT(FNUM(1))
         IHKLF = 2
         GOTO 1152
         ENDIF
      GOTO 151
 1152 CALL FILCLO (ISHEL, 'KEEP')
  152 CONTINUE
      CALL FILCLO (ICRIN, 'KEEP')
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KINCR)
      IF (KINCR .NE. 0) THEN
         CHOUT = ' CRYSIN file not found: rerun CRYSDA !'
         CALL SHOUT
         GOTO 1155
         ENDIF
  153 READ (ICRIN, END = 1155, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'HKLF') THEN
         CALL FILCLO (ICRIN, 'KEEP')
         CALL KERINB (LIT, 1)
         INUMX = NINT(FNUM(1))
         IF (IHKLF .GT. 0 .AND. INUM .NE. INUMX) THEN
            CHOUT = ' HKLF on CRYSIN incorrect / discarded '
            CALL SHOUT
         ELSEIF (INUM .EQ. 0) THEN
            INUM = INUMX
            IHKLF = 3
         ELSE
            IHKLF = 3
            ENDIF
         GOTO 1155
         ENDIF
      GOTO 153
 1155 CALL FILCLO (ICRIN, 'KEEP')
      IF (INUM .NE. 0 .AND. IHKLF .GT. 0) GOTO 156
  155 WRITE (IPR1,FMT= '
     *  ('' The reflection file may contain F or F**2 values:''/
     *   '' does your file have F**2 values ? (Y / N)'')')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 155
      IF (LIT(1) .NE. 'N'  .AND. LIT(1) .NE. 'Y') GOTO 155
      IF (LIT(1) .EQ. 'Y') F2 = .TRUE.
      CHIN = CHINA
      INUM = 3
      IF ( F2 ) INUM = 4
      IHKLF = 4
  156 IF (IABS (INUM) .NE. 3 .AND. IABS (INUM) .NE. 4) THEN
         WRITE (CHOUT, FMT='('' input: HKLF'', I3, '' ??'')') INUM
         CALL SHOUT
         GOTO 155
         ENDIF
      IF (KINCR .NE. 0 .OR. IHKLF .EQ. 3) GOTO 163
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'OUTPUT', KINCR)
      CALL FILINQ (ISHEL, 'PAULTB', 'FORMATTED', 'SCRATCH', IIIII)
  157 READ (ICRIN, END = 158, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'HKLF') GOTO 157
      WRITE (ISHEL, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'END ') GOTO 158
      GOTO 157
  158 REWIND ICRIN
      REWIND ISHEL
 1157 READ (ISHEL, END = 1158, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'END ') GOTO 1158
      WRITE (ICRIN, FMT = '(A80)') CHIN
      GOTO 1157
 1158 WRITE (ICRIN, FMT='(''HKLF'', I4 / ''END'' )') INUM
      WRITE (CHOUT, FMT='('' HKLF'', I3,
     *   ''  :  written to the CRYSIN file'')') INUM
      CALL SHOUT
      CALL FILCLO (ICRIN, 'KEEP')
      CALL FILCLO (ISHEL, 'DELETE')
 163  INUM = IABS (INUM)
      WRITE (CHOUT, 162) INUM
 162  FORMAT ('HKLF', I4, ' .. HKLF number for SHELX data file')
      CALL LOGWR (IDDL)
      IF (INUM.EQ.3) THEN
         WRITE (LIS1, 165)
 165     FORMAT(' Input SHELXL or HKL file: SHELX format (Fobs values)')
      ELSEIF (INUM.EQ.4) THEN
         WRITE (LIS1, FMT=
     *   '('' Input SHELXL or HKL file with Fobs**2 values '')')
         F2 = .TRUE.
      ELSE
         CALL FILCLO (IBINS, 'DELETE')
         CALL KERROR ('Unknown contents of SHELXL or HKL file ...', 165,
     *      'MEREAD')
         ENDIF
      IF (NFNUM .GE. 11) THEN
         TRANS = .TRUE.
         DO 175  I = 1, 3
         DO 175  J = 1, 3
  175    HH(I,J) = FNUM(3*I + J -1)
         ENDIF
      GOTO 310
  180 IDNUM = 4
  190 CALL KERINA( IHKL, LIT(32),1, KEND)
      IF (KEND .NE. 0) THEN
         CALL FILCLO (IBINS, 'DELETE')
         CALL KERROR ('Incorrect CIF file', 190, 'MEREAD')
         ENDIF
      IF (CHIN(1:5) .EQ. 'data_') THEN
         IF (CHIN(6:11) .NE. CCODE) WRITE(LIS1, FMT=
     *       '('' Warning: input CIF file has incorrect CCODE'')')
         GOTO 190
         ENDIF
      IF (CHIN(1:13) .EQ.'_refln_F_calc') THEN
         WRITE(LIS1, FMT='('' Input CIF file with Fobs values '')')
         GOTO 190
         ENDIF
      IF (CHIN(1:21) .EQ.'_refln_F_squared_calc') THEN
         WRITE(LIS1, FMT='('' Input CIF file with Fobs**2 values '')')
         F2 = .TRUE.
         GOTO 190
         ENDIF
      IF (CHIN(1:21) .EQ.'_refln_intensity_calc') THEN
         CALL FILCLO (IBINS, 'DELETE')
         CALL KERROR ('CIF file with intensities', 190, 'MEREAD')
         ENDIF
      IF (CHIN(1:23) .NE.'_refln_scale_group_code') GOTO 190
  310 IEND = 0
      GOTO (410,  420, 430,  440), IDNUM
  410 READ (IHKL, 415, END=418) IE, HKL, JC, FOBS, SIG
  415 FORMAT (A1, 3F3.0 ,I2, F9.2, F7.2)
      IF (IE .NE. 'E') RETURN
  417 CALL FILCLO (IHKL, 'KEEP')
      IEND = -1
      RETURN
  418 CHOUT = ' Warning: sentinel E missing on FREF file !'
      CALL SHOUT
      GOTO 417
  419 CHOUT = ' Warning: sentinel 0 0 0 missing on refl.file !'
      CALL SHOUT
      GOTO 417
  420 ICARD = MOD (ICARD,3) + 1
      IF (ICARD .EQ. 1) THEN
         READ (IHKL, 422) IE,
     *        (HH(1,I), HH(2,I), HH(3,I), JJ(I), FF(I), SS(I), I=1,3)
  422    FORMAT (A1, 3F3.0, I2, F7.2, F5.2, 2(1X,3F3.0, I2, F7.2,F5.2))
         IF (IE .EQ. 'E') GOTO 417
         ENDIF
      CALL KERNAB (HH(1,ICARD), HKL, 3)
      IF (ABS(HKL(1)) + ABS(HKL(2)) + ABS(HKL(3)) .LT. 0.1) GOTO 420
      JC = JJ(ICARD)
      FOBS = FF(ICARD)
      SIG = SS(ICARD)
      RETURN
  430 READ (IHKL, 435, END=419) HKL, FOBS, SIG
  435 FORMAT (3F4.0, 2F8.2)
      IF (ABS(HKL(1)) + ABS(HKL(2)) + ABS(HKL(3)) .LT. 0.1) GOTO 417
      IF (TRANS) THEN
         CALL KERNAB (HKL, HT, 3)
         DO 437 I = 1,3
         HKL(I) = 0.0
         DO 437 J = 1,3
  437    HKL(I) = HKL(I) + HT(J) * HH(I,J)
         ENDIF
      JC = 0
  438 IF (.NOT. F2) RETURN
      FOBS = AMAX1 (FOBS, SIG / 100. , 0.0001)
      FOBS = SQRT(FOBS)
      SIG  = SIG / (2. * FOBS)
      RETURN
  440 CALL KERINA( IHKL, LIT(32),1, KEND)
      IF (KEND .NE. 0 .OR. CHIN(1:6) .EQ. '_publ_')  GOTO 417
      CALL KERNAB (FNUM, HKL, 3)
      FOBS = FNUM(4)
      SIG =  FNUM(5)
      GOTO 438
      END
      SUBROUTINE LOGMER (NREF, HMAX, HMIN, HKLMAX, STLMAX, SCALE, BOV)
      DIMENSION HMAX(3), HMIN(3), HKLMAX(3)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1))
      CALL LOGRD (IDDL, 'MERBSC', KLOG)
      IF (KLOG .LT. 0 .OR. LIT(2) .NE. 'SCALE') GOTO 188
      IF (NINT (10000.*SCALE) .NE. NINT(10000.*FNUM(2)) ) GOTO 188
      IF (NINT (1000.*BOV) .NE. NINT(1000.*FNUM(3)) ) GOTO 188
      CALL LOGRD (IDDL, 'NREF', KLOG)
      IF (KLOG .LT. 0 .OR. FNUM(2) .LT. 0.9) GOTO 188
      IF (NREF .NE. NINT(FNUM(2)) ) GOTO 188
      NREF = 0
      RETURN
  188 WRITE (CHOUT, 200) NREF, HMAX, HMIN
  200 FORMAT ('NREF ', I6, ' HMAX ', 3F5.0, ' HMIN ', 3F5.0)
      CALL LOGWR (IDDL)
      WRITE (CHOUT, 220) STLMAX, HKLMAX
  220 FORMAT ('STLMAX ', F7.5, ' HKLMAX ', 3F6.0)
      CALL LOGWR (IDDL)
      WRITE (CHOUT, 230) SCALE, BOV
  230 FORMAT ('SCALE ', F14.7, ' BOV ', F10.5,  ' MERBSC')
      CALL LOGWR (IDDL)
      RETURN
      END
      SUBROUTINE WILSIM
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      PARAMETER (MAXAT = 993)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),  EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      COMMON / WILS / NOW(9),   NUW(9),   AW(9),   AAW(9),  BW(9),
     *                NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7),
     *                VS(7,7) , FHMN,     BPMAX,   BPMIN,   BRMAX,
     *                BRMIN,    BPINP,    BRINP,   KEYWIL,  PSQM,
     *                EPMAX,    EPMIN
      PARAMETER  (NRS = 9)
      LOGICAL     SWIL
      DATA SWIL / .FALSE. /
      DATA  STLM2, FNRS3 / 0.0 , 0.0 /
      IF (SWIL) GOTO 180
      KEYWIL =-1
      EPMIN = 9999.
      EPMAX =-9999.
      CALL KERNZI (0 , NOW, NRS)
      CALL KERNZI (0 , NUW, NRS)
      CALL KERNZA (0.,  AW, NRS)
      CALL KERNZA (0., AAW, NRS)
      CALL KERNZA (0.,  BW, NRS)
      FHMN = 0.
      SWIL = .TRUE.
      FNRS3  = FLOAT(NRS+1)
      STLM2  = STLMAX**2
      BPINP = BP
      BRINP = BR
      BPMAX = 10.
      BPMIN =  0.
      BRMAX = 10.
      BRMIN =  0.
  180 ISS = IFIX (STL * 400. + 1.5)
      FOBS = FOBS / EXPBR(ISS)
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      TUMF2 = SUMF2(ISS) * EPSIL
      K = (STL2/STLM2) * (FNRS3) + 1.
      IF (K.GT.NRS) K = NRS
      IF (K.LT.1 .OR. K.GT.NRS) RETURN
      NOW(K) = NOW(K) + 1
      IF (FOBS .LT. 5.*SIG)  NUW(K) = NUW(K) + 1
      FOBS = FOBS**2 / TUMF2 / ALATT
      AW(K) = AW(K)  + FOBS
      BW(K) = BW(K) + STL2
      RETURN
      END
      SUBROUTINE WRPEAK (KEY, BOV, HMAX)
      DIMENSION HMAX(3)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (LIS2, IFILE(8))
      EQUIVALENCE (IBINFO, IFILE(11)), (IBINS,  IFILE(13))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      DIMENSION FITFO(3)
      EQUIVALENCE (HCODE, FITFO(1))
      DIMENSION HKL(3)
      EQUIVALENCE (HKL(1), HKLX(1,1))
      PARAMETER (MAXAT = 993)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),  EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      PARAMETER (MAXBUF = 198)
      PARAMETER (MAXA = 10000)
      COMMON /BUFREF/ BUFS(MAXBUF), BUFFO(MAXBUF), AREF(4, MAXA)
      DIMENSION FH(5,10), FHSUM(5,10), FHSYS(5,10), RHO(5,10)
      DIMENSION IKSYS(3), FBOV(5), ISYSAR(111)
      DIMENSION NWRP(100,2)
      LOGICAL CONT1
      DATA CONT1 / .FALSE. /
      IF (KEY .GT. 0) GOTO 151
      IF (CONT1) GOTO 133
      CALL KERNZI (0, NWRP, 200)
      CONT1 = .TRUE.
  133 CONTINUE
      IPH = IFIX (STL * 100. + 1.5)
      IF (IPH .GT. 100) IPH = 100
      IF (FOBS .GT. 2. * SIG) THEN
         NWRP(IPH, 1) = NWRP(IPH, 1) + 1
      ELSE
         NWRP(IPH, 2) = NWRP(IPH, 2) + 1
         ENDIF
      RETURN
  151 CONTINUE
      STLPH = STLMAX
      IF (KEY .LT. 500) GOTO 166
      I1 = IFIX (STLMAX * 100. + 1.5) / 2
      DO 158 I = I1, 100
      IF (NWRP(I, 1) + NWRP(I, 2) .LT. 10) GOTO 158
      IF (NWRP(I, 1) .LT. NWRP(I, 2)) THEN
         STLPH = FLOAT(I-1) / 100.
         GOTO 166
         ENDIF
  158 CONTINUE
  166 CONTINUE
      CALL KERNZA (0., FH, 50)
      CALL KERNZA (0., FHSUM, 50)
      CALL KERNZA (0., RHO, 50)
      IREFL = 0
      INREPS = 0
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO)
  201 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO)
      IF (KENDFO.LT.0) GOTO 220
      IF (FOBS .LT. SIG) GOTO 201
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL * 400. + 1.5)
      IF (STL .GT. STLPH) GOTO 201
      IREFL = IREFL + 1
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      DO 205 I = 1,5
      FACBOV = I-3
      FBOV(I) = BOV + FACBOV * 0.1 * BOV
      EXPBOV = EXP(- FBOV(I) * STL2)
      DO 205 J = 1,NTYPE
      FH(I,J) = FF(ISS,J) * EXPBOV
      FHSUM(I,J) = FHSUM(I,J) + (FH(I,J)/EPSIL)
      IF (EPSIL.GT.1.01) INREPS = INREPS + 1
  205 CONTINUE
      INREPS = INREPS / 5
      GOTO 201
  220 CALL KERNZA (0.,FHSYS,50)
      CALL KERNZI (0,ISYSAR,111)
      IF (ISYST.EQ.1) GOTO 230
      IF (ISYST.EQ.2) THEN
         CALL KERNZI (0,IKSYS,3)
         IKSYS(IUNIQ)=1
         CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH)
         CALL KERNZI (1,IKSYS,3)
         IKSYS(IUNIQ)=0
         CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH)
         ENDIF
      IF (ISYST.EQ.3) THEN
         DO 225 IC = 1,3
         CALL KERNZI (1,IKSYS,3)
         IKSYS(IC) = 0
         CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH)
  225    CONTINUE
         ENDIF
      IF (ISYST.GE.4) THEN
         CALL KERNZI (1,IKSYS,3)
         CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH)
         ENDIF
  230 FMULTT = FLOAT( 2 * NSYMM * NLATT )
      DO 240 I = 1, 5
      DO 240 J = 1, NTYPE
      RHO(I,J) = (FLOAT(IZTYPE(J)) +
     *   ((FMULTT * FHSUM(I,J)) + (2. * FHSYS(I,J)))  )/ VOLUM
  240 CONTINUE
      WRITE (LIS2, FMT='('' Write expected atomic peak heights'',
     *       '' (for various B values) to DDLOG'')')
      WRITE(CHOUT, 245) (FBOV(IT), IT=1,5)
  245 FORMAT ('WRPEAK  B',2X,5F7.3)
      CALL LOGWR (IDDL)
      WRITE (LIS2, FMT='('' Possible isotropic B values  '', 35(''-'')/
     *                   '' Expected peak height for ATOM'')')
      DO 260 J = 1,NTYPE
      WRITE(CHOUT, 250)J,CELATY(J), (RHO(I,J),I=1,5)
  250 FORMAT ('TYPE',I3,1X,A2,1X,5F7.2)
      CALL LOGWR (IDDL)
  260 CONTINUE
      WRITE(LIS2,FMT='('' TEMP   h  k  l   nr of syst.ext. refl'',/
     *                 '' --------------   for hemisphere H > 0'')')
      DO 270 I=0,1
      DO 270 J=0,1
      DO 270 K=0,1
      IKCODE = (100*I)+(10*J)+K
      IF (IKCODE.EQ.0) GOTO 270
      IF (ISYSAR(IKCODE) .GT. 0)
     *   WRITE (LIS2,265)I,J,K,ISYSAR(IKCODE)
  265 FORMAT (' Refl:',3I3,I10)
  270 CONTINUE
      WRITE(LIS2,FMT='('' TEMP:  Nr refl. Epsil>1.0 :'', I6)')INREPS
      RETURN
      END
      SUBROUTINE SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      PARAMETER (MAXAT = 993)
      COMMON /  / SICO(12500), FF(500,10),  EXPBP(500),  EXPBR(500),
     *            SUMF2(500),  SUMF2P(500), SFAC(13,10),
     *            ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      DIMENSION HMAX(3), HKL(3), FH(5,10), FHSYS(5,10)
      DIMENSION IHMAXT(3), IKSYS(3), ISYSAR(111)
      CALL KERNZA (0., FH, 50)
      DO 200 I=1,3
      IF (IKSYS(I).EQ.0) THEN
         IHMAXT(I) = 0
      ELSE
         IHMAXT(I) = NINT(HMAX(I)) - 1
         ENDIF
  200 CONTINUE
      STLMT = AMIN1 (0.90 * STLMAX, STLPH)
      DO 229 IH=0,IHMAXT(1)
      IF ((ISYST.EQ.3).AND.(IH.EQ.0)) THEN
         IF ((IKSYS(2).EQ.0).OR.(IKSYS(3).EQ.0)) GOTO 229
         ENDIF
      HKL(1)=IH
      DO 228 IK=-IHMAXT(2),IHMAXT(2)
      IF ((ISYST.EQ.3).AND.(IKSYS(3).EQ.0).AND.(IK.EQ.0)) GOTO 228
      HKL(2)=IK
      DO 227 IL=-IHMAXT(3),IHMAXT(3)
      HKL(3)=IL
      CALL HKLSTL (HKL, STL, STL2)
      IF (STL.GT.STLMT) GOTO 227
      ISS = IFIX (STL * 400. + 1.5)
      CALL HKLC1(HKL,HCODE)
      CALL HKLAXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 227
      CALL HKLEXT (HKL, KEND)
      IF (KEND.LT.0) THEN
         IKCODE = 0
         IF (NINT(HKL(1)).NE.0) IKCODE = IKCODE + 100
         IF (NINT(HKL(2)).NE.0) IKCODE = IKCODE + 10
         IF (NINT(HKL(3)).NE.0) IKCODE = IKCODE + 1
         ISYSAR(IKCODE) = ISYSAR(IKCODE) + 1
         DO 223 I = 1,5
         FACBOV = I-3
         BOVMOD = BOV + FACBOV * 0.1 * BOV
         EXPBOV = EXP(- BOVMOD * STL2)
         DO 223 J = 1,NTYPE
         FH(I,J) = FF(ISS,J) * EXPBOV
         FHSYS(I,J) = FHSYS(I,J) + FH(I,J)
  223    CONTINUE
         ENDIF
  227 CONTINUE
  228 CONTINUE
  229 CONTINUE
      RETURN
      END
      SUBROUTINE WILPAR (IWILP)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      LOGICAL SWIPRI
      EQUIVALENCE (SWIPRI, SWITCH(10))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      COMMON /FCALCA/ BP,       BR,       SCALE,    HKLMAX(3), STLMAX,
     *                IZTYPE(10), CELPAR(10), PSQ,  P1SQ,     ITRS(24),
     *        AMULT,  ASYMM,    ALATT,    ASYMCL,   NSYMC,    ASYMC,
     *                HKLX(3,24), IDHKL(24), HCODE, FOBS,     SIG,
     *                STL,      STL2,     ISS,      ENORM,
     *                FP,       PHIP,     FAP,      FBP,      EPSIL,
     *                EPSIL2,   SF2,      SF2P,     FPEXP(2,24)
      COMMON / WILS / NOW(9),   NUW(9),   AW(9),   AAW(9),  BW(9),
     *                NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7),
     *                VS(7,7) , FHMN,     BPMAX,   BPMIN,   BRMAX,
     *                BRMIN,    BPINP,    BRINP,   KEYWIL,  PSQM,
     *                EPMAX,    EPMIN
      PARAMETER (BDMAX = 1.0)
      IWILP = 1
      IF (KEYWIL.EQ.4) RETURN
      IF (.NOT. SWIPRI) GOTO 220
      IF (KEYWIL.GE.0) THEN
         WRITE (LIS2, 200)
  200    FORMAT(/ ' Data for WILSON-PARTHASARATHY plot:', /,
     *          ' Range  NOBS NUNOBS  <FO2/F2>  <(FP2+F2R)/F2>  STL2 ',
     *          ' ln<FO2/(FP2+F2R)>')
      ELSE
         WRITE (LIS2, 210)
  210    FORMAT(/ ' Data for WILSON plot:', /,
     *          ' Range  NOBS NUNOBS  <FO2/F2>  STL2  ln<FO2/F2>')
         ENDIF
  220 NRS = 9
      NNOW = 0
      DO 230 I=1,NRS
  230 NNOW = NNOW + NOW(I)
      IF (NNOW.GT. 399) GOTO 250
      J = 0
      DO 240 I=1,(NRS-1),2
      J = J + 1
      NOW(J) = NOW(I) + NOW(I+1)
      NUW(J) = NUW(I) + NUW(I+1)
      AW(J)  = AW(I)  + AW(I+1)
      AAW(J) = AAW(I) + AAW(I+1)
  240 BW(J)  = BW(I)  + BW(I+1)
      NOW(J) = NOW(J) + NOW(NRS)
      NUW(J) = NUW(J) + NUW(NRS)
      AW(J)  = AW(J)  + AW(NRS)
      AAW(J) = AAW(J) + AAW(NRS)
      BW(J)  = BW(J)  + BW(NRS)
      NRS = J
  250 I = 1
  260 IF (NNOW.GT.399 .AND. NOW(I).GT.25) GOTO 280
      IF (NNOW.LE.399 .AND. NOW(I).GT.NNOW/20) GOTO 280
      NRS = NRS - 1
      IF (I.GT.NRS) GOTO 320
      DO 270 J=I,NRS
      NOW(J) = NOW(J+1)
      NUW(J) = NUW(J+1)
      AW(J)  = AW(J+1)
      AAW(J) = AAW(J+1)
  270 BW(J)  = BW(J+1)
      GOTO 260
  280 AW(I)  = AW(I)  / NOW(I)
      AAW(I) = AAW(I) / NOW(I)
      BW(I)  = BW(I)  / NOW(I)
      IF (AAW(I).LT.0.001 .OR. KEYWIL.EQ.-1) AAW(I) = 1.0
      X1 = ALOG(AW(I) / AAW(I))
      IF (.NOT. SWIPRI) GOTO 310
      IF (KEYWIL.GE.0) THEN
          WRITE (LIS2, 290) I, NOW(I), NUW(I), AW(I), AAW(I), BW(I), X1
  290     FORMAT (1X, I3, I8, I5, F11.4, F13.4, F11.4, F13.4)
      ELSE
          WRITE (LIS2, 300) I, NOW(I), NUW(I), AW(I), BW(I), X1
  300     FORMAT (1X, I3, I8, I5, F11.4, F8.4, F10.4)
          ENDIF
  310 AW(I) = X1
      I = I + 1
      IF (I.LE.NRS)  GOTO 260
  320 IF (NRS.LE.1)  THEN
          WRITE (LIS1, 330) NRS
          WRITE (LIS2, 330) NRS
  330     FORMAT (' WILSON-PARTHASARATHY plot not possible, number of',
     *            ' ranges: ', I3)
          RETURN
          ENDIF
      IF (KEYWIL .NE. -1) THEN
         WRITE (LIS2, FMT='('' Input values for WILSON-PARTHASARATHY'',
     *          '' plot: Bp ='', F7.3, '' Br ='', F7.3)') BP, BR
         WRITE (LIS2, 340)
  340    FORMAT (' WILSON-PARTHASARATHY plot '/
     *            ' LN <FO**2/(FP**2+F2R)>')
         WRITE (LIS1, FMT='(A)') ' WILSON-PARTHASARATHY plot '
      ELSE
         WRITE (LIS2, FMT='('' Input values for WILSON plot:  '',
     *     '' Overall B ='', F7.3,''  Scale SC ='', F9.5)') BP, SCALE
         WRITE (LIS2, 350)
  350    FORMAT (' WILSON plot' / ' LN <FO**2/F2>')
         WRITE (LIS1, FMT='(A)') ' WILSON plot results'
         ENDIF
      CALL WILDUP (AW, BW, NOW, NUW, NRS, C, S, R)
      IWILP = 0
      IF (SWITCH(1)) WRITE (LIS2, 3511) SCALE, BPINP, BRINP, BP, BR
 3511 FORMAT (' PTB: TEMP: SCALE BpINP BrINP BP BR:', 2(3F9.5, 3X) )
      SCALE = EXP(-0.5 * C)
      BD = -0.5 * S
      BP = BP + BD
      BR = BR + BD
      IF (SWITCH(1)) WRITE (LIS2, 3512) SCALE, BP, BR
 3512 FORMAT (' PTB: TEMP: WILSON SCALE Bp Br: new:', 2(3F9.5, 3X) )
      WRITE (LIS2, 356)
  356 FORMAT ( ' Results are applied (as shifts)',
     *         ' to the input values. New values are:')
      IF (ABS(BP-BR).LT.0.001) THEN
          WRITE (LIS1, 360) SCALE, BP
          WRITE (LIS2, 360) SCALE, BP
  360 FORMAT (' Scale and overall temperature factor: Scale =',
     *          F9.5, ' Bov:', F6.3)
      ELSE
          WRITE (LIS1, 370) SCALE, BP, BR
          WRITE (LIS2, 370) SCALE, BP, BR
  370 FORMAT (' Scale and B-values to be used: Scale =',
     *          F9.5, ' Bp =', F6.3, ' Br =', F6.3)
          ENDIF
      IF (KEYWIL.LE.0) GOTO 390
      IF (KEYWIL.EQ.1 .OR. KEYWIL.EQ.3) BP = BP - BD
      IF (KEYWIL.EQ.2 .OR. KEYWIL.EQ.3) BR = BR - BD
      WRITE (LIS2, 380) KEYWIL, SCALE, BP, BR
      WRITE (LIS1, 380) KEYWIL, SCALE, BP, BR
  380 FORMAT (' (KEYWIL = ', I2, ') Reset: Scale =', F9.5,
     * ' Bp =', F6.3, ' Br =')
  390 CONTINUE
      IF (KEYWIL.EQ.-1) BD = 0.0
      IF (BP.GT.0.001 .AND. BR.GT.0.001 .AND. ABS(BD).LT.1. .AND.
     *    SCALE.GT.0.001) RETURN
      SIGNBD = SIGN(BDMAX,BD)
      IF (KEYWIL.LE.0) BP = BPINP + SIGNBD
      IF (KEYWIL.LE.1) BR = BRINP + SIGNBD
      IF (KEYWIL.EQ.2) BP = BPINP + SIGNBD
      SCALE = 0.0
      KRSTL = 8 * NRS / 10
      IF (NRS.LE.5)  KRSTL = 4
      IF (NRS.LT.4)  KRSTL = NRS
      DO 400 I=1,KRSTL
  400 SCALE = SCALE - AW(I) - 2.0*BW(I)*(BP-BPINP)
      SCALE = EXP (0.5 * SCALE / KRSTL)
      WRITE (LIS1, 410)
      WRITE (LIS2, 410)
  410 FORMAT (' Resetting of temperature factors and scale required:')
      WRITE (LIS1, 370)  SCALE, BP, BR
      WRITE (LIS2, 370)  SCALE, BP, BR
      RETURN
      END
      SUBROUTINE WILDUP (Y, X, NOW, NUW, N, C, S, R)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH, SWIPRI
      EQUIVALENCE (SWIPRI, SWITCH(10))
      EQUIVALENCE (LIS2, IFILE(8))
      DIMENSION X(N), Y(N)
      DIMENSION NOW(N), NUW(N)
      DIMENSION YAXIS(6), XAXIS(6)
      CHARACTER * 1  BLANK, STAR, CH(78)
      DATA BLANK, STAR / ' ', '*' /
      KTEST = 0
      SY  = 0.0
      SYY = 0.0
      SX  = 0.0
      SXX = 0.0
      SXY = 0.0
      YMIN = Y(1)
      YMAX = YMIN
      XMAX = X(N) * 1.125
      W = FLOAT(N)
      WWW = 0.
      DO 150  I=1,N
      WW = MAX0 (1, NOW(I) - NUW(I) )
      WWW = WWW + WW
      IF (Y(I).LT.YMIN)  YMIN = Y(I)
      IF (YMAX.LT.Y(I))  YMAX = Y(I)
      SY  = SY  + WW * Y(I)
      SYY = SYY + WW * Y(I)**2
      SX  = SX  + WW * X(I)
      SXX = SXX + WW * X(I)**2
  150 SXY = SXY + WW * X(I)*Y(I)
      S = (SY*SX - WWW*SXY) / (SX*SX - WWW*SXX)
      C = (SY - S*SX) / WWW
      YSCAL = 0.2 * (YMAX-YMIN)
      YMAX = YMAX + YSCAL
      YMIN = YMIN - YSCAL
      YSCAL = YMAX - YMIN
      YFAC = 20./YSCAL
      XFAC = 80./XMAX
      YAXIS(1) = YMAX
      XAXIS(1) = 0.00001
      DO 210  I=2,6
      FI1 = FLOAT(I-1)
      XAXIS(I) = XMAX/5.0*FI1
  210 YAXIS(I) = YMAX - (YSCAL/5.*FI1)
      CALL KERNZ1 (STAR, CH, 78)
      WRITE (LIS2, 220)  STAR, YAXIS(1), (CH(II),II=7,78)
  220 FORMAT (' ', A1, F5.2, ' ', 72A1)
      M = 2
      DO 260  I=2,19
      FI20 = FLOAT(20 - I)
      CALL KERNZ1 (BLANK, CH, 78)
      CH(1) = '*'
      L  = ((YMIN + (YSCAL*  FI20)     /20.) -C)/S*XFAC + 0.5
      L1 = ((YMIN + (YSCAL* (FI20-1.)) /20.) -C)/S*XFAC + 0.5
      IF (L.GT.0 .AND. L.LE.78) CH(L) = '.'
      IF (ABS(L1-L).LE.5) GOTO 229
      IF (S.LT.0.00001) THEN
          I1 = L + 3
          I2 = L1 - 3
      ELSE
          I1 = L1 + 3
          I2 = L - 3
          ENDIF
      IF (I1.LE. 1) I1 = 2
      IF (I2.GT.78) I2 = 78
      DO 225 I12=I1,I2,3
  225 CH(I12) = '.'
  229 DO 230  J=1,N
      K = (Y(J)-YMIN)*YFAC + 0.5 + FLOAT(I)
      L = X(J)*XFAC + 0.5
      IF (K.EQ.20 .AND. L.LE.78)  CH(L) = 'X'
      IF (K.EQ.20 .AND. L.GT.78)  CH(78)= '+'
  230 CONTINUE
      IF (I/4*4.EQ.I)  GOTO 250
      WRITE (LIS2, 240)  CH
  240 FORMAT (1H , 78A1)
      GOTO 260
  250 WRITE (LIS2, 220)  STAR, YAXIS(M), (CH(II), II=7,78)
      M = M + 1
  260 CONTINUE
      CALL KERNZ1 (STAR, CH, 78)
      WRITE (LIS2, 220)  STAR, YAXIS(6), (CH(II), II=7,78)
      WRITE (LIS2, 270)  (XAXIS(II), II=2,6)
  270 FORMAT (F15.3, 4F16.3)
      WRITE (LIS2, 280)
  280 FORMAT (60X, '(sinTHETA/LAMBDA)**2')
      IF (SWIPRI)  WRITE (LIS2, 290) N, S, C
  290 FORMAT (/' Line based on', I10, ' points,    slope is ', F10.4, /
     *        ' intercept is ', F10.4)
      RETURN
      END
