      PROGRAM NUTS
*********************************************  NUTS FORTRAN  =  NUTS FOR
***** Nijmegen UTilety System  **************  Last update: 11 Nov. 1999
***** with subprograms :       **************  >>>>>>> see CSUBPROG for:
***** AT2X, X2AT, SHAT, INVERT, PRIFC, BINPRI, BIJVOET, EULER ..... etc.
 
***** NUTS LOG of recent modifications (last on top:
C 11 Nov  DDOKA STOP 99
C 22 Feb. 1999  Outout SCHAKAL file (SCAHAKL): 'ATOM ' x y z (Struempl)
      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 (IDDJ, IDDS, IFILE(1))
      EQUIVALENCE (ICRYS, IFILE(3)), (ICON, IFILE(4)), (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IBINFO, IFILE(13))
      EQUIVALENCE (IRUN, KEYS(13))
      LOGICAL     SWHAND, NIJMEG
      EQUIVALENCE (SWHAND, SWITCH(28))
      EQUIVALENCE (NIJMEG, SWITCH(1))
      CHARACTER * 2 ISTAR
      CHARACTER *6 L(20), LL
      CHARACTER *72 FMHELP(8)
      DATA LMAX, LMAXP / 20, 15/
      DATA L    /  'NUTS'  , 'AT2X'  , 'X2AT'  , 'FR2BIN', 'BIN2FR',
     *             'BIJVOE', 'SHAT'  , 'EULER' , 'INVERT', 'BINPRI',
     *             'METFOU', 'SHELIN', 'SELECT', 'PRIFC' , 'SHELXL',
     *             '????'  , 'MISFIT', 'R'     , 'H'     , 'Q'       /
      DATA ISTAR / '**' /
      DATA FMHELP /
     *' AT2X, X2AT : transform ATOMS file to SHELX XYZN file, and v.v.',
     *' FR2BIN, BIN2FR: transform FREF file to BINary file, and v.v.'  ,
     *' BINPRI : print BINary data files (BINFO BINFC(2) BINFFT)'      ,
     *' SHAT, EULER and INVERT : shift, rotate or invert atomic coords',
     *' METFOUR : (obsolete)',
     *' PRIFC   : print FC: combines a BINFO and a BINFC file )',
     *' SELECT  : select an atom set from file CCODE ATOLD (ERROR!)',
     *' BIJVOET : calculate Bijvoet coefficients (:absolute conf.!)'   /
      DATA ICONT /0/
      CALL KEPROG ('NUTS')
      WRITE (LIS2, FMT = '('' Last NUTS update: 11 Nov. 1999'')')
      CHOUT = '0Nijmegen UTility System'
      CALL SHOUT2
      IF (IRUN .GT. 1) THEN
         WRITE (CHOUT, FMT = '(66X, ''RUN'', I3)') IRUN
         CALL SHOUT
         ENDIF
      CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KEND)
      CALL FILCLO (IDDJ, 'KEEP')
      IF (KEND .NE. 0) GOTO 107
      LL  = LIT(2)
      IF (LL .EQ. 'NUTS') LL = LIT(3)
      IF (LL .EQ. ' ') GOTO 107
      IF (LL .NE. 'MISFIT') GOTO 106
      WRITE (IPR1, 103)
      WRITE (LIS1, 103)
      WRITE (LIS2, 103)
  103 FORMAT (/' Present procedure for MISFIT structures:' /
     *   ' structure solution for one of the layers completed, '/
     *   ' control passed on to program MISFIT' /)
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDS, FMT='(''MISFIT'')')
      WRITE (IDDS, FMT='(''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      CALL KEPROX
      GOTO 999
  106 CALL KEREQ6 (LL, L, LMAXP, KEND)
      IF (KEND .LE. 0 .OR. KEND .GT. LMAXP) GOTO 107
      GOTO 206
  107 CALL RDCOND (ICON, L, 1, KEND)
      LL = LIT(2)
      IF (LL .EQ. 'NUTS') LL = LIT(3)
      IF (KEND .EQ. 1) CALL RDCOND (ICON, L, 1, KKKK)
      CALL FILCLO (ICON, 'KEEP')
      IF (KEND .NE. 1) GOTO 110
      IF (LL .EQ.  ' ') GOTO 110
      CALL KEREQ6 (LL, L, LMAXP, KEND)
      IF (KEND .LE. 0 .OR. KEND .GT. LMAXP) GOTO 110
      GOTO 206
  110 ICONT = 1
      WRITE (IPR1, 112) (L(J), J=2,LMAXP)
  112 FORMAT (' Select one of the following options (or R or H or Q):'
     *         /  10 (1X, A6) )
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 110
      LL = LIT(1)
      IF (LL .EQ. 'Q') GOTO 990
      IF (LL .EQ. 'R') GOTO 110
      IF (LL .EQ. 'H') THEN
         DO 114 I = 1, 8
  114    WRITE (IPR1, FMT = '(A72)') FMHELP(I)
         GOTO 110
         ENDIF
      SWHAND = .TRUE.
      CALL KEREQ6 (LL, L, LMAX, KEND)
      IF (KEND.LE.1) THEN
         WRITE (IPR1, 202)
  202    FORMAT (' Answer not understood: please, try again:')
         GOTO 110
         ENDIF
  206 PROGNM = LL
      IF (PROGNM .EQ. 'METFOU') PROGNM = 'METFOUR'
      IF (PROGNM .EQ. 'BIJVOE') PROGNM = 'BIJVOET'
      WRITE (LIS2, 207) (ISTAR, I=1,23), PROGNM, (ISTAR, I=1,23)
  207 FORMAT (/ 1X, 23A2 / ' ****', 38X, '****' / ' ****', 16X, A8,
     +       14X, '****' / ' ****', 38X, '****' / 1X, 23A2 )
      WRITE (CHOUT, FMT='(''0============ Program '', A8)') PROGNM
      IF (CCODE .NE. 'NONAME') THEN
         LIT(31) = ' '
         IF (CCODE(5:6) .EQ. '  ') THEN
            LIT(31)(3:6) = CCODE(1:4)
         ELSEIF (CCODE(6:6) .EQ. ' ') THEN
            LIT(31)(2:6) = CCODE(1:5)
         ELSE
            LIT(31) = CCODE
            ENDIF
         WRITE (CHOUT, FMT='(''0============ Execute program '', A8,
     *      '' ============ for compound: '', A6  )') PROGNM, LIT(31)
         LIT(31) = ' '
         ENDIF
      CALL SHOUT
      GOTO (2,2,3,4,5,6,7,8,9,10,11,12,13,14,15,18,18,18,19,20), KEND
  2   CALL AT2X
      GOTO 770
  3   CALL X2AT
      GOTO 770
  4   CALL FR2BIN
      GOTO 770
  5   CALL BIN2FR
      GOTO 770
  6   CALL BIJVOE
      GOTO 770
  7   CALL SHAT
      GOTO 770
  8   CALL EULER
      GOTO 770
  9   CALL INVERT
      IF (SWHAND) CALL SHAT
      GOTO 770
  10  CALL BINPRI
      GOTO 770
  11  CALL METFOU
      GOTO 770
  12  CONTINUE
      WRITE (IPR1, 212)
  212 FORMAT (
     *' Various output files with atomic parameters ([-profile-]).'/
     *' Note: XYZN = control data + atomic params for SHELXL 1993 !!'/
     *' For use in SHELXL:  rename  CCODE.XYZN  to  CCODE.INS  .')
      CALL AT2X
      GOTO 770
  13  CALL SELECT
      GOTO 770
  14  CALL PRIFC
      GOTO 770
  15  CONTINUE
      IF (NIJMEG) WRITE (IPR1, 212)
      CALL AT2X
      GOTO 770
  18  IF (ICONT.EQ.0) GOTO 800
      GOTO 110
  19  IF (ICONT.EQ.0) GOTO 800
      WRITE (IPR1, 719)
  719 FORMAT (' Possible options are:'/
     *  ' AT2X   = convert ATOMS file to eXternal par. file format' /
     *  ' X2AT   = convert SHELX param. file to ATOMS file' /
     *  ' FR2BIN = convert FREF file (refl.data) to binary file' /
     *  ' BIJVOET  calculate Bijvoet coefficient'/
     *  ' etc.  ,  please try again:')
      GOTO 110
  20  IF (ICONT.EQ.0) GOTO 800
      WRITE (IPR1, 720)
  720 FORMAT (' So you quit.')
      GOTO 990
  770 IF (ICONT .EQ. 0) GOTO 990
      WRITE (IPR1, 777)
  777 FORMAT (' DONE'//' Do you wish to run more options? Say Q or:')
      GOTO 110
  800 CALL KERROR ('Illegal parameter', 800, 'NUTS')
  990 WRITE (CHOUT, 992) PROGNM
  992 FORMAT ('0End of program ', A8)
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ)
      IF (KINQ .EQ. 0) THEN
         WRITE (LIS1, FMT='('' Existing CONDA file erased'')')
         CALL FILCLO (ICON, 'DELETE')
         ENDIF
      CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ)
      IF (KINQ .EQ. 0) GOTO 995
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'TEST', KINQ)
      IF (KINQ .NE. 0) GOTO 995
      CALL KERINA (ICRYS, LIT(32), 1, LEND)
      IF (NFNUM.LE.0 .OR. NLIT.LE.0) GOTO 994
      IRUNCR = FNUM(NFNUM)
      IF (LIT(NLIT).EQ.'RUN' .AND. IRUNCR.EQ.KEYS(13)) THEN
         CALL FILCLO (ICRYS, 'DELETE')
         GOTO 995
         ENDIF
  994 WRITE (LIS1, FMT='(/'' Note: old CRYSDA file retained !!''/)' )
      CALL FILCLO (ICRYS, 'KEEP')
  995 PROGNM = 'NUTS'
      CALL KEPROX
  999 CONTINUE
      WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)')
      STOP 99
      END
      SUBROUTINE AT2X
      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)), (ICRIN, IFILE(4))
      EQUIVALENCE (IATOMS, IFILE(2)), (ICRYS, IFILE(3))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (ISPEK, IFILE(9)), (ISHEL, IFILE(11))
      EQUIVALENCE (ISCHAK, IFILE(12))
      EQUIVALENCE (IBINFO, IFILE(13))
      EQUIVALENCE (IATX, KEYS(11))
      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
      DIMENSION IUNIT(10),LATT(7)
      PARAMETER       (NSLOT = 10, MAXAT = 2513)
      COMMON /  /     DUMMY(1),
     *                ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER (MAXBUF = 198)
      DIMENSION BUFFO(MAXBUF), FITFO(3)
      CHARACTER * 1 LR
      DIMENSION IZTYPA(10)
      PARAMETER (U2B = 8. * 3.141593 **2)
      DATA LATT / 1,5,6,7,2,4,3 /
      DATA TF / 0.06/
      CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ)
      IF (KINQ .NE. 0) GOTO 109
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IRUNFO = NINT (BUFFO(5))
      IF (IRUNFO .EQ. - KEYS(13)) THEN
         CALL FILCLO (IBINFO, 'DELETE')
         GOTO 109
         ENDIF
      WRITE (LIS1, FMT='(/'' Note: old BINFO file retained !!'')' )
  109 CALL RDCRYS (ICRYS)
      DO 110 I= 1, NTYPE
  110 CALL ATOMIZ (CELATY(I), NLET, IZTYPA(I))
      IF (IATX .EQ. 4 .OR. IATX .EQ. 5) THEN
         CALL FILINQ (ISCHAK, 'SCHAKL', 'FORMATTED', 'OUTPUT', KINQ)
         WRITE (ISCHAK, 217) CCODE
         WRITE (ISCHAK, 219) CELL
         WRITE (LIS1, FMT='(
     *   '' Output SCHAKAL file is denoted  SCHAKL  or  ccode.sch'')')
         ENDIF
      WRITE (LIS1, FMT='(
     *   '' Output SHELX-INS file is denoted  XYZN  or ccode.xyzn'')')
      CALL FILINQ (ISHEL, 'XYZN' , 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ISHEL, FMT = '(''TITL XYZN file = SHELXL INS file,'',
     *   '' from DIRDIF output for '', A6)') CCODE
      WRITE (ISHEL,115) WAVE, CELL
  115 FORMAT ('CELL  ',F8.5,2X,3F9.5,3F9.4)
      WRITE (ISHEL,125) ZET, CELLSD
  125 FORMAT ('ZERR ',F9.3,2X,3F9.5,3F9.4)
         LR = '+'
      IF (ICENT .EQ. 1) LR = '-'
      WRITE (ISHEL, FMT = '(''LATT  '', A1, I1)') LR, LATT(ILATT)
      IF (NSYMM .EQ. 1) GOTO 140
      CALL RDCRYB (ICRYS, 'SYMIT', KEND)
      DO 135 I = 2,NSYMM
      READ (ICRYS, FMT = '(A80)') CHIN
  135 WRITE (ISHEL, FMT = '(''SYMM  '', A60)') CHIN(11:70)
  140 WRITE (ISHEL, 145) (CELATY(I), I=1,NTYPE)
  145 FORMAT('SFAC      ',10(A2,3X))
      DO 190 I = 1,NTYPE
  190 IUNIT(I) = IFIX (CELALL(I) + 0.5)
      WRITE (ISHEL, FMT = '(''UNIT  '', 10I5)') (IUNIT(I),I=1,NTYPE)
      WRITE (ISHEL, FMT = '(''L.S.  3'')')
      CHOUT = 'REM      use BOND for distances and angles:'
      WRITE (ISHEL, FMT = '(A72)') CHOUT
      WRITE (ISHEL, FMT = '(''BOND'')')
      CHOUT='REM      FMAP 3 = electr.dens.,    FMAP 2:  Fo-Fc Fourier'
      WRITE (ISHEL, FMT = '(A72)') CHOUT
      WRITE (ISHEL, FMT = '(''FMAP  3'')')
      CHOUT = 'REM      Plan  n: print n additional Fourier peaks'
      WRITE (ISHEL, FMT = '(A72)') CHOUT
      CHOUT = 'REM      Plan -n: print includes connectivity'
      WRITE (ISHEL, FMT = '(A72)') CHOUT
      WRITE (ISHEL, FMT = '(''PLAN  -10'')')
      CHOUT='REM      TEMP nn = Temperature of data collect. in Celcius'
      WRITE (ISHEL, FMT = '(A72)') CHOUT
      WRITE (ISHEL, FMT = '(''REM      TEMP 20'')')
      CHOUT = 'REM      SIZE = crystal size in mm :'
      WRITE (ISHEL, FMT = '(A72)') CHOUT
      WRITE (ISHEL, FMT = '(''REM      SIZE 0.5 0.5 0.5 '')')
      WRITE (ISHEL, FMT = '(''REM      crystal color and shape ?'')')
      CHOUT = 'REM      Write atoms file in PDB format (with H) :'
      WRITE (ISHEL, FMT = '(A72)') CHOUT
      WRITE (ISHEL, FMT = '(''WPDB  -1 '')')
      WRITE (ISHEL, FMT= '(''REM      Warning: check HKLF below !! '')')
      WRITE (ISHEL, FMT= '(''REM      ---------------------------- '')')
      WRITE (ISHEL, FMT= '(''REM      3=Fobs, 4=FobsSQ, > HKL file '')')
      CHOUT = ' '
      IF (IATX .NE. 3 .AND. IATX .NE. 5) GOTO 225
      WRITE (LIS1, FMT='(
     *   '' Output for PLUTON (Spek) is  CCODE.SPF  or  ccode.spf''/)')
      CALL FILINQ (ISPEK,  'SPF',   'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ISPEK, 217) CCODE
  217 FORMAT ('TITL  : DIRDIF output for : ',A6)
      WRITE (ISPEK, 219) CELL
  219 FORMAT ('CELL  ',6F10.5)
      WRITE (ISPEK, 221) SPGR
  221 FORMAT ('SPGR  ',A16)
  225 CONTINUE
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found',
     *   225, 'AT2X')
      FVAR = - 999.
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CHOUT = ' Transform ATOMS parameter file format to: '
      CALL SHOUT
      IF (IATX .EQ. 0) THEN
         CHOUT = '      XYZN (INS) file '
      ELSEIF (IATX .EQ. 3) THEN
         CHOUT = '      SPF and XYZN (INS) files'
      ELSEIF (IATX .EQ. 4) THEN
         CHOUT = '      SCHAKAL and XYZN (INS) files'
      ELSEIF (IATX .EQ. 5) THEN
         CHOUT = '      SPF, SCHAKAL and XYZN (INS) files'
      ELSE
         CHOUT = '      XYZN (INS) file '
         ENDIF
      CALL SHOUT
      IF (NFNUM .LE. 0) GOTO 231
      IF (LIT(NLIT). EQ. 'SC=' .AND. FNUM(NFNUM) .GT. 0.001) THEN
         FVAR = 1. / FNUM(NFNUM)
         CHOUT = '      FVAR = 1 / SCALE from the ATOMS file '
         CALL SHOUT
         ENDIF
  231 CALL LOGRD (IDDL, 'MERBSC', KLOG)
      IF (KLOG .GT. 0 .AND. LIT(2) .EQ. 'SCALE') THEN
         IF (FVAR .LT. 0.0) THEN
            FVAR  = 1. / FNUM(2)
            CHOUT='      FVAR = 1 / MERBIN scale (from the DDLOG file)'
            CALL SHOUT
            ENDIF
         TF = FNUM(3) /U2B
         CHOUT = '      MERBIN U(iso) (from the DDLOG file)'
         CALL SHOUT
         ENDIF
         IF (FVAR .LT. 0.0) FVAR = 1.
      WRITE(ISHEL, FMT = '(''FVAR  '', F10.5)') FVAR
      CALL ATOMST (1, ATXYZ, NAT, KEYT)
      DO 300 I = 1,NAT
      ISF = 0
      DO 235 J=1,NTYPE
      IF (IZAT(I) .EQ. IZTYPA(J)) THEN
         ISF = J
         GOTO 250
      ENDIF
  235 CONTINUE
      WRITE (CHOUT, 240) ATNAME(I)
  240 FORMAT (' Atom ', A6,' not found in CRYSDA file',
     *' ISFAC=0 was assigned' )
      IF (ATNAME(I)(1:1).EQ.'Q') CHOUT(14:38) = ' is a peak (disorder?)'
      CALL SHOUT
  250 IF (ATXYZ(5,I) .LE. 0.0001) ATXYZ(5,I) = TF
      ATXYZ(4,I) = 11.0
      KK = 10
      IF (ATXYZ(6,I) .LE. 0.00001) KK = 5
      WRITE (ISHEL, 260) ATNAME(I)(1:4), ISF, (ATXYZ(K,I) ,K=1,KK)
  260 FORMAT (A4, I5, 6F10.5, ' =' / 9X, 4F10.5 )
      IF (IATX .EQ. 3 .OR. IATX .EQ. 5)
     *   WRITE (ISPEK, 276) ATNAME(I), (ATXYZ(J,I),J=1,3)
  276 FORMAT (A6,2X,3F10.5)
      IF (IATX .EQ. 4 .OR. IATX .EQ. 5)
     *   WRITE (ISCHAK, 277) ATNAME(I), (ATXYZ(K,I),K=1,3)
  277 FORMAT ('ATOM ',A6,2X,3F10.5)
  300 CONTINUE
      CALL FILCLO (ICRIN, 'KEEP')
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KCRIN)
      IHKLF = 0
      IF (KINQ.EQ.-1) GOTO 304
  301 CALL KERINA (ICRIN, LIT(32), 1, LEND)
      IF (LEND .NE. 0) GOTO 304
      IF (CHIN(1:4) .NE. 'HKLF') GOTO 301
      IF (NFNUM .LE. 0) GOTO 304
      IHKLF = IABS (NINT (FNUM(1)))
      IF (IHKLF .NE. 3 .AND. IHKLF .NE. 4) GOTO 304
  304 CALL FILCLO (ICRIN, 'KEEP')
      IF (IHKLF .EQ. 0) THEN
         WRITE (ISHEL, FMT = '(''REM   HKLF   ??  '')')
      ELSE
         WRITE (ISHEL, FMT = '(''HKLF  '',I3)') IHKLF
         ENDIF
      WRITE (ISHEL, FMT = '(''END       '')')
      CALL FILCLO (ISHEL, 'KEEP')
      IF (IATX .EQ. 3 .OR. IATX .EQ. 5) THEN
         WRITE (ISPEK, 311)
  311    FORMAT ('LABELS OFF'/'BOX OFF'/'EXCL Q'/'STRAW COL'/'PLOT')
         CALL FILCLO (ISPEK, 'KEEP')
         ENDIF
      IF (IATX .EQ. 4 .OR. IATX .EQ. 5) CALL FILCLO (ISCHAK, 'KEEP')
      IRUN = -999
      KPROG = 999
      CALL LOGRD(IDDL, 'NAT=', KLOG)
      IF (KLOG .GT. 0) IRUN = NINT(FNUM(2))
      IF (IRUN .EQ. KEYS(13)) KPROG= NINT(FNUM(4))
      IF (KPROG .GE. 1 .AND. KPROG .LE. 10) GOTO 345
      WRITE (LIS1, FMT='(/'' First 7 records of ATOMS file:'')')
      REWIND IATOMS
      DO 327 I = 1, 7
      CALL KERINA (IATOMS, LIT, 1, LENDX)
  327 WRITE (LIS1, FMT='(1X,A80)') CHIN
      WRITE (LIS1, FMT='(/)')
  345 REWIND ICRYS
      CALL KERINA (ICRYS, LIT, 1, LENDX)
      IF (LIT(NLIT) .EQ. 'KEEP') GOTO 900
      IF (IRUN .NE. KEYS(13)) GOTO 900
      IF (KPROG .GT. 10 .OR. KPROG .LE. 0) GOTO 999
      CALL FILCLO (ICRYS, 'DELETE')
      GOTO 999
  900 WRITE (LIS1,FMT='('' Existing (old) CRYSDA file retained'')')
  999 CONTINUE
      CALL FILCLO (IDDL, 'KEEP')
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (ICRYS, 'KEEP')
      WRITE (IPR1, 212)
  212 FORMAT (
     *' Note: XYZN = control data + atomic parameters for SHELXL !!'/
     *' For use in SHELXL:  rename file CCODE.XYZN  to  CCODE.INS .')
      CALL WRLIS2
      RETURN
      END
      SUBROUTINE X2AT
      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 (IXYZN,  IFILE(1) )
      EQUIVALENCE (IATOMS, IFILE(2) )
      EQUIVALENCE (ICRYS,  IFILE(3) )
      EQUIVALENCE (IRD,    IFILE(5) )
      EQUIVALENCE (IPR1,   IFILE(6) )
      EQUIVALENCE (IATOLD, IFILE(10))
      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
      PARAMETER       (NSLOT = 10, MAXAT = 2513)
      COMMON /  /     DUMMY(1),
     *                ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DIMENSION   B(MAXAT), NLET(10), IZTYPA(10)
      DIMENSION  HU(MAXAT)
      CHARACTER * 1  ISF
      CALL RDCRYS (ICRYS)
      CALL FILINQ (IXYZN, 'XYZN', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR ('XYZN file not found',0,'X2AT')
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IATOMS, 110) CCODE
  110 FORMAT (5HATOMS, 5X, A6)
      DO 140  I=1,NTYPE
      CALL ATOMIZ (CELATY(I), NLET(I), IZTYPA(I))
  140 CONTINUE
      CALL ATSHEL (IXYZN, ATXYZ, ATNAME, IZAT, MAXAT, NAT)
      IF (NAT .LE. 0)  GOTO 250
      CALL KERNZA( 0.0, HU, NAT)
      DO 150   I =1, NAT
      IF (ATXYZ(5,I) .LT. 0.0) HU(I) = ABS(ATXYZ(5,I))
150   CONTINUE
      BCRES = 0.0
      CALL ATOMST (2, ATXYZ, NAT, KEYT)
      IF (KEYT .EQ. 3) CALL ATBEQ (ATXYZ, B, NAT)
      CALL ATOMOC (2, ATXYZ, ITAT, NAT)
      DO 210  I=1,NAT
      ISF = ' '
      DO 160 J=1,NTYPE
  160 IF (IZAT(I).EQ.IZTYPA(J))  GOTO 180
      WRITE (IPR1, 170)  ATNAME(I)
  170 FORMAT (' ATOM ' , A6, ' not found in CRYSDA file,',
     +        ' ISFAC = X was assigned ')
      ISF = 'X'
  180 NN = 10
      IF (ATXYZ(6,I) .LE. 0.) NN = 5
      IF (NN .EQ. 5) B(I) = ATXYZ(5,I)
      IF (HU(I) .LE. 0.0005) THEN
         BCRES = B(I)
      ELSE
         B(I) = HU(I) * BCRES
         ENDIF
      WRITE (IATOMS, 190)  ATNAME(I), (ATXYZ(K,I),K=1,4), B(I), ISF
  190 FORMAT ('ATOM', 1X, A6, 1X, 5F10.5, 4X, A1)
      IF (NN.EQ.5) GOTO 210
      WRITE (IATOMS, 200)  (ATXYZ(K,I), K=5,10)
  200 FORMAT ('BIJ', 9X, 6F10.5)
  210 CONTINUE
      WRITE (IATOMS, 230)
  230 FORMAT ('END')
      CALL FILCLO (IXYZN,  'KEEP')
      CALL FILCLO (IATOMS, 'KEEP')
      WRITE (IPR1, 240)  NAT
  240 FORMAT (' Number of atoms input is',  I5 )
      RETURN
  250 CALL KERROR ('XYZN file  incorrect',0,'X2AT')
      RETURN
      END
      SUBROUTINE ATSHEL (IXYZN, ATXYZ, ATNAME, IZAT, MAXAT, NAT)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,MAXAT), IZAT(MAXAT)
      CHARACTER * 6  ATNAME(MAXAT)
      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  L(69)
      DATA  LMAX / 69 /
      DATA   L    / 'SHEL', 'DUMM', 'SFAC', 'FVAR', 'BLOC',
     +              'WGHT', 'AFIX', 'DFIX', '=   ', 'ANIS' ,
     * 'ACTA', 'BASF', 'BIND', 'BOND', 'BUMP', 'CELL', 'CGLS', 'CHIV',
     * 'CONF', 'CONN', 'DAMP', 'DEFS', 'DELU', 'DISP', 'EADP', 'END ',
     * 'EQIV', 'EXTI', 'EXYZ', 'FEND', 'FLAT', 'FMAP', 'FRAG', 'FREE',
     * 'GRID', 'HFIX', 'HKLF', 'ISOR', 'L.S.', 'LATT', 'LAUE', 'LIST',
     * 'MERG', 'MOLE', 'MORE', 'MOVE', 'MPLA', 'OMIT', 'PART', 'PLAN',
     * 'REM ', 'RESI', 'RTAB', 'SADI', 'SAME', 'SIMU', 'SIZE', 'SLIM',
     * 'SPEC', 'SUMP', 'SWAT', 'SYMM', 'TEMP', 'TIME', 'TITL', 'TWIN',
     * 'UNIT', 'WPDB', 'ZERR'/
      CALL ATOMIS (IXYZN, L, LMAX, ATXYZ, ATNAME, IZAT, MAXAT, NAT)
      RETURN
      END
      SUBROUTINE ATOMIS (IXYZN, L, LMAX, ATXYZ, ATNAME, IZAT, MAXAT,NAT)
      CHARACTER * 6  L(LMAX)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,MAXAT), IZAT(MAXAT)
      CHARACTER * 6  ATNAME(MAXAT)
      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))
      DIMENSION FVAR(99)
      DATA MFVAR / 99 /
      DATA I / 0 /
      CALL KERNZA (0.0, FVAR, MFVAR)
      IFVAR  = 0
      KELAST = 0
      KEACT  = 0
      NAT    = 0
  100 CALL KERIFF (IXYZN, L, LMAX, LEND)
      IF (LEND.NE.0) GOTO 190
      KELAST = KEACT
      KEACT  = 0
      IFNUM  = 1
      IF (KELAST.NE.9) GOTO 120
      I1 = 1
  110 I = I + 1
      IF (I .GT. NSLOT) GOTO 180
      ATXYZ(I,NAT) = FNUM(I1)
      I1 = I1 + 1
      GOTO 110
  120 IF (CHIN(1:4) .EQ. ' ') GOTO 100
      IF (CHIN(1:3) .EQ. 'REM') GOTO 100
      KEY1 = NLUSER(1)
      IF (KEY1 .GT. 10) GOTO 100
      KEACT = 0
      IF (NLIT.GT.1) KEACT = NLUSER(NLIT)
      IF (KEY1.NE.4) GOTO 160
      IF (CHIN(73:80) .EQ. ' ') GOTO 129
      IF (NFNUM .LT. 6) CALL KERROR(' FORMAT error on FVAR', 0, 'X2AT')
      READ (CHIN, 128) (FNUM(I), I=1,7)
  128 FORMAT (10X, 7F10.5)
      NFNUM = 7
  129 CONTINUE
      DO 130 I=1,NFNUM
      IF (I.GT.MFVAR) GOTO 140
  130 FVAR(I+IFVAR) = FNUM(I)
      IFVAR = IFVAR + NFNUM
      GOTO 160
  140 WRITE (IPR1,150) MFVAR
  150 FORMAT (' TOO MANY FREE VARIABLES, MAXIMUN ', I2)
      GOTO 200
  160 CONTINUE
      IF (KEY1 .GT. 0) GOTO 100
      NAT = NAT + 1
      IF (NAT.GT.MAXAT) CALL KERROR
     *   ('Too many atoms on Shelx atoms file', 160, 'ATOMIS')
      CALL ATOMSH (IZAT(NAT), ISFAC)
      IF (IZAT(NAT).LE.0) GOTO 200
      ATNAME(NAT) = LIT(1)
      CALL KERNZA (0., ATXYZ(4,NAT), NSLOT-3)
      I = 0
  170 I = I + 1
      I1 = I + 1
      IF (I.LE.3 .AND. NCOLN(I1).LE.0) GOTO 200
      IF (I.GT.3 .AND. NCOLN(I1).LE.0) THEN
         I = I - 1
         GOTO 180
         ENDIF
      ATXYZ(I,NAT) = FNUM(I1)
      IF (I.LT.NSLOT) GOTO 170
  180 CONTINUE
      IF (KEACT.EQ.9) GOTO 100
      NVAR = I
      IF (NVAR .GT. 10) NVAR = 10
      CALL ATOSHX (FVAR, MFVAR, NVAR, ATXYZ, MAXAT, NAT, KI)
      IF (KI.LT.0) GOTO 200
      GOTO 100
  190 IF (NAT.LE.0) CALL KERROR ('No atoms found', 190, 'ATOMIS')
      RETURN
  200 CALL KERROR  ('Error in SHELX atom record', 0, 'ATOMIS')
      END
      SUBROUTINE ATOMSH (IZ, ISFAC)
      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
      IZ = 0
      IF (NFDOL(1).GE.0) RETURN
      I = NCOLL(1)
      CALL ATOMIZ (CHIN(I:I+1), NLET, IZ)
      IF (IZ.LE.0) RETURN
      I = NLET + 1
      IF (I.GT.5) GOTO 150
      IF (CHIN(4:4).NE.' ' .AND. CHIN(5:5).NE.' ') GOTO 150
      IF (I.EQ.5) GOTO 140
      IF (CHIN(3:3).EQ.' ') CHIN(3:4) = CHIN(4:4)
      IF (CHIN(2:2).EQ.' ') CHIN(2:4) = CHIN(3:4)
      IF (CHIN(1:1).EQ.' ') CHIN(1:4) = CHIN(2:4)
      CALL ATOMIZ (CHIN(1:2), NLET, I)
      IF (I.NE.IZ) GOTO 150
      I = NLET + 1
      IF (CHIN(I:I).EQ.' ') GOTO 140
      CALL KERC2I (CHIN(I:I), NEN)
      IF (NEN.EQ.37 .OR. NEN.EQ.38) NEN = 0
      IF (NEN.EQ.45 .OR. NEN.EQ.46) NEN = 0
      IF (NEN.LT.0 .OR. NEN.GT.9) GOTO 150
      CALL KERINB (LIT(32), 1)
  140 IF (NFDOT(1).NE.1) GOTO 150
      ISFAC = NINT (FNUM(1))
      IF (ISFAC.LE.0) GOTO 150
      RETURN
  150 IZ = 0
      RETURN
      END
      SUBROUTINE ATOSHX (FVAR, MFVAR, NVAR, ATXYZ, MAXAT, NAT,KI)
      PARAMETER (NSLOT = 10)
      DIMENSION ATXYZ(NSLOT,MAXAT)
      DIMENSION FVAR(MFVAR)
      DO 150 I=1,NVAR
      IF (ABS(ATXYZ(I,NAT)).LT.5.0) GOTO 150
      IF (ATXYZ(I,NAT).GT.10.0) GOTO 100
      IF (ATXYZ(I,NAT).LT.-10.0) GOTO 110
      ATXYZ(I,NAT) = ATXYZ(I,NAT) - 10.0
      GOTO 150
  100 IX = IFIX( ATXYZ(I,NAT) / 10.0 + .05)
      VALP = ATXYZ(I,NAT) - FLOAT(IX*10)
      IF (IX.GT.1) GOTO 130
      ATXYZ(I,NAT) = ATXYZ(I,NAT) - 10.0
      GOTO 150
  110 IX = IFIX( ABS(ATXYZ(I,NAT)) / 10.0 + .05)
      VALN = ATXYZ(I,NAT) + FLOAT(IX*10)
      IF (IX.LE.1) GOTO 160
      IF (ABS(FVAR(IX)).LT.0.000001) GOTO 160
      ATXYZ(I,NAT) = (FVAR(IX)-1.0) * VALN
      IF (ABS(FVAR(IX)).LT.5.0) GOTO 150
      IF (FVAR(IX).GT.10.0) GOTO 120
      ATXYZ(I,NAT) = FVAR(IX) - 10.0
      ATXYZ(I,NAT) = (ATXYZ(I,NAT) - 1.0) * VALN
      GOTO 150
  120 ATXYZ(I,NAT) = FVAR(IX) - 10.0
      ATXYZ(I,NAT) = (ATXYZ(I,NAT) - 1.0) * VALN
      GOTO 150
  130 CONTINUE
      IF (ABS(FVAR(IX)).LT.0.000001) GOTO 160
      ATXYZ(I,NAT) = FVAR(IX) * VALP
      IF (ABS(FVAR(IX)).LT.5.0) GOTO 150
      IF (FVAR(IX).GT.10.0) GOTO 140
      ATXYZ(I,NAT) = (10.0 - FVAR(IX)) * VALP
      GOTO 150
  140 ATXYZ(I,NAT) = (FVAR(IX) - 10.0) * VALP
  150 CONTINUE
      KI = 1
      RETURN
  160 KI = -1
      RETURN
      END
      SUBROUTINE FR2BIN
      CALL FR2BIX
      RETURN
      END
      SUBROUTINE FR2BIX
      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 (IDDJ,  IFILE( 1))
      EQUIVALENCE (IPR1,  IFILE( 6))
      EQUIVALENCE (LIS1,  IFILE( 7))
      EQUIVALENCE (IFREF, IFILE(11))
      EQUIVALENCE (IBIN,  IFILE(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
      DIMENSION HKL(3)
      DIMENSION FITEMS(3)
      PARAMETER (MAXBUF = 198)
      DIMENSION BUFO(MAXBUF)
      EQUIVALENCE (FITEMS(1),HCODE), (FITEMS(2),FOBS), (FITEMS(3),SIG)
      CHARACTER * 6 FILENM, BINNM
      CHARACTER * 1 IE
      CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KEND)
      IF (KEND .EQ. 0) THEN
         CALL KERINA ( IDDJ, LIT(32), 1, LEND)
         FILENM = LIT(4)
         CALL FILCLO (IDDJ, 'KEEP')
         GOTO 110
         ENDIF
      CALL FILCLO (IDDJ, 'KEEP')
100   WRITE (IPR1, FMT = '(/,
     *'' Execution of program FR2BIN for file transformation:'',/,
     *'' Please, give input FREF type (e.g. FREFA, FREFLP, .. ): '')')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 100
      FILENM = LIT(1)
110   IF (FILENM(1:4) .NE. 'FREF') GOTO 100
      BINNM = 'BIN'
      BINNM(4:5) = FILENM(5:6)
      WRITE (CHOUT, 114) FILENM, BINNM
  114 FORMAT (' Convert a ', A6, ' file into a ', A6, ' file.')
      CALL FILINQ (IFREF,  FILENM , 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR (' No FREFxx file ', 0, 'FR2BIN')
      READ (IFREF, FMT = '(A28)' ) CHIN(1:28)
      WRITE( LIS1, FMT = '('' Input file header '',A28)' ) CHIN(1:28)
      IF (CHIN(1:4) .NE. 'FREF') CALL KERROR
     * (' Input file is not a FREF file', 0, 'FR2BIN')
      CALL KERINB (LIT(32),1)
      CCODE = LIT(2)
      IFI = 1
      IF (CHIN(18:20) .EQ. 'FRI') IFI = 2
      IF (CHIN(18:20) .EQ. 'BIJ') IFI = 3
      IAB = 1
      IF (CHIN(22:24) .EQ. 'EMP') IAB = 2
      IDI = 1
      IF (CHIN(26:28) .EQ. 'DIF') IDI = 2
      BUFO(5) = FLOAT (IAB + IFI * 10 + IDI * 100)
      NIT = 3
      CALL BINOFF (5, IBIN, BINNM, FITEMS, NIT, BUFO, NEND)
      NREF = 0
  240 READ (IFREF, 250) IE, HKL, JC, FOBS, SIG
  250 FORMAT (A1, 3F3.0 ,I2, F9.2, F7.2)
      IF (IE.EQ.'E') GOTO 270
      CALL HKLC1 (HKL, HCODE)
      NREF = NREF + 1
      CALL BINOFF (0, IBIN, BINNM, FITEMS, NIT, BUFO, NEND)
      GOTO 240
  270 CALL BINOFF (-1, IBIN, BINNM, FITEMS, NIT, BUFO, NEND)
      WRITE (LIS1, 300) NREF
  300 FORMAT(' Number of reflections: ', I14,/)
      CALL FILCLO (IFREF, 'KEEP')
      CALL FILCLO (IBIN, 'KEEP')
      RETURN
      END
      SUBROUTINE BIN2FR
      CALL BIN2FX (ISTOP)
      IF (ISTOP .NE. 0) CALL KERROR
     *   ('Check stars (****) in output FREF-file',0,'BIN2FR')
      END
      SUBROUTINE BIN2FX (ISTOP)
      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 (IDDJ, IFILE(1)), (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7)), (IBIN, IFILE(11))
      EQUIVALENCE (IFREF, IFILE(12))
      DIMENSION HKL(3), IHKL(3)
      DIMENSION FITEMS(3)
      PARAMETER (MAXBUF = 198)
      DIMENSION BUFI(MAXBUF)
      EQUIVALENCE (FITEMS(1),HCODE), (FITEMS(2),FOBS), (FITEMS(3),SIG)
      CHARACTER * 6 FILENM, FREFNM
      CHARACTER * 3 FI(3), FA(3), FD(3)
      DATA FI /'   ','FRI','BIJ'/
      DATA FA /'   ','EMP','   '/
      DATA FD /'   ','DIF','   '/
      DATA SIGM / 0.0 /
      ISTOP = 0
      CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KEND)
      IF (KEND .EQ. 0) THEN
         CALL KERINA ( IDDJ, LIT(32), 1, LEND)
         FILENM = LIT(4)
         CALL FILCLO (IDDJ, 'KEEP')
         GOTO 110
         ENDIF
      CALL FILCLO (IDDJ, 'KEEP')
100   WRITE (IPR1, FMT = '(/,
     * '' Execution of program BIN2FR for file transformation:'',/,
     * '' Please, give input BIN- type (e.g. BINA, BINLP, .. ): '')')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 100
      FILENM = LIT(1)
110   IF (FILENM(1:3) .NE. 'BIN') GOTO 100
      FREFNM = 'FREF'
      FREFNM(5:6) = FILENM(4:5)
      WRITE (CHOUT, 114) FILENM, FREFNM
  114 FORMAT (' Convert a ', A6, ' file into a ', A6, ' file.')
      CALL FILINQ (IFREF, FREFNM, 'FORMATTED', 'OUTPUT', KINQ)
      NIT = 3
      CALL BINIFF (6, IBIN, FILENM, FITEMS, NIT, BUFI, NEND)
      CCODE = CHIN(7:12)
      CHIN = ' '
      CHIN(1:6) = FREFNM
      CHIN(8:13) = CCODE
      IB = NINT(BUFI(5))
      IDI = IB/100
      IF (IDI.LT.1 .OR. IDI.GT.3) GOTO 117
      CHIN(26:28) = FD(IDI)
      IB  = IB - IDI * 100
      IFI = IB/10
      IF (IFI.LT.1 .OR. IFI.GT.3) GOTO 117
      CHIN(18:20) = FI(IFI)
      IFA = (MOD(IB,10))
      IF (IFA.LT.1 .OR. IFA.GT.3) GOTO 117
      CHIN(22:24) = FA(IFA)
 117  WRITE (LIS1, FMT = '('' Output file header '',A28)' ) CHIN(1:28)
      WRITE (IFREF, FMT = '(A28)' ) CHIN(1:28)
      NREF = 0
  240 CALL BINIFF (0, IBIN, FILENM, FITEMS, NIT, BUFI, NEND)
      IF (NEND .LT. 0) GOTO 270
      NREF = NREF + 1
      CALL HKLC1U (HCODE, HKL)
      CALL KERF2I (HKL, IHKL, 3)
      JC = 0
      IF (SIG .LT. 0.0) THEN
         SIG = ABS(SIG)
         JC = 2
         ENDIF
      IF (FOBS .LT. 5.0 * SIG) JC = 2
      CALL FREF9F(IFREF, IHKL(1), IHKL(2), IHKL(3), JC, FOBS, SIG, KEND)
      IF (KEND .EQ. 1) THEN
         WRITE (CHOUT, 260) IHKL, FOBS, SIGM
  260    FORMAT (' Fobs or sig for refl.', 3I3, ' to big ',
     *           'Fobs =',F10.0,' sig =',F10.0)
         CALL SHOUT
         ISTOP = 5
         ENDIF
      GOTO 240
  270 WRITE (IFREF, 280)
  280 FORMAT ('E')
      WRITE (LIS1, 300) NREF
  300 FORMAT (' Number of reflections (output): ', I14,/)
      CALL FILCLO (IFREF, 'KEEP')
      CALL FILCLO (IBIN, 'KEEP')
      RETURN
      END
      SUBROUTINE PRIFC
      CALL FOFC2 (ISTOP)
      IF (ISTOP .NE. 0) CALL KERROR
     *   ('Check stars (****) in output FREF-file',0,'PRIFC')
      RETURN
      END
      SUBROUTINE FOFC2 (ISTOP)
      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))
      EQUIVALENCE (  LIS1, IFILE( 7)),  ( LIS2,   IFILE( 8))
      EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC,   IFILE(13))
      EQUIVALENCE (IFREF, IFILE(12)), (ICRYS, IFILE(3))
      PARAMETER (MAXBUF = 198)
      DIMENSION       BUFFO(MAXBUF),       BUFFC(MAXBUF)
      DIMENSION   HKL(3),   IHKL(3), FITFO(3),  FITFC(2)
      EQUIVALENCE (HCODE, FITFO(1)),  (FOBS,   FITFO(2)),
     *            (  SIG, FITFO(3))
      EQUIVALENCE ( FCAL, FITFC(1)),    (PH,   FITFC(2))
      CHOUT = '0Output PRInt FCalc to LIS2'
      CALL SHOUT
      CALL RDCRYS (ICRYS)
      NITFC = 2
      NITFO = 3
      IREF = 0
      CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      CALL BINIFF (1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC)
      SCALE = BUFFC(18)
      WRITE(LIS2, FMT = '('' Scale applied to Fobs: '', F9.4)') SCALE
      WRITE(LIS2, FMT = '(
     * ''   h  k  l       Fobs   sigma  Fcalc  phase   sin(th)/L''/)')
  200 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
      IF (KENDFO.LT.0) GOTO 300
      IREF = IREF + 1
      CALL BINIFF (0, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC)
      CALL HKLC1U (HCODE, HKL)
      CALL HKLSTL (HKL, STL, STL2)
      CALL KERF2I (HKL, IHKL, 3)
      FOBS = FOBS * SCALE
      SIG = SIG * SCALE
      WRITE(LIS2,  FMT = '( 1X, 3I3, 2X, 2(F9.3, F7.2), F9.5)')
     * IHKL, FOBS, SIG, FCAL, PH, STL
      GOTO 200
 300  ISTOP = 0
      WRITE(LIS2,  FMT = '(1X)')
      WRITE(CHOUT, FMT = '('' Number of reflections '', I5)') IREF
      CALL SHOUT
      CALL FILCLO (IBINFO, 'KEEP')
      CALL FILCLO (IBINFC, 'KEEP')
      RETURN
      END
      SUBROUTINE FREF9F (IFIL, IH, IK, IL, JC, FF, SIG, KEND)
      CHARACTER * 1  CH(9)
      DATA CH /' ','2','3','4','5','6','7','8','9'/
      KEND = 0
      K = JC
      IF (JC.EQ.0) K = 1
      IF (JC.LT.0 .OR. JC.GT.9) K = 9
      IF (FF .LE. 9999.9 .AND. SIG .LE. 999.9) THEN
         WRITE (IFIL,161) IH,IK,IL, CH(K), FF, SIG
  161    FORMAT (1X,3I3,1X,A1,F9.4,F7.3)
      ELSE
         WRITE (IFIL,162) IH,IK,IL, CH(K), FF, SIG
  162    FORMAT (1X,3I3,1X,A1,F9.2,F7.2)
         IF (FF .GT. 999999.99 .OR. SIG .GT. 9999.99) KEND=1
         ENDIF
       RETURN
       END
      SUBROUTINE BIJVOE
      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 (IXYZN,  IFILE(1) ), (IATOMS, IFILE(2) )
      EQUIVALENCE (IRD,    IFILE(5) ), (IPR1,   IFILE(6) )
      EQUIVALENCE (LIS1,   IFILE(7) ), (LIS2,   IFILE(8) )
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINIA)
      CALL FILINQ (IXYZN, 'XYZN', 'FORMATTED', 'INPUT', KINIX)
      IF (KINIA .NE. 0 .AND. KINIX .NE. 0)
     * CALL KERROR( ' No ATOMS or XYZN file present ', 0, 'BIJVOE')
      IF (KINIA .EQ. 0 .AND. KINIX .NE. 0) GOTO 200
      IF (KINIA .NE. 0 .AND. KINIX .EQ. 0) GOTO 150
  110 WRITE (IPR1, 112)
  112 FORMAT (' Select one of the atomic input files: XYZN or ATOMS',
     * ' (X/A)')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 110
      IF (LIT(1)(1:1) .EQ. 'A') GOTO 190
      IF (LIT(1)(1:1) .NE. 'X') GOTO 110
  150 CALL X2AT
  190 CALL FILCLO (IXYZN, 'KEEP')
  200 CALL MERBIB
      CALL FCALCB
      CALL BIJVOX
      RETURN
      END
      SUBROUTINE MERBIB
      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 (ICRYS, IFILE(3))
      EQUIVALENCE (LIS1,   IFILE( 7))
      EQUIVALENCE (LIS2,   IFILE( 8))
      EQUIVALENCE (IFREF , IFILE(11))
      EQUIVALENCE (IHKL,   IFILE(11))
      EQUIVALENCE (IBINFO, IFILE(12))
      EQUIVALENCE (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
      PARAMETER (MAXA=6000, FMAXA=6000.)
      COMMON / / AREF(7, MAXA)
      DIMENSION HKL(3), HKL2(3), HMAX(3), HMIN(3)
      DIMENSION FITFO(3), FITFOB(5)
      EQUIVALENCE (FITFO(1),HCODEX), (FITFO(2),FOBS), (FITFO(3),SIG)
      EQUIVALENCE (FITFOB(1),HCODEF), (FITFOB(2),FOBSA),
     + (FITFOB(3),SIGA), (FITFOB(4),FOBSB), (FITFOB(5),SIGB)
      PARAMETER (MAXBUF = 198)
      DIMENSION BUFS(MAXBUF), BUFO(MAXBUF)
      PARAMETER (MAXP = 500)
      LOGICAL FRIE
      CHARACTER *1 IE
      DATA FRIE /.FALSE./
      DATA DF1MIN, DF2MIN / 0., 0. /
      CALL KERNZA (  9999., HMIN, 3)
      CALL KERNZA ( -9999., HMAX, 3)
      STLMAX = 0.0
      HCODMI = 4.0 * 256.**3
      HCODMA = - HCODMI
      CALL RDCRYS (ICRYS)
      WRITE (LIS1, FMT='(66X, A6)') CCODE
      WRITE (LIS2, FMT='(66X, A6)') CCODE
      WRITE (LIS2, FMT='(1X, ''SUBROUTINE MERBIB'')')
      IF (ICENT.EQ.2) CALL KERROR (' Space group is centrosymmetric, no
     +further calculations', 0, 'MERBIB')
      WRITE (LIS1,FMT='('' Wavelength of radiation'',41X,F7.5)') WAVE
      WRITE (LIS2,FMT='('' Wavelength of radiation'',41X,F7.5)') WAVE
      NIT = 3
      CALL BINOFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NEND)
      NREF = 0
      NNREF = 0
      MREF99 = 0
      CALL FILINQ (IFREF, 'FREFB', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) THEN
         CALL FILINQ (IFREF, 'FREF', 'FORMATTED', 'INPUT', KINQA)
         IF (KINQA .NE. 0)
     *      CALL KERROR ('No FREF or FREFB file found', 0, 'MERBIB')
         ENDIF
      CHIN = ' '
      READ (IFREF, FMT='(A28)') CHIN(1:28)
      WRITE (LIS1, 124) CHIN(1:28)
  124 FORMAT (' Input reflection file is:', 3X, A28)
      CALL KERINB (LIT, 1)
      IF (KINQ .EQ. 0) THEN
         IF (LIT(1) .NE. 'FREFB') CALL KERROR
     *      ('Header of input file is not = FREFB =' , 0, 'MERBIB')
         IF (LIT(2) .NE. CCODE) CALL KERROR
     *      ('Input file has incorrect CCODE', -6, 'MERBIB')
         ENDIF
  130 READ (IFREF, 131) IE, HKL, JC, FOBS, SIG
  131 FORMAT (A1, 3F3.0 ,I2, F9.2, F7.2)
      IF(IE .EQ. 'E') GOTO 200
      CALL HKLAXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 130
      CALL HKLEXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 130
      MREF99 = MREF99 + 1
      IF (ABS (HKL(1)) .GT. 99. .OR. ABS (HKL(2)) .GT. 99. .OR.
     *    ABS (HKL(3)) .GT. 99. ) GOTO 130
      DO 143 I=1,3
  143 HKL2(I)= -HKL(I)
      CALL HKLEXS (FRIE, HKL , HCODE1)
      CALL HKLEXS (FRIE, HKL2, HCODE2)
      IF (ILAUE .GE. 6 .AND. ILAUE .LE. 12) THEN
         H99 = AMAX1 ( ABS(HCODE1), ABS(HCODE2) )
         IF (H99 .GT. 3920000.) GOTO 130
         ENDIF
      NREF = NREF + 1
      IF (NINT(HCODE1) .EQ. NINT(HCODE2)) GOTO 130
      IF (HCODE1.GT.HCODE2)  THEN
         HCODEX = HCODE1
      ELSE
         HCODEX = -HCODE2
         ENDIF
      HCODEF = ABS(HCODEX)
      FOBS = AMAX1 (FOBS, SIG / 1000. , 0.001)
      SIG  = AMAX1 (SIG, FOBS / 1000. , 0.001)
      IF (JC .EQ. 2) SIG = AMAX1(FOBS/6.0, SIG)
      SIG = SIG * 2. * FOBS
      FOBS = FOBS**2
      HCODMI = AMIN1(HCODMI, HCODEF)
      HCODMA = AMAX1(HCODMA, HCODEF)
      CALL HKLC1U (HCODEF, HKL)
      DO 150 I =1,3
      HMAX(I) = AMAX1 (HKL(I),HMAX(I))
  150 HMIN(I) = AMIN1 (HKL(I),HMIN(I))
      CALL HKLSTL (HKL, STL, STL2)
      STLMAX = AMAX1(STLMAX, STL)
      NNREF = NNREF + 1
      CALL BINOFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, NEND)
      GOTO 130
  200 CALL FILCLO (IFREF, 'KEEP')
      CALL BINOFF (-1, IBINS, 'BINS', FITFO, NIT, BUFS, NEND)
      WRITE (LIS1, 301) NREF
      WRITE (LIS2, 301) NREF
  301 FORMAT(' Number of reflections from input file ', 27X, I6)
      MREF99 = MREF99 - NREF
      IF (MREF99 .GT. 0) WRITE (LIS1, 303) MREF99
  303 FORMAT (' Number of relections with hkl exceeding 99:  ', I7/
     *        ' WARNING: these reflections are not used in BIJVOET!'/)
      BUFO(5) = 0.
      BUFO(6) = STLMAX
      CALL KERNZA (0., BUFO(7), 3)
      CALL KERNAB (HMAX,  BUFO(10), 3)
      CALL KERNAB (HMIN,  BUFO(13), 3)
      NITB = 5
      CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ)
      IF (KINQ .EQ. 0) THEN
         CALL FILCLO (IBINFO, 'DELETE')
         WRITE (CHOUT, FMT = '('' The file BINFO is erased'')')
         CALL SHOUT2
         ENDIF
      CALL BINOFF (15, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDO)
      CALL BINIFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI)
      CALL HKLC2I (HMIN, HMAX)
      CALL HKLC1U (HCODMI, HKL)
      CALL HKLC2  (HKL, ACODMI)
      NREW = 0
      IPAIR = 0
      KPAIR = 0
      SDF1 = 0.
      SDF2 = 0.
      NDF1 = 0
      NDF2 = 0
      NDF3 = 0
      NDF4 = 0
  310 AF = ACODMI - 1.1
      CALL HKLC2U (ACODMI + FMAXA - 1., HKL)
      CALL HKLC1  (HKL, HCODEL)
      CALL KERNZA (0.0, AREF, 7 * MAXA)
  320 CALL BINIFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI)
      IF (NENDI .LT. 0 ) GOTO 325
      HCODEF = ABS(HCODEX)
      IF (HCODEF.LT.HCODMI .OR.
     *    HCODEF.GT.HCODEL) GOTO 320
      CALL HKLC1U (HCODEF, HKL)
      CALL HKLC2  (HKL, ACODE)
      IA = IFIX (ACODE - AF)
      AREF(1,IA) = HCODEF
      IF (HCODEX.LT.0.1) GOTO 323
      AREF(2,IA) = AREF(2,IA) + 1.
      AREF(3,IA) = AREF(3,IA) + FOBS
      AREF(4,IA) = AREF(4,IA) + SIG
      GOTO 320
  323 AREF(5,IA) = AREF(5,IA) + 1.
      AREF(6,IA) = AREF(6,IA) + FOBS
      AREF(7,IA) = AREF(7,IA) + SIG
      GOTO 320
  325 IF (NREW .GT. 0) GOTO 330
      NREW = NREW + 1
      IF (NNREF .LT. 500) GOTO 330
      DO 328 I = 1,MAXA
      IF (AREF(2,I) .LE. 0.1 .OR. AREF(5,I).LE.0.1) GOTO 328
      IPAIR = IPAIR + 1
      FOBSA  = SQRT( AREF(3,I) / AREF(2,I) )
      SIGA   = AREF(4,I) / AREF(2,I)**1.5  / (2. * FOBSA)
      FOBSB  = SQRT( AREF(6,I) / AREF(5,I) )
      SIGB   = AREF(7,I) / AREF(5,I)**1.5  / (2. * FOBSB)
      SDF1 = SDF1 + ABS(FOBSA - FOBSB) / (0.5 * (FOBSA + FOBSB))
      SDF2 = SDF2 + ABS(FOBSA - FOBSB) / SQRT( SIGA**2 + SIGB**2)
  328 CONTINUE
      DF1MIN = 0.25 * SDF1 / FLOAT(IPAIR)
      DF2MIN = SDF2 / FLOAT(IPAIR)
      DF2MIN = 0.5 * (DF2MIN + 1.0)
      IPAIR = 0
  330 DO 340 I = 1,MAXA
      IF (AREF(2,I) .LE. 0.1 .OR. AREF(5,I).LE.0.1) GOTO 340
      IPAIR = IPAIR + 1
      HCODEF = AREF(1,I)
      FOBSA  = SQRT( AREF(3,I) / AREF(2,I) )
      SIGA   = AREF(4,I) / AREF(2,I)**1.5  / (2. * FOBSA)
      FOBSB  = SQRT( AREF(6,I) / AREF(5,I) )
      SIGB   = AREF(7,I) / AREF(5,I)**1.5  / (2. * FOBSB)
      IF (NNREF .LT. 500) GOTO 332
      DF1 = ABS (FOBSA - FOBSB) / (0.5 * (FOBSA + FOBSB))
      DF2 = ABS(FOBSA - FOBSB) / SQRT( SIGA**2 + SIGB**2)
      IF (DF1.LT.DF1MIN) NDF1 = NDF1 + 1
      IF (DF2.LT.DF2MIN) NDF2 = NDF2 + 1
      IF (DF1.LT.DF1MIN .AND. DF2 .LT. DF2MIN) NDF3 = NDF3 + 1
      IF (DF1.LT.DF1MIN) GOTO 340
      IF (DF2.LT.DF2MIN) GOTO 340
  332 CALL BINOFF (0, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDO)
      KPAIR = KPAIR + 1
  340 CONTINUE
      IF (HCODEL.GE.HCODMA) GOTO 350
      ACODMI = ACODMI + FMAXA
      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', FITFOB, NITB, BUFO, NENDO)
      IF (IPAIR.EQ.0) CALL KERROR (' No Bijvoet pairs found, no further
     *calculations', 0, 'MERBIB')
      WRITE (LIS1, 352) IPAIR
      WRITE (LIS2, 352) IPAIR
  352 FORMAT (' Number of Bijvoet pairs ', 41X, I6)
      IF (NNREF .LT. 500) GOTO 360
      WRITE (LIS2, FMT='(/,'' Selection of Bijvoet pairs on'',
     * '' dFo = Fo(h) - Fo(-h)'',/, 3X,
     * '' with sig(dFo) = sqrt(sig(Fo(h))**2 + sig(Fo(-h))**2)'',
     * /, 29X, ''rejection criterion'', 9X, ''number of pairs'')')
      WRITE (LIS2, FMT='(
     * ''    abs(dFo)/(0.5*(Fo(h)+Fo(-h))         <'', F6.3, 18X, I6)')
     * DF1MIN, NDF1
      WRITE (LIS2, FMT='(
     * ''    abs(dFo)/sig(dFo)'',20X,''<'',F6.3,18X,I6)')  DF2MIN, NDF2
      WRITE (LIS2, FMT='(
     * ''    abs(dFo)/(0.5*((Fo(h)+Fo(-h)))       <'',F6.3, '' and'',/,
     * ''    abs(dFo)/sig(dFo)'',20X,''<'', F6.3, 18X, I6)')
     * DF1MIN, DF2MIN, NDF3
      WRITE (LIS2, 354) KPAIR
  354 FORMAT (' Number of Bijvoet pairs selected on dFo', 26X, I6)
      IF (KPAIR .GT. MAXP) WRITE (LIS2, 357) MAXP
  357 FORMAT (' Number of pairs used is limited to', 31X, I6)
  360 CALL FILCLO (IBINS, 'DELETE')
      RETURN
      END
      SUBROUTINE FCALCB
      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)), (ICRYS, IFILE(3))
      EQUIVALENCE (LIS1,   IFILE(7)), (LIS2,  IFILE(8))
      EQUIVALENCE (IBINFO, IFILE(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 /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 (MAXP = 500, MAXAT = 993, MAXSCS = 3000)
      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,
     *            PAIRS (6, MAXP), MPAIR, SCS(2,MAXSCS)
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      CHARACTER *6 ATNAME(MAXAT)
      DIMENSION FITFOB(5), FITB(6)
      EQUIVALENCE (FITFOB(1),HCODEF),
     *            (FITFOB(2), FOBSA), (FITFOB(3), SIGA),
     *            (FITFOB(4), FOBSB), (FITFOB(5), SIGB)
      EQUIVALENCE (FPF, PHIP)
      PARAMETER (MAXBUF = 198)
      DIMENSION BUFO(MAXBUF)
      DATA ST1, ST2, ST6, ST4, ST5, STO, STC / 0.,0.,0.,0.,0.,0.,0./
      FNSYMM = FLOAT (NSYMM)
      FICENT = FLOAT (ICENT)
      CALL KERNZA (0., PAIRS, 6*MAXP)
         WRITE (LIS2, FMT='(/,1X, ''SUBROUTINE FCALCB'',/)')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('No ATOMS file found', 0, 'FCALCB')
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL ATOMPR (LIS2, 7, ATXYZ, ATNAME, IZAT, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
      WRITE (LIS1, 115) NAT
  115 FORMAT (' Number of atoms from input file', I40)
      IF (KEYT.EQ.1) CALL KERROR
     *   ('No temp.factors given: no further calculations', 0, 'FCALCB')
      CHOUT = '    Atoms have mixed/anisotropic temperature factors '
      IF (KEYT.EQ.2) CHOUT =
     *   '    Atoms have individual isotropic temperature factors'
      CALL SHOUT2
      BDFT = 0.
      BDFN = 0.
      DO 110 I=1,NTYPE
      CALL RDCRYB(ICRYS, 'ELEM ', KEND)
      IF (KEND .LE. 0) CALL KERROR ('Error in CRYSDA file', 0, 'FCALCB')
      READ (CHIN, FMT='(10X, 2X, I8)') IZTYPE(I)
      CALL RDCRYX (ICRYS, 'SFAC  ', SFAC(1,I), 13)
      BDFT = BDFT + CELALL(I) * SFAC(11,I)**2
      BDFN = BDFN + CELALL(I) * IZTYPE(I)**2
  110 CONTINUE
      BDF= SQRT(BDFT / BDFN)
      WRITE (LIS2, FMT='(/,'' Anomalous scattering fraction '',
     * ''of the structure '' , /,
     * 3X, '' sqrt(sum(Df"**2) / sum(Z**2)) ='', 29X, F8.5)') BDF
      NPAIR = 0
      NITB = 5
      CALL BINIFF (1, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDI)
      STLMAX = BUFO(6)
      CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT)
      CALL FILCLO (ICRYS, 'KEEP')
      MPAIR = 0
      SUMDFC = 0.
      SUMFC = 0.
      SUMFO = 0.
      SUMSIG= 0.
      BQ1 = 0.
      BQ2 = 0.
  200 CALL BINIFF (0, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDI)
      IF (NENDI.LT.0) GOTO 220
      NPAIR = NPAIR + 1
      DFO = FOBSA - FOBSB
      SIG2 = SIGA**2 + SIGB**2
      CALL HKLC1U (HCODEF, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      CALL FCALB1 (KEYT, ATXYZ, ITAT, NAT)
      DFC = FP - FPF
      FITB(1) = ABS(DFC * DFO / SIG2)
      FITB(2) = HCODEF
      FITB(3) = DFC
      FITB(4) = DFO
      FITB(5) = SIG2
      FITB(6) = (FP**2 + FPF**2) * 0.5
      CALL SORTP(FITB, 6, PAIRS, MAXP, MPAIR)
      SUMDFC = SUMDFC + ABS(DFC)
      SUMFC = SUMFC + FP + FPF
      SUMFO = SUMFO + FOBSA + FOBSB
      IF (NPAIR .LE. MAXSCS) THEN
         SCS(1,NPAIR) = DFC
         SCS(2,NPAIR) = DFO
         SUMSIG= SUMSIG + SQRT(SIG2)
         ENDIF
      BQ1 = BQ1 + DFC**2
      BQ2 = BQ2 + FITB(6)
      GOTO 200
  220 CONTINUE
      CALL FILCLO (IBINFO, 'DELETE')
      DFCMIN = AMAX1 (0.005, 0.5 * SUMDFC/FLOAT(NPAIR) )
      SC = SUMFC / SUMFO
      IF (NPAIR .GT. MAXSCS) NPAIR = MAXSCS
      SUMDDF = 0.
      DO 222 I=1,NPAIR
      SUMDDF = SUMDDF + ABS(ABS(SCS(1,I)) - ABS(SCS(2,I)*SC))
  222 CONTINUE
      SCSIG = SUMDDF / (SUMSIG * SC)
      BQ = SQRT (BQ1 / BQ2)
      WRITE (LIS2, FMT = '( /
     * '' Anomalous scattering '',
     * ''fraction for the selected Bijvoet pairs'',
     * /,3X, '' sqrt(sum(dFc**2) / sum(Fc)**2) ='', 28X, F8.5)') BQ
      WRITE (LIS2, FMT = '( /,
     * '' Scale factor'', /
     * 4X, ''SC = sumFc / sumFo = '', 39X, F8.4)')  SC
      WRITE (LIS2,FMT='(4X,''SCSIG = sum||dFc|-|dFo||/sum sig(dFo) ='',
     *   19X, F10.4)') SCSIG
      IF (SCSIG .GT. 3.0)    WRITE (LIS1, FMT='(
     *    '' Warning: your SIG(Fobs) are probably underestimated!'')')
      WRITE (LIS2, FMT = '( /
     * '' Sorting Bijvoet pairs on |BT|=|dFc*dFo/sig(dFo)**2|'')')
      L = 0
      DO 230 I=1,MPAIR
      IF (ABS(PAIRS(3,I)) .LT. DFCMIN) GOTO 230
      L = L + 1
      PAIRS(2,L) = PAIRS(2,I)
      PAIRS(3,L) = PAIRS(3,I)
      PAIRS(4,L) = PAIRS(4,I) * SC
      PAIRS(5,L) = PAIRS(5,I) * SC * SC
      PAIRS(6,L) = PAIRS(6,I)
      PAIRS(1,L) = PAIRS(3,L) * PAIRS(4,L) / PAIRS(5,L)
  230 CONTINUE
      WRITE (LIS2, FMT = '(/, '' Selection of Bijvoet pairs on '',
     * ''dFc = Fc(h) - Fc(-h)'')')
      WRITE (LIS2, 231)  DFCMIN, MPAIR -L
  231 FORMAT (' Number of Bijvoet pairs with abs(dFc) <',
     * F6.3, 20X, I6)
      WRITE (LIS2, 232) L
  232 FORMAT (' Number of Bijvoet pairs selected on dFc and dFo',
     * 18X, I6)
      MPAIR = L
      IF (NPAIR .GT. MPAIR) WRITE (LIS1, 241) MPAIR
  241 FORMAT (' Number of Bijvoet pairs ',
     * 'selected for the calculation of B', I14)
      WRITE (LIS2, FMT='(/'' Statistics for '', I6, '' pairs '',
     * ''in batches of 25 '', /,
     * ''    (a)    average |Fc(h) - Fc(-h)|'',/
     * ''    (b)    average |Fo(h) - Fo(-h)|'',/
     * ''    (d)    average |Fo(h) - Fo(-h)| /sig(dFo)'')') MPAIR
      WRITE (LIS2, FMT='(
     * ''    (e)    percentage of positive values dFc'',/
     * ''    (f)    percentage of positive values dFo'',/
     * ''    (g)    SQRT (sum dFc**2 / sum Fc**2) '')')
      WRITE (LIS2, FMT='(/, 1X,
     * ''     ----------cumulative----------------'',
     * ''  -----individual badges------'', /,
     * ''        a     b     d   e   f     g    a/b '',
     * ''   a     b     d     g    a/b '')')
      SSSDFC = 0.
      SSSDFO = 0.
      SSUMDS = 0.
      STELC = 0.
      STELO = 0.
      ST5T = 0.
      ST5N = 0.
      SUMDFC = 0.
      SUMDFO = 0.
      SUMDS = 0.
      T5T = 0.
      T5N = 0.
      DO 460 I = 1, MPAIR
      FNFR = FLOAT(I)
      SUMDFC = SUMDFC + ABS(PAIRS(3,I))
      SUMDFO = SUMDFO + ABS(PAIRS(4,I))
      SUMDS = SUMDS + ABS(PAIRS(4,I)) / SQRT(PAIRS(5,I))
      IF (PAIRS(3,I) .GT. 0.) STELC = STELC + 1.
      IF (PAIRS(4,I) .GT. 0.) STELO = STELO + 1.
      T5T = T5T + PAIRS(3,I)**2
      T5N = T5N + PAIRS(6,I)
      IF (MPAIR.LT.25 .AND. I.EQ.MPAIR) THEN
         FMPAIR = FLOAT(MPAIR)
         T1  = SUMDFC / FMPAIR
         T2  = SUMDFO / FMPAIR
         T4  = SUMDS  / FMPAIR
         T5 = SQRT (T5T / T5N)
         T6 = T1 / T2
         GOTO 420
         ENDIF
      IF (MOD(I, 25) .NE. 0) GOTO 460
      T1  = SUMDFC / 25.
      T2  = SUMDFO / 25.
      T4  = SUMDS  / 25.
      T5 = SQRT (T5T / T5N)
      T6 = T1 / T2
      SSSDFC = SSSDFC + SUMDFC
      SSSDFO = SSSDFO + SUMDFO
      SSUMDS = SSUMDS + SUMDS
      ST5T = ST5T + T5T
      ST5N = ST5N + T5N
      ST1  = SSSDFC / FNFR
      ST2  = SSSDFO / FNFR
      ST4  = SSUMDS  / FNFR
      STC = 100. * STELC / FNFR
      STO = 100. * STELO / FNFR
      ST5 = SQRT (ST5T / ST5N)
      ST6 = ST1 / ST2
  420 WRITE (LIS2, 430) I, ST1, ST2, ST4, STC, STO, ST5, ST6,
     *                  T1, T2, T4,  T5, T6
  430 FORMAT (I4, 3F6.2, 2F4.0, F6.3, F6.3,  3F6.2, F6.3, F6.3 )
      SUMDFC = 0.
      SUMDFO = 0.
      SUMDS = 0.
      T5T = 0.
      T5N = 0.
  460 CONTINUE
      RETURN
      END
      SUBROUTINE FCALB1  (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 /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))
      EQUIVALENCE (LIS2,   IFILE( 8))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  MOLW,       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))
      EQUIVALENCE (PHIP, FPF)
      DIMENSION FFF(10), ADTRIG(24)
      DATA  ADTRIG / 24*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 A = 0.0
      B = 0.0
      AF = 0.0
      BF = 0.0
      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)
      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
      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
      A  = A + A1 * FFF(IJ)     * TF
      B  = B + B1 * SFAC(11,IJ) * TF
      AF = AF+ A2 * SFAC(11,IJ) * TF
      BF = BF+ B2 * FFF(IJ)     * TF
  250 CONTINUE
      FP = ASYMCL * SQRT((A + AF)**2 + (B + BF)**2)
      FPF= ASYMCL * SQRT((A - AF)**2 + (B - BF)**2)
      RETURN
      END
      SUBROUTINE SORTP (A, NA, B, NB, M)
      DIMENSION A(NA), B(NA, NB)
      IF (M .EQ. NB) THEN
         IF (A(1) .LE. B(1, NB)) RETURN
         GOTO 400
         ENDIF
      M = M + 1
      IF (M .EQ. 1) GOTO 482
  400 DO 480 K = M, 2, -1
      IF (A(1) .LE. B(1, K-1)) GOTO 483
      CALL KERNAB (B(1, K-1), B(1, K), NA)
  480 CONTINUE
  482 K = 1
  483 CALL KERNAB (A, B(1, K), NA)
      RETURN
      END
      SUBROUTINE BIJVOX
      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))
      EQUIVALENCE (LIS2,   IFILE( 8))
      PARAMETER (MAXP = 500, 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,
     *            PAIRS (6, MAXP), MPAIR
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), SICO(1))
      DIMENSION HKLT(3), IHKL(3)
      CHARACTER ADFO *1, ABTAV *1
      DIMENSION MODA(5), MODB(5), MODC(5)
      DATA MODA /  3,  5,  8,  12,  18 /
      DATA MODB /  3,  8, 16,  28,  46 /
      DATA MODC / 30, 50, 90, 150, 230 /
      DATA MSEL, BSEL, SIGSEL, PSEL / 0, 0., 0., 0. /
      BTAV1 = 0.
      II = MIN0(25, MPAIR)
      DO 104 I = 1,II
  104 BTAV1 = BTAV1 + ABS(PAIRS(1,I))
      BTMIN1 = 2.*BTAV1/FLOAT(II)
      BTAV2 = 0.
      DO 106 I = 1,II
  106 BTAV2 = BTAV2 + AMIN1(BTMIN1, ABS(PAIRS(1,I)))
      BTMIN = 2.*BTAV2/FLOAT(II)
      WRITE (LIS2, FMT='(/ '' SUBROUTINE BIJVOX'')')
      WRITE (LIS2, FMT='('' Bijvoet calculations'' / )')
      WRITE (LIS2, FMT='('' Values of abs(dFo) if >'',
     * '' abs(dFc) + 3 sig(dFo) are cut off to this value '' )')
      WRITE (LIS2, FMT='('' Values of '',
     * ''BT=|dFc*dFo|/sig(dFo)**2  >'', F8.2,
     * '' are cut off to this value'')') BTMIN
      WRITE (LIS2, FMT='(/,'' Statistics of the first 25 '',
     * '' Bijvoet pairs (cut off values are marked +)'')')
      WRITE (LIS2, FMT='( ''    H  K  L       <Fc>      dFc      dFo'',
     * ''   sig(dFo)     BT     Bcumul '')')
      MFR = 0
      MFR25 = 0
      I25 = 0
      SUMP = 0.0
      SUMQ = 0.0
      SUMR = 0.0
      SUMP25 = 0.0
      SUMQ25 = 0.0
      SUMR25 = 0.0
      DO 150 I=1,MPAIR
      MFR  = MFR + 1
      MFR25  = MFR25 + 1
      DFC  = PAIRS(3,I)
      DFO  = PAIRS(4,I)
      SIG2 = PAIRS(5,I)
      SIG  = SQRT(SIG2)
      IF (ABS(DFO) .GT. ABS(DFC) + 3.* SIG)  THEN
         DFO = (ABS(DFC) + 3. * SIG) * DFO / ABS(DFO)
         ADFO = '+'
      ELSE
         ADFO = ' '
         ENDIF
      BT = DFC * DFO / SIG2
      IF (MFR.LE.25) THEN
         QQ = ABS(BTMIN/BT)
         IF(QQ .LT. 1.) THEN
            BT = BT * QQ
            ABTAV = '+'
         ELSE
            ABTAV = ' '
            ENDIF
         ENDIF
      SUMP = SUMP + BT
      SUMQ = SUMQ + ABS(BT)
      SUMR = SUMR + DFC**2 / SIG2
      SUMP25 = SUMP25 + BT
      SUMQ25 = SUMQ25 + ABS(BT)
      SUMR25 = SUMR25 + DFC**2 / SIG2
      IF (MFR .LE. 25) THEN
         HCODEF = PAIRS(2,I)
         SQ = SQRT(PAIRS(6,I))
         CALL HKLC1U (HCODEF, HKLT)
         CALL KERF2I (HKLT, IHKL, 3)
         BCUM = SUMP/SUMQ
         WRITE (LIS2, FMT='(1X, I4, 2I3, 3X, 3F9.4, A1, F8.4,
     *    F10.4, A1, F8.2)')
     *    (IHKL(J), J=1,3), SQ, DFC, DFO, ADFO, SIG, BT, ABTAV, BCUM
         ENDIF
      IF (MOD(MFR, 25) .NE. 0) GOTO 150
      I25 = I25 + 1
      B = SUMP/SUMQ
      SIGB = (1. - ABS(B)) * SQRT(SUMR)/SUMQ
      IF (SIGB .LT. 0.0001) SIGB = 0.0001
      BS = 2. * B / SIGB
      ARGPA = 0.707107 * ABS(BS)
      PPA = ERFU(ARGPA)
      B25 = SUMP25/SUMQ25
      SIGB25 = (1. - ABS(B25)) * SQRT(SUMR25)/SUMQ25
      IF (SIGB25 .LT. 0.0001) SIGB25 = 0.0001
      BS25 = 2. * B25 / SIGB25
      MFR25 = 0
      SUMP25 = 0.0
      SUMQ25 = 0.0
      SUMR25 = 0.0
      IF (MFR .NE. 25) GOTO 120
      WRITE (LIS2,FMT='(/,'' Statistics in batches of 25 pairs'',/,
     * ''       ------cumulative------------'',
     * ''     ---individual-batches---'')')
      WRITE (LIS2,FMT='('' pairs'', 5X,''B   sig(B) 2B/sig(B)'',
     * '' Prob        B   sig(B) 2B/sig(B)'')')
  120 IF (BS .GT. 999.9) BS = 999.99
      IF (BS25 .GT. 999.9) BS25 = 999.99
      IF (BS .LT. -999.9) BS = -999.99
      IF (BS25 .LT. -999.9) BS25 = -999.99
      WRITE (LIS2, FMT=' (I5, F8.3, F7.3, F9.2, F6.3, 3X,
     *  F8.3, F7.3, F9.2)')
     *    MFR, B, SIGB, BS, PPA, B25, SIGB25, BS25
      IF (MFR .NE. 100) GOTO 150
      MSEL = 100
      BSEL = B
      SIGSEL = SIGB
      PSEL = PPA
  150 CONTINUE
      WRITE (LIS2, FMT='(/'' A better choice of batches: '')')
      WRITE (LIS1, FMT='(/'' Calculation of the BIJVOET'',
     * '' coefficients (B) and their probabilities (Prob)'')')
      DO 200 I = 1, 5
      IF (MODC(I) .GE. MPAIR) GOTO 202
  200 CONTINUE
      I = 5
      MPAIR = MODC(5)
  202 MODC(I) = MPAIR
      IF (I .EQ. 1) GOTO 210
      DO 204 K = 1, I-1
      MODC(K) = NINT (FLOAT(MPAIR * MODA(K)) / FLOAT(MODB(I)))
  204 MODC(I) = MODC(I) - MODC(K)
  210 MODB(1) = MODC(1)
      IF (I .EQ. 1) GOTO 220
      DO 214 K = 2, I
  214 MODB(K) = MODB(K-1) + MODC(K)
  220 NBAT = I
      SUMP = 0.
      SUMQ = 0.
      SUMR = 0.
      IPAIR = 0
      WRITE (LIS1, 222) NBAT
      WRITE (LIS2, 222) NBAT
  222 FORMAT (/ ' ----------cumulative--------------    --------',
     * I2, ' individual batches----' /
     *  ' pairs    B   sig(B) 2B/sig(B) Prob ',
     * '  pairs    B   sig(B) 2B/sig(B) Prob ')
      DO 320 I = 1, NBAT
      BSUMP = 0.
      BSUMQ = 0.
      BSUMR = 0.
      KBAT = MODB(I)
      KBBAT = MODC(I)
  310 IPAIR = IPAIR + 1
      DFC  = PAIRS(3,IPAIR)
      DFO  = PAIRS(4,IPAIR)
      SIG2 = PAIRS(5,IPAIR)
      SIG  = SQRT(SIG2)
      IF (ABS(DFO) .GT. ABS(DFC) + 3.* SIG)  THEN
         DFO = (ABS(DFC) + 3. * SIG) * DFO / ABS(DFO)
         PAIRS(4,IPAIR) = DFO
         ENDIF
      BT = DFC * DFO / SIG2
      IF (IPAIR .LE. 25) THEN
         QQ = ABS(BTMIN/BT)
         IF(QQ .LT. 1.) THEN
            BT = BT * QQ
            ENDIF
         ENDIF
      PAIRS(1,IPAIR) = BT
      BSUMP = BSUMP + PAIRS(1,IPAIR)
      BSUMQ = BSUMQ + ABS(PAIRS(1,IPAIR))
      BSUMR = BSUMR + PAIRS(3,IPAIR)**2 / PAIRS(5,IPAIR)
      IF (IPAIR .LT. KBAT) GOTO 310
      SUMP = SUMP + BSUMP
      SUMQ = SUMQ + BSUMQ
      SUMR = SUMR + BSUMR
      BBAT = SUMP / SUMQ
      SIGB = (1. - ABS(BBAT)) * SQRT (SUMR) / SUMQ
      SIGM = AMAX1(SIGB, 0.002 * ABS(BBAT))
      BBSS = 2. * BBAT / SIGM
      IF (BBSS .GT. 999.99) BBSS = 999.99
      IF (BBSS .LT.-999.99) BBSS =-999.99
      IF (SIGB .LT. 0.0001) SIGB = 0.0001
      ARGPA = 0.707107 * ABS(BBSS)
      PA = ERFU(ARGPA)
      BBBAT = BSUMP / BSUMQ
      BSIGB = (1. - ABS(BBBAT)) * SQRT (BSUMR) / BSUMQ
      BSIGM = AMAX1(BSIGB, 0.002 * ABS(BBBAT))
      BBBSS = 2. * BBBAT / BSIGM
      IF (BBBSS .GT. 999.99) BBBSS = 999.99
      IF (BBBSS .LT.-999.99) BBBSS =-999.99
      IF (BSIGB .LT. 0.0001) BSIGB = 0.0001
      ARGPA = 0.707107 * ABS(BBBSS)
      BPA = ERFU(ARGPA)
      WRITE (LIS1, 318) KBAT, BBAT, SIGB, BBSS,  PA,
     * KBBAT, BBBAT, BSIGB, BBBSS, BPA
      WRITE (LIS2, 318) KBAT, BBAT, SIGB, BBSS,  PA,
     * KBBAT, BBBAT, BSIGB, BBBSS, BPA
  318 FORMAT ( 2(I5, F8.3, F7.3, F8.2,  F7.3, 2X))
      IF (I .LT. NBAT) GOTO 320
      IF (MPAIR .GT. 100) GOTO 320
      MSEL = MPAIR
      BSEL = BBAT
      SIGSEL = SIGB
      PSEL = PA
  320 CONTINUE
      WRITE (LIS1, 321) MSEL, BSEL, SIGSEL, PSEL
      WRITE (LIS2, 321) MSEL, BSEL, SIGSEL, PSEL
  321 FORMAT (/ ' The Bijvoet coefficient for the strongest', I4,
     * ' Bijvoet pairs is' / ' B = ' ,   F6.3,'(', F5.3,')  ',
     * ' and its probability is ' ,   F6.3 /)
      IF (PSEL .GT. 0.999) THEN
         IF (BSEL .GT. 0.0) THEN
            WRITE (LIS1, 325)
            WRITE (LIS2, 325)
  325     FORMAT (' The atomic parameters of the structure are in ',
     *        'agreement with its ' / ' absolute configuration.' / )
         ELSE
            WRITE (LIS1, 326)
            WRITE (LIS2, 326)
  326     FORMAT (' The atomic parameters of the structure have to be ',
     *         'inverted' /
     *         ' to be in agreement with its absolute configuration.'/)
            ENDIF
         RETURN
         ENDIF
      IF (BSEL .GT. 0.0) THEN
         WRITE (LIS1, 327)
         WRITE (LIS2, 327)
  327 FORMAT (' The atomic parameters of the structure are in ',
     * 'agreement with' / ' its absolute configuration,' /
     * ' but inspect the Bijvoet coefficients to judge the validity.'/)
      ELSE
         WRITE (LIS1, 328)
         WRITE (LIS2, 328)
  328    FORMAT (' The atomic parameters of the structure have to be ',
     *      'inverted' /
     *      ' to be in agreement with its absolute configuration,' /
     * ' but inspect the Bijvoet coefficients to judge the validity.'/)
         ENDIF
      IF (PSEL .LT. 0.95) THEN
          WRITE (LIS1, 425)
          WRITE (LIS2, 425)
  425     FORMAT (' Be careful !' /)
          ENDIF
      RETURN
      END
      SUBROUTINE SHAT
      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 (IRD,    IFILE(5) )
      EQUIVALENCE (IPR1,   IFILE(6) )
      EQUIVALENCE (LIS1,   IFILE(7) )
      EQUIVALENCE (IATOLD, IFILE(10))
      PARAMETER       (NSLOT = 10, MAXAT = 2513)
      COMMON /  /     DUMMY(1),
     *                ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DIMENSION SHIFT (3)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. -1) CALL KERROR(' No ATOMS file found', 0,' SHAT')
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT)
  120 WRITE (IPR1, FMT = '('' Enter the shift vector (tx ty tz)'')')
      CALL KETERM (3, -1, KEND)
      IF (KEND .LT. 0 ) GOTO 120
      CALL KERNAB (FNUM, SHIFT, 3)
      WRITE (CHOUT, FMT = '('' Shift vector applied: '',3F8.4)') SHIFT
      CALL SHOUT2
      REWIND IATOMS
      DO 200 J = 1,NAT
      DO 200 I = 1,3
  200 ATXYZ(I,J) = ATXYZ(I,J) + SHIFT(I)
      WRITE (CHOUT, FMT = '(''REMARK Shift vector: '',3F8.2)') SHIFT
      CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT)
      CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
      RETURN
      END
      SUBROUTINE EULER
      CALL EULERC
      RETURN
      END
      SUBROUTINE EULERC
      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 (IATMOD, IFILE(1))
      EQUIVALENCE (IATOMS, IFILE(2))
      EQUIVALENCE (IATOLD, IFILE(10))
      EQUIVALENCE (ICRYS,  IFILE(3))
      EQUIVALENCE (IPR1,   IFILE(6))
      EQUIVALENCE (LIS1,   IFILE(7))
      EQUIVALENCE (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)
      PARAMETER (MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(10, MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(2513)
      CHARACTER * 6   ATNAME
      DIMENSION  RR(3,3)
      WRITE(IPR1, FMT = '('' Preliminary version'')')
      CALL RDCRYS (ICRYS)
      CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .LT.  0) CALL KERROR ('No ATMOD file', 0, 'EULER')
      CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL KERINB (LIT, 1)
      IF (LIT(2) .NE. 'CARTX' .AND. LIT(2) .NE. 'CART')
     *   CALL KERROR ('No CART or CARTX on ATMOD header', 0, 'EULER')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .GE. 0) THEN
         CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
         ENDIF
      CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT)
  260 WRITE (IPR1, FMT = '('' Please, supply three Eulerian angles'')')
      CALL KETERM ( 3, 0, KEND)
      IF (KEND .LT. 0) GOTO 260
      AIN = FNUM(1)
      BIN = FNUM(2)
      CIN = FNUM(3)
      WRITE (LIS1, FMT = '('' Euler angles: '',3F7.2)') AIN, BIN, CIN
      CALL MATABC (AIN, BIN, CIN, RR)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (CHOUT, FMT = '('' ABC = '', 3F7.2)') AIN, BIN, CIN
      CALL ATOMWA (IATOMS)
      DO 300 I = 1,NAT
      CALL MATXV3 (RR, ATXYZ(1,I), ATXYZ(5,I))
      CALL MAT6XV (CART2F, ATXYZ(5,I), ATXYZ(8,I))
      WRITE (LIS2,  FMT = '(3X, A6, 2X,3F8.4, F5.0,2(2X,3F8.4))')
     * ATNAME(I), (ATXYZ(J,I), J=1,10)
      WRITE (LIS1,  FMT = '(3X, A6, 2X,3F8.4)')
     * ATNAME(I), (ATXYZ(J,I), J=8,10)
      WRITE (IATOMS,  FMT = '(''ATOM'', 3X, A6, 2X,3F8.4)')
     * ATNAME(I), (ATXYZ(J,I), J=8,10)
300   CONTINUE
      WRITE(IATOMS, FMT = '(''END'')')
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATMOD, 'KEEP')
      RETURN
      END
      SUBROUTINE MATABC (AE, BE, CE, R)
      DIMENSION  R(3,3)
      D2R = ATAN(1.0) / 45.0
      CA = COS (AE * D2R)
      CB = COS (BE * D2R)
      CC = COS (CE * D2R)
      SA = SIN (AE * D2R)
      SB = SIN (BE * D2R)
      SC = SIN (CE * D2R)
      CALL MATEUL (CA, CB, CC, SA, SB, SC, R)
      RETURN
      END
      SUBROUTINE MATEUL (CA, CB, CC, SA, SB, SC, R)
      DIMENSION  R(3,3)
      R(1,1) = CB
      R(1,2) = SB * SC
      R(1,3) = -SB * CC
      R(2,1) = SA * SB
      R(2,2) = CA * CC - SA * CB * SC
      R(2,3) = SA * CB * CC + CA * SC
      R(3,1) = CA * SB
      R(3,2) =-CA * CB * SC - SA * CC
      R(3,3) = CA * CB * CC - SA * SC
      RETURN
      END
      SUBROUTINE INVERT
      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        SWHAND
      EQUIVALENCE   (SWHAND, SWITCH(28))
      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)), (ICRYS, IFILE(3))
      EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6)), (LIS1, IFILE(7))
      EQUIVALENCE (IATOLD, IFILE(10))
      CHARACTER *  6 LL
      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
      PARAMETER       (NSLOT = 10, MAXAT = 2513)
      COMMON /  /     DUMMY(1),
     *                ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DIMENSION ZZ(3), AA(3), BB(3), CC(3)
      CALL RDCRYS (ICRYS)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT',  KINQ)
      IF (KINQ.EQ.-1) CALL KERROR ('ATOMS file not found',0,'INVERT')
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      REWIND IATOMS
      CALL KERNZA (0.0, ZZ, 3)
      DO 150 I = 1,NAT
      DO 150 J = 1,3
  150 ZZ(J) = ZZ(J) + ATXYZ(J,I)
      DO 160 J =1,3
      ZZ(J) = ZZ(J) / FLOAT(NAT)
      BB(J) = 1.0
      IF (ZZ(J) .LT. 0.2) BB(J) = 0.5
      IF (ZZ(J) .GT. 0.8) BB(J) = 1.5
      CC(J) = ZZ(J) + 0.5
      AA(J) = 1.0
      IF (IPOLA .EQ. 7) AA(J) = CC(J)
  160 CONTINUE
      GOTO     (171, 171, 173, 171, 173, 173, 200, 200), IPOLA
      GOTO 191
  171 I = IPOLA
      IF (I.EQ.4) I=3
      AA(I) = CC(I)
      GOTO 192
  173 I = 8 - IPOLA
      IF (I.EQ.5) I=1
      AA(I) = CC(I)
      J = MOD (I, 3) + 1
      AA(J) = CC(J)
      GOTO 193
  191 IF (ISYST .GT. 3) GOTO 200
      I = 1
      AA(I) = BB(I)
  192 IF (ISYST .GT. 3) GOTO 200
      J = MOD (I, 3) + 1
      AA(J) = BB(J)
  193 IF (ISYST .GT. 3) GOTO 200
      K = MOD (J, 3) + 1
      AA(K) = BB(K)
  200 DO 210 J = 1,3
  210 ZZ(J) = AA(J) / 2.
      IF (SWHAND) THEN
         WRITE (CHOUT, FMT = '('' Inversion point: '', 3F9.5)') ZZ
         CALL SHOUT
  220    WRITE(IPR1, 221)
  221    FORMAT(' Do you wish to use another point? (Y,N,Q,H?)')
         CALL KETERM (0, 1, KEND)
         IF (KEND .LT. 0) GOTO 220
         LL = LIT(1)
         IF (LL .EQ. 'Q') THEN
            WRITE(CHOUT,FMT='('' Terminal: Q=Quit: nothing done...'')')
            CALL SHOUT
            RETURN
            ENDIF
         IF (LL .EQ. 'N') THEN
            SWHAND = .FALSE.
            GOTO 240
            ENDIF
         IF (LL .EQ. 'Y') GOTO 230
         WRITE(IPR1, 227)
  227    FORMAT (' Y: you will be prompted to supply another point,'/
     *      '    for instance 0 0 0 for x= -x, y= -y, z= -z,'/
     *      '        or 0.5 0.5 0.5 for x=1-x, y=1-y, z=1-z,'/
     *      '    but... there is no check for symmetry-errors !!!' /
     *      ' Q: quit, stop, don.t do anything.'/
     *      ' N: use default (as printed above).')
         GOTO 220
         ENDIF
  230 WRITE (CHOUT, FMT = '('' Give coordinates of inversion point:'')')
      CALL SHOUT
      CALL KETERM (3, 0, KEND)
      IF (KEND .LT. 0) GOTO 230
      DO 235 I = 1,3
      ZZ(I) = FNUM(I)
  235 AA(I) = ZZ(I) * 2.0
  240 DO 250  I = 1,NAT
      DO 250  J = 1,3
  250 ATXYZ(J,I) = AA(J) - ATXYZ(J,I)
      WRITE (IPR1, 260)  NAT
  260 FORMAT (' Number of atoms inverted',  I5 )
      WRITE (CHOUT, FMT = '('' Inversion point: '', 3F9.5)') ZZ
      CALL SHOUT
      WRITE (CHOUT, FMT = '('' Inversion point: '', 3F9.5)') ZZ
      CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
      RETURN
      END
      SUBROUTINE BINPRI
      CALL BINPRX
      RETURN
      END
      SUBROUTINE BINPRX
      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 (ICRYS, IFILE(3))
      EQUIVALENCE (ICON,  IFILE(4))
      EQUIVALENCE (LIS1,  IFILE(7))
      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
      DIMENSION    FITEMS(51), HKL(3)
      PARAMETER (MAXBUF = 198)
      DIMENSION BUFIN(MAXBUF)
      EQUIVALENCE (FITEMS(1),HCODE)
      EQUIVALENCE (FITEMS(1),HKL(1))
      DIMENSION IBUFIN(MAXBUF), ITEMS(51), IHKL(3), THKL(3)
      PARAMETER (LCMAX = 2)
      CHARACTER*6  LCONDA (LCMAX)
      PARAMETER (LBMAX = 4)
      CHARACTER*6  LBIN (LBMAX)
      DIMENSION    NBIN (LBMAX), NPRINT(LBMAX)
      DATA LBIN   /'BINFO', 'BINFC', 'BINFC2', 'BINFFT' /
      DATA NBIN   / 17,      27,      27,       29      /
      DATA NPRINT / 25,      25,      25,       25      /
      DATA LCONDA /'BINPRI', 'NPRINT' /
      CALL RDCRYS (ICRYS)
  110 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)
      GOTO (110, 112), KEND
      GOTO 114
  112 IF (NFNUM.NE.4) CALL KERROR ('INCORR. NPRINT', 112, 'BINPRI')
      CALL KERF2I (FNUM, NPRINT, LBMAX)
      GOTO 110
  114 DO 500 IFBIN = 11, 14
      LB = IFBIN - 10
      CALL FILINQ (IFBIN, LBIN(LB), 'UNFORMATTED', 'TEST', KINQ)
      IF (KINQ .EQ. -1) NPRINT(LB) = 0
      IF (NPRINT(LB).LE.0) GOTO 500
      CALL BINIFF (1, IFBIN, LBIN(LB), FITEMS, NIT, BUFIN, NEND)
      NB = NBIN(LB)
      CALL KERF2I (BUFIN, IBUFIN, NB)
      IF (IFBIN.GT.11) WRITE (LIS1, FMT='(''1BINPRI'')')
      WRITE (LIS1, 122) LBIN(LB), IFBIN, CHIN(1:6), CHIN(7:12),
     *                 CHIN(13:20), CHIN(21:80), (IBUFIN(K),K=1,4), NIT
  122 FORMAT (//' Binary file  ' , A6, '  is present at unit ',I2/
     *          ' file name    ' , A6, '  for compound   ',A6/
     *          ' generated by program ',A8/
     *          ' TITLE = ', A60 /
     *          ' ITIME = ', I4, 2I3, I6 /
     *          ' Number of items per reflection is  ',I3 /
     *          ' Specific data are'/)
      GOTO (1,2,3,4), LB
  1   WRITE (LIS1, 301) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15)
  301 FORMAT ( ' IRUN/FRIE    STLMAX           HKLMAX',
     * '             HMAX      ',
     * '       HMIN     '/ 6X, I4, F10.6, 3(5X, 3I4) /)
      WRITE (LIS1, 305) NPRINT(LB)
  305 FORMAT ( ' Print' , I6, ' reflection records  '/
     * ' HCODE      (  H   K   L )    Fobs    sig ' /)
      GOTO 130
  2   WRITE (LIS1, 302) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15),
     *                (BUFIN(K),K=16,17),(BUFIN(K), K=18,20)
  302 FORMAT ( ' IRUN/FRIE    STLMAX           HKLMAX          ',
     * '   HMAX      ',
     * '       HMIN     ',/ 6X, I4, F10.6, 3(5X, 3I4) /
     * / '    SC Wils.P. BOV Wils.P.  ',
     * 'SC 2dim.r.      BP          BR'/  5(2X, F10.4))
      WRITE (LIS1, 303)  BUFIN(21), (IBUFIN(K), K=22,24),
     * IBUFIN(25), BUFIN(26), BUFIN(27)
  303 FORMAT ( / '    STLMAX        HKLMAX       NAT',
     * '      P1SQ       PSQ  '/
     * F10.4, 2X, 3I4, 6X, I4, 2F10.4/)
      WRITE (LIS1, 306) NPRINT(LB)
  306 FORMAT ( ' Print' , I6, ' reflection records (hkl as in BINFO)'/
     * ' Fcalc   phase '/)
      GOTO 130
  3   WRITE (LIS1, 302) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15),
     *                 (BUFIN(K), K=16,17), (BUFIN(K),K=18,20)
      WRITE (LIS1, 303)  BUFIN(21), (IBUFIN(K), K=22,24),
     * IBUFIN(25), BUFIN(26), BUFIN(27)
      WRITE (LIS1, 307) NPRINT(LB)
  307 FORMAT ( ' Print' , I6, ' reflection records (hkl as in BINFO)'/
     * ' EPSIL2    SF2    SF2P   FCALC phase   FCALC phase '/)
      GOTO 130
  4   WRITE (LIS1, 302) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15),
     *                 (BUFIN(K),K=16,17), (BUFIN(K), K=18,20)
      WRITE (LIS1, 304)  BUFIN(21), (IBUFIN(K), K=22,24),
     * IBUFIN(25), (BUFIN(K),K=26,27), (IBUFIN(K), K=28,29)
  304 FORMAT ( / '    STLMAX        HKLMAX       NAT',
     * '      P1SQ       PSQ    KEYFFT     KFOUR'/,
     * F10.4, 2X, 3I4, 6X, I4, 2F10.4, 2(6X, I4)/)
      WRITE (LIS1, 308) NPRINT(LB)
  308 FORMAT ( ' Print' , I6, ' reflection records  '/
     * '    H   K   L  amplitude phase'/)
      GOTO 130
  130 NREF = 0
      IF (IFSTAT(IFBIN).NE.0) GOTO 500
  140 CALL BINIFF (0, IFBIN, LBIN(LB), FITEMS, NIT, BUFIN, NEND)
      IF (NEND.LT.0) GOTO 490
      NREF = NREF + 1
      IF (NREF.GT.NPRINT(LB)) GOTO 140
      CALL KERF2I (FITEMS, ITEMS, NIT)
      GOTO (11, 12, 13, 14), LB
  11  CALL HKLC1U (HCODE, THKL)
      CALL KERF2I (THKL, IHKL, 3)
      WRITE (LIS1, 411) ITEMS(1), IHKL, (FITEMS(K), K=2,3)
  411 FORMAT (I10, 2X,3I4, F10.3, F7.3)
      GOTO 140
  12  WRITE (LIS1, 412) (FITEMS(K), K=1,2)
  412 FORMAT (F10.3, F5.0)
      GOTO 140
  13  WRITE (LIS1, 413) (FITEMS(K), K=1,NIT)
  413 FORMAT (F6.0, 2F8.0, 4(F9.3, F5.0), 6(/16X, 4(F9.3, F5.0) ))
      GOTO 140
  14  CALL KERF2I (HKL, IHKL, 3)
      WRITE (LIS1, 414) IHKL, (FITEMS(K), K=4,5)
  414 FORMAT (' ', 3I4, F11.4, F6.1 )
      GOTO 140
  490 WRITE (LIS1, 492) NREF
  492 FORMAT (' number of reflections  ', I5)
      IF (LB.EQ.3) WRITE (LIS1, 494)
  494 FORMAT (' (only independent reflections counted)' )
  500 CONTINUE
      RETURN
      END
      SUBROUTINE METFOU
      CALL KERROR('METFOUR not available ', 0, 'NUTS')
      END
      SUBROUTINE SELECT
      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 (IRD,    IFILE(5)), (IPR1,   IFILE( 6))
      EQUIVALENCE (LIS1,   IFILE(7)), (LIS2,   IFILE( 8))
      EQUIVALENCE (IATOMS, IFILE(2)), (IDDS, IFILE(1))
      EQUIVALENCE (ICON,   IFILE(4)), (IATOLD, IFILE(10))
      PARAMETER       (NSLOT = 10, MAXAT = 2513)
      COMMON /  /     DUMMY(1),
     *                ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      CHARACTER * 80  CHINR
      LOGICAL        SWRUN
      SWRUN = .FALSE.
      JRUN = -1
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'INPUT ', KINQ)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
  105 WRITE (IPR1,
     *    FMT = '('' Gives a run number '')')
      CALL KETERM (1, 0, KEND)
      IF (KEND .LT. 0) GOTO 105
      JRUN = NINT(FNUM(1))
  110 CALL KERINA (IATOLD, LIT, 1, LEND)
      IF (LEND .EQ. -1) GOTO 300
      IF (SWRUN) GOTO 120
      IF (LIT(1) .EQ. 'Next' .OR. LIT(1) .EQ. 'NEXT') THEN
         IRUN = NINT(FNUM(4))
         IF (IRUN .GT. JRUN) THEN
              WRITE(IPR1, FMT = '('' No success '')')
              RETURN
         ENDIF
         IF (JRUN .NE. IRUN) GOTO 110
         SWRUN = .TRUE.
         WRITE (CHOUT, FMT = '(2X, A70)') CHIN(1:70)
         CALL SHOUT
      ENDIF
      GOTO 110
 120  IF (LIT(1) .EQ. 'ATOMS' .OR. LIT(1) .EQ. 'ATMOD') GOTO 125
      GOTO 110
 125  CCODE = LIT(2)
      WRITE (CHOUT, FMT = '(2X, A70)') CHIN(1:70)
      CALL SHOUT
      READ (IATOLD, FMT = '(A80)') CHINR
      IF (CHINR(1:6) .EQ. 'REMARK') THEN
         WRITE (CHOUT, FMT = '(2X,A70)') CHINR(1:70)
         CALL SHOUT
      ELSE
      BACKSPACE IATOLD
         CHINR = ' '
      ENDIF
  130 WRITE (IPR1,
     *    FMT = '(/, '' Do you want this atom set ?(Y/N,Q)'')')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 130
      IF (LIT(1) .EQ. 'N') THEN
         SWRUN = .FALSE.
         GOTO 110
      ENDIF
      IF (LIT(1) .EQ. 'Q') RETURN
      IF (LIT(1) .NE. 'Y') GOTO 130
      NAT = 1
      BACKSPACE IATOLD
      READ (IATOLD, FMT = '(A80)') CHIN
      LEND = 999
  150 CALL ATOMIA (IATOLD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND)
      IF (LEND . EQ .0) THEN
         NAT = NAT + 1
         GOTO 150
      ENDIF
      NAT = NAT - 1
      CHOUT = ' '
      IF (CHINR(1:6) .EQ. 'REMARK') CHOUT(1:72) = CHINR(8:80)
      CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      CALL FILCLO(IATOMS, 'KEEP')
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IPR1, FMT = 211)
  211 FORMAT(' Do you want to continue with program: TRACOR, PHASEX, ...
     * ....')
  212 WRITE (IPR1, FMT = 213)
  213 FORMAT(' Type a program name or Q for stop')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 212
      IF (LIT(1) .EQ. 'Q') THEN
         WRITE(IDDS, FMT = '(''STOP'')')
         REWIND IDDS
         CALL FILCLO (IDDS, 'KEEP')
      ELSE
         WRITE(IDDS, FMT = '(''STOP'')')
         REWIND IDDS
         CALL FILCLO(IDDS, 'KEEP')
         CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ)
         IF (KINQ .EQ. 0) CALL FILCLO (ICON, 'DELETE')
         ENDIF
      GOTO 400
  300 WRITE (CHOUT, FMT = '('' End of the ATOLD file '')')
  400 CALL FILCLO(IATOLD, 'KEEP')
      RETURN
      END
      SUBROUTINE KEPROR
      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))
      CHARACTER * 2  IISO
      DATA IISO   / '==' /
      CALL KETIME (LIS2)
      WRITE (LIS2, 110) TITLE, PROGNM, (IISO, I=1,23)
  110 FORMAT (' TITLE: ', A64 / ' End of program ' , A8 /
     +     ' ' , 23A2  //  '$FINISH')
      WRITE (LIS1, FMT='('' End of program '', A8 // ''$FINISH'')')
     * PROGNM
      RETURN
      END
      SUBROUTINE WRLIS2
      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))
      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
      COMMON / / COMBLA(1), CHINT(420)
      CHARACTER CHINT *80
      DIMENSION BLACOM(42000)
      EQUIVALENCE (COMBLA(1), BLACOM(1))
      CHARACTER T *8
      I = 1
      WRITE (LIS2, FMT='(/ ''$FINISH'')')
      REWIND LIS2
  111 READ (LIS2, FMT = '(A80)', END = 119) CHIN
      IF (CHIN(1:8) .EQ. '$FINISH ') GOTO 121
      IF (CHIN(1:4) .NE. ' $TE') GOTO 111
      CHINT(I) = CHIN
      I = I + 1
      IF (I .EQ. 420) GOTO 121
      GOTO 111
  119 CALL KERROR (' kan niet', 119, 'MAIN')
  121 BACKSPACE LIS2
      CHINT(I) = ' '
      WRITE (LIS2, FMT = '(/'' $TEMP  summary'')')
      N = I
      I1 = 1
  200 T = ' '
      DO 225 I = I1, N
      IF (CHINT(I)(1:4) .EQ. ' $TE') THEN
         T = CHINT(I) (3:10)
         WRITE (LIS2, FMT = '(/'' $ '')')
         I2 = I
         GOTO 300
         ENDIF
  225 CONTINUE
      GOTO 900
  300 DO 325 I = I2, N
      IF (CHINT(I)(3:10) .EQ. T) THEN
         WRITE (LIS2, FMT = '(A80)') CHINT(I)
         CHINT(I)(1:4) = '    '
         ENDIF
  325 CONTINUE
      I1 = I2
      GOTO 200
  900 WRITE (LIS2, FMT = '(/'' $ ------- '')')
      RETURN
      END
