      PROGRAM DIRDIF
C-----------------------------------------------------------------------
CPROGRAM DIRDIF                unified version                      2008
C                              subfile DIRDIF1.FOR
C                              contents:   DIRDIF-main  +  NIJX routines
C-----------------------------------------------------------------------
C dirdif MAIN program contains:
C - some COMMON bloks definitions
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zatq2.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zch80.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zwils.inc'
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      COMMON /SINGP/ SINGPK, ORIGIN, PATP(8)
      COMMON /BLANK/ ITAB4(160000)
      KEYT = 1
      DATUM = ' version 2008.3   updt 15 Aug. 2008 '
      CALL DDUNIF
      END
      SUBROUTINE CONDAT
      INCLUDE 'Zaaaa.inc'
      PARAMETER (KEND = 20)
      CHARACTER*6 CONDA(KEND)
      SAVE NCALL
      DATA CONDA / 'STLMAX', 'HKLMAX', 'SCALE' , 'BOV'   , 'BP'
     *           , 'BR',     '$DUMM$', 'PARAMS', 'VMAX'  , 'MIN'
     *           , 'PRINT' , 'PRIMAP', 'LOCCEN', 'NCEST' , 'ACCEPT'
     *           , 'EMIN'  , 'SCSG'  , 'BHSG'  , 'DAMP'  , 'PRIMAP'/
      DATA NCALL /0/
      IF (NCALL .GT. 0) RETURN
      NCALL = NCALL + 1
      MESS = 0
      STLMAX = 0.0
      CALL KERNZA (0.0, HKLMAX, 3)
      SCALE = 1.0
      BOV = 2.0
      BP = 2.0
      BR = 2.0
      LEVEL = 0
      LEV6 = 24
      LEV7 = 8
      LEV8 = 27
      CALL FILINQ (13, 'CONDAT', 'FORMATTED', 'INPUT', K)
      IF (K .EQ. -1) GOTO 400
      I = 0
  100 CONTINUE
      CALL KERINA (13, CONDA, KEND, K)
      IF (K .NE. 0) GOTO 300
      I = I + 1
      IF (I .GT. 1) GOTO 200
      IF (LIT(1) .NE. 'CONDAT' ) THEN
         WRITE (9, FMT='(1X/A)') ' Incorrect CONDAT file: ignored! '
         MESS = MESS + 1
         GOTO 300
         ENDIF
      IF (LIT(2) .EQ. ' ') GOTO 100
      IF (CCODE .NE. ' ' .AND. LIT(2) .EQ. CCODE)  GOTO 100
      WRITE (24, FMT='(/A)')
     *    ' Incorrect CCODE on CONDAT file: ignored! '
      MESS = MESS + 1
      GOTO 300
  200 CONTINUE
      IF (LIT(1) .EQ. 'TITLE') THEN
         WRITE (9, FMT='(1X,'' CONDAT: '', A61)') CHIN(1:61)
         MESS = MESS + 1
         GOTO 100
         ENDIF
      IF (LIT(1) .EQ. 'REMARK') GOTO 100
      ISKIP = 0
      IF ( LITJ1.EQ.'PATTY'  .OR. LITJ2 .EQ. 'PATTY' ) ISKIP = 1
      IF ( LITJ1.EQ.'ORIENT' .OR. LITJ2 .EQ. 'ORIENT' .OR.
     *     LITJ1.EQ.'TRACOR' .OR. LITJ2 .EQ. 'TRACOR' ) ISKIP = 2
      DO 290 K = 1, KEND
      CALL KERING (CONDA(K), N, KTOT)
      IF (N .LE. 0) GOTO 290
      GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20), K
    1 CONTINUE
      IF (FNUM(N) .GT. 0.01) THEN
         STLMAX = FNUM(N)
         WRITE (9, FMT='('' CONDAT: STLMAX ='', F10.5)') STLMAX
         MESS = MESS + 1
         ENDIF
      GOTO 290
    2 CONTINUE
      IF (KTOT .LT. 3) THEN
         WRITE (9, FMT='('' CONDAT error: HKLMAX needs 3 numbers !'')')
         MESS = MESS + 1
         GOTO 290
         ENDIF
      CALL KERNAB (FNUM(N), HKLMAX, 3)
      WRITE (9, FMT='('' CONDAT: HKLMAX ='', 3F5.0)') HKLMAX
      MESS = MESS + 1
      GOTO 290
    3 CONTINUE
      IF (FNUM(N) .GT. 0.00001) THEN
         SCALE = FNUM(N)
         WRITE (9, FMT='('' CONDAT: SCALE  ='', F10.5)') SCALE
         MESS = MESS + 1
         ENDIF
      GOTO 290
    4 CONTINUE
      IF (FNUM(N) .GT. 0.001) THEN
         BOV = FNUM(N)
         WRITE (9, FMT='('' CONDAT: BOV  ='', F8.4)') BOV
         MESS = MESS + 1
         ENDIF
      GOTO 290
    5 CONTINUE
      IF (ISKIP .EQ. 2) GOTO 290
      IF (FNUM(N) .GT. 0.001) THEN
         BP = FNUM(N)
         WRITE (9, FMT='('' CONDAT: BP   ='', F8.4)') BP
         IF (ISKIP .EQ. 1) WRITE (9,
     *         FMT='(''      note: BP   = BPatt used for sharpening'')')
         MESS = MESS + 1
         ENDIF
      GOTO 290
    6 CONTINUE
      IF (ISKIP .GE. 1) GOTO 290
      IF (FNUM(N) .GT. 0.001) THEN
         BR = FNUM(N)
         WRITE (9, FMT='('' CONDAT: BR   ='', F8.4)') BR
         MESS = MESS + 1
         ENDIF
      GOTO 290
    7 CONTINUE
      GOTO 290
    8 CONTINUE
      GOTO 290
    9 CONTINUE
      GOTO 290
   10 CONTINUE
      GOTO 290
   11 CONTINUE
      LEVEL = NINT(FNUM(1))
      IF (LEVEL .EQ. 0) GOTO 290
      WRITE (9, FMT='('' CONDAT: PRINT LEVEL ='', I2)') LEVEL
      MESS = MESS + 1
      LEV6 = 9
      IF (LEVEL .EQ. 1) GOTO 290
      LEV8 = 8
      IF (LEVEL .EQ. 2) GOTO 290
      LEV7 = 24
      GOTO 290
   12 CONTINUE
      GOTO 290
   13 CONTINUE
      GOTO 290
   14 CONTINUE
      GOTO 290
   15 CONTINUE
      GOTO 290
   16 CONTINUE
      GOTO 290
   17 CONTINUE
      GOTO 290
   18 CONTINUE
      GOTO 290
   19 CONTINUE
      GOTO 290
   20 CONTINUE
  290 CONTINUE
      GOTO 100
  300 CONTINUE
      IF (MESS .GT. 0) WRITE (9, FMT='('' --------------------''/ 1X )')
      CALL FILCLO (13, 'KEEP')
      CALL WR24
  400 CONTINUE
      OPEN (UNIT = 27, FORM = 'FORMATTED', STATUS = 'SCRATCH')
      RETURN
      END
      SUBROUTINE FILINX (FNAME)
      CHARACTER *64 FNAME
      INCLUDE 'Zsyst.inc'
      CHARACTER *6 CCCC, CA, CB
      CA = FNAME(1:6)
      CB = '  '
      CALL KERC2L (CA, CB, 6)
      FNAME = CB
      IF (FNAME.NE.'res' .AND. FNAME.NE.'ins' .AND. FNAME.NE.'hkl' .AND.
     *    FNAME.NE.'cif' .AND. FNAME.NE.'spf' ) RETURN
      IF (  CCODE .EQ. ' ' ) RETURN
      CCCC = '  '
      CALL KERC2L (CCODE, CCCC, 6)
      L = 0
      DO 10 I = 1, 6
         IF ( CCODE(I:I) .EQ. ' ' ) GOTO 20
         L = L + 1
   10 CONTINUE
   20 CONTINUE
      FNAME = CCCC(1:L) // '.' // CB
      RETURN
      END
      SUBROUTINE KERASE (FNAMEX)
      CHARACTER FNAMEX*(*), FNAME*64
      FNAME = FNAMEX
      CALL FILTES (FNAMEX, KINQ)
      IF (KINQ .LT. 0) RETURN
      IF (KINQ .GT. 0) THEN
         CALL FILCLO (KINQ, 'DELETE')
      ELSE
         CALL FILCLO (19, 'KEEP')
         CALL FILINX (FNAME)
         OPEN (UNIT=19, FILE=FNAME, STATUS='OLD')
         CALL FILCLO (19, 'DELETE')
         ENDIF
      RETURN
      END
      SUBROUTINE WR24
      INCLUDE 'Zsyst.inc'
      CHARACTER CH*72
      SAVE NCALL, NBL
      DATA NCALL, NBL /0, 0/
      DATA LIS3 /25/
      IF (NCALL .EQ. 0) THEN
         NCALL = 1
         OPEN (UNIT = 9, FORM = 'FORMATTED', STATUS = 'SCRATCH')
         OPEN (UNIT = 24, FORM = 'FORMATTED', STATUS = 'SCRATCH')
         OPEN (UNIT = 7, FORM = 'FORMATTED', STATUS = 'SCRATCH')
         OPEN (UNIT = 8, FORM = 'FORMATTED', STATUS = 'SCRATCH')
         WRITE (9, FMT='('' '')')
         WRITE (24, FMT='('' '')')
         WRITE (7, FMT='('' '')')
         WRITE (8, FMT='('' '')')
         CH = ' '
         CALL WINOUT (CH)
         WRITE (CH, 1175)  DATUM
 1175 FORMAT (' ========== DIRDIF ==========     ', A36)
         CALL WINOUT (CH)
         CH = ' '
         CALL WINOUT (CH)
         CALL KERASE ('LIS3')
         OPEN (UNIT = 25,FORM = 'FORMATTED', FILE='lis3',STATUS = 'NEW')
         WRITE (LIS3,FMT='(/'' File LIS3 = selected DIRDIF testresults''
     *    // '' This file will be overwritten at each DIRDIF call''//)')
         RETURN
         ENDIF
      WRITE (24, FMT='(''$PTB$   unit 24'')')
      REWIND 24
  123 CONTINUE
      CH = ' '
      READ (24, FMT='(A)') CH
      IF (CH(1:5) .EQ. '$PTB$') GOTO 199
      WRITE (7, FMT='(A)') CH
      WRITE (8, FMT='(A)') CH
      GOTO 123
  199 CONTINUE
      REWIND 24
      WRITE (9, FMT='(''$PTB$   unit 9 '')')
      REWIND 9
  223 CONTINUE
      CH = ' '
      READ (9, FMT='(A)') CH
      IF (CH(1:5) .EQ. '$PTB$') GOTO 299
      IF (CH .EQ. ' ') THEN
         NBL = NBL + 1
         IF (NBL .GE. 2) GOTO 223
      ELSE
         NBL = 0
         ENDIF
      CALL WINOUT (CH)
      WRITE (7, FMT='(''! '', A72)') CH
      WRITE (8, FMT='(''! '', A72)') CH
      GOTO 223
  299 CONTINUE
      REWIND 9
      END
      SUBROUTINE WININP (CH)
      CHARACTER CH*80
      CALL WR24
      INCLUDE 'Zwini.inc'
      SUBROUTINE WINOUT (CH)
      INCLUDE 'Zwino.inc'
      SUBROUTINE KERNAB (A, B, N)
      DIMENSION A(N), B(N)
      DO 100 I=1,N
  100 B(I) = A(I)
      RETURN
      END
      SUBROUTINE KERNAI (IA, IB, N)
      DIMENSION IA(N), IB(N)
      DO 100 I=1,N
  100 IB(I) = IA(I)
      RETURN
      END
      SUBROUTINE KERNAC (CHA, CHB, N)
      CHARACTER *6 CHA(N), CHB(N)
      DO 100 I=1,N
  100 CHB(I) = CHA(I)
      RETURN
      END
      SUBROUTINE KERNZA (X, A, N)
      DIMENSION A(N)
      DO 100 I=1,N
  100 A(I) = X
      RETURN
      END
      SUBROUTINE KERNZI (IX, IA, N)
      DIMENSION IA(N)
      DO 100 I=1,N
  100 IA(I) = IX
      RETURN
      END
      SUBROUTINE KERNZ1 (CH, CHA, N)
      CHARACTER * 1  CH, CHA(N)
      DO 100 I=1,N
  100 CHA(I) = CH
      RETURN
      END
      SUBROUTINE KERNZ6 (CH, CHA, N)
      CHARACTER *6  CH, CHA(N)
      DO 100 I=1,N
  100 CHA(I) = CH
      RETURN
      END
      SUBROUTINE KEREQ1 (L, LL, N, KEND)
      CHARACTER *1  LL(N), L
      DO 100 KEND=1,N
      IF (LL(KEND).EQ.L) GOTO 110
  100 CONTINUE
      KEND = -1
  110 RETURN
      END
      SUBROUTINE KEREQ6 (L6, LL6, N, KEND)
      CHARACTER * 6  L6, LL6(N)
      DO 110 KEND=1,N
      IF (L6.NE.LL6(KEND)) GOTO 110
      RETURN
  110 CONTINUE
      KEND = -1
      RETURN
      END
      SUBROUTINE KERC2I (L, KEND)
      CHARACTER * 1 L, LLL(49), LLC(26)
      DATA LLL / '1','2','3','4','5', '6','7','8','9',' ',
     +           'A','B','C','D','E', 'F','G','H','I','J',
     +           'K','L','M','N','O', 'P','Q','R','S','T',
     +           'U','V','W','X','Y', 'Z','+','-','.',',',
     +           '*','/','=','$','''','(',')','?',':'      /
      DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j',
     +           'k','l','m','n','o', 'p','q','r','s','t',
     +           'u','v','w','x','y', 'z'                  /
      KEND = 0
      IF (L.EQ.'0') RETURN
      CALL KEREQ1 (L, LLL, 49, KEND)
      IF (KEND.GT.0) RETURN
      CALL KEREQ1 (L, LLC,  26, KEND)
      IF (KEND.GT.0) KEND = KEND + 10
      RETURN
      END
      SUBROUTINE KERI2C (I, CCC, N)
      CHARACTER * 6  CCC
      CHARACTER * 1  N10(10)
      DATA N10 / '1', '2', '3', '4', '5', '6', '7', '8', '9', '0' /
      CCC = ' '
      JNUM = IABS(I)
      NN = N
      IF (NN .GT. 6) NN = 6
      K = 10**NN
      IF (JNUM .GE. K) JNUM = K-1
      J = K / 10
      DO 100 L=1,NN
      IF (JNUM.GE.J) GOTO 110
      NN = NN- 1
      J = J / 10
  100 CONTINUE
  110 DO 120 L=1,NN
      K = JNUM / J
      IF (K.EQ.0) THEN
         CCC(L:L) = N10(10)
      ELSE
         CCC(L:L) = N10(K)
         ENDIF
      JNUM = JNUM - K*J
  120 J = J / 10
      RETURN
      END
      SUBROUTINE KERI2F (IA, FA, N)
      DIMENSION IA(N), FA(N)
      DO 100 I=1,N
  100 FA(I) = IA(I)
      RETURN
      END
      SUBROUTINE KERF2I (FA, IA, N)
      DIMENSION FA(N), IA(N)
      DO 100 I=1,N
  100 IA(I) = NINT (FA(I))
      RETURN
      END
      SUBROUTINE KERC2U (CA, CB, N)
      CHARACTER CA *(*), CB *(*)
      CHARACTER * 1  LUC(26), LLC(26), Z
      DATA LUC / 'A','B','C','D','E', 'F','G','H','I','J',
     +           'K','L','M','N','O', 'P','Q','R','S','T',
     +           'U','V','W','X','Y', 'Z'                  /
      DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j',
     +           'k','l','m','n','o', 'p','q','r','s','t',
     +           'u','v','w','x','y', 'z'                  /
      DO 120 I = 1, N
      CB(I:I) = CA(I:I)
      IF (CB(I:I) .EQ. ' ') GOTO 120
      Z = CB(I:I)
      CALL KEREQ1 (Z, LLC, 26, KEND)
      IF (KEND .LE. 0) GOTO 120
      CB(I:I) = LUC(KEND)
  120 CONTINUE
      RETURN
      END
      SUBROUTINE KERC2L (CA, CB, N)
      CHARACTER CA *(*), CB *(*)
      CHARACTER * 1  LUC(26), LLC(26), Z
      DATA LUC / 'A','B','C','D','E', 'F','G','H','I','J',
     +           'K','L','M','N','O', 'P','Q','R','S','T',
     +           'U','V','W','X','Y', 'Z'                  /
      DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j',
     +           'k','l','m','n','o', 'p','q','r','s','t',
     +           'u','v','w','x','y', 'z'                  /
      DO 120 I = 1, N
      CB(I:I) = CA(I:I)
      IF (CB(I:I) .EQ. ' ') GOTO 120
      Z  = CB(I:)
      CALL KEREQ1 (Z, LUC, 26, KEND)
      IF (KEND .LE. 0) GOTO 120
      CB(I:I) = LLC(KEND)
  120 CONTINUE
      RETURN
      END
      SUBROUTINE KERICH (I, CH, KEND)
      CHARACTER * 1 CH, LLL(50), LLC(26)
      DATA LLL / '1','2','3','4','5', '6','7','8','9',' ',
     +           'A','B','C','D','E', 'F','G','H','I','J',
     +           'K','L','M','N','O', 'P','Q','R','S','T',
     +           'U','V','W','X','Y', 'Z','+','-','.',',',
     +           '*','/','=','$','''','(',')','?',':','@'  /
      DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j',
     +           'k','l','m','n','o', 'p','q','r','s','t',
     +           'u','v','w','x','y', 'z'                  /
      IF (I .GT. 99) GOTO 100
      IF (I .EQ. 0) THEN
         CH = '0'
      ELSEIF (I .LT. 0 .OR. I .GT. 76) THEN
         CH = ' '
      ELSEIF (I .LE. 50) THEN
         CH = LLL(I)
      ELSE
         CH = LLC (I - 50)
         ENDIF
      RETURN
  100 CONTINUE
      KEND = 0
      IF (CH .EQ. '0') RETURN
      CALL KEREQ1 (CH, LLL, 50, KEND)
      IF (KEND.GT.0) RETURN
      CALL KEREQ1 (CH, LLC,  26, KEND)
      IF (KEND.GT.0) KEND = KEND + 50
      IF (KEND.LE.0) KEND = 97
      RETURN
      END
      SUBROUTINE KEPROG (NAME)
      CHARACTER NAME *(*)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zch80.inc'
      PROGNM = NAME
      PROSNM = ' '
      CALL KERNZI (0, KEYS, 28)
      DO 101 I=10,28
  101 SWITCH(I) = .FALSE.
      CALL WR24
      WRITE (8, FMT='(1X)')
      IF (NRECYR .EQ. 0) THEN
         WRITE (24, 105)  PROGNM
  105    FORMAT (1X/1X/' ============ Program ', A8)
         IF (PROGNM .EQ. 'ORIENT' .OR. PROGNM .EQ. 'TRACOR' .OR.
     *       PROGNM .EQ. 'TRAVEC') THEN
             WRITE (24, FMT='('' ===========================''/1X)')
             ENDIF
      ELSE
         WRITE (24, 106) PROGNM, IPAT, NRECYR, NRECYS, NRECYT
  106    FORMAT (1X/1X/' ============ Program ', A8, 8X, 'IPAT=', I2,
     *       4X, '[cycle', I3, ' /', I2,I2, ']'/1X)
         ENDIF
      CALL WR24
      WRITE (8, FMT='(1X/1X/1X)')
      CALL FILCLO (2, 'KEEP')
      CALL FILINQ (2, 'DDSYST', 'FORMATTED', 'INPUT', KIDDS)
      IF (KIDDS .EQ. -1) CALL KERROR ('No DDSYST file', 152, 'KEPROG')
      CALL KERINA (2, LIT, 1, LEND)
      IF (LIT(1) .NE. PROGNM(1:6))
     *     CALL KERROR (' Incorrect DDSYST file', 152, 'KEPROG')
      NCH = 0
  201 CALL KERINA (2, LIT, 1, LEND)
      IF (LEND .EQ. -1) GOTO 207
      NCH = NCH + 1
      CH80(NCH) = CHIN
      GOTO 201
  207 REWIND 2
      DO 208 I = 1, NCH
  208 WRITE (2, FMT = '(A80) ') CH80(I)
      REWIND 2
      CALL FILCLO (2, 'KEEP')
      RETURN
      END
      SUBROUTINE KEPROX
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDOKA, KEYS(10))
      CHARACTER * 2  IISO
      DATA IISO   / '==' /
      WRITE (8, 111)  PROGNM, (IISO, I=1,23)
  111 FORMAT (/' End of program ' , A8 / ' ' , 23A2  // )
      DO 200 I=1,20
      IF (I.GE.6 .AND. I.LE.8) GOTO 200
      CALL FILCLO (I, 'KEEP')
  200 CONTINUE
      IF (IDOKA .EQ. -17) CALL DDEXIT
      IDOKA = 17
      RETURN
      END
      SUBROUTINE KERNER (KEY, NAME)
      CHARACTER NAME *(*), NAMEX *8
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IRUN, KSTAT(13))
      CHARACTER * 6  SUBPGM
      DATA SUBPGM /'SUBPGM'/
      NAMEX = NAME
      IF (PROSNM.EQ.' ') SUBPGM=' '
      CALL WR24
      CALL FILCLO (20, 'KEEP')
      CALL FILINQ (20, 'DDSTOP', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ .LT. 0) THEN
         WRITE (20, FMT= '(''DDSTOP  error stop in RUN'', I4,
     *      ''  for CCODE = '', A6)') IRUN, CCODE
         WRITE (20, FMT= '(''ERROR MESSAGE:'')')
      ELSE
         READ (20, END=99, FMT='(1X)')
         READ (20, END=99, FMT='(1X)')
         READ (20, END=99, FMT='(1X)')
         ENDIF
   99 CONTINUE
      WRITE (9, 100) PROGNM, SUBPGM, PROSNM, NAMEX
      WRITE (20, 100) PROGNM, SUBPGM, PROSNM, NAMEX
  100 FORMAT (' ERROR STOP IN ' ,A8, 3X,A6,1X,A6,' MODULE ',A8)
      IF (KEY.EQ.0) GOTO 190
      IF (KEY.LT.0) GOTO 120
  110 WRITE (CHOUT, 111) KEY
  111 FORMAT (' ERROR NUMBER',I6)
      IF (KEY.EQ.-99) CHOUT(20:41) = '?? impossible error ??'
      GOTO 190
  120 WRITE (CHOUT, 130) KEY
  130 FORMAT (' ERROR NUMBER', I5)
      IF (KEY .LT. -6 .OR. KEY .EQ. -4) GOTO 110
      WRITE (9, FMT='(A72)') CHOUT
      WRITE (20, FMT='(A72)') CHOUT
      IF (KEY.EQ.-1) THEN
         CHOUT = ' ERROR : INPUT DATA INCORRECT'
      ELSEIF (KEY.EQ.-2) THEN
         CHOUT = ' ERROR : INPUT DATA FILE(S) INCORRECT'
      ELSEIF (KEY.EQ.-3) THEN
         CHOUT = ' ERROR : SORRY, DATA IS INCONSISTENT'
      ELSEIF (KEY.EQ.-5) THEN
         CHOUT = ' ERROR ... SEE MANUAL FOR DETAILS....'
      ELSEIF (KEY.EQ.-6) THEN
         WRITE (9, 188)
         WRITE (20, 188)
  188 FORMAT (' ERROR : INPUT DATA INCORRECT'/
     *        ' ERROR : LAST INPUT RECORD WAS:')
         CHOUT = CHIN(1:72)
         ENDIF
  190 CONTINUE
      WRITE (9, FMT='(A72)') CHOUT
      WRITE (20, FMT='(A72)') CHOUT
      WRITE (24, 200)
      WRITE (20,200)
  200 FORMAT (1X/' ERROR ! '/
     * ' The present error-stop  is the result of an internal test'/
     * ' which could refer to a user- or to a programmers-error. '/
     * ' If the present error message is not clear to you,  please, '/
     * ' tell us about it: we would like to know what can go wrong. '/
     * ' Thank you for your help.   Paul T. Beurskens.'/
     * '                   email:   PTBeurskens[at]hetnet.nl'/1X)
      CALL WR24
      WRITE (20, FMT='(''STOP'')')
      CALL FILCLO ( 20, 'KEEP')
      CALL KERASE ('MERCUR')
      WRITE (7, FMT='(/''$FINISH'')')
      WRITE (8, FMT='(/''$FINISH'')')
      CALL DDEXIT
      END
      SUBROUTINE KERROR (MESGE, KEY, NAME)
      CHARACTER MESGE *(*) , MESGEX *70
      CHARACTER NAME  *(*)
      INCLUDE 'Zsyst.inc'
      PARAMETER (ISTOP=20)
      EQUIVALENCE (IRUN, KSTAT(13))
      MESGEX = MESGE
      CALL WR24
      WRITE (9, 100) MESGEX
  100 FORMAT (1X/' ERROR : ', A70)
      CLOSE (UNIT = ISTOP)
      CALL FILINQ (ISTOP, 'DDSTOP', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ISTOP, FMT=   '(''DDSTOP  error stop in RUN'',
     *   I4, ''  for CCODE = '', A6)') IRUN, CCODE
      WRITE (ISTOP, FMT='(''ERROR MESSAGE:'')')
      WRITE (ISTOP, 100) MESGEX
      WRITE (ISTOP, FMT='(''END'')')
      CALL KERNER (KEY, NAME)
      END
      SUBROUTINE KERINA (IRD, L, LMAX, LEND)
      CHARACTER * 6  L(LMAX)
      INCLUDE 'Zsyst.inc'
      LEND = 0
      IF (IRD .LE. 0) STOP 27
      IF (IRD .EQ. 5) THEN
         CALL WININP(CHIN)
         IF (CHIN .EQ. ' ') GOTO 120
         GOTO 130
         ENDIF
      CHIN = ' '
      READ (IRD, 110, ERR = 199, END = 120, IOSTAT = NINQ) CHIN
  110 FORMAT (A)
      IF (NINQ .EQ. 0) GOTO 130
  120 LEND = -1
      CHIN = ' '
  130 CALL KERINB (L, LMAX)
      IF (LEND.LE.-1) RETURN
      IF (LIT(1).EQ.'END   ') LEND = 4
      IF (LIT(1).EQ.'FINISH') LEND = 5
      IF (LIT(1).EQ.'STOP  ') LEND = 6
      RETURN
  199 CONTINUE
      WRITE (CHOUT, FMT='('' QUEST: '', A6, '' ? '')') L(1)
      CALL KERROR (CHOUT(1:16), 199, 'KERINA')
      END
      SUBROUTINE KERINB (LUSER, LUMAX)
      INCLUDE 'Zsyst.inc'
      CHARACTER * 6  LUSER(LUMAX)
      CHARACTER * 1  CH1
      CHARACTER * 6  CHLIT, IBL, LBOS
      DATA IDMAX  / 32 /
      DATA IBL    /'  '/
      DATA MCOL   / 80 /
      CALL KERNZ6 (IBL,  LIT, IDMAX)
      CALL KERNZA (0.0, FNUM, IDMAX)
      CALL KERNZI (0,  NCOLN, IDMAX)
      CALL KERNZI (0,  NCOLL, IDMAX)
      CALL KERNZI (0,  NFDOT, IDMAX)
      CALL KERNZI (0,  NFDOL, IDMAX)
      CALL KERNZI (0, NLUSER, IDMAX)
      LUMA = LUMAX
      IF (LUMA.EQ.1 .AND. LUSER(1).EQ.' ') LUMA = 0
      NFNUM = 0
      NLIT  = 0
      ITEM  = 0
      KEND  = 0
      NEND  = 0
      I = 1
  110 IF (I.GT.MCOL) GOTO 270
      DO 120 K=I,MCOL
      CH1 = CHIN(K:K)
      IF (CH1.NE.' ' .AND. CH1.NE.',') GOTO 130
  120 CONTINUE
      GOTO 270
  130 NONUM  = 0
      NONUM2 = 0
      NSIG = 0
      NDOT = 0
      I = K
      DO 170 K=I,MCOL
      CH1 = CHIN(K:K)
      CALL KERC2I (CH1, J)
      IF (J.GE.0 .AND. J.LE.9) GOTO 140
      IF (CH1.EQ.'.') GOTO 150
      IF (J.LT.0 .OR. J.GE.41) GOTO 240
      IF (J.GE.11 .AND. J.LE.36) GOTO 240
      IF (NDOT.EQ.1  .AND. NONUM.EQ.0) GOTO 240
      IF (CH1.EQ.',' .AND. NONUM.EQ.0) GOTO 240
      IF (CH1.EQ.',') GOTO 180
      IF (CH1.EQ.'+'.OR. CH1.EQ.'-') GOTO 160
      IF (NONUM2.EQ.1) GOTO 240
      IF (NSIG.EQ.1) GOTO 170
      IF (NONUM.EQ.0) GOTO 240
      GOTO 180
  140 NONUM  = 1
      NONUM2 = 0
      NSIG = 0
      GOTO 170
  150 NDOT = NDOT + 1
      IF (NDOT.EQ.2) GOTO 240
      GOTO 170
  160 IF (NSIG.EQ.1) GOTO 240
      IF (NDOT.EQ.1 .AND. NONUM.EQ.0) GOTO 240
      NSIG = 1
      NONUM2 = NONUM
      NONUM  = 0
      NDOT = 0
  170 CONTINUE
      IF (NONUM.EQ.0) GOTO 240
  180 ITEM  = ITEM  + 1
      NFNUM = NFNUM + 1
      IF (NFNUM.LE.IDMAX) NCOLN(NFNUM) = I
      IF (NFNUM.GT.IDMAX) NCOLN(IDMAX) = - IABS(NCOLN(IDMAX))
      NONUM = 0
      NSIG  = 0
      NDOT  = 0
      DO 220 K=I,MCOL
      CH1 = CHIN(K:K)
      CALL KERC2I (CH1, J)
      IF (J.GE.0 .AND. J.LE.9) GOTO 190
      IF (CH1.EQ.'.') GOTO 200
      IF (CH1.EQ.',') GOTO 230
      IF (CH1.EQ.'+' .OR. CH1.EQ.'-') GOTO 210
      IF (J.NE.10) CALL KERNER (-4, 'KERINB')
      IF (NSIG.EQ.1) GOTO 220
      IF (NONUM.EQ.1) GOTO 230
      CALL KERNER (-4, 'KERINB')
  190 CONTINUE
      NONUM = 1
      NSIG  = 0
      GOTO 220
  200 NDOT = 1
      GOTO 220
  210 IF (NONUM.EQ.1) GOTO 230
      NSIG  = 1
      NONUM = 0
  220 CONTINUE
      KEND = 999
  230 CONTINUE
      CALL KERINF (CHIN, I, K-1, A, NEND)
      I = K
      IF (NFNUM.LE.IDMAX) FNUM(NFNUM)  = A
      IF (NFNUM.LE.IDMAX) NFDOT(NFNUM) = NDOT+1
      IF (NFNUM.GT.IDMAX) NFNUM = IDMAX
      IF (ITEM.LE.IDMAX)  NFDOL(ITEM) = NDOT+1
      GOTO 110
  240 ITEM = ITEM + 1
      NLIT = NLIT + 1
      IF (NLIT.LE.IDMAX) NCOLL(NLIT)  = I
      IF (NLIT.GT.IDMAX) NCOLL(IDMAX) = - IABS(NCOLL(IDMAX))
      L = 1
      CHLIT = ' '
      DO 250 K=I,MCOL
      CH1 = CHIN(K:K)
      IF (CH1.EQ.' ' .OR. CH1.EQ.',') GOTO 260
      IF (L.LE.6) CHLIT(L:L) = CH1
  250 L = L + 1
      KEND = 999
      L = MCOL - I + 2
  260 I = K
      IF (NLIT.LE.IDMAX) LIT(NLIT) = CHLIT
      IF (NLIT.GT.IDMAX) NLIT = IDMAX
      IF (ITEM.LE.IDMAX) NFDOL(ITEM) = 1 - L
      IF (NLIT.GT.IDMAX) GOTO 270
      CALL KERC2U (LIT(NLIT), LBOS, 6)
      LIT(NLIT) = LBOS
      IF (LUMA.GT.0) CALL KEREQ6 (LIT(NLIT), LUSER, LUMA, NLUSER(NLIT))
      IF (KEND.EQ.999) I = KEND
      GOTO 110
  270 RETURN
      END
      SUBROUTINE KERINC (IPRX, LEND)
      INCLUDE 'Zsyst.inc'
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      CHARACTER * 6  L(9)
      DATA  L     / '    ', 'REMARK', 'TITLE', 'END', 'FINISH',
     +              'STOP', 'BATCH',  '     ', 'PRINT' /
      DATA LMAX / 9 /
      CALL KEREQ6 (LIT(1), L, LMAX, LEND)
      IF (LEND.LE.0) GOTO 100
      GOTO (1,2,3,4,4,4,7,1,9), LEND
    1 IF (NFNUM.LE.0) GOTO 4
  100 LEND = 0
      RETURN
    2 IF (IPRX .GT. 0) WRITE (IPRX, 110) CHIN(1:72)
  110 FORMAT (1X, 72A )
      GOTO 4
    3 CONTINUE
    4 RETURN
    7 CONTINUE
      GOTO 150
    9 SWPRI = .TRUE.
  150 IF (SWPRI) WRITE (8, 110)  CHIN(1:72)
      RETURN
      END
      SUBROUTINE KERINF (CHIN, I, K, FF, KEND)
      CHARACTER * 80 CHIN
      CHARACTER * 6  LL
      CHARACTER * 8  CHFMT
      M = K - I + 1
      KEND = 0
      CALL KERI2C (M, LL, 6)
      CHFMT = '(F'//LL(1:3)//'.0)'
      READ (CHIN(I:K), FMT = CHFMT, ERR = 99) FF
      RETURN
   99 KEND = -1
      RETURN
      END
      SUBROUTINE KERIFF (IRD, L, LMAX, LEND)
      INCLUDE 'Zsyst.inc'
      LOGICAL      SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      CHARACTER * 6  L(LMAX)
      IPRX = 0
      IF (SWPRI) IPRX = 8
  100 CALL KERINA (IRD, L, LMAX, LEND)
      IF (LEND.LE.-1) RETURN
      CALL KERINC (IPRX, LEND)
      IF (LEND.EQ.0) RETURN
      IF (LEND.LT.3 .OR. LEND.GT.7) GOTO 100
      RETURN
      END
      SUBROUTINE KETERM (KNUM, KLIT, KEND)
      INCLUDE 'Zsyst.inc'
      CHARACTER Z *1
      DATA I / 0 /
      IF (KNUM.EQ.0 .AND. KLIT.EQ.0) CALL KERNER (-4, 'KETERM')
      CALL WR24
      CHIN = ' '
      CALL WININP (CHIN)
      IF (CHIN .EQ. ' ') THEN
         WRITE (9, 110)
  110    FORMAT (' Your input line is empty' )
         KEND = -1
         RETURN
         ENDIF
      CALL KERINB (LIT, 1)
      IF ((KNUM.GE.0 .AND. NFNUM.NE.KNUM) .OR.
     *    (KLIT.GE.0 .AND. NLIT .NE.KLIT))    THEN
         WRITE (9, 142) KLIT, KNUM, NLIT, NFNUM
  142    FORMAT (' Program requested', I3, ' literal(s) and',
     +   I3, ' number(s)' / ' but you supplied:', I3,
     +   ' literal(s) and', I3, ' number(s). Please, try again'  /1X)
         KEND = -3
         RETURN
         ENDIF
      KEND = 99
      IF (NFDOL(2).NE.0) RETURN
      IF (NLIT.EQ.1)  I = NCOLL(1)
      IF (NFNUM.EQ.1) I = NCOLN(1)
      IF (CHIN(I+1:I+1).NE.' ') RETURN
      Z = CHIN(I:I)
      CALL KERC2I (Z, KEND)
      IF (KEND.LT.0) KEND = 99
      RETURN
      END
      SUBROUTINE FILINQ (IUNIT, FNAMEX, FFORMX, FKEYX, KINQ)
      CHARACTER FNAMEX *(*), FFORMX *(*), FKEYX *(*),
     *          FNAME  *64,  FFORM  *11,  FKEY  *7
      INCLUDE 'Zsyst.inc'
      CHARACTER FORMIN *11, FULNAM *255, POSFMT *7, POSUNF *7, FULNA *63
      LOGICAL   OPN, EXS, NMD
      FNAME = '  '
      FNAME = FNAMEX
      CALL FILINX (FNAME)
      FFORM = FFORMX
      FKEY  = FKEYX
      KINQ = 0
      IF ((FKEY.NE.'SCRATCH' .AND. FKEY.NE.'INPUT'
     *    .AND. FKEY.NE.'OUTPUT') .OR. IUNIT.LE.0 .OR. IUNIT.GT.29) THEN
         WRITE (9, 148) IUNIT, FNAME, FKEY
  148    FORMAT (1X/' ERROR in call FILINQ (',I3, 1X, A6, 1X, A6, ')')
         CALL KERROR('Programmers error in call params', 148, 'FILINQ')
         ENDIF
      CALL FILCLO (IUNIT, 'KEEP')
      CALL FILTES (FNAMEX, KINQQ)
      IF (KINQQ .GT. 0 .AND. KINQQ .NE. IUNIT) THEN
         WRITE (CHOUT, 149) FNAMEX, KINQQ, IUNIT
  149    FORMAT (' File error: file, KINQQ, IUNIT = ', A6, 2I3)
         CALL KERROR (CHOUT, -4, 'FILINQ')
         ENDIF
      INQUIRE (FILE = FNAME, ERR  = 900, IOSTAT = KINQ, EXIST = EXS,
     *         OPENED = OPN, FORM = FORMIN, NUMBER = NUM,
     *         NAMED  = NMD, NAME = FULNAM,
     *         FORMATTED = POSFMT, UNFORMATTED = POSUNF)
      IF ( EXS ) THEN
         IF ( OPN ) CALL KERROR (' 2007 ? impossible!', -4, 'FILINQ')
         IF (FFORM .EQ. '  FORMATTED' .AND. POSFMT .EQ. 'NO') GOTO 930
         IF (FFORM .EQ. 'FORMATTED'   .AND. POSFMT .EQ. 'NO') GOTO 930
         IF (FFORM .EQ. 'UNFORMATTED' .AND. POSUNF .EQ. 'NO') GOTO 932
         IF (FKEY .EQ. 'SCRATCH') THEN
            OPEN (UNIT = IUNIT, ERR = 940, IOSTAT = KINQ,
     *            FORM = FFORM, STATUS = 'SCRATCH')
            REWIND IUNIT
            KINQ = 0
            RETURN
            ENDIF
         OPEN (UNIT = IUNIT, ERR = 940, IOSTAT = KINQ, FILE = FNAME,
     *         FORM = FFORM, STATUS = 'OLD')
         REWIND IUNIT
         KINQ = 0
         RETURN
      ELSE
         IF (FKEY .EQ. 'SCRATCH') THEN
            OPEN (UNIT = IUNIT, ERR = 950, IOSTAT = KINQ,
     *            FORM = FFORM, STATUS = 'SCRATCH')
         ELSEIF (FKEY .EQ. 'OUTPUT') THEN
            OPEN (UNIT = IUNIT, ERR = 950, IOSTAT = KINQ, FILE = FNAME,
     *            FORM = FFORM, STATUS = 'NEW')
            ENDIF
         KINQ = -1
         ENDIF
      RETURN
  900 WRITE (7, 901) IUNIT, FNAME, KINQ
  901 FORMAT (
     *' ERROR Transmission error during execution of INQUIRE statement'/
     * 'ERROR ? Unit number:',I3,' File name: ', A24,' Error code:',I4)
      GOTO 990
  912 WRITE (7, 913)
  913 FORMAT (' ERROR :',
     *    ' Full file name not returned by INQUIRE, unnamed file!')
      GOTO 990
  917 FULNA = FULNAM(1:63)
      WRITE (7, 918) FULNA
  918 FORMAT (' ERROR : Full file name: ',A63)
      GOTO 990
  930 WRITE (7, 931) FNAME, IUNIT, FFORM, POSFMT
  931 FORMAT (' ERROR :',
     * ' The requested I/O-access mode for an already existing file' /
     * ' ERROR !',
     * ' does not match the allowed I/O-access mode for this file as' /
     * ' ERROR !',
     * ' found by INQUIRE for filenm: ',A24, 'Unit nr: ', I2 /
     * ' ERROR !',
     * ' Requested mode: ', A11, 5X, 'FORMATTED mode allowed: ', A7)
      IF ( NMD ) GOTO 917
      GOTO 912
  932 WRITE (7, 933) FNAME, IUNIT, FFORM, POSUNF
  933 FORMAT (' ERROR :',
     * ' The requested I/O-access mode for an already existing file' /
     * ' ERROR !',
     * ' does not match the allowed I/O-access mode for this file as' /
     * ' ERROR !',
     * ' found by INQUIRE for filenm: ',A24, 'Unit nr: ', I2 /
     * ' ERROR !',
     * ' Requested mode: ', A11, 5X, 'UNFORMATTED mode allowed: ', A7)
      IF ( NMD ) GOTO 917
      GOTO 912
  940 WRITE (7, 941) FKEY, IUNIT, FNAME, KINQ
  941 FORMAT (' ERROR :',
     * ' Transmission error during execution of OPEN statement' /
     * ' ERROR ! on an already existing file, option ', A7 /
     * ' ERROR !',
     * ' Unit nr: ',I2, 4X, 'Filenm: ', A24, ' Error code: ',I4)
      GOTO 990
  950 WRITE (7, 951) FKEY, IUNIT, FNAME, KINQ
  951 FORMAT (' ERROR :',
     * ' Transmission error during execution of OPEN statement' /
     * ' ERROR ! for a new file, option ', A7 /
     * ' ERROR !',
     * ' Unit nr: ',I2, 4X, 'Filenm: ', A24, ' Error code: ',I4)
  990 WRITE (CHOUT, 992) FNAME(1:13)
  992 FORMAT (' File error concerning file (name): ', A13)
      CALL KERROR (CHOUT, 0, 'FILINQ')
      END
      SUBROUTINE FILTES (FNAMEX, KINQ)
      CHARACTER FNAMEX *(*), FNAME  *64
      LOGICAL   OPN, EXS
      FNAME = ' '
      FNAME = FNAMEX
      CALL FILINX (FNAME)
      INQUIRE (FILE=FNAME, EXIST=EXS, OPENED=OPN, NUMBER=NUM)
      KINQ = -1
      IF ( .NOT. EXS ) RETURN
      KINQ = 0
      IF ( .NOT. OPN ) RETURN
      KINQ = NUM
      RETURN
      END
      SUBROUTINE FILCLO (IUNIT, FKEYX)
      CHARACTER  FKEYX *(*), FKEY *7
      INCLUDE 'Zsyst.inc'
      LOGICAL  OPN
      IF (IUNIT.EQ.5 .OR. IUNIT.EQ.6 .OR. IUNIT.EQ.9) RETURN
      FKEY = FKEYX
      IF (FKEY.NE.'KEEP'.AND.FKEY.NE.'DELETE') GOTO 999
      INQUIRE (UNIT = IUNIT, ERR = 201, OPENED = OPN)
      IF (.NOT. OPN) RETURN
      CLOSE (UNIT = IUNIT, ERR = 202, IOSTAT = KCLO, STATUS = FKEY)
      IF (KCLO.LE.0) RETURN
  201 WRITE (9, FMT='('' inquire error in FILCLO'')')
      GOTO 999
  202 WRITE (9, FMT='('' CLOSE error in FILCLO'')')
  999 WRITE (9, FMT='('' CLOSE IUNIT'',I3,'' FKEY  '',A7)') IUNIT,FKEY
      CALL WR24
      STOP 35
      END
      SUBROUTINE RDCRYS (ICRYS)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      CHARACTER CONT*1
      CHARACTER * 6  XTEST
      CHARACTER * 6  LLIT(30)
      CHARACTER * 6  NAME
      SAVE NPRI
      DATA NAME    / 'RDCRYS' /
      DATA LLMAX   / 27 /
      DATA LLIT   / 'CRYSDA', 'CELL  ', 'CELLSD', 'SPGR  ', 'RCELL ',
     +              'VOLUM ', 'WAVE  ', 'FORMUL', 'MOLW  ', 'Z     ',
     +              'NELEC ', 'F000  ', 'MU    ', 'ICENT ', 'ILATT ',
     +              'ISYST ', 'ILAUE ', 'IMULT ', 'IUNIQ ', 'IPOLA ',
     +              'NTYPE ', 'NSYMM ', 'NLATT ', 'FRAC2C', 'CART2F',
     +              'RRMAT ', 'SSMAT ', '      ', '      ', '      ' /
      DATA NPRI / 0 /
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         WRITE (CHOUT, 100) CCODE
  100    FORMAT (' ERROR no CRYSDA file found for ', A6)
         CALL KERROR (CHOUT, 0, 'RDCRYS')
         ENDIF
      NPRI = NPRI + 1
      DO 7101 I = 1,10
 7101 CELATY(I) = '  '
      DO 170 I=1,LLMAX
      CALL RDCRYB (ICRYS, LLIT(I), KEND)
      IF (KEND.LT.0) THEN
         WRITE (9, 917) LLIT(I)
  917    FORMAT (' ERROR : search for keyword ', A6,
     *           ' on CRYSDA file failed')
         GOTO 990
         ENDIF
      GOTO  (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
     *      16,17,18,19,20,21,22,23,24, 25, 26, 27,170,170,170), I
    1 IF (NPRI .EQ. 1) WRITE (8, 101)
  101 FORMAT (' Input crystal data file  CRYSDA')
      CALL KERINB (LIT,1)
      IF (CCODE .EQ. ' ' .OR. CCODE .EQ. 'CCODE') CCODE = LIT(2)
      IF (CCODE .EQ. LIT(2)) GOTO 170
      WRITE (24, 102) LIT(2), CCODE
  102 FORMAT (' Error: compound code on CRYSDA file is: ', A6,
     * ' expected: ', A6)
      GOTO 990
    2 READ (CHIN, 130) CELL
      GOTO 170
    3 READ (CHIN, 130) CELLSD
      GOTO 170
    4 CONTINUE
      SPGR = CHIN(11:26)
      GOTO 170
    5 READ (CHIN, 130) RCELL
      GOTO 170
    6 READ (CHIN, 130) VOLUM
      GOTO 170
    7 READ (CHIN, 107) WAVEAT, WAVE
  107 FORMAT (10X, A2, 8X, F10.6)
      GOTO 170
    8 READ (CHIN, 108) (CELATY(J), CELALL(J), J=1,5), CONT
  108 FORMAT (10X, 5(A2, F9.2, 1X), 1X, A1)
      IF (CONT.EQ.'=') READ (ICRYS,108) (CELATY(J), CELALL(J), J=6,10)
      GOTO 170
    9 READ (CHIN, 130) AMOLW
      GOTO 170
   10 READ (CHIN, 140) IZ
      ZET = IZ
      GOTO 170
   11 READ (CHIN, 140) NELEC
      GOTO 170
   12 READ (CHIN, 130) F000
      GOTO 170
   13 READ (CHIN, 130) ABSMU
      GOTO 170
   14 READ (CHIN, 140) ICENT
      GOTO 170
   15 READ (CHIN, 140) ILATT
      GOTO 170
   16 READ (CHIN, 140) ISYST
      GOTO 170
   17 READ (CHIN, 140) ILAUE
      GOTO 170
   18 READ (CHIN, 140) IMULT
      GOTO 170
   19 READ (CHIN, 140) IUNIQ
      GOTO 170
   20 READ (CHIN, 140) IPOLA
      GOTO 170
   21 READ (CHIN, 140) NTYPE
      DO 121 J=1,NTYPE
  121 CELALL(J) = CELALL(J) * ZET
      GOTO 170
   22 READ (CHIN, 140) NSYMM
      DO 122 M=1,NSYMM
  122 READ (ICRYS,1122) XTEST, ((IRSYMM(J,K,M),K=1,3),TSYMM(J,M),J=1,3)
 1122 FORMAT (A6, 4X, 3(3I3,1X,F10.7))
      IF (XTEST .NE. 'SYMMAT') GOTO 990
      GOTO 170
   23 READ (CHIN, 140) NLATT
      DO 123 M=1,NLATT
  123 READ (ICRYS, 1123) XTEST, (TLATT(J,M), J=1,3)
 1123 FORMAT (A6, 4X, 3(F10.7))
      IF (XTEST .NE. 'CENVEC') GOTO 990
      GOTO 170
   24 BACKSPACE ICRYS
      READ (ICRYS, 150) ((FRAC2C(J,K), K=1,3), J=1,3)
      GOTO 170
   25 BACKSPACE ICRYS
      READ (ICRYS, 150) ((CART2F(J,K), K=1,3), J=1,3)
      GOTO 170
   26 BACKSPACE ICRYS
      READ (ICRYS, 150) ((RRMAT(J,K), K=1,3), J=1,3)
      GOTO 170
   27 BACKSPACE ICRYS
      READ (ICRYS, 150) ((SSMAT(J,K), K=1,3), J=1,3)
  130 FORMAT (10X, 6F10.5)
  140 FORMAT (10X, I10)
  150 FORMAT (10X, 3F15.6 / 10X, 3F15.6 / 10X, 3F15.6 )
  170 CONTINUE
      AMULT = FLOAT (IMULT)
      ASYMM = FLOAT (NSYMM)
      ALATT = FLOAT (NLATT)
      ASYMCL= FLOAT (ICENT*NLATT)
      NSYMC = NSYMM * ICENT
      ASYMC = FLOAT (NSYMC)
      CALL KERNZI (0, IZTYPE, 10)
      DO 233 J=1,NTYPE
      CALL ATOMIZ (CELATY(J), NLET, IZ)
      IZTYPE(J) = IZ
  233 CONTINUE
      NATSYM = 0
      DO 244 IT = 1, NTYPE
      IF (IZTYPE(IT).NE.1) NATSYM = NATSYM + NINT ( CELALL(IT) )
  244 CONTINUE
      NATSYM = NATSYM / IMULT
      IF (NPRI .NE. 1) RETURN
      WRITE (8, 371) CELL, SPGR
  371 FORMAT (' Cell', 3F8.3, 3F7.2, '  SpGr ', A16/1X)
      IF (PROGNM .EQ. 'DDSTART' .OR. PROGNM .EQ. 'FFT')
     *   WRITE (24, 371) CELL, SPGR
      CALL WR24
      RETURN
  990 WRITE (24,991) LLIT(I)
  991 FORMAT (' ERROR : CONTENTS OF CRYSDA FILE INCORRECT: '/
     *        ' ERROR ! TRYING TO READ RECORD: ', A6)
      CALL KERNER (-6, NAME)
      RETURN
      END
      SUBROUTINE RDCRYB (ICRYS, LLITX, KEND)
      CHARACTER LLITX *(*), LLIT *6
      INCLUDE 'Zsyst.inc'
      LLIT = LLITX
      KEND = -3
  100 CHIN = ' '
      READ (ICRYS, 110, END=120) CHIN
  110 FORMAT (A)
      IF (CHIN(1:4).EQ.'END')  GOTO 120
      IF (CHIN(1:6).EQ.LLIT) GOTO 130
      GOTO 100
  120 KEND = KEND + 1
      REWIND ICRYS
      IF (KEND.LT.-1) GOTO 100
      RETURN
  130 KEND = 1
      RETURN
      END
      SUBROUTINE RDCRYX (ICRYS, LLITX, F, N)
      CHARACTER LLITX *(*), LLIT *6
      DIMENSION F(N)
      INCLUDE 'Zsyst.inc'
      CHARACTER * 6  NAME
      DATA NAME   / 'RDCRYX' /
      LLIT = LLITX
      CALL RDCRYB (ICRYS, LLIT, KEND)
      IF (KEND.LT.0) GOTO 990
      M = MIN0 (6, N)
      READ (CHIN, 100) (F(I), I=1,M)
  100 FORMAT (10X, 6F10.5)
      IF (N.LE.6) RETURN
      IF (LLIT.NE.'SFAC') GOTO 990
      READ (ICRYS, 110) (F(I), I=7,N)
  110 FORMAT (10X, 3F10.5, 2F7.3, F11.3, F5.2)
      RETURN
  990 CALL KERNER (-2, NAME)
      RETURN
      END
      SUBROUTINE RCELLR (CELL, V, RCELL)
      DIMENSION CELL(6), RCELL(6), AC(6)
      EQUIVALENCE (AC(1),      A), (AC(2),      B),  (AC(3),      C)
      EQUIVALENCE (AC(4),  ALPHA), (AC(5),   BETA),  (AC(6),  GAMMA)
      R2D = 45. / ATAN(1.0)
      CALL KERNAB (CELL, AC, 6)
      CA = COS(ALPHA / R2D)
      CB = COS(BETA  / R2D)
      CC = COS(GAMMA / R2D)
      SA = SQRT(1.0-CA**2)
      SB = SQRT(1.0-CB**2)
      SC = SQRT(1.0-CC**2)
      CASTR = (CB*CC-CA) / (SB*SC)
      CBSTR = (CA*CC-CB) / (SA*SC)
      CCSTR = (CA*CB-CC) / (SA*SB)
      SASTR = SQRT(1.0-CASTR**2)
      SBSTR = SQRT(1.0-CBSTR**2)
      SCSTR = SQRT(1.0-CCSTR**2)
      V = A*B*C * SQRT (1.0-CA*CA-CB*CB-CC*CC+2.0*CA*CB*CC)
      RCELL(1) = B*C*SA / V
      RCELL(2) = A*C*SB / V
      RCELL(3) = A*B*SC / V
      RCELL(4) = ASIN(SASTR) * R2D
      RCELL(5) = ASIN(SBSTR) * R2D
      RCELL(6) = ASIN(SCSTR) * R2D
      IF (CASTR .LT. 0.0) RCELL(4) = 180.0 - RCELL(4)
      IF (CBSTR .LT. 0.0) RCELL(5) = 180.0 - RCELL(5)
      IF (CCSTR .LT. 0.0) RCELL(6) = 180.0 - RCELL(6)
      RETURN
      END
      SUBROUTINE CELLRR (CELL, RR)
      DIMENSION CELL(6), RR(3,3)
      R2D = 45. / ATAN(1.0)
      CA = COS(CELL(4) / R2D)
      CB = COS(CELL(5) / R2D)
      CC = COS(CELL(6) / R2D)
      RR(1,1) = CELL(1) * CELL(1)
      RR(1,2) = CELL(1) * CELL(2) * CC
      RR(1,3) = CELL(1) * CELL(3) * CB
      RR(2,1) = RR(1,2)
      RR(2,2) = CELL(2) * CELL(2)
      RR(2,3) = CELL(2) * CELL(3) * CA
      RR(3,1) = RR(1,3)
      RR(3,2) = RR(2,3)
      RR(3,3) = CELL(3) * CELL(3)
      RETURN
      END
      SUBROUTINE CELZAT (ACELTY, NCELTY, NCELLZ)
      DIMENSION ACELTY(10), NCELTY(10), NCELLZ(10)
      CHARACTER ACELTY *2
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      DIMENSION JCELLZ(10)
      DO 160 N = 1, NTYPE
  160 CALL ATOMIZ(CELATY(N), K, JCELLZ(N))
      DO 180 N = 1, 10
      NCELLZ(N) = 0
      NCELTY(N) = 0
  180 ACELTY(N) = ' '
      LZ = 999
      DO 580 N = 1, NTYPE
      DO 570 J = 1, NTYPE
      IF (JCELLZ(J) .GE. LZ) GOTO 570
      IF (JCELLZ(J) .EQ. NCELLZ(N))
     *   NCELTY(N) = NCELTY(N) + NINT(CELALL(J))
      IF (JCELLZ(J) .GT. NCELLZ(N)) THEN
         NCELLZ(N) = JCELLZ(J)
         NCELTY(N) = NINT(CELALL(J))
         ACELTY(N) = CELATY(J)
         ENDIF
  570 CONTINUE
  580 LZ = NCELLZ(N)
      WRITE (8, 611) (ACELTY(I), I=1,NTYPE)
  611 FORMAT (' Cell contents.  Atoms:  ', 10(3X, A2))
      WRITE (8, 612) (NCELLZ(I), I=1,NTYPE)
  612 FORMAT (17X, 'Z =  : ', 10I5)
      WRITE (8, 613) (NCELTY(I), I=1,NTYPE)
  613 FORMAT (' Total number of atoms: ', 10I5)
      RETURN
      END
      SUBROUTINE BINIFF (KEY, IFI, FILENM, FITEMS, NIT, BUF, NEND)
      CHARACTER FILENM *(*), FILEN *6
      DIMENSION BUF(60)
      INCLUDE 'Zsyst.inc'
      DIMENSION FITEMS (NIT)
      PARAMETER (MAXBUF = 60)
      DATA FSTOP / -66.9E06 /
      IF (IFI.LE.0 .OR. IFI.GT.20) CALL KERROR (' IFI?',-4,'BINIFF')
      FILEN = FILENM
      IF (KEY) 140, 110, 100
  100 CONTINUE
      CALL FILCLO (IFI, 'KEEP')
      CALL FILINQ (IFI, FILEN, 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.LT.0) THEN
         WRITE (CHOUT, FMT='(''Binary input file '',
     *         A6, '' not found'')') FILEN
         CALL KERROR (CHOUT, 0, 'BINIFF')
         ENDIF
      NEND = -1
      RETURN
  110 IF (NEND.LT.0) GOTO 115
      IF (NEND.LE.MAXBUF-NIT) GOTO 120
  115 READ (IFI, ERR=148, END=149, IOSTAT=NINQ) BUF
      IF (NINQ .NE. 0) GOTO 150
      NEND = 0
  120 IF (BUF(NEND+1).LE.FSTOP) GOTO 130
      CALL KERNAB (BUF(NEND+1), FITEMS, NIT)
      NEND = NEND + NIT
      RETURN
  130 NEND = -1
  140 RETURN
  148 WRITE (7, FMT='('' ---- lable 148 --- '')')
      GOTO 150
  149 WRITE (7, FMT='('' ---- EOF --- '')')
  150 WRITE (CHOUT, 160) FILEN, IFI
  160 FORMAT (' Error reading input file ', A6, ', unit number ', I3)
      CALL KERROR (CHOUT, 0, 'BINIFF')
      END
      SUBROUTINE BINOFF (KEY, IFO, FILENM, FITEMS, NIT, BUF, NEND)
      CHARACTER FILENM *(*), FILEN *6
      PARAMETER (MAXBUF = 60)
      DIMENSION BUF(60)
      INCLUDE 'Zsyst.inc'
      DIMENSION FITEMS (NIT)
      DATA FSTOP / -67.0E06 /
      IF (IFO.LE.0 .OR. IFO.GT.20) CALL KERROR (' IFO?',-4,'BINOFF')
      FILEN = FILENM
      IF (KEY) 120, 110, 100
  100 CONTINUE
      CALL FILINQ (IFO, FILEN, 'UNFORMATTED', 'OUTPUT', KINQ)
      CALL KERNZA (0., BUF, 60)
      NEND = 0
      RETURN
  110 CALL KERNAB (FITEMS, BUF(NEND+1), NIT)
      NEND = NEND + NIT
      IF (NEND .LE. MAXBUF-NIT) RETURN
      GOTO 130
  120 BUF(NEND+1) = FSTOP
      CALL KERNZA (0.0, BUF(NEND+2), MAXBUF-NEND-1)
  130 CONTINUE
      WRITE (IFO, ERR=150, IOSTAT=NINQ) BUF
      NEND = 0
      RETURN
  150 WRITE (CHOUT, 160) FILEN, IFO
  160 FORMAT (' Error writing output file ', A6, ', unit number ', I3)
      CALL KERROR (CHOUT, 0, 'BINOFF')
      RETURN
      END
      SUBROUTINE ATOMIZ (LM, NLET, IZ)
      CHARACTER * 2 LM, L, LL, LLC, LLLC
      DIMENSION L(100), LLC(100), LLLC(100)
      CHARACTER Z *1
      DATA L    / 'H ', 'HE', 'LI', 'BE', 'B ', 'C ', 'N ', 'O ', 'F ',
     *      'NE', 'NA', 'MG', 'AL', 'SI', 'P ', 'S ', 'CL', 'AR', 'K ',
     *      'CA', 'SC', 'TI', 'V ', 'CR', 'MN', 'FE', 'CO', 'NI', 'CU',
     *      'ZN', 'GA', 'GE', 'AS', 'SE', 'BR', 'KR', 'RB', 'SR', 'Y ',
     *      'ZR', 'NB', 'MO', 'TC', 'RU', 'RH', 'PD', 'AG', 'CD', 'IN',
     *      'SN', 'SB', 'TE', 'I ', 'XE', 'CS', 'BA', 'LA', 'CE', 'PR',
     *      'ND', 'PM', 'SM', 'EU', 'GD', 'TB', 'DY', 'HO', 'ER', 'TM',
     *      'YB', 'LU', 'HF', 'TA', 'W ', 'RE', 'OS', 'IR', 'PT', 'AU',
     *      'HG', 'TL', 'PB', 'BI', 'PO', 'AT', 'RN', 'FR', 'RA', 'AC',
     *      'TH', 'PA', 'U ', 'NP', 'PU', 'AM', 'CM', 'BK', 'CF', 'ES',
     *      'FM' /
      DATA LLC  / 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ',
     *      'Ne', 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ',
     *      'Ca', 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu',
     *      'Zn', 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ',
     *      'Zr', 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In',
     *      'Sn', 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr',
     *      'Nd', 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm',
     *      'Yb', 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au',
     *      'Hg', 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac',
     *      'Th', 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es',
     *      'Fm' /
      DATA LLLC / 'h ', 'he', 'li', 'be', 'b ', 'c ', 'n ', 'o ', 'f ',
     *      'ne', 'na', 'mg', 'al', 'si', 'p ', 's ', 'cl', 'ar', 'k ',
     *      'ca', 'sc', 'ti', 'v ', 'cr', 'mn', 'fe', 'co', 'ni', 'cu',
     *      'zn', 'ga', 'ge', 'as', 'se', 'br', 'kr', 'rb', 'sr', 'y ',
     *      'zr', 'nb', 'mo', 'tc', 'ru', 'rh', 'pd', 'ag', 'cd', 'in',
     *      'sn', 'sb', 'te', 'i ', 'xe', 'cs', 'ba', 'la', 'ce', 'pr',
     *      'nd', 'pm', 'sm', 'eu', 'gd', 'tb', 'dy', 'ho', 'er', 'tm',
     *      'yb', 'lu', 'hf', 'ta', 'w ', 're', 'os', 'ir', 'pt', 'au',
     *      'hg', 'tl', 'pb', 'bi', 'po', 'at', 'rn', 'fr', 'ra', 'ac',
     *      'th', 'pa', 'u ', 'np', 'pu', 'am', 'cm', 'bk', 'cf', 'es',
     *      'fm' /
      IZ = -1
      Z = LM(2:2)
      CALL KERC2I (Z, KEND1)
      NLET = 1
      IF (KEND1.GT.10 .AND. KEND1.LT.37) NLET = 2
      LL = LM(1:NLET)
      IF (LL .EQ. 'Q' .OR. LL .EQ. 'q') LL = 'H'
      IF (LL.EQ.'D' .OR. LL.EQ.'T') LL = 'H'
      IF (LL.EQ.'d' .OR. LL.EQ.'t') LL = 'H'
      DO 100 I=1,100
      IF (LL.EQ.L(I) .OR. LL.EQ.LLC(I) .OR. LL.EQ.LLLC(I)) GOTO 110
  100 CONTINUE
      RETURN
  110 IZ = I
      RETURN
      END
      SUBROUTINE ATOMCH (IZ)
      INCLUDE 'Zsyst.inc'
      CHARACTER Z *1
      CHARACTER ZZ *2
      IF (NFDOL(2).GE.0) GOTO 150
      I = NCOLL(2)
      ZZ = CHIN(I:I+1)
      CALL ATOMIZ (ZZ, NLET, IZ)
      IF (IZ .LE. 0) GOTO 150
      I = I + NLET
      IF (CHIN(I:I).NE.' ') GOTO 110
      IF (NFDOL(3).EQ.2) RETURN
      IF (NFDOL(3).LE.0) GOTO 150
      K = NCOLN(1)
      IF (CHIN(K:K).EQ.'+' .OR. CHIN(K:K).EQ.'-') RETURN
      IF (K-I.GT.4) GOTO 150
      IF (NFNUM .EQ. 3) RETURN
      CHOUT(I:NCOLN(2)-1) = CHIN(K:NCOLN(2)-1)
      CHIN(I:NCOLN(2)-1) = CHOUT(I:NCOLN(2)-1)
      CHOUT = ' '
      CALL KERINB (LIT,1)
      RETURN
  110 Z = CHIN(I:I)
      CALL KERC2I (Z, 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
      RETURN
  150 CALL KERROR (' Incorrect atomic symbol', -6, 'ATOMCH')
      END
      SUBROUTINE ATOMIN (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      DIMENSION ATXYZ(10,MAXAT), IZAT(MAXAT)
      CHARACTER * 6 ATNAME(MAXAT)
      INCLUDE 'Zsyst.inc'
      CHARACTER      CHIN2 *80
   99 FORMAT (/' DIRDIF cannot proceed:'/
     *         ' the input ATOMS or ATMOD file is incorrect')
      IF (IFAT.LE.0 .OR. IFAT.GT.20) CALL KERROR (' IFAT?',-4,'ATOMIN')
      KEYS(1) = 0
      READ (IFAT, 105, ERR = 940, END = 940, IOSTAT = NINQ) CHIN(1:72)
  105 FORMAT (A72)
      CHIN2 = CHIN
      CALL KERINB (LIT, 1)
      IF (LIT(1) .NE. 'ATMOD' .AND. LIT(1) .NE. 'ATOMS'
     *   .AND. LIT(1) .NE. 'ATLIT' ) GOTO 951
      IF (LIT(1) .EQ. 'ATOMS' .AND. LIT(2) .NE.  CCODE) GOTO 953
      IF (LIT(1) .EQ. 'ATLIT' .AND. LIT(2) .NE.  CCODE) GOTO 953
      LEND = 999
      NAT = 1
  107 CALL ATOMIA (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND)
      IF (LEND.NE.0) GOTO 200
      NAT = NAT + 1
      IF (NAT .EQ. MAXAT) CALL KERROR ('Too many atoms', -6, 'ATOMIN')
      GOTO 107
  200 CONTINUE
      KEYS(1) = LEND
      NAT = NAT - 1
      IF (NAT .LE. 0) GOTO 955
      IF (LEND .LT. 0) WRITE (9, *)
     *  ' Warning ATOMS or ATMOD file: END card missing'
      CALL ATOMST (0, ATXYZ, NAT, KEYT)
      DO 302 I = 1, NAT
      IF (ATNAME(I) (1:1) .EQ. 'Q') THEN
         ATXYZ(4,I) = 0.0
         ATXYZ(5,I) = 0.0
         ENDIF
  302 CONTINUE
      CHIN = CHIN2
      CALL KERINB (LIT, 1)
      RETURN
  940 WRITE (9, 99)
      CALL KERROR('File error reading ATOMS or ATMOD file', 0,'ATOMIN')
  951 WRITE (9, 99)
      CALL KERROR
     *   ('No file identification on ATOMS or ATMOD file', -6,'ATOMIN')
  953 WRITE (9, 99)
      CALL KERROR ('Incorrect CCODE on ATOMS file', -6,'ATOMIN')
  955 WRITE (9, 99)
      CALL KERROR
     *   ('No atoms found on ATOMS or ATMOD file', -6, 'ATOMIN')
      END
      SUBROUTINE ATOMIA (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND)
      DIMENSION ATXYZ(10,MAXAT),   IZAT(MAXAT)
      CHARACTER * 6 ATNAME(MAXAT)
      INCLUDE 'Zsyst.inc'
      CHARACTER CHIN2 *80 ,  LITA(4) *6
      SAVE LEND2
      DATA LITA /'ATOM', 'BIJ', 'ATESD', 'BIJESD' /
      DATA LEND2 / 0 /
      IF (LEND .EQ. 999) THEN
         CALL KERIFF (IFAT, LITA, 4, LEND)
         IF (LIT(1).NE.'ATOM') CALL KERROR
     *   ('First atom on ATOMS or ATMOD file not: ATOM', -6, 'ATOMIA')
      ELSE
         CHIN = CHIN2
         LEND = LEND2
         CALL KERINB (LIT, 1)
         ENDIF
      IF (LEND.NE.0) RETURN
      CALL ATOMCH (IZAT(NAT))
      ATNAME(NAT) = LIT(2)
      DO 110 I = 1, 10
      IF (I.LE.3 .AND. NCOLN(I).LE.0) CALL KERROR
     *   ('Data on atoms card not correct', -6, 'ATOMIA')
  110 ATXYZ(I,NAT) = FNUM(I)
  117 CALL KERIFF (IFAT, LITA, 4, LEND)
      IF (LEND .NE. 0) GOTO 201
      GOTO (201, 202, 203, 204), NLUSER(1)
      CALL KERROR
     *   ('Record on ATOMS or ATMOD file not recognised', -6, 'ATOMIA')
  201 CHIN2 = CHIN
      LEND2 = LEND
      LEND = 0
      RETURN
  202 CALL KERNAB (FNUM, ATXYZ(5,NAT), 6)
      GOTO 117
  203 CALL KERNAB (FNUM, ATXYZ(1,NAT+1), 5)
      GOTO 117
  204 CALL KERNAB (FNUM, ATXYZ(5,NAT+1), 6)
      GOTO 117
      END
      SUBROUTINE ATOMPR (IPRX, NAPR, ATXYZ, ATNAME, IZAT, NAT)
      DIMENSION ATXYZ(10,NAT), IZAT(NAT), ATNAME(NAT)
      CHARACTER *6 ATNAME
      NATX = (NAPR * 5 + 1) / 2
      IF (NATX .GT. NAT) NATX = NAT
      IF (NATX .LT. NAT) NATX = NAPR
      IF (NATX .LE. 0) NATX = MIN0 (3, NAT)
      WRITE (IPRX, FMT='('' Number of atoms stored:'', I4)') NAT
      KEYT = 1
      DO 102 I=1,NATX
      IF (ATXYZ(4,I) .LT. 0.999 .OR. ATXYZ(5,I) .GT. 0.0001) KEYT = 2
      IF (ATXYZ(6,I) .GT. 0.000001) GOTO 103
  102 CONTINUE
      IF (KEYT .EQ. 1) WRITE (IPRX, FMT='
     *   ('' Atom name    x        y        z'', 8X,''Z'')')
      IF (KEYT .EQ. 2) WRITE (IPRX, FMT=' ('' Atom name    x'',
     *    ''        y        z'', 8X,''Z   occ.f.      B'')')
      GOTO 104
  103 WRITE (IPRX, FMT=' ('' Atom name    x'',
     *    ''        y        z'', 8X,''Z   occ.f.      B.equiv.'')')
  104 DO 109 I=1,NATX
      IF (ATXYZ(4,I) .LT. 0.999 .OR. ATXYZ(5,I) .GT. 0.0001) THEN
         WRITE (IPRX, 106)  ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I),
     *      (ATXYZ(J,I),J=4,5)
  106    FORMAT (3X, A6, 2X, 3F9.5, I4, 2F9.4)
      ELSE
         WRITE (IPRX, 106)  ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I)
         ENDIF
  109 CONTINUE
      IF (NAT .GT. NATX) WRITE (IPRX, FMT='('' Printing of remaining'',
     *                                    '' atoms supressed.'')')
      RETURN
      END
      SUBROUTINE ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      DIMENSION ATXYZ(10,NAT), ATNAME(NAT)
      CHARACTER *6 ATNAME
      INCLUDE 'Zsyst.inc'
      CHARACTER FATOMX * 6
      FATOMX = 'ATOMS'
      IF (SWITCH(25)) FATOMX = 'ATMOD'
      CALL ATOMWA (IATOMS)
      DO 109 NATR = 1, NAT
  109 CALL ATOMWB (IATOMS, ATXYZ, ATNAME, NATR)
      WRITE (8, 120) FATOMX, NAT
  120 FORMAT (' Number of atoms written to ', A6, 'file:', I4)
      WRITE (IATOMS, FMT = '(''END'')')
      RETURN
      END
      SUBROUTINE ATOMWA (IATOMS)
      INCLUDE 'Zsyst.inc'
      IF (SWITCH(25)) THEN
         WRITE (IATOMS, 101) PROGNM, KSTAT(13)
  101    FORMAT ('ATMOD  CART   generated by program ',
     *            A8, '  0   RUN', I4)
      ELSEIF (FNUM(32) .LT. 0.0001) THEN
         WRITE (IATOMS, 102) CCODE, PROGNM,  KSTAT(13)
  102    FORMAT ('ATOMS  ', A6, ' generated by program ',
     *            A8, '  0   RUN', I4)
      ELSE
         WRITE (IATOMS, 103) CCODE, PROGNM, KSTAT(13), FNUM(32)
  103    FORMAT ('ATOMS  ', A6, ' gener. progr. ',
     *            A8, '  0  RUN', I4, ' SC=', F12.7)
         FNUM(32) = 0.0
         ENDIF
      IF (CHOUT .NE. ' ') THEN
         WRITE (IATOMS, FMT = '(''REMARK '', A65)') CHOUT(1:65)
         CHOUT = ' '
         ENDIF
      RETURN
      END
      SUBROUTINE ATOMWB (IATOMS, ATXYZ, ATNAME, NATR)
      DIMENSION ATXYZ(10,NATR), ATNAME(NATR)
      CHARACTER *6 ATNAME
      INCLUDE 'Zsyst.inc'
      DIMENSION BEQ(1)
      BEQ(1) = ATXYZ(5,NATR)
      IF (ATXYZ(5,NATR) .GT. 0.00001 .AND. ATXYZ(6,NATR) .GT. 0.00001)
     *   CALL ATBEQ (ATXYZ(1,NATR), BEQ, 1)
      IF ((ATXYZ(4,NATR) .GT. 0.00001 .AND. ABS(ATXYZ(4,NATR)-1.)
     *   .GT. 0.00001) .OR. ATXYZ(5,NATR) .GT. 0.00001) THEN
         WRITE (IATOMS, 104) ATNAME(NATR), (ATXYZ(J,NATR), J=1,4), BEQ
  104    FORMAT ('ATOM  ', A6, 2X, 3F9.5, 2F8.4)
      ELSE
         WRITE (IATOMS, 104) ATNAME(NATR), (ATXYZ(J,NATR), J=1,3)
         ENDIF
      IF (ATXYZ(5,NATR) .GT. 0.00001 .AND. ATXYZ(6,NATR) .GT. 0.00001)
     *   WRITE (IATOMS, 108)  ATNAME(NATR), (ATXYZ(J,NATR), J = 5,10)
  108 FORMAT ('BIJ   ', A6, 2X, 6F9.5)
      RETURN
      END
      SUBROUTINE ATOMST (KEY, ATXYZ, NAT, KEYT)
      DIMENSION ATXYZ(10,NAT)
      PARAMETER (U2B = 8. * 3.141593 **2)
      FAC = U2B
      IF (KEY .EQ. 1) FAC = 1. / U2B
      KEYT = 1
      DO 200 I=1,NAT
      IF (ABS(ATXYZ(4,I)).LT.0.000001) ATXYZ(4,I) = 1.0
      IF (ATXYZ(5,I).LT.0.000001) THEN
         ATXYZ(5,I) = 0.0
         ATXYZ(6,I) = -0.000001
         GOTO 150
         ENDIF
      IF (ATXYZ(6,I).GT.0.000001) THEN
         KEYT = 3
      ELSE
         ATXYZ(6,I) = -0.000001
         ENDIF
      IF (KEYT.EQ.1) KEYT = 2
  150 IF (KEY .EQ. 0) GOTO 200
      IF (ABS(ATXYZ(5,I)) .LT. 0.000001) GOTO 200
      ATXYZ(5,I) = ATXYZ(5,I) * FAC
      IF (ATXYZ(6,I) .LE. 0.) GOTO 200
      DO 180 J=6, 10
  180 ATXYZ(J,I) = ATXYZ(J,I) * FAC
  200 CONTINUE
      RETURN
      END
      SUBROUTINE ATOMOC (KEY, ATXYZ, MSELF, NAT)
      DIMENSION ATXYZ(10,NAT), MSELF(NAT)
      INCLUDE 'Zcrys.inc'
      DIMENSION  XYZ(3)
      DO 150 I=1,NAT
      N = 0
      DO 140 IL=1,NLATT
      DO 140 J=1,NSYMM
      DO 120 K=1,3
  120 XYZ(K) = TSYMM(K,J) + TLATT(K,IL)
     *       + ATXYZ(1,I) * IRSYMM(K,1,J)
     *       + ATXYZ(2,I) * IRSYMM(K,2,J)
     *       + ATXYZ(3,I) * IRSYMM(K,3,J)
      N = N + ISELFD (ATXYZ(1,I), XYZ, 0.04)
      IF (ICENT.EQ.1)  GOTO 140
      DO 130 IC=1,3
  130 XYZ(IC) = -XYZ(IC)
      N = N + ISELFD (ATXYZ(1,I), XYZ, 0.04)
  140 CONTINUE
      IF (KEY .EQ. 0) MSELF(I) = N
      IF (KEY .EQ. 1) ATXYZ(4,I) = ATXYZ(4,I) / FLOAT(N)
      IF (KEY .LE. 1) GOTO 150
      ATXYZ(4,I) = ATXYZ(4,I) * FLOAT(N)
      IF (ABS (ATXYZ(4,I) - 1.0) .LT. 0.0001) ATXYZ(4,I) = 1.0
  150 CONTINUE
      RETURN
      END
      SUBROUTINE ATBEQ (ATXYZ, BEQ, NAT)
      DIMENSION ATXYZ(10,NAT), BEQ(NAT)
      INCLUDE 'Zcrys.inc'
      DIMENSION SI(3), CO(3), SISI(6)
      LOGICAL CONT
      DATA CONT /.FALSE./
      DATA R4 / 0.0 /
      IF (NAT .GT. 1) CONT = .FALSE.
      IF (CONT) GOTO 133
      CONT = .TRUE.
      WRITE (7, FMT='( '' ATBEQ ....  NAT= '', I4)') NAT
      RAD = 57.295789
      DO 100  I=4,6
      SI(I-3) = SIN(CELL(I)/RAD)
      CO(I-3) = COS(CELL(I)/RAD)
      IF (ABS(CELL(I)-90.).LT.0.0001)  CO(I-3)=0.0
  100 CONTINUE
      R4 = 1.0
      DO 110  I=1,3
  110 R4 = R4 - CO(I)**2
      R4 = (R4 + (2. * CO(1) * CO(2) * CO(3))) * 3.
      DO 130  I=1,3
      SISI(I) = SI(I)**2
      DO 130  J=1,3
      IF (J - I)   130, 130, 120
  120 SISI(9-I-J) = SI(I) * SI(J) * 2.0 * CO(6-I-J)
  130 CONTINUE
  133 DO 150  M=1,NAT
      B = 0.0
      DO 140  I=1,6
  140 B = B + SISI (I) * ATXYZ(I+4,M)
  150 BEQ(M) = B / R4
      RETURN
      END
      SUBROUTINE ATBETA (ATXYZ, NAT)
      DIMENSION ATXYZ(10,NAT)
      INCLUDE 'Zcrys.inc'
      DIMENSION RLP(3), RLP2(6)
      DO 200 K=1,3
      RLP(K)  = SQRT(SSMAT(K,K))
  200 RLP2(K) = SSMAT(K,K)
      RLP2(4) = RLP(2) * RLP(3) * 2.
      RLP2(5) = RLP(1) * RLP(3) * 2.
      RLP2(6) = RLP(1) * RLP(2) * 2.
      DO 220 I=1,NAT
      IF (ATXYZ(6,I).LE.0.0) GOTO 220
      DO 210 J=5,10
  210 ATXYZ(J,I) = ATXYZ(J,I) * RLP2(J-4)
  220 CONTINUE
      RETURN
      END
      SUBROUTINE CELZIN (ATXYZ, IZAT, NAT, NCELLZ, NCELIN)
      DIMENSION ATXYZ(10,NAT),  IZAT(NAT), NCELLZ(10), NCELIN(10)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      DIMENSION IOCC(1)
      CALL KERNZI (0, NCELIN, 10)
      DO 590 I = 1, NAT
      CALL ATOMOC (0, ATXYZ(1,I), IOCC(1), 1)
      NN = NINT (ATXYZ(4,I) * FLOAT (IMULT/IOCC(1)))
      DO 585 N = 1, NTYPE
      IF (NCELLZ(N) .NE. IZAT(I)) GOTO 585
      NCELIN(N) = NCELIN(N) + NN
      GOTO 590
  585 CONTINUE
      IF (IZAT(I) .LE. 1) GOTO 590
      CALL KERROR
     *   (' Input atom type not defined by CRYSDA', 585, 'CELZIN')
  590 CONTINUE
      WRITE (8, 614) (NCELIN(I), I=1,NTYPE)
  614 FORMAT (' Number of atoms input: ', 10I5)
      RETURN
      END
      SUBROUTINE RDCOND (IRDX, L, LMAX, KEND)
      CHARACTER * 6  L(LMAX)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zch80.inc'
      CHARACTER * 6  PROLD
      SAVE PROLD, KDAT
      DATA PROLD / '      ' /
      DATA NCH, NCHA, KDAT  / 0, 0, 0 /
      DATA N295 /0/
      KEND = -2
      IF (PROLD .NE. ' ') GOTO 300
      CALL FILINQ (IRDX, 'CONDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         WRITE (8, 190) CCODE
  190    FORMAT (' Control data file: ', A6,' CONDA not present')
         RETURN
         ENDIF
      CALL KERINA (IRDX, LIT, 1, LEND)
      IF (LEND.NE.0 .OR. LIT(1).NE.'CONDA' .OR. LIT(2).EQ.' ')
     * CALL KERROR ('ERROR on first record of CONDA file', 0, 'RDCOND')
      IF (CCODE .EQ. ' ') CCODE = LIT(2)
      WRITE (8, 230)
  230 FORMAT (/' Input control data file  CONDA')
      IF (CCODE .NE. LIT(2)) THEN
         WRITE (CHOUT, 250) CCODE, LIT(2)
  250    FORMAT ('ERROR: CCODE = ', A6,' but on CONDA file it is ', A6)
         CALL KERROR (CHOUT, 0, 'RDCOND')
         ENDIF
      NCH = 1
      NCHA = 1
      CH80(NCH) = CHIN
      CALL KERINA (IRDX, LIT, 1, LEND)
      IF (LEND.LT.0 .OR. LEND.GE.5) THEN
         WRITE (9, FMT='('' Empty CONDA file ...... '')')
         CALL FILCLO (IRDX, 'DELETE')
         RETURN
         ENDIF
      PROLD = '$DUMMY'
      IF (LIT(1) .NE. 'TITLE') BACKSPACE IRDX
  290 CALL KERINA (IRDX, L, LMAX, LEND)
      IF (LEND .LT. 0 .OR. LEND .GE. 5) THEN
         N295 = N295 + 1
         IF (N295 .LE. 2) WRITE (24, 295) L(1)
  295    FORMAT (' Requested record: PROGRAM ', A6 /
     *            ' not found in CONDA file ' )
         PROLD = ' '
         KEND = -1
         CALL FILCLO (IRDX, 'KEEP')
         RETURN
         ENDIF
      IF   (LIT(1).NE.'PROGRA' .OR. LIT(2).NE.L(1)) GOTO 290
      KDAT = 0
      KEND = 1
      RETURN
  300 KEND = 0
      CALL KERIFF (IRDX, L, LMAX, KSTOP)
      IF (KSTOP .LT. 0) GOTO 807
      IF (KSTOP .GE. 5) GOTO 803
      IF (KSTOP .NE. 0) GOTO 801
      IF (LIT(1).EQ.'PROGRA') GOTO 803
      IF (KDAT .EQ. 0) THEN
         WRITE (8, 320) CCODE
  320 FORMAT (' Input from control data file CONDA for compound ', A6)
         KDAT = 1
         ENDIF
      WRITE (8, 322) CHIN(1:65)
  322 FORMAT (' Input: ' , A65)
      IF (NLUSER(1).LE.0) CALL KERROR (' Unidentified control card',
     *    0, 'RDCOND')
      KEND = NLUSER(1)
      RETURN
  801 CALL KERINA (IRDX, LIT, 1, LEND)
      IF (LEND .EQ. -1) GOTO 807
  803 NCH = NCH + 1
      IF (LIT(1) .EQ. 'STOP' .OR. LIT(1) .EQ. 'FINISH') NCHA = NCHA+1
      IF (NCH .GE. MCH80) CALL KERROR ('CONDA too big', 801, 'RDCOND')
      CH80(NCH) = CHIN
      IF (LIT(1) .NE. 'STOP' .AND. LIT(1) .NE. 'FINISH') GOTO 801
  807 REWIND IRDX
      DO 808 I = 1, NCH
  808 WRITE (IRDX, FMT = '(A80)') CH80(I)
      REWIND IRDX
      IF (NCHA .GE. NCH) CALL FILCLO (IRDX, 'DELETE')
      PROLD =' '
      RETURN
      END
      SUBROUTINE LOGWR (IDDL)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IRUN, KSTAT(13))
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      CHARACTER*60 CHOUT2
      SAVE NCALL
      DATA NCALL / 0 /
      IF (CCODE .EQ. ' ') RETURN
      CHOUT2 = CHOUT(1:60)
      CALL FILINQ (IDDL, 'DDLOG', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ.EQ.0) GOTO 220
      WRITE (IDDL, 200) CCODE
  200 FORMAT ('DDLOG ', A6, '  DATA FILE    DO NOT DESTROY')
      WRITE (9, FMT='('' Welcome to DIRDIF Wonderland'' )')
      CHOUT = 'RUN   1'
      WRITE (IDDL, 217) PROGNM, CHOUT(1:60)
  217 FORMAT (A8, ' 0  ', A60)
      CHOUT = ' '
      IRUN = 1
      IF (CHOUT2 .EQ. ' ') RETURN
      GOTO 250
  220 READ (IDDL, FMT='(A3)', END=230) CHIN(1:3)
      IF (CHIN(1:3).NE.'END') GOTO 220
      GOTO 245
  230 WRITE (7, FMT='(A)')
     * ' Warning: no END record found on the DDLOG file'
  245 BACKSPACE IDDL
  250 CONTINUE
      IF (NCALL .EQ. 0) THEN
         NCALL = 1
         WRITE (IDDL, *) '-'
         ENDIF
      WRITE (IDDL, 260) PROGNM, CHOUT2
  260 FORMAT (A8, ' 0  ', A60 / 'END' / 'END')
      CHOUT = ' '
      RETURN
      END
      SUBROUTINE LOGRD (IDDL, LITX, KLOG)
      CHARACTER LITX *(*)
      INCLUDE 'Zsyst.inc'
      CHARACTER CHINX *72
      CHARACTER LITS(1) *6
      LITS(1) = LITX
      CALL FILCLO (IDDL, 'KEEP')
      CALL FILINQ (IDDL, 'DDLOG', 'FORMATTED', 'INPUT', KLOG)
      IF (KLOG.EQ.-1) RETURN
      ICOUNT = 0
      IREGEL = 0
  200 CALL KERINA (IDDL, LITS, 1, LEND)
      IF (ICOUNT .EQ. 0 .AND. LIT(1) .NE. 'DDLOG') THEN
         WRITE (9, FMT='('' DDLOG searching for '', A6)') LITS
         WRITE (9, FMT='('' Requested DDLOG incorrect; unit,'',
     *      '' name= '',I4,A6,'' ?? '',A6/1X)') IDDL, LIT(1), LIT(2)
         CALL KERNER (-4, 'LOGRD')
         ENDIF
      ICOUNT = ICOUNT + 1
      IF (LEND .EQ. -1) WRITE (7,
     *    FMT='('' Warning: no END marker on the DDLOG file'')' )
      IF (LEND .NE. 0) GOTO 230
      DO 210 I=1,NLIT
      IF (NLUSER(I).EQ.1) GOTO 220
  210 CONTINUE
      GOTO 200
  220 KLOG = I
      IREGEL = ICOUNT
      CHINX = CHIN(1:72)
      GOTO 200
  230 IF (KLOG .EQ. 0) RETURN
      CHIN = CHINX
      CALL KERINB (LITS, 1)
      REWIND (IDDL)
      DO 300 I=1,IREGEL
  300 READ (IDDL,FMT='(A1)')
      RETURN
      END
      SUBROUTINE COPY80 (IIN, FIN, IOUT, FOUT)
      CHARACTER FIN *(*), FOUT *(*), FINX *7, FOUTX *7
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (KSTAT(13), IRUN)
      CHARACTER LAST *6
      DATA IPATX /0/
      FINX  = FIN
      FOUTX = FOUT
      LAST = ' '
      IF (IIN.LE.0 .OR. IIN.GT.29 .OR. FIN.EQ.' ') STOP 62
      IF (IOUT.LE.0 .OR. IOUT.GT.29 .OR. FOUT.EQ.' ') STOP 62
      IF (IIN.EQ.5 .OR. IIN.EQ.6 .OR.
     *    IOUT.EQ.5 .OR. IOUT.EQ.6) STOP 62
      CALL FILCLO (IIN, 'KEEP')
      CALL FILCLO (IOUT, 'KEEP')
      CALL FILINQ (IIN, FINX, 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) RETURN
      CALL FILINQ (IOUT, FOUTX, 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ .EQ. -1) THEN
         IF (FOUT .EQ. 'ATRES' .OR. FOUT .EQ. 'ATOMS' .OR.
     *       FOUT .EQ. 'ATPAT' .OR. FOUT .EQ. 'ATORI' .OR.
     *       FOUT .EQ. 'ATTRA' .OR. FOUT .EQ. 'ATVEC' )  GOTO 200
         IF (FOUT .EQ. 'ATOLD') THEN
            WRITE (IOUT, 142) CCODE, CCODE, PROGNM, IRUN
  142       FORMAT ('ATOLD ', A6, ' back-up file (= ATOMS OLD) '/1X/
     *        '    Note: for proper reuse of old atomic parameters:'/
     *        '    select wanted header record (ATOMS ', A6, '), and'/
     *        '    copy it with following records up to (incl.) END'/
     *        '    to the ATOMS file'/1X/
     *        'First set appended by program ', A8, ' RUN', I4 /1X)
         ELSEIF (FOUT .EQ. 'ATTEM') THEN
            WRITE (IOUT, 143) CCODE, IRUN
  143       FORMAT ('ATTEM ', A6, ' file ( TEMPRY ATOMS ) created at',
     *         ' RUN', I4 /
     *       '   Note: these parameters are recycling intermediates'/1X)
         ELSEIF (FOUT .EQ. 'ATPATX') THEN
            IPATX = 0
            WRITE (IOUT, 144) FOUT, CCODE
  144       FORMAT ( A6, 1X, A6, ' PATTY sets expanded' )
            GOTO 195
         ELSE
            WRITE (IOUT, 149) FOUT, CCODE, IRUN
  149       FORMAT ( A6, 1X, A6, ' file created at RUN', I4 /1X)
            ENDIF
         GOTO 200
         ENDIF
      NR = 0
  150 READ (IOUT, 202, END=180, ERR=250) CHIN
      NR = NR + 1
      IF (CHIN(1:6) .NE. 'FINISH') THEN
         LAST = CHIN(1:6)
         GOTO 150
         ENDIF
      BACKSPACE IOUT
      GOTO 190
  180 REWIND IOUT
      DO 182 I = 1, NR
  182 READ (IOUT, 202)
  190 IF (LAST .NE. 'END   ') WRITE (IOUT, FMT='(''END'')')
      IF (FOUT .EQ. 'ATTRA') GOTO 200
  195 IF (FOUT .EQ. 'ATPATX') THEN
         IPATX = IPATX + 1
         WRITE (IOUT, 196) IRUN, IPATX
  196       FORMAT (/'PATTY set expanded: RUN=', I4, ' IPAT=', I3 /1X)
      ELSE
         WRITE (IOUT, 197) PROGNM, IRUN
  197    FORMAT (/'Next file appended by program ', A8, ' RUN', I4 /1X)
         ENDIF
  200 CONTINUE
      N = 0
      READ (IIN, 202, END=210, ERR=270) CHIN
  202 FORMAT (A80)
      N = N + 1
      WRITE (IOUT, 202) CHIN
      IF (CHIN(1:6) .NE. 'FINISH') GOTO 200
  210 IF (CHIN(1:6) .NE. 'FINISH') WRITE (IOUT, FMT='(''FINISH'')')
      REWIND IIN
      CALL FILCLO (IOUT, 'KEEP')
      RETURN
  250 WRITE (CHOUT, 280) FOUTX, IOUT
      GOTO 282
  270 WRITE (CHOUT, 280) FINX, IIN
  280 FORMAT (' Error reading file ', A7, ', unit number ', I3)
  282 CALL KERROR (CHOUT, 0, 'COPY80')
      RETURN
      END
      SUBROUTINE VALDIS (KEY, V1, V2, KARR, KM, KEND)
      SAVE
      DIMENSION KARR(KM)
      DATA VINC, VBOT, VTOP, VSUB, VMIN / 0.0, 0.0, 0.0, 0.0, 0.0 /
      IF (KEY) 100, 110, 140
  100 KEND = 0
      CALL KERNZI (0, KARR, KM)
      VMIN = V1
      VINC = (V2 - V1) / (KM - 2)
      VSUB = VMIN - VINC - VINC
      GOTO 130
  110 KEND = KEND + 1
      IF (KEND.GT.1) GOTO 120
      VBOT = V1
      VTOP = V1
  120 IF (V1.GT.VTOP) VTOP = V1
      IF (V1.LT.VBOT) VBOT = V1
      KAD = IFIX( (V1 - VSUB) / VINC )
      IF (KAD.LE.0)  KAD = 1
      IF (KAD.GT.KM) KAD = KM
      KARR(KAD) = KARR(KAD) + 1
  130 RETURN
  140 IF (VINC.GT.0.) GOTO 150
      VSUB = VBOT
      VBOT = VTOP
      VTOP = VSUB
  150 KE = KEND - KEY
      V1 = VBOT
      IF (KE.LE.0) GOTO 130
      KSOM = 0
      DO 160 KAD=1,KM
      KSOM = KSOM + KARR(KAD)
      IF (KSOM.GE.KE) GOTO 170
  160 CONTINUE
  170 A2 = VMIN + KAD*VINC - VINC
      A1 = A2 - VINC
      IF (KAD.EQ.1)  A1 = VBOT
      IF (KAD.EQ.KM) A2 = VTOP
      V1 = A1 + ((A2-A1) * (KE-KSOM+KARR(KAD))) / KARR(KAD)
      GOTO 130
      END
      SUBROUTINE LINPRI (KEY, FITEMS, NIT)
      DIMENSION FITEMS(*)
      SAVE
      INCLUDE 'Zsyst.inc'
      CHARACTER PRFORM *72
      PARAMETER (MAXBUF = 100)
      DIMENSION BUF(MAXBUF)
      DATA NUMNIT, NITMAX, IPR  / 0, 0, 0 /
      IF (NIT.GT.MAXBUF .OR. NIT.LE.0) CALL KERROR
     *    (' Incorrect number of items send to LINPRI', 0, 'LINPRI')
      IF (KEY) 240, 220, 200
  200 IPR = KEY
      PRFORM = CHOUT
      CHOUT = ' '
      NITMAX = NIT
  210 CALL KERNZA (0., BUF, NITMAX)
      NUMNIT = 0
      RETURN
  220 IF (NUMNIT+NIT.GT.NITMAX) THEN
          WRITE (IPR, FMT=PRFORM) (BUF(IBUF),IBUF=1,NUMNIT)
          CALL KERNZA (0., BUF, NITMAX)
          NUMNIT = 0
      ENDIF
      DO 230 I=1,NIT
  230 BUF(NUMNIT+I) = FITEMS(I)
      NUMNIT = NUMNIT + NIT
      RETURN
  240 IF (NUMNIT.GT.0) WRITE (IPR, FMT=PRFORM) (BUF(IBUF),IBUF=1,NUMNIT)
      GOTO 210
      END
      SUBROUTINE XHELP
      CHARACTER*64 CH(549)
      DATA (CH(I), I=1, 9)
     1/'+101 Usually DIRDIF is started by typing ',
     2'DIRDIF CCODE    (CCODE means: give the true compound code) or:',
     3'DIRDIF CCODE PARAMS  (PARAMS: give one or more parameters) or:',
     4'DIRDIF H   (H means: help                                     ',
     5'==> in some implementations, type <dirdif>  (lower case) C$   ',
     6'+102 The HELP option can be activated by entering: DIRDIF H   ',
     7'but any second parameter then is ignored!   C$                ',
     8'+103 The HELP option is activated by entering DIRDIF H ',
     9'NOTE: it is also be activated by entering the letter H       '/
      DATA (CH(I), I=  10,  19)
     * /'as an answer to various questions. Help now is available for:',
     1'+103.01 CCODE CONDA DIRDIF PROG FILES START AUTO TEST H R Q   ',
     2'Please, enter one of these HELP options.                      ',
     3'+A CCODE 103.1 CONDA 103.2 H 103.4 R 103.5 Q 103.6            ',
     4'+A DIRDIF 103.7                                               ',
     5'+A PROG 103.75 FILES 103.8 START 103.9 AUTO 103.91 TEST 103.92',
     6'+103.1                                                        ',
     7'The DIRDIF command file is activated with parameters,         ',
     8'denoted &1, &2, &3... If there is no parameter, or if &1 = H  ',
     9'(for Help), the present help option is invoked.  '/
      DATA (CH(I), I=  20,  29)
     * /'. For normal use: the first parameter &1 is a compound code ',
     1'to be denoted CCODE : CCODE stands for an alphanummeric word  ',
     2'(up to 6 characters, of which the first one must be a letter) ',
     3'which identifies the structure under investigation, and       ',
     4'which is used to define the files in use for this structure.  ',
     5'. Usually no more parameters are needed.                      ',
     6'. Control will be given to the program DDSTART for an online  ',
     7'(interactive) preparation of the JOB stream control data.     ',
     8'. When the second parameter is a program name, it refers to a ',
     9'special option or a fully automatic run (see primer ).        '/
      DATA (CH(I), I=  30,  39)
     * /'+103.11 -------                                             ',
     1'We repeat the present help options: 103.01$                   ',
     2'+103.2 Most calculations are controled by the CONDA  file:    ',
     3'usually it is generated automatically, and erased at the end. ',
     4'The CONDA option allows the CONDA file to be saved.           ',
     5'To gain experience, do try out different options. 103.11$     ',
     6'+103.4 H stands for : please, enter H for (more) help.        ',
     7'Usually, H is not mentioned as one of the options, but you    ',
     8'may always enter H to see if there is any help.               ',
     9'Note: when a question is asked by the DIRDIF system,          '/
      DATA (CH(I), I=  40,  49)
     * /'it is followed by                                           ',
     1'- a list of possible answers, names, etc., or                 ',
     2'- a list of choices (usually abreviated, in parentheses,      ',
     3'for instance: (Y / N / Q) for Yes, No or Quit, repectively.   ',
     4'Dont hesitate to try one or more of the answers or choices:   ',
     5'more info will become available, and usually there is a way to',
     6'go back. If in doubt, try: H for Help. H never does any harm. ',
     7'Now help is available for:  Q$                                ',
     8'+103.5 R stands for: Repeat                                   ',
     9'If R is entered, we will repeat the question or the list of   '/
      DATA (CH(I), I=  50,  59)
     * /'possible options. (R is never shown in the list of options, ',
     1'except in the present call for DIRDIF H) 103.11$              ',
     2'+103.6 Q stands for: Quit = return to preceding level of      ',
     3'interrogation. Note: sometimes you must re-enter: Q           ',
     4'To enter Q is always allowed, but usually it is not           ',
     5'shown in the list of options.                                 ',
     6'So Quit this HELP session ----- C$                            ',
     7'+103.7 The new DIRDIF program is a unification of programs    ',
     8'for the ab-initio solution of structures by Patterson methods ',
     9'[ using Heavy Atom- as well as Vector Search techniques ]     '/
      DATA (CH(I), I=  60,  69)
     * /'and for partial structure expansion by direct methods,      ',
     1'and for R2-driven Fourier recycling techniques.               ',
     2'. The main programs ORIENT, TRACOR, PHASEX, FOUR, .... will be',
     3'activated by the control and supervisor program DDSTART,      ',
     4'as soon as you have entered: DIRDIF CCODE (true compound code)',
     5'and have answered the appropriate questions about what to do. ',
     6'. Note about ORIENT : you need to prepare a file CCODE ATMOD  ',
     7'with atomic parameters of the known (rigid) molecular fragment',
     8'before using vector search methods to find the orientation of ',
     9'the fragment; further calculations (calls for sub-programs)   '/
      DATA (CH(I), I=  70,  79)
     * /'are done automatically.                                     ',
     1'. Note about PHASEX : within the DIRDIF system the name PHASEX',
     2'refers to the phase refinement and phase expasion procedure   ',
     3'using DIRect methods applied to DIFference structure factors. ',
     4'When atomic coordinates have not been generated by foregoing  ',
     5'Patterson methods, an input ATOMS file is needed.             ',
     6'. More details about the main programs or options will become ',
     7'available on running DIRDIF for your compound. 103.11$        ',
     8'+103.75 PROG : summary of main programs:                      ',
     9'DDSTART supervisor program (interactive starting up)          '/
      DATA (CH(I), I=  80,  89)
     * /'DDMAIN  various calculations  (not to be called by the user)',
     1'CRYSDA  prepare the CRYSDA file (usually done automatically)  ',
     2'                                                              ',
     3'ORIENT  Vector search orientation: called by option ORIENT    ',
     4'TRACOR  translations by correlation  (automat. after ORIENT)  ',
     5'TRAVEC  select from multiple TRACOR results  (Vector Search)  ',
     6'PHASEX  phase expansion using DIR. meth. on DIFference strf.  ',
     7'. Note: option PHASEX means: programs DDMAIN + PHASEX + FOUR  ',
     8'FOUR    Fourier program  (automatically called  when needed)  ',
     9'NUTS    Nijmegen UTility System:  a collection of utilities:  '/
      DATA (CH(I), I=  90,  99)
     * /'.    e.g. the options : AT2X, X2AT, BIJVOET ... etc.',
     1'.    For more details, just try:  DIRDIF CCODE NUTS  103.11$  ',
     2'+103.8 The DIRDIF system uses many files which you do not     ',
     3'need to know.  However some of them are of importance:        ',
     4'.  Input reflection data: FREF SHELX SHELXL HKL etc;          ',
     5'.  - to be prepared automatically by your local system.       ',
     6'                                                              ',
     7'.                                                             ',
     8'. Input primary crystal data: CRYSIN . This should also       ',
     9'. - automatically be prepared by the loal computing system.   '/
      DATA (CH(I), I= 100, 109)
     * /'. Atomic parameters: see test examples and PRIMER: they are ',
     1'ATMOD : fractional or Cartesian coords.: model for ORIENT,    ',
     2'ATOMS : fractional coords.: input for TRACOR, PHASEX, FOUR,   ',
     3'ATOMS : also final output of the Fourier program FOUR,        ',
     4'ATOLD : some input or intermediate atomic params  (= back up) ',
     5'ORUSER: your private collection of search models for ORIENT   ',
     6'.  Listing files: may or may not be printed:                  ',
     7'LIS1 = CCODE LISTING = main prints for inspection, results,   ',
     8'LIS2 = auxiliar LISTING : more data to check when problems.   ',
     9'.   Other files (DDLOG, CONDA, etc.)                        '/
      DATA (CH(I), I= 110, 119)
     * /'. may sometimes be of importance for the experienced user.  ',
     1'+103.801 For a summary,                                       ',
     2'enter: SHELX, CRYSIN, ATMOD, or ATOMS. Else: Q                ',
     3'+A SHELX 103.81 CRYSIN 103.82 ATMOD 103.83 ATOMS 103.84       ',
     4'+A H 103.8 Q 103.11                                           ',
     5'+103.81 SHELX write-up ...                                    ',
     6'the file names SHELX or SHEXL or HKL refer to the             ',
     7'SHELX reflection data file with either F or F-squared!        ',
     8'No default: a HKLF record is needed with: HKLF 3 or HKLF 4.   ',
     9'This record may be present in the SHELXL RES or - INS file,   '/
      DATA (CH(I), I= 120, 129)
     * /'or it may be inserted as a leading record in the file.      ',
     1'SHELX data records are: (3I4,2F8.2)                           ',
     2'for h k l F-or-F**2 Sigma 103.801$                            ',
     3'+103.82 CRYSIN : an example for CCODE = MONOX                 ',
     4'CRYSIN MONOX                                                  ',
     5'CELL 8.166 11.405 15.936 90 90 90                             ',
     6'CELLSD 0.004 0.003 0.004 0 0 0                                ',
     7'SPGR P 21 21 21                                               ',
     8'WAVE CU                                                       ',
     9'REMARK : the contents of he entire unit cell is: FORMUL * Z   '/
      DATA (CH(I), I= 130, 139)
     * /'FORMUL C 15.00 H 16.00 N 2 O 2 S 1                          ',
     1'Z 4                                                           ',
     2'END                                                           ',
     3'        103.801$                                              ',
     4'+103.83 ATMOD write-up ...                                    ',
     5'        103.801$                                              ',
     6'+103.84 ATOMS write-up ...                                    ',
     7'        103.801$                                              ',
     8'+103.9 DIRDIF should be imbedded in your local system:        ',
     9'see the PRIMER about the reflection data files, etc.          '/
      DATA (CH(I), I= 140, 149)
     * /'By entering at the terminal:                                ',
     1'DIRDIF CCODE (where CCODE is your true compound code name)    ',
     2'you will be prompted to tell what you want to do.             ',
     3'For ORIENT you must have prepared in advance an ATMOD file    ',
     4'-   (or you know that a model is present in the ORBASE),      ',
     5'for PHASEX or TRACOR or FOUR you must have an ATOMS file,     ',
     6'-   or be ready to supply the atomic params at the terminal.  ',
     7'The automatic procedure is called by entering at the terminal:',
     8'DIRDIF CCODE PROG (=> ORIENT, TRACOR, PATTY, PHASEX or FOUR)  ',
     9'If this is your first DIRDIF experience, please, do try it out'/
      DATA (CH(I), I= 150, 159)
     * /'on the MONOS test example as described in the PRIMER.       ',
     1'In this help-session you may enter now: TEST 103.11$          ',
     2'+103.91 AUTO : fully automatic runs are most useful if your   ',
     3'local system automatically prepares a CRYSIN file (with space ',
     4'group, etc.) and for ORIENT, PHASEX, FOUR prepares (with your ',
     5'help) the ATMOD or ATOMS file.                                ',
     6'Possible starting-up calls are: DIRDIF CCODE PROG             ',
     7'- where CCODE is your true compound code                      ',
     8'- and PROG is: ORIENT, TRACOR, PHASEX, FOUR or PATTY          ',
     9'NOTE: if you do not want automatic recycling, you can add     '/
      DATA (CH(I), I= 160, 169)
     * /'NORECY as an extra parameter,                               ',
     1'i.e. enter: DIRDIF CCODE PROG NORECY (with proper CCODE       ',
     2'and PROG). This is adviced only if you know that you          ',
     3'can do better than the automatic recycling procedure! 103.11$ ',
     4'+103.92 TEST : CCODE = MONOS. Data are supplied with the      ',
     5'DIRDIF system, including the CRYSIN file (with space group,   ',
     6'etc.) and the FREF file.                                      ',
     7'Note: the total number of indepndnt non-hydrogen atoms is 20. ',
     8'Test interactive procedures.                                  ',
     9'Test ORIENT: enter: DIRDIF MONOS                              '/
      DATA (CH(I), I= 170, 179)
     * /'- ask for ORIENT, select ATMOD from ORBASE, model code: MONOS',
     1'Test PHASEX: enter: DIRDIF MONOS                              ',
     2'- ask for PHASEX, supply one S atom now: S 0.000 0.097 0.146  ',
     3'- or the same without enantiomer problem: S 0.017 0.097 0.146 ',
     4'ADVICED GENERAL STRATEGIES FOR SOLVING YOUR STRUCTURE         ',
     5'1. To solve MONOS as a heavy atom structure,                  ',
     6'.  enter: DIRDIF MONOS PATTY                                  ',
     7'2. To use Vector Search: make ATMOD file first,               ',
     8'.  e.g. for MONOS, enter:                                     ',
     9': DIRDIF MONOS ORBASE : ask for model code MONOS, then enter: '/
      DATA (CH(I), I= 180, 189)
     * /': DIRDIF MONOS ORIENT: have the structure solved using ATMOD.',
     1'To get some experience: try everything and read all output !  ',
     2'103.11$                                                       ',
     3'+104 The call: DIRDIF ? or HELP or END means: DIRDIF H C$     ',
     4'+105 Sorry...., the string CCODE                              ',
     5'is not accepted as a possible name for a compound.            ',
     6'CCODE is a mnemonic for a string with                         ',
     7'up to 6 characters, the first being a letter. 106.1$          ',
     8'+106 Sorry...., the string BATCH is not accepted              ',
     9'as a possible  name for a compound.                           '/
      DATA (CH(I), I= 190, 199)
     * /'+106.1 Please try some other help options. C$               ',
     1'+109 Remember:                                                ',
     2'- you can always answer any question with H or R or Q         ',
     3'- (for Help, Repeat or Quit, resp.) C$                        ',
     4'+110 Please select one of the following options:              ',
     5'ORIENT, TRACOR, PHASEX, DIRP1, FOUR, PATTY, U, X              ',
     6'+A X 110.1 U 110.2 H 110.01  N 0                              ',
     7'+A ORIENT 0 TRACOR 0  PHASEX 0  DIRP1 0 FOUR 0                ',
     8'+A PATTY 0 PATTER 0                                           ',
     9'+A FCALC 0 DDMAIN 0  FOUR 0  NUTS 0                           '/
      DATA (CH(I), I= 200, 209)
     * /'+A AT2X 0 X2AT 0  CRYSDA 0  MERBIN 0                        ',
     1'                                                              ',
     2'+A EDAT 0 SHAT 0  EULER 0  INVERT 0                           ',
     3'+A BIJVOE 0 SHELIN 0                                          ',
     4'                                                              ',
     5'+110.01 Short summary of these options:                       ',
     6'ORIENT Vector search ORIENTation:                             ',
     7'.   input file ATMOD = geom.known fragment                    ',
     8'TRACOR TRAnslations by CORrelation:                           ',
     9'.   input ATOMS = misplaced fragment                          '/
      DATA (CH(I), I= 210, 219)
     * /'PHASEX PHASe EXpansion and -refinement:                     ',
     1'.   input ATOMS = partial structure                           ',
     2'DIRP1 PHASEX with (autom) expansion to P1 for troubles with   ',
     3'.   Heavy.At.                                                 ',
     4'FOUR Fourier methods (various options)                        ',
     5'PATTY Heavy Atom Patterson Interpretation .                   ',
     6'U    : Utility programs                          Q$           ',
     7'+110.1                                                        ',
     8'                                                              ',
     9'                                                              '/
      DATA (CH(I), I= 220, 229)
     * /'                                                            ',
     1'                                                              ',
     2'                                                              ',
     3'                                                              ',
     4'+110.2 Note: U stands for some utility programs.              ',
     5'Next time, do not enter U, but enter the correct program name,',
     6'as you can do now; please choose:                             ',
     7'+110.21 CRYSDA, MERBIN, NUTS, AT2X, X2AT,                     ',
     8'SHAT, EULER, INVERT, BIJVOET, FCALC, DDMAIN,                  ',
     9'FFT, PATTER, SHELIN, R2                                       '/
      DATA (CH(I), I= 230, 239)
     * /'+A FCALC 0 DDMAIN 0 FFT 0 PATTER 0                          ',
     1'+A AT2X 0 X2AT 0 CRYSDA 0 MERBIN 0 H 110.3                    ',
     2'                                                              ',
     3'+A SHAT 0 EULER 0 INVERT 0 NUTS 0                             ',
     4'+A SHELIN 0 BIJVOE 0 R2 0                                     ',
     5'+110.3 Short summary of some of these options:                ',
     6'CRYSDA and MERBIN : call for a rerun of these programs        ',
     7'NUTS : call for interactive use of                            ',
     8'one of the following utilities:                               ',
     9'AT2X, X2AT : transform ATOMS into SHELX XYZN file, and v.v.   '/
      DATA (CH(I), I= 240, 249)
     * /'                                                            ',
     1'                                                              ',
     2'                                                              ',
     3'SHAT, EULER and INVERT : shift, rotate or invert ATOMS        ',
     4'BIJVOET : calculate the Bijvoet coefficients etc.             ',
     5'FCALC, DDMAIN, FOUR : single run options for expert users     ',
     6'PATTER : calculation of a sharpened Patterson (no interpr.)   ',
     7'SHELIN : set up of SHELX input cards    Q$                    ',
     8'+201.3 Do you want to use (and maybe update) this file? (Y/N) ',
     9'+A Y 0 N 201.31 Q 201.33 H 0                                  '/
      DATA (CH(I), I= 250, 259)
     * /'+201.31 New file ATMOD is to be created. C$                 ',
     1'+201.32 Use local facilities to inspect your file.            ',
     2'Use Q to exit. C$                                             ',
     3'+201.33 Quit: full stop now, inspect ATMOD file. C$           ',
     4'+201.34 Is all OK?                                            ',
     5'Can we use (and maybe edit) this file? (Y/N)                  ',
     6'+A Y 0 N 201.32 Q 201.32 H 0                                  ',
     7'+201.4 No file ATMOD with positional parameters of the search ',
     8'model is available. C$                                        ',
     9'+201.41 Can you supply the atomic parameters now (at the      '/
      DATA (CH(I), I= 260, 269)
     * /'Terminal (T) or Select or Suggest an item from ORBASE (S) ? ',
     1'+A T 0 S 201.433 Q 201.42 H 201.43                            ',
     2'+201.42 Sorry! Without a model (molecular fragment) ORIENT    ',
     3'can not run.  Please, do get an ATMOD parameter file.         ',
     4'Bye bye. C$                                                   ',
     5'+201.43 If you have a search fragment (set of atomic          ',
     6'parameters which  defines a part of the molecule in arbitrary ',
     7'orientation), given either as Cartesian or as fractional      ',
     8'coordinates (in any unit cell),  you can either enter these   ',
     9'coordinates now (enter: T)                                    '/
      DATA (CH(I), I= 270, 279)
     * /'or select an entry from the small data base ORBASE (enter: S)',
     1'or quit (meaning full stop, enter: Q) and                     ',
     2'. use local editing facilities to prepare the ATMOD file.     ',
     3'. Information about the format is given in the handout. Q$    ',
     4'+201.433 We will now read ORBASE to find your model C$        ',
     5'+201.44 or are the parameters given in a different cell?      ',
     6'If Y you will be prompted to supply the model cell. (Y/N)     ',
     7'+A Y 0 N 0 H 201.46 Q 201.47                                  ',
     8'+201.45 Give the unit cell of the model. Supply six numbers   ',
     9'(A, B, C in Angstrom, alpha, beta, gamma in degrees):         '/
      DATA (CH(I), I= 280, 289)
     * /'+D MCELL 6 0                                                ',
     1'+201.46 We must know the unit cell (if parameters come from   ',
     2'an other  structure): A, B, C in Angstrom, angles in degrees, ',
     3'so is it the present cell Q$                                  ',
     4'+201.47 We must know the unit cell ... C$                     ',
     5'+201.5 Do you need (more) special control data to execute     ',
     6'ORIENT?  (N PARAMS VMAX MIN PRINT PRIMAP H Q)                 ',
     7'+A H 201.51 PARAMS 201.52 VMAX 201.53 MIN 201.54 PRINT -1     ',
     8'+A PRIMAP 201.56 N 0 Q 0                                      ',
     9'+201.51 Possible control data entries are:                    '/
      DATA (CH(I), I= 290, 299)
     * /'PARAMS for ABC-scan parameters for angular ranges           ',
     1'.   (angles in degrees)                                       ',
     2'- You may supply many sets of PARAMS                          ',
     3'.   for consecutive calculations                              ',
     4'VMAX for maximum vector length                                ',
     5'.   (to be used in fine scan, default 7.5)                    ',
     6'MIN for minimum functions MIN(N), N = ? (max. 3 numbers)      ',
     7'PRINT for printing additional intermediate results            ',
     8'. (for instance atoms, vectors) on your output listing        ',
     9'PRIMAP for bulk listing of the maps PATIN, DEK and MAPSIG     '/
      DATA (CH(I), I= 300, 309)
     * /'. (the files are not automatically printed by the program)  ',
     1'Q to quit (also use Q to escape). Q$                          ',
     2'+201.52 PARAMS for ABC scan (begin, increment, nr.of points,  ',
     3'.   for A,B,C),  enter nine numbers, in this order:           ',
     4'  ==>  Abeg Aincr Nr. Bbeg Bincr Nr. Cbeg Cincr Nr.           ',
     5'+D PARAMS 9 0                                                 ',
     6'+201.53 VMAX for max vectorlength to be used. Enter one number',
     7'+D VMAX 1 0                                                   ',
     8'+201.54 .                                                     ',
     9'ORIENT calculates the minimum functions MIN(N), N = ... ?     '/
      DATA (CH(I), I= 310, 319)
     * /'Enter 1, 2 or 3 numbers (in the order of increasing value)  ',
     1'+D MIN -4 0                                                   ',
     2'+201.56 PRIMAP for bulk listing of the Patterson map (PATIN)  ',
     3'and/or the input map for the search (DEK)                     ',
     4'and/or the output maps of the scan ranges (MAPSIG).           ',
     5'. Enter 1, 2 or 3 keywords (PATIN, DEK, MAPSIG)               ',
     6'+D PRIMAP 0 -3                                                ',
     7'+202                                                          ',
     8'Do you need (more) special control data to execute TRACOR?    ',
     9'(N EMIN SCSG BHSG DAMP SMM PRINT PRIMAP STLMAX PSQMAX H Q)    '/
      DATA (CH(I), I= 320, 329)
     * /'+A H 202.05 EMIN 202.1 SCSG 202.2 BHSG 202.3 DAMP 202.4     ',
     1'+A SMM 202.5                                                  ',
     2'+A PRINT -1 PRIMAP -1 STLMAX 202.8 PSQMAX 202.9 N 0 Q 0       ',
     3'+202.05 Possible control data entries are:                    ',
     4'EMIN for minimum E value                                      ',
     5'SCSG additional scale factor (must be around 1.0)             ',
     6'BHSG additional temp.factor for model (Bp := Bp + BHSG)       ',
     7'DAMP damping factor (anything better than default???)         ',
     8'STLMAX limitations on reflections (if not given with FCALC)   ',
     9'PSQMAX value of PSQ after symmetry application                '/
      DATA (CH(I), I= 330, 339)
     * /'.   (only for use if a                                      ',
     1'- heavy atom of the model is expected to lie on a symm.elem.  ',
     2'Q to quit (also use Q to escape). Q$                          ',
     3'+202.1 enter EMIN (minimum E value) :                         ',
     4'+D EMIN 1 0                                                   ',
     5'+202.2 enter SCSG additional scale factor                     ',
     6'.   (must be around 1.0):                                     ',
     7'+D SCSG 1 0                                                   ',
     8'+202.3 enter BHSG additional temp.factor for model            ',
     9'.   (Bp := Bp + BHSG):                                        '/
      DATA (CH(I), I= 340, 349)
     * /'+D BHSG 1 0                                                 ',
     1'+202.4 enter DAMP damping factor (suggested range 1. - 10.):  ',
     2'+D DAMP 1 0                                                   ',
     3'+202.5 enter SMM weet ik niet: doe maar Q ?                   ',
     4'+D SMM 1 0                                                    ',
     5'+202.8 enter STLMAX limitations on reflections to be used:    ',
     6'+D STLMAX 1 0                                                 ',
     7'+202.9 enter PSQMAX value of PSQ after symmetry application:  ',
     8'+D PSQMAX 1 0                                                 ',
     9'+203 Do you need (more) special control data to run PHASEX?   '/
      DATA (CH(I), I= 350, 359)
     * /'(N STLMAX MAXHKL LOCCEN NCEST ACCEPT PRINT H Q)             ',
     1'+A H 203.05 STLMAX 203.1 MAXHKL 203.2 LOCCEN 203.3            ',
     2'+A NCEST 203.4                                                ',
     3'+A ACCEPT 203.5 PRINT -1 N 0 Q 0                              ',
     4'+203.05 Possible control data entries are:                    ',
     5'STLMAX for maximum value of sin(theta)/lambda                 ',
     6'MAXHKL for maximum value of hkl. Enter 0 for those indices    ',
     7'- on which you do not want to impose a limit.                 ',
     8'LOCCEN approximate center of symmetry in model structure      ',
     9'- (a center of symmetry will be found by the program,         '/
      DATA (CH(I), I= 360, 369)
     * /'- but if the deviations are too large the user can force    ',
     1'- the execution of the enantiomorph-fixation procedure)       ',
     2'NCEST number of cycles for tangent refinement (max. 5)        ',
     3'- and five E-start values. Enter 0 for NCEST and for the      ',
     4'- first E-start value if default values should be used.       ',
     5'ACCEPT min. value of alpha / beta (= QEET) and max. number    ',
     6'- of reflections accepted for secondary set of symbolic       ',
     7'- reflections (= MAXT). Enter 0 for those indices on which    ',
     8'_ you do not want to impose a limit.                          ',
     9'PRINT bulk print requested (when you have a problem)          '/
      DATA (CH(I), I= 370, 379)
     * /'Q to quit (also use Q to escape). Q$                        ',
     1'+203.1 STLMAX for maximum value of sin(theta)/lambda.         ',
     2'.   Enter one number.                                         ',
     3'+D STLMAX 1 0                                                 ',
     4'+203.2 MAXHKL for maximum value of hkl. Enter three numbers.  ',
     5'.   Enter 0 for those indices                                 ',
     6'.   on which you do not want to impose a limit.               ',
     7'+D MAXHKL 3 0                                                 ',
     8'+203.3 LOCCEN if the model structure has an approximate       ',
     9'center of symmetry. Enter the fractional coords x, y and z    '/
      DATA (CH(I), I= 380, 389)
     * /'of the (pseudo) center of symmetry (three numbers):         ',
     1'+D LOCCEN 3 0                                                 ',
     2'+203.4 NCEST: number of cycles of tangent refinement (max. 5) ',
     3'and five E-start values. Enter 0 for NCEST and for the        ',
     4'first E-start value if default values should be used.         ',
     5'+D NCEST 6 0                                                  ',
     6'+203.5 ACCEPT for min. value of alpha / beta (= QEET) and     ',
     7'max. number  of reflections accepted for secondary set of     ',
     8'symbolic  reflections (= MAXT).  Enter 0 for those indices on ',
     9'which you do not want to impose a limit.                      '/
      DATA (CH(I), I= 390, 399)
     * /'+D ACCEPT 2 0                                               ',
     1'+204 Utility program: prepare file and stop.                  ',
     2'Supply an option number for the execution of DDMAIN:          ',
     3'OPTION 0 : call FCALC and prepare BINFC or BINFC2 file        ',
     4'OPTION 1 : call FCALC and prepare input (= BINDUA file) for   ',
     5'- phase expansion and phase refinement (PHASEX)               ',
     6'OPTION 2 : prepare input (= BINFFT file) for a DIRDIF-Fourier ',
     7'- (the program PHASEX must precede to obtain the BINDIF file) ',
     8'OPTION 3 : prepare input (= BINFFT file) for a Fourier map    ',
     9'- (sub-options WFOUR, WDELF, AFOUR, DELF, 2FO-FC, FCALC)      '/
      DATA (CH(I), I= 400, 409)
     * /'OPTION 4 : prepare input (= BINFFT file) for a Patterson map',
     1'- (sub-options PATOR, PATTY, EF, FOBS2)                       ',
     2'OPTION 7 : call FCALC, R2-calculation for all sets of ATOMS   ',
     3'- on the ATOMS file                                           ',
     4'Please give option number:                                    ',
     5'+D OPTION 1 0                                                 ',
     6'+204.02 Select one of the options for a Fourier synthesis:    ',
     7'WFOUR 2FO-FC WDELF AFOUR DELF FCALC                           ',
     8'+A WFOUR 0 2FO-FC 0 WDELF 0 AFOUR 0 DELF 0 FCALC 0 Q 204.03   ',
     9'+A H 204.04                                                   '/
      DATA (CH(I), I= 410, 419)
     * /'+204.03 .                                                   ',
     1'Quit not accepted: Keyword needed by the calling program!     ',
     2'You are able to escape later. (If in doubt, try H) 204.02$    ',
     3'+204.04 The keywords have the following meaning:              ',
     4'WFOUR : default: conventional Sim-weighted Fourier synthesis  ',
     5'- with (for large fragments) partly (2FO-FC)-contribution     ',
     6'2FO-FC: 2 Fobs - Fcalc synthesis                              ',
     7'WDELF : weighted difference Fourier synthesis                 ',
     8'AFOUR : unweighted Fourier synthesis                          ',
     9'DELF : unweighted difference synthesis                        '/
      DATA (CH(I), I= 420, 429)
     * /'FCALC : Fourier synthesis with Fcalc as coefficients Q$     ',
     1'+204.05 Please select one of the options for a Patterson map: ',
     2'PATOR EF FOBS2                                                ',
     3'+A PATOR 0 PATTY 0 EF 0 FOBS2 0 Q 204.06 H 204.07             ',
     4'+204.06 Quit not accepted:                                    ',
     5'Keyword needed by the calling program!                        ',
     6'You are able to escape later. (If in doubt, try H) 204.05$    ',
     7'+204.07 The keywords have the following meaning:              ',
     8'PATOR : Patterson synthesis for ORIENT                        ',
     9'EF : Patterson synthesis with coefficients: |E * F|           '/
      DATA (CH(I), I= 430, 439)
     * /'FOBS2 : unsharpened Patterson synthesis   204.05$           ',
     1'+205 EXPAND (Y/N/H/Q)?                                        ',
     2'+A Y 205.02 N 0 H 205.01 Q 0                                  ',
     3'+205.01 .                                                     ',
     4'EXPAND: expand data to P1 symmetry (or centered equivalent),  ',
     5'only possible if selected program is FCALC or DDMAIN. 205$    ',
     6'+205.02 Enter EXPAND (to confirm) or Q (to quit):             ',
     7'+A EXPAND 0 Q 0                                               ',
     8'+205.1 Do you need (more) special control data for FCALC?     ',
     9'(N STLMAX MAXHKL SCALE BBB WILSON PRINT H Q)                  '/
      DATA (CH(I), I= 440, 449)
     * /'+A STLMAX 205.21 MAXHKL 205.22 SCALE 205.23 BBB 205.24      ',
     1'+A WILSON 205.25                                              ',
     2'+A N 0 H 205.11 Q 0 PRINT -1                                  ',
     3'+205.11 Possible control data entries are:                    ',
     4'STLMAX for max. value of sin (theta)/lambda                   ',
     5'MAXHKL for max. values of H, K, L                             ',
     6'SCALE for scale factor (Fcalc == Scale * Fobs)                ',
     7'BBB for temperture factors: Bov, Bp, Br                       ',
     8'- Bov = overall temperature factor calculated by              ',
     9'-  WILSON-PARTHASARATY plot                                   '/
      DATA (CH(I), I= 450, 459)
     * /'- Bp = temperature factor of partial structure (= input)    ',
     1'-  calculated by WILSON-BpBr-plot                             ',
     2'- Br = temperature factor of rest structure (= output)        ',
     3'-  calculated by WILSON-BpBr-plot                             ',
     4'WILSON for WILSON-PARTHASARATY plot and WILSON-BpBr-plot      ',
     5'PRINT if you wish to see more intermediate data printed       ',
     6'and give Q to quit (also use Q to escape). Q$                 ',
     7'+205.21 .                                                     ',
     8'STLMAX for max. value of sin (theta)/lambda. Enter one number:',
     9'+D STLMAX 1 0                                                 '/
      DATA (CH(I), I= 460, 469)
     * /'+205.22 .                                                   ',
     1'MAXHKL for max. values of H, K, L (if 0, retain original data)',
     2'+D MAXHKL 3 0                                                 ',
     3'+205.23 Supply the value of the scale factor:                 ',
     4'+D SCALE 1 0                                                  ',
     5'+205.24 BBB for three temp. factors: Bov, Bp, Br              ',
     6'(if .0, default calc.):                                       ',
     7'Enter three numbers:                                          ',
     8'+D BBB 3 0                                                    ',
     9'+205.25 .                                                     '/
      DATA (CH(I), I= 470, 479)
     * /'WILSON for WILSON-PARTHASARATY plot and WILSON-BpBr-plot    ',
     1'Please select one of the following numbers (or Q to quit):    ',
     2'0 = all paramters (Bov, Bp, Br) free                          ',
     3'1 = fix temperature factor for the partial structure (BP)     ',
     4'2 = fix temperature factor for the rest structure (BR)        ',
     5'3 = fix temp. fact. for partial and rest structure (BP,BR)    ',
     6'4 = no WILSON-PARTHASARATY plot and no WILSON-BpBr-plot       ',
     7'5 = no WILSON-BpBr-plot, only WILSON-PARTHASARATY plot        ',
     8'+D WILSON 1 0                                                 ',
     9'+205.3 Do you want to use this file? (Y/N)                    '/
      DATA (CH(I), I= 480, 489)
     * /'+A Y 0 N 205.31 Q 205.33 H 0                                ',
     1'+205.31 New file ATOMS is to be created. C$                   ',
     2'+205.32 Use local facilities to inspect your file.            ',
     3'Use Q to exit. C$                                             ',
     4'+205.34 Is all OK? Can we use this file? (Y/N)                ',
     5'+A Y 0 N 205.35 Q 205.35 H 0                                  ',
     6'+205.35 Quit: stop now, inspect ATOMS file. C$                ',
     7'+205.4 .                                                      ',
     8'No file ATOMS with positional parameters is available. C$     ',
     9'+205.41 Can you supply the atomic parameters now? (Y/N)       '/
      DATA (CH(I), I= 490, 499)
     * /'+A Y 0 N 205.42 Q 205.42 H 205.43                           ',
     1'+205.42 Please, get an ATOMS file. Bye bye. C$                ',
     2'+205.43 If you have a set of atomic parameters (given         ',
     3'either as Cartesian or as fractional coordinates)             ',
     4'you can either enter these coordinates now or quit and        ',
     5'use local editing facilities to prepare the ATOMS file.       ',
     6'Information about the format is obtained by just trying out:  ',
     7'supply some arbitrary atoms in an arbitrary format, quit and  ',
     8'inspect the created ATOMS file. Q$                            ',
     9'+206 Do you need (more) special control data to execute FOUR? '/
      DATA (CH(I), I= 500, 509)
     * /'(N GRID MAXXYZ MAXHKL GRIDMO PRIMAP PEAKS DMAX NORECY PRINT ',
     1'+A H 206.05 GRID 206.1 MAXXYZ 206.2 MAXHKL 206.3 GRIDMO 206.4 ',
     2'+A PRIMAP -1 PEAKS 206.6 DMAX 206.7 PRINT -1 N 0 Q 0 NORECY -1',
     3'+206.05 Possible control data entries are:                    ',
     4'GRID grid spacing in Angstrom (the grid on which the Fourier  ',
     5'- function is evaluated will have a default spacing of        ',
     6'- approximately 0.3 A)                                        ',
     7'MAXXYZ maximum x,y,z on printed map (if PRIMAP) (from origin) ',
     8'GRIDMO for values of MODULO Nx, Ny, Nz (default 1, 1, 2)      ',
     9'PRIMAP print of the Fourier map                               '/
      DATA (CH(I), I= 510, 519)
     * /'PEAKS number of peaks to be sought on the Fourier map       ',
     1'DMAX maximum distance to be considered as bonding distance    ',
     2'NORECY to suppress recycling: write ATOMS and STOP after FOUR ',
     3'PRINT for extra information to be printed                     ',
     4'Q to quit (also use Q to escape). Q$                          ',
     5'+206.1 GRID for grid spacing in Angstrom. Give one number     ',
     6'+D GRID 1 0                                                   ',
     7'+206.2 if PRIMAP: MAXXYZ for maximum x, y, z on printed map   ',
     8'+D MAXXYZ 3 0                                                 ',
     9'+206.3 MAXHKL for maximum h, k, l. Enter three numbers        '/
      DATA (CH(I), I= 520, 529)
     * /'+D MAXHKL 3 0                                               ',
     1'+206.4 GRIDMO for values of MODULO Nx, Ny, Nz.                ',
     2'Enter three numbers                                           ',
     3'+D GRIDMO 3 0                                                 ',
     4'+206.6 PEAKS for number of peaks. Enter one number            ',
     5'+D PEAKS 1 0                                                  ',
     6'+206.7 DMAX maximum distance for bonding. Enter one number    ',
     7'+D DMAX 1 0                                                   ',
     8'+207 No special control data to execute PATTY needed. Q$      ',
     9'+208 No special control data to execute PATTERSON needed. Q$  '/
      DATA (CH(I), I= 530, 539)
     * /'+212                    C$                                  ',
     1'                                                              ',
     2'                                                              ',
     3'                                                              ',
     4'                                                              ',
     5'                                                              ',
     6'                                                              ',
     7'                                                              ',
     8'                                                              ',
     9'                                                              '/
      DATA (CH(I), I= 540, 549)
     * /'                                                            ',
     1'                                                              ',
     2'                                                              ',
     3'                                                              ',
     4'                                                              ',
     5'                                                              ',
     6'                                                              ',
     7'                                                              ',
     8'+999                                                          ',
     9'+999 END OF DDHELP LIST                                       '/
      IHELP = 18
      CALL FILCLO (IHELP, 'KEEP')
      CALL FILINQ (IHELP, 'DDHELP', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IHELP, 111)
  111 FORMAT ( '     file DDHELP     Sept. 2006 '/1X)
      DO 999 K = 1, 549
      WRITE (IHELP, 222) CH(K)
  222 FORMAT (A64, 8X)
  999 CONTINUE
      CALL FILCLO (IHELP, 'KEEP')
      END
      FUNCTION ISELFD (X, Y, DMAX)
      DIMENSION X(3), Y(3)
      SAVE
      INCLUDE 'Zcrys.inc'
      DIMENSION DM(3), D(3)
      DATA DMOLD /-999.0/
      DATA DMAXSQ / 0.0 /
      IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN
         DO 100 I=1, 3
  100    DM(I) = DMAX * RCELL(I)
         DMOLD = DMAX
         DMAXSQ = DMAX * DMAX
         ENDIF
      ISELFD=0
      DO 120 I=1, 3
      D(I) = X(I) - Y(I) - ANINT (X(I)-Y(I))
      IF (ABS (D(I)) .GT. DM(I)) RETURN
  120 CONTINUE
      CALL VMATV1 (D, RRMAT, D, DIST2)
      IF (DIST2 .LE. DMAXSQ) ISELFD = 1
      RETURN
      END
      SUBROUTINE DISTSQ (X, Y, DMAX, Z, DIST2)
      DIMENSION X(3), Y(3), Z(3)
      SAVE
      INCLUDE 'Zcrys.inc'
      DIMENSION DM(3)
      DATA DMOLD /-9999.9/
      IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN
         DO 100 I=1, 3
  100    DM(I) = DMAX * RCELL(I)
         DMOLD=DMAX
         ENDIF
      DIST2 = 9999.9
      DO 120 I=1, 3
      Z(I) = Y(I) - X(I) - ANINT (Y(I)-X(I))
      IF (ABS (Z(I)) .GT. DM(I)) RETURN
  120 CONTINUE
      CALL VMATV1 (Z, RRMAT, Z, DIST2)
      RETURN
      END
      SUBROUTINE SYMOP1 (IS, X, XS)
      DIMENSION X(3), XS(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION RSYMM(3,3,24)
      LOGICAL CONT
      SAVE CONT
      DATA CONT / .FALSE. /
      IF (CONT) GOTO 200
      CONT = .TRUE.
      CALL KERI2F (IRSYMM, RSYMM, 9 * NSYMM)
  200 IF (IS .EQ. 1) THEN
         CALL KERNAB (X, XS, 3)
      ELSE
         CALL MATXV3 (RSYMM(1,1,IS), X, XS)
         XS(1) = XS(1) + TSYMM(1,IS)
         XS(2) = XS(2) + TSYMM(2,IS)
         XS(3) = XS(3) + TSYMM(3,IS)
         ENDIF
      END
      SUBROUTINE SYMOP2 (IC, IL, XS, XST)
      DIMENSION XS(3), XST(3)
      INCLUDE 'Zcrys.inc'
      IF (IC .EQ. 1) THEN
         XST(1) = TLATT(1,IL) + XS(1)
         XST(2) = TLATT(2,IL) + XS(2)
         XST(3) = TLATT(3,IL) + XS(3)
      ELSE
         XST(1) = TLATT(1,IL) - XS(1)
         XST(2) = TLATT(2,IL) - XS(2)
         XST(3) = TLATT(3,IL) - XS(3)
         ENDIF
      END
      FUNCTION ISELFX (X, Y, DMAX)
      DIMENSION X(3), Y(3)
      SAVE
      INCLUDE 'Zcrys.inc'
      DIMENSION DM(3), D(3)
      DATA DMOLD /-999.0/
      DATA DMAXSQ / 0.0 /
      IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN
         DO 100 I=1, 3
  100    DM(I) = DMAX * RCELL(I)
         DMOLD = DMAX
         DMAXSQ = DMAX * DMAX
         ENDIF
      ISELFX=0
      DO 120 I=1, 3
      D(I) = X(I) - Y(I) - ANINT (X(I)-Y(I))
      IF (ABS (D(I)).GT.DM(I)) RETURN
  120 CONTINUE
      CALL VMATV1 (D, RRMAT, D, DISTSQ)
      IF (DISTSQ .LE. DMAXSQ) THEN
         DO 130 I = 1,3
  130    Y(I) = Y(I) + ANINT( X(I)-Y(I) )
         ISELFX = 1
         ENDIF
      RETURN
      END
      SUBROUTINE LOCKIN (ATIN, DMAX, ATOUT, DIST, NPOS)
      DIMENSION ATIN(3), ATOUT(3), D(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION  XYZ(3), XYZC(3), TPOS(3,48)
      LOGICAL CENTRO, AGAIN
      DATA CENTRO / .FALSE. /
      DATA DELTA  / 0.0001  /
      AGAIN = .FALSE.
      IF ( ICENT .EQ. 2 ) CENTRO = .TRUE.
      CALL KERNZA ( 0.0, ATOUT, 3 )
      CALL KERNAB (ATIN, TPOS, 3)
      NPOS = 1
      NADD = 0
  120 DO 200 I = 1,NPOS
      DO 190 JT = 1,NLATT
      DO 190 J  = 1,NSYMM
      IF ( CENTRO ) AGAIN = .TRUE.
      DO 130 K = 1,3
      XYZ(K) = TSYMM(K,J) + TLATT(K,JT) +
     *   TPOS(1,I) * IRSYMM(K,1,J) +
     *   TPOS(2,I) * IRSYMM(K,2,J) +
     *   TPOS(3,I) * IRSYMM(K,3,J)
  130 XYZC(K) = -XYZ(K)
  140 IF ( ISELFX (ATIN, XYZ, DMAX) .EQ. 1 ) THEN
         DO 150 L = 1,NPOS+NADD
         IF ( ( ABS(XYZ(1)-TPOS(1,L)) .LT. DELTA ) .AND.
     *      ( ABS(XYZ(2)-TPOS(2,L)) .LT. DELTA ) .AND.
     *      ( ABS(XYZ(3)-TPOS(3,L)) .LT. DELTA ) ) GOTO 170
  150    CONTINUE
         NADD = NADD + 1
         IF ( NPOS+NADD .GT. 48 ) CALL KERROR
     *      ('Program symm. error?', 150, 'LOCKIN')
         DO 160 K = 1,3
  160    TPOS(K,NPOS+NADD) = XYZ(K)
         ENDIF
  170 IF ( .NOT. CENTRO )  GOTO 190
      IF ( AGAIN ) THEN
         DO 180 K = 1,3
  180    XYZ(K) = XYZC(K)
         AGAIN = .FALSE.
         GOTO 140
         ENDIF
  190 CONTINUE
  200 CONTINUE
      IF ( NADD .EQ. 0 ) GOTO 220
      NPOS = NPOS + NADD
      NADD = 0
      GOTO 120
  220 DIST = 0.0
      FNPOS = FLOAT(NPOS)
      DO 240 I = 1,3
      DO 230 K = 1,NPOS
  230 ATOUT(I) = ATOUT(I) + TPOS(I,K)
  240 ATOUT(I) = ATOUT(I) / FNPOS
      IF ( NPOS .LE. 1 ) GOTO 260
      DO 250 I = 1,3
  250 D(I) = ATIN(I) - ATOUT(I)
      CALL VMATV1( D, RRMAT, D, DIST )
      DIST = SQRT( DIST )
  260 RETURN
      END
      SUBROUTINE HKLSTL (HKL, STL, STL2)
      INCLUDE 'Zcrys.inc'
      DIMENSION HKL(3)
      STL2 = 0.0
      DO 100 I =1,3
      DO 100 J =1,3
  100 STL2 = STL2 + HKL(I) * SSMAT(I,J) * HKL(J)
      STL2 = STL2 / 4.0
      STL = SQRT(STL2)
      RETURN
      END
      SUBROUTINE HKLEXS (SWITCH, HKL, HCODE)
      LOGICAL SWITCH
      DIMENSION HKL(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION RSYMM(3,3,24), HHH(3)
      LOGICAL IRSW
      SAVE IRSW
      DATA IRSW / .FALSE. /
      IF (IRSW) GOTO 110
      IRSW = .TRUE.
      CALL KERI2F (IRSYMM, RSYMM, 9*NSYMM)
  110 DO 200 J = 1,NSYMM
      DO 120 K = 1,3
      HHH(K) = HKL(1) * RSYMM(1,K,J)
     *       + HKL(2) * RSYMM(2,K,J)
     *       + HKL(3) * RSYMM(3,K,J)
  120 CONTINUE
      CALL HKLC1 (HHH, HC)
      IF (SWITCH) HC = ABS(HC)
      IF (J.EQ.1) HCODE = HC
      HCODE = AMAX1 (HC, HCODE)
  200 CONTINUE
      RETURN
      END
      SUBROUTINE HKLEXT (HKL, KEND)
      DIMENSION HKL(3)
      SAVE
      INCLUDE 'Zcrys.inc'
      DIMENSION KSYMM(3,3,24), TT(3,24), III(3), KKK(3)
      LOGICAL IRSW, SKIP
      DATA IRSW , SKIP / .FALSE. , .FALSE. /
      DATA NST / 0 /
      IF (SKIP) GOTO 102
      IF (IRSW) GOTO 110
      IF (NSYMM.GT.1) GOTO 103
  101 SKIP = .TRUE.
  102 KEND = 0
      RETURN
  103 IRSW = .TRUE.
      NST = 0
      DO 104 J = 2,NSYMM
      IF (ABS(TSYMM(1,J)) .LT. 0.01 .AND.
     *    ABS(TSYMM(2,J)) .LT. 0.01 .AND.
     *    ABS(TSYMM(3,J)) .LT. 0.01) GOTO 104
      NST = NST + 1
      CALL KERNAI (IRSYMM(1,1,J), KSYMM(1,1,NST), 9)
      CALL KERNAB (TSYMM(1,J), TT(1,NST), 3)
  104 CONTINUE
      IF (NST.EQ.0) GOTO 101
  110 CALL KERF2I (HKL, III, 3)
      DO 200 J = 1,NST
      TEST = 0.
      DO 120 K = 1,3
      KKK(K) = III(1) * KSYMM(1,K,J)
     *       + III(2) * KSYMM(2,K,J)
     *       + III(3) * KSYMM(3,K,J)
  120 CONTINUE
      IF (III(1).EQ.KKK(1) .AND. III(2).EQ.KKK(2) .AND.
     *    III(3).EQ.KKK(3) ) GOTO 130
      IF (ICENT.EQ.1) GOTO 200
      IF (III(1).NE.-KKK(1) .OR. III(2).NE.-KKK(2) .OR.
     *    III(3).NE.-KKK(3) ) GOTO 200
  130 TEST = TT(1,J) * HKL(1) + TT(2,J) * HKL(2) + TT(3,J) * HKL(3)
      IF (AMOD (ABS(TEST)+0.01, 1.0) .LT. 0.02) GOTO 200
      KEND = -1
      RETURN
  200 CONTINUE
      KEND = 0
      RETURN
      END
      SUBROUTINE HKLEX1 (HKL, HKLX)
      DIMENSION HKL(3), HKLX(3,24)
      SAVE
      INCLUDE 'Zcrys.inc'
      DIMENSION RSYMM(3,3,24)
      LOGICAL IRSW
      DATA IRSW / .FALSE. /
      IF (IRSW) GOTO 110
      IRSW = .TRUE.
      CALL KERI2F (IRSYMM, RSYMM, 9*NSYMM)
  110 CALL KERNAB (HKL, HKLX, 3)
      IF (NSYMM.EQ.1) RETURN
      DO 120 J = 2,NSYMM
      DO 120 K = 1,3
  120 HKLX(K,J) = HKL(1) * RSYMM(1,K,J)
     *          + HKL(2) * RSYMM(2,K,J)
     *          + HKL(3) * RSYMM(3,K,J)
      RETURN
      END
      SUBROUTINE HKLEX2 (HKL, IDHKL, IEPS, IEPS2)
      DIMENSION HKL(3,24), IDHKL(24)
      INCLUDE 'Zcrys.inc'
      IDHKL(1) = 0
      IF (NSYMM.EQ.1) THEN
         IEPS  = 1
         IEPS2 = 1
         RETURN
         ENDIF
      IEPS  = 0
      IEPS2 = 0
      DO 300 J=2,NSYMM
      IDHKL(J) = 0
      DO 200 K=1,J-1
      IF (ABS(HKL(1,K)-HKL(1,J)) .GT. 0.1) GOTO 180
      IF (ABS(HKL(2,K)-HKL(2,J)) .GT. 0.1) GOTO 180
      IF (ABS(HKL(3,K)-HKL(3,J)) .GT. 0.1) GOTO 180
      IDHKL(J) = K
      IEPS = IEPS + 1
      GOTO 300
  180 CONTINUE
      IF (ABS(HKL(1,K)+HKL(1,J)) .GT. 0.1) GOTO 200
      IF (ABS(HKL(2,K)+HKL(2,J)) .GT. 0.1) GOTO 200
      IF (ABS(HKL(3,K)+HKL(3,J)) .GT. 0.1) GOTO 200
      IDHKL(J) = - K
      IEPS2 = IEPS2 + 1
      GOTO 300
  200 CONTINUE
  300 CONTINUE
      IEPS2 = NSYMM / (NSYMM - IEPS - IEPS2)
      IF (ICENT .EQ. 1) THEN
         IEPS  = NSYMM / (NSYMM - IEPS)
      ELSE
         IEPS = IEPS2
         ENDIF
      RETURN
      END
      SUBROUTINE HKLEX3 (HKL, IDHKL, PSHIFT)
      DIMENSION HKL(3), IDHKL(24), PSHIFT(24)
      INCLUDE 'Zcrys.inc'
      CALL KERNZA (0., PSHIFT, NSYMM)
      IF (NSYMM .EQ. 1) RETURN
      DO 220 I=1,NSYMM
      IF (IDHKL(I) .NE. 0) GOTO 210
      XTEST = 0.0
      DO 200 J=1,3
  200 XTEST  = XTEST - HKL(J) * TSYMM(J,I)
      XTEST  = AMOD(XTEST,1.0)
      IF (XTEST .LT. -0.01) XTEST = XTEST + 1.
      PSHIFT(I) = XTEST * 360.
      GOTO 220
  210 ITEST = IABS(IDHKL(I))
      PSHIFT(I) = PSHIFT(ITEST)
  220 CONTINUE
      RETURN
      END
      SUBROUTINE HKLAXT (HKL, KEND)
      DIMENSION HKL(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION IH(3)
      CALL KERF2I (HKL, IH, 3)
      GOTO (200, 2, 3, 4, 5, 6, 7), ILATT
  2   I = IH(2) + IH(3)
      GOTO 100
  3   I = IH(1) + IH(3)
      GOTO 100
  4   I = IH(1) + IH(2)
      GOTO 100
  5   I = IH(1) + IH(2) + IH(3)
  100 IF (MOD(I,2) .EQ. 0) GOTO 200
      GOTO 150
  6   IF (MOD (IH(1)+IH(2),2) .EQ. 0 .AND.
     *    MOD (IH(1)+IH(3),2) .EQ. 0) GOTO 200
      GOTO 150
  7   IF (MOD (-IH(1)+IH(2)+IH(3),3) .EQ. 0) GOTO 200
  150 KEND = -1
      RETURN
  200 CONTINUE
      KEND = 0
      RETURN
      END
      SUBROUTINE HKLC1 (HKL, HCODE)
      DIMENSION HKL(3), HKL1(3)
      PARAMETER (ADD   = -99.,  SPANL = 200., SPANKL = 200. * 200.,
     *                          LSPAN = 200 , KLSPAN = 200  * 200,
     *          IDDHKL =  99 * (KLSPAN + LSPAN + 1) )
      HCODE = HKL(1) * SPANKL + HKL(2) * SPANL + HKL(3)
      RETURN
      ENTRY HKLC1U (HCODE1, HKL1)
      KCODE  =  NINT (HCODE1) + IDDHKL
      I = KCODE / KLSPAN
      HKL1(1) = FLOAT (I) + ADD
      M = MOD(KCODE,KLSPAN)
      I = M / LSPAN
      HKL1(2) = FLOAT (I) + ADD
      M = MOD(KCODE, LSPAN)
      HKL1(3) = FLOAT (M) + ADD
      RETURN
      END
      SUBROUTINE HKLC2 (HKL, ACODE)
      DIMENSION HKL(3), HKL1(3), HMIN(3), HMAX(3)
      DIMENSION ADD(3)
      SAVE
      DATA SPANL, SPANKL, LSPAN, KLSPAN, IDDHKL  / 0.0, 0.0, 0, 0, 0 /
      ACODE = HKL(1) * SPANKL + HKL(2) * SPANL + HKL(3)
      RETURN
      ENTRY HKLC2U (ACODE1, HKL1)
      KCODE   = IFIX  (ACODE1) + IDDHKL
      HKL1(1) = FLOAT (     KCODE         /KLSPAN) + ADD(1)
      HKL1(2) = FLOAT ( MOD(KCODE,KLSPAN) / LSPAN) + ADD(2)
      HKL1(3) = FLOAT ( MOD(KCODE, LSPAN)        ) + ADD(3)
      RETURN
      ENTRY HKLC2I (HMIN, HMAX)
      CALL KERNAB (HMIN, ADD, 3)
      SPANL  = HMAX(3) - HMIN(3) + 1.
      SPANKL = SPANL * (HMAX(2) - HMIN(2) + 1.)
      LSPAN  = IFIX (SPANL  + 0.1)
      KLSPAN = IFIX (SPANKL + 0.1)
      ADDHKL = - HMIN(1) * SPANKL
     *         - HMIN(2) * SPANL - HMIN(3)
      IDDHKL = NINT (ADDHKL)
      RETURN
      END
      SUBROUTINE FCALCI (ATXYZ, IZAT, ITAT, NAT7)
      DIMENSION ATXYZ(10,NAT7), IZAT(NAT7), ITAT(NAT7)
      SAVE
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zfcala.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      LOGICAL EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      CALL KERNZI (0, IZTYPE, 10)
      DO 130 I=1,NTYPE
      CALL RDCRYB (ICRYS, 'ELEM' , KEND)
      IF (KEND.LE.0) THEN
        WRITE (CHOUT, 110) I
  110   FORMAT (' CRYSDA file: ELEM for atom TYPE no. ',I2,' not found')
        CALL KERROR (CHOUT, 0, 'FCALCI')
        ENDIF
      READ (CHIN, 120) IZTYPE(I)
  120 FORMAT (10X, 2X, I8)
  130 CALL RDCRYX (ICRYS, 'SFAC' , SFAC(1,I), 13)
      DO 150 I=1,NSYMM
      IF (ABS(TSYMM(1,I)).GT.0.001 .OR.
     *    ABS(TSYMM(2,I)).GT.0.001 .OR.
     *    ABS(TSYMM(3,I)).GT.0.001 ) THEN
         ITRS(I) = 1
         ELSE
         ITRS(I) = 0
         ENDIF
  150 CONTINUE
      IF (.NOT. EXPAND) CALL ATOMOC (1, ATXYZ, ITAT, NAT)
      CALL KERNZA (0.0, CELPAR, NTYPE)
      AAMULT = AMULT
      IF (EXPAND) AAMULT = ALATT
      DO 161 I=1,NAT
      DO 160 J=1,NTYPE
      IF (IZAT(I).NE.IZTYPE(J)) GOTO 160
      ITAT(I) = J
      CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AAMULT
  160 CONTINUE
  161 CONTINUE
      IF (KEYT.EQ.3) CALL ATBETA (ATXYZ, NAT)
      CALL SICOT (SICO, 12500)
      ISMAX = IFIX (STLMAX * 400. +0.04) + 2
      IF (ISMAX.LE.500) GOTO 200
      WRITE (CHOUT, 198) STLMAX
  198 FORMAT (' Found max. sin(th/lam) = STLMAX =', F7.3,
     *        ' Max = 1.249 . ??DATA ERROR?? ')
      CALL KERROR (CHOUT, 0, 'FCALCI')
  200 CONTINUE
      BPAV = 0.
      IF (KEYT .GT. 1) THEN
         IZATT = 0
         DO 174 I = 1, NAT
         BPAV = BPAV + ATXYZ(5,I) * IZAT(I) **2
  174    IZATT = IZATT + IZAT(I) ** 2
         BPAV = BPAV / FLOAT(IZATT)
         WRITE (8, 173) BPAV
  173    FORMAT (1X/' FCALCI: Averaged value of Bp for known atoms:',
     *      ' Bp = ', F8.3/1X)
         BP = BPAV
         ENDIF
      DO 260 IS=1,ISMAX
      STL = FLOAT(IS-1) * 0.0025
      STL2 = STL * STL
      EXPBP(IS) = EXP(-BP * STL2)
      EXPBR(IS) = EXP(-BR * STL2)
      SUMF2(IS)  = 0.0
      SUMF2P(IS) = 0.0
      DO 260 I=1,NTYPE
      SFAC6 = AMIN1 (SFAC(6,I) * STL2, 99.99)
      SFAC8 = AMIN1 (SFAC(8,I) * STL2, 99.99)
      FF(IS,I) = SFAC(9,I) + SFAC(10,I)
     * + SFAC(1,I) * EXP (-SFAC(2,I) * STL2)
     * + SFAC(3,I) * EXP (-SFAC(4,I) * STL2)
     * + SFAC(5,I) * EXP (-SFAC6)    + SFAC(7,I) * EXP (-SFAC8)
      SUMF2(IS)  = SUMF2(IS) + FF(IS,I) * FF(IS,I) * CELALL(I)
  260 SUMF2P(IS) = SUMF2P(IS)+ FF(IS,I) * FF(IS,I) * CELPAR(I)
      PSQ = SUMF2P(2)/SUMF2(2)
      P1SQ = PSQ / ASYMC
      IF (.NOT. EXPAND) RETURN
      P1SQ = PSQ
      PSQ = AMIN1 (0.999 , P1SQ * ASYMC)
      RETURN
      END
      SUBROUTINE SICOT (SICO, M)
      DIMENSION SICO(M)
      PARAMETER (PI2 = 2.0 * 3.14159265 )
      M1 = M  / 5
      M2 = M1 * 2
      M4 = M2 * 2
      F = PI2 / FLOAT(M4)
      DO 240 I=1,M1
      AI = SIN (FLOAT(I) * F)
      SICO(I)    = AI
      SICO(M2-I) = AI
      SICO(M2+I) =-AI
      SICO(M4-I) =-AI
  240 SICO(M4+I) = AI
      SICO(M2)   = 0.0
      SICO(M4)   = 0.0
      RETURN
      END
      SUBROUTINE MACOL(A)
      DIMENSION A(3,3)
      N=1
  105 K=2
  110 T=A(K,N)
      A(K,N)=A(N,K)
      A(N,K)=T
      IF (N.EQ.3) RETURN
      K=K+1
      IF (K.LE.3) GOTO 110
      N=3
      GOTO 105
      END
      SUBROUTINE MATINV(A,B,D,KEND)
      DIMENSION A(3,3),B(3,3)
      PARAMETER (DETMAX = 10.E-15)
      KEND=0
      CALL VECAXB (A(1,2),A(1,3),B(1,1))
      CALL VECAXB (A(1,3),A(1,1),B(1,2))
      CALL VECAXB (A(1,1),A(1,2),B(1,3))
      D=A(1,1)*B(1,1)+A(2,1)*B(2,1)+A(3,1)*B(3,1)
      IF (D.LT.DETMAX .AND. D.GT.-DETMAX) KEND = -99
      IF (KEND.EQ.-99) RETURN
      DO 15 N=1,3
      DO 15 K=1,3
   15 B(K,N)=B(K,N)/D
      CALL MACOL(B)
      RETURN
      END
      FUNCTION ERFU (X)
      DIMENSION E(31)
      DATA E / .00000, .11246, .22270, .32863, .42839,
     *         .52050, .60386, .67780, .74210, .79691,
     *         .84270, .88021, .91031, .93401, .95229,
     *         .96611, .97635, .98379, .98909, .99279,
     *         .99532, .99702, .99814, .99886, .99931,
     *         .99959, .99976, .99987, .99992, .99996, .99998 /
      X10 = X*10. + 1.00001
      IX = X10
      IF (IX.GT.30) GOTO 100
      ERFU = E(IX) + (X10-IX) * (E(IX+1)-E(IX))
      RETURN
  100 ERFU = 1.
      RETURN
      END
      FUNCTION IPHFIX (HKL)
      DIMENSION HKL(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION ICODE(13), LTEST(3), IHKL(3)
      DATA ICODE / 2, -1, 9, 8, 7, -1, 6, -1, 5, 4, 3, -1, 2 /
      CALL KERF2I (HKL, IHKL, 3)
      IF(ICENT.EQ.1) GOTO 150
      IPHFIX = 2
      RETURN
  150 IPHFIX = 1
      IOLD = -1
      DO 180 I=2,NSYMM
      XTEST = 0.0
      KTEST = 0
      DO 170 J=1,3
      LTEST(J) = 0
      DO 160 L=1,3
  160 LTEST(J) = LTEST(J) + IHKL(L)*IRSYMM(L,J,I)
      KTEST = KTEST + IHKL(J) + LTEST(J)
      IF (KTEST.NE.0) GOTO 180
  170 XTEST = XTEST - (HKL(J) * TSYMM(J,I))
      XTEST = XTEST - IFIX(XTEST)
      IF (XTEST.LT.-0.01) XTEST = XTEST + 1.0
      IPHS = IFIX(12.*XTEST+0.1) + 1
      IPHFIX = ICODE(IPHS)
      IF (IOLD.EQ.-1) IOLD = IPHFIX
      IF (IPHFIX.NE.IOLD) GOTO 190
  180 CONTINUE
      IF (IPHFIX.GE.1) RETURN
  190 IPHFIX = -1
      RETURN
      END
      FUNCTION E2EXP (ITYP, E1, E2)
      EX1 = E1 * E1
      EX2 = E2 * E2
      IF (ITYP.NE.0) GOTO 100
      Q = (EX2-EX1) / 2.0
      E2EXP = EX1 + Q * (1. - SIMW(Q))
      RETURN
  100 EXX1 = EXP(-EX1*.5)
      EX3 = EXX1 / (EXX1 + EXP(-EX2*.5) )
      E2EXP = EX1*EX3 + (1.0 - EX3)*EX2
      RETURN
      END
      FUNCTION SIMW (Q)
      SIMW = ((0.0106 * Q - 0.1304) * Q + 0.5658) * Q
      IF (Q.GT.5.) SIMW=0.8565 + 0.0075*Q
      RETURN
      END
      SUBROUTINE MATC2F (CELL, CX)
      DIMENSION CELL(6), CX(3,3)
      DIMENSION CELLT(6)
      EQUIVALENCE (A   ,CELLT(1)),  (B   ,CELLT(2))
      EQUIVALENCE (C   ,CELLT(3)),  (ALPH,CELLT(4))
      EQUIVALENCE (BET ,CELLT(5)),  (GAMM,CELLT(6))
      CALL KERNAB (CELL, CELLT, 6)
      D2R = ATAN(1.0) / 45.0
      ALPHA = ALPH * D2R
      BETA = BET * D2R
      GAMMA = GAMM * D2R
      COSA = COS(ALPHA)
      COSB = COS(BETA)
      COSC = COS(GAMMA)
      SINC = SIN(GAMMA)
      S = 0.5*(ALPHA+BETA+GAMMA)
      V = A*B*C *2. *SQRT(SIN(S)*SIN(S-ALPHA)*SIN(S-BETA)*SIN(S-GAMMA))
      CX(1,1) = 1./A
      CX(1,2) = -COSC/(A*SINC)
      CX(1,3) = B*C*(COSC*COSA-COSB)/(V*SINC)
      CX(2,1) = 0.
      CX(2,2) = 1./(B*SINC)
      CX(2,3) = A*C*(COSB*COSC-COSA)/(V*SINC)
      CX(3,1) = 0.
      CX(3,2) = 0.
      CX(3,3) = A*B*SINC/V
      RETURN
      END
      SUBROUTINE MATF2C (CELL, XC)
      DIMENSION CELL(6), XC(3,3)
      DIMENSION CELLT(6)
      EQUIVALENCE (A   ,CELLT(1)),  (B   ,CELLT(2))
      EQUIVALENCE (C   ,CELLT(3)),  (ALPH,CELLT(4))
      EQUIVALENCE (BET ,CELLT(5)),  (GAMM,CELLT(6))
      CALL KERNAB (CELL, CELLT, 6)
      D2R = ATAN(1.0) / 45.0
      ALPHA = ALPH * D2R
      BETA = BET * D2R
      GAMMA = GAMM * D2R
      COSA = COS(ALPHA)
      COSB = COS(BETA)
      COSC = COS(GAMMA)
      SINC = SIN(GAMMA)
      S = 0.5*(ALPHA+BETA+GAMMA)
      V = A*B*C *2. *SQRT(SIN(S)*SIN(S-ALPHA)*SIN(S-BETA)*SIN(S-GAMMA))
      XC(1,1) = A
      XC(1,2) = B*COSC
      XC(1,3) = C*COSB
      XC(2,1) = 0.
      XC(2,2) = B*SINC
      XC(2,3) = -C*(COSB*COSC-COSA)/SINC
      XC(3,1) = 0.
      XC(3,2) = 0.
      XC(3,3) = V/(A*B*SINC)
      RETURN
      END
      SUBROUTINE VECAXB (A, B, V)
      DIMENSION A(3), B(3), V(3)
      T1   = A(2) * B(3) - A(3) * B(2)
      T2   = A(3) * B(1) - A(1) * B(3)
      V(3) = A(1) * B(2) - A(2) * B(1)
      V(1) = T1
      V(2) = T2
      RETURN
      END
      SUBROUTINE MATAXB (A, B, P)
      DIMENSION A(3,3), B(3,3), P(3,3)
      DO 112 K = 1, 3
      DO 111 L = 1, 3
      P(K,L) = A(K,1) * B(1,L) + A(K,2) * B(2,L) + A(K,3) * B(3,L)
  111 CONTINUE
  112 CONTINUE
      RETURN
      END
      SUBROUTINE MATAXI (IA, IB, IP)
      DIMENSION IA(3,3), IB(3,3), IP(3,3)
      DO 112 I = 1, 3
      DO 111 J = 1, 3
      IP(I,J) = IA(I,1) * IB(1,J) +IA(I,2) * IB(2,J) +IA(I,3) * IB(3,J)
  111 CONTINUE
  112 CONTINUE
      RETURN
      END
      SUBROUTINE MAT6XV (XC, X, C)
      DIMENSION XC(3,3), X(3), C(3)
      C(1) = X(1)*XC(1,1) + X(2)*XC(1,2) + X(3)*XC(1,3)
      C(2) =                X(2)*XC(2,2) + X(3)*XC(2,3)
      C(3) =                               X(3)*XC(3,3)
      RETURN
      END
      SUBROUTINE MATXV3 (RR, A, B)
      DIMENSION RR(3,3), A(3), B(3)
      T1   = RR(1,1) * A(1) + RR(1,2) * A(2) + RR(1,3) * A(3)
      T2   = RR(2,1) * A(1) + RR(2,2) * A(2) + RR(2,3) * A(3)
      B(3) = RR(3,1) * A(1) + RR(3,2) * A(2) + RR(3,3) * A(3)
      B(1) = T1
      B(2) = T2
      RETURN
      END
      SUBROUTINE VXMATI (K, IR, L)
      DIMENSION K(3), IR(3,3), L(3)
      L1   = K(1) * IR(1,1)  + K(2) * IR(2,1)  + K(3) * IR(3,1)
      L2   = K(1) * IR(1,2)  + K(2) * IR(2,2)  + K(3) * IR(3,2)
      L(3) = K(1) * IR(1,3)  + K(2) * IR(2,3)  + K(3) * IR(3,3)
      L(1) = L1
      L(2) = L2
      RETURN
      END
      SUBROUTINE VMATV1 (A, R, B, Q)
      DIMENSION  A(3), R(3,3), B(3)
      Q=A(1) * (R(1,1) * B(1) + R(1,2) * B(2) + R(1,3) * B(3)) +
     *  A(2) * (R(2,1) * B(1) + R(2,2) * B(2) + R(2,3) * B(3)) +
     *  A(3) * (R(3,1) * B(1) + R(3,2) * B(2) + R(3,3) * B(3))
      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 SYMM (X, Y, Z)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (KLAUE, KEYS(6))
      IF (KLAUE.LT.0) THEN
        IF (Y.LT.0.0) THEN
            X=-X
            Y=-Y
            Z=-Z
        ENDIF
        IF (X.LT.0.0) X=1.+X
        IF (Z.LT.0.0) Z=1.+Z
        RETURN
      ENDIF
      GOTO (5, 15, 25, 35), KLAUE
   5  IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      Z = -Z
      RETURN
   15 Y = ABS(Y)
      IF (X.GE.0.0) RETURN
      X = -X
      Z = -Z
      RETURN
   25 X = ABS(X)
      Y = ABS(Y)
      Z = ABS(Z)
      RETURN
   35 Z = ABS(Z)
      IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      RETURN
      END
      SUBROUTINE NULL5 (IX, I1, I2, I3, I4, I5)
      I1 = IX
      I2 = IX
      I3 = IX
      I4 = IX
      I5 = IX
      RETURN
      END
      SUBROUTINE ZERO5 (FX, F1, F2, F3, F4, F5)
      F1 = FX
      F2 = FX
      F3 = FX
      F4 = FX
      F5 = FX
      RETURN
      END
      SUBROUTINE DDEXIT
      INCLUDE 'Zsyst.inc'
      DIMENSION FIL(15)
      CHARACTER FIL*6
      DATA FIL /'MSDOS',  'DDJOB',  'DDSYST', 'CONDA',  'ORBASE',
     *          'BINFC',  'DDHELP', '$XPTB$', '$XPTB$', '$XPTB$',
     *          '$XPTB$', '$XPTB$', '$XPTB$', '$XPTB$', '$XPTB$'/
      CALL WR24
      IF (CCODE .EQ. ' ') THEN
         WRITE (9, 433)
  433    FORMAT (1X/' End of DIRDIF  -  bye-bye'/1X)
      ELSE
         WRITE (9, 434) CCODE
  434    FORMAT (1X/' End of DIRDIF for ', A6, ' -  bye-bye'/1X)
         ENDIF
      CALL WR24
      CALL FILCLO (4, 'KEEP')
      CALL KERASE ('LIS4')
      OPEN (UNIT = 4, FORM = 'FORMATTED', FILE='lis4',STATUS = 'NEW')
      WRITE (4, FMT='(''LIS4 '', A6 /1X/
     *   '' File lis4 = copy of console (=screen) output''/1X/
     *   '' This file will be overwritten at each DIRDIF call''/1X/1X)')
     *   CCODE
      REWIND 7
  103 CHIN = '  '
      READ (7, END = 105, FMT='(A)') CHIN
      IF ( CHIN(1:2) .EQ. '! ') WRITE (4, FMT='(A)') CHIN
      GOTO 103
  105 CONTINUE
      CALL FILCLO (4, 'KEEP')
      CALL KERASE ('LIS5')
      OPEN (UNIT = 4, FORM = 'FORMATTED', FILE='lis5',STATUS = 'NEW')
      WRITE (4, FMT='(''LIS5 '', A6 /1X/
     *   '' File lis5 = copy of test => $TE records from LIS2''/1X/
     *   '' This file will be overwritten at each DIRDIF call''/1X/
     *   '' =================================================''/1X)')
     *   CCODE
      CALL WRLIS5
      DO 144 I = 1, 20
      IF (I.EQ.5 .OR. I.EQ.6 .OR. I.EQ.9) GOTO 144
      CALL FILCLO (I, 'KEEP')
  144 CONTINUE
      DO 200 I = 1, 15
      CALL KERASE (FIL(I))
  200 CONTINUE
      IF (LITJ2 .NE. 'CRYSDA') CALL KERASE ('CRYSDA')
      STOP
      END
CSUBFILE dirdif2.for
C
C       contents: - subr  099 = DDUNIF --> see 100.ddstart
C       DDSTART --- subr  100 - 197    --> see 100.ddstart
C                COFRED = 127 - 156 -----> see 127.cofred
C                CRYSDA = 165 - 197 -----> see 165.crysda
C       ORFLEX ---- subr. 198 e.v. (not numbered !) --> see 198.orflex
C
      SUBROUTINE DDUNIF
      INCLUDE 'Zdatx.inc'
      CHARACTER EXPROG *6
      SAVE NSTART
      DATA NSTART /0/
      IF (NSTART .EQ. 0) THEN
         MPAT = 0
         IPAT = 0
         MORIE = 0
         IORIE = 0
         ENDIF
      NSTART = NSTART + 1
      CALL WR24
      CALL DDSTAR
  300 CONTINUE
      CALL WR24
      CALL FILCLO (4, 'KEEP')
      CALL FILINQ (4, 'DDSYST', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) THEN
         WRITE (9, FMT='(1X/'' No DDSYST file = error ...'')')
         CALL DDEXIT
         ENDIF
      READ (4, 305, END=400) EXPROG
  305 FORMAT (A6)
      CALL FILCLO (4, 'KEEP')
      IF (EXPROG .EQ. 'DDMAIN') THEN
         CALL DDMAIN
      ELSEIF (EXPROG .EQ. 'FOUR') THEN
         CALL FOUR
      ELSEIF (EXPROG .EQ. 'NUTS') THEN
         CALL NUTS
      ELSEIF (EXPROG .EQ. 'ORIENT') THEN
         CALL ORIENT
      ELSEIF (EXPROG .EQ. 'PATTY') THEN
         CALL PATTY
      ELSEIF (EXPROG .EQ. 'PHASEX') THEN
         CALL PHASEX
      ELSEIF (EXPROG .EQ. 'TRACOR') THEN
         CALL TRACOR
      ELSEIF (EXPROG .EQ. 'TRAVEC') THEN
         CALL TRAVEC
      ELSEIF (EXPROG .EQ. 'STOP') THEN
         GOTO 400
      ELSE
         WRITE (9, FMT='(1X/'' DDSYST file error ...'')')
         CALL DDEXIT
         ENDIF
      GOTO 300
  400 CONTINUE
      CALL DDEXIT
      END
      SUBROUTINE DDSTAR
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (ICON,  IFILE(4))
      EQUIVALENCE (ICON1, IFILE(1))
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (KPROG1, KSTAT(18))
      LOGICAL SEMAUT, FULAUT
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      PARAMETER (LITAM = 35)
      CHARACTER * 6  LITA (LITAM)
      CHARACTER LITA8 *8
      DATA NCALL / 0 /
      DATA LITA   / 'ORIENT', 'TRACOR', 'PHASEX', 'DDMAIN', 'FCALC' ,
     *              'FFT'   , 'PATTY' , 'PATTER', 'FOUR'  , 'DIRP1' ,
     *              'CRYSDA', '$PTB$$', '$PTB$$', '$PTB$$', '$PTB$$',
     *              'EULER' , 'AT2X'  , 'X2AT'  , 'FR2HKL', 'SHAT'  ,
     *              'ORFLEX', 'NUTS'  , 'TRAMOL', 'INVERT', 'BIJVOE',
     *              'SHELIN', 'R2'    , 'NOFREE', 'NORECY', 'ATMOD' ,
     *              '$PTB$$', 'ATSETS', 'NEXT'  , '$PTB$$', '$PTB$$'/
      NCALL = NCALL + 1
      IF (NCALL .EQ. 1) CCODE = ' '
      CHIN = ' '
      CHOUT = ' '
      TITLE = ' '
      CALL NULL5 (0, NRECY, NRECYR, NRECYS, NRECYT, NATS)
      NATL = 0
      DO 100 I=1,20
  100 IFILE(I) = I
      IF (MPAT .EQ. 0) THEN
         CALL KERNZI (0, KSTAT, 20)
      ELSEIF (MPAT .GT. -99) THEN
         WRITE (9, 102) IPAT, CCODE
  102    FORMAT(1X/1X/1X
     *       /' -------------------------------------------------'
     *       /' Start structure expansion for atoms set AtSET=',I3,
     *        '    for ', A6/1X)
         ENDIF
      CALL KERNZI (0, KEYS, 28)
      CALL KERNZI (0, ITIME, 4)
      DO 111 I=1,28
  111 SWITCH(I) = .FALSE.
      PROGNM = 'DDSTART'
      PROSNM = 'DDSTIN'
      CALL WR24
      CALL DDSTIN (LITA, LITAM, KPROG)
      IF (IDOKA .EQ. 17) RETURN
      PROSNM = ' '
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQCR)
      IF (KINQCR .NE. 0) THEN
         CALL CRYSDA
         CALL RDCRYS (ICRYS)
         CALL FILCLO (ICRYS, 'KEEP')
         ENDIF
      WRITE (ICON, FMT='(''REMARK PROGRAM OR OPTION CALLED: '',
     *       A6)') LITA(KPROG)
      KPROG1 = KPROG
      IF (KPROG .GE. 11) GOTO 240
      IF (KPROG .EQ. 7) FULAUT = .TRUE.
      IF (FULAUT) GOTO 240
  230 WRITE (9, FMT='('' Do you wish to run this job'',
     *  '' using default control parameters? (Y / N)'')')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 230
      IF (LIT(1).NE.'Y' .AND. LIT(1).NE.'N') THEN
         WRITE (9, FMT='('' Just: Y or N , please;''/
     *   '' For a first run, say: Y , when in doubt, try: N .'')')
         GOTO 230
         ENDIF
      IF (LIT(1) .EQ. 'Y') SEMAUT = .TRUE.
  240 KPROG2 = KPROG
      GOTO (1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 30, 30, 93, 93, 93,
     *     93, 93, 93, 93, 30, 30, 93, 30, 93, 93, 30, 27, 93, 30, 30,
     *     30, 30 ), KPROG
  270 CALL WR24
      IF (KPROG .EQ. 0) GOTO 400
      IF (KPROG .EQ. KPROG2) GOTO 91
      IF (KPROG .LT. 0) GOTO 30
      GOTO 240
  1   CALL DDORIE (KPROG)
      GOTO 270
  2   CALL DDTRAC (KPROG)
      GOTO 270
  3   CALL DDDIRD (KPROG)
      GOTO 270
  4   CALL DDMAIX (KPROG)
      GOTO 270
  5   CALL DDFCAL (KPROG)
      GOTO 270
  6   CALL DDFFT  (KPROG)
      GOTO 270
  7   CALL DDPATY (KPROG)
      GOTO 270
  8   CALL DDPATR (KPROG)
      GOTO 270
  9   CALL DDFOUR (KPROG)
      GOTO 270
  10  CALL DDDP1  (KPROG)
      GOTO 270
  27  CALL DDR2   (KPROG)
      GOTO 270
  30  CALL KERROR ('Kan niet .. ', 30, 'DDSTART')
  91  LITA8 = LITA(KPROG)
  93  LITA8 = LITA(KPROG)
      IF (LITA8 .EQ. 'NUTS') LITA8 = ' '
      WRITE (ICON, FMT='(''PROGRAM NUTS '', A8)') LITA8
  400 WRITE (ICON, FMT='(''FINISH'' )')
      CALL DDSTYX
      CALL KERASE ('DDHELP')
      RETURN
      END
      SUBROUTINE DDSTIN (LITA, LITAM, KPROG)
      CHARACTER * 6  LITA (LITAM)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IDDL,  IFILE(1)), (IDDS, IFILE(2)), (ICRYS, IFILE(3))
      EQUIVALENCE (IATMOD, IFILE(1)), (IDDJ,IFILE(2)), (ICRIN, IFILE(4))
      EQUIVALENCE (ICON, IFILE( 4))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (MFLEX, KSTAT(10))
      EQUIVALENCE (IDOKA, KEYS(10)), (KP2, KEYS(21))
      LOGICAL SEMAUT, FULAUT, NORECY, NOFREE
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      EQUIVALENCE (NORECY, SWITCH(8)), (NOFREE, SWITCH(9))
      CHARACTER LITA8 *8
      CHARACTER *6 L(6), CCLOG, CCJOB, CCCRY, DDL, DDJ, DDC, CCC
      CHARACTER *6 LHELP(6), XXX, QQQ
      CHARACTER ISTAR *2
      DATA ISTAR /'=='/
      DATA LMAX / 6 /
      DATA L    /  'END', 'H', '?', 'HELP', 'CCODE', 'BATCH' /
      DATA LHMAX /6/
      DATA LHELP / 'CONDA', 'DIRDIF', 'PROG', 'FILES', 'START', 'AUTO'/
      DATA KINQCO /0/
      DATA  CCLOG, CCJOB, CCCRY,  DDL,     DDJ,     DDC,      CCC
     *    /  ' ',   ' ',   ' ',  'DDLOG', 'DDJOB', 'CRYSIN', 'CCODE' /
      DATA LDDJOB, KDDJOB, ICONT, IXXX / 0, 0, 0, 0 /
      DATA XXX / ' '/
      DATA NCALL / 0 /
      DATA LIS3, L192 / 25, 9 /
      WRITE (8, FMT='(/'' ***** subroutine DDSTIN''/)')
      NCALL = NCALL + 1
      CALL KERNZ6 (XXX, LIT, 32)
      CALL KERNZ6 (XXX, LITJ, 5)
      KPROG = 0
      IF (NCALL .EQ. 1) CALL XHELP
      CALL KERASE ('MERCUR')
      CALL KERASE ('DDSTOP')
      CALL KERASE ('ATTEM')
      CALL FILINQ (2, 'DDJOB', 'FORMATTED', 'INPUT', KIDDJ)
      IF (KIDDJ .EQ. -1) GOTO 113
      CALL KERINA (2, LIT, 1, LEND)
      CALL KERNAC (LIT, LITJ, 5)
      IF (NCALL .NE. 1) THEN
         WRITE (24, FMT='(1X/1X/'' DDJOB = '', 5A7)') (LIT(I), I=1,5)
         ENDIF
      CALL FILCLO (2, 'DELETE')
      IF (LITJ1 .EQ. 'PATTY' .OR. LITJ2 .EQ. 'PATTY' ) THEN
         MPAT = NINT(FNUM(1))
         IF (MPAT .EQ. 0) THEN
            MPAT = 55
         ELSE
            WRITE (9,FMT='(1X/'' PATTY, max nr of solutions:'',I3/1X)')
     *         MPAT
            ENDIF
         ENDIF
      IF (LITJ1 .EQ. 'ORIENT' .OR. LITJ2 .EQ. 'ORIENT' ) THEN
         MORIE = NINT(FNUM(1))
         IF (MORIE .EQ. 0 .OR. MORIE .GT. 55) THEN
            MORIE = 55
         ELSE
            WRITE(9,FMT='(1X/'' ORIENT, max nr of solutions:'',I3/1X)')
     *         MORIE
            ENDIF
         ENDIF
      IF (LITJ1 .EQ. 'TRAVEC' .OR. LITJ2 .EQ. 'TRAVEC' ) THEN
         WRITE (9, FMT='('' You supplied TRAVEC, which is'',
     *      '' neither acceptable as CCODE ''/,
     *      '' nor as parameter: calling TRACOR assumed ! '')')
         IF (LITJ1 .EQ. 'TRAVEC') LITJ1 = 'TRACOR'
         IF (LITJ2 .EQ. 'TRAVEC') LITJ2 = 'TRACOR'
         ENDIF
      IF (LITJ1 .EQ. 'MERBIN' .OR. LITJ2 .EQ. 'MERBIN' ) THEN
         WRITE (9, FMT='(1X/'' Wrong call ''/
     *      '' You supplied MERBIN, which is'',
     *      '' obsolete  ''/ '' Please, call again! '' )')
         GOTO 130
         ENDIF
      IF (LITJ1 .EQ. 'ORBASE' .OR. LITJ2 .EQ. 'ORBASE' ) THEN
         WRITE (9, FMT='(1X/'' You supplied ORBASE, which is'',
     *      '' obsolete - next time call ATMOD  ''/1X)')
         IF (LITJ1 .EQ. 'ORBASE') LITJ1 = 'ATMOD'
         IF (LITJ2 .EQ. 'ORBASE') LITJ2 = 'ATMOD'
         ENDIF
      IF (LITJ1 .EQ. 'NOFREE' .OR. LITJ2 .EQ. 'NOFREE' .OR.
     *    LITJ3 .EQ. 'NOFREE' .OR. LITJ4 .EQ. 'NOFREE' ) THEN
         WRITE (9, 107)
  107    FORMAT (' NOFREE is interpreted as: ccode FOUR NOFREE NORECY')
         NOFREE = .TRUE.
         NORECY = .TRUE.
         LITJ4 = ' '
         LITJ5 = ' '
         IF (LITJ1 .EQ. 'NOFREE') THEN
            LITJ1 = 'FOUR'
            LITJ2 = 'NOFREE'
            LITJ3 = ' '
         ELSE
            LITJ2 = 'FOUR'
            LITJ3 = 'NOFREE'
            ENDIF
         ENDIF
      IF (LITJ1 .EQ. 'NORECY' .OR. LITJ2 .EQ. 'NORECY' .OR.
     *    LITJ3 .EQ. 'NORECY' ) THEN
         NORECY = .TRUE.
         LITJ4 = ' '
         LITJ5 = ' '
         IF (LITJ1 .EQ. 'NORECY') THEN
            LITJ1 = 'FOUR'
            LITJ2 = 'NORECY'
            LITJ3 = ' '
         ELSE
            LITJ2 = 'FOUR'
            LITJ3 = 'NORECY'
            ENDIF
         ENDIF
      IF (LITJ1 .EQ. ' ') THEN
         IF (CHIN .EQ. ' ') THEN
            WRITE (9, FMT='('' Ignore empty DDJOB file '')')
         ELSE
            WRITE (9, FMT='('' Wrong params; HELP invoked '')')
            ENDIF
         KIDDJ = -1
         QQQ = ' '
         CALL KERNZ6 (QQQ, LITJ, 5)
         GOTO 113
         ENDIF
      IXXX = 1
      XXX = LITJ1
  111 CONTINUE
      CALL KEREQ6 (XXX, L, LMAX, LDDJOB)
      IF (LDDJOB .GT. 0) GOTO 113
      CALL KEREQ6 (XXX, LHELP, LHMAX, LDDJOB)
      IF (LDDJOB .GT. 0) GOTO 113
      CALL KEREQ6 (XXX, LITA, LITAM, KDDJOB)
      IF (KDDJOB .GT. 0) GOTO 113
      CCJOB = XXX
  113 CONTINUE
          IF (IXXX .EQ. -1) GOTO 135
          IF (IXXX .EQ. 2 ) GOTO 138
          IF (IXXX .EQ. 3 ) GOTO 151
      CALL LOGRD (IDDL, 'DDLOG', KIDDL)
      IF (KIDDL .GE. 0) THEN
         CCLOG = LIT(2)
         CALL FILCLO (IDDL, 'KEEP')
         ENDIF
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KIDDC)
      IF (KIDDC .GE. 0) THEN
         CALL KERINA (ICRIN, LIT, 1, LEND)
         IF (LIT(1).NE.'CRYSIN')  CALL KERROR
     *      ('ERROR on first record of CRYSIN file', 0, 'RDCRIN')
         CCCRY = LIT(2)
         CALL FILCLO (ICRIN, 'KEEP')
         ENDIF
      IF (CCLOG.NE.' ' .AND. CCCRY.NE.' ' .AND. CCLOG.NE.CCCRY) THEN
         WRITE (9, 123) DDL, CCLOG, DDC, CCCRY
  123    FORMAT (' Error: CCODE on the ', A6, ' file    is ', A6 /
     *           '        but   on the ', A6, ' file it is ', A6 /
     *      ' File errors or wrong directory? Sorry, we must quit! '/
     *      '                ---------------?             Bye bye.')
         GOTO 130
         ENDIF
      IF (CCJOB.NE.' ' .AND. CCCRY.NE.' ' .AND. CCJOB.NE.CCCRY) THEN
         WRITE (9, 123) DDJ, CCJOB, DDC, CCCRY
         GOTO 130
         ENDIF
      IF (CCJOB.NE.' ' .AND. CCLOG.NE.' ' .AND. CCJOB.NE.CCLOG) THEN
         WRITE (9, 123) DDJ, CCJOB, DDL, CCLOG
         GOTO 130
         ENDIF
      IF (CCODE .EQ. ' ') GOTO 125
      IF (CCLOG .NE. ' ' .AND. CCLOG .NE. CCODE) THEN
         WRITE (9, 123) DDL, CCLOG, CCC, CCODE
         GOTO 130
         ENDIF
      IF (CCCRY .NE. ' ' .AND. CCCRY .NE. CCODE) THEN
         WRITE (9, 123) DDC, CCCRY, CCC, CCODE
         GOTO 130
         ENDIF
      IF (CCJOB .NE. ' ' .AND. CCJOB .NE. CCODE) THEN
         WRITE (9, 123) DDJ, CCJOB, CCC, CCODE
         GOTO 130
         ENDIF
  125 CONTINUE
      IF (NCALL .NE. 1) GOTO 131
      IF (CCLOG .NE. ' ') CCODE = CCLOG
      IF (CCCRY .NE. ' ') CCODE = CCCRY
      IF (CCJOB .NE. ' ') CCODE = CCJOB
      IF (CCLOG.NE.' ' .AND. CCCRY.NE.' ') THEN
         WRITE (9, 126 ) CCODE
  126    FORMAT (' Continue structure solution for compound  ', A6)
      ELSEIF ( CCLOG .NE. ' ') THEN
         WRITE (9, 127 ) CCODE
  127    FORMAT (' Continue structure solution for compound  ', A6/
     *           ' WARNING: file CRYSIN missing! ')
      ELSEIF ( CCODE .NE. ' ' ) THEN
         WRITE (9, 128 ) CCODE
  128    FORMAT (' Start  structure solution  for  compound  ', A6)
      ELSEIF ( KDDJOB .GT. 0) THEN
            GOTO 133
      ELSEIF ( KIDDJ .EQ. -1) THEN
         GOTO 139
      ELSE
         WRITE (9, FMT=
     *        '('' your input not understood: invoke help:'') ')
         GOTO 139
         ENDIF
      IF (CCODE .NE. 'ERROR') GOTO 131
         WRITE (9, FMT=
     *        '('' ERROR is not acceptable: wrong directory ??''/
     *          '' Please, call again!      --------------- ??''/
     *          '' STOP 102 '' )')
  130 CONTINUE
      CALL WR24
      CALL KERASE ('DDHELP')
      CALL KERASE ('LIS3')
      STOP
  131 CONTINUE
      IF ( CCJOB .NE. ' ') CCODE = CCJOB
      IF ( CCODE .EQ. ' ' .AND. KIDDJ .EQ. -1) GOTO 139
      IF ( LDDJOB .GT. 0) GOTO 139
      IF ( CCODE .NE. ' ') GOTO 137
  133 WRITE (9, 134)
  134    FORMAT (' enter: CCODE (true compound code) or H or Q')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 133
      IF (LIT(1).EQ.'H') GOTO 3
      IF (LIT(1).EQ.'Q') GOTO 130
      IXXX = -1
      XXX = LIT(1)
      KXXX = KDDJOB
      KDDJOB = 0
      GOTO 111
  135 CONTINUE
      IF (CCJOB .EQ. ' ') THEN
         WRITE (9, 136 ) XXX
  136    FORMAT (' input ', A6, ' incorrect: invoke help:')
         KDDJOB = 0
         GOTO 139
         ENDIF
      KDDJOB = KXXX
      CCODE = CCJOB
  137 CONTINUE
      CALL KERASE ('DDSTOP')
      CALL KERASE ('DDSYST')
      CALL LOGRD (IDDL, 'DDLOG', KIDDL)
      IF (KIDDL .LT. 0) GOTO 1115
      CCLOG = LIT(2)
      CALL FILCLO (IDDL, 'KEEP')
 1115 CONTINUE
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KIDDC)
      IF (KIDDC .LT. 0) GOTO 1117
      LIT(1) = ' '
      CALL KERINA (ICRIN, LIT, 1, LEND)
      IF (LIT(1).NE.'CRYSIN') CALL KERROR
     *   ('ERROR on first record of CRYSIN file', 0, 'RDCRIN')
      CCCRY = LIT(2)
      CALL FILCLO (ICRIN, 'KEEP')
 1117 CONTINUE
      IF (LITJ1 .EQ. ' ') GOTO 139
      IF (LDDJOB .GT. 0) GOTO 139
      IF (KDDJOB .GT. 0) GOTO 170
      IF (LITJ1 .NE. CCODE) THEN
         WRITE (9, 136 ) LITJ1
         GOTO 139
         ENDIF
      IF (LITJ2 .EQ. ' ') GOTO 139
      IXXX = 2
      XXX = LITJ2
      GOTO 111
  138 CONTINUE
      IF (LDDJOB .GT. 0) GOTO 139
      IF (KDDJOB .GT. 0) GOTO 170
      WRITE (9, 136 ) LITJ2
  139 CALL DDHELP (101., 101., 103., L, 1, KEND)
      IF (KIDDJ .NE. 0) GOTO 140
      GOTO (4,   2,  4,  4,   5,    6),   LDDJOB
  4   CALL DDHELP (104., 102., 105., L, 1, KEND)
  2   IF (LITJ2 .EQ. ' ') GOTO 3
      CALL DDHELP (102., 102., 105., L, 1, KEND)
  3   CALL DDHELP (103., 102., 105., L, 1, KEND)
      GOTO 140
  5   CALL DDHELP (105., 105., 107., L, 1, KEND)
      GOTO 2
  6   CALL DDHELP (106., 106., 107., L, 1, KEND)
      GOTO 2
  140 WRITE (9, 141)
  141 FORMAT (' Enter:  Q     to quit now, or else:')
      IF (CCODE .EQ. ' ') THEN
         WRITE (9, 142)
  142    FORMAT (' enter:  CCODE  ( true compound code )')
         CALL KETERM (0, 1, KEND)
         IF (KEND .LT. 0) GOTO 140
         ICONT = 1
         IF (LIT(1).EQ.'H') GOTO 3
         IF (LIT(1).EQ.'Q') GOTO 130
         GOTO 150
      ELSE
  144    WRITE (9, 146 )
  146    FORMAT (' enter: program/option (+params)' )
         CALL KETERM (0, -1, KEND)
         IF (KEND .LT. 0) GOTO 140
         IF (LIT(1).EQ.'H') GOTO 3
         IF (LIT(1).EQ.'Q') GOTO 130
         IF (LIT(1) .EQ. CCODE) THEN
            WRITE (9, FMT='('' NOT AGAIN CCODE...'')')
            GOTO 144
            ENDIF
         GOTO 160
         ENDIF
  150 CONTINUE
      IXXX = 3
      XXX = LIT(1)
      CCJOB = ' '
      GOTO 111
  151 CONTINUE
      IF (CCJOB .NE. ' ') GOTO 154
      WRITE (9, 152) LIT(1)
  152 FORMAT (' NOT ACCEPTED: ', A6, ' is not a valid compound code')
      GOTO 140
  154 CCODE = LIT(1)
      WRITE (9, 155 ) CCODE
  155 FORMAT (' Start structure solution for compound ', A6)
  156 WRITE (9, 157 )
  157 FORMAT (' Enter: program/option (+params) or H or Q :' )
      CALL KETERM (0, -1, KEND)
      IF (KEND .LT. 0) GOTO 156
      IF (LIT(1).EQ.'H') GOTO 3
      IF (LIT(1).EQ.'Q') CALL KEPROZ
      IF (LIT(1) .EQ. CCODE) THEN
         WRITE (9, FMT='('' NOT AGAIN <CCODE> ...'')')
         GOTO 156
         ENDIF
  160 CONTINUE
      IF (LIT(1) .EQ. 'NORECY') THEN
         LIT(2) = LIT(1)
         LIT(1) = 'FOUR'
         ENDIF
      CALL KEREQ6 (LIT(1), LITA, LITAM, KP2)
      IF (KP2 .GT. 0) GOTO 164
      WRITE (9, 162) LIT(1)
  162 FORMAT (' NOT ACCEPTED: ', A6, ' is not a valid program/option')
      GOTO 156
  164 CONTINUE
      IF (LIT(1) .EQ. 'PATTY') MPAT = 55
      IF (LIT(1) .EQ. 'ORIENT') MORIE = 55
      CALL KERNAC (LIT, LITJ, 5)
      KDDJOB = 0
  170 IF (CCODE .EQ. LITJ1) GOTO 173
      LITJ5 = LITJ4
      LITJ4 = LITJ3
      LITJ3 = LITJ2
      LITJ2 = LITJ1
      LITJ1 = CCODE
  173 CONTINUE
      CALL LOGRD (IDDL, 'RUN', IIIRUN)
      IF (IIIRUN .GT. 0 .AND. IRUN .EQ. 0) IRUN = NINT(FNUM(2)) +1
      CALL FILCLO (IDDL, 'KEEP')
      IF (CCODE .EQ. ' ') STOP 111
      IF (MPAT .LT. 0) GOTO 176
      CALL FILCLO (7, 'DELETE')
      CALL FILCLO (8, 'DELETE')
      CALL KERASE ('LIS1X')
      CALL KERASE ('LIS2X')
      CALL COPY80 (7, 'LIS1', 3, 'LIS1X')
      CALL COPY80 (8, 'LIS2', 3, 'LIS2X')
      CALL FILINQ (7, 'LIS1', 'FORMATTED', 'OUTPUT', KINQ)
      CALL FILINQ (8, 'LIS2', 'FORMATTED', 'OUTPUT', KINX)
      WRITE (7, FMT='(1X/ 25X, ''File  '', A6, ''  LIS1'')') CCODE
      WRITE (8, FMT='(1X/ 17X, ''File  '', A6,
     *   ''  LIS2:  Auxiliary listing''/ 11X,
     *   ''!! Extra information for troublesome structures !!''/)')
     *   CCODE
      WRITE (24, 1175) (ISTAR, I=1,35), DATUM, (ISTAR, I=1,35)
 1175 FORMAT (1X/1X/1X/1X, 35A2, '=' / ' ****', 62X, ' ****' / ' ****',
     + ' The DIRDIF program system,', A36,
     +              '****' / ' ****', 62X, ' ****' / 1X, 35A2, '=')
      WRITE (24, 175) LITJ
  175 FORMAT (1X/ ' DIRDIF Calling control parameters:', 5A7 /1X/1X)
      REWIND LIS3
      WRITE (LIS3, FMT='(''LIS3 '', A6,
     *      '' = test results'')') CCODE
  176 CONTINUE
      IF (LITJ2 .EQ. 'PATTY' .AND. MPAT .GT. 0 .AND. MPAT .LT. 55 )
     *    WRITE(24,FMT='(/'' PATTY, max nr of solutions:'',I3/)') MPAT
      IF (LITJ1 .EQ. 'ORIENT' .AND. MORIE .GT. 0 .AND. MORIE .LT. 55 )
     *  WRITE(24,FMT='(/'' ORIENT, max nr of solutions:'',I3/)') MORIE
      CALL WR24
      CCODER = ' '
      IF (CCODE(2:2) .EQ. ' ') THEN
         CCODER(6:6) = CCODE(1:1)
      ELSEIF (CCODE(3:3) .EQ. ' ') THEN
         CCODER(5:6) = CCODE(1:2)
      ELSEIF (CCODE(4:4) .EQ. ' ') THEN
         CCODER(4:6) = CCODE(1:3)
      ELSEIF (CCODE(5:5) .EQ. ' ') THEN
         CCODER(3:6) = CCODE(1:4)
      ELSEIF (CCODE(6:6) .EQ. ' ') THEN
         CCODER(2:6) = CCODE(1:5)
      ELSE
         CCODER = CCODE
         ENDIF
      CALL CONDAT
      CALL FILINQ (15, 'ATOLD', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. -1) THEN
         CALL KERASE ('ATOLDX')
         CALL COPY80 (15, 'ATOLD', 16, 'ATOLDX')
         CALL FILCLO (15, 'DELETE')
         ENDIF
      IF (MPAT .EQ. -999) MPAT = 0
      IF (LITJ2 .EQ. 'NEXT  ') LITJ2 = 'ATSETS'
      IF (LITJ2 .EQ. 'ATSETS') CALL ATSETS
      IF (LITJ2 .EQ. 'ORFLEX') CALL ORFLEX
      IF (LITJ2 .EQ. 'ORIENT') THEN
         CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'INPUT', KINQ)
         IF (KINQ .NE. 0) THEN
            WRITE (9, FMT='(
     *       '' For ORIENT, an ATMOD file must be present.'')')
            CALL RESTRT ('ORBASE')
            ENDIF
         MFLEX = 0
         MFLAT = 0
 180     READ (IATMOD, END=186, FMT='(A72)') CHIN
         IF (MFLEX .EQ. 0 .AND. CHIN(1:5) .NE. 'ATMOD') CALL KERROR
     *      ('File ATMOD not correct', 180, 'DDSTIN')
         IF (CHIN(1:4) .EQ. 'END ') GOTO 186
         IF (CHIN(1:6) .EQ. 'FINISH') GOTO 186
         IF (CHIN(1:5) .NE. 'ATMOD') GOTO 180
         MFLEX = MFLEX + 1
         MFLAT = 0
 182     READ (IATMOD, END=183, FMT='(A72)') CHIN
         IF (CHIN(1:4) .EQ. 'END ') GOTO 184
         IF (CHIN(1:6) .EQ. 'REMARK') GOTO 182
         IF (CHIN .EQ. '           ') GOTO 182
         IF (CHIN(1:5) .NE. 'ATOM ') THEN
            WRITE (9, FMT='(1X, A71)') CHIN(1:71)
            CALL KERROR ('File ATMOD not correct', 182, 'DDSTIN')
            ENDIF
         MFLAT = MFLAT + 1
         GOTO 182
 183     CALL KERROR
     *      ('File ATMOD, unexpected end of atoms ', 183, 'DDSTIN')
 184     IF (MFLAT .LE. 1) CALL KERROR
     *      ('File ATMOD, set with only 1 or 2 atoms ', 184, 'DDSTIN')
         GOTO 180
 186     IF (MFLEX .EQ. 0) CALL KERROR
     *      ('File ATMOD is empty ', 186, 'DDSTIN')
         WRITE (9, 188) MFLEX
 188     FORMAT(1X/' The ATMOD file contains',I4,
     *      ' model(s) for ORIENT'/1X)
         IF (MORIE .LT. 55) THEN
            IF (MFLEX .LE. 1) THEN
               WRITE (9, FMT='('' At most'',I4,
     *            ''  orientations will be analysed''/)') MORIE
            ELSE
               WRITE (9, FMT='('' For each model, at most'',I4,
     *            ''  orientations will be analysed''/)') MORIE
               ENDIF
            ENDIF
         CALL FILCLO (IATMOD, 'KEEP')
         ENDIF
      CALL WR24
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KIDDS)
      WRITE (IDDS, FMT='(''STOP'')')
      CALL FILCLO (IDDS, 'KEEP')
      KPROG = KDDJOB
      IF (KP2 .GT. 0) KPROG = KP2
      KDDJOB = KPROG
      IF (KPROG .EQ. 30) THEN
         WRITE (9, FMT='(A)')
     *      ' prepare ATMOD ( using the ORBASE data base ? ) '
         IF (CCODE .EQ. ' ') KPROG = 31
         CALL ORBAX (KPROG)
         ENDIF
      IF (KDDJOB .LE. 0 .OR. KDDJOB .GT. 10 ) GOTO 194
         SEMAUT = .TRUE.
      IF (KDDJOB.LE.3 .OR. KDDJOB.EQ.7 .OR. KDDJOB.GE.9) THEN
         WRITE (L192, 192) LITJ2, CCODE, IRUN
  192       FORMAT (10X, ' Automatic run of program ', A8 ,
     *               ' for compound', A7, ' RUN=' , I3 /1X)
         FULAUT = .TRUE.
         L192 = 24
      ELSE
         WRITE (24, 193) LITJ2, CCODE, IRUN
  193    FORMAT (' Interactive run of pgm/opt ', A8 ,
     *               ' for compound', A7, ' RUN=' , I3 /1X)
         ENDIF
  194 CONTINUE
         KP2 = KPROG
      CALL KEREQ6 (LITJ3, LITA, LITAM, KP3)
      IF (LITJ3 .EQ. ' ') KP3 = 0
      IF (LITJ3 .EQ. 'NORECY') THEN
         KP3 = 0
         NORECY = .TRUE.
         ENDIF
      CALL WR24
      IF (IRUN .EQ. 0) IRUN = 1
      WRITE (CHOUT, FMT='(''RUN '', I3, '' Call DIRDIF '', 5A7)')
     *  IRUN, LITJ
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
  327 IF (KP2 .EQ. 11) THEN
         CALL CRYSDA
         IDOKA = -17
         CALL KEPROX
         ENDIF
      IF (NCALL .EQ. 1) CALL CRYSDA
      IF (NCALL .EQ. 1) CALL RDCRYS (ICRYS)
      IF (KP2 .EQ. 30) CALL ORBAX (KP2)
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'OUTPUT', KINQCO)
      WRITE (ICON, FMT='(''CONDA '', A6 )') CCODE
      IF (KPROG .GT. 0) RETURN
      IF (KP2 .GT. 0) CALL DDSPEC (LITA, LITAM, KP2, KP3)
      IF (KP2 .GT. 0) RETURN
      IF (IRUN .LE. 2) CALL DDHELP (109., 109., 109.1, LIT, 1, KELP)
  807 CALL DDHELP (110., 110., 112., LITA, LITAM, KELP)
      IF (KELP .LE. 0) GOTO 880
      IF (IPOLA .NE. 7) GOTO 811
      IF (KELP .NE. 2 .AND. KELP .NE. 10) GOTO 811
      WRITE (9, 809) LITA(KELP)
  809 FORMAT (3X, A6, ' is not applicable to space group P1: ')
      GOTO 807
  811 KPROG = KELP
      LITA8 = LITA(KPROG)
      IF (LITA8 .EQ. 'BIJVOE') LITA8 = 'BIJVOET'
      IF (LITA8 .EQ. 'CRYSDA') THEN
         WRITE (9, 819) CCODE
  819 FORMAT (' The CRYSDA file for ', A6,' will be generated.'/
     *   ' Note: if you want to change the crystal data,' /
     *   ' edit CRYSIN ! , and delete  the CRYSDA file !' )
         KP2 = 11
         GOTO 327
         ENDIF
      WRITE (9, FMT='('' The DIRDIF system will be activated'',
     *    '' to execute option/ program '', A8)') LITA8
      CALL WR24
      RETURN
  880 WRITE (9, FMT='(A)') ' No program given. STOP'
      CALL FILCLO (ICON, 'DELETE')
      CALL KEPROZ
      END
      SUBROUTINE DDSTYX
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDDS, IFILE(2)), (ICON, IFILE(4))
      EQUIVALENCE (IDOKA, KEYS(10))
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      CHARACTER LITA8 *8
      WRITE (8, FMT='(1X/'' ***** subroutine DDSTIX''/1X)')
      NCRY = -999
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      REWIND ICON
      IF (FULAUT) GOTO 200
  200 CALL KERINA (ICON, LIT, 1, LEND)
      IF (LEND .EQ. -1 .OR. LEND .GE.  5) GOTO 230
      IF (LIT(1) .NE. 'PROGRA') GOTO 200
      LITA8 = LIT(2)
      NCRY = NCRY + 1
      IF (LITA8 .EQ. 'CRYSDA') NCRY = 1
      WRITE (IDDS, 220)  LITA8
  220 FORMAT (A8)
      WRITE (8, FMT='('' DDSYST file : '', A8)') LITA8
      GOTO 200
  230 WRITE (IDDS, FMT='(''STOP'')' )
      CALL FILCLO (IDDS, 'KEEP')
      IF (NCRY .EQ. 1) THEN
         CALL FILCLO (ICON, 'DELETE')
         IDOKA = -17
         CALL KEPROX
         ENDIF
      REWIND ICON
      CALL WR24
      WRITE (8, 231)
  231 FORMAT (/' Contents of the CONDA file:')
      CHOUT = ' '
  233 READ (ICON, END=234, FMT='(A72)') CHOUT
      WRITE (8, FMT='(3X, A72)') CHOUT
      IF (CHOUT(1:6).NE.'FINISH' .OR. CHOUT(1:5).NE.'STOP ') GOTO 233
  234 CALL FILCLO (ICON, 'KEEP')
      CALL KEPROX
      IDOKA = 17
      RETURN
      END
      SUBROUTINE DDHELP (AKEY, AKEYB, AKEYM, LITA, LITAM, KEND)
      CHARACTER * 6  LITA (LITAM)
      INCLUDE 'Zsyst.inc'
      PARAMETER (NNMAX=96, LLMAX=296)
      DIMENSION NN(NNMAX), NL(NNMAX), NC(NNMAX), NB(NNMAX)
      INCLUDE 'Zch80.inc'
      CHARACTER*72 CH(LLMAX)
      EQUIVALENCE (CH80(2), CH(1))
      CHARACTER ALIT*6
      LOGICAL QUIT
      DIMENSION LLAB(20)
      PARAMETER  (LCHM = 4)
      CHARACTER*6 LCH(LCHM)
      DATA LCH   /'+$', '+A', '+$', '+D' /
      DATA MINA, MAXA /1000000, 1000/
      DATA I, LEVEL, LASTLA, KEYOLD / 0, 0, 0, 0 /
      DATA IRD, IHELP / 5, 18 /
      KEY  = NINT (1000. * AKEY)
      KEYB = NINT (1000. * AKEYB)
      KEYM = NINT (1000. * AKEYM)
      IF (KEY.LT.KEYB .OR. KEY.GT.KEYM) CALL KERROR
     *   ('Help call range error', 1 , 'DDHELP')
      IF (KEYB.EQ.MINA .AND. KEYM.EQ.MAXA) GOTO 490
      L = 0
      I = 0
      CALL FILCLO (IHELP, 'KEEP')
      CALL FILINQ (IHELP, 'DDHELP', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) CALL KERROR
     *   ('File dirdif.ddhelp not found', 200, 'DDHELP')
      BKEY = AKEYB - 0.0005
  200 READ (IHELP, 210, END=990, ERR=990) CHIN(1:72)
  210 FORMAT (A72)
      IF (CHIN(1:1).NE.'+') GOTO 200
      IF (CHIN(1:2).EQ.'++' .OR.
     *    CHIN(1:2).EQ.'+A' .OR. CHIN(1:2).EQ.'+D') GOTO 200
      CALL KERINB (LCH, LCHM)
      IF (NCOLN(1).NE.1) GOTO 200
      IF (BKEY.GT.FNUM(1)) GOTO 200
      N = NINT (1000. * FNUM(1))
      IF (N.NE.KEYB) THEN
         WRITE (9, FMT='('' REQUESTED LABEL:'', F8.3)') FNUM(1)
         CALL KERROR
     *   ('Requested label not found',210, 'DDHELP')
         ENDIF
      MINA = KEYB
      MAXA = KEYM
      KEYOLD = 0
      GOTO 310
  300 CONTINUE
      READ (IHELP, 210, END=990, ERR=990) CHIN(1:72)
  310 CALL CHINLI (KEND, L3, L4, LEND)
      GOTO (300,  320, 330, 360, 992, 360), KEND
  320 IF (NB(I).NE.0) CALL KERROR ('Help file error', 320, 'DDHELP')
      GOTO 350
  330 N = NINT (1000. * FNUM(1))
      IF (N.GE.MAXA) GOTO 480
      IF (I.EQ.0) GOTO 340
      IF (NB(I).EQ.0) NB(I) = N
  340 I = I + 1
      IF (I.GT.NNMAX) CALL KERROR
     *   ('Too many labels: AKEY - AKEYM spans > 96', 340, 'DDHELP')
      NN(I) = N
      NC(I) = 0
      NB(I) = 0
      NL(I) = L+1
  350 IF (L3.LE.0) GOTO 400
      L = L + 1
      IF (L.GE.LLMAX) CALL KERROR
     *   ('Too many lines: AKEY - AKEYM spans > 296', 350, 'DDHELP')
      CH(L) = CHIN(L3:L4)
      NC(I) = NC(I) + 1
      GOTO 400
  360 L = L + 1
      IF (L.GE.LLMAX) CALL KERROR
     *   ('Too many lines: AKEY - AKEYM spans > 296', 360, 'DDHELP')
      CH(L) = CHIN(1:72)
      IF (NB(I).EQ.0) NB(I) = -KEND
      GOTO 300
  400 GOTO (300, 300, 430, 440, 440, 440, 440, 440, 992), LEND
  430 NB(I) = NINT (1000. * FNUM(NFNUM))
      IF (NB(I).LT.KEYB .OR. NB(I).GT.KEYM) CALL KERROR
     +   ('Branch outside stored range: KEYB .. KEYM', 430, 'DDHELP')
      GOTO 300
  440 NB(I) = -LEND
      GOTO 300
  480 REWIND IHELP
      CH(L+1)  = ' '
      I = 1
  490 LEVH = 0
      KEND = 0
      LIT(1) = ' '
      QUIT = .FALSE.
      IF (KEY.EQ.KEYOLD) THEN
         KEY = LLAB (LEVEL)
      ELSE
         KEYOLD = KEY
         LEVEL = 1
         LLAB(1) = KEY
         LASTLA = 0
         ENDIF
  500 CONTINUE
      IF (KEY-NN(I)) 504, 510, 508
  502 IF (KEY-NN(I)) 504, 510, 992
  504 IF (I.LE.1) CALL KERROR
     *   ('Negative index (to find label address for printing)',
     *     504, 'DDHELP')
      I = I - 1
      GOTO 502
  506 IF (KEY-NN(I)) 992, 510, 508
  508 IF (I.GE.NNMAX) CALL KERROR
     *   ('Index (to find label address for printing) exceeds maximum',
     *     508, 'DDHELP')
      I = I + 1
      GOTO 506
  510 LASTI = I
      L = NL(I)
      LM = L + NC(I) - 1
      IF (LM.LT.L) GOTO 520
      IF (LM.GT.LLMAX) GOTO 992
      WRITE (9,516)
      DO 515 LL=L,LM
  515 WRITE (9, 516) CH(LL)
  516 FORMAT (1X, A72)
      WRITE (9,516)
  520 KEY = NB(I)
      IF (KEY) 525, 992, 500
  525 IF (KEY.EQ.-5) RETURN
      IF (KEY.NE.-4) GOTO 700
      CALL KETERM (0, 1, KETE)
      IF (KETE.LT.0) THEN
         WRITE (9, FMT='('' Please, supply one item!'')')
         ALIT = 'R'
         GOTO 570
         ENDIF
      ALIT = LIT(1)
      LA = LM
  530 LA = LA + 1
      IF (LA.GT.LLMAX) CALL KERROR
     *   ('Help error: +A line not found', 530, 'DDHELP')
      IF (CH(LA)(1:3).NE.'+A ') GOTO 530
      IF (QUIT) THEN
         QUIT = .FALSE.
         GOTO 545
        ENDIF
      IF (LASTLA.EQ.LA) GOTO 545
      LEVEL = LEVEL + 1
      LLAB(LEVEL) = NN(I)
      LASTLA = LA
  545 IF (NN(I).GT.LLAB(LEVEL)) LLAB(LEVEL) = NN(I)
      DO 550 LL=LA,LLMAX
      IF (CH(LL)(1:3).NE.'+A ') GOTO 560
      CHIN = CH(LL) (3:72)
      CALL KERINB (LIT, 1)
      DO 550 K=1,NLIT
      IF (ALIT.EQ.LIT(K)) GOTO 600
  550 CONTINUE
  560 LIT(1) = ALIT
      IF (ALIT.NE.'Q') GOTO 570
  561 QUIT = .TRUE.
      IF (LEVH.GT.0) THEN
         LEVEL = LEVH
         LEVH = 0
      ELSE
         LEVEL = LEVEL - 1
         IF (LEVEL .EQ. 0) RETURN
         ENDIF
  563 KEY = LLAB(LEVEL)
      GOTO 500
  570 IF (ALIT.NE.'R') GOTO 580
      WRITE (9, FMT='('' Question will be repeated:'')')
      GOTO 563
  580 IF (ALIT.NE.'H') GOTO 590
      WRITE (9, FMT =
     * '('' Sorry, help not available. Please try again.'')' )
      GOTO 563
  590 WRITE (9, FMT =
     * '('' Answer not understood; please try again (Q for quit).'')' )
      GOTO 563
  600 IF (FNUM(K).GT.0) FNUM(K) = 1000. * FNUM(K)
      KEY = NINT (FNUM(K))
      LIT(1) = ALIT
      IF (KEY .LE. 0) GOTO 602
      IF (ALIT .EQ. 'H') LEVH = LEVEL
      GOTO 500
  602 CALL KEREQ6 (ALIT, LITA, LITAM, KER6)
      IF (KEY .NE. -1) GOTO 620
      IF (KER6.LT.0) GOTO 614
  605 WRITE (9, 610) ALIT
  610 FORMAT (' You supplied ', A6, ', OK? (Y/N)')
      CALL KETERM (0, 1, KETE)
      IF (KETE.LT.0) GOTO 605
      IF (LIT(1).EQ.'Y') GOTO 620
  614 WRITE (9, 615) ALIT
  615 FORMAT (1X, A6, ' .... answer discarded ')
      KEY = LLAB(LEVEL)
      GOTO 500
  620 IF (KEY.LT.-1) CALL KERROR ('Error in DDHELP file',620, 'DDHELP')
      LIT(1) = ALIT
      IF (KER6 .GT. 0) KEND = KER6
      RETURN
  700 IF (KEY.EQ.-7) GOTO 561
      IF (KEY .NE. -6) CALL KERROR
     *   ('Error in DDHELP file', 700, 'DDHELP')
  800 LA = LM + 1
      IF (LA.GT.LLMAX) CALL KERROR
     *   ('Help error: +D line not found', 800, 'DDHELP')
      IF (CH(LA)(1:3).NE.'+D ') GOTO 800
      CHIN = CH(LA)(3:72)
      CALL KERINB (LITA, LITAM)
      IF (NLUSER(1).LE.0 .OR. NFNUM.NE.2) GOTO 992
      NLUSE = NLUSER(1)
      INUM = NINT(FNUM(1))
      ILIT = NINT(FNUM(2))
      IF (INUM.EQ.0 .AND. ILIT.EQ.0)
     *   CALL KERROR ('Error in DDHELP file file', 802, 'DDHELP')
      CALL KERINA (IRD, LITA, LITAM, KETE)
         I = LASTI
      IF (KETE .EQ. -1) THEN
         WRITE (9, FMT='('' Your input line is empty; again:'')')
         GOTO 510
         ENDIF
      IF (NFNUM.EQ.0 .AND. NLIT.EQ.0) THEN
         WRITE (9, FMT='('' Blank line; please, try again:'')')
         GOTO 510
         ENDIF
      IF (LIT(1).EQ.'Q') THEN
         WRITE (9, FMT='('' data request rejected. Repeat?'')')
         GOTO 563
         ENDIF
      IF (LIT(1).EQ.'H') THEN
         WRITE (9, FMT='
     *    ('' HELP not available at this level, use Q to escape'')')
         GOTO 510
         ENDIF
      IF (LIT(1).EQ.'R') GOTO 563
      IF ((INUM.GE.0 .AND. NFNUM.NE.INUM) .OR.
     *    (ILIT.GE.0 .AND. NLIT.NE.ILIT)) THEN
         WRITE (9, 822) ILIT, INUM, NLIT, NFNUM
  822    FORMAT (' Program requested', I3, ' literal(s) and' ,
     +      I3, ' number(s)' / ' but you supplied:' , I3 ,
     +      ' literal(s) and', I3, ' number(s). Please, try again' )
         IF (INUM.LT.0 .OR. ILIT.LT.0)
     *      WRITE (9, FMT='('' (Negative : number not fixed)'' /1X)')
         GOTO 510
         ENDIF
      KEND = NLUSE
      RETURN
  990 WRITE(9, 991)
  991 FORMAT (' Fatal error occurred in the reading DDHELP file ' )
      GOTO 999
  992 WRITE (9, 993) CHIN
  993 FORMAT (' Error found in interpretation of HELP record:' /1X/A72
     * /1X/ ' Could be an incorrect modification of the HELP file?'/1X)
  999 CALL KERNER (999, 'DDHELP')
      RETURN
      END
      SUBROUTINE CHINLI (KEND, L3, L4, LEND)
      INCLUDE 'Zsyst.inc'
      PARAMETER (M72 = 72)
      LOGICAL PLUS, DOL
      CHARACTER L(7)*6
      DATA L          /'++', '+A', '+D', 'A', 'C', 'D', 'Q' /
      KEND = 1
      L3 = 0
      L4 = 0
      LEND = 1
      IF (CHIN(1:2).EQ.'++') RETURN
      DO 200 L6=M72,1,-1
      IF (CHIN(L6:L6).NE.' ') GOTO 210
  200 CONTINUE
      RETURN
  210 PLUS = .FALSE.
      DOL = .FALSE.
      L1 = 1
      IF (CHIN(1:1).NE.'+') GOTO 230
      PLUS = .TRUE.
      IF (CHIN(2:2).EQ.' ') GOTO 990
      DO 220 L1=2,10
      IF (CHIN(L1:L1).EQ.' ') GOTO 230
  220 CONTINUE
      GOTO 990
  230 DO 240 L3=L1,M72
      IF (CHIN(L3:L3).NE.' ') GOTO 250
  240 CONTINUE
      L3 = 0
  250 L4 = L6
      IF (CHIN(L6:L6).NE.'$') GOTO 270
      DOL = .TRUE.
      IF (L6.EQ.1) GOTO 990
      L6 = L6 - 1
      IF (CHIN(L6:L6).EQ.' ') GOTO 990
      DO 260 L4=L6,1,-1
      IF (CHIN(L4:L4).EQ.' ') GOTO 270
  260 CONTINUE
      L4 = 0
  270 IF (L4.LT.L3) L3 = 0
      IF (PLUS .OR. DOL) GOTO 290
      KEND = 2
      LEND = 2
      RETURN
  290 IF (DOL)  CHIN(L6+1:L6+1) = ' '
      CALL KERINB (L, 7)
      IF (DOL)  CHIN(L6+1:L6+1) = '$'
      M = NFNUM + NLIT
      IF (M.EQ.1 .AND. DOL .AND. PLUS) GOTO 990
      IF (.NOT. PLUS) GOTO 310
      IF (NFDOL(1).LE.0) GOTO 300
      KEND = 3
      LEND = 2
      GOTO 320
  300 IF (NLUSER(1).LE.0) GOTO 990
      KEND = 2 * NLUSER(1)
      IF (M.EQ.1) GOTO 990
      IF (DOL) GOTO 990
      RETURN
  310 KEND = 2
      IF (.NOT. DOL) GOTO 990
  320 IF (.NOT. DOL) RETURN
      IF (NFDOL(M).LE.0) GOTO 330
      LEND = 3
      GOTO 340
  330 IF (NLUSER(NLIT).LE.0) GOTO 990
      LEND = NLUSER(NLIT)
  340 IF (M.EQ.2 .AND. DOL .AND. PLUS) L3 = 0
      RETURN
  990 WRITE (9, 995) CHIN
  995 FORMAT (' Syntax error in the help file. Last input line was:'/
     *  1X, A72 )
      CALL KERNER (-4, 'CHINLI')
      END
      SUBROUTINE DDSPEC (LITA, LITAM, KP2, KP3)
      CHARACTER * 6  LITA (LITAM)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDDS, IFILE(2)), (ICON, IFILE(4))
      CHARACTER *8 LL, LLL
      IF (KP3.LT.0) CALL KERROR
     *   ('Illegal third call parameter', 0, 'DDSPEC')
      LL = LITA(KP2)
      LLL = ' '
      IF (KP3 .GT. 0) LLL = LITA(KP3)
      IF (KP2 .NE. 22 .AND. KP3 .GT. 0) CALL KERROR
     *   ('Illegal third call parameter', 0, 'DDSPEC')
      IF (KP2 .EQ. 22 .AND. KP3 .EQ. 0) GOTO 113
      IF (KP2 .EQ. 22 .AND. KP3 .GT. 0) GOTO 500
      LLL = LL
      LL  = 'NUTS'
      GOTO 500
  113 CALL FILCLO (ICON, 'DELETE')
  117 CONTINUE
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDS, FMT='(A8)') LL
      WRITE (IDDS, FMT='(''STOP'')')
      CALL FILCLO (IDDS, 'KEEP')
      CALL KEPROX
      RETURN
  500 CONTINUE
      IF (LLL .EQ. 'BIJVOE') WRITE (9,
     *     FMT='('' BIJVOET : here no test for ATOMS file'')')
      IF (LLL .EQ. 'BIJVOE') LLL = 'BIJVOET'
      WRITE (ICON, 510) LLL
  510 FORMAT ('PROGRAM NUTS ', A8 / 'FINISH')
      CALL FILCLO (ICON, 'KEEP')
      GOTO 117
      END
      SUBROUTINE ATTERM (IATOMS, FATOMX, NAT)
       CHARACTER FATOMX *(*), FATOMS * 6
      INCLUDE 'Zsyst.inc'
      CHARACTER Z *1
      CHARACTER ZZ *2
      FATOMS = FATOMX
      CALL FILINQ (IATOMS, FATOMS, 'FORMATTED', 'OUTPUT', KINQ)
      SWITCH(25) = FATOMS .EQ. 'ATMOD'
      IF (SWITCH(25)) CHOUT = 'This is a scratch file: not correct !!'
      CALL ATOMWA (IATOMS)
      WRITE(9,FMT = '('' Please give atom parameters as follows'')')
      NAT = 1
 130  WRITE(9,FMT = '('' Supply : atom-name   x     y     z'' /
     +                   ''  ( eg. :    C12     0.13  0.14  0.15 )''
     +                ,5X,'' or type Q to quit'')')
 160  WRITE(9,FMT = '('' Enter atom number'',I4,'' :'')') NAT
      CALL KETERM (-1,1,KEND)
      IF (KEND.GE.0) GOTO 180
 170  WRITE(9,FMT = '('' Answer not acceptable''/)')
      GOTO 130
 180  IF (NFNUM.NE.3) GOTO 300
      IF (LIT(1)(1:1) .EQ. 'Q') GOTO 195
      IZ = 0
      ZZ = LIT(1)(1:2)
      CALL ATOMIZ (ZZ, NLET, IZ)
      I = NLET + 1
      Z = LIT(1)(I:I)
      CALL KERC2I (Z, NEN)
      IF (NEN.EQ.37 .OR. NEN.EQ.38) NEN = 0
      IF (NEN.EQ.45 .OR. NEN.EQ.46) NEN = 0
      IF (NEN.EQ.10) NEN = 0
      IF (NEN.LT.0 .OR. NEN.GT.9) GOTO 195
      IF (IZ .GT. 0) GOTO 240
 195  WRITE(9,200)
 200  FORMAT(' The atomic name is invalid. Please try again.'/
     *  ' Valid names are eg. : C12  C12A  PT  CA2+ '/ )
      GOTO 130
 240  WRITE(IATOMS,250) LIT(1),(FNUM(I),I = 1,3)
 250  FORMAT('ATOM  ',A6,1X,3F10.5 )
      NAT = NAT + 1
      GOTO 160
 300  IF ( NFNUM.NE.0 .OR. LIT(1).NE.'Q' )  GOTO 170
      IF (NAT.EQ.1) THEN
         WRITE(9,310)
 310     FORMAT(' * No atoms input so far; Q not acceptable * '/)
         GOTO 130
         ENDIF
      NAT = NAT - 1
      WRITE (IATOMS,FMT = '(''END'')')
      WRITE (9, 450) FATOMS
 450  FORMAT(' The ', A7, ' file has been created')
      REWIND IATOMS
      RETURN
      END
      SUBROUTINE DDORIE (KPROG)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (IDDL, IFILE(1)), (IATMOD, IFILE(1))
      EQUIVALENCE (ICON, IFILE(4))
      EQUIVALENCE (IATOLD, IFILE(10))
      LOGICAL SEMAUT, FULAUT
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      LOGICAL SWORBA
      EQUIVALENCE (SWORBA, SWITCH(13))
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (MFLEX, KSTAT(10))
      DIMENSION ACELTY(10), NCELTY(10), NCELLZ(10)
      CHARACTER ACELTY *2
      PARAMETER (MPARM = 100)
      DIMENSION PAR1(3,MPARM), PAR2(3,MPARM), NPAR(3,MPARM)
      DIMENSION MINF(4), CELLM(6), XC(9)
      CHARACTER *6 PRIMAP(3)
      CHARACTER *80 CHIN2, CHIN3
      PARAMETER (LITAM=5)
      DIMENSION IDHEL(LITAM), XYZT(3)
      CHARACTER *6 LITA(LITAM), LITCEL(1)
      DATA LITA   / 'PARAMS', 'VMAX', 'MIN', 'PRINT', 'PRIMAP' /
      DATA LITCEL / 'MCELL' /
      DATA MPAR, MCELL / 0, 0 /
      DATA NMINF, VMAX / 0, 0.0 /
      CHIN3 =' '
      ISYMX = -1
      CALL KERNZI (0, IDHEL, LITAM)
      IF (MFLEX .GT. 0) GOTO 8250
      CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ .NE. 0 .AND. FULAUT) THEN
         CALL FILCLO (IATMOD, 'DELETE')
         CALL KERROR
     *      (' No ATMOD file: it is needed in AUTO mode', 0, ' DDORIE')
         ENDIF
      IF (KINQ .NE. 0) GOTO 150
      CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CHIN2 = CHIN
      CHIN3 = CHIN
      IF (LIT(NLIT) .EQ. 'SYMX') ISYMX = NINT(FNUM(NFNUM))
      ICELL = 1
      WRITE (9, FMT='('' File ATMOD with '', I4,
     *    '' atoms is available'')') NAT
      IF (FULAUT) GOTO 230
  120 CALL DDHELP (201.3, 201.3, 201.5 , LITA, LITAM, KEND)
      IF (LIT(1) .EQ. 'Y') THEN
         CALL ATOMPR (8, 17, ATXYZ, ATNAME, IZAT, NAT)
         CALL ATOMPR (7, 5, ATXYZ, ATNAME, IZAT, NAT)
         GOTO 230
         ENDIF
      IF (LIT(1) .EQ. 'N') GOTO 210
      IF (LIT(1) .EQ. 'Q') THEN
         IDOKA = -17
         CALL KEPROX
         ENDIF
      IF (LIT(1) .NE. 'H') CALL KERROR ('Kanniet', 120, 'DDORIE')
      IF (NAT .GT. 50) THEN
         CALL DDHELP(201.32, 201.3, 201.5, LITA, LITAM, KEND)
      ELSE
         WRITE (9,FMT='('' List ATMOD-file (may be edited later)'')')
         REWIND IATMOD
         DO 130 I= 1, NAT
  130    WRITE (9, FMT='(1X, A6, 3F10.5)')
     *      ATNAME(I),  (ATXYZ(J,I), J=1,3)
         ENDIF
      GOTO 120
  150 CALL DDHELP (201.4, 201.3, 201.5 , LITA, LITAM, KEND)
  210 CONTINUE
      IF (KINQ .EQ. 0) CALL COPY80 (IATMOD,'ATMOD',IATOLD,'ATOLD')
      CALL FILCLO (IATMOD, 'DELETE')
      CHIN3 = ' '
      CALL DDHELP (201.41, 201.3, 201.5 , LITA, LITAM, KEND)
      IF (LIT(1) .EQ. 'Q') CALL KEPROZ
      IF (LIT(1) .EQ. 'H') GOTO 210
      IF (LIT(1) .EQ. 'S') GOTO 220
      IF (LIT(1) .NE. 'T') CALL KERROR ('kanniet', 210, 'DDORIE')
  213 CALL ATTERM (IATMOD, 'ATMOD', NAT)
      CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CHIN2 = CHIN
      ICELL = 2
      WRITE (9, FMT='('' File ATMOD with '', I4,
     *    '' atoms has been created'')') NAT
      IF (NAT .LE. 1) THEN
         WRITE (9, FMT='('' Minimum 2 atoms... try again:'')')
         GOTO 213
         ENDIF
  216 CALL DDHELP (201.34, 201.3, 201.5 , LITA, LITAM, KEND)
      IF (LIT(1) .EQ. 'Y') GOTO 230
      IF (LIT(1) .EQ. 'N') CALL KEPROZ
      IF (LIT(1) .EQ. 'Q') CALL KEPROZ
      IF (LIT(1) .NE. 'H') CALL KERROR ('kanniet', 216, 'DDORIE')
      WRITE (9, FMT='('' List ATMOD file (may be edited later)'')')
      REWIND IATMOD
      DO 217 I= 1, NAT
  217 WRITE (9, FMT='(1X, A6, 3F10.5)')
     *      ATNAME(I), (ATXYZ(J,I), J=1,3)
      GOTO 216
  220 CALL SELORB
      CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CHIN2 = CHIN
      ICELL = 3
  230 CALL KERNZA (0., XYZT, 3)
      DO 232 I = 1, NAT
      DO 232 J = 1, 3
  232 XYZT(J) = XYZT(J) + ATXYZ(J,I)
      DO 234 J = 1, 3
  234 XYZT(J) = - XYZT(J) / FLOAT(NAT)
      TT = 0.
      DO 236 I = 1, NAT
      DO 236 J = 1,3
      ATXYZ(J,I) = XYZT(J) + ATXYZ(J,I)
  236 TT = TT + ABS(ATXYZ(J,I))
      TT = TT / FLOAT(NAT-1)
      IF (TT .GT. 1.0) ICELL = - ICELL
      CHIN = CHIN2
      CALL KERINB (LIT, 1)
      IF (LIT(2) .EQ. 'CART' .OR. LIT(3) .EQ. 'CART') MCELL = -1
      IF (LIT(3) .EQ. 'CELL') LIT(3) = 'MCELL'
      IF (LIT(3) .NE. 'MCELL') GOTO 237
      IF (NCOLN(1) .LT. NCOLL(3)) THEN
         IF (NCOLN(2) .LT. NCOLL(3) .OR. NFNUM .LT. 7) CALL KERROR
     *      ('Incorrect leading record of ATMOD', 237, 'DDORIE')
         CALL KERNAB (FNUM(2), CELLM, 6)
         GOTO 244
         ENDIF
      IF (NFNUM .LT. 6) CALL KERROR
     *      ('Incorrect MCELL data on ATMOD', 237, 'DDORIE')
      GOTO 243
  237 CONTINUE
      IF (ICELL .EQ. 2) THEN
         IF (KPROG .EQ. 31) GOTO 242
         IF (SWORBA) THEN
            CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQCR)
            IF (KINQCR .NE. 0) THEN
               CALL CRYSDA
               CALL FILINQ (ICRYS,'CRYSDA','FORMATTED', 'INPUT', KINQCR)
               IF (KINQCR .NE. 0) CALL KERROR ('???', 238, 'DDORIE')
               CALL RDCRYS (ICRYS)
               ENDIF
            ENDIF
         CALL KERNAB (FRAC2C, XC, 9)
         GOTO 245
         ENDIF
      IF (ICELL .NE. -2) GOTO 240
  238 WRITE (9, FMT='('' Are the atoms of the'',
     *   '' model given as Cartesion coords (in Angstroms) ? Y/N '')')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 238
      IF (LIT(1) .EQ. 'N') GOTO 242
      IF (LIT(1) .NE. 'Y') GOTO 238
      GOTO 247
  240 IF (MCELL .LT. 0 .AND. ICELL .GT. 0) CALL KERROR
     *  ('CART in ATMOD header is incorrect', 236, 'DDORIE')
      IF (ICELL .LT. 0) GOTO 247
      IF (LIT(2) .NE. CCODE) THEN
         WRITE (9, 8240) LIT(2), CCODE
 8240 FORMAT (
     * ' The atomic parameters of the model are given as fractional'/
     * ' coordinates and no MCELL is given,  but the  CCODE  of the'/
     * ' model is incorrect, it is: ', A6 /
     * ' Is the model from ATMOD given in the same cell as ', A6, ' ?'/
     * ' Answer Y/N  ( if N we will ask to supply the cell )')
         CALL KETERM (0, 1, LEND)
         IF (LEND .LT. 0) GOTO 240
         IF (LIT(1) .EQ. 'N') GOTO 242
         IF (LIT(1) .NE. 'Y') GOTO 240
         ENDIF
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQCR)
      IF (KINQCR .NE. 0) CALL CRYSDA
      CALL RDCRYS (ICRYS)
      CALL KERNAB (FRAC2C, XC, 9)
      IF (FULAUT) THEN
         WRITE (24, FMT='(/
     * '' The atomic parameters of the model are given as fractional''/
     * '' coordinates and no MCELL is given: we assume that the cell''/
     * '' of the present compound is to be used ....'')')
         GOTO 245
         ENDIF
      IF (LIT(2) .NE. CCODE) GOTO 242
      IF (KPROG .EQ. 31) GOTO 242
      WRITE (9, FMT='('' The atomic parameters of the model may be''/
     * '' given in the unit cell of the present compound '', A6 )')
     *    CCODE
  241 CALL DDHELP (201.44, 201.3, 201.5 , LITA, LITAM, KEND)
      IF (LIT(1) .EQ. 'H') GOTO 241
      IF (LIT(1) .EQ. 'N') THEN
         IF (SWORBA) THEN
            CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQCR)
            IF (KINQCR .NE. 0) THEN
               CALL CRYSDA
               CALL RDCRYS (ICRYS)
               ENDIF
            ENDIF
         CALL KERNAB (FRAC2C, XC, 9)
         GOTO 245
         ENDIF
  242 CALL DDHELP (201.45, 201.3, 201.5, LITCEL, 1, KEND)
  243 CALL KERNAB (FNUM, CELLM, 6)
      IF (CELLM(1).GT.0.9 .AND. CELLM(2).GT.0.9 .AND. CELLM(3).GT.0.9
     * .AND. CELLM(4).GT.40..AND.CELLM(5).GT.40..AND.CELLM(6).GT.40.)
     *    GOTO 244
      WRITE (9, FMT='(A)')
     * ' Incorrect cell (in Angstrom/degrees !), please try again.'
      GOTO 242
  244 CALL MATF2C (CELLM, XC)
      WRITE (8, 1244) CELLM
 1244 FORMAT (' transform input parameters to Cartesian coordinates',
     *   ' using '/ ' MCELL = ', 3F9.4,1X,3F8.3)
  245 DO 246 I =1, NAT
  246 CALL MAT6XV (XC, ATXYZ(1,I), ATXYZ(1,I))
      IF (KINQ .EQ. 0) CALL COPY80 (IATMOD, 'ATMOD', IATOLD, 'ATOLD')
  247 IF (IABS(ICELL) .EQ. 3) GOTO 248
      IF (FULAUT) GOTO 249
      WRITE (9, FMT='('' Do you wish to edit the fragment ? Y/N'')')
      CALL KETERM (0, 1, LEND)
      IF (LEND .LT. 0) GOTO 247
      IF (LIT(1) .EQ. 'N') GOTO 249
      IF (LIT(1) .NE. 'Y') GOTO 247
  248 CALL COFRED
      IF (NAT .LT. 0) GOTO 220
      IF (NAT .LE. 1) THEN
         WRITE (9, *) ' .... no ATMOD file created ... '
         CALL FILCLO (IATMOD, 'KEEP')
         ENDIF
      IF (NAT .EQ. 0) CALL KEPROZ
      IF (NAT .EQ. 1) CALL KERROR (
     *   'Only one atom left....', 248, 'DDORIE')
  249 REWIND IATMOD
      IF (SWORBA) GOTO 2499
      CALL CELZAT (ACELTY, NCELTY, NCELLZ)
      DO 2498 I = 1, NAT
      DO 2495 J = 1, NTYPE
      IF (NCELLZ(J) .EQ. IZAT(I) .OR. IZAT(I) .EQ. 1) GOTO 2498
 2495 CONTINUE
      IF (FULAUT) THEN
         WRITE (9, 2496) ATNAME(I), I
 2496    FORMAT (' Atom ', A6, ' (number ', I3,
     *       ') is not in the CRYSDA file.'/
     *       ' .... no ATMOD file created ... ')
         CALL FILCLO (IATMOD, 'KEEP')
         CALL KERROR (' Bad ATMOD file', 2496, 'DDORIE')
         ENDIF
      WRITE (9, 2496) ATNAME(I), I
      WRITE (9, 2497)
 2497 FORMAT (' Goto (re) edit the ATMOD model parameters')
      GOTO 248
 2498 CONTINUE
 2499 CONTINUE
      NATQ = 0
      NATH = 0
      N = 1
  143 CONTINUE
      IF (ATNAME(N)(1:1) .EQ. 'Q' .OR. ATNAME(N)(1:1) .EQ. 'H') THEN
         IF (ATNAME(N)(1:1) .EQ. 'H') NATH = NATH + 1
         IF (ATNAME(N)(1:1) .EQ. 'Q') NATQ = NATQ + 1
         IF (N .EQ. NAT) GOTO 148
         DO 146 N1 = N, NAT - 1
         CALL KERNAB (ATXYZ(1,N1+1), ATXYZ(1,N1), 10)
         ATNAME(N1) = ATNAME(N1+1)
  146    IZAT(N1) = IZAT(N1+1)
  148    NAT = NAT - 1
         N = N - 1
         ENDIF
      N = N + 1
      IF (N .LE. NAT) GOTO 143
      IF (NATQ .GT. 0) WRITE (24, FMT=
     *  '('' Nr of Q-atoms rejected:'', I3)') NATQ
      IF (NATH .GT. 0) WRITE (24, FMT=
     *  '('' Nr of H atoms rejected:'', I3)') NATH
      IF (NAT .LE. 1) THEN
         WRITE(9,*) ' .... no ATMOD file created ... '
         CALL FILCLO (IATMOD, 'KEEP')
         ENDIF
      IF (NAT .LE. 0) CALL KERROR ('.... No atoms left!', 0, 'DDORIE')
      IF (NAT.LE.1) CALL KERROR ('.... Only one atom left!', 0,'DDORIE')
      CALL KERNZA (0., XYZT, 3)
      DO 4232 I = 1, NAT
      DO 4232 J = 1, 3
 4232 XYZT(J) = XYZT(J) + ATXYZ(J,I)
      DO 4234 J = 1, 3
 4234 XYZT(J) = - XYZT(J) / FLOAT(NAT)
      IF (XYZT(1) .LT. 0.002 .AND.
     *    XYZT(2) .LT. 0.002 .AND.
     *    XYZT(3) .LT. 0.002) GOTO 4237
      DO 4236 I = 1, NAT
      DO 4236 J = 1,3
      ATXYZ(J,I) = XYZT(J) + ATXYZ(J,I)
 4236 CONTINUE
 4237 ISM = 0
      IF (KINQ .EQ. 0 .AND. ISYMX .EQ. 0) THEN
         WRITE (24, FMT='(A)')
     *      ' Note: symmetry indicator on ATMOD file: SYMX=0 accepted'
         GOTO 3490
         ENDIF
      CALL ATSYM1 (ISM)
      IF (KINQ .NE. 0) GOTO 3490
      IF (ISM .EQ. 0 .AND. ISYMX .LE. 0) GOTO 3490
      IF (ISM .EQ. ISYMX) THEN
         WRITE (24, FMT='(A)')
     * ' ...not done: symmetry indicator on ATMOD file accepted !'
         GOTO 3490
         ENDIF
 3490 CONTINUE
      WRITE (24, FMT='('' Number of atoms:'', I4)') NAT
      IF (CHIN3 .NE. ' ') THEN
         CHOUT = CHIN3(1:72)
         CHOUT(1:6) = ' from '
         ENDIF
      CALL FILINQ (IATMOD, 'ATMOD' , 'FORMATTED', 'OUTPUT', KKKQQ)
      REWIND IATMOD
      CALL ATOMWO (IATMOD, ATXYZ, ATNAME, NAT, 1, ISM)
      CALL FILCLO (IATMOD, 'KEEP')
      CALL RESTRT ('ORIENT')
      IF (KPROG .GE. 30) RETURN
      WRITE (CHOUT,FMT='(''RUN '',I3,'' ATMOD NAT= '',I4,
     *    '' KPROG '', I3)') IRUN, NAT, KPROG
 8250 CONTINUE
      IF (MFLEX .GT. 0)
     *    WRITE (CHOUT,FMT='(''RUN '',I3,'' ATMOD MFLEX'',I5,
     *    '' KPROG '', I2)') IRUN, MFLEX, KPROG
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      WRITE (ICON, FMT='(''PROGRAM DDMAIN''/
     *    ''OPTION 4 PATT 0 PATOR'')')
      IF (.NOT. SEMAUT) WRITE (9, FMT='('' You may now supply'',
     *    '' control data for the Patterson function'')')
      CALL DDFFT (KPROG)
      IF (SEMAUT) GOTO 270
  250 CALL DDHELP (201.5, 201.5, 202., LITA, LITAM, KEND)
      IF (KEND.EQ.0) GOTO 270
      IDHEL(KEND) = NFDOL(1)
      GOTO (1,    2,   3,  250,    5), KEND
    1 MPAR = MPAR + 1
      M = 1
      DO 252 I = 0,6,3
      IF (FNUM(2+I).LT.0.1 .OR. FNUM(2+I).GT. 90.1) GOTO 260
      IF (FNUM(3+I).LT.0.1 .OR. FNUM(2+I).GT. 90.1) GOTO 260
      IF (FNUM(2+I) * (FNUM(3+I) -1) .GT. 361.0) GOTO 260
      PAR1(M, MPAR) = FNUM(1+I)
      PAR2(M, MPAR) = FNUM(2+I)
      NPAR(M, MPAR) = NINT(FNUM(3+I))
  252 M = M + 1
      WRITE (9, FMT='('' PARAMS set no.'',I3, '' accepted'')') MPAR
      GOTO 250
  2   VMAX = FNUM(1)
      GOTO 250
  3   IF (NFNUM .LE. 0 .OR. NFNUM .GT. 3) GOTO 260
      CALL KERF2I (FNUM, MINF, NFNUM)
      NMINF = NFNUM
      GOTO 250
  5   IF (NLIT.EQ.0 .OR. NLIT.GT.3) GOTO 260
      DO 255 I = 1, NLIT
      IF (LIT(I).NE.'PATIN'  .AND. LIT(I).NE.'DEK'  .AND.
     *    LIT(I).NE.'MAPSIG')  GOTO 260
  255 CONTINUE
      DO 257 I = 1, 3
  257 PRIMAP(I) = LIT(I)
      GOTO 250
  260 WRITE (9, FMT='('' Unacceptable answer: rejected.'')')
      IF (KEND .NE. 1) THEN
         IDHEL(KEND) = 0
         GOTO 250
         ENDIF
      MPAR = MPAR - 1
      GOTO 250
  270 WRITE (ICON, FMT='(''PROGRAM ORIENT'')')
      IF (MPAR .EQ. 0) GOTO 290
      WRITE (24, FMT= '(/'' PARAMS for ABC scan in ORIENT:''/ 10X,
     * '' Abeg  Ainc Nr.     Bbeg  Binc Nr.     Cbeg  Cinc Nr.'')')
      DO 280 M = 1, MPAR
      WRITE (ICON, 274) (PAR1(I,M), PAR2(I,M), NPAR(I,M), I=1,3)
  274 FORMAT ('PARAMS A:', F6.1, ' I', F5.1, ' N', I3,
     *              ' B:', F6.1, ' I', F5.1, ' N', I3,
     *              ' C:', F7.1, ' I', F5.1, ' N', I3 )
  280 WRITE (24, 284) M, (PAR1(I,M), PAR2(I,M), NPAR(I,M), I=1,3)
  284 FORMAT (' Set', I2, 2X, 3(2F8.1, I3))
  290 DO 300 I=2,LITAM
      IF (IDHEL(I).EQ.0) GOTO 300
      IF (I.EQ.2) WRITE (ICON, FMT='(''VMAX  '', F7.2)')   VMAX
      IF (I.EQ.3) WRITE (ICON, FMT='(''MIN  '' ,4I3  )')
     * (MINF(J), J=1, NMINF)
      IF (I.EQ.4) WRITE (ICON, FMT='(''PRINT '',4(1X,A6))')
      IF (I.EQ.5) WRITE (ICON, FMT='(''PRIMAP '',3(1X, A6))') PRIMAP
  300 CONTINUE
      IF (SEMAUT) WRITE (ICON, FMT='(''VMAX  0  1'')')
      KPROG = 2
      RETURN
      END
      SUBROUTINE SELORB
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IATMOD, IFILE(1))
      CHARACTER *6 LTEST, ORB
      LOGICAL SWIF, ASKED
      DATA SWIF, ASKED  / .FALSE., .FALSE. /
      DATA FTEST, ITEST / 0.0, 0 /
      DATA IORB /21/
      CALL WR24
      ITRY = 0
  100 ORB = 'ORUSER'
      ASKED = .FALSE.
  101 CALL FILCLO (IORB, 'KEEP')
      CALL FILINQ (IORB, ORB, 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0 .AND. ORB .EQ. 'ORUSER') THEN
         WRITE (9, FMT='('' File ORUSER not found, read ORBASE'')')
         ORB = 'ORBASE'
         GOTO 101
         ENDIF
      IF (KINQ .NE.0) CALL KERROR ('File ORBASE not found', 0, 'SELORB')
      IF ( ASKED ) GOTO 140
  120 WRITE (9, 122)
  122 FORMAT (' Enter model code or number (or H for Help)')
      CALL KETERM (-1, -1, LEND)
      IF (NFNUM + NLIT .EQ. 1) GOTO 130
  124 WRITE (9, 126)
  126 FORMAT (' See ORBASE (file ORBASE LIST, or primer) for details:'/
     *  ' Each set of ATOMS starts with a ATMOD header record, which'/
     *  ' contains a number and a code (for identification): enter '/
     *  ' either one (not both)  (or enter Q to quit = full stop). So:')
      GOTO 120
  130 IF (LIT(1) .EQ. 'H') GOTO 124
      IF (LIT(1) .EQ. 'Q') CALL KEPROZ
      IF (NFNUM .EQ. 1) THEN
         FTEST = FNUM(1) + 0.0003
         ITEST = NINT (FTEST * 1000.)
         IF (ITEST.LE.0 .OR. ITEST.GE.1000000) THEN
            WRITE (9, FMT='('' Number must be'',
     *      '' in the range 0.001 - 999.999, please, try again:'')')
            GOTO 120
            ENDIF
         SWIF = .TRUE.
      ELSE
         LTEST = LIT(1)
         SWIF = .FALSE.
         ENDIF
      ASKED = .TRUE.
  140 READ (IORB, 142, END=150) CHIN
  142 FORMAT (A80)
      IF (CHIN(1:6) .NE. 'ATMOD') GOTO 140
      CALL KERINB (LIT, 1)
      IF (SWIF) THEN
         IF (NINT (FNUM(1) * 1000.) .EQ. ITEST) GOTO 200
      ELSE
         IF (LTEST .EQ. LIT(2)) GOTO 200
         ENDIF
      GOTO 140
  150 REWIND IORB
      IF (ORB .EQ. 'ORUSER') THEN
         ORB = 'ORBASE'
         GOTO 101
         ENDIF
      ORB = 'ORUSER'
      ITRY = ITRY + 1
      WRITE (9, 153)
  153 FORMAT (' End of file: search unsuccesful')
      IF (ITRY .EQ. 3) CALL KERROR ('Too many trials', 200, 'SELORB')
      WRITE (9, 155)
  155 FORMAT (' Try again??')
      GOTO 100
  200 CHOUT = ' Search model found in  ORBASE.  Header record:'
      WRITE (9, FMT='(A72/1X,A71)') CHOUT, CHIN(1:71)
      CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'OUTPUT', KINQ)
      IF (LIT(3) .NE. 'MCELL') LIT(3) = 'CART'
      WRITE (IATMOD, 210) LIT(2), FNUM(1), LIT(3), (FNUM(I), I=2,7)
  210 FORMAT ('ATMOD ', A6, F8.3, 1X, A6, 3F8.3, 3F7.2)
  220 READ (IORB, 142, END=250) CHIN
      IF (CHIN(1:4) .EQ. 'END ') GOTO 250
      IF (CHIN(1:6) .EQ. 'FINISH') GOTO 250
      IF (CHIN(1:5) .NE. 'ATOM ' .AND.
     *    CHIN(1:6) .NE. 'REMARK') CALL KERROR
     *    ('Error on ORBASE file', 220, 'SELORB')
      IF (CHIN(1:6) .EQ. 'REMARK') WRITE (9, FMT='(1X, A72)') CHIN
      WRITE (IATMOD, 142) CHIN
      GOTO 220
  250 WRITE (IATMOD, FMT='(''END'')')
      REWIND IATMOD
      CALL FILCLO (IORB, 'KEEP')
      CALL WR24
      RETURN
      END
      SUBROUTINE DDTRAC (KPROG)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICON,  IFILE(4))
      EQUIVALENCE (KPROG1, KSTAT(18))
      EQUIVALENCE (IFMAP, IFILE(17))
      LOGICAL SEMAUT
      EQUIVALENCE (SWITCH(10), SEMAUT)
      PARAMETER (LITAM=9)
      DIMENSION IDHEL(LITAM)
      CHARACTER *6 LITA(LITAM)
      DATA LITA / 'EMIN',  'SCSG',  'BHSG',   'DAMP',    'SMM',
     *            'PRINT', 'PRIMAP','STLMAX', 'PSQMAX' /
      DATA SMM, SCSG, EMIN, PSQMAX, SMAX, DAMP, BHSG
     *   / 0.0, 0.0,  0.0,  0.0,    0.0,  0.0,  0.0 /
      IF (IPOLA .EQ. 7) THEN
         IF (KPROG1 .EQ. 2) CALL KERROR
     *      ('TRACOR not applicable to space group P1', 0, 'DDTRAC')
         GOTO 183
         ENDIF
      IF (KPROG1 .NE. 2) GOTO 101
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.0) CALL FILCLO (IFMAP, 'DELETE')
      WRITE (ICON, FMT='(''PROGRAM DDMAIN''/
     *   ''OPTION 4 PATT 0 PATOR'' / ''PROGRAM FOUR'')')
  101 WRITE (ICON, FMT='(''PROGRAM TRACOR'')')
      IF (SEMAUT) GOTO 102
      WRITE (9, FMT='('' You may now supply'',
     * '' (control) data for the structure factor calculation'')')
 102  CALL DDFCAL (KPROG)
      CALL KERNZI (0, IDHEL, LITAM)
      IF (SEMAUT) GOTO 180
  150 CALL DDHELP (202., 202., 203., LITA, LITAM, KEND)
      IF (KEND.EQ.0) GOTO 170
      IDHEL(KEND) = NFDOL(1)
      GOTO (1,  2,   3,   4,   5,  150,  150,    8,     9),   KEND
  1   EMIN = FNUM(1)
      IF (EMIN .GT. 3.0) GOTO 160
      GOTO 150
  2   SCSG = FNUM(1)
      IF (SCSG.LT.0.8 .OR. SCSG.GT.1.2) GOTO 160
      GOTO 150
  3   BHSG=FNUM(1)
      GOTO 150
  4   DAMP = FNUM(1)
      GOTO 150
  5   SMM =FNUM(1)
      IF(SMM.LT.0.0001) SMM=0.000001
      GOTO 150
  8   GOTO 150
  9   IF (FNUM(1) .LT. 0.01 .OR. FNUM(1).GT.1.) GOTO 160
      PSQMAX = FNUM(1)
      GOTO 150
  160 WRITE (9, FMT='('' Unacceptable answer: rejected.'')')
      IDHEL(KEND) = 0
      GOTO 150
  168 FORMAT (A6, F14.6)
  170 IF (IDHEL(1).NE.0) WRITE (ICON, 168) LITA(1), EMIN
      IF (IDHEL(2).NE.0) WRITE (ICON, 168) LITA(2), SCSG
      IF (IDHEL(3).NE.0) WRITE (ICON, 168) LITA(3), BHSG
      IF (IDHEL(4).NE.0) WRITE (ICON, 168) LITA(4), DAMP
      IF (IDHEL(5).NE.0) WRITE (ICON, 168) LITA(5), SMM
      IF (IDHEL(6).NE.0) WRITE (ICON, 168) LITA(6)
      IF (IDHEL(7).NE.0) WRITE (ICON, 168) LITA(7)
      IF (IDHEL(8).NE.0) WRITE (ICON, 168) LITA(8), SMAX
      IF (IDHEL(9).NE.0) WRITE (ICON, 168) LITA(8), PSQMAX
  180 CONTINUE
      WRITE(ICON, FMT='(''PROGRAM TRAVEC NOREF'')')
  183 KPROG = 3
      RETURN
      END
      SUBROUTINE DDDIRD (KPROG)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ICON,  IFILE(4))
      EQUIVALENCE (KPROG1, KSTAT(18))
      LOGICAL SEMAUT, FULAUT
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      DIMENSION ALOCC(3), ESTART(6), ACC(2)
      PARAMETER (LITAM = 6)
      DIMENSION IDHEL(LITAM)
      CHARACTER * 6 LITA(LITAM)
      DATA LITA / 'STLMAX', 'MAXHKL', 'LOCCEN', 'NCEST', 'ACCEPT',
     *            'PRINT' /
      WRITE (ICON, FMT='(''PROGRAM DDMAIN'')')
      WRITE (ICON, FMT='( ''OPTION 1 PHASEX'')')
      IF(KPROG1 .EQ. 10) WRITE (ICON, FMT='(''DIRP1'')')
      IF (SEMAUT) GOTO 142
      IF (KPROG1 .GE. 3) WRITE (9, FMT='('' You may now supply'',
     * '' (control) data for the structure factor calculation'')')
 142  CALL DDFCAL (KPROG)
      CALL KERNZI (0, IDHEL, LITAM)
      WRITE (ICON, FMT='(''PROGRAM PHASEX'')')
      IF(KPROG1 .EQ. 10) WRITE (ICON, FMT='(''DIRP1'')')
      IF (SEMAUT) GOTO 182
  150 CALL DDHELP (203., 203., 204., LITA, LITAM, KEND)
      IF (KEND.EQ.0) GOTO 170
      IDHEL(KEND) = NFDOL(1)
      GOTO (1,     2,     3,     4,     5,  150 ),  KEND
  1    GOTO 150
  2      GOTO 150
  3   IF (NFNUM .NE. 3) GOTO 160
      DO 153 I=1,3
  153 ALOCC(I) = FNUM(I)
      GOTO 150
  4   IF (NFNUM .NE. 6) GOTO 160
      CALL KERNAB (FNUM(1), ESTART, 6)
      GOTO 150
  5   IF (NFNUM .NE. 2) GOTO 160
      CALL KERNAB (FNUM(1), ACC, 2)
      GOTO 150
  160 WRITE (9, FMT='('' Unacceptable answer: rejected.'')')
      IDHEL(KEND) = 0
      GOTO 150
  167 FORMAT (A6, 6F7.4)
  168 FORMAT (A6, 3F10.6)
  170 CONTINUE
      IF (IDHEL(3).NE.0) WRITE (ICON, 168) LITA(3), ALOCC
      IF (IDHEL(4).NE.0) WRITE (ICON, 167) LITA(4), ESTART
      IF (IDHEL(5).NE.0) WRITE (ICON, 168) LITA(5), ACC
      IF (IDHEL(6).NE.0) WRITE (ICON, 168) LITA(6)
  182 WRITE (ICON, FMT='(''PROGRAM DDMAIN'' /
     *                   ''OPTION 2 FOUR(PHASEX)'')')
      IF (KPROG1 .EQ. 10) WRITE (ICON, FMT='(''DIRP1'')')
      KPROG = 6
      RETURN
      END
      SUBROUTINE DDMAIX (KPROG)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ICON, IFILE(4))
      EQUIVALENCE (KPROG1, KSTAT(18))
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      PARAMETER    (LITAM = 1,   LITFM = 6,    LITPM = 4)
      DIMENSION     LITA(LITAM), LITFN(LITFM), LITPN(LITPM)
      CHARACTER * 6 LITA,        LITF(LITFM),  LITP(LITPM)
      DATA LITA  / 'OPTION' /
      DATA LITF  / 'WFOUR', 'WDELF', 'AFOUR', 'DELF', '2FO-FC', 'FCALC'/
      DATA LITFN /    0,      1,        4,      5,       6,       9    /
      DATA LITP  / 'PATOR', 'PATTY', 'EF', 'FOBS2' /
      DATA LITPN /    0,      1,      2,      3   /
      DATA IOPT1, IOPT2, KEND / 0, 0, 0 /
      IF (KPROG1 .EQ. 8) IOPT1 = 4
      IF (KPROG1 .EQ. 9) IOPT1 = 3
      IF (KPROG1 .EQ. 27) IOPT1 = 7
      IF (KPROG1 .NE. 4) GOTO 210
  200 CALL DDHELP (204., 204., 205., LITA, LITAM, KEND)
      IOPT1 = NINT (FNUM(1))
      IF (IOPT1.EQ.5 .OR. IOPT1.EQ.6) GOTO 200
      IF (IOPT1.LT.0 .OR. IOPT1.GT.7) GOTO 200
  210 IF (IOPT1 .EQ. 3) THEN
         KEND = 1
         IF (.NOT. FULAUT)
     *      CALL DDHELP (204.02, 204., 205., LITF, LITFM, KEND)
         IOPT2 = LITFN(KEND)
         WRITE (9,FMT='(48X,''option specified: '',A6)') LITF(KEND)
         ENDIF
      IF (IOPT1 .EQ. 4) THEN
         CALL DDHELP (204.05, 204., 205., LITP, LITPM, KEND)
         IOPT2 = LITPN(KEND)
         WRITE (9,FMT='(48X,''option specified: '',A6)') LITP(KEND)
         ENDIF
      WRITE (ICON, FMT='(''PROGRAM DDMAIN'')')
      IF (IOPT1 .EQ. 0) WRITE (ICON, FMT='(''OPTION 0 FCALC'')')
      IF (IOPT1 .EQ. 1) WRITE (ICON, FMT='(''OPTION 1 PHASEX'')')
      IF (IOPT1 .EQ. 2) WRITE (ICON, FMT='(''OPTION 2 FOUR(PHASEX)'')')
      IF (IOPT1 .EQ. 3) WRITE (ICON, FMT='(''OPTION 3 FOUR'',I3,1X,A6)')
     *                                       IOPT2, LITF(KEND)
      IF (IOPT1 .EQ. 4) WRITE (ICON, FMT='(''OPTION 4 PATT'',I3,1X,A6)')
     *                                       IOPT2, LITP(KEND)
      IF (IOPT1 .EQ. 7) WRITE (ICON, FMT='(''OPTION 7    '')')
      IF (IOPT1.EQ.0 .OR.IOPT1.EQ.1 .OR.IOPT1.EQ.3) CALL DDFCAL (KPROG)
      KPROG = 0
      IF (KPROG1.EQ.8 .OR. KPROG1.EQ.9) KPROG = 6
      RETURN
      END
      SUBROUTINE DDFCAL (KPROG)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      EQUIVALENCE (IDDL,   IFILE(1))
      EQUIVALENCE (IATOMS, IFILE(1)),  (ICON, IFILE(4))
      EQUIVALENCE (IATOLD, IFILE(10))
      EQUIVALENCE (IRUN,   KSTAT(13))
      EQUIVALENCE (KPROG1, KSTAT(18))
      LOGICAL EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      LOGICAL SEMAUT, FULAUT
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      PARAMETER (LITAM = 7)
      DIMENSION IDHEL(LITAM)
      CHARACTER * 6 LITA(LITAM)
      DATA LITA / 'STLMAX','MAXHKL','SCALE','BBB','WILSON','PRINT',
     *            'EXPAND' /
      DATA NPROG, LITM / 0, 6 /
      DATA NATQ / 0 /
      NPROG = NPROG + 1
      IF (NPROG .GT. 1) GOTO 250
      IF (KPROG1 .EQ. 1) GOTO 190
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ .EQ. 0) GOTO 101
      IF (.NOT. FULAUT) GOTO 120
      CALL KERROR (' No ATOMS file ', 0, 'DDFCAL')
 101  CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      IF (LIT(4) .EQ. 'PAT.R2') THEN
         WRITE (24, FMT='('' Input ATOMS file head: ''/ A72 /)')
     *      CHIN(1:72)
      ELSE
         CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
         ENDIF
      NATQ = NAT
      DO 103 I = 1, NATQ
      IF (ATNAME(I)(1:1) .EQ. 'Q') NAT = NAT - 1
  103 CONTINUE
      IF (FULAUT) GOTO 130
         WRITE (9, FMT='('' File ATOMS with '', I4,
     *    '' atoms is available'')') NAT
  102    CALL DDHELP (205.3, 205., 205.5 , LITA, LITAM, KEND)
         IF (LIT(1) .EQ. 'Y') GOTO 130
         IF (LIT(1) .EQ. 'N') GOTO 120
         IF (LIT(1) .EQ. 'Q') CALL KEPROZ
         IF (LIT(1) .EQ. 'H' .AND. NAT .GT. 50) THEN
            CALL DDHELP(205.32, 205., 205.5, LITA, LITAM, KEND)
            GOTO 102
            ENDIF
         IF (LIT(1) .EQ. 'H' .AND. NAT .LT. 50) THEN
            WRITE (9, FMT='('' List ATOMS-file'')')
            DO 104 I= 1, NAT
  104       WRITE (9, FMT='(1X, A6, 3F10.5)')
     *         ATNAME(I),  (ATXYZ(J,I), J=1,3)
            GOTO 102
            ENDIF
      CALL DDHELP (205.4, 205. , 205.5 , LITA, LITAM, KEND)
  120 CALL DDHELP (205.41, 205. , 205.5 , LITA, LITAM, KEND)
      IF (LIT(1) .EQ. 'N') CALL KEPROZ
      IF (LIT(1) .EQ. 'Q') CALL KEPROZ
      IF (LIT(1) .EQ. 'Y') THEN
         CALL ATTERM (IATOMS, 'ATOMS', NAT)
         CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
         WRITE (9, FMT='('' File ATOMS with '', I4,
     *      '' atoms has been created'')') NAT
         NATQ = NAT
  106    CALL DDHELP (205.34, 205., 205.5 , LITA, LITAM, KEND)
         IF (LIT(1) .EQ. 'Y') GOTO 130
         IF (LIT(1) .EQ. 'N') CALL KEPROZ
         IF (LIT(1) .EQ. 'Q') CALL KEPROZ
         IF (LIT(1) .EQ. 'H') THEN
            WRITE (9, FMT='('' List ATOMS-file'')')
            DO 107 I= 1, NAT
  107       WRITE (9, FMT='(1X, A6, 3F10.5)')
     *         ATNAME(I),  (ATXYZ(J,I), J=1,3)
            GOTO 106
            ENDIF
         ENDIF
  130 CALL FILCLO (IATOMS, 'KEEP')
      IF (NATQ .NE. NAT) THEN
         WRITE (9, FMT='
     *      (I7, '' Q-atoms (peaks) ignored'')') NATQ-NAT
         IF (NAT .EQ. 0) CALL KERROR (' Only Q-atoms ', 0, 'DDFCAL')
         ENDIF
      WRITE (CHOUT,FMT='(''RUN '',I3,'' ATOMS NAT= '',I4,
     *    '' KPROG '', I3)') IRUN, NAT, KPROG1
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
  190 CALL KERNZI (0, IDHEL, LITAM)
      IF (KPROG1.EQ.4 .OR. KPROG1.EQ.5) THEN
         CALL DDHELP (205., 205., 206., LITA, LITAM, KEND)
         IF (KEND .EQ. 7) EXPAND = .TRUE.
         ENDIF
      IF (SEMAUT) GOTO 250
  200 CALL DDHELP (205.1, 205., 206., LITA, LITM, KEND)
      IF (KEND .EQ. 0) GOTO 250
      IDHEL(KEND) = NFDOL(1)
      GOTO (1, 2, 3, 4, 5, 200) KEND
  1    GOTO 200
  2    GOTO 200
  3    GOTO 200
  4    GOTO 200
  5    GOTO 200
  250 IF (KPROG1.LE.2  .OR. KPROG1.EQ.10) EXPAND = .TRUE.
      IF (NPROG .GT. 1) EXPAND = .FALSE.
      IF (IPOLA .EQ. 7) EXPAND = .FALSE.
      IF (KPROG1 .EQ. 5) WRITE (ICON, FMT='(''PROGRAM DDMAIN''/
     *                                      ''OPTION 0 FCALC'')')
      IF (KPROG1.GT.2 .AND. EXPAND) WRITE (ICON, FMT='(''EXPAND'')')
      DO 300 I=1,LITM
      IF (IDHEL(I) .EQ. 0) GOTO 300
  300 CONTINUE
      IF (KPROG .NE. 5) GOTO 360
  350 WRITE (9, 351)
  351 FORMAT (' Is FCALC to be followed by NUTS PRIFC ? (Y,H,N,Q)')
      CALL KETERM (-1, 1, KEND)
      IF (KEND .LT. 0) GOTO 350
      IF (LIT(1) .EQ. 'N' .OR. LIT(1) .EQ. 'Q') GOTO 360
      IF (LIT(1) .EQ. 'H') THEN
         WRITE (ICON, FMT = '(''PROGRAM NUTS'')')
         WRITE (9, FMT = '('' After DDMAIN (Fcalc) control will be'',
     *      '' passed on to program NUTS'')')
         GOTO 360
         ENDIF
      IF (LIT(1) .EQ. 'Y') THEN
         WRITE (ICON, FMT = '(''PROGRAM NUTS PRIFC '')')
         GOTO 360
         ENDIF
      WRITE (9, FMT = '('' Answer not clear: please try again:'')')
      GOTO 350
  360 CONTINUE
      KPROG = 0
      RETURN
      END
      SUBROUTINE DDFFT  (KPROG)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ICON,   IFILE(4))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (KPROG1, KSTAT(18))
      LOGICAL PATTER
      EQUIVALENCE (PATTER, SWITCH(26))
      LOGICAL SEMAUT
      EQUIVALENCE (SWITCH(10), SEMAUT)
      LOGICAL NORECY
      EQUIVALENCE (NORECY, SWITCH(8))
      DIMENSION XLIM(3), IGM3(3)
      PARAMETER (LITAM = 9)
      DIMENSION IDHEL(LITAM)
      CHARACTER * 6 LITA(LITAM)
      DATA LITA / 'GRID', 'MAXXYZ', 'MAXHKL', 'GRIDMO', 'PRIMAP',
     * 'PEAKS', 'DMAX', 'PRINT', 'NORECY'/
      DATA NPROG / 0 /
      DATA DMAX, PEAKS, GRID / 0.0, 0.0, 0.0 /
      IF (KPROG1 .NE. 6) GOTO 130
      CALL FILINQ (IBINFF, 'BINFFT', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. 0) GOTO 130
      WRITE (9, FMT='('' File BINFFT (Fourier coeff.) not present''/
     * '' Use option FOUR or prepare the file with DDMAIN.'')')
      CALL KERNER (0, 'DDFFT')
  130 NPROG = NPROG + 1
      WRITE (ICON, FMT = '(''PROGRAM FOUR'')')
      IF (KPROG1.EQ.1 .OR. KPROG1.EQ.7 .OR. KPROG1.EQ.8) PATTER =.TRUE.
      IF (NPROG .GT. 1) PATTER = .FALSE.
      CALL KERNZI (0, IDHEL, LITAM)
      IF (SEMAUT) GOTO 170
  150 CALL DDHELP (206., 206., 207., LITA, LITAM, KEND)
      IF (KEND.EQ.0) GOTO 170
      IDHEL(KEND) = NFDOL(1)
      GOTO (1,     2,     3,     4,    150,    6,   7,  150, 150), KEND
  1   GRID = FNUM(1)
      GOTO 150
  2   IF (NFNUM .NE. 3) GOTO 160
      DO 152 I=1,3
  152 XLIM(I) = AMIN1 (FNUM(I), 1.0)
      IDHEL(5) = 1
      GOTO 150
  3   GOTO 150
  4   IF (NFNUM .NE. 3) GOTO 160
      DO 154 I=1,3
      IF (FNUM(I) .GE. 1.0) IGM3(I) = NINT (FNUM(I))
      IF (IGM3(I) .EQ. 5  .OR.  IGM3(I) .GE. 7)
     * CALL KERROR ('BAD GRIDMO CARD ', 6, 'DDFFT')
  154 CONTINUE
      GOTO 150
  6   IF (FNUM(1).GT.999. .OR. FNUM(1).LT.0.9) GOTO 160
      PEAKS = FNUM(1)
      GOTO 150
  7   IF (PATTER) THEN
         WRITE (9, FMT='('' DMAX not useful for a Patterson map'')')
         GOTO 160
         ENDIF
      DMAX = FNUM(1)
      GOTO 150
  160 WRITE (9, FMT='('' Unacceptable answer: rejected.'')')
      IDHEL(KEND) = 0
      GOTO 150
  166 FORMAT (A6, 4X, 3F10.4)
  167 FORMAT (A6, 4X, 4I5)
  170 IF (IDHEL(1).NE.0) WRITE (ICON, 166) LITA(1), GRID
      IF (IDHEL(5).NE.0) WRITE (ICON, 166) LITA(5)
      IF (IDHEL(2).NE.0) WRITE (ICON, 166) LITA(2), (XLIM(I), I=1,3)
      IF (IDHEL(4).NE.0) WRITE (ICON, 167) LITA(4), (IGM3(I), I=1,3)
      IF (IDHEL(8).NE.0) WRITE (ICON, 166) LITA(8)
      IF (IDHEL(6).NE.0) WRITE (ICON, 166) LITA(6), PEAKS
      IF (IDHEL(7).NE.0) WRITE (ICON, 166) LITA(7), DMAX
      IF (IDHEL(9).NE.0) NORECY = .TRUE.
      IF (NORECY .AND. .NOT. PATTER) WRITE (ICON, FMT = '(''NORECY'')')
      KPROG = 0
      RETURN
      END
      SUBROUTINE DDPATY (KPROG)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICON, IFILE(4))
      LOGICAL SEMAUT
      EQUIVALENCE (SWITCH(10), SEMAUT)
      LOGICAL NORECY
      EQUIVALENCE (NORECY, SWITCH(8))
      PARAMETER (LITAM = 4)
      DIMENSION IDHEL(LITAM)
      CHARACTER * 6 LITA(LITAM)
      DATA LITA / 'AAAA', 'BHBLSC', 'BBBB', 'PRINT' /
      DATA AAAA / 0.0 /
      IF (ISYST .EQ. 5) THEN
         WRITE (9, FMT = '('' Sorry: at present PATTY does not'',
     *   '' operate in rhombohedral setting!''/
     *   '' TRACOR on one Heavy Atom is a possible alternative.''/
     *   '' Better: transforms data to hexagonal setting.''/
     *   '' Sorry for the inconveniance '')')
         CALL KERROR ('Rhomb. setting for Patty', 0, 'DDPATY')
         ENDIF
      CALL KERNZI (0, IDHEL, LITAM)
      IF (SEMAUT) GOTO 170
  150 CALL DDHELP (207., 207., 208., LITA, LITAM, KEND)
      IF (KEND.EQ.0) GOTO 170
      IDHEL(KEND) = NFDOL(1)
      GOTO (1,     2,     3,   150 ),  KEND
  1   IF (FNUM(1) .GT. 99.) GOTO 160
      AAAA = FNUM(1)
      GOTO 150
  2   GOTO 150
  3   GOTO 150
  160 WRITE (9, FMT='('' Unacceptable answer: rejected.'')')
      IDHEL(KEND) = 0
      GOTO 150
  168 FORMAT (A6, F14.6)
  170 IF (IDHEL(1).NE.0) WRITE (ICON, 168) LITA(1), AAAA
      IF (IDHEL(2).NE.0) WRITE (ICON, 168) LITA(2)
      IF (IDHEL(3).NE.0) WRITE (ICON, 168) LITA(3)
      IF (IDHEL(4).NE.0) WRITE (ICON, 168) LITA(4)
      WRITE (ICON, 131)
  131 FORMAT ('PROGRAM DDMAIN' / 'OPTION 4 PATT 1 PATTY'/
     *   'PROGRAM FOUR'   / 'PROGRAM PATTY'  /
     *   'PROGRAM DDMAIN' / 'OPTION 7 R2CALC from PATTY' /
     *   'PROGRAM DDMAIN' / 'OPTION 1 PHASEX' /
     *   'PROGRAM PHASEX' / 'PROGRAM DDMAIN' / 'OPTION 2 FOUR(PHASEX)'/
     *   'PROGRAM FOUR' )
      IF (NORECY) WRITE (ICON, FMT = '(''NORECY'')')
      KPROG = 0
      RETURN
      END
      SUBROUTINE DDPATR (KPROG)
      KPROG = 4
      RETURN
      END
      SUBROUTINE DDFOUR (KPROG)
      KPROG = 4
      RETURN
      END
      SUBROUTINE DDDP1  (KPROG)
      WRITE (9, FMT='('' Expand reflection data to space group P1'',
     *                   '' (or centered equivalent)'')')
      KPROG = 3
      RETURN
      END
      SUBROUTINE DDR2 (KPROG)
      KPROG = 4
      RETURN
      END
      SUBROUTINE ORBAX (KP2)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (ICRYS, IFILE(3))
      LOGICAL SWORBA
      EQUIVALENCE (SWORBA, SWITCH(13))
      SWORBA = .TRUE.
      WRITE (9, 101)
  101 FORMAT (' Online preparation of an ATMOD file, '/
     * ' manual input, update ATMOD, or input from the ORBASE file')
      CALL DDORIE (KP2)
      WRITE (9, 102)
  102 FORMAT (' End of online editing of an ATMOD file ')
      IDOKA = -17
      CALL KEPROX
      END
      SUBROUTINE KEPROZ
      CALL FILCLO (4, 'KEEP')
      CALL KERASE ('CONDA')
      CALL KERASE ('MERCUR')
      CALL KERASE ('DDSYST')
      CALL KERASE ('DDHELP')
      CALL KERASE ('ORBASE')
      CALL KERASE ('LIS3')
      WRITE (9, FMT='(A)') ' bye-bye from DIRDIF'
      CALL WR24
      CALL FILCLO (8, 'DELETE')
      CALL FILCLO (7, 'DELETE')
      STOP
      END
      SUBROUTINE COFRED
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78  AL15, AL16, AL17
      IF (NAT .GT. MAXX) THEN
    1    FORMAT (/
     *' COFRED [ the COmmon FRagment EDitor ] has been designed for'/
     *' small fragments ( maximum:', I4, ' atoms ). Yours is too big.'/
     *' Please, use local editing facilities to modify your molecule.'/)
         WRITE (9, 1) MAXX
         CALL DDEXIT
         ENDIF
      AL15 =   ' Commands: Del  Repl  Save  Undo  X Y Z  Add  Fuse Geom
     *  Exit=Quit Help'
      AL16 =  ' Enter first letter of one command and appropriate number
     * of parameters'
      AL17 =  '             Use ENTER or blank line to repaint fragment'
      LEEG = 0
      N = MAXX*22
      CALL KERNZI (0, IBON2, N)
      WRITE (9,*) ' Fragment Editor commands applied:'
      IF (NAT .LE. 20) CALL BESTVW
      SCALED = .FALSE.
      RINGED = .FALSE.
      METAED = .FALSE.
      CALL CFSAVE
      AL(1) =  ' Edit fragment'
   20 AL(15) = AL15
      AL(16) = AL16
      AL(17) = AL17
      AL(18) = ' '
      AL(19) = ' '
      CALL BSCHEM
      CALL SCFRAG
  100 CALL XFLUSH
  101 CALL WININP(CHIN)
      IF (CHIN .EQ. ' ') GOTO 130
      CALL KERINB (LIT, 1)
      IF ( NLIT .LE. 0 ) GOTO 130
      EDOPT = LIT(1)(1:3)
      AT2 = LIT(2)
      AT3 = LIT(3)
      AT4 = LIT(4)
      AL(18) = ' '
      AL(19) = ' '
      IF (EDOPT .EQ. 'H') THEN
         CALL CFHELP
         GOTO 117
         ENDIF
      IF (EDOPT .EQ. 'D' .OR. EDOPT .EQ. 'DEL') THEN
         CALL CFDELE
         GOTO 101
         ENDIF
      IF (EDOPT .EQ. 'R') THEN
         CALL CFREPL
         GOTO 101
         ENDIF
      IF (EDOPT .EQ. 'S') THEN
         CALL CFSAVE
         GOTO 101
         ENDIF
      IF (EDOPT .EQ. 'U') THEN
         CALL CFUNDO
         GOTO 100
         ENDIF
      IF (EDOPT .EQ. 'X' .OR. EDOPT .EQ. 'Y' .OR.
     *    EDOPT .EQ. 'Z') THEN
         CALL CFROTA (KEYR)
         IF (KEYR .EQ. 0) GOTO 101
         GOTO 100
         ENDIF
      IF (EDOPT .EQ. 'A' .OR. EDOPT .EQ. 'F') THEN
         IF (NAT .GT. MAXX-6) THEN
            WRITE (9, FMT='(A)')
     *         'Limitation of nr of atoms reached: no more additions !'
            GOTO 117
            ENDIF
         IF (EDOPT .EQ. 'A') CALL CFADD
         IF (EDOPT .EQ. 'F') CALL CFFUSE
         GOTO 101
         ENDIF
      IF (EDOPT .EQ. 'G') THEN
         CALL CFGEOM
         GOTO 101
         ENDIF
      IF (EDOPT .EQ. 'E  ' .OR. EDOPT .EQ. 'Q') GOTO 9000
      WRITE (9, FMT='('' Illegal EDIT option entered: '',A6)') LIT(1)
  117 WRITE (9, FMT='(A78)') AL15
      WRITE (9, FMT='(A78)') AL16
      GOTO 101
  130 CONTINUE
      LEEG = LEEG + 1
      IF (LEEG .EQ. 3) AL(1) = ' '
      AL(15) = AL15
      AL(16) = AL16
      AL(17) = ' '
      IF (LEEG .LE. 3) AL(17) = AL17
      AL(18) = ' '
      AL(19) = ' '
      GOTO 100
 9000 KEY = 0
      CALL CFEXIT ( KEY )
      IF ( KEY .EQ. 1 ) GOTO 20
      IF ( KEY .EQ. 2 ) GOTO 117
      RETURN
      END
      SUBROUTINE BESTVW
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      DIMENSION    DELTA(3), XYZM(3)
      DATA  IVM, JVM / 0 , 0 /
      DATA PI / 3.1415926535 /
      VECMAX = 0.0
      DO 100 I = 1, NAT - 1
      DO 100 J = I+1, NAT
         V = (ATXYZ(1,I)-ATXYZ(1,J))**2 + (ATXYZ(2,I)-ATXYZ(2,J))**2 +
     *       (ATXYZ(3,I)-ATXYZ(3,J))**2
         IF ( V .GT. VECMAX ) THEN
            VECMAX = V
            IVM = I
            JVM = J
         ENDIF
  100 CONTINUE
      DO 110 I = 1, 3
  110 DELTA(I) = ATXYZ(I,IVM)
      DO 120 J = 1, NAT
      DO 120 I = 1, 3
  120 ATXYZ(I,J) = ATXYZ(I,J) - DELTA(I)
      CALL DETANG ( ATXYZ(2,JVM), ATXYZ(1,JVM), ANG1 )
      CALL ROTATE ( 'Z', ANG1, ATXYZ, NAT )
      CALL DETANG ( ATXYZ(1,JVM), ATXYZ(3,JVM), ANG2 )
      CALL ROTATE ( 'Y', ANG2-0.5*PI, ATXYZ, NAT )
      CALL KERNZA ( 0.0, XYZM, 3 )
      DO 200 J = 1, NAT
      SCALEQ = ( (ATXYZ(2,J))**2 + (ATXYZ(3,J))**2 )**0.20
      IF ( SCALEQ .LT. 0.001 ) GOTO 200
      IF ( ATXYZ(2,J) .GE. 0.0 ) THEN
         XYZM(2) = XYZM(2) + ATXYZ(2,J)/SCALEQ
         XYZM(3) = XYZM(3) + ATXYZ(3,J)/SCALEQ
      ELSE
         XYZM(2) = XYZM(2) - ATXYZ(2,J)/SCALEQ
         XYZM(3) = XYZM(3) - ATXYZ(3,J)/SCALEQ
      ENDIF
  200 CONTINUE
      DO 220 J = 1, NAT
      DO 220 I = 1, 3
  220 ATXYZ(I,J) = ATXYZ(I,J) - XYZM(I)
      CALL DETANG ( XYZM(3), XYZM(2), ANG3 )
      CALL ROTATE ( 'X', ANG3, ATXYZ, NAT )
      RETURN
      END
      SUBROUTINE CFSAVE
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      LOGICAL FIRST
      SAVE FIRST
      DATA FIRST /.TRUE./
      IF (FIRST) GOTO 9
      IF (AT2 .NE. ' ' .OR. NFNUM .NE. 0) THEN
         WRITE (9, FMT='(A)')
     *       ' Not saved: option S does not take any parameters'
         RETURN
         ENDIF
      WRITE (24, FMT='('' $$$-edit: '', A80)') CHIN
   9  DO 10 I = 1, NAT
      ATNSAV( I ) = ATNAME( I )
      IZTSAV( I ) = IZAT( I )
      DO 10 J = 1, 3
      XYZSAV( J,I ) = ATXYZ( J,I )
   10 CONTINUE
      NATSAV = NAT
      IF (FIRST) THEN
         WRITE (9, FMT='(A)')
     *   ' Input fragment saved (it can be retrieved by command U)'
         FIRST = .FALSE.
         RETURN
         ENDIF
      WRITE (9, 20) NAT
   20 FORMAT (' Current fragment saved:', I3, ' atoms.',
     *   ' Previously saved model overwritten')
      RETURN
      END
      SUBROUTINE BSCHEM
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION  IW1(M200,2),  IW2(M200)
      CHARACTER*15 D(7),E(7)
      CHARACTER*3 H(5)
      DATA D(1) /'Single         '/
      DATA D(2) /'Double         '/
      DATA D(3) /'Triple         '/
      DATA D(4) /'Metal pi       '/
      DATA D(5) /'Aromatic       '/
      DATA D(6) /'Undetermined   '/
      DATA D(7) /'Delocalized N:O'/
      DATA E(1) /'Aliph. cyclic  '/
      DATA E(2) /'End-of-chain   '/
      DATA E(3) /'Side-chain     '/
      DATA E(4) /'Connecting     '/
      DATA E(5) /'Aromatic       '/
      DATA E(6) /'Isolated       '/
      DATA E(7) /'Undetermined   '/
      DATA H(1) /'---'/
      DATA H(2) /'sp '/
      DATA H(3) /'sp2'/
      DATA H(4) /'sp3'/
      DATA H(5) /'Und'/
      DATA IICALL / 0 /
      IICALL = IICALL + 1
      RINGED = .FALSE.
      CALL KERNZI (0, NBATOM, NAT)
      CALL KERNZI (7, IATYP,  NAT)
      CALL KERNZI (1, IHTYP,  NAT)
      NBONDS = 0
      DO 110 I1 = 1, NAT-1
      DO 110 I2 = I1+1, NAT
      CALL ZZDIST ( IZAT(I1), IZAT(I2), SB )
      SB = ( SB * 1.15 )**2
      DIST =        ( ATXYZ(1,I1) - ATXYZ(1,I2) )**2
      IF ( DIST .GT. SB ) GOTO 110
      DIST = DIST + ( ATXYZ(2,I1) - ATXYZ(2,I2) )**2
      IF ( DIST .GT. SB ) GOTO 110
      DIST = DIST + ( ATXYZ(3,I1) - ATXYZ(3,I2) )**2
      IF ( DIST .GT. SB ) GOTO 110
      IF ( NBONDS .GT. M200-20 ) THEN
         WRITE (9, 105)
  105    FORMAT(' Too many bonds....., TRY TO CONTINUE !')
         IF (NBONDS .GE. M200) GOTO 110
         ENDIF
      NBONDS = NBONDS + 1
      IBOND(NBONDS,1) = I1
      IBOND(NBONDS,2) = I2
      DIST = SQRT( DIST )
      BONDIS(NBONDS) = DIST
      IBTYP(NBONDS) = 1
      IF (     IZAT(I1) .EQ. 6 .AND. IZAT(I2) .EQ. 6 ) THEN
         IF ( DIST .LT. 1.40 .AND. DIST .GE. 1.25 ) IBTYP(NBONDS) = 2
         IF (                      DIST .LT. 1.25 ) IBTYP(NBONDS) = 3
         ENDIF
      IF ( ( ( IZAT(I1) .EQ. 6 .AND. IZAT(I2) .EQ. 7 ) .OR.
     *       ( IZAT(I1) .EQ. 7 .AND. IZAT(I2) .EQ. 6 )      ) .AND.
     *                             DIST .LT. 1.25 ) IBTYP(NBONDS) = 3
      IF ( ( ( IZAT(I1) .EQ. 6 .AND. IZAT(I2) .EQ. 8 ) .OR.
     *       ( IZAT(I1) .EQ. 8 .AND. IZAT(I2) .EQ. 6 )      ) .AND.
     *                             DIST .LT. 1.30 ) IBTYP(NBONDS) = 2
      IF ( ( ( IZAT(I1) .EQ. 7 .AND. IZAT(I2) .EQ. 8 ) .OR.
     *       ( IZAT(I1) .EQ. 8 .AND. IZAT(I2) .EQ. 7 )      ) .AND.
     *                             DIST .LT. 1.25 ) IBTYP(NBONDS) = 7
  110 CONTINUE
      DO 120 I = 1,NBONDS
      NBATOM(IBOND(I,1)) = NBATOM(IBOND(I,1)) + 1
      NBATOM(IBOND(I,2)) = NBATOM(IBOND(I,2)) + 1
      IF ( NBATOM(IBOND(I,1)) .GT. 11 .OR.
     *     NBATOM(IBOND(I,2)) .GT. 11 ) THEN
         WRITE (9,125)
  125    FORMAT(' Too many bonds on a single atom (continue anyhow..)')
         GOTO 120
         ENDIF
      IBON2(IBOND(I,1),NBATOM(IBOND(I,1)),1) = IBOND(I,2)
      IBON2(IBOND(I,2),NBATOM(IBOND(I,2)),1) = IBOND(I,1)
      IBON2(IBOND(I,1),NBATOM(IBOND(I,1)),2) = I
      IBON2(IBOND(I,2),NBATOM(IBOND(I,2)),2) = I
  120 CONTINUE
      NB = NBONDS
      DO 210 I = 1, NB
      IW1(I,1) = IBOND(I,1)
  210 IW1(I,2) = IBOND(I,2)
      DO 220 I = 1, NAT
      IF (NBATOM(I) .EQ. 0) IATYP(I) = 6
      IF (NBATOM(I) .EQ. 1) IATYP(I) = 2
      IF (IATYP(I)  .EQ. 7) IATYP(I) = 1
  220 CONTINUE
  230 CALL KERNZI( 0, IW2, NAT )
      DO 240 I = 1,NB
      IW2(IW1(I,1)) = IW2(IW1(I,1)) + 1
  240 IW2(IW1(I,2)) = IW2(IW1(I,2)) + 1
      DO 280 I = 1,NAT
      IF (IW2(I) .EQ. 1) THEN
         DO 270 J = 1,NB
         IF (IW1(J,1) .EQ. I .OR. IW1(J,2) .EQ. I) THEN
            IF ( J .LT. NB ) THEN
               DO 260 K = J,NB-1
               IW1(K,1) = IW1(K+1,1)
               IW1(K,2) = IW1(K+1,2)
  260          CONTINUE
               ENDIF
            NB = NB - 1
            IF ( IATYP(I) .NE. 2 ) IATYP(I) = 3
            GOTO 230
            ENDIF
  270    CONTINUE
         WRITE (9,250) I
  250    FORMAT (' Program error, stop. Bond not found for atom ',I3)
         CALL KERROR ('Prog.error: Kan niet .. ', 250, 'BSCHEM')
         ENDIF
  280 CONTINUE
      CALL RING
      DO 350 I = 1, NAT
      NHADD(I) = -1
      IF ( IZAT(I) .LT. 6 .OR. IZAT(I) .GT. 8 ) GOTO 350
      IF ( IZAT(I) .EQ. 6 ) IHTYP(I) = 4
      IF ( IZAT(I) .EQ. 7 ) IHTYP(I) = 3
      IF ( IZAT(I) .EQ. 8 ) IHTYP(I) = 2
      NBTOT = 0
      DO 310 J = 1, NBATOM(I)
  310 NBTOT = NBTOT + IBTYP(IBON2(I,J,2))
      IF         ( IZAT(I) .EQ. 6 ) THEN
         IF      ( NBATOM(I) .EQ. 1 ) THEN
            IF      ( NBTOT .EQ.  1 ) THEN
               IHTYP(I) = 4
               NHADD(I) = 3
            ELSEIF ( NBTOT .EQ.  2 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 2
            ELSEIF ( NBTOT .EQ.  3 ) THEN
               IHTYP(I) = 2
               NHADD(I) = 1
               ENDIF
         ELSEIF ( NBATOM(I) .EQ. 2 ) THEN
            IF      ( NBTOT .EQ. 2 ) THEN
               IHTYP(I) = 4
               NHADD(I) = 2
            ELSEIF ( NBTOT .EQ.  3 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 1
            ELSEIF ( NBTOT .EQ. 10 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 1
               ENDIF
         ELSEIF ( NBATOM(I) .EQ. 3 ) THEN
            IF      ( NBTOT .EQ. 3 ) THEN
               IHTYP(I) = 4
               NHADD(I) = 1
            ELSEIF ( NBTOT .EQ. 4 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 0
            ELSEIF ( NBTOT .EQ. 11 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 0
            ELSEIF ( NBTOT .EQ. 15 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 0
               ENDIF
         ELSEIF ( NBATOM(I) .EQ. 4 ) THEN
            IF      ( NBTOT .EQ. 4 ) THEN
               IHTYP(I) = 4
               NHADD(I) = 0
               ENDIF
            ENDIF
      ELSEIF    ( IZAT(I) .EQ. 7 ) THEN
         IF      ( NBATOM(I) .EQ. 1 ) THEN
            IF      ( NBTOT .EQ.  1 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 2
            ELSEIF ( NBTOT .EQ.  2 ) THEN
               IHTYP(I) = 2
               NHADD(I) = 1
            ELSEIF ( NBTOT .EQ. 3 ) THEN
               IHTYP(I) = 2
               NHADD(I) = 0
               ENDIF
         ELSEIF ( NBATOM(I) .EQ. 2 ) THEN
            IF      ( NBTOT .EQ. 2 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 1
            ELSEIF ( NBTOT .EQ. 3 ) THEN
               IHTYP(I) = 2
               NHADD(I) = 0
            ELSEIF ( NBTOT .EQ. 10 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 1
               ENDIF
         ELSEIF ( NBATOM(I) .EQ. 3 ) THEN
            IF      ( NBTOT .EQ. 3 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 0
            ELSEIF ( NBTOT .EQ. 11 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 0
            ELSEIF ( NBTOT .EQ. 15 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 0
               ENDIF
         ELSEIF ( NBATOM(I) .EQ. 4 ) THEN
            IF      ( NBTOT .EQ. 4 ) THEN
               IHTYP(I) = 4
               NHADD(I) = 0
               ENDIF
            ENDIF
      ELSEIF    ( IZAT(I) .EQ. 8 ) THEN
         IF      ( NBATOM(I) .EQ. 1 ) THEN
            IF       ( NBTOT .EQ. 1 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 1
            ELSEIF ( NBTOT .EQ.  2 ) THEN
               IHTYP(I) = 2
               NHADD(I) = 0
            ELSEIF ( NBTOT .EQ.  7 ) THEN
               IHTYP(I) = 2
               NHADD(I) = 0
            ENDIF
         ELSEIF ( NBATOM(I) .EQ. 2 ) THEN
            IF      ( NBTOT .EQ. 2 ) THEN
               IHTYP(I) = 3
               NHADD(I) = 0
               ENDIF
            ENDIF
         ENDIF
  350 CONTINUE
      IF (IICALL .NE. 1) RETURN
      WRITE (8,910)
  910 FORMAT (/' Atomic connectivity of the input atoms' /
     * ' Atom    Atom-type      Hybr.  H?  NB  Z  Bonds:' )
      DO 920 I = 1, NAT
         IF (NBATOM(I) .EQ. 0) WRITE (8,930)
     *      ATNAME(I), E(IATYP(I)), H(IHTYP(I)), NHADD(I), NBATOM(I)
         IF (NBATOM(I) .NE. 0) WRITE (8,930)
     *      ATNAME(I), E(IATYP(I)), H(IHTYP(I)), NHADD(I), NBATOM(I),
     *      IZAT(I),
     *      (ATNAME(IBON2(I,J,1)),J=1,NBATOM(I))
  920 CONTINUE
  930 FORMAT(1X,A6,2X,A15,1X,A3,I5, I4, I3,1X,10(1X,A6))
      NHADDT = 0
      DO 935 I = 1, NAT
  935 IF ( NHADD(I) .GT. 0 ) NHADDT = NHADDT + NHADD(I)
      WRITE (8,940)
  940 FORMAT (/' Table of bonds' /
     * ' Atom    Atom    Dist   Bond-type' )
      DO 950 I = 1, NBONDS
         WRITE (8,960) ATNAME(IBOND(I,1)), ATNAME(IBOND(I,2)),
     *                    BONDIS(I), D(IBTYP(I))
  950 CONTINUE
  960 FORMAT (1X,A6,2X,A6,2X,F5.3,2X,A15)
      RETURN
      END
      SUBROUTINE ZZDIST ( IZAT1, IZAT2, DIST )
      DIMENSION COVR(102)
      DIMENSION ARC1(25),ARC2(25),ARC3(25),ARC4(25),ARC5(2)
      EQUIVALENCE (COVR(  1),ARC1(1))
      EQUIVALENCE (COVR( 26),ARC2(1))
      EQUIVALENCE (COVR( 51),ARC3(1))
      EQUIVALENCE (COVR( 76),ARC4(1))
      EQUIVALENCE (COVR(101),ARC5(1))
      DATA ARC1 /
     *  0.32  , 0.93  , 1.23  , 0.90  , 0.82  ,
     *  0.77  , 0.75  , 0.73  , 0.72  , 0.71  ,
     *  1.54  , 1.36  , 1.18  , 1.11  , 1.06  ,
     *  1.02  , 0.99  , 0.98  , 2.03  , 1.74  ,
     *  1.44  , 1.32  , 1.22  , 1.18  , 1.17  /
      DATA ARC2 /
     *  1.17  , 1.16  , 1.15  , 1.17  , 1.25  ,
     *  1.26  , 1.22  , 1.20  , 1.16  , 1.14  ,
     *  1.12  , 2.16  , 1.91  , 1.62  , 1.45  ,
     *  1.34  , 1.30  , 1.27  , 1.25  , 1.25  ,
     *  1.28  , 1.34  , 1.48  , 1.44  , 1.41  /
      DATA ARC3 /
     *  1.40  , 1.36  , 1.33  , 1.31  , 2.35  ,
     *  1.98  , 1.69  , 1.65  , 1.65  , 1.64  ,
     *  1.63  , 1.62  , 1.85  , 1.61  , 1.59  ,
     *  1.59  , 1.58  , 1.57  , 1.56  , 1.74  ,
     *  1.56  , 1.44  , 1.34  , 1.30  , 1.28  /
      DATA ARC4 /
     *  1.26  , 1.27  , 1.30  , 1.34  , 1.49  ,
     *  1.48  , 1.47  , 1.46  , 1.46  , 1.45  ,
     *  1.5   , 1.5   , 1.5   , 1.5   , 1.65  ,
     *  1.5   , 1.42  , 1.5   , 1.5   , 1.5   ,
     *  1.5   , 1.5   , 1.5   , 1.5   , 1.5   /
      DATA ARC5 /
     *  0.32  , 0.32  /
      DIST = COVR(IZAT1) + COVR(IZAT2)
      RETURN
      END
      SUBROUTINE RING
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION NSOL(7), NSOLA(7), ICYCB(M200,2), KYPB(M200,2)
      DIMENSION NWT(M200), NATTAK(MAXX), NBTEMP(M200)
      IF ( RINGED ) RETURN
      M222 = 2 * M200
      CALL KERNZI ( 0, KYPB, M222)
      CALL KERNZI ( 0, NWT, M200)
      NCB = 0
      NRING = 0
      DO 10 I = 1, NBONDS
         IF ( ( IATYP(IBOND(I,1)) .EQ. 1 .OR.
     *          IATYP(IBOND(I,1)) .EQ. 5 ) .AND.
     *        ( IATYP(IBOND(I,2)) .EQ. 1 .OR.
     *          IATYP(IBOND(I,2)) .EQ. 5 ) ) THEN
            NCB = NCB + 1
            ICYCB(NCB,1) = IBOND(I,1)
            ICYCB(NCB,2) = IBOND(I,2)
         ENDIF
   10 CONTINUE
      CALL KERNZI (-1, NATTAK, NAT)
      CALL KERNZI ( 0, NBTEMP, NAT)
      IF (NCB .GT. 25) RETURN
      DO 15 I = 1, NCB
      DO 15 J = 1,2
         NBTEMP( ICYCB(I,J) ) = NBTEMP( ICYCB(I,J) ) + 1
   15 CONTINUE
      NTAK = 0
      DO 30 I = 1, NAT
         IF ( NBTEMP(I) .GE. 3 ) THEN
            NATTAK(I) = 0
            NTAK = NTAK + NBTEMP(I)
            DO 20 J = 1, NCB
               IF ( ICYCB(J,1) .EQ. I ) THEN
                  ICT = ICYCB(J,2)
                  ICYCB(J,2) = -ICYCB(J,1)
                  ICYCB(J,1) = ICT
               ELSEIF ( ICYCB(J,2) .EQ. I ) THEN
                  ICYCB(J,2) = -ICYCB(J,2)
               ENDIF
   20       CONTINUE
         ENDIF
   30 CONTINUE
      IF ( NCB .GT. 0 .AND. NTAK .EQ. 0 ) THEN
         IZOEK = ICYCB(1,2)
         ICYCB(1,2) = -ICYCB(1,2)
         DO 35 J = 2, NCB
            IF ( ICYCB(J,2) .EQ. IZOEK ) THEN
               ICYCB(J,2) = -ICYCB(J,2)
               GOTO 37
            ELSEIF ( ICYCB(J,1) .EQ. IZOEK ) THEN
               ICT = ICYCB(J,2)
               ICYCB(J,2) = -ICYCB(J,1)
               ICYCB(J,1) = ICT
               GOTO 37
            ENDIF
   35    CONTINUE
      ENDIF
   37 NUMTAK = 0
      NWTOT = 0
      DO 40 I = 1, NCB
         IF ( ICYCB(I,1) .LT. 0 .AND. ICYCB(I,2) .LT. 0 ) THEN
            NUMTAK = NUMTAK + 1
            KYPB(NUMTAK,1) = -ICYCB(I,1)
            KYPB(NUMTAK,2) = -ICYCB(I,2)
            NWT(NUMTAK) = 1
            NWTOT = NWTOT + NWT(NUMTAK)
            ICYCB(I,1) = 0
            ICYCB(I,2) = 0
         ENDIF
   40 CONTINUE
      DO 80 I = 1, NCB-1
         IF ( ICYCB(I,1) .EQ. 0 ) GOTO 80
         IF ( ICYCB(I,2) .LT. 0 ) THEN
            NUMTAK = NUMTAK + 1
            KYPB(NUMTAK,1) = -ICYCB(I,2)
            NZOEK = ICYCB(I,1)
            NATTAK(NZOEK) = NUMTAK
            NWT(NUMTAK) = 1
            ICYCB(I,1) = 0
            ICYCB(I,2) = 0
   50       DO 60 J = 1, NCB
               IF ( ICYCB(J,1) .EQ. 0 ) GOTO 60
               IF ( ICYCB(J,1) .EQ. NZOEK .OR.
     *              ICYCB(J,2) .EQ. NZOEK) THEN
                  NWT(NUMTAK) = NWT(NUMTAK) + 1
                  IF ( ICYCB(J,1) .EQ. NZOEK ) THEN
                     IF ( ICYCB(J,2) .GT. 0 ) THEN
                        NZOEK = ICYCB(J,2)
                        NATTAK(NZOEK) = NUMTAK
                        ICYCB(J,1) = 0
                        ICYCB(J,2) = 0
                        GOTO 50
                     ELSE
                        KYPB(NUMTAK,2) = -ICYCB(J,2)
                        ICYCB(J,1) = 0
                        ICYCB(J,2) = 0
                        NWTOT = NWTOT + NWT(NUMTAK)
                        GOTO 80
                     ENDIF
                  ELSE
                     NZOEK = ICYCB(J,1)
                     NATTAK(NZOEK) = NUMTAK
                     ICYCB(J,1) = 0
                     ICYCB(J,2) = 0
                     GOTO 50
                  ENDIF
               ENDIF
   60       CONTINUE
         ENDIF
   80 CONTINUE
      NT = 1
      IF ( NCB .LT. NT ) GOTO 800
      DO 131 I1 = 1, NCB
      IF ( KYPB(I,1) .EQ. KYPB(I,2) ) THEN
         NTOT = NWT(I1)
         IF ( NTOT .GT. 7 ) GOTO 131
         IF ( NTOT .LT. 5 ) GOTO 131
         NSOL(1) = I1
         CALL SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
         CALL PLATST ( NSOLA, NTOT, KEYP )
         IF ( KEYP .EQ. 0 ) THEN
            DO 110 J = 1, NTOT
            IF ( IATYP( NSOLA(J) ) .NE. 5 ) IATYP( NSOLA(J) ) = 1
  110       CONTINUE
         ELSE
            IF ( NRING .EQ. 100 ) RETURN
            NRING = NRING + 1
            RINGAT(1,NRING) = NTOT
            DO 120 J = 1, NTOT
               IATYP( NSOLA(J) ) = 5
               RINGAT(1+J,NRING) = NSOLA(J)
  120       CONTINUE
            DO 125 J = 1, NTOT
            DO 125 K = 1, NBATOM(NSOLA(J))
               IF ( IATYP( IBON2(NSOLA(J),K,1)) .EQ. 5 )
     *              IBTYP( IBON2(NSOLA(J),K,2)) = 5
  125       CONTINUE
         ENDIF
      ENDIF
  131 CONTINUE
      NT = 2
      IF ( NCB .LT. NT ) GOTO 800
      DO 232 I1 =    1, NCB-1
      NTOT1 = NWT(I1)
      IF ( NTOT1 .GE. 7 ) GOTO 232
      NSOL(1) = I1
      DO 231 I2 = I1+1, NCB
      NTOT = NTOT1 + NWT(I2)
      IF ( NTOT .GT. 7 ) GOTO 231
      IF ( NTOT .LT. 5 ) GOTO 231
      NSOL(2) = I2
      CALL CYCLE ( KYPB, NSOL, NT, KEY )
      IF (KEY .EQ. 0) GOTO 231
      CALL SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
      CALL PLATST ( NSOLA, NTOT, KEYP )
      IF ( KEYP .EQ. 0 ) THEN
         DO 210 J = 1, NTOT
         IF ( IATYP( NSOLA(J) ) .NE. 5 ) IATYP( NSOLA(J) ) = 1
  210    CONTINUE
      ELSE
         IF ( NRING .EQ. 100 ) RETURN
         NRING = NRING + 1
         RINGAT(1,NRING) = NTOT
         DO 220 J = 1, NTOT
         IATYP( NSOLA(J) ) = 5
         RINGAT(1+J,NRING) = NSOLA(J)
  220    CONTINUE
         DO 225 J = 1, NTOT
         DO 225 K = 1, NBATOM(NSOLA(J))
            IF ( IATYP( IBON2(NSOLA(J),K,1)) .EQ. 5 )
     *           IBTYP( IBON2(NSOLA(J),K,2)) = 5
  225    CONTINUE
      ENDIF
  231 CONTINUE
  232 CONTINUE
      NT = 3
      IF ( NCB .LT. NT ) GOTO 800
      DO 333 I1 =    1, NCB-2
      NTOT1 = NWT(I1)
      IF ( NTOT1 .GE. 6 ) GOTO 333
      NSOL(1) = I1
      DO 332 I2 = I1+1, NCB-1
      NTOT2 = NTOT1 + NWT(I2)
      IF ( NTOT2 .GE. 7 ) GOTO 332
      NSOL(2) = I2
      DO 331 I3 = I2+1, NCB
      NTOT = NTOT2 + NWT(I3)
      IF ( NTOT .GT. 7 ) GOTO 331
      IF ( NTOT .LT. 5 ) GOTO 331
      NSOL(3) = I3
      CALL CYCLE ( KYPB, NSOL, NT, KEY )
      IF (KEY .EQ. 0) GOTO 331
      CALL SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
      CALL PLATST ( NSOLA, NTOT, KEYP )
      IF ( KEYP .EQ. 0 ) THEN
         DO 310 J = 1, NTOT
         IF ( IATYP( NSOLA(J) ) .NE. 5 ) IATYP( NSOLA(J) ) = 1
  310    CONTINUE
      ELSE
         IF ( NRING .EQ. 100 ) RETURN
         NRING = NRING + 1
         RINGAT(1,NRING) = NTOT
         DO 320 J = 1, NTOT
         IATYP( NSOLA(J) ) = 5
         RINGAT(1+J,NRING) = NSOLA(J)
  320    CONTINUE
         DO 325 J = 1, NTOT
         DO 325 K = 1, NBATOM(NSOLA(J))
            IF ( IATYP( IBON2(NSOLA(J),K,1)) .EQ. 5 )
     *           IBTYP( IBON2(NSOLA(J),K,2)) = 5
  325    CONTINUE
      ENDIF
  331 CONTINUE
  332 CONTINUE
  333 CONTINUE
      NT = 4
      IF ( NCB .LT. NT ) GOTO 800
      DO 434 I1 =    1, NCB-3
      NTOT1 = NWT(I1)
      IF ( NTOT1 .GE. 5 ) GOTO 434
      NSOL(1) = I1
      DO 433 I2 = I1+1, NCB-2
      NTOT2 = NTOT1 + NWT(I2)
      IF ( NTOT2 .GE. 6 ) GOTO 433
      NSOL(2) = I2
      DO 432 I3 = I2+1, NCB-1
      NTOT3 = NTOT2 + NWT(I3)
      IF ( NTOT3 .GE. 7 ) GOTO 432
      NSOL(3) = I3
      DO 431 I4 = I3+1, NCB
      NTOT = NTOT3 + NWT(I4)
      IF ( NTOT .GT. 7 ) GOTO 431
      IF ( NTOT .LT. 5 ) GOTO 431
      NSOL(4) = I4
      CALL CYCLE ( KYPB, NSOL, NT, KEY )
      IF (KEY .EQ. 0) GOTO 431
      CALL SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
      CALL PLATST ( NSOLA, NTOT, KEYP )
      IF ( KEYP .EQ. 0 ) THEN
         DO 410 J = 1, NTOT
         IF ( IATYP( NSOLA(J) ) .NE. 5 ) IATYP( NSOLA(J) ) = 1
  410    CONTINUE
      ELSE
         IF ( NRING .EQ. 100 ) RETURN
         NRING = NRING + 1
         RINGAT(1,NRING) = NTOT
         DO 420 J = 1, NTOT
         IATYP( NSOLA(J) ) = 5
         RINGAT(1+J,NRING) = NSOLA(J)
  420    CONTINUE
         DO 425 J = 1, NTOT
         DO 425 K = 1, NBATOM(NSOLA(J))
            IF ( IATYP( IBON2(NSOLA(J),K,1)) .EQ. 5 )
     *           IBTYP( IBON2(NSOLA(J),K,2)) = 5
  425    CONTINUE
      ENDIF
  431 CONTINUE
  432 CONTINUE
  433 CONTINUE
  434 CONTINUE
      NT = 5
      IF ( NCB .LT. NT ) GOTO 800
      DO 535 I1 =    1, NCB-4
      NTOT1 = NWT(I1)
      IF ( NTOT1 .GE. 4 ) GOTO 535
      NSOL(1) = I1
      DO 534 I2 = I1+1, NCB-3
      NTOT2 = NTOT1 + NWT(I2)
      IF ( NTOT2 .GE. 5 ) GOTO 534
      NSOL(2) = I2
      DO 533 I3 = I2+1, NCB-2
      NTOT3 = NTOT2 + NWT(I3)
      IF ( NTOT3 .GE. 6 ) GOTO 533
      NSOL(3) = I3
      DO 532 I4 = I3+1, NCB-1
      NTOT4 = NTOT3 + NWT(I4)
      IF ( NTOT4 .GE. 7 ) GOTO 532
      NSOL(4) = I4
      DO 531 I5 = I4+1, NCB
      NTOT = NTOT4 + NWT(I5)
      IF ( NTOT .GT. 7 ) GOTO 531
      IF ( NTOT .LT. 5 ) GOTO 531
      NSOL(5) = I5
      CALL CYCLE ( KYPB, NSOL, NT, KEY )
      IF (KEY .EQ. 0) GOTO 531
      CALL SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
      CALL PLATST ( NSOLA, NTOT, KEYP )
      IF ( KEYP .EQ. 0 ) THEN
         DO 510 J = 1, NTOT
         IF ( IATYP( NSOLA(J) ) .NE. 5 ) IATYP( NSOLA(J) ) = 1
  510    CONTINUE
      ELSE
         IF ( NRING .EQ. 100 ) RETURN
         NRING = NRING + 1
         RINGAT(1,NRING) = NTOT
         DO 520 J = 1, NTOT
         IATYP( NSOLA(J) ) = 5
         RINGAT(1+J,NRING) = NSOLA(J)
  520    CONTINUE
         DO 525 J = 1, NTOT
         DO 525 K = 1, NBATOM(NSOLA(J))
            IF ( IATYP( IBON2(NSOLA(J),K,1)) .EQ. 5 )
     *           IBTYP( IBON2(NSOLA(J),K,2)) = 5
  525    CONTINUE
      ENDIF
  531 CONTINUE
  532 CONTINUE
  533 CONTINUE
  534 CONTINUE
  535 CONTINUE
      NT = 6
      IF ( NCB .LT. NT ) GOTO 800
      DO 636 I1 =    1, NCB-5
      NTOT1 = NWT(I1)
      IF ( NTOT1 .GE. 3 ) GOTO 636
      NSOL(1) = I1
      DO 635 I2 = I1+1, NCB-4
      NTOT2 = NTOT1 + NWT(I2)
      IF ( NTOT2 .GE. 4 ) GOTO 635
      NSOL(2) = I2
      DO 634 I3 = I2+1, NCB-3
      NTOT3 = NTOT2 + NWT(I3)
      IF ( NTOT3 .GE. 5 ) GOTO 634
      NSOL(3) = I3
      DO 633 I4 = I3+1, NCB-2
      NTOT4 = NTOT3 + NWT(I4)
      IF ( NTOT4 .GE. 6 ) GOTO 633
      NSOL(4) = I4
      DO 632 I5 = I4+1, NCB-1
      NTOT5 = NTOT4 + NWT(I5)
      IF ( NTOT5 .GE. 7 ) GOTO 632
      NSOL(5) = I5
      DO 631 I6 = I5+1, NCB
      NTOT = NTOT5 + NWT(I6)
      IF ( NTOT .GT. 7 ) GOTO 631
      IF ( NTOT .LT. 5 ) GOTO 631
      NSOL(6) = I6
      CALL CYCLE ( KYPB, NSOL, NT, KEY )
      IF (KEY .EQ. 0) GOTO 631
      CALL SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
      CALL PLATST ( NSOLA, NTOT, KEYP )
      IF ( KEYP .EQ. 0 ) THEN
         DO 610 J = 1, NTOT
         IF ( IATYP( NSOLA(J) ) .NE. 5 ) IATYP( NSOLA(J) ) = 1
  610    CONTINUE
      ELSE
         IF ( NRING .EQ. 100 ) RETURN
         NRING = NRING + 1
         RINGAT(1,NRING) = NTOT
         DO 620 J = 1, NTOT
         IATYP( NSOLA(J) ) = 5
         RINGAT(1+J,NRING) = NSOLA(J)
  620    CONTINUE
         DO 625 J = 1, NTOT
         DO 625 K = 1, NBATOM(NSOLA(J))
            IF ( IATYP( IBON2(NSOLA(J),K,1)) .EQ. 5 )
     *           IBTYP( IBON2(NSOLA(J),K,2)) = 5
  625    CONTINUE
      ENDIF
  631 CONTINUE
  632 CONTINUE
  633 CONTINUE
  634 CONTINUE
  635 CONTINUE
  636 CONTINUE
      NT = 7
      IF ( NCB .LT. NT ) GOTO 800
      DO 737 I1 =    1, NCB-6
      NTOT1 = NWT(I1)
      IF ( NTOT1 .GE. 2 ) GOTO 737
      NSOL(1) = I1
      DO 736 I2 = I1+1, NCB-5
      NTOT2 = NTOT1 + NWT(I2)
      IF ( NTOT2 .GE. 3 ) GOTO 736
      NSOL(2) = I2
      DO 735 I3 = I2+1, NCB-4
      NTOT3 = NTOT2 + NWT(I3)
      IF ( NTOT3 .GE. 4 ) GOTO 735
      NSOL(3) = I3
      DO 734 I4 = I3+1, NCB-3
      NTOT4 = NTOT3 + NWT(I4)
      IF ( NTOT4 .GE. 5 ) GOTO 734
      NSOL(4) = I4
      DO 733 I5 = I4+1, NCB-2
      NTOT5 = NTOT4 + NWT(I5)
      IF ( NTOT5 .GE. 6 ) GOTO 733
      NSOL(5) = I5
      DO 732 I6 = I5+1, NCB-1
      NTOT6 = NTOT5 + NWT(I6)
      IF ( NTOT6 .GE. 7 ) GOTO 732
      NSOL(6) = I6
      DO 731 I7 = I6+1, NCB
      NTOT = NTOT6 + NWT(I7)
      IF ( NTOT .GT. 7 ) GOTO 731
      IF ( NTOT .LT. 5 ) GOTO 731
      NSOL(7) = I7
      CALL CYCLE ( KYPB, NSOL, NT, KEY )
      IF (KEY .EQ. 0) GOTO 731
      CALL SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
      CALL PLATST ( NSOLA, NTOT, KEYP )
      IF ( KEYP .EQ. 0 ) THEN
         DO 710 J = 1, NTOT
         IF ( IATYP( NSOLA(J) ) .NE. 5 ) IATYP( NSOLA(J) ) = 1
  710    CONTINUE
      ELSE
         IF ( NRING .EQ. 100 ) RETURN
         NRING = NRING + 1
         RINGAT(1,NRING) = NTOT
         DO 720 J = 1, NTOT
         IATYP( NSOLA(J) ) = 5
         RINGAT(1+J,NRING) = NSOLA(J)
  720    CONTINUE
         DO 725 J = 1, NTOT
         DO 725 K = 1, NBATOM(NSOLA(J))
            IF ( IATYP( IBON2(NSOLA(J),K,1)) .EQ. 5 )
     *           IBTYP( IBON2(NSOLA(J),K,2)) = 5
  725    CONTINUE
      ENDIF
  731 CONTINUE
  732 CONTINUE
  733 CONTINUE
  734 CONTINUE
  735 CONTINUE
  736 CONTINUE
  737 CONTINUE
  800 RINGED = .TRUE.
      RETURN
      END
      SUBROUTINE SOLATO ( KYPB, NWT, NATTAK, NSOL, NSOLA, NT, NTOT )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       KYPB(M200,2), NWT(M200), NATTAK(MAXX)
      DIMENSION       NSOL(NTOT), NSOLA(NTOT)
      NF = 0
      DO 100 I = 1, NT
         IF ( NF .EQ. 0 ) THEN
            NSOLA(1) = KYPB(NSOL(1),1)
            NF = 1
         ELSE
            DO 10 J = 1, NF
               IF ( NSOLA(J) .EQ. KYPB(NSOL(I),1) ) GOTO 20
   10       CONTINUE
            NF = NF + 1
            NSOLA(NF) = KYPB(NSOL(I),1)
         ENDIF
   20    CONTINUE
         IF ( NWT(NSOL(I)) .EQ. 1 ) GOTO 50
         DO 40 K = 1, NAT
            IF ( NATTAK(K) .EQ. NSOL(I) ) THEN
               NF = NF + 1
               NSOLA(NF) = K
               ENDIF
   40       CONTINUE
   50    DO 60 J = 1, NF
            IF ( NSOLA(J) .EQ. KYPB(NSOL(I),2) ) GOTO 100
   60    CONTINUE
         NF = NF + 1
         IF (NF .GT. NTOT) GOTO 100
         NSOLA(NF) = KYPB(NSOL(I),2)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE PLATST ( NSOLA, NTOT, KEYP )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      DIMENSION NSOLA(NTOT)
      DIMENSION V1(3), V2(3), V3(3), V4(4), VSOL(3)
      KEYP = 1
      DO 10 I = 1, 3
      V1(I) = ATXYZ(I,NSOLA(2)) - ATXYZ(I,NSOLA(1))
      V2(I) = ATXYZ(I,NSOLA(3)) - ATXYZ(I,NSOLA(2))
   10 V3(I) = ATXYZ(I,NSOLA(1))
      CALL VECAXB ( V1, V2, VSOL )
      CALL VECDOT ( VSOL, V3, SOL )
      DO 30 I = 4, NTOT
         DO 20 J = 1, 3
   20       V4(J) = ATXYZ(J,NSOLA(I))
         CALL VECDOT ( VSOL, V4, PSOL )
         DEL = ABS ( PSOL - SOL )
         IF ( DEL .GT. 0.25 ) THEN
            KEYP = 0
         ENDIF
   30 CONTINUE
      RETURN
      END
      SUBROUTINE CYCLE ( KYPB, NSOL, NT, KEY )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       NSOL(*), IBONX(14), KYPB(M200,2)
      NS2 = NT * 2
      DO 5 I = 1, NT
      J = (I-1)*2 + 1
      IBONX(J  ) = KYPB(NSOL(I),1)
    5 IBONX(J+1) = KYPB(NSOL(I),2)
      KEY = 0
      NFIT = 1
      NHEAD = IBONX(2)
   10 DO 20 I = 3, NS2
      IF ( IBONX(I) .EQ. NHEAD ) GOTO 30
   20 CONTINUE
      RETURN
   30 J = I - 1
      IF ( (I/2)*2 .NE. I ) J = I + 1
      NHEAD = IBONX(J)
      IBONX(I) = 0
      IBONX(J) = 0
      NFIT = NFIT + 1
      IF ( NFIT .EQ. NT ) THEN
         IF ( NHEAD .EQ. IBONX(1) ) KEY = 1
         RETURN
      ELSE
         GOTO 10
      ENDIF
      END
      SUBROUTINE SCFRAG
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION P(MAXX), Q(MAXX)
      DATA SCALEF /0.0/
      DO 100 I = 2, 14
  100 AL(I) = ' '
      XMIN =  100000.
      XMAX = -100000.
      YMIN =  100000.
      YMAX = -100000.
      DO 110 I = 1, NAT
      IF ( ATXYZ(1,I) .LT. XMIN ) XMIN = ATXYZ(1,I)
      IF ( ATXYZ(1,I) .GT. XMAX ) XMAX = ATXYZ(1,I)
      IF ( ATXYZ(2,I) .LT. YMIN ) YMIN = ATXYZ(2,I)
      IF ( ATXYZ(2,I) .GT. YMAX ) YMAX = ATXYZ(2,I)
  110 CONTINUE
      XMID   = ( XMAX + XMIN ) / 2.0
      YMID   = ( YMAX + YMIN ) / 2.0
      DO 120 I = 1, NAT
      P(I) = ( ATXYZ(1,I) - XMID ) * 0.75 * 3.0
      Q(I) = ( ATXYZ(2,I) - YMID ) * 0.75
  120 CONTINUE
      XRANGE = ABS( XMAX - XMIN )
      YRANGE = ABS( YMAX - YMIN )
      SCMAX = 3.0
      XSCALE = SCMAX
      YSCALE = SCMAX
      IF ( XRANGE .GE. 37.0/SCMAX ) XSCALE = 37.0 / XRANGE
      IF ( YRANGE .GE. 13.0/SCMAX ) YSCALE = 13.0 / YRANGE
      IF ( .NOT. SCALED ) SCALEF = MIN ( XSCALE, YSCALE )
      DO 130 I = 1, NAT
      IXP =     NINT( P(I)*SCALEF ) + 37
      IYP = 8 - NINT( Q(I)*SCALEF )
      IF ( IXP .LT.  1 ) IXP =  1
      IF ( IXP .GT. 73 ) IXP = 73
      IF ( IYP .LT.  2 ) IYP =  2
      IF ( IYP .GT. 14 ) IYP = 14
      CALL CURPOS ( AL, IYP, IXP, ATNAME(I) )
  130 CONTINUE
      SCALED = .TRUE.
      RETURN
      END
      SUBROUTINE CURPOS (AL, IL, IC, STRING)
      CHARACTER*78 AL(19)
      CHARACTER STRING*6
      DO 10 I = 6, 1, -1
      IF ( STRING(I:I) .NE. ' ' ) GOTO 20
   10 CONTINUE
      I = 6
   20 LS = I
      IF ( AL(IL) (IC:IC+LS-1) .EQ. ' ' ) GOTO 70
      N = IC - 1
   30 IF ( AL(IL) (N:N) .EQ. ' ' ) GOTO 40
      AL(IL) (N:N) = ' '
      N = N - 1
      IF ( N .EQ. 0 ) GOTO 40
      GOTO 30
   40 N = IC
   50 IF ( AL(IL) (N:N) .EQ. ' ' ) GOTO 60
      AL(IL) (N:N) = ' '
      N = N + 1
      IF ( N .EQ. 79 ) GOTO 60
      GOTO 50
   60 AL(IL) (IC:IC) = '*'
      RETURN
   70 AL(IL) (IC:IC+LS-1) = STRING(1:LS)
      RETURN
      END
      SUBROUTINE XFLUSH
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DATA M, MAL / 0 , 19 /
      IF (M .NE. 0) GOTO 160
      WRITE (9, 110)
  110 FORMAT (' If your terminal does not scroll, then ....'/
     *   ' clear your screen before entering an edit command.')
      M = -1
  160 WRITE (9,180) AL(1)
      DO 166 II = 2, 12
      IF (AL(II).NE.' ') GOTO 168
  166 CONTINUE
      II = 13
  168 CONTINUE
      DO 170 I = II, 13
      WRITE (9,180) AL(I)
  170 CONTINUE
      DO 175 I = 14, MAL
      IF (AL(I) .NE. ' ') WRITE (9,180) AL(I)
  175 CONTINUE
  180 FORMAT (A78)
      RETURN
      END
      SUBROUTINE CFHELP
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcofr.inc'
      IF (AT2 .NE. ' '.OR. NFNUM .NE. 0 .OR. NLIT .NE. 1) THEN
         WRITE (9, FMT='(A)')
     *      ' Error? Option H does not take any parameters'
         RETURN
         ENDIF
      WRITE (9, 10)
   10 FORMAT (
     * ' Fragment editor commands:'/
     * '       Parameters between brackets () are optional'/
     * '       Leave out the brackets when supplying values!'/1X/
     * ' D At : Delete At (At = an end-of-chain atom)'/
     * '       Use command DEL to delete any atom (be careful!)'/
     * '       Note: at the end all hydrogens will be deleted !'/
     * ' R At1 At2 (dist) : Replace At1 (atom) by At2 (new atom)'/
     * '       Only if At1 is an end-of-chain atom (i.e.'/
     * '       with one bond only) the distance to the nearest atom'/
     * '       will be adapted to the correct single-bond distance,'/
     * '       i.e. the position of At2 may be shifted.'/
     * '       If the user supplies a new distance (dist) as a third'/
     * '       parameter (e.g. double-bond distance), this distance'/
     * '       will be used. Otherwise the user will be warned for a'/
     * '       possibly inaccurate bond distance.'/
     * ' ........ Hit any key to continue this help message......')
      CALL WININP (CHIN)
      WRITE (9, 50)
   50 FORMAT (
     * ' A At1 At2 (Hy) (dist) : Add one or more atoms to atom At1,'/
     * '       possibly in non-default hybridization.'/
     * '       AT2 : atom or element to be added (at given distant);'/
     * '       Hy: can be -T or -P or -L (specify literally) for'/
     * '           tetrahedral (sp3), planar (sp2) or linear (sp)'/
     * '           hybridization (when different from default).'/
     * '       New atoms will be numbered automatically.'/
     * ' A At1 Gr : Add one specific group to (carbon) atom At1,'/
     * '       Gr : can be =O or -NO2 or -CN (specify literally);'/
     * ' F At1 At2 n : Fuse 5- (n=5) or 6-membered aromatic ring (n=6)'/
     * '       to At1-At2 bond. At1 and At2 must belong to aromatic'/
     * '       part of molecule; new ring will be in that same plane.'/
     * '       Other coinciding atoms will be detected. All new atoms'/
     * '       will be carbon. Automatic numbering.'/
     * ' Hit any key to continue this help message .......')
      CALL WININP (CHIN)
      WRITE (9, 80)
   80 FORMAT (1X/
     * ' G At: Show bond distances and angles involving atom At :',/
     *'       bonds to atoms 1,2,3,..; angles with 12, 13,.. 23, 24,..',
     * ' S   : Save the current fragment temporarily'/
     * ' U   : Undo changes since last Save instruction'/
     * ' X d : Rotate the model d degrees around the X-axis (hor).'/
     * ' Y d : Rotate the model d degrees around the Y-axis (vert).'/
     * ' Z d : Rotate the model d degrees around the Z-axis (perp).'/
     * ' E   : (Exit = quit) finished, delete all hydrogens.'/
     * ' Q   : (exit = Quit) finished, delete all hydrogens.'/
     * ' ----> You may reject the final result, if you wish!'/
     * ' Note: enter blank for a repaint of the fragment !')
      RETURN
      END
      SUBROUTINE CFDELE
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78  AL18
      NTODEL = 0
      TEMPAT = AT2
      IF (TEMPAT .EQ. ' ' .OR. NFNUM .NE. 0) THEN
         WRITE (9, FMT='(A)')
     *         ' D or DEL must be followed by a single atom-name'
         RETURN
         ENDIF
      IF (AT3 .NE. ' ') THEN
            WRITE (9, FMT='(A)')
     *         ' D or DEL must be followed by one atom-name only'
         RETURN
         ENDIF
      DO 10 I = 1, NAT
      IF ( TEMPAT .EQ. ATNAME(I) ) GOTO 20
   10 CONTINUE
      AL18 = '       : Unknown atom identification'
      AL18 (2:7) = TEMPAT
      WRITE (9, FMT='(A78)') AL18
      RETURN
   20 IF ( IATYP(I) .EQ. 2 .OR. IATYP(I) .EQ. 6 ) GOTO 50
      NONH = 0
      DO 30 J = 1, 10
      IF ( IBON2(I,J,1) .EQ. 0 ) GOTO 40
      IF ( IZAT(IBON2(I,J,1)) .EQ. 1 ) THEN
         NTODEL = NTODEL + 1
         NDEL(NTODEL) = IBON2(I,J,1)
      ELSE
         NONH = NONH + 1
         ENDIF
   30 CONTINUE
   40 IF ( NONH .LE. 1 ) GOTO 60
      IF ( EDOPT .EQ. 'D  ' ) THEN
         AL18 =
     *      ' Atom           is not an end-of-chain atom: not deleted'
         AL18 (7:12) = TEMPAT
         WRITE (9, FMT='(A78)') AL18
         WRITE (9, FMT='(A)')
     *      ' Use option DEL to delete this atom anyway. Watch out!!!'
         RETURN
      ELSE
         GOTO 60
         ENDIF
   50 IF ( NAT .GT. 1 ) GOTO 60
      WRITE (9, FMT='(A)')
     *    ' Deletion impossible, you have only one atom left!'
      RETURN
   60 NTODEL = NTODEL + 1
      NDEL(NTODEL) = I
      IF ( NTODEL .EQ. 1 ) GOTO 90
   70 NSW = 0
      DO 80 J1 = 1, NTODEL-1
      DO 80 J2 = J1+1, NTODEL
      IF ( NDEL(J1) .GE. NDEL(J2) ) GOTO 80
      NTEM = NDEL(J2)
      NDEL(J2) = NDEL(J1)
      NDEL(J1) = NTEM
      NSW = NSW + 1
   80 CONTINUE
      IF ( NSW .NE. 0 ) GOTO 70
   90 DO 110 J = 1, NTODEL
      I = NDEL(J)
      DO 100  K = I, NAT-1
      ATNAME(K)  = ATNAME(K+1)
      ATXYZ(1,K) = ATXYZ(1,K+1)
      ATXYZ(2,K) = ATXYZ(2,K+1)
      ATXYZ(3,K) = ATXYZ(3,K+1)
  100 IZAT(K)    = IZAT(K+1)
      NAT = NAT - 1
  110 CONTINUE
      IF ( NTODEL .EQ. 1 ) THEN
         AL18 = ' Atom        has been deleted'
      ELSE
         AL18 = ' Atom        has been deleted, including hydrogen'
         ENDIF
      AL18 (7:12) = TEMPAT
      WRITE (9, FMT='(A78)') AL18
      IF ( EDOPT .EQ. 'DEL' ) WRITE (9, FMT='(A)')
     *   ' DEL option was used for deletion. Check your model!'
      RINGED = .FALSE.
      WRITE (24, FMT='('' $$$-edit: '', A80)') CHIN
      CALL BSCHEM
      CALL SCFRAG
      RETURN
      END
      SUBROUTINE CFREPL
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER CHOUTX*80
      CHARACTER*78  AL18
      DUSER = 0.0
      IF ( NFNUM .EQ. 1 ) DUSER = FNUM(1)
      CHOUTX = CHIN
      TEMPAT = AT2
      IF (AT2 .EQ. ' ' .OR. AT3 .EQ. ' ' .OR. NFNUM .GT. 1 .OR.
     *   AT4 .NE. ' ' ) THEN
         AL18=' Option R must be followed by two atom-names and, optionn
     *ally, a new distance'
         GOTO 500
         ENDIF
      AL18 = ' '
      AL18 (2:7) = AT2
      DO 10 I = 1, NAT
      NREP = I
      IF ( TEMPAT .EQ. ATNAME(I) ) GOTO 20
   10 CONTINUE
      AL18 (8:78) = ': unknown atom identification, nothing done'
      GOTO 500
   20 AL18 = AT3
      IF (AT2 .EQ. AT3) GOTO 26
      DO 25 I = 1, NAT
      IF ( AT3 .NE. ATNAME(I) ) GOTO 25
      AL18 (8:78) = ': atom name exists already: nothing done'
      GOTO 500
   25 CONTINUE
   26 CALL ATCHK (AT3, NLET, IZTNEW)
      IF ( IZTNEW .LE. 0 ) RETURN
      ATNAME(NREP) = AT3
      IZTDIF = IZAT(NREP) - IZTNEW
      IZAT(NREP)   = IZTNEW
      IF ( IATYP(NREP) .EQ. 2 ) GOTO 40
      IF (IZTDIF.EQ.0 .AND. NFNUM.EQ.0) GOTO 310
      AL18 =' Done. Atom is not end-of-chain: distance NOT changed !'
      IF (NFNUM .GE. 1) THEN
         WRITE (9, FMT='(A78)') AL18
         AL18 = ' Supplied distance ignored !'
         ENDIF
      GOTO 300
   40 K = IBON2( NREP, 1, 1 )
      CALL CARDIS ( ATXYZ(1,K), ATXYZ(1,NREP), DISOLD )
      IF ( DUSER .GT. 0.0001 ) THEN
         DISNEW = DUSER
      ELSE
         CALL NEWDIS (K, IZAT(NREP), DISNEW)
         ENDIF
      IF ( DISOLD .GT. 0.0001 ) THEN
         SC = DISNEW / DISOLD
      ELSE
         SC = 1.0
         ENDIF
      DO 50 I = 1,3
      ATXYZ(I,NREP) = ATXYZ(I,K) + ( ATXYZ(I,NREP) - ATXYZ(I,K) )*SC
   50 CONTINUE
      I = NLET + 1
      IF ( AT3(I:I) .EQ. ' ') THEN
         CALL ATN4C ( AT3, ATNAME, NAT, AT3)
         WRITE (9, FMT='('' Atom name for replacing element is '',
     *      A6)') AT3
         ATNAME(NREP) = AT3
         AL18 = AT3
         ENDIF
      WRITE (AL18, 60) DISNEW
   60 FORMAT (' End-of-chain atom replaced: distance is', F5.2)
  300 WRITE (9, FMT='(A78)') AL18
  310 WRITE (24, FMT='('' $$$-edit: '', A80)') CHOUTX
      CALL BSCHEM
      CALL SCFRAG
      RETURN
  500 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ATCHK (ATN, NLET, IZ)
      CHARACTER*6 ATN
      INCLUDE 'Zsyst.inc'
      CHARACTER Z *1
      CHARACTER ZZ *2
      CHARACTER*78    AL18
      AL18 = ' '
      AL18 (2:7) = ATN
      ZZ = ATN(1:2)
      CALL ATOMIZ (ZZ, NLET, IZ)
      IF (IZ .LE. 0) THEN
         AL18 (8:78) = ': incorrect atomic symbol'
         WRITE (9, FMT='(A78)') AL18
         RETURN
         ENDIF
      I = NLET + 1
      IF (ATN(I:I) .EQ. ' ') RETURN
      Z = ATN(I:I)
      CALL KERC2I (Z, NEN)
      IF (NEN.EQ.37 .OR. NEN.EQ.38) NEN = 0
      IF (NEN.EQ.45 .OR. NEN.EQ.46) NEN = 0
      IF (NEN.GE.0 .AND. NEN.LE.9) RETURN
      AL18 (8:78) = ': atomic symbol followed by illegal character'
      WRITE (9, FMT='(A78)') AL18
      IZ = -1
      RETURN
      END
      SUBROUTINE ATN4C (CHEM, ATNAME, NAT, ATNEW)
      CHARACTER*6 CHEM, ATNAME(NAT), ATNEW, CH, CT
      CT = CHEM
      IF (NAT .LE. 0) GOTO 999
      N = 3
      IF (CT(2:2) .EQ. ' ') N = 2
      II = 0
  607 II = II + 1
      CALL KERI2C (II, CH, 6)
      CT(N:6) = CH
      CALL KEREQ6 (CT, ATNAME, NAT, KEND)
      IF (KEND .GT. 0) GOTO 607
  999 ATNEW = CT
      RETURN
      END
      SUBROUTINE NEWDIS (NADD, IZAT2, DIST)
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION ARDIST (3)
      DATA ARDIST / 1.50, 1.45, 1.37 /
      CALL ZZDIST (IZAT(NADD), IZAT2, DIST )
      IF (IZAT2.LT.6 .OR. IZAT2.GT.8) RETURN
      IF (IZAT(NADD).EQ.6 .AND. IZAT2.EQ.8) DIST = 1.43
      IF (IATYP(NADD) .NE. 5) GOTO 500
      DIST = ARDIST (IZAT2 - 5)
  500 RETURN
      END
      SUBROUTINE CFUNDO
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      IF (AT2 .NE. ' ' .OR. NFNUM .NE. 0) THEN
         WRITE (9, FMT='(A)')
     *           ' Not Undone: Option U does not take any parameters'
         RETURN
         ENDIF
      WRITE (24, FMT='('' $$$-edit: '', A80)') CHIN
      DO 10 I = 1, NATSAV
      ATNAME( I ) = ATNSAV( I )
      IZAT( I )   = IZTSAV( I )
      DO 10 J = 1,3
      ATXYZ( J,I ) = XYZSAV( J,I )
   10 CONTINUE
      NAT = NATSAV
      WRITE (9, FMT='(A)') ' Previously saved model restored'
      CALL BSCHEM
      CALL SCFRAG
      RETURN
      END
      SUBROUTINE CFROTA (KEYR)
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcofr.inc'
      KEYR = 0
      IF ( NFNUM .NE. 1 .OR. NLIT .NE. 1 ) THEN
         WRITE (9,10) EDOPT(1:1)
   10    FORMAT (' Option ',A1,
     *      ' must only be followed by a rotation angle in degrees')
         RETURN
         ENDIF
      ROTANG = FNUM(1)
      IF ( ROTANG .GT. -0.9 .AND. ROTANG .LT. 0.9 ) THEN
         WRITE (9, FMT='(A)')
     *      ' Rotation less than one degree is ignored'
         RETURN
         ENDIF
      ROTANG = ROTANG/57.2957795
      CALL ROTATE ( EDOPT(1:1), ROTANG, ATXYZ, NAT )
      SCALED = .FALSE.
      CALL SCFRAG
      KEYR = 1
      RETURN
      END
      SUBROUTINE CFADD
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER CHOUTX*80
      CHARACTER*78  AL18
      CHARACTER*6 LGR(3), LHY(4)
      DATA LGR / '=O', '-NO2', '-CN' /
      DATA LHY / '$PTB$', '-L', '-P', '-T' /
      DATA AL18 /' '/
      CHOUTX = CHIN
      AFSTAN = 0.0
      IF ( NFNUM .EQ. 1 ) AFSTAN = FNUM(1)
      IF (NLIT.LE.2 .OR. NLIT.GT.4 .OR. NFNUM.GT.1) GOTO 905
      TEMPAT = AT2
      AL18 (2:7) = AT2
      DO 10 I = 1, NAT
      IF ( TEMPAT .EQ. ATNAME(I) ) GOTO 20
   10 CONTINUE
      AL18 (8:78) = ': unknown atom identification, nothing done'
      GOTO 900
   20 NAT2 = I
      IF ( IZAT(NAT2) .EQ. 1 ) THEN
         AL18 =' Nothing done: you are trying to add to a hydrogen atom'
         GOTO 500
         ENDIF
      CALL KEREQ6 (AT3, LGR, 3, KGR)
      IF (KGR .GT. 0) GOTO 300
      AL18 (2:7) = AT3
      DO 25 I = 1, NAT
      IF ( AT3 .NE. ATNAME(I) ) GOTO 25
      AL18 (8:78) = ': atom name exists already: nothing done'
      GOTO 500
   25 CONTINUE
      CALL ATCHK (AT3, NLET, IZTNEW)
      IF ( IZTNEW .LE. 0 ) GOTO 905
      KHY = 0
      IF (AT4 .EQ. ' ') GOTO 150
      CALL KEREQ6 (AT4, LHY, 4, KHY)
      IF (KHY .GT. 0) GOTO 150
      AL18 (2:7) = AT4
      AL18 (8:78) =
     *    ': unacceptable parameter for adding an atom: nothing done'
      GOTO 500
  150 CALL ATOMAD ( NAT2, IZTNEW, KHY, AFSTAN)
      GOTO 390
  300 CONTINUE
      IF (AT4 .NE. ' ') THEN
         AL18 (2:7) = AT4
         AL18 (8:78) =
     *      ': unacceptable parameter for adding a group: nothing done'
         GOTO 500
         ENDIF
      IF (NFNUM .EQ. 1) THEN
         AL18 = ' Unacceptable number supplied...: nothing done'
         GOTO 500
         ENDIF
      IF (NHADD(NAT2) .EQ. 0) THEN
         AL18 =
     *      ' Sorry: no further addition possible to this atom !'
         GOTO 500
         ENDIF
      IF (KGR .EQ. 1) CALL ADDO(NAT2)
      IF (KGR .EQ. 2) CALL ADDNO2(NAT2)
      IF (KGR .EQ. 3) CALL ADDCN(NAT2)
  390 SCALED = .FALSE.
      WRITE (24, FMT='('' $$$-edit: '', A80)') CHOUTX
      CALL BSCHEM
      CALL SCFRAG
      RETURN
  500 WRITE (9, FMT='(A78)') AL18
      RETURN
  900 WRITE (9, FMT='(A78)') AL18
  905 WRITE (9, 910)
  910 FORMAT ('       Please, try again. Syntax for option A:'/
     * ' A At1 At2 (Hy): Add one or more atoms to atom At1,'/
     * '       AT2 : atom or element to be added;'/
     * '       Hy: can be -T or -P or -L (specify literally) for'/
     * '           tetrahedral (sp3), planar (sp2) or linear (sp)'/
     * ' A At1 Gr : Add one specific group to (carbon) atom At1,'/
     * '       Gr : can be =O or -NO2 or -CN (specify literally)')
      RETURN
      END
      SUBROUTINE ATOMAD ( NATADD, IZT, NHYBR, AFSTAN)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78 AL18
      IF ( NHYBR .EQ. 0 .AND. NHADD(NATADD) .EQ. 0 ) THEN
         AL18 = ' No further addition possible to this atom'
         GOTO 500
         ENDIF
      IF ( NBATOM(NATADD) .EQ. 1 ) THEN
         IF ( NHYBR .EQ. 0 ) THEN
            IF ( IBTYP( IBON2(NATADD,1,2) ) .EQ. 1 )
     *         CALL ADDSP3 ( NATADD, IZT, 3, AFSTAN)
            IF ( IBTYP( IBON2(NATADD,1,2) ) .EQ. 2 )
     *         CALL ADDSP2 ( NATADD, IZT, 2, AFSTAN )
            IF ( IBTYP( IBON2(NATADD,1,2) ) .EQ. 3 )
     *         CALL ADDSP1  ( NATADD, IZT, AFSTAN )
         ELSEIF ( NHYBR .EQ. 4 ) THEN
            CALL ADDSP3 ( NATADD, IZT, 3, AFSTAN )
         ELSEIF ( NHYBR .EQ. 3 ) THEN
            CALL ADDSP2 ( NATADD, IZT, 2, AFSTAN )
         ELSEIF ( NHYBR .EQ. 2 ) THEN
            CALL ADDSP1  ( NATADD, IZT, AFSTAN )
            ENDIF
      ELSEIF ( NBATOM(NATADD) .EQ. 2 ) THEN
         IF ( NHYBR .EQ. 0 ) THEN
               IF ( IBTYP( IBON2(NATADD,1,2) ) .EQ. 1 .AND.
     *           IBTYP( IBON2(NATADD,2,2) ) .EQ. 1 )
     *           CALL ADDSP3 ( NATADD, IZT, 2, AFSTAN )
            IF ( IBTYP( IBON2(NATADD,1,2) ) .EQ. 1 .AND.
     *           IBTYP( IBON2(NATADD,2,2) ) .EQ. 2 )
     *           CALL ADDSP2 ( NATADD, IZT, 1, AFSTAN )
            IF ( IBTYP( IBON2(NATADD,1,2) ) .EQ. 2 .AND.
     *           IBTYP( IBON2(NATADD,2,2) ) .EQ. 1 )
     *           CALL ADDSP2 ( NATADD, IZT, 1, AFSTAN )
            IF ( IBTYP( IBON2(NATADD,1,2) ) .EQ. 5 .AND.
     *           IBTYP( IBON2(NATADD,2,2) ) .EQ. 5 )
     *           CALL ADDSP2 ( NATADD, IZT, 1, AFSTAN )
         ELSEIF ( NHYBR .EQ. 4 ) THEN
            CALL ADDSP3 ( NATADD, IZT, 2, AFSTAN )
         ELSEIF ( NHYBR .EQ. 3 ) THEN
            CALL ADDSP2 ( NATADD, IZT, 1, AFSTAN )
         ELSE
            AL18 = ' No sp hybridization possible on this atom'
            GOTO 500
            ENDIF
      ELSEIF ( NBATOM(NATADD) .EQ. 3 ) THEN
         IF ( NHYBR .EQ. 0 .OR. NHYBR .EQ. 4 ) THEN
            CALL ADDSP3 ( NATADD, IZT, 1, AFSTAN )
         ELSE
            AL18 = ' Only sp3 hybridization possible on this atom'
            GOTO 500
            ENDIF
      ELSE
         AL18 = ' Zero or more than 3 bonds already; no addition'
         GOTO 500
         ENDIF
      RETURN
  500 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ADDSP3 ( NATADD, IZT, NADD, AFSTAN )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       X(3), X1(3), X2(3), X3(3), X4(3), NPRV(3)
      IF ( NADD .EQ. 1 ) THEN
         NATPRV = IBON2 ( NATADD, 1, 1 )
         CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X1 )
         NATPRV = IBON2 ( NATADD, 2, 1 )
         CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X2 )
         NATPRV = IBON2 ( NATADD, 3, 1 )
         CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X3 )
         CALL VECAPB ( X1, X2, X4 )
         CALL VECAPB ( X4, X3, X  )
         CALL VECLEN ( X, DISOLD )
         DISNEW = AFSTAN
         IF ( DISNEW .LT. 0.01) CALL NEWDIS (NATADD, IZT, DISNEW)
         IF ( DISOLD .GT. 0.0001 ) THEN
            SC = DISNEW / DISOLD
            CALL VECSCL ( X, SC )
            ENDIF
         CALL ATN4A (AT3, ATNAME, NAT, AT4)
         NAT = NAT + 1
         CALL VECAPB ( ATXYZ(1,NATADD), X, ATXYZ(1,NAT) )
         CALL CARDIS ( ATXYZ(1,NATADD), ATXYZ(1,NAT), DISNEW )
         IZAT(NAT) = IZT
         ATNAME(NAT) = AT4
         WRITE (9, 111) AT4, ATNAME(NATADD), DISNEW
  111    FORMAT (' Atom ',A6,'added to ',A6,'in sp3; dist =', F6.3)
      ELSEIF ( NADD .EQ. 2 ) THEN
         NATPRV = IBON2 ( NATADD, 1, 1 )
         CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X1 )
         NATPRV = IBON2 ( NATADD, 2, 1 )
         CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X2 )
         CALL VECAPB ( X1, X2, X )
         CALL VECLEN ( X, VLEN1 )
         CALL VECAXB ( X1, X2, X4 )
         CALL VECLEN ( X4, VLEN2 )
         SC = VLEN1 / ( 0.71329228 * VLEN2 )
         CALL VECSCL ( X4, SC )
         CALL VECAPB ( X, X4, X1 )
         CALL VECAMB ( X, X4, X2 )
         CALL VECLEN ( X1, DISOLD )
         DISNEW = AFSTAN
         IF ( DISNEW .LT. 0.1 ) CALL NEWDIS (NATADD, IZT, DISNEW)
         IF ( DISOLD .GT. 0.0001 ) THEN
            SC = DISNEW / DISOLD
            CALL VECSCL ( X1, SC )
            CALL VECSCL ( X2, SC )
            ENDIF
         CALL ATN4A (AT3, ATNAME, NAT, AT4)
         NAT = NAT + 1
         CALL VECAPB ( ATXYZ(1,NATADD), X1, ATXYZ(1,NAT) )
         IZAT(NAT) = IZT
         ATNAME(NAT) = AT4
         CALL ATN4A (AT3, ATNAME, NAT, AT4)
         NAT = NAT + 1
         CALL VECAPB ( ATXYZ(1,NATADD), X2, ATXYZ(1,NAT) )
         IZAT(NAT) = IZT
         ATNAME(NAT) = AT4
         CALL CARDIS ( ATXYZ(1,NATADD), ATXYZ(1,NAT), DISNEW )
         WRITE (9, 122) ATNAME(NAT-1), AT4, ATNAME(NATADD), DISNEW
  122    FORMAT (' Atoms ',A6,'and ',A6,'added to ',A6,
     *           ' in sp3; dist =',F6.3)
      ELSEIF ( NADD .EQ. 3 ) THEN
         NATPRV = IBON2 ( NATADD, 1, 1 )
         IF ( NBATOM(NATADD) .EQ. 1 .AND. IHTYP(NATPRV) .EQ. 4 .AND.
     *        NBATOM(NATPRV) .EQ. 4 ) THEN
            J = 0
            DO 10 I = 1, 4
               IF ( IBON2( NATPRV, I, 1 ) .EQ. NATADD ) GOTO 10
               J = J + 1
               NPRV(J) = IBON2 ( NATPRV, I, 1 )
   10       CONTINUE
            CALL VECAMB ( ATXYZ(1,NATPRV), ATXYZ(1,NPRV(1)), X1 )
            CALL VECAMB ( ATXYZ(1,NATPRV), ATXYZ(1,NPRV(2)), X2 )
            CALL VECAMB ( ATXYZ(1,NATPRV), ATXYZ(1,NPRV(3)), X3 )
            CALL VECLEN ( X1, DISOLD )
            DISNEW = AFSTAN
            IF ( DISNEW .LT. 0.1 )
     *         CALL NEWDIS (NATADD, IZT, DISNEW)
            IF ( DISOLD .GT. 0.0001 ) THEN
               SC = DISNEW / DISOLD
               CALL VECSCL ( X1, SC )
               ENDIF
            CALL VECLEN ( X2, DISOLD )
            DISNEW = AFSTAN
            IF ( DISNEW .LT. 0.1 )
     *         CALL NEWDIS (NATADD, IZT, DISNEW)
            IF ( DISOLD .GT. 0.0001 ) THEN
               SC = DISNEW / DISOLD
               CALL VECSCL ( X2, SC )
               ENDIF
            CALL VECLEN ( X3, DISOLD )
            DISNEW = AFSTAN
            IF ( DISNEW .LT. 0.1 )
     *         CALL NEWDIS (NATADD, IZT, DISNEW)
            IF ( DISOLD .GT. 0.0001 ) THEN
               SC = DISNEW / DISOLD
               CALL VECSCL ( X3, SC )
               ENDIF
            CALL ATN4A (AT3, ATNAME, NAT, AT4)
            NAT = NAT + 1
            CALL VECAPB ( ATXYZ(1,NATADD), X1, ATXYZ(1,NAT) )
            IZAT(NAT) = IZT
            ATNAME(NAT) = AT4
            CALL ATN4A (AT3, ATNAME, NAT, AT4)
            NAT = NAT + 1
            CALL VECAPB ( ATXYZ(1,NATADD), X2, ATXYZ(1,NAT) )
            IZAT(NAT) = IZT
            ATNAME(NAT) = AT4
            AL(18) (10:15) = AT4
            CALL ATN4A (AT3, ATNAME, NAT, AT4)
            NAT = NAT + 1
            CALL VECAPB ( ATXYZ(1,NATADD), X3, ATXYZ(1,NAT) )
            IZAT(NAT) = IZT
            ATNAME(NAT) = AT4
            CALL CARDIS ( ATXYZ(1,NATADD), ATXYZ(1,NAT), DISNEW )
            WRITE (9, 133) ATNAME(NAT-2),
     *          ATNAME(NAT-1), AT4, ATNAME(NATADD), DISNEW
  133       FORMAT (' Atoms ',A6,', ',A6,'and ',A6, 'added to ',A6 /
     *         ' Atoms added in staggered conformation at dist =',F6.3)
         ELSE
            WRITE (9, FMT='(A)')
     *            ' Undetermined sp3 orientation, no addition'
            ENDIF
         ENDIF
      RINGED = .FALSE.
      RETURN
      END
      SUBROUTINE ADDSP2 ( NATADD, IZT, NADD, AFSTAN )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       X(3), X1(3), X2(3), NPRV(2)
      DIMENSION DBDIST(3)
      DATA DBDIST / 1.33, 1.30, 1.23 /
      IF ( NADD .EQ. 1 ) THEN
         NATPRV = IBON2 ( NATADD, 1, 1 )
         CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X1 )
         NATPRV = IBON2 ( NATADD, 2, 1 )
         CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X2 )
         CALL VECAPB ( X1, X2, X )
         CALL VECLEN ( X, DISOLD )
         DISNEW = AFSTAN
         IF (DISNEW .LT. 0.1 .AND. IZAT(NATADD).EQ.6 .AND.
     *      IZT.GE.6 .AND. IZT.LE.8) THEN
            CALL VECLEN (X1, DIST1)
            CALL VECLEN (X2, DIST2)
            IF (DIST1.GT.1.43 .AND. DIST2.GT.1.43) DISNEW=DBDIST(IZT-5)
            ENDIF
         IF ( DISNEW .LT. 0.1 ) CALL NEWDIS (NATADD, IZT, DISNEW)
         IF ( DISOLD .GT. 0.0001 ) THEN
            SC = DISNEW / DISOLD
            CALL VECSCL ( X, SC )
            ENDIF
         CALL ATN4A (AT3, ATNAME, NAT, AT4)
         NAT = NAT + 1
         CALL VECAPB ( ATXYZ(1,NATADD), X, ATXYZ(1,NAT) )
         CALL CARDIS ( ATXYZ(1,NATADD), ATXYZ(1,NAT), DISNEW )
         IZAT(NAT) = IZT
         ATNAME(NAT) = AT4
         WRITE (9, 111) AT4, ATNAME(NATADD), DISNEW
  111    FORMAT (' Atom ',A6,'added to ',A6,'in sp2; dist =', F6.3)
         IF (DISNEW .LT. 0.1) THEN
            NAT = NAT - 1
            WRITE (9, FMT='(A)')
     *        ' No!! Error: new atom rejected because of bad geometry !'
            ENDIF
      ELSEIF ( NADD .EQ. 2 ) THEN
         NATPRV = IBON2 ( NATADD, 1, 1 )
         IF ( NBATOM(NATADD) .EQ. 1 .AND. IHTYP(NATPRV) .EQ. 3 .AND.
     *        NBATOM(NATPRV) .EQ. 3 ) THEN
            J = 0
            DO 10 I = 1, 3
               IF ( IBON2( NATPRV, I, 1 ) .EQ. NATADD ) GOTO 10
               J = J + 1
               NPRV(J) = IBON2 ( NATPRV, I, 1 )
   10       CONTINUE
            CALL VECAMB ( ATXYZ(1,NATPRV), ATXYZ(1,NPRV(1)), X1 )
            CALL VECAMB ( ATXYZ(1,NATPRV), ATXYZ(1,NPRV(2)), X2 )
            CALL VECLEN ( X1, DISOLD )
            DISNEW = AFSTAN
            IF ( DISNEW .LT. 0.1 )
     *         CALL NEWDIS (NATADD, IZT, DISNEW)
            IF ( DISOLD .GT. 0.0001 ) THEN
               SC = DISNEW / DISOLD
               CALL VECSCL ( X1, SC )
               ENDIF
            CALL VECLEN ( X2, DISOLD )
            DISNEW = AFSTAN
            IF ( DISNEW .LT. 0.1 )
     *         CALL NEWDIS (NATADD, IZT, DISNEW)
            IF ( DISOLD .GT. 0.0001 ) THEN
               SC = DISNEW / DISOLD
               CALL VECSCL ( X2, SC )
               ENDIF
            CALL ATN4A (AT3, ATNAME, NAT, AT4)
            NAT = NAT + 1
            CALL VECAPB ( ATXYZ(1,NATADD), X1, ATXYZ(1,NAT) )
            IZAT(NAT) = IZT
            ATNAME(NAT) = AT4
            CALL ATN4A (AT3, ATNAME, NAT, AT4)
            NAT = NAT + 1
            CALL VECAPB ( ATXYZ(1,NATADD), X2, ATXYZ(1,NAT) )
            IZAT(NAT) = IZT
            ATNAME(NAT) = AT4
            CALL CARDIS ( ATXYZ(1,NATADD), ATXYZ(1,NAT), DISNEW )
            WRITE (9, 122) ATNAME(NAT-1), AT4, ATNAME(NATADD), DISNEW
  122       FORMAT (' Atoms ',A6,'and ',A6,'added to ',A6,
     *           'in planar conformation, dist =',F6.3)
         ELSE
            WRITE (9, FMT='(A)')
     *            ' Undetermined sp2 orientation, no addition'
            ENDIF
         ENDIF
      RINGED = .FALSE.
      RETURN
      END
      SUBROUTINE ADDSP1 ( NATADD, IZT, AFSTAN )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       X(3)
      NATPRV = IBON2 ( NATADD, 1, 1 )
      CALL VECAMB ( ATXYZ(1,NATADD), ATXYZ(1,NATPRV), X )
      CALL VECLEN ( X, DISOLD )
      DISNEW = AFSTAN
      IF ( DISNEW .LT. 0.1 ) CALL NEWDIS (NATADD, IZT, DISNEW)
      IF ( DISOLD .GT. 0.0001 ) THEN
         SC = DISNEW / DISOLD
         CALL VECSCL ( X, SC )
         ENDIF
      CALL ATN4A (AT3, ATNAME, NAT, AT4)
      NAT = NAT + 1
      CALL VECAPB ( ATXYZ(1,NATADD), X, ATXYZ(1,NAT) )
      CALL CARDIS ( ATXYZ(1,NATADD), ATXYZ(1,NAT), DISNEW )
      IZAT(NAT) = IZT
      ATNAME(NAT) = AT4
      WRITE (9, 111) AT4, ATNAME(NATADD), DISNEW
  111 FORMAT (' Atom ',A6,'added to ',A6,
     *     'in linear conformation; dist =', F6.3)
      RETURN
      END
      SUBROUTINE ATN4A (ATN, ATNAME, NAT, ATNEW)
      CHARACTER*6 ATN, ATNAME(NAT), ATNEW, CT, CH
      CHARACTER ZZ *2
      CT = ATN
      IF (NAT .LE. 0) GOTO 999
      ZZ = ATN(1:2)
      CALL ATOMIZ (ZZ, NLET, IZ)
      N = NLET + 1
  101 IF (ATN(N:N) .EQ. ' ') THEN
         CALL ATN4C (ATN, ATNAME, NAT, ATNEW)
         RETURN
         ENDIF
      DO 111 N = 6, 1, -1
      IF (ATN(N:N) .NE. ' ') GOTO 113
  111 CONTINUE
  113 N = N + 1
      IF (N .GT. 5) N = 5
      II = 0
  607 CONTINUE
      CALL KEREQ6 (CT, ATNAME, NAT, KEND)
      IF (KEND .LE. 0) GOTO 999
      II = II + 1
      CALL KERI2C (II, CH, 3)
      CT(N:6) = CH(1:3)
      IF (N.LT.5 .OR. II.LT.99) GOTO 607
      ATN = 'C '
      N = 2
      GOTO 101
  999 ATNEW = CT
      RETURN
      END
      SUBROUTINE ADDO ( NATADD )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78 AL18
      DCO = 1.23
      IF ( IZAT(NATADD) .NE. 6 ) WRITE (9, FMT='(A)')
     *      ' Warning: addition of =O to a non-carbon atom !'
      IF ( NHADD(NATADD) .LT. 2 ) THEN
         AL18 = ' No addition: =O requires at least 2 ''free'' orbitals'
         GOTO 900
         ENDIF
      IF ( NHADD(NATADD) .GT. 2 ) THEN
         AL18 = ' Indeterminate position for =O, no addition'
         GOTO 900
         ENDIF
      NELJS = 8
      NADJS = 1
      AT3 = 'O'
      IF ( IHTYP(NATADD) .EQ. 2 ) THEN
         CALL ADDSP1 ( NATADD, NELJS, DCO )
      ELSEIF ( IHTYP(NATADD) .EQ. 3 .OR.IHTYP(NATADD) .EQ. 4 ) THEN
         CALL ADDSP2 ( NATADD, NELJS, NADJS, DCO )
      ELSE
         AL18 = ' Atom has undetermined hybridization, no addition'
         GOTO 900
         ENDIF
      RETURN
  900 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ADDNO2 ( NATADD )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78 AL18
      DCN = 1.47
      DNO = 1.22
      IF ( IZAT(NATADD) .NE. 6 ) WRITE (9, FMT='(A)')
     *      ' Warning: addition of -NO2 to a non-carbon atom !'
      IF ( NHADD(NATADD) .LT. 1 ) THEN
         AL18 =
     *   ' No addition of -NO2: it requires at least 1 ''free'' orbital'
         GOTO 900
         ENDIF
      IF ( NHADD(NATADD) .GT. 1 ) THEN
         AL18 =
     *      ' Indeterminate position for -NO2, no addition'
         GOTO 900
         ENDIF
      NELJS = 7
      NADJS = 1
      AT3 = 'N'
      IF      ( IHTYP(NATADD) .EQ. 2 ) THEN
         CALL ADDSP1  ( NATADD, NELJS, DCN )
      ELSEIF ( IHTYP(NATADD) .EQ. 3 ) THEN
         CALL ADDSP2 ( NATADD, NELJS, NADJS, DCN )
      ELSEIF ( IHTYP(NATADD) .EQ. 4 ) THEN
         CALL ADDSP3 ( NATADD, NELJS, NADJS, DCN )
      ELSE
         WRITE (9, FMT='(A)')
     *      ' Atom has undetermined hybridization, no addition'
         GOTO 900
         ENDIF
      RINGED = .FALSE.
      CALL BSCHEM
      NATADD = NAT
      NELJS = 8
      NADJS = 2
      NATOLD = NAT
      AT3 = 'O'
      CALL ADDSP2 ( NATADD, NELJS, NADJS, DNO )
      IF (NAT .LE. NATOLD) THEN
         AL18 = ' Undetermined oxygen positions, only nitrogen added'
      ELSE
         AL18 = ' Oxygens added to nitrogen in planar configuration'
         ENDIF
      RINGED = .FALSE.
  900 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ADDCN ( NATADD )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78 AL18
      DATA AL18 /' '/
      DCC = 1.50
      DCN = 1.16
      IF ( IZAT(NATADD) .NE. 6 ) WRITE (9, FMT='(A)')
     *      'Warning: addition of -CN to a non-carbon atom !'
      IF ( NHADD(NATADD) .LT. 1 ) THEN
         AL18 =
     *    ' No addition of -CN: it requires at least 1 ''free'' orbital'
         GOTO 900
         ENDIF
      IF ( NHADD(NATADD) .GT. 1 ) THEN
         AL18 =
     *      ' Indeterminate position for -CN, no addition'
         GOTO 900
         ENDIF
      NELJS = 6
      NADJS = 1
      AT3 = 'C'
      IF      ( IHTYP(NATADD) .EQ. 2 ) THEN
         CALL ADDSP1  ( NATADD, NELJS, DCC )
      ELSEIF ( IHTYP(NATADD) .EQ. 3 ) THEN
         CALL ADDSP2 ( NATADD, NELJS, NADJS, DCC )
      ELSEIF ( IHTYP(NATADD) .EQ. 4 ) THEN
         CALL ADDSP3 ( NATADD, NELJS, NADJS, DCC )
      ELSE
         AL18 (2:7) = AT3
         AL18(8:78) = ': undetermined hybridization, no addition'
         GOTO 900
         ENDIF
      RINGED = .FALSE.
      CALL BSCHEM
      NATADD = NAT
      NELJS = 7
      AT3 = 'N'
      CALL ADDSP1  ( NATADD, NELJS, DCN )
      RINGED = .FALSE.
      RETURN
  900 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE CFFUSE
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78 AL18
      DIMENSION DELTA(3)
      DATA PI / 3.1415926535 /
      IF ( AT2 .EQ. ' ' .OR. AT3 .EQ. ' ' .OR. AT4 .NE. ' '
     *                  .OR. NFNUM .NE. 1 ) THEN
         AL18 = ' F must be followed by two atom names and one number'
         GOTO 200
         ENDIF
      ISIZE = FNUM(1) + 0.01
      IF ( ISIZE .LE. 4 .OR. ISIZE .GE. 7 ) THEN
         AL18 = ' Nothing done. Ring size must be 5 or 6'
         GOTO 200
         ENDIF
      DO 10 I = 1, NAT
      NR1 = I
      IF ( AT2 .EQ. ATNAME(I) ) GOTO 20
   10 CONTINUE
      AL18 = '       : Unknown first atom identification'
      AL18 (2:7) = AT2
      GOTO 200
   20 DO 30 I = 1, NAT
      NR2 = I
      IF ( AT3 .EQ. ATNAME(I) ) GOTO 40
   30 CONTINUE
      AL18 = '       : Unknown second atom identification'
      AL18 (2:7) = AT3
      GOTO 200
   40 IF ( IATYP( NR1 ) .NE. 5 ) THEN
         AL18 = '       : first atom is not in an aromatic ring'
         AL18 (2:7) = AT2
         GOTO 200
         ENDIF
      IF ( IATYP( NR2 ) .NE. 5 ) THEN
         AL18 = '       : second atom is not in an aromatic ring'
         AL18 (2:7) = AT3
         GOTO 200
         ENDIF
      IF ( NR1 .EQ. NR2 ) THEN
         AL18 = ' The two atoms are identical'
         GOTO 200
         ENDIF
      DO 50 I = 1, NBATOM( NR1 )
         IF ( IBON2( NR1,I,1 ) .EQ. NR2 ) GOTO 60
   50 CONTINUE
      AL18 = ' The two atoms are not bonded to each other'
      GOTO 200
   60 IF ( IBTYP (IBON2( NR1,I,2 )) .EQ. 5 ) GOTO 65
      AL18 = ' The bond between these two atoms is not aromatic'
      GOTO 200
   65 DAB = BONDIS( IBON2( NR1,I,2 ) )
      DO 90 I = 1, NRING
      N = RINGAT(1,I)
      DO 80 J = 1, N
      IF ( NINT(RINGAT(1+J,I)) .EQ. NR1 ) THEN
         DO 70 K = 1, N
         IF ( NINT(RINGAT(1+K,I)) .EQ. NR2 ) GOTO 100
   70    CONTINUE
         GOTO 90
         ENDIF
   80 CONTINUE
   90 CONTINUE
      AL18 = ' No aromatic ring found with these two atoms in it'
      GOTO 200
  100 DO 110 K = 1, N
      NR3 = RINGAT(1+K,I)
      IF ( NR3 .NE. NR1 .AND. NR3 .NE. NR2 ) GOTO 120
  110 CONTINUE
      AL18 = ' No suitable third atom found in the same ring'
      GOTO 200
  120 DO 130 I = 1, 3
  130 DELTA(I) = ATXYZ(I,NR1)
      DO 140 I = 1, NAT
      DO 140 J = 1, 3
  140 ATXYZ(J,I) = ATXYZ(J,I) - DELTA(J)
      WRITE (24, FMT='('' $$$-edit: '', A80)') CHIN
      CALL DETANG ( ATXYZ(2,NR2), ATXYZ(1,NR2), ANG1 )
      CALL ROTATE ( 'Z', ANG1, ATXYZ, NAT )
      CALL DETANG ( ATXYZ(1,NR2), ATXYZ(3,NR2), ANG2 )
      CALL ROTATE ( 'Y', ANG2-0.5*PI, ATXYZ, NAT )
      CALL DETANG ( ATXYZ(3,NR3), ATXYZ(2,NR3), ANG3 )
      CALL ROTATE ( 'X', ANG3, ATXYZ, NAT )
      IF ( ISIZE .EQ. 5 ) CALL FUSE5 ( NR1, NR2, DAB )
      IF ( ISIZE .EQ. 6 ) CALL FUSE6 ( NR1, NR2, DAB )
      CALL ROTATE ( 'X', -ANG3, ATXYZ, NAT )
      CALL ROTATE ( 'Y', -ANG2+0.5*PI, ATXYZ, NAT )
      CALL ROTATE ( 'Z', -ANG1, ATXYZ, NAT )
      DO 150 I = 1, NAT
      DO 150 J = 1, 3
  150 ATXYZ(J,I) = ATXYZ(J,I) + DELTA(J)
      SCALED = .FALSE.
      RINGED = .FALSE.
      CALL BSCHEM
      CALL SCFRAG
      RETURN
  200 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE FUSE5 ( NR1, NR2, DIST )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       ATNEW(3,3)
      CHARACTER*6     NEWATS(3)
      DATA RAD        / 57.2957795 /
      P = DIST * SIN ( 18.0 / RAD )
      Q = DIST * COS ( 18.0 / RAD )
      R = DIST * SIN ( 36.0 / RAD )
      NATOLD = NAT
      DIST5 = 1.420
      NATOLD = NAT
      SHIFT = ( DIST5 - DIST ) / 2.0
      DO 5 I = 1, NATOLD
         ATXYZ(1,I) = ATXYZ(1,I) + SHIFT
    5 CONTINUE
      ATXYZ(1,NR1) = ATXYZ(1,NR1) / 2.0
      ATXYZ(1,NR2) = ( ATXYZ(1,NR2) + DIST5 ) / 2.0
      ATNEW(1,1) = -P
      ATNEW(2,1) = -Q
      ATNEW(3,1) =  0.0
      ATNEW(1,2) =  0.5 * DIST5
      ATNEW(2,2) = -Q-R
      ATNEW(3,2) =  0.0
      ATNEW(1,3) =  DIST5 + P
      ATNEW(2,3) = -Q
      ATNEW(3,3) =  0.0
      IZT = 6
      TEMPAT = 'C'
      NADD = 0
      DO 30 I = 1, 3
      DON =0.0
      DO 10 J = 1, NATOLD
      CALL CARDIS ( ATNEW(1,I), ATXYZ(1,J), DON )
      IF ( DON .LT. 0.4 ) THEN
         DO 15 K = 1, 3
         ATXYZ(K,J) = ( ATXYZ(K,J) + ATNEW(K,I) ) / 2.0
   15    CONTINUE
         WRITE (9, FMT='(A)')
     *      ' Warning, at least one original atom merged with new one'
         GOTO 30
         ENDIF
   10 CONTINUE
      CALL ATN4A (TEMPAT, ATNAME, NAT, AT4)
      NAT = NAT+1
      NADD = NADD + 1
      DO 20 K = 1, 3
   20 ATXYZ(K,NAT) = ATNEW(K,I)
      IZAT(NAT) = IZT
      ATNAME(NAT) = AT4
      NEWATS(NADD) = AT4
      IF ( DON .LT. 0.9 ) WRITE (9, FMT='(A)')
     *   ' Warning, at least one atom added with some distance .LT. 0.9'
   30 CONTINUE
      IF ( NADD .NE. 0 ) THEN
         WRITE (9, FMT='('' 5-membered aromatic ring added, '',
     *      ''  new atoms:'' / 6(1X, A6))') (NEWATS(I), I=1,NADD)
      ELSE
         WRITE (9, FMT='(A)')
     *      ' All (new) atoms will overlap, no atoms added'
         ENDIF
      RETURN
      END
      SUBROUTINE FUSE6 ( NR1, NR2, DIST )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       ATNEW(3,4)
      CHARACTER*6     NEWATS(4)
      DIST6 = 1.395
      SQ3 = SQRT( 3.0 )
      NATOLD = NAT
      SHIFT = ( DIST6 - DIST ) / 2.0
      DO 5 I = 1, NATOLD
      ATXYZ(1,I) = ATXYZ(1,I) + SHIFT
    5 CONTINUE
      ATXYZ(1,NR1) = ATXYZ(1,NR1) / 2.0
      ATXYZ(1,NR2) = ( ATXYZ(1,NR2) + DIST6 ) / 2.0
      ATNEW(1,1) = -0.5 * DIST6
      ATNEW(2,1) = -0.5 * SQ3 * DIST6
      ATNEW(3,1) =  0.0
      ATNEW(1,2) =  0.0
      ATNEW(2,2) = -SQ3 * DIST6
      ATNEW(3,2) =  0.0
      ATNEW(1,3) =  DIST6
      ATNEW(2,3) = -SQ3 * DIST6
      ATNEW(3,3) =  0.0
      ATNEW(1,4) =  1.5 * DIST6
      ATNEW(2,4) = -0.5 * SQ3 * DIST6
      ATNEW(3,4) =  0.0
      IZT = 6
      TEMPAT = 'C'
      NADD = 0
      DO 30 I = 1, 4
      DON =0.0
      DO 10 J = 1, NATOLD
      CALL CARDIS ( ATNEW(1,I), ATXYZ(1,J), DON )
      IF ( DON .LT. 0.4 ) THEN
         DO 15 K = 1, 3
         ATXYZ(K,J) = ( ATXYZ(K,J) + ATNEW(K,I) ) / 2.0
   15    CONTINUE
         WRITE (9, FMT='(A)')
     *      ' Warning, at least one original atom merged with new one'
         GOTO 30
         ENDIF
   10 CONTINUE
      CALL ATN4A (TEMPAT, ATNAME, NAT, AT4)
      NAT = NAT+1
      NADD = NADD + 1
      DO 20 K = 1, 3
   20 ATXYZ(K,NAT) = ATNEW(K,I)
      IZAT(NAT) = IZT
      ATNAME(NAT) = AT4
      NEWATS(NADD) = AT4
      IF ( DON .LT. 0.9 ) WRITE (9, FMT='(A)')
     *   ' Warning, at least one atom added with some distance .LT. 0.9'
   30 CONTINUE
      IF ( NADD .NE. 0 ) THEN
         WRITE (9, FMT='('' 6-membered aromatic ring added, '',
     *      ''  new atoms:'' / 6(1X, A6))') (NEWATS(I), I=1,NADD)
      ELSE
         WRITE (9, FMT='(A)')
     *       ' All (new) atoms will overlap, no atoms added'
         ENDIF
      RETURN
      END
      SUBROUTINE CFGEOM
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       ANGLES(10)
      CHARACTER*78 AL18
      TEMPAT = AT2
      IF (AT2 .EQ. ' ' .OR. NFNUM .NE. 0) THEN
         AL18 = ' G must be followed by one atom-name only'
         GOTO 500
         ENDIF
      IF (AT3 .NE. ' ') THEN
         AL18 = ' Option G must be followed by one atom-name only'
         GOTO 500
      ENDIF
      DO 10 I = 1, NAT
         NR = I
         IF ( TEMPAT .EQ. ATNAME(I) ) GOTO 20
   10 CONTINUE
      AL18 = '       : Unknown atom identification'
      AL18 (2:7) = TEMPAT
      GOTO 500
   20 NB = NBATOM(NR)
      IF (NB .EQ. 0 ) THEN
         AL18 = ' No bonds to atom       '
         AL18 (19:24) = TEMPAT
         GOTO 500
         ENDIF
      WRITE (9, FMT='(1X, A6, ''is bonded to: '', 10A6)')
     *   TEMPAT,  (ATNAME(IBON2(NR,I,1)),I=1,NB)
      WRITE (9, FMT='('' with distances:  '', 10F6.3)')
     *    (BONDIS(IBON2(NR,I,2)),I=1,NB)
      IF ( NB .EQ. 1 ) THEN
         AL18 = ' No angles on this atom'
         GOTO 500
         ENDIF
      NA = 0
      DO 60 I1 = 1, NB-1
      DO 50 I2 = I1+1, NB
      IF ( NA .EQ. 11 ) GOTO 70
      NA = NA + 1
      CALL CALANG
     *   ( NR, IBON2(NR,I1,1), IBON2(NR,I2,1), ANGLES(NA) )
   50 CONTINUE
   60 CONTINUE
   70 IF ( NA .GE. 11) THEN
         AL18 = 'First 10 angles: '
         NA = 10
      ELSE
         AL18 = '      and angles: '
         ENDIF
      WRITE (AL18(19:78), FMT='(10F6.1)') (ANGLES(J),J=1,NA)
  500 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE CFEXIT ( KEY )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      CHARACTER*78 AL18, AL17X, AL18X, AL1X
      AL17X = ' Is this final result acceptable?  Answer Y or N (or H)!'
      AL18X = ' ( If the answer is Y , the model is going to be used !)'
      AL1X  = ' Hydrogen atoms removed'
      IF (AT2 .NE. ' ' .OR. NFNUM .NE. 0) THEN
         AL18 = ' ? option E or Q does not take any parameters'
         KEY = 2
         GOTO 500
         ENDIF
      KEY = 0
      L = 0
      DO 10 K = 1, NAT
      IF (IZAT(K) .EQ. 1) GOTO 10
      L = L + 1
      IF (K .EQ. L) GOTO 10
      ATNAME(L)  = ATNAME(K)
      ATXYZ(1,L) = ATXYZ(1,K)
      ATXYZ(2,L) = ATXYZ(2,K)
      ATXYZ(3,L) = ATXYZ(3,K)
      IZAT(L)    = IZAT(K)
   10 CONTINUE
      WRITE (24, FMT='('' $$$-edit: '', A80)') CHIN
         AL(15) = ' '
         AL(16) = ' '
         AL(17) = AL17X
         AL(18) = AL18X
         AL(19) = ' '
      NATDIF = NAT - L
      IF (NATDIF .NE. 0) THEN
         WRITE (9, FMT='(A78)') AL1X
         NAT = L
         CALL SCFRAG
         CALL XFLUSH
      ELSE
         WRITE (9, FMT='(A78/A78)') AL17X, AL18X
         ENDIF
   20 CALL WININP (CHIN)
      IF (CHIN .EQ. ' ') GOTO 60
      CALL KERINB (LIT, 1)
      IF ( NLIT .LE. 0 ) GOTO 60
      ANSWER = LIT(1)(1:1)
      IF ( ANSWER .EQ. 'Y') THEN
         WRITE (24, FMT='('' $$$-edit: Q OK'')')
         RETURN
         ENDIF
   40 IF ( ANSWER .EQ. 'N') GOTO 70
      IF ( ANSWER.EQ.'H' .OR. ANSWER.EQ. ' ') THEN
         IF (ANSWER .EQ. 'H') WRITE (9, FMT='(A)')
     *       ' H: Repaint present fragment:'
         CALL XFLUSH
         GOTO 20
         ENDIF
      WRITE (9, FMT='(A)')
     * ' Illegal answer, please enter Y or N (or H to repaint fragment)'
      WRITE (9, FMT='(A78/A78)') AL17X, AL18X
      GOTO 20
   60 ANSWER = ' '
      GOTO 40
   70 WRITE(9, 80)
   80 FORMAT (
     * ' FRED  simple  FRagment EDitor : Exit/Quit ?  enter A B C :'/
     * ' C : Continue .... we forgot something : let us go on .....'/
     * ' B : Bad results .... bad model .... let us stop completely'/
     * ' A : Another model ? let us try (another) entry from ORBASE')
      CALL WININP (CHIN)
      CALL KERINB (LIT, 1)
      IF (NLIT .EQ. 1) GOTO 120
  100 WRITE(9, FMT='(A)')
     * ' Illegal answer, you must answer A B or C :'
      GOTO 70
  120 IF (LIT(1) .EQ. 'C') THEN
         WRITE (24, FMT='('' $$$-edit: Q=NOTOK CONTINUE'')')
         KEY = 1
         AL18 = ' Okay, continue...'
         GOTO 500
         ENDIF
      AL18 = ' finished with this fragment'
      IF (LIT(1) .EQ. 'B') THEN
         WRITE (24, FMT='('' $$$-edit: Q=NOTOK BADMODEL STOP'')')
         NAT = 0
         GOTO 500
         ENDIF
      IF (LIT(1) .NE. 'A') GOTO 100
      WRITE (24, FMT='('' $$$-edit: Q=NOTOK ANOTHER MODEL'')')
      NAT = - NAT
  500 WRITE (9, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE VECDOT ( V1, V2, SOL )
      DIMENSION V1(3), V2(3)
      SOL = V1(1)*V2(1) + V1(2)*V2(2) + V1(3)*V2(3)
      RETURN
      END
      SUBROUTINE VECAMB ( V1, V2, V3 )
      DIMENSION V1(3), V2(3), V3(3)
      DO 10 I = 1, 3
   10 V3(I) = V1(I) - V2(I)
      RETURN
      END
      SUBROUTINE VECAPB ( V1, V2, V3 )
      DIMENSION V1(3), V2(3), V3(3)
      DO 10 I = 1, 3
   10 V3(I) = V1(I) + V2(I)
      RETURN
      END
      SUBROUTINE CARDIS ( V1, V2, DIST )
      DIMENSION V1(3), V2(3)
      DIST = (V1(1)-V2(1))**2 + (V1(2)-V2(2))**2 + (V1(3)-V2(3))**2
      DIST = SQRT( DIST )
      RETURN
      END
      SUBROUTINE VECLEN ( V1, VLEN )
      DIMENSION V1(3)
      VLEN = V1(1)**2 + V1(2)**2 + V1(3)**2
      VLEN = SQRT( VLEN )
      RETURN
      END
      SUBROUTINE VECSCL ( V1, SCALE )
      DIMENSION V1(3)
      DO 10 I = 1, 3
   10 V1(I) = V1(I)*SCALE
      RETURN
      END
      SUBROUTINE CALANG ( NP, N1, N2, ANG )
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcofr.inc'
      DIMENSION       V1(3), V2(3), V3(3)
      DATA RAD        / 57.2957795 /
      CALL VECAMB ( ATXYZ(1,NP), ATXYZ(1,N1), V1 )
      CALL VECAMB ( ATXYZ(1,NP), ATXYZ(1,N2), V2 )
      CALL VECAMB ( ATXYZ(1,N1), ATXYZ(1,N2), V3 )
      CALL VECLEN ( V1, D1 )
      CALL VECLEN ( V2, D2 )
      CALL VECLEN ( V3, D3 )
      COSA = ( D1*D1 + D2*D2 - D3*D3 ) / ( 2.0 * D1 * D2 )
      IF ( COSA .GT.  1.0 ) COSA =  1.0
      IF ( COSA .LT. -1.0 ) COSA = -1.0
      ANG = ACOS ( COSA )
      ANG = ANG * RAD
      RETURN
      END
      SUBROUTINE DETANG ( T1, T2, ANG )
      DATA DIFF, PI / 0.00001, 3.1415926535 /
      IF ( T2 .GT. DIFF ) THEN
         ANG = ATAN ( T1/T2 )
         IF ( ANG .LT. 0.0 ) ANG = ANG + 2.0*PI
      ELSEIF ( T2 .LT. -DIFF ) THEN
            ANG = ATAN ( T1/T2 ) + PI
      ELSE
         ANG = 0.0
         IF ( T1 .GT.  DIFF ) ANG = 0.5*PI
         IF ( T1 .LT. -DIFF ) ANG = 1.5*PI
         ENDIF
      RETURN
      END
      SUBROUTINE ROTATE ( OPT, ANG, XYZ, NVEC )
      CHARACTER*(*) OPT
      DIMENSION XYZ(10,NVEC)
      DIMENSION TM(3,3), T(3)
      CALL KERNZA ( 0.0, TM, 9 )
      COSR = COS( ANG )
      SINR = SIN( ANG )
      IF ( OPT(1:1) .EQ. 'Y' ) GOTO 20
      IF ( OPT(1:1) .EQ. 'Z' ) GOTO 30
      TM(1,1) =  1.0
      TM(2,2) =  COSR
      TM(2,3) =  SINR
      TM(3,2) = -SINR
      TM(3,3) =  COSR
      GOTO 40
   20 TM(2,2) =  1.0
      TM(1,1) =  COSR
      TM(1,3) = -SINR
      TM(3,1) =  SINR
      TM(3,3) =  COSR
      GOTO 40
   30 TM(3,3) =  1.0
      TM(1,1) =  COSR
      TM(1,2) =  SINR
      TM(2,1) = -SINR
      TM(2,2) =  COSR
   40 DO 50 I = 1, NVEC
      CALL MATXV3 ( TM, XYZ(1,I), T )
      DO 50 J = 1, 3
      XYZ(J,I) = T(J)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE ATSYM1 (ISM)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      DIMENSION R(10,MAXAT), S(10,MAXAT)
      EQUIVALENCE (R(1,1),ATXYZ(5,1)), (S(1,1),ATXYZ(8,1))
      DIMENSION RRR(MAXAT), A(9,37), B(9,37), ISYM(10,37)
      DATA IMAX /0/
      DO 102 I = 1,NAT
  102 RRR(I) = SQRT (ATXYZ(1,I)**2 + ATXYZ(2,I)**2 + ATXYZ(3,I)**2 )
      NR = 0
      L = 0
      R1 = 0.
  104 RMAX = 0.
      IF (L.EQ.NAT) GOTO 200
      DO 106 I = 1,NAT
      IF (RRR(I).LE.RMAX) GOTO 106
      RMAX = RRR(I)
      IMAX = I
  106 CONTINUE
      IF (NR .EQ. 37) GOTO 200
      NR = NR + 1
      L = L + 1
      RRR(IMAX) = -RMAX
      CALL KERNAB (ATXYZ(1,IMAX), A(1,NR), 3)
      CALL VECIN (NR, A)
      A(4,NR) = IZAT(IMAX)
      IF (R1.LT. .1) R1=RMAX
      IF (NR.LE.5) GOTO 120
      IF (R1 - RMAX .GE. 0.7) GOTO 200
  120 CALL VECAT (NR, A)
      IF (NR.LT.5 .OR. R1-RMAX.LT.0.7) GOTO 104
  200 NV = 0
      DO 380 I = 1,NR
      NV = NV + 1
      IF (NV.GT.30) GOTO 400
      CALL KERNAB (A(1,I), B(1,NV), 3)
      CALL VECIN(NV, B)
      CALL VECEQ(NV, B)
      IF (I.EQ.1) GOTO 380
      II = I - 1
      DO 300 L = 1, II
      NV = NV + 1
      IF (NV.GT.27) GOTO 400
      IF (ABS (A(4,I)-A(4,L)) .GT. 1.5) GOTO 280
      DO 240 K=1,3
  240 B(K,NV) = A(K,I) + A(K,L)
      CALL VECIN (NV,B)
      CALL VECEQ (NV,B)
      NV = NV + 1
      DO 260 K=1,3
  260 B(K,NV) = A(K,I) - A(K,L)
      CALL VECIN (NV,B)
      CALL VECEQ (NV,B)
      NV = NV + 1
  280 CALL VECAXB (A(1,I),A(1,L),B(1,NV))
      CALL VECIN (NV,B)
      CALL VECEQ (NV,B)
  300 CONTINUE
  380 CONTINUE
      GOTO 410
  400 NV = NV - 1
  410 VXMAX = -1.
      IVMAX = 0
      DO 700 I=1,NV
      CALL ROT2X (B(1,I), ATXYZ, R, NAT)
      IS2 = 0
      ISM = 0
      DO 600 IS = 1,6
      IF (IS.GT.1) GOTO 440
      DO 420 L=1,NAT
      S(1,L) = -R(1,L)
      S(2,L) =  R(2,L)
  420 S(3,L) =  R(3,L)
      GOTO 460
  440 ANG = 360. / FLOAT(IS)
      CALL ROTAX (ANG, R, S, NAT)
  460 ISYM(IS, I) = 0
      DO 500 IA = 1,NAT
      DO 480 IB = 1,NAT
      IF (ABS(IZAT(IA) - IZAT(IB)) .GT. 1) GOTO 480
      IF ( (R(1,IA) - S(1,IB))**2
     *   + (R(2,IA) - S(2,IB))**2
     *   + (R(3,IA) - S(3,IB))**2  .LT. .20) GOTO 500
  480 CONTINUE
      GOTO 600
  500 CONTINUE
      IS2 = IS2 + IS
      ISYM (IS, I) = IS
      IF (IS.LE.ISM) GOTO 600
      ISM = IS
  600 CONTINUE
      IF (IS2 .EQ. 0) GOTO 700
      IF (ISYM(1,I) .EQ.1 .AND. ISYM(3,I) .EQ. 3) ISM = 6
      IF (ISM.GE.3) GOTO 800
      V = 0.
      DO 620 J = 1, NAT
      IF (ABS(R(1,J)).GT.V) V=ABS(R(1,J))
  620 CONTINUE
      IF (V.LE.VXMAX) GOTO 700
      VXMAX = V
      IVMAX = I
  700 CONTINUE
      IF (IVMAX.GT.0) GOTO 773
      WRITE (9, *) ' No symmetry found in input model'
      ISM = 0
      RETURN
  773 CALL ROT2X (B(1,IVMAX), ATXYZ, R, NAT)
      IF (ISYM(2,IVMAX).EQ.2) THEN
         WRITE (9, 774) ISYM(2,IVMAX)
  774    FORMAT (' Rotate model to bring' ,I3 ,
     *           '-fold rotation axis to the x-axis' )
      ELSE
         WRITE (9, *)
     *   ' Rotate model to bring normal of mirror plane to the x-axis'
         ENDIF
      ISM = 2
      GOTO 884
  800 IF (NV .EQ. 1) THEN
         WRITE (9, *) ' Rotate model to bring vector along the x-axis'
      ELSE
         WRITE (9, 774) ISM
         ENDIF
  884 CONTINUE
      DO 930  J = 1, NAT
  930 CALL KERNAB (ATXYZ(5,J), ATXYZ(1,J), 3)
      RETURN
      END
      SUBROUTINE ROTAX (A, R, S, NA)
      DIMENSION R(10,NA), S(10,NA)
      DATA D2R /0.01745329252/
      AR = A * D2R
      COSA = COS (AR)
      SINA = SIN (AR)
      DO 7 I = 1,NA
      S(1,I) = R(1,I)
      S(2,I) = COSA * R(2,I) - SINA * R(3,I)
  7   S(3,I) = SINA * R(2,I) + COSA * R(3,I)
      RETURN
      END
      SUBROUTINE ROT2X (V, XYZ, R, NA)
      DIMENSION V(3), XYZ(10,NA), R(10,NA)
      DIMENSION T(3,3)
      EQUIVALENCE (T(1,1),X), (T(1,2),Y), (T(1,3),Z)
      Q = SQRT (V(1)**2 + V(2)**2 + V(3)**2)
      X = V(1) / Q
      Y = V(2) / Q
      Z = V(3) / Q
      Q = Y**2 + Z**2
      IF (Q.LT.0.000001) GOTO 8
      T(2,1) = -Y
      T(2,2) = (X*Y*Y + Z*Z) / Q
      T(2,3) = (X*Y*Z - Y*Z) / Q
      T(3,1) = -Z
      T(3,2) = T(2,3)
      T(3,3) = (X*Z*Z + Y*Y) / Q
      DO 7 I = 1, NA
      DO 7 K = 1, 3
  7   R(K,I) = T(K,1) * XYZ(1,I) + T(K,2) * XYZ(2,I) + T(K,3) * XYZ(3,I)
      RETURN
  8   DO 9 I = 1, NA
      DO 9 K = 1, 3
  9   R(K,I) = XYZ(K,I)
      RETURN
      END
      SUBROUTINE VECAT (N, A)
      DIMENSION A(9,37)
      IF (N.LE.1) RETURN
      II = N - 1
      DO 40 L = 1, II
      DEL2 = ( A(9,L) + A(9,N) )**2
      IF ( (A(6,L) - A(6,N) )**2
     *   + (A(7,L) - A(7,N) )**2
     *   + (A(8,L) - A(8,N) )**2 .GT. DEL2 ) GOTO 4
 2    N = N - 1
      RETURN
 4    IF ( (A(6,L) + A(6,N) )**2
     *   + (A(7,L) + A(7,N) )**2
     *   + (A(8,L) + A(8,N) )**2 .GT. DEL2 ) GOTO 40
      GOTO 2
   40 CONTINUE
      RETURN
      END
      SUBROUTINE VECIN (I, A)
      DIMENSION A(9,37)
      A(5,I) = SQRT ( A(1,I)**2 + A(2,I)**2 + A(3,I)**2 )
      DO 1 K=1,3
   1  A(K+5,I) = A(K,I) / A(5,I)
      ESD = AMAX1 (0.2, 0.03 * A(5,I))
      A(9,I) = ESD / A(5,I)
      RETURN
      END
      SUBROUTINE VECUP (I, A)
      DIMENSION A(9,37)
      T = SQRT ( A(1,I)**2 + A(2,I)**2 + A(3,I)**2 )
      IF (T .LT. 0.1) CALL KERROR ('Impossible atoms..',1, 'VECUP')
      DO 1 K=1,3
   1  A(K+5,I) = A(K,I) / T
      TDIF = T - A(5,I)
      ESD = AMAX1 (0.2, 0.03 * TDIF)
      A(9,I) = (A(9,I) * A(5,I) + ESD) / T
      A(5,I) = T
      RETURN
      END
      SUBROUTINE VECEQ (N, A)
      DIMENSION A(9,37)
      IF (N.LE.1) RETURN
      IF (A(5,N).LT.0.8) GOTO 500
      II = N - 1
      DO 40 L = 1, II
      DEL2 = ( A(9,L) + A(9,N) )**2
      IF ( (A(6,L) - A(6,N) )**2
     *   + (A(7,L) - A(7,N) )**2
     *   + (A(8,L) - A(8,N) )**2 .GT. DEL2 ) GOTO 4
      DO 2 K=1,3
 2    A(K,L) = A(K,L) + A(K,N)
      CALL VECUP (L,A)
      GOTO 500
 4    IF ( (A(6,L) + A(6,N) )**2
     *   + (A(7,L) + A(7,N) )**2
     *   + (A(8,L) + A(8,N) )**2 .GT. DEL2 ) GOTO 40
      DO 6 K=1,3
 6    A(K,L) = A(K,L) - A(K,N)
      CALL VECUP (L,A)
      GOTO 500
   40 CONTINUE
      RETURN
  500 N = N - 1
      RETURN
      END
      SUBROUTINE ATOMWO (IATMOD, ATXYZ, ATNAME, NAT, MOD, ISM)
      DIMENSION ATXYZ(10,NAT), ATNAME(NAT)
      CHARACTER *6 ATNAME
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IRUN, KSTAT(13))
      IT = 0
      WRITE (IATMOD, 102) CCODE, IT, IRUN, MOD, ISM
  102 FORMAT ('ATMOD ', A6, ' CART ',
     *         I7, ' RUN', I4, ' MOD', I3, ' SYMX', I2)
      IF (CHOUT .NE. ' ') THEN
         WRITE (IATMOD, FMT = '(''REMARK '', A65)') CHOUT(1:65)
         CHOUT = ' '
         ENDIF
      WRITE (24, 103) CCODE, IT, IRUN, MOD, ISM
  103 FORMAT (/ ' Leading record (header) of output ATMOD file is:'
     *      / ' ATMOD ', A6, ' CART ',
     *         I7, ' RUN', I4, ' MOD', I3, ' SYMX', I2/)
      DO 109 I = 1, NAT
      WRITE (IATMOD, 104) ATNAME(I), (ATXYZ(J,I), J=1,3)
  104 FORMAT ('ATOM  ', A6, 2X, 3F9.5)
  109 CONTINUE
      WRITE (IATMOD, FMT = '(''END'')')
      RETURN
      END
      SUBROUTINE CRYSDA
      COMMON /ATOMS/ NUMATO, ATCNT(10), IATCNT(10), IFORM, ATWT(10),
     *               IATNO(10), RADIUS(10), COVRAD(10), ATRAD(10),
     *               SCTCOF(9,10), DFP(10), DFDP(10), ABSCO(10),
     *               IATCEL(10), ABSLIN, DCALC, F0002, AMOL
      COMMON /MATRIX/ KEYORI, RR(3,3), SS(3,3), VV(3,3), WW(3,3),
     *                XX(3,3), YY(3,3)
      COMMON /WAVETT/ RLAMB1,RLAMB2,RLAMB3,RLAMB4,IWAVE
      COMMON /SPACE/ LAUE, NAXIS, ICEN, LATCEN, NEQV, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      COMMON /CELTT/ CELLDT(25), AHEX, CHEX, ARHMB, ALPRHM, SIGV
      NWCRIN = 0
      CALL CRINIT (NWCRIN)
      CALL SPGRIN
      CALL CRCELL
      CALL CRATOM
      CALL CRWRIT
      IF ( NWCRIN .NE. 0 ) CALL WRCRIN
      CALL RDCRYS (3)
      END
      SUBROUTINE CRINIT (NWCRIN)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRYS, IFILE(3)), (ICRIN,IFILE(14))
      EQUIVALENCE (KEYS(21), KP2)
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(24), KICRIN)
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      COMMON /ATOMS/ NUMATO, ATCNT(10), IATCNT(10), IFORM, ATWT(10),
     *               IATNO(10), RADIUS(10), COVRAD(10), ATRAD(10),
     *               SCTCOF(9,10), DFP(10), DFDP(10), ABSCO(10),
     *               IATCEL(10), ABSLIN, DCALC, F0002, AMOL
      COMMON /MATRIX/ KEYORI, RR(3,3), SS(3,3), VV(3,3), WW(3,3),
     *                XX(3,3), YY(3,3)
      DIMENSION LINP(9)
      KEYCEL = 0
      KEYORI = 0
      SPGR = ' '
      WAVEAT = ' '
      DO 102 I = 1, 10
      CELALL(I) = 0.
  102 CELATY(I) = ' '
      CALL RESRD ( KEYCEL )
      CALL CIFCRY ( KEYCEL )
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KICRIN)
      IF (KICRIN .EQ. -1) THEN
         NWCRIN = NWCRIN - 1
         GOTO 220
         ENDIF
      CALL RDCRIN (RR, LINP)
      IF (LINP(2) .EQ. 1) KEYCEL = 1
      IF (LINP(8) .EQ. 1) KEYORI = 1
  220 IF (CELATY(1) .NE. '  ') THEN
         NUMATO = NTYPE
         DO 250 I = 1, 10
         ATCNT(I) = CELALL(I) / ZET
  250    IATCNT(I) = ATCNT(I) + 0.5
         IFORM = ZET + 0.01
         ENDIF
      IF (KEYCEL .EQ. 1) GOTO 310
      WRITE (9, 291)
  291 FORMAT (1X/
     * ' Neither CRYSIN file, nor INS, RES or CIF file available.' /
     * ' This is NOT an advisable situation. The CRYSIN file normally'/
     * ' is prepared by the local conversion-to-DIRDIF procedure.'/
     * ' Maybe... you are now working in the wrong directory ?'/
     * ' Or.... did you made a typing error for the compound code ?'/1X/
     * ' Please, correct, and call again!')
      CALL FILCLO (ICRYS, 'DELETE')
      CALL KEPROZ
  310 CONTINUE
      IF (WAVEAT .NE. '  ') RETURN
  311 WRITE (9, 312)
  312 FORMAT (' Enter radiation source: Cu, Mo, Fe, Ag, or Cr  :')
      CALL KETERM (0, 1, KEND)
      IF  (KEND .LT. 0) GOTO 311
      WAVEAT = LIT(1)(1:2)
      CALL WAVELN (WAVEAT, NEND)
      IF (NEND .NE. 0) GOTO 311
      WRITE (9, 317) WAVEAT
  317 FORMAT (' Entered from terminal: radiation source = ', A2)
      RETURN
      END
      SUBROUTINE RDCRIN (ORIN, LINP)
      DIMENSION ORIN(3,3), LINP(9)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRIN, IFILE(14))
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(26), IHKLF)
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      LOGICAL NWCRIN
      CHARACTER * 6  L(9)
      DATA L / 'TITLE', 'CELL', 'CELLSD', 'SPGR', 'FORMUL', 'Z',
     *         'WAVE',  'ORIN', 'HKLF' /
      CALL KERNZI (0, LINP, 9)
      JORIN = 0
      NWCRIN = .FALSE.
      CALL KERINA (ICRIN, LIT, 1, LEND)
      IF (LIT(1).NE.'CRYSIN')
     * CALL KERROR ('ERROR on first record of CRYSIN file', 0, 'RDCRIN')
      WRITE (24, 102)
      WRITE (8, 102)
  102 FORMAT (' Input from file CRYSIN')
      NDAT = 1
      LAST = 0
  190 CALL KERIFF (ICRIN, L, 9, LEND)
      IF (LEND .LT. 0 .OR. LEND .GE. 5) THEN
         WRITE (24, FMT=
     *   '('' Incorrect END of CRYSIN file: continue anyhow .... '')')
         NWCRIN = .TRUE.
         GOTO 300
         ENDIF
      IF (LEND .EQ. 4) GOTO 300
      KEND = NLUSER(1)
      WRITE (8, 193) CHIN(1:72)
  193 FORMAT (A72)
      IF (KEND .LE. 0) GOTO 200
      LINP(KEND) = 1
      NDAT = NDAT + 1
      LAST = 0
      GOTO (210, 220, 230, 240, 250, 260, 270, 280, 290), KEND
  200 IF (LAST .EQ. 5) GOTO 255
      IF (LAST .EQ. 8) GOTO 288
      IF (LAST .EQ. 9) GOTO 289
      CALL KERROR (' Unidentified control card', -6, 'RDCRIN')
  210 CONTINUE
  213 FORMAT (/' Input TITLE from CRYSIN file:'/1X, A74/)
      WRITE (24, 213) CHIN (7:80)
      GOTO 190
  220 IF (NFNUM .NE. 6 .OR. NLIT .NE. 1) GOTO 900
      CALL KERNAB(FNUM, CELL, 6)
      GOTO 190
  230 IF (NFNUM .NE. 6 .OR. NLIT .NE. 1) GOTO 900
      CALL KERNAB(FNUM, CELLSD, 6)
      GOTO 190
  240 DO 243 I=71,1,-1
      IF (CHIN(I:I+1) .NE. '  ') GOTO 243
      CHOUT = CHIN(1:72)
      CHIN(I:72) = CHOUT(I+1:72)
  243 CONTINUE
      I = 6
      IF (CHIN(1:1) .EQ. ' ' ) I = 7
      SPGR = CHIN(I:I+15)
      CHOUT = ' '
      GOTO 190
  250 LAST = 5
      IF (CHIN(72:72) .EQ. '=') THEN
         IF (NFNUM+2 .NE. NLIT) GOTO 900
      ELSE
         IF (NFNUM+1 .NE. NLIT) GOTO 900
         ENDIF
      IF (NFNUM.GT.10) CALL KERROR ('Too many atom kinds',-6, 'RDCRIN')
      DO 252 I = 1, 10
      IF (FNUM(I) .LT. 0.001) GOTO 254
      CELATY(I) = LIT(I + 1)(1:2)
      IF (LIT(I) .EQ. ' ') GOTO 900
  252 CELALL(I) = FNUM(I)
  253 LAST = 0
      NTYPE = 10
      GOTO 190
  254 NTYPE = I - 1
      IF (NTYPE .EQ. 0) GOTO 900
      GOTO 190
  255 LAST = 0
      IF (NFNUM .NE. NLIT) GOTO 900
      IF (NTYPE + NFNUM .GT. 10)
     *   CALL KERROR ('Too many atom kinds', -6, 'RDCRIN')
      J = 0
      DO 257 I = NTYPE + 1, 10
      J = J + 1
      IF (FNUM(J) .LT. 0.001) GOTO 254
      CELATY(I) = LIT(J)(1:2)
      IF (LIT(J) .EQ. ' ') GOTO 900
  257 CELALL(I) = FNUM(J)
      GOTO 253
  260 IF (NFNUM .NE. 1) GOTO 900
      ZET = FNUM(1)
      GOTO 190
  270 IF (NLIT .LT. 2) GOTO 900
      WAVEAT = LIT(2)
      GOTO 190
  280 IF (NFNUM .NE. 3 .OR. NLIT .NE. 1) GOTO 900
      LAST = 8
  281 JORIN = JORIN + 1
      ORIN(JORIN,1) = FNUM(1)
      ORIN(JORIN,2) = FNUM(2)
      ORIN(JORIN,3) = FNUM(3)
      GOTO 190
  288 IF (NFNUM .NE. 3 .OR. NLIT .NE. 0) GOTO 900
      LAST = 9
      GOTO 281
  289 IF (NFNUM .NE. 3 .OR. NLIT .NE. 0) GOTO 900
      LAST = 0
      GOTO 281
  290 IHKLF = IABS (NINT (FNUM(1) ) )
  300 CALL FILCLO (ICRIN, 'KEEP')
      IF (LINP(1) .EQ. 1) NDAT = NDAT - 1
      IF (NDAT .LE. 1) THEN
         WRITE (9, FMT='('' Empty CRYSIN file: local PGM error?'')')
         GOTO 800
         ENDIF
      IF (LINP(4) .EQ .0) CALL KERROR
     *      (' No spacegroup given on CRYSIN File ', 0,'RDCRIN')
      IF (LINP(5) .EQ .0) CALL KERROR
     *      (' No cell contents given on CRYSIN File ', 0 ,'RDCRIN')
      IF (LINP(2) .EQ. 0 .OR. LINP(3) .EQ. 0) THEN
      WRITE (9, *)  'CELL and CELLSD must be given on CRYSIN file'
         GOTO 800
         ENDIF
      IF (LINP(5) .EQ. 0 .OR. LINP(6) .EQ. 0) THEN
         WRITE (9, *) 'FORMUL and Z must be given'
         GOTO 800
         ENDIF
      IF (LINP(5) .EQ. 1) THEN
         ATN = 0.
         DO 450 I = 1, NTYPE
         CELALL(I) = CELALL(I) * ZET
  450    ATN = ATN + CELALL(I)
         IF (ATN .LT. 0.9) CALL KERROR ('No atoms given in FORMUL ...',
     *      450, 'RDCRIN')
         ENDIF
      IF (LINP(7) .EQ. 1) THEN
         CALL WAVELN (WAVEAT, NEND)
         IF (NEND .NE. 0) THEN
           WRITE(9,*) 'Radiation source error (only Cu, Mo, Fe, Ag, Cr)'
            GOTO 800
            ENDIF
         ENDIF
      IF (LINP(8) .EQ. 1 .AND. JORIN .NE. 3) THEN
         WRITE(9,*) ' ORIN matrix must consists of three records ...'
         GOTO 800
         ENDIF
      DO 500 I = 2, 7
         IF ( LINP(I) .EQ. 0 ) THEN
            NWCRIN = .TRUE.
            WRITE (24, 499) L(I)
  499       FORMAT (' Item ',A6,' missing, write new CRYSIN')
         ENDIF
  500 CONTINUE
      IF (NWCRIN) GOTO 800
      RETURN
  800 CALL KERROR ('Error on CRYSIN file', 0, 'RDCRIN')
  900 CALL KERROR ('This record in CRYSIN file is incorrect', -6,
     *   'RDCRIN')
      END
      SUBROUTINE WAVELN (WAVEAT, NEND)
      CHARACTER * 2 WAVEAT
      COMMON /WAVETT/ RLAMB1,RLAMB2,RLAMB3,RLAMB4,IWAVE
      DIMENSION RLAM1(5),RLAM2(5),RLAM3(5),RLAM4(5)
      CHARACTER * 2  RADTN(5)
      DATA  RADTN / 'AG',   'MO',   'CU',   'FE',   'CR' /
      DATA  RLAM1 / 0.5594075,0.709300,1.540562,1.936042,2.28970 /
      DATA  RLAM2 / 0.563798 ,0.713590,1.544390,1.939980,2.293606/
      DATA  RLAM3 / 0.560871 ,0.710730,1.541838,1.937355,2.291002/
      DATA  RLAM4 / 0.497069 ,0.632288,1.392218,1.75661 ,2.08487 /
      DO 2 I = 1,5
      J = I
      IF (WAVEAT .EQ. RADTN(I)) GOTO 5
    2 CONTINUE
      NEND = -1
      RETURN
    5 RLAMB1 = RLAM1(J)
      RLAMB2 = RLAM2(J)
      RLAMB3 = RLAM3(J)
      RLAMB4 = RLAM4(J)
      WAVEAT = RADTN(J)
      IWAVE = J
      NEND = 0
      RETURN
      END
      SUBROUTINE SPGRIN
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(24), KICRIN)
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      COMMON /SPACE/ LAUE, NAXIS, ICEN, LATCEN, NEQV, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      LOGICAL QUEST
      QUEST = .TRUE.
      IF (KICRIN .EQ. 0 .OR. FULAUT) QUEST = .FALSE.
      IF (SPGR .EQ. ' ') GOTO 40
   21 IF (QUEST) THEN
              WRITE (9, 30) SPGR
   30         FORMAT (' Space-group symbol was found to be ', A30 /
     *        ' Shall I retain this information? Y or N')
      ELSE
         CHIN = SPGR
              GOTO 70
      ENDIF
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 21
      IF (LIT(1) .EQ. 'Y') THEN
         WRITE (9, 32) SPGR
   32    FORMAT (' Space-group symbol retained: ', A16)
         CHIN = SPGR
         GOTO 70
         ENDIF
      IF (LIT(1) .NE. 'N') GOTO 21
      WRITE (9, 33) SPGR
   33 FORMAT (' Previous space-group symbol rejected: ', A16)
   40 WRITE (9, 50)
   50 FORMAT (' Give the space group symbol (30 characters max.)',
     * ' or H (help) or Q ')
      CALL KETERM (-1, -1, KEND)
      IF (KEND .EQ. 18) THEN
         WRITE (9, 51)
   51    FORMAT (' As in Intl. Tables. Separate directions by blanks.'/
     * ' Examples: P-1 , P2 , P 2 ,  P21/n , P21 21 21 , Fd d d , R-3'/
     *    ' Monoclinic: b axis unique, unless given as e.g.: P1 2 1)'/
     *    ' Tetragonal, Trigon.(P or R cell), Hexagonal: c axis unique'/
     *    ' Rhombohedral: hexagonal or rhombohedral cell '/
     *    '     ---- however: TRACOR rhombohedral cell not yet OK '/
     *    ' Please, try: ')
         GOTO 40
         ENDIF
      IF (KEND .LT. 0) GOTO 40
      WRITE (24, 53) CHIN
   53 FORMAT (' Space group entered from terminal: ', A30)
   70 CALL SGTEST (9, KEND)
      IF (KEND .GT. 0) GOTO 40
      IF (KEND .EQ. 0) CALL CRSPGR (SPGR)
      M = NPOL
      NPOL = M / 10000
      M = M - (NPOL*10000)
      NSYS = M / 1000
      MULTIP = M - (NSYS*1000)
      ISYST = NSYS
      IUNIQ = NAXIS
      IMULT = MULTIP
      IF (NAXIS.GE.4) GOTO 40
      CALL SGCELL (KEND)
      IF (KEND .GE. 0) RETURN
  302 WRITE (9, 303)
  303 FORMAT (' Cell or space group incorrect ...: '/
     * ' Do you wish to supply another space group? (Y, N, H, Q)')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 302
      IF (LIT(1) .EQ. 'Y') GOTO 40
      IF (LIT(1) .EQ. 'Q') GOTO 340
      IF (LIT(1) .EQ. 'N') GOTO 330
      IF (LIT(1) .NE. 'H') GOTO 302
      WRITE (9, 51)
  330 CONTINUE
  340 CONTINUE
      IF (LIT(1) .EQ. 'H') GOTO 302
      CALL KERROR ('CELL and SPGR incompatible', 0, 'SPGRIN')
      END
      SUBROUTINE SGTEST (IPRX, KEND)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      DIMENSION NSYMEL(21)
      CHARACTER * 72 BOS
      CHARACTER * 4 LIT4, SYMEL(126)
      CHARACTER * 8 RSG(11)
      CHARACTER * 6 LATTI(7)
      CHARACTER * 1 CH(29)
      DATA LATTI / 'P','A','B','C','I','F','R'/
      DATA CH     / ' ','1','2','3','4','5','6','-','/',
     *              'P','A','B','C','I','F','R','M','N','D',
     *              'p','a','b','c','i','f','r','m','n','d'/
      DATA NSYMEL /1,  2,  3,  4,  6, -1, -2, -3, -4, -6,
     *             21, 31, 32, 41, 42, 43, 61, 62, 63, 64, 65 /
      DATA (SYMEL(I), I=1, 60)
     *            / 'M   ','A   ','B   ','C   ','N   ','D   ',
     *              '2/M ','2/A ','2/B ','2/C ','2/N ','2/D ',
     *              '3/M ','3/A ','3/B ','3/C ','3/N ','3/D ',
     *              '4/M ','4/A ','4/B ','4/C ','4/N ','4/D ',
     *              '6/M ','6/A ','6/B ','6/C ','6/N ','6/D ',
     *              '-1/M','-1/A','-1/B','-1/C','-1/N','-1/D',
     *              '-2/M','-2/A','-2/B','-2/C','-2/N','-2/D',
     *              '-3/M','-3/A','-3/B','-3/C','-3/N','-3/D',
     *              '-4/M','-4/A','-4/B','-4/C','-4/N','-4/D',
     *              '-6/M','-6/A','-6/B','-6/C','-6/N','-6/D'/
      DATA (SYMEL(I), I=61, 126)
     *             /'21/M','21/A','21/B','21/C','21/N','21/D',
     *              '31/M','31/A','31/B','31/C','31/N','31/D',
     *              '32/M','32/A','32/B','32/C','32/N','32/D',
     *              '41/M','41/A','41/B','41/C','41/N','41/D',
     *              '42/M','42/A','42/B','42/C','42/N','42/D',
     *              '43/M','43/A','43/B','43/C','43/N','43/D',
     *              '61/M','61/A','61/B','61/C','61/N','61/D',
     *              '62/M','62/A','62/B','62/C','62/N','62/D',
     *              '63/M','63/A','63/B','63/C','63/N','63/D',
     *              '64/M','64/A','64/B','64/C','64/N','64/D',
     *              '65/M','65/A','65/B','65/C','65/N','65/D'/
      DATA RSG     /'R 3     ','R 3 1   ','R -3    ','R -3 1  ',
     *              'R 3 2   ','R 3 M   ','R 3 C   ',
     *              'R -3 M  ','R -3 2/M','R -3 C  ','R -3 2/C'/
      KEND = 0
      DO 103 I=70,1,-1
      BOS(I:72) = CHIN(I:72)
  103 IF (CHIN(I:I+1) .EQ. '  ') CHIN(I:72) = BOS(I+1:72)
      BOS = CHIN(1:72)
      IF (CHIN(1:1)   .EQ. ' ' ) CHIN(1:72) = BOS(2  :72)
      IF (CHIN(17:18) .NE. '  ') GOTO 880
      IF (CHIN(2:2)   .EQ. ' ') GOTO 105
      IF (CHIN(16:16) .NE. ' ') GOTO 880
      SPGR = CHIN(1:16)
      CHIN(2:2) = ' '
      CHIN(3:16) = SPGR(2:15)
  105 DO 108 I = 1, 16
      DO 106 J = 1, 29
      IF (CHIN(I:I) .EQ. CH(J)) GOTO 107
  106 CONTINUE
      GOTO 890
  107 IF (J .GE. 20) CHIN(I:I) = CH(J-10)
  108 CONTINUE
      SPGR = CHIN(1:16)
      CALL KERINB (LATTI, 7)
      NTOT = NFNUM + NLIT
      IF (NTOT .GT. 4) GOTO 900
      IF (NLUSER(1) .LE. 0) GOTO 920
      IF (NTOT .LE. 1) GOTO 910
      IF (NFNUM .EQ. 0) GOTO 120
      DO 113 I = 1, NFNUM
      NUM = NINT(FNUM(I))
      DO 112 K = 1, 21
      IF (NUM .EQ. NSYMEL(K)) GOTO 113
  112 CONTINUE
      GOTO 950
  113 CONTINUE
  120 IF (NLIT .LE. 1) GOTO 130
      DO 123 I = 2, NLIT
      IF (LIT(I)(5:5) .NE. ' ') GOTO 930
      LIT4 = LIT(I)(1:4)
      DO 122 K = 1, 126
      IF (LIT4 .EQ. SYMEL(K)) GOTO 123
  122 CONTINUE
      GOTO 970
  123 CONTINUE
  130 IF (LIT(1) (1:1) .NE. 'R') RETURN
      IF (NTOT .GT. 3) GOTO 205
      DO 200 I = 1,11
      IF (CHIN(1:8) .EQ. RSG(I)) GOTO 250
  200 CONTINUE
  205 WRITE (IPRX, 210) SPGR
  210 FORMAT(' Illegal rhombohedral space-group symbol detected: ',A16)
      WRITE (IPRX, 220) RSG
  220 FORMAT ( ' Standard rhombohedral space-group symbols are:' /
     * ' R 3    R -3     R 3 2    R 3 m    R 3 c     R -3 m    R -3 c')
      GOTO 980
  250 NRSG = I
      IF (I.EQ.2 .OR. I.EQ.4 .OR. I.EQ.9 .OR. I.EQ.11) THEN
         NRSG = I - 1
         SPGR = RSG(NRSG)
         WRITE (9, 260) SPGR
  260    FORMAT (' Non-standard space group-symbol changed into ',A16)
         ENDIF
      IF (ABS(CELL(1) - CELL(2)) .GT. 1. .OR.
     *    ABS(CELL(4) - CELL(5)) .GT. 1.) GOTO 966
      IF (ABS(CELL(4) - 90.0) .LT. 1. .OR.
     *    ABS(CELL(6) -120.0) .LT. 1.) RETURN
      IF (ABS(CELL(1) - CELL(3)) .GT. 1. .OR.
     *    ABS(CELL(4) - CELL(6)) .GT. 1.) GOTO 966
      KEND = -1
      CALL SETRSG (NRSG)
      RETURN
  880 WRITE (IPRX, 881)
  881 FORMAT (' Error detected, too many characters given')
      GOTO 980
  890 WRITE (IPRX, 891) CHIN(I:I)
  891 FORMAT (' Error detected, illegal character: ',A1)
      GOTO 980
  900 WRITE (IPRX, 901)
  901 FORMAT (' Error detected, more than four items entered')
      GOTO 980
  910 WRITE (IPRX, 911)
  911 FORMAT (' Error detected, only lattice given')
      GOTO 980
  920 WRITE (IPRX, 921) LIT(1)
  921 FORMAT (' Error detected, incorrect lattice symbol given: ', A6)
      GOTO 980
  930 WRITE (IPRX, 931) LIT(I)
  931 FORMAT (' Error detected, literal item too long: ',A6)
      GOTO 980
  950 WRITE (IPRX, 951) NUM
  951 FORMAT (' Error detected, inpossible number: ',I10)
      GOTO 980
  966 WRITE (IPRX, 967)
  967 FORMAT (' Error: cell and R-sp.group incompatible')
      GOTO 980
  970 WRITE (IPRX, 971) LIT4
  971 FORMAT (' Error detected, illegal symmetry item: ',A4)
  980 KEND = 1
      RETURN
      END
      SUBROUTINE SETRSG (NRSG)
      COMMON /SPACE/ LAUE, NAXIS, ICEN, LATCEN, NEQV, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      DIMENSION NRT(3,4,12)
      DATA (((NRT(I,J,K),J=1,4),I=1,3),K=1,12) /
     *      1, 0, 0, 0,    0, 1, 0, 0,    0, 0, 1, 0,
     *      0, 0, 1, 0,    1, 0, 0, 0,    0, 1, 0, 0,
     *      0, 1, 0, 0,    0, 0, 1, 0,    1, 0, 0, 0,
     *      0,-1, 0, 0,   -1, 0, 0, 0,    0, 0,-1, 0,
     *     -1, 0, 0, 0,    0, 0,-1, 0,    0,-1, 0, 0,
     *      0, 0,-1, 0,    0,-1, 0, 0,   -1, 0, 0, 0,
     *      0, 1, 0, 0,    1, 0, 0, 0,    0, 0, 1, 0,
     *      1, 0, 0, 0,    0, 0, 1, 0,    0, 1, 0, 0,
     *      0, 0, 1, 0,    0, 1, 0, 0,    1, 0, 0, 0,
     *      0, 1, 0, 6,    1, 0, 0, 6,    0, 0, 1, 6,
     *      1, 0, 0, 6,    0, 0, 1, 6,    0, 1, 0, 6,
     *      0, 0, 1, 6,    0, 1, 0, 6,    1, 0, 0, 6 /
      CALL KERNAI (NRT, JRT, 72)
      CALL KERNZA (0.0, CEN, 12)
      NAXIS  =  0
      LATCEN =  1
      NCV    =  1
      NSYS   =  5
      LAUE   =  6
      ICEN   =  0
      NEQV   =  3
      NPOL   =  8
      MULTIP =  3
      GOTO (200,200,120,120,130,140,150,160,160,170,170), NRSG
  120 ICEN   =  1
      NPOL   =  0
      MULTIP =  6
      GOTO 200
  130 LAUE   =  7
      NEQV   =  6
      NPOL   =  0
      MULTIP =  6
      GOTO 200
  140 LAUE   =  7
      NEQV   =  6
      MULTIP =  6
      CALL KERNAI (NRT(1,1,7), JRT(1,1,4), 36)
      GOTO 200
  150 LAUE   =  7
      NEQV   =  6
      MULTIP =  6
      CALL KERNAI (NRT(1,1,10), JRT(1,1,4), 36)
      GOTO 200
  160 LAUE   =  7
      ICEN   =  1
      NEQV   =  6
      NPOL   =  0
      MULTIP = 12
      CALL KERNAI (NRT(1,1,7), JRT(1,1,4), 36)
      GOTO 200
  170 LAUE   =  7
      ICEN   =  1
      NEQV   =  6
      NPOL   =  0
      MULTIP = 12
      CALL KERNAI (NRT(1,1,10), JRT(1,1,4), 36)
  200 NPOL = NPOL*10000 + NSYS*1000 + MULTIP
      RETURN
      END
      SUBROUTINE SGCELL (KEND)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(24), KICRIN)
      LOGICAL XAB, XAC, XBC, A90, B90, C90, C120
      KEND = 0
      XAB = ABS(CELL(1) - CELL(2)) .GT. 0.1
      XAC = ABS(CELL(1) - CELL(3)) .GT. 0.1
      XBC = ABS(CELL(2) - CELL(3)) .GT. 0.1
      A90 = ABS(CELL(4) - 90.) .GT. 0.2
      B90 = ABS(CELL(5) - 90.) .GT. 0.2
      C90 = ABS(CELL(6) - 90.) .GT. 0.2
      C120= ABS(CELL(6) -120.) .GT. 0.2
      GOTO (200, 140, 130, 120, 170, 160, 160, 110), ISYST
  110 IF (XAB .OR. XAC .OR. XBC .OR. A90 .OR. B90 .OR. C90) GOTO 900
      CELL(1) = (CELL(1)+CELL(2)+CELL(3))/3.0
      CELL(2) =  CELL(1)
      CELL(3) =  CELL(1)
      CELLSD(1) = (CELLSD(1)+CELLSD(2)+CELLSD(3))/3.0
      CELLSD(2) =  CELLSD(1)
      CELLSD(3) =  CELLSD(1)
      GOTO 130
  120 IF (XAB .OR. A90 .OR. B90 .OR. C90) GOTO 900
      CELL(1) = (CELL(1)+CELL(2))/2.0
      CELL(2) =  CELL(1)
      CELLSD(1) = (CELLSD(1)+CELLSD(2))/2.0
      CELLSD(2) =  CELLSD(1)
  130 IF (A90 .OR. B90 .OR. C90) GOTO 900
      CELL(4) = 90.0
      CELL(5) = 90.0
      CELL(6) = 90.0
      GOTO 200
  140 GOTO (141,142,143), IUNIQ
  141 IF (B90 .OR. C90) GOTO 900
      CELL(5) = 90.0
      CELL(6) = 90.0
      GOTO 200
  142 IF (A90 .OR. C90) GOTO 900
      CELL(4) = 90.0
      CELL(6) = 90.0
      GOTO 200
  143 IF (A90 .OR. B90) GOTO 900
      CELL(4) = 90.0
      CELL(5) = 90.0
      GOTO 200
  160 IF (XAB .OR. A90 .OR. B90 .OR. C120) GOTO 900
      CELL(1)  = (CELL(1)+CELL(2))/2.0
      CELL(2)  =  CELL(1)
      CELLSD(1)  = (CELLSD(1)+CELLSD(2))/2.0
      CELLSD(2)  =  CELLSD(1)
      CELL(4) =  90.0
      CELL(5) =  90.0
      CELL(6) = 120.0
      GOTO 200
  170 IF (XAB .OR. XAC .OR. XBC) GOTO 900
      CELL(1)  = (CELL(1)+CELL(2)+CELL(3))/3.0
      CELL(2)  =  CELL(1)
      CELL(3)  =  CELL(1)
      CELLSD(1)  = (CELLSD(1)+CELLSD(2)+CELLSD(3))/3.0
      CELLSD(2)  =  CELLSD(1)
      CELLSD(3)  =  CELLSD(1)
      IF (ABS(CELL(4) - CELL(5)) .GT. 0.5 .OR.
     *    ABS(CELL(4) - CELL(6)) .GT. 0.5 .OR.
     *    ABS(CELL(5) - CELL(6)) .GT. 0.5) GOTO 900
      CELL(4) = (CELL(4)+CELL(5)+CELL(6))/3.0
      CELL(5) =  CELL(4)
      CELL(6) =  CELL(4)
      CELLSD(4) = (CELLSD(4)+CELLSD(5)+CELLSD(6))/3.0
      CELLSD(5) =  CELLSD(4)
      CELLSD(6) =  CELLSD(4)
  200 RETURN
  900 KEND = -1
      RETURN
      END
      SUBROUTINE CRCELL
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      COMMON /CELTT/ CELLDT(25), AHEX, CHEX, ARHMB, ALPRHM, SIGV
      EQUIVALENCE
     * (CELLDT( 1), A    ),(CELLDT( 2), B    ),(CELLDT( 3), C    ),
     * (CELLDT( 4),CA    ),(CELLDT( 5),CB    ),(CELLDT( 6),CC    ),
     * (CELLDT( 7),SA    ),(CELLDT( 8),SB    ),(CELLDT( 9),SC    ),
     * (CELLDT(10), ALPHA),(CELLDT(11), BETA ),(CELLDT(12), GAMMA),
     * (CELLDT(13), ASTR ),(CELLDT(14), BSTR ),(CELLDT(15), CSTR )
      EQUIVALENCE
     * (CELLDT(16),CASTR ),(CELLDT(17),CBSTR ),(CELLDT(18),CCSTR ),
     * (CELLDT(19),SASTR ),(CELLDT(20),SBSTR ),(CELLDT(21),SCSTR ),
     * (CELLDT(22),ALPSTR),(CELLDT(23),BETSTR),(CELLDT(24),GAMSTR),
     * (CELLDT(25),V     )
      COMMON /MATRIX/ KEYORI, RR(3,3), SS(3,3), VV(3,3), WW(3,3),
     *                XX(3,3), YY(3,3)
      COMMON /SPACE/ LAUE, NAXIS, ICEN, LATCEN, NEQV, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      DATA RADIAN /57.2957795147/
      CALL SGCELL (KEND)
      IF (KEND .NE. 0)
     *   CALL KERROR ('CELL and SPGR incompatible', 0, 'CRCELL')
      CALL RCELLR (CELL, VOLUM, RCELL)
      CALL CELLRR (CELL, XX)
      DO 103 I = 1, 3
      CELLDT(I) = CELL(I)
      CELLDT(I+3) = COS (CELL(I+3) / RADIAN)
      CELLDT(I+6) = SIN (CELL(I+3) / RADIAN)
      CELLDT(I+9) = CELL(I+3)
      CELLDT(I+12) = RCELL(I)
      CELLDT(I+15) = COS (RCELL(I+3) / RADIAN)
      CELLDT(I+18) = SIN (RCELL(I+3) / RADIAN)
  103 CELLDT(I+21) = RCELL(I+3)
      CELLDT(25) = VOLUM
      AHEX = 0.0
      CHEX = 0.0
      ARHMB = 0.0
      ALPRHM = 0.0
      TERM1 = B*B*C*C*CELLSD(1)*CELLSD(1)+
     *        A*A*C*C*CELLSD(2)*CELLSD(2)+
     *        A*A*B*B*CELLSD(3)*CELLSD(3)
      TERM2 = A*A*B*B*C*C
      CELE4 = CELLSD(4)/RADIAN
      CELE5 = CELLSD(5)/RADIAN
      CELE6 = CELLSD(6)/RADIAN
      GOTO (150,140,130,120,170,         160,      160,110), ISYST
  110 SIGV = 3.0*A*A*CELLSD(1)
      GOTO 200
  120 SIGV = A*SQRT(4.0*C*C*CELLSD(1)*CELLSD(1)+A*A*CELLSD(3)*CELLSD(3))
      GOTO 200
  130 SIGV = SQRT(TERM1)
      GOTO 200
  140 GOTO (141,142,143), IUNIQ
  141 SIGV = SQRT(TERM1*SA*SA+TERM2*CA*CA*CELE4*CELE4)
      GOTO 200
  142 SIGV = SQRT(TERM1*SB*SB+TERM2*CB*CB*CELE5*CELE5)
      GOTO 200
  143 SIGV = SQRT(TERM1*SC*SC+TERM2*CC*CC*CELE6*CELE6)
      GOTO 200
  150 Q = 1.0-CA*CA-CB*CB-CC*CC+2.0*CA*CB*CC
      TERM1 = TERM1*Q
      TERM2 = (CA*SA-CB*CC*SA)*(CA*SA-CB*CC*SA)*CELE4*CELE4+
     *        (CB*SB-CA*CC*SB)*(CB*SB-CA*CC*SB)*CELE5*CELE5+
     *        (CC*SC-CA*CB*SC)*(CC*SC-CA*CB*SC)*CELE6*CELE6
      TERM2 = TERM2*(A*A*B*B*C*C/Q)
      SIGV  = SQRT(TERM1+TERM2)
      GOTO 200
  160 SIGV = A*SQRT(3.0 *C*C*CELLSD(1)*CELLSD(1)+
     *              0.75*A*A*CELLSD(3)*CELLSD(3))
      IF (LATCEN .NE. 7) GOTO 200
      ARHMB = (1./3.)*SQRT(C**2+3.0*(A**2))
      ALPRHM = 2.0*RADIAN*ASIN(0.5*A/ARHMB)
      GOTO 200
  170 Q = 1.0-3.0*CA*CA+2.0*CA*CA*CA
      TERM1 = 9.0*A*A*A*A*Q*CELLSD(1)*CELLSD(1)
      TERM2 = 9.0*A*A*A*A*A*A*CA*CA*SA*SA*(1.0-CA)*(1.0-CA)/Q
      TERM2 = TERM2*CELE4*CELE4
      SIGV = SQRT(TERM2+TERM2)
      AHEX = SQRT(2.0)*A*SQRT(1.0-CA)
      CHEX = 3.0*A*SQRT((1./3.)+(2./3.)*CA)
  200 WRITE (8, 240) A, B, C, ALPHA,
     * BETA, GAMMA, CELLSD, V, SIGV,ASTR,BSTR,CSTR,
     * ALPSTR,BETSTR,GAMSTR
  240 FORMAT (// ' Real cell lattice constants are' /
     * ' A=', F8.4,  ' B=', F8.4, ' C=', F8.4,
     * ' Alpha', F7.3, '  Beta', F7.3, ' Gamma', F7.3 /
     * ' esd:', F6.4, 2(F11.4), 3(F13.3) /
     * ' Volume', F9.2, '  with esd:', F6.2  //
     * ' Reciprocal cell lattice constants are' /
     * ' A* =', F10.7, '  B* =', F10.7, '  C* =', F10.7 /
     * ' Alpha* =',F 6.2, '  Beta*  =', F6.2, '  Gamma* =', F6.2 /)
      IF (ARHMB.GT.0.0) WRITE (8, 250) ARHMB, ALPRHM
  250 FORMAT (' The equivalent rhombohedral cell has A =', F8.4,
     * ' and Alpha =', F7.2 /)
      IF (AHEX.GT.0.0) WRITE (8, 260) AHEX, CHEX
  260 FORMAT (' The equivalent hexagonal cell has A =', F8.4,
     * ' and C =', F8.4 /)
      VV(1,1)=A
      VV(1,2)=B*CC
      VV(1,3)=C*CB
      VV(2,1)=0.
      VV(2,2)=B*SC
      VV(2,3)=-C*SB*CASTR
      VV(3,1)=0.
      VV(3,2)=0.
      VV(3,3)=C*SB*SASTR
      CALL MATINV(VV, WW, DET, KEND2)
      CALL MATINV(XX, YY, DET, KEND2)
      RETURN
      END
      SUBROUTINE CRATOM
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (KEYS(24), KICRIN)
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      EQUIVALENCE (V, VOLUM)
      COMMON /ATOMS/ NUMATO, ATCNT(10), IATCNT(10), IFORM, ATWT(10),
     *               IATNO(10), RADIUS(10), COVRAD(10), ATRAD(10),
     *               SCTCOF(9,10), DFP(10), DFDP(10), ABSCO(10),
     *               IATCEL(10), ABSLIN, DCALC, F0002, AMOL
      COMMON /MATRIX/ KEYORI, RR(3,3), SS(3,3), VV(3,3), WW(3,3),
     *                XX(3,3), YY(3,3)
      COMMON /WAVETT/ RLAMB1,RLAMB2,RLAMB3,RLAMB4,IWAVE
      LOGICAL QUEST
      CHARACTER * 2 TEMP
      DIMENSION IFOR(20), ATCEL(10)
      DATA IFOR /  1,  2,  3,  4,  6,  8,  9, 12, 15, 16,
     *            18, 24, 32, 36, 48, 64, 72, 96,128,192 /
      QUEST = .TRUE.
      IF (KICRIN .EQ. 0 .OR. FULAUT) QUEST = .FALSE.
      AVOGAD = 1.6605655
      ISKIP = 0
      IF (CELATY(1) .EQ. '  ') GOTO 409
  308 IF (QUEST) THEN
         WRITE (9, 401) (CELATY(K), ATCNT(K), K=1,NUMATO)
  401    FORMAT (' The molecular formula was found to be' /
     *      1X, 10(A2,F8.2,2X) )
      ELSE
         GOTO 403
         ENDIF
      WRITE (9, 402) IFORM
  402 FORMAT (' with ',I3,' formula units in the whole unit cell:' /
     *        ' shall I retain this information? Y or N')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LT. 0) GOTO 308
      IF (LIT(1) .EQ. 'N') GOTO 407
      IF (LIT(1) .NE. 'Y') GOTO 308
      WRITE (9, 405)
  405 FORMAT (' Valid molecular formula and Z retained.')
  403 ISKIP = 1
      DO 406 I = 1, NUMATO
      LIT(I) = CELATY(I)
  406 FNUM(I) = ATCNT(I)
      GOTO 431
  407 WRITE (9, 408)
  408 FORMAT (' Previous molecular formula and Z rejected.')
  409 WRITE (9, 410)
  410 FORMAT (' Enter the molecular formula: Atom Nr Atom Nr  ....' /
     * ' You must give the complete chemical formula. However, it is' /
     * ' possible to give a partial occupancy (e.g. hemihydrate).' /
     * ' It is allowed to separate distinct chemical fragments' /
     * ' as long as you do not give more than 10 combinations of' /
     * ' atomic symbol and number of atoms.' /
     * ' Numbers may be given as integers and/or reals.' /
     * ' Separate symbols and numbers by a blank...' )
      CALL KETERM(-1,-1,KEND)
      IF (NFNUM.GT.0 .AND. NFNUM.EQ.NLIT .AND. NFNUM.LE.10) GOTO 430
      WRITE (9, 420) NLIT, NFNUM
  420 FORMAT (' Error detected, you entered', I2, ' symbols and',
     * I2,' numbers.')
      GOTO 409
  430 NUMATO=NLIT
      NTYPE = NUMATO
  431 DO 450 I=1,NUMATO
      IF (FNUM(I) .LT. 0.001) THEN
         WRITE (9, 435) FNUM(I)
  435    FORMAT (' Error detected, zero or negative number', F8.2)
         GOTO 409
         ENDIF
      IF (LIT(I) (3:3) .NE. ' ') THEN
         WRITE (9, 436) LIT(I)
  436    FORMAT (' Illegal atom symbol: ', A6, ' Please, try again')
         GOTO 409
         ENDIF
      TEMP = LIT(I)(1:2)
      CALL CDATWT(TEMP, ATWT(I), IATNO(I), RADIUS(I),
     *   COVRAD(I), ATRAD(I), IERR)
      IF (IERR .NE. 0) THEN
         WRITE (9, 436) LIT(I)
         GOTO 409
         ENDIF
  450 CONTINUE
      DO 480 I=1, NUMATO
      CELATY(I) = LIT(I)(1:2)
      ATCNT(I) = FNUM(I)
      IATCNT(I) = ATCNT(I)+0.5
      CALL CDSFC0 (IATNO(I), SCTCOF(1,I))
      CALL CDSFC1 (IATNO(I), SCTCOF(6,I))
      CALL CDSFD1 (IATNO(I), IWAVE, DFP(I))
      CALL CDSFD2 (IATNO(I), IWAVE, DFDP(I))
      CALL CDABSC (IATNO(I), IWAVE, ABSCO(I), KEND)
      IF (KEND.GT.0) WRITE (24, 460) CELATY(I)
  460 FORMAT (' No mu/rho in the file for ',A2,' (approximation used)')
  480 CONTINUE
      IF (ISKIP.EQ.1) GOTO 544
  496 DO 520 I=1,20
      IFO = IFOR(I)
      AFO = FLOAT(IFO)
      AW=0.0
      DO 500 J=1,NUMATO
  500 AW=AW+ATCNT(J)*AFO*ATWT(J)
      DCALC=AVOGAD*AW/V
      IF (DCALC .LT. 0.8) GOTO 520
      IF (DCALC .GT. 3.0) GOTO 530
      WRITE (9, 510) IFO, DCALC
  510 FORMAT (' For',I3,' formula units per cell,  Dcalc is:', F6.3)
  520 CONTINUE
  530 TOTNOH = 0.0
      DO 531 I=1,NUMATO
  531 IF (IATNO(I) .NE. 1) TOTNOH = TOTNOH + ATCNT(I)
      TOTVOL = TOTNOH * 18.0
      ZPRED = VOLUM / TOTVOL
      WRITE (9, 541) IMULT
  541 FORMAT (' The multiplicity of the general position is:',I3 )
      WRITE (9, 542) ZPRED
  542 FORMAT (' Prediction based on volume considerations',
     *    ' (18 A**3 /atom) is: Z =',F6.2 )
      WRITE (9, 543)
  543 FORMAT
     *  (' Enter Z = number of formula units in the whole unit cell:')
      CALL KETERM(1,0,KEND)
      IF (KEND.EQ.-1) GOTO 496
      IFORM = FNUM(1) + 0.01
      IF (IFORM.GT.0) GOTO 544
      WRITE (9, 436) FNUM(1)
      GOTO 496
  544 AW = 0.0
      ABSLIN = 0.0
      F0002 = 0.0
      DO 550 I=1,NUMATO
      ATCEL(I) = FLOAT(IFORM) * ATCNT(I)
      IATCEL(I)=ATCEL(I)+0.5
      ABSLIN = ABSLIN + ABSCO(I)*ATCEL(I)*ATWT(I)
      AW = AW + ATCEL(I)*ATWT(I)
      F0002 = F0002 + ATCEL(I)*(SCTCOF(1,I) + SCTCOF(3,I) + SCTCOF(5,I)
     *  + SCTCOF(7,I) + SCTCOF(9,I))
  550 CONTINUE
      DCALC = AVOGAD*AW/V
      ABSLIN = ABSLIN/AW*DCALC
      AMOLW = AW / FLOAT(IFORM)
      RETURN
      END
      SUBROUTINE CRWRIT
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (IRUN, KSTAT(13)), (KP2, KEYS(21))
      COMMON /ATOMS/ NUMATO, ATCNT(10), IATCNT(10), IFORM, ATWT(10),
     *               IATNO(10), RADIUS(10), COVRAD(10), ATRAD(10),
     *               SCTCOF(9,10), DFP(10), DFDP(10), ABSCO(10),
     *               IATCEL(10), ABSLIN, DCALC, F0002, AMOL
      COMMON /CELTT/ CELLDT(25), AHEX, CHEX, ARHMB, ALPRHM, SIGV
      EQUIVALENCE
     * (CELLDT( 1), A    ),(CELLDT( 2), B    ),(CELLDT( 3), C    ),
     * (CELLDT( 4),CA    ),(CELLDT( 5),CB    ),(CELLDT( 6),CC    ),
     * (CELLDT( 7),SA    ),(CELLDT( 8),SB    ),(CELLDT( 9),SC    ),
     * (CELLDT(10), ALPHA),(CELLDT(11), BETA ),(CELLDT(12), GAMMA),
     * (CELLDT(13), ASTR ),(CELLDT(14), BSTR ),(CELLDT(15), CSTR ),
     * (CELLDT(16),CASTR ),(CELLDT(17),CBSTR ),(CELLDT(18),CCSTR ),
     * (CELLDT(19),SASTR ),(CELLDT(20),SBSTR ),(CELLDT(21),SCSTR ),
     * (CELLDT(22),ALPSTR),(CELLDT(23),BETSTR),(CELLDT(24),GAMSTR),
     * (CELLDT(25),V     )
      COMMON /MATRIX/ KEYORI, RR(3,3), SS(3,3), VV(3,3), WW(3,3),
     *                XX(3,3), YY(3,3)
      COMMON /SPACE/ LAUE, NAXIS, ICEN, LATCEN, NEQV, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      COMMON /WAVETT/ RLAMB1,RLAMB2,RLAMB3,RLAMB4,IWAVE
      DIMENSION ORGVEC(3,8)
      CHARACTER * 1  NAX(3)
      CHARACTER * 4  POLAR(8)
      CHARACTER * 8  LAUEGR(14)
      CHARACTER * 12 LTYP(7), SYST(8)
      DATA LTYP /   'Primitive   ', 'A-centered  ', 'B-centered  ',
     *              'C-centered  ', 'I-centered  ', 'F-centered  ',
     *              'R-centered  ' /
      DATA SYST /   'Triclinic   ', 'Monoclinic  ', 'Orthorhombic',
     *              'Tetragonal  ', 'Trigonal-Rho', 'Trigonal-Hex',
     *              'Hexagonal   ', 'Cubic       ' /
      DATA LAUEGR / '1bar    ', '2/m     ', 'mmm     ', '4/m     ',
     *              '4/mmm   ', '3bar    ', '3barm   ', '3bar    ',
     *              '3barm1  ', '3bar1m  ', '6/m     ', '6/mmm   ',
     *              'm3bar   ', 'm3barm  ' /
      DATA POLAR  / 'x   ',   'y   ',   'x y ',   'z   ',   'x z ',
     *              'y z ',   'xyz ',   '111 ' /
      DATA NAX    / 'A',      'B',      'C' /
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'OUTPUT', KICRYS)
      WRITE (ICRYS, 571) CCODE, IRUN
  571 FORMAT ('CRYSDA    ', A6, ' Crystal data file  RUN=', I4)
      WRITE (ICRYS, 576) CELL
  576 FORMAT ('CELL      ', 6F10.5)
      WRITE (ICRYS, 577) CELLSD
  577 FORMAT ('CELLSD    ', 6F10.5)
      WRITE (ICRYS, 579) SPGR
  579 FORMAT ('SPGR      ', A16)
      IF (NUMATO.LE.5) THEN
         WRITE (ICRYS, 581) (CELATY(I), IATCEL(I), I=1,NUMATO)
  581    FORMAT ('CELLCO    ', 5 (A2, I6, 4X))
      ELSE
         WRITE (ICRYS, 582) (CELATY(I), IATCEL(I), I=1,5)
  582    FORMAT ('CELLCO    ', 5 (A2, I6, 4X), ' =')
         WRITE (ICRYS, 583) (CELATY(I), IATCEL(I), I=6,NUMATO)
  583    FORMAT (10X, 5 (A2, I6, 4X))
         ENDIF
      WRITE (ICRYS, 601) ASTR, BSTR, CSTR, ALPSTR, BETSTR, GAMSTR
  601 FORMAT ('RCELL     ', 3F10.7, 3F10.5)
      WRITE (ICRYS, 604) V, SIGV
  604 FORMAT ('VOLUM     ', 2F10.3, 20X, 'Volume, Sigma(Volume)')
      NELEC=0
      DO 608 I=1,NUMATO
  608 NELEC=NELEC+IATCEL(I)*IATNO(I)
      WRITE (ICRYS, 610) WAVEAT, RLAMB3, RLAMB1, RLAMB2, RLAMB4
  610 FORMAT ('WAVE      ', A2, 8X, 4F10.6, ' <A>,A1,A2,B')
      IF (NUMATO.LE.5) THEN
         WRITE (ICRYS, 611) (CELATY(I), ATCNT(I), I=1,NUMATO)
  611    FORMAT ('FORMUL    ', 5 (A2, F9.2, 1X))
      ELSE
         WRITE (ICRYS, 623) (CELATY(I), ATCNT(I), I=1,5)
  623    FORMAT ('FORMUL    ', 5 (A2, F9.2, 1X), ' =')
         WRITE (ICRYS, 624) (CELATY(I), ATCNT(I), I=6,NUMATO)
  624    FORMAT ('          ', 5 (A2, F9.2, 1X))
         ENDIF
      WRITE (ICRYS, 612) AMOLW
      WRITE (ICRYS, 613) IFORM
      WRITE (ICRYS, 614) NELEC
      WRITE (ICRYS, 615) F0002
      WRITE (ICRYS, 616) ABSLIN
      WRITE (ICRYS, 617) DCALC
      WRITE (24, 618) DCALC
  612 FORMAT ('MOLW      ', F10.3, 10X, 'Molecular weight')
  613 FORMAT ('Z         ', I10,   10X, 'Number of formula units/cell')
  614 FORMAT ('NELEC     ', I10,   10X, 'Total number of electrons')
  615 FORMAT ('F000      ', F10.2, 10X, 'F000 including anom.scatt.')
  616 FORMAT ('MU        ', F10.3, 10X, 'Linear abs. coeff. in cm**-1')
  617 FORMAT ('DCALC     ', F10.3, 10X, 'Calculated density')
  618 FORMAT (' Calculated density:', F7.3)
      IF (ICEN.EQ.0) WRITE (ICRYS, 1006)
      IF (ICEN.EQ.1) WRITE (ICRYS, 1007)
      WRITE (ICRYS, 1008) LATCEN, LTYP(LATCEN)
      WRITE (ICRYS, 1009) NSYS, SYST(NSYS)
      WRITE (ICRYS, 1010) LAUE, LAUEGR(LAUE)
 1006 FORMAT ('ICENT     ', 9X, '1', 10X, 'Noncentrosymmetric')
 1007 FORMAT ('ICENT     ', 9X, '2', 10X, 'Centrosymmetric')
 1008 FORMAT ('ILATT     ', I10, 10X, A12)
 1009 FORMAT ('ISYST     ', I10, 10X, A12)
 1010 FORMAT ('ILAUE     ', I10, 10X, A8)
      IF ((LAUE.GE.8.AND.LAUE.LE.10) .AND. LATCEN.EQ.7)
     *   WRITE (ICRYS, 606) ARHMB, ALPRHM
  606 FORMAT ('EQRHOM    ', 2F10.5, 10X, 'Rhombohedral A and Alpha')
      IF (LAUE.EQ.6 .OR. LAUE.EQ.7) WRITE (ICRYS, 607) AHEX, CHEX
  607 FORMAT ('EQHEXA    ', 2F10.5, 10X, 'Hexagonal A and C')
      WRITE (ICRYS, 1011) MULTIP
      IF (NSYS.EQ.4 .OR. NSYS.EQ.6 .OR. NSYS.EQ.7) NAXIS = 3
      IF (NAXIS.GT.0) WRITE (ICRYS, 1012) NAXIS, NAX(NAXIS)
      IF (NAXIS.EQ.0) WRITE (ICRYS, 1013) NAXIS
      IF (NPOL.GT.0) WRITE (ICRYS, 1014) NPOL, POLAR(NPOL)
      IF (NPOL.LE.0) WRITE (ICRYS, 1015) NPOL
 1011 FORMAT ('IMULT     ', I10, 10X, 'Multiplicity of genl. position')
 1012 FORMAT ('IUNIQ     ', I10, 10X, A1, ' axis unique')
 1013 FORMAT ('IUNIQ     ', I10, 10X, 'No unique axis')
 1014 FORMAT ('IPOLA     ', I10, 10X, 'Polar along ', A4)
 1015 FORMAT ('IPOLA     ', I10, 10X, 'Not polar')
      WRITE (ICRYS, 1100) NUMATO
      DO 1099 I=1,NUMATO
      WRITE (ICRYS, 1101) CELATY(I), IATNO(I), ATWT(I), ABSCO(I),
     *                    RADIUS(I), COVRAD(I), ATRAD(I)
      AMU = ABSCO(I) * ATWT(I) * 1.66043
      WRITE (ICRYS, 1102) CELATY(I), (SCTCOF(J,I), J=1,6)
 1099 WRITE (ICRYS, 1103) (SCTCOF(J,I), J=7,9), DFP(I), DFDP(I), AMU,
     *                    COVRAD(I)
 1100 FORMAT ('NTYPE     ', I10, 10X, 'Number of atom types')
 1101 FORMAT ('ELEM      ', A2, 2X, I6, 5F10.5)
 1102 FORMAT ('SFAC  ', A2, 2X, 6F10.5, ' =')
 1103 FORMAT ('          ', 3F10.5, 2F7.3, F11.3, F5.2)
      CALL CRSYMM
      CALL ORIGIN (ORGVEC, NORIG)
      WRITE (ICRYS, 1104) NORIG
 1104 FORMAT ('NORIG     ',I10,10X,'Nr. of origin translation vectors')
      DO 1106 I = 1, NORIG
      WRITE (ICRYS, 1105) (ORGVEC(J,I),J=1,3)
 1105 FORMAT ('ORGVEC    ', 3F10.7)
 1106 CONTINUE
      WRITE (ICRYS, 1204) ((VV(I,J), J=1,3), I=1,3)
      WRITE (ICRYS, 1205) ((WW(I,J), J=1,3), I=1,3)
      WRITE (ICRYS, 1206) ((XX(I,J), J=1,3), I=1,3)
      WRITE (ICRYS, 1207) ((YY(I,J), J=1,3), I=1,3)
      IF (KEYORI .EQ. 1) WRITE (ICRYS, 1208) ((RR(I,J), J=1,3), I=1,3)
 1204 FORMAT ('FRAC2C    ', 3F15.6  / 10X, 3F15.6  /  10X, 3F15.6)
 1205 FORMAT ('CART2F    ', 3F15.11 / 10X, 3F15.11 /  10X, 3F15.11)
 1206 FORMAT ('RRMAT     ', 3F15.6  / 10X, 3F15.6  /  10X, 3F15.6)
 1207 FORMAT ('SSMAT     ', 3F15.11 / 10X, 3F15.11 /  10X, 3F15.11)
 1208 FORMAT ('ORIN      ', 3F15.11 / 10X, 3F15.11 /  10X, 3F15.11)
      WRITE (ICRYS, 1311)
 1311 FORMAT ('END       '/'END')
      WRITE (8, FMT='(A)')
     *  ' The CRYSDA file has been created'
      IF (IRUN .LE. 2 .OR. KP2 .EQ. 11 .OR. KP2 .EQ. 12) GOTO 584
      RETURN
  584 WRITE (24, FMT='(A)')
     *  '                                 : a print is given in LIS2'
      WRITE (8, 585)
  585 FORMAT (/' The following CRYSDA file has been created:' /)
      REWIND ICRYS
  589 READ (ICRYS, 586, END=587) CHIN
  586 FORMAT (A80)
      WRITE (8, 588) CHIN
  588 FORMAT (1X,A80)
      GOTO 589
  587 WRITE (8, 588)
      RETURN
      END
      SUBROUTINE CRSYMM
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      COMMON /MATRIX/ KEYORI, RR(3,3), SS(3,3), VV(3,3), WW(3,3),
     *                XX(3,3), YY(3,3)
      COMMON /SPACE/ LAUE, NAXIS, ICEN, LATCEN, NEQV, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      CHARACTER * 4  XYZ2(15), TRA(11), OUTL(3,2,1)
      DIMENSION TRA2(11)
      DIMENSION IG(3,4),NCEN2(3,4),NCENV2(3,6)
      DATA XYZ2  /  '-Z  ',   '-Y  ',   '-X  ',   'X-Y ',   'ERR ',
     *              'Y-X ',   ' X  ',   ' Y  ',   ' Z  ',   '+X-Y',
     *              'ERR ',   '+Y-X',   '+X  ',   '+Y  ',   '+Z  ' /
      DATA TRA   /  '    ',   'ERR ',   '1/6 ',   '1/4 ',   '1/3 ',
     *              'ERR ',   '1/2 ',   'ERR ',   '2/3 ',   '3/4 ',
     *              '5/6 ' /
      DATA
     * TRA2( 1),TRA2( 2),TRA2( 3) /0.0      ,0.0      ,0.1666667/,
     * TRA2( 4),TRA2( 5),TRA2( 6) /0.25     ,0.3333333,0.0      /,
     * TRA2( 7),TRA2( 8),TRA2( 9) /0.5      ,0.0      ,0.6666667/,
     * TRA2(10),TRA2(11)          /0.75     ,0.8333333/
      DATA
     * NCENV2(1,1),NCENV2(2,1),NCENV2(3,1) /0,6,6/,
     * NCENV2(1,2),NCENV2(2,2),NCENV2(3,2) /6,0,6/,
     * NCENV2(1,3),NCENV2(2,3),NCENV2(3,3) /6,6,0/,
     * NCENV2(1,4),NCENV2(2,4),NCENV2(3,4) /6,6,6/,
     * NCENV2(1,5),NCENV2(2,5),NCENV2(3,5) /4,8,8/
      DATA
     * NCENV2(1,6),NCENV2(2,6),NCENV2(3,6) /8,4,4/
      DATA IJ2 / 0 /
      NCEN2(1,1)=0
      NCEN2(2,1)=0
      NCEN2(3,1)=0
      IF (NCV.LE.1) GOTO 110
      J=LATCEN-1
      IF (LATCEN.EQ.6) J = 1
      IF (LATCEN.EQ.7) J = 5
      DO 100 I=2,NCV
      NCEN2(1,I)=NCENV2(1,J)
      NCEN2(2,I)=NCENV2(2,J)
      NCEN2(3,I)=NCENV2(3,J)
      J=J+1
  100 CONTINUE
  110 CONTINUE
      WRITE (ICRYS, 7001) NEQV
 7001 FORMAT ('NSYMM     ', I10, 10X, 'Number of symmetry matrices')
      DO 7005 I=1,NEQV
      WRITE (ICRYS, 7010)
     *    ((JRT(J,K,I), K=1,3), TRA2(JRT(J,4,I)+1), J=1,3)
 7010 FORMAT ('SYMMAT    ', 3 (3I3, 1X, F10.7))
 7005 CONTINUE
      WRITE (ICRYS, 7020) NCV
 7020 FORMAT ('NLATT     ',I10,10X,'Nr. of lattice centering vectors')
      DO 7030 I=1,NCV
      WRITE (ICRYS, 7025) (CEN(J,I), J=1,3)
 7025 FORMAT ('CENVEC    ', 3F10.7)
 7030 CONTINUE
      NEQV2=(ICEN+1)*NEQV*NCV
      WRITE (ICRYS, 1008) NEQV2
 1008 FORMAT ('NSXYZ     ', I10, 10X,'Number of X,Y,Z symmetry cards')
      DO 5010 J=1,NCV
      DO 5100 I=1,NEQV
      DO 5001 J1=1,3
      DO 5001 J2=1,3
 5001 IG(J1,J2)=JRT(J1,J2,I)
      DO 5011 J1=1,3
      IG(J1,4)=JRT(J1,4,I)+NCEN2(J1,J)
      IF(IG(J1,4).GE.12) IG(J1,4)=IG(J1,4)-12
 5011 CONTINUE
      DO 5050 L=1,3
      IJ=2*IG(L,1)+3*IG(L,2)+4*IG(L,3)+5
      IK=IG(L,4)+1
      IF(IK.GT.1.AND.IJ.GT.3) IJ=IJ+6
      OUTL(L,2,1)=XYZ2(IJ)
      OUTL(L,1,1)=TRA(IK)
 5050 CONTINUE
      WRITE (ICRYS, 5005) (OUTL(I1,1,1),OUTL(I1,2,1),I1=1,3)
 5005 FORMAT ('SYMIT     ',2(A3,A4,' , '),A3,A4)
 5100 CONTINUE
      IF(ICEN.EQ.0) GOTO 5010
      DO 5101 I=1,NEQV
      DO 5102 J1=1,3
      DO 5102 J2=1,3
 5102 IG(J1,J2)=JRT(J1,J2,I)
      DO 5103 J1=1,3
      IG(J1,4)=JRT(J1,4,I)+NCEN2(J1,J)
      IF(IG(J1,4).GE.12) IG(J1,4)=IG(J1,4)-12
 5103 CONTINUE
      DO 5060 L=1,3
      IJ=2*IG(L,1)+3*IG(L,2)+4*IG(L,3)+5
      IF(IJ.GT.9) IJ2=16-IJ
      IF(IJ.LE.9) IJ2=10-IJ
      IG(L,4)=12-IG(L,4)
      IF(IG(L,4).GE.12) IG(L,4)=IG(L,4)-12
      IK=IG(L,4)+1
      IF(IK.GT.1.AND.IJ2.GT.3) IJ2=IJ2+6
      OUTL(L,2,1)=XYZ2(IJ2)
      OUTL(L,1,1)=TRA(IK)
 5060 CONTINUE
      WRITE (ICRYS, 5005) (OUTL(I1,1,1),OUTL(I1,2,1),I1=1,3)
 5101 CONTINUE
 5010 CONTINUE
      RETURN
      END
      SUBROUTINE INV33 (A)
      DIMENSION A(3,3),B(3)
      DO 7 L=1,3
      B(3)=1.0/A(1,1)
      DO 5 I = 2,3
    5 B(I-1)=A(I,1)*B(3)
      DO 6 I = 2,3
      A(3,I-1)=-A(1,I)*B(3)
      DO 6 J=2,3
    6 A(J-1,I-1)=A(J,I)-A(1,I)*B(J-1)
      DO 7 J=1,3
    7 A(J,3)=B(J)
      RETURN
      END
      SUBROUTINE MAVEC(A,B,C)
      DIMENSION A(3,3),B(3),C(3)
      DO 10 N=1,3
   10 C(N)=A(N,1)*B(1)+A(N,2)*B(2)+A(N,3)*B(3)
      RETURN
      END
      SUBROUTINE ANGV2(A,B,C)
      DIMENSION A(3),B(3),T(3)
      DATA RADIAN /57.2957795147/
      CO=A(1)*B(1)+A(2)*B(2)+A(3)*B(3)
      CALL VECAXB (A, B, T)
      T(1)=T(1)*T(1)+T(2)*T(2)+T(3)*T(3)
      SI=SQRT(T(1))
      C=ATAN2(SI,CO)*RADIAN
      RETURN
      END
      FUNCTION BETW(A,R)
      BETW=A-2.0*R*FLOAT(INT((SIGN(R,A)+A)/(2.0*R)))
      RETURN
      END
      FUNCTION COSD(A)
      DATA RADIAN /57.2957795147/
      COSD=COS(A/RADIAN)
      RETURN
      END
      FUNCTION SIND(A)
      DATA RADIAN /57.2957795147/
      SIND=SIN(A/RADIAN)
      RETURN
      END
      SUBROUTINE CDABSC (IZ, J, ABSC, KEND)
      DIMENSION ABSCO(100,5)
      DIMENSION ABSC11(25),ABSC12(25),ABSC13(25),ABSC14(25)
      DIMENSION ABSC21(25),ABSC22(25),ABSC23(25),ABSC24(25)
      DIMENSION ABSC31(25),ABSC32(25),ABSC33(25),ABSC34(25)
      DIMENSION ABSC41(25),ABSC42(25),ABSC43(25),ABSC44(25)
      DIMENSION ABSC51(25),ABSC52(25),ABSC53(25),ABSC54(25)
      EQUIVALENCE (ABSCO( 1,1),ABSC11(1)),(ABSCO(26,1),ABSC12(1))
      EQUIVALENCE (ABSCO(51,1),ABSC13(1)),(ABSCO(76,1),ABSC14(1))
      EQUIVALENCE (ABSCO( 1,2),ABSC21(1)),(ABSCO(26,2),ABSC22(1))
      EQUIVALENCE (ABSCO(51,2),ABSC23(1)),(ABSCO(76,2),ABSC24(1))
      EQUIVALENCE (ABSCO( 1,3),ABSC31(1)),(ABSCO(26,3),ABSC32(1))
      EQUIVALENCE (ABSCO(51,3),ABSC33(1)),(ABSCO(76,3),ABSC34(1))
      EQUIVALENCE (ABSCO( 1,4),ABSC41(1)),(ABSCO(26,4),ABSC42(1))
      EQUIVALENCE (ABSCO(51,4),ABSC43(1)),(ABSCO(76,4),ABSC44(1))
      EQUIVALENCE (ABSCO( 1,5),ABSC51(1)),(ABSCO(26,5),ABSC52(1))
      EQUIVALENCE (ABSCO(51,5),ABSC53(1)),(ABSCO(76,5),ABSC54(1))
      DATA ABSC11 /
     * 0.3663E+00, 0.1931E+00, 0.1788E+00, 0.2047E+00, 0.2558E+00,
     * 0.3537E+00, 0.4756E+00, 0.6479E+00, 0.8507E+00, 0.1163E+01,
     * 0.1501E+01, 0.2004E+01, 0.2540E+01, 0.3254E+01, 0.3911E+01,
     * 0.4816E+01, 0.5803E+01, 0.6280E+01, 0.8080E+01, 0.9573E+01,
     * 0.1054E+02, 0.1176E+02, 0.1278E+02, 0.1488E+02, 0.1623E+02/
      DATA ABSC12 /
     * 0.1931E+02, 0.2092E+02, 0.2432E+02, 0.2552E+02, 0.2872E+02,
     * 0.2993E+02, 0.3178E+02, 0.3500E+02, 0.3723E+02, 0.4041E+02,
     * 0.4253E+02, 0.4533E+02, 0.4789E+02, 0.5296E+02, 0.5524E+02,
     * 0.5963E+02, 0.6253E+02, 0.6499E+02, 0.1100E+02, 0.1191E+02,
     * 0.1258E+02, 0.1367E+02, 0.1445E+02, 0.1525E+02, 0.1619E+02/
      DATA ABSC13 /
     * 0.1705E+02, 0.1772E+02, 0.1918E+02, 0.2001E+02, 0.2131E+02,
     * 0.2245E+02, 0.2385E+02, 0.2572E+02, 0.2680E+02, 0.2802E+02,
     * 0.2925E+02, 0.3069E+02, 0.3240E+02, 0.3330E+02, 0.3542E+02,
     * 0.3652E+02, 0.3831E+02, 0.3983E+02, 0.4212E+02, 0.4321E+02,
     * 0.4527E+02, 0.4693E+02, 0.4825E+02, 0.5140E+02, 0.5278E+02/
      DATA ABSC14 /
     * 0.5424E+02, 0.5675E+02, 0.5858E+02, 0.6021E+02, 0.6263E+02,
     * 0.6456E+02, 0.6614E+02, 0.6873E+02, 0.2000E+04, 0.2000E+04,
     * 0.7414E+02, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.8629E+02,
     * 0.2000E+04, 0.8692E+02, 0.2000E+04, 0.5876E+02, 0.2000E+04,
     * 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04/
      DATA ABSC21 /
     * 0.3727E+00, 0.2019E+00, 0.1968E+00, 0.2451E+00, 0.3451E+00,
     * 0.5348E+00, 0.7898E+00, 0.1147E+01, 0.1584E+01, 0.2209E+01,
     * 0.2939E+01, 0.3979E+01, 0.5043E+01, 0.6533E+01, 0.7870E+01,
     * 0.9625E+01, 0.1164E+02, 0.1262E+02, 0.1620E+02, 0.1900E+02,
     * 0.2104E+02, 0.2325E+02, 0.2524E+02, 0.2925E+02, 0.3186E+02/
      DATA ABSC22 /
     * 0.3774E+02, 0.4102E+02, 0.4724E+02, 0.4934E+02, 0.5546E+02,
     * 0.5690E+02, 0.6047E+02, 0.6597E+02, 0.6882E+02, 0.7468E+02,
     * 0.7910E+02, 0.8300E+02, 0.8804E+02, 0.9756E+02, 0.1610E+02,
     * 0.1696E+02, 0.1844E+02, 0.1978E+02, 0.2133E+02, 0.2305E+02,
     * 0.2442E+02, 0.2638E+02, 0.2773E+02, 0.2913E+02, 0.3118E+02/
      DATA ABSC23 /
     * 0.3301E+02, 0.3392E+02, 0.3633E+02, 0.3831E+02, 0.4044E+02,
     * 0.4237E+02, 0.4534E+02, 0.4856E+02, 0.5078E+02, 0.5328E+02,
     * 0.5552E+02, 0.5796E+02, 0.6118E+02, 0.6279E+02, 0.6677E+02,
     * 0.6889E+02, 0.7214E+02, 0.7561E+02, 0.7898E+02, 0.8023E+02,
     * 0.8418E+02, 0.8633E+02, 0.8951E+02, 0.9576E+02, 0.9874E+02/
      DATA ABSC24 /
     * 0.1002E+03, 0.1034E+03, 0.1086E+03, 0.1113E+03, 0.1147E+03,
     * 0.1194E+03, 0.1228E+03, 0.1259E+03, 0.2000E+04, 0.2000E+04,
     * 0.1172E+03, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.9946E+02,
     * 0.2000E+04, 0.9667E+02, 0.2000E+04, 0.4884E+02, 0.2000E+04,
     * 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04/
      DATA ABSC31 /
     * 0.3912E+00, 0.2835E+00, 0.4770E+00, 0.1007E+01, 0.2142E+01,
     * 0.4219E+01, 0.7142E+01, 0.1103E+02, 0.1595E+02, 0.2213E+02,
     * 0.3030E+02, 0.4088E+02, 0.5023E+02, 0.6532E+02, 0.7728E+02,
     * 0.9253E+02, 0.1092E+03, 0.1195E+03, 0.1484E+03, 0.1714E+03,
     * 0.1860E+03, 0.2024E+03, 0.2226E+03, 0.2523E+03, 0.2725E+03/
      DATA ABSC32 /
     * 0.3044E+03, 0.3386E+03, 0.4883E+02, 0.5154E+02, 0.5951E+02,
     * 0.6213E+02, 0.6792E+02, 0.7565E+02, 0.8289E+02, 0.9029E+02,
     * 0.9702E+02, 0.1063E+03, 0.1153E+03, 0.1271E+03, 0.1368E+03,
     * 0.1488E+03, 0.1583E+03, 0.1677E+03, 0.1808E+03, 0.1941E+03,
     * 0.2050E+03, 0.2181E+03, 0.2293E+03, 0.2421E+03, 0.2533E+03/
      DATA ABSC33 /
     * 0.2665E+03, 0.2734E+03, 0.2917E+03, 0.3098E+03, 0.3254E+03,
     * 0.3361E+03, 0.3535E+03, 0.3788E+03, 0.4022E+03, 0.4179E+03,
     * 0.4411E+03, 0.4535E+03, 0.4179E+03, 0.4267E+03, 0.3219E+03,
     * 0.3366E+03, 0.1284E+03, 0.1343E+03, 0.1402E+03, 0.1447E+03,
     * 0.1520E+03, 0.1577E+03, 0.1615E+03, 0.1705E+03, 0.1783E+03/
      DATA ABSC34 /
     * 0.1838E+03, 0.1922E+03, 0.1982E+03, 0.2078E+03, 0.2162E+03,
     * 0.2222E+03, 0.2321E+03, 0.2429E+03, 0.2000E+04, 0.2000E+04,
     * 0.2637E+03, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.3068E+03,
     * 0.2000E+04, 0.3057E+03, 0.2000E+04, 0.3529E+03, 0.2000E+04,
     * 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04/
      DATA ABSC41 /
     * 0.4003E+00, 0.3616E+00, 0.7977E+00, 0.1916E+01, 0.4282E+01,
     * 0.8547E+01, 0.1449E+02, 0.2223E+02, 0.3196E+02, 0.4400E+02,
     * 0.5994E+02, 0.8021E+02, 0.9754E+02, 0.1260E+03, 0.1476E+03,
     * 0.1766E+03, 0.2046E+03, 0.2251E+03, 0.2745E+03, 0.3190E+03,
     * 0.3389E+03, 0.3701E+03, 0.4114E+03, 0.4622E+03, 0.5993E+02/
      DATA ABSC42 /
     * 0.7040E+02, 0.7829E+02, 0.9176E+02, 0.9736E+02, 0.1096E+03,
     * 0.1173E+03, 0.1264E+03, 0.1416E+03, 0.1555E+03, 0.1686E+03,
     * 0.1807E+03, 0.1979E+03, 0.2154E+03, 0.2353E+03, 0.2538E+03,
     * 0.2759E+03, 0.2926E+03, 0.3102E+03, 0.3325E+03, 0.3567E+03,
     * 0.3749E+03, 0.3984E+03, 0.4220E+03, 0.4492E+03, 0.4597E+03/
      DATA ABSC43 /
     * 0.4794E+03, 0.4973E+03, 0.5353E+03, 0.5649E+03, 0.5966E+03,
     * 0.6149E+03, 0.6356E+03, 0.5923E+03, 0.4501E+03, 0.4635E+03,
     * 0.1856E+03, 0.1917E+03, 0.2025E+03, 0.2073E+03, 0.2192E+03,
     * 0.2270E+03, 0.2335E+03, 0.2441E+03, 0.2551E+03, 0.2632E+03,
     * 0.2762E+03, 0.2864E+03, 0.2928E+03, 0.3057E+03, 0.3209E+03/
      DATA ABSC44 /
     * 0.3315E+03, 0.3480E+03, 0.3646E+03, 0.3705E+03, 0.3882E+03,
     * 0.3998E+03, 0.4177E+03, 0.4345E+03, 0.2000E+04, 0.2000E+04,
     * 0.4743E+03, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.5493E+03,
     * 0.2000E+04, 0.5452E+03, 0.2000E+04, 0.6376E+03, 0.2000E+04,
     * 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04/
      DATA ABSC51 /
     * 0.4116E+00, 0.4648E+00, 0.1243E+01, 0.3183E+01, 0.7232E+01,
     * 0.1446E+02, 0.2442E+02, 0.3719E+02, 0.5314E+02, 0.7271E+02,
     * 0.9848E+02, 0.1308E+03, 0.1580E+03, 0.2027E+03, 0.2355E+03,
     * 0.2819E+03, 0.3215E+03, 0.3555E+03, 0.4268E+03, 0.4996E+03,
     * 0.5209E+03, 0.5714E+03, 0.7506E+02, 0.8571E+02, 0.9608E+02/
      DATA ABSC52 /
     * 0.1131E+03, 0.1246E+03, 0.1457E+03, 0.1552E+03, 0.1717E+03,
     * 0.1869E+03, 0.1999E+03, 0.2240E+03, 0.2461E+03, 0.2662E+03,
     * 0.2846E+03, 0.3117E+03, 0.3393E+03, 0.3689E+03, 0.3986E+03,
     * 0.4319E+03, 0.4574E+03, 0.4855E+03, 0.5179E+03, 0.5552E+03,
     * 0.5809E+03, 0.6174E+03, 0.6588E+03, 0.7058E+03, 0.7088E+03/
      DATA ABSC53 /
     * 0.7334E+03, 0.7689E+03, 0.8352E+03, 0.7554E+03, 0.8027E+03,
     * 0.5873E+03, 0.2229E+03, 0.2404E+03, 0.2605E+03, 0.2713E+03,
     * 0.2847E+03, 0.2950E+03, 0.3127E+03, 0.3189E+03, 0.3389E+03,
     * 0.3517E+03, 0.3633E+03, 0.3797E+03, 0.3970E+03, 0.4096E+03,
     * 0.4295E+03, 0.4450E+03, 0.4547E+03, 0.4704E+03, 0.4955E+03/
      DATA ABSC54 /
     * 0.5124E+03, 0.5396E+03, 0.5716E+03, 0.5680E+03, 0.5979E+03,
     * 0.6169E+03, 0.6445E+03, 0.6672E+03, 0.2000E+04, 0.2000E+04,
     * 0.7314E+03, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.8441E+03,
     * 0.2000E+04, 0.7740E+03, 0.2000E+04, 0.8032E+03, 0.2000E+04,
     * 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04, 0.2000E+04/
      I = IZ
      KEND = 0
      IF (IZ.LE.83 .OR. IZ.EQ.86 .OR. IZ.EQ.90) GOTO 111
      IF (IZ.EQ.92 .OR. IZ.EQ.94) GOTO 111
      IF (IZ.EQ.84) I=83
      IF (IZ.GE.85) I=86
      IF (IZ.GE.88) I=90
      IF (IZ.GE.91) I=92
      IF (IZ.GE.93) I=94
      KEND = I
  111 ABSC = ABSCO(I,J)
      RETURN
      END
      SUBROUTINE CDATWT(ASYMB,ATWT,IATNO,RADIUS,COVRAD,ATRAD,IERRX)
      CHARACTER * 2  ASY1(25), ASY2(25), ASY3(25), ASY4(25), ASY5(2)
      CHARACTER * 2  ASYM(102), ASYMB
      DIMENSION AWGT(102),ARAD(102),COVR(102),ATOR(102)
      DIMENSION AWG1(25),AWG2(25),AWG3(25),AWG4(25),AWG5(2)
      DIMENSION ARA1(25),ARA2(25),ARA3(25),ARA4(25),ARA5(2)
      DIMENSION ARC1(25),ARC2(25),ARC3(25),ARC4(25),ARC5(2)
      DIMENSION ATR1(25),ATR2(25),ATR3(25),ATR4(25),ATR5(2)
      EQUIVALENCE (ASYM(  1),ASY1(1))
      EQUIVALENCE (ASYM( 26),ASY2(1))
      EQUIVALENCE (ASYM( 51),ASY3(1))
      EQUIVALENCE (ASYM( 76),ASY4(1))
      EQUIVALENCE (ASYM(101),ASY5(1))
      EQUIVALENCE (AWGT(  1),AWG1(1))
      EQUIVALENCE (AWGT( 26),AWG2(1))
      EQUIVALENCE (AWGT( 51),AWG3(1))
      EQUIVALENCE (AWGT( 76),AWG4(1))
      EQUIVALENCE (AWGT(101),AWG5(1))
      EQUIVALENCE (ARAD(  1),ARA1(1))
      EQUIVALENCE (ARAD( 26),ARA2(1))
      EQUIVALENCE (ARAD( 51),ARA3(1))
      EQUIVALENCE (ARAD( 76),ARA4(1))
      EQUIVALENCE (ARAD(101),ARA5(1))
      EQUIVALENCE (COVR(  1),ARC1(1))
      EQUIVALENCE (COVR( 26),ARC2(1))
      EQUIVALENCE (COVR( 51),ARC3(1))
      EQUIVALENCE (COVR( 76),ARC4(1))
      EQUIVALENCE (COVR(101),ARC5(1))
      EQUIVALENCE (ATOR(  1),ATR1(1))
      EQUIVALENCE (ATOR( 26),ATR2(1))
      EQUIVALENCE (ATOR( 51),ATR3(1))
      EQUIVALENCE (ATOR( 76),ATR4(1))
      EQUIVALENCE (ATOR(101),ATR5(1))
      DATA ASY1  / 'H ', 'HE', 'LI', 'BE', 'B ', 'C ', 'N ', 'O ',
     *             'F ', 'NE', 'NA', 'MG', 'AL', 'SI', 'P ', 'S ',
     *             'CL', 'AR', 'K ', 'CA', 'SC', 'TI', 'V ', 'CR', 'MN'/
      DATA ASY2  / 'FE', 'CO', 'NI', 'CU', 'ZN', 'GA', 'GE', 'AS',
     *             'SE', 'BR', 'KR', 'RB', 'SR', 'Y ', 'ZR', 'NB',
     *             'MO', 'TC', 'RU', 'RH', 'PD', 'AG', 'CD', 'IN', 'SN'/
      DATA ASY3  / 'SB', 'TE', 'I ', 'XE', 'CS', 'BA', 'LA', 'CE',
     *             'PR', 'ND', 'PM', 'SM', 'EU', 'GD', 'TB', 'DY',
     *             'HO', 'ER', 'TM', 'YB', 'LU', 'HF', 'TA', 'W ', 'RE'/
      DATA ASY4  / 'OS', 'IR', 'PT', 'AU', 'HG', 'TL', 'PB', 'BI',
     *             'PO', 'AT', 'RN', 'FR', 'RA', 'AC', 'TH', 'PA',
     *             'U ', 'NP', 'PU', 'AM', 'CM', 'BK', 'CF', 'ES', 'FM'/
      DATA ASY5  / 'D ', 'T ' /
      DATA AWG1 /
     *    1.0079  ,   4.00260 ,   6.941   ,   9.01218 ,  10.81    ,
     *   12.011   ,  14.0067  ,  15.9994  ,  18.998403,  20.179   ,
     *   22.98977 ,  24.305   ,  26.98154 ,  28.0855  ,  30.97376 ,
     *   32.06    ,  35.453   ,  39.948   ,  39.0983  ,  40.08    ,
     *   44.9559  ,  47.90    ,  50.9415  ,  51.996   ,  54.9380  /
      DATA AWG2 /
     *   55.847   ,  58.9332  ,  58.70    ,  63.546   ,  65.38    ,
     *   69.72    ,  72.59    ,  74.9216  ,  78.96    ,  79.904   ,
     *   83.80    ,  85.4678  ,  87.62    ,  88.9059  ,  91.22    ,
     *   92.9064  ,  95.94    ,  98.      , 101.07    , 102.9055  ,
     *  106.4     , 107.868   , 112.41    , 114.82    , 118.69    /
      DATA AWG3 /
     *  121.75    , 127.60    , 126.9045  , 131.30    , 132.9054  ,
     *  137.33    , 138.9055  , 140.12    , 140.9077  , 144.24    ,
     *  145.      , 150.4     , 151.96    , 157.25    , 158.9254  ,
     *  162.50    , 164.9304  , 167.26    , 168.9342  , 173.04    ,
     *  174.967   , 178.49    , 180.9479  , 183.85    , 186.207   /
      DATA AWG4 /
     *  190.2     , 192.22    , 195.09    , 196.9665  , 200.59    ,
     *  204.37    , 207.2     , 208.9804  , 209.      , 210.      ,
     *  222.      , 223.      , 226.0254  , 227.0278  , 232.0381  ,
     *  231.0359  , 238.029   , 237.0482  , 244.      , 243.      ,
     *  247.      , 247.      , 251.      , 252.      , 257.      /
      DATA AWG5 /
     *    2.0141  ,   3.0160  /
      DATA ARA1 /
     *  0.78  , 1.25  , 1.562 , 1.128 , 0.98  ,
     *  0.916 , 0.88  , 0.89  , 1.10  , 1.30  ,
     *  1.911 , 1.602 , 1.432 , 1.319 , 1.28  ,
     *  1.27  , 1.50  , 1.80  , 2.376 , 1.974 ,
     *  1.641 , 1.462 , 1.346 , 1.360 , 1.304 /
      DATA ARA2 /
     *  1.274 , 1.252 , 1.246 , 1.278 , 1.394 ,
     *  1.411 , 1.369 , 1.39  , 1.40  , 1.60  ,
     *  1.90  , 2.546 , 2.151 , 1.801 , 1.602 ,
     *  1.468 , 1.400 , 1.360 , 1.339 , 1.345 ,
     *  1.376 , 1.445 , 1.568 , 1.663 , 1.623 /
      DATA ARA3 /
     *  1.59  , 1.60  , 1.70  , 2.10  , 2.731 ,
     *  2.243 , 1.877 , 1.825 , 1.828 , 1.821 ,
     *  1.810 , 1.802 , 2.042 , 1.802 , 1.782 ,
     *  1.773 , 1.776 , 1.757 , 1.746 , 1.904 ,
     *  1.734 , 1.580 , 1.467 , 1.408 , 1.375 /
      DATA ARA4 /
     *  1.353 , 1.357 , 1.387 , 1.442 , 1.573 ,
     *  1.716 , 1.750 , 1.70  , 1.76  , 1.80  ,
     *  2.20  , 2.80  , 2.26  , 1.878 , 1.798 ,
     *  1.63  , 1.56  , 1.595 , 1.64  , 1.81  ,
     *  2.    , 2.    , 2.    , 2.    , 2.    /
      DATA ARA5 /
     *  0.78  , 0.78  /
      DATA ARC1 /
     *  0.32  , 0.93  , 1.23  , 0.90  , 0.82  ,
     *  0.77  , 0.75  , 0.73  , 0.72  , 0.71  ,
     *  1.54  , 1.36  , 1.18  , 1.11  , 1.06  ,
     *  1.02  , 0.99  , 0.98  , 2.03  , 1.74  ,
     *  1.44  , 1.32  , 1.22  , 1.18  , 1.17  /
      DATA ARC2 /
     *  1.17  , 1.16  , 1.15  , 1.17  , 1.25  ,
     *  1.26  , 1.22  , 1.20  , 1.16  , 1.14  ,
     *  1.12  , 2.16  , 1.91  , 1.62  , 1.45  ,
     *  1.34  , 1.30  , 1.27  , 1.25  , 1.25  ,
     *  1.28  , 1.34  , 1.48  , 1.44  , 1.41  /
      DATA ARC3 /
     *  1.40  , 1.36  , 1.33  , 1.31  , 2.35  ,
     *  1.98  , 1.69  , 1.65  , 1.65  , 1.64  ,
     *  1.63  , 1.62  , 1.85  , 1.61  , 1.59  ,
     *  1.59  , 1.58  , 1.57  , 1.56  , 1.74  ,
     *  1.56  , 1.44  , 1.34  , 1.30  , 1.28  /
      DATA ARC4 /
     *  1.26  , 1.27  , 1.30  , 1.34  , 1.49  ,
     *  1.48  , 1.47  , 1.46  , 1.46  , 1.45  ,
     *  1.5   , 1.5   , 1.5   , 1.5   , 1.65  ,
     *  1.5   , 1.42  , 1.5   , 1.5   , 1.5   ,
     *  1.5   , 1.5   , 1.5   , 1.5   , 1.5   /
      DATA ARC5 /
     *  0.32  , 0.32  /
      DATA ATR1 /
     *  0.79  , 0.49  , 2.05  , 1.40  , 1.17  ,
     *  0.91  , 0.75  , 0.65  , 0.57  , 0.51  ,
     *  2.23  , 1.72  , 1.82  , 1.46  , 1.23  ,
     *  1.09  , 0.97  , 0.88  , 2.77  , 2.23  ,
     *  2.09  , 2.00  , 1.92  , 1.85  , 1.79  /
      DATA ATR2 /
     *  1.72  , 1.67  , 1.62  , 1.57  , 1.53  ,
     *  1.81  , 1.52  , 1.33  , 1.22  , 1.12  ,
     *  1.03  , 2.98  , 2.45  , 2.27  , 2.16  ,
     *  2.08  , 2.01  , 1.95  , 1.89  , 1.83  ,
     *  1.79  , 1.75  , 1.71  , 2.00  , 1.72  /
      DATA ATR3 /
     *  1.53  , 1.42  , 1.32  , 1.24  , 3.34  ,
     *  2.78  , 2.74  , 2.70  , 2.67  , 2.64  ,
     *  2.62  , 2.59  , 2.56  , 2.54  , 2.51  ,
     *  2.49  , 2.47  , 2.45  , 2.42  , 2.40  ,
     *  2.25  , 2.16  , 2.09  , 2.02  , 1.97  /
      DATA ATR4 /
     *  1.92  , 1.87  , 1.83  , 1.79  , 1.76  ,
     *  2.08  , 1.81  , 1.63  , 1.53  , 1.43  ,
     *  1.34  , 2.    , 2.    , 2.    , 2.    ,
     *  2.    , 2.    , 2.    , 2.    , 2.    ,
     *  2.    , 2.    , 2.    , 2.    , 2.    /
      DATA ATR5 /
     *  0.79  , 0.79  /
      IERRX = 0
      DO 120 J=1,102
      IATNO = J
      IF (ASYMB.EQ.ASYM(J)) GOTO 130
  120 CONTINUE
      IERRX = 1
      ATWT = 0.0
      RADIUS = 0.0
      COVRAD = 0.0
      ATRAD = 0.0
      IATNO = 0
      RETURN
  130 RADIUS = ARAD(IATNO)
      ATWT = AWGT(IATNO)
      COVRAD = COVR(IATNO)
      ATRAD = ATOR(IATNO)
      IF (IATNO.GT.100 ) IATNO=1
      RETURN
      END
      SUBROUTINE CDSFC0 (IZ, F)
      DIMENSION F(5)
      DIMENSION SCFCO(100,5)
      DIMENSION A11(25),B11(25),A21(25),B21(25),A31(25)
      DIMENSION A12(25),B12(25),A22(25),B22(25),A32(25)
      DIMENSION A13(25),B13(25),A23(25),B23(25),A33(25)
      DIMENSION A14(25),B14(25),A24(25),B24(25),A34(25)
      EQUIVALENCE (SCFCO( 1,1),A11(1)),(SCFCO(26,1),A12(1))
      EQUIVALENCE (SCFCO(51,1),A13(1)),(SCFCO(76,1),A14(1))
      EQUIVALENCE (SCFCO( 1,2),B11(1)),(SCFCO(26,2),B12(1))
      EQUIVALENCE (SCFCO(51,2),B13(1)),(SCFCO(76,2),B14(1))
      EQUIVALENCE (SCFCO( 1,3),A21(1)),(SCFCO(26,3),A22(1))
      EQUIVALENCE (SCFCO(51,3),A23(1)),(SCFCO(76,3),A24(1))
      EQUIVALENCE (SCFCO( 1,4),B21(1)),(SCFCO(26,4),B22(1))
      EQUIVALENCE (SCFCO(51,4),B23(1)),(SCFCO(76,4),B24(1))
      EQUIVALENCE (SCFCO( 1,5),A31(1)),(SCFCO(26,5),A32(1))
      EQUIVALENCE (SCFCO(51,5),A33(1)),(SCFCO(76,5),A34(1))
      DATA A11 /
     *   0.493002,   0.873400,   1.12820 ,   1.59190 ,   2.05450 ,
     *   2.31000 ,  12.2126  ,   3.04850 ,   3.53920 ,   3.95530 ,
     *   4.76260 ,   5.42040 ,   6.42020 ,   6.29150 ,   6.43450 ,
     *   6.90530 ,  11.4604  ,   7.48450 ,   8.21860 ,   8.62660 ,
     *   9.18900 ,   9.75950 ,  10.2971  ,   10.6406 ,  11.2819  /
      DATA A12 /
     *  11.7695  ,  12.2841  ,  12.8376  ,  13.3380  ,  14.0743  ,
     *  15.2354  ,  16.0816  ,  16.6723  ,  17.0006  ,  17.1789  ,
     *  17.3555  ,  17.1784  ,  17.5663  ,  17.7760  ,  17.8765  ,
     *  17.6142  ,   3.70250 ,  19.1301  ,  19.2674  ,  19.2957  ,
     *  19.3319  ,  19.2808  ,  19.2214  ,  19.1624  ,  19.1889  /
      DATA A13 /
     *  19.6418  ,  19.9644  ,  20.1472  ,  20.2933  ,  20.3892  ,
     *  20.3361  ,  20.5780  ,  21.1671  ,  22.0440  ,  22.6845  ,
     *  23.3405  ,  24.0042  ,  24.6274  ,  25.0709  ,  25.8976  ,
     *  26.5070  ,  26.9049  ,  27.6563  ,  28.1819  ,  28.6641  ,
     *  28.9476  ,  29.1440  ,  29.2024  ,  29.0818  ,  28.7621  /
      DATA A14 /
     *  28.1894  ,  27.3049  ,  27.0059  ,  16.8819  ,  20.6809  ,
     *  27.5446  ,  31.0617  ,  33.3689  ,  34.6726  ,  35.3163  ,
     *  35.5631  ,  35.9299  ,  35.7630  ,  35.6597  ,  35.5645  ,
     *  35.8847  ,  36.0228  ,  36.1874  ,  36.5254  ,  36.6706  ,
     *  36.6488  ,  36.7881  ,  36.9185  ,   0.0     ,   0.0     /
      DATA B11 /
     *  10.5109  ,   9.10370 ,   3.95460 ,  43.6427  ,  23.2185  ,
     *  20.8439  ,   0.005700,  13.2771  ,  10.2825  ,   8.40420 ,
     *   3.28500 ,   2.82750 ,   3.03870 ,   2.43860 ,   1.90670 ,
     *   1.46790 ,   0.010400,   0.907200,  12.7949  ,  10.4421  ,
     *   9.02130 ,   7.85080 ,   6.86570 ,   6.10380 ,   5.34090 /
      DATA B12 /
     *   4.76110 ,   4.27910 ,   3.87850 ,   3.58280 ,   3.26550 ,
     *   3.06690 ,   2.85090 ,   2.63450 ,   2.40980 ,   2.17230 ,
     *   1.93840 ,   1.78880 ,   1.55640 ,   1.40290 ,   1.27618 ,
     *   1.18865 ,   0.277200,   0.864132,   0.808520,   0.751536,
     *   0.698655,   0.644600,   0.594600,   0.547600,   5.83030 /
      DATA B13 /
     *   5.30340 ,   4.81742 ,   4.34700 ,   3.92820 ,   3.56900 ,
     *   3.21600 ,   2.94817 ,   2.81219 ,   2.77393 ,   2.66248 ,
     *   2.56270 ,   2.47274 ,   2.38790 ,   2.25341 ,   2.24256 ,
     *   2.18020 ,   2.07051 ,   2.07356 ,   2.02859 ,   1.98890 ,
     *   1.90182 ,   1.83262 ,   1.77333 ,   1.72029 ,   1.67191 /
      DATA B14 /
     *   1.62903 ,   1.59279 ,   1.51293 ,   0.461100,   0.545000,
     *   0.655150,   0.690200,   0.704000,   0.700999,   0.685870,
     *   0.663100,   0.646453,   0.616341,   0.589092,   0.563359,
     *   0.547751,   0.529300,   0.511929,   0.499384,   0.483629,
     *   0.465154,   0.451018,   0.437533,   0.0     ,   0.0     /
      DATA A21 /
     *   0.322912,   0.630900,   0.750800,   1.12780 ,   1.33260 ,
     *   1.02000 ,   3.13220 ,   2.28680 ,   2.64120 ,   3.11250 ,
     *   3.17360 ,   2.17350 ,   1.90020 ,   3.03530 ,   4.17910 ,
     *   5.20340 ,   7.19640 ,   6.77230 ,   7.43980 ,   7.38730 ,
     *   7.36790 ,   7.35580 ,   7.35110 ,   7.35370 ,   7.35730 /
      DATA A22 /
     *   7.35730 ,   7.34090 ,   7.29200 ,   7.16760 ,   7.03180 ,
     *   6.70060 ,   6.37470 ,   6.07010 ,   5.81960 ,   5.23580 ,
     *   6.72860 ,   9.64350 ,   9.81840 ,  10.2946  ,  10.9480  ,
     *  12.0144  ,  17.2356  ,  11.0948  ,  12.9182  ,  14.3501  ,
     *  15.5017  ,  16.6885  ,  17.6444  ,  18.5596  ,  19.1005  /
      DATA A23 /
     *  19.0455  ,  19.0138  ,  18.9949  ,  19.0298  ,  19.1062  ,
     *  19.2970  ,  19.5990  ,  19.7695  ,  19.6697  ,  19.6847  ,
     *  19.6095  ,  19.4258  ,  19.0886  ,  19.0798  ,  18.2185  ,
     *  17.6383  ,  17.2940  ,  16.4285  ,  15.8851  ,  15.4345  ,
     *  15.2208  ,  15.1726  ,  15.2293  ,  15.4300  ,  15.7189  /
      DATA A24 /
     *  16.1550  ,  16.7296  ,  17.7639  ,  18.5913  ,  19.0417  ,
     *  19.1584  ,  13.0637  ,  12.9510  ,  15.4733  ,  19.0211  ,
     *  21.2816  ,  23.0547  ,  22.9064  ,  23.1032  ,  23.4219  ,
     *  23.2948  ,  23.4128  ,  23.5964  ,  23.8083  ,  24.0992  ,
     *  24.4096  ,  24.7736  ,  25.1995  ,   0.0     ,   0.0     /
      DATA B21 /
     *  26.1257  ,   3.35680 ,   1.05240 ,   1.86230 ,   1.02100 ,
     *  10.2075  ,   9.89330 ,   5.70110 ,   4.29440 ,   3.42620 ,
     *   8.84220 ,  79.2611  ,   0.742600,  32.3337  ,  27.1570  ,
     *  22.2151  ,   1.16620 ,  14.8407  ,   0.774800,   0.659900,
     *   0.572900,   0.500000,   0.438500,   0.392000,   0.343200/
      DATA B22 /
     *   0.307200,   0.278400,   0.256500,   0.247000,   0.233300,
     *   0.241200,   0.251600,   0.264700,   0.272600,  16.5796  ,
     *  16.5623  ,  17.3151  ,  14.0988  ,  12.8006  ,  11.9160  ,
     *  11.7660  ,   1.09580 ,   8.14487 ,   8.43467 ,   8.21758 ,
     *   7.98929 ,   7.47260 ,   6.90890 ,   6.37760 ,   0.503100/
      DATA B23 /
     *   0.460700,   0.420885,   0.381400,   0.344000,   0.310700,
     *   0.275600,   0.244475,   0.226836,   0.222087,   0.210628,
     *   0.202088,   0.196451,   0.194200,   0.181951,   0.196143,
     *   0.202172,   0.197940,   0.223545,   0.238849,   0.257119,
     *   9.98519 ,   9.59990 ,   9.37046 ,   9.22590 ,   9.09227 /
      DATA B24 /
     *   8.97948 ,   8.86553 ,   8.81174 ,   8.62160 ,   8.44840 ,
     *   8.70751 ,   2.35760 ,   2.92380 ,   3.55078 ,   3.97458 ,
     *   4.06910 ,   4.17619 ,   3.87135 ,   3.65155 ,   3.46204 ,
     *   3.41519 ,   3.32530 ,   3.25396 ,   3.26371 ,   3.20647 ,
     *   3.08997 ,   3.04619 ,   3.00775 ,   0.0     ,   0.0     /
      DATA A31 /
     *   0.140191,   0.311200,   0.617500,   0.539100,   1.09790 ,
     *   1.58860 ,   2.01250 ,   1.54630 ,   1.51700 ,   1.45460 ,
     *   1.26740 ,   1.22690 ,   1.59360 ,   1.98910 ,   1.78000 ,
     *   1.43790 ,   6.25560 ,   0.653900,   1.05190 ,   1.58990 ,
     *   1.64090 ,   1.69910 ,   2.07030 ,   3.32400 ,   3.01930 /
      DATA A32 /
     *   3.52220 ,   4.00340 ,   4.44380 ,   5.61580 ,   5.16520 ,
     *   4.35910 ,   3.70680 ,   3.43130 ,   3.97310 ,   5.63770 ,
     *   5.54930 ,   5.13990 ,   5.42200 ,   5.72629 ,   5.41732 ,
     *   4.04183 ,  12.8876  ,   4.64901 ,   4.86337 ,   4.73425 ,
     *   5.29537 ,   4.80450 ,   4.46100 ,   4.29480 ,   4.45850 /
      DATA A33 /
     *   5.03710 ,   6.14487 ,   7.51380 ,   8.97670 ,  10.6620  ,
     *  10.8880  ,  11.3727  ,  11.8513  ,  12.3856  ,  12.7740  ,
     *  13.1235  ,  13.4396  ,  13.7603  ,  13.8518  ,  14.3167  ,
     *  14.5596  ,  14.5583  ,  14.9779  ,  15.1542  ,  15.3087  ,
     *  15.1000  ,  14.7586  ,  14.5135  ,  14.4327  ,  14.5564  /
      DATA A34 /
     *  14.9305  ,  15.6115  ,  15.7131  ,  25.5582  ,  21.6575  ,
     *  15.5380  ,  18.4420  ,  16.5877  ,  13.1138  ,   9.49887 ,
     *   8.00370 ,  12.1439  ,  12.4739  ,  12.5977  ,  12.7473  ,
     *  14.1891  ,  14.9491  ,  15.6402  ,  16.7707  ,  17.3415  ,
     *  17.3990  ,  17.8919  ,  18.3317  ,   0.0     ,   0.0     /
      DO 100 J=1,5
  100 F(J)=SCFCO(IZ,J)
      RETURN
      END
      SUBROUTINE CDSFC1 (IZ, F)
      DIMENSION F(4)
      DIMENSION SCFC1(100,5)
      DIMENSION B31(25),A41(25),B41(25),C11(25)
      DIMENSION B32(25),A42(25),B42(25),C12(25)
      DIMENSION B33(25),A43(25),B43(25),C13(25)
      DIMENSION B34(25),A44(25),B44(25),C14(25)
      EQUIVALENCE (SCFC1( 1,1),B31(1)),(SCFC1(26,1),B32(1))
      EQUIVALENCE (SCFC1(51,1),B33(1)),(SCFC1(76,1),B34(1))
      EQUIVALENCE (SCFC1( 1,2),A41(1)),(SCFC1(26,2),A42(1))
      EQUIVALENCE (SCFC1(51,2),A43(1)),(SCFC1(76,2),A44(1))
      EQUIVALENCE (SCFC1( 1,3),B41(1)),(SCFC1(26,3),B42(1))
      EQUIVALENCE (SCFC1(51,3),B43(1)),(SCFC1(76,3),B44(1))
      EQUIVALENCE (SCFC1( 1,4),C11(1)),(SCFC1(26,4),C12(1))
      EQUIVALENCE (SCFC1(51,4),C13(1)),(SCFC1(76,4),C14(1))
      DATA B31 /
     *   3.14236 ,  22.9276  ,  85.3905  , 103.483   ,  60.3498  ,
     *   0.568700,  28.9975  ,   0.323900,   0.261500,   0.230600,
     *   0.313600,   0.380800,  31.5472  ,   0.678500,   0.526000,
     *   0.253600,  18.5194  ,  43.8983  , 213.187   ,  85.7484  ,
     * 136.108   ,  35.6338  ,  26.8938  ,  20.2626  ,  17.8674  /
      DATA B32 /
     *  15.3535  ,  13.5359  ,  12.1763  ,  11.3966  ,  10.3163  ,
     *  10.7805  ,  11.4468  ,  12.9479  ,  15.2372  ,   0.260900,
     *   0.226100,   0.274800,   0.166400,   0.125599,   0.117622,
     *   0.204785,  11.0040  ,  21.5707  ,  24.7997  ,  25.8749  ,
     *  25.2052  ,  24.6605  ,  24.7008  ,  25.8499  ,  26.8909  /
      DATA B33 /
     *  27.9074  ,  28.5284  ,  27.7660  ,  26.4659  ,  24.3879  ,
     *  20.2073  ,  18.7726  ,  17.6083  ,  16.7669  ,  15.8850  ,
     *  15.1009  ,  14.3996  ,  13.7546  ,  12.9331  ,  12.6648  ,
     *  12.1899  ,  11.4407  ,  11.3604  ,  10.9975  ,  10.6647  ,
     *   0.261033,   0.275116,   0.295977,   0.321703,   0.350500/
      DATA B34 /
     *   0.382661,   0.417916,   0.424593,   1.48260 ,   1.57290 ,
     *   1.96347 ,   8.61800 ,   8.79370 ,   9.55642 ,  11.3824  ,
     *  14.0422  ,  23.1052  ,  19.9887  ,  18.5990  ,  17.8309  ,
     *  16.9235  ,  16.0927  ,  15.3622  ,  14.9455  ,  14.3136  ,
     *  13.4346  ,  12.8946  ,  12.4044  ,   0.0     ,   0.0     /
      DATA A41 /
     *   0.040810,   0.178000,   0.465300,   0.702900,   0.706800,
     *   0.865000,   1.16630 ,   0.867000,   1.02430 ,   1.12510 ,
     *   1.11280 ,   2.30730 ,   1.96460 ,   1.54100 ,   1.49080 ,
     *   1.58630 ,   1.64550 ,   1.64420 ,   0.865900,   1.02110 ,
     *   1.46800 ,   1.90210 ,   2.05710 ,   1.49220 ,   2.24410 /
      DATA A42 /
     *   2.30450 ,   2.34880 ,   2.38000 ,   1.67350 ,   2.41000 ,
     *   2.96230 ,   3.68300 ,   4.27790 ,   4.35430 ,   3.98510 ,
     *   3.53750 ,   1.52920 ,   2.66940 ,   3.26588 ,   3.65721 ,
     *   3.53346 ,   3.74290 ,   2.71263 ,   1.56756 ,   1.28918 ,
     *   0.605844,   1.04630 ,   1.60290 ,   2.03960 ,   2.46630 /
      DATA A43 /
     *   2.68270 ,   2.52390 ,   2.27350 ,   1.99000 ,   1.49530 ,
     *   2.69590 ,   3.28719 ,   3.33049 ,   2.82428 ,   2.85137 ,
     *   2.87516 ,   2.89604 ,   2.92270 ,   3.54545 ,   2.95354 ,
     *   2.96577 ,   3.63837 ,   2.98233 ,   2.98706 ,   2.98963 ,
     *   3.71601 ,   4.30013 ,   4.76492 ,   5.11982 ,   5.44174 /
      DATA A44 /
     *   5.67589 ,   5.83377 ,   5.78370 ,   5.86000 ,   5.96760 ,
     *   5.52593 ,   5.96960 ,   6.46920 ,   7.02588 ,   7.42518 ,
     *   7.44330 ,   2.11253 ,   3.21097 ,   4.08655 ,   4.80703 ,
     *   4.17287 ,   4.18800 ,   4.18550 ,   3.47947 ,   3.49331 ,
     *   4.21665 ,   4.23284 ,   4.24391 ,   0.0     ,   0.0     /
      DATA B41 /
     *  57.7997  ,   0.982100, 168.261   ,   0.542000,   0.140300,
     *  51.6512  ,   0.582600,  32.9089  ,  26.1476  ,  21.7184  ,
     * 129.424   ,   7.19370 ,  85.0886  ,  81.6937  ,  68.1645  ,
     *  56.1720  ,  47.7784  ,  33.3929  ,  41.6841  , 178.437   ,
     *  51.3531  , 116.105   , 102.478   ,  98.7399  ,  83.7543  /
      DATA B42 /
     *  76.8805  ,  71.1692  ,  66.3421  ,  64.8126  ,  58.7097  ,
     *  61.4135  ,  54.7625  ,  47.7972  ,  43.8163  ,  41.4328  ,
     *  39.3972  , 164.934   , 132.376   , 104.354   ,  87.6627  ,
     *  69.7957  ,  61.6584  ,  86.8472  ,  94.2928  ,  98.6062  ,
     *  76.8986  ,  99.8156  ,  87.4825  ,  92.8029  ,  83.9571  /
      DATA B43 /
     *  75.2825  ,  70.8403  ,  66.8776  ,  64.2658  , 213.904   ,
     * 167.202   , 133.124   , 127.113   , 143.644   , 137.903   ,
     * 132.721   , 128.007   , 123.174   , 101.398   , 115.362   ,
     * 111.874   ,  92.6566  , 105.703   , 102.961   , 100.417   ,
     *  84.3298  ,  72.0290  ,  63.3644  ,  57.0560  ,  52.0861  /
      DATA B44 /
     *  48.1647  ,  45.0011  ,  38.6103  ,  36.3956  ,  38.3246  ,
     *  45.8149  ,  47.2579  ,  48.0093  ,  47.0045  ,  45.4715  ,
     *  44.2473  , 150.645   , 142.325   , 117.020   ,  99.1722  ,
     * 105.251   , 100.613   ,  97.4908  , 105.980   , 102.273   ,
     *  88.4834  ,  86.0030  ,  83.7881  ,   0.0     ,   0.0     /
      DATA C11 /
     *   0.003038,   0.006400,   0.037700,   0.038500,  -0.19320 ,
     *   0.215600, -11.529   ,   0.250800,   0.277600,   0.351500,
     *   0.676000,   0.858400,   1.11510 ,   1.14070 ,   1.11490 ,
     *   0.866900,  -9.5574  ,   1.44450 ,   1.42280 ,   1.37510 ,
     *   1.33290 ,   1.28070 ,   1.21990 ,   1.18320 ,   1.08960 /
      DATA C12 /
     *   1.03690 ,   1.01180 ,   1.03410 ,   1.19100 ,   1.30410 ,
     *   1.71890 ,   2.13130 ,   2.53100 ,   2.84090 ,   2.95570 ,
     *   2.82500 ,   3.48730 ,   2.50640 ,   1.91213 ,   2.06929 ,
     *   3.75591 ,   4.38750 ,   5.40428 ,   5.37874 ,   5.32800 ,
     *   5.26593 ,   5.17900 ,   5.06940 ,   4.93910 ,   4.78210 /
      DATA C13 /
     *   4.59090 ,   4.35200 ,   4.07120 ,   3.71180 ,   3.33520 ,
     *   2.77310 ,   2.14678 ,   1.86264 ,   2.05830 ,   1.98486 ,
     *   2.02876 ,   2.20963 ,   2.57450 ,   2.41960 ,   3.58324 ,
     *   4.29728 ,   4.56796 ,   5.92046 ,   6.75621 ,   7.56672 ,
     *   7.97628 ,   8.58154 ,   9.24354 ,   9.88750 ,  10.4720  /
      DATA C14 /
     *  11.0005  ,  11.4722  ,  11.6883  ,  12.0658  ,  12.6089  ,
     *  13.1746  ,  13.4118  ,  13.5782  ,  13.6770  ,  13.7108  ,
     *  13.6905  ,  13.7247  ,  13.6211  ,  13.5266  ,  13.4314  ,
     *  13.4287  ,  13.3966  ,  13.3573  ,  13.3812  ,  13.3592  ,
     *  13.2887  ,  13.2754  ,  13.2674  ,   0.0     ,   0.0     /
      DO 100 J=1,4
  100 F(J) = SCFC1 (IZ, J)
      RETURN
      END
      SUBROUTINE CDSFD1 (IZ, J, DELFP)
      DIMENSION DLFPO(100,5)
      DIMENSION DLFP11(25),DLFP21(25),DLFP31(25),DLFP41(25),DLFP51(25)
      DIMENSION DLFP12(25),DLFP22(25),DLFP32(25),DLFP42(25),DLFP52(25)
      DIMENSION DLFP13(25),DLFP23(25),DLFP33(25),DLFP43(25),DLFP53(25)
      DIMENSION DLFP14(25),DLFP24(25),DLFP34(25),DLFP44(25),DLFP54(25)
      EQUIVALENCE (DLFPO( 1,1),DLFP11(1)),(DLFPO(26,1),DLFP12(1))
      EQUIVALENCE (DLFPO(51,1),DLFP13(1)),(DLFPO(76,1),DLFP14(1))
      EQUIVALENCE (DLFPO( 1,2),DLFP21(1)),(DLFPO(26,2),DLFP22(1))
      EQUIVALENCE (DLFPO(51,2),DLFP23(1)),(DLFPO(76,2),DLFP24(1))
      EQUIVALENCE (DLFPO( 1,3),DLFP31(1)),(DLFPO(26,3),DLFP32(1))
      EQUIVALENCE (DLFPO(51,3),DLFP33(1)),(DLFPO(76,3),DLFP34(1))
      EQUIVALENCE (DLFPO( 1,4),DLFP41(1)),(DLFPO(26,4),DLFP42(1))
      EQUIVALENCE (DLFPO(51,4),DLFP43(1)),(DLFPO(76,4),DLFP44(1))
      EQUIVALENCE (DLFPO( 1,5),DLFP51(1)),(DLFPO(26,5),DLFP52(1))
      EQUIVALENCE (DLFPO(51,5),DLFP53(1)),(DLFPO(76,5),DLFP54(1))
      DATA DLFP11 /
     *   0.000  ,   0.000  ,   0.000  ,  -0.001  ,   0.000  ,
     *   0.000  ,   0.001  ,   0.003  ,   0.006  ,   0.011  ,
     *   0.016  ,   0.023  ,   0.032  ,   0.042  ,   0.055  ,
     *   0.068  ,   0.084  ,   0.101  ,   0.118  ,   0.137  ,
     *   0.156  ,   0.175  ,   0.194  ,   0.213  ,   0.229  /
      DATA DLFP12 /
     *   0.244  ,   0.256  ,   0.261  ,   0.265  ,   0.260  ,
     *   0.249  ,   0.228  ,   0.196  ,   0.152  ,   0.090  ,
     *   0.008  ,  -0.099  ,  -0.230  ,  -0.406  ,  -0.639  ,
     *  -0.957  ,  -1.416  ,  -2.205  ,  -5.524  ,  -2.649  ,
     *  -2.128  ,  -1.834  ,  -1.637  ,  -1.493  ,  -1.378  /
      DATA DLFP13 /
     *  -1.284  ,  -1.212  ,  -1.144  ,  -1.084  ,  -1.029  ,
     *  -0.983  ,  -0.942  ,  -0.904  ,  -0.859  ,  -0.842  ,
     *  -0.818  ,  -0.798  ,  -0.782  ,  -0.774  ,  -0.767  ,
     *  -0.761  ,  -0.765  ,  -0.773  ,  -0.790  ,  -0.815  ,
     *  -0.847  ,  -0.890  ,  -0.937  ,  -0.993  ,  -1.048  /
      DATA DLFP14 /
     *  -1.127  ,  -1.216  ,  -1.319  ,  -1.438  ,  -1.576  ,
     *  -1.730  ,  -1.910  ,  -2.116  ,  -2.353  ,  -2.630  ,
     *  -2.932  ,  -3.285  ,  -3.702  ,  -4.192  ,  -4.784  ,
     *  -5.555  ,  -6.735  ,  -7.842  ,  -8.473  ,  -7.701  ,
     *  -7.388  ,  -7.485  ,  -7.638  ,   0.000  ,   0.000  /
      DATA DLFP21 /
     *   0.000  ,   0.000  ,   0.000  ,   0.000  ,   0.000  ,
     *   0.002  ,   0.004  ,   0.008  ,   0.014  ,   0.021  ,
     *   0.030  ,   0.042  ,   0.056  ,   0.072  ,   0.090  ,
     *   0.110  ,   0.132  ,   0.155  ,   0.179  ,   0.203  ,
     *   0.226  ,   0.248  ,   0.267  ,   0.284  ,   0.295  /
      DATA DLFP22 /
     *   0.301  ,   0.299  ,   0.285  ,   0.263  ,   0.222  ,
     *   0.163  ,   0.081  ,  -0.030  ,  -0.178  ,  -0.374  ,
     *  -0.652  ,  -1.044  ,  -1.657  ,  -2.951  ,  -2.965  ,
     *  -2.197  ,  -1.825  ,  -1.590  ,  -1.420  ,  -1.287  ,
     *  -1.177  ,  -1.085  ,  -1.005  ,  -0.936  ,  -0.873  /
      DATA DLFP23 /
     *  -0.816  ,  -0.772  ,  -0.726  ,  -0.684  ,  -0.644  ,
     *  -0.613  ,  -0.588  ,  -0.564  ,  -0.530  ,  -0.535  ,
     *  -0.530  ,  -0.533  ,  -0.542  ,  -0.564  ,  -0.591  ,
     *  -0.619  ,  -0.666  ,  -0.723  ,  -0.795  ,  -0.884  ,
     *  -0.988  ,  -1.118  ,  -1.258  ,  -1.421  ,  -1.598  /
      DATA DLFP24 /
     *  -1.816  ,  -2.066  ,  -2.352  ,  -2.688  ,  -3.084  ,
     *  -3.556  ,  -4.133  ,  -4.861  ,  -5.924  ,  -7.444  ,
     *  -8.862  ,  -7.912  ,  -7.620  ,  -7.725  ,  -8.127  ,
     *  -8.960  , -10.673  , -11.158  ,  -9.725  ,  -8.926  ,
     *  -8.416  ,  -7.990  ,  -7.683  ,   0.000  ,   0.000  /
      DATA DLFP31 /
     *   0.000  ,   0.000  ,   0.001  ,   0.003  ,   0.008  ,
     *   0.017  ,   0.029  ,   0.047  ,   0.069  ,   0.097  ,
     *   0.129  ,   0.165  ,   0.204  ,   0.244  ,   0.283  ,
     *   0.319  ,   0.348  ,   0.366  ,   0.365  ,   0.341  ,
     *   0.285  ,   0.189  ,   0.035  ,  -0.198  ,  -0.568  /
      DATA DLFP32 /
     *  -1.179  ,  -2.464  ,  -2.956  ,  -2.019  ,  -1.612  ,
     *  -1.354  ,  -1.163  ,  -1.011  ,  -0.879  ,  -0.767  ,
     *  -0.665  ,  -0.574  ,  -0.465  ,  -0.386  ,  -0.314  ,
     *  -0.248  ,  -0.191  ,  -0.145  ,  -0.105  ,  -0.077  ,
     *  -0.059  ,  -0.060  ,  -0.079  ,  -0.126  ,  -0.194  /
      DATA DLFP33 /
     *  -0.287  ,  -0.418  ,  -0.579  ,  -0.783  ,  -1.022  ,
     *  -1.334  ,  -1.716  ,  -2.170  ,  -2.939  ,  -3.431  ,
     *  -4.357  ,  -5.696  ,  -7.718  ,  -9.242  ,  -9.498  ,
     * -10.423  , -12.255  ,  -9.733  ,  -8.488  ,  -7.701  ,
     *  -7.133  ,  -6.715  ,  -6.351  ,  -6.048  ,  -5.790  /
      DATA DLFP34 /
     *  -5.581  ,  -5.391  ,  -5.233  ,  -5.096  ,  -4.990  ,
     *  -4.883  ,  -4.818  ,  -4.776  ,  -4.756  ,  -4.772  ,
     *  -4.787  ,  -4.833  ,  -4.898  ,  -4.994  ,  -5.091  ,
     *  -5.216  ,  -5.359  ,  -5.529  ,  -5.712  ,  -5.930  ,
     *  -6.176  ,  -6.498  ,  -6.798  ,   0.000  ,   0.000  /
      DATA DLFP41 /
     *   0.000  ,   0.000  ,   0.002  ,   0.005  ,   0.013  ,
     *   0.026  ,   0.044  ,   0.069  ,   0.100  ,   0.138  ,
     *   0.180  ,   0.224  ,   0.269  ,   0.311  ,   0.347  ,
     *   0.370  ,   0.375  ,   0.352  ,   0.286  ,   0.163  ,
     *  -0.038  ,  -0.357  ,  -0.896  ,  -1.973  ,  -3.367  /
      DATA DLFP42 /
     *  -2.095  ,  -1.623  ,  -1.343  ,  -1.129  ,  -0.978  ,
     *  -0.841  ,  -0.717  ,  -0.607  ,  -0.503  ,  -0.413  ,
     *  -0.328  ,  -0.256  ,  -0.161  ,  -0.106  ,  -0.061  ,
     *  -0.028  ,  -0.012  ,  -0.017  ,  -0.039  ,  -0.083  ,
     *  -0.157  ,  -0.259  ,  -0.416  ,  -0.626  ,  -0.888  /
      DATA DLFP43 /
     *  -1.214  ,  -1.630  ,  -2.147  ,  -2.812  ,  -3.652  ,
     *  -4.832  ,  -6.683  ,  -8.388  , -12.457  , -11.016  ,
     * -12.122  ,  -9.616  ,  -8.352  ,  -7.565  ,  -6.980  ,
     *  -6.492  ,  -6.112  ,  -5.810  ,  -5.565  ,  -5.361  ,
     *  -5.190  ,  -5.088  ,  -4.948  ,  -4.823  ,  -4.719  /
      DATA DLFP44 /
     *  -4.647  ,  -4.578  ,  -4.535  ,  -4.510  ,  -4.523  ,
     *  -4.532  ,  -4.596  ,  -4.688  ,  -4.817  ,  -4.992  ,
     *  -5.173  ,  -5.402  ,  -5.659  ,  -5.976  ,  -6.313  ,
     *  -6.695  ,  -7.126  ,  -7.624  ,  -8.187  ,  -8.872  ,
     *  -9.743  , -10.539  , -11.641  ,   0.000  ,   0.000  /
      DATA DLFP51 /
     *   0.000  ,   0.000  ,   0.002  ,   0.008  ,   0.018  ,
     *   0.035  ,   0.059  ,   0.090  ,   0.129  ,   0.174  ,
     *   0.223  ,   0.272  ,   0.318  ,   0.355  ,   0.377  ,
     *   0.374  ,   0.335  ,   0.243  ,   0.070  ,  -0.221  ,
     *  -0.717  ,  -1.683  ,  -3.841  ,  -2.161  ,  -1.639  /
      DATA DLFP52 /
     *  -1.339  ,  -1.124  ,  -0.956  ,  -0.795  ,  -0.684  ,
     *  -0.570  ,  -0.462  ,  -0.365  ,  -0.273  ,  -0.198  ,
     *  -0.130  ,  -0.082  ,  -0.012  ,   0.006  ,   0.007  ,
     *  -0.013  ,  -0.063  ,  -0.153  ,  -0.270  ,  -0.424  ,
     *  -0.639  ,  -0.924  ,  -1.303  ,  -1.788  ,  -2.401  /
      DATA DLFP53 /
     *  -3.194  ,  -4.267  ,  -5.852  ,  -8.133  , -10.742  ,
     * -11.460  , -12.135  ,  -9.574  ,  -7.817  ,  -7.486  ,
     *  -6.891  ,  -6.429  ,  -6.050  ,  -5.779  ,  -5.525  ,
     *  -5.250  ,  -5.040  ,  -4.878  ,  -4.753  ,  -4.652  ,
     *  -4.580  ,  -4.592  ,  -4.540  ,  -4.499  ,  -4.483  /
      DATA DLFP54 /
     *  -4.503  ,  -4.527  ,  -4.584  ,  -4.668  ,  -4.803  ,
     *  -4.945  ,  -5.161  ,  -5.420  ,  -5.742  ,  -6.132  ,
     *  -6.545  ,  -7.052  ,  -7.614  ,  -8.318  ,  -9.150  ,
     * -10.382  , -10.930  , -12.152  , -12.280  , -12.771  ,
     * -13.513  , -14.827  , -16.272  ,   0.000  ,   0.000  /
      DELFP = DLFPO (IZ, J)
      RETURN
      END
      SUBROUTINE CDSFD2 (IZ, J, DELFPP)
      DIMENSION DFPPO(100,5)
      DIMENSION DFPP11(25),DFPP21(25),DFPP31(25),DFPP41(25),DFPP51(25)
      DIMENSION DFPP12(25),DFPP22(25),DFPP32(25),DFPP42(25),DFPP52(25)
      DIMENSION DFPP13(25),DFPP23(25),DFPP33(25),DFPP43(25),DFPP53(25)
      DIMENSION DFPP14(25),DFPP24(25),DFPP34(25),DFPP44(25),DFPP54(25)
      EQUIVALENCE (DFPPO( 1,1),DFPP11(1)),(DFPPO(26,1),DFPP12(1))
      EQUIVALENCE (DFPPO(51,1),DFPP13(1)),(DFPPO(76,1),DFPP14(1))
      EQUIVALENCE (DFPPO( 1,2),DFPP21(1)),(DFPPO(26,2),DFPP22(1))
      EQUIVALENCE (DFPPO(51,2),DFPP23(1)),(DFPPO(76,2),DFPP24(1))
      EQUIVALENCE (DFPPO( 1,3),DFPP31(1)),(DFPPO(26,3),DFPP32(1))
      EQUIVALENCE (DFPPO(51,3),DFPP33(1)),(DFPPO(76,3),DFPP34(1))
      EQUIVALENCE (DFPPO( 1,4),DFPP41(1)),(DFPPO(26,4),DFPP42(1))
      EQUIVALENCE (DFPPO(51,4),DFPP43(1)),(DFPPO(76,4),DFPP44(1))
      EQUIVALENCE (DFPPO( 1,5),DFPP51(1)),(DFPPO(26,5),DFPP52(1))
      EQUIVALENCE (DFPPO(51,5),DFPP53(1)),(DFPPO(76,5),DFPP54(1))
      DATA DFPP11 /
     *   0.000  ,   0.000  ,   0.000  ,   0.000  ,   0.000  ,
     *   0.001  ,   0.002  ,   0.004  ,   0.006  ,   0.010  ,
     *   0.015  ,   0.022  ,   0.031  ,   0.043  ,   0.058  ,
     *   0.076  ,   0.099  ,   0.125  ,   0.156  ,   0.193  ,
     *   0.235  ,   0.283  ,   0.338  ,   0.399  ,   0.468  /
      DATA DFPP12 /
     *   0.545  ,   0.630  ,   0.724  ,   0.826  ,   0.938  ,
     *   1.059  ,   1.190  ,   1.332  ,   1.481  ,   1.643  ,
     *   1.820  ,   2.003  ,   2.203  ,   2.411  ,   2.630  ,
     *   2.860  ,   3.103  ,   3.353  ,   3.651  ,   0.596  ,
     *   0.654  ,   0.717  ,   0.783  ,   0.854  ,   0.930  /
      DATA DFPP13 /
     *   1.010  ,   1.096  ,   1.187  ,   1.284  ,   1.391  ,
     *   1.500  ,   1.615  ,   1.735  ,   1.873  ,   1.995  ,
     *   2.135  ,   2.281  ,   2.435  ,   2.595  ,   2.764  ,
     *   2.940  ,   3.124  ,   3.316  ,   3.515  ,   3.723  ,
     *   3.937  ,   4.164  ,   4.399  ,   4.643  ,   4.894  /
      DATA DFPP14 /
     *   5.156  ,   5.427  ,   5.708  ,   5.998  ,   6.299  ,
     *   6.610  ,   6.930  ,   7.258  ,   7.600  ,   7.949  ,
     *   8.307  ,   8.674  ,   9.047  ,   9.428  ,   9.819  ,
     *  10.227  ,  10.637  ,   9.570  ,   6.999  ,   7.296  ,
     *   7.589  ,   7.931  ,   8.246  ,   0.000  ,   0.000  /
      DATA DFPP21 /
     *   0.000  ,   0.000  ,   0.000  ,   0.000  ,   0.001  ,
     *   0.002  ,   0.003  ,   0.006  ,   0.010  ,   0.016  ,
     *   0.025  ,   0.036  ,   0.052  ,   0.071  ,   0.095  ,
     *   0.124  ,   0.159  ,   0.201  ,   0.250  ,   0.306  ,
     *   0.372  ,   0.446  ,   0.530  ,   0.624  ,   0.729  /
      DATA DFPP22 /
     *   0.845  ,   0.973  ,   1.113  ,   1.266  ,   1.431  ,
     *   1.609  ,   1.801  ,   2.007  ,   2.223  ,   2.456  ,
     *   2.713  ,   2.973  ,   3.264  ,   3.542  ,   0.560  ,
     *   0.621  ,   0.688  ,   0.759  ,   0.836  ,   0.919  ,
     *   1.007  ,   1.101  ,   1.202  ,   1.310  ,   1.424  /
      DATA DFPP23 /
     *   1.546  ,   1.675  ,   1.812  ,   1.958  ,   2.119  ,
     *   2.282  ,   2.452  ,   2.632  ,   2.845  ,   3.018  ,
     *   3.225  ,   3.442  ,   3.669  ,   3.904  ,   4.151  ,
     *   4.410  ,   4.678  ,   4.958  ,   5.248  ,   5.548  ,
     *   5.858  ,   6.185  ,   6.523  ,   6.872  ,   7.232  /
      DATA DFPP24 /
     *   7.605  ,   7.990  ,   8.388  ,   8.798  ,   9.223  ,
     *   9.659  ,  10.102  ,  10.559  ,  11.042  ,   9.961  ,
     *  10.403  ,   7.754  ,   8.105  ,   8.472  ,   8.870  ,
     *   9.284  ,   9.654  ,   4.148  ,   4.330  ,   4.511  ,
     *   4.697  ,   4.908  ,   5.107  ,   0.000  ,   0.000  /
      DATA DFPP31 /
     *   0.000  ,   0.000  ,   0.000  ,   0.001  ,   0.004  ,
     *   0.009  ,   0.018  ,   0.032  ,   0.053  ,   0.083  ,
     *   0.124  ,   0.177  ,   0.246  ,   0.330  ,   0.434  ,
     *   0.557  ,   0.702  ,   0.872  ,   1.066  ,   1.286  ,
     *   1.533  ,   1.807  ,   2.110  ,   2.443  ,   2.808  /
      DATA DFPP32 /
     *   3.204  ,   3.608  ,   0.509  ,   0.589  ,   0.678  ,
     *   0.777  ,   0.886  ,   1.006  ,   1.139  ,   1.283  ,
     *   1.439  ,   1.608  ,   1.820  ,   2.025  ,   2.245  ,
     *   2.482  ,   2.735  ,   3.005  ,   3.296  ,   3.605  ,
     *   3.934  ,   4.282  ,   4.653  ,   5.045  ,   5.459  /
      DATA DFPP33 /
     *   5.894  ,   6.352  ,   6.835  ,   7.348  ,   7.904  ,
     *   8.460  ,   9.036  ,   9.648  ,  10.535  ,  10.933  ,
     *  11.614  ,  12.320  ,  11.276  ,  11.946  ,   9.242  ,
     *   9.748  ,   3.704  ,   3.937  ,   4.181  ,   4.432  ,
     *   4.693  ,   4.977  ,   5.271  ,   5.577  ,   5.891  /
      DATA DFPP34 /
     *   6.221  ,   6.566  ,   6.925  ,   7.297  ,   7.686  ,
     *   8.089  ,   8.505  ,   8.930  ,   9.383  ,   9.843  ,
     *  10.317  ,  10.803  ,  11.296  ,  11.799  ,  12.330  ,
     *  12.868  ,  13.409  ,  13.967  ,  14.536  ,  15.087  ,
     *  15.634  ,  16.317  ,  16.930  ,   0.000  ,   0.000  /
      DATA DFPP41 /
     *   0.000  ,   0.000  ,   0.001  ,   0.002  ,   0.007  ,
     *   0.015  ,   0.029  ,   0.052  ,   0.085  ,   0.132  ,
     *   0.195  ,   0.277  ,   0.381  ,   0.509  ,   0.664  ,
     *   0.847  ,   1.061  ,   1.309  ,   1.589  ,   1.904  ,
     *   2.256  ,   2.643  ,   3.070  ,   3.533  ,   0.481  /
      DATA DFPP42 /
     *   0.566  ,   0.662  ,   0.769  ,   0.888  ,   1.021  ,
     *   1.168  ,   1.331  ,   1.508  ,   1.704  ,   1.916  ,
     *   2.149  ,   2.398  ,   2.709  ,   3.009  ,   3.329  ,
     *   3.676  ,   4.043  ,   4.434  ,   4.854  ,   5.300  ,
     *   5.773  ,   6.271  ,   6.800  ,   7.356  ,   7.943  /
      DATA DFPP43 /
     *   8.557  ,   9.203  ,   9.885  ,  10.608  ,  11.382  ,
     *  12.164  ,  12.937  ,  11.953  ,   6.285  ,   9.874  ,
     *   3.627  ,   3.883  ,   4.149  ,   4.427  ,   4.721  ,
     *   5.026  ,   5.343  ,   5.675  ,   6.022  ,   6.378  ,
     *   6.745  ,   7.148  ,   7.565  ,   7.996  ,   8.439  /
      DATA DFPP44 /
     *   8.903  ,   9.389  ,   9.895  ,  10.418  ,  10.963  ,
     *  11.528  ,  12.108  ,  12.700  ,  13.331  ,  13.969  ,
     *  14.629  ,  15.299  ,  15.977  ,  16.668  ,  17.397  ,
     *  18.140  ,  18.879  ,  19.642  ,  20.425  ,  21.173  ,
     *  21.896  ,  21.942  ,  22.785  ,   0.000  ,   0.000  /
      DATA DFPP51 /
     *   0.000  ,   0.000  ,   0.001  ,   0.003  ,   0.009  ,
     *   0.021  ,   0.042  ,   0.073  ,   0.119  ,   0.184  ,
     *   0.270  ,   0.381  ,   0.522  ,   0.693  ,   0.900  ,
     *   1.142  ,   1.423  ,   1.747  ,   2.110  ,   2.514  ,
     *   2.968  ,   3.470  ,   0.459  ,   0.548  ,   0.650  /
      DATA DFPP52 /
     *   0.764  ,   0.893  ,   1.036  ,   1.196  ,   1.373  ,
     *   1.569  ,   1.786  ,   2.022  ,   2.283  ,   2.563  ,
     *   2.872  ,   3.201  ,   3.608  ,   4.002  ,   4.422  ,
     *   4.876  ,   5.353  ,   5.862  ,   6.406  ,   6.984  ,
     *   7.594  ,   8.235  ,   8.912  ,   9.627  ,  10.380  /
      DATA DFPP53 /
     *  11.166  ,  11.995  ,  12.850  ,  11.933  ,  12.919  ,
     *   9.981  ,   3.565  ,   3.843  ,   4.130  ,   4.427  ,
     *   4.741  ,   5.073  ,   5.416  ,   5.773  ,   6.153  ,
     *   6.549  ,   6.958  ,   7.387  ,   7.833  ,   8.291  ,
     *   8.759  ,   9.277  ,   9.811  ,  10.364  ,  10.929  /
      DATA DFPP54 /
     *  11.520  ,  12.140  ,  12.787  ,  13.451  ,  14.143  ,
     *  14.860  ,  15.595  ,  16.341  ,  17.139  ,  17.942  ,
     *  18.775  ,  19.615  ,  20.461  ,  21.327  ,  22.240  ,
     *  23.161  ,  23.121  ,  24.097  ,  23.658  ,  24.607  ,
     *  25.540  ,  26.801  ,  27.898  ,   0.000  ,   0.000  /
      DELFPP = DFPPO (IZ, J)
      RETURN
      END
      SUBROUTINE CRSPGR (SPGR)
      CHARACTER SPG * 30 , SPGR * 16
      COMMON /SPACE/ LAUENO, NAXIS, NCENT, LCENT, NSYM, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      DIMENSION RT(5,4,25), D(3,3), L(4,4)
      CHARACTER * 1  CHR(25)
      DIMENSION LCEN(7)
      DATA LCEN /4,3,2,1,6,5,7/
      DATA CHR  / ' ', 'C', 'B', 'A', 'P', 'F', 'I', 'R', 'M', 'N',
     *            'D', '1', '2', '3', '4', '5', '6', '-', '/', 'H',
     *            '.', ' ', ' ', ' ', ' ' /
      DATA ID / 0 /
      SPG = SPGR
      CALL KERNZI (0, L, 16)
        K = 0
        M = 0
        IER = 0
        NCENT = 0
        LAUENO = 0
        NAXIS = 0
        IERX = 0
        N = 0
        DO 110 J=1,30
        DO 100 I=1,21
  100   IF (SPG(J:J).EQ.CHR(I)) GOTO 101
        GOTO 110
  101 IF (K+M+I.EQ.1) GOTO 110
        IF (I.EQ.1) GOTO 108
        IF (M.EQ.0 ) K=K+1
        M = M+1
        L(M,K) = I
        IF (I.LT.12) GOTO 108
        IF (M-4 ) 110,108,108
  108 CONTINUE
        M = 0
        IF (K.GT.3) GOTO 200
  110 CONTINUE
  200 IF (K.LE.1 ) IER=1
        IF (IER.GT.0) GOTO 500
        IF (L(1,1).GT.8 ) IER=2
        IF (IER.GT.0) GOTO 500
        IF (L(1,2).EQ.18 ) CALL SGLPAK(L(1,2),IER)
        IF (IER.GT.0) GOTO 500
        IF (L(1,3).EQ.18 ) CALL SGLPAK(L(1,3),IER)
        IF (IER.GT.0) GOTO 500
        IF (L(1,4).EQ.18 ) CALL SGLPAK(L(1,4),IER)
        IF (IER.GT.0) GOTO 500
        N = 2
      CALL KERNZA (0.0, D, 9)
        LCENT = L(1,1)-1
        LCENT = LCEN(LCENT)
        IF (LCENT.NE.7) GOTO 119
        IF (L(1,2).NE.14 ) IER=3
        IF (IER.GT.0) GOTO 500
        IF (L(1,K).EQ.8) GOTO 201
        IF (L(1,K).EQ.20 ) K=K-1
        LAUENO = K+6
        GOTO 210
  201 CONTINUE
        LCENT = 1
        K = K-1
        LAUENO = K+4
        GOTO 209
  119 CONTINUE
        IER = 0
        I209 = 0
        CALL SGLATC (K,L,D,LCENT,LAUENO,NAXIS,IER,I209,ID)
        IF (IER.GT.0) GOTO 500
        IF (I209.EQ.0) GOTO 210
  209 CONTINUE
        CALL SGRMAT(RT(1,1,2),0,1,0,0,0,1,1,0,0)
        CALL SGRMAT(RT(1,1,3),0,0,1,1,0,0,0,1,0)
        N = 4
  210 CONTINUE
        CALL SGRMAT(RT,1,0,0,0,1,0,0,0,1)
      DO 3000 M=2,K
      IF (L(1,M).EQ.0 ) IER=6
      IF (IER.GT.0) GOTO 500
      I = IABS(L(1,M)-5)
  219 IF (I.LE.0.OR.I.GT.15 ) IER=7
        IF (IER.GT.0) GOTO 500
        NXI = N
        GOTO (220,220,220,220,220,245,250,255,260,265,500,270,300,300,
     1 300),I
  220 CONTINUE
        GOTO (500,221,222,223),M
  221 CONTINUE
        IF (LAUENO.GT.3) GOTO 2230
        IF (K.EQ.2) GOTO 2220
 2210 CONTINUE
        IF (I.EQ.1 ) IER=8
        IF (IER.GT.0) GOTO 500
        CALL SGRMAT(RT(1,1,N),-1,0,0,0,1,0,0,0,1)
        RT(1,4,N) = D(1,1)
        IF (I.EQ.2.OR.I.EQ.5 ) RT(2,4,N)=0.5
        IF (I.EQ.3.OR.I.EQ.5 ) RT(3,4,N)=0.5
        GOTO 300
  222 IF (L(1,2).EQ.14.OR.L(1,2).EQ.17) GOTO 225
        IF (L(1,2).EQ.15) GOTO 2210
 2220 CONTINUE
        IF (I.EQ.2 ) IER=9
        IF (IER.GT.0) GOTO 500
        CALL SGRMAT(RT(1,1,N),1,0,0,0,-1,0,0,0,1)
        RT(2,4,N) = D(2,2)
        IF (I.EQ.1.OR.I.EQ.5 ) RT(1,4,N) = 0.5
        IF (I.EQ.3.OR.I.EQ.5 ) RT(3,4,N) = 0.5
        GOTO 300
  223 IF (L(1,3).EQ.14.OR.L(1,2).EQ.15) GOTO 224
        IF (L(1,2).EQ.14.OR.L(1,2).EQ.17) GOTO 224
 2230 CONTINUE
        IF (I.EQ.3 ) IER=10
        IF (IER.GT.0) GOTO 500
        CALL SGRMAT(RT(1,1,N),1,0,0,0,1,0,0,0,-1)
        RT(3,4,N) = D(3,3)
        IF (I.EQ.1.OR.I.EQ.5 ) RT(1,4,N) = 0.5
        IF (I.EQ.2.OR.I.EQ.5 ) RT(2,4,N) = 0.5
        IF (M.NE. 2.OR.L(1,2).NE.17) GOTO 300
        IF (L(2,2).EQ.14 ) RT(3,4,N)=0.5
        GOTO 300
  224 CONTINUE
        CALL SGRMAT(RT(1,1,N),0,1,0,1,0,0,0,0,1)
        RT(1,4,N) = D(2,2)
        RT(2,4,N) = -D(2,2)
        IF (I.EQ.3.OR.I.EQ.5 ) RT(3,4,N) = 0.5
        IF (LAUENO.EQ.7.AND.I.EQ.3) GOTO 2240
        IF (I.EQ.3.OR.I.EQ.4) GOTO 300
 2240   CONTINUE
        IF (LCENT.EQ.6.OR.LCENT.EQ.4) GOTO 2241
        RT(1,4,N) = 0.5+RT(1,4,N)
        RT(2,4,N) = 0.5+RT(2,4,N)
        GOTO 300
2241    CONTINUE
        RT(1,4,N) = 0.25+RT(1,4,N)
        RT(2,4,N) = 0.25+RT(2,4,N)
        GOTO 300
  225 CONTINUE
        IF (LAUENO.EQ.7) GOTO 224
        CALL SGRMAT(RT(1,1,N),-1,1,0,0,1,0,0,0,1)
        IF (I.EQ.3 ) RT(3,4,N)=0.5
226     CONTINUE
        GOTO 300
245     CONTINUE
        IF (LCENT.LE.1 ) IER=11
        IF (IER.GT.0) GOTO 500
        GOTO (500,246,247,248),M
246     IF (LAUENO.GT.3) GOTO 2480
        IF (K.EQ.2) GOTO 247
        CALL SGRMAT(RT(1,1,N),-1,0,0,0,1,0,0,0,1)
        IF (ID.EQ.2 ) RT(1,4,N)=0.25
        RT(2,4,N) = 0.25
        RT(3,4,N) = 0.25
        GOTO 300
  247 CONTINUE
        CALL SGRMAT(RT(1,1,N),1,0,0,0,-1,0,0,0,1)
        RT(1,4,N) = 0.25
        IF (ID.EQ.2 ) RT(2,4,N)=0.25
        IF (LAUENO.EQ.5 ) RT(2,4,N) = D(2,1)
        RT(3,4,N) = 0.25
        GOTO 300
  248 IF (L(1,2).EQ.15.OR.L(1,3).EQ.14) GOTO 249
2480    CONTINUE
        CALL SGRMAT(RT(1,1,N),1,0,0,0,1,0,0,0,-1)
        RT(1,4,N) = 0.25
        RT(2,4,N) = 0.25
        IF (ID.EQ.2 ) RT(3,4,N)=0.25
        GOTO 300
  249 CONTINUE
        CALL SGRMAT(RT(1,1,N),0,1,0,1,0,0,0,0,1)
        RT(1,4,N) = 0.25
        RT(2,4,N) = 0.25
        RT(3,4,N) = 0.25
        IF (L(1,3).NE.13) GOTO 226
        RT(1,4,N) = 0.0
        RT(2,4,N) = 0.5
        GOTO 300
  250 IF (L(2,M).NE.3) GOTO 3000
        NCENT = 1
        GOTO 3000
  255 CONTINUE
      IF (L(2,M).EQ.3 ) IER=19
      IF (IER.GT.0) GOTO 500
      GOTO (500,256,257,258),M
  256 IF (K.EQ.2) GOTO 2571
      CALL SGRMAT(RT(1,1,N),1,0,0,0,-1,0,0,0,-1)
      RT(2,4,N) = D(2,1)
      RT(3,4,N) = D(3,1)
      IF (IABS(L(2,M)-13).EQ.1 ) RT(1,4,N) = 0.5
      GOTO 300
  257 IF (L(1,2).EQ.14) GOTO 2590
      IF (L(1,2).EQ.17) GOTO 259
 2571 CONTINUE
      CALL SGRMAT(RT(1,1,N),-1,0,0,0,1,0,0,0,-1)
      RT(1,4,N) = D(1,2)
      RT(3,4,N) = D(3,2)
      IF (L(2,M).EQ.12 ) RT(2,4,N)=0.5
      GOTO 300
  258 IF (L(1,2).GE.14  ) GOTO 2595
      IF (L(1,3).EQ.14) GOTO 2595
      CALL SGRMAT(RT(1,1,N),-1,0,0,0,-1,0,0,0,1)
      RT(1,4,N) = D(1,3)
      RT(2,4,N) = D(2,3)
      IF (IABS(L(2,M)-13).EQ.1 ) RT(3,4,N) = 0.5
      IF (   L(2,M).EQ.16    ) RT(3,4,N) = 0.5
      GOTO 300
  259 CONTINUE
      IF (L(1,4).EQ.12) GOTO 2590
      CALL SGRMAT(RT(1,1,N),1,-1,0,0,-1,0,0,0,-1)
      GOTO 300
 2590 CONTINUE
      IF (LAUENO.EQ.7) GOTO 2592
 2591 CALL SGRMAT(RT(1,1,N),0,1,0,1,0,0,0,0,-1)
      RT(1,4,N) = D(2,1)
      IF (L(2,M).EQ.12 ) RT(1,4,N)=RT(1,4,N)+0.5
      RT(2,4,N) = -D(2,1)
      RT(3,4,N) = D(3,1)
      GOTO 300
 2592 CALL SGRMAT(RT(1,1,N),0,-1,0,-1,0,0,0,0,-1)
      GOTO 300
 2595 IF (L(1,2).EQ.15) GOTO 2591
      CALL SGRMAT(RT(1,1,N),1,0,0,1,-1,0,0,0,-1)
      GOTO 300
260   GOTO (500,261,250,500),M
261   CONTINUE
      IF (LAUENO.LE.7) GOTO 250
        CALL SGRMAT(RT(1,1,N),0,-1,0,1,-1,0,0,0,1)
        IF (L(2,M).EQ.12 ) RT(3,4,N)=0.33333333
        IF (L(2,M).EQ.13 ) RT(3,4,N)=0.66666667
        IF (L(2,2).EQ.3 ) NCENT=1
        GOTO 300
265     CONTINUE
        IF (M.NE.2 ) IER=12
        IF (IER.GT.0) GOTO 500
        IF (L(2,2).EQ. 3) GOTO 266
        CALL SGRMAT(RT(1,1,N),0,-1,0,1,0,0,0,0,1)
        RT(1,4,N) = D(1,3)
        RT(2,4,N) = D(2,3)
        IF (L(2,2).EQ.12 ) RT(3,4,N) = 0.25
        IF (L(2,2).EQ.13 ) RT(3,4,N) = 0.5
        IF (L(2,2).EQ.14 ) RT(3,4,N) = 0.75
        GOTO 300
266     CONTINUE
        CALL SGRMAT(RT(1,1,N),0,1,0,-1,0,0,0,0,-1)
        RT(1,4,N) = D(1,3)
        RT(2,4,N) = D(2,3)
        RT(3,4,N) = D(3,3)
        GOTO 300
270     CONTINUE
        IF (M.NE.2 ) IER=13
        IF (IER.GT.0) GOTO 500
        IF (L(2,2).EQ.3) GOTO 271
        CALL SGRMAT(RT(1,1,N),1,-1,0,1,0,0,0,0,1)
        IF (L(2,2).GT.11.AND.L(2,2).LT.18 ) RT(3,4,N)=(L(2,2)-11)/6.0
        GOTO 300
271     CONTINUE
        CALL SGRMAT(RT(1,1,N),-1,1,0,-1,0,0,0,0,-1)
        IF (L(1,3).EQ.2.OR.L(1,4).EQ.2 ) RT(3,4,N)=0.5
300     CONTINUE
        RT(1,4,N) = AMOD(RT(1,4,N)+5.0,1.0)
        RT(2,4,N) = AMOD(RT(2,4,N)+5.0,1.0)
        RT(3,4,N) = AMOD(RT(3,4,N)+5.0,1.0)
        RT(5,2,N) = 1728*RT(1,4,N)+144*RT(2,4,N)+12*RT(3,4,N)
      NJS=N-1
        DO 2920 M2=1,NJS
        IF (ABS (RT(5,1,M2) - RT(5,1,N)) .LT. 0.000001) GOTO 2910
        IF (ABS (RT(5,1,M2) + RT(5,1,N)) .GT. 0.000001) GOTO 2920
        NCENT = 1
2910    CONTINUE
        IF ( ABS (RT(5,2,N) - RT(5,2,M2)) .GT. 0.000001) GOTO 2990
        GOTO 3000
2920    CONTINUE
        N = N+1
        IF (N.GT.25 ) IER=14
        IF (IER.GT.0) GOTO 500
2900    CONTINUE
        NXL = N-1
        IF (NXL.LT.NXI) GOTO 2960
        DO 2955 NX=NXI,NXL
        DO 2950 M1=2,NX
        CALL SGMTML(RT,M1,RT,NX,RT,N)
      NJS=N-1
        DO 2940 M2=1,NJS
        IF ( ABS (RT(5,1,N) - RT(5,1,M2)) .LT. 0.000001) GOTO 2930
        IF ( ABS (RT(5,1,N) + RT(5,1,M2)) .GT. 0.000001) GOTO 2940
        NCENT = 1
2930    CONTINUE
        GOTO 2950
2940    CONTINUE
        N = N+1
        IF (N.GT.25 ) IER=15
        IF (IER.GT.0) GOTO 500
2950    CONTINUE
        IF (N-1.EQ.NXL) GOTO 2960
2955    CONTINUE
        NXI = NXL+1
        GOTO 2900
2960    CONTINUE
        IF (L(1,M).LT.12) GOTO 3000
        IF (L(2,M).EQ.3) GOTO 3000
        DO 2970 I=2,3
        IF (L(I,M).EQ.0) GOTO 3000
        IF (L(I,M).EQ.19) GOTO 2980
        IF (L(I,M).LT.12 ) IER=16
        IF (IER.GT.0) GOTO 500
2970    CONTINUE
        GOTO 3000
2980    IF (L(I+1,M).LE.1 ) IER=17
        IF (IER.GT.0) GOTO 500
        I = IABS(L(I+1,M)-5)
        GOTO 219
2990    CONTINUE
        CALL SGTRCF(M,RT,N,M2,LCENT,LAUENO,IER)
        IF (IER.GT.0 ) IERX = IER
        IER = 0
3000    CONTINUE
        NSYM = N-1
        DO 4000 I=1,3
        DO 4000 K=1,NSYM
        DO 3900 J=1,3
        JRT(I,J,K) = RT(I,J,K)
3900    CONTINUE
        JRT(I,4,K) = 12*RT(I,4,K)+144.1
        JRT(I,4,K) = JRT(I,4,K)-12*(JRT(I,4,K)/12)
4000    CONTINUE
        CALL SGPRNT (JRT,LAUENO,NCENT,LCENT,NSYM,NPOL,CEN,NCV)
        IF (IERX .EQ. 0) RETURN
      IER = IERX
  500 CALL SGERRS (SPG,IER)
      NAXIS = 4
      RETURN
      END
      SUBROUTINE SGPRNT(JRT,LAUENO,NCENT,LCENT,NSYM,NPOL,CEN,NCV)
      DIMENSION JRT(3,4,24),CEN(3,4)
      DIMENSION NCVT(7),CENV(3,6)
      DIMENSION NSYS(14)
      DATA
     * NSYS( 1),NSYS( 2),NSYS( 3),NSYS( 4),NSYS( 5) /1,2,3,4,4/,
     * NSYS( 6),NSYS( 7),NSYS( 8),NSYS( 9),NSYS(10) /5,5,6,6,6/,
     * NSYS(11),NSYS(12),NSYS(13),NSYS(14)          /7,7,8,8/
      DATA
     * NCVT(1),NCVT(2),NCVT(3),NCVT(4),NCVT(5) /1,2,2,2,2/,
     * NCVT(6),NCVT(7)                         /4,3/
      DATA
     * CENV(1,1),CENV(2,1),CENV(3,1) /0.0      ,0.5      ,0.5      /,
     * CENV(1,2),CENV(2,2),CENV(3,2) /0.5      ,0.0      ,0.5      /,
     * CENV(1,3),CENV(2,3),CENV(3,3) /0.5      ,0.5      ,0.0      /,
     * CENV(1,4),CENV(2,4),CENV(3,4) /0.5      ,0.5      ,0.5      /,
     * CENV(1,5),CENV(2,5),CENV(3,5) /0.3333333,0.6666667,0.6666667/
      DATA
     * CENV(1,6),CENV(2,6),CENV(3,6) /0.6666667,0.3333333,0.3333333/
        NCV = NCVT(LCENT)
        MULT = NCV*NSYM*(NCENT+1)
        LSYS = NSYS(LAUENO)
        CEN(1,1) = 0.0
        CEN(2,1) = 0.0
        CEN(3,1) = 0.0
        IF (NCV.LE.1) GOTO 110
        J = LCENT-1
        IF (LCENT.EQ.6 ) J=1
        IF (LCENT.EQ.7 ) J=5
        DO 100 I=2,NCV
        CEN(1,I) = CENV(1,J)
        CEN(2,I) = CENV(2,J)
        CEN(3,I) = CENV(3,J)
        J = J+1
100     CONTINUE
110     CONTINUE
        NPX = 1
        NPY = 2
        NPZ = 4
        NPXYZ = 0
        NPYXZ = 1
        DO 120 I=1,NSYM
        IF (JRT(1,1,I).LE.0 ) NPX=0
        IF (JRT(2,2,I).LE.0 ) NPY=0
        IF (JRT(3,3,I).LE.0 ) NPZ=0
        IF (JRT(1,3,I).GT.0 ) NPXYZ=8
        IF (JRT(1,3,I).LT.0 ) NPYXZ=0
120     CONTINUE
        NPOL = (NPX+NPY+NPZ+NPXYZ*NPYXZ)*(1-NCENT)
      NPOL=NPOL*10000+LSYS*1000+MULT
      RETURN
      END
      SUBROUTINE SGERRS (SGP, IER)
      CHARACTER * 30 SGP
    1 FORMAT(' Either a 5-axis anywhere of a 3-axis in field 4')
    6 FORMAT(' Lattice subroutine found an error')
    8 FORMAT(' I for computed GOTO out of range')
    9 FORMAT(' An a-glide mirror normal to A')
   10 FORMAT(' A b-glide mirror normal to B')
   11 FORMAT(' A c-glide mirror normal to C')
   12 FORMAT(' D-glide in a primitive lattice')
   13 FORMAT(' A 4-axis not in the 2nd operator field')
   14 FORMAT(' A 6-axis not in the 2nd operator field')
   15 FORMAT(' More than 24 matrices needed to define the group')
   17 FORMAT(' Improper construction of a rotation operator')
   18 FORMAT(' No mirror following a /')
   19 FORMAT(' A translation conflict between operators')
   21 FORMAT(' 3 fields are legal only in R-lattices and m3 cubic')
   22 FORMAT(' Syntax error. Expected I-43d at this point')
   23 FORMAT(' Error unknown')
   24 FORMAT(' A or B centered tetragonal?  Impossible!!!!')
  999 FORMAT(' Error no.',I3,' in processing space group symbol ', A30)
      LIS1 = 9
      WRITE (LIS1, 999) IER,SGP
      IERR=IER+1
      GOTO (51,99,99,99,99,56,99,58,59,60,61,62,63,64,65,65,67,68,
     *      69,99,71,72,73,74),IERR
   51 WRITE (LIS1, 1)
      GOTO 99
   56 WRITE (LIS1, 6)
      GOTO 99
   58 WRITE (LIS1, 8)
      GOTO 99
   59 WRITE (LIS1, 9)
      GOTO 99
   60 WRITE (LIS1, 10)
      GOTO 99
   61 WRITE (LIS1, 11)
      GOTO 99
   62 WRITE (LIS1, 12)
      GOTO 99
   63 WRITE (LIS1, 13)
      GOTO 99
   64 WRITE (LIS1, 14)
      GOTO 99
   65 WRITE (LIS1, 15)
      GOTO 99
   67 WRITE (LIS1, 17)
      GOTO 99
   68 WRITE (LIS1, 18)
      GOTO 99
   69 WRITE (LIS1, 19)
      GOTO 99
   71 WRITE (LIS1, 21)
      GOTO 99
   72 WRITE (LIS1, 22)
      GOTO 99
   73 WRITE (LIS1, 23)
      GOTO 99
   74 WRITE (LIS1, 24)
   99 RETURN
      END
      SUBROUTINE SGLATC (K,L,D,LCENT,LAUENO,NAXIS,IER,I209,ID)
        DIMENSION D(3,3),L(4,4)
        IF (K-3 ) 120,130,140
  120 CONTINUE
        IF (L(1,2).EQ.17) GOTO 122
        IF (L(1,2).EQ.14) GOTO 123
        IF (L(1,2).EQ.15) GOTO 124
        IF (L(1,2).EQ.12) GOTO 125
        IM = 2
        GOTO 1419
 1220 CONTINUE
        IF (L(1,4).NE.12) GOTO 1530
  122 CONTINUE
        LAUENO = 11
        GOTO 210
  123 CONTINUE
        LAUENO = 8
        GOTO 210
  124 CONTINUE
        LAUENO = 4
        IF (LCENT.GE.5) GOTO 1240
        IF (LCENT.EQ.4) GOTO 1241
        IF (L(3,2).EQ.10) GOTO 1552
        IF (L(4,2).EQ.10 ) D(2,3)=0.5
        GOTO 210
1240    CONTINUE
        IF (L(4,2).NE.4.AND.L(4,2).NE.11) GOTO 1553
        D(1,3) = 0.75
        IF (LCENT.EQ.5 ) D(2,3) = 0.25
        GOTO 210
1241    CONTINUE
        IF (L(3,2).NE.4.AND.L(4,2).NE.4) GOTO 210
        D(1,3) = 0.25
        D(2,3) = 0.25
        IF (L(4,2).EQ.4 ) D(2,3)=0.75
        GOTO 210
  125 CONTINUE
        LAUENO = 1
        GOTO 210
  130 CONTINUE
        IF (L(1,3).NE.14 ) IER=20
        IF (IER.GT.0) GOTO 500
        LAUENO = 13
        IF (L(2,2).EQ.12 ) D(2,1)=0.5
        IF (L(1,2).EQ.3.OR.L(1,2).EQ.4 ) D(3,3)=0.5
        GOTO 209
  140 IF (L(1,3).EQ.14) GOTO 151
        IF (L(1,2).EQ.17) GOTO 153
        IF (L(1,2).EQ.14) GOTO 154
        IF (L(1,2).EQ.15) GOTO 155
        IF (L(1,2).EQ.12) GOTO 141
        IF (L(1,3).EQ.12) GOTO 142
1399    CONTINUE
        LAUENO = 3
        IM = 0
        IR = 0
        IA = 0
        IB = 0
        IC = 0
        ID = 0
        I21 = 0
        IF (L(1,2).NE.13) GOTO 1400
        IF (L(2,2).NE.12) GOTO 1401
        D(1,2) = 0.5
        D(1,3) = 0.5
        I21 = 4
        GOTO 1401
1400    CONTINUE
        IR = 1
        IF (L(1,2).EQ.9 ) IM=4
        IF (L(1,2).EQ.3 ) IB=1
        IF (L(1,2).EQ.2 ) IC=1
        IF (L(1,2).EQ.11 ) ID=1
        IF (L(1,3).EQ.4.OR.L(1,3).EQ.10 ) D(1,1)=0.5
        IF (L(1,4).EQ.4.OR.L(1,4).EQ.10 ) D(1,1)=D(1,1)+0.5
1401    CONTINUE
        IF (L(1,3).NE.13) GOTO 1402
        IF (L(2,3).NE.12) GOTO 1403
        D(2,1) = 0.5
        D(2,3) = 0.5
        I21 = I21+2
        GOTO 1403
1402    CONTINUE
        IR = IR+1
        IF (L(1,3).EQ.9 ) IM=IM+2
        IF (L(1,3).EQ.4 ) IA=1
        IF (L(1,3).EQ.2 ) IC=IC+1
        IF (L(1,3).EQ.11 ) ID=ID+1
        IF (L(1,2).EQ.3.OR.L(1,2).EQ.10 ) D(2,2)=0.5
        IF (L(1,4).EQ.3.OR.L(1,4).EQ.10 ) D(2,2)=D(2,2)+0.5
1403    CONTINUE
        IF (L(1,4).NE.13) GOTO 1404
        IF (L(2,4).NE.12) GOTO 1405
        D(3,1) = 0.5
        D(3,2) = 0.5
        I21 = I21+1
        GOTO 1405
1404    CONTINUE
        IR = IR+1
        IF (L(1,4).EQ.9 ) IM=IM+1
        IF (L(1,4).EQ.4 ) IA=IA+1
        IF (L(1,4).EQ.3 ) IB=IB+1
        IF (L(1,4).EQ.11 ) ID=ID+1
        IF (L(1,2).EQ.2.OR.L(1,2).EQ.10 ) D(3,3)=0.5
        IF (L(1,3).EQ.2.OR.L(1,3).EQ.10 ) D(3,3)=D(3,3)+0.5
1405    CONTINUE
        IF (IR.EQ.3) GOTO 1409
        IF (I21.EQ.4.OR.I21.EQ.5.OR.I21.EQ.7 ) D(1,2)=0.0
        IF (I21.EQ.6.OR.I21.EQ.7 ) D(1,3)=0.0
        IF (I21.EQ.3 ) D(2,1)=0.0
        IF (I21.EQ.2.OR.I21.EQ.6.OR.I21.EQ.7 ) D(2,3)=0.0
        IF (I21.EQ.1.OR.I21.EQ.3.OR.I21.EQ.7 ) D(3,1)=0.0
        IF (I21.EQ.5 ) D(3,2)=0.0
        IF (IM.LE.0) GOTO 210
        IF (IM.EQ.1.AND.(I21.EQ.4.OR.I21.EQ.2)) GOTO 1406
        IF (IM.EQ.2.AND.(I21.EQ.4.OR.I21.EQ.1)) GOTO 1407
        IF (IM.EQ.4.AND.(I21.EQ.2.OR.I21.EQ.1)) GOTO 1408
        GOTO 210
1406    CONTINUE
        IF ( ABS (D(3,3)) .LT. 0.000001) GOTO 210
        D(3,3)=0.0
        D(3,2) = D(3,2)+0.5
        GOTO 210
1407    CONTINUE
        IF ( ABS (D(2,2)) .LT. 0.000001) GOTO 210
        D(2,2)=0.0
        D(2,1) = D(2,1)+0.5
        GOTO 210
1408    CONTINUE
        IF ( ABS (D(1,1)) .LT. 0.000001) GOTO 210
        D(1,1)=0.0
        D(1,3) = D(1,3)+0.5
        GOTO 210
1409    CONTINUE
        IF (LCENT.EQ.1) GOTO 210
        IF (LCENT.EQ.2) GOTO 1410
        IF (LCENT.EQ.3) GOTO 1411
        IF (LCENT.EQ.4) GOTO 1412
        IF (LCENT.NE.5) GOTO 210
        IF (IA+IB+IC.NE.1) GOTO 210
        D(1,1) = D(1,1)+0.5
        D(2,2) = D(2,2)+0.5
        D(3,3) = D(3,3)+0.5
        GOTO 210
1410    CONTINUE
        IF (IB+IC.NE.1) GOTO 210
        IF (IA.EQ.2) GOTO 210
        D(2,2) = D(2,2)+0.5
        D(3,3) = D(3,3)+0.5
        GOTO 210
1411    CONTINUE
        IF (IA+IC.NE.1) GOTO 210
        IF (IB.EQ.2) GOTO 210
        D(1,1) = D(1,1)+0.5
        D(3,3) = D(3,3)+0.5
        GOTO 210
1412    CONTINUE
        IF (IA+IB.NE.1) GOTO 210
        IF (IC.EQ.2) GOTO 210
        D(1,1) = D(1,1)+0.5
        D(2,2) = D(2,2)+0.5
        GOTO 210
  141 IF (L(1,3).EQ.12) GOTO 143
        IF (L(1,4).NE.12) GOTO 1399
        IM = 3
1419    CONTINUE
        LAUENO = 2
        NAXIS = 2
        IA = 4
        IC = 2
        NA = 1
        NB = 2
        NC = 3
        GOTO 1430
  142 IF (L(1,4).NE.12) GOTO 1399
        LAUENO = 2
        NAXIS = 1
        IA = 3
        IC = 2
        NA = 2
        NB = 1
        NC = 3
        IM = 2
        GOTO 1430
  143 IF (L(1,4).EQ.12) GOTO 125
        LAUENO = 2
        NAXIS = 3
        IA = 4
        IC = 3
        NA = 1
        NB = 3
        NC = 2
        IM = 4
1430    CONTINUE
        IF (L(2,IM).EQ.12 ) D(NB,NAXIS)=0.5
        IF (L(3,IM).EQ.IA.OR.L(3,IM).EQ.10 ) D(NA,NAXIS)=0.5
        IF (L(3,IM).EQ.IC.OR.L(3,IM).EQ.10 ) D(NC,NAXIS)=0.5
        IF (L(4,IM).EQ.IA.OR.L(4,IM).EQ.10 ) D(NA,NAXIS)=0.5
        IF (L(4,IM).EQ.IC.OR.L(4,IM).EQ.10 ) D(NC,NAXIS)=0.5
        GOTO 210
  151 CONTINUE
        LAUENO = 14
        IF (L(1,2).EQ.3.OR.L(1,2).EQ.4 ) D(3,3)=0.5
        IF (L(1,2).NE.15) GOTO 209
        IF (L(2,2).EQ.3) GOTO 1511
        IF (L(2,2).LT.12) GOTO 209
        IF (L(2,2).GT.14) GOTO 209
        IF (L(2,2).EQ.12) GOTO 1512
        IF (L(2,2).EQ.13) GOTO 1513
        IF (LCENT.EQ.6) GOTO 1514
        D(1,3) = 0.75
        D(2,3) = 0.25
        GOTO 209
1511    CONTINUE
        IF (L(1,4).EQ.9) GOTO 209
        IF (L(1,4).EQ.11) GOTO 1515
        D(1,3) = 0.5
        D(2,3) = 0.5
        D(3,3) = 0.5
        GOTO 209
1512    CONTINUE
        IF (LCENT.EQ.6) GOTO 1514
        D(1,3) = 0.25
        D(2,3) = -0.25
        GOTO 209
1513    CONTINUE
        D(1,3) = 0.5
        D(2,3) = 0.5
        GOTO 209
1514    CONTINUE
        D(1,3) = 0.25
        D(2,3) = 0.25
        GOTO 209
1515    CONTINUE
        IF (LCENT.NE.5 ) IER=21
        IF (IER.GT.0 )GOTO 500
        D(1,3) = 0.75
        D(2,3) = 0.25
        D(3,3) = 0.75
        GOTO 209
  153 CONTINUE
        IF (L(1,3).EQ.12) GOTO 1220
1530    CONTINUE
        LAUENO = 12
        GOTO 210
  154 CONTINUE
        IF (L(1,3).EQ.12) GOTO 156
        IF (L(1,4).NE.12) GOTO 1530
        LAUENO = 9
        GOTO 210
155     CONTINUE
        LAUENO = 5
        IF (L(3,2).EQ.10.OR.L(4,2).EQ.10 ) D(1,1)=0.5
        IF (L(3,2).EQ.4.OR.L(4,2).EQ.4 ) D(2,2)=0.25
        IF (L(1,3).EQ.13.AND.L(2,3).EQ.12 ) D(1,2)=0.5
        IF (L(1,3).EQ.3.OR.L(1,3).EQ.10 ) D(1,1)=D(1,1)+0.5
        IF (L(1,4).EQ.3.OR.L(1,4).EQ.10 ) D(2,2)=D(2,2)+0.25
        IF (L(2,2).GT.11.AND.L(2,2).LT.15.AND.L(2,3).NE.12 )
     1    D(3,1)=-(L(2,2)-11)/4.0
        IF (L(1,4).EQ.13.AND.L(2,4).NE.12) GOTO 1549
        IF (L(2,2).GT.11.AND.L(2,2).LT.15 ) D(3,1)=(L(2,2)-11)/4.0
1549    CONTINUE
        IF (L(1,3).EQ.13.AND.L(2,3).NE.12) GOTO 1550
        IF (L(2,2).GT.11.AND.L(2,2).LT.15 ) D(3,2)=(L(2,2)-11)/4.0
1550    CONTINUE
        IF (L(1,3)+L(3,2).EQ.11.AND.LCENT.EQ.6 ) D(2,1)=0.75
        IF (L(1,4).EQ.2.AND.LCENT.EQ.6 ) D(1,1)=0.5
        IF (L(2,2).EQ.3) GOTO 1556
        IF (LCENT.GT.1) GOTO 1553
        IF (L(3,2).EQ.10.OR.L(4,2).EQ.10) GOTO 1552
        IF (L(1,3).EQ.13.AND.L(2,3).EQ.12) GOTO 1551
        IF (L(1,3).NE.10) GOTO 210
        IF (L(2,2).LE.0) GOTO 210
        IF (L(2,2).GT.15) GOTO 210
1551    CONTINUE
        D(1,3) = 0.5
        D(2,3) = 0.5
        GOTO 210
1552    CONTINUE
        D(1,3) = 0.5
        GOTO 210
1553    CONTINUE
        IF (LCENT.LT.5) GOTO 1555
        IF (L(1,4).EQ.2 ) D(2,1)=D(2,1)+0.5
        IF (L(4,2).NE.4.AND.L(4,2).NE.11) GOTO 1554
        D(1,3) = 0.25
        IF (LCENT.EQ.5 ) D(2,3) = 0.75
        GOTO 210
1554    CONTINUE
        IF (L(2,2).NE.12) GOTO 210
        IF (LCENT.EQ.6) GOTO 1558
        D(2,3) = 0.5
        GOTO 1557
1555    CONTINUE
        IF (LCENT.NE.4 ) IER=23
        IF (IER.GT.0) GOTO 500
        IF (L(3,2).EQ.4.OR.L(4,2).EQ.4) GOTO 1559
        IF ( ABS (D(1,1)) .LT. 0.000001) D(1,1)=2.0*D(2,2)
        IF (L(1,4).EQ.13.AND.L(2,4).EQ.12) GOTO 1552
        IF (L(2,2).LE.0) GOTO 210
        IF (L(1,4).NE.10) GOTO 210
        IF (L(2,2).GT.15) GOTO 210
        D(1,1) = D(1,1)-2.0*D(2,2)
        GOTO 1552
1556    CONTINUE
        IF (L(1,3).EQ.11.AND.LCENT.EQ.6 ) D(3,1)=0.25
        IF (L(1,4).EQ.13.AND.L(2,4).EQ.12 ) D(1,1)=0.5
        IF (L(1,4).EQ.2.OR.L(1,4).EQ.10 ) D(3,2)=0.5
        IF (L(1,4).EQ.3.OR.L(1,4).EQ.10 ) D(1,2)=0.5
        IF (L(1,4).NE.11) GOTO 210
1557    CONTINUE
        IF (LCENT.EQ.5 ) D(1,2) = 0.5
        D(3,2) = 0.75
        GOTO 210
1558    CONTINUE
        D(1,3) = 0.25
        D(2,3) = 0.75
        GOTO 210
1559    CONTINUE
        D(1,3) = 0.25
        D(2,3) = 0.25
        IF (L(1,4).EQ.3.OR.L(1,4).EQ.10 ) D(1,1)=0.5
        GOTO 210
  156 CONTINUE
        IF (L(1,4).EQ.12) GOTO 123
        LAUENO = 10
        GOTO 210
  209 CONTINUE
        I209 = 1
210     CONTINUE
        RETURN
  500   IF (IER.EQ.0 ) IER=5
        RETURN
      END
      SUBROUTINE SGLPAK (L, IER)
        DIMENSION L(4)
        IF (L(2).LT.12 ) IER=4
        IF (L(2).GT.17 ) IER=4
        L(1) = L(2)
        L(2) = 3
      RETURN
      END
      SUBROUTINE SGMTML (X, I, Y, J, Z, K)
        DIMENSION X(5,4,24),Y(5,4,24),Z(5,4,24)
        DO 100 L=1,4
        DO 100 M=1,4
        Z(L,M,K) = 0.0
        DO 100 N=1,4
        Z(L,M,K) = Z(L,M,K)+Y(L,N,J)*X(N,M,I)
100     CONTINUE
        Z(1,4,K) = AMOD(5.0+Z(1,4,K),1.0)
        Z(2,4,K) = AMOD(5.0+Z(2,4,K),1.0)
        Z(3,4,K) = AMOD(5.0+Z(3,4,K),1.0)
        Z(5,1,K) = 81*(2*Z(1,1,K)+3*Z(1,2,K)+4*Z(1,3,K))
     1             +9*(2*Z(2,1,K)+3*Z(2,2,K)+4*Z(2,3,K))
     2                +2*Z(3,1,K)+3*Z(3,2,K)+4*Z(3,3,K)
        Z(5,2,K) = 1728*Z(1,4,K)+144*Z(2,4,K)+12*Z(3,4,K)
        Z(5,3,K) = 0.0
        Z(5,4,K) = 0.0
      RETURN
      END
      SUBROUTINE SGRMAT (RT, A, B, C, D, E, F, G, H, O)
      INTEGER A,B,C,D,E,F,G,H,O
      DIMENSION RT(5,4)
      CALL KERNZA (0.0, RT, 20)
      RT(1,1) = A
      RT(1,2) = B
      RT(1,3) = C
      RT(2,1) = D
      RT(2,2) = E
      RT(2,3) = F
      RT(3,1) = G
      RT(3,2) = H
      RT(3,3) = O
      RT(4,4) = 1.0
      RT(5,1) = 81*(2*RT(1,1)+3*RT(1,2)+4*RT(1,3))
     1          +9*(2*RT(2,1)+3*RT(2,2)+4*RT(2,3))
     2             +2*RT(3,1)+3*RT(3,2)+4*RT(3,3)
      RT(5,3) = 10.0
      RT(5,4) = 20.
      RETURN
      END
      SUBROUTINE SGTRCF (M, RT, N, M2, LCENT, LAUENO, IER)
      DIMENSION RT(5,4,24)
      DIMENSION ICENV(3,5),NCVT(7),JCVT(7)
      DATA ICENV /0,0,0, 0,6,6, 6,0,6, 6,6,0, 6,6,6/
      DATA NCVT  /1,2,3,4,5,4,1/
      DATA JCVT  /1,1,2,3,4,1,1/
      DATA TOTTR / 0.0 /
      IPRX=9
        IER = 0
        IRN = RT(5,2,N)
        IRM = RT(5,2,M2)
        IRX = MOD((IRN/144+IRM/144),12)
        IRY = MOD((IRN/12 +IRM/12 ),12)
        IRZ = MOD(IRN+IRM,12)
        NCV = NCVT(LCENT)
        JCV = JCVT(LCENT)
        DO 100 ICV=1,NCV,JCV
        IRX1 = MOD(IRX+ICENV(1,ICV),12)
        IRY1 = MOD(IRY+ICENV(2,ICV),12)
        IRZ1 = MOD(IRZ+ICENV(3,ICV),12)
        M2Z = M2
        IF ( ABS (RT(5,1,N)+RT(5,1,M2)) .LT. 0.000001) M2Z=1
        IF (RT(3,3,N)+RT(3,3,M2Z) .LT. 0.00001) IRZ1=0
        IF (LAUENO.LE.3.OR.M.NE.4) GOTO 70
        IRX1 = MOD(IRX1+IRY1,12)
        IRY1 = 0
        GOTO 80
70      CONTINUE
        IF (RT(1,1,N)+RT(1,1,M2Z).LE.0.) IRX1=0
        IF (RT(2,2,N)+RT(2,2,M2Z).LE.0.) IRY1=0
80      CONTINUE
        TOTTR = 144*IRX1+12*IRY1+IRZ1
        IF (NINT(TOTTR) .EQ. 0 ) RETURN
100     CONTINUE
        WRITE (IPRX, 10000) RT(5,2,N),RT(5,2,M2),
     1    TOTTR,IRX,IRY,IRZ,RT(5,1,N),RT(5,1,M2)
10000   FORMAT (3F10.1,3I5,2F10.1)
        IER = 18
        WRITE (IPRX, 2991) M,N,M2
 2991 FORMAT(' Operator ',I2,' generates matrix',I3,' which has a',
     * ' translation conflict',2I3)
      RETURN
      END
      SUBROUTINE ORIGIN (ORIG, NOR)
      DIMENSION    ORIG(3,8)
      COMMON /SPACE/ LAUE, NAXIS, ICEN, LATCEN, NEQV, NPOL, NSYS,
     *               JRT(3,4,24), CEN(3,4), NCV, MULTIP
      PARAMETER   (EPS = 0.0001)
      DIMENSION    X(3), XS(3), XS1(3), XS2(3), LV(3), MS(3),
     *             FRSYMM(3,3,24), TEMCEN(3,4)
      LOGICAL      LAST, LDIR, OK
      DIMENSION    LL(3,0:8)
      DATA LL /1, 1, 1,    0, 1, 1,    1, 0, 1,
     *         0, 0, 1,    1, 1, 0,    0, 1, 0,
     *         1, 0, 0,    0, 0, 0,    1, 1, 0/
      NOR=1
      CALL KERNZA (0.0, ORIG(1,NOR),3)
      IF (NPOL.EQ.7) RETURN
      CALL KERNAI (LL(1,NPOL), LV, 3)
      DO 10 I1 = 1, 3
      DO 10 I2 = 1, 3
      DO 10 I3 = 1, NEQV
   10 FRSYMM(I1,I2,I3) = JRT(I1,I2,I3)
      MSTEP=3
      IF (NSYS.GE.5 .AND. NSYS.LE.7) MSTEP=5
      STEP=1.0 / (FLOAT(MSTEP) + 1.0)
      DO 110 J=1, 3
  110 MS(J)=MSTEP * LV(J)
      DO 170 I1=0, MS(1)
      X(1)=STEP * FLOAT(I1)
      DO 170 I2=0, MS(2)
      X(2)=STEP * FLOAT(I2)
      DO 170 I3=0, MS(3)
      X(3)=STEP * FLOAT(I3)
      IF (I1.EQ.0 .AND. I2.EQ.0 .AND. I3.EQ.0) GOTO 170
         DO 160 IS=1, NEQV
         CALL MATXV3 (FRSYMM(1,1,IS), X, XS)
         DO 160 IC=1, ICEN+1
         IF (IC.EQ.1) THEN
            DO 120 J=1, 3
  120       XS1(J)=XS(J) - X(J)
         ELSE
            DO 130 J=1, 3
  130       XS1(J)= - (XS(J) + X(J))
            ENDIF
         OK=.FALSE.
         LAST=IS.EQ.NEQV .AND. IC.EQ.ICEN+1
         DO 150 IL=1, NCV
            LDIR=.TRUE.
            DO 140 J=1, 3
            XS2(J)=XS1(J) + CEN(J,IL)
  140       LDIR=LDIR .AND. (ABS(XS2(J) - ANINT(XS2(J))) .LE. EPS)
  150       OK=OK .OR. LDIR
         IF (.NOT. OK) GOTO 170
         IF (LAST) THEN
            NOR=NOR + 1
            CALL KERNAB (X, ORIG(1,NOR), 3)
            ENDIF
  160    CONTINUE
  170 CONTINUE
      DO 210 I = 1,NOR
      DO 210 J = 1,3
         ORIG(J,I) = AMOD( ORIG(J,I), 1.0 )
         IF ( ORIG(J,I) .LT. 0.0 ) ORIG(J,I) = ORIG(J,I) + 1.0
  210 CONTINUE
      IF ( NOR .EQ. 1 ) GOTO 250
      DO 221 I = 1,NOR-1
         IF ( ORIG(1,I) .LT. -0.5 ) GOTO 221
         DO 220 J = I+1,NOR
            IF ( ORIG(1,J) .LT. -0.5 ) GOTO 220
            IF (
     *         ( ABS(ORIG(1,I)-ORIG(1,J)) .LT. EPS ) .AND.
     *         ( ABS(ORIG(2,I)-ORIG(2,J)) .LT. EPS ) .AND.
     *         ( ABS(ORIG(3,I)-ORIG(3,J)) .LT. EPS )
     *         ) ORIG(1,J) = -1.0
  220    CONTINUE
  221 CONTINUE
      IF ( NCV .EQ. 1 ) GOTO 250
      NTEMC = 0
      CALL KERNAB (CEN, TEMCEN, 3*NCV)
      DO 226 I = 1,3
         IF ( LV(I) .EQ. 0 ) THEN
            NTEMC = NTEMC + 1
            DO 225 J = 1,NCV
               TEMCEN(I,J) = 0.0
  225       CONTINUE
         END IF
  226 CONTINUE
      DO 232 I = 1,NOR
         IF ( ORIG(1,I) .LT. -0.5 ) GOTO 232
         DO 231 J = 1,NOR
            IF ( I .EQ. J ) GOTO 231
            IF ( ORIG(1,J) .LT. -0.5 ) GOTO 231
            DO 230 K = 2,NCV
               PC1 = ABS( MOD( (ORIG(1,I) + CEN(1,K)),1. ) - ORIG(1,J) )
               PC2 = ABS( MOD( (ORIG(2,I) + CEN(2,K)),1. ) - ORIG(2,J) )
               PC3 = ABS( MOD( (ORIG(3,I) + CEN(3,K)),1. ) - ORIG(3,J) )
               IF ( PC1 .LT. EPS .AND. PC2 .LT. EPS .AND.
     *              PC3 .LT. EPS ) ORIG(1,J) = -1.0
  230       CONTINUE
  231    CONTINUE
  232 CONTINUE
      IF ( NTEMC .EQ. 0 ) GOTO 250
      DO 242 I = 1,NOR
         IF ( ORIG(1,I) .LT. -0.5 ) GOTO 242
         DO 241 J = 1,NOR
            IF ( I .EQ. J ) GOTO 241
            IF ( ORIG(1,J) .LT. -0.5 ) GOTO 241
            DO 240 K = 2,NCV
               PC1 = ABS( MOD( (ORIG(1,I)+TEMCEN(1,K)),1.) - ORIG(1,J) )
               PC2 = ABS( MOD( (ORIG(2,I)+TEMCEN(2,K)),1.) - ORIG(2,J) )
               PC3 = ABS( MOD( (ORIG(3,I)+TEMCEN(3,K)),1.) - ORIG(3,J) )
               IF ( PC1 .LT. EPS .AND. PC2 .LT. EPS .AND.
     *              PC3 .LT. EPS ) ORIG(1,J) = -1.0
  240       CONTINUE
  241    CONTINUE
  242 CONTINUE
  250 N = 0
      DO 270 I = 1,NOR
         IF ( ORIG(1,I) .LT. -0.5 ) GOTO 270
         N = N + 1
         IF ( N .EQ. I ) GOTO 270
         DO 260 J = 1,3
  260       ORIG(J,N) = ORIG(J,I)
  270 CONTINUE
      NOR = N
      RETURN
      END
      SUBROUTINE RESRD ( KEYCEL )
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      COMMON /ATOMS/ NUMATO, ATCNT(10), IATCNT(10), IFORM, ATWT(10),
     *               IATNO(10), RADIUS(10), COVRAD(10), ATRAD(10),
     *               SCTCOF(9,10), DFP(10), DFDP(10), ABSCO(10),
     *               IATCEL(10), ABSLIN, DCALC, F0002, AMOL
      CHARACTER Z *1
      PARAMETER (LMAX = 5)
      CHARACTER*6 LTEXT (LMAX)
      CHARACTER*2 RADTN(5)
      DIMENSION RLAM3(5)
      DATA IRES /2/
      DATA LTEXT /'TITL','CELL','ZERR','SFAC','UNIT'/
      DATA RADTN / 'AG',    'MO',    'CU',    'FE',    'CR' /
      DATA RLAM3 / 0.560871 ,0.710730,1.541838,1.937355,2.291002/
      CALL FILINQ (IRES, 'INS' , 'FORMATTED', 'INPUT', KINI)
      IF (KINI .EQ. 0) GOTO 99
      CALL FILINQ (IRES, 'RES' , 'FORMATTED', 'INPUT', KINR)
      IF (KINR .EQ. 0) GOTO  99
      CALL FILINQ (IRES, 'XYZN' , 'FORMATTED', 'INPUT', KINI)
      IF (KINI .NE. 0) RETURN
      WRITE (9, FMT='('' warning: file XYZN will become obsolete'')')
   99 NTYPE = 0
      ZET = 1.
  100 READ(IRES, 105, END = 200) CHIN
  105 FORMAT (A80)
      CALL KERINB(LTEXT,LMAX)
      GOTO ( 110, 120, 130, 140, 150 ), NLUSER(1)
      GOTO 100
  110 TITLE = CHIN(6:69)
      GOTO 100
  120 WAVE = FNUM(1)
      NL = 1
      DM = 99.9
      DO 125 I = 1, 5
         D = ABS( WAVE - RLAM3(I) )
         IF ( D .LT. DM ) THEN
            NL = I
            DM = D
         END IF
  125 CONTINUE
      WAVEAT = RADTN(NL)
      CALL WAVELN( WAVEAT, NEND )
      CALL KERNAB( FNUM(2), CELL, 6 )
      KEYCEL = 1
      GOTO 100
  130 ZET  = FNUM(1)
      IF ( ZET .LT. 0.1 ) THEN
         WRITE (9, 135) ZET
  135    FORMAT (' Warning, ZET from INS/RES reset to 1.0; was: ',F5.2)
         ZET = 1.0
         ENDIF
      CALL KERNAB( FNUM(2), CELLSD, 6 )
      GOTO 100
  140 IF ( NLIT .GT. 11 ) THEN
         WRITE(9, 145)
  145    FORMAT (' Warning, more than ten atom species on INS/RES file')
         NLIT = 11
      ENDIF
      DO 148 N = 2, NLIT
         NTYPE = NTYPE + 1
         I2 = 2
         Z = LIT(N)(2:2)
         CALL KERC2I(Z, KEND )
         IF ( KEND .LT. 11 .OR. KEND .GT. 36 ) I2 = 1
  148    CELATY(NTYPE)(1:I2) = LIT(N)(1:I2)
      GOTO 100
  150 IF ( NFNUM .GT. 10 ) NFNUM = 10
      IF ( NFNUM .NE. NTYPE ) THEN
         WRITE(9, 155)
  155    FORMAT (' Warning, SFAC and UNIT do not match on INS/RES file')
         NFNUM = NTYPE
      ENDIF
      CALL KERNAB( FNUM, CELALL, NFNUM )
      DO 158 N = 1, NFNUM
  158 ATCNT(N) = CELALL(N) / ZET
      GOTO 100
  200 CONTINUE
      CALL FILCLO (IRES, 'KEEP')
      RETURN
      END
      SUBROUTINE CIFCRY ( KEYCEL )
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRIN,  IFILE(1)), (ICIF,   IFILE(2))
      COMMON /ATOMS/ NUMATO, ATCNT(10), IATCNT(10), IFORM, ATWT(10),
     *               IATNO(10), RADIUS(10), COVRAD(10), ATRAD(10),
     *               SCTCOF(9,10), DFP(10), DFDP(10), ABSCO(10),
     *               IATCEL(10), ABSLIN, DCALC, F0002, AMOL
      LOGICAL ZFOUND, FFOUND
      CHARACTER*1 CT, Z
      CHARACTER*2 RADTN(5)
      CHARACTER*80 FORTMP
      DIMENSION RLAM3(5)
      DATA RADTN / 'AG',    'MO',    'CU',    'FE',    'CR' /
      DATA RLAM3 / 0.560871 ,0.710730,1.541838,1.937355,2.291002/
      DATA ICELL / 0 /
      DATA FST   / 1.0 /
      CALL FILINQ ( ICIF, 'CIF', 'FORMATTED', 'INPUT', KINC )
      IF ( KINC .NE. 0 ) RETURN
      ZFOUND = .FALSE.
      FFOUND = .FALSE.
100   CALL KERINA( ICIF, LIT, 1, KEND )
      IF ( KEND .NE. 0 ) GOTO 200
      IF ( CHIN(1:6) .EQ.'_cell_' ) THEN
         IF ( CHIN(7:14) .EQ. 'length_a'    .OR.
     *        CHIN(7:14) .EQ. 'length_b'    .OR.
     *        CHIN(7:14) .EQ. 'length_c'    .OR.
     *        CHIN(7:17) .EQ. 'angle_alpha' .OR.
     *        CHIN(7:16) .EQ. 'angle_beta'  .OR.
     *        CHIN(7:17) .EQ. 'angle_gamma' ) THEN
            ICELL = ICELL + 1
            IST = 1
            DO 110 I = NCOLL(2), NCOLL(2) + IABS(NFDOL(2)) - 1
            GOTO ( 111, 112, 113 ), IST
  111          IF ( CHIN(I:I) .EQ. '.' ) IST = 2
               FST = 1.0
               GOTO 110
  112          IF ( CHIN(I:I) .EQ. '(' ) THEN
                  IST = 3
                  CHIN(I:I) = ' '
               ELSE
                  FST = FST * 0.1
               ENDIF
               GOTO 110
  113          IF ( CHIN(I:I) .EQ. ')' ) CHIN(I:I) = ' '
  110       CONTINUE
            CALL KERINB (LIT, 1)
            CELL(ICELL) = FNUM(1)
            CELLSD(ICELL) = FST * FNUM(2)
            IF ( ICELL .EQ. 6 ) KEYCEL = 1
            GOTO 100
        ELSE IF ( CHIN(7:21) .EQ. 'formula_units_Z' ) THEN
            ZET = FNUM(1)
            IF ( ZET .LT. 0.1 ) THEN
               WRITE (9, 115) ZET
  115          FORMAT (' Warning, ZET from CIF reset to 1.0; was:',F5.2)
               ZET = 1.0
            END IF
            ZFOUND = .TRUE.
            GOTO 100
         ENDIF
      ENDIF
      IF ( CHIN(1:30) .EQ. '_symmetry_space_group_name_H-M' ) THEN
         IF ( LIT(2) .EQ. '?' ) GOTO 100
         DO 120 I = 31, 80
            IF ( CHIN(I:I) .EQ. '''' ) THEN
               IST = I + 1
               GOTO 125
            END IF
  120    CONTINUE
         GOTO 100
  125    ISP = 0
         DO 127 I = IST, 80
            IF ( CHIN(I:I) .EQ. '''' ) GOTO 100
            ISP = ISP + 1
            IF ( ISP .GT. 16 ) THEN
               SPGR = ' '
               GOTO 100
            END IF
            SPGR(ISP:ISP) = CHIN(I:I)
  127    CONTINUE
         GOTO 100
      ENDIF
      IF ( CHIN(1:28) .EQ. '_diffrn_radiation_wavelength' ) THEN
         WAVE = FNUM(1)
         NL = 1
         DM = 99.9
         DO 130 I = 1, 5
            D = ABS( WAVE - RLAM3(I) )
            IF ( D .LT. DM ) THEN
               NL = I
               DM = D
            END IF
  130    CONTINUE
         WAVEAT = RADTN(NL)
         CALL WAVELN ( WAVEAT, KEND )
         GOTO 100
      ENDIF
      IF ( CHIN(1:21) .EQ. '_chemical_formula_sum' ) THEN
         FORTMP = ' '
         FORTMP(1:59) = CHIN(22:80)
         CHIN = FORTMP
         DO 140 I = 1, 80
  140    IF ( CHIN(I:I) .EQ. '''' ) CHIN(I:I) = ' '
         CALL KERINB (LIT, 1)
         IF ( LIT(1) .EQ. '?' ) GOTO 100
         NTYPE = NLIT
         DO 145 I = 1, NTYPE
            CT = LIT(I) (2:2)
            CELATY(I) (1:1) = LIT(I) (1:1)
            IF ( CT .EQ. ' ' ) THEN
               ATCNT(I) = 1.0
               GOTO 145
            ELSE IF ( CT .GE. 'A' .AND. CT .LE. 'Z' .OR.
     *                CT .GE. 'a' .AND. CT .LE. 'z' ) THEN
               CELATY(I) (2:2) = LIT(I) (2:2)
               IF ( LIT(I) (3:3) .EQ. ' ' ) THEN
                  ATCNT(I) = 1.0
                  GOTO 145
               ELSE
                  NUMST = 3
               END IF
            ELSE
               NUMST = 2
            END IF
            ATCNT(I) = 0.0
            DO 143 J = NUMST, 6
               IF ( LIT(I) (J:J) .EQ. ' ' ) GOTO 145
               Z = LIT(I)(J:J)
               CALL KERC2I (Z, K )
               ATCNT(I) = ATCNT(I)*10.0 + FLOAT(K)
  143       CONTINUE
  145    CONTINUE
         FFOUND = .TRUE.
         GOTO 100
      ENDIF
      GOTO 100
  200 IF ( ZFOUND .AND. FFOUND ) THEN
         DO 202 I = 1, NTYPE
            CELALL(I) = ATCNT(I) * ZET
  202    CONTINUE
      END IF
      CALL FILCLO (ICIF, 'KEEP')
      WRITE (24, 205)
  205 FORMAT
     * (' At least some data has been read from the CIF file...')
      RETURN
      END
      SUBROUTINE WRCRIN
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRIN, IFILE(1))
      EQUIVALENCE (KEYS(26), IHKLF)
      COMMON /ATOMS/ NUMATO, ATCNT(10), IATCNT(10), IFORM, ATWT(10),
     *               IATNO(10), RADIUS(10), COVRAD(10), ATRAD(10),
     *               SCTCOF(9,10), DFP(10), DFDP(10), ABSCO(10),
     *               IATCEL(10), ABSLIN, DCALC, F0002, AMOL
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE(ICRIN, 10) CCODE
      WRITE(ICRIN, 30) CELL
      WRITE(ICRIN, 40) CELLSD
      WRITE(ICRIN, 50) SPGR
      IF (NUMATO.LE.5) THEN
         WRITE (ICRIN, 601) (CELATY(I), ATCNT(I), I=1,NUMATO)
      ELSE
         WRITE (ICRIN, 611) (CELATY(I), ATCNT(I), I=1,5)
         WRITE (ICRIN, 612) (CELATY(I), ATCNT(I), I=6,NUMATO)
      ENDIF
      WRITE(ICRIN, 70) IFORM
      WRITE(ICRIN, 80) WAVEAT
      IF (IHKLF .NE. 0) WRITE (ICRIN, 85) IHKLF
      WRITE(ICRIN, 90)
   10 FORMAT ('CRYSIN    ', A6)
   30 FORMAT ('CELL      ', 6F10.5)
   40 FORMAT ('CELLSD    ', 6F10.5)
   50 FORMAT ('SPGR      ', A16)
  601 FORMAT ('FORMUL    ', 5 (A2, F9.2, 1X))
  611 FORMAT ('FORMUL    ', 5 (A2, F9.2, 1X), ' =')
  612 FORMAT ('          ', 5 (A2, F9.2, 1X))
   70 FORMAT ('Z         ', I10)
   80 FORMAT ('WAVE      ', A2)
   85 FORMAT ('HKLF      ', I2)
   90 FORMAT ('END       ')
      WRITE (24, 100)
  100 FORMAT (///' The following CRYSIN file has been created:' /)
      REWIND ICRIN
  110 READ (ICRIN, 120, END=140) CHIN
  120 FORMAT (A80)
      WRITE (24, 130) CHIN
  130 FORMAT (1X,A80)
      GOTO 110
  140 WRITE (24, 150)
  150 FORMAT
     * (/' N.B.The CRYSIN input file has highest priority when',/,
     *   ' a new CRYSDA file is created!' /)
      CALL FILCLO (ICRIN, 'KEEP')
      RETURN
      END
      SUBROUTINE ORFLEX
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDOKA, KEYS(10))
      PARAMETER                  (MAXAT=100, MXTORB=10)
      COMMON /MOLEC/ NATOMS, XO(3,MAXAT), MPRT(4,MAXAT),NFRAGS,
     *               IAPRT(MAXAT,MXTORB), NT(2,MXTORB),
     *               DROT(MXTORB), TRANGL(MXTORB), ISEQR(MXTORB),
     *               TORSI(MXTORB), NBFIXD, DISPMX, DLIM, BONDMX
      DATA K2,NTOR /0,0/
      CALL FILCLO (1, 'KEEP')
      CALL FILCLO (2, 'KEEP')
      CALL FILCLO (3, 'KEEP')
      CALL FILINQ (1, 'DDSYST', 'FORMATTED', 'OUTPUT', KIDDS)
      WRITE (1, FMT='(''ORFLEX''/''STOP'')')
      CALL FILCLO (1, 'KEEP')
      CALL KEPROG ('ORFLEX')
      IDOKA = -17
      SWITCH(25) = .TRUE.
      DISPMX=0.5
      DLIM=2.7
      BONDMX=1.8
      NB=0
 111  NB=NB+1
      K=0
      K3=0
 222  IF (NB.EQ.1) THEN
        CALL PREMOD (1)
        NTOR=NFRAGS-1
      ELSE
        K=K+1
        IF (K.GT.K2) GOTO 310
         CALL PREMOD (2)
        ENDIF
      NR=ISEQR(NBFIXD)
      CALL ATORB(NR, MGEN)
      K3=K3+MGEN
      IF (NB.NE.1) GOTO 222
 310  CONTINUE
      IF (K3.NE.0) THEN
        IF (NB.NE.1) CALL FILCLO (2, 'DELETE')
        CALL FILINQ (2, 'ATFLEX', 'FORMATTED', 'OUTPUT', KINQ)
        CALL COPYGA(3, 2)
        CLOSE (3,STATUS='DELETE')
        K2=K3
      ELSE
        IF (K2.EQ.0) THEN
         IPR=9
 401     WRITE (IPR, FMT='('' Check your input-model'')')
         WRITE (IPR,FMT='('' It is not possible to generate models'')')
         WRITE (IPR,FMT=
     *    '('' in which non-bonded distances >'',F6.2)') DLIM
         IF (IPR.EQ.7)   CALL KEPROX
         IPR=7
         GOTO 401
        ENDIF
      ENDIF
      IF (NB.LT.NTOR)  GOTO    111
      IF (K2.GT.0) CALL REMMOD(K2)
      CALL FILCLO (2, 'KEEP')
      CALL KEPROX
      END
      SUBROUTINE WRIMOD (NUNIT, X, NATOMS, NBF, ISEQR,TORSI)
      PARAMETER (MAXAT=100)
      DIMENSION X(3,MAXAT)
      PARAMETER (MXTORB=10)
      DIMENSION ISEQR(MXTORB), TORSI(MXTORB)
      DIMENSION ATXYZ(10, MAXAT)
      COMMON /MOLECA/ ATNAME
      CHARACTER * 6 ATNAME(MAXAT)
      DO 110 N=1,NATOMS
      CALL KERNZA (0., ATXYZ(4,N), 7)
      DO 110 I=1,3
 110  ATXYZ(I,N)=X(I,N)
      IF (NBF.GT.0) THEN
        WRITE(NUNIT, FMT='(I2)') NBF
        WRITE(NUNIT, FMT='(12I2)') (ISEQR(I),I=1,NBF)
        WRITE(NUNIT, FMT='(12F6.1)') (TORSI(I),I=1,MXTORB)
      ENDIF
      CALL ATOMWR(NUNIT, ATXYZ, ATNAME, NATOMS)
      RETURN
      END
      SUBROUTINE PREMOD(IUNIT)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IATOMS,IFILE(1))
      PARAMETER (NSLOT = 10, MAXAT=100)
      DIMENSION ATXYZ(NSLOT,MAXAT), IZAT(MAXAT)
      PARAMETER (MXTORB=10)
      COMMON /MOLEC/ NATOMS, XO(3,MAXAT), MPRT(4,MAXAT),NFRAGS,
     *               IAPRT(MAXAT,MXTORB), NT(2,MXTORB),
     *               DROT(MXTORB), TRANGL(MXTORB), ISEQR(MXTORB),
     *               TORSI(MXTORB), NBFIXD, DISPMX, DLIM, BONDMX
      COMMON /MOLECA/ ATNAME
      CHARACTER * 6 ATNAME(MAXAT), ATN12
      DIMENSION  NSETA(MAXAT), NSR(MAXAT),NSR1(MAXAT)
      DIMENSION  XYZT(3)
      PARAMETER (DE2RA=3.141593/180.)
      LOGICAL    CALROT, SRCHAP, FIRST
      DATA       CALROT, FIRST /.FALSE., .TRUE./
      IATOMS=IUNIT
      IF (IUNIT .EQ. 1) THEN
         CALL FILINQ (IATOMS, 'ATMOD', 'FORMATTED', 'INPUT', KINQ)
         IF (KINQ.EQ.-1) CALL KERROR('ATMOD not found',0,'MODGEN')
         NBFIXD=0
         CALL KERNZA (0.0, TORSI, MXTORB)
      ELSE
         READ (IATOMS,FMT='(I2)') NBFIXD
         READ (IATOMS,FMT='(12I2)') (ISEQR(I),I=1,NBFIXD)
         READ (IATOMS,FMT='(12F6.1)') (TORSI(I),I=1,NFRAGS-1)
         ENDIF
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      NATOMS=NAT
      CALL KERNZA (0., XYZT, 3)
      DO 232 I = 1, NAT
      DO 232 J = 1, 3
232   XYZT(J) = XYZT(J) + ATXYZ(J,I)
      DO 234 J = 1, 3
234   XYZT(J) = - XYZT(J) / FLOAT(NAT)
      TT = 0.
      DO 236 I = 1, NAT
      DO 236 J = 1,3
236   TT = TT + ABS(ATXYZ(J,I) + XYZT(J))
      TT = TT / FLOAT(NAT-1)
      IF (TT .LT. 1.0)
     *    CALL KERROR(' No Cartesian coordinates', 0 , 'PREMOD')
      DO 110 N=1,NATOMS
      DO 110 J=1,3
110   XO(J,N)=ATXYZ(J,N)
      IF (IUNIT.NE.1)   GOTO  1000
      CALROT=.FALSE.
      WRITE (9,FMT='(
     *   '' Program ORFLEX generates a number of models,''/
     *   '' by variing torsion angles of specified bonds.''/
     *   '' These rotation-bonds must be given by the names of''/
     *   '' the two atoms forming the bond.''/1X/
     *   '' The DEFAULT value for the minimum distance between''/
     *   '' nonbonded atoms (which are not involved in a bond-angle)''/
     *   '' is '',F4.2,'' Angstrom)'')')  DLIM
        WRITE (9, FMT=
     *  '('' Do you want to use the DEFAULT value? (Y/N)'')')
 111    CALL KETERM (0,1,KEND)
        IF (KEND.NE.24 .AND. KEND.NE.35) THEN
          WRITE (9, FMT='('' Give Y or N'')')
          GOTO 111
        ENDIF
        IF (KEND.EQ.24) THEN
          WRITE (9, FMT='('' Give your own value'')')
 121      CALL KETERM (1,0,KEND)
          IF (KEND.LT.0 .OR. NFNUM.NE.1) GOTO 121
          DLIM = FNUM(1)
          ENDIF
        WRITE (24, FMT='('' The minimum distance between'',
     *  '' nonbonded atoms (which are not involved in a bond-angle)'',
     *  '' is '',F4.2,'' Angstrom)'')')  DLIM
        WRITE (24, FMT='(''     '')')
        NB=1
 131    CONTINUE
        DO 250 IFS=1,2
 241    IF (IFS.EQ.1) THEN
         WRITE(9,FMT='(//'' Give the first atom of rotation bond '',
     *      I2, '' (or Q if bond'',I2,'' was the last one)'')')NB,NB-1
        ELSE
          WRITE (9,FMT='('' Give the second atom of rotation bond '',
     *      I2, '' (or Q if bond'',I2,'' was the last one)'')')NB,NB-1
        ENDIF
        CALL KETERM (0,1,KEND)
        IF (KEND.LT.0)  GOTO 241
        ATN12=LIT(1)
        IF (ATN12.EQ.'Q') GOTO 600
        DO 245 I=1,NATOMS
        IF (ATNAME(I).NE.ATN12) GOTO 245
           NT(IFS,NB)=I
           GOTO 250
 245    CONTINUE
        WRITE (9, FMT='('' Atom '',A6,'' not present on atom file.'',
     *        '' Please try again'')')
        GOTO 241
 250    CONTINUE
        NA1=NT(1,NB)
        NA2=NT(2,NB)
        WRITE (9, FMT='('' Rotation-bond'',I2,'' : '',A6,''-'',A6)')
     *   NB, ATNAME(NA1),ATNAME(NA2)
        WRITE (9, FMT='('' Is it OK? (Y/N)'')')
 251    CALL KETERM (0,1,KEND)
        IF (KEND.NE.24 .AND. KEND.NE.35) THEN
          WRITE (9, FMT='('' Give Y or N'')')
          GOTO 251
        ENDIF
        IF (KEND.EQ.24) GOTO 131
        D12= SQRT( (XO(1,NA2)-XO(1,NA1))**2 + (XO(2,NA2)-XO(2,NA1))**2
     *                                      + (XO(3,NA2)-XO(3,NA1))**2 )
        IF (D12.GT.BONDMX) THEN
        WRITE (9, FMT='('' The distance between atom '',A6,
     *  '' and atom '',A6,'' is:'', F6.2)') ATNAME(NA1),ATNAME(NA2),D12
        WRITE (9, FMT='('' This is rather long. Is it OK? (Y/N)'')')
 301    CALL KETERM (0,1,KEND)
        IF (KEND.NE.24 .AND. KEND.NE.35) THEN
          WRITE (9, FMT='('' Give Y or N'')')
          GOTO 301
        ENDIF
        IF (KEND.EQ.24) GOTO 131
        ENDIF
        DO 410 N=1,NATOMS
 410    IAPRT(N,NB)=-1
        SRCHAP=.TRUE.
 411    CONTINUE
        DO 420 N=1,NATOMS
 420    NSETA(N)=N
        IF (SRCHAP) THEN
          N1=NT(1,NB)
          N2=NT(2,NB)
          IAPRT(N1,NB)=1
        ELSE
          N1=NT(2,NB)
          N2=NT(1,NB)
          IAPRT(N1,NB)=0
        ENDIF
        KS=1
        NSR(KS)=N1
        NSETA(N1)=0
 431    K1=0
        DO 450 K=1,KS
        N1=NSR(K)
        DO 440 M1=1,NATOMS
        M=NSETA(M1)
        IF (M.EQ.N2 .OR. M.EQ.0) GOTO 440
          D12= SQRT( (XO(1,M)-XO(1,N1))**2 + (XO(2,M)-XO(2,N1))**2
     *                                     + (XO(3,M)-XO(3,N1))**2 )
        IF (D12.LT.BONDMX) THEN
          NSETA(M1)=0
          IF (SRCHAP) THEN
          IAPRT(M1,NB)=1
          ELSE
          IF (IAPRT(M1,NB).EQ.1) THEN
          WRITE (9, FMT='('' Rotation bond within a ring system'')')
          WRITE (9, FMT='('' This rotation bond between atom '',A6,
     *  '' and atom '',A6,'' cannot be used by ORFLEX'')') ATNAME(N2),
     *     ATNAME(N1)
          GOTO 131
          ENDIF
          IAPRT(M1,NB)=0
          ENDIF
          K1=K1+1
          NSR1(K1)=M
        ENDIF
 440  CONTINUE
 450  CONTINUE
      IF (K1.GT.0) THEN
         CALL KERNAI (NSR1,NSR,K1)
         KS=K1
         GOTO 431
      ENDIF
      IF (SRCHAP) THEN
          SRCHAP=.FALSE.
          GOTO 411
      ELSE
  461   DMINAB=1000.
        NMIN=0
        DO 480 N=1,NATOMS
        IF (IAPRT(N,NB).EQ.-1) THEN
          DO 470 M=1,NATOMS
          IF (IAPRT(M,NB).EQ.-1) GOTO 470
          DAB= SQRT( (XO(1,M)-XO(1,N))**2 + (XO(2,M)-XO(2,N))**2
     *                                    + (XO(3,M)-XO(3,N))**2 )
          IF (DMINAB.LT.DAB) GOTO 470
            DMINAB=DAB
            IF (IAPRT(M,NB).EQ.1) NMIN=N
            IF (IAPRT(M,NB).EQ.0) NMIN=-N
 470      CONTINUE
        ENDIF
 480    CONTINUE
        IF (NMIN.NE.0) THEN
           IF (NMIN.LT.0) THEN
            NMIN=-NMIN
            IAPRT(NMIN,NB)=0
           ELSE
            IAPRT(NMIN,NB)=1
           ENDIF
           GOTO 461
         ENDIF
      ENDIF
        IF (FIRST) THEN
          WRITE (9, FMT='(1X/'' The size of the rotation steps can'',
     *    '' now be given in degrees'',/'' for each rotation-bond'')')
          WRITE (9, FMT='('' Or the rotation steps can be '',
     *    ''calculated by the program.'')')
          WRITE (9, FMT='('' Do you want calculation of stepsize?'',
     *    '' (Y/N)'')')
 511      CALL KETERM (0,1,KEND)
          IF (KEND.NE.24 .AND. KEND.NE.35) THEN
            WRITE (9, FMT='('' Give Y or N'')')
            GOTO 511
          ENDIF
          IF (KEND.EQ.35) CALROT=.TRUE.
          IF (KEND.EQ.24) CALROT=.FALSE.
        ENDIF
        IF (.NOT.CALROT) THEN
 512      WRITE (9, FMT='('' Give the stepsize (in degrees) for'',
     *   '' rotation around'')')
          WRITE (9, FMT='('' this bond'')')
          CALL KETERM (-1,-1,KEND)
          IF (KEND.LT.0) GOTO 512
          IF (NFNUM.GT.1 .OR. NFNUM.LT.0) GOTO 512
          DRODEG=FNUM(1)
          WRITE (24,FMT='('' The rotation stepsize around the'',
     *      '' bond between atoms '',A6,''and '',A6,''is'',F6.1,
     *      '' degrees'')') ATNAME(NA1), ATNAME(NA2),DRODEG
          DROT(NB)=DRODEG * DE2RA
          ISEQR(NB)=NB
        ELSE IF (FIRST) THEN
          FIRST=.FALSE.
          WRITE (9, FMT='(1X/'' The DEFAULT value for the maximal'',
     *    '' displacement in Angstrom'')')
          WRITE (9, FMT=
     *  '('' of an atom due to rotation around given bonds is'',F5.2,
     *      '' A'')') DISPMX
          WRITE (9,
     *    FMT='('' Do you want to use the DEFAULT value? (Y/N)'')')
 521      CALL KETERM (0,1,KEND)
          IF (KEND.NE.24 .AND. KEND.NE.35) THEN
            WRITE (9, FMT='('' Give Y or N'')')
            GOTO 521
          ENDIF
          IF (KEND.EQ.24) THEN
            WRITE (9, FMT='('' Give your own value'')')
 531        CALL KETERM (1,0,KEND)
            IF (KEND.LT.0 .OR. NFNUM.NE.1) GOTO 531
            DISPMX = FNUM(1)
          ENDIF
        WRITE (24,FMT='('' Rotation stepsizes are calculated such'',
     *  '' that the maximal displacement of an atom'')')
        WRITE (24,FMT='('' by one step is not more than'',
     *     F5.2,'' Angstrom'')')  DISPMX
        ENDIF
 541      WRITE (9,FMT='(1X/'' Give the total rotation in degrees'',
     *       ''(or 0 for 360.)'')')
        CALL KETERM (-1,-1,KEND)
        IF (KEND.LT.0) GOTO 541
        IF (NFNUM.GT.1 .OR. NFNUM.LT.0) GOTO 541
        IF (FNUM(1).LT.0.001) FNUM(1)=360.
        WRITE (24 ,FMT='('' The total rotation around the'',
     *      '' bond between atoms '',A6,''and '',A6,''is'',F6.1,
     *      '' degrees'')') ATNAME(NA1), ATNAME(NA2), FNUM(1)
        TRANGL(NB)=FNUM(1) * DE2RA
      NB=NB+1
      GOTO 131
 600  NB=NB-1
      IF (NB.EQ.0) CALL KEPROX
        NFRAGS=NB+1
      DO 710 N=1,NATOMS
 710    NSETA(N)=1
      N1=1
      DO 730 L1=1,NB
      DO 720 N=1,NATOMS
 720  IF (IAPRT(N,L1).EQ.1) NSETA(N)=NSETA(N)+N1
      N1=N1+1
 730  CONTINUE
      DO 740 N=1,NATOMS
      DO 740 M=1,4
 740  MPRT(M,N)=0
      DO 760 L1=1,NB
      N1=NT(1,L1)
      IF (NSETA(N1).EQ.0) THEN
        NT(1,L1)=NT(2,L1)
        NT(2,L1)=NT(1,L1)
        N1=NT(1,L1)
      ENDIF
      NK=NSETA(N1)
      DO 750 N=1,NATOMS
      IF (NSETA(N).EQ.NK) THEN
          MPRT(1,N)=L1
          NSETA(N)=0
      ENDIF
 750  CONTINUE
 760  CONTINUE
      DO 770 N=1,NATOMS
       IF (NSETA(N).NE.0) MPRT(1,N)=NB+1
 770  CONTINUE
      DO 790 N=1,NATOMS
      M=1
      DO 780 L=1,NB
      N1=NT(1,L)
      N2=NT(2,L)
      IF (N1.EQ.N) THEN
        M=M+1
        MPRT(M,N)=MPRT(1,N2)
      ELSE IF (N2.EQ.N) THEN
        M=M+1
        MPRT(M,N)=MPRT(1,N1)
      ENDIF
 780  CONTINUE
 790  CONTINUE
 1000 IF (NBFIXD.EQ.NFRAGS-1) RETURN
      IF (CALROT) THEN
          CALL ROTSTP
      ELSE
          NBFIXD=NBFIXD+1
      ENDIF
      RETURN
      END
      SUBROUTINE ROTSTP
      PARAMETER (MAXAT=100, MXTORB=10)
      COMMON /MOLEC/ NATOMS, XO(3,MAXAT), MPRT(4,MAXAT),NFRAGS,
     *               IAPRT(MAXAT,MXTORB), NT(2,MXTORB),
     *               DROT(MXTORB), TRANGL(MXTORB), ISEQR(MXTORB),
     *               TORSI(MXTORB), NBFIXD, DISPMX, DLIM, BONDMX
      DIMENSION  XZ(3,MAXAT), NPL(MAXAT)
      DATA LS /1/
      K=NBFIXD
       DO 103 I=1,NFRAGS-1
       DO 102 J=1,NBFIXD
       JJ=ISEQR(J)
       IF (JJ.EQ.I) GOTO 103
 102   CONTINUE
       K=K+1
       ISEQR(K)=I
 103   CONTINUE
      DL=10000.
      DO 140 NI=NBFIXD+1, NFRAGS-1
      CALL KERNZI (0,NPL,NATOMS)
      DO 110 NJ=NBFIXD+1,NFRAGS-1
      IF (NJ.EQ.NI) GOTO 110
      I=ISEQR(NJ)
      N=NT(1,I)
      NPL(N)=1
      N=NT(2,I)
      NPL(N)=1
 110  CONTINUE
      DLA=0.0
      DLB=0.0
      I=ISEQR(NI)
      DO 120 N=1,NATOMS
      IF (NPL(N).EQ.1) THEN
        IF (IAPRT(N,I).EQ.1) DLA=1000.
        IF (IAPRT(N,I).EQ.0) DLB=1000.
      ENDIF
 120  CONTINUE
      IF (DLA.GT.999. .AND. DLB.GT.999.) GOTO 140
      N1=NT(1,I)
      N2=NT(2,I)
      CALL ROTL2Z(N1,N2,XO,NATOMS,XZ)
      DO 130 N=1,NATOMS
      IF (IAPRT(N,I).EQ.1 .AND. DLA.LT.999.) THEN
        D2Z=XZ(1,N)**2 + XZ(2,N)**2
        IF (DLA.LT.D2Z) DLA=D2Z
      ELSE IF (IAPRT(N,I).EQ.0 .AND. DLB.LT.999.) THEN
        D2Z=XZ(1,N)**2 + XZ(2,N)**2
        IF (DLB.LT.D2Z) DLB=D2Z
      ENDIF
 130  CONTINUE
      DLAB=AMIN1(DLA,DLB)
      IF (DL.GT.DLAB) THEN
          DL=DLAB
          LS=NI
      ENDIF
 140  CONTINUE
      NBFIXD=NBFIXD+1
      ISEQLS=ISEQR(NBFIXD)
      ISEQR(NBFIXD)=ISEQR(LS)
      ISEQR(LS)=ISEQLS
      I=ISEQR(NBFIXD)
      DROT(I)=DISPMX/DL
      TRANGL(I)=TRANGL(I)-0.5*DROT(I)
      RETURN
      END
      SUBROUTINE ATORB(NB, MGEN)
      PARAMETER    (MAXAT=100, MXTORB=10, RA2DE=180./3.141593)
      COMMON /MOLEC/ NATOMS, XO(3,MAXAT), MPRT(4,MAXAT),NFRAGS,
     *               IAPRT(MAXAT,MXTORB), NT(2,MXTORB),
     *               DROT(MXTORB), TRANGL(MXTORB), ISEQR(MXTORB),
     *               TORSI(MXTORB), NBFIXD, DISPMX, DLIM, BONDMX
      COMMON /MOLECA/ ATNAME
      CHARACTER * 6 ATNAME(MAXAT)
      DIMENSION YO(3,MAXAT), XON1(3), RM(3,3)
      DATA NBL,IKLAD /0,3/
      IF (NBL.NE.NB) THEN
        CALL FILINQ (IKLAD, 'ATMODK', 'FORMATTED', 'OUTPUT', KINQ)
        NBL=NB
      ENDIF
      N1=NT(1,NB)
      XON1(1)=XO(1,N1)
      XON1(2)=XO(2,N1)
      XON1(3)=XO(3,N1)
      DO 120 N=1,NATOMS
      DO 110 I=1,3
      XO(I,N)=XO(I,N)-XON1(I)
 110  YO(I,N)=XO(I,N)
 120  CONTINUE
      N2=NT(2,NB)
      CALL LENG (XO(1,N2),R)
      CD1=XO(1,N2)/R
      CD2=XO(2,N2)/R
      CD3=XO(3,N2)/R
      ROT=-DROT(NB)
      MGEN = 0
 1111 ROT=ROT+DROT(NB)
      IF (ROT.GT.TRANGL(NB)) RETURN
      CALL ROTMTX (ROT, CD1, CD2, CD3, RM)
      DO 1300 N=1,NATOMS
      IF (IAPRT(N,NB).EQ.1) GOTO 1300
         DO 1210 I=1,3
 1210    YO(I,N)=RM(I,1)*XO(1,N) + RM(I,2)*XO(2,N) + RM(I,3)*XO(3,N)
 1300 CONTINUE
      N1=NT(1,NB)
      N2=NT(2,NB)
      NF1=MPRT(1,N1)
      NF2=MPRT(1,N2)
      DO 1500 N=1,NATOMS
      DO 1350 J=1,4
 1350 IF (MPRT(J,N).EQ.NF2) GOTO 1500
      DO 1450 I=1,4
      IF (MPRT(I,N).NE.NF1) GOTO 1450
         DO 1400 M=1,NATOMS
         DO 1370 J=1,4
 1370    IF (MPRT(J,M).EQ.NF1) GOTO 1400
         DO 1380 I1=1,4
         IF (MPRT(I1,M).NE.NF2) GOTO 1380
             D12= SQRT( (YO(1,N)-YO(1,M))**2 + (YO(2,N)-YO(2,M))**2
     *                                       + (YO(3,N)-YO(3,M))**2 )
             IF (D12.LT.DLIM) GOTO 1111
             GOTO 1400
 1380    CONTINUE
 1400    CONTINUE
         GOTO 1500
 1450 CONTINUE
 1500 CONTINUE
      MGEN=MGEN+1
      TORSI(NB)=ROT*RA2DE
      CALL WRIMOD (IKLAD, YO, NATOMS, NBFIXD,ISEQR,TORSI)
      GOTO 1111
      END
      SUBROUTINE COPYGA (IIN,  IOUT)
      CHARACTER CHIN *80
      REWIND IIN
  111 READ (IIN, 202, END=210, ERR=270) CHIN
  202 FORMAT (A80)
      WRITE (IOUT, 202) CHIN
      GOTO 111
  210 IF (CHIN(1:6) .NE. 'FINISH') WRITE (IOUT, FMT='(''FINISH'')')
  270 REWIND IIN
      REWIND IOUT
      RETURN
      END
      SUBROUTINE REMMOD(K2)
      PARAMETER                  (MAXAT=100, MXTORB=10)
      COMMON /MOLEC/ NATOMS, XO(3,MAXAT), MPRT(4,MAXAT),NFRAGS,
     *               IAPRT(MAXAT,MXTORB), NT(2,MXTORB),
     *               DROT(MXTORB), TRANGL(MXTORB), ISEQR(MXTORB),
     *               TORSI(MXTORB), NBFIXD, DISPMX, DLIM, BONDMX
      DATA IKLAD  /3/
      CALL FILINQ (IKLAD, 'ATMODK', 'FORMATTED', 'OUTPUT', KINQ)
      DO 110 K=1,K2
      CALL PREMOD (2)
      CALL DISTCH
 110  CONTINUE
      CALL FILCLO (2, 'DELETE')
      CALL FILINQ (2, 'ATFLEX', 'FORMATTED', 'OUTPUT', KINQ)
      CALL COPYGA(3, 2)
      CLOSE (3,STATUS='DELETE')
      RETURN
      END
      SUBROUTINE DISTCH
      INCLUDE 'Zsyst.inc'
      PARAMETER                  (MAXAT=100, MXTORB=10)
      COMMON /MOLEC/ NATOMS, XO(3,MAXAT), MPRT(4,MAXAT),NFRAGS,
     *               IAPRT(MAXAT,MXTORB), NT(2,MXTORB),
     *               DROT(MXTORB), TRANGL(MXTORB), ISEQR(MXTORB),
     *               TORSI(MXTORB), NBFIXD, DISPMX, DLIM, BONDMX
      COMMON /MOLECA/ ATNAME
      CHARACTER * 6 ATNAME(MAXAT)
      DATA IKLAD  /3/
      DATA NMODEL /0/
      DO 150 N=1,NATOMS
      DO 140 M=N+1,NATOMS
      DO 130 I=1,4
      NF=MPRT(I,N)
      IF (NF.EQ.0) GOTO 135
      DO 120 J=1,4
      MF=MPRT(J,M)
 120  IF (MF.EQ.NF) GOTO 140
 130  CONTINUE
 135  D12= SQRT( (XO(1,N)-XO(1,M))**2 + (XO(2,N)-XO(2,M))**2
     *                                + (XO(3,N)-XO(3,M))**2 )
      IF (D12.LT.DLIM) RETURN
 140  CONTINUE
 150  CONTINUE
      NBF=0
      CALL WRIMOD (IKLAD, XO, NATOMS, NBF,ISEQR,TORSI)
      NMODEL=NMODEL+1
      IF (NMODEL.EQ.1) THEN
      WRITE (24,FMT='(''  '')')
      DO 210 I=1,NBFIXD
      N1=NT(1,I)
      N2=NT(2,I)
 210  WRITE (24,FMT='(''  Bond'',I2,'' is bond connecting atoms  '',
     *       A6,''and '',A6)')  I,ATNAME(N1),ATNAME(N2)
      WRITE (24,FMT='(''  Rotation in degrees around bonds'' /
     *  ''       Model   bond 1    bond 2    bond 3'' / )')
         ENDIF
      WRITE (24,FMT='('' '',I10,10F10.1)') NMODEL,(TORSI(I),I=1,NBFIXD)
      RETURN
      END
      SUBROUTINE SETMAT (X, Y, V, T)
      DIMENSION X(3), Y(3), V(3), T(3,3)
      COSA = X(1)*Y(1) + X(2)*Y(2)  + X(3)*Y(3)
      CALL LENG (X, R)
      IF (R .LT. 0.0001) GOTO 210
      COSA = COSA / R
      CALL LENG (Y ,R)
      IF (R .LT. 0.0001) GOTO 210
      CO = COSA / R
      SI = SQRT (1. - CO**2)
      CALL LENG (V, R)
      IF (R .LT. 0.0001) GOTO 210
      DO 200 I = 1,3
  200 V(I) = V(I) / R
      T(1,1) =       V(1)**2      +    CO  * (1 -V(1)*V(1))
      T(1,2) = -SI * V(3)         + (1-CO) *     V(1)*V(2)
      T(1,3) =  SI * V(2)         + (1-CO) *     V(3)*V(1)
      T(2,1) =  SI * V(3)         + (1-CO) *     V(1)*V(2)
      T(2,2) =       V(2)**2      +    CO  * (1 -V(2)*V(2))
      T(2,3) = -SI * V(1)         + (1-CO) *     V(3)*V(2)
      T(3,1) = -SI * V(2)         + (1-CO) *     V(3)*V(1)
      T(3,2) =  SI * V(1)         + (1-CO) *     V(3)*V(2)
      T(3,3) =       V(3)**2      +    CO *  (1 -V(3)*V(3))
      RETURN
  210 CALL KERROR( ' No rotation angle ', 0, 'SETMAX')
      RETURN
      END
      SUBROUTINE ROTL2Z(NL1,NL2,XO,NATOMS,XZ)
      DIMENSION XO(3,NATOMS),XZ(3,NATOMS)
      DIMENSION ZAXIS(3),V(3),RM(3,3),YO(3)
      DATA ZAXIS /0.,0.,1.0/
      DO 110 N=1,NATOMS
      DO 110 I=1,3
 110  XZ(I,N)=XO(I,N)-XO(I,NL1)
      CALL VECAXB (XZ(1,NL2), ZAXIS, V)
      CALL SETMAT(XZ(1,NL2),ZAXIS,V,RM)
      DO 130 N=1,NATOMS
      DO 120 I=1,3
 120  YO(I)=RM(I,1)*XZ(1,N) + RM(I,2)*XZ(2,N) + RM(I,3)*XZ(3,N)
      CALL KERNAB (YO,XZ(1,N),3)
 130  CONTINUE
      RETURN
      END
      SUBROUTINE LENG (X, R)
      DIMENSION X(3)
      R = SQRT (X(1)**2 + X(2)**2 + X(3)**2)
      RETURN
      END
C dirdif3.FOR       contents: progr. DDMAIN, FOUR, PHASEX, NUTS (+subpr)
C
C=======================================================================
C=======================================================================
CPROGRAM DDMAIN dd3.C$200.                                 updt Jan 2008
C$200.
C=======================================================================
C=======================================================================
      SUBROUTINE DDMAIN
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zddif.inc'
      EQUIVALENCE (ICRYS,  IFILE(3)),  (IE100,  IFILE(10))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15))
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (KEYD, KSTAT(19))
      DATA NCALL /0/
      IF (NCALL .EQ. 0) THEN
         NCALL = 1
         BPINP = 2.0
         ENDIF
      CALL KEPROG ('DDMAIN')
      IF (IORIE .EQ. -999) THEN
         IORIE = 0
         CALL ATPATS (0)
         ENDIF
      CALL DDMINI
      IF (IDOKA .EQ. 17) RETURN
      IF (KEYD .EQ. 9) STOP 201
      CALL DICALC
      IF (IDOKA .EQ. 17) RETURN
      IF (KEYD .EQ. 2 .OR. KEYD .EQ. 3) THEN
         CALL FILINQ (IBINDU, 'BINDUA', 'UNFORMATTED', 'INPUT', KINQU)
         IF (KINQU .NE. -1) CALL FILCLO (IBINDU, 'DELETE')
         CALL FILINQ (IBINDI, 'BINDIF', 'UNFORMATTED', 'INPUT', KINQI)
         IF (KINQI .NE. -1) CALL FILCLO (IBINDI, 'DELETE')
         CALL FILINQ (IE100,  'E100',   'FORMATTED',   'INPUT', KINIE)
         IF (KINIE .NE. -1) CALL FILCLO (IE100,  'DELETE')
         ENDIF
      CALL KEPROX
      RETURN
      END
      SUBROUTINE AT123P (INOUT, FINAM, LISX, ATN, ATX, N)
      CHARACTER INOUT*6, FINAM*6, ATN(N)*6
      DIMENSION ATX(10,N)
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IRUN, KSTAT(13))
      CHARACTER INO*6, FROMTO*11
      LIS = LISX
      IF (LIS .EQ. 24) GOTO 100
      IF (LIS .LT. 6 .OR. LIS .GT. 9) STOP 201
      IF (LIS .EQ. 6) LIS=9
      IF (LIS .EQ. 7) LIS=24
      IF (LIS .EQ. 8) CALL WR24
  100 CONTINUE
      INO = INOUT
      IF (INOUT(1:1) .EQ. ' ') INO = INOUT(2:6)
      FROMTO = '  to  file '
      IF (INOUT .EQ. ' INPUT') FROMTO = ' from file '
      WRITE (LIS, 121) INO, FROMTO, FINAM, N
  121 FORMAT (/ 1X, A6,' atoms ', A11, A6, 24X,' ( list max =',I2,' )')
      DO 111 I=1,N
      WRITE (LIS, 103) IRUN, NRECYR, ATN(I), (ATX(K,I), K=1,5)
  103 FORMAT (8X, 'RUN', I4,' cycle',I3,'  atom ',A6, 3F7.4, 2F7.3)
  111 CONTINUE
      WRITE (LIS, FMT='(1X)')
      IF (LIS .NE. 8) CALL WR24
      RETURN
      END
      SUBROUTINE NNRECY (KEY)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zsear.inc'
      LOGICAL NOFREE, SWRECY, NORECY
      EQUIVALENCE (SWITCH(7), SWRECY), (SWITCH(8), NORECY)
      EQUIVALENCE (SWITCH(9), NOFREE)
      DIMENSION R2MUL(50,MRECY), MUL2NA(MRECY),
     *   PSMUL2(MRECY), R2EMU2(MRECY), R1MUL2(MRECY)
      DATA NCALL, LAST, NRSTAR / 0, 0, 4 /
      NCALL = NCALL + 1
      IF (NCALL .EQ. 1) THEN
         NCALL1 = 0
         NCALL2 = 0
         WRITE (8,FMT='('' $TE!NNRECY :MPAT IPAT MORIE IORIE !!!!'',
     *      4I3)') MPAT, IPAT, MORIE, IORIE
         IF (MPAT .GT. 0) WRITE (8,*) '$TE!NNRECY : PATTY called'
         IF (MORIE .GT. 0) WRITE (8,*) '$TE!NNRECY : ORIENT called'
         NRECYX = 0
         IF (MPAT .GT. 0) NRECYX = 1
         IF (MORIE .GT. 0) NRECYX = 2
         WRITE (8,FMT='('' $TE!NNRECY A: NRECYX ='', I1)') NRECYX
         ENDIF
      NOFREE = .TRUE.
      NS = NRECYS
      NT = NRECYT
      CALL WR24
      IF (KEY .NE. -1) GOTO 40
      IF (NCALL1 .EQ. 1) GOTO 19
      NCALL1 = 1
      WRITE (8,FMT='('' $TE!NNRECY :NAT '',   I6)')    NAT
      WRITE (8,FMT='('' $TE!NNRECY :PSQ '',   F6.3)')  PSQ
      WRITE (8,FMT='('' $TE!NNRECY :NATSYM'', I4)')    NATSYM
      WRITE (8,FMT='('' $TE!NNRECY :NRECYX'', I6)')    NRECYX
      IZMAX = 1
      DO 16 I = 1, NAT
   16 IZMAX = MAX0 (IZMAX, IZAT(I))
      NRECYX = 2
      IF (NAT .LT. 10 .AND. IZMAX.GT.10 ) NRECYX = 1
      IF (NAT .GT. 0.7*NATSYM .OR. PSQ.GT.0.9 ) NRECYX = 3
      WRITE (8,FMT='('' $TE!NNRECY B: NRECYX ='', I1)') NRECYX
   19 CONTINUE
      IF (NCALL2 .EQ. 1) RETURN
      IF (MPAT .EQ. -99 ) THEN
         NCALL2 = 1
         NRECYX = 3
         IF (NAT .LT. 0.5*NATSYM) NRECYX = 2
         WRITE (8,FMT='('' $TE!NNRECY C: NRECYX ='', I1)') NRECYX
         ENDIF
      IF (NRECYS .EQ. 1) THEN
         IF (NRECYX .EQ. 2) NRECYS = 3
         IF (NRECYX .EQ. 3) NRECYS = 5
         ENDIF
      RETURN
   40 CONTINUE
      IF (KEY .EQ. 1) GOTO 100
      IF (KEY .EQ. 5) GOTO 500
      IF (KEY .EQ.90) GOTO 900
      IF (KEY .EQ.99) GOTO 990
      IF (NRECYR .NE. 0) GOTO 50
      NRECY = 1
      NRECYR = 1
      NRECYS = 1
      NRECYT = 1
         WRITE (8, FMT='(/'' $TE NNRECY    start'', 30X,
     *       ''    R2X'')')
         WRITE (8, 98) KEY, NRECYR, NS, NT, NRECYS, NRECYT
         WRITE (8, FMT='(/'' $TE-NNRECY(0) cy-R -S -T  '',
     *       '' NATS NATL -REC  NAT   PSQ   R2X'')')
      IF (IPAT .GT. 0) THEN
         LAST = IPAT
      ELSE
         LAST = LAST + 1
         ENDIF
      CALL KERNZI (0,  MUL2NA, 21)
      CALL KERNZA (0., PSMUL2, 21)
      CALL KERNZA (0., R2EMU2, 21)
      CALL KERNZA (0., R1MUL2, 21)
      RETURN
   50 CONTINUE
      NRECYR = NRECYR + 1
      NRECYT = NRECYT + 1
      IF (NS .EQ. 1) THEN
         NRECYS = 2
         NRECYT = 1
      ELSEIF (NS .EQ. 2) THEN
         F = FLOAT(NATREC) / FLOAT(NAT)
         IF (NRECYT .EQ. 1 ) GOTO 99
         IF (NRECYT .EQ. 2 .AND. NATL .LE. 9) GOTO 99
         IF (NRECYT .LE. 3 .AND. F .LE. .70) GOTO 99
         IF (NRECYT .LE. 3 .AND. NATS .LE. 5) GOTO 99
         NRECYS = 4
         NRECYT = 1
      ELSEIF (NRECYT .GE. 3) THEN
         NRECYS = NRECYS + 1
         NRECYT = 1
         ENDIF
   98 FORMAT (// ' $TE NNRECY(',I2,')  cy-R', I3, '  -S -T =',
     *           I3,I2,' ===>', I3,I2, 3X, F7.3/)
   99 WRITE (8, 98) KEY, NRECYR, NS, NT, NRECYS, NRECYT,  R2X
      RETURN
  100 CONTINUE
      IF (LAST .LE. 0 .OR. NRECYR .LE. 0) RETURN
      R2MUL(LAST, NRECYR) = R2X
      MUL2NA(NRECYR) = NAT
      PSMUL2(NRECYR) = PSQ
      R2EMU2(NRECYR) = R2EX
      R1MUL2(NRECYR) = R1X
      R2LAST = R2X
      NRLAST = NRECYR
      IF (IPAT .EQ. 1) THEN
         IF (NRECYR .EQ. 3 .AND. PSQ .GT. 0.90) NRSTAR = 3
         IF (NRECYR .EQ. 4 .AND.
     *       NRSTAR .LE. 2 .AND. PSQ .GT. 0.80) NRSTAR = 4
         IF (NRECYR .EQ. 5 .AND. NRSTAR .LE. 2) NRSTAR = 5
         R2BEST = R2X
         IF (NRECYR .GT. NRSTAR+2) THEN
            R2BEST = (3.* R2MUL(IBEST, NRECYR-2) +
     *                4.* R2MUL(IBEST, NRECYR-1) +
     *                5.* R2MUL(IBEST, NRECYR)   ) /12.
            ENDIF
         NRBEST = NRECYR
         IBEST = 1
      ELSEIF (IPAT .GT. 1  .AND. NRECYR .GE. NRSTAR) THEN
         IF (NRECYR .GT. NRBEST .AND. NRECYR .LT. MRECY) THEN
            R2MUL(IBEST, NRECYR) = R2MUL(IBEST, NRBEST)
            ENDIF
         IF (NRECYR .EQ. NRSTAR) THEN
            IF (R2X-0.05 .GT. 1.3 * R2MUL(IBEST, NRECYR)) THEN
               R2BES1 = R2MUL(IBEST, NRECYR)
               R2LAST = R2MUL(LAST,  NRECYR)
               GOTO 150
               ENDIF
         ELSEIF (NRECYR .EQ. NRSTAR+1) THEN
            R2BES1 = (3.* R2MUL(IBEST, NRSTAR) +
     *                4.* R2MUL(IBEST, NRECYR) ) / 7.
            R2LAST = (3.* R2MUL(LAST,  NRSTAR) +
     *                4.* R2MUL(LAST,  NRECYR) ) / 7.
            IF (R2LAST-0.02 .GT. 1.2 * R2BES1) GOTO 150
         ELSEIF (NRECYR .EQ. NRSTAR+2) THEN
            R2BES1 = (3.* R2MUL(IBEST, NRSTAR)  +
     *                4.* R2MUL(IBEST, NRSTAR +1) +
     *                5.* R2MUL(IBEST, NRECYR)  ) / 12.
            R2LAST = (3.* R2MUL(LAST,  NRSTAR)  +
     *                4.* R2MUL(LAST,  NRSTAR +1) +
     *                5.* R2MUL(LAST,  NRECYR)  ) / 12.
            IF (R2LAST .GT. 1.1 * R2BES1) GOTO 150
         ELSEIF (NRECYR .GT. NRSTAR+2) THEN
            R2BES1 = (3.* R2MUL(IBEST, NRECYR-2) +
     *                4.* R2MUL(IBEST, NRECYR-1) +
     *                5.* R2MUL(IBEST, NRECYR)   ) / 12.
            R2LAST = (3.* R2MUL(LAST,  NRECYR-2) +
     *                4.* R2MUL(LAST,  NRECYR-1) +
     *                5.* R2MUL(LAST,  NRECYR)   ) / 12.
            IF (R2LAST .GT. 1.0 * R2BES1) GOTO 150
         ENDIF
      ENDIF
      IF (NRECYS.LE.3 .OR. (NRECYS.EQ.4 .AND. NRECYT.LE.2)) GOTO 147
      IF (NRECYS .LE. 5) THEN
         IF ((NRECYT .LE. 2 .AND. NATL .LE. 10) .OR.
     *       (NRECYT .LE. 4 .AND. R2X .GT. .40)) GOTO 147
         ENDIF
      NRECYT = 0
      IF (NS .LE. 5) THEN
         NRECYS = NRECYS + 1
      ELSEIF (NS .LE. 7) THEN
         NRECYS = 8
         NOFREE = .TRUE.
      ELSEIF (NS .LE. 9) THEN
         NRECYS = 10
      ELSEIF (NS .LE. 11) THEN
         NRECYS = 12
      ELSEIF (NRECYS .LE. 20) THEN
         NRECYS = NS + 2
      ELSE
         NRECYS = 99
         ENDIF
      WRITE (8, 98) KEY, NRECYR, NS, NT, NRECYS, NRECYT,  R2X
  147 CONTINUE
      WRITE (8,FMT='('' $TE-NNRECY('',I2,'') '', 3I3, 2X, 4I5, 2F6.3)')
     *   KEY, NRECYR, NRECYS, NRECYT, NATS, NATL, NATREC, NAT, PSQ, R2X
      RETURN
  150 CONTINUE
      WRITE (9, FMT='('' Stop : R2av='', F5.3,
     *  ''   (best set so far is AtSET='',I2,'', R2av='', F5.3,
     *  '' )'')')
     *      R2LAST, IBEST, R2BES1
      R2LAST = 99.9
      GOTO 900
  500 CONTINUE
      NATNOH = KSTAT(4)
      IF (NRECYS .LT. 4 .AND.
     *      (R2X .LT. 0.25 .OR. NATREC .GE. NATNOH - NATNOH/10)) THEN
         NRECYS = 4
         NRECYT = 0
         GOTO 99
         ENDIF
      RETURN
  900 CONTINUE
      SWRECY = .FALSE.
      NORECY = .TRUE.
      GOTO 1000
  990 CONTINUE
      IF (NRECYR .GE. 17 .OR. NRECYS .GE. 13) THEN
         NRECYS = 99
         NRECYT = 1
         SWRECY = .FALSE.
         NORECY = .TRUE.
         GOTO 1000
         ENDIF
      RETURN
 1000 CONTINUE
      IF (IPAT .EQ. 1) WRITE (9, FMT='(/'' First set: AtSET= 1'',
     *         ''  R2av='', F5.3, ''  (Nr cy:'', I2, '')''/)')
     *   R2BEST, NRBEST
      IF (IPAT .GT. 1) THEN
         IF (R2LAST .LT. R2BEST) THEN
            WRITE (9, FMT='(/'' BEST now: AtSET='', I2, '' R2av='',F5.3,
     *          ''   (was: AtSET='', I2, '' R2av='',F5.3, '')''/ )')
     *         IPAT, R2LAST, IBEST, R2BEST
            R2BEST = R2LAST
            IBEST = IPAT
            NRBEST = NRLAST
            ENDIF
          ENDIF
      CALL WR24
      I1 = NRECYR - 9
      IF (I1 .LT. 1) I1 = 1
      L=8
      DO 1100 LL=1,2
      WRITE (L, FMT='(1X/'' NNRECY summary   IRUN='', I3,
     *                   '' IPAT='',I3/)') KSTAT(13), IPAT
      WRITE (L, FMT='( '' Ncy '', 10I6   )') (I, I = I1, NRECYR)
      WRITE (L, FMT='( '' NAT '', 10I6   )') (MUL2NA(I), I = I1, NRECYR)
      WRITE (L, FMT='( '' PSQ '', 10F6.3 )') (PSMUL2(I), I = I1, NRECYR)
      WRITE (L, FMT='( '' R1X '', 10F6.3 )') (R1MUL2(I), I = I1, NRECYR)
      WRITE (L, FMT='( '' R2E '', 10F6.3 )') (R2EMU2(I), I = I1, NRECYR)
      WRITE (L, FMT='( '' R2X '', 10F6.3/)') (R2MUL(LAST,I),
     *                                                   I = I1, NRECYR)
      L=25
 1100 CONTINUE
      RETURN
      END
      SUBROUTINE DDMINI
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      INCLUDE 'Zsear.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (IDDS, IFILE(1)), (ICRYS,IFILE(3))
      EQUIVALENCE (ICON, IFILE(4))
      EQUIVALENCE (IBINFC, IFILE(12))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (KEYWIL, KSTAT(17))
      LOGICAL      SWPRI, EXPAND, SWRECY, NORECY
      EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (SWRECY, SWITCH(7)), (NORECY, SWITCH(8))
      EQUIVALENCE (IMAP, KSTAT(7))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (KEYD, KSTAT(19))
      EQUIVALENCE (KEYDS, KSTAT(20))
      EQUIVALENCE (KEXPA, KSTAT(21))
      DIMENSION BUFFOX(10), BUFFOY(10)
      DIMENSION SCRAT(10)
      CHARACTER*6 LITA(1)
      PARAMETER (LCMAX = 10)
      CHARACTER*6 LCONDA(LCMAX)
      DATA LCONDA / 'DDMAIN', 'OPTION', 'DIRP1',  'PRINT',  'EXPAND',
     *              '$PTB$' , '$PTB$'   , '$PTB$', '$PTB$', '$PTB$' /
      DATA IATOMS, IAT10 /2, 10/
      DATA NCALL, NCALLM /0, 0/
      CALL WR24
      NITFC = 2
      NITDUA = 7
      NITDIF = 4
      NITFFT = 5
      NITDOP = 9
      NITB = 5
      IF (NCALL .EQ. 0) THEN
         NCALL = 1
         NATL = 0
         WRITE (8, FMT='('' $TE SCALE sub  Ncy   PSQ    R2   SCALE'',
     *     ''  Bp    Br   KEYWIL'')' )
         ENDIF
      IF (NCALLM .EQ. 0) R2X = 999.
      KEYWIL = 0
      CALL WILSIN (999)
      CALL RDCRYS (ICRYS)
      NITFC2 = 3 + 2 * NSYMM
      IF (MPAT .LT. 0) GOTO 120
      IF (NCALLM .EQ. 0) THEN
         DO 110 I=1,NTYPE
  110    SCRAT(I) = CELALL(I) / ZET
         I = NTYPE
         J = NINT(ZET)
         WRITE (24, 114) J, (CELATY(K), SCRAT(K), K=1,I)
  114 FORMAT (' Z:', I3/' FORMUL:', 6(2X,A2,F6.1)/ ( 8X,6(2X,A2,F6.1)))
         ENDIF
      IF (NCALLM .NE. 0) BOV = BOVMER
      KEYD = -1
      KEYBB = 0
  120 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)
      GOTO (120, 2, 3, 120, 3, 6, 7, 8, 9, 10), KEND
      IF (KEND.EQ.0) GOTO 140
  122 CALL KERROR ('No option given or wrong data', 120, 'DDMINI')
  2   IF (NFNUM.LE.0) CALL KERROR
     *   ('No OPTION number given in CONDA file', 2, 'DDMINI')
      KEYD = NINT(FNUM(1))
      KEYDS = NINT(FNUM(2))
      CHOUT = ' '
      IF (KEYD.EQ.5) CALL KERROR ('KEYD=5 ???', 122, 'DDMINI')
      IF (KEYD.EQ.7)
     *   WRITE (9, FMT='('' Get R2 values for multi PATTY results'')')
      IF (KEYD.EQ.2) THEN
         WRITE (24, 1122)
 1122 FORMAT(1X/' ****** Prepare for FOUR using',
     *   ' dir.method phases *****'/1X)
         ENDIF
      IF (KEYD.EQ.0) WRITE (24, FMT='(1X/'' ============ Program'',
     *       '' DDMAIN: structure factor calculation''/1X)')
      IF (KEYD.GT.7 .OR. KEYD.LT.0 .OR. KEYD.EQ.6)
     *   CALL KERROR ('Wrong option given', 2, 'DDMINI')
      IF (KEYD .EQ. 7) WRITE (24,
     *   FMT='('' DDMAIN input option KEYD ='', I2)') KEYD
      GOTO 120
  3   EXPAND = .TRUE.
      NORECY = .TRUE.
      WRITE (8, 123)
  123 FORMAT (' EXPAND data to P1 symmetry (or centered equivalent)')
      GOTO 120
  6   CONTINUE
  7   CONTINUE
  8   CONTINUE
  9   CONTINUE
  10  GOTO 120
  140 CONTINUE
      IF (KEYD .LT. 0) GOTO 122
      CALL FILCLO (ICON, 'KEEP')
      IF (((KEYD.EQ.1 .OR. KEYD.EQ.3 ) .AND. .NOT. NORECY ) .OR.
     *     (KEYD.EQ.0 .AND. NRECYR.GT.2)) THEN
         CALL NNRECY (0)
         KSTAT(6) = 0
         IF (NRECYS .GE. 2) KEYWIL = -2
         IF (KEYD.EQ.1) WRITE (24, FMT=
     *      '(44X, '' prepare for PHASEX cycle'', I3)') NRECYR
         IF (KEYD.EQ.3) WRITE (24, FMT=
     *      '(43X, '' prepare for Fourier cycle'', I3)') NRECYR
         IF (KEYD.EQ.0 .AND. NRECYR .GT. 2) WRITE (9, FMT=
     *      '('' cycle'', I3, ''   = final SF '')') NRECYR
         ENDIF
      IF (NRECYR .EQ. 1 .AND. ( KEYD.EQ.1 .OR. KEYD.EQ.3 )) THEN
         IF ( KEYD.EQ.1 )  WRITE (9, 1111)
 1111    FORMAT (1X/' PHASEX+FOUR recycling procedure:')
         IF( KEYD.EQ.3 )  WRITE (9, 1112)
 1112    FORMAT (1X/' FOUR recycling procedure:')
         IF (MPAT .LT. 0) THEN
            SCALE = SCAMER
            BOV = BOVMER
            BP = BOV
            BR = BOV
            ENDIF
         ENDIF
         NORECY = .FALSE.
         SWRECY = .TRUE.
      CALL WR24
      IF (KSTAT(6) .EQ. 17) THEN
         WRITE (8, 142)
  142    FORMAT (' stop multi PATTY    [ switch KSTAT(6)=17 ]')
         WRITE (8, 259) IPAT, NRECYR, NRECYS, R2X
         SWRECY = .FALSE.
         NORECY = .TRUE.
         ENDIF
      IF ((KEYD.EQ.1 .OR. KEYD.EQ.3) .AND. SWRECY) THEN
         WRITE(24, 1114) NRECYR
 1114    FORMAT ( ' cycle', I3 / ' -----'/ )
         ENDIF
      CALL WR24
      IF (NRECYR .GT. 1) GOTO 6142
      IF (NCALLM .GT. 0) GOTO 6142
      CALL MERBIN
      IF (KEYWIL .NE. 4 .AND. NINT(10000.*BP) .NE. 20000) KEYWIL = 1
      IF (KEYWIL .NE. 4 .AND. NINT(10000.*BR) .NE. 20000)
     *                                           KEYWIL = KEYWIL + 2
      WRITE (8, FMT='('' SCALE, BOV, BP, BR, KEYWIL ='', 4F8.4, I2)')
     *                   SCALE, BOV, BP, BR, KEYWIL
      CALL WILSIN (999)
      NCALLM = NCALLM + 1
      IF (EXPAND) KEYWIL = 4
 6142 CONTINUE
      WRITE (8, 1142) KEYD, IRUN, NRECYR, SCALE, BP, BR
 1142 FORMAT (// ' KEYD',I2,' RUN',I4, ' cy', I3,
     *   ' [  SCALE, Bp, Br, :', F8.4, 2F7.3,' ] '//)
      IF (KEYD .NE. 4) GOTO 143
      NAT  = 1
      KEYT = 1
      CALL KERNZA (0., ATXYZ, 10)
      IZAT(1) = 1
      ATNAME(1) = 'H'
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
      IMAP = 2
      IF (KEYDS .EQ. 1) IMAP = 6
      GOTO 935
  143 CONTINUE
      IF (NRECYR .EQ. 1 .AND. ( KEYD.EQ.1 .OR. KEYD.EQ.3 ))
     *   WRITE (9, FMT='(12X,
     *      ''nr of     deleted   expected R2-----       actual R2'')')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found',
     *   143, 'DDMINI')
      CALL KERINA (IATOMS, LIT, 1, LEND)
      IF (LIT(1) .NE. 'ATOMS') CALL KERROR
     *   (' Incorrect header on ATOMS file', 143, 'DDMINI')
      REWIND IATOMS
      NSET = 0
      CHIN(1:10) = ' $TE!NREC-'
      WRITE (8,*) CHIN
      LITA(1) = 'SC='
      CALL KERINB (LITA, 1)
      ATSCAL = -1.
      IF (LIT(NLIT) .EQ. LITA(1)) ATSCAL=FNUM(NFNUM)
      CALL ATIN7 (NSET)
      IF (KEYD .NE. 7) THEN
         NN = MIN0 (5, NAT)
         CALL AT123P (' INPUT', ' ATOMS', 24, ATNAME, ATXYZ, NN)
         ENDIF
         CALL WR24
      NATINP = NAT
      IF (NATS .EQ. 0) NATS = NAT
      IF (KEYT .EQ. 3 .AND. EXPAND) THEN
         WRITE (9,*) ' EXPAND with anisotropic temp.f. is nonsense'
         KEYT = 2
         ENDIF
      IF ((KEYT .EQ. 2 .AND. EXPAND) .OR.
     *    (KEYT .GE. 2 .AND. KEYBB .EQ. 1)) THEN
         WRITE (24, FMT='('' Ignore individual temp. factors'')')
         KEYT = 1
         DO 145 I = 1, NAT
         ATXYZ(5,I) = 0.0
  145    ATXYZ(6,I) = 0.0
         ENDIF
      IF (KEYT .GE. 2) KEYWIL = -2
      CALL WR24
      IF (KEYD.EQ.2) THEN
         CALL FILINQ (IBINDU, 'BINDUA', 'UNFORMATTED', 'INPUT', KINQU)
         CALL FILINQ (IBINDI, 'BINDIF', 'UNFORMATTED', 'INPUT', KINQI)
         IF (KINQU.EQ.-1 .OR. KINQI.EQ.-1) CALL KERROR
     *      (' No BINDUA or BINDIF file found', 0, 'DDMAIN')
         CALL BINIFF (1, IBINDU,'BINDUA',FITDUA,NITDUA,BUFDUA,KENDUA)
         CALL BINIFF (1, IBINDI,'BINDIF',FITDIF,NITDIF,BUFDIF,KENDIF)
         GOTO 255
         ENDIF
      CALL WR24
      IF (NORECY) CALL ATOMPR (7, 7, ATXYZ, ATNAME, IZAT, NAT)
      CALL ATOMPR (8, 7, ATXYZ, ATNAME, IZAT, NAT)
      IF (KEYT.EQ.2) WRITE (8, 156)
  156 FORMAT (' Individual isotropic temp.factors on input atoms file')
      IF (KEYT.EQ.3) WRITE (8, 157)
  157 FORMAT (' Mixed isotropic / anisotropic temp.factors used')
      IF (KEYT .EQ. 1) WRITE (8, 173) BOV
  173 FORMAT (' temp KEYT=1, Overall temp.f.: Bov =', F8.3/)
      IF (KEYT.EQ.3 .AND. KEYD.GE.5) CALL KERROR
     *   ('Anisotr.t.f. not allowed for AUTOR2 TEST', 180, 'DDMINI')
      IF (KSTAT(1) .NE. 12357) GOTO 7167
      CALL KERNZA (0.0, CELPAR, NTYPE)
      DO 7161 I=1,NAT
      DO 7160 J=1,NTYPE
      IF (IZAT(I).NE.IZTYPE(J)) GOTO 7160
      CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AMULT
 7160 CONTINUE
 7161 CONTINUE
      IIII = 0
      DO 7162 J=1,NTYPE
      BUFFOY(J) = CELALL(J)
      IF ( CELPAR(J) .LE. CELALL(J)) GOTO 7162
      IF (( NRECYS .GE. 11 .AND. IZTYPE(J) .GE. 20 ) .OR.
     *    ( NRECYS .GE. 12 .AND. IZTYPE(J) .GE. 10 ) .OR.
     *    ( NRECYS .GE. 13 .AND. IZTYPE(J) .GE.  4)) THEN
         CELALL(J) = CELPAR(J)
         IIII = 1
         ENDIF
 7162 CONTINUE
      IF (IIII .EQ. 0) GOTO 7167
      DO 7165 I=1,NTYPE
      BUFFOY(I) = BUFFOY(I) / ZET
 7165 BUFFOX(I) = CELALL(I) / ZET
      J = NINT(ZET)
      WRITE(24, 7766) J, (CELATY(K), BUFFOY(K), K=1,NTYPE)
 7766 FORMAT (/' NOTE: Cell Contents was: '/
     *  ' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) /
     *                           ( 8X, 6(2X,A2,F6.1))/)
      WRITE(24, 7166) J, (CELATY(K), BUFFOX(K), K=1,NTYPE)
 7166 FORMAT (/' NOTE: Cell Contents reset [ output FOUR !! ] :'/
     *  ' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) /
     *                           ( 8X, 6(2X,A2,F6.1))/)
 7167 CONTINUE
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
      CALL NNRECY(-1)
      IF (EXPAND) GOTO 183
      WRITE (24, FMT='('' Scattering fraction, p**2 = '',F7.3)') PSQ
      IF (PSQ .GT. 1.2) THEN
         WRITE (24, FMT='('' Note: this may cause errors;'' /
     *                    '' Cell contents incorrect?'')')
         IF (NRECYR .LE. 1) THEN
         WRITE (9,FMT='('' Scattering fraction, p**2 = '',F7.3)') PSQ
            WRITE (9, 8183)
 8183 FORMAT (1X/' Too many atoms, or too many HEAVY atoms. '/
     * '                    --------------       Check your data:'/
     * ' if the cell contents are incorrect:'/
     * '      modify CRYSIN (call CRYSDA), or change the input ATOMS.'/
     * ' If a complete molecule lies on a symmetry element:' /
     * '      remove the symmetry-redundent part of it,      else:'/
     * ' if FOUR recycling led to too many HEAVY atoms:' /
     * '      rename some of the HEAVY atoms to lower its Z value!'/
     * ' Note:  p**2 up to 1.2 is acceptable but causes scaling'/
     * '      errors.   You should make  p**2 = 1,  approximately.'/)
            ENDIF
         NATINP = NAT
         NAT10 = MAX0(2, NATINP/10)
         NAT = MAX0(1, NATINP - NAT10)
         CALL FCALII
         IF (PSQ .GT. 1.2) THEN
            NAT10 = MAX0(NAT10+1, NATINP/5)
            NAT = MAX0(1, NATINP - NAT10)
            CALL FCALII
            ENDIF
         NAT10 = NATINP - NAT
         WRITE (24, 181) NAT10, PSQ
  181    FORMAT (' The last', I3, ' atoms from the input atoms set '/
     *      ' will be rejected; p**2 then is', F7.3/)
         IF (NRECYR .LE. 1) WRITE (9, 181) NAT10, PSQ
         ENDIF
      IF (PSQ .GT. 1.0) THEN
        WRITE(24,FMT='('' P**2 is artificially reset to p**2 = 1.0'')')
        PSQ = 1.0
         ENDIF
  183 CONTINUE
      IF (KEYT .NE. 3 .AND. .NOT.EXPAND) CALL FCALII
      IF (NRECYR .GE. 2) KEYWIL = -2
      IF (KEYD .GE. 5) KEYWIL = 0
      IF (KEYWIL .EQ. 4) GOTO 190
      IF (NAT .GT. 15 .OR. PSQ .GT. .90) KEYWIL = -2
      IZMAX = 1
      DO 186 I = 1, NAT
  186 IZMAX = MAX0 (IZMAX, IZAT(I))
      IF (IZMAX .LT. 50 .AND. PSQ .GT. .80) KEYWIL = -2
      IF (IZMAX .LT. 35 .AND. PSQ .GT. .70) KEYWIL = -2
      IF (IZMAX .LT. 20 .AND. PSQ .GT. .60) KEYWIL = -2
      IF (NRECYS .EQ. 3) KEYWIL = -2
      IF (NRECYS .EQ. 5) KEYWIL = 4
      IF (NRECYS .EQ. 5 .AND. NRECYX .EQ. 3 .AND. ATSCAL .GT. 0.) THEN
         WRITE (8, FMT='('' SCALE from ATOMS file ATSCAL='', F10.7)')
     *      ATSCAL
         IF (ABS ( SCALE - ATSCAL) .GT. 0.0001) WRITE (8,FMT=
     *     '('' [ old internal SCALE was SCALE='', F10.7)') SCALE
         WRITE (8, FMT='('' $TE!NRECY ATSCAL='', F10.7)') ATSCAL
         SCALE = ATSCAL
         WRITE (8, FMT='('' $TE SCALE ATsc '',I3,2F6.3,F8.4,2F6.3, I5)')
     *       NRECYR, PSQ, R2X, SCALE, BP, BR, KEYWIL
         ENDIF
  190 CONTINUE
      CALL WR24
      WRITE (8, FMT='(/'' DDMAIN : KEYT ='', I2)') KEYT
      WRITE (8, 211) SCALE, BP, BR
  211 FORMAT (' DDMAIN : Scale and B-values : Scale =',
     *          F9.5, ' Bp =', F6.3, ' Br =', F6.3)
         WRITE (8, FMT='('' $TE SCALE >>SF '',I3,2F6.3,F8.4,2F6.3,
     *      '' KEYD='', I1)')
     *       NRECYR, PSQ, R2X, SCALE, BP, BR, KEYD
      IF (KEYD.EQ.0 .OR. KEYD.EQ.5 .OR. EXPAND) THEN
         CALL FCALC (NSET, 0)
         CALL WR24
      ELSEIF (KEYT .LT. 3) THEN
         CALL AUTOFR (NSET)
         CALL WR24
         IF (KSTAT(6) .EQ. 17) THEN
            WRITE (8, 7142)
 7142       FORMAT (' stop multi PATTY    [ switch KSTAT(6)=17 ]')
            WRITE (8, 259) IPAT, NRECYR, NRECYS, R2X
            ENDIF
         IF (KSTAT(6) .EQ. 17) GOTO 739
         IF (IDOKA .EQ. 17) RETURN
      ELSE
         WRITE (9,*) ' AUTOFR is suppressed when using Anisotr.t.f. !'
         CALL FCALC (NSET, 0)
         ENDIF
      IF (KEYD .EQ. 0) THEN
         CALL FILCLO (IATOMS, 'KEEP')
         CALL FILCLO (IBINFC, 'KEEP')
         CALL KEPROX
         RETURN
         ENDIF
      IF (KEYD .GE. 5) THEN
         CALL FILCLO (IATOMS, 'KEEP')
         CALL KEPROX
         RETURN
         ENDIF
      IF (.NOT.EXPAND .AND. NORECY .AND. KEYD.EQ.0) CALL SCALE7
      CALL WR24
      CALL NNRECY (1)
      IF (NAT .GT. 799) GOTO 254
      IF (KEYT .EQ. 1) THEN
         IF (.NOT. EXPAND .AND. KEYD.EQ.1) CALL SCASTA
         DO 233 I = 1, NAT
         ATXYZ(6,I) = 0.0
  233    ATXYZ(5,I) = BP
         IF (.NOT. EXPAND) CALL ATOMOC (1, ATXYZ, IZAT,  NAT)
         KEYT = 2
         GOTO 237
         ENDIF
      IF (NAT .EQ. NATINP) GOTO 254
  237 CONTINUE
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      IF (.NOT. EXPAND) CALL ATOMOC (2, ATXYZ, IZAT,  NAT)
      IF (IPAT .EQ. 0) THEN
         WRITE (CHOUT, 242) CCODE, IRUN, NRECYR, R2X, SCALE
  242    FORMAT ('ATOMS ', A6, ' < DDMAIN 0 ',
     *   ' RUN', I4, ' CY=', I3, '  R2=', F6.3, '  SC=', F10.6 )
      ELSE
         WRITE (CHOUT, 243) CCODE, IPAT, IRUN, NRECYR, R2X, SCALE
  243    FORMAT ('ATOMS ', A6, ' PAT=', I3,
     *   ' RUN', I4, ' CY=', I3, '  R2=', F6.3, '  SC=', F10.6 )
         ENDIF
      WRITE (IATOMS, FMT = '(A72)') CHOUT
      NN = NATINP - NAT
      IF (NRECYR .GE. 1) WRITE (IATOMS, 247) NN, NRECYR
  247 FORMAT ('REMARK DDMAIN,', I3, ' atoms rejected in CYCLE', I3 )
      IF (NRECYR .EQ. 1 .AND. SWRECY) WRITE (IATOMS, FMT=
     *  '(''REMARK DDMAIN, input atoms, CYCLE 1'' )')
      NN = MIN0 (3, NAT)
      CALL AT123P ('OUTPUT', ' ATOMS', 24, ATNAME, ATXYZ, NN)
      WRITE (8, 248) CHOUT
  248 FORMAT (/' output atoms set to file ATTEM :'// 1X, A72/)
      DO 252 NATR = 1, NAT
  252 CALL ATOMWB (IATOMS, ATXYZ, ATNAME, NATR)
      WRITE (24, 253) NAT
  253 FORMAT (' Number of atoms written to ATOMS file:', I4)
      CALL WR24
      WRITE (IATOMS, FMT = '(''END'')')
      IF (NRECYR .EQ. 1 .AND. SWRECY) THEN
         CALL FILINQ (IAT10, 'ATTEM', 'FORMATTED', 'INPUT', KINQ)
         CALL FILCLO (IAT10, 'DELETE')
      ELSE
         CALL COPY80 (IATOMS, 'ATOMS', IAT10, 'ATTEM')
         ENDIF
  254 CONTINUE
      CALL FILCLO (IATOMS, 'KEEP')
      IF (NRECYS .LE. 7) GOTO 739
      IF (MPAT .GT. -99 .AND. MPAT .LT. -1) THEN
         IF (NRECYS .LE. 8 .AND. R2X .LT. .50) GOTO 739
         WRITE (8, 259) IPAT, NRECYR, NRECYS, R2X
  259    FORMAT(/ ' stop multi PATTY analysis for IPAT=',I2/ 6X,
     *       ' NRECYR=',I2,' NRECYS=',I2, ' R2X=', F5.3 /)
         CALL NNRECY (90)
         KSTAT(14) = 0
         GOTO 1357
         ENDIF
      CALL GETR2X (0, 10, IRUN, KEND)
      WRITE (8, FMT='('' TEMP99 KEND'', I3)') KEND
      IF (KEND .LE. 0) GOTO 739
      CALL KERNZA (-1.0, R2CYCA, MRECY)
      NCY = KEND+1
      IF (NCY .LT. 7) WRITE (8, *) ' check NCY, NRECYR:', NCY, NRECYR
      IF (NCY .LT. 7) GOTO 739
      R2CYC(NCY) = R2X
      R2MIN = 9.999
      NR2MIN = NCY
      IF ( R2CYC(1).GT.0.) R2CYCA(1) =  R2CYC(1)
      IF ( R2CYC(1).GT.0. .AND. R2CYC(2).GT.0.)
     *   R2CYCA(2) = ( R2CYC(1) + R2CYC(2) ) / 2.
      IF( R2CYC(1).GT.0. .AND. R2CYC(2).GT.0. .AND. R2CYC(3).GT.0.)
     *    R2CYCA(3) = ( R2CYC(1) + R2CYC(2) + R2CYC(3) ) / 3.
      DO 723 N = 3, NCY
      IF (R2CYC(N) .LT. R2MIN) THEN
         NR2MIN = N
         R2MIN = R2CYC(N)
         ENDIF
      IF (N .EQ. 3) GOTO 723
      IF( R2CYC(N-3).GT.0. .AND. R2CYC(N-2).GT.0. .AND. R2CYC(N-1).GT.0.
     *   .AND. R2CYC(N).GT.0.)   R2CYCA(N) =
     *   ( R2CYC(N-3) + R2CYC(N-2) + R2CYC(N-1) + R2CYC(N) ) / 4.
  723 CONTINUE
      NCY1 = MAX0 (1, NCY - 9)
      WRITE (8, 733) (I, I=NCY1,NCY)
  733 FORMAT(/' For cycle nr', I4, 9I6)
      WRITE (8, 734) (R2CYC(I), I=NCY1,NCY)
  734 FORMAT (' R2 values: ', 10F6.3)
      WRITE (8, 735) (R2CYCA(I), I=NCY1,NCY)
  735 FORMAT (' Smoothed : ', 10F6.3)
      IF (R2CYC(NCY) .LT. R2CYC(NCY-1)) GOTO 739
      IF (R2CYC(NCY) .LT. R2CYC(NCY-2)) GOTO 739
      IF (R2CYCA(NCY) .LT. R2CYCA(NCY-1)) GOTO 739
      IF (R2CYCA(NCY) .LT. R2CYCA(NCY-2)) GOTO 739
      IF (R2X .LT. 1.01 * R2MIN) GOTO 739
      IF (R2X .LT. R2CYCA(NCY-1)) GOTO 739
      IF (R2X .LT. 1.1 * R2CYCA(NCY-1) .AND. NRECYR .LE. 8 .AND.
     *    R2X .LT. 1.1 * R2CYCA(NCY-2)) GOTO 739
      WRITE(9,*) ' The R2 value increases, the refinement is not stable'
      CALL GETR2X (NR2MIN, 10,  IRUN, KEND)
      IF (KEND .LE. 0) GOTO 739
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
  736 READ (10, FMT='(A80)', END= 737) CHIN
      WRITE (IATOMS, FMT='(A80)' ) CHIN
      IF (CHIN(1:4) .NE. 'END ') GOTO 736
  737 READ (10,  FMT='(A80)', END= 1737) CHIN
      IF (CHIN(1:6) .NE. 'ATOMS ') GOTO 737
      CALL KERINB (LIT, 1)
      IF (LIT(4) .NE. 'DDMAIN') GOTO 1737
      REWIND IATOMS
      WRITE (IATOMS, FMT='(A80)' ) CHIN
 2736 READ (10,  FMT='(A80)', END= 1737) CHIN
      WRITE (IATOMS, FMT='(A80)' ) CHIN
      IF (CHIN(1:4) .NE. 'END ') GOTO 2736
 1737 CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (10, 'KEEP')
      WRITE (9,*) 'The atoms set with the lowest R2 value retrieved'
      IF (R2MIN .GT. .50) THEN
         WRITE (9,*) 'The R2 value is too high: stop.'
         CALL WR24
         IF (MPAT .GE. -1)
     *      CALL KERROR (' Wrong model used ?', 1737, 'DDMINI')
         CALL NNRECY (90)
         CALL ATPATS (1)
         ENDIF
      NORECY = .TRUE.
 1357 CONTINUE
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KIDDS)
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'OUTPUT', KINQCO)
      WRITE (ICON, 630) CCODE
  630 FORMAT ('CONDA ', A6)
      IF (MPAT .EQ. -99) THEN
         CALL XCONDA (ICON, IDDS, ICENT, 0)
         GOTO 631
      ELSEIF (MPAT .LE. -2 .AND. MPAT .GT. -99) THEN
         WRITE (IDDS, FMT='(''DDMAIN'' / ''STOP'')')
         WRITE (ICON, FMT='(''PROGRAM DDMAIN''/ ''OPTION 0 FCALC''/
     *      ''FINISH'')' )
      ELSE
         WRITE (IDDS, FMT='(''DDMAIN'' / ''FOUR''/
     *                      ''DDMAIN'' / ''NUTS''/ ''STOP'')')
         WRITE (ICON, FMT='(''PROGRAM DDMAIN''/ ''OPTION 3 FOUR ''/
     *                      ''PROGRAM FOUR '')')
         WRITE (ICON, FMT='(''PROGRAM DDMAIN''/ ''OPTION 0 FCALC''/
     *                      ''PROGRAM NUTS  AT2X'' / ''FINISH'')' )
         ENDIF
      CALL FILCLO (IDDS, 'KEEP')
      CALL FILCLO (ICON, 'KEEP')
      KSTAT(6) = 17
  631 CONTINUE
      CALL KEPROX
      RETURN
  739 CONTINUE
  255 CONTINUE
      IF (.NOT. EXPAND) THEN
         CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      ELSE
         CALL BINIFF (1, IBINFC, 'BINFC2', FITFC2, NITFC2,BUFFC,KENDFC)
         ENDIF
      PSQX = PSQ
      IF (EXPAND) PSQX = P1SQ
      IF (KEYD .EQ. 2) CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
      IF (KEYD .NE. 1) GOTO 270
      IF (NAT .GE. 100) GOTO 260
      IF (IFIX (100.0 * PSQX) .LT. MAX0(79, 100- 3*NAT)
     *                           - MIN0(14, NAT/3) ) GOTO 270
  260 CONTINUE
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR ('No DDSYST file found',0,'DDMAIN')
      LITFFT = 0
  261 READ (IDDS, FMT='(A6)') LIT(1)
      IF (LIT(1) .EQ. 'FOUR') LITFFT = 1
      IF (LIT(1) .NE. 'STOP') GOTO 261
      REWIND IDDS
      IF (LITFFT .EQ. 1) THEN
         IF (NORECY) WRITE (24, 262)
  262    FORMAT (1X/' The scattering power is too large',
     *                  ' therefore program PHASEX is not' /
     *          ' applied and program FOUR follows.'/1X)
         WRITE (IDDS, FMT='(''FOUR'' / ''NUTS'' )')
         ENDIF
      WRITE (IDDS, FMT='(''STOP'')')
      CALL FILCLO (IDDS, 'KEEP')
      KEYD = 3
      KEYDS = 0
  270 CONTINUE
      IF (KEYD.EQ.3 .AND. KEYDS.GE.3) GOTO 310
      IF (KEYD .EQ. 2) GOTO 310
      IF (.NOT.EXPAND) CALL FCALII
      IF (KEYD .NE. 1) GOTO 310
      RDENR = 0
      RNUMR = 0
      DO 290 I=1,NTYPE
      RDENR = RDENR + (CELALL(I)-CELPAR(I))*IZTYPE(I)**2
  290 RNUMR = RNUMR + (CELALL(I)-CELPAR(I))*IZTYPE(I)**3
      E000R = (RDENR**1.5) / RNUMR / SQRT(ALATT)
      CALL BINOFF (1, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      RETURN
  310 IEF = 1
      IF (KEYD.EQ.3 .AND. KEYDS.EQ.5) IEF = -1
      IMAP = 3
      IF (IEF.EQ.-1) IMAP = 4
  935 CONTINUE
      IF (EXPAND) KEXPA = 1
      CALL BINOFF (1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      CALL WR24
      WRITE (8, FMT='(/'' ***** end of subr DDMINI ***** ''/)')
      RETURN
      END
      SUBROUTINE ATIN7 (NSET)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      EQUIVALENCE (IATOMS, IFILE(2))
      COMMON /ORFLES/ LASTV, NORFLX (6, 50)
      CHARACTER *80 CHIN2, CHIN3
  110 CALL KERINA (IATOMS, LIT, 1, LEND)
      IF (LEND .NE. 0) THEN
         NSET  = -NSET
         RETURN
         ENDIF
      IF (LIT(1) .NE. 'ATOMS') GOTO 110
      CHIN2 = CHIN
      IF (NSET.EQ.0 .AND. LIT(5).EQ.'MOD=' .AND. LIT(9).EQ.'R2=') THEN
         NTV = NINT(FNUM(4))
         IF (NTV .GT. 50) NTV = 50
         NORFLX(4,NTV) = NTV
         NORFLX(1,NTV) = NINT(FNUM(1))
         NORFLX(2,NTV) = NINT(FNUM(2))
         NORFLX(3,NTV) = NINT(FNUM(3))
         NORFLX(5,NTV) = NINT(FNUM(6))
         LASTV = NTV
         WRITE(24, 114) (NORFLX(I, NTV), I=1,5)
         WRITE (8, 114) (NORFLX(I, NTV), I=1,5)
  114    FORMAT (22X,' atoms set MOD= OR= TR= TV= FOM= ', 4I3, I5)
         ENDIF
      READ (IATOMS, 117, ERR = 123, END = 123) CHIN3
  117 FORMAT (A)
      GOTO 129
  123 CALL KERNER (123, 'ATIN7')
  129 BACKSPACE IATOMS
      BACKSPACE IATOMS
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      NSET = NSET + 1
      NATQ = NAT
      NATH = 0
      N = 1
  143 CONTINUE
      IF (ATNAME(N)(1:1).EQ.'H' .AND. IZAT(N).EQ.1) NATH = NATH + 1
      IF (ATNAME(N)(1:1) .EQ. 'Q') THEN
         IF (N .EQ. NAT) GOTO 148
         DO 146 N1 = N, NAT - 1
         CALL KERNAB (ATXYZ(1,N1+1), ATXYZ(1,N1), 10)
         ATNAME(N1) = ATNAME(N1+1)
  146    IZAT(N1) = IZAT(N1+1)
  148    NAT = NAT - 1
         N = N - 1
         ENDIF
      N = N + 1
      IF (N .LE. NAT) GOTO 143
      IF (NAT.LT.NATQ) WRITE (8, FMT=
     *  '('' Nr of Q-atoms (= peaks) rejected:'', I3)') NATQ-NAT
      IF (NATH.NE.0) WRITE(24, FMT=
     *  '('' Number of H atoms included:'', I3)') NATH
      IF (NAT .LE. 0) CALL KERROR ('.... No atoms left!', 0, 'ATIN7')
      IF (NSET .GT. 1) CALL ATOMPR (8, 2, ATXYZ, ATNAME, IZAT, NAT)
      CHIN = CHIN2
      CALL KERINB (LIT, 1)
      CALL QFOMR2 (1, NSET, 0., 0., CHIN3)
      RETURN
      END
      SUBROUTINE QFOMR2 (KEY, NSET, R2E, R2, CHIN3)
      CHARACTER *80 CHIN3
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (KEYWIL, KSTAT(17))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (KEYD, KSTAT(19))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zatq2.inc'
      DIMENSION NSKIP(MS), QQ(MS), LL(MS), LLL(MS)
      PARAMETER (LITAM = 10)
      CHARACTER *6 LITA(LITAM)
      DATA LITA / 'OR=   ', 'ISIG= ', 'TR=   ', 'TV=   ', 'FOM=  ',
     *            'PAT   ', 'R2=   ', 'RUN   ', 'X=    ', 'PAT=  ' /
      DATA IATOMS /2/
      DATA K     /0/
      DATA ISTOP /0/
      DATA PFOMM /0./
      DATA MSET  /0/
      DATA NSET9 /999/
      DATA BPST, BRST, BPMIN, BRMINP /0., 0., 999., 999./
      CALL WR24
      IF (KEY .EQ. 0) THEN
         ISTOP = 0
         NSET9 = 999
         RETURN
         ENDIF
      IF (KEYD .NE. 7) ISTOP = 1
      IF (LITJ2 .NE. 'PATTY ') ISTOP = 1
      IF (ISTOP .GT. 0) RETURN
         NPAT = 0
         PFOM = 0.
         RR2 = 0.
         NPAT1 = 0
         NPAT2 = 0
      NF = 0
      FFF = 0.
      IF (KEY .LT. 0) GOTO 700
      IF (KEY .EQ. 2) GOTO 500
      IF (NSET .LE. 0) RETURN
      IF (NSET .LT. NSET9) THEN
         PFOMM = 0.
         NSET9 = NSET
         MSET = NSET
         ISTOP = 0
         ENDIF
      IF (MPAT .GE. 2) SCALE = SCAMER
      NCHIN = 0
  100 NCHIN = NCHIN + 1
      CALL KERINB (LITA, LITAM)
      IF (NLIT .LT. 3 .OR. NFNUM .LT. 2) GOTO 400
      NF = 0
      NL = 0
      NPAT = 0
      PFOM = 0.
      RR2 = 0.
      NPAT1 = 0
      NPAT2 = 0
      DO 312 I = 1, 32
      IF (NFDOL(I) .LT. 0) THEN
         NL = NL + 1
      ELSEIF (NFDOL(I) .GT. 0) THEN
         NF = NF + 1
         FFF = FNUM(NF)
         IF (NLUSER(NL) .LE. 0) GOTO 312
         IF (NLUSER(NL) .EQ. 6) NPAT1 = NINT (FFF)
         IF (NLUSER(NL) .EQ. 10) NPAT2 = NINT (FFF)
         IF (NLUSER(NL) .EQ. 5) PFOM = FFF
         IF (NLUSER(NL) .EQ. 7) RR2 = FFF
      ELSE
         GOTO 317
         ENDIF
  312 CONTINUE
  317 CONTINUE
      IF (NPAT1 .GT. 0 .AND. PFOM .GT. 0.01) THEN
         NPAT = NPAT1
         GOTO 403
      ELSEIF (NPAT2 .GT. 0 .AND. PFOM .GT. 0.01) THEN
         NPAT = NPAT2
         GOTO 403
      ELSE
         NPAT1 = 0
         NPAT2 = 0
         PFOM = 0.
         RR2 = 0.
         ENDIF
  400 CONTINUE
      IF (NCHIN .EQ. 1) THEN
         CHIN =  CHIN3
         GOTO 100
         ENDIF
  403 CONTINUE
      NPATS(NSET) = NPAT
      PFOMS(NSET) = PFOM
      R2S(NSET) = RR2
      IF (PFOM .GT. PFOMM) PFOMM = PFOM
      NATSS(NSET) = NAT
      DO 147 I=1, NAT
      K = K + 1
      CALL KERNAB (ATXYZ(1,I), XYZ(1,K), 5)
      ATNMS(K) = ATNAME(I)
  147 CONTINUE
      MSET = NSET
      RETURN
  500 CONTINUE
      R2ES(NSET) = R2E
      R2S(NSET) = R2
      BPS(NSET) = BP
      BRS(NSET) = BR
      BPST = BPST + BP
      BRST = BRST + BR
      IF (BP .LT. BPMIN) THEN
         BPMIN = BP
         BRMINP = BR
         ENDIF
      BP = BOVMER
      BR = BP
      SCALE = SCAMER
      RETURN
  700 CONTINUE
      ISTOP = 999
      IF (PFOMM .LE. 0.) RETURN
      BPST = BPST / MSET
      BRST = BRST / MSET
      BPMAX = 1.1 * BPST
      BPSE = 0.
      BRSE = 0.
      NBPS = 0
      DO 711 I = 1, MSET
      PFOMS(I) = PFOMS(I) / PFOMM
      BPSS(I) = 0.
      IF (BPS(I) .LE. BPMAX) THEN
         BPSE = BPSE + BPS(I)
         BRSE = BRSE + BRS(I)
         NBPS = NBPS + 1
         ENDIF
      IF (BPS(I) .GT. 0.01) BPSS(I) = BPST / BPS(I)
  711 CONTINUE
      BPSE = BPSE / NBPS
      BRSE = BRSE / NBPS
      WRITE (24, FMT='(1X/'' Values of Bp and Br for all PATTY sets''/
     *  1X/'' Nset    Bp     Br    BpFOM ''/1X)')
      WRITE (24, FMT='(I4, 2F7.2, F9.2)')
     *      (I, BPS(I), BRS(I), BPSS(I), I=1,MSET)
      WRITE (24, FMT='(1X/'' Average values of Bp and Br'', 2F6.2 /
     *                    '' Lower average  of Bp and Br'', 2F6.2 /
     *                    '' Lowest value of Bp, with Br'', 2F6.2 )')
     *      BPST, BRST, BPSE, BRSE, BPMIN, BRMINP
      BP = BPS(1)
      BR = BRS(1)
      KEYWIL = -2
      NSKIP(1) = 0
      DO 713 I = 2, MSET
      NSKIP(I) = NSKIP(I-1) + NATSS(I-1)
  713 CONTINUE
      QFM = 0.
      DO 715 I = 1, MSET
      IF (R2S(I) .LT. 0.01) R2S(I) = 1.0
      F = PFOMS(I) * R2ES(I)
      IF (F .LT. 0.01) F = 0.01
      QFOMS(I) = SQRT(F) / R2S(I)
      IF (QFM .LT. QFOMS(I)) QFM = QFOMS(I)
  715 CONTINUE
      DO 716 I = 1, MSET
      QFOMS(I) = QFOMS(I) / QFM
      QQ(I) = QFOMS(I)
  716 CONTINUE
      IL = 0
      DO 720 L = 1, MSET
      Q = 0.
      IM = 0
      DO 718 I = 1, MSET
      IF (QQ(I) .LE. Q) GOTO 718
      Q = QQ(I)
      IM = I
  718 CONTINUE
      QQ(IM) = 0.
      LL(IM) = L
      IL = IL + 1
      LLL(L) = IM
  720 CONTINUE
      WRITE (24, FMT='(1X/'' final R2 TEST results '' /1X/ ,
     * '' input  PATTY-results  R2-results   Combined  new order'',
     *    ''     Bp-results''/
     * '' NSET    PAT   FOM=    R2Expect R2     FOM=     PAT=   '',
     *    ''     BpFOM''/1X)')
      MPAT2 = 1
      IF (MSET .LE. 1) GOTO 721
      MPAT2 = MAX0(LL(1), LL(2))
      IF (MSET .GE. 3) MPAT2 = MAX0(MPAT2, LL(3))
      CALL WR24
      WRITE (8, FMT='( '' $TE best PATTY'',3I3)') LL(1), LL(2), MPAT2
      NSETM = NINT(R2E)
      IF (NSETM .LE. 0) NSETM = 1
      NSETM2 = NINT(R2)
      IF (NSETM2 .LE. 0) NSETM2 = 1
      MPAT3 = MAX0(LL(NSETM), LL(NSETM2))
      WRITE (8, FMT='( '' $TE best < R2 '',3I3)')
     *   LL(NSETM), LL(NSETM2), MPAT3
      IF (MPAT3 .GT. MPAT2) MPAT2 = MPAT3
      IF (MPAT2 .GT. 10) MPAT2 = 10
  721 CONTINUE
      NNNPAT = 0
      DO 725 I = 1, MSET
      IFOM = NINT (PFOMS(I) * 10000.)
      WRITE (24, 724) I, NPATS(I), IFOM, R2ES(I),R2S(I),QFOMS(I),LL(I)
     *   , BPSS(I)
  724 FORMAT (I5,   I7,    I7,    F9.3, F6.3, F9.4, I9, F12.2)
         IF (I .NE. NPATS(I))  NNNPAT = 1
  725 CONTINUE
      IF (MPAT .EQ. 55) THEN
         MPAT = MPAT2
         IF (MPAT .GT. MSET) MPAT = MSET
         WRITE(9,FMT='(/'' PATTY, max nr of solutions:'',I3/)') MPAT
         ENDIF
      IF (MPAT .GT. MSET) MPAT = MSET
      CALL WR24
      WRITE(24, 727) MPAT
  727 FORMAT (/' Nr of PATTY sets to be expanded:',I3/)
      IF (NNNPAT .EQ. 1) WRITE(24, FMT='(/
     *      '' NOTE: the sequence of input sets'',
     *      '' (NSET) is not equal''/'' to the original PATTY output'',
     *      '' sequence (PAT):''/ '' see REMARK on ATOMS file'',
     *      '' when NSET and PAT do not match.''/
     *      '' The present output ATOMS sequence is denoted PAT=''/)')
      IM = LLL(1)
      BP = BPS(IM)
      BR = BRS(IM)
      REWIND IATOMS
      DO 757 M = 1, MSET
      IM = LLL(M)
      WRITE (IATOMS, FMT='(''ATOMS '', A6, '' < PAT.R2 0 RUN'', I4,
     *   '' PAT='', I3, '' R2='', F6.3, '' FOM='', F6.3)')
     *   CCODE, IRUN, LL(IM), R2S(IM), QFOMS(IM)
      WRITE (IATOMS, FMT='(''REMARK BpBr= '', 2F9.4)') BPS(IM), BRS(IM)
      IF (NNNPAT .EQ. 1) WRITE (IATOMS, FMT='(
     *    ''REMARK original from PATTY:'', I3,
     *    '', was now input NSET='', I3)') NPATS(IM), M
      K = NSKIP(IM) + 1
      KK = K - 1 + NATSS(IM)
      DO 747 I = K, KK
      WRITE (IATOMS, FMT='( ''ATOM   '',A6, 3F9.5, 2F9.4)')
     *   ATNMS(I), (XYZ(J,I), J=1,5)
  747 CONTINUE
      WRITE (IATOMS, FMT='(''END''/)')
  757 CONTINUE
      WRITE (IATOMS, FMT='(''FINISH'')')
      WRITE (24, 760)
  760 FORMAT (1X/
     * ' All accepted parameter sets are written to the ATPAT file' /)
      CALL KERASE ('ATPAT')
      CALL COPY80 (IATOMS, 'ATOMS', 10, 'ATPAT')
      IF (MPAT .EQ. 1) THEN
         MPAT = -1
         PATBP = BP
         PATBR = BR
         RETURN
         ENDIF
      CALL WR24
      IF (MPAT .GT. 0) MPAT = - MPAT
      CALL ATPATS (0)
      RETURN
      END
      SUBROUTINE FCALII
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (KEYD, KSTAT(19))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      DIMENSION KLAD(MAXAT)
      CALL ATOMOC (0, ATXYZ, KLAD, NAT)
      CALL KERNZA (0.0, CELPAR, NTYPE)
      DO 170 I = 1,NAT
      DO 170 J = 1,NTYPE
      IF (IZAT(I) .NE. IZTYPE(J)) GOTO 170
      ITAT(I) = J
      CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AMULT / FLOAT(KLAD(I))
  170 CONTINUE
      SUMZP = 0.0
      SUMZA = 0.0
      DO 180 I = 1,NTYPE
      SUMZP = SUMZP + CELPAR(I) * FF(2,I) ** 2
  180 SUMZA = SUMZA + CELALL(I) * FF(2,I) ** 2
      PSQ = SUMZP / SUMZA
      P1SQ = PSQ / ( ICENT * NSYMM )
      BPAV = 0.
      IF (KEYT .GT. 1) THEN
         IZATT = 0
         DO 174 I = 1, NAT
         BPAV = BPAV + ATXYZ(5,I) * IZAT(I) **2
  174    IZATT = IZATT + IZAT(I) ** 2
         BPAV = BPAV / FLOAT(IZATT)
         WRITE (8, 173) BPAV
  173    FORMAT (/' FCALII: Averaged value of Bp for known atoms:',
     *      ' Bp = ', F8.3/)
         BP = BPAV
         ENDIF
      IF (PSQ .GT. 1.1) THEN
         WRITE (24, FMT='('' Warning: P**2:'', F7.3)') PSQ
         ENDIF
      CALL WR24
      ISMAX = IFIX (STLMAX * 400. + 0.04) + 2
      IF (ISMAX .GT. 500) CALL KERROR ('STLMAX reset?', 270, 'FCALII')
      DO 282 IS=1,ISMAX
      STL = FLOAT(IS-1) * 0.0025
      STL2 = STL * STL
      SUMF2P(IS) = 0.0
      DO 260 I=1,NTYPE
  260 SUMF2P(IS) = SUMF2P(IS)+ FF(IS,I) * FF(IS,I) * CELPAR(I)
      EXPBR(IS) = EXP(-BR * STL2)
  282 EXPBP(IS) = EXP(-BP * STL2)
      RETURN
      END
      SUBROUTINE FCALC (NSET, KEYAUT)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IBINFC, IFILE(12))
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (KEYWIL, KSTAT(17))
      EQUIVALENCE (KEYD, KSTAT(19))
      EQUIVALENCE (KEYDS, KSTAT(20))
      LOGICAL SWRECY, EXPAND, LTESTR
      EQUIVALENCE (SWRECY, SWITCH(7)), (EXPAND, SWITCH(23))
      EQUIVALENCE (LTESTR, SWITCH(27))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      LOGICAL LBINFC, LCALR2
      LBINFC = .TRUE.
      LCALR2 = .FALSE.
      LTESTR = .TRUE.
      CALL WR24
      IF (KEYD .LT. 5) LTESTR = .FALSE.
      IF (KEYD .EQ. 0 .AND. KEYDS .EQ. -1) LCALR2 = .TRUE.
      IF (LCALR2) LTESTR = .TRUE.
      IF (LCALR2) KEYWIL = 4
      IF (LTESTR) LBINFC = .FALSE.
      IF (LBINFC) LTESTR = .FALSE.
      R2MIN = 999.
      WRITE(24, FMT='(/'' Calculate structure factors'')')
      CALL WILSIN (999)
      IF (.NOT. LCALR2)
     *   WRITE (8, FMT='(/'' Calculate structure factors, new'',
     *       '' temperature factors and new scale'')')
      FICENT = FLOAT (ICENT)
      IF (KEYD .GE. 5) STOP 206
      GOTO 151
  100 CALL ATIN7 (NSET)
      IF (NSET .LE. 0) GOTO 910
      IF (KEYT .EQ. 3) CALL KERROR
     *   (' No anisotr. allowed in AUTOR2 TEST runs', 100, 'AUTOFR')
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
  151 CONTINUE
      IF (EXPAND) THEN
         WRITE(24, 183) P1SQ
  183    FORMAT (' Scattering fraction of known part:'/
     *   '    excluding symmetry related molecules: P1**2 =', F6.3)
      ELSE
         IF (PSQ .LT. 0.99) THEN
            WRITE (8, 184) PSQ
  184       FORMAT (' Scattering fraction of known part: P**2 =', F6.3)
            ENDIF
         ENDIF
      CALL WR24
      IF (.NOT. EXPAND) THEN
         IF (LBINFC)
     *   CALL BINOFF (1, IBINFC,'BINFC', FITFC, NITFC, BUFFC, KENDFC)
      ELSE
         CALL BINOFF (1, IBINFC,'BINFC2', FITFC2, NITFC2, BUFFC, KENDFC)
         ENDIF
      CALL RINI (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,
     *          RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT)
      SUMNR2 = 0.
      SUMFO2 = 0.
      SUMFP2 = 0.
      SUMFF2 = 0.
      SUMFC2 = 0.
      SUMFO4 = 0.
      SUMFR4 = 0.
      IREFX = 0
  200 CONTINUE
      IREFX = IREFX + 1
      HCODE = FBINX(1,IREFX)
      FOBS = FBINX(2,IREFX)
      IF (FOBS .LT. 0.) GOTO 220
      SIG = FBINX(3,IREFX)
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      IF (.NOT. EXPAND) THEN
         CALL FCALC1 (ATXYZ, ITAT, NAT)
         FP2F2R = FP**2 + (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2
         SUMFO2 = SUMFO2 + FOBS**2
         SUMFP2 = SUMFP2 + FP2F2R
         SUMFC2 = SUMFC2 + FP**2
         FOSC  = FOBS * SCALE
         SUMFR4 = SUMFR4 + (FP**2 - FOSC**2)**2
         SUMFO4 = SUMFO4 + FOSC**4
         CALL R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *        RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2)
         R2X = RNM2XZ
         CALL WILSIN (0)
      ELSE
         CALL FCALC2 (ATXYZ, ITAT, NAT)
         SUMNR2 = SUMNR2 + ASYMM / EPSIL2
         SF2 = SUMF2 (ISS)
         SF2P= SUMF2P(ISS)
         SUMFF2 = SUMFF2 + (SF2 - SF2P*ASYMC) * EXPBR(ISS) / EPSIL2
         SUMFO2 = SUMFO2 + FOBS**2 / EPSIL2
         DO 210 I = 1, NSYMM
         IF (FPEXP(1,I).GT.0.0) SUMFP2 = SUMFP2 + FPEXP(1,I)**2
  210    CONTINUE
         ENDIF
      IF (.NOT. EXPAND) THEN
         FITFC(1) = FP
         FITFC(2) = PHIP
         IF (LBINFC)
     *   CALL BINOFF (0, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      ELSE
         FITFC2(1) = EPSIL2
         FITFC2(2) = SF2
         FITFC2(3) = SF2P
         CALL KERNAB (FPEXP, FITFC2(4), NITFC2-3)
         CALL BINOFF (0, IBINFC, 'BINFC2',FITFC2, NITFC2,BUFFC, KENDFC)
         ENDIF
      GOTO 200
  220 CONTINUE
      IF (.NOT. EXPAND) THEN
         IF (LBINFC)
     *   CALL BINOFF (-1, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      ELSE
         CALL BINOFF (-1, IBINFC, 'BINFC2',FITFC2, NITFC2,BUFFC, KENDFC)
         ENDIF
      IF (.NOT. EXPAND) THEN
         CALL RPR (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *        RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN)
         R2X = RNM2XZ
      IF (KEYAUT .EQ. 1) RETURN
      IF (MPAT .LE. -2 .AND. MPAT .GT. -99) CALL ATPATS(1)
         IF (IPAT .LT. 0)  CALL ATSETS
         IF (LCALR2) GOTO 990
         IF (LTESTR) THEN
            IF (NSET .EQ. 1) WRITE(24, FMT='(/
     *         '' Structure factor calculation for all atom sets:''/
     *         '' Set No.  Nr.atoms  p**2  expected R2  actual R2'')')
            WRITE(24, 1254) NSET, NAT, PSQ, RNM2EZ, RNM2XZ
 1254       FORMAT (I7, I8, F9.3, F13.3, F11.3)
            IF (RNM2XZ .LT. R2MIN) THEN
               R2MIN = RNM2XZ
               NSETM = NSET
               ENDIF
            ENDIF
      ELSE
         WRITE (8, 254) NINT(SUMNR2)
  254    FORMAT (' Number of reflections after expansion:', I10)
         SUMFP2 = SUMFP2 * FICENT  + SUMFF2
         ENDIF
      CALL WR24
      IF (LTESTR) GOTO 100
      GOTO 990
  910 CONTINUE
      WRITE(24, FMT='(
     *      '' Structure factor calc finished for all atom sets '')')
      IF (R2MIN .LT. 998. .AND. NSETM .NE. 1) THEN
         WRITE(24, 1255) R2MIN, NSETM
 1255    FORMAT(' Note: Lowest value of R2 =', F6.3, ' for set nr.', I3)
         ENDIF
      CALL WR24
      IDOKA = 17
  990 RETURN
      END
      SUBROUTINE FCALC1 (ATXYZ, ITAT, NAT7)
      DIMENSION ATXYZ(10,NAT7), ITAT(NAT7)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      DIMENSION FFF(10), ADTRIG(24)
      DATA  FFF, ADTRIG / 34*0.0 /
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      DO 110 J=1,NTYPE
      IF (CELPAR(J).LE.0.0) GOTO 110
      FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL
  110 CONTINUE
      CALL HKLEX1 (HKLX, HKLX)
      IF (NSYMM.EQ.1) GOTO 150
      DO 140 J=2,NSYMM
      IF (ITRS(J).EQ.0) GOTO 140
      ADTRIG(J) = HKLX(1,1)*TSYMM(1,J) + HKLX(2,1)*TSYMM(2,J) +
     *            HKLX(3,1)*TSYMM(3,J)
  140 CONTINUE
  150 FAP = 0.0
      FBP = 0.0
      IF (KEYT.EQ.1) GOTO 300
      DO 250 I=1,NAT
      A1 = 0.
      B1 = 0.
      A2 = 0.
      B2 = 0.
      DO 200 J=1,NSYMM
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      IF (ATXYZ(6,I) .GT. 0.0) GOTO 180
      A1 = A1 + SICO(ITRIG + 2500)
      B1 = B1 + SICO(ITRIG + 2500)
      IF (ICENT.EQ.2) GOTO 200
      A2 = A2 - SICO(ITRIG)
      B2 = B2 + SICO(ITRIG)
      GOTO 200
  180 X1 = HKLX(1,J) * ATXYZ (5,I)
     *   + HKLX(2,J) * ATXYZ(10,I)
     *   + HKLX(3,J) * ATXYZ (9,I)
      X2 = HKLX(2,J) * ATXYZ (6,I)
     *   + HKLX(3,J) * ATXYZ (8,I)
      X3 = HKLX(3,J) * ATXYZ (7,I)
      TF = EXP(-0.25 * ( X1*HKLX(1,J) + X2*HKLX(2,J) + X3*HKLX(3,J) ))
      A1 = A1 + SICO(ITRIG + 2500) * TF
      B1 = B1 + SICO(ITRIG + 2500) * TF
      IF (ICENT.EQ.2) GOTO 200
      A2 = A2 - SICO(ITRIG) * TF
      B2 = B2 + SICO(ITRIG) * TF
  200 CONTINUE
      IJ = ITAT(I)
      IF (ATXYZ(6,I).LT.0.0) THEN
         TF = ATXYZ(4,I) * EXP (-STL2 * ATXYZ(5,I))
      ELSE
         TF = ATXYZ(4,I)
         ENDIF
      FAP = FAP + A1 * FFF(IJ)     * TF
      FBP = FBP + B1 * SFAC(11,IJ) * TF
      IF (ICENT .EQ. 2) GOTO 250
      FAP = FAP + A2 * SFAC(11,IJ) * TF
      FBP = FBP + B2 * FFF(IJ)     * TF
  250 CONTINUE
      FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP)
      GOTO 500
  300 DO 450 I=1,NAT
      A1 = 0.
      B2 = 0.
      DO 400 J=1,NSYMM
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      A1 = A1 + SICO(ITRIG + 2500)
      IF (ICENT.EQ.2) GOTO 400
      B2 = B2 + SICO(ITRIG)
  400 CONTINUE
      IJ = ITAT(I)
      FAP = FAP + A1 * FFF(IJ) * ATXYZ(4,I)
      IF (ICENT .EQ. 2) GOTO 450
      FBP = FBP + B2 * FFF(IJ) * ATXYZ(4,I)
  450 CONTINUE
      FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP) * EXPBP(ISS)
  500 PHIP = 0.0
      IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925
      IF (PHIP.LT.0.0) PHIP = PHIP + 360.
      RETURN
      END
      SUBROUTINE FCALC2  (ATXYZ, ITAT, NAT7)
      DIMENSION ATXYZ(10,NAT7), ITAT(NAT7)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zbuff.inc'
      DIMENSION FFF(10)
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      DO 110 J=1,NTYPE
      IF (CELPAR(J).LE.0.0) GOTO 110
      FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL
  110 CONTINUE
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = IEPS
      EPSIL2 = IEPS2
      DO 600 J=1,NSYMM
      IF (IDHKL(J).EQ.0) GOTO 200
      K = IABS(IDHKL(J))
      FPEXP(1,J) = -K
      FPEXP(2,J) = FPEXP(2,K)
      IF (FPEXP(2,J).LT.0.0001) FPEXP(2,J)=0.0001
      IF (IDHKL(J).LT.0) FPEXP(2,J)=-FPEXP(2,J)
      GOTO 600
  200 FAP = 0.0
      FBP = 0.0
      DO 400 I=1,NAT
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      IJ = ITAT(I)
      FAP = FAP + SICO(ITRIG + 2500) * FFF(IJ)
      FBP = FBP + SICO(ITRIG)        * FFF(IJ)
  400 CONTINUE
      FP = ALATT * SQRT (FAP*FAP + FBP*FBP) * EXPBP(ISS)
      PHIP = 0.0
      IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925
      IF (PHIP.LT.0.0) PHIP = PHIP + 360.
      FPEXP(1,J) = FP
      FPEXP(2,J) = PHIP
  600 CONTINUE
      RETURN
      END
      SUBROUTINE SCALE7
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (KEYWIL, KSTAT(17))
      LOGICAL SWRECY, EXPAND
      EQUIVALENCE (SWRECY, SWITCH(7)), (EXPAND, SWITCH(23))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zddif.inc'
      PARAMETER (PSQMAX = 0.90)
      CALL WR24
      WRITE (8, FMT='('' Calculate new SCALE and B values'')')
      IF (MPAT .GE. 1) KEYWIL = 0
      SC2 = SQRT (SUMFP2 / SUMFO2)
      IF (MPAT .GE. 2) GOTO 112
      IF (MPAT .LE. 2222) GOTO 112
      WRITE (8, 258) SC2
  258 FORMAT (' New scale = SQRT((SUMFP2 + FF2R) / SUMFO2):', F11.5)
      IF (PSQ .LT. PSQMAX) THEN
         WRITE (8, FMT='(''+'', 56X, ''(not used)'')')
      ELSE
         WRITE (8, FMT='(''+'', 56X, '' accepted!'')')
         SCALE = SC2
         KEYWIL = 4
         ENDIF
  112 CONTINUE
      IF (KEYWIL .NE. 4 .AND. NRECYS .LE. 5) CALL WILPAR
      CALL WR24
      IF (KEYWIL.NE.4 .AND. KEYWIL.GE.0) CALL WIL2DI
      RETURN
      END
      SUBROUTINE AUTOFR (NSET)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICOND, IFILE(4)), (IDDL, IFILE(1)), (IDDS, IFILE(2))
      EQUIVALENCE (IBINFC, IFILE(12))
      EQUIVALENCE (KEYWIL, KSTAT(17))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (KPROG, KSTAT(18))
      EQUIVALENCE (KEYD, KSTAT(19))
      LOGICAL SWRECY, NORECY, LTESTR
      EQUIVALENCE (SWRECY, SWITCH(7)), (NORECY, SWITCH(8))
      EQUIVALENCE (LTESTR, SWITCH(27))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      EQUIVALENCE (ICYCL, NRECYR)
      DOUBLEPRECISION ATFP4(MAXAT), ATFPO(MAXAT), SFPS2, SFPS4, TERM2,
     *   TERM3, RNUM2C, RDEN2C
      DOUBLEPRECISION ATTOT(MAXAT)
      LOGICAL LBINFC
      LBINFC = .TRUE.
      LTESTR = .FALSE.
      CALL WR24
      WRITE (8, 100) 1
  100 FORMAT (/' -------------------- autofour bench mark', I3/)
      IF (KEYD .EQ. 7) THEN
         LTESTR = .TRUE.
         LBINFC = .FALSE.
         KEYWIL = 0
         BOV = BOVMER
         BP = BOV
         BR = BOV
         WRITE(24, 102)
  102    FORMAT (/' Structure factor calculation for all atom sets'/)
         ENDIF
      R2MIN =  999.9
      NSETM = 0
      NSETM2 = 0
      NATNOW = 0
      DO 103 IT = 1, NTYPE
      IF (IZTYPE(IT).NE.1) THEN
         NATNOW = NATNOW + NINT ( CELPAR(IT) )
         ENDIF
  103 CONTINUE
      NATEND = NATSYM
      NATNOW = NATNOW / IMULT
      NATRES = NATEND - NATNOW
      IF (.NOT. LTESTR .AND. NRECYR .GT. 1) THEN
         WRITE(24,*)
     *   'Number of original input atoms (minus removed ones) =',NATS
         WRITE(24,*)
     *   'Number of atoms fed into the last Fourier synthesis =',NATL
         WRITE(24,*)
     *   'Number of atoms (peaks) taken from last Fourier map =',NAT
         IF (NATEND .NE. NAT) WRITE(24,*)
     *   'Number of atoms  expected in the complete structure =',NATEND
         ENDIF
      IF (NATL .LT. NATS) NATL = NATS
      CRTEST = 0.0
      NDELM  = (NAT-3) / 2
      IF (NAT .LE. 4) NDELM = 0
      IF (NAT .GE. 10) NDELM = NAT / 3
      IF (NAT .GE. 20) NDELM = NAT / 4 + 1
      IF (NDELM .GT. 25 ) NDELM = 25
      NATFIX = 0
      IF (ICYCL .LE. 3 .AND. NATS .LE. 3) NATFIX = NATS
      IF (ICYCL .LE. 1) GOTO 105
      IF( NRECYS .GE. 3 ) NATFIX = 0
      IF( NRECYS .GE. 4 ) NDELM = NAT / 5
      IF( NRECYS .GE. 6 ) NDELM = NAT / 7
      IF( NRECYS .GE. 8 ) NDELM = NAT / 9
      IF( NRECYS .GE. 10) NDELM = NAT / 12
      IF (NDELM .GT. 25 ) NDELM = 25
      IF (NRECYS .GE. 12) NDELM = 0
  105 CONTINUE
      CALL WR24
      ISTART = MAX ( NATFIX + 1, NAT - 500)
      ISTORE = MAX ( 2, ISTART )
      ISTORM = ISTORE - 1
      GOTO 113
  109 CONTINUE
      CALL WR24
      WRITE (8, 100) 4
      CALL WILSIN (999)
      CALL ATIN7 (NSET)
      IF (NSET .LE. 0) GOTO 910
      IF (KEYT .EQ. 3) CALL KERROR
     *   (' No anisotr. allowed in AUTOR2 TEST runs', 100, 'AUTOFR')
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
  113 CONTINUE
      IF (LTESTR) THEN
         WRITE(24, 114) NSET
  114 FORMAT (//' ----------------------------------'/
     *          ' AUTOFR: test PATTY Atom Set Nr.', I3//)
         NDELM = 0
         KEYWIL = 0
         NN = MIN0 (3, NAT)
         CALL AT123P (' INPUT', ' ATOMS', 24,  ATNAME, ATXYZ, NN)
         ENDIF
      CALL WR24
      IF (LBINFC)
     *   CALL BINOFF (1, IBINFC,'BINFC', FITFC, NITFC, BUFFC, KENDFC)
      CALL RINI(RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,
     *          RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT)
      DO 117 J = 1, MAXAT
      ATTOT(J) = 0.0
      ATFP4(J) = 0.0
  117 ATFPO(J) = 0.0
      IREFL = 0
      SUMFO2 = 0.
      SUMFP2 = 0.
      RNUM2C = 0.
      RDEN2C = 0.
      TERM2  = 0.
      TERM3  = 0.
      SUMFC2 = 0.
      SUMFO4 = 0.
      SUMFR4 = 0.
      SFPS2  = 0.
      SFPS4  = 0.
      SUME2 = 0.
      SUME1 = 0.
  200 CONTINUE
      IREFL = IREFL + 1
      HCODE = FBINX(1,IREFL)
      FOBS = FBINX(2,IREFL)
      IF (FOBS .LT. 0.) GOTO 220
      SIG = FBINX(3,IREFL)
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      CALL FCALC7 (ATXYZ, ITAT, NAT, ETAO2)
      FP2F2R = FP**2 + (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2
      SUMFO2 = SUMFO2 + FOBS**2
      SUMFP2 = SUMFP2 + FP2F2R
      SUMFC2 = SUMFC2 + FP**2
      FOSC  = FOBS * SCALE
      SUMFR4 = SUMFR4 + (FP**2 - FOSC**2)**2
      SUMFO4 = SUMFO4 + FOSC**4
      CALL R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *             RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2)
      CALL WILSIN (0)
      FOSC   = FOBS * SCALE
      EOBS2  = ( FOSC * FOSC ) / ETAO2
      SUME2 = SUME2 + EOBS2
      SUME1 = SUME1 + ABS(EOBS2 - 1.)
      FPS2   = ( FP * FP ) / ETAO2
      IF (FPS2 .LT. 0.000001) FPS2 = 0.000001
      FPS4   = FPS2 * FPS2
      SFPS2  = SFPS2 + FPS2
      SFPS4  = SFPS4 + FPS4
      FAPM = FAP
      FBPM = FBP
      DO 205 I= 1, ISTORM
      FAPM = FAPM - ATXYZ(8,I)
      FBPM = FBPM - ATXYZ(9,I)
  205 CONTINUE
      FPM  = ASYMCL * SQRT(FAPM*FAPM+FBPM*FBPM)
      FPS2M  = ( FPM * FPM ) / ETAO2
      IF (FPS2M .LT. 0.000001) FPS2M = 0.000001
      FPS4M  = FPS2M * FPS2M
      ATFP4(ISTORM)=ATFP4(ISTORM) + FPS4M
      ATFPO(ISTORM)=ATFPO(ISTORM) - 2 * EOBS2 * FPS2M
      ATTOT(ISTORM)=ATTOT(ISTORM) + FPS4M - 2 * EOBS2 * FPS2M
      DO 210 I= ISTORE, NAT
      FAPM = FAP - ATXYZ(8,I)
      FBPM = FBP - ATXYZ(9,I)
      FPM  = ASYMCL * SQRT(FAPM*FAPM+FBPM*FBPM)
      FPS2M  = ( FPM * FPM ) / ETAO2
      IF (FPS2M .LT. 0.000001) FPS2M = 0.000001
      FPS4M  = FPS2M * FPS2M
      ATFP4(I)=ATFP4(I) + FPS4M
      ATFPO(I)=ATFPO(I) - 2 * EOBS2 * FPS2M
      ATTOT(I)=ATTOT(I) + FPS4M - 2 * EOBS2 * FPS2M
  210 CONTINUE
      TERM2  = TERM2 + FPS4
      TERM3  = TERM3  - 2 * EOBS2 * FPS2
      RNUM2C = RNUM2C + FPS4 - 2 * EOBS2 * FPS2
      RDEN2C = RDEN2C + EOBS2 * EOBS2
      FITFC(1) = FP
      FITFC(2) = PHIP
      IF (LBINFC)
     *   CALL BINOFF (0, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      GOTO 200
  220 CONTINUE
      CALL WR24
      IF (LBINFC)
     *   CALL BINOFF (-1, IBINFC, 'BINFC', FITFC,  NITFC, BUFFC, KENDFC)
      IF (NSET .EQ. 1) WRITE (8, 240) IREFL
  240 FORMAT (' Number of reflections read from file BINFO:', I5)
      SUME2 = SUME2 / FLOAT(NREFL)
      SUME1 = SUME1 / FLOAT(NREFL)
      SUME1X= 0.986
      IF (ICENT .EQ. 1) SUME1X= 0.736
      IF (NSET .LE. 1) WRITE(24, 1242) SUME2, SUME1, SUME1X
 1242 FORMAT (/' Statistics:  <E2> =', F6.3, '  <|E2-1|> =', F6.3/
     *         ' Expected  :  <E2> = 1.000  <|E2-1|> =', F6.3/)
      IF (SUME1 .LT. 0.65) WRITE(24, 1243)
 1243 FORMAT (' Beware of possible twinning !!!!!!!!!!!!!!!!!'/)
      CALL RPR (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *        RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN)
      R2X = RNM2XZ
      CALL WR24
      WRITE (8, 100) 7
      CALL SCALE7
      CALL WR24
      CALL QFOMR2 (2, NSET, RNM2EZ, RNM2XZ, CHIN)
      CALL WR24
      WRITE (8, 100) 8
      R2X = RNM2XZ
      SC98 = SQRT (SUMFC2 / SUMFO2)
      R2FFFF = SUMFR4 / SUMFO4
      WRITE (8, 249) NRECYR, SCALE, SC98, R2FFFF
  249    FORMAT (' $TEX Ncy, SCALE, SC98(Fc/Fo), R2(F2):',
     * I2, 2F8.4, F6.3)
      IF( NDELM.EQ.0 ) GOTO 857
      IF( NAT .EQ. 1 ) GOTO 857
      WRITE (8, 100) 9
      TERM2  = TERM2  / RDEN2C
      EXPRC = 36. * FLOAT(IMULT) / SUMF2(2)
      AVCR = 0.
      NAVCR = 0
      SDCR = 0.
      DO 251 IR = ISTORM, NAT
      ATXYZ(8,IR) = SFPS4 - ATFP4(IR)
      ATXYZ(8,IR) = ATXYZ(8,IR) / RDEN2C
      IF ((ATXYZ(8,IR)) .LT. 0.000001) ATXYZ(8,IR) = 0.000001
      ATXYZ(9,IR) = TERM3 - ATFPO(IR)
      ATXYZ(9,IR) = ATXYZ(9,IR) / RDEN2C
      ATXYZ(10,IR) = ATXYZ(8,IR) + ATXYZ(9,IR)
      ATXYZ(10,IR) = RNUM2C - ATTOT(IR)
      ATXYZ(10,IR) = ATXYZ(10,IR) / RDEN2C
      CR = 10000.
      IF ((ATXYZ(8,IR)) .LT. 0.0000001) CALL KERROR
     *   (' R2-TERM2 too low: impossible??', 244, 'AUTOFR')
      CR = ATXYZ(10,IR) * 36. / ( IZAT(IR)**2 * ATXYZ(4,IR) )
      CR = CR / EXPRC
      ATXYZ(7,IR) = CR
      AVCR = AVCR + CR
      NAVCR= NAVCR + 1
  251 CONTINUE
      IF ( NAVCR .LE. 0 ) THEN
         WRITE(24, FMT='('' SET'', I3,
     *     '' : all atoms increase R2: wrong atom set?'')') NSET
         NAVCR = 1
         ENDIF
      AVCR = AVCR / FLOAT(NAVCR)
      DO 254 IR = ISTORM, NAT
      CR = ATXYZ(7,IR)
      IF ( IR.GT.ISTORM .OR. NATFIX.LE.1 ) THEN
      SDCR = SDCR + (AVCR - CR)**2
      ENDIF
  254 CONTINUE
      SDCR = SQRT ( SDCR / FLOAT(NAVCR) )
      IF (.NOT. LTESTR) WRITE(24, 1250) AVCR, SDCR, NAVCR
      WRITE (8, 1250) AVCR, SDCR, NAVCR
 1250 FORMAT (' Averaged relative contribution:', F6.3,
     *  ' s.d.:', F6.3 , ' for ', I4, ' terms')
      AVSD2 = AVCR + 2. * SDCR
      IF ( PSQ.LT.0.95 .AND. ICYCL.LE.2 ) THEN
         CRTEST = AMIN1( 0.25, AVSD2)
         IF (AVCR.GT.0.0) CRTEST = AMIN1( 0.75, AVSD2)
      ELSE
         CRTEST = AMIN1 (0.5, AVSD2)
         IF (NATRES.LE.2) THEN
            IF (NAT.GT.100) THEN
               SDADD = 0.
               DO 257 IL = NAT-30,NAT
               SDADD = SDADD + SDCR * 0.04
               ATXYZ(7,IL) = ATXYZ(7,IL) + SDADD
  257          CONTINUE
               ENDIF
            ENDIF
         ENDIF
      AVSD1 = AVCR + SDCR
      BADR2 = R2X - RNM2EZ
      IF (R2X .GT. 0.2 .AND. BADR2 .GT. 0.09999)
     *   AVSD1 = AVCR + SDCR * 0.1 / BADR2
      CRTES1 = CRTEST
      IF (BADR2 .GT. 0.1) CRTES1 = AMIN1 (CRTEST, AVSD1)
      CRTEST = AMAX1( CRTEST, AVCR + 0.001)
      IF( CRTEST .LT. -0.5 ) CRTEST = -0.5
      IF (PSQ .GT. 0.90) CRTEST = AMAX1 (CRTEST, 0.5 * PSQ)
      IF (CRTEST .LT. AVCR) CRTEST = AVCR
      IF (.NOT. LTESTR) WRITE (8, 259) CRTES1, CRTEST
  259 FORMAT (' Acceptance criterion for R2-rejection =', F7.3, ' ???'/
     *        ' Acceptance criterion ( heavy atoms !) =', F7.3, ' ???'/
     1        ' Expected relative contribution to R2  = -1.000')
      NDELMC = 0
      DO 263 IR = ISTORM, NAT
      CR = ATXYZ(7,IR)
      IF (LTESTR) THEN
         WRITE(8,261) NSET, IR,
     *      ATNAME(IR),ATXYZ(8,IR),ATXYZ(9,IR),ATXYZ(10,IR), CR
  261 FORMAT(' Set', I3,' Atom', I3, 1X, A6, ' contr. to R2 =', F6.5,
     *      F7.5, ' =', F7.5, ' Rel:', F7.3 )
      ELSE
         IF ((CR .GT. CRTEST .AND. IZAT(IR) .GT. 13) .OR.
     *       (CR .GT. CRTES1 .AND. IZAT(IR) .LE. 13))  THEN
            NDELMC = NDELMC + 1
            IF (NDELM .EQ. 0) WRITE(24,262) IR, ATNAME(IR), CR
            IF (NDELM .NE. 0) WRITE(8,262) IR, ATNAME(IR), CR
  262 FORMAT(' Atom', I3,1X, A6, ' Relative contribution to R2 =', F6.4)
            ENDIF
         ENDIF
  263 CONTINUE
      CALL WR24
      WRITE (8, 100) 10
      NDELM7 =  NDELM
      IF( NAT .GE. 10 .AND. ICYCL .LE. 7 )
     *   NDELM = MAX0( NDELM, INT( FLOAT(NAT)*(RNM2XZ-RNM2EZ)/(PSQ*2.)))
      WRITE (8, FMT='('' $TE NDELM .1. NDELM7 '', 2I3)') NDELM, NDELM7
      IF( NAT .GE. 20 .AND. ICYCL .LE. 7 .AND. PSQ .GT. 0.8)
     *   NDELM = MAX0( NDELM, INT( FLOAT(NAT)*(RNM2XZ-RNM2EZ)/(PSQ)))
      WRITE (8, FMT='('' $TE NDELM .2. NDELM7 '', 2I3)') NDELM, NDELM7
      NDELM = MIN0 (NDELM, NAT*2/3)
      WRITE (8, FMT='('' $TE NDELM .3. NDELM7 '', 2I3)') NDELM, NDELM7
      IF (FLOAT(NDELM)/FLOAT(NAT).LT.0.01*FLOAT(ICYCL-3)) NDELM = 0
      WRITE (8, FMT='('' $TE NDELM .4. NDELM7 '', 2I3)') NDELM, NDELM7
      NDELM = MIN0 ( NDELM, NDELMC )
      WRITE (8, FMT='('' $TE NDELM .!. NDELMC '', 2I3)') NDELM, NDELMC
      IF (NDELM .LT. 0) NDELM = 0
      WRITE (8, FMT='('' $TE NDELM .6. NDELM7 '', 2I3)') NDELM, NDELM7
      IF (NDELM7 .LE. 0 ) THEN
         NDELM = NDELM7
      ELSEIF (NDELM .GE. NDELM7) THEN
         NDELM = NDELM7
      ELSE
         NDELM = (NDELM7 + NDELM) / 2
         ENDIF
      WRITE (8, FMT='('' $TE NDELM Ncy > NDELM '', 2I3)') NRECYR, NDELM
      NDEL =0
      IF (NORECY) THEN
         WRITE (8, FMT='(A)')
     *      ' No rejections if NORECY is given in automatic mode'
         GOTO 857
         ENDIF
      IF (LTESTR) GOTO 857
      IF( NDELM.EQ.0 ) THEN
         WRITE(24,*) 'atom check finished: All input atoms accepted!'
         GOTO 857
         ENDIF
      CALL WR24
      WRITE (8, 100) 11
      IZAV = 0
      Z2TOT = 0.
      DO 267 I = 1, NAT
      Z2TOT = Z2TOT + FLOAT(IZAT(I))**2
  267 IZAV = IZAV + IZAT(I)
      IZ2TOT = NINT (Z2TOT * 0.90)
      ZAV = FLOAT(IZAV) / FLOAT(NAT)
      DO 277 ID = 1, NDELM
      CRMAX = -100.0
      IAD   =  0
      DO 273 IS = ISTART, NAT
      IF ( ATXYZ(8,IS). LT . 0.000001 ) GOTO 273
      IF ( ATXYZ(7,IS) .GT. CRMAX) THEN
         CRMAXT = ATXYZ(7,IS)
         FZAF = SQRT (FLOAT(IZAT(IS)) / ZAV)
         IF (CRMAXT .GT. 0. .AND. FZAF .GT. 1.2) CRMAXT = CRMAXT / FZAF
         IF (CRMAXT .LT. CRMAX) GOTO 273
         CRMAX = CRMAXT
         IAD = IS
         ENDIF
  273 CONTINUE
      IF (CRMAX .LT. CRTEST) GOTO 309
      IF(IAD.EQ.0) GOTO 309
      IZ2TOT = IZ2TOT - IZAT(IAD)**2
      IF (IZ2TOT .LT. 0) GOTO 309
      NDEL = NDEL + 1
      KEYS(2) = NDEL
      WRITE(24,275) IAD, ATNAME(IAD), CRMAX
  275 FORMAT(' Atom', I4, ' = ' , A6,
     1 ' is deleted! (Rel. contribution to R2 =', F7.4, ')')
      TERM2  = TERM2  - ATXYZ(8,IAD)
      TERM3  = TERM3  - ATXYZ(9,IAD) * RDEN2C
      ATXYZ(8,IAD)  = 0.0
      ATXYZ(9,IAD)  = 0.0
      ATXYZ(10,IAD) = -999.
      ISMAX = IFIX (STLMAX * 400. +0.0001) + 2
      ITY = ITAT(IAD)
      DO 276 IS=1,ISMAX
  276 SUMF2P(IS) = SUMF2P(IS) - FF(IS,ITY) * FF(IS,ITY) * ICENT * NSYMM
      PSQ = SUMF2P(2)/SUMF2(2)
  277 CONTINUE
  309 CONTINUE
      IF( NDEL.LE.0 ) THEN
         CALL WR24
         WRITE(24,*) ' atom check finished: All input atoms accepted!'
         GOTO 801
         ENDIF
      CALL WR24
      WRITE (8, 100) 12
      KEYS(2) = NDEL
      WRITE(24, 333) NDEL
  333 FORMAT (' Nr of atoms deleted because of R2: ', I4)
      NATSN = 0
      IF (NATFIX.EQ.0) THEN
         DO 388 IR = 1 ,NATS
  388    IF (ATXYZ(10,IR).LT.-998.) NATSN = NATSN + 1
         ENDIF
      NSC   = NAT
      ISC   = 1
  390 IF (ATXYZ(10,ISC).LT.-998.) THEN
         NSC = NSC - 1
         DO 395 IS2 = ISC, NSC
         ATNAME(IS2) = ATNAME(IS2 + 1)
         IZAT(IS2)   = IZAT(IS2 + 1)
         ITAT(IS2)   = ITAT(IS2 + 1)
         DO 392 NE  = 1, 10
         ATXYZ(NE,IS2) = ATXYZ(NE, IS2 + 1)
  392    CONTINUE
  395    CONTINUE
      ELSE
         ISC = ISC + 1
         ENDIF
      IF ( ISC .LE. (NAT-NDEL) ) GOTO 390
      NAT = NAT - NDEL
      IF (NATSN .GT. 0) THEN
            WRITE(24, 397) NATS, NATSN
  397    FORMAT(' Of the',I4,' original input atoms,',I3,' are deleted')
         NATS = NATS - NATSN
         WRITE (CHOUT,FMT='(''RUN '',I3,'' NEW   NAT= '',I4,
     *       '' KPROG '', I3)') IRUN, NATS, KPROG
         CALL LOGWR (IDDL)
         CALL FILCLO (IDDL, 'KEEP')
         ENDIF
      CALL FCALII
      DO 475 I = 1, NAT
      ATXYZ(8,I)  = -0.000001
      ATXYZ(9,I)  = 0.0
      ATXYZ(10,I) = 0.0
  475 CONTINUE
      CALL WR24
      WRITE (8, 100) 13
      CALL FCALC (NSET, 1)
      IF (NRECYS .LT. 9) RETURN
      KEYD = 3
      CALL WR24
      WRITE (8, 100) 14
      WRITE(24, FMT='(//'' EXIT via AUTOFR ? 13579''//)')
      CALL FILINQ (ICOND, 'CONDA', 'FORMATTED', 'OUTPUT', KINQ)
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ICOND,
     *   FMT = '(''CONDA  '', A6, '' generated by AUTOFR'' )') CCODE
      WRITE (ICOND, FMT = '(''PROGRAM  FOUR'')')
      WRITE (ICOND, FMT = '(''PROGRAM DDMAIN ''/''OPTION 0 FCALC'')')
      WRITE (ICOND, FMT = '(''PROGRAM  NUTS AT2X'')')
      WRITE (ICOND, FMT = '(''FINISH'')')
      WRITE (IDDS, FMT = '(''FOUR'' /''DDMAIN'' /''NUTS'' /''STOP'')')
      CALL FILCLO (ICOND, 'KEEP')
      CALL FILCLO (IDDS, 'KEEP')
      CALL COPY80 (ICOND, ' CONDA' , 9, ' ATPTB' )
      CALL FILCLO (ICOND, 'KEEP')
      CALL FILCLO (9, 'KEEP')
      CALL WR24
      RETURN
  801 CONTINUE
      WRITE (8, 100) 15
  857 CONTINUE
      WRITE (8, 100) 16
      IF (LTESTR) THEN
         WRITE(24, FMT='(/ '' R2 results:''/
     *      '' Set No.  Nr.atoms  p**2  expected R2  actual R2'')')
         WRITE(24, 1254) NSET, NAT, PSQ, RNM2EZ, RNM2XZ
 1254    FORMAT (I7, I8, F9.3, F13.3, F11.3)
      CALL WR24
         IF (RNM2XZ .LT. R2MIN) THEN
            R2MIN = RNM2XZ
            NSETM2 = NSETM
            NSETM = NSET
            ENDIF
         GOTO 109
         ENDIF
      CALL WR24
      WRITE(24,*) 'autofr finished!'
      RETURN
  910 CONTINUE
  911 FORMAT(//' ========================================',
     *        /' AUTOFR tests finished for all atom sets '
     *        /' ========================================'/)
      WRITE(24, 911)
      CALL WR24
      IF (R2MIN .LT. 998.) THEN
         WRITE (9, 1255) R2MIN, NSETM
 1255    FORMAT(' Note: Lowest value of R2 =',F6.3,' for set nr.', I3)
      CALL WR24
         FSETM = NSETM
         FSETM2 = NSETM2
         CALL QFOMR2 (-1, 0, FSETM, FSETM2, CHIN)
         ENDIF
      CALL WR24
      RETURN
      END
      SUBROUTINE FCALC7 (ATXYZ, ITAT, NAT7, ETAO2)
      DIMENSION ATXYZ(10,NAT7), ITAT(NAT7)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      DIMENSION FFF(10), ADTRIG(24)
      DATA  FFF, ADTRIG / 34*0.0 /
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      DO 110 J=1,NTYPE
      IF (CELPAR(J).LE.0.0) GOTO 110
      FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL
  110 CONTINUE
      TBPOV = EXPBP (ISS)
      CALL HKLEX1 (HKLX, HKLX)
      IF (NSYMM.EQ.1) GOTO 150
      DO 140 J=2,NSYMM
      IF (ITRS(J).EQ.0) GOTO 140
      ADTRIG(J) = HKLX(1,1)*TSYMM(1,J) + HKLX(2,1)*TSYMM(2,J) +
     *            HKLX(3,1)*TSYMM(3,J)
  140 CONTINUE
  150 FAP = 0.0
      FBP = 0.0
      DO 250 I=1,NAT
      A1 = 0.
      B2 = 0.
      DO 200 J=1,NSYMM
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      A1 = A1 + SICO(ITRIG + 2500)
      IF (ICENT.NE.2) B2 = B2 + SICO(ITRIG)
  200 CONTINUE
      IF (KEYT .EQ. 1) THEN
         TF = ATXYZ(4,I) * TBPOV
      ELSE
         TF = ATXYZ(4,I) * EXP (-STL2*ATXYZ(5,I))
         ENDIF
      IJ = ITAT(I)
      ATXYZ(8,I) = A1 * FFF(IJ) * TF
      FAP = FAP + ATXYZ(8,I)
      IF (ICENT.EQ.2) GOTO 250
      ATXYZ(9,I) = B2 * FFF(IJ) * TF
      FBP = FBP + ATXYZ(9,I)
  250 CONTINUE
      ETAO2 = SUMF2P(ISS) * EXPBP(ISS) * EXPBP(ISS) +
     *      ( SUMF2(ISS) - SUMF2P(ISS) ) * EXPBR(ISS) * EXPBR(ISS)
      FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP)
      PHIP = 0.0
      IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925
      IF (PHIP.LT.0.0) PHIP = PHIP + 360.
      RETURN
      END
      SUBROUTINE RINI (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,
     * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT)
      IF (ICENT.EQ.1) THEN
         C1 = 4
         C2 = 2
      ELSE
         C1 = 6
         C2 = 3
         ENDIF
      RNUM  = 0.
      RDEN  = 0.
      RNM2XF= 0.
      RDN2XF= 0.
      RNM2EF= 0.
      RNM2XZ= 0.
      RDN2XZ= 0.
      RNM2EZ= 0.
      RDN2EZ= 0.
      SR2NUM= 0.
      SR2DEN= 0.
      RETURN
      END
      SUBROUTINE R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL SWRECY, EXPAND
      EQUIVALENCE (SWRECY, SWITCH(7)), (EXPAND, SWITCH(23))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      INCLUDE 'Zbuff.inc'
      EQUIVALENCE (IBINFC, IFILE(12))
      FOSC  = FOBS * SCALE
      FDEL  = ABS (FOSC-FP)
      RNUM  = RNUM  + FDEL
      RDEN  = RDEN  + FOSC
      ETAC2 = SUMF2P(ISS) * EXPBP(ISS)**2
      ETAO2 = ETAC2 + (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2
      ETA2  = ETAC2 / ETAO2
      EOBS2 = FOSC **2 / ETAO2
      EOBS4 = EOBS2 **2
      ETAEP2 = FP**2 / ETAO2
      EP = FP / ETAC2 **0.5
      RNM2XF = RNM2XF + (EOBS2 - ETAEP2)**2
      RDN2XF = RDN2XF +  EOBS4
      ETA4   = ETA2 * ETA2
      ETA8   = ETA4 * ETA4
      ETA2M4 = ETA2 - ETA4
      RNM2EF = RNM2EF + EOBS4 * (ETA8 - 2*ETA4 + 1) +
     *                  EOBS2 * (C1 * ETA4 - 2) * ETA2M4 +
     *                  C2    * ETA2M4**2
      RDN2EF = RDN2XF
      ETA2  = SUMF2P(2) / SUMF2(2)
      RNM2XZ = RNM2XZ + (EOBS2 - ETA2 * EP**2)**2
      RDN2XZ = RDN2XZ +  EOBS4
      ETA4   = ETA2 * ETA2
      ETA8   = ETA4 * ETA4
      ETA2M4 = ETA2-ETA4
      RNM2EZ = RNM2EZ + EOBS4 * (ETA8 - 2*ETA4 + 1) +
     *                  EOBS2 * (C1 * ETA4 - 2) * ETA2M4 +
     *                  C2    * ETA2M4**2
      RDN2EZ = RDN2XF
      EOBS6  = EOBS2 * EOBS4
      ETA6   = ETA2 * ETA4
      ETA10  = ETA2 * ETA8
      ETA12  = ETA4 * ETA8
      ETA14  = ETA2 * ETA12
      IF(ICENT.EQ.1) THEN
         SR2NUM = SR2NUM +
     *   EOBS6    *  (  8  * ETA14 -  16 * ETA10 +  8 * ETA6 ) *
     *                  ( 1 - ETA2 )    +
     *   EOBS4    *  (  52 * ETA12 -  48 * ETA8  +  4 * ETA4 ) *
     *                  ( 1 - ETA2 )**2 +
     *   EOBS2    *  (  80 * ETA10 -  16 * ETA6 )              *
     *                  ( 1 - ETA2 )**3 +
     *   20 * ETA8 *    ( 1 - ETA2 )**4
      ELSE
         SR2NUM = SR2NUM +
     *   EOBS6    *  ( 16  * ETA14 -  32 * ETA10 + 16 * ETA6 ) *
     *                  ( 1 - ETA2 )    +
     *   EOBS4    *  ( 168 * ETA12 - 144 * ETA8  +  8 * ETA4 ) *
     *                  ( 1 - ETA2 )**2 +
     *   EOBS2    *  ( 384 * ETA10 -  48 * ETA6 )              *
     *                  ( 1 - ETA2 )**3 +
     *   96 * ETA8 *    ( 1 - ETA2 )**4
         ENDIF
      SR2DEN = SR2DEN + EOBS4
      RETURN
      END
      SUBROUTINE RPR(RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF,
     *           RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN)
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (KEYD, KSTAT(19))
      LOGICAL LTESTR
      EQUIVALENCE (LTESTR, SWITCH(27))
      RNUM   = RNUM   / RDEN
      RNM2XF = RNM2XF / RDN2XF
      RNM2XZ = RNM2XZ / RDN2XZ
      RNM2EF = RNM2EF / RDN2EF
      RNM2EZ = RNM2EZ / RDN2EZ
      RNM2EF = RNM2EF**2 + (1.0 - RNM2EF) * SQRT(RNM2EF**2 + 0.0025)
      RNM2EZ = RNM2EZ**2 + (1.0 - RNM2EZ) * SQRT(RNM2EZ**2 + 0.0025)
      IF ( SR2NUM .LT. 0.0 ) SR2NUM = 0.0
      SR2NUM = SR2NUM**0.5
      SR2NUM = SR2NUM / SR2DEN
      R2EX = RNM2EZ
      R1X = RNUM
      IF (LTESTR) RETURN
      CALL WR24
      IF (PSQ .GT. .5) WRITE(24, 251) RNUM
      IF (KEYD .EQ. 0) WRITE (9, 251) RNUM
  251 FORMAT (12X, 'Conventional R-factor =', F7.3)
      CALL WR24
      WRITE (8, 250) RNM2XF,RNM2EF,RNM2XZ,RNM2EZ, RNM2XZ
  250 FORMAT (' R2 (fj) =', F6.3, ' (est.:', F5.3,
     *  ')  R2 (Zj) =', F6.3, ' (est.:', F5.3, ') =====>', F6.3,/)
      WRITE (CHOUT, FMT='('' cycle'', I3)') NRECYR
      IF (KEYS(2) .GT. 0) THEN
         WRITE (CHOUT(24:59), 255) KEYS(2), RNM2EZ
  255    FORMAT ( '-', I3, 14X, F6.3)
      ELSE
         WRITE (CHOUT(13:45), 256) NAT, RNM2EZ
  256    FORMAT ('atoms', I4, 11X, 'R2E=', F6.3)
         ENDIF
      WRITE (CHOUT(51:64), 257) RNM2XZ
  257 FORMAT ('==>  R2=', F6.3)
      KEYS(2) = 0
      IF ( RNM2XZ .LT. 0.0495 ) CHOUT(30:49) = ' '
      WRITE (9, FMT='(A)') CHOUT
      CALL WR24
      IF (NRECYR .EQ. 1) WRITE (8, FMT='('' '')')
      WRITE (8, 301) CCODE, IRUN, NRECYR, NAT, RNUM, RNM2EZ, RNM2XZ
  301 FORMAT (A6,' IRUN',I4, ' Ncy', I3,
     *   ' NAT',I4,' R',F6.3,' R2E',F6.3,' R2',F6.3)
      RETURN
      END
      SUBROUTINE SCASTA
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      INCLUDE 'Zbuff.inc'
      EQUIVALENCE (IBINFC, IFILE(12))
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (KEYWIL, KSTAT(17))
      DIMENSION AVAL(100),BVAL(100),CVAL(200),
     * SCERR(21),IPGO(9,21,3),PGO1(9,21,3),PGO2(9,21,3),FPGOS(2,9,3),
     * FBEX(3),PGOS1(2,9,3),PGOS2(2,9,3),IREFST(2,9,3),SCTAB(2,9,3),
     * RSCTL(2,9,3),RSCNM(2,9,3),RSC(2,9,3),E2SUMT(2,9,3),BPVAR(10,3),
     * BRVAR(10,3),E2FOM(2,9,3)
      EQUIVALENCE (AVAL(1),CVAL(1)), (BVAL(1),CVAL(101))
      LOGICAL   SCOK1, SCOK2, WCHOSE
      PARAMETER (DELTAB = 0.05, DELTAS = 0.02, RAD = 57.29578)
      PARAMETER (BOVVAR = 0.2)
      DATA AVAL /
     * 0.05607, 0.05316, 0.10737, 0.43949, 0.38354, 0.94552, 0.78177,
     * 1.77778,-0.62897, 0.52696, 0.26794, 0.64104,-1.23707, 0.66410,
     * 0.17746, 0.48249,-0.40477,-0.20574, 1.01686,-1.02381,-0.49083,
     *-0.99899,-0.10605, 1.22243,-0.79348,-0.50365, 0.05771, 0.11873,
     *-0.38572,-0.48818, 0.51336,-1.72440, 0.29756, 0.62057,-1.10752,
     *-0.72877, 0.91284,-0.28598,-1.39700,-0.02802,-0.98413,-0.29812,
     * 0.14420,-0.03831, 0.77742,-0.97348, 0.24064, 0.88360,-0.00087,
     * 0.94690,-0.76506, 0.21406, 0.55916, 0.60612, 0.73216,-0.60812,
     *-0.68421, 0.26031,-0.51343,-0.56541,-0.59166, 0.13868, 1.21770,
     *-0.61774, 0.74481,-0.29790,-0.54401,-0.14904, 0.24532,-0.07146,
     *-1.18466,-0.11162, 0.01974, 0.40478,-0.11380, 0.18916,-0.65419,
     * 0.16521,-0.35749, 0.44576, 1.40299,-0.74702,-0.64231, 0.42047,
     * 0.10152,-0.42354,-0.98954,-0.03869,-0.02689,-0.32888,-0.49380,
     * 0.37292,-0.93195, 0.76896, 0.12626, 0.35347,-0.72071, 0.33275,
     *-0.34783, 0.03697 /
      DATA BVAL /
     *-0.03907,-1.75002,-0.06408, 1.12202,-0.24004,-0.66600,-0.11809,
     *-1.40804,-1.42002,-0.24606,-0.88801, 0.52319,-0.64014, 0.34116,
     * 0.29016,-0.28116,-0.14612, 0.24712, 0.47915,-0.28316,-0.48419,
     *-1.24918,-0.84426, 1.10029, 1.17727, 0.76122, 0.86424, 0.25520,
     * 0.52625,-0.99430, 0.06231,-0.58133, 0.29139, 1.01030,-0.79730,
     * 0.23834, 0.25831, 2.00439, 0.59242,-0.90149, 0.09043, 0.54341,
     * 0.45847, 0.93748,-0.03748,-0.07542, 0.47249, 0.61343,-0.26141,
     * 1.63743,-0.34850,-0.11253,-0.23654, 0.30458, 0.07050,-0.16750,
     *-1.13557,-0.26351, 0.87757,-0.58550, 0.24956,-0.64854, 0.24951,
     *-1.58359,-0.79956, 1.46555, 0.04664,-0.41467, 0.42766,-0.56565,
     *-0.86260,-0.74867, 0.30365, 0.22761, 0.68965,-0.06278, 0.70473,
     * 0.68972, 0.00874, 0.23871, 0.33476,-1.04381,-0.61488, 1.28188,
     * 1.22180, 1.09083,-0.28580,-0.59186,-1.14085, 0.73180, 0.87385,
     * 0.14382,-0.85487,-1.05181,-0.18495, 0.15194,-0.04698,-0.81092,
     *-0.98992, 0.16298 /
      DATA SCMIN1, BPMIN1, BRMIN1 / 0., 0., 0. /
      DATA SCMIN2, BPMIN2, BRMIN2 / 0., 0., 0. /
      DATA SCMIN3, BPMIN3, BRMIN3 / 0., 0., 0. /
      CALL WR24
      IF (KEYWIL .EQ. 4) RETURN
      FKEYP2 = PSQ / SQRT(FLOAT(NAT))
      FCRIT=0.23
      PSQCRT=0.3
      IF (FKEYP2 .LT. FCRIT .OR. PSQ .LT. PSQCRT) THEN
         WRITE (8, 55)
  55     FORMAT(' Known fragment is small: Smykalla-refinement',
     *         ' is not executed!')
         WRITE (8, 56) PSQ, FKEYP2
  56        FORMAT(' TEMP: p**2 and FPKEY2 are ',F5.2,' and ',F5.2)
         RETURN
         ENDIF
      EGRENS=AMAX1(PSQ,0.5)
      WCHOSE=.TRUE.
      IUNOBS=0
      IREF=0
      ITAB1=0
      ITAB2=0
      ITAB3=0
      SQ2=SQRT(2.)
      ZRTMP=0.
      ZRTMPX=0.
      ZPTMPX=0.
      BRX=0.
      BPX=0.
      YX=0.
      BOV = BOVMER
      DO 100 ISC=1,21
  100   SCERR(ISC)=SCAMER*(1.+FLOAT(ISC-11)*DELTAS)
      CALL KERNZI (0, IPGO,567)
      CALL KERNZA (0.,FPGOS,54)
      CALL KERNZI (0, IREFST,54)
      CALL KERNZA (0.,PGO1,567)
      CALL KERNZA (0.,PGO2,567)
      CALL KERNZA (0.,PGOS1,54)
      CALL KERNZA (0.,PGOS2,54)
      CALL KERNZA (0.,BRVAR,30)
      CALL KERNZA (0.,BPVAR,30)
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      BPINP=BP
      IEXS=1
      EXVAR1=0.
      EXVAR2=0.
      E2AVE=0.
      RSCAVE=0.
      E2SDIF=0.
      RSCDIF=0.
      IAVE=0
      IREFX = 0
  130 CONTINUE
      IREFX = IREFX + 1
      HCODE = FBINX(1,IREFX)
      FOBS = FBINX(2,IREFX)
      IF (FOBS .LT. 0.) GOTO 210
      SIG = FBINX(3,IREFX)
      CALL BINIFF (0, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'SCASTA')
      FP = FITFC(1)
      PHIP = FITFC(2)
      IF (FP .LT. -990.) GOTO 130
      JCODE=1
      IF (FOBS.LT.5.*SIG) JCODE=2
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL*400. + 1.5)
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = IEPS
      SUMF2R=SUMF2(ISS)-SUMF2P(ISS)
      ZTMP = SQRT (SUMF2(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZPTMP= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZRTMP= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BOV*STL2)
      YBOV = FP * EXP((-BOV+BPINP)*STL2)
      Y    = FP * EXP((-BP+BPINP)*STL2)
      IF (ABS(Y) .LT. 0.0001) GOTO 130
      IF (ICENT.EQ.1) THEN
        IF (ITAB1.EQ.100) ITAB2=ITAB2+1
        ITAB1 = MOD(ITAB1,100)+1
        ITAB2 = MOD(ITAB2,100)+1
        ER = SQRT(AVAL(ITAB1)**2+BVAL(ITAB2)**2)
        PHIR = ATAN2(BVAL(ITAB2),AVAL(ITAB1))
      ELSE
        ITAB3= MOD(ITAB3,200)+1
        ER = 0.
        PHIR = 0.
      ENDIF
      EOB = (SCALE * FOBS) / ZTMP
      IF (EOB.GT.EGRENS) THEN
         IF (JCODE.EQ.2) IUNOBS = IUNOBS+1
         IREF=IREF+1
         ENDIF
      FBEX(1)=-1*BOVVAR
      FBEX(2)=0.
      FBEX(3)=BOVVAR
      IF (BOV.LT.BOVVAR*2) THEN
        FBEX(1)=AMIN1(BOV,BOVVAR)-BOV
        IF (ABS(FBEX(1)).LT.0.00001) IEXS=2
      ENDIF
      IF (BOV.GT.BOVVAR*10) THEN
        FBEX(1)=-0.1*BOV
        FBEX(3)=0.1*BOV
      ENDIF
      DO 140 IB=1,10
      DO 140 IEX=IEXS,3
      BOVCOR=EXP(-1*FBEX(IEX)*STL2)
      IF ((IB.EQ.10.AND.IEX.EQ.1).OR.(IB.EQ.10.AND.IEX.EQ.2)) GOTO 140
      IF (IB.LT.10) THEN
      IF (PSQ.GT.0.5) THEN
        BRVAR(IB,IEX) = (BOV+FBEX(IEX))*(FLOAT(IB-5)*DELTAB)
        BPVAR(IB,IEX) = (BRVAR(IB,IEX) * (PSQ-1))/PSQ
      ELSE
        BPVAR(IB,IEX) = (BOV+FBEX(IEX)) * (FLOAT(IB-5)*DELTAB)
        BRVAR(IB,IEX) = (BPVAR(IB,IEX)*PSQ)/(PSQ-1)
      ENDIF
        EXVAR1 = EXP(-BRVAR(IB,IEX)*STL2)
        EXVAR2 = EXP(-BPVAR(IB,IEX)*STL2)
      ENDIF
        IF (IB.EQ.10) THEN
          ZRTMPX= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2)
          ZPTMPX= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BP*STL2)
          YX=Y
        ELSE
          ZRTMPX = ZRTMP * EXVAR1 * BOVCOR
          ZPTMPX = ZPTMP * EXVAR2 * BOVCOR
          YX = YBOV * EXVAR2 * BOVCOR
        ENDIF
        FPX=0.
        IF (ICENT.EQ.1) THEN
          FPX= YX * COS(PHIP/RAD)
          FRSTAT=ER*ZRTMPX
          XO= FPX+(FRSTAT*COS(PHIR))
          YO= (YX*SIN(PHIP/RAD))+(FRSTAT*SIN(PHIR))
          FO= SQRT((XO**2)+(YO**2))
        ELSE
          FRX= CVAL(ITAB3)*ZRTMPX*SQ2
          FO= ABS(YX+FRX)
        ENDIF
        EO= FO/SQRT(ZPTMPX**2+ZRTMPX**2)
        IF (IB.LT.10) THEN
        DO 135 IEO=0,1
         EGR=EGRENS+(IEO*0.1)
         JEO=IEO+1
         IF (EO.GT.EGR) THEN
         IREFST(JEO,IB,IEX) = IREFST(JEO,IB,IEX)+1
         IF (ABS(YX).GT.FO) FPGOS(JEO,IB,IEX)=FPGOS(JEO,IB,IEX)+1.
           IF (WCHOSE) THEN
             PGOS1(JEO,IB,IEX)=PGOS1(JEO,IB,IEX)+
     *                           ((ABS(YX)-FO)/SQRT(SUMF2(ISS)))
             PGOS2(JEO,IB,IEX)=PGOS2(JEO,IB,IEX)+
     *                           (ABS(YX)/SQRT(SUMF2(ISS)))
           ELSE
             PGOS1(JEO,IB,IEX)=PGOS1(JEO,IB,IEX)+(ABS(YX)-FO)
             PGOS2(JEO,IB,IEX)=PGOS2(JEO,IB,IEX)+ABS(YX)
           ENDIF
         ENDIF
  135  CONTINUE
       ENDIF
       IF (IB.LT.10) THEN
       IF (EOB.GT.EGRENS) THEN
         DO 150 ISC=1,21
         FSC = FOBS * SCERR(ISC)
           IF (ABS(YX).GT.FSC) IPGO(IB,ISC,IEX)=IPGO(IB,ISC,IEX)+1
           IF (WCHOSE) THEN
             PGO1(IB,ISC,IEX)=PGO1(IB,ISC,IEX)+
     *                     ((ABS(YX)-FSC)/SQRT(SUMF2(ISS)))
             PGO2(IB,ISC,IEX)=PGO2(IB,ISC,IEX)+
     *                     (ABS(YX)/SQRT(SUMF2(ISS)))
           ELSE
             PGO1(IB,ISC,IEX)=PGO1(IB,ISC,IEX)+(ABS(YX)-FSC)
             PGO2(IB,ISC,IEX)=PGO2(IB,ISC,IEX)+ABS(YX)
           ENDIF
  150   CONTINUE
      ENDIF
      ENDIF
  140 CONTINUE
      GOTO 130
  210 DO 215 IB=1,9
      DO 215 IEX=IEXS,3
      FRFDIF=FLOAT(ABS(IREFST(1,IB,IEX)-IREFST(2,IB,IEX)))
      IF(FRFDIF.GT.0.001) THEN
        FINTPO=FLOAT(IREFST(2,IB,IEX)-IREF)/FRFDIF
      ELSE
        FINTPO = 0.0
      ENDIF
      FPGOSD=FPGOS(2,IB,IEX)-FPGOS(1,IB,IEX)
      PGOSD1=PGOS1(2,IB,IEX)-PGOS1(1,IB,IEX)
      PGOSD2=PGOS2(2,IB,IEX)-PGOS2(1,IB,IEX)
      FPGOS(1,IB,IEX)=FPGOS(2,IB,IEX)+FINTPO*FPGOSD
      PGOS1(1,IB,IEX)=PGOS1(2,IB,IEX)+FINTPO*PGOSD1
      PGOS2(1,IB,IEX)=PGOS2(2,IB,IEX)+FINTPO*PGOSD2
  215 CONTINUE
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      DO 230 IB=1,9
      DO 230 IEX=IEXS,3
      FOMOL1=0.
      FOMOL2=0.
      SCOKE1=0.
      SCOKE2=0.
      SCOK1=.FALSE.
      SCOK2=.FALSE.
      FOM1ST=FPGOS(1,IB,IEX)/FLOAT(IREF)
      FOM2S=PGOS1(1,IB,IEX)/PGOS2(1,IB,IEX)
      DO 220 ISC=1,21
      FOM1=(FLOAT(IPGO(IB,ISC,IEX))/FLOAT(IREF))-FOM1ST
      FOM2=(PGO1(IB,ISC,IEX)/PGO2(IB,ISC,IEX))-FOM2S
      IF (ISC.NE.1) THEN
        SCDIF=SCERR(ISC)-SCERR(ISC-1)
        IF (.NOT. SCOK1) THEN
          IF (FOM1.LE.0) THEN
            FOMDIF=ABS(FOM1-FOMOL1)
            SCOKE1=SCERR(ISC)+((FOM1/FOMDIF)*SCDIF)
            SCOK1=.TRUE.
          ELSE
            IF (ISC.EQ.21) SCOKE1=SCERR(ISC)
          ENDIF
        ENDIF
        IF (.NOT. SCOK2) THEN
          IF (FOM2.LE.0.) THEN
            FOMDIF=ABS(FOM2-FOMOL2)
            SCOKE2=SCERR(ISC)+((FOM2/FOMDIF)*SCDIF)
            SCOK2=.TRUE.
          ELSE
            IF (ISC.EQ.21) SCOKE2=SCERR(ISC)
          ENDIF
        ENDIF
      ELSE
        IF (FOM1.LE.0) THEN
          SCOKE1=SCERR(1)
          SCOK1=.TRUE.
        ENDIF
        IF (FOM2.LE.0) THEN
          SCOKE2=SCERR(1)
          SCOK2=.TRUE.
        ENDIF
      ENDIF
      FOMOL1=FOM1
      FOMOL2=FOM2
  220 CONTINUE
      SCTAB(1,IB,IEX)=SCOKE1
      SCTAB(2,IB,IEX)=SCOKE2
  230 CONTINUE
      WRITE(8,243)
  243 FORMAT (' ')
      WRITE(8,244)
      WRITE(24,244)
  244 FORMAT (' New refinement of SCALE, Bp and Br:',
     *' (Israel et al., Z. f. Krist., 1995)')
      WRITE(8,FMT='(''  Bp     Br      scale     Ra  '',
     * ''     DaRa     Rb       DbRb     FOM3'')')
      CALL KERNZA(0.,E2SUMT,54)
      CALL KERNZA(0.,E2FOM,54)
      CALL KERNZA(0.,RSCTL,54)
      CALL KERNZA(0.,RSCNM,54)
      CALL KERNZA(0.,RSC,54)
      RSCTL2=0.
      RSCNM2=0.
      E2SMT2=0.
      FOMMN1=999.
      FOMMN2=999.
      FOMMN3=999.
      ITPX = 0
      IREFX = 0
  250 CONTINUE
      IREFX = IREFX + 1
      HCODE = FBINX(1,IREFX)
      FOBS = FBINX(2,IREFX)
      IF (FOBS .LT. 0.) GOTO 310
      SIG = FBINX(3,IREFX)
      CALL BINIFF (0, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'SCASTA')
      FP = FITFC(1)
      PHIP = FITFC(2)
      IF (FP .LT. -990.) GOTO 250
      JCODE=1
      IF (FOBS.LT.5.*SIG) JCODE=2
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL*400. + 1.5)
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      SUMF2R=SUMF2(ISS)-SUMF2P(ISS)
      ZTMP = SQRT (SUMF2(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZRTMP= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BOV*STL2)
      ZPTMP= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2)
      YBOV = FP * EXP((-BOV+BPINP)*STL2)
      Y    = FP * EXP((-BP+BPINP)*STL2)
      DO 280 IFOM=1,3
      M=3
      N=9
      IF (IFOM.EQ.3) THEN
        M=IEXS
        N=1
      ENDIF
      DO 280 IB=1,N
      DO 280 IEX=IEXS,M
      BOVCOR=EXP(-1*FBEX(IEX)*STL2)
      IF (IFOM.NE.3) THEN
        EXVAR1 = EXP(-BRVAR(IB,IEX)*STL2)
        EXVAR2 = EXP(-BPVAR(IB,IEX)*STL2)
        ZRTMPX = ZRTMP * EXVAR1 * BOVCOR
        ZPTMPX = ZPTMP * EXVAR2 * BOVCOR
        YX = YBOV * EXVAR2 * BOVCOR
        FSC=FOBS*SCTAB(IFOM,IB,IEX)
      ELSE
        ZRTMPX = SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2)
        YX = Y
        FSC=FOBS*SCALE
      ENDIF
      FONRM = (FSC*FSC)/SUMF2(ISS)
      FPNRM = (YX*YX)/SUMF2(ISS)
      FRNRM = (ZRTMPX*ZRTMPX)/SUMF2(ISS)
      IF (IFOM.NE.3) THEN
        RSCTL(IFOM,IB,IEX)=RSCTL(IFOM,IB,IEX)+(FONRM-FPNRM-FRNRM)**2
        RSCNM(IFOM,IB,IEX)=RSCNM(IFOM,IB,IEX)+FONRM**2
      ELSE
        RSCTL2=RSCTL2+(FONRM-FPNRM-FRNRM)**2
        RSCNM2=RSCNM2+FONRM**2
      ENDIF
      ITPX = IPHFIX(HKLX) - 1
      E1T = (FSC-YX) / ZRTMPX
      E1ST = ABS(E1T)
      IF (E1ST.GT.4.) E1ST = 4.
      IF (JCODE.LE.1) GOTO 270
      IF (E1T.GT.0.) GOTO 260
      E1T = (1.4*FSC - YX)/ZRTMPX
      IF (E1T.GT.0.) E1 = 0.0
      GOTO 270
  260 E1T = (0.7*FSC - YX)/ZRTMPX
      IF (E1T.LT.0.0) E1T = 0.0
  270 E2T = (FSC+YX) / ZRTMPX
      IF (JCODE.GT.1) E2T = AMAX1(YX/ZRTMPX, E1T)
      CALL W1PROB (ITPX, E1T, E2T, PT)
      EEX = E2EXP(ITPX, E1ST, E2T)
      IF (IFOM.NE.3) THEN
        E2SUMT(IFOM,IB,IEX) = E2SUMT(IFOM,IB,IEX) + EEX
      ELSE
        E2SMT2=E2SMT2+EEX
      ENDIF
  280 CONTINUE
      GOTO 250
  310 DO 320 IFOM=1,2
      DO 320 IB=1,9
      DO 320 IEX=IEXS,3
        E2SUMT(IFOM,IB,IEX)=E2SUMT(IFOM,IB,IEX)/FLOAT(NREFL)
        E2FOM(IFOM,IB,IEX)=0.
        IF (E2SUMT(IFOM,IB,IEX).LT.1.0)
     *           E2FOM(IFOM,IB,IEX)=2*ABS(1.0-E2SUMT(IFOM,IB,IEX))
        IF (E2SUMT(IFOM,IB,IEX).GT.1.1)
     *           E2FOM(IFOM,IB,IEX)=ABS(1.1-E2SUMT(IFOM,IB,IEX))
        E2AVE=E2AVE+E2FOM(IFOM,IB,IEX)
        RSC(IFOM,IB,IEX)=RSCTL(IFOM,IB,IEX)/RSCNM(IFOM,IB,IEX)
        RSCAVE=RSCAVE+RSC(IFOM,IB,IEX)
        IAVE=IAVE+1
  320 CONTINUE
      E2SMT2=E2SMT2/NREFL
      E2FOM2=0.
      IF (E2SMT2.LT.1.0) E2FOM2=2*ABS(1.0-E2SMT2)
      IF (E2SMT2.GT.1.1) E2FOM2=ABS(1.1-E2SMT2)
      IAVE=IAVE+1
      E2AVE=(E2AVE+E2FOM2)/FLOAT(IAVE)
      RSC2=RSCTL2/RSCNM2
      RSCAVE=(RSCAVE+RSC2)/FLOAT(IAVE)
      DO 321 IFOM=1,2
      DO 321 IB=1,9
      DO 321 IEX=IEXS,3
        ATERM=ABS(E2FOM(IFOM,IB,IEX)-E2AVE)
        BTERM=ABS(RSC(IFOM,IB,IEX)-RSCAVE)
        E2SDIF=E2SDIF+ATERM
        RSCDIF=RSCDIF+BTERM
  321 CONTINUE
      ATERM=ABS(E2FOM2-E2AVE)
      BTERM=ABS(RSC2-RSCAVE)
      E2SDIF=AMAX1((E2SDIF+ATERM)/FLOAT(IAVE),0.1)
      RSCDIF=AMAX1((RSCDIF+BTERM)/FLOAT(IAVE),0.01)
      FOM3P1=RSCDIF*E2FOM2
      FOM3P2=E2SDIF*RSC2
      FOM3=FOM3P1+FOM3P2
      WRITE(8,FMT='(2F7.4, 6F9.4)')
     *    BP,BR,SCALE,E2FOM2,FOM3P1,RSC2,FOM3P2, FOM3
      IF (FOM3.LT.FOMMN1) THEN
        FOMMN1=FOM3
        SCMIN1=SCALE
        BPMIN1=BP
        BRMIN1=BR
      ENDIF
      DO 330 IFOM=1,2
        WRITE(8,FMT='('' FOM'',I1,''-------------------'')')IFOM
      DO 330 IB=1,9
      DO 330 IEX=IEXS,3
        BPX = (BOV+FBEX(IEX)) + BPVAR(IB,IEX)
        BRX = (BOV+FBEX(IEX)) + BRVAR(IB,IEX)
        FOM3P1=RSCDIF*E2FOM(IFOM,IB,IEX)
        FOM3P2=E2SDIF*RSC(IFOM,IB,IEX)
        FOM3=FOM3P1+FOM3P2
        IF (FOM3.LT.FOMMN1) THEN
          FOMMN3=FOMMN2
          BPMIN3=BPMIN2
          BRMIN3=BRMIN2
          SCMIN3=SCMIN2
          FOMMN2=FOMMN1
          BPMIN2=BPMIN1
          BRMIN2=BRMIN1
          SCMIN2=SCMIN1
          FOMMN1=FOM3
          BPMIN1=BPX
          BRMIN1=BRX
          SCMIN1=SCTAB(IFOM,IB,IEX)
          GOTO 329
        ENDIF
        IF ((FOM3.LT.FOMMN2).AND.(FOM3.GT.FOMMN1))THEN
          FOMMN3=FOMMN2
          BPMIN3=BPMIN2
          BRMIN3=BRMIN2
          SCMIN3=SCMIN2
          FOMMN2=FOM3
          BPMIN2=BPX
          BRMIN2=BRX
          SCMIN2=SCTAB(IFOM,IB,IEX)
          GOTO 329
        ENDIF
        IF ((FOM3.LT.FOMMN3).AND.(FOM3.GT.FOMMN2)) THEN
          FOMMN3=FOM3
          BPMIN3=BPX
          BRMIN3=BRX
          SCMIN3=SCTAB(IFOM,IB,IEX)
        ENDIF
  329   WRITE(8,FMT='(2F7.4, 6F9.4)')
     *     BPX,BRX,SCTAB(IFOM,IB,IEX),
     *     E2FOM(IFOM,IB,IEX),FOM3P1,RSC(IFOM,IB,IEX),FOM3P2,FOM3
  330 CONTINUE
      WRITE(8,FMT='('' Best solutions: '')')
      WRITE(8, 333) BPMIN1, BRMIN1, SCMIN1, FOMMN1
      WRITE(8, 333) BPMIN2, BRMIN2, SCMIN2, FOMMN2
      WRITE(8, 333) BPMIN3, BRMIN3, SCMIN3, FOMMN3
  333 FORMAT (' Bp ',F7.3, ' Br ', F7.3, ' Sc ',F7.3,' FOM3 ',F7.5)
      WRITE (8, 334)
  334 FORMAT (' We selected the first solution for further',
     * ' calculations!')
      WRITE(24, 335)
  335 FORMAT (' New values are:')
      SCALE=SCMIN1
      BP=BPMIN1
      BR=BRMIN1
      WRITE(24, 336) BP, BR, SCALE
  336 FORMAT (' Bp =', F6.3, '  Br = ', F6.3, '  Scale = ', F9.5)
      WRITE (CHOUT, 337) SCALE, BP, BR
  337 FORMAT ('SCALE ', F14.7, ' BP ', F11.5, ' BR ', F10.5)
      CALL LOGWR (IDDL)
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      CALL WR24
      END
      SUBROUTINE GETR2X (KEY, IATT, IRUN, KEND)
      INCLUDE 'Zaaaa.inc'
      KEND = 0
      IF (KEY .NE. 0) GOTO 813
      CALL KERNZA (-1.0, R2CYC, MRECY)
      NCYT = 0
      NCY = 0
      CALL FILINQ (IATT, 'ATTEM', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) RETURN
  313 CALL KERINA (IATT,  LIT, 1, LEND)
      IF (LEND .EQ. 5) GOTO 713
      IF (LEND .LT. 0) GOTO 713
      IF (LIT(1) .NE. 'ATOMS') GOTO 313
      CALL KERING ('RUN', N, KTOT)
      IF (N .LE. 0) GOTO 313
      NRUN = NINT (FNUM(N))
      IF (NRUN .NE. IRUN) GOTO 313
      CALL KERING ('CY=', N, KTOT)
      IF (N .LE. 0) GOTO 313
      NCYT = NINT (FNUM(N))
      IF (NCYT .LE. 0 .OR. NCYT .GT. 20) GOTO 313
      CALL KERING ('R2X=', N, KTOT)
      IF (N .LE. 0) GOTO 313
      R2X = FNUM(N)
      IF (R2X .LE. -0.001 .OR. R2X .GT. 9.999) GOTO 313
      NCY = NCYT
      R2CYC(NCY) = R2X
      GOTO 313
  713 CALL FILCLO (IATT, 'KEEP')
      KEND = NCY
      CALL WR24
      WRITE (8, 714) (I, I=1,10), (R2CYC(J), J=1,NCY)
  714 FORMAT (/' For cycle nr', I4, 9I6/
     *         ' R2 values: ', 10F6.3/ 12X, 10F6.3)
      RETURN
  813 CONTINUE
      CALL FILINQ (IATT, 'ATTEM', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) RETURN
      KEY1 = KEY - 1
  823 CALL KERINA (IATT,  LIT, 1, LEND)
      IF (LEND .EQ. 5) GOTO 893
      IF (LEND .LT. 0) GOTO 893
      IF (LIT(1) .NE. 'ATOMS') GOTO 823
      CALL KERING ('RUN', N, KTOT)
      IF (N .LE. 0) GOTO 823
      NRUN = NINT (FNUM(N))
      IF (NRUN .NE. IRUN) GOTO 823
      CALL KERING ('CY=', N, KTOT)
      IF (N .LE. 0) GOTO 823
      NCYT = NINT (FNUM(N))
      IF (NCYT .LT. KEY1) GOTO 823
      IF (NCYT .GT. KEY1) CALL KERROR (' ?? ', 823, 'GETR2X')
      CALL KERING ('R2X=', N, KTOT)
      IF (N .LE. 0) GOTO 823
      KEND = 1
      BACKSPACE IATT
      RETURN
  893 CALL FILCLO (IATT, 'KEEP')
      RETURN
      END
      SUBROUTINE KERING (ALI, KEND, KTOT)
      CHARACTER ALI *(*)
      INCLUDE 'Zsyst.inc'
      CHARACTER * 6  ALIT
      ALIT = ALI
      KTOT = 0
      IF (NLIT .LE. 0) GOTO 202
      DO 200 L = 1, NLIT
      IF (LIT(L) .NE. ALIT) GOTO 200
      LCOL = NCOLL(L)
      LCOL2 = 99
      IF (L .LT. NLIT) LCOL2 = NCOLL(L+1)
      IF (LCOL2 .LT. 0) LCOL2 = 99
      GOTO 250
  200 CONTINUE
  202 KEND = -1
      RETURN
  250 IF (NFNUM .LE. 0) GOTO 302
      DO 300 N = 1, NFNUM
      NCOL = NCOLN(N)
      IF (NCOL .LE. 0) GOTO 302
      IF (NCOL .LT. LCOL) GOTO 300
      IF (NCOL .GT. LCOL2) GOTO 302
      GOTO 400
  300 CONTINUE
  302 KEND = -2
      RETURN
  400 CONTINUE
      KEND = N
      KTOT = 1
  460 CONTINUE
      IF (N .GE. NFNUM) RETURN
      N = N + 1
      IF (NCOLN(N) .GT. LCOL2) RETURN
      KTOT = KTOT + 1
      GOTO 460
      END
      SUBROUTINE DICALC
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (IBINFC, IFILE(12))
      EQUIVALENCE (KEYD, KSTAT(19))
      EQUIVALENCE (KEYDS, KSTAT(20))
      LOGICAL EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      DIMENSION IHKL(3), HKLXX(3,24)
      KEYDX = KEYD
      KEYRET = 0
      IF (KEYD.EQ.1) WRITE (8, FMT =
     *    '(/'' ****** Prepare input for program PHASEX ******''/)')
      IF (KEYD.EQ.2 .OR. KEYD.EQ.3) WRITE (8, FMT =
     *    '(/'' ****** Prepare input for program FOUR ******''/)')
  200 IF (KEYD.NE.4) CALL DIDUAL (-1)
      IF (KEYD.EQ.2 .OR. KEYD.EQ.3) CALL DIFFT (-1)
      IF (KEYD.EQ.4) CALL DIPATT (-1)
      ITP = 0
      LOOPFP = 1
      IF (EXPAND) LOOPFP = NSYMM
      NR = 0
      EPSIL2 = 1.
      IREFX = 0
  210 KEYDX = KEYD
      IREFX = IREFX + 1
      HCODE = FBINX(1,IREFX)
      FOBS = FBINX(2,IREFX)
      IF (FOBS .LT. 0.) GOTO 230
      SIG = FBINX(3,IREFX)
      IF (KEYD.EQ.4) GOTO 215
      IF (.NOT. EXPAND) THEN
         CALL BINIFF (0, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
         FP = FITFC(1)
         PHIP = FITFC(2)
      ELSE
         CALL BINIFF (0, IBINFC, 'BINFC2', FITFC2, NITFC2,BUFFC,KENDFC)
         EPSIL2 = FITFC2(1)
         SF2 = FITFC2(2)
         SF2P = FITFC2(3)
         CALL KERNAB (FITFC2(4), FPEXP, NITFC2-3)
         ENDIF
      IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'DICALC')
      IF (EXPAND) THEN
         IF (EPSIL2.LT.-990.) GOTO 210
      ELSE
         IF (FP.LT.-990.) GOTO 210
         ENDIF
  215 JCODE = 1
      IF (FOBS .LT. 5.*SIG) JCODE = 2
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL * 400. + 1.5)
      SUMF2R = SUMF2(ISS) - SUMF2P(ISS)
      IF (SUMF2R.LT.0.001) SUMF2R = 0.001
      X = FOBS * SCALE
      XSIG = SIG * SCALE
      IF (KEYD.EQ.4) THEN
         NR = NR + 1
         CALL DIPATT (0)
         GOTO 210
         ENDIF
      IF (EXPAND) CALL HKLEX1 (HKLX, HKLXX)
      DO 229 IFP=1,LOOPFP
      IF (EXPAND) THEN
          KEYDX = KEYD
          FP   = FPEXP(1,IFP)
          IF (FP .LT. 0.0) GOTO 229
          PHIP = FPEXP(2,IFP)
          HKLX(1,1) = HKLXX(1,IFP)
          HKLX(2,1) = HKLXX(2,IFP)
          HKLX(3,1) = HKLXX(3,IFP)
          CALL HKLC1 (HKLX, HCODE)
          ENDIF
      NR = NR + 1
      IF (KEYT.EQ.1) THEN
          Y = FP * EXP(-BP*STL2)
      ELSE
          Y = FP
          ENDIF
      IF (EXPAND) GOTO 221
      ITP = IPHFIX(HKLX) - 1
      IF (ITP .LT. -1) THEN
          CALL KERF2I (HKLX, IHKL, 3)
          WRITE(24, 220) (IHKL(I), I=1,3)
  220     FORMAT (' Reflection ',3I3, ' gives impossible phase restr.')
          CALL KERNER (220, 'DICALC')
          ENDIF
  221 IF (KEYD.EQ.2) CALL DIFFT (0)
      IF (KEYD.EQ.3 .AND. KEYDS.GE.4) GOTO 228
      IF (KEYDX.NE.2) CALL DIDUAL (0)
  228 IF (KEYDX.EQ.3) CALL DIFFT (0)
  229 CONTINUE
      GOTO 210
  230 IF (KEYD .EQ. 2 .OR. KEYD .EQ. 3) CALL FILCLO (IBINFC, 'DELETE')
      IF (KEYD.EQ.2) THEN
         CALL DIFFT (1)
         RETURN
         ENDIF
      IF (KEYD.EQ.4) THEN
         CALL DIPATT (1)
         RETURN
         ENDIF
      IF (KEYD.EQ.3 .AND. KEYDS.GE.4) THEN
         CALL DIFFT (1)
         RETURN
         ENDIF
      CALL DIDUAL (1)
      IF (IDOKA .EQ. 17) RETURN
      IF (KEYRET.LT.10) GOTO 200
      IF (KEYD.EQ.3) CALL DIFFT (1)
      RETURN
      END
      SUBROUTINE DIDUAL (KEY)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zddif.inc'
      EQUIVALENCE (NOPHAS, KSTAT(3))
      LOGICAL      SWPRI, EXPAND
      EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (IDDL, IFILE(1)), (IDDS, IFILE(2))
      EQUIVALENCE (IE100,  IFILE(10)), (ICOND,  IFILE(4))
      EQUIVALENCE (IBINFC, IFILE(12))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINFF, IFILE(16))
      EQUIVALENCE (KEYD, KSTAT(19))
      EQUIVALENCE (FITDUA(4), ZSCATT), (FITDUA(5), P1), (FITDUA(6), P2),
     *            (FITDUA(7), W1)
      PARAMETER (PSQMIN = 0.15, E1MINP = 0.9)
      DIMENSION  DEG(8), IHKL(3), W1LIM(6), EPLIM(6)
      DIMENSION HKLM(3), HKLMA(3), HKLMI(3)
      CHARACTER * 7 RESTR(9)
      DATA ESUMMI /  .50  /
      DATA W1LIM  /  .001, .050, .200, .800,  .999,  1.000  /
      DATA EPLIM  /  .01,  .20,  .60, 1.00,  1.50,  10.000  /
      DATA DEG    / 0., 30., 45., 60., 90., 120., 135., 150. /
      DATA RESTR  / '   NONE', '  0/180', ' 30/210',
     *              ' 45/225', ' 60/240', ' 90/270',
     *              '120/300', '135/315', '150/330' /
      DATA PSQX, NGN, NSP, NR1, NPP, IEPS  / 0.0 , 0, 0, 0, 0, 0 /
      DATA HKMAX, NGNLE,NSPLE, E2CLE,E2ALE, NE1ALL /0., 0, 0, 0., 0., 0/
      DATA E1MIN / 0./
      CALL WR24
      IF (KEY) 200, 240, 380
  200 E2SUM = 0.
      E2ALE = 0.
      E2CLE = 0.
      NSP   = 0
      NGN   = 0
      NSPLE = 0
      NGNLE = 0
      SUMX  = 0.
      SUMX2 = 0.
      SUMY2 = 0.
      SUMXY = 0.
      CALL KERNZI (0, NUMW1,  6)
      CALL KERNZI (0, NUMEP,  6)
      CALL KERNZI (0, NUMEP2, 6)
      IF (NREFL .GT. 1000) THEN
         E1MIN = E1MINP
      ELSE
         IF (NREFL .GT. 500) THEN
            E1MIN = 0.7
         ELSE
            E1MIN = 0.5
            ENDIF
         WRITE(8, FMT = '('' E1MIN reset to: '', F6.3)') E1MIN
         ENDIF
      EPSIL = 1.
      IEPS  = 1
      IF (KEYD.EQ.1) THEN
         CALL KERNZA (-9999., HKLM,  3)
         CALL KERNZA (-9999., HKLMA, 3)
         CALL KERNZA ( 9999., HKLMI, 3)
         HKMAX =  0.0
         ENDIF
      IF (SWPRI .AND. KEYD.NE.2) THEN
         NPP = MAX0(1,(NREFL/40))
         IF (KEYD.EQ.1) NPP = MAX0(1,(NREFL/160))
         WRITE (8, FMT='(/'' Print every '', I3,
     *                      ''th- reflection'')') NPP
         IF (KEYD .EQ. 1) WRITE (8, FMT='(''+'', 31X,
     *                           ''(accepted for PHASEX)'')')
         IF (KEYD .EQ. 3) WRITE (8, FMT='(''+'', 31X,
     *                           ''(accepted for FOUR)'')')
         WRITE (8, 230)
  230    FORMAT ('   H   K   L  JC  EPS    FO*SC    FP(BP)   ',
     *   'PHASE REST.   PH      P1      P2      W1      E1      E2')
      ENDIF
      NR1 = 0
      NE1ALL = 0
      PSQX = PSQ
      IF (EXPAND) PSQX = P1SQ
      HMUL = 1.0
      IF (NREFL .GT. 5000) HMUL = 0.5
      HKLX(1,1) = HKLMAX(1) * HMUL
      HKLX(2,1) = HKLMAX(2) * HMUL
      HKLX(3,1) = HKLMAX(3) * HMUL
      IF (PSQX.LE.PSQMIN) THEN
         CALL E1WEAK (1, HKLX, ESUM)
         IF (NREFL.LT.4000) ESUMMI = 1.0
         ENDIF
      RETURN
  240 CONTINUE
      IF (EXPAND) GOTO 255
      IF (ITP.EQ.0) GOTO 250
      DIF = ABS(DEG(ITP) - PHIP)
      DIF = MIN1(DIF, 360.-DIF)
      PHIP = DEG(ITP)
      IF (DIF.GT.90.) PHIP = PHIP + 180.
  250 CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
  255 Z = SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2)
      IF (FOBS.LT.0.0001) THEN
         FOBS = 0.0001
         X = 0.0001 * SCALE
         ENDIF
      EOBS = X / Z
      SIGE = SIG*SCALE / Z
      ZSCATT = Z
      E1 = (X-Y) / Z
      SUMX  = SUMX  + X
      SUMX2 = SUMX2 + X*X
      SUMY2 = SUMY2 + Y*Y
      SUMXY = SUMXY + ABS(X-Y)
      E1STAT = ABS(E1)
      IF (E1STAT.GT.4.) E1STAT = 4.
      IF (JCODE.LE.1) GOTO 270
      IF (E1.GT.0.) GOTO 260
      E1 = (1.4*X - Y)/Z
      IF (E1.GT.0.) E1 = 0.0
      GOTO 270
  260 E1 = (0.7*X - Y)/Z
      IF (E1.LT.0.0) E1 = 0.0
  270 P1 = PHIP
      IF (E1.LT.0.0)  P1 = PHIP - 180.
      IF (P1.LT.-0.5) P1 = P1 + 360.
      E2 = (X+Y) / Z
      IF (JCODE.GT.1) E2 = AMAX1(Y/Z, E1)
      P2 = PHIP - 180.
      IF (P2.LT.-0.5) P2 = P2 + 360.
      CALL W1PROB (ITP, E1, E2, P)
      W1 = 4.0 * (P-0.5)**2
      IF (P.LT.0.5) W1 = 0.0
      EEX = E2EXP(ITP, E1STAT, E2)
      E2SUM = E2SUM + EEX
      CALL KERF2I (HKLX, IHKL, 3)
      IF (.NOT. SWPRI .OR.  KEYD.EQ.2) GOTO 300
      IF (KEYD.EQ.1 .AND. E1.LT.E1MIN) GOTO 300
      IF (NR / NPP*NPP .NE. NR ) GOTO 300
      IJ = ITP + 1
      WRITE (8, 290) (IHKL(I),I=1,3), JCODE, IEPS, X, Y, RESTR(IJ),
     *                  PHIP, P1, P2, W1, E1, E2
  290 FORMAT (5I4, 2F10.3, 3X, A7, 2X, 3F8.0, 3F8.3)
  300 IF (ITP.GE.1) NSP = NSP + 1
      IF (ITP.EQ.0) NGN = NGN + 1
      EP = 0.0
      IF (SUMF2P(ISS).GT.0.000001)
     *    EP = Y / SQRT(EPSIL * ALATT * SUMF2P(ISS))
      DO 310 IEP=1,6
      IF (EP.LT.EPLIM(IEP)) GOTO 320
  310 CONTINUE
      IEP = 6
  320 NUMEP(IEP) = NUMEP(IEP) + 1
      IF (ABS(PHIP-P1) .LT. 90.) GOTO 330
      NUMEP2(IEP) = NUMEP2(IEP) + 1
      NUMW1(6) = NUMW1(6) + 1
      GOTO 360
  330 DO 340 I=1,5
      IW1 = I
      IF (W1.LT.W1LIM(I)) GOTO 350
  340 CONTINUE
      IW1 = 5
  350 NUMW1(IW1) = NUMW1(IW1) + 1
  360 CONTINUE
      IF (PSQX.GT.PSQMIN) GOTO 365
      IF (IEPS.NE.1) GOTO 365
      ESUM = E1 + EOBS + SIGE
      IF (ESUM.GT.ESUMMI) GOTO 365
      NE1ALL = NE1ALL + 1
      CALL E1WEAK (0, HKLX, ESUM)
  365 IF (E1.GE.E1MIN .OR. KEYD.NE.1) GOTO 370
      IF (ITP.EQ.0) THEN
          E2ALE = E2ALE + EEX
          NGNLE = NGNLE + 1
          ELSE
          E2CLE = E2CLE + EEX
          NSPLE = NSPLE + 1
          ENDIF
      RETURN
  370 NR1 = NR1 + 1
      IF (KEYD.NE.1) RETURN
      FITDUA(1) = HCODE
      FITDUA(2) = E1
      FITDUA(3) = E2
      CALL BINOFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      DO 375 I=1,3
      HKLMA(I) = AMAX1(HKLMA(I), HKLX(I,1))
  375 HKLMI(I) = AMIN1(HKLMI(I), HKLX(I,1))
      HKMAX   = AMAX1 (HKMAX, ABS(HKLX(1,1)-HKLX(2,1)) )
      RETURN
  380 KEYOLD = KEYRET
      CALL WR24
      CALL DIRESC (PSQX)
      IF (KEYOLD.EQ.KEYRET .OR. KEYRET.GT.2) GOTO 390
      IF (KEYD.NE.1 .OR. EXPAND) GOTO 390
      CALL BINIFF (1, IBINFC, 'BINFC',  FITFC,  NITFC, BUFFC,KENDFC)
      CALL BINIFF (1, IBINDU, 'BINDUA', FITDUA,NITDUA,BUFDUA,KENDUA)
      CALL BINOFF (1, IBINDU, 'BINDUA', FITDUA,NITDUA,BUFDUA,KENDUA)
      RETURN
  390 IF (ICENT.EQ.1 .AND. .NOT.EXPAND) WRITE (8, 400) NSP, NGN
  400 FORMAT (/' Number of special  reflections:', I6 /
     *        ' Number of general  reflections:', I6)
      IF (ICENT.EQ.2 .AND. .NOT. EXPAND ) WRITE (8, 410) NSP
      IF (EXPAND) WRITE (8, 410) NGN
  410 FORMAT (23H Number of reflections:, I6 )
      IF (KEYD.NE.1) GOTO 450
      CALL BINOFF (-1, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      WRITE (8, 420) NR1, E1MIN
  420 FORMAT (' Number of accepted reflections:', I6,
     *        '  (E1 > ', F4.2, ', sent to PHASEX)')
      IF (ICENT.EQ.1 .AND. .NOT.EXPAND)
     *    WRITE (8, 430) NSP-NSPLE, NGN-NGNLE
  430 FORMAT (' Number of accepted special reflections:', I6 /
     *        ' Number of accepted general reflections:', I6)
      JSYST = ISYST
      IF (EXPAND) JSYST = 0
      CALL HKLSYX (JSYST, HKLMA, HKLMI, HKMAX, HKLM)
      CALL KERF2I (HKLM, IHKL, 3)
      IF ( IHKL(1).LE.2 .OR. IHKL(2).LE.2 .OR. IHKL(3).LE.2 .OR.
     *      NR1.LT.100 ) THEN
         NOPHAS = 1
         WRITE(24, FMT='(/'' goto NOT to PHASEX but to WFOUR !''/)')
         CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KIDDS)
         WRITE (IDDS, FMT='( ''DDMAIN'' /''FOUR'' /
     *                       ''DDMAIN'' /''NUTS'' /''STOP'')')
         CALL FILCLO (IDDS, 'KEEP')
         CALL FILINQ (ICOND, 'CONDA', 'FORMATTED', 'OUTPUT', KINQCO)
         WRITE (ICOND, 630) CCODE
  630    FORMAT ('CONDA ', A6,  ' return from PHASEX (rejected) ')
         WRITE (ICOND, FMT='(''PROGRAM DDMAIN''/
     *       ''OPTION 3 FOUR 0 ''/
     *       ''PROGRAM FOUR '' /
     *       ''PROGRAM DDMAIN ''/''OPTION 0 FCALC''/
     *       ''PROGRAM NUTS A2X'' / ''FINISH'')' )
         CALL FILCLO (ICOND, 'KEEP')
         CALL COPY80 (ICOND, ' CONDA' , 29, ' ATPTB' )
         CALL FILCLO (ICOND, 'KEEP')
         CALL FILCLO (29, 'KEEP')
         CALL KEPROX
         RETURN
         ENDIF
      WRITE (CHOUT, 440) NAT, PSQX, IHKL, NR1
  440 FORMAT ('PHASEX NAT',I4, ' PSQ',F6.3, ' MHKL',3I4, ' NREFL1',I7)
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      CALL FILINQ (IE100, 'E100', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IE100, 442) CCODE, NGN, NSP, E2ALE, E2CLE
  442 FORMAT ('E100   ', A6, 4X, 2I6, 2F7.0)
      IF (PSQX.LE.PSQMIN .AND. KEYD.EQ.1) THEN
          CALL E1WEAK (-1, HKLX, ESUM)
          WRITE (8, 445) NREFL, NE1ALL, ESUMMI
  445     FORMAT (' Number of all reflections     : ', I6, /
     *            ' Number of possible weak refl. : ', I6, /
     *            ' (E1+Eobs+SIG(Eobs) < ', F4.2, ')')
          ELSE
          WRITE (IE100, FMT='(''END'')')
          ENDIF
  450 KEYRET = 10
      RETURN
      END
      SUBROUTINE E1WEAK (KEYE1, HKL, ESUM)
      DIMENSION HKL(3)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IE100, IFILE(10))
      PARAMETER (MAXDAT = 100)
      DIMENSION DATE1(4, MAXDAT), HKLME1(3)
      DATA IE1 / 0 /
      IF (KEYE1.LE.0) GOTO 200
      IE1 = MAXDAT + 1
      CALL KERNZA (-1.,  DATE1, 4*MAXDAT)
      CALL KERNAB (HKL, HKLME1, 3)
      CALL WR24
      RETURN
  200 IF (KEYE1.LT.0) GOTO 300
      IF (ABS(HKL(1)).GT.HKLME1(1) .OR. ABS(HKL(2)).GT.HKLME1(2) .OR.
     *    ABS(HKL(3)).GT.HKLME1(3)) RETURN
      IE1 = IE1 - 1
      DO 210 J=MAXDAT,IE1+1,-1
      IF (ESUM.GE.DATE1(4,J)) GOTO 210
      JJ = J
      GOTO 220
  210 CONTINUE
      JJ = IE1
      IF (IE1.EQ.0) THEN
         IE1 = 1
         RETURN
         ENDIF
      GOTO 240
  220 IF (IE1.EQ.0) IE1 = 1
      DO 230 J=IE1+1,JJ
      DO 230 L=1,4
  230 DATE1(L,J-1) = DATE1(L,J)
  240 DO 250 L=1,3
  250 DATE1(L,JJ) = HKL(L)
      DATE1(4,JJ) = ESUM
      RETURN
  300 IE1 = MAXDAT + 1 - IE1
      I = MAXDAT - IE1 + 1
      ESUMMA = DATE1(4,I)
      ESUMMI = DATE1(4,MAXDAT)
      WRITE (IE100, 410) IE1, ESUMMI, ESUMMA
      CALL WR24
      WRITE (8, 410) IE1, ESUMMI, ESUMMA
  410 FORMAT (' For ', I3, ' weakest reflections: E1+Eobs+SIG(Eobs) = ',
     *         F4.2, ' upto ', F4.2)
      DO 430 I=MAXDAT,MAXDAT-IE1+1,-1
      WRITE (IE100, 420) (NINT(DATE1(I1,I)), I1=1,3)
  420 FORMAT (3I4)
  430 CONTINUE
      WRITE (IE100, FMT='(''END'')')
      RETURN
      END
      SUBROUTINE DIFFT (KEY)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zddif.inc'
      LOGICAL      SWPRI, EXPAND
      EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (KEYD, KSTAT(19))
      EQUIVALENCE (KEYDS, KSTAT(20))
      EQUIVALENCE (FITDUA(4), ZSCATT), (FITDUA(5), P1), (FITDUA(6), P2),
     *            (FITDUA(7), W1)
      EQUIVALENCE (FITDIF(1), HCODI), (FITDIF(2), EL), (FITDIF(3), PL),
     *            (FITDIF(4), WL)
      DIMENSION NNNN(3)
      PARAMETER (WMIN = 0.9, EFMIN = 0.4)
      PARAMETER (RAD = 57.29578)
      LOGICAL LOGDUA, LOGDIF
      CALL WR24
      IF (KEY) 200, 230, 420
  200 CALL KERNZI (0, NNNN,   3)
      LOGDUA = .FALSE.
      LOGDIF = .FALSE.
      NTEL = 20
      NTEL2 = 0
      SHARP = 0.0
      WRITE (8, 211) STLMAX, BR, SHARP
      IF (STLMAX .LT. 0.5) THEN
         SHARP = BR * (0.55 - STLMAX) * 10.
         IF (SHARP .GT. 20.) SHARP = 20.
         WRITE (8, 211) STLMAX, BR, SHARP
  211    FORMAT(' STLMAX=',F6.4,' BR=',F6.3,' Sharpening: SHARP =',F6.3)
         ENDIF
      WRITE (8, FMT='(/)')
      WFIND = 1.0
      WF2 = 0.0
      WF3 = 0.0
      IF ((KEYD .EQ. 3 .AND. KEYDS .EQ. 0) .OR. KEYD .EQ. 2) THEN
         IF (PSQ .GT. .60) WFIND = AMAX1 ((0.90 - PSQ) / 0.30 , 0.)
         IF (WFIND .LT. .30) WFIND = 0.0
         WF3 = (1. - WFIND) * AMAX1 ((PSQ - 0.70) / 0.30, 0.0)
         WF2 = 1. - WFIND - WF3
         ENDIF
      D123 = AMIN1 (0.1 + (1.-PSQ)/4.,  0.2)
      X123 = AMIN1 (0.1 + (1.-PSQ)/0.8, 0.4)
      IF (.NOT. SWPRI .OR. KEYD.EQ.3) RETURN
      CHOUT = '(5(F6.0, 2F4.0, F6.0, F5.0))'
      CALL LINPRI (8, FITFFT, 25)
      NPP = MAX0 (1, (NREFL/200))
      WRITE (8, FMT='(/'' DDMAIN listing for '', A6,
     *      '', OPTION: Prepare input for PROGRAM FOUR'')') CCODE
      WRITE (8, FMT='(/'' Print every '',I3,''th- reflection'',
     *       '' (accepted for FOUR)'', /,
     *       ''     H   K   L  AMPL PHASE'', /)') NPP
      RETURN
  230 CONTINUE
      WXY= AMAX1 (AMIN1 ((Y /  AMAX1(X, 0.01) - D123) / X123, 1.0), 0.0)
      WX = AMAX1 (AMIN1 ((XSIG/AMAX1(X, 0.01) - 0.2) / 0.15 , 2.0), 0.0)
      WX = WX * AMIN1 (1.5 - PSQ, 1.0)
      WXDX = AMIN1 (WX * XSIG, X)
      WXDY = AMIN1 (WX * XSIG, ABS(X-Y))
      IF (X -Y .LT. 0.0) WXDY = - WXDY
      NTEL = NTEL + 1
      IF (NTEL .LE. 10) WRITE (8, FMT='('' NTEL X,Y,WXY,WX,WXDX,WXDY '',
     *   6F7.3 )')   X,Y,WXY,WX,WXDX,WXDY
      IF (KEYD.EQ.3 .AND. KEYDS.GE.4) GOTO 321
      IF (KEYDX.EQ.3 .OR. LOGDUA) GOTO 270
      CALL BINIFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      IF (KENDUA.LT.0) THEN
         LOGDUA = .TRUE.
         KEYDX = 3
         RETURN
         ENDIF
      HCODU = FITDUA(1)
      IF (HCODU-HCODE .GE. 0.99) THEN
         KEYDX = 3
         KENDUA = KENDUA - NITDUA
         NTEL2 = NTEL2 + 1
      IF (NTEL .LE. 10) WRITE (8, FMT='('' NTEL NTEL2'',I3 )')  NTEL2
         RETURN
         ENDIF
      E1 = FITDUA(2)
      E2 = FITDUA(3)
      IF (NTEL .LE. 10) WRITE (8, FMT='('' NTEL E1,E2'',2F8.4)')E1,E2
      IF (LOGDIF) GOTO 270
      CALL BINIFF (0, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      IF (KENDIF.LT.0) THEN
         LOGDIF = .TRUE.
         GOTO 270
         ENDIF
      IF (HCODI-HCODE .GE. 0.99) THEN
         KENDIF = KENDIF - NITDIF
      NNNN(2) = NNNN(2) + 1
         GOTO 270
         ENDIF
      IF (WL.GE.WMIN .OR. WL.GT.5*W1) GOTO 260
      NNNN(1) = NNNN(1) + 1
      GOTO 270
  260 FL = EL * ZSCATT
      EF = FL * WL
      IF (NTEL .LE. 10) WRITE (8, FMT='('' NTEL 260: EF'',F8.4 )') EF
      PLRAD = PL / RAD
      PHIRAD = PHIP / RAD
      FA = EF * COS(PLRAD) + Y * COS(PHIRAD)
      FB = EF * SIN(PLRAD) + Y * SIN(PHIRAD)
      EF = SQRT(FA*FA + FB*FB)
      PHAMP = ATAN2(FB,FA) * RAD
      IF (PHAMP.LT.-0.5) PHAMP = PHAMP + 360.
      GOTO 300
  270 EX1 = -0.5 * E1**2
      EX2 = -0.5 * E2**2
      IF (NTEL.LE.10) WRITE(8,FMT='('' NTEL EX1'',2F8.4,I2 )')
     *    EX1,EX2,ITP
      IF (ITP .NE. 0) GOTO 280
      Q = EX1 - EX2
      EF = X * SIMW(Q)
      IF (NTEL.LE.10) WRITE(8,FMT='('' NTEL 270: EF'',F8.4 )') EF
      GOTO 290
  280 EX1 = EXP(EX1)
      EF = X * (2. * EX1 / (EX1+EXP(EX2)) -1.0)
      IF (NTEL.LE.10) WRITE(8,FMT='('' NTEL 280: EF'',F8.4 )') EF
  290 CONTINUE
      IF (NTEL.LE.10) WRITE(8,FMT='('' NTEL 290: EF'',F8.4 )') EF
      EF = WFIND * EF + WF2 * WXY * (X - WXDX + X - Y - WXDY)
     *                + WF3 * WXY * (X - WXDX)
      IF (NTEL.LE.10) WRITE(8,FMT='('' NTEL 290+ EF'',F8.4 )') EF
      IF (PSQ .LE. .95) GOTO 296
      IF ( (NAT .EQ. NATL .AND. NRECYR .GE. 4) .OR.
     *  ( NAT .LE. NATL+1 .AND. NRECYR .GE. 5) .OR. NRECYR .GE. 6) THEN
         XX4 = AMIN1 (X, 4.* Y)
         YY4 = AMIN1 (Y, 4.* X)
         EF = 2. * XX4 - YY4
         IF (2. * X .LT. XSIG) EF = 0.
         ENDIF
  296 PHAMP = PHIP
      IF (EF.GT.0.) GOTO 300
      EF = -EF
      PHAMP = PHAMP - 180.
      IF (PHAMP.LT.-0.5) PHAMP = PHAMP + 360.
  300 CONTINUE
      IF (NTEL.LE.10) WRITE(8,FMT='('' NTEL 300: EF'',F8.4 )') EF
      IF (EF.LT.EFMIN) RETURN
      NNNN(3) = NNNN(3) + 1
      CALL KERNAB (HKLX, FITFFT, 3)
      FITFFT(4) = EF * EXP (SHARP * STL2)
      FITFFT(5) = PHAMP
      IF (.NOT. SWPRI .OR. KEYD.NE.2) GOTO 310
      IF (NNNN(3) / NPP*NPP .NE. NNNN(3)) GOTO 310
      CALL LINPRI (0, FITFFT, 5)
  310 CALL BINOFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      RETURN
  321 EF = WXY * (X - WXDX)
      IF (KEYDS .EQ. 6) EF = EF + WXY * (X - Y - WXDY)
      IF (KEYDS .EQ. 5) EF = WXY * (X - Y - WXDY)
      IF (KEYDS .EQ. 9) EF = Y
      GOTO 296
  420 CONTINUE
      CALL WR24
      IF (KEYD.EQ.2) THEN
          IF (SWPRI) CALL LINPRI (-1, FITFFT, 5)
          WRITE (8, 430) NNNN(2)
  430     FORMAT (/ I6, ' reflections skipped by PHASEX')
          WRITE (8, 440) NNNN(1), WMIN
  440     FORMAT (I6, ' refined reflections with weight < ', F6.4,
     *            ' considered unrefined')
          ENDIF
      CALL BINOFF (-1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      NNNN2 = NR - NNNN(3)
      WRITE (8, 445) NNNN2, EFMIN, NNNN(3)
  445 FORMAT (     I6, ' reflections with ampl. < ', F4.2, ', skipped',
     *         / , I6, ' reflections accepted (written to BINFFT file)')
      IF (NNNN(3) .LT. 97) WRITE(24, 445) NNNN2, EFMIN, NNNN(3)
      IF (NNNN(3) .GT. 37) RETURN
      WRITE (9,*) ' Structure expansion failed. Wrong scale ?'
      IF (MPAT .LE. -2) CALL ATPATS(1)
      CALL KERNER (445, 'DIFFT')
      RETURN
      END
      SUBROUTINE W1PROB (ITYP, A, B, PROB)
      IF (B.GT.6.0) B = 6.0
      IF (A.GE.0.0) GOTO 100
      PROB = 1.0
      A = -A
      IF (A.GT.4.0) A = 4.0
      RETURN
  100 IF (A.LE.4.0) GOTO 110
      A = 4.0
      B = 4.0
      PROB = 0.5
      RETURN
  110 IF (ITYP.GE.1) GOTO 120
      R1 = A*EXP(-A*A)
      R2 = B*EXP(-B*B) +  R1
      GOTO 130
  120 R1 = EXP(-0.5*A*A)
      R2 = EXP(-0.5*B*B) + R1
  130 PROB = R1 / R2
      RETURN
      END
      SUBROUTINE DIRESC (PSQ)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zddif.inc'
      EQUIVALENCE (KEYD, KSTAT(19))
      DIMENSION  W1LIM(6), EPLIM(6)
      DATA W1LIM /  .001, .050, .200, .800,  .999,  1.000  /
      DATA EPLIM /  .01,  .20,  .60, 1.00,  1.50,  10.000  /
      CALL WR24
      IF (SUMX2 .LT. 0.000001 .OR. SUMX .LT. 0.0001) THEN
         WRITE(24, FMT='(/'' Emergency wayout: RESCALE bypassed'')')
         RETURN
         ENDIF
      PSQX  = SUMY2/SUMX2
      SUMXY = SUMXY/SUMX
      WRITE(24, 200) NR, SUMXY
      WRITE (8, 200) NR, SUMXY
  200 FORMAT (/' R-value on ', I6, ' reflections is  R =  ', F6.3 )
      DO 210 I=1,6
      IF (NUMEP(I).LE.0) EPPROC(I) = 0.
      IF (NUMEP(I).GT.0) EPPROC(I) =
     *                   100. * FLOAT(NUMEP2(I)) / FLOAT(NUMEP(I))
  210 CONTINUE
      W1PROC = 100. * FLOAT(NUMW1(6)) / NR
      IF (KEYD .EQ. 1) WRITE (8, 220) (W1LIM(I), NUMW1(I),
     *   EPLIM(I), NUMEP(I), NUMEP2(I), EPPROC(I), I=1,6), W1PROC
  220 FORMAT (/' Distribution of reflections in ranges of weight W1',
     * ' and EP:' / '      W1-interval       EP-interval' /
     * '      W1-lim.  No       EP-lim.  No   No(*)  Perc(*)' /
     *        ' 0.000-',F5.3, I5, '   0.00-', F5.2, 2I5, F9.2,
     *   5 (/ 7X,F5.3, I5, F13.2, 2I5, F9.2) /9X,'  *    *'/
     *        9X, '  *=FP.gt.FO : percentage', F6.2 )
      WRITE (8, 230) PSQX
  230 FORMAT (' Recalculated Psq of the known part is',
     *        '  P(av)**2 = ', F6.3, ' (not used)')
      E2AV = E2SUM / NR
      RESC = SQRT(E2AV)
      IF (PSQ .GT. 0.98) RETURN
      IF (KEYD .NE. 1 ) GOTO 277
      IF (RESC.LT..88 .OR. RESC.GT.1.12 )
     *   WRITE (8, 246) E2AV
  246    FORMAT (' TEMP ... The average value of Er**2 is', F5.2 )
      IF (PSQ .GT. 0.95) GOTO 277
      IF (RESC.LT..80 .OR. RESC.GT.1.22) THEN
         WRITE(24, 247) E2AV
  247    FORMAT (' The average value of Er**2 is', F5.2, ' (not used)')
         WRITE(24, 270)
  270    FORMAT (20X, 'This is a rather large deviation'
     *            / 20X, 'Check your input data ...' //)
         ENDIF
  277 IF (RESC.LT..95 .OR. RESC.GT.1.10) GOTO 280
      RETURN
  280 CONTINUE
      RESCAL = SQRT (RESC**2  * (1. - PSQ) + PSQ )
      WRITE(24, 291) RESCAL
      WRITE (8, 291) RESCAL
  291 FORMAT (' The RESCALE factor to make avg. Er**2 = 1.0 is', F6.3,
     * ' (not used)' )
      RETURN
      END
      SUBROUTINE DIPATT (KEY)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zddif.inc'
      LOGICAL      SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (KEYD, KSTAT(19))
      EQUIVALENCE (KEYDS, KSTAT(20))
      COMMON /SINGP/ SINGPK, ORIGIN, PATP(8)
      DIMENSION NNNN(2), PATX(11)
      PARAMETER (EFMIN = 0.1, PI02 = 0.6283185)
      DATA NPP, DEL10  / 0, 0.0/
      IF (KEY) 200, 230, 260
  200 CALL KERNZA (0.0, PATX, 11)
      CALL KERNZI (0,   NNNN,  2)
      SINGPK = 0.0
      CALL WR24
      WRITE (8, FMT='('' Prepare input for sharpened Patterson'')')
      BPATT = BOV
      IF (2000 .NE. NINT(1000. * BP)) BPATT = BP
      BP = 2.0
      IF (.NOT. SWPRI) RETURN
      DEL10 = 10.0
      WRITE (8, FMT='('' DDMAIN listing for '', A6,
     *      '', OPTION: Prepare input for PROGRAM ORIENT'')') CCODE
      NPP = MAX0 (1, (NREFL/200))
      WRITE (8, FMT='('' Print every '',I3,''th- reflection'',
     *       '' (accepted for sharpened Patterson)'', /,
     *       ''     H   K   L  AMPL PHASE'')') NPP
      CHOUT = '(5(F6.0, 2F4.0, F6.0, F5.0))'
      CALL LINPRI (8, FITFFT, 25)
      RETURN
  230 DDD = (0.2 + STL)**2 * EXP(BPATT * STL2)
      EFP = X**2 * DDD
      IF (KEYDS .EQ. 0) THEN
         EF  = EFP - EXP(-2. * BOV * STL2) * SUMF2R * ALATT * DDD
      ELSE
         EF = EFP
         ENDIF
      SINGPK = SINGPK + EFP
      XH = 0.0
      DELXH = HKLX(1,1) * PI02 / CELL(1)
      DO 240 I=1,11
      PATX(I) = PATX(I) + EFP*COS(XH)
  240 XH = XH + DELXH
      IF (EF.GE.0.0) THEN
          PHAMP = 0.
          ELSE
          PHAMP = 180.
          EF = -EF
        ENDIF
      NNNN(2) = NNNN(2) + 1
      IF (EF.LT.EFMIN) RETURN
      IF (SWPRI .AND. NNNN(2).EQ.1) THEN
         IF (EF.GT.1000.) DEL10 = 100.
         WRITE (8, FMT='(''+'',27X,''(AMPL/'',F4.0,'')'',/)') DEL10
         ENDIF
      CALL KERNAB (HKLX, FITFFT, 3)
      FITFFT(4) = EF
      FITFFT(5) = PHAMP
      CALL BINOFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      IF (.NOT. SWPRI) RETURN
      IF (NNNN(2)/NPP*NPP .NE. NNNN(2)) RETURN
      EF = EF / DEL10
      CALL LINPRI (0, FITFFT, 5)
      RETURN
  260 IF (SWPRI) CALL LINPRI (-1, FITFFT, 5)
      CALL BINOFF (-1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF)
      SINGPK = SINGPK * 2. * ASYMM / VOLUM
      SUMAL = 0
      DO 265 I=1,NTYPE
      IF (CELATY(I) .NE. 'H ') SUMAL = SUMAL + CELALL(I)
  265 CONTINUE
      SINGPK = SINGPK / SUMAL
      PATX1 = PATX(1) * 2. * ASYMM / VOLUM
      WRITE(24, 270) SCALE, BPATT
  270 FORMAT (/' Origin removed sharpened PATTERSON function', /
     *        ' ((', F7.4, '*Fobs)**2 - ORIGIN) * (0.2+STL)**2 * exp(',
     *        F6.3, '*STL2)')
      CALL WR24
      WRITE (8, 280)  PATX1, SINGPK
  280 FORMAT (' Output ORIENT parameters:'/
     *        ' Patterson origin peak height =', F9.2 /
     *        ' Averaged single peak maximum =', F9.2 )
      DO 290 I=2,11
      IF (PATX(I) .LT. 0.) PATX(I) = 0.
  290 PATX(I) = PATX(I) / PATX(1)
      PATX(1) = 1.0
      WRITE(24, 300) PATX
  300 FORMAT (' Observed Patterson peak shape' /
     *        '   xa = 0.0  0.1   0.2   0.3   0.4   0.5 ',
     *                 '  0.6   0.7   0.8   0.9   1.0 A' /
     *        ' P(xa)=', F5.2, 10F6.3 )
      ORIGIN = PATX1
      CALL KERNAB (PATX(2), PATP, 8)
      DO 320 I = 2, 8
      IF (PATP(I) .LT. 0.) PATP(I) = 0.
      IF (PATP(I-1) .LT. 0.2) THEN
         PATP(I-1) = PATP(I-1) * 0.9
         PATP(I) = AMIN1 (0.99, PATP(I))
         ENDIF
  320 PATP(I) = AMIN1 (PATP(I), PATP(I-1) * (1. - 0.02 * FLOAT(I)))
      WRITE(24, 323) PATP
  323 FORMAT (/' Peak profile (smoothed):'/
     * ' for x.a = 0.0   0.1   0.2   0.3   0.4   0.5   0.6   0.7   0.8'/
     * ' shape   = 1.000', 8F6.3 )
      CALL WR24
      NNNN(1) = NNNN(2) - NR
      NNNN(2) = NR
      WRITE (8, 410) NNNN(1), EFMIN, NNNN(2)
  410 FORMAT (/I8, ' Reflections with amplitude <', F5.2, ' skipped',
     *    /   I8, ' Reflections accepted (written to BINFFT file)')
      IF (NNNN(2) .LT. 10) CALL KERNER (320, 'DIPATT')
      RETURN
      END
      SUBROUTINE WILSIN (KEY)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (KEYWIL, KSTAT(17))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zwils.inc'
      PARAMETER  (NRS = 9, NRF = 7)
      LOGICAL     SWIL
      DATA SWIL / .FALSE. /
      DATA FNRF1, STLM2, FNRS3 / 0.0, 0.0, 0.0/
      IF (KEY .EQ. 999) THEN
         SWIL = .FALSE.
         RETURN
         ENDIF
      IF (SWIL) GOTO 180
      SWIL = .TRUE.
      EPMIN = 9999.
      EPMAX =-9999.
      CALL KERNZI (0 , NOW, NRS)
      CALL KERNZI (0 , NUW, NRS)
      CALL KERNZA (0.,  AW, NRS)
      CALL KERNZA (0., AAW, NRS)
      CALL KERNZA (0.,  BW, NRS)
      CALL KERNZI (0 , NOV, NRF * NRF)
      CALL KERNZI (0 , NUV, NRF * NRF)
      CALL KERNZA (0.,  VA, NRF * NRF)
      CALL KERNZA (0.,  VB, NRF * NRF)
      CALL KERNZA (0.,  VC, NRF * NRF)
      CALL KERNZA (0.,  VS, NRF * NRF)
      FHMN = 0.
      BPINP = BP
      BRINP = BR
      FNRF1  = FLOAT(NRF+1)
      FNRS3  = FLOAT(NRS+1)
      STLM2  = STLMAX**2
  180 IF (KEYWIL .EQ. 4) RETURN
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      TUMF2 = SUMF2(ISS) * EPSIL * ALATT
      TUMF2P = SUMF2P(ISS) * EPSIL * ALATT
      TUMF2R = (TUMF2 - TUMF2P) * EXPBR(ISS)**2
      K = (STL2/STLM2) * FNRS3 + 1.
      IF (K.GT.NRS) K = NRS
      NOW(K) = NOW(K) + 1
      IF (FOBS .LT. 5.*SIG)  NUW(K) = NUW(K) + 1
      AW(K)  = AW(K)  + FOBS**2 / TUMF2
      AAW(K) = AAW(K) + (FP**2 + TUMF2R) / TUMF2
      BW(K) = BW(K) + STL2
      IF (KEYWIL .EQ. -2) RETURN
      FPW = FP /  EXPBP(ISS)
      FHMN = FHMN + FPW**2 / TUMF2
      EP = FPW / SQRT(TUMF2P)
      EPMIN = AMIN1 (EPMIN, EP)
      EPMAX = AMAX1 (EPMAX, EP)
      IF (ABS(EP).GT.6.)  EP = 6.0
      K =  (STL2/STLM2)**1.5  * FNRF1
      L = (1.0 - EXP(-EP*EP)) * FNRF1
      IF (ICENT.EQ.2)  L = ERFU(EP/1.414) * FNRF1
      DO 220 IK=0,1
      I = K + IK
      IF (I.GT.NRF .OR. I.LT.1)  GOTO 220
      DO 210 IL=0,1
      J = L + IL
      IF (J.GT.NRF .OR. J.LT.1)  GOTO 210
      VA(I,J) = VA(I,J) + FOBS**2 / TUMF2
      VB(I,J) = VB(I,J) + FP**2 / TUMF2
      VC(I,J) = VC(I,J) + TUMF2R / TUMF2
      VS(I,J) = VS(I,J) + STL2
      NOV(I,J) = NOV(I,J) + 1
      IF (FOBS .LT. 5.*SIG)  NUV(I,J) = NUV(I,J) + 1
  210 CONTINUE
  220 CONTINUE
      RETURN
      END
      SUBROUTINE WIL2DI
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (KEYWIL, KSTAT(17))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zwils.inc'
      CALL WR24
      BMAXD = 1.0 - AMIN1 (1.0, PSQ)
      BDMAX = AMIN1 (1.00, 1.5 * BMAXD)
      CALL WIL2DC (NRF, IWILP)
         WRITE (8, FMT='('' $TE SCALE W.2D '',I3,2F6.3,F8.4,2F6.3, I5)')
     *       NRECYR, PSQ, R2X, SCALE, BP, BR, KEYWIL
      WRITE (24, 200)
  200 FORMAT (1X/' Parameters after two-dim. refinement:')
      IF (IWILP.EQ.1)  THEN
         WRITE (24, 210) SCALE, BP, BR
  210    FORMAT (' .... not acceptable . Use old parameters:'/
     *      15X,' Scale= ',F9.5,'   Bp= ',F6.3, '  Br= ',F6.3/1X)
         RETURN
         ENDIF
      BPMAX = BPINP + BMAXD
      BPMIN = AMAX1 (BPINP - BMAXD, 0.0)
      BRMAX = BRINP + BMAXD
      BRMIN = AMAX1 (BRINP - BMAXD, 0.0)
      IF (KEYWIL.NE.2 .AND. KEYWIL.NE.0) THEN
         BP = BPINP
         BPMAX = BP
         BPMIN = BP
         ENDIF
      IF (KEYWIL.NE.1 .AND. KEYWIL.NE.0) THEN
         BR = BRINP
         BRMAX = BR
         BRMIN = BR
         ENDIF
      IF (KEYWIL.EQ.0 .OR. KEYWIL.EQ.1) THEN
         BRMAX = AMIN1(BRMAX, BRINP+BDMAX)
         BRMIN = AMAX1(BRMIN, BRINP-BDMAX)
         ENDIF
      IF (KEYWIL.EQ.0 .OR. KEYWIL.EQ.2) THEN
         BPMAX = AMIN1(BPMAX, BPINP+BDMAX)
         BPMIN = AMAX1(BPMIN, BPINP-BDMAX)
         ENDIF
      BD = BP - BR
      SD = SIGN(1.0,BD)
      BD = ABS (BD)
      IF (BP.LE.BPMAX .AND. BP.GE.BPMIN .AND. BD.LE.BDMAX .AND.
     *    BR.LE.BRMAX .AND. BR.GE.BRMIN) RETURN
      BP = AMIN1(BP,BPMAX)
      BP = AMAX1(BP,BPMIN)
      BR = AMIN1(BR,BRMAX)
      BR = AMAX1(BR,BRMIN)
      IF (KEYWIL.GE.3) GOTO 230
      BD = BP - BR
      SD = SIGN(1.0,BD)
      BD = ABS (BD)
      IF (BD.LT.BDMAX) GOTO 230
      FHMN = FHMN / FLOAT(NREFL)
      IF (KEYWIL.EQ.1) FHMN = 1.
      IF (KEYWIL.EQ.2) FHMN = 0.
      BM = BP*FHMN + BR*(1.0-FHMN)
      BP = BM + SD*(1.0-FHMN)*BDMAX
      BR = BM - SD*FHMN*BDMAX
  230 SCNUM = 0.0
      SCDEN = 0.0
      DO 240 I=1,NRF
      DO 240 J=1,NRF
      IF (NOV(I,J).LT.10) GOTO 240
      SCDEN = SCDEN + VA(I,J)
      X = (BP-BPINP) * VS(I,J)
      Y = (BR-BRINP) * VS(I,J)
      IF (X.GT.50.) X = 50.
      IF (Y.GT.50.) Y = 50.
      SCNUM = SCNUM + VB(I,J)*EXP(-X) + VC(I,J)*EXP(-Y)
  240 CONTINUE
      SCALE = SQRT (SCNUM/SCDEN)
      WRITE (24, 250) SCALE, BP, BR
  250 FORMAT (' Resetting of parameters required,'/
     *   13X, ' new values are:'
     *   ,'    Scale=',F9.5,'  Bp= ',F6.3, '  Br= ',F6.3)
      CALL WR24
      WRITE (8, FMT='('' $TE SCALE ---: '',I3,2F6.3,F8.4,2F6.3, I5)')
     *       NRECYR, PSQ, R2X, SCALE, BP, BR, KEYWIL
      RETURN
      END
      SUBROUTINE WIL2DC (NRF, IWILP)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL SWIPRI
      EQUIVALENCE (SWIPRI, SWITCH(10))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zwils.inc'
      DIMENSION IY(9), STLRAN(8), EPRAN1(2,7), EPRAN2(2,7), EPRANG(2,7)
      DIMENSION D(3,7,7), AMAT(3,3), AMATIN(3,3), V(3), SH(3),
     *         ERR(3), PA(3), AC(7,7)
      EQUIVALENCE (SC, PA(1))
      DIMENSION NPERCA(7), NPERCU(7), PERCU(7)
      CHARACTER *8  VARI(3)
      DATA VARI / '      K', 'delta BP', 'delta BR' /
      DATA EPRAN1 / 0.00, 0.53,  0.36, 0.68,  0.54, 0.83,  0.69, 0.99,
     *              0.84, 1.17,  1.00, 1.44,  1.18, 4.26 /
      DATA EPRAN2 / 0.00, 0.31,  0.15, 0.48,  0.32, 0.67,  0.49, 0.88,
     *              0.68, 1.15,  0.89, 1.53,  1.16, 3.50 /
      DATA PSC /0.0/
      CALL WR24
      NRF = 7
      IF (NREFL.GT.400) GOTO 190
      K = 0
      DO 170 I=1, (NRF-1), 2
      K = K + 1
      IJ = 0
      DO 170 J=1, (NRF-1), 2
      IJ = IJ + 1
      NOV(IJ,K) = NOV(J,I) + NOV(J+1,I) + NOV(J,I+1) + NOV(J+1,I+1)
      NUV(IJ,K) = NUV(J,I) + NUV(J+1,I) + NUV(J,I+1) + NUV(J+1,I+1)
      VA(IJ,K)  = VA(J,I)  + VA(J+1,I)  + VA(J,I+1)  + VA(J+1,I+1)
      VB(IJ,K)  = VB(J,I)  + VB(J+1,I)  + VB(J,I+1)  + VB(J+1,I+1)
      VC(IJ,K)  = VC(J,I)  + VC(J+1,I)  + VC(J,I+1)  + VC(J+1,I+1)
  170 VS(IJ,K)  = VS(J,I)  + VS(J+1,I)  + VS(J,I+1)  + VS(J+1,I+1)
      IJ = 0
      DO 180 I=1, (NRF-1), 2
      IJ = IJ + 1
      NOV(IJ,K) = NOV(IJ,K) + NOV(I,NRF) + NOV(I+1,NRF)
      NOV(K,IJ) = NOV(K,IJ) + NOV(NRF,I) + NOV(NRF,I+1)
      NUV(IJ,K) = NUV(IJ,K) + NUV(I,NRF) + NUV(I+1,NRF)
      NUV(K,IJ) = NUV(K,IJ) + NUV(NRF,I) + NUV(NRF,I+1)
      VA(IJ,K)  = VA(IJ,K)  + VA(I,NRF)  + VA(I+1,NRF)
      VA(K,IJ)  = VA(K,IJ)  + VA(NRF,I)  + VA(NRF,I+1)
      VB(IJ,K)  = VB(IJ,K)  + VB(I,NRF)  + VB(I+1,NRF)
      VB(K,IJ)  = VB(K,IJ)  + VB(NRF,I)  + VB(NRF,I+1)
      VC(IJ,K)  = VC(IJ,K)  + VC(I,NRF)  + VC(I+1,NRF)
      VC(K,IJ)  = VC(K,IJ)  + VC(NRF,I)  + VC(NRF,I+1)
      VS(IJ,K)  = VS(IJ,K)  + VS(I,NRF)  + VS(I+1,NRF)
  180 VS(K,IJ)  = VS(K,IJ)  + VS(NRF,I)  + VS(NRF,I+1)
      NOV(K,K)  = NOV(K,K)  + NOV(NRF,NRF)
      NUV(K,K)  = NUV(K,K)  + NUV(NRF,NRF)
      VA(K,K)   = VA(K,K)   + VA(NRF,NRF)
      VB(K,K)   = VB(K,K)   + VB(NRF,NRF)
      VC(K,K)   = VC(K,K)   + VC(NRF,NRF)
      VS(K,K)   = VS(K,K)   + VS(NRF,NRF)
      NRF = K
  190 CONTINUE
      CALL WR24
      WRITE (24, 201)
  201 FORMAT (/' Two-dimensional refinement of BP and BR' /)
      FNRF1  = FLOAT(NRF+1)
      F13 = 1. / 3.
      DO 205 I=1,NRF
  205 STLRAN(I) = STLMAX * (FLOAT(I)/FNRF1)**F13
      STLRAN(NRF+1) = STLMAX
      CALL KERNZI (0, NPERCU, NRF)
      CALL KERNZI (1, NPERCA, NRF)
      DO 207 I = 1, NRF
      DO 207 J = 1, NRF
      NPERCA(I) = NPERCA(I) + NOV(I,J)
  207 NPERCU(I) = NPERCU(I) + NUV(I,J)
      PERCUM = 0.0
      DO 208 I = 1, NRF
      PERCU(I) = 100. * FLOAT(NPERCU(I)) / FLOAT(NPERCA(I))
      IF (PERCU(I) .GT. PERCUM) PERCUM = PERCU(I)
  208 CONTINUE
      IF (PERCUM .LE. 30.) GOTO 214
      WRITE(24, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1)
  210 FORMAT (/' sinTH/L range:  0.0-', F3.2, 6(1X, F3.2,'-', F3.2),
     *                                         1X, F3.2,'-', F4.2 )
      WRITE(24, 212) (PERCU(I), I = 1, NRF)
  212 FORMAT (' Percentage unobs:', 7(F6.0,2X))
  214 CONTINUE
      CALL WR24
      WRITE (8, 215)
  215 FORMAT (/' Distribution of reflections (and unobs.) in array')
      WRITE (8, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1)
      CALL KERNAB (EPRAN1, EPRANG, 14)
      IF (ICENT .EQ. 2) CALL KERNAB (EPRAN2, EPRANG, 14)
      EPRANG(1,1) = AMAX1 (EPRANG(1,1), EPMIN)
      EPRANG(2,NRF) = AMIN1 (EPRANG(2,NRF), EPMAX)
      WRITE (8, 220)
  220 FORMAT (' Ep range=')
      DO 260 J=1,NRF
      WRITE (8, 230) (EPRANG(I2,J),I2=1,2), (NOV(I,J), I=1,NRF)
  230 FORMAT (/' ', F4.2, '-', F4.2, '  All ', 7I8)
      WRITE (8, 240) (NUV(I,J), I=1,NRF)
  240 FORMAT (10X, 'Unobs ', 7I8)
      DO 260 I=1,NRF
      XN = NOV(I,J)
      IF (XN.LT.1.0) XN = 1.0
      IF (NOV(I,J).GT.10) GOTO 250
      NOV(I,J) = 0
      NUV(I,J) = 0
      VA(I,J) = 0.0
      AC(I,J) = 0.0
      VB(I,J) = 0.0
      VC(I,J) = 0.0
      VS(I,J) = 0.0
      GOTO 260
  250 VA(I,J) = VA(I,J) / XN
      VB(I,J) = VB(I,J) / XN
      VC(I,J) = VC(I,J) / XN
      VS(I,J) = VS(I,J) / XN * 2.0
  260 CONTINUE
      KEYNRS = 0
  270 KEYNRS = KEYNRS + 1
      SC = 1.0 / SCALE**2
      PA(2) = 0.
      PA(3) = 0.
      NY = 0
      IWILP = 0
      DO 290 J=1,NRF
      NX = 0
      IY(J) = 0
      DO 280 I=1,NRF
      NX = NX + NOV(I,J)
  280 CONTINUE
      IF (NX.EQ.0) GOTO 290
      NY = NY + 1
      IY(NY) = J
  290 CONTINUE
      IF (NY.GT.2) GOTO 330
      IF (NY.EQ.2) GOTO 320
  300 IWILP = 1
      WRITE (8, 310)
  310 FORMAT (' Refining scale and temperature factors seperately' /
     *        ' is impossible for this problem: use old parameters.')
      RETURN
  320 IF ((IY(2)-IY(1)) .EQ. 1) GOTO 300
  330 SIG = 10000.0
      WRITE(24, 333) SCALE, BPINP, BRINP
  333 FORMAT (/' Input for 2-dim. refinement:',
     * '    Scale=', F9.5 , '  Bp=', F7.3,'  Br=', F7.3/)
      CALL WR24
      NCYC = 10
      NP  = 3
      PCYMAX = 1.2
      DO 490 NC=1,NCYC
      SIGOLD = SIG
      SIG = 0.0
      CALL KERNZA (0., AMAT, 9)
      CALL KERNZA (0.,   V, 3)
      DO 370 I=1,NRF
      DO 370 J=1,NRF
      IF (NOV(I,J).EQ.0) GOTO 370
      P = EXP (-PA(2)*VS(I,J))
      Q = EXP (-PA(3)*VS(I,J))
      D(1,I,J) = VB(I,J)*P + VC(I,J)*Q
      D(2,I,J) = -VB(I,J) * VS(I,J) * P * SC
      D(3,I,J) = -VC(I,J) * VS(I,J) * Q * SC
      AC(I,J) = VA(I,J) - SC*D(1,I,J)
      XN = 100.0 / NOV(I,J)
      IF (XN.LT.1.0) XN = 1.0
      DO 360 K=1,NP
      DO 350 L=1,NP
  350 AMAT(K,L) = AMAT(K,L) + D(K,I,J)*D(L,I,J)/XN
      V(K) = V(K) + D(K,I,J)*AC(I,J)/XN
      SIG = SIG + AC(I,J)**2/XN
  360 CONTINUE
  370 CONTINUE
      SIG = SQRT (SIG / (NRF*NRF-NP))
      IF (SWIPRI) WRITE (8, 380) NC, SIG
  380 FORMAT (' Cycle', I2, ' Sigma   =', G12.4)
      CALL MATINV (AMAT, AMATIN, DMAT, KEND)
      IF (DMAT .LT. 10.E-9) WRITE (8, 381)
  381 FORMAT (' Warning: small determinant, results unreliable?')
      IF (KEND.EQ.-99) GOTO 545
      DO 390 I=1,NP
      SH(I) = 0.0
      ERR(I) = SQRT (AMATIN(I,I))
      DO 390 J=1,NP
  390 SH(I) = SH(I) + AMATIN(I,J)*V(J)
      DO 400 I=1,NP
      DO 400 J=1,NP
  400 AMATIN(I,J) = AMATIN(I,J) / (ERR(I) * ERR(J))
      DO 410 I=1,NP
  410 ERR(I) = ERR(I) * SIG
      IF (SWIPRI) WRITE (8, 420)
  420 FORMAT (30X, ' Par', 5X, 'Old', 5X, 'Shift', 5X, 'New',5X,'Error')
      DO 470 J=1,3
      P = SH(J)
      IF (NC.LE.3) P = P * .9
      IF (J.EQ.1) GOTO 430
      IF (P.GT.PCYMAX) P = PCYMAX
      IF (P.LT.-PCYMAX) P = -PCYMAX
  430 X = PA(J) + P
      IF (J .EQ. 1) X = AMAX1 (X, PA(1) / 5.)
      IF (SWIPRI) WRITE (8, 450) VARI(J), PA(J), SH(J), X, ERR(J)
  450 FORMAT (27X, A8, 4F9.4)
      PA(J) = X
      IF (J.GT.1) GOTO 470
      PSC = 1. / SQRT(ABS(X))
      IF (SWIPRI) WRITE (8, 460) PSC
  460 FORMAT (1H+, 8X, 'SC(new) =', F7.4)
  470 CONTINUE
      WRITE (8, 480) NC, PSC, BPINP+PA(2), BRINP+PA(3)
  480 FORMAT ('    Cycle', I2, '    Scale =', F9.5,
     *   '  New Bp =', F7.3, '  Br =', F7.3 )
      IF (NC.LT.4) GOTO 489
      IF (ABS(SIGOLD-SIG).LT.0.01*SIG) GOTO 590
      IF (SIG.GT.1.5*SIGOLD) GOTO 550
      IF ((PA(2)+BPINP).LT.-5. .OR. (PA(2)+BPINP).GT.30. .OR.
     *    (PA(3)+BRINP).LT.-5. .OR. (PA(3)+BRINP).GT.30.) GOTO 530
      IF (SC.LT.0.0000001) GOTO 530
  489 PCYMAX = PCYMAX + .15
  490 CONTINUE
      WRITE (8, 500) NCYC
  500 FORMAT (' Series is still unconverged after', I3, ' cycles')
      GOTO 570
  530 WRITE (8, 540)
  540 FORMAT (' Unreasonable results' )
      GOTO 570
  545 WRITE (8, 546)
  546 FORMAT (' Determinant is zero: no 2-dimens. Bp Br Sc ref. plot ')
      GOTO 570
  550 WRITE (8, 560)
  560 FORMAT (' Series is diverging seriously')
  570 IWILP = 1
      IF (KEYNRS.GT.1 .OR. NRF.LE.6) GOTO 610
      WRITE(24, 580)
      WRITE (8, 580)
  580 FORMAT (' Try again; skip high order refl.')
      NRF = NRF-2
      GOTO 270
  590 WRITE (8, 595) NC
  595 FORMAT (' Series has converged after', I3, ' cycles')
      IF (KEYNRS.GT.1 .OR. NRF.LE.6) GOTO 610
      IF (ABS(PA(2)) .LT. 2.5) GOTO 610
      WRITE (8, 600)
  600 FORMAT (' A large change of BP, too large.')
      GOTO 570
  610 IF (IWILP.GT.0) RETURN
      IF (SWIPRI)
     * WRITE (8, 620) VARI, (VARI(I), (AMATIN(I,J), J=1,NP), I=1,NP)
  620 FORMAT (' Correlation matrix',12X,A8,4X,A8,2X,A8 /(22X,A8,3F10.4))
      SCALE = 1.0 / SQRT(SC)
      BP = PA(2) + BPINP
      BR = PA(3) + BRINP
      RETURN
      END
      SUBROUTINE MERBIN
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zwils.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (KEYWIL, KSTAT(17))
      DIMENSION HKL(3)
      EQUIVALENCE (HKL(1), HKLX(1,1))
      PARAMETER (MAXA = 10000)
      COMMON /BLANK/ AREF(4, MAXA), DUMMY(120000)
      PARAMETER (AMAX = 10000.)
      DIMENSION HMAX(3), HMIN(3), HCON(3)
      LOGICAL FRIE
      DIMENSION ITEMP(9)
      DATA FRIE /.TRUE./
      DATA IREF /0/
      CALL WR24
      CALL KERNZA (  9999., HMIN, 3)
      CALL KERNZA ( -9999., HMAX, 3)
      HKMAX =  0.0
      HCODMI = 4.0 * 256.**3
      HCODMA = - HCODMI
      STLCON = 9999.9
      IF (STLMAX .GT. 0.00001) STLCON = STLMAX
      STLMAX = 0.
      DO 230 I=1,3
      HCON(I) = 9999.
      IF (HKLMAX(I) .GT. 0.1) HCON(I) = HKLMAX(I)
  230 CONTINUE
      NREF = 0
      MREF = 0
      MREF99 = 0
      IEND = 1
  240 CALL MEREAD (HKL, JC, FOBS, SIG, IEND)
      IF (IEND .LT. 0) GOTO 270
      MREF = MREF + 1
      CALL HKLAXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 240
      CALL HKLEXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 240
      IF (ABS(HKL(1)).GT.HCON(1) .OR. ABS(HKL(2)).GT.HCON(2) .OR.
     *    ABS(HKL(3)).GT.HCON(3)) GOTO 240
      CALL HKLSTL (HKL, STL, STL2)
      IF (STL .GT. STLCON) GOTO 240
      MREF99 = MREF99 + 1
      IF (ABS (HKL(1)) .GT. 99. .OR. ABS (HKL(2)) .GT. 99. .OR.
     *    ABS (HKL(3)) .GT. 99. ) GOTO 240
      STLMAX = AMAX1 (STLMAX, STL)
      NREF = NREF + 1
      CALL HKLEXS (FRIE, HKL, HCODE)
      FOBS = AMAX1 (FOBS, 0.01)
      SIG  = AMAX1 (SIG, FOBS / 100. , 0.01)
      IF (JC .EQ. 2) SIG = AMAX1(FOBS/6.0, SIG)
      CALL WRPEAK(0)
      SIG = SIG * 2. * FOBS
      FOBS = FOBS ** 2
      HCODMI = AMIN1(HCODMI, HCODE)
      HCODMA = AMAX1(HCODMA, HCODE)
      CALL HKLC1U (HCODE, HKL)
      DO 260 I =1,3
      HMAX(I) = AMAX1 (HKL(I),HMAX(I))
  260 HMIN(I) = AMIN1 (HKL(I),HMIN(I))
      HKMAX  = AMAX1 (HKMAX, ABS(HKL(1)+HKL(2)) )
      FBINX(4,NREF) = HCODE
      FBINX(5,NREF) = FOBS
      FBINX(6,NREF) = SIG
      IF (NREF .EQ. MBINX) STOP 230
      GOTO 240
  270 CONTINUE
      FBINX(4,NREF+1) = 0.
      FBINX(5,NREF+1) = -1.
      FBINX(6,NREF+1) = 0.
      CALL KERNZA (0., ATXYZ, 10)
      IZAT(1) = 1
      STLMAX = STLMAX + 0.00001
      NAT = 1
      CALL FCALCI (ATXYZ, IZAT, ITAT, 1)
      CALL HKLSYX (ISYST, HMAX, HMIN, HKMAX, HKLMAX)
      WRITE(24, 292) MREF
  292 FORMAT (' Number of input reflections:    ', I17)
      IF (MREF-NREF .GT. 0) WRITE(24, 294) NREF
  294 FORMAT (' Number of relections accepted:  ', I17)
      MREF99 = MREF99 - NREF
      IF (MREF99 .GT. 0) WRITE (9, 295) MREF99
  295 FORMAT (' Number of relections with hkl exceeding 99:  ', I7/
     *        ' WARNING: these reflections are not used in DIRDIF !'/1X)
      CALL KERF2I (HMAX, ITEMP, 3)
      CALL KERF2I (HMIN, ITEMP(4), 3)
      CALL KERF2I (HKLMAX, ITEMP(7), 3)
      WRITE(24, 300) ITEMP, STLMAX
  300 FORMAT (10X, ' Maximum indices output: ', 3I5 /
     *        10X, ' Minimum indices output: ', 3I5 /
     *        10X, ' HKLmax  incl. symmetry: ', 3I5 /
     *        10X, ' Maximum sin(TH/LAMBDA): ', F15.5 )
      CALL WR24
      IF (KSTAT(13) .LE. 0) KSTAT(13) = 1
      SUMRN1 = 0.
      SUMRN2 = 0.
      NSUMR  = 0
      CALL HKLC2I (HMIN, HMAX)
      CALL HKLC1U (HCODMI, HKL)
      CALL HKLC2  (HKL, ACODMI)
      IREFX = 0
  310 AF = ACODMI - 1.1
      CALL HKLC2U (ACODMI + AMAX - 1., HKL)
      CALL HKLC1  (HKL, HCODEL)
      CALL KERNZA (0.0, AREF, 4 * MAXA)
  320 CONTINUE
      IF (IREFX .GE. NREF) GOTO 330
      IREFX = IREFX + 1
      HCODE = FBINX(4,IREFX)
      FOBS = FBINX(5,IREFX)
      SIG = FBINX(6,IREFX)
      IF (FOBS.LT.0.) GOTO 330
      IF (HCODE.LT.HCODMI .OR. HCODE.GT.HCODEL) GOTO 320
      CALL HKLC1U (HCODE, HKL)
      CALL HKLC2  (HKL, ACODE)
      IA = IFIX (ACODE - AF)
      AREF(1,IA) = AREF(1,IA) + 1.
      IF (NINT(AREF(1,IA)) .EQ. 2) THEN
         SUMRN1 = SUMRN1 + ABS(AREF(3,IA)-FOBS)
         SUMRN2 = SUMRN2 +     AREF(3,IA)+FOBS
         NSUMR = NSUMR + 1
         ENDIF
      AREF(2,IA) = HCODE
      AREF(3,IA) = AREF(3,IA) + FOBS
      AREF(4,IA) = AREF(4,IA) + SIG
      GOTO 320
  330 DO 340 I = 1,MAXA
      IF (AREF(1,I).LE.0.1) GOTO 340
      TOT = AREF(1,I)
      HCODE = AREF(2,I)
      FOBS  = AREF(3,I) / TOT
      SIG   = AREF(4,I) / TOT **1.5
      FOBS = SQRT(FOBS)
      SIG  = SIG / (2. * FOBS)
      IREF = IREF + 1
      FBINX(1,IREF) = HCODE
      FBINX(2,IREF) = FOBS
      FBINX(3,IREF) = SIG
      CALL HKLC1U (HCODE, HKL)
      CALL HKLSTL (HKL, STL, STL2)
      CALL WILSIM
  340 CONTINUE
      IF (HCODEL.GE.HCODMA) GOTO 350
      ACODMI = ACODMI + AMAX
      CALL HKLC2U (ACODMI, HKL)
      CALL HKLC1 (HKL, HCODMI)
      GOTO 310
  350 CONTINUE
      FBINX(1,IREF+1) = 0.
      FBINX(2,IREF+1) = -1.
      FBINX(3,IREF+1) = 0.
      WRITE (9, 360) IREF
  360 FORMAT (' Number of reflections (merged) output: ' , I8/1X)
      IF (IREF .LE. 0) CALL KERROR ('Number of refl. = 0',0,'MERBIN')
      NREFL = IREF
      IF (NSUMR .GT. 10) THEN
         SUMRN1 = SUMRN1 / SUMRN2
         WRITE (24, 401) NSUMR, SUMRN1
  401    FORMAT (' R-merge  on F**2 for',I5,' reflections is R=',F6.2)
         ENDIF
      CALL WR24
      WRITE (8,490)
  490 FORMAT (/' Least squares Wilson plot' /
     *   ' Range  Sin(Th/Lambda)**2   Number  <|Fobs|**2/F2>' )
      STLM2  = STLMAX**2 / 9.
      NOWT = 0
      DO 560 I=1,9
      NOWT = NOW(I) + NOWT
      STMIN= FLOAT(I-1)  * STLM2
      STMAX= FLOAT(I)    * STLM2
      AWNOW = 0.
      IF (NOW(I) .GT. 0) AWNOW = AW(I)/NOW(I)
      WRITE(8,550) I, STMIN, STMAX, NOW(I), AWNOW
  550 FORMAT(I5,F10.4,' - ',F6.4,I10,F14.6)
  560 CONTINUE
      WRITE(8,570) NOWT
  570 FORMAT(/' Total number of reflections:', I5/)
      CALL WILPAR
      CALL WR24
      SCAMER = SCALE
      BOVMER = BOV
      CALL LOGMER (IREF, HMAX, HMIN, HKLMAX, STLMAX, SCALE, BP)
      CALL WRPEAK(NREF)
      CALL FILCLO (IDDL, 'KEEP')
      CALL WR24
      WRITE (8, 603)
  603 FORMAT( /' ==== END OF SUB-PROGRAM MERBIN ==== '//)
      RETURN
      END
      SUBROUTINE MEREAD (HKL, JC, FOBS, SIG, IEND)
      DIMENSION HKL(3)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (ICRIN,IFILE(4)), (IHKL,IFILE(11)), (ISHEL,IFILE(12))
      DIMENSION HH(3,3), HT(3)
      CHARACTER IE *1
      CHARACTER *6 XHKL(7)
      CHARACTER *80 CHINA
      LOGICAL FIRST, F2, TRANS
      DATA XHKL / 'HKL', 'SHELX'  ,
     *            'FREFB', 'FREFC', 'FREFA', 'FREF', 'CIF' /
      DATA FIRST /.FALSE./
      IF (IEND .EQ. 1) THEN
         IEND = 0
         FIRST = .FALSE.
         F2 = .FALSE.
         TRANS = .FALSE.
         IDNUM = 0
         ENDIF
      IF (FIRST) GOTO 310
      FIRST = .TRUE.
      DO 110 ID = 1, 7
      CALL FILINQ (IHKL, XHKL(ID), 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. 0) GOTO 120
  110 CONTINUE
      CALL KERROR ('No reflection file found', 0, 'MERBIN')
  119 CONTINUE
      CALL KERROR(' Empty refl.data file', 119, 'MEREAD')
  120 IF (ID .EQ. 7) GOTO 180
      IDNUM = 1
      CHIN = ' '
      READ (IHKL, FMT='(A28)', END=119) CHIN(1:28)
      WRITE (24, 140) XHKL(ID), CHIN(1:28)
  140 FORMAT (1X/' Input data file: ', A6, ' Header: ', A28)
      CALL KERINB (LIT, 1)
      IF (ID .LE. 2) GOTO 145
      IF (ID .LE. 6 .AND. LIT(1)(1:4) .NE. 'FREF')
     *   CALL KERROR ('File name and header inconsistent' , 0, 'MERBIN')
      IF (LIT(2) .NE. CCODE)
     *   CALL KERROR ('Input file has incorrect CCODE', -6, 'MERBIN')
      IDNUM=1
      GOTO 310
  145 IDNUM = 3
      INUM = 0
      IHKLF = 0
      CHINA = CHIN
      IF (LIT(1) .EQ. ' ') THEN
         BACKSPACE IHKL
         GOTO 148
      ELSE
         IF (CHIN(1:4) .NE. 'HKLF') THEN
            CALL FILCLO (IHKL, 'KEEP')
            CALL KERROR ('Incorrect header record', 167, 'MEREAD')
            ENDIF
         ENDIF
      KINS = -1
      CALL KERINB (LIT, 1)
      INUM = NINT(FNUM(1))
      IHKLF = 1
      GOTO 152
  148 CONTINUE
      CALL FILINQ (ISHEL, 'INS', 'FORMATTED', 'INPUT', KINS)
      IF (KINS .EQ. 0) GOTO 151
      CALL FILINQ (ISHEL, 'RES', 'FORMATTED', 'INPUT', KINS)
      IF (KINS .NE. 0) GOTO 152
  151 READ (ISHEL, END = 1152, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'HKLF') THEN
         CALL FILCLO (ISHEL, 'KEEP')
         CALL KERINB (LIT, 1)
         INUM = NINT(FNUM(1))
         IHKLF = 2
         GOTO 1152
         ENDIF
      GOTO 151
 1152 CALL FILCLO (ISHEL, 'KEEP')
  152 CONTINUE
      CALL FILCLO (ICRIN, 'KEEP')
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KINCR)
      IF (KINCR .NE. 0) THEN
         WRITE (9,*) 'CRYSIN file not found: rerun CRYSDA !'
         GOTO 1155
         ENDIF
  153 READ (ICRIN, END = 1155, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'HKLF') THEN
         CALL FILCLO (ICRIN, 'KEEP')
         CALL KERINB (LIT, 1)
         INUMX = NINT(FNUM(1))
         IF (IHKLF .GT. 0 .AND. INUM .NE. INUMX) THEN
            WRITE (9,*) 'HKLF on CRYSIN incorrect / discarded '
         ELSEIF (INUM .EQ. 0) THEN
            INUM = INUMX
            IHKLF = 3
         ELSE
            IHKLF = 3
            ENDIF
         GOTO 1155
         ENDIF
      GOTO 153
 1155 CONTINUE
      IF (INUM .NE. 0 .AND. IHKLF .GT. 0) GOTO 156
  155 WRITE (9,2155)
      WRITE(24,2155)
 2155 FORMAT (' The reflection file may contain F or F**2 values;'/
     *   ' but no HKLF record was found.'/
     *   ' your hkl file is assumed to have F**2 values.')
      F2 = .TRUE.
      CHIN = CHINA
      INUM = 4
      IHKLF = 4
  156 IF (IABS (INUM) .NE. 3 .AND. IABS (INUM) .NE. 4) THEN
         WRITE (9, FMT='('' input: HKLF'', I3, '' ??'')') INUM
         GOTO 155
         ENDIF
      IF (KINCR .NE. 0 .OR. IHKLF .EQ. 3) GOTO 163
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'OUTPUT', KINCR)
      CALL FILINQ (ISHEL, 'PAULTB', 'FORMATTED', 'SCRATCH', IIIII)
  157 READ (ICRIN, END = 158, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'HKLF') GOTO 157
      WRITE (ISHEL, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'END ') GOTO 158
      GOTO 157
  158 REWIND ICRIN
      REWIND ISHEL
 1157 READ (ISHEL, END = 1158, FMT = '(A80)') CHIN
      IF (CHIN(1:4) .EQ. 'END ') GOTO 1158
      WRITE (ICRIN, FMT = '(A80)') CHIN
      GOTO 1157
 1158 WRITE (ICRIN, FMT='(''HKLF'', I4 / ''END'' )') INUM
      WRITE (9, FMT='('' HKLF'', I3,
     *   ''  :  written to the CRYSIN file'')') INUM
      CALL FILCLO (ICRIN, 'KEEP')
      CALL FILCLO (ISHEL, 'DELETE')
 163  INUM = IABS (INUM)
      WRITE (CHOUT, 162) INUM
 162  FORMAT ('HKLF', I4, ' .. HKLF number for SHELX data file')
      CALL LOGWR (IDDL)
      IF (INUM.EQ.3) THEN
         WRITE(24, 165)
 165     FORMAT(' Input SHELXL or HKL file: SHELX format (Fobs values)')
      ELSEIF (INUM.EQ.4) THEN
         WRITE(24, FMT=
     *   '('' Input SHELX or HKL file with Fobs**2 values '')')
         F2 = .TRUE.
      ELSE
         CALL KERROR ('Unknown contents of SHELX or HKL file ...', 165,
     *      'MEREAD')
         ENDIF
      IF (NFNUM .GE. 11) THEN
         TRANS = .TRUE.
         DO 175  I = 1, 3
         DO 175  J = 1, 3
  175    HH(I,J) = FNUM(3*I + J -1)
         ENDIF
      GOTO 310
  180 IDNUM = 4
  190 CALL KERINA( IHKL, LIT, 1, KEND)
      IF (KEND .NE. 0) CALL KERROR ('Incorrect CIF file', 190, 'MEREAD')
      IF (CHIN(1:5) .EQ. 'data_') THEN
         IF (CHIN(6:11) .NE. CCODE) WRITE(24, FMT=
     *       '('' Warning: input CIF file has incorrect CCODE'')')
         GOTO 190
         ENDIF
      IF (CHIN(1:13) .EQ.'_refln_F_calc') THEN
         WRITE(24, FMT='('' Input CIF file with Fobs values '')')
         GOTO 190
         ENDIF
      IF (CHIN(1:21) .EQ.'_refln_F_squared_calc') THEN
         WRITE(24, FMT='('' Input CIF file with Fobs**2 values '')')
         F2 = .TRUE.
         GOTO 190
         ENDIF
      IF (CHIN(1:21) .EQ.'_refln_intensity_calc') THEN
         CALL KERROR ('CIF file with intensities', 190, 'MEREAD')
         ENDIF
      IF (CHIN(1:23) .NE.'_refln_scale_group_code') GOTO 190
  310 IEND = 0
      GOTO (410,  420, 430,  440), IDNUM
  410 READ (IHKL, 415, END=418) IE, HKL, JC, FOBS, SIG
  415 FORMAT (A1, 3F3.0 ,I2, F9.2, F7.2)
      IF (IE .NE. 'E') RETURN
  417 CALL FILCLO (IHKL, 'KEEP')
      IEND = -1
      RETURN
  418 WRITE (9,FMT='(A)') ' Warning: sentinel E missing on FREF file !'
      GOTO 417
  419 WRITE (9,FMT='(A)') ' Warning: sentinel 000 missing on HKL file !'
      GOTO 417
  420 WRITE (9,FMT='(A)') ' CARD3 refl.file is obsolete !'
      STOP 420
  430 READ (IHKL, 435, END=419) HKL, FOBS, SIG
  435 FORMAT (3F4.0, 2F8.2)
      IF (ABS(HKL(1)) + ABS(HKL(2)) + ABS(HKL(3)) .LT. 0.1) GOTO 417
      IF (TRANS) THEN
         CALL KERNAB (HKL, HT, 3)
         DO 437 I = 1,3
         HKL(I) = 0.0
         DO 437 J = 1,3
  437    HKL(I) = HKL(I) + HT(J) * HH(I,J)
         ENDIF
      JC = 0
  438 IF (.NOT. F2) RETURN
      FOBS = AMAX1 (FOBS, SIG / 100. , 0.0001)
      FOBS = SQRT(FOBS)
      SIG  = SIG / (2. * FOBS)
      RETURN
  440 CALL KERINA( IHKL, LIT, 1, KEND)
      IF (KEND .NE. 0 .OR. CHIN(1:6) .EQ. '_publ_')  GOTO 417
      CALL KERNAB (FNUM, HKL, 3)
      FOBS = FNUM(4)
      SIG =  FNUM(5)
      GOTO 438
      END
      SUBROUTINE LOGMER (NREF, HMAX, HMIN, HKLMAX, STLMAX, SCALE, BOV)
      DIMENSION HMAX(3), HMIN(3), HKLMAX(3)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      CALL LOGRD (IDDL, 'MERBSC', KLOG)
      IF (KLOG .LT. 0 .OR. LIT(2) .NE. 'SCALE') GOTO 188
      IF (NINT (10000.*SCALE) .NE. NINT(10000.*FNUM(2)) ) GOTO 188
      IF (NINT (1000.*BOV) .NE. NINT(1000.*FNUM(3)) ) GOTO 188
      CALL LOGRD (IDDL, 'NREF', KLOG)
      IF (KLOG .LT. 0 .OR. FNUM(2) .LT. 0.9) GOTO 188
      IF (NREF .NE. NINT(FNUM(2)) ) GOTO 188
      RETURN
  188 WRITE (CHOUT, 200) NREF, HMAX, HMIN
  200 FORMAT ('NREF ', I6, '    HMAX  ', 3F5.0, ' HMIN', 3F5.0)
      CALL LOGWR (IDDL)
      WRITE (CHOUT, 220) STLMAX, HKLMAX
  220 FORMAT ('STLMAX ', F7.5, ' HKLMAX', 3F5.0)
      CALL LOGWR (IDDL)
      WRITE (CHOUT, 230) SCALE, BOV
  230 FORMAT ('SCALE ', F14.7, ' BOV ', F10.5, 14X, ' MERBSC')
      CALL LOGWR (IDDL)
      RETURN
      END
      SUBROUTINE WILSIM
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zwils.inc'
      EQUIVALENCE (KEYWIL, KSTAT(17))
      PARAMETER  (NRS = 9)
      LOGICAL     SWIL
      DATA SWIL / .FALSE. /
      DATA  STLM2, FNRS3 / 0.0 , 0.0 /
      IF (SWIL) GOTO 180
      SWIL = .TRUE.
      KEYWIL =-1
      EPMIN = 9999.
      EPMAX =-9999.
      CALL KERNZI (0 , NOW, NRS)
      CALL KERNZI (0 , NUW, NRS)
      CALL KERNZA (0.,  AW, NRS)
      CALL KERNZA (0., AAW, NRS)
      CALL KERNZA (0.,  BW, NRS)
      FHMN = 0.
      FNRS3  = FLOAT(NRS+1)
      STLM2  = STLMAX**2
      BPINP = 2.0
      IF (NINT(10000.*BOV) .NE. 20000 ) BPINP = BOV
      BRINP = BPINP
      BPMAX = 10.
      BPMIN =  0.
      BRMAX = 10.
      BRMIN =  0.
  180 ISS = IFIX (STL * 400. + 1.5)
      FOBS = FOBS / EXPBR(ISS)
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      TUMF2 = SUMF2(ISS) * EPSIL
      K = (STL2/STLM2) * FNRS3 + 1.
      IF (K.GT.NRS) K = NRS
      NOW(K) = NOW(K) + 1
      IF (FOBS .LT. 5.*SIG)  NUW(K) = NUW(K) + 1
      FOBS = FOBS**2 / TUMF2 / ALATT
      AW(K) = AW(K)  + FOBS
      BW(K) = BW(K) + STL2
      RETURN
      END
      SUBROUTINE WRPEAK (KEY)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      DIMENSION FBOV(5), RHO(10,5)
      EQUIVALENCE (FBOV, BFAC), (RHO, PHFAC)
      DIMENSION HKL(3)
      EQUIVALENCE (HKL(1), HKLX(1,1))
      PARAMETER (MAXA = 10000)
      COMMON /BLANK/ AREF(4, MAXA), DUMMY(120000)
      DIMENSION FH(5,10), FHSUM(5,10), FHSYS(5,10)
      DIMENSION IKSYS(3), ISYSAR(111)
      DIMENSION NWRP(100,2)
      DATA NCALL /0/
      IF (NCALL .EQ. 2) RETURN
      IF (KEY .GT. 0) GOTO 151
      IF (NCALL .EQ. 0) THEN
         CALL KERNZI (0, NWRP, 200)
         CALL WR24
         NCALL = 1
         ENDIF
      IPH = IFIX (STL * 100. + 1.5)
      IF (IPH .GT. 100) IPH = 100
      IF (FOBS .GT. 2. * SIG) THEN
         NWRP(IPH, 1) = NWRP(IPH, 1) + 1
      ELSE
         NWRP(IPH, 2) = NWRP(IPH, 2) + 1
         ENDIF
      RETURN
  151 CONTINUE
      STLPH = STLMAX
      IF (KEY .LT. 500) GOTO 166
      I1 = IFIX (STLMAX * 100. + 1.5) / 2
      DO 158 I = I1, 100
      IF (NWRP(I, 1) + NWRP(I, 2) .LT. 10) GOTO 158
      IF (NWRP(I, 1) .LT. NWRP(I, 2)) THEN
         STLPH = FLOAT(I-1) / 100.
         GOTO 166
         ENDIF
  158 CONTINUE
  166 CONTINUE
      CALL KERNZA (0., FH, 50)
      CALL KERNZA (0., FHSUM, 50)
      CALL KERNZA (0., RHO, 50)
      INREPS = 0
      IREFX = 0
  201 CONTINUE
      IREFX = IREFX + 1
      HCODE = FBINX(1,IREFX)
      FOBS = FBINX(2,IREFX)
      IF (FOBS .LT. 0.) GOTO 220
      SIG = FBINX(3,IREFX)
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      ISS = IFIX (STL * 400. + 1.5)
      IF (STL .GT. STLPH) GOTO 201
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = FLOAT(IEPS)
      DO 205 I = 1,5
      FACBOV = I-3
      FBOV(I) = BOV + FACBOV * 0.1 * BOV
      EXPBOV = EXP(- FBOV(I) * STL2)
      DO 205 J = 1,NTYPE
      FH(I,J) = FF(ISS,J) * EXPBOV
      FHSUM(I,J) = FHSUM(I,J) + (FH(I,J)/EPSIL)
      IF (EPSIL.GT.1.01) INREPS = INREPS + 1
  205 CONTINUE
      INREPS = INREPS / 5
      GOTO 201
  220 CALL KERNZA (0.,FHSYS,50)
      CALL KERNZI (0,ISYSAR,111)
      IF (ISYST.EQ.1) GOTO 230
      IF (ISYST.EQ.2) THEN
         CALL KERNZI (0,IKSYS,3)
         IKSYS(IUNIQ)=1
         CALL SYSEX (IKSYS,    FHSYS,ISYSAR, STLPH)
         CALL KERNZI (1,IKSYS,3)
         IKSYS(IUNIQ)=0
         CALL SYSEX (IKSYS,  FHSYS,ISYSAR, STLPH)
         ENDIF
      IF (ISYST.EQ.3) THEN
         DO 225 IC = 1,3
         CALL KERNZI (1,IKSYS,3)
         IKSYS(IC) = 0
         CALL SYSEX (IKSYS,  FHSYS,ISYSAR, STLPH)
  225    CONTINUE
         ENDIF
      IF (ISYST.GE.4) THEN
         CALL KERNZI (1,IKSYS,3)
         CALL SYSEX (IKSYS,  FHSYS,ISYSAR, STLPH)
         ENDIF
  230 FMULTT = FLOAT( 2 * NSYMM * NLATT )
      DO 240 I = 1, 5
      DO 240 J = 1, NTYPE
      RHO(J,I) = (FLOAT(IZTYPE(J)) +
     *   ((FMULTT * FHSUM(I,J)) + (2. * FHSYS(I,J)))  )/ VOLUM
  240 CONTINUE
      WRITE (8, FMT='(/'' WRPEAK: expected atomic peak heights'',
     *       '' for five isotropic B values:''/)')
      WRITE (8,FMT='(''    for B =   '',5F7.3/
     *      '' Atom         '', 35(''-'')) ') FBOV
      DO 260 J = 1,NTYPE
      WRITE(8,FMT='('' Type'',I2,3X,A2,1X,5F7.2)') J,CELATY(J),
     *         (RHO(J,I), I=1,5)
  260 CONTINUE
      WRITE(8,FMT='(/'' Type   h  k  l   nr of syst.ext. refl'',/
     *                 '' --------------   for hemisphere H > 0'')')
      DO 270 I=0,1
      DO 270 J=0,1
      DO 270 K=0,1
      IKCODE = (100*I)+(10*J)+K
      IF (IKCODE.EQ.0) GOTO 270
      IF (ISYSAR(IKCODE) .GT. 0)
     *   WRITE (8,265)I,J,K,ISYSAR(IKCODE)
  265 FORMAT (' Refl:',3I3,I10)
  270 CONTINUE
      WRITE(8,FMT='(/'' Nr refl. with Epsilon>1.0 :'', I6)') INREPS
      NCALL = 2
      RETURN
      END
      SUBROUTINE SYSEX (IKSYS,   FHSYS,ISYSAR, STLPH)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      DIMENSION HKL(3), FH(5,10), FHSYS(5,10)
      DIMENSION IHMAXT(3), IKSYS(3), ISYSAR(111)
      CALL KERNZA (0., FH, 50)
      DO 200 I=1,3
      IF (IKSYS(I).EQ.0) THEN
         IHMAXT(I) = 0
      ELSE
         IHMAXT(I) = NINT(HKLMAX(I)) - 1
         ENDIF
  200 CONTINUE
      STLMT = AMIN1 (0.90 * STLMAX, STLPH)
      DO 229 IH=0,IHMAXT(1)
      IF ((ISYST.EQ.3).AND.(IH.EQ.0)) THEN
         IF ((IKSYS(2).EQ.0).OR.(IKSYS(3).EQ.0)) GOTO 229
         ENDIF
      HKL(1)=IH
      DO 228 IK=-IHMAXT(2),IHMAXT(2)
      IF ((ISYST.EQ.3).AND.(IKSYS(3).EQ.0).AND.(IK.EQ.0)) GOTO 228
      HKL(2)=IK
      DO 227 IL=-IHMAXT(3),IHMAXT(3)
      HKL(3)=IL
      CALL HKLSTL (HKL, STL, STL2)
      IF (STL.GT.STLMT) GOTO 227
      ISS = IFIX (STL * 400. + 1.5)
      CALL HKLC1(HKL,HCODE)
      CALL HKLAXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 227
      CALL HKLEXT (HKL, KEND)
      IF (KEND.LT.0) THEN
         IKCODE = 0
         IF (NINT(HKL(1)).NE.0) IKCODE = IKCODE + 100
         IF (NINT(HKL(2)).NE.0) IKCODE = IKCODE + 10
         IF (NINT(HKL(3)).NE.0) IKCODE = IKCODE + 1
         ISYSAR(IKCODE) = ISYSAR(IKCODE) + 1
         DO 223 I = 1,5
         FACBOV = I-3
         BOVMOD = BOV + FACBOV * 0.1 * BOV
         EXPBOV = EXP(- BOVMOD * STL2)
         DO 223 J = 1,NTYPE
         FH(I,J) = FF(ISS,J) * EXPBOV
         FHSYS(I,J) = FHSYS(I,J) + FH(I,J)
  223    CONTINUE
         ENDIF
  227 CONTINUE
  228 CONTINUE
  229 CONTINUE
      RETURN
      END
      SUBROUTINE WILPAR
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL SWIPRI
      EQUIVALENCE (SWIPRI, SWITCH(10))
      EQUIVALENCE (KEYWIL, KSTAT(17))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zwils.inc'
      CALL WR24
      IF (KEYWIL.EQ.4) RETURN
      IF (.NOT. SWIPRI) GOTO 220
      IF (KEYWIL.NE.-1) THEN
         WRITE (8, 200)
  200    FORMAT(/ ' Data for WILSON-PARTHASARATHY plot:', /,
     *          ' Range  NOBS NUNOBS  <FO2/F2>  <(FP2+F2R)/F2>  STL2 ',
     *          ' ln<FO2/(FP2+F2R)>')
      ELSE
         WRITE (8, 210)
  210    FORMAT(/ ' Data for WILSON plot:', /,
     *          ' Range  NOBS NUNOBS  <FO2/F2>  STL2  ln<FO2/F2>')
         ENDIF
  220 NRS = 9
      NNOW = 0
      DO 230 I=1,NRS
  230 NNOW = NNOW + NOW(I)
      IF (NNOW.GT. 399) GOTO 250
      J = 0
      DO 240 I=1,(NRS-1),2
      J = J + 1
      NOW(J) = NOW(I) + NOW(I+1)
      NUW(J) = NUW(I) + NUW(I+1)
      AW(J)  = AW(I)  + AW(I+1)
      AAW(J) = AAW(I) + AAW(I+1)
  240 BW(J)  = BW(I)  + BW(I+1)
      NOW(J) = NOW(J) + NOW(NRS)
      NUW(J) = NUW(J) + NUW(NRS)
      AW(J)  = AW(J)  + AW(NRS)
      AAW(J) = AAW(J) + AAW(NRS)
      BW(J)  = BW(J)  + BW(NRS)
      NRS = J
  250 I = 1
  260 IF (NNOW.GT.399 .AND. NOW(I).GT.25) GOTO 280
      IF (NNOW.LE.399 .AND. NOW(I).GT.NNOW/20) GOTO 280
      NRS = NRS - 1
      IF (I.GT.NRS) GOTO 320
      DO 270 J=I,NRS
      NOW(J) = NOW(J+1)
      NUW(J) = NUW(J+1)
      AW(J)  = AW(J+1)
      AAW(J) = AAW(J+1)
  270 BW(J)  = BW(J+1)
      GOTO 260
  280 AW(I)  = AW(I)  / NOW(I)
      AAW(I) = AAW(I) / NOW(I)
      BW(I)  = BW(I)  / NOW(I)
      IF (AAW(I).LT.0.001 .OR. KEYWIL.EQ.-1) AAW(I) = 1.0
      IF (AW(I) .LT. 0.0001) AW(I) = 0.0001
      X1 = ALOG(AW(I) / AAW(I))
      IF (.NOT. SWIPRI) GOTO 310
      IF (KEYWIL.NE.-1) THEN
          WRITE (8, 290) I, NOW(I), NUW(I), AW(I), AAW(I), BW(I), X1
  290     FORMAT (1X, I3, I8, I5, F11.4, F13.4, F11.4, F13.4)
      ELSE
          WRITE (8, 300) I, NOW(I), NUW(I), AW(I), BW(I), X1
  300     FORMAT (1X, I3, I8, I5, F11.4, F8.4, F10.4)
          ENDIF
  310 AW(I) = X1
      I = I + 1
      IF (I.LE.NRS)  GOTO 260
  320 IF (NRS.LE.1)  THEN
          WRITE(24, 330) NRS
          WRITE (8, 330) NRS
  330     FORMAT (' WILSON-PARTHASARATHY plot not possible, number of',
     *            ' ranges: ', I3)
          RETURN
          ENDIF
      IF (KEYWIL .NE. -1) THEN
         WRITE (8, 339)  BP, BR
  339    FORMAT (/' Input values for WILSON-PARTHASARATHY',
     *           ' plot: Bp=', F7.3, '  Br=', F7.3/)
         WRITE (8, 340)
  340    FORMAT (/' WILSON-PARTHASARATHY plot '/
     *            ' LN <FO**2/(FP**2+F2R)>')
         WRITE(24, FMT='(/ A)') ' WILSON-PARTHASARATHY plot results'
      ELSE
         WRITE (8, FMT='('' Input values for WILSON plot:  '',
     *     '' Overall B ='',F7.3,''  Scale SC ='',F9.5/)') BOV, SCALE
         WRITE (8, 350)
  350    FORMAT (' WILSON plot' / ' LN <FO**2/F2>')
         ENDIF
      CALL WILDUP (AW, BW, NOW, NUW, NRS, C, S)
      SCALET = EXP(-0.5 * C)
      IF (SCALET .LT. 0.001) THEN
         WRITE (24, FMT='('' WIL-PAR Scale:'', F10.6,
     *      '' not accepted '')') SCALET
         WRITE (8, FMT='('' $TE SCALE W.P.x'',I3,2F6.3,F8.4,12X, I5 )')
     *       NRECYR, PSQ, R2X, SCALET, KEYWIL
         RETURN
         ENDIF
      IF (KEYWIL .NE. -1) THEN
         SCALE = SCALET
      ELSE
         IF (NINT(10000.*SCALE) .EQ. 10000 ) THEN
            SCALE = SCALET
         ELSE
            KEYWIL = -4
         WRITE (24, FMT='('' CONDAT Scale:'', F8.4,
     *      '' retained '')') SCALE
            ENDIF
         ENDIF
      BD = -0.5 * S
      BPT = BP + BD
      IF (BPT .GT. 25. .OR. BPT .LE. 0.001) THEN
         WRITE (24, FMT='('' WIL-PAR Scale+Bov:'', F8.4, F7.3,
     *      '' not accepted '')') SCALE, BPT
      WRITE (8, FMT='('' $TE SCALE W.P.x'',I3,2F6.3,F8.4, 12X, I5)')
     *       NRECYR, PSQ, R2X, SCALE, KEYWIL
         IF (KEYWIL .EQ. -4) KEYWIL = -1
         RETURN
         ENDIF
      WRITE (8, FMT='('' $TE SCALE W.P. '',I3,2F6.3,F8.4, ''  Bov='',
     *   F6.3, I5)')  NRECYR, PSQ, R2X, SCALE, BPT, KEYWIL
      IF (KEYWIL .EQ. -1  .OR. KEYWIL .EQ. -4) THEN
         IF (NINT(10000.*BOV) .EQ. 20000 ) THEN
            BOV = BPT
         ELSE
            WRITE (24, FMT='('' CONDAT B-0v: '', F8.4,
     *         '' retained '')') BOV
            ENDIF
         WRITE (24, 360) SCALE, BOV
  360    FORMAT (/' Wilson scale and overall temperat. factor:',
     *          '  Scale=', F9.5, '  Bov=', F6.3)
         IF (KEYWIL .EQ. -4) KEYWIL = 4
         IF (KEYWIL .EQ. -1) KEYWIL = 0
         SCAMER = SCALE
         BOVMER = BOV
         RETURN
      ELSE
         IF (ABS(BP - BR) .LT. 0.0001) THEN
            BP = BPT
            BR = BP
            WRITE (24, 370) SCALE, BP
  370          FORMAT (/' WIL-PAR  Scale and Bov-value:   Scale=',
     *          F9.5, '  Bov=', F6.3)
         ELSE
            BRT = BR + BD
            WRITE (24, 372) SCALE, BRT
  372 FORMAT (/' WIL-PAR  Scale =',
     *          F9.5, ' (but new Bov=', F6.3, ' is ignored)')
            ENDIF
         ENDIF
      RETURN
      END
      SUBROUTINE WILDUP (Y, X, NOW, NUW, N, C, S)
      DIMENSION X(N), Y(N), NOW(N), NUW(N)
      INCLUDE 'Zsyst.inc'
      LOGICAL SWIPRI
      EQUIVALENCE (SWIPRI, SWITCH(10))
      DIMENSION YAXIS(6), XAXIS(6)
      CHARACTER * 1  BLANK, STAR, CH(78)
      DATA BLANK, STAR / ' ', '*' /
      SY  = 0.0
      SYY = 0.0
      SX  = 0.0
      SXX = 0.0
      SXY = 0.0
      YMIN = Y(1)
      YMAX = YMIN
      XMAX = X(N) * 1.125
      WWW = 0.
      DO 150  I=1,N
      WW = MAX0 (1, NOW(I) - NUW(I) )
      WWW = WWW + WW
      IF (Y(I).LT.YMIN)  YMIN = Y(I)
      IF (YMAX.LT.Y(I))  YMAX = Y(I)
      SY  = SY  + WW * Y(I)
      SYY = SYY + WW * Y(I)**2
      SX  = SX  + WW * X(I)
      SXX = SXX + WW * X(I)**2
  150 SXY = SXY + WW * X(I)*Y(I)
      S = (SY*SX - WWW*SXY) / (SX*SX - WWW*SXX)
      C = (SY - S*SX) / WWW
      YSCAL = 0.2 * (YMAX-YMIN)
      YMAX = YMAX + YSCAL
      YMIN = YMIN - YSCAL
      YSCAL = YMAX - YMIN
      YFAC = 20./YSCAL
      XFAC = 80./XMAX
      YAXIS(1) = YMAX
      XAXIS(1) = 0.00001
      DO 210  I=2,6
      FI1 = FLOAT(I-1)
      XAXIS(I) = XMAX/5.0*FI1
  210 YAXIS(I) = YMAX - (YSCAL/5.*FI1)
      CALL KERNZ1 (STAR, CH, 78)
      WRITE (8, 220)  STAR, YAXIS(1), (CH(II),II=7,78)
  220 FORMAT (' ', A1, F5.2, ' ', 72A1)
      M = 2
      DO 260  I=2,19
      FI20 = FLOAT(20 - I)
      CALL KERNZ1 (BLANK, CH, 78)
      CH(1) = '*'
      L  = ((YMIN + (YSCAL*  FI20)     /20.) -C)/S*XFAC + 0.5
      L1 = ((YMIN + (YSCAL* (FI20-1.)) /20.) -C)/S*XFAC + 0.5
      IF (L.GT.0 .AND. L.LE.78) CH(L) = '.'
      IF (ABS(L1-L).LE.5) GOTO 229
      IF (S.LT.0.00001) THEN
          I1 = L + 3
          I2 = L1 - 3
      ELSE
          I1 = L1 + 3
          I2 = L - 3
          ENDIF
      IF (I1.LE. 1) I1 = 2
      IF (I2.GT.78) I2 = 78
      DO 225 I12=I1,I2,3
  225 CH(I12) = '.'
  229 DO 230  J=1,N
      K = (Y(J)-YMIN)*YFAC + 0.5 + FLOAT(I)
      L = X(J)*XFAC + 0.5
      IF (K.EQ.20 .AND. L.LE.78)  CH(L) = 'X'
      IF (K.EQ.20 .AND. L.GT.78)  CH(78)= '+'
  230 CONTINUE
      IF (I/4*4.EQ.I)  GOTO 250
      WRITE (8, 240)  CH
  240 FORMAT (1H , 78A1)
      GOTO 260
  250 WRITE (8, 220)  STAR, YAXIS(M), (CH(II), II=7,78)
      M = M + 1
  260 CONTINUE
      CALL KERNZ1 (STAR, CH, 78)
      WRITE (8, 220)  STAR, YAXIS(6), (CH(II), II=7,78)
      WRITE (8, 270)  (XAXIS(II), II=2,6)
  270 FORMAT (F15.3, 4F16.3)
      WRITE (8, 280)
  280 FORMAT (60X, '(sinTHETA/LAMBDA)**2')
      IF (SWIPRI)  WRITE (8, 290) N, S, C
  290 FORMAT (/' Line based on', I10, ' points,    slope is ', F10.4, /
     *        ' intercept is ', F10.4)
      RETURN
      END
      SUBROUTINE HKLSYX (ISYST, HMAX, HMIN, HKMAX, HKLMAX)
      DIMENSION HMAX(3), HMIN(3), HKLMAX(3)
      DO 280 I=1,3
  280 HKLMAX(I) = AMAX1 (ABS(HMAX(I)), ABS(HMIN(I)) )
      IF (ISYST.LE.3) RETURN
      IF (HKMAX .GT. 99) HKMAX = 99
      IF (ISYST.EQ.6 .OR. ISYST.EQ.7)
     *                HKLMAX(1) = AMAX1 (HKLMAX(1), HKMAX)
      IF (ISYST.EQ.5 .OR. ISYST.EQ.8)
     *                HKLMAX(1) = AMAX1 (HKLMAX(1), HKLMAX(3))
      HKLMAX(1) = AMAX1 (HKLMAX(1),HKLMAX(2))
      HKLMAX(2) = HKLMAX(1)
      IF (ISYST.EQ.5 .OR. ISYST.EQ.8) HKLMAX(3) = HKLMAX(1)
      RETURN
      END
       SUBROUTINE FOUR
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IDOKA, KEYS(10)), (IRUN, KSTAT(13))
      PARAMETER (KUSER2=30000, KUSER1=KUSER2/3)
      CALL KEPROG('FOUR')
      WRITE(24, FMT = '(65X, ''RUN'', I4)') IRUN
      IF ( MPAT .NE. 0 .AND. MPAT .NE. -99) THEN
         WRITE(24, FMT = '(59X, ''atoms set'', I4)') IPAT
         ENDIF
      CALL FFTIN(KUSER1)
      CALL PP1
      CALL SEARCH
      IF (IDOKA .EQ. 17) RETURN
      CALL KEPROX
      RETURN
      END
      SUBROUTINE FFTIN (KUSER1)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zsear.inc'
      INCLUDE 'Zbuff.inc'
      EQUIVALENCE (ICRYS, IFILE(3)), (ICOND, IFILE(4))
      EQUIVALENCE (IBINFF, IFILE(16)), (IFMAP,  IFILE(17))
      EQUIVALENCE (ISCRA,  IFILE(18))
      EQUIVALENCE (KEYDS, KSTAT(20))
      EQUIVALENCE (KEYS(28), IHALF)
      LOGICAL      SWPRI, PRIMAP, SWRECY, NORECY
      EQUIVALENCE (SWRECY, SWITCH(7)), (NORECY, SWITCH(8))
      EQUIVALENCE (SWPRI, SWITCH(10)), (PRIMAP, SWITCH(11))
      EQUIVALENCE (IMAP, KSTAT(7))
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      DIMENSION IGM3(3)
      PARAMETER (LCMAX = 16)
      CHARACTER * 6 LCONDA(LCMAX)
      DATA LCONDA / 'FOUR',   'PRIMAP', 'GRID' , 'MAXXYZ', 'MINXYZ',
     *              'MAXHKL', 'GRIDMO', 'PEAKS', 'PROJEC', 'DOUT',
     *              'DMIN',   'DMAX',   'AMIN',  'AMAX',   'dummy$',
     *              'NORECY'/
      CALL WR24
      IACTOR  = 0
      FACTOR  = 0.25
      CALL KERNZA (0.0, XLMIN, 3)
      CALL KERNZA (1.0, XLMAX, 3)
      IGM3(1) = 1
      IGM3(2) = 1
      IGM3(3) = 2
      NPIC = 0
      NATIN = 0
      DMOUT = -1.
      DMINB = -1.
      DMAXB = -1.
      ANGM(1) = -1.
      ANGM(2) = -1.
      NAT = 0
      NATREC = 0
      NATX = 0
      NATSN = 0
  85  CALL RDCOND (ICOND, LCONDA, LCMAX , KEND)
      IF (KEND.LE.0) GOTO 101
      GOTO (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 85, 16), KEND
  1   CONTINUE
      GOTO 85
  2   PRIMAP = .TRUE.
      GOTO 85
  3   FACTOR = FNUM(1)
      IACTOR  = 1
      GOTO 85
  4   XLMAX(1) = AMIN1 (FNUM(1), 1.0)
      XLMAX(2) = AMIN1 (FNUM(2), 1.0)
      XLMAX(3) = AMIN1 (FNUM(3), 1.0)
      GOTO 85
  5   XLMIN(1) = AMAX1 (FNUM(1), 0.0)
      XLMIN(2) = AMAX1 (FNUM(2), 0.0)
      XLMIN(3) = AMAX1 (FNUM(3), 0.0)
      GOTO 85
   6   GOTO 85
  7   DO 707 I=1,3
      IF (FNUM(I).GE.1.0) IGM3(I) = NINT (FNUM(I))
      IF (IGM3(I).EQ.5 .OR. IGM3(I).GE.7)
     *    CALL KERROR ('BAD GRIDMO CARD', 6, 'FFTIN')
  707 CONTINUE
      GOTO 85
  8   NPIC = IFIX(FNUM(1))
      GOTO 85
  9   NATIN = IFIX(FNUM(1))
      GOTO 85
  10  DMOUT = FNUM(1)
      GOTO 85
  11  DMINB = FNUM(1)
      GOTO 85
  12  DMAXB = FNUM(1)
      GOTO 85
  13  ANGM(1) = FNUM(1)
      GOTO 85
  14  ANGM(2) = FNUM(1)
      GOTO 85
  16  NORECY = .TRUE.
      GOTO 85
  101 CALL FILCLO (ICOND, 'KEEP')
      WRITE (8, FMT='('' Option IMAP = '', I2)') IMAP
      IF (R2X .GT. 0.001 .AND. R2X .LT. 99.) THEN
         WRITE (24, FMT='(48X, '' ----------   R2 ='', F6.3)') R2X
         ENDIF
      CALL FILINQ (ISCRA, 'BINBIG', 'UNFORMATTED', 'OUTPUT', KINQ)
      IF (IMAP .NE. 5) THEN
         CALL FILINQ (IFMAP, 'FMAP',  'UNFORMATTED', 'OUTPUT', KINQ)
      ELSE
         CALL FILINQ (IFMAP, 'FMAPT', 'UNFORMATTED', 'OUTPUT', KINQ)
         ENDIF
      CALL KERF2I (HKLMAX, MH, 3)
      CALL RDCRYS (ICRYS)
      IHALF = 0
      GOTO (110, 120, 130, 130, 215, 120), IMAP
      STOP 302
  110 WRITE (24,111) CCODE
  111 FORMAT (' Fourier in space group P1 for compound ', A6)
      IF (ILATT.NE.1) WRITE (24, 112)
  112 FORMAT ('+', 47X, 'in non-promitive setting')
      NSYMM = 1
      IMULT = NLATT
      ICENT = 1
      ILAUE = 1
      NORECY = .TRUE.
      SWRECY = .FALSE.
      GOTO 190
  120 ICENT = 2
      IMULT = NSYMM * ICENT * NLATT
      CALL KERNZA(0.0, TSYMM, 72)
      IF (IMAP .EQ. 2) WRITE (24, 121)
  121 FORMAT (1X/' PATOR: sharpened Patterson for program ORIENT')
      IF (IMAP .EQ. 6) WRITE (24, 122)
  122 FORMAT (1X/' Sharpened Patterson for program PATTY')
      IF (ILAUE.EQ.2 .AND. IUNIQ.EQ.3) GOTO 220
      IF (ILAUE.EQ.1 .OR. ILAUE.EQ.4) GOTO 220
      IF (ILAUE.GE.6 .AND. ILAUE.LE.12) GOTO 220
      IHALF = -1
      GOTO 220
  130 IF (ICENT.EQ.2) THEN
         IHALF = -1
         GOTO 220
         ENDIF
  190 GOTO (192,191,192,191,191,191,191), ILATT
  191 IHALF = 1
      GOTO 220
  192 IF (IMAP.EQ.1) GOTO 220
      DO 197 II=1,NSYMM
      IF (IRSYMM(2,2,II).EQ.-1 .AND. TSYMM(2,II).LT.0.01) IHALF = -1
  197 IF (IRSYMM(2,2,II).EQ.1 .AND. (ABS(TSYMM(2,II)-0.5)).LT.0.01)
     *   IHALF = 1
      GOTO 220
  215 CONTINUE
      CALL KERROR (' IMAP=5 not accepted!', 215, 'FFTIN')
  220 IF (IACTOR .EQ.1) GOTO 230
      IF (IMAP .NE. 2 .AND. IMAP .NE. 6) GOTO 223
      IF (VOLUM .LE. 4000.) GOTO 223
      RESOL = ALOG(VOLUM/4000.) / 3.
      RESOL = 0.3 * EXP(RESOL)
      IF (RESOL.LT.FACTOR) GOTO 223
      FACTOR = RESOL
      WRITE (8, 222) FACTOR
  222 FORMAT (' The GRID spacing is approximately', F6.3, ' Angstrom')
  223 RESOL = AMIN1 (CELL(1) / FLOAT(MH(1)),
     +               CELL(2) / FLOAT(MH(2)),
     +               CELL(3) / FLOAT(MH(3))) * 0.25
      IF (RESOL .GE. FACTOR) THEN
         IF (RESOL .LT. FACTOR + 0.06) RESOL = FACTOR + 0.01
         IF (RESOL .GE. FACTOR + 0.06) RESOL = RESOL - 0.05
         FACTOR = RESOL
         WRITE(24, 222) FACTOR
         ENDIF
  230 IF (IHALF.NE.0 .AND. IGM3(3).EQ.1) IGM3(2) = 2
  240 DO 241 I=1,3
  241 NPP(I) = CELL(I) / FACTOR + 0.5
      DO 280 I=1,3
      ISGG = MOD (NPP(I), IGM3(I))
      IF (ISGG.NE.0) NPP(I) = NPP(I) + IGM3(I) - ISGG
  250 NTEST = NPP(I)
      DO 270 J=2,5
  260 IF (NTEST.NE.(NTEST/J)*J) GOTO 270
      NTEST = NTEST / J
      IF (NTEST.EQ.1) GOTO 280
      GOTO 260
  270 CONTINUE
      NPP(I) = NPP(I) + IGM3(I)
      GOTO 250
  280 CONTINUE
      WRITE (8, 222) FACTOR
      IF (NPP(1) .LE. 250) GOTO 400
      WRITE (8, 320)
  320 FORMAT (' NX GREATER THAN 250 (SEE SUBR. -OUTPUT-). RESET.'/)
      FACTOR = FACTOR * FLOAT(NPP(1)) / 245.
      GOTO 240
  400 I = (NPP(1)+2) * (NPP(3)+2)
      IF (I.LT.KUSER1) GOTO 406
      FACTOR = FACTOR * 1.02 * SQRT(FLOAT(I)/FLOAT(KUSER1))
      WRITE(24, 405)
      WRITE (8, 405)
  405 FORMAT (' TOO MANY GRID POINTS FOR PEAK SEARCH. RESET.'/)
      GOTO 240
  406 WRITE (8, 407) MH, NPP
  407 FORMAT (
     + ' Maximum indices allowed   h:', I4, '    k:', I4, '    l:', I4/
     + ' Number of grid points    Nx:', I4, '   Ny:', I4, '   Nz:', I4)
      DO 408 I = 1,3
      IF (NPP(I) .GE. 2 * MH(I) + 2) GOTO 408
      MH(I) = NPP(I) / 2 -1
      WRITE (8, FMT='(/'' Reset MAXHKL:'')')
      GOTO 406
  408 CONTINUE
      IF (SWPRI .AND. PRIMAP) WRITE (8, 410) XLMAX
  410 FORMAT (' FOURIER MAP TO BE PRINTED FROM:'/' X =  0.0  TO',
     +         F7.3,',  Y =  0.0  TO',F7.3,',  Z =  0.0  TO',F7.3)
      RETURN
      END
      SUBROUTINE SEARCH
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zsear.inc'
      COMMON /BLANK/ IFRAG(MAXAT), ISYM(MAXAT),     IDUM(MAXAT),
     *               DUM(MAXAT),   IBOND(MAXAT*10), JBOND(MAXAT*10),
     *               XXXGEO(135520)
      COMMON /SIZEX/ KFRAG(20), NFRAG, LFRAG(20), NOFRAG, NNA
      COMMON /DIRBFA/ NCELTY(10), NCELLZ(10), NCELIN(10), NCELIX(10)
      COMMON /DIRBFB/ ACELTY(10)
      CHARACTER ACELTY *2
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IFMAP, IFILE(17))
      EQUIVALENCE (IDOKA, KEYS(10)), (KEYS(28), IHALF)
      LOGICAL SWRECY, NORECY, DMAXCH
      EQUIVALENCE (SWRECY, SWITCH(7)), (NORECY, SWITCH(8))
      EQUIVALENCE (SWITCH(28), DMAXCH)
      EQUIVALENCE (IMAP, KSTAT(7))
      CHARACTER SYMB(10) *2
      EQUIVALENCE (CHIN, SYMB(1))
      DIMENSION  XLOCK(3), CELPAR(10), BUFFOX(10)
      CALL WR24
      CALL GEOFOB (0, 0, 0.)
      IPRY = 24
      SCALAT = 0.
      NPROJ  = 2
      IF (NATIN .GT. 0) THEN
         IF (NATIN.EQ.1 .OR. NATIN.EQ.3) NPROJ = NATIN
         NATIN = 0
         ENDIF
      NPC = MIN0 (NPIC, MAXAT-50)
      IF (DMAXB .LT. 0.) THEN
         DMAXB  = 1.95
      ELSE
         IF (DMAXB .GT. 1.95) DMAXCH = .TRUE.
         ENDIF
      IF (ANGM(1) .LT. 0.) ANGM(1) = 80.0
      IF (ANGM(2) .LT. 0.) ANGM(2) = 145.0
      IF (DMINB .LT. 0.) DMINB = 0.90
      IF (DMOUT .LT. 0.) DMOUT = 2.40
      DMPIC  = 0.85
      REWIND IFMAP
      READ (IFMAP) SCALOR, IMAP, IHALF
      WRITE (8, FMT='('' OPTION IMAP = '', I2)') IMAP
      IF (IMAP .LE. 0 .OR. IMAP .EQ. 5 .OR. IMAP.GE.7) CALL KERROR
     *  ('Error reading output Fourier map for search', 0, 'SEARCH')
      IF (IMAP .EQ. 2) GOTO 120
      IF (IMAP .NE. 6) THEN
         CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
         IF (KINQ.NE.0) CALL KERROR ('No atoms file found', 0, 'SEARCH')
      ELSE
         CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
         ENDIF
  120 IF (IMAP.EQ.2 .OR. IMAP.EQ.6) GOTO 190
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NATIN, KEYT)
      REWIND IATOMS
      IF (NFNUM .GT. 0 .AND. NLIT .GT. 0) THEN
         IF (LIT(NLIT). EQ. 'SC=' .AND.
     *      FNUM(NFNUM) .GT. 0.0001) SCALAT = FNUM(NFNUM)
         ENDIF
      NATQ = NATIN
      NATH = 0
      N = 1
  131 CONTINUE
      IF (NRECYR.NE.0 .AND.ATNAME(N)(1:1).EQ.'H'.AND.IZAT(N).EQ.1) THEN
         NATH = NATH + 1
         ATNAME(N)(1:1) = 'Q'
         ENDIF
      IF (ATNAME(N)(1:1) .EQ. 'Q') THEN
         IF (N .EQ. NATIN) GOTO 135
         DO 133 N1 = N, NATIN - 1
         CALL KERNAB (ATXYZ(1,N1+1), ATXYZ(1,N1), 10)
         ATNAME(N1) = ATNAME(N1+1)
  133    IZAT(N1) = IZAT(N1+1)
  135    NATIN = NATIN - 1
         N = N - 1
         ENDIF
      N = N + 1
      IF (N .LE. NATIN) GOTO 131
      IF (NATIN.LT.NATQ) THEN
         NATQ = NATQ - NATIN - NATH
         IF (NATH .GT. 0) WRITE (8, FMT=
     *      '('' Nr of H atoms rejected:'', I3)') NATH
         IF (NATH .GT. 0) WRITE (8, FMT=
     *      '('' Nr of Q-atoms (= peaks) rejected:'', I3)') NATQ
         IF (NATIN.LE.0) CALL KERROR ('No atoms left!', 135, 'SEARCH')
         WRITE (8, FMT='(1X)')
         ENDIF
      IF (KSTAT(1) .NE. 12357) GOTO 7167
      IF (NRECYR .LE. 1) GOTO 7167
      CALL KERNZI (0, IZTYPE, 10)
      DO 7157 J=1,NTYPE
      CALL ATOMIZ (CELATY(J), NLET, IZ)
      IZTYPE(J) = IZ
 7157 CONTINUE
      CALL KERNZA (0.0, CELPAR, 10)
      DO 7161 I=1,NATIN
      DO 7160 J=1,NTYPE
      IF (IZAT(I).NE.IZTYPE(J)) GOTO 7160
      CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AMULT
 7160 CONTINUE
 7161 CONTINUE
      IIII = 0
      DO 136 J=1,NTYPE
      IF ( ( IZTYPE(J) .GE. 10 .AND. CELPAR(J) .GT. CELALL(J)
     *       .AND. NRECYS .GE. 6 ) .OR.
     *     ( IZTYPE(J) .GE. 2 .AND. CELPAR(J) .GT. CELALL(J)
     *       .AND. NRECYR .GE. 8) ) THEN
         CELALL(J) = CELPAR(J)
         IIII = 1
         ENDIF
  136 CONTINUE
      IF (IIII .EQ. 0) GOTO 7167
      DO 7165 I=1,NTYPE
 7165 BUFFOX(I) = CELALL(I) / ZET
      I = NTYPE
      J = NINT(ZET)
      WRITE(24, 7166) J, (CELATY(K), BUFFOX(K), K=1,I)
 7166 FORMAT (/' NOTE: Cell Contents reset [ output DDMAIN! ] :'/
     *  ' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) /
     *                           ( 8X, 6(2X,A2,F6.1))/)
 7167 CONTINUE
      CALL CELZAT (ACELTY, NCELTY, NCELLZ)
      CALL CELZIN (ATXYZ, IZAT, NATIN, NCELLZ, NCELIN)
      WRITE (8, FMT='('' = symmetry included ='')')
      CALL KERNZI (0, NCELIX, 10)
      DO 137 I = 1, NTYPE
      NCELIX(I) = NCELTY(I)
  137 CONTINUE
      WRITE(24, 139) NATIN
  139 FORMAT (/' Number of atoms input:',I5)
      NATTR = 0
      NATTH = 0
      NATTHA= 0
      NATR = 0
      NATH = 0
      DO 140 I=1,NTYPE
      IF (NCELLZ(I) .NE. 1) THEN
         NATTR = NATTR + NCELTY(I)
         NATR = NATR + NCELIN(I)
         IF (NCELLZ(I) .GT. 40) NATTHA = NATTHA + NCELTY(I)
      ELSE
         NATTH = NATTH + NCELTY(I)
         NATH = NATH + NCELIN(I)
         ENDIF
  140 CONTINUE
      IF (NATTHA .GE. 1) NATTHA = NATTR / NATTHA
      IF (NATH .GT. 0) THEN
         NATR = NATR + NATH
         NATTR = NATTR + NATTH
         ENDIF
      NATX = MAX0(0, (NATTR - NATR)/IMULT)
      IF (NRECYR .GE. 3) THEN
         DO 147 I = 1, NTYPE
         NCELIX(I) = MAX0 (NCELTY(I), NCELIN(I))
  147    CONTINUE
         ENDIF
      WRITE (8, 154) NATIN, NATX
  154 FORMAT (/' Number of atoms input:', I5/
     + ' NUMBER OF NEW ATOMS TO BE FOUND IS',I6, ' (if on genl posn)')
      NATXX = NATX + NATIN
      IF (DMAXB .GT. DMOUT) DMOUT = DMAXB
      IF (DMAXB .LT. DMINB) THEN
         DMINB   = 0.
         ANGM(1) = 0.
         ANGM(2) = 180.
         ENDIF
      IF (NPC .GT. 0) THEN
         NPIC = NPC
         NATX = NPC
         WRITE (8, 163) NATX
  163    FORMAT (' NUMBER OF ATOMS (PEAKS) TO BE CONSIDERED IS', I5)
      ELSE
         NATX = MIN0((20*NATXX + 5)/19, MAXAT-50) + 2
         NPIC = MIN0((15*NATXX + 6)/14, MAXAT-50) + 1
         NPIC = MAX0(NPIC, MIN0(20, NATTR) +3)
         IF (NATTHA .GT. 0)
     *      NPIC = NPIC + MIN0 (7 * (NATIN + NATX) / NATTHA, NATX/2)
         IF (NPIC .EQ. NATX) NPIC = NPIC + 1
         WRITE (8, 172) NATX, NPIC
  172    FORMAT (' NUMBER OF ATOMS TO BE CONSIDERED IS', I5/
     +           ' NUMBER OF PEAKS to be searched is ',I6)
            III = MAX0(150, NATIN * 3/2)
            IF (IMAP .EQ. 1 .AND. NATX .GT. III) THEN
            WRITE (8, 174) III
  174       FORMAT (' because of DIRP1 this is reduced to:', I4)
            NPIC = III + 1
            NATX = III
            ENDIF
         ENDIF
      WRITE (8, 184) DMINB, DMAXB, ANGM
  184 FORMAT (' STEREOCHEMICAL CRITERIA'/ ' For molecular clusters:',
     *   15X, 'MINIMUM BONDING DISTANCE  =', F6.2 /
     *  ' defaults, or',  26X, 'MAXIMUM BONDING DISTANCE  =', F6.2 /
     *  ' user-defined;', 31X, 'MINIMUM BOND ANGLE  =', F6.1 /
     *  ' may be modified later.', 22X, 'MAXIMUM BOND ANGLE  =', F6.1 )
      IF (NPROJ .NE. 2) WRITE (8, 186) NPROJ
  186 FORMAT (9X,'NUMBER OF PROJECTIONS OF EACH CLUSTER TO BE OUTPUT',
     +' IS',I3)
      GOTO 200
  190 IF (NPC .LE. 0) NPIC = 60
      NATX = NPIC
      NATIN = 0
  200 D2R = ATAN(1.0) / 45.0
      NAT = NATIN
      CALL PKSRCH (ATX4, MAXAT, IHALF, IFMAP)
      DMAXLI = 0.5
      IF (IMAP .NE. 3) DMAXLI = 0.1
      DO 225 I = 1, NPIC
      CALL LOCKIN ( ATX4(1,I), DMAXLI, XLOCK, DISTLI, NPOSLI )
      IF (DISTLI .GT. 0.15)
     *   WRITE(24,223) I, DISTLI, (ATX4(J,I),J=1,3), XLOCK
  223 FORMAT (' Atom ',I3,' locked in: peak shifted over', F6.2,
     *   ' Angstrom' / ' Peak xyz:',3F9.5, '  LOCKED xyz:',3F9.5)
  225 IF (NPOSLI .GT. 1) CALL KERNAB (XLOCK, ATX4(1,I), 3)
      IF (IMAP .EQ. 2 .OR. IMAP .EQ. 6) THEN
         CALL FILCLO (IFMAP, 'KEEP')
      ELSE
         CALL FILCLO (IFMAP, 'DELETE')
         ENDIF
      CALL DIRBON (IMAP, ZSCAL)
      IF (IDOKA .EQ. 17) RETURN
      NNA = 0
      CALL CLSTRS
      IF (MCON.GT.0) GOTO 350
      WRITE(24, 227) ((ATX4(J,I),J=1,4),I=1,NAT)
      WRITE (8, 227) ((ATX4(J,I),J=1,4),I=1,NAT)
  227 FORMAT (' NO BONDS FOUND'//
     + ' ATOMIC POSITIONS'//46X,'X',9X,'Y',9X,'Z',3X,
     + 'HEIGHT'/(41X,3F10.4,F8.0))
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      CHOUT = ' Uninterpreted peaks, denoted C-atoms'
      CALL ATOMWA (IATOMS)
      DO 344 I=1,NAT
  344 WRITE (IATOMS, 341) I, (ATX4(J,I),J=1,3)
  341 FORMAT ('ATOM   C', I3, 2X, 3F8.5)
      WRITE (IATOMS, FMT = '(''END'')')
      CALL FILCLO(IATOMS, 'KEEP')
      WRITE (9,*)
     *' Warning: No atoms interpretation; No recycling: check file!'
      IF (MPAT .LE. -2 .AND. MPAT .GT. -99) CALL ATPATS(1)
      CALL KERROR
     * ('Savety stop: peaks output to ATOMS file.', 0, 'SEARCH')
  350 CONTINUE
      DO 600 NOFRG=1,NFRAG
      NOFRAG = NOFRG
      IF (NOFRAG .EQ. 20) GOTO 600
      IF (KFRAG(NOFRAG) .LT. 4) GOTO 600
      CALL PICTUR (NPROJ)
  600 CONTINUE
      CALL SCHOUT (SCALAT, ZSCAL)
      IF (NRECYR .LE. 0) RETURN
      WRITE (24, FMT='('' Cycle'',I2,'' is finished'')')  NRECYR
      IF (NORECY) THEN
         WRITE (24,*) ' Fourier recycling procedure completed'
         IF (NRECYR .GT. 1) WRITE (24,*)
     *    ' ATOMS from the each cycle written to the ATTEM file.'
         WRITE (24,*)
     *    ' Final atomic parameters written to the ATOMS file'
         ENDIF
      CALL WR24
      RETURN
      END
      SUBROUTINE PKSRCH (X, MAXAT, IHALF, LIN)
      DIMENSION  X(4, MAXAT)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zsear.inc'
      PARAMETER (KUSER2=30000)
      COMMON /BLANK/ NR3D, DUMMY(145000)
      INTEGER*2 NR3D(KUSER2)
      DIMENSION XS(3), X1(3), IDIFF(19), B(19)
      DIMENSION DXYZM(3)
      CALL WR24
      MAX = 0
      E = 0.0
      D = 0.0
      DO 101 I = 1, 3
  101 DXYZM(I) = DMPIC * RCELL(I)
      READ (LIN) NNX, NNZ, NNY, NNYT
      NNYOLD=NNY
      IF (IHALF.NE.0) NNY=NNY-3
      NNXP2 = NNX + 2
      NXZ = NNXP2 * (NNZ + 2)
      NXZ3 = 3 * NXZ
      DX = 1.0 / FLOAT(NNX)
      DY = 1.0 / FLOAT(NNYT)
      DZ = 1.0 / FLOAT(NNZ)
      LEVEL = 0
      LIMIT = MIN0(MAXAT, 2*NATX)
 1100 IDIFF(1) = -NXZ - 1
      IDIFF(2) = -NXZ - NNXP2
      IDIFF(3) = -NXZ
      IDIFF(4) = -NXZ + NNXP2
      IDIFF(5) = -NXZ + 1
      IDIFF(6) = -NNXP2 - 1
      IDIFF(7) = -1
      IDIFF(8) = NNXP2 - 1
      IDIFF(9) = -NNXP2
      IDIFF(10) = 0
      DO 1120 I=1,9
      J=20-I
      IDIFF(J) = -IDIFF(I)
 1120 CONTINUE
      NO = 0
      IY = -1
      NY = 0
 1200 REWIND LIN
      READ(LIN) SCALOR, IMAP
      READ(LIN)
      IF (IMAP.EQ.1 .OR. IMAP.EQ.3 .OR. IMAP.EQ.4) THEN
         RESCAL = 4000. / VOLUM / SCALOR
      ELSE
         RESCAL = 1.
         IMAP = 0
         ENDIF
      IF (IY+2.EQ.NNYOLD) GOTO 1400
      MAX=NXZ
      ISKIP = (NNYOLD-1) * NNZ
      DO 1305 I=1,ISKIP
 1305 READ (LIN)
      CALL RDSECT (MAX, NNXP2, NNZ, NXZ3, LIN)
      REWIND LIN
      READ(LIN)
      READ(LIN)
      CALL RDSECT (MAX, NNXP2, NNZ, NXZ3, LIN)
 1400 MX = MAX - NXZ + NNX + 1
      CALL RDSECT (MAX, NNXP2, NNZ, NXZ3, LIN)
      IY = IY + 1
      NY = MOD(NY+2, 3) - 1
      KK = NXZ3
      IF (NY) 1440, 1460, 1500
 1440 KK = -NXZ3
 1460 DO 1480 I=1,5
      IDIFF(I) = IDIFF(I) - KK
 1480 CONTINUE
      IF (NY .EQ. 0) GO TO 1540
 1500 DO 1520 I=15,19
      IDIFF(I) = IDIFF(I) - KK
 1520 CONTINUE
 1540 DO 2000 IZ=1,NNZ
      MN = MX + 3
      MX = MX + NNXP2
      DO 1980 IX=MN,MX
      IF (NR3D(IX) .LT. LEVEL) GO TO 1980
      DO 1560 I=1,9
      J = IDIFF(I) + IX
      IF (NR3D(IX) .LE. NR3D(J)) GO TO 1980
 1560 CONTINUE
      DO 1580 I=11,19
      J = IDIFF(I) + IX
      IF (NR3D(IX) .LT. NR3D(J)) GO TO 1980
 1580 CONTINUE
      DO 1600 I=1,19
      J = IDIFF(I) + IX
      B(I) = NR3D(J)
 1600 CONTINUE
      B1 = B(3) + B(7) + B(9) + B(11) + B(13) + B(17)
      B2 = B(1) + B(2) + B(4) + B(5) + B(6) + B(8) + B(12) + B(14) +
     +  B(15) + B(16) + B(18) + B(19)
      F = (30.0 * B(10) + 11.0 * B1 - 8.0 * B2) / 63.0
      C = (B(5)+B(12)+B(13)+B(14)+B(19)-B(1)-B(6)-B(7)-B(8)-B(15))/10.0
      IF ( ABS(C) .GT. ABS(F) ) GOTO 1620
      DELTAX = C / F
      D = (B(15)+B(16)+B(17)+B(18)+B(19)-B(1)-B(2)-B(3)-B(4)-B(5))/10.0
      IF ( ABS(D) .GT. ABS(F) ) GOTO 1620
      DELTAY = D / F
      E = (B(4)+B(8)+B(11)+B(14)+B(18)-B(2)-B(6)-B(9)-B(12)-B(16))/10.0
      IF ( ABS(E) .GT. ABS(F) ) GOTO 1620
      DELTAZ = E / F
      GOTO 1640
 1620 DELTAX = 0.0
      DELTAY = 0.0
      DELTAZ = 0.0
 1640 XX = (FLOAT(IX-MN+1) + DELTAX) * DX
      YY = (FLOAT(IY) + DELTAY) * DY
      ZZ = (FLOAT(IZ) + DELTAZ) * DZ
      A = (9.0 * B(10) + 4.0 * B1 - B2) / 21.0
      BINT = A + 0.5 * (C * DELTAX + D * DELTAY + E * DELTAZ)
      IF (BINT .GT. 1.1 * B(10)) BINT = 1.1 * B(10)
      B10 = B(10)
      B(10) =  AMAX1(B(10), BINT)
      IF (IMAP .EQ. 0) GOTO 1660
      IF (B(10) .LT. 1.) B(10) = 1.
      B(10) = SQRT (B(10) * RESCAL)
      BSUM = B(10)
      IF (B1 .LT. 0.0 .OR. B2 .LT. 0.) GOTO 1650
      B30 = 0.
      BX2 = B(3)  + B(2)  + B(4)  + B(1)  + B(5)
      BX3 = B10   + B(9)  + B(11) + B(7)  + B(13)
      BX4 = B(17) + B(16) + B(18) + B(15) + B(19)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B30 = B30 + BX1 + BX5
      BX2 = B(9)  + B(6)  + B(12) + B(2)  + B(16)
      BX3 = B10   + B(7)  + B(13) + B(3)  + B(17)
      BX4 = B(11) + B(8)  + B(14) + B(4)  + B(18)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B30 = B30 + BX1 + BX5
      BX2 = B(13) + B(12) + B(14) + B(5)  + B(19)
      BX3 = B10   + B(9)  + B(11) + B(3)  + B(17)
      BX4 = B(7)  + B(6)  + B(8)  + B(1)  + B(15)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B30 = B30 + BX1 + BX5
      B8 = 0.
      BX2 = B(1)  + B(2)
      BX3 = B(3) * 2.
      BX4 = B(4)  + B(5)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(1)  + B(4)
      BX4 = B(2)  + B(5)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(15)  + B(16)
      BX3 = B(17) * 2.
      BX4 = B(18)  + B(19)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(15)  + B(18)
      BX4 = B(16)  + B(19)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(1)   + B(6)
      BX3 = B(7) * 2.
      BX4 = B(8)  + B(15)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(1)  + B(8)
      BX4 = B(6)  + B(15)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(5)  + B(12)
      BX3 = B(13) * 2.
      BX4 = B(14) + B(19)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(5)  + B(14)
      BX4 = B(12) + B(19)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(8)  + B(18)
      BX3 = B(11) * 2.
      BX4 = B(14) + B(4)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(18) + B(14)
      BX4 = B(8) + B(4)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(6)  + B(16)
      BX3 = B(9) * 2.
      BX4 = B(12) + B(2)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      BX2 = B(12) + B(16)
      BX4 = B(6) + B(2)
      CALL EXTPOL (BX2, BX3, BX4, BX1, BX5)
      B8 = B8 + BX1 + BX5
      B8 = B8 / 6.
      PX2 = B10
      PX3 = (B1+B2) / 18.
      PX4 = (B8+B30)/ 38.
      CALL EXTPOL (PX2, PX3, PX4, PX1, PX5)
      PX5 = AMIN1(PX5, 0.3 * PX4)
      B58  = 29. * PX5
      BSUM = B10 + B1 + B2 + B30 + B8 + B58
 1650 CONTINUE
      IF (BSUM .LT. 1.) BSUM = 1.
      BSUM = SQRT(BSUM)
      IF (BSUM .GT. 999.) BSUM = 999.
      I10 = NINT(B(10))
      B(10) = FLOAT(I10) + BSUM / 1000.
 1660 NOP1 = NO + 1
      IF(NOP1.GT.MAXAT) GOTO 1821
      X(1,NOP1) = XX
      X(2,NOP1) = YY
      X(3,NOP1) = ZZ
      X(4,NOP1) = B(10)
      IF (NO .EQ. 0) GO TO 1820
      IR=0
      DO 1800 K=1, IMULT
      CALL OPER1 (K, XS, X(1,NOP1))
      DO 1780 I=1,NO
      DO 1720 L=1,3
      X1(L) = X(L,I) - XS(L)
 1680 IF (ABS(X1(L)) .LE. 0.5) GO TO 1700
      X1(L) = X1(L) - SIGN(1.0, X1(L))
      GO TO 1680
 1700 IF (ABS(X1(L)) .GT. DXYZM(L)) GO TO 1780
 1720 CONTINUE
      IF (QUAD2 (X1, X1) .GT. DMPIC) GOTO 1780
      IF (IR.GT.0) X(4,IR)=0.0
      IR=0
      IF (B(10) .LE. X(4,I)) GOTO 1980
      X(1,I) = XX
      X(2,I) = YY
      X(3,I) = ZZ
      X(4,I) = B(10)
      IR=I
 1780 CONTINUE
 1800 CONTINUE
      IF(IR.GT.0) GO TO 1980
 1820 NO = NOP1
 1821 IF (NO .LT. LIMIT) GO TO 1980
      CALL SORT (X, MAXAT, NO, 4)
      NO = LIMIT
      NPIC = NO
      IF (IMAP .EQ. 0) THEN
         LEVEL = X(4,NPIC) + 0.5
      ELSE
         LEVEL = X(4,NPIC)**2 / RESCAL + 0.5
         ENDIF
 1980 CONTINUE
 2000 CONTINUE
      IF (IY .GE. NNY) GO TO 2100
      IF (IY - NNYOLD + 2) 1400, 1200, 1400
 2100 CONTINUE
      IF (IMAP .NE. 1 .AND. IMAP .NE. 3) GOTO 2200
      DO 2155 I = 1, NO
      I10 = X(4,I)
      ITOT = X(4,I) * 10000.
      ISUM = ITOT - 10000 * I10
      IF (I10 .GT. 999) I10 = 999
      X(4,I) = FLOAT(ISUM) + FLOAT(I10)/1000.
 2155 CONTINUE
 2200 CALL SORT (X, MAXAT, NO, 4)
      NNN = MIN0 (NO, NPIC)
      IF (NNN .EQ. NPIC) GOTO 3000
      LEVEL = LEVEL - 100
      IF(LEVEL.GE.(-200)) GO TO 1100
      NPIC=NO
 3000 CONTINUE
      RETURN
      END
      SUBROUTINE EXTPOL (BX2, BX3, BX4, BX1, BX5)
      A = BX3
      B = (BX4 - BX2) / 2.0
      C = BX4 - A - B
      BX1 = A - 2.0 * B + 4.0 * C
      BX5 = A + 2.0 * B + 4.0 * C
      IF (BX1 .GT. BX2) BX1 = BX2
      IF (BX1 .LT. 0.0) BX1 = 0.0
      IF (BX5 .GT. BX4) BX5 = BX4
      IF (BX5 .LT. 0.0) BX5 = 0.0
      RETURN
      END
      SUBROUTINE DIRBON (IMAP, ZSCAL)
      CALL WR24
      GOTO (1,   2,   1,   4,   5,   2), IMAP
  1   CALL DIRBF (ZSCAL)
      GOTO 100
  4   CALL DIRBD
  100 CALL DIRBB
      RETURN
  2   CALL DIRBP
  5   RETURN
      END
      SUBROUTINE DIRBF (ZSCAL)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zsear.inc'
      COMMON /BLANK/ IFRAG(MAXAT), ISYM(MAXAT),     IDUM(MAXAT),
     *               DUM(MAXAT),   IBOND(MAXAT*10), JBOND(MAXAT*10),
     *               XXXGEO(135520)
      DIMENSION LW(MAXAT), JCON(MAXAT), XDUM(MAXAT)
      EQUIVALENCE (LW(1),IFRAG(1)), (JCON(1),ISYM(1)),(XDUM(1),IDUM(1))
      COMMON /DIRBFA/ NCELTY(10), NCELLZ(10), NCELIN(10), NCELIX(10)
      COMMON /DIRBFB/ ACELTY(10)
      CHARACTER ACELTY *2
      EQUIVALENCE (NOPHAS, KSTAT(3))
      EQUIVALENCE (IDDL, IFILE(1)), (IDDS, IFILE(2)), (ICRYS,IFILE(3))
      EQUIVALENCE (ICOND,IFILE(4))
      EQUIVALENCE (NTYPEZ, KEYS(4))
      EQUIVALENCE (KEYD, KSTAT(19))
      EQUIVALENCE (KEYDS, KSTAT(20))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (KPROG, KSTAT(18))
      LOGICAL SWRECY, NORECY, REN98, NOFREE
      EQUIVALENCE (SWITCH(9), NOFREE)
      EQUIVALENCE (SWITCH(16), REN98)
      EQUIVALENCE (SWITCH(7), SWRECY), (SWITCH(8), NORECY)
      DIMENSION XS(3), XST(3), XSHIFT(3)
      CHARACTER ATNAM *6 , ATNAMX(MAXAT) *6
      DIMENSION RCELTY(10), WCELTY(10), TCELTY(10), LCELTY(10)
      DIMENSION SATLD(133), ISATL(133), JSATL(133)
       DIMENSION XBTEMP(MAXAT), IZTEMP(MAXAT)
      DIMENSION IOCC(1), IRECY(8)
      LOGICAL SWMATE
      CHARACTER ZZZ *1
      BOV = BOVMER
      DPAR2 = 0.
      II = 0
      NTYPEZ = NTYPE
  101 IF (ACELTY(NTYPEZ) .EQ. ' ') THEN
         NTYPEZ = NTYPEZ - 1
         GOTO 101
         ENDIF
      DAV = 0.48
      DAV2 = DAV * DAV
      NQQQ = 0
      CALL KERNZI (0, LW, MAXAT)
      IF ((KPROG .GE. 4 .AND. KPROG .LE. 6) .OR.
     *     KPROG .EQ. 8 .OR. KPROG .GE. 11) KPROG = 0
      IF (NATS .LE. 0) NATS = NATIN
      IF (NATS .GT. NATIN) NATS = NATIN
      WRITE (8, FMT='('' ***** DIRBF  *****''/ 20X, ''KEYD='', I2,
     *   '' KEYDS='', I2 , '' SWRECY=TRUE, NORECY=FALSE?  IPAT='',
     *   I2)') KEYD, KEYDS, IPAT
      IF (.NOT. SWRECY) WRITE (8, FMT='(/ 36X, '' SWRECY=FALSE'')')
      IF (NORECY) WRITE (8, FMT='(/ 48X, ''NORECY=TRUE'')')
      KEYDSS = KEYD * 10 + KEYDS
      IF (KEYDSS.GT. 30 .AND. KEYDSS .LT. 40) THEN
         SWRECY = .FALSE.
         NORECY = .TRUE.
         ENDIF
      REN98 = .FALSE.
      IF (.NOT.NOFREE .AND. NRECYS .GE. 8) THEN
         REN98 = .TRUE.
         NATS = 0
         IF (NRECYS .GE. 8) GOTO 112
         WRITE (24, FMT='(
     *     '' From now on all input atoms may be renamed!''/
     *     '' -------------------------------------------'' )')
         ENDIF
  112 IF (NOFREE) THEN
         WRITE(24,*)
     *      ' $TE All input atoms are renamed following CRYSIN data!'
         NATS = 0
         ENDIF
      IF (NORECY) THEN
         IPRY=24
      ELSEIF (NRECYR .LE. 1) THEN
         IPRY=8
      ELSE
         IPRY=0
         ENDIF
      NATSN = NATS
      SUMBZ = 0.
      SUMZ = 0.
      DO 121 I = 1, NATIN
      Z2 = FLOAT ( IZAT(I))
      SUMZ = SUMZ + Z2
      SUMBZ = SUMBZ + Z2 * ATXYZ(5,I)
  121 CONTINUE
      BAV = SUMBZ / SUMZ
      SUMZ = 0.
      DO 122 I = 1, NATIN
      SUMZ = SUMZ + (ATXYZ(5,I) - BAV)**2
  122 CONTINUE
      BPSD = SQRT ( SUMZ / FLOAT(NATIN) )
      IF ((NRECYR .EQ. 2 .OR. NRECYR .EQ. 3) .AND. BAV .GT. BR) BR = BAV
      IF (FLOAT(NATIN) / FLOAT(NATX) .GT. 0.70 .AND.
     *    PSQ .GT. 0.85 .AND. NRECYR .GE. 4) BR = BAV + BPSD
      IF (PSQ .GT. 0.95 .AND. NRECYR .GE. 8) BR = BAV + 1.5 * BPSD
      IF (BPAV .LT. 0.0001) BPAV = BP
      WRITE (8, 124) NRECYR, PSQ, R2X, BAV, BPAV, BPSD, BR
  124 FORMAT (' $TE >Ncy PSQ R2X BAV BPAV sd BR=', I3, 6F6.3)
      IF (NATIN .NE. -12359) GOTO 134
      IF (.NOT. REN98) GOTO 134
      BOVBAV = BOV / BAV
      IF (BOVBAV .GT. 1.07) BOVBAV = 1.07
      IF (BOVBAV .LT. 0.93) BOVBAV = 0.93
      BB7 = 0.07*BOV
      DO 125 I = 1, NATIN
      A123 = ATXYZ(5,I)*BOVBAV
      B123 = ATXYZ(5,I)+BB7
      C123 = ATXYZ(5,I)
      ATXYZ(5,I) = AMIN1 (ATXYZ(5,I)*BOVBAV , ATXYZ(5,I)+BB7 )
      WRITE (8,FMT='('' $TE B '' ,4F7.3)') C123,A123,B123,ATXYZ(5,I)
  125 CONTINUE
  134 CONTINUE
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ)
      DO 159 N = 1, NTYPE
      CALL RDCRYB (ICRYS, 'ELEM' , KEND)
      IF (KEND.LE.0) THEN
         WRITE (CHOUT, 142) N
  142    FORMAT (' CRYSDA file: ELEM for atom No ', I2, ' not found')
         CALL KERROR (CHOUT, 142, 'DIRBF')
         ENDIF
      CALL KERINB (LIT, 1)
      IZ = NINT(FNUM(1))
      DO 153 I = 1, NTYPE
      IF (NCELLZ(I) .EQ. IZ) GOTO 154
  153 CONTINUE
      CALL KERROR ('Atom-type conflict', 153, 'DIRBF')
  154 RCELTY(I) = AMIN1 (FNUM(4), FNUM(5), FNUM(6))
      IF (NCELLZ(I) .GT. 18) RCELTY(I) = RCELTY(I) + 0.35
      IF (NCELLZ(I) .LT. 10) RCELTY(I) = 0.01
  159 CONTINUE
      NSATL = 0
      NNOMAT = 0
      NNOMAS = 0
      NNOMAX = 0
      NNOMAW = 0
      CALL KERNZI (0, JCON, NPIC)
      MSGT = 0
      MSGS = 0
      ZSCAL = 100. * NCELLZ(1) / ATX4(4,1) ** 2
      ZSCALA = 0.
      ZSCALX = 0.
      CALL EXPEAK(0, 0, 0, IPPQQ)
      IF (IPPQQ .EQ. -123499) GOTO 160
      QPPQQ = FLOAT(IPPQQ) / 1000.
      SCALEX = 1.0000000
      IF (QPPQQ .GT. 1.0 .AND. SCALEX .GT. 0.0001) THEN
         WRITE (8, FMT='('' $TEX scale /QPPQQ , old SCALE'',
     *      2F9.4)') QPPQQ, SCALEX
         IF (QPPQQ .GT. 1.05) QPPQQ = 1.05
         IF (QPPQQ .LT. 0.95) QPPQQ = 0.95
         SCALEX = SCALEX / QPPQQ
         WRITE (8, FMT='('' $TEX scale /QPPQQ: new SCALE='',
     *      2F9.4)') QPPQQ, SCALEX
         WRITE (CHOUT,FMT='(''RUN '',I3, '' CY'', I3,
     *     '' SCALEX '', F10.5)') IRUN, NRECYR, SCALEX
         CALL LOGWR (IDDL)
         CALL FILCLO (IDDL, 'KEEP')
         ENDIF
  160 CONTINUE
      CALL KERNZI (0, IRECY, 8)
      IRECYD = 0
      CALL KERNZA (0.0, XBTEMP, MAXAT)
      CALL KERNZI (0  , IZTEMP, MAXAT)
      DO 420 I= 1, NATIN
      SWMATE = .FALSE.
      LW(I) = 0
      IBOND(I) = 0
      ATNAMX(I) = ATNAME(I)
      DUM(I) = 0.
      XDUM(I) = 0.
      CALL ATOMOC (0, ATXYZ(1,I), IOCC, 1)
      ATXYZ(9,I) = IMULT/IOCC(1)
      DO 310 N = 1, NTYPE
      IF (NCELLZ(N) .NE. IZAT(I)) GOTO 310
      ATXYZ(10,I) = FLOAT(N)
      DPAR = RCELTY(N)
      DPAR2 = DPAR * DPAR
      DTEST = AMAX1 (DPAR, DAV)
      GOTO 312
  310 CONTINUE
      CALL KERROR (' Impossible...', 310, 'DIRBF')
  312 DO 410 J = 1, NPIC
      IF (ATX4(4,J) .LE. 0.1) GOTO 410
      DO 400 IS = 1, NSYMM
      CALL SYMOP1 (IS, ATX4(1,J), XS)
      DO 400 IC = 1, ICENT
      DO 400 IL = 1, NLATT
      CALL SYMOP2 (IC, IL, XS, XST)
      CALL DISTSQ (ATXYZ(1,I), XST, DTEST, XSHIFT, DIST2)
      IF (DIST2 .GT. DAV2) GOTO 380
      DIST = SQRT(DIST2)
      IF (DIST .GT. 0.20) GOTO 330
      WAV = 1.
      IF (DIST .GT. 0.05 .AND. DIST .LT. 0.10) WAV = 0.1 / DIST
      IF (DIST .LE. 0.05) WAV = 2.
      GOTO 340
  330 WAV = 5. * DIST
      WRED = AMIN1(6.0, FLOAT(J-NATIN-1)/2.0)
      IF (WRED.GT.1.0) WAV = AMIN1 (WRED*WAV - WRED + 1., DIST/0.08)
  340 DO 350 L = 1, 3
  350 ATXYZ(L,I) = ATXYZ(L,I) + XSHIFT(L) / WAV
      SHIFT = DIST / WAV
      IF (DIST.GT.0.2298 .AND. DIST.LT.0.2302) DIST = 0.2298
      SWMATE = .TRUE.
      DUM(I) = DIST
      XDUM(I) = SHIFT
      IF (DIST .GT. 0.05) IRECYD = IRECYD + 1
      ATXYZ(6,I) = ABS (ATX4(4,J))
      ATXYZ(8,I) = ATX4(4,J) ** 2 * ZSCAL
      ATX4(4,J) = - ABS(ATX4(4,J))
      LW(I) = J
      IF (JCON(J) .LT. 0) WRITE(24, 357) ATNAME(I), I
  357 FORMAT (' Warning: suspect input atom ', A6, ' (number', I3,
     *        ') : check bonds' )
      JCON(J) = I
      IF (DIST .GT. 0.23) THEN
         MSGT = MSGT + 1
         IF (I .LE. NATS) MSGS = MSGS + 1
         ENDIF
      CALL EXPEAK(1, I, NATSN, IZOLD)
      IF (IZOLD .NE. 0) THEN
         ATNAMX(I) = ATNAME(I)
         IRECY(1) = IRECY(1) + 1
         ENDIF
      ZSCALA = ZSCALA + FLOAT(IZAT(I))
      ZSCALX = ZSCALX + ATX4(4,J) ** 2
      IF (IZAT(I) .GT. 18) GOTO 410
      IF (IZAT(I) .GT. 10 .AND. I .LE. NATS) GOTO 410
      IF (IZAT(I) .GT. 10 .AND. REN98) GOTO 410
      GOTO 420
  380 IF (IZAT(I) .LE. 10) GOTO 400
      IF (IZAT(I) .LE. 18 .AND. I .GT. NATS .AND. .NOT. REN98) GOTO 400
      IF (DIST2 .GT. DPAR2 .OR. ATX4(4,J) .LE. 0.1) GOTO 400
      IF (ABS(ATX4(4,J)) .GT. 0.25 * ATXYZ(6,I)) THEN
         IRECY(2) = IRECY(2) + 1
         IF (ABS(ATX4(4,J)) .GT. 0.50 * ATXYZ(6,I)) THEN
            WRITE(24, 383) J, I, ATNAME(I)
  383       FORMAT (' WARNING: strong peak',I3, '  close to heavy atom',
     *      ' (nr',I3, ' = ', A6,')  retained' )
            GOTO 400
         ELSE
            WRITE(24, 384) J, I, ATNAME(I)
  384       FORMAT (' WARNING: strong peak',I3, '  close to heavy atom',
     *      ' (nr',I3, ' = ', A6,')  deleted' )
            ENDIF
         ENDIF
      NSATL = MIN0 (NSATL+1, 133)
      SATLD(NSATL) = SQRT(DIST2)
      ISATL(NSATL) = I
      JSATL(NSATL) = J
      ATX4(4,J) = -ABS(ATX4(4,J))
      JCON(J) = -I
  400 CONTINUE
  410 CONTINUE
      IF (SWMATE) GOTO 420
      ATXYZ(8,I) = -0.0001
      NNOMAT = NNOMAT + 1
      IRECY(3) = IRECY(3) + 1
      IF (LW(I) .NE. 0) STOP 307
      IF (I .LE. NATS) THEN
         NNOMAS = NNOMAS + 1
         IF (NRECYR .GT. 1) THEN
            IF ( NATS  .GT. 1) THEN
               NNOMAX = NNOMAX + 1
               LW(I) = -1
            ELSE
               LW(I) = -4
               ATXYZ(8,I) = 0.0001
               ENDIF
            ENDIF
         ENDIF
      ATXYZ(6,I) = ATXYZ(8,I)
  420 CONTINUE
      IF (NSATL .EQ. 0) GOTO 460
      IF (NATIN .GT. NATS .AND. .NOT. REN98) WRITE (8, 431)
  431 FORMAT (/' (May be based on the tentative chemical assignement:)')
      WRITE (8, 433) NSATL
  433 FORMAT (' We have removed ', I4,
     *   ' peaks from the Fourier-peaklist,' /
     *   '    because they are too close to the input heavy atom.  ',
     *   '   They are:' /
     *   '  No. peakhght     x       y       z     close to atom:  No.')
      WRITE(24, 435) NSATL
  435 FORMAT (' We have removed ', I4, ' peaks from the peaklist,' /
     * '    because they are too close to the heavy atom: see LIS2' )
      DO 440 N = 1, NSATL
      I = ISATL(N)
      J = JSATL(N)
      DDSATL = ABS ( ATX4(4,J)) ** 2 * ZSCAL
      WRITE (8, 439) J, DDSATL, (ATX4(NN,J), NN=1,3),
     *   ATNAME(I), I, SATLD(N)
  439 FORMAT (I5, F8.0, 3F8.4, '  close to ', A6, I5, '   Dist=', F5.2)
  440 CONTINUE
  460 IF (NRECYR .LE. 1) GOTO 478
      IF (REN98 .OR. NOFREE) GOTO 492
      CALL KERNZA (0.0,  WCELTY, 10)
      CALL KERNZA (0.01, TCELTY, 10)
      DO 471 I = 1, NATIN
      IF (ATXYZ(8,I) .LE. 0.1) GOTO 471
      N = NINT(ATXYZ(10,I))
      IF (TCELTY(N) .GT. 8.5) THEN
         WCELTY(N) = 0.9 * (WCELTY(N) + ATXYZ(8,I))
      ELSE
         WCELTY(N) = WCELTY(N) + ATXYZ(8,I)
         TCELTY(N) = TCELTY(N) + 1.
         ENDIF
  471 CONTINUE
      DO 472 N = 1, NTYPE
  472 WCELTY(N) = WCELTY(N) / TCELTY(N)
      DO 477 I = 1, NATS
      IF (ATXYZ(8,I) .LT. 0.1) GOTO 477
      IF (NRECYR.EQ.3 .AND. IZAT(I).GE.5 .AND. IZAT(I).LE.9
     *    .AND. ATXYZ(8,I) .LT. 200.) NQQQ = 1
      N = NINT(ATXYZ(10,I))
      IF (ATXYZ(8,I) .LT. 0.3 * WCELTY(N)) THEN
         ATXYZ(8,I) = - ABS(ATXYZ(8,I))
         ATXYZ(6,I) = - ABS(ATXYZ(6,I))
         J = LW(I)
         IF (J .LE. 0) GOTO 477
         ATX4(4,J) = - ABS(ATX4(4,J))
         LW(I) = -2
         NNOMAW = NNOMAW + 1
         ENDIF
  477 CONTINUE
      NQQQ = NQQQ + NNOMAW + NNOMAX
  478 CONTINUE
      IF (NATS .EQ. 1 .AND. NATIN .LE. 10) THEN
         IBOND(1) = 1
         GOTO 489
         ENDIF
      II = 0
      DO 487 I= 1, NATS
      J = LW(I)
      IF (J .LT. 0 .AND. J .NE. -4) GOTO 487
      II = II + 1
      IBOND(I) = II
      IF (I .GT. II) THEN
         CALL KERNAB (ATXYZ(1,I), ATXYZ(1,II), 10)
         IZAT(II) = IZAT(I)
         ATNAME(II) = ATNAME(I)
         JCON(J) = II
         ENDIF
  487 CONTINUE
      NATSN  = II
      IF (II .NE. NATS - NNOMAX - NNOMAW) WRITE(24,
     *   FMT= '(/'' Error in count of messages.. ''/)')
  489 IF (NATS .GE. NATIN) GOTO 502
  492 CONTINUE
      DO 501 I = NATS + 1 , NATIN
      J = LW(I)
      IF (J .LE. 0) GOTO 501
      IF (JCON(J) .LT. 0) GOTO 501
      ATX4(1,J) = ATXYZ(1,I)
      ATX4(2,J) = ATXYZ(2,I)
      ATX4(3,J) = ATXYZ(3,I)
      ATX4(4,J) = ATXYZ(6,I)
      XBTEMP(J) = ATXYZ(5,I)
      IZTEMP(J) = IZAT(I)
  501 CONTINUE
  502 CONTINUE
      IF (REN98 .OR. NOFREE) GOTO 8505
      WRITE (8, 503) (ACELTY(I), I=1, NTYPE)
  503 FORMAT (/' Cell contents:  atoms:  ', 10(3X, A2))
      WRITE (8, FMT='('' Count  original input,'')')
      CALL CELZIN (ATXYZ, IZAT, NATSN, NCELLZ, NCELIN)
      WRITE (8, FMT='('' = symmetry included ='')')
      IF (NCELLZ(1) .GE. 10) WRITE (8, 504) (RCELTY(I), I=1, NTYPEZ)
  504 FORMAT (' Satellite skip-distance ', 10F5.2)
 8505 CONTINUE
      DO 505 N = 1, NTYPE
      RCELTY(N) = 1.25
      IF (NCELLZ(N) .LE. 12) RCELTY(N) = 1.55
      IF (NCELLZ(N) .LT. 10) RCELTY(N) = 0.85
      IF (NCELLZ(N) .GT. 18) RCELTY(N) = 1.60
  505 CONTINUE
      WRITE (8, 508) (ACELTY(I), I=1, NTYPE)
  508 FORMAT (/'             For atom type: ', 10(1X,A2,2X))
      WRITE (8, 507) (RCELTY(I), I=1, NTYPE)
  507 FORMAT (' Approximate atomic radius: ', 10F5.2)
      IF (NNOMAW .GT. 0) WRITE (8, 511) (WCELTY(I), I=1, NTYPE)
  511 FORMAT (' Averaged low peak level:    ', 10F5.0)
      WRITE (8, FMT='('' '')')
      IF (NNOMAT .EQ. 0) THEN
         WRITE (24, *) 'Results: all input atoms recognized.'
      ELSE
         WRITE (24, FMT='('' Nr of input atoms'',
     *     '' rejected because no mate was found:'',I4)')  NNOMAT
         IF (NNOMAS .GT. 0 .AND. NNOMAT .GT. NNOMAS) THEN
            WRITE (24, FMT='(I6, '' of these belong to the'',
     *           '' original list of input atoms'')')  NNOMAS
            ENDIF
         ENDIF
      IF (NNOMAW .GT. 0) THEN
         WRITE (24, 515) NNOMAW
  515    FORMAT (' Nr of original input atoms rejected: ',
     *       'too low Peakheight:', I3)
         IRECY(4) = IRECY(4) + NNOMAW
         ENDIF
      I = NNOMAX + NNOMAW
      IF (I .GT. 0) THEN
         WRITE(24, 517) I
         WRITE (8, 517) I
  517 FORMAT (' Because', I3,
     *       ' of the original input atoms will be rejected,' /
     *       ' the original input atoms have been reordered.'/
     *       ' The atom-names are not changed  '/
     *       '    except when the atom type is changed !  .' )
         ENDIF
      ZSCAL1 = ZSCAL
      IF (ZSCALX .LT. 0.0001) GOTO 1532
      ZSCAL = 100. * ZSCALA / ZSCALX
      WRITE (8, 1531) ZSCAL1, ZSCAL
 1531 FORMAT (/' $TEMP :   old and new ZSCAL =', 2F15.7)
 1532 CONTINUE
      CALL WR24
      WRITE (8, 531)
  531 FORMAT (/' Table 307     INPUT ATOMS AND THEIR AVERAGED MATES'//
     +   '   ATOM        PEAK        modified coordinates   ',
     *   ' mate atom-  (input:)'/
     +   '  No. NAME    No. Integr.   x        y        z   ',
     *   '-DIST SHIFT  No. NAME' )
      IF (MSGS .GT. 0 .OR. NNOMAS + NNOMAW .GT. 0) WRITE(24, 533)
  533 FORMAT (1X/'  No. ATOM    No. PEAK')
      IF (REN98 .OR. NOFREE) GOTO 592
      DO 570 I = 1, NATS
      ABSX = -1.
      II = IBOND(I)
      IF (II .EQ. 0) GOTO 553
      IF (ABS(ATXYZ(8,II)) .GT. 1.)
     *   ATXYZ(8,II) = ATXYZ(8,II) * ZSCAL / ZSCAL1
      IF (I .LE. 0) CALL KERROR ('kanniet', 545, 'DIRBF')
      J = LW(I)
      ABSX = ABS(ATXYZ(8,II))
      IF (II .EQ. I) THEN
         WRITE (8, 545) II, ATNAMX(I), J, ABSX,
     *      (ATXYZ(K,II),K=1,3), DUM(I), XDUM(I)
  545    FORMAT (I5, 1X, A6, I4, F7.0, 1X, 3F9.5, 2F5.2, 1X, I4, 1X, A6)
      ELSE
         WRITE (8, 545) II, ATNAME(II), J, ABSX,
     *      (ATXYZ(K,II),K=1,3), DUM(I), XDUM(I), I, ATNAMX(I)
         ENDIF
      IF (DUM(I) .GT. 0.23) THEN
         WRITE (8, 547)
  547    FORMAT (53X, '----', 8X, 'WARNING')
         WRITE(24, 549) II, ATNAME(I), J, ABSX, I, DUM(I)
  549    FORMAT (I5, 1X, A6, I5, F7.0, ' MATE FOR INPUT ATOM No.',
     *      I4, ' found at DIST = ', F4.2 )
         ENDIF
      IF (J .EQ. -4) THEN
         WRITE (24,
     *      FMT = '(12X, ''  This only input atom is not rejected'')')
         GOTO 570
         ENDIF
      GOTO 570
  553 IF (J .EQ. -2) GOTO 564
      III = II
      IF (J .EQ. -1) III = 0
      WRITE (8, 555) III, ATNAMX(I), I, ATNAMX(I)
      WRITE(24, 555) III, ATNAMX(I), I, ATNAMX(I)
  555 FORMAT (I5, 1X, A6, '  WARNING: no mate found for input atom', I4/
     *      ' ---> ', A6, '  will be removed from',
     *        ' the list of original input atoms')
      IF (J .EQ. 0) CALL KERROR ('KANNIET', 555, 'DIRBF')
      GOTO 570
  564 WRITE(24, 566) ATNAMX(I), ABSX, I
      WRITE (8, 566) ATNAMX(I), ABSX, I
  566 FORMAT (4X, '0', 1X, A6, F6.0,
     *  ' : peak height is too low for input atom', I3)
  570 CONTINUE
      IF (NRECYR .LE. 1) THEN
         WRITE(24, 572)
         WRITE (8, 572)
  572    FORMAT (/' The input atoms are appended by the remaining ',
     *    '(unidentified) peaks,' / ' the tentative chemical ',
     *    ' assignment is based on the CRYSDA file' /
     *    ' and the peak height, not on any chemical argument.' / )
      ELSEIF (NRECYR .EQ. 2) THEN
         WRITE(24, 575)
         WRITE (8, 575)
  575    FORMAT (/' Note: the secondary input atoms, tentatively',
     *      ' assigned and added to' / ' the original list in',
     *      ' the foregoing cycle(s), are now merged with the '/
     *      ' new (unidentified) peaks, sorted',
     *      ' to peakheight, and reinterpreted.'/)
         ENDIF
  592 CALL KERNZI (0, LCELTY, 10)
      LCELTY(NTYPEZ) = LCELTY(NTYPEZ) + 9999
      L = 0
      IF (REN98 .OR. NOFREE) CALL KERNZI (0, NCELIN, 10)
      DO 600 N = 1, NTYPEZ
      LCELTY(N) = LCELTY(N) + NCELTY(N) - NCELIN(N)
      IF (LCELTY(N) .LT. 0) THEN
         LCELTY(N+1) = LCELTY(N+1) + LCELTY(N)
         LCELTY(N) = 0
         ENDIF
      IF (L .EQ. 0 .AND. LCELTY(N) .GT. 0) L = N
  600 CONTINUE
      LH = 3
      IF (ACELTY(NTYPEZ) .NE. 'H ') LH = 0
      NPC = NPIC - NATX
      NATXX = 99
      IF (NPC .NE. 0) NATXX = MAX0(5, (NATX-NATS)/7 +3)
      NAT = NATSN
      DO 603 J = 1, NPIC
      IF (ATX4(4,J) .LE. 0.1) GOTO 603
      PEAKI = ATX4(4,J) **2 * ZSCAL
      IF (PEAKI . LT. 50.) GOTO 604
      NAT = NAT + 1
      CALL KERNAB (ATX4(1,J), ATXYZ(1,NAT), 3)
      ATXYZ(4,NAT) = 1.
      CALL KERNZA (0., ATXYZ(5,NAT), 6)
      ATXYZ(5,NAT) = XBTEMP(J)
      ATXYZ(6,NAT) = ATX4(4,J)
      ATXYZ(8,NAT) = PEAKI
      ATXYZ(7,NAT) = FLOAT(J)
  603 CONTINUE
  604 CONTINUE
      NAT = MIN0 (NAT, NATX)
      NATNOH = NATSN
      DO 620 I = NATSN + 1, NAT
      CALL ATOMOC (0, ATXYZ(1,I), IOCC, 1)
      LLL = L
      IF (L .EQ. NTYPEZ.AND. LH .GT. 0 .AND. ATXYZ(8,I) .GT. 200.) THEN
         LLL = L - 1
         LH = LH - 1
         ENDIF
      CALL ATN4CN (ACELTY(LLL), I, I-1, ATNAME, I, ATNAME(I))
      J = NINT (ATXYZ(7,I))
      ATXYZ(7,I) = 0.
      N = JCON(J)
      KEY = 2
      IF (N .LE. 0) KEY = 3
      IF (REN98) KEY = 4
      IZAT(I) = NCELLZ(L)
      ATXYZ(10,I) = L
      CALL EXPEAK(KEY, I, I-1, IZOLD)
      IF (IZOLD .NE. 0) IRECY(5) = IRECY(5) + 1
      IF (N .GT. 0) THEN
         LW(N) = -3
         WRITE (8, 545) I, ATNAME(I),J,ATXYZ(8,I),(ATX4(K,J), K=1,3),
     *      DUM(N), XDUM(N), N, ATNAMX(N)
         IF (NRECYR .LE. 2) GOTO 610
         IF (ATNAME(I)(1:1) .EQ. ATNAMX(N)(1:1) ) GOTO 610
         CALL ATCHK (ATNAME(I), NLET, IZZ)
         CALL ATCHK (ATNAMX(N), NLET, NZZ)
  610    CONTINUE
      ELSE
         WRITE (8, 545) I, ATNAME(I), J, ATXYZ(8,I)
         ATXYZ(5,I) = BR
         ENDIF
      LIOCC = IMULT/IOCC(1)
      ATXYZ(9,I) = LIOCC
      LCELTY(L) = LCELTY(L) - LIOCC
      IF (IZAT(I) .NE. 1) NATNOH = NATNOH + 1
  615 IF (LCELTY(L) .LE. 0) THEN
         L = L + 1
         LCELTY(L) = LCELTY(L) + LCELTY(L-1)
         IF (LCELTY(L) .LE. 0) GOTO 615
         ENDIF
      IF (L .LT. NTYPEZ) GOTO 620
      IF (NCELIN(L).GT.0 .AND. LCELTY(L) .GT. 9999) GOTO 620
      IF (IZAT(I) .GT. 1) GOTO 620
      NATXX = NATXX - 1
      IF (NATXX .LE. 0) THEN
         NAT = I
         GOTO 640
         ENDIF
  620 CONTINUE
  640 CONTINUE
      I = MSGT - MSGS
      IF (I .GT. 0) WRITE(24, 641) I
  641 FORMAT (/' Of the atoms tentatively added in the forgoing cycle'/
     *       I5, ' were found at distances larger than 0.23 Angstrom.')
      IF (NATIN .LE. NATS) GOTO 666
      II = 0
      DO 643 I = NATS+1, NATIN
      IF (LW(I) .LT. 0) GOTO 643
      II = II + 1
  643 CONTINUE
      IF (II .EQ. 0) GOTO 666
      WRITE(24, 644) II
  644 FORMAT (' Of the atoms tentatively added in the forgoing cycle'/
     *    I5, ' is(are) left out: no mate found or too weak to use.')
      WRITE (8, 645)
  645 FORMAT (/' Of the atoms tentatively added in the forgoing cycle'
     *        /' some were found at distances > 0.23 angstrom, and/or'
     *        /' some are left out: no mate found or too weak to use:'/
     *        /' old No.  old name   PEAK  ATXYZ(8,I)  ATX4(4,J)')
      DO 647 I = NATS+1, NATIN
      IF (LW(I) .EQ. 0) WRITE (8, 646) I, ATNAMX(I)
  646 FORMAT (I8, 4X, A6, I7, 4X, F6.0, F13.5)
      IF (LW(I) .LE. 0) GOTO 647
      J = LW(I)
      BSUM = ATXYZ(8,I)
      WRITE (8, 646) I, ATNAMX(I), J, BSUM, ATX4(4,J)
  647 CONTINUE
  666 IRECY(6) = NQQQ
      I = 15 * IRECYD / NAT
      IRECY(8) = I
      I = IFIX ((ATXYZ(8,NAT) - 70.) / 50.)
      IF (I .GT. 0) IRECY(7) = I
      IRECYS = 0
      DO 677 I = 1, 8
      IRECYS = IRECYS + IRECY(I)
  677 CONTINUE
      CALL NNRECY(99)
      IF (NRECYS .GT. 90) IPRY = 24
      IF (.NOT. REN98 .AND. .NOT.NOFREE) CALL EXPEAK(-1, 0, 0, IDUMM)
      IF (NORECY) GOTO 690
      PSQN = 1.0
      IF (PSQ .LT. 0.30) PSQN = AMIN1 (0.70, 3. * PSQ)
      IF (PSQ .LT. 0.07) PSQN = 0.20
      NNNN = 0
      DO 682 N = 1, NTYPE
  682 NNNN = NNNN + NCELTY(N) * NCELLZ(N) ** 2
      NNNR = FLOAT (NNNN) * PSQN * 1.00001
      N = 0
  685 N = N + 1
      IF (N .GT. NAT) GOTO 687
      ITYPE = NINT(ATXYZ(10,N))
      IF (ITYPE .EQ. 0) GOTO 687
      IF (NCELLZ(ITYPE) .EQ. 1) GOTO 687
      NNNR = NNNR - NINT(ATXYZ(9,N)) * NCELLZ(ITYPE) ** 2
      IF (NNNR .LT. 0) GOTO 687
      GOTO 685
  687 NATPSQ = N - 1
      NDIFF = MIN0 (MAX0 (2, NATX-NATIN) * 30 / 40, 50)
      NATDIF = NATPSQ
      IF (NDIFF .GT. 30) NATDIF = NATIN + NDIFF
      NATREC = MIN0 (NAT, NATPSQ, NATNOH, NATDIF)
      IF (NATNOH .LE. NATREC * 20 /18) NATREC = NATNOH
      NATREC = MAX0 (NATIN, NATREC)
      IF (NRECYR .LE. 3) GOTO 690
      KSTAT(4) = NATNOH
      CALL NNRECY (5)
  690 CONTINUE
      IF (MPAT .LT. 0  .AND. NRECYR .GE. 13) THEN
         NORECY = .TRUE.
         SWRECY = .FALSE.
         ENDIF
      IF (MPAT .EQ. 0) KSTAT(14) = 1
      IF (NORECY) THEN
         KEYOPT = 0
      ELSEIF (KPROG .GT. 0 .AND. KPROG .NE. 9 .AND. NRECYR.LE.3
     *      .AND. NOPHAS .EQ. 0) THEN
         KEYOPT = 1
      ELSE
         KEYOPT = 2
         ENDIF
      CALL XCONDA (ICOND, IDDS, ICENT, KEYOPT)
      NATL = NATIN
      RTYMAX = 0.0
      DO 800 I = 1, NAT
      CALL KERNAB (ATXYZ(1,I), ATX4(1,I), 3)
      ATX4(4,I) = ATXYZ(6,I)
      IF (ATXYZ(8,I) .GT. 0.0) GOTO 798
      ATX4(4,J) = -ATXYZ(6,I)
      IF (ATXYZ(8,I) .GT. -1.1) ATX4(4,J) = ATXYZ(8,I)
  798 N = NINT(ATXYZ(10,I))
      IF (N .EQ. 0) GOTO 800
      IF (RCELTY(N) .GT. RTYMAX) RTYMAX = RCELTY(N)
      ATXYZ(7,I) = RCELTY(N)
  800 CONTINUE
      NAT = MIN0 (NAT, NATNOH + 2 + NATNOH / 30)
      NPIC = NAT
      RTYMAX = 2.0 * RTYMAX
      IF (RTYMAX .GT. DMAXB .AND. ABS(1.95 - DMAXB) .LT. 0.001) THEN
         DMAXB = RTYMAX
         IF (DMAXB .GT. DMOUT) DMOUT = DMAXB
         ENDIF
      NNNN = 0
      DO 812 N = 1, NTYPE
      IF (NCELLZ(N) .NE. 1) NNNN = NNNN + NCELTY(N) * NCELLZ(N) ** 2
  812 CONTINUE
      ILAST = 1
      NNNR = 0
      DO 822 I =1, NAT
      IF (IZAT(I) .NE. 1) NNNR = NNNR + NINT(ATXYZ(9,I)) * IZAT(I) ** 2
      IF (IZAT(I) .NE. 1 .AND. NNNR .LE. NNNN) GOTO 820
      IF (NNNR .LE. NNNN*125/100) GOTO 820
      ATNAME(I) (1:1)  = 'Q'
      ATNAM = ATNAME(I) (3:6)
      ZZZ = ATNAME(I)(2:2)
      CALL KERC2I (ZZZ, LEND)
      IF (LEND.LT.0 .OR. LEND.GT.9) ATNAME(I)(2:6) = ATNAM
      IZAT(I) = 1
  820 CONTINUE
      IF (IFIX(ATXYZ(8,I)) .GE. 100) ILAST = I
      IF (NRECYR .LE. 2 .AND. IFIX(ATXYZ(8,I)) .GE. 60) ILAST = I
      IF (NRECYR .LE. 1 .AND. IFIX(ATXYZ(8,I)) .GE. 40) ILAST = I
  822 CONTINUE
      NAT = ILAST
      IF (NRECYR .EQ.1) WRITE (8, FMT='('' $TEM NRECYR'')')
      WRITE (8, 833)  NRECYR, IRECY, IRECYD, IRECYS
  833 FORMAT (/ ' $TEM NRECYR', I3,' IRECY(8) IRECYD IRECYS ', 8I3, 2I4)
      IF (NRECYS .LT. 7) RETURN
      SUMB2Z = 0.
      ISUMZ = 0
      DO 901 I=1, NAT
      CALL EXPEAK(5, I, 0, IB100)
      FB100 = FLOAT (IB100) / 100.
      B2Z = FLOAT( IZAT(I) ) * FB100 * FB100
      IF (IB100 .LT. 0) B2Z = -B2Z
      SUMB2Z = SUMB2Z + B2Z
      ISUMZ = ISUMZ + IZAT(I)
  901 CONTINUE
      SUMB2Z = SUMB2Z / FLOAT (ISUMZ)
      SUMB2S = SQRT ( ABS (SUMB2Z) )
      IF (SUMB2Z .LT. 0.0) SUMB2S = - SUMB2S
      WRITE (8, FMT='('' $TE AVERAGE B SHIFT IS:'', F7.3,
     *   '' reset !''  )') SUMB2S
      DO 905 I=1, NAT
      ATXYZ(5,I) = ATXYZ(5,I) - SUMB2S
  905 CONTINUE
      IF (NORECY .OR. NRECYS .LT. 8) RETURN
      WRITE (8, FMT='('' $TEMPPP last line DIRBF '')')
      RETURN
      END
      SUBROUTINE XCONDA (ICOND, IDDS, ICENT, KEYOPT)
      INCLUDE 'Zaaaa.inc'
      CALL WR24
      WRITE (8, FMT='(/'' ***** XCONDA *****''/
     *   20X, ''KEYOPT='' ,I3, ''  MPAT='',I3 / )') KEYOPT, MPAT
      CALL FILCLO (IDDS, 'KEEP')
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      CALL FILINQ (ICOND, 'CONDA', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ICOND,
     *      FMT = '(''CONDA  '', A6, '' generated by XCONDA'' )') CCODE
      IF (KEYOPT .EQ. 0) THEN
         IF (MPAT .GT. -99 .AND. MPAT .LE. -2) CALL ATPATS(1)
         WRITE (24, *) 'Final SF'
      ELSEIF (KEYOPT .EQ. 1) THEN
         WRITE (ICOND, FMT = '(''PROGRAM DDMAIN'')')
         WRITE (ICOND, FMT = '(''OPTION 1 PHASEX 0 '')')
         WRITE (IDDS,  FMT = '(''DDMAIN'')')
         WRITE (ICOND, FMT = '(''PROGRAM  PHASEX  '')')
         WRITE (IDDS,  FMT = '(''PHASEX'')')
         WRITE (ICOND, FMT = '(''PROGRAM  DDMAIN  '')')
         WRITE (ICOND, FMT = '(''OPTION 2 FOUR.PH 0 '')')
         WRITE (IDDS,  FMT = '(''DDMAIN'')')
         WRITE (ICOND, FMT = '(''PROGRAM  FOUR '')')
         WRITE (IDDS,  FMT = '(''FOUR'')')
      ELSEIF (KEYOPT .GE. 2) THEN
         WRITE (ICOND, FMT ='(''PROGRAM DDMAIN'')')
         WRITE (ICOND, FMT = '(''OPTION 3 FOUR 0 '')')
         WRITE (IDDS, FMT = '(''DDMAIN'')')
         WRITE (ICOND, FMT = '(''PROGRAM  FOUR '')')
         WRITE (IDDS,  FMT = '(''FOUR'')')
         ENDIF
      WRITE (ICOND, FMT ='(''PROGRAM DDMAIN'')')
      WRITE (ICOND, FMT ='(''OPTION 0 FCALC'')')
      WRITE (IDDS, FMT = '(''DDMAIN'')')
      IF (ICENT.EQ.1 .AND. KEYOPT.EQ.0 .AND. R2X.LE.0.33) THEN
         KSTAT(14) = 1
         WRITE (ICOND, FMT ='(''PROGRAM NUTS BIJVOET'')')
         WRITE (IDDS,  FMT ='(''NUTS'')')
         ENDIF
      WRITE (ICOND, FMT ='(''PROGRAM NUTS AT2X'' / ''FINISH'')')
      WRITE (IDDS,  FMT ='(''NUTS''/''STOP'')')
      CALL FILCLO (ICOND, 'KEEP')
      CALL FILCLO (IDDS, 'KEEP')
      RETURN
      END
      SUBROUTINE ATN4CN (CHEM, NUMB, KEY, ATNAME, NAT, ATNEW)
      CHARACTER*2 CHEM
      CHARACTER*6 ATNAME(NAT), ATNEW, C, CNUMB
      ATNEW = ' '
      N = NUMB
  607 CALL KERI2C (N, CNUMB, 6)
      C(1:2) = CHEM
      C(3:6) = CNUMB
      IF (C(2:2) .EQ. ' ') C(2:6) = CNUMB
      IF (KEY .LE. 0) GOTO 999
      CALL KEREQ6 (C, ATNAME, KEY, KEND)
      IF (KEND .LE. 0) GOTO 999
      N = N + 100
      IF (N .LT. 300) N = N + 100
      IF (N .LT. 300) N = N + 100
      GOTO 607
  999 ATNEW = C
      RETURN
      END
      SUBROUTINE ATN2CN (ATNAM, CHEM, NUMB)
      CHARACTER*2 CHEM
      CHARACTER*6 ATNAM
      CHARACTER*1 Z, ZZ
      CHEM = ATNAM(1:2)
      NUMB = 0
      IF (CHEM(2:2) .EQ. ' ') RETURN
      I = 1
      Z = ATNAM(2:2)
      CALL KERC2I (Z, LEND)
      IF (LEND.LT.0 .OR. LEND.GT.9) I=2
      IF (I .EQ. 1) CHEM(2:2) = ' '
      DO 101 N = I+1, 6
      ZZ = ATNAM(2:2)
      CALL KERC2I (ZZ, LEND)
      IF (LEND .EQ. 10) RETURN
      IF (LEND.GE.0 .AND. LEND.LE.9) THEN
         NUMB = 10*NUMB + LEND
      ELSE
         IF (NUMB .EQ. 0) NUMB = 999
         NUMB = - NUMB
         RETURN
         ENDIF
  101 CONTINUE
      RETURN
      END
      SUBROUTINE ATN24X (ATNAM, ATNAME, NAT, ATNEW)
      CHARACTER*6 ATNAME(NAT), ATNAM, ATNEW, C
      CHARACTER*2 CHEM
      C = ATNAM
      ATNEW = ' '
      CALL KEREQ6 (C, ATNAME, NAT, KEND)
      IF (KEND .LE. 0) THEN
         ATNEW = C
         RETURN
         ENDIF
      CALL ATN2CN (C, CHEM, NUMB)
      N = IABS(NUMB)
      CALL ATN4CN (CHEM, N, NAT, ATNAME, NAT, ATNEW)
      RETURN
      END
      SUBROUTINE EXPEAK(KEY, IAT, MIAT, IZOLD)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IDDL, IFILE(1))
      EQUIVALENCE (NTYPEZ, KEYS(4))
      EQUIVALENCE (IMAP, KSTAT(7))
      LOGICAL SWRECY
      EQUIVALENCE (SWITCH(7), SWRECY)
      DIMENSION PH(10,5)
      EQUIVALENCE (PH(1,1), PHFAC(1,1))
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zsear.inc'
      COMMON /DIRBFA/ NCELTY(10), NCELLZ(10), NCELIN(10), NCELIX(10)
      COMMON /DIRBFB/ ACELTY(10)
      CHARACTER ACELTY *2
      DIMENSION SUM1(10,2), SUM2(10,2), SUM3(10,2), EXPP(10), EXPP2(10)
      DIMENSION RSUM(10,2), TSUM1(2), TSUM2(2), TSUM3(2)
      DIMENSION NCELIC(10), DBDP(10)
      CHARACTER *6 ATOLD
      CHARACTER *2 AC
      IZOLD = 0
      MTYPE = NTYPEZ
      IF (ACELTY(NTYPE) .EQ. 'H ') MTYPE = MTYPE - 1
      IF (KEY .GT. 0) GOTO 203
      IF (KEY .LT. 0) GOTO 603
      ISKIP = 0
      BDELTN = 0.
      TPH = 8.
      ATOLD = ' '
      NUMB = 0
      XPPXX = 0.80
      NPRINT = 0
      CALL KERNZI (0, NCELIC, 10)
      IF (NRECYR .LE. 1)  WRITE(8,FMT='( / '' EXPH:'' ,
     *   '' Expected peak heights of atoms for five B values:''/)')
      IF (NRECYR .LE. 1) THEN
         WRITE (8,FMT='(''    for B =   '',5F7.3/
     *      '' Atom         '', 35(''-'')) ') BFAC
         DO 166 J=1,NTYPE
         WRITE(8,FMT='('' Type'',I2,3X,A2,1X,5F7.2)') J,CELATY(J),
     *         (PH(J,IH), IH=1,5)
  166    CONTINUE
         ENDIF
      BDELTN = BFAC(2)-BFAC(1)
      BNMIN = AMAX1 (0.9, 0.9 * BFAC(1))
      BNMAX = AMIN1 (9.9, 1.1 * BFAC(5))
      ISKIP = 1
      CALL KERNZA (0.0, SUM1, 20)
      CALL KERNZA (0.0, SUM2, 20)
      CALL KERNZA (0.0, SUM3, 20)
      CALL KERNZA (0.0, RSUM, 20)
      CALL KERNZA (1.0, EXPP, 10)
      CALL KERNZA (1.0, EXPP2, 10)
      CALL KERNZA (0.1, DBDP, 10)
      DO 171 JTYPE = 1, NTYPE
      AC = ACELTY(JTYPE)
      IF   (AC.EQ.'P ' .OR. AC.EQ.'S ' .OR. AC.EQ.'CL' .OR. AC.EQ.'SE'
     * .OR. AC.EQ.'F ' .OR. AC.EQ.'BR' .OR. AC.EQ.'I ') EXPP(JTYPE)=.90
      IF   (AC.EQ.'O ' .OR. AC.EQ.'N ' .OR. AC.EQ.'C ') EXPP(JTYPE)=.80
      DBDP(JTYPE)=BDELTN/
     *   AMIN1(-0.005, (PH(JTYPE,4)-PH(JTYPE,3))) /200.
  171 CONTINUE
      EXPP(NTYPEZ)= 0.70
      EXPP(MTYPE) = 0.70
      IF (NRECYR .LE. 1) WRITE(8,FMT=
     *   '(/'' EXPP atoms :'', 10(4X,A2))') (ACELTY(J), J=1,NTYPE)
      IF (NRECYR .LE. 1) WRITE(8,FMT=
     *   '( '' EXPP relax :'', 10F6.2 )') (EXPP(J), J=1,NTYPE)
      QQN = 0.
      QQS = 0.
      WQQN = 0.
      WQQS = 0.
      DO 172 I = 1, NTYPEZ
      IF (PH(I,3) .LT. 3.0) GOTO 172
      QQS = QQS + PH(I,3) * CELALL(I)
      QQN = QQN + CELALL(I)
      IF (CELATY(I) .EQ. 'C' .OR. CELATY(I) .EQ. 'N' .OR.
     *   (CELATY(I) .EQ. 'O' )) GOTO 172
      WQQS = WQQS + PH(I,3) * CELALL(I)
      WQQN = WQQN + CELALL(I)
  172 CONTINUE
      QQA = QQS/QQN
      WQQA = - 1.0
      IF (WQQN .GT. 9.) WQQA = WQQS / WQQN
      IQQ = NPIC * 95 / 100
      QQN = 0.
      QQS = 0.
      WQQN = 0.
      WQQS = 0.
      DO 174 J = 1, IQQ
      QQQ = ABS ( ATX4(4,J) )
      KK = QQQ * 10000.
      KK = KK - IFIX ( QQQ ) * 10000
      KK = ( FLOAT(KK) )**2 / 4000.
      FKK = KK
      IF (FKK .LT. 250.) GOTO 174
      QQS = QQS + FKK / 100.
      QQN = QQN + 1.
      WQQS = WQQS + FKK / 100.
      WQQN = WQQN + 1.
  174 CONTINUE
      IF (ABS(QQN) .GT. 0.1) THEN
         QQB = QQS/QQN
      ELSE
         QQB = 1.
         ENDIF
      QPPQQ = QQB / QQA
      WRITE (8, FMT ='(
     *   '' $TEMP Aver.[PH/EXPH=XPPF] = QPPQQ ='', F 6.3)') QPPQQ
      IF (WQQA .LT. 0.001) GOTO 184
      IF (WQQN .LT. 17.) GOTO 184
      WQQB = WQQS/WQQN
      WPPQQ = WQQB / WQQA
      IZOLD = NINT (1000. * WPPQQ)
  184 XPPXX = QPPQQ * 0.90
      IF (NRECYR .LE. 1) THEN
         XPPXX = QPPQQ * 0.60
         IF (NATS .LT. NPIC/5 .OR. PSQ .LT. 0.30) XPPXX = QPPQQ * 0.40
         IF (PSQ .LT. 0.20)  XPPXX = QPPQQ * 0.25
      ELSEIF (PSQ .LT. 0.50) THEN
         XPPXX = QPPQQ * 0.50
      ELSEIF (NRECYS.LE.4) THEN
         XPPXX = QPPQQ * 0.60
      ELSEIF (NRECYS.LE.8) THEN
         XPPXX = QPPQQ * 0.70
      ELSE
         XPPXX = QPPQQ * 0.75
         ENDIF
      IF (IMAP .EQ. 1) XPPXX = 0.25
      DO 194 JTYPE = 1, NTYPE
      EXPP2(JTYPE) = EXPP(JTYPE) * XPPXX
  194 CONTINUE
      WRITE (8, FMT='('' $TEMP EXPP2'', 10F6.2)')
     *   (EXPP2(IJ), IJ = 1, NTYPE)
      RETURN
  203 CONTINUE
      IF (ISKIP .EQ. 0) RETURN
      TT44 = 1.0
      IF (ABS(ATXYZ(4,IAT)) .LT. 0.9) THEN
         TT44 = ABS(ATXYZ(4,IAT))
         IF (TT44 .LT. 0.3333) TT44 = 0.3333
         IF (IPRY .GT. 0) WRITE(24, 205) IAT, ATNAME(IAT), TT44
         WRITE(24, 205) IAT, ATNAME(IAT), TT44
  205    FORMAT (' Warning: reduced occupancy of atom', I4,
     *     ' = ', A6,'  is',F7.4)
         ENDIF
      KK = ATXYZ(6,IAT) * 10000.
      KK = KK - IFIX ( ATXYZ(6,IAT)) * 10000
      KK = ( FLOAT(KK) )**2 / 4000.
      FKK = KK
      JNAT = 1
      IF (KEY .EQ. 3) JNAT = 2
      MIATX = MIAT
      IF (KEY .GE. 4) MIATX = 0
      XPPXX2 = 0.90
      IF (JNAT .EQ. 2) XPPXX2 = 0.85
      IF (NRECYR .LE. 1 .AND. JNAT .EQ. 2) XPPXX2 = 0.70
      IF (NRECYS .EQ. 2 .AND. JNAT .EQ. 2) XPPXX2 = 0.80
      IZOLD = 0
      NAGAIN = 0
  209 N = NINT(ATXYZ(10,IAT))
      DO 210 JTYPE = 1,NTYPEZ
      IF (CELATY(JTYPE) .EQ. ACELTY(N)) GOTO 215
  210 CONTINUE
  215 CONTINUE
      BTEMP = ATXYZ(5,IAT)
      IF (BTEMP .LE. 0.0001) BTEMP = BR
      IF (BTEMP .LE. BFAC(1)) THEN
         TPH = PH(JTYPE,1)
      ELSEIF (BTEMP .GE. BFAC(5)) THEN
         TPH = PH(JTYPE,5)
      ELSE
         IF (ABS(BDELTN) .LT. 0.01) STOP 31202
         DO 300 IB = 2,5
         IF (BTEMP .LE. BFAC(IB)) THEN
            BRATIO = (BTEMP - BFAC(IB-1)) / BDELTN
            TPH = PH(JTYPE,IB-1)+((PH(JTYPE,IB)-PH(JTYPE,IB-1))*BRATIO)
            GOTO 325
            ENDIF
  300    CONTINUE
         ENDIF
  325 CONTINUE
      IF (TPH .LT. 0.1) TPH = 0.7
      EXPH = TPH * 100.
      EXPH = TT44 * EXPH
      XPPF = FKK/EXPH
      IF (KEY .EQ. 5) GOTO 551
      IF (NAGAIN .NE. 0 .OR. IPRY .EQ. 0) GOTO 1234
      IF (IZAT(IAT) .LE. 6) GOTO 1234
      IF (KEY .EQ. 1 .AND. IAT .GT. MIAT) GOTO 1234
      IF ((IZAT(IAT).GT.8  .AND. XPPF .LT. 0.5) .OR.
     *    (IZAT(IAT).GT.20 .AND. XPPF .LT. 0.6))
     *    WRITE (8,350) IAT, ATNAME(IAT), FKK, EXPH
  350 FORMAT (' $TEMP WARNING PkHeight of atom',I4,
     *     ' = ', A6,' is',F6.0, ' Expected:', F6.0)
 1234 CONTINUE
      XPP = EXPP2(N) * XPPXX2
      IF (NAGAIN .LT. 0) GOTO 524
      IF (N .GE. MTYPE) GOTO 404
      IF (XPPF .GE. XPP) GOTO 404
      IF (NAGAIN .EQ. 0) THEN
         WRITE (8,351) IAT, ATNAME(IAT), FKK, EXPH, XPPF
  351    FORMAT (' $TE7 atom', I4, 1X, A6,' PH, exPH :', 2F7.0,
     *      ' PH/exPH factor =', F5.2)
         RSUM(N,JNAT) = RSUM(N,JNAT) + 1.
         IZOLD = IZAT(IAT)
         ATOLD = ATNAME(IAT)
         NAGAIN = 1
         ENDIF
      N = N + 1
      IZAT(IAT) = NCELLZ(N)
      ATXYZ(10,IAT) = N
      IF (KEY .EQ. 1 .AND. MIAT.NE.0) THEN
         CALL ATN2CN (ATOLD, AC, NUMB)
         NUMB = IABS (NUMB)
         IF (NUMB .EQ. 0 .OR. NUMB .GE. 999) NUMB = IAT
      ELSE
         NUMB = IAT
         ENDIF
      CALL ATN4CN (ACELTY(N), NUMB, MIATX, ATNAME, MIATX, ATNAME(IAT))
      GOTO 209
  404 IF (NAGAIN .GT. 0) THEN
         WRITE (8,407) IAT, ATNAME(IAT)
  407    FORMAT (' New name',I4, ' = ', A6)
         IF (IAT .LE. NATSN) WRITE(24, 408) IAT, ATOLD, ATNAME(IAT)
  408    FORMAT (/' Original input atom ',I4, ' = ', A6,
     *      ' renamed to ', A6, ' LOW PEAK HEIGHT'/)
         ENDIF
      IF (KEY .EQ. 2) GOTO 422
      SUM1(N,JNAT) = SUM1(N,JNAT) + FKK
      SUM2(N,JNAT) = SUM2(N,JNAT) + EXPH
      SUM3(N,JNAT) = SUM3(N,JNAT) + 1.
  422 CONTINUE
      IF (IMAP .EQ. 1) GOTO 444
      IF (NAGAIN .GE. 1 .OR. N .LE. 1 .OR. NRECYR .LE. 2
     *   .OR. PSQ .LE. 0.85 .OR. XPPF .LT. 0.90*EXPP(N)) GOTO 444
      IF (XPPF .LT. 1.20 * QPPQQ) GOTO 444
      IF (ABS(XPPXX) .LT. 0.01) STOP 33444
      XPPNEW = QPPQQ * EXPP2(N-1) / XPPXX
      DO 425 JT = 1,NTYPEZ
      IF (CELATY(JT) .EQ. ACELTY(N-1)) GOTO 426
  425 CONTINUE
  426 CONTINUE
      EXPHNW = EXPH * PH(JT,3) / PH(JTYPE,3)
      XPPFNW = FKK / EXPHNW
      IF (XPPFNW .GT. 1.70 * XPPNEW ) THEN
         IF (NPRINT .EQ. 0) THEN
            WRITE (8, FMT='('' $TEM FLIPZ Cy  -atom-    FKK   '',
     *         '' EXPHNW  XPPFNW  XPPNEW   new at.name?'' )')
            NPRINT = 1
            ENDIF
         IF (XPPFNW .LT. 1.80 * XPPNEW) THEN
            WRITE (8,432)
     *      NRECYR, IAT, ATNAME(IAT), FKK, EXPHNW, XPPFNW, XPPNEW
  432       FORMAT (' $TEM FLIPZ', I3, I4, 1X, A6, 2F7.0, 2F7.2,
     *         5X, A2)
            GOTO 444
            ENDIF
         WRITE (8,432)
     *      NRECYR, IAT, ATNAME(IAT), FKK, EXPHNW, XPPFNW, XPPNEW,
     *      CELATY(JT)
         III = MAX0 (2, NCELIX(N-1)/20)
         IF (NCELIC(N-1) .GE. III) GOTO 444
         IF ( PSQ.LE.0.85 .OR. NRECYS.LE.3 ) GOTO 444
         IF ( NRECYS.LE.4 .AND. XPPF.GT.2.5) GOTO 500
         IF ( NRECYS.LE.6 .AND. XPPF.GT.2.0 .AND. R2X.LT.0.30) GOTO 500
         IF ( NRECYS.LE.8 .AND. XPPF.GT.1.8 .AND. R2X.LT.0.20) GOTO 500
         IF ( NRECYS.LE.10.AND. XPPF.GT.1.6 .AND. R2X.LT.0.20) GOTO 500
         IF ( NRECYS.LE.18.AND. XPPF.GT.1.5 .AND. R2X.LT.0.15) GOTO 500
         ENDIF
  444 RETURN
  500 CONTINUE
      IZOLD = IZAT(IAT)
      FKKOLD = FKK
      XPPFOL = XPPF
      ATOLD = ATNAME(IAT)
      NAGAIN = -1
      N = N - 1
      IZAT(IAT) = NCELLZ(N)
      ATXYZ(10,IAT) = N
         IF (KEY .EQ. 1 .AND. MIAT.NE.0) THEN
         CALL ATN2CN (ATOLD, AC, NUMB)
         NUMB = IABS (NUMB)
         IF (NUMB .EQ. 0 .OR. NUMB .GE. 999) NUMB = IAT
      ELSE
         NUMB = IAT
         ENDIF
      CALL ATN4CN (ACELTY(N), NUMB, MIATX, ATNAME, MIATX, ATNAME(IAT))
      GOTO 209
  524 CONTINUE
      IF (XPPF .GE. XPP + 0.20) GOTO 544
      IF (NRECYR .GE. 6 .AND. XPPF .GE. XPP + 0.15) GOTO 544
      WRITE (8, FMT='('' $TE UPGRADE? No: atom name not changed'')')
      IZAT(IAT) = IZOLD
      IZOLD = 0
      ATNAME(IAT) = ATOLD
      N = N + 1
      ATXYZ(10,IAT) = N
      GOTO 444
  544 CONTINUE
      WRITE (8, FMT='('' $TE new name: Cy'',I3,'' atom '', I4, 1X,
     *   A6, '' R2'', F5.2, '' PH XPPF'',F6.0, F5.2, '' >> '',A6 )')
     *   NRECYR, IAT, ATOLD, R2X, FKKOLD, XPPFOL, ATNAME(IAT)
      IF (IAT .LE. NATSN) WRITE(24, 548) IAT, ATOLD, ATNAME(IAT)
  548 FORMAT (/' Original input atom ',I4, ' = ', A6,
     *   ' renamed to ', A6, ' HIGH PEAK HEIGHT'/)
      RETURN
  551 CONTINUE
      IZOLD = 0
      IF (NPRINT .NE. -12459) RETURN
      DELB = DBDP(JTYPE) * ( FKK - QPPQQ * EXPH )
      BNEW = BTEMP + DELB
      IF (BNEW .LT. BNMIN) BNEW = BNMIN
      IF (BNEW .GT. BNMAX) BNEW = BNMAX
      WRITE (8, 1551) BTEMP, BR, BNEW, XPPF, QPPQQ, IZAT(IAT)
 1551 FORMAT (' $TE modify B!  B BR BNEW XPPF QPPQQ Z', 5F5.2, I4)
      BNEW = 0.75 * BTEMP + 0.25 * BNEW
      ATXYZ(5,IAT) = BNEW
      DELB = BNEW - BTEMP
      IZOLD = NINT ( DELB * 100. )
      RETURN
  603 CONTINUE
      WRITE (8, FMT='(//'' EXPEAK entry -1 (print) '', I2//)') ISKIP
      IF (ISKIP .EQ. 0) RETURN
      DO 614 JNAT = 1, 2
      TSUM1(JNAT) = 0.0
      TSUM2(JNAT) = 0.0
      TSUM3(JNAT) = 0.0
      DO 613 J = 1, NTYPEZ
      TSUM1(JNAT) = TSUM1(JNAT) + SUM1(J,JNAT)
      TSUM2(JNAT) = TSUM2(JNAT) + SUM2(J,JNAT)
      TSUM3(JNAT) = TSUM3(JNAT) + SUM3(J,JNAT)
      IF (SUM3(J,JNAT) .LT. 0.5) THEN
         SUM1(J,JNAT) = 0.0
      ELSE
         SUM1(J,JNAT) = SUM1(J,JNAT) / SUM3(J,JNAT)
         ENDIF
      IF (SUM3(J,JNAT) .LT. 0.5) THEN
         SUM2(J,JNAT) = 0.0
      ELSE
         SUM2(J,JNAT) = SUM2(J,JNAT) / SUM3(J,JNAT)
         ENDIF
  613 CONTINUE
      IF (TSUM3(JNAT) .LT. 0.5) THEN
         TSUM1(JNAT) = 0.0
         TSUM2(JNAT) = 0.0
      ELSE
         TSUM1(JNAT) = TSUM1(JNAT) / TSUM3(JNAT)
         TSUM2(JNAT) = TSUM2(JNAT) / TSUM3(JNAT)
         ENDIF
  614 CONTINUE
      ATOLD = 'all'
      WRITE (8, 643)
  643 FORMAT (/' Statistics for PH (Peak height), EXPH (Expected PH),'
     *  /' (averaged) for input atoms (INPUT) and new peak (PEAKS) with'
     *  /' expected ratios PH/EXPH, and applied factor for Z-reduction')
      WRITE (8, 644) (ACELTY(I), I=1,NTYPEZ), ATOLD
  644 FORMAT (/' For atom types: ', 11(3X, A3))
      WRITE (8, 645) (SUM3(I,1), I=1,NTYPEZ), TSUM3(1)
  645 FORMAT ( ' nr.atoms: INPUT ', 11F6.0)
      WRITE (8, 646) (SUM3(I,2), I=1,NTYPEZ), TSUM3(2)
  646 FORMAT ( '     + new PEAKS ', 11F6.0)
      WRITE (8, 647) (SUM1(I,1), I=1,NTYPEZ), TSUM1(1)
  647 FORMAT (/' aver. PH: INPUT ', 11F6.0)
      WRITE (8, 648) (SUM1(I,2), I=1,NTYPEZ), TSUM1(2)
  648 FORMAT ( '           PEAKS ', 11F6.0)
      WRITE (8, 649) (SUM2(I,1), I=1,NTYPEZ), TSUM2(1)
  649 FORMAT (/' av. EXPH: INPUT ', 11F6.0)
      WRITE (8, 650) (SUM2(I,2), I=1,NTYPEZ), TSUM2(2)
  650 FORMAT ( '           PEAKS ', 11F6.0)
      DO 664 JNAT = 1, 2
      DO 663 J = 1, NTYPEZ
      IF (SUM2(J,JNAT) .GT. 0.1) THEN
         SUM1(J,JNAT) = SUM1(J,JNAT) / SUM2(J,JNAT)
      ELSE
         SUM1(J,JNAT) = 0.0
         ENDIF
  663 CONTINUE
      IF (TSUM2(JNAT) .GT. 0.1) THEN
         TSUM1(JNAT) = TSUM1(JNAT) / TSUM2(JNAT)
      ELSE
         TSUM1(JNAT) = 0.0
         ENDIF
  664 CONTINUE
      WRITE (8, 675) (SUM1(I,1), I=1,NTYPEZ), TSUM1(1)
  675 FORMAT (/'  PH/EXPH::INPUT ', 11F6.2)
      WRITE (8, 676) (SUM1(I,2), I=1,NTYPEZ), TSUM1(2)
  676 FORMAT ( '           PEAKS ', 11F6.2)
      WRITE (8, 691) (EXPP2(I), I=1,NTYPEZ)
  691 FORMAT (/' minimum PH/EXPH'  /' required: INPUT ', 11F6.2)
      RSUM1 = 0.
      RSUM2 = 0.
      DO 693 N = 1, NTYPEZ
      RSUM1 = RSUM1 + RSUM(N,1)
      RSUM2 = RSUM2 + RSUM(N,2)
      EXPP2(N) = XPPXX2 * EXPP2(N)
  693 CONTINUE
      WRITE (8, 695) (EXPP2(I), I=1,NTYPEZ)
  695 FORMAT ( '   for new PEAKS ', 11F6.2)
      WRITE (8, 697) (RSUM(I,1), I=1,NTYPEZ), RSUM1
  697 FORMAT (/' Nr of atoms with'
     *        /' reduced Z INPUT ', 11F6.0)
      WRITE (8, 698) (RSUM(I,2), I=1,NTYPEZ), RSUM2
  698 FORMAT ( ' reduced Z PEAKS ', 11F6.0)
      WRITE (8, FMT='(1X)')
      RETURN
      END
      SUBROUTINE DIRBD
      INCLUDE 'Zsyst.inc'
      WRITE(24, 1)
      WRITE (8, 1)
   1  FORMAT (/' WARNING !!, INPUT ATOMS ARE NOT AVERAGED WITH'/
     + ' PEAK POSITIONS:  LOOK AT YOUR HEAVY ATOM SHIFTS'/
     + ' ESPECIALLY WITH VERY STRONG "RESIDUAL" PEAKS...'/)
      RETURN
      END
      SUBROUTINE DIRBP
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zsear.inc'
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IMAP, KSTAT(7))
      DIMENSION XS(3)
      IF (IMAP .EQ. 6 )  WRITE(24, 1)
      IF (IMAP .EQ. 6 )  WRITE (8, 1)
   1  FORMAT (' Patterson peak coordinates written to file ATOMS')
      WRITE(24, 2)
   2  FORMAT (' List of ten highest Patterson peaks and their vector',
     + ' length',/,
     +        '    Peak  height ',4X,'x',7X,'y',7X,'z    length'/)
      WRITE (8, 3)
   3  FORMAT (' List of Patterson peaks and their vector length'/
     +        '    Peak  height ',4X,'x',7X,'y',7X,'z    length'/)
      NPEAK = 1
      IF (IMAP .EQ. 6) THEN
         CHOUT = 'Patterson peaks (not atoms !)'
         CALL ATOMWA (IATOMS)
         ENDIF
      NAT = MIN0 (NPIC, NATX)
      DO 50 I = 1,NAT
      IF (ATX4(4,I) .LE. 0.5) GOTO 333
      DDIST=999.
      DO 3040 II = NLATT,1,-1
      DO 30 L = 1,3
      XS(L) = ATX4(L,I)-TLATT(L,II)
      IF (ABS(XS(L)) .GT. 0.5) XS(L) = XS(L) - SIGN(1.0,XS(L))
   30 CONTINUE
      DIST = SQRT ( QUAD2 (XS, XS) )
 3040 DDIST = AMIN1(DIST,DDIST)
      IF (I .LE. 10) WRITE(24,  35) NPEAK, ATX4(4,I), XS, DDIST
      WRITE (8,  35) NPEAK, ATX4(4,I), XS, DDIST
   35 FORMAT (I8, F8.0, 3F8.4, F8.2)
      IF (IMAP .EQ. 6) WRITE (IATOMS, 36) NPEAK, XS, ATX4(4,I)
   36 FORMAT ('ATOM   Q', I3, 2X, 3F8.5, ' Peakheight ', F8.0)
      NPEAK = NPEAK + 1
   50 CONTINUE
  333 IF (IMAP .EQ. 6) WRITE (IATOMS, FMT='(''END'')')
      CALL FILCLO( IATOMS, 'KEEP')
      CALL KEPROX
      KEYS(10) = 17
      RETURN
      END
      SUBROUTINE DIRBB
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zsear.inc'
      COMMON /BLANK/ IFRAG(MAXAT), ISYM(MAXAT),     IDUM(MAXAT),
     *               DUM(MAXAT),   IBOND(MAXAT*10), JBOND(MAXAT*10),
     *               XXXGEO(135520)
      DIMENSION JCON(MAXAT)
      EQUIVALENCE (JCON(1), ISYM(1))
      COMMON /XXANG/ KANG(64), LANG(64), KLANG(64)
      LOGICAL SWRECY, NORECY, REN98
      EQUIVALENCE (SWITCH(16), REN98)
      EQUIVALENCE (SWRECY, SWITCH(7)), (NORECY, SWITCH(8))
      DIMENSION XS(3), XST(3), XSHIFT(3)
      DIMENSION VEC(3,9)
      LOGICAL ID
      DATA ID / .FALSE. /
      CALL WR24
      WRITE (8, 106) NRECYR, NRECYS, NRECYT
  106 FORMAT (/' ***** DIRBB  *****', 29X,'[cycle', I3, ' /',I3,I2,']'/)
      IF (IPRY.NE.0) WRITE (IPRY, 200)
  200 FORMAT (/' Table 315-1  Interatomic bonding distances  (Angstrom)'
     *  //'      Atom    peak',
     *   /'  No. name  integr N1 dist  N2 dist  N3 dist  ....'
     *   /'              x100'/)
      NMAX = 0
      IANG = 1
      DO 500 I = 1, NAT
      IF (IPRY.NE.0 .AND. I.EQ.NATSN+1 .AND. NRECYR .LE. 1)
     *   WRITE (IPRY, FMT = '('' New atoms:'')')
      IF (IPRY.NE.0 .AND. I.EQ.NATSN+1 .AND. NRECYR .GT. 1)
     *   WRITE (IPRY, FMT = '('' New atoms, including those added '',
     *      '' earlier (resorted/renamed):'')')
      RTYI = ATXYZ(7,I)
      N = 0
      II= 0
      DO 430 J = 1, NAT
      DAV2 = (ATXYZ(7,J) + RTYI) **2
      IF (I .EQ. J) ID = .TRUE.
      DO 400 IS = 1, NSYMM
      CALL SYMOP1 (IS, ATX4(1,J), XS)
      DO 400 IC = 1, ICENT
      DO 400 IL = 1, NLATT
      IF (ID) THEN
         ID = .FALSE.
         GOTO 400
         ENDIF
      CALL SYMOP2 (IC, IL, XS, XST)
      CALL DISTSQ (ATXYZ(1,I), XST, DMAXB, XSHIFT, DIST2)
      IF (DIST2 .GT. DAV2) GOTO 400
      IF (I .NE. J) GOTO 350
      II = 1
      IF (DIST2 .LT. 0.04) GOTO 400
      II = 2
  350 N = N + 1
      IDUM(N) = J
      DUM(N) = SQRT(DIST2)
      IF (DUM(N) .LT. 0.85  .AND. IPRY.NE.0) THEN
         WRITE (IPRY, 355) I, J
         IF (I .LE. NATSN .AND. J .LE. NATSN) WRITE (IPRY, 356)
  355    FORMAT (I5, ' short contact with No.' , I4)
  356    FORMAT ('+', 30X, '... possible input error ... ')
         ENDIF
      IF (N .LE. 9) THEN
         CALL KERNAB (XSHIFT, VEC(1,N), 3)
      ELSE
         NMAX = 10
         ENDIF
  400 CONTINUE
  430 CONTINUE
      IFRAG(I) = N
      JCON(I) = 0
      IF (IPRY.NE.0) THEN
      IF (II .EQ. 1) WRITE (IPRY, 441) I
  441 FORMAT (/ I5,' lies on a symmetry element')
      IF (II .EQ. 2) WRITE (IPRY, 442) I
  442 FORMAT (/ I5,' is close to a symm. element')
      IF (N .EQ. 0) WRITE (IPRY, 443) I, ATNAME(I), ATXYZ(8,I)
  443 FORMAT (I5, 1X, A6, F6.0, ' *')
      ENDIF
      IF (N .LE. 0) GOTO 500
      IF (IPRY.NE.0)
     * WRITE (IPRY,445) I, ATNAME(I), ATXYZ(8,I), (IDUM(K),DUM(K),K=1,N)
  445 FORMAT (I5, 1X, A6, F6.0, 6(I4,F5.2)/ (18X, 6(I4,F5.2)) )
      IF (N .GT. 0) CALL GEOFOB (0, I, 0.0)
      IF (N .LE. 1) GOTO 500
      IF (IANG .GE. 10*MAXAT - 64) GOTO 500
      N = MIN0 (N, 9)
      IFRAG(I) = N
      IBAD= 10*I - 9
      CALL KERNAI (IDUM, IBOND(IBAD), N)
      JCON(I) = IANG
      DO 458 K = 1, N-1
      QK = DUM(K)
      QK2 = QK * QK
      DO 457 L = K+1, N
      QL = DUM(L)
      IF (QL .LT. 0.3 .OR. QK .LT. 0.3) THEN
         JBOND(IANG) = 0
         GOTO 453
         ENDIF
      DO 450 J = 1, 3
  450 XSHIFT(J) = VEC(J,L) - VEC(J,K)
      CALL VMATV1 (XSHIFT, RRMAT, XSHIFT, QJ2)
      JBOND(IANG) = NINT (
     *   ACOS ((QK2 + QL*QL - QJ2) / (2.00001 * QK*QL)) / D2R  )
  453 IANG = IANG + 1
  457 CONTINUE
  458 CONTINUE
  500 CONTINUE
      IF (IPRY.NE.0 .AND. NMAX .GT. 9) WRITE (IPRY, 502)
  502 FORMAT (/
     *  ' Note: angles are calculated only for the first 9 contacts')
      IANG = 1
      IF (NORECY) WRITE (8, FMT='(  '' For distances and angles,
     * plots and COORDINATES see LIS1'')')
      IF (IPRY.NE.0) THEN
         IF (NAT. LE. 99) WRITE (IPRY, 510)
  510 FORMAT (/' Table 315-2    Interatomic bonding angles'/
     *   /'     Atom   peak'
     *   /'  No name integr  N1-No-N2 ang  N1-No-N3 ang  ......'
     *   /'            x100'/)
         IF (NAT. GT. 99) WRITE (IPRY, 511)
  511 FORMAT (/' Table 315-2    Interatomic bonding angles'/
     *   /'      Atom    peak'
     *   /'   No name  integr     N1-No-N2  ang      N1-No-N3 ang  ...'
     *   /'             x100'/)
         ENDIF
      DO 800 I = 1, NAT
      IF (IPRY.NE.0 .AND. I .EQ. NATSN+1 .AND. NRECYR .LE. 1)
     *   WRITE (IPRY, FMT = '('' New atoms:'')')
      IF (IPRY.NE.0 .AND. I .EQ. NATSN+1 .AND. NRECYR .GT. 1)
     *   WRITE (IPRY, FMT = '('' New atoms, including those added '',
     *      '' earlier (resorted/renamed):'')')
      M = 0
      IF (JCON(I) .LE. 0) GOTO 790
      N = IFRAG(I)
      IBAD= 10*I - 9
      CALL KERNAI (IBOND(IBAD), IDUM, N)
      DO 758 K = 1, N-1
      DO 757 L = K+1, N
      IF (JBOND(IANG) .EQ. 0) GOTO 753
      M = M + 1
      KLANG(M) = JBOND(IANG)
      KANG(M) = IDUM(K)
      LANG(M) = IDUM(L)
  753 IANG = IANG + 1
  757 CONTINUE
  758 CONTINUE
  790 IF (M .LE. 0) THEN
         IF (IPRY.NE.0) THEN
           IF (NAT. LE. 99) WRITE (IPRY, 791) I, ATNAME(I), ATXYZ(8,I)
  791      FORMAT (I4, 1X, A6, F5.0, 1X, '*')
           IF (NAT. GT. 99) WRITE (IPRY, 792) I, ATNAME(I), ATXYZ(8,I)
  792      FORMAT (I5, 2X, A6, F6.0, 1X, '*')
           ENDIF
         GOTO 800
         ENDIF
      IF (NAT .LE. 99) THEN
         IF(IPRY.NE.0) WRITE (IPRY, 794) I, ATNAME(I), ATXYZ(8,I),
     *     (KANG(J), I, LANG(J), KLANG(J), J=1,M)
  794    FORMAT (I4, 1X, A6, F5.0, 4(I4,2I3,I4) / (16X, 4(I4,2I3,I4) ))
      ELSE
         IF(IPRY.NE.0) WRITE (IPRY, 795) I, ATNAME(I), ATXYZ(8,I),
     *     (KANG(J), LANG(J), KLANG(J), J=1,M)
  795    FORMAT (I5, 2X, A6, F6.0, 4(3I4, '.') / (19X, 4(3I4, '.') ))
         ENDIF
      CALL GEOFOB (M, I, 0.0)
  800 CONTINUE
      CALL FCALR2
      RETURN
      END
      SUBROUTINE GEOFOB (KEYGEO, IGEO, ZSCAL)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zsear.inc'
      INCLUDE 'Zatomx.inc'
      COMMON /BLANK/ IFRAG(MAXAT), ISYM(MAXAT),     IDUM(MAXAT),
     *               DUM(MAXAT),   IBOND(MAXAT*10), JBOND(MAXAT*10),
     *               IFOB(3,1000), AFOB(1000),      IFOBC(10,100),
     *               WFOB(MAXAT),  WFOBA(MAXAT),    WFOBC(MAXAT),
     *               XXGEO(127460)
      COMMON /XXANG/ KANG(64), LANG(64), KLANG(64)
      LOGICAL REN98, SWRECY
      EQUIVALENCE (SWITCH(16), REN98), (SWITCH(7), SWRECY)
      LOGICAL CONT
      CHARACTER ZZZ *1
      DATA DMINX, DMIN, DMAX, DMAXX / 1.10, 1.20, 1.57, 1.70 /
      DATA EMINX, EMIN, EMAX, EMAXX /  90., 103., 126., 139. /
      DATA WANG / 0.5 /
      DATA DELMIN, DELMAX, ELMIN, ELMAX / .15, .15, 10., 10. /
      DATA LFOB, LFOBC, M / 0, 0, 0 /
      IF (KEYGEO .EQ. 0 .AND. IGEO .EQ. 0) THEN
         CONT = .FALSE.
         RETURN
         ENDIF
      IF (REN98) THEN
         IF (KEYGEO .LT. 0) KEYS(24) = 0
         RETURN
         ENDIF
      IF (CONT) GOTO 111
      CONT = .TRUE.
      CALL KERNZI (0, IFOB, 3000)
      CALL KERNZA (0., AFOB, 1000)
      CALL KERNZI (0, IFOBC, 1000)
      LFOB = 0
      LFOBC = 0
      DELMIN = DMIN - DMINX
      DELMAX = DMAXX - DMAX
      ELMIN = EMIN - EMINX
      ELMAX = EMAXX - EMAX
  111 I = IGEO
      IF (KEYGEO) 517, 117, 317
  117 CONTINUE
      IF (IZAT(I) .GT. 9) RETURN
      M = IFRAG(I)
      IF (LFOB .EQ. 1000) GOTO 138
      DO 137 N = 1, M
      J = IDUM(N)
      IF (IZAT(J) .GT. 9) GOTO 137
      IF (J .LT. I) GOTO 137
      IF (DUM(N).GT.DMIN .AND. DUM(N).LT.DMAX) GOTO 137
      IF (DUM(N) .GT. 1.35) THEN
         FOB = AMIN1 (1.4, (DUM(N)-DMAX) / DELMAX)
      ELSE
         FOB = AMIN1 (1.4, (DMIN-DUM(N)) / DELMIN)
         ENDIF
      IF (FOB .LT. 0.1) GOTO 137
      LFOB = LFOB + 1
      IFOB(1,LFOB) = 0
      IFOB(2,LFOB) = I
      IFOB(3,LFOB) = J
      AFOB(LFOB) = FOB
  137 CONTINUE
  138 IF (M .LE. 4) RETURN
      IF (LFOBC .EQ. 100) RETURN
      M = MIN0 (M, 9)
      LFOBC = LFOBC + 1
      IFOBC(1, LFOBC) = I
      CALL KERNAI (IDUM(1), IFOBC(2, LFOBC), M)
      RETURN
  317 CONTINUE
      IF (IZAT(I) .GT. 9) RETURN
      IF (LFOB .EQ. 1000) RETURN
      M = KEYGEO
      DO 337 N = 1, M
      ANG = KLANG(N)
      IF (ANG.GT.EMIN .AND. ANG.LT.EMAX) GOTO 337
      K = KANG(N)
      IF (IZAT(K) .GT. 9) GOTO 337
      J = LANG(N)
      IF (IZAT(J) .GT. 9) GOTO 337
      IF (ANG .GT. 115) THEN
         FOB = AMIN1 (1.4, (ANG-EMAX) / ELMAX)
      ELSE
         FOB = AMIN1 (1.4, (EMIN-ANG) / ELMIN)
         ENDIF
      IF (FOB .LT. 0.1) GOTO 337
      LFOB = LFOB + 1
      IFOB(1,LFOB) = K
      IFOB(2,LFOB) = I
      IFOB(3,LFOB) = J
      AFOB(LFOB) = FOB * WANG
  337 CONTINUE
      RETURN
  517 CONTINUE
      IF (NAT .LE. 5) RETURN
      IF (NRECYR .LE. 1) THEN
         MSKIP = (NAT - NATS + 3) / 4
      ELSE
         MSKIP = NAT / 4
         ENDIF
      SCFOB = SQRT(600./ZSCAL)
      NSKIP = 0
      NSKIPT = 0
  555 CALL KERNZA (0., WFOB, NAT)
      CALL KERNZA (0., WFOBA, NAT)
      CALL KERNZA (0., WFOBC, NAT)
      IF (LFOB+LFOBC .EQ. 0) GOTO 901
      IF (LFOB .EQ. 0) GOTO 578
      DO 577 N = 1, LFOB
      K = IFOB(1,N)
      I = IFOB(2,N)
      J = IFOB(3,N)
      IF (I .LE. 0 .OR. J .EQ. 0) GOTO 577
      IF (I .GT. MAXAT) GOTO 577
      IF (IZAT(I) .GT. 9) THEN
          IFOB(2,N) = 0
          GOTO 577
          ENDIF
      IF (K .EQ. 0) THEN
         WFOB(I) = SQRT(WFOB(I)**2 + AFOB(N)**2)
         WFOB(J) = SQRT(WFOB(J)**2 + AFOB(N)**2)
      ELSE
         IF ( K .GT. MAXAT .OR. J .GT. MAXAT ) GOTO 577
         IF ( K .LT. 0 .OR. J .LE. 0 ) GOTO 577
         WFOBA(I) = SQRT(WFOBA(I)**2 + AFOB(N)**2)
         WFOBA(J) = SQRT(WFOBA(J)**2 + AFOB(N)**2)
         WFOBA(K) = SQRT(WFOBA(K)**2 + AFOB(N)**2)
         ENDIF
  577 CONTINUE
  578 CONTINUE
      IF (LFOBC .EQ. 0) GOTO 598
      DO 587 N = 1, LFOBC
      I = IFOBC(1, N)
      IF (I .EQ. 0) GOTO 587
      IF (IZAT(I) .GT. 9) THEN
          IFOBC(1,N) = 0
          GOTO 587
          ENDIF
      WFOBC(I) = WFOBC(I) + 1.
      DO 581 NN = 2, 10
      NNN = IFOBC(NN, N)
      IF (NNN .EQ. 0) GOTO 581
      WFOBC(NNN) = WFOBC(NNN) + 1.
  581 CONTINUE
  587 CONTINUE
  598 CONTINUE
      XMAX = 0.
      IXMAX = 0
      DO 625 I = 1, NAT
      IF (IZAT(I).GT.9) GOTO 625
      XX = (WFOB(I) + WFOBA(I) + WFOBC(I))*SCFOB/ATX4(4,I)
      IF (I .LT. 10) XX = XX * FLOAT(I) / 10.
      IF (XX .GT. XMAX) THEN
         XMAX = XX
         IXMAX = I
         ENDIF
  625 CONTINUE
      I = IXMAX
      IF (I .EQ. 0) GOTO 901
      IF (XMAX .LT. 0.9) GOTO 901
      CALL WR24
      IF (SWRECY .AND. (NRECYR .GT. 1 .OR. I .GT. NATSN)) THEN
         IF (ATNAME(I)(1:1) .NE. 'Q')
     *      WRITE (8, FMT='('' Bad geometry: atom'',I4, 1X, A6,
     *      '' GEOFOB ='',F6.2,'' atom rejected :Q'')') I,ATNAME(I),XMAX
         IF (I .LE. NATSN) THEN
            NSKIP = NSKIP + 1
            write(24, FMT='('' Bad geometry: atom'',I4, 1X, A6,
     *          '' is rejected !'' )') I,ATNAME(I)
            ENDIF
         ATNAME(I)(1:1) = 'Q'
         ZZZ = ATNAME(I)(2:2)
         CALL KERC2I (ZZZ, LEND)
         IF ((LEND.LT.0).OR.(LEND.GT.9)) ATNAME(I)(2:6) = ATNAME(I)(3:6)
         IZAT(I) = 1
         IF (I .LE. NATREC + NSKIPT) NSKIPT = NSKIPT + 1
      ELSE
         IF (I .LE. NATSN .OR. I .LE. (NATREC*10)/11 )
     *      write(24, FMT='('' Bad geometry for atom'',I4, 1X, A6,
     *          ''  but atom is retained !'' )') I,ATNAME(I)
         WRITE (8, FMT='('' Bad geometry: atom'',I4, 1X, A6,
     *   '' GEOFOB ='', F6.2, '' atom retained !!'' )') I,ATNAME(I),XMAX
         ENDIF
      IF (NSKIPT .GE. MSKIP) GOTO 901
      IF (LFOB .EQ. 0) GOTO 638
      NC = 0
      DO 637 N = 1, LFOB
      IF (IFOB(1,N).EQ.I .OR. IFOB(2,N).EQ.I .OR. IFOB(3,N).EQ.I)
     *   IFOB(2,N) = 0
      IF (IFOB(2,N) .EQ. 0) NC = NC + 1
  637 CONTINUE
      IF (NC .EQ. LFOB) LFOB = 0
  638 CONTINUE
      IF (LFOBC .EQ. 0) GOTO 698
      NC = 0
      DO 687 N = 1, LFOBC
      IF (IFOBC(1, N    ) .EQ. I) IFOBC(1, N    ) = 0
      IF (IFOBC(1, N    ) .EQ. 0) THEN
         NC = NC+ 1
         GOTO 687
         ENDIF
      NNC = 0
      DO 681 NN = 2, 10
      IF (IFOBC(NN, N    ) .EQ. I) IFOBC(NN, N    ) = 0
      IF (IFOBC(NN, N    ) .GT. 0) NNC = NNC + 1
  681 CONTINUE
      IF (NNC .GT. 4) GOTO 687
      IFOBC(1,LFOBC) = 0
      NC = NC + 1
  687 CONTINUE
      IF (NC .EQ. LFOBC) LFOBC = 0
  698 CONTINUE
      GOTO 555
  901 CONTINUE
      IF (NSKIPT .GT. NSKIP) WRITE(24, 903) NSKIPT
  903    FORMAT (' Nr of peaks not output because of bad geometry:', I4)
      KEYS(24) = NSKIP
      RETURN
      END
      SUBROUTINE FCALR2
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zsear.inc'
      COMMON /BLANK/ DUMFC(19630),
     *               ITATQQ(MAXAT),    ITAT1(MAXAT),   ITAT3(MAXAT),
     *               ACI(3,3,MAXAT), BCI(3,3,MAXAT), DUMMY(118950)
      COMMON /DIRBFA/ NCELTY(10), NCELLZ(10), NCELIN(10), NCELIX(10)
      COMMON /DIRBFB/ ACELTY(10)
      CHARACTER ACELTY *2
      EQUIVALENCE (ICRYS, IFILE(3))
      DIMENSION NCELL1(10), NCELL3(10), IZTYP1(10), IZTYP3(10)
      DIMENSION BMINX(3), R2MINX(3)
      DOUBLEPRECISION SUMEO4, SUMTR1, SUMTR2, SUMTR3, SUMEC4, SUMEE4
      CHARACTER ATTEMP *6
      DIMENSION SK(4,9)
      DIMENSION ECI4(3,3,MAXAT)
      DIMENSION ECI22(3,3,MAXAT)
      DOUBLEPRECISION ECI22, ECI4, SK
      DIMENSION BNEWZ(3, MAXAT)
      EQUIVALENCE (BNEWZ(1,1), ECI22(1,1,1))
      DIMENSION ACALC(MAXAT), BCALC(MAXAT), BNEWR2(MAXAT), R2MIN2(MAXAT)
      DIMENSION EXPB9(500,9), B9(9)
      DIMENSION IZZM(2,3,15), FZZM(2,3,15)
      DIMENSION FFF(10), ADTRIG(24)
      DATA ADTRIG / 24*0.0 /
      DATA NCALL, NCYOLD / 0, 999 /
      DATA B9I /0.03/
      DATA LSMINB / 0 /
      IF (NRECYS .LT. 4) LSMINB = 0
      IF (NRECYS .LE. 3 .OR. (NRECYS.EQ.4 .AND. PSQ.LT.0.90) ) RETURN
      DO 10 K=1,9
   10 B9(K) = FLOAT(K-5) * B9I * BP
      ISMAX = IFIX (STLMAX * 400. + 0.0001) + 2
      DO 11 IS=1,ISMAX
      STL = FLOAT(IS-1) * 0.0025
      STL2 = STL * STL
      DO 11 K = 1,9
      EXPB9(IS,K) = EXP(-B9(K) * STL2)
   11 CONTINUE
      DO 12 I=1,4
      DO 12 K=1,9
      SK(I,K) = 0.0
   12 CONTINUE
      DELB = 0.25 * BP
      IF (DELB .GT. 2.) DELB = 2.
      NCALL = NCALL + 1
      IF (NCYOLD .GT. NRECYR) NCALL = 1
      NCYOLD = NRECYR
      CALL WR24
      WRITE(24,101) NCALL, NRECYR, NRECYS, NRECYT
  101 FORMAT ( / ' ***** FCALR2 *****  subr 317 call', I2, 12X,
     *    '[cycle', I3, ' /', I3, I2, ']'/ )
      CALL WR24
      WRITE (8, 102) SCALE, BOV, DELB
  102 FORMAT (/' Structure factor calculation for FCALR2 refinement'/
     *         ' FCALR2 input data : Scale =', F9.5, ' Bov:', F6.3,
     *         ' delta-B:', F6.3 /)
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ)
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
      BSYMCL = ASYMCL**2
      NREFL  = 0
      IREFL  = 0
      SUMTR1 = 0.
      SUMTR2 = 0.
      SUMTR3 = 0.
      SUMEO4 = 0.
      SUMEC4 = 0.
      SUMEE4 = 0.
      SUMEO2 = 0.
      SUMEC2 = 0.
      NAT9 = 9 * NAT
      EFBP = 0.
      DO 104 I3 = 1,NAT
      BNEWR2(I3) = 0.
      R2MIN2(I3) = 0.
      DO 104 I2 = 1,3
      DO 104 I1 = 1,3
      ECI22(I1,I2,I3) = 0.
      ECI4(I1,I2,I3) = -0.0001
  104 CONTINUE
      NCELL1(10) = 0
      NCELL3(1) = 0
      DO 105 M = 1, 9
      NCELL1(M) = NCELLZ(M+1)
      NCELL3(M+1) = NCELLZ(M)
  105 CONTINUE
      DO 106 M = 1, 10
      IZTYP1(M) = 0
      IZTYP3(M) = 0
      IF (NCELLZ(M) .LE. 1) THEN
         NCELL1(M) = 0
         NCELL3(M) = 0
         GOTO 106
         ENDIF
      IF (NCELL1(M) .EQ. 1) NCELL1(M) = 0
      IF (NCELL3(M) .EQ. 1) NCELL3(M) = 0
      IF (NCELLZ(M) .LT. 10) THEN
         IF ( NCELLZ(M) .GT. 3 + NCELL1(M) ) NCELL1(M) = 0
         IF ( NCELL3(M) .GT. 3 + NCELLZ(M) ) NCELL3(M) = 0
      ELSE
         IF ( 4*NCELLZ(M) .GT. 5*NCELL1(M) ) NCELL1(M) = 0
         IF ( 4*NCELL3(M) .GT. 5*NCELLZ(M) ) NCELL3(M) = 0
         ENDIF
  106 CONTINUE
      IF (NCALL .LE. 2) WRITE (8, 107) ACELTY, NCELLZ, NCELL1, NCELL3
  107 FORMAT (/' Atomic Z and next LOWER and HIGHER Z :'
     *        /' ACELTY ', 10 (1X, A2),
     *        /' NCELLZ', 10I3/' NCELL1', 10I3/' NCELL3', 10I3)
      DO 114 J = 1, 10
      IZ = IZTYPE(J)
      IF (IZ .LE. 1) GOTO 114
      DO 110 M = 1, 10
      IF (NCELLZ(M) .EQ. IZ) GOTO 111
  110 CONTINUE
  111 CONTINUE
      IZTYP1(J) = NCELL1(M)
      IZTYP3(J) = NCELL3(M)
  114 CONTINUE
      IF (NCALL .LE. 2) WRITE (8, 115) CELATY, IZTYPE, IZTYP1, IZTYP3
  115 FORMAT (/' Atoms with atom type reference numbers : '
     *        /' CELATY ', 10 (1X, A2),
     *        /' IZTYPE', 10I3/' IZTYP1', 10I3/' IZTYP3', 10I3)
      IZ2 = 0
      NZ2 = 0
      DO 119 I = 1, NAT
      IF (ATXYZ(5,I) .LE. 0.001) ATXYZ(5,I) = BR
      ITAT3(I) = 0
      IF (IZAT(I) .NE. IZ2) THEN
         IZ2 = IZAT(I)
         NZ2 = 1
      ELSE
         NZ2 = NZ2 + 1
         IF (NZ2 .GE. 27) GOTO 119
         ENDIF
      J = ITAT(I)
      IZ3 = IZTYP3(J)
      DO 117 M = 1, NTYPE
      IF (IZTYPE(M) .EQ. IZ3) THEN
         ITAT3(I) = M
         GOTO 119
         ENDIF
  117 CONTINUE
  119 CONTINUE
      IZ2 = 0
      NZ2 = 0
      DO 123 I = NAT, 1, -1
      ITAT1(I) = 0
      IF (IZAT(I) .NE. IZ2) THEN
         IZ2 = IZAT(I)
         NZ2 = 1
      ELSE
         NZ2 = NZ2 + 1
         IF (NZ2 .GE. 10) GOTO 123
         ENDIF
      J = ITAT(I)
      IZ1 = IZTYP1(J)
      DO 121 M = 1, NTYPE
      IF (IZTYPE(M) .EQ. IZ1) THEN
         ITAT1(I) = M
         GOTO 123
         ENDIF
  121 CONTINUE
  123 CONTINUE
      IF (NCALL .LE. 2) THEN
         NATLIM = MIN0 (NAT, 20)
         WRITE (8, FMT='(/ '' TEST pointers to CELATY tables:''/
     *      '' Atomic Z   JTYPE       J-       J+    '',
     *      '' top 20 atoms:'')')
         DO 127 I = 1, NATLIM
         WRITE (8, 125) IZAT(I), ITAT(I), ITAT1(I), ITAT3(I)
  125    FORMAT (' IZAT', I4,' ITAT', I3,' ITAT1', I3,' ITAT3', I3)
  127    CONTINUE
         ENDIF
  130 CONTINUE
      NREFL = NREFL + 1
      HCODE = FBINX(1,NREFL)
      FOBS = FBINX(2,NREFL)
      IF (FOBS .LT. 0.) GOTO 400
      SIG = FBINX(3,NREFL)
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      SF2 = SUMF2 (ISS)
      GNORM = SQRT (SF2) * EXP ( - BP * STL2 )
      EOBS2 = ( SCALE * FOBS / GNORM )**2
      EOBS4 = EOBS2**2
      IREFL = IREFL + 1
      DO 135 J=1,NTYPE
      FFF(J) = ( FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL ) / GNORM
  135 CONTINUE
      Q5 = EXP (- DELB * STL2)
      Q4 = 1./ Q5
      CALL HKLEX1 (HKLX, HKLX)
      IF (NSYMM.EQ.1) GOTO 150
      DO 140 J=2,NSYMM
      IF (ITRS(J).EQ.0) GOTO 140
      ADTRIG(J) = HKLX(1,1)*TSYMM(1,J) + HKLX(2,1)*TSYMM(2,J) +
     *            HKLX(3,1)*TSYMM(3,J)
  140 CONTINUE
  150 FAP = 0.0
      FBP = 0.0
      CALL KERNZA (0.0, ACI, NAT9)
      IF (ICENT.EQ.1) CALL KERNZA (0.0, BCI, NAT9)
      DO 250 I=1,NAT
      A1 = 0.
      B2 = 0.
      DO 200 J=1,NSYMM
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      A1 = A1 + SICO(ITRIG + 2500)
      IF (ICENT.EQ.1) B2 = B2 + SICO(ITRIG)
  200 CONTINUE
      IJ = ITAT(I)
      TF = ATXYZ(4,I) * EXP (- ATXYZ(5,I) * STL2)
      A1 = A1 * TF
      ACALC(I) = A1 * FFF(IJ)
      FAP = FAP + ACALC(I)
      IF (ICENT .EQ. 1) THEN
         B2 = B2 * TF
         BCALC(I) = B2 * FFF(IJ)
         FBP = FBP + BCALC(I)
         ENDIF
      DO 220 M = 1, 3
      IF (M .EQ. 1) IJ = ITAT1(I)
      IF (M .EQ. 2) IJ = ITAT(I)
      IF (M .EQ. 3) IJ = ITAT3(I)
      IF (IJ .EQ. 0) GOTO 220
      A1FFF = A1 * FFF(IJ)
      ACI(1,M,I) = A1FFF * Q4
      ACI(2,M,I) = A1FFF
      ACI(3,M,I) = A1FFF * Q5
      IF (ICENT .EQ. 2) GOTO 220
      B2FFF = B2 * FFF(IJ)
      BCI(1,M,I) = B2FFF * Q4
      BCI(2,M,I) = B2FFF
      BCI(3,M,I) = B2FFF * Q5
  220 CONTINUE
  250 CONTINUE
      EC2 = BSYMCL * (FAP*FAP + FBP*FBP)
      SUMTR1 = SUMTR1 + (0.99 * EOBS2 - EC2)**2
      SUMTR2 = SUMTR2 + (EOBS2 - EC2)**2
      SUMTR3 = SUMTR3 + (1.01 * EOBS2 - EC2)**2
      SUMEO4 = SUMEO4 + EOBS4
      SUMEC4 = SUMEC4 + EC2*EC2
      SUMEE4 = SUMEE4 + EC2*EOBS2
      SUMEO2 = SUMEO2 + EOBS2
      SUMEC2 = SUMEC2 + EC2
      DO 307 I = 1, NAT
      DO 305 M = 1, 3
      IF (M .EQ. 1 .AND. ITAT1(I) .EQ. 0) GOTO 305
      IF (M .EQ. 3 .AND. ITAT3(I) .EQ. 0) GOTO 305
      DO 303 L = 1, 3
      EFAP = FAP - ACALC(I) + ACI(L,M,I)
      IF (ICENT .EQ. 1) EFBP = FBP - BCALC(I) + BCI(L,M,I)
      ECI2 = BSYMCL * (EFAP*EFAP + EFBP*EFBP)
      ECI22(L,M,I) = ECI22(L,M,I) + EOBS2 * ECI2
      ECI4(L,M,I) = ECI4(L,M,I) + ECI2 * ECI2
  303 CONTINUE
  305 CONTINUE
  307 CONTINUE
      S1 = SQRT(EOBS2 * EC2)
      S2 = EC2
      S3 = STL2 * S1
      S4 = STL2 * S2
      DO 320 K = 1,9
      T = EXPB9(ISS, K)
      T2 = T * T
      SK(1,K) = SK(1,K) + T  * S1
      SK(2,K) = SK(2,K) + T2 * S2
      SK(3,K) = SK(3,K) + T  * S3
      SK(4,K) = SK(4,K) + T2 * S4
  320 CONTINUE
      GOTO 130
  400 CONTINUE
      DO 429 K = 1,9
      SK(1,K) = SK(1,K) / SK(2,K)
      SK(2,K) = SK(3,K) / SK(4,K)
      SK(3,K) = SK(1,K) - SK(2,K)
      IF (K .EQ. 1) SK(4,K) = 99999.
      IF (K .GT. 1) SK(4,K) = SK(3,K) - SK(3,K-1)
  429 CONTINUE
      WRITE (8, 430) B9, (SK(1,K), K=1,9), (SK(2,K), K=1,9),
     *    (SK(3,K), K=1,9), (SK(4,K), K=2,9)
  430 FORMAT (/' LSCALB results:'//' delta B', 9(F7.3)/
     *  '      K1', 9F7.4/ '      K2', 9F7.4/
     *  '   K1-K2', 9F7.4/ ' increment     ', 8F7.4/)
      KK  = 5
      DO 433 K = 1,9
      IF (ABS (SK(3,K)) .LT. 0.00001) THEN
         KK = K
         GOTO 450
         ENDIF
  433 CONTINUE
      IF ( SK(3,1) * SK(4,2) .GT. 0. ) THEN
         KK = 1
         GOTO 450
         ENDIF
      IF ( SK(3,9) * SK(4,9) .LT. 0. ) THEN
         KK = 9
         GOTO 450
         ENDIF
      DO 437 K = 1,8
      IF (SK(3,K) * SK(3,K+1) .LT. 0.) GOTO 440
  437 CONTINUE
      GOTO 450
  440 QQ = ABS ( SK(3,K) / ( SK(3,K) - SK(3,K+1) ) )
      SCALK = SK(1,K) + QQ * ( SK(1,K+1) - SK(1,K) )
      B9K = B9(K) + QQ * ( B9(K+1) - B9(K) )
      GOTO 460
  450 SCALK = SK(1,KK)
      B9K = B9(KK)
  460 SCALEK = SCALE / SCALK
      BPK = BP + B9K
      WRITE (8, 465) SCALK, SCALE, SCALEK, B9K, BP, BPK
  465 FORMAT (/' Interpolated reciprocal scale multiplier:  ', F8.4/
     *         '    old scale: ', F8.4,'  new scale:', F8.4/
     *         ' change of average atomic temperature factor', F8.4/
     *         '       old Bp: ', F8.4,'     new Bp:', F8.4/ )
      WRITE (8, FMT='('' $TE SCALE LS-B '',I3,2F6.3,F8.4,2F6.3,
     *   '' NcyS='',I2)') NRECYR, PSQ, R2X, SCALEK, BPK, BR, NRECYS
      R1 = SUMTR1 / (SUMEO4 * 0.96)
      R2 = SUMTR2 / SUMEO4
      R3 = SUMTR3 / (SUMEO4 * 1.04)
      WRITE (8, 503) R2, NREFL, R1, R2, R3
  503 FORMAT (/' FCALR2 :  R2 =', F8.4, ' for ', I5, ' reflections',
     * //      ' For SCALE * [ 0.99  1.00 1.01  ], R2 =:', 3F8.4 )
      SCALE4 = SUMEC4 / SUMEE4
      SCALE2 = SUMEC2 / SUMEO2
      SCALE1 = SCALE * SQRT (SCALE4)
      WRITE (8, FMT='(/'' test FCALR2 : SCALE1,2,4 ='', 3F9.4)')
     *   SCALE1, SCALE2, SCALE4
      R2NEW = 1. - SUMEE4**2 / SUMEO4 / SUMEC4
      WRITE (8, FMT='('' test FCALR2 : with SCALE1 ='', F7.4,
     *   '' R2-theor. ='', F7.4, '' ???'')') SCALE1, R2NEW
      TESTA = SUMEO4 / SCALK**4
      TESTB = SUMEE4 / SCALK**2
      R2TEST = 1. -2. * TESTB / TESTA + SUMEC4 /TESTA
      WRITE (8, FMT='('' test FCALR2 : LS-B scale ='', F7.4,
     *   '' New R2-theor. ='', F7.4, '' !!!''/)') SCALEK, R2TEST
      SC2K2 = 2. / ( SUMEO4 * SCALK**2 )
      SCK4 = 1. / (  SUMEO4 * SCALK**4 )
      RDIFF1 = 0.0
      RDIFF3 = 0.0
      SDIFF1 = 0.0
      SDIFF3 = 0.0
      RDIFF2 = 0.0
      SDIFF2 = 0.0
      BOVPLU = DELB
      BOVMIN = - DELB
      BOVNUL = 0.
      WRITE (8, FMT='(//'' Tab 317-1 [ cy'', 2I3, I2, '' ]''//
     *   ''    Results atoms B refinements:''//
     *   '' Nr atom     Z     --- R2-theor. ---     B    Booth''/ 12X,
     *   ''  dB= '', 3F6.3, ''   input   B    R2-theor. del-R2''/)')
     *   NRECYR, NRECYS, NRECYT, BOVMIN, BOVNUL, BOVPLU
      BNEWRD = 0.0
      BNEWRA = 0.0
      BNEWRE = 0.0
      BNEWRB = 0.0
      DO 517 I = 1, NAT
      DO 515 M = 1, 3
      IF (M .EQ. 1 .AND. ITAT1(I) .EQ. 0) GOTO 515
      IF (M .EQ. 3 .AND. ITAT3(I) .EQ. 0) GOTO 515
      DO 513 L = 1, 3
      ECI4(L,M,I) = 1. + SCK4 * ECI4(L,M,I) - SC2K2 * ECI22(L,M,I)
  513 CONTINUE
      IF (M .NE. 2) GOTO 515
      RR1 = ECI4(1,M,I)
      RR2 = ECI4(2,M,I)
      RR3 = ECI4(3,M,I)
      CALL BOOTH (RR1, RR2, RR3, ATXYZ(5,I), DELB, BBOOTH, R2MIN)
      BNEWR2(I) = BBOOTH
      R2MIN2(I) = R2MIN
      DELR2 = BBOOTH - ATXYZ(5,I)
      BNEWRD = BNEWRD + DELR2
      BNEWRA = BNEWRA + ABS (DELR2)
      BNEWRE = BNEWRE + DELR2 - B9K
      BNEWRB = BNEWRB + ABS (DELR2 - B9K)
      DELR2 = R2MIN - RR2
      IZ = IZAT(I)
      WRITE (8, 514) I, ATNAME(I), IZ, ( ECI4(L,M,I), L=1,3 ),
     *   ATXYZ(5,I), BBOOTH, R2MIN, DELR2
  514 FORMAT (I4, 1X, A6, I3, 4X, 3(1X,F5.4), 2X, 2F6.2, 2F9.5)
      RDIFF2 = RDIFF2 + R2MIN - ECI4(2,2,I)
      SDIFF2 = SDIFF2 + 1.
  515 CONTINUE
  517 CONTINUE
      BNEWRD = BNEWRD / FLOAT(NAT)
      BNEWRA = BNEWRA / FLOAT(NAT)
      BNEWRE = BNEWRE / FLOAT(NAT)
      BNEWRB = BNEWRB / FLOAT(NAT)
      WRITE (8,FMT='( /'' Booth interpolation for B: ''/
     *   '' Averaged change in B (delB) and aver abs delB: '', 2F8.4/
     *   '' Averaged valuies after LS-B Bp-new correction: '', 2F8.4)')
     *   BNEWRD, BNEWRA, BNEWRE, BNEWRB
      IF (SDIFF2 .GT. 0.5) RDIFF2 = RDIFF2 / SDIFF2
      WRITE (8,FMT='(/
     *    '' If B(Booth) is accepted: average change in R2: '',F8.4
     *   /''                               number of terms: '',F8.0/)')
     *   RDIFF2, SDIFF2
      WRITE (8, FMT='(//'' Tab 317-2 [ cy'', 2I3, I2, '' ]''//
     *   ''    Results atoms Z refinements:''//
     *   '' Nr atom new-Z     --- R2-theor. ---     B    Booth''/ 12X,
     *   ''  dB= '', 3F6.3, ''   input   B    R2-theor. del-R2''/)')
     *   NRECYR, NRECYS, NRECYT, BOVMIN, BOVNUL, BOVPLU
      CALL KERNZI (0, IZZM, 90)
      CALL KERNZA (999., FZZM, 90)
      DO 627 I = 1, NAT
      BMINX(2) = BNEWR2(I)
      R2MINX(2) = R2MIN2(I)
      DELR2 = 0.
      DO 618 M = 1, 3, 2
      BMINX(M) = -1.
      R2MINX(M) = 999.
      IF (M .EQ. 1 .AND. ITAT1(I) .EQ. 0) GOTO 618
      IF (M .EQ. 3 .AND. ITAT3(I) .EQ. 0) GOTO 618
      RR1 = ECI4(1,M,I)
      RR2 = ECI4(2,M,I)
      RR3 = ECI4(3,M,I)
      CALL BOOTH (RR1, RR2, RR3, ATXYZ(5,I), DELB, BBOOTH, R2MIN)
         IF (M .EQ. 1 ) THEN
         DELR2 = R2MIN - R2MINX(2)
         IF (DELR2 .GT. -0.0000001) GOTO 604
         RDIFF1 = RDIFF1 + DELR2
         SDIFF1 = SDIFF1 + 1.0
      ELSEIF (M .EQ. 3 ) THEN
         DELR2 = R2MIN - R2MINX(2)
         IF (DELR2 .GT. -0.0000001) GOTO 604
         RDIFF3 = RDIFF3 + DELR2
         SDIFF3 = SDIFF3 + 1.0
         ENDIF
  604 CONTINUE
      BMINX(M) = BBOOTH
      R2MINX(M) = R2MIN
      IF (M .EQ. 1) II = ITAT1(I)
      IF (M .EQ. 3) II = ITAT3(I)
      IZ = IZTYPE(II)
      IF (DELR2 .LE. -0.000001)
     *   WRITE (8,614) I, ATNAME(I), IZ, ( ECI4(L,M,I), L=1,3 ),
     *   ATXYZ(5,I), BBOOTH, R2MIN, DELR2
  614 FORMAT (I4,1X, A6,'?',I2,4X,3(1X,F5.4), 2X, 2F6.2, 2F9.5, ' ??')
  618 CONTINUE
      BNEWZ(2,I) = 0.
      BNEWZ(1,I) = -999.
      IF (BMINX(1) .LT. 0. .AND. BMINX(3) .LT. 0.) GOTO 624
      M = 0
      IF (BMINX(1) .GT. 0. .AND. BMINX(3) .GT. 0.) THEN
         IF (R2MINX(1) .LT. R2MINX(3)) THEN
            M=1
         ELSE
            M=3
            ENDIF
      ELSE
         M=3
         IF (R2MINX(1) .LT. R2MINX(3)) M=1
         ENDIF
      IF (M .EQ. 0) GOTO 624
      IF (M .EQ. 1) II = ITAT1(I)
      IF (M .EQ. 3) II = ITAT3(I)
      R2DEL = R2MINX(M) - R2MINX(2)
      IF (R2DEL .GE. FZZM(1,M,15)) GOTO 624
      DO 620 NZZ = 14, 1, -1
      IF (R2DEL .GE. FZZM(1,M,NZZ)) GOTO 621
  620 CONTINUE
      NZZ = 0
  621 CONTINUE
      NZZ = NZZ + 1
      DO 622 NZZ2 = 14, NZZ, -1
      IZZM(1,M,NZZ2+1) = IZZM(1,M,NZZ2)
      IZZM(2,M,NZZ2+1) = IZZM(2,M,NZZ2)
      FZZM(1,M,NZZ2+1) = FZZM(1,M,NZZ2)
      FZZM(2,M,NZZ2+1) = FZZM(2,M,NZZ2)
  622 CONTINUE
      IZZM(1,M,NZZ) = I
      IZZM(2,M,NZZ) = II
      FZZM(1,M,NZZ) = R2DEL
      FZZM(2,M,NZZ) = BMINX(M)
      IF (R2DEL .GT. -0.0000001) GOTO 624
      BNEWZ(1,I) = FLOAT(II)
      BNEWZ(2,I) = R2DEL
      BNEWZ(3,I) = BMINX(M)
  624 CONTINUE
  627 CONTINUE
      IF (SDIFF1 .GT. 0.5) RDIFF1 = RDIFF1 / SDIFF1
      IF (SDIFF3 .GT. 0.5) RDIFF3 = RDIFF3 / SDIFF3
      WRITE (8,FMT='(/ '' If all negative terms are accepted:''
     *   /'' averaged change in R2 by smaller Z: '', F8.5,
     *    '' or larger Z: '', F8.5
     *   /''    number of terms: '', 17X, F8.0, 14X, F8.0 )')
     *   RDIFF1, RDIFF3, SDIFF1, SDIFF3
      TDIFF1 = 0.00001
      TDIFF3 = 0.00001
      SDIFF1 = 0.
      SDIFF3 = 0.
      DO 628 I = 1, NAT
      IF (ECI4(1,1,I) .GT. 0.0) THEN
         TDIFF1 = TDIFF1 + ECI4(2,1,I) - ECI4(2,2,I)
         SDIFF1 = SDIFF1 + 1.
         ENDIF
      IF (ECI4(3,3,I) .GT. 0.0) THEN
         TDIFF3 = TDIFF3 + ECI4(2,3,I) - ECI4(2,2,I)
         SDIFF3 = SDIFF3 + 1.
         ENDIF
  628 CONTINUE
      IF (SDIFF1 .GT. 0.5) TDIFF1 =  (TDIFF1 / SDIFF1)
      IF (SDIFF3 .GT. 0.5) TDIFF3 =  (TDIFF3 / SDIFF3)
      WRITE (8,FMT='(/ '' If all term (+/-) are included:''
     *   /'' averaged change in R2 by smaller Z: '', F8.5,
     *    '' or larger Z: '', F8.5
     *   /''    number of terms: '', 17X, F8.0, 14X, F8.0 )')
     *   TDIFF1, TDIFF3, SDIFF1, SDIFF3
      WRITE (8,FMT='(/ '' Iat, II, R2-del, new-B  '')')
      DO 629 I = 1, NAT
      II = NINT(BNEWZ(1,I))
      IF (II .GT. 0)  WRITE (8,FMT='(
     *   2I4, F9.5, F6.3)') I, II, BNEWZ(2,I), BNEWZ(3,I)
      BNEWZ(3,I) = ATXYZ(5,I)
  629 CONTINUE
      WRITE (8,FMT='( / '' Z refine:''/
     *   '' Nat  IZ  IZ-       R2      B'', 5X,
     *   '' Nat  IZ  IZ+       R2      B''/)')
      DO 1630 I=1,15
      IZ1 = IZZM(1,1,I)
      IF (IZ1 .GT. 0) IZ1 = IZAT(IZ1)
      IZM1 = IZZM(2,1,I)
      IF (IZM1 .GT. 0) IZM1 = IZTYPE(IZM1)
      IZ3 = IZZM(1,3,I)
      IF (IZ3 .GT. 0) IZ3 = IZAT(IZ3)
      IZM3 = IZZM(2,3,I)
      IF (IZM3 .GT. 0) IZM3 = IZTYPE(IZM3)
      WRITE (8, 630)
     *   IZZM(1,1,I), IZ1, IZM1, FZZM(1,1,I), FZZM(2,1,I),
     *   IZZM(1,3,I), IZ3, IZM3, FZZM(1,3,I), FZZM(2,3,I)
  630 FORMAT (2 (3I4, F10.5, F8.4, 4X) )
 1630 CONTINUE
      WRITE (8,FMT='(/ '' Atom pairs suitable for switching ''/)')
      IZZTOT = 0
      DO 633 K1=1,15
      I1 = IZZM(1,1,K1)
      IF (I1 .LE. 0) GOTO 633
      IZ1 = IZAT(I1)
      IZM1 = IZZM(2,1,K1)
      IF (IZM1 .GT. 0) IZM1 = IZTYPE(IZM1)
      DO 632 K3=1,15
      I3 = IZZM(1,3,K3)
      IF (I3 .LE. 0) GOTO 632
      IZ3 = IZAT(I3)
      IZM3 = IZZM(2,3,K3)
      IF (IZM3 .GT. 0) IZM3 = IZTYPE(IZM3)
      IF (IZM3 .NE. IZ1 .OR. IZ3 .NE. IZM1) GOTO 632
      IF (FZZM(1,1,K1) + FZZM(1,3,K3) .LE. 0.) THEN
         WRITE (8, 630)
     *      I1, IZ1, IZM1, FZZM(1,1,K1), FZZM(2,1,K1),
     *      I3, IZ3, IZM3, FZZM(1,3,K3), FZZM(2,3,K3)
         IZZM(1,1,K1) = -IZZM(1,1,K1)
         IZZM(1,3,K3) = -IZZM(1,3,K3)
         IZZTOT = IZZTOT + 2
         GOTO 633
         ENDIF
  632 CONTINUE
  633 CONTINUE
      IF (IZZTOT .GT. 0) THEN
         WRITE (8, FMT='(/I3,'' renames accepted'')') IZZTOT
      ELSE
         WRITE (8, FMT='('' -------------> none''/)')
         ENDIF
      IF (NRECYS .GT. 5) THEN
         LSMINB = LSMINB + 1
         IF (LSMINB .EQ. 1) SCALE = 0.5 * (SCALE + SCALEK)
         IF (LSMINB .EQ. 2) SCALE = (2. * SCALE + SCALEK) / 3.
         IF (LSMINB .GT. 2) SCALE = (3. * SCALE + SCALEK) / 4.
         WRITE (8, FMT='('' $TE scale LS+B '',I3,2F6.3,F8.4,2F6.3,
     *   '' NcyS='',I2)') NRECYR, PSQ, R2X, SCALE, BPK, BR, NRECYS
         ENDIF
      XXX = AMAX1 (0.4, 0.1 * BP)
      IF (NRECYS .GE. 8) XXX = 0.3
      FAC2 = 0.80
      IF (NRECYS .GE. 5) FAC2 = 0.50
      IF (NRECYS .GE. 8) FAC2 = 0.30
      WRITE(24, FMT='('' '')')
      WRITE (8,FMT='( /'' B values:    B-old  Booth  B-del  B-new ''/
     *   42X, '' lim=   *fac=   B9K=''/42X, F6.3, F6.1, F9.3)')
     *   XXX, FAC2, B9K
      DO 649 I = 1, NAT
      TEMPAB = ATXYZ(5,I)
      TEMPAC = TEMPAB + 0.5 * BNEWRD
      IF (NRECYS .GE. 5) TEMPAC = TEMPAB + B9K
      BDELR2 = (BNEWR2(I) - ATXYZ(5,I) - BNEWRD)
      IF (BDELR2 .GT. XXX) BDELR2 = XXX
      IF (BDELR2 .LT. -XXX) BDELR2 = -XXX
      ATXYZ(5,I) = TEMPAC + FAC2 * BDELR2
      WRITE (8, 637) I, ATNAME(I), TEMPAB, BNEWR2(I), BDELR2, ATXYZ(5,I)
  637 FORMAT (I4, 1X, A6, '=', 4F7.3)
  649 CONTINUE
      IF (IZZTOT .LE. 0) GOTO 740
      CALL WR24
      IF (NRECYS .GT. 5) THEN
         IF (LSMINB .GT. 1) B9K = B9K / FLOAT(LSMINB)
         WRITE (8, FMT='('' $TE LS+B, B9K ='', F9.4, F6.3,
     *   ''   Ncy, NcyS='',2I3)') SCALE, B9K, NRECYR, NRECYS
         ENDIF
      WRITE(24, FMT='('' '')')
      WRITE (8, FMT='(/'' test Z refine ''//
     *   '' Atnr Z --> Z-new  R-del B-new    name ---> new name''/)')
      WRITE(24, FMT='(/'' Z refinement ''/
     *   '' Atnr  name   renamed'', 3X,''R2-del     B-old  B-new ''/)')
      DO 730 M=1,3,2
      DO 730 K1=1,15
      I = IZZM(1,M,K1)
      IF (I .GE. 0) GOTO 730
      I = - I
      IZ1 = IZAT(I)
      II = IZZM(2,M,K1)
      IZM1 = IZTYPE(II)
      WRITE (8, FMT='(3I4, F10.5, F8.4, 4X, A6, 1X, A2)')
     *   I, IZ1, IZM1, FZZM(1,M,K1), FZZM(2,M,K1), ATNAME(I), CELATY(II)
      IZAT(I) = IZM1
      BOLD9 = BNEWZ(3,I)
      BDIF9 = 0.3
      IF (NRECYS .LE. 4) BDIF9 = 0.1
      IF (NRECYS .GE. 8) BDIF9 = 0.2
      IF (IZM1 .LT. IZ1) BDIF9 = - BDIF9
      ADD9 = B9K
      IF (NRECYS .GE. 8) ADD9 = 0.5 * B9K
      ATXYZ(5,I) = BNEWZ(3,I)
      BDIF9 = 0.3
      IF (NRECYS .GE. 5) BDIF9 = 0.2
      IF (NRECYS .GE. 8) BDIF9 = 0.1
      IF (IZM1 .GT. IZ1) BDIF9 = - BDIF9
      ADD9 = B9K
      IF (NRECYS .GE. 5) ADD9 = 0.5 * B9K
      IF (NRECYS .GE. 8) ADD9 = 0.1 * B9K
      ATXYZ(5,I) = BNEWZ(3,I) + ADD9 + BDIF9
      ATTEMP = ATNAME(I)
      CALL ATN4CN (CELATY(II), I, NAT, ATNAME, NAT, ATNAME(I))
      WRITE(24, 644) I, ATTEMP, ATNAME(I), FZZM(1,M,K1),
     *   BOLD9, ATXYZ(5,I)
  644 FORMAT (I4, 3X, A6, 1X, A6, F10.5, 3X, 2F7.3)
  730 CONTINUE
  740 CONTINUE
      CALL WR24
      CALL ATOMOC (2, ATXYZ, ITAT, NAT)
      WRITE (8, FMT='(//'' FCALR2 finished '' //)')
      RETURN
      END
      SUBROUTINE BOOTH (R1, R2, R3, X2, DELX, XM, RM)
      X1 = X2 - DELX
      X3 = X2 + DELX
      C = ( R1 +R3 -R2 -R2 ) / (2. * DELX * DELX)
      B = ( R3 - R1 ) / (2. * DELX) - C * 2. * X2
      IF (C .LT. 0.0001) THEN
         XM = X2
         RM = R2
         IF (B .GT. 0.0001 .AND. R1 .LT. R2) THEN
            XM = X1
            RM = R1
         ELSEIF (B .LT. -0.0001 .AND. R3 .LT. R2) THEN
            XM = X3
            RM = R3
            ENDIF
         GOTO 111
         ENDIF
      XM = - 0.5 * B / C
      IF (XM .GT. X3) THEN
         XM = X3
         RM = R3
      ELSEIF (XM .LT. X1) THEN
         XM = X1
         RM = R1
      ELSE
         RM = R2 + B * (XM-X2) + C * (XM*XM-X2*X2)
         ENDIF
  111 CONTINUE
      IF (XM .LT. 0.5) XM = 0.5
      RETURN
      END
      SUBROUTINE CLSTRS
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      COMMON /BLANK/ IFRAG(MAXAT), ISYM(MAXAT),     IDUM(MAXAT),
     *               DUM(MAXAT),   IBOND(MAXAT*10), JBOND(MAXAT*10),
     *               XXXGEO(135520)
      DIMENSION LW(MAXAT), LR(MAXAT)
      EQUIVALENCE (LW(1), IDUM(1)), (LR(1), DUM(1))
      COMMON /SIZEX/ KFRAG(20), NFRAG, LFRAG(20), NOFRAG, NNA
      INCLUDE 'Zsear.inc'
      DIMENSION   IB(3), XS(3), X1(3), XSTOR(3)
      LOGICAL ISWFRM
      DATA    ISWFRM  /.FALSE./
      CALL WR24
      DFRG = 2.80
      IF (DMAXB .GT. DFRG) DFRG = DMAXB
      DFRG2 = DFRG * DFRG
      DMAXB2 = DMAXB * DMAXB
      ICHECK=0
      GOTO 1010
 1000 NAT = NPIC
 1010 NNA = 0
      MCON=0
      DO 1020 I=1,NAT
      IFRAG(I)=0
      LW(I) = 0
 1020 LR(I) = 0
      NFRAG=0
      NOFRAG=0
      NAT1=NAT-1
      DO 1180 II=1,NAT1
      IF (IFRAG(II).EQ.(-1000)) GOTO 1030
      IF (ICHECK.EQ.1.OR.IFRAG(II).NE.0) GOTO 1180
      IF (NOFRAG .LT. 20) THEN
         NOFRAG = NOFRAG + 1
         NFRAG = NFRAG + 1
         ENDIF
      IF (NOFRAG .EQ. 20 .AND. .NOT. ISWFRM) THEN
         WRITE (8, FMT='('' Warning: 20 or more fragments '')')
         ISWFRM = .TRUE.
         ENDIF
 1030 ICHECK=0
      IFRAG(II)=NOFRAG
      KOUNT=1
      I=II
      IBEGIN=II
 1040 DO 1140 J=IBEGIN,NAT
      IF (IFRAG(J).LT.0.AND.IFRAG(J).NE.(-1000)) GOTO 1140
      JMOVE = 0
      KSYM=0
      DO 1120 K =1, IMULT
      IF (I.EQ.J.AND.K.EQ.1) GOTO 1120
      IF (JSYMM(I,J,K,IB,XS,X1).NE.0) GOTO 1120
      DIST2 = QUAD2 (X1, X1)
      IF (DIST2 .GT. DFRG2) GOTO 1120
      LR(J)=1
      IF (DIST2 .GT. DMAXB2) GOTO 1120
      IF (DIST2 .GT. (ATXYZ(7,I) + ATXYZ(7,J)) **2 ) GOTO 1120
      IF (I .EQ. J .AND. DIST2 .LT. 0.04) GOTO 1120
      IF (IABS(IFRAG(J)).EQ.NOFRAG) GOTO 1080
      IF (IFRAG(J).EQ.(-1000)) GOTO 1060
      JMOVE=1
      KSYM=K
      DO 1050 L=1,3
 1050 XSTOR(L)=XS(L)
 1060 IFRAG(J)=NOFRAG
      KOUNT=KOUNT+1
      IF (KSYM.EQ.K) GOTO 1100
 1080 JBND=100000*IB(1)+10000*IB(2)+1000*IB(3)+K
      IF (JBND.EQ.555001) GOTO 1100
      IF (NNA .EQ. MAXAT-1) WRITE (8, 1085) NOFRAG, MAXAT-1
 1085 FORMAT (/' CLUSTER ',I3,' BONDS ',I4,' TIMES TO ITSELF')
      IF (NNA .LE. MAXAT-1) NNA = NNA + 1
      IF (I.LT.J) ISYM(NNA)=250000*NOFRAG+500*I+J
      IF (I .GE. J) ISYM(NNA) = 250000*NOFRAG + 500*J + I
      GOTO 1120
 1100 IF (I.EQ.J) GOTO 1120
      IDIST = 1000.0 * SQRT(DIST2) + 0.5
      MCON=MCON+1
      IBOND(MCON)=(512*I+J)*8192+IDIST
      MCON=MCON+1
      IBOND(MCON)=(512*J+I)*8192+IDIST
 1120 CONTINUE
      IF (JMOVE .EQ. 0) GOTO 1140
      DO 1125 L=1,3
      ATX4(L,J) = XSTOR(L)
 1125 CONTINUE
 1140 CONTINUE
      IFRAG(I)=-IFRAG(I)
      DO 1160 I=1,NAT
      IF (IFRAG(I).EQ.NOFRAG)GOTO 1040
 1160 CONTINUE
      IF (NAT .EQ. NPIC) GOTO 1178
      DO 1175 I=1,NAT
      IF (KOUNT.LT.4) GOTO 1170
      IF (IABS(IFRAG(I)) .NE. NOFRAG) GOTO 1165
      IF (LW(I) .EQ. 0) GOTO 1170
      GOTO 1000
 1165 IF (LW(I) .EQ. 0) LW(I) = LR(I)
 1170 LR(I) = 0
 1175 CONTINUE
 1178 IF (KOUNT.EQ.1)GOTO 1179
      KFRAG(NOFRAG)=KOUNT
      GOTO 1180
 1179 IFRAG(II)=0
      NFRAG=NFRAG-1
      NOFRAG=NOFRAG-1
 1180 CONTINUE
      DO 1240 I=1,NAT
      IFRAG(I)=IABS(IFRAG(I))
 1240 CONTINUE
      IF (MCON.GT.0) CALL ISORT(IBOND,MCON)
      RETURN
      END
      SUBROUTINE PICTUR (NPROJ)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zsear.inc'
      COMMON /BLANK/ IFRAG(MAXAT), ISYM(MAXAT),     IDUM(MAXAT),
     *               DUM(MAXAT),   IBOND(MAXAT*10), JBOND(MAXAT*10),
     *               XXXGEO(135520)
      DIMENSION XA(3,MAXAT), XB(4,MAXAT)
      PARAMETER (MX7=3*MAXAT+1)
      EQUIVALENCE (XA(1,1), IBOND(1)), (XB(1,1), IBOND(MX7))
      COMMON /SIZEX/ KFRAG(20), NFRAG, LFRAG(20), NOFRAG, NNA
      CHARACTER *124 CLINE1
      CHARACTER *6 CL
      DIMENSION B(3,3), V(3,3), IND(3), SUM(3), XMAX(3), XMIN(3)
      CALL WR24
      IF (IPRY.EQ.0)  RETURN
      NUM = KFRAG(NOFRAG)
      IF (NUM .LT. 4) RETURN
      ANUM = NUM
      COSW = (COS(D2R*CELL(5)) - COS(D2R*CELL(6))*COS(D2R*CELL(4))) /
     *                          (SIN(D2R*CELL(6))*SIN(D2R*CELL(4)))
      SINW=SQRT(1.0-COSW**2)
      A11=CELL(1)*SINW*SIN(D2R*CELL(6))
      A21=CELL(1)*COS(D2R*CELL(6))
      A22=CELL(2)
      A23=CELL(3)*COS(D2R*CELL(4))
      A31=CELL(1)*COSW*SIN(D2R*CELL(6))
      A33 = CELL(3) * SIN(D2R*CELL(4))
      CALL KERNZA (0.0, SUM, 3)
      CALL KERNZA (-10000.0, XMAX, 3)
      CALL KERNZA ( 10000.0, XMIN, 3)
      CALL KERNZA (0.0, B, 9)
      DO 108 I=1,NAT
      IF (IFRAG(I).NE.NOFRAG)GOTO 108
      XA(1,I)=ATX4(1,I)*A11
      XA(2,I)=ATX4(1,I)*A21+ATX4(2,I)*A22+ATX4(3,I)*A23
      XA(3,I)=ATX4(1,I)*A31+ATX4(3,I)*A33
      DO 106 J=1,3
      SUM(J)=SUM(J)+XA(J,I)
      DO 106 K=1,3
  106 B(J,K)=B(J,K)+XA(J,I)*XA(K,I)
  108 CONTINUE
      DO 120 J=1,3
      DO 120 K=1,3
  120 B(J,K)=B(J,K)-SUM(J)*SUM(K)/ANUM
      CALL EIGEN(B,V,IND)
      K=0
      DO 180 I=1,NAT
      IF (IFRAG(I).NE.NOFRAG) GOTO 180
      K=K+1
      XB(4,K)=I
      DO 140 J=1,3
      L=IND(J)
      XB(J,K)=XA(1,I)*V(1,L)+XA(2,I)*V(2,L)+XA(3,I)*V(3,L)
      XMAX(J)=AMAX1(XMAX(J),XB(J,K))
  140 XMIN(J)=AMIN1(XMIN(J),XB(J,K))
  180 CONTINUE
      NNN = 0
      N1 = 2
      N2 = 1
      IF (115.0/(XMAX(1)-XMIN(1)) .GE. 2.0/0.254) GOTO 190
      N1 = 1
      N2 = 2
  190 AMAX = AMAX1(XMAX(N2)-XMIN(N2), XMAX(N2+1)-XMIN(N2+1))
      SCALEP = AMIN1(115.0/AMAX, 2.5/0.254)
      SCL = 0.254 * SCALEP
  200 CALL SORT (XB, MAXAT, NUM, N1)
  210 NNN = NNN + 1
      WRITE (IPRY, 220) NOFRAG
  220 FORMAT (/// ' ', 72('+')// ' Cluster ',I3)
      GOTO (240, 280, 320), NNN
  240 WRITE (IPRY, 260) SCL
  260 FORMAT ('+', 17X, ' Plot on least squares plane,   scale  ='
     +,F6.2,'  cm /A' /)
      GOTO 360
  280 WRITE (IPRY, 300)
  300 FORMAT ('+', 17X, ' Plot on plane orthogonal to l.s. plane' /)
      GOTO 360
  320 WRITE (IPRY, 340)
  340 FORMAT ('+', 17X, ' Plot on most squares plane' )
  360 IX=0
      OFFSET = 2.5
      ALN = 6.
      CLINE1 = ' '
      DO 460 I =1, NUM
      IXREL = 0.1 * ALN * SCALEP * (XMAX(N1)-XB(N1,I)) - FLOAT(IX) +0.5
      IF (IXREL .LE. 0) GOTO 420
      WRITE (IPRY, 402) CLINE1
  402 FORMAT (A124)
      CLINE1 = ' '
      IX = IX + IXREL
      IF (IXREL .EQ. 1) GOTO 420
      DO 410 J = 1, IXREL-1
  410 WRITE (IPRY, 402) CLINE1
  420 IY=SCALEP*(XB(N2,I)-XMIN(N2))+OFFSET
      K = XB(4,I) + 0.5
      CALL KERI2C (K, CL, 3)
      IYE = IY + 1
      IF (K .GT. 99) IYE = IY + 2
      IF (K .LE.  9) IYE = IY
      ICL = 1 + IYE - IY
      IF (CLINE1(IY:IYE) .NE. ' ') GOTO 430
      CLINE1(IY:IYE) = CL(1:ICL)
      GOTO 460
  430 CLINE1(IY:IY) = '*'
  460 CONTINUE
      WRITE (IPRY, 402) CLINE1
      IF (NPROJ .GT. NNN) GOTO 500
      IF (NPROJ .GT. 0 .OR. NNN .GE. 2) GOTO 600
      NTEMP = 4-NNN
      IND1 = IND(NTEMP)
      IND2 = IND(NTEMP-1)
      IF (B(IND2,IND2) .GT. 2.0*B(IND1,IND1)) GOTO 600
  500 IF (NNN .EQ. 2) GOTO 540
      IF (N1 .EQ. 2) GOTO 560
      N2 = 3
      GOTO 210
  540 N2 = 2
      IF (N1 .EQ. 3) GOTO 210
  560 N1 = 3
      GOTO 200
  600 CONTINUE
      RETURN
      END
      SUBROUTINE SCHOUT (SCALAT, ZSCAL)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zsear.inc'
      PARAMETER (IP1=1)
      PARAMETER (IDUMAM=24*MAXAT+1)
      PARAMETER (IP160=160000, IPDUM=IP160-IP1-IDUMAM)
      COMMON /BLANK/ DUMMM(IP1), IFRAG(MAXAT), ISYM(MAXAT), IDUM(MAXAT),
     *               DUM(MAXAT), IBOND(MAXAT*10), JBOND(MAXAT*10), XGEO,
     *               DUMMY(IPDUM)
      DIMENSION LW(MAXAT)
      EQUIVALENCE (LW(1), IDUM(1))
      COMMON /SIZEX/ KFRAG(20), NFRAG, LFRAG(20), NOFRAG, NNA
      COMMON /DIRBFA/ NCELTY(10), NCELLZ(10), NCELIN(10), NCELIX(10)
      COMMON /DIRBFB/ ACELTY(10)
      CHARACTER ACELTY *2
      CHARACTER * 2   AQQQ
      EQUIVALENCE (IATOMS, IFILE(1)), (IDDL, IFILE(2))
      EQUIVALENCE (ISPEK, IFILE(4))
      EQUIVALENCE (IATOLD, IFILE(10))
      EQUIVALENCE (NTYPEZ, KEYS(4))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (KPROG, KSTAT(18))
      EQUIVALENCE (IMAP, KSTAT(7))
      LOGICAL NOFREE
      EQUIVALENCE (SWITCH(9), NOFREE)
      LOGICAL DMAXCH, SWRECY
      EQUIVALENCE (SWITCH(28), DMAXCH), (SWITCH(7), SWRECY)
      CHARACTER *6 CFRAG, RFAC6
      CHARACTER *12 CFRAGX
      CHARACTER *4 RFAC
      CHARACTER ZZZ *1
      LOGICAL SPEK
      SPEK = .TRUE.
      CALL WR24
      WRITE (8, FMT='(/'' ***** SCHOUT *****''/)')
      NRFAC = 0
      IF (IPRY.NE.0) WRITE (IPRY, 101)
  101 FORMAT (/ 1X,71('-')/)
      IF (SWRECY) CALL DDRECY
      CALL FILINQ (ISPEK,  'SPF',   'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ISPEK, 117) CCODE
  117 FORMAT ('TITL  : DIRDIF output for : ',A6)
      WRITE (ISPEK, 119) CELL
  119 FORMAT ('CELL  ',6F10.5)
      WRITE (ISPEK, 121) SPGR
  121 FORMAT ('SPGR  ',A16)
      IF (SPEK) WRITE(24, FMT='(/'' Output atomic parameter file '',
     *   A6, ''.spf  for PLUTON''/)') CCODER
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      REWIND IATOMS
      R2 = 9.99
      IF (R2X .GT. 0.0002) R2 = R2X
      IF (NRECY .GE. 1) SCALAT = SCALE
      WRITE (CHOUT, 7102) CCODE, KSTAT(13), NRECYR, R2, SCALAT
 7102 FORMAT ('ATOMS ', A6, ' < FOUR 0 ',
     *   ' RUN', I4, ' CY=', I3, ' R2X=', F6.3, '  SC=', F12.8 )
      WRITE (8, 7103) CHOUT
 7103 FORMAT (63X,'[321-121]'/' Output ATOMS:'/ 1X, A72/)
      IF (SCALAT .LE. 0.001) CHOUT(52:72) = ' '
      WRITE (IATOMS, FMT = '(A72)') CHOUT
      WRITE (IATOMS, 123) NRECYR
  123 FORMAT ('REMARK OUTPUT FOURIER CYCLE', I3, ' [ R2X = R2(input) ]')
       IF (NATREC .EQ. 0) NATREC = NAT
      NQQQ = 0
      AQQQ = ACELTY(NTYPEZ)
      IF (AQQQ .EQ. 'H') AQQQ = ACELTY(NTYPEZ-1)
      CALL GEOFOB (-1, 0, ZSCAL)
      IILWM = 1.0 + VOLUM / 17.
      CALL ATOMOC (0, ATXYZ, LW, NAT)
      IILW = 0
      DO 127 I = 1, NAT
      LW(I) = (NSYMM * NLATT) / LW(I)
      IILW = IILW + ATXYZ(4,I) * LW(I)
      IF (IILW .GT. IILWM .AND. I .LT. NAT) THEN
         WRITE (8, FMT='('' Limit NAT because at.vol. = 17 Ang3'')')
         GOTO 129
         ENDIF
  127 CONTINUE
      WIILW = VOLUM / FLOAT(IILW)
      WRITE(8,FMT='('' $TE NAT, Volume/atom:'',I4,F5.1)') NAT,WIILW
  129 II = 0
      IF (IPRY.NE.0) WRITE (IPRY, 3109)
 3109 FORMAT (/' Table 321   COORDINATES of atoms and (interpreted)',
     *  ' peaks'//
     *  ' N# name PKintegr PKheight    x',8X,'y',8X,'z',6X,'B', 4X,
     *     'cluster'/ 13X, 'x100  x100', 38X, 'number'/)
      DO 180 I=1, NAT
      IFRAG(I)=IABS(IFRAG(I))
      CALL KERI2C (IFRAG(I), CFRAG, 2)
      IF (IFRAG(I) .EQ. 0) CFRAG = '0 '
      N=MIN0(IFRAG(I)+1,11)
      CFRAGX = ' '
      CFRAGX(N:N+1) = CFRAG
      RFAC = ' '
      IF (ATXYZ(9,I) .LT. 0.0001) THEN
         WRITE(8, FMT = '('' occ. factor = 0: '', A6)') ATNAME(I)
      ELSE
         IRFAC = IMULT / NINT (ATXYZ(9,I))
         IF (IRFAC .GT. 1) THEN
            CALL KERI2C (IRFAC, RFAC6, 2)
            RFAC(2:4) = RFAC6
            RFAC(4:4) = 'R'
            IF (RFAC(3:3) .EQ. ' ') RFAC(3:3) = ':'
            NRFAC = NRFAC + 1
            ENDIF
         ENDIF
      K  = ATX4(4,I) **2 * ZSCAL
      KK = ATX4(4,I) * 10000.
      KK = KK - IFIX ( ATX4(4,I)) * 10000
      KK = ( FLOAT(KK) )**2 / 4000.
      IF (SWRECY .AND. I.LE.NATSN .AND. NRECYR.GE.3 .AND.
     *      IZAT(I).GE.5 .AND. IZAT(I).LE.9 .AND. K.LT.200) THEN
         IF (IPRY .GT. 0) WRITE (IPRY, FMT='('' Following weak atom '',
     *      A6, '' denoted Q !!!'')') ATNAME(I)
         IF (IPRY .EQ. 0) WRITE(24, FMT='('' Initial weak atom '',
     *      A6, '' rejected, i.e. denoted Q !!!'')') ATNAME(I)
         ATNAME(I)(1:1) = 'Q'
         ZZZ = ATNAME(I)(2:2)
         CALL KERC2I (ZZZ, LEND)
         IF ((LEND.LT.0).OR.(LEND.GT.9)) ATNAME(I)(2:2) = '0'
         IZAT(I) = 1
         NQQQ = NQQQ + 1
         ENDIF
      IF (I.GT.NATSN .AND. NRECYR.GE.3 .AND. I*100/95.GE.NAT .AND.
     *   ATNAME(I)(1:1) .EQ. 'Q' .AND. K.GT.111 .AND. NQQQ.GE.-2) THEN
         IF (IPRY .GT. 0) WRITE (IPRY, FMT=
     *      '('' Following tail (Q) atom accepted  !!!'')')
         ATNAME(I)(1:1) = AQQQ(1:1)
         IF (AQQQ(2:2) .NE. ' ') THEN
            RFAC6 = ATNAME(I)
            ATNAME(I)(1:2) = AQQQ
            ATNAME(I)(3:6) = RFAC6(2:6)
            ENDIF
         IZAT(I) = NCELLZ(NTYPEZ)
         IF (IZAT(I) .EQ. 1) IZAT(I) = NCELLZ(NTYPEZ-1)
         NQQQ = NQQQ - 1
         ENDIF
      IF (I.LE.NATSN .AND. ATXYZ(5,I).LT.0.0001) ATXYZ(5,I) = BP
      IF (I.GT.NATSN .AND. ATXYZ(5,I).LT.0.0001) ATXYZ(5,I) = BR
      IF (I.GT.NATSN .AND. ATNAME(I)(1:1).EQ.'Q' .AND. K.LT.99) GOTO 136
      IF (K .LT. 1) GOTO 136
      IF (II .GE. NATREC) THEN
         ATNAME(I)(1:1) = 'Q'
         ZZZ = ATNAME(I)(2:2)
         CALL KERC2I (ZZZ, LEND)
         IF ((LEND.LT.0).OR.(LEND.GT.9)) ATNAME(I)(2:6) = ATNAME(I)(3:6)
         IZAT(I) = 1
         ENDIF
  136 IF (IPRY.NE.0) THEN
         WRITE (IPRY, 137) I,ATNAME(I),K,KK, RFAC,(ATX4(J,I),J=1,3),
     *      ATXYZ(5,I), CFRAGX
  137    FORMAT (I4, 1X, A6, 2I6, A4, 3F9.5, F5.2, 1X, A12)
         IF (K .LT. 100 .AND. I .GT. NATSN) WRITE (IPRY, FMT=
     *       '(8X, A6, '' <---- not output ----'')') ATNAME(I)
         ENDIF
      IF (K .LT. 1) GOTO 180
      IF (K .GT. 100 .OR. I .LE. NATSN) THEN
         IF (IMAP .EQ. 1) ATXYZ(5,I) = 0.0
         WRITE (IATOMS, 173)
     *      ATNAME(I), (ATX4(J,I),J=1,3), (ATXYZ(J,I),J=4,5), K, CFRAG
  173    FORMAT ('ATOM   ', A6, 5F9.5, 3X, I6, '$', A6)
         IF (SPEK) WRITE (ISPEK, 174) ATNAME(I), (ATXYZ(J,I),J=1,3)
  174    FORMAT (A6,2X,3F10.5)
         IF (ATNAME(I)(1:1).NE.'Q') THEN
            II = II + 1
            IF (IPRY.NE.0 .AND. SWRECY .AND. II.EQ.NATREC) WRITE (IPRY,
     *         FMT='('' Following peaks not output for recycling'')')
            ENDIF
         ENDIF
  180 CONTINUE
      WRITE (IATOMS, FMT = '(''END'')')
      CALL COPY80 (IATOMS, 'ATOMS', 10, 'ATTEM')
      CALL FILCLO (IATOMS, 'KEEP')
      IF (SPEK) CALL FILCLO (ISPEK, 'KEEP')
      IF (NRFAC .GT. 0 .AND. IPRY.NE.0) WRITE (IPRY, 236) NRFAC
  236 FORMAT (/ ' :R =', ' symmetry reduction factor for',
     *         I3, ' atoms at special positions ')
      NATSN = NATSN - KEYS(24)
      IF (NATSN.NE.NATS) THEN
         WRITE (CHOUT,FMT='(''RUN '',I3,'' NEW   NAT= '',I4,
     *       '' KPROG '', I3)') IRUN, NATSN, KPROG
         CALL LOGWR (IDDL)
         CALL FILCLO (IDDL, 'KEEP')
         ENDIF
      NATS = NATSN
      IF (SWRECY) THEN
         NATREC = II
         WRITE(24, 242) NATREC
  242    FORMAT (' Number of atoms output  for Fourier recycling :',I4)
         ENDIF
      IF (NNA .LE. 0) GOTO 1900
      IF (NNA .GT. 1) CALL ISORT (ISYM, NNA)
      ISYM(NNA + 1) = 0
      JJ=0
      K=0
      DO 1890 I = 1, NNA
      II=ISYM(I)/250000
      IF (IPRY.NE.0 .AND. II.NE.JJ) WRITE (IPRY, 1860) II
 1860 FORMAT (/' Cluster', I3, '  joins to itself through the peak',
     *          'pairs)')
      JJ=II
      K=K+2
      LW(K-1)=MOD(ISYM(I),250000)/500
      LW(K)=MOD(ISYM(I),500)
      IF (K .GT. 2) THEN
         IF (LW(K) .EQ. LW(K-2)) K = K - 2
         ENDIF
      IF (K.LT.12.AND.II.EQ.ISYM(I+1)/250000) GOTO 1890
      IF (IPRY.NE.0) WRITE (IPRY, 1870) (LW(J),J=1,K)
 1870 FORMAT (1X, 6(I7,',',I3))
      K=0
 1890 CONTINUE
 1900 RETURN
      END
      SUBROUTINE DDRECY
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL SWRECY
      EQUIVALENCE   (SWITCH(7),SWRECY)
      EQUIVALENCE (IHELP, IFILE(10))
      EQUIVALENCE (NTYPEZ, KEYS(4))
      INCLUDE 'Zatomx.inc'
      PARAMETER (IP1=1)
      PARAMETER (IDUMAM=24*MAXAT+1)
      PARAMETER (IP160=160000, IPDUM=IP160-IP1-IDUMAM)
      COMMON /BLANK/ DUMMM(IP1), IFRAG(MAXAT), ISYM(MAXAT), IDUM(MAXAT),
     *               DUM(MAXAT), IBOND(MAXAT*10), JBOND(MAXAT*10), XGEO,
     *               DUMMY(IPDUM)
      INCLUDE 'Zsear.inc'
      COMMON /DIRBFA/ NCELTY(10), NCELLZ(10), NCELIN(10), NCELIX(10)
      COMMON /DIRBFB/ ACELTY(10)
      CHARACTER ACELTY *2
      CHARACTER CAT *2
      CHARACTER*4 ATNAM
      LOGICAL FIRST
      CHARACTER ZZZ *1
      DATA JZAT / 1 /
      DATA NCALL / 0 /
      NCALL = NCALL + 1
      FIRST = .FALSE.
      CALL WR24
      IF (NRECYR.LE.1 .OR. (NRECYR.EQ.2 .AND. NATREC-NATSN .GT. 30))
     *   FIRST = .TRUE.
      IF (NRECYR .LE. 1 .AND. NCALL .EQ. 1) WRITE(24, 101)
  101 FORMAT (' NOTE about the RECYCLING procedure with PHASEX and',
     * ' FOUR.'/ ' Usually, the R2 driven dual space',
     * ' recycling strategy, with'/' atom clean-up based upon expected',
     * ' peak heights and molecular geometry,'/
     * ' leads to completeness of the structure in 10 - 20 cycles.'/
     * ' If almost correct, you may rename atoms and reconsider the'/
     * ' unit cell contents, and continue with:  DIRDIF CCODE FOUR'/)
      NCAT = NTYPEZ
      IF (ACELTY(NCAT) .EQ. 'H' .AND. NCAT .GT. 1) NCAT = NCAT - 1
      IF (NCELLZ(NCAT) .GT. 6) RETURN
      CAT = ACELTY(NCAT)
      IRESET = 0
      IF (.NOT. FIRST) GOTO 500
      DO 300 I = NATSN + 1, NATREC
      IF (IRESET .GT. 0) GOTO 250
      IF (IZAT(I) .GT. 18) GOTO 300
      IF (IZAT(I) .LE. 14) GOTO 300
      IF (ATXYZ(8,I) .GT. 0.5 * FLOAT(IZAT(I)) ) GOTO 300
      IRESET = I
      WRITE (8, FMT='('' $TEMP .... P .. S .. CL  low peak >?'')')
  250 IZAT(I) = NCELLZ(NCAT)
      ZZZ = ATNAME(I)(2:2)
      CALL KERC2I (ZZZ, KEND)
      ATNAM = ATNAME(I) (2:5)
      IF (KEND .GE. 10) ATNAM = ATNAME(I) (3:6)
      ATNAME(I) (1:2) = CAT
      ATNAME(I) (3:6) = ATNAM
      IF (ATNAME(I) (2:2) .EQ. ' ') ATNAME(I) (2:6) = ATNAM
      CALL ATN24X (ATNAME(I), ATNAME, NATREC, ATNAME(I))
  300 CONTINUE
  400 IF (IPRY.NE.0 .AND. IRESET .GT. 0)
     *  WRITE (IPRY, 402) IRESET, CAT
  402 FORMAT (/' Note about the recycling strategy:'/
     *        /' Starting from peak number' , I3,
     *  ' all peaks have been named ', A2/)
      RETURN
  500 NPK = 0
      PK = 0.
      DO 510 I = NATSN + 1, NATREC
      IF (IZAT(I) .GT. 10 .OR. IZAT(I) .LE. 1) GOTO 510
      NPK = NPK + 1
      PK = PK + ATXYZ(8,I)
      IF (NPK .GT. 1) GOTO 510
      JZAT = IZAT(I)
      CAT = ATNAME(I) (1:2)
      ZZZ = ATNAME(I)(2:2)
      CALL KERC2I (ZZZ, KEND)
      IF (KEND .LE. 10 .OR. KEND .GE. 37) CAT(2:2) = ' '
  510 CONTINUE
      IF (NPK .LE. 4) RETURN
      PK = PK / FLOAT(NPK)
      DO 600 I = NATSN + 1, NATREC
      IF (IZAT(I) .GT. 18 .OR. IZAT(I) .LT. 10) GOTO 600
      IF (ATXYZ(8,I) .GT. 1.5 * PK) GOTO 600
      IF (IRESET .EQ. 0) IRESET = I
      IZAT(I) = JZAT
      ZZZ = ATNAME(I)(2:2)
      CALL KERC2I (ZZZ, KEND)
      ATNAM = ATNAME(I) (2:5)
      IF (KEND .GE. 10) ATNAM = ATNAME(I) (3:6)
      ATNAME(I) (1:2) = CAT
      ATNAME(I) (3:6) = ATNAM
      IF (ATNAME(I) (2:2) .EQ. ' ') ATNAME(I) (2:6) = ATNAM
  600 CONTINUE
      GOTO 400
      END
      SUBROUTINE ISORT (N, M)
      DIMENSION N(M)
      INT=2
 1000 INT=INT+INT
      IF (INT.LT.M) GOTO 1000
      INT=MIN0(M,(3*INT)/4-1)
 1020 INT=INT/2
      IFIN=M-INT
      DO 1200 II=1,IFIN
      I=II
      J=I+INT
      IF (N(I).LE.N(J)) GOTO 1200
      IT=N(J)
 1080 N(J)=N(I)
      J=I
      I=I-INT
      IF (I.LE.0) GOTO 1090
      IF (N(I).GT.IT) GOTO 1080
 1090 CONTINUE
      N(J)=IT
 1200 CONTINUE
      IF (INT.NE.1) GOTO 1020
      RETURN
      END
      FUNCTION JSYMM(I,J,K,IB,XS,X1)
      DIMENSION IB(3),XS(3),X1(3)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zsear.inc'
      DIMENSION DXYZM(3)
      LOGICAL CONT
      DATA CONT / .FALSE. /
      IF (CONT) GOTO 111
      CONT = .TRUE.
      DM = AMAX1 (2.8, DMAXB)
      DO 101 L = 1, 3
  101 DXYZM(L) = DM * RCELL(L)
  111 JSYMM = 0
      CALL OPER1 (K, XS, ATX4(1,J))
      DO 1080 L=1,3
      IB(L)=5
 1060 X1(L)=ATX4(L,I)-XS(L)
      IF (ABS(X1(L)).LE.0.5)GOTO 1070
      XS(L)=XS(L)+SIGN(1.0,X1(L))
      IB(L)=IB(L)+ISIGN(1,IFIX(2.0*X1(L)))
      GOTO 1060
 1070 IF (ABS(X1(L)) .GT. DXYZM(L)) GOTO 1100
 1080 CONTINUE
      RETURN
 1100 JSYMM = 1
      RETURN
      END
      SUBROUTINE EIGEN (B, V, IND)
      DIMENSION B(3,3),V(3,3),IND(3)
      DATA ZERO / 1.0E-12 /
      DO 1020 I=1,3
      DO 1000 J=1,3
      V(I,J)=0.0
 1000 CONTINUE
      V(I,I)=1.0
 1020 CONTINUE
      NNN = 17
 1040 KNT=0
      NNN = NNN - 1
      IND1=1
      IND3=1
      DO 1500 I=1,2
      IP1=I+1
      DO 1460 J=IP1,3
      IF (ABS(B(I,J)) .LT. 0.000001 * B(IND1,IND1)) KNT = KNT + 1
      BIJ=B(I,I)-B(J,J)
      IF (ABS(B(I,J)).LT.ABS(BIJ))GOTO 1100
      IF (ABS(BIJ).LT.ZERO) THEN
         BIJ = 0.0
         T = 1.
      ELSE
         T=SIGN(1.0,B(I,J)*BIJ)
         ENDIF
      GOTO 1180
 1100 CONTINUE
      T=B(I,J)/BIJ
 1180 CONTINUE
      IF (ABS(T) .GT. 1.E-6) THEN
         G=T/(2.0+2.0*T*T)
         SN=2.0*G/(1.0+G*G)
         CS=1.0-G*SN
      ELSE
         SN = 0.
         CS = 1.
         ENDIF
      DO 1200 K=1,3
      BIK=B(I,K)
      B(I,K)=CS*B(I,K)+SN*B(J,K)
      B(J,K)=CS*B(J,K)-SN*BIK
 1200 CONTINUE
      DO 1220 K=1,3
      BKI=B(K,I)
      B(K,I)=CS*B(K,I)+SN*B(K,J)
      B(K,J)=CS*B(K,J)-SN*BKI
      VKI=V(K,I)
      V(K,I)=CS*V(K,I)+SN*V(K,J)
      V(K,J)=CS*V(K,J)-SN*VKI
 1220 CONTINUE
 1460 CONTINUE
      IF (B(IP1,IP1).GT.B(IND1,IND1))IND1=IP1
      IF (B(IND3,IND3).GT.B(IP1,IP1))IND3=IP1
 1500 CONTINUE
      IF (KNT.LT.3 .AND. NNN.GT.0) GOTO 1040
      IND(1)=IND1
      IND(2)=1
      IND(3)=IND3
      IF (IND1.EQ.IND(2).OR.IND3.EQ.IND(2))IND(2)=2
      IF (IND1.EQ.IND(2).OR.IND3.EQ.IND(2))IND(2)=3
      DET = V(1,1)*(V(2,2)*V(3,3)-V(2,3)*V(3,2))+V(1,2)*(V(2,3)*V(3,1)
     1  -V(2,1)*V(3,3))+V(1,3)*(V(2,1)*V(3,2)-V(2,2)*V(3,1))
      IF (DET .GT. 0.0) RETURN
      DO 1520 I=1,3
      V(I,3) = -V(I,3)
 1520 CONTINUE
      RETURN
      END
      SUBROUTINE PP1
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IFMAP, IFILE(17)), (ISCRA, IFILE(18))
      EQUIVALENCE (KEYS(28), IHALF)
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      EQUIVALENCE (IMAP, KSTAT(7))
      PARAMETER (KUSER2=30000, LUSER2=15000)
      COMMON /BLANK/ X(KUSER2), DUMMY(130000)
      COMPLEX YCOM(LUSER2)
      EQUIVALENCE (X(1), YCOM(1))
      INTEGER  P1, P2, R, SKIP, RECS,  D(5)
      DATA NCALL /0/
      NCALL = NCALL + 1
      NSIZE = KUSER2 - 1
      NX = NPP(1)
      NY = NPP(2)
      NZ = NPP(3)
      RECMAX = 32000.
      MAXSIZ = IFIX ( SQRT (RECMAX * 0.25 * FLOAT (NX*NY*NZ)) )
      NSIZE  = MIN0 (NSIZE, MAXSIZ)
      P1 = NSIZE / (2*NY*(MH(3) + 1))
      P2 = NSIZE / (NX*NZ)
      MPASS = MAX0 (1, NX / MAX0 (1, P1) )
      NBYTES = P1 * P2 * (MH(3)+1) * 8 + 8
      IF (NCALL .GE. 3) GOTO 103
      WRITE (8, 101) NBYTES
  101 FORMAT (' Scratch file has max.', I6, ' bytes per record')
      IF (NRECYR .LE. 1 .AND. MPASS .GT. 2) WRITE (24, 102) MPASS
  102 FORMAT (' Appr. nr of intermediate Fourier-transform passes:', I3)
      MPASS = MPASS / MAX0 (1, MPASS/4)
  103 CONTINUE
      NPASS = 0
      NEX = -1
      REWIND ISCRA
      R = -MH(1)
  111 CONTINUE
      IF (R+P1 .GT. MH(1)) P1 = MH(1) + 1 - R
      CALL RDHKL (NEX, YCOM, NY, MH(3)+1, P1, R)
      D(1) = 2*(NY*P1*(MH(3)+1))
      D(2) = 2
      D(3) = D(1)
      D(4) = D(1)
      D(5) = 2*NY
      CALL CMPLFT (X(1), X(2), NSIZE, NY, D)
      CALL WRITEY (YCOM, NY, MH(3)+1, P1, P2, ISCRA)
      NPASS = NPASS + 1
      IF (MPASS .GT. 1 .AND. NRECYR .LE. 1 .AND.
     *   MOD (NPASS, MPASS) .EQ. 0 .AND. NCALL .LE. 2)
     *   WRITE (24, FMT=
     *   '(1X/'' Intermediate Fourier transform,  pass'', I2)') NPASS
      CALL WR24
      R = R + P1
      IF (R .LE. MH(1)) GOTO 111
      IF (IMAP.EQ.5) THEN
         SCALEW = 500.0 / SCALEW
      ELSE
         SCALEW = 3000.0 / SCALEW
         ENDIF
      SCALOR = SCALEW
      REWIND IFMAP
      NYNEW = NY
      WRITE (IFMAP) SCALOR, IMAP, IHALF
      IF (IHALF.NE.0) NYNEW = MIN0 (NY-NY/2+3, NY)
      WRITE (IFMAP) NX,NZ,NYNEW,NY
      REWIND ISCRA
      SKIP = 0
      R = 0
      P1 = NSIZE / (2*NY*(MH(3) + 1))
      RECS = (NY - 1)/P2
      NPASS = 0
  200 IF (R+P2 .GT. NY) P2 = NY - R
      CALL READHL (YCOM, NX,NZ/2, P2,MH(1),MH(3),P1,SKIP,RECS,ISCRA)
      IF (R + P2 .LT. NY) REWIND ISCRA
      SKIP = SKIP + 1
      D(1) = NX * NZ * P2
      D(2) = NZ
      D(3) = NZ * NX
      D(4) = 2 * (MH(3) + 1)
      D(5) = 2
      CALL CMPLFT (X(1), X(2), NSIZE, NX, D)
      D(2) = 2
      D(3) = D(1)
      D(4) = D(1)
      D(5) = NZ
      CALL HERMFT (X(1), X(2), NSIZE, NZ/2, D)
      CALL OUTPUT (X, NZ, NX, P2, R, NY)
      NPASS = NPASS + 1
      IF (MPASS .GT. 1 .AND. NRECYR .LE. 1 .AND.
     *   MOD (NPASS, MPASS) .EQ. 0 .AND. NCALL .LE. 2)
     *   WRITE (24, FMT=
     *   '(16X, ''  Final transform,  pass'', I2)') NPASS
      CALL WR24
      R = R + P2
      IF (R .LT. NY) GOTO 200
      CALL FILCLO (ISCRA, 'DELETE')
      RETURN
      END
      SUBROUTINE RDHKL (NEX, X, NY, NZ, NX, HS)
      INTEGER HS
      COMPLEX X(NY,NZ,NX)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (IMAP, KSTAT(7))
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      EQUIVALENCE (FITFFT(4),EI), (FITFFT(5),PHI)
      INTEGER H, HM, HL
      DIMENSION IHKLX(3,24), PHX(24), NSYMEX(24), GRI(2,24), TAB(15)
      DIMENSION IHKLI(3), ITSYMM(3,24), NRCO(5)
      D2R = ATAN(1.0) / 45.0
      CALL WR24
      IF (NEX .GE. 0) GOTO 210
      NEX = 0
      NPASS = 0
      SCALEW = 0.0
      CALL KERNZI (0, NRCO, 5)
      DO 110 I=1,15
  110 TAB(I) = SIN (FLOAT(30*I) * D2R)
      DO 113 J=1,NSYMM
      DO 113 I=1,3
  113 ITSYMM(I,J) = NINT (TSYMM(I,J) * 12.0)
  210 CONTINUE
      CALL BINIFF (1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, NEND)
      NPASS = NPASS + 1
      HM = HS + NX - 1
      HL = HS
      IDISC = HL * HM
      IHMAX = MAX0 (IABS(HL), IABS(HM))
      IHMIN = MIN0 (IABS(HL), IABS(HM))
      DO 220 H=1,NX
      DO 220 L=1,NZ
      DO 220 K=1,NY
  220 X(K,L,H) = CMPLX(0.0,0.0)
  320 CALL BINIFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, NEND)
      IF (NEND.LT.0) GOTO 500
      IF (NPASS .GT. 1) GOTO 330
      NRCO(1) = NRCO(1) + 1
      IF (EI .LT. 0.0) THEN
         NRCO(2) = NRCO(2) + 1
         GOTO 320
         ENDIF
  330 CALL KERF2I(FITFFT, IHKLI, 3)
      IF (ISYST.GT.4 .AND. ISYST.LT.8) GOTO 360
      INMAX = MAX0 (IABS(IHKLI(1)), IABS(IHKLI(2)), IABS(IHKLI(3)))
      INMIN = MIN0 (IABS(IHKLI(1)), IABS(IHKLI(2)), IABS(IHKLI(3)))
      IF (IDISC.LT.0) GOTO 360
      IF (INMIN.GT.IHMAX .OR. INMAX.LT.IHMIN) GOTO 320
  360 CALL FEXPAN (IHKLI, IHKLX, PHX, NSYMEX, NEXP)
      PHI = PHI * D2R
      EC  = EI * COS(PHI)
      ES  = EI * SIN(PHI)
      DO 380 J=1,NEXP
      H = IHKLX(1,J)
      IF (H.GT.HM .OR. H.LT.HL) GOTO 380
      IF (IABS(H) .GE. NPP(1)/2 .OR. IABS(H) .GT. MH(1)) THEN
         NRCO(3) = NRCO(3) + 1
         GOTO 380
         ENDIF
      K = IHKLX(2,J)
      IF (IABS(K) .GE. NPP(2)/2 .OR. IABS(K) .GT. MH(2)) THEN
         NRCO(4) = NRCO(4) + 1
         GOTO 380
         ENDIF
      L = IHKLX(3,J)
      IF (IABS(L) .GE. NPP(3)/2 .OR. IABS(L) .GT. MH(3)) THEN
         NRCO(5) = NRCO(5) + 1
         GOTO 380
         ENDIF
      NU = 0
      IF (IMAP.LE.0 .OR. IMAP.EQ.2 .OR. IMAP.GE.5) GOTO 370
      NSYMX = NSYMEX(J)
      NU = - IHKLI(1)*ITSYMM(1,NSYMX) - IHKLI(2)*ITSYMM(2,NSYMX)
     *     - IHKLI(3)*ITSYMM(3,NSYMX)
      NU = MOD(NU,12)
  370 IF (NU.LE.0) NU = NU + 12
      XS = TAB(NU)
      XC = TAB(NU+3)
      GRI(1,J) =  XC*EC - XS*ES
      GRI(2,J) = (XS*EC + XC*ES) * PHX(J)
      NEX = NEX + 1
      SCALEW = SCALEW + SQRT(GRI(1,J)*GRI(1,J)+GRI(2,J)*GRI(2,J))
      NOKO = 0
      IF (H.EQ.0 .AND. L.EQ.0 .AND. K.NE.0) NOKO = NY - K + 1
      H = H - HS + 1
      IF (K.LT.0) K = NY + K
      K = K + 1
      L = L + 1
      X(K,L,H) = CMPLX(GRI(1,J),GRI(2,J))
      IF (NOKO.NE.0) X(NOKO,L,H) = CONJG(X(K,L,H))
  380 CONTINUE
      GOTO 320
  500 CONTINUE
      IF (NX + HS .LE. MH(1)) RETURN
      CALL FILCLO (IBINFF, 'DELETE')
      WRITE (8, 631) NPASS
  631 FORMAT (' Intermediate transforms required ', I3, ' passes')
      WRITE (8, 690) NRCO(1)
  690 FORMAT (' Number of reflections from input file   =',I7)
      IF (NRCO(2) .GT. 0) WRITE (8, 691) NRCO(2)
  691 FORMAT (' of which',I7,' were rejected'/)
      WRITE (8, 692) NEX
  692 FORMAT (' Number of reflections in one hemisphere =',I7)
      IF (NEX .EQ. 0) CALL KERROR ('No reflections found', 0,'RDHKL')
      IF (NRCO(3).GT.0 .OR. NRCO(4).GT.0 .OR. NRCO(5).GT.0)
     *    WRITE (8, 693)
  693 FORMAT (' not included in calculations, because: '/)
      IF (NRCO(3).GT.0) WRITE (8, 694) MH(1), NRCO(3)
  694 FORMAT (8X,' having H greater than ',I3,'  were ',I6/)
      IF (NRCO(4).GT.0) WRITE (8, 695) MH(2), NRCO(4)
  695 FORMAT (8X,' having K greater than ',I3,'  were ',I6/)
      IF (NRCO(5).GT.0) WRITE (8, 696) MH(3), NRCO(5)
  696 FORMAT (8X,' having L greater than ',I3,'  were ',I6/)
      RETURN
      END
      SUBROUTINE FEXPAN (IHKLI, IHKLX, PHX, NSYMEX, NEXP)
      DIMENSION IHKLI(3), IHKLX(3,24), PHX(24), NSYMEX(24)
      INCLUDE 'Zcrys.inc'
      DIMENSION IHKLS(3)
      NEXP = 0
      DO 3900 J=1,NSYMM
      CALL VXMATI (IHKLI, IRSYMM(1,1,J), IHKLS)
      B1 = 1.0
      IF (IHKLS(3)) 1590, 1570, 1600
 1570 IF (IHKLS(1)) 1590, 1580, 1600
 1580 IF (IHKLS(2)) 1590, 1600, 1600
 1590 B1 = -1.0
      DO 3610 I=1,3
 3610 IHKLS(I) = -IHKLS(I)
 1600 CONTINUE
      IF (J.EQ.1) GOTO 1630
      DO 3620 JJ=1, NEXP
      IF (IHKLX(1,JJ) .EQ. IHKLS(1) .AND. IHKLX(2,JJ) .EQ. IHKLS(2)
     *   .AND. IHKLX(3,JJ) .EQ. IHKLS(3)) GOTO 3900
 3620 CONTINUE
 1630 NEXP = NEXP + 1
      CALL KERNAI (IHKLS, IHKLX(1, NEXP), 3)
      PHX(NEXP) = B1
      NSYMEX(NEXP) = J
 3900 CONTINUE
      RETURN
      END
      SUBROUTINE WRITEY (X, NY, NZ, NX, SIZE, ISCRA)
      COMPLEX X(NY,NZ,NX)
      INTEGER SIZE, H, P, Q, R
      P = SIZE
      Q = 0
  100 R = Q + 1
      IF (Q+P .GT. NY) P = NY - Q
      Q = Q + P
      WRITE (ISCRA) (((X(K,L,H), H=1,NX), K=R,Q), L=1,NZ)
      IF (Q .LT. NY) GOTO 100
      RETURN
      END
      SUBROUTINE READHL (X,NX,NZ,NY,HMAX,LMAX,SIZE,SKIP,RECS,ISCRA)
      INTEGER HMAX, SIZE, SKIP ,RECS, H, HL, HU, P, Q
      COMPLEX X(NZ,NX,NY)
      LM = LMAX + 1
      P = SIZE
      HU = NX - HMAX
      IF (SKIP .LE. 0) GOTO 200
      DO 100 Q=1,SKIP
      READ (ISCRA)
  100 CONTINUE
  200 IF (HU + P .GT. NX) GOTO 400
      HL = HU + 1
      HU = HU + P
      READ (ISCRA) (((X(L,H,K), H=HL,HU), K=1,NY), L=1,LM)
      IF (RECS .LE. 0) GOTO 200
      DO 300 Q=1,RECS
      READ (ISCRA)
  300 CONTINUE
      GOTO 200
  400 IF (HU .NE. NX) GOTO 700
      HU = 0
  500 IF (HU+P .GT. HMAX+1) P = HMAX + 1 - HU
      HL = HU + 1
      HU = HU + P
      READ (ISCRA) (((X(L,H,K), H=HL,HU), K=1,NY), L=1,LM)
  550 IF (HU .EQ. HMAX + 1) GOTO 800
      IF (RECS .LE. 0) GOTO 500
      DO 600 Q=1,RECS
      READ (ISCRA)
  600 CONTINUE
      GOTO 500
  700 HL = HU + 1
      HU = HU + P - NX
      IF (HU .GT. HMAX+1) HU = HMAX + 1
      READ (ISCRA) (((X(L,H,K), H=HL,NX), (X(L,H,K), H=1,HU),
     *   K=1,NY), L=1,LM)
      GOTO 550
  800 DO 900 H=2,HU
      HL = NX + 2 - H
      DO 900 K=1,NY
      X(1,HL,K) = CONJG(X(1,H,K))
  900 CONTINUE
      HL = HMAX + 2
      HU = NX - HMAX
      IF (HU .LT. HL) GOTO 920
      DO 910 L=1,LM
      DO 910 K=1,NY
      DO 910 H=HL,HU
      X(L,H,K) = CMPLX(0.0,0.0)
  910 CONTINUE
  920 IF (LM .GE. NZ) GOTO 940
      P = LM + 1
      DO 930 K=1,NY
      DO 930 L=P,NZ
      DO 930 H=1,NX
      X(L,H,K) = CMPLX(0.0,0.0)
  930 CONTINUE
  940 RETURN
      END
      SUBROUTINE OUTPUT (X, NZ, NX, NY, Y, NYT)
      REAL X(NZ,NX,NY)
      INTEGER Y
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IFMAP, IFILE(17))
      EQUIVALENCE (KEYS(28), IHALF)
      LOGICAL PRIMAP
      EQUIVALENCE (PRIMAP, SWITCH(11))
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      INTEGER SEC, XL, XU
      INTEGER*2 INUT(250)
      DIMENSION LINE(50)
      DATA NCOL /36/
      CALL WR24
      IF (IHALF.NE.0)THEN
         NSECO = MIN0 (NYT-NYT/2+2, NYT)
         XLMAX(2) = AMIN1 (XLMAX(2), 0.5)
      ELSE
         NSECO = NYT
         ENDIF
      NXM = MIN0 (NX,  INT(XLMAX(1)*FLOAT(NX)) +1)
      NYM = MIN0 (NYT, INT(XLMAX(2)*FLOAT(NYT))+1)
      NZM = MIN0 (NZ,  INT(XLMAX(3)*FLOAT(NZ)) +1)
      ASC = 1000.0 / FLOAT(NX)
      DO 900 K=1,NY
      SEC = Y + K - 1
      NRSEC = SEC + 1
      DO 350 J=1,NZ
      DO 330 I=1,NX
      X(J,I,K) = X(J,I,K) * SCALEW
      INUT4 = MIN0 (NINT (X(J,I,K)), 32767)
      INUT4 = MAX0 (INUT4, -32767)
  330 INUT(I) = INUT4
      IF (NRSEC.LE.NSECO) WRITE (IFMAP) SEC, J, NX, (INUT(I),I=1,NX)
      IF (NRSEC.EQ.NYT .AND. IHALF.NE.0)
     +WRITE (IFMAP) SEC, J, NX, (INUT(I),I=1,NX)
  350 CONTINUE
      IF (.NOT. PRIMAP) GOTO 900
      XU = 0
  450 XL = XU + 1
      XU = XU + NCOL
      IF (XU.GT.NXM) XU = NXM
      DO 460 L=XL,XU
      INUT(L) = FLOAT((L-1))*ASC + 0.5
  460 CONTINUE
      NEC = 1000.*(FLOAT(SEC))/(FLOAT(NYT)) + 0.5
      WRITE (8, 480) NEC
  480 FORMAT ('1SECTION  Y = ', I4 /)
      WRITE (8, 500) (INUT(NN), NN=XL,XU,2)
  500 FORMAT (8X,'X =',I4,17I6)
      ILIM = XL + 1
      WRITE (8, 520) (INUT(NN), NN=ILIM,XU,2)
  520 FORMAT (12X,18I6)
      WRITE (8, 530)
  530 FORMAT ('0')
      DO 700 I=1,NZM
      LINE(1) = FLOAT((I-1))*1000./FLOAT(NZ) + 0.5
      L = 1
      DO 600 J=XL,XU
      L = L + 1
      LINE(L) = NINT (0.1 * X(I,J,K))
      IF (LINE(L) .LT. -99) LINE(L) = -99
  600 CONTINUE
      WRITE (8, 630) (LINE(J), J=1,L)
  630 FORMAT (' Z =',I4,' *  ',36I3)
  700 CONTINUE
      IF (XU.LT.NXM)GOTO 450
      IF (SEC.GE.NYM) PRIMAP = .FALSE.
  900 CONTINUE
      RETURN
      END
      SUBROUTINE CMPLFT (X, Y, NSIZE, N, D)
      REAL X(NSIZE), Y(NSIZE)
      INTEGER D(5),PMAX,PSYM,TWOGRP,FACTOR(15),SYM(15),UNSYM(15)
      PMAX   = 5
      TWOGRP = 4
      CALL SRFP (N, PMAX, TWOGRP, FACTOR, SYM, PSYM, UNSYM)
      CALL MDFTKD (N, FACTOR, D, X, Y, NSIZE)
      CALL DIPRP (N, SYM, PSYM, UNSYM, D, X, Y, NSIZE)
      RETURN
      END
      SUBROUTINE SRFP (PTS,PMAX,TWOGRP,FACTOR,SYM,PSYM,UNSYM)
      INTEGER PTS,PMAX,TWOGRP,PSYM, FACTOR(15), SYM(15), UNSYM(15)
      INTEGER PP(14), QQ(7), F, P, PTWO, Q, R
      N = PTS
      PSYM = 1
      F = 2
      P = 0
      Q = 0
  100 IF (N.LE.1) GOTO 500
      DO 200 J=F,PMAX
      IF (N.EQ.(N/J)*J) GOTO 300
  200 CONTINUE
      CALL KERNER (200, 'SRFP')
  300 F = J
      N = N / F
      IF (N.EQ.(N/F)*F) GOTO 400
      Q = Q + 1
      QQ(Q) = F
      GOTO 100
  400 N = N / F
      P = P + 1
      PP(P) = F
      PSYM = PSYM * F
      GOTO 100
  500 R = 1
      IF (Q.EQ.0) R = 0
      IF (P.LT.1) GOTO 700
      DO 600 J=1,P
      JJ = P + 1 - J
      SYM(J) = PP(JJ)
      FACTOR(J) = PP(JJ)
      JJ = P + Q + J
      FACTOR(JJ) = PP(J)
      JJ = P + R + J
      SYM(JJ) = PP(J)
  600 CONTINUE
  700 IF (Q.LT.1) GOTO 900
      DO 800 J=1,Q
      JJ = P + J
      UNSYM(J) = QQ(J)
      FACTOR(JJ) = QQ(J)
  800 CONTINUE
      SYM(P+1) = PTS / PSYM**2
  900 JJ = 2*P + Q
      FACTOR(JJ+1) = 0
      PTWO = 1
      J = 0
 1000 J = J + 1
      IF (FACTOR(J).EQ.0) GOTO 1200
      IF (FACTOR(J).NE.2) GOTO 1000
      PTWO = PTWO * 2
      FACTOR(J) = 1
      IF (PTWO .GE. TWOGRP) GOTO 1100
      IF (FACTOR(J+1).EQ.2) GOTO 1000
 1100 FACTOR(J) = PTWO
      PTWO = 1
      GOTO 1000
 1200 IF (P.EQ.0) R = 0
      JJ = 2*P + R
      SYM(JJ+1) = 0
      IF (Q.LE.1) Q = 0
      UNSYM(Q+1) = 0
      RETURN
      END
      SUBROUTINE DIPRP (PTS, SYM, PSYM, UNSYM, DIM, X, Y, NSIZE)
      REAL X(NSIZE), Y(NSIZE)
      INTEGER SYM(15), UNSYM(15), DIM(5), PTS, PSYM, DK, PUNSYM, TEST
      LOGICAL ONEMOD
      INTEGER SEP, DELTA, P, P0, P1, P2, P3, P4, P5, SIZE
      INTEGER V(14), MODULO(14), S(14), U(14)
      DATA MODS / 0 /
      NEST = 14
      NT = DIM(1)
      SEP = DIM(2)
      P2 = DIM(3)
      SIZE = DIM(4) - 1
      P4 = DIM(5)
      IF (SYM(1).EQ.0) GOTO 500
      DO 100 J=1,NEST
      U(J) = 1
      S(J) = 1
  100 CONTINUE
      N = PTS
      DO 200 J=1,NEST
      IF (SYM(J).EQ.0) GOTO 300
      JJ = NEST + 1 - J
      U(JJ) = N
      N = N / SYM(J)
      S(JJ) = N
  200 CONTINUE
  300 JJ = 0
      L = 1
      V(1) = 1
  310 L = L + 1
      V(L) = V(L-1)
  320 IF (L.LT.NEST) GOTO 310
      N = V(NEST)
      JJ = JJ + 1
      IF (JJ.GE.N) GOTO 400
      DELTA = (N-JJ) * SEP
      P1 = (JJ-1)*SEP + 1
      DO 350 P0=P1,NT,P2
      P3 = P0 + SIZE
      DO 350 P=P0,P3,P4
      P5 = P + DELTA
      T = X(P)
      X(P) = X(P5)
      X(P5) = T
      T = Y(P)
      Y(P) = Y(P5)
      Y(P5) = T
  350 CONTINUE
  400 V(L) = V(L) + S(L)
      IF (V(L).LE.U(L)) GOTO 320
      L = L - 1
      IF (L.NE.0) GOTO 400
  500 IF (UNSYM(1).EQ.0) GOTO 1900
      PUNSYM = PTS / PSYM**2
      MULT = PUNSYM / UNSYM(1)
      TEST = (UNSYM(1)*UNSYM(2)-1) * MULT * PSYM
      LK = MULT
      DK = MULT
      DO 600 K=2,NEST
      IF (UNSYM(K).EQ.0) GOTO 700
      LK = LK * UNSYM(K-1)
      DK = DK / UNSYM(K)
      U(K) = (LK-DK) * PSYM
      MODS = K
  600 CONTINUE
  700 ONEMOD = MODS.LT.3
      IF (ONEMOD) GOTO 900
      DO 800 J=3,MODS
      JJ = MODS + 3 - J
      MODULO(JJ) = U(J)
  800 CONTINUE
  900 MODULO(2) = U(2)
      JL = (PUNSYM-3) * PSYM
      MS = PUNSYM * PSYM
      DO 1800 J=PSYM,JL,PSYM
      K = J
 1000 K = K * MULT
      IF (ONEMOD) GOTO 1200
      DO 1100 I=3,MODS
      K = K - (K/MODULO(I))*MODULO(I)
 1100 CONTINUE
 1200 IF (K.GE.TEST) GOTO 1300
      K = K - (K/MODULO(2))*MODULO(2)
      GOTO 1400
 1300 K = K - (K/MODULO(2))*MODULO(2)+MODULO(2)
 1400 IF (K.LT.J) GOTO 1000
      IF (K.EQ.J) GOTO 1800
      DELTA = (K-J) * SEP
      DO 1600 L=1,PSYM
      DO 1500 M=L,PTS,MS
      P1 = (M+J-1)*SEP + 1
      DO 1500 P0=P1,NT,P2
      P3 = P0 + SIZE
      DO 1500 JJ=P0,P3,P4
      KK = JJ + DELTA
      T = X(JJ)
      X(JJ) = X(KK)
      X(KK) = T
      T = Y(JJ)
      Y(JJ) = Y(KK)
      Y(KK) = T
 1500 CONTINUE
 1600 CONTINUE
 1800 CONTINUE
 1900 RETURN
      END
      SUBROUTINE MDFTKD (N, FACTOR, DIM, X, Y, NSIZE)
      INTEGER FACTOR(15), DIM(5), F, P, R, S
      REAL X(NSIZE), Y(NSIZE)
      S = DIM(2)
      F = 0
      M = N
  100 F = F + 1
      P = FACTOR(F)
      IF (P.EQ.0) RETURN
      M = M / P
      R = M * S
      NDIR1 = NSIZE - R
      NDIR2 = NDIR1 - R
      NDIR3 = NDIR2 - R
      NDIR4 = NDIR3 - R
      GOTO (100, 200, 300, 400, 500), P
  200 CALL R2CFTK (N, M, X(1), Y(1), X(R+1), Y(R+1), DIM, NSIZE, NDIR1)
      GOTO 100
  300 CONTINUE
      CALL R3CFTK(N, M, X(1), Y(1), X(R+1), Y(R+1), X(2*R+1), Y(2*R+1)
     ., DIM, NSIZE, NDIR1, NDIR2)
      GOTO 100
  400 CALL R4CFTK (N, M, X(1), Y(1), X(R+1), Y(R+1), X(2*R+1), Y(2*R+1)
     ., X(3*R+1), Y(3*R+1), DIM, NSIZE, NDIR1, NDIR2, NDIR3)
      GOTO 100
  500 CALL R5CFTK (N, M, X(1), Y(1), X(R+1), Y(R+1), X(2*R+1), Y(2*R+1)
     ., X(3*R+1), Y(3*R+1), X(4*R+1), Y(4*R+1), DIM, NSIZE, NDIR1,
     +  NDIR2, NDIR3, NDIR4)
      GOTO 100
      END
      SUBROUTINE R2CFTK (N, M, X0, Y0, X1, Y1, DIM, NDIR0, NDIR1)
      INTEGER DIM(5), SIZE, SEP
      REAL X0(NDIR0), Y0(NDIR0), X1(NDIR1), Y1(NDIR1), IS, IU
      LOGICAL FOLD,ZERO
      DATA TWOPI / 6.2831853 /
      DATA C, S / 0.0, 0.0 /
      DATA ZEROX / 1.0E-12 /
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N * SEP
      M2 = M * 2
      FM2 = FLOAT(M2)
      MOVER2 = M/2 + 1
      MM2 = SEP * M2
      FJM1 = -1.0
      DO 600 J=1, MOVER2
      FOLD = J.GT.1 .AND. 2*J.LT.M+2
      K0 = (J-1)*SEP + 1
      FJM1 = FJM1 + 1.0
      ANGLE = TWOPI * FJM1 / FM2
      ZERO = ABS(ANGLE).LT.ZEROX
      IF (ZERO) GOTO 200
      C = COS(ANGLE)
      S = SIN(ANGLE)
      GOTO 200
  100 FOLD = .FALSE.
      K0 = (M+1-J)*SEP + 1
      C = -C
  200 DO 500 KK=K0,NS,MM2
      DO 440 L=KK,NT,L1
      K1 = L + SIZE
      DO 420 K=L,K1,K2
      RS = X0(K) + X1(K)
      IS = Y0(K) + Y1(K)
      RU = X0(K) - X1(K)
      IU = Y0(K) - Y1(K)
      X0(K) = RS
      Y0(K) = IS
      IF (ZERO) GOTO 300
      X1(K) = RU*C + IU*S
      Y1(K) = IU*C - RU*S
      GOTO 420
  300 X1(K) = RU
      Y1(K) = IU
  420 CONTINUE
  440 CONTINUE
  500 CONTINUE
      IF (FOLD) GOTO 100
  600 CONTINUE
      RETURN
      END
      SUBROUTINE R3CFTK (N, M, X0, Y0, X1, Y1, X2, Y2, DIM,
     +     NDIR0, NDIR1, NDIR2)
      REAL X0(NDIR0),Y0(NDIR0),X1(NDIR1),Y1(NDIR1),X2(NDIR2),Y2(NDIR2),
     +      I0,I1,I2,IA,IB,IS
      LOGICAL FOLD,ZERO
      INTEGER DIM(5), SIZE, SEP
      DATA TWOPI / 6.2831853 /
      DATA A/-0.5/, B/0.866/
      DATA C1, S1, C2, S2 / 0.0, 0.0, 0.0, 0.0 /
      DATA ZEROX / 1.0E-12 /
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N * SEP
      M3 = M * 3
      FM3 = FLOAT(M3)
      MM3 = SEP * M3
      MOVER2 = M/2 + 1
      FJM1 = -1.0
      DO 600 J=1, MOVER2
      FOLD = J.GT.1 .AND. 2*J.LT.M+2
      K0 = (J-1)*SEP + 1
      FJM1 = FJM1 + 1.0
      ANGLE = TWOPI * FJM1 / FM3
      ZERO = ABS(ANGLE).LT.ZEROX
      IF (ZERO) GOTO 200
      C1 = COS(ANGLE)
      S1 = SIN(ANGLE)
      C2 = C1*C1 - S1*S1
      S2 = S1*C1 + C1*S1
      GOTO 200
  100 FOLD = .FALSE.
      K0 = (M+1-J)*SEP + 1
      T = C1*A + S1*B
      S1 = C1*B - S1*A
      C1 = T
      T = C2*A - S2*B
      S2 = -C2*B - S2*A
      C2 = T
  200 DO 500 KK=K0,NS,MM3
      DO 440 L=KK,NT,L1
      K1 = L + SIZE
      DO 420 K=L,K1,K2
      R0 = X0(K)
      I0 = Y0(K)
      RS = X1(K) + X2(K)
      IS = Y1(K) + Y2(K)
      X0(K) = R0 + RS
      Y0(K) = I0 + IS
      RA = R0 + RS*A
      IA = I0 + IS*A
      RB = (X1(K)-X2(K)) * B
      IB = (Y1(K)-Y2(K)) * B
      IF (ZERO) GOTO 300
      R1 = RA + IB
      I1 = IA - RB
      R2 = RA - IB
      I2 = IA + RB
      X1(K) = R1*C1 + I1*S1
      Y1(K) = I1*C1 - R1*S1
      X2(K) = R2*C2 + I2*S2
      Y2(K) = I2*C2 - R2*S2
      GOTO 420
  300 X1(K) = RA + IB
      Y1(K) = IA - RB
      X2(K) = RA - IB
      Y2(K) = IA + RB
  420 CONTINUE
  440 CONTINUE
  500 CONTINUE
      IF (FOLD) GOTO 100
  600 CONTINUE
      RETURN
      END
      SUBROUTINE R4CFTK (N, M, X0, Y0, X1, Y1, X2, Y2, X3, Y3, DIM,
     +   NDIR0, NDIR1, NDIR2, NDIR3)
      REAL X0(NDIR0),Y0(NDIR0),X1(NDIR1),Y1(NDIR1),
     +     X2(NDIR2),Y2(NDIR2),X3(NDIR3),Y3(NDIR3)
      INTEGER DIM(5), SIZE, SEP
      LOGICAL FOLD,ZERO
      REAL I1,I2,I3,IS0,IS1,IU0,IU1
      DATA TWOPI / 6.2831853 /
      DATA C1, S1, C2, S2, C3, S3 / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 /
      DATA ZEROX / 1.0E-12 /
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N * SEP
      M4 = M * 4
      FM4 = FLOAT(M4)
      MM4 = SEP * M4
      MOVER2 = M/2 + 1
      FJM1 = -1.0
      DO 600 J=1, MOVER2
      FOLD = J.GT.1 .AND. 2*J.LT.M+2
      K0 = (J-1)*SEP + 1
      FJM1 = FJM1 + 1.0
      ANGLE = TWOPI * FJM1 / FM4
      ZERO = ABS(ANGLE).LT.ZEROX
      IF (ZERO) GOTO 200
      C1 = COS(ANGLE)
      S1 = SIN(ANGLE)
      C2 = C1*C1 - S1*S1
      S2 = S1*C1 + C1*S1
      C3 = C2*C1 - S2*S1
      S3 = S2*C1 + C2*S1
      GOTO 200
  100 FOLD = .FALSE.
      K0 = (M+1-J)*SEP + 1
      T = C1
      C1 = S1
      S1 = T
      C2 = -C2
      T = C3
      C3 = -S3
      S3 = -T
  200 DO 500 KK=K0,NS,MM4
      DO 440 L=KK,NT,L1
      K1 = L + SIZE
      DO 420 K=L,K1,K2
      RS0 = X0(K) + X2(K)
      IS0 = Y0(K) + Y2(K)
      RU0 = X0(K) - X2(K)
      IU0 = Y0(K) - Y2(K)
      RS1 = X1(K) + X3(K)
      IS1 = Y1(K) + Y3(K)
      RU1 = X1(K) - X3(K)
      IU1 = Y1(K) - Y3(K)
      X0(K) = RS0 + RS1
      Y0(K) = IS0 + IS1
      IF (ZERO) GOTO 300
      R1 = RU0 + IU1
      I1 = IU0 - RU1
      R2 = RS0 - RS1
      I2 = IS0 - IS1
      R3 = RU0 - IU1
      I3 = IU0 + RU1
      X2(K) = R1*C1 + I1*S1
      Y2(K) = I1*C1 - R1*S1
      X1(K) = R2*C2 + I2*S2
      Y1(K) = I2*C2 - R2*S2
      X3(K) = R3*C3 + I3*S3
      Y3(K) = I3*C3 - R3*S3
      GOTO 420
  300 X2(K) = RU0 + IU1
      Y2(K) = IU0 - RU1
      X1(K) = RS0 - RS1
      Y1(K) = IS0 - IS1
      X3(K) = RU0 - IU1
      Y3(K) = IU0 + RU1
  420 CONTINUE
  440 CONTINUE
  500 CONTINUE
      IF (FOLD) GOTO 100
  600 CONTINUE
      RETURN
      END
      SUBROUTINE R5CFTK (N, M, X0, Y0, X1, Y1, X2, Y2, X3, Y3, X4, Y4,
     *                   DIM, NDIR0, NDIR1, NDIR2, NDIR3, NDIR4)
      REAL X0(NDIR0),Y0(NDIR0),X1(NDIR1),Y1(NDIR1),X2(NDIR2),
     +     Y2(NDIR2),X3(NDIR3),Y3(NDIR3),X4(NDIR4),Y4(NDIR4),
     +     I0,I1,I2,I3,I4,IA1,IA2,IB1,IB2,IS1,IS2,IU1,IU2
      INTEGER DIM(5), SIZE, SEP
      LOGICAL FOLD,ZERO
      DATA TWOPI / 6.2831853 /
      DATA A1/0.30902/   ,B1/0.95106/   ,A2/-0.80902/   ,B2/0.58779/
      DATA C1, S1, C2, S2, C3, S3, C4, S4 / 0.,0.,0.,0.,0.,0.,0.,0. /
      DATA ZEROX / 1.0E-12 /
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N * SEP
      M5 = M * 5
      FM5 = FLOAT(M5)
      MM5 = SEP*M5
      MOVER2 = M/2 + 1
      FJM1 = -1.0
      DO 600 J=1, MOVER2
      FOLD = J.GT.1 .AND. 2*J.LT.M+2
      K0 = (J-1)*SEP + 1
      FJM1 = FJM1 + 1.0
      ANGLE = TWOPI * FJM1 / FM5
      ZERO = ABS(ANGLE).LT.ZEROX
      IF (ZERO) GOTO 200
      C1 = COS(ANGLE)
      S1 = SIN(ANGLE)
      C2 = C1*C1 - S1*S1
      S2 = S1*C1 + C1*S1
      C3 = C2*C1 - S2*S1
      S3 = S2*C1 + C2*S1
      C4 = C2*C2 - S2*S2
      S4 = S2*C2 + C2*S2
      GOTO 200
  100 FOLD = .FALSE.
      K0 = (M+1-J)*SEP + 1
      T = C1*A1 + S1*B1
      S1 = C1*B1 - S1*A1
      C1 = T
      T = C2*A2 + S2*B2
      S2 = C2*B2 - S2*A2
      C2 = T
      T = C3*A2 - S3*B2
      S3 = -C3*B2 - S3*A2
      C3 = T
      T = C4*A1 - S4*B1
      S4 = -C4*B1 - S4*A1
      C4 = T
  200 DO 500 KK=K0,NS,MM5
      DO 440 L=KK,NT,L1
      K1 = L + SIZE
      DO 420 K=L,K1,K2
      R0 = X0(K)
      I0 = Y0(K)
      RS1 = X1(K) + X4(K)
      IS1 = Y1(K) + Y4(K)
      RU1 = X1(K) - X4(K)
      IU1 = Y1(K) - Y4(K)
      RS2 = X2(K) + X3(K)
      IS2 = Y2(K) + Y3(K)
      RU2 = X2(K) - X3(K)
      IU2 = Y2(K) - Y3(K)
      X0(K) = R0 + RS1+RS2
      Y0(K) = I0 + IS1+IS2
      RA1 = R0 + RS1*A1+RS2*A2
      IA1 = I0 + IS1*A1+IS2*A2
      RA2 = R0 + RS1*A2+RS2*A1
      IA2 = I0 + IS1*A2+IS2*A1
      RB1 = RU1*B1 + RU2*B2
      IB1 = IU1*B1 + IU2*B2
      RB2 = RU1*B2 - RU2*B1
      IB2 = IU1*B2 - IU2*B1
      IF (ZERO) GOTO 300
      R1 = RA1 + IB1
      I1 = IA1 - RB1
      R2 = RA2 + IB2
      I2 = IA2 - RB2
      R3 = RA2 - IB2
      I3 = IA2 + RB2
      R4 = RA1 - IB1
      I4 = IA1 + RB1
      X1(K) = R1*C1 + I1*S1
      Y1(K) = I1*C1 - R1*S1
      X2(K) = R2*C2 + I2*S2
      Y2(K) = I2*C2 - R2*S2
      X3(K) = R3*C3 + I3*S3
      Y3(K) = I3*C3 - R3*S3
      X4(K) = R4*C4 + I4*S4
      Y4(K) = I4*C4 - R4*S4
      GOTO 420
  300 X1(K) = RA1 + IB1
      Y1(K) = IA1 - RB1
      X2(K) = RA2 + IB2
      Y2(K) = IA2 - RB2
      X3(K) = RA2 - IB2
      Y3(K) = IA2 + RB2
      X4(K) = RA1 - IB1
      Y4(K) = IA1 + RB1
  420 CONTINUE
  440 CONTINUE
  500 CONTINUE
      IF (FOLD) GOTO 100
  600 CONTINUE
      RETURN
      END
      SUBROUTINE HERMFT (X, Y, NSIZE, N, DIM)
      REAL X(NSIZE), Y(NSIZE)
      INTEGER DIM(5), D2, D3, D4, D5
      DATA TWOPI / 6.2831853 /
      TWON = FLOAT(2*N)
      NT = DIM(1)
      D2 = DIM(2)
      D3 = DIM(3)
      D4 = DIM(4) - 1
      D5 = DIM(5)
      DO 100 I0=1,NT,D3
      I1 = I0 + D4
      DO 100 I=I0,I1,D5
      A = X(I)
      B = Y(I)
      X(I) = A + B
      Y(I) = A - B
  100 CONTINUE
      NOVER2 = N/2 + 1
      IF (NOVER2 .LT. 2) GOTO 500
      DO 400 I0 = 2, NOVER2
      ANGLE = TWOPI * FLOAT(I0-1) / TWON
      CO = COS(ANGLE)
      SI = SIN(ANGLE)
      K = (N + 2 - 2*I0)*D2
      K1 = (I0 - 1)*D2 + 1
      DO 300 I1=K1,NT,D3
      I2 = I1 + D4
      DO 200 I=I1,I2,D5
      J = I + K
      A = X(I) + X(J)
      B = X(I) - X(J)
      C = Y(I) + Y(J)
      D = Y(I) - Y(J)
      E = B*CO + C*SI
      F = B*SI - C*CO
      X(I) = A + F
      X(J) = A - F
      Y(I) = E + D
      Y(J) = E - D
  200 CONTINUE
  300 CONTINUE
  400 CONTINUE
      CALL CMPLFT (X, Y, NSIZE, N, DIM)
  500 RETURN
      END
      SUBROUTINE RDSECT (MAX, NNXP2, NNZ, NXZ3, LIN)
      PARAMETER (KUSER2=30000)
      COMMON /BLANK/ NR3D, DUMMY(145000)
      INTEGER*2 NR3D(KUSER2)
      IF (MAX .GE. NXZ3) MAX = 0
      MX = MAX
      MAX = MAX - 2
      DO 1320 IZ=1,NNZ
      MIN = MAX + 3
      MAX = MAX + NNXP2
      READ (LIN) IYSEC, IZLIN, IXTOT, (NR3D(IX),IX=MIN,MAX)
      NR3D(MAX+1) = NR3D(MIN)
      NR3D(MAX+2) = NR3D(MIN+1)
 1320 CONTINUE
      MIN = MAX + 3
      MAX = MAX + NNXP2 + NNXP2 + 2
      DO 1340 IX=MIN,MAX
      MX = MX + 1
      NR3D(IX) = NR3D(MX)
 1340 CONTINUE
      RETURN
      END
      SUBROUTINE SORT (X, MAXAT, NAT, N)
      DIMENSION X(4,MAXAT), T(4)
      INT=2
 1000 INT=INT+INT
      IF(INT.LT.NAT)GO TO 1000
      INT = MIN0 (NAT, (3*INT)/4-1)
 1020 INT=INT/2
      IFIN=NAT-INT
      DO 1200 II=1,IFIN
      I=II
      J=I+INT
      IF (X(N,I) .GE. X(N,J)) GOTO 1200
      DO 1060 K=1,4
      T(K) = X(K,J)
 1060 CONTINUE
 1080 DO 1100 K=1,4
      X(K,J) = X(K,I)
 1100 CONTINUE
      J=I
      I=I-INT
      IF (I) 1140, 1140, 1120
 1120 IF (X(N,I) .LT. T(N)) GOTO 1080
 1140 DO 1160 K=1,4
      X(K,J) = T(K)
 1160 CONTINUE
 1200 CONTINUE
      IF(INT.NE.1)GO TO 1020
      RETURN
      END
      FUNCTION QUAD2 (X1, X2)
      DIMENSION X1(3), X2(3)
      INCLUDE 'Zcrys.inc'
      CALL VMATV1 (X1, RRMAT, X2, DIST2)
      QUAD2 = DIST2
      RETURN
      END
      SUBROUTINE OPER1 (J, XN, XYZ)
      DIMENSION XN(3), XYZ(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION FS(3,3,24)
      LOGICAL CONT
      DATA CONT / .FALSE. /
      IF (CONT) GOTO 111
      CONT = .TRUE.
      CALL KERI2F (IRSYMM, FS, 9*NSYMM)
  111 ISYM = MOD(J,NSYMM)
      IF (ISYM .EQ. 0) ISYM = NSYMM
      IP = (J-1) / NSYMM
      ILAT = MOD(IP,NLATT) + 1
      IF (IP .LT. NLATT) THEN
         DO 120 I = 1,3
  120    XN(I) = XYZ(1) * FS(I,1,ISYM)
     *         + XYZ(2) * FS(I,2,ISYM)
     *         + XYZ(3) * FS(I,3,ISYM) + TSYMM(I,ISYM) + TLATT(I,ILAT)
      ELSE
         DO 130 I = 1,3
  130    XN(I) =-XYZ(1) * FS(I,1,ISYM)
     *         - XYZ(2) * FS(I,2,ISYM)
     *         - XYZ(3) * FS(I,3,ISYM) - TSYMM(I,ISYM) + TLATT(I,ILAT)
         ENDIF
      RETURN
      END
      SUBROUTINE PHASEX
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      DATA NCALL / 0 /
      NCALL = NCALL + 1
      CALL KEPROG ('PHASEX')
      KSTAT(5) = 0
      IF (NCALL .EQ. 1)
     *   WRITE(24, FMT='(/'' The program  PHASEX  performs the'',
     *    '' DIRDIF phase expansion and ''/ '' refinement'',
     *    '' procedure by application of''/'' direct metods to'',
     *    '' difference structure factors''/)')
      CALL DIFTIN
      IPSQ = 0
      CALL DDOP
      IF (IDC .GT. 0) CALL DACOP
      IF (IDC .GT. 1) CALL DAMAIN
      IF (IDC .EQ. 1) CALL DCMAIN
      IF (IDC .GT. 0) CALL DACEND
      CALL DDTAN
      CALL KEPROX
      RETURN
      END
      SUBROUTINE DIFTIN
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      LOGICAL SWIPRI, EXPAND
      EQUIVALENCE   (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (IDDL,   IFILE( 1)), (ICRYS,  IFILE( 3))
      EQUIVALENCE (ICON,   IFILE( 4))
      EQUIVALENCE (IE100,  IFILE(10))
      EQUIVALENCE (IBINDU, IFILE(14))
      EQUIVALENCE (NBINDU, KEYS (14))
      INCLUDE 'Zdifta.inc'
      EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      EQUIVALENCE (FITDUA(1), HCODE), (FITDUA(2), E1), (FITDUA(3), E2),
     *            (FITDUA(5), P1),    (FITDUA(6), P2), (FITDUA(7), W1)
      DIMENSION KARR(100), MAXHC(3), IHKL(3), HKL(3)
      PARAMETER (LCMAX = 8)
      CHARACTER LCONDA(LCMAX) *6
      DATA LCONDA / 'PHASEX', 'NCEST', 'ACCEPT', 'LOCCEN', 'STLMAX',
     *              'MAXHKL', 'DIRP1', 'PRINT' /
      DATA K, IBIG, NN / 0, 0, 0/
      CALL WR24
      NITDUA = 7
      EMIN  = 0.9
      MAXREF = 2047
      CALL KERNZI (0,  MAXHKL, 3)
      CALL KERNZA (0.,     TO, 3)
      CALL KERNZA (0., ESTART, 5)
      CALL KERNZA (0.,   E2AG, 7)
      CALL KERNZA (0.,   E2CG, 7)
      DO 190 I=1,ISIZ
  190 ITAB(I) = 0
      WRITE (8, 200) ISIZ
  200 FORMAT (/' Available storage: ', I6)
      NC =  0
      E2AGE = 0.0
      E2CGE = 0.0
      NR  = 0
      IDC = 0
      QEET = 0.8
      MAXT = 60
      CALL KERNZI (0, MAXHC,  3)
      CALL RDCRYS (ICRYS)
      KEYS(19) = ICENT
  210 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)
      GOTO (210, 211, 212, 213, 214, 215, 216, 217) KEND
      IF (KEND .EQ. 0) GOTO 260
      CALL KERROR ('Error reading CONDA file', 0, 'DIFTIN')
  211 IF (NFNUM .NE. 6) CALL KERNER (211, 'DIFTIN')
      NC = IFIX(FNUM(1))
      IF (NC .GT. 5) NC = 5
      CALL KERNAB (FNUM(2), ESTART, 5)
      GOTO 210
  212 IF (NFNUM .NE. 2) CALL KERNER (212, 'DIFTIN')
      QEET = FNUM(1)
      IF (QEET .LT. 0.5) QEET = 0.5
      MAXT = IFIX(FNUM(2))
      IF (MAXT .LT. 10)  MAXT = 60
      GOTO 210
  213 IF (NFNUM .NE. 3) CALL KERNER (213, 'DIFTIN')
      CALL KERNAB (FNUM, TO, 3)
      IDC = 1
      GOTO 210
  214 IF (NFNUM .NE. 1) CALL KERNER (214, 'DIFTIN')
      STLMAX = FNUM(1)
      GOTO 210
  215 IF (NFNUM .NE. 3) CALL KERNER (215, 'DIFTIN')
      CALL KERF2I (FNUM, MAXHC, 3)
      GOTO 210
  216 EXPAND = .TRUE.
      GOTO 210
  217 SWIPRI = .TRUE.
      GOTO 210
  260 CALL FILINQ (IE100, 'E100', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('No E100 file found', 0, 'DIFTIN')
      CALL KERINA (IE100, LIT, 1, LEND)
      IF (LIT(1).NE.'E100' .OR. LIT(2).NE.CCODE) CALL KERROR
     *   ('Error reading E100 file', 0, 'DIFTIN')
      NGN = IFIX(FNUM(1))
      NSP = IFIX(FNUM(2))
      E2ALE = FNUM(3)
      E2CLE = FNUM(4)
      CALL LOGRD (IDDL, 'PHASEX', KLOG)
      CALL FILCLO (IDDL, 'KEEP')
      IF (KLOG.LE.0 .OR. LIT(5).NE.'MHKL' .OR. LIT(6).NE.'NREFL1')
     *    CALL KERROR ('Error reading DDLOG file', 0, 'DIFTIN')
      CALL KERF2I (FNUM(4), MAXHKL, 3)
      NR = IFIX(FNUM(7))
      IF (MAXHKL(1).EQ.0 .AND. MAXHKL(2).EQ.0 .AND. MAXHKL(3).EQ.0)
     *    CALL KERROR ('No MAXHKL given on DDLOG file', 0, 'DIFTIN')
      IF (NR .EQ. 0)
     *    CALL KERROR ('No NREFL1 given on DDLOG file', 0, 'DIFTIN')
      IF (NGN.EQ.0 .AND. NSP.EQ.0)
     *    CALL KERROR ('No NGN or NSP given on E100 file', 0, 'DIFTIN')
      IF (E2ALE.LT.0.01 .AND. E2CLE.LT.0.01) CALL KERROR
     *           ('No E2ACLE or E2CLE given on E100 file', 0, 'DIFTIN')
      DO 265 I=1,3
  265 IF (MAXHC(I) .GT. 0) MAXHKL(I) = MIN0(MAXHKL(I), MAXHC(I))
      KORIS = 0
      IICENT = ICENT
      IF (EXPAND) IICENT = 1
      IF (IDC .EQ. 0) CALL LOCCEN (IDC, TO)
      IF (IDC .GT. 0) THEN
         KORIS = 1
         IDC = 1
         ENDIF
      IF (IDC .EQ. 0) GOTO 310
      IF (IICENT .EQ. 1) GOTO 280
      WRITE (8, 270)
  270 FORMAT (' Input LOCCEN ignored' /)
      IDC = 0
      KORIS = 0
      GOTO 310
  280 WRITE(24, 285)
      WRITE (8, 285)
  285 FORMAT (/ ' ***** Enantiomorph fixation *****' /)
      IF (ABS(TO(1)).LT..001 .AND. ABS(TO(2)).LT..001 .AND.
     *   ABS(TO(3)).LT..001) THEN
         KORIS = 0
         GOTO 310
         ENDIF
      WRITE(24, 290) TO
      WRITE (8, 290) TO
  290 FORMAT (' The origin is shifted over a vector (',3(F6.3,','),')')
      WRITE (8, 300)
  300 FORMAT(' All phases printed by PHASEX are in agreement with the',
     *       ' new origin', / ' phases on the final output file are',
     *       ' set back to the original origin')
      CALL PSEUDO (TO)
  310 CALL BINIFF (1, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      WRITE (8, FMT='('' Input atoms resulted in R2 ='',F6.3)') R2X
      IF (PSQ .GT. 0.99) CALL KERROR ('PSQ too big...', 310, 'DIFTIN')
      IF (NC .GT. 0) GOTO 320
      IF (IDC .EQ. 1) NC = 2
      NC = 3
      IF (NR .LT. 200) NC = 2
  320 IDC3 = IDC + 1
      IF (ESTART(1) .GT. 0.1) GOTO 340
      XX = 1.3
      IF (IICENT .EQ. 2) XX = 1.5
      DO 330 I=1,NC
  330 ESTART(I) = XX - 0.1*(I/2)
  340 WRITE (8, 350) EMIN, NC, (ESTART(I), I=1,NC)
  350 FORMAT (/ ' Start    E1min = ', F4.2, '       Tangent formula:' /
     *        29X, 'minimum Er for', I2, ' cycles :   ', 5F5.2)
      IF (IDC .NE. 1) GOTO 370
      ESTART(1) = ESTART(1) - 0.1
      ESTAR1 = ESTART(1)
      WRITE (8, 360) ESTAR1
  360 FORMAT (26X, 'Min E1 for cycle zero (with symbols): ', F4.2)
  370 WRITE (8, FMT='('' MAXHKL:'', 3I4)') MAXHKL
      MCTMAX = 32767
      I34 = 1
      I35 = 1
      MCTLAT = 1
      FR = 1.
      M = 0
      MS = 1
      CALL KERNAI (MAXHKL, IHKL, 3)
  380 GOTO (410, 400, 390), I35
  390 IF (MOD(MAXL,3) .GT. 0) MAXL = MAXL + 3 - MOD(MAXL,3)
      GOTO 410
  400 MAXL = MAXL + MOD(MAXL,2)
  410 MCK = 2*MAXL/I35 + 1
      IF (I34 .EQ. 2) MAXK = MAXK + MOD(MAXK,2)
      MCH = MCK * (2*MAXK/I34+1)
      MCT = MCH*MAXH + MCK*MAXK/I34 + MAXL/I35
      IF (MCT .LE. MCTMAX) GOTO 470
      GOTO (420, 430, 430, 460), MS
  420 MS = 2
      IF (MCT .LE. 5*MCTMAX/4) GOTO 430
      IF (ILATT.EQ.1) GOTO 430
      MCTLAT = ILATT
      IF (ILATT.EQ.6 .AND. MCT.LE.7*MCTMAX/3) MCTLAT = 3
      IF (MCTLAT.EQ.6 .OR. MCTLAT.EQ.4) I34 = 2
      IF (MCTLAT .NE. 4) I35 = 2
      IF (MCTLAT .EQ. 7) I35 = 3
      GOTO 380
  430 M = 1
      FR = FR * ( (FLOAT(MCT)/MCTMAX - 1.)/3. + 1. )
      DO 450 N=1,3
  450 MAXHKL(N) = IHKL(N)/FR + 1.
      IF (MS .LT. 4) MS = MS + 1
      GOTO 380
  460 FR = FR * 1.02
      GOTO 430
  470 IF (M .GT. 0) WRITE (8, 480) MAXHKL
  480 FORMAT (' Storage too small; new MAXHKL: ', 3I3)
      WRITE (8, 500) MCH, MCK, I34, I35, MCT
  500 FORMAT (' Packed indices are', I14, '*H + ', I4, '*K/', I1,
     *   ' + L/', I1, /, ' Dimension of address table is', I22)
      I34 = MAXK / I34
      I35 = MAXL / I35
      KK = 0
      ICR = 9
      NTAL = ISIZ - ICR
      MAXRE = (ISIZ-MCT) / 10
      IF (MAXRE .GT. MAXREF-5) MAXRE = MAXREF - 5
      WRITE (8, 503) MAXRE
  503 FORMAT (' Dimension of reflection table is', I19)
      EMINO = EMIN
      EMAX = EMIN + 0.9
      CALL VALDIS (-1, EMIN, EMAX, KARR, 100, NREFDI)
      MMS = 1
      NCOUNT = 500
      NBINDU = 0
  510 CALL BINIFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA)
      IF (KENDUA .LT. 0) GOTO 580
      NBINDU = NBINDU + 1
      CALL HKLC1U (HCODE, HKL)
      CALL HKLSTL (HKL, STL, STL2)
      IT = 1
      IF (.NOT. EXPAND) IT = IPHFIX (HKL)
      ITP = IT - 1
      EEX = E2EXP (ITP, E1, E2)
      CALL KERF2I (HKL, IHKL, 3)
      IF (MAXH.LT.IABS(IHKL(1)) .OR. MAXK.LT.IABS(IHKL(2)) .OR.
     *    MAXL.LT.IABS(IHKL(3)) .OR. E1.LT.EMIN .OR.
     *    STL.GT.STLMAX) GOTO 570
      ITAB(NCOUNT+1) = IHKL(1)
      ITAB(NCOUNT+2) = IHKL(2)
      ITAB(NCOUNT+3) = IHKL(3)
      ITAB(NCOUNT+4) = NINT (100.*E1)
      ITAB(NCOUNT+5) = NINT (100.*E2)
      IF (ABS(P1-P2) .LT. 5.) ITAB(NCOUNT+5) = -ITAB(NCOUNT+5)
      IF (KORIS .EQ. 1) CALL ORSHIF (HKL, TO, P1, P2, 0., KORIS)
      ITAB(NCOUNT+6) = NINT (P1)
      IF (ITAB(NCOUNT+6) .GE. 360) ITAB(NCOUNT+6) = ITAB(NCOUNT+6) - 360
      ITAB(NCOUNT+7) = NINT (1000.*W1)
      ITAB(NCOUNT+8) = IT
      ITAB(NCOUNT+9) = NINT (100.*EEX)
      CALL VALDIS (0, E1, 0., KARR, 100, NREFDI)
      NCOUNT = NCOUNT + ICR
      IF (NCOUNT .LT. NTAL-ICR) GOTO 510
      CALL VALDIS (MAXRE, EMIN, 0., KARR, 100, NREFDI)
      WRITE (8, 520) EMIN
  520 FORMAT (' Too many refl.; new E1min =', F5.2)
      IF (EMIN .GT. EMAX) THEN
         WRITE(24, 522) EMAX-1., EMAX-0.99, EMAX-0.98, EMAX-0.97,
     *      (KARR(I), I= 1,100)
         WRITE (8, 522) EMAX-1., EMAX-0.99, EMAX-0.98, EMAX-0.97,
     *      (KARR(I), I= 1,100)
  522    FORMAT (' Expected scaling error: distribution of E1 values:'/
     *      3X, 4F5.2, '  ....'/ (5X, 12I5) )
         EMIN = EMAX
         WRITE (8, 524) EMIN
  524    FORMAT (' Reset: ........ new E1min =', F5.2)
         IF (EMIN .GT. EMINO + 1.0) WRITE (24,*)
     *      'Too many tryals: scaling error!: see what happens.'
         ENDIF
      EMAX = EMIN + 0.9
      CALL VALDIS (-1, EMIN, EMAX, KARR, 100, NREFDI)
      KK = NCOUNT
      NCOUNT  = 500
      K  = 500
      MMS = 2
  530 E1 = ITAB(K+4) / 100.
      IF (E1 .GE. EMIN) GOTO 540
      EEX = ITAB(K+9) / 100.
      IT = ITAB(K+8)
      K = K + ICR
      GOTO 570
  540 DO 550 I=1,9
      K = K + 1
      NCOUNT = NCOUNT + 1
  550 ITAB(NCOUNT) = ITAB(K)
      CALL VALDIS (0, E1, 0., KARR, 100, NREFDI)
  560 IF (K .LT. KK) GOTO 530
      MMS = 1
      GOTO 510
  570 IF (IT .EQ. 1) E2ALE = E2ALE + EEX
      IF (IT .GT. 1) E2CLE = E2CLE + EEX
      GOTO (510, 560, 660), MMS
  580 CONTINUE
      WRITE (8, 581) NBINDU
  581 FORMAT (' Number of reflections input from file BINDUA:', I6)
      IF (NREFDI .LT. MAXRE+5) GOTO 600
      CALL VALDIS (MAXRE, EMIN, 0., KARR, 100, NREFDI)
      WRITE (8, 520) EMIN
      MAXRE = (ISIZ - NCOUNT) / 8   - 5
      MAXRE = MIN0 (MAXRE, MAXREF)
  600 KK = NCOUNT
      IF (MCT .GT. NCOUNT) NCOUNT = MCT
      IBIG = NCOUNT
      NN = NCOUNT + 8*(MAXRE+5)
      K = 500
      MMS = 3
  610 E1  = ITAB(K+4) / 100.
      EEX = ITAB(K+9) / 100.
      IT  = ITAB(K+8)
      IF (E1 .GE. EMIN) GOTO 620
      K = K + ICR
      GOTO 570
  620 IF (IT.GT.1) GOTO 630
      E2AGE = E2AGE + EEX
      E2AG(1) = E2AG(1) + E1*E1
      GOTO 640
  630 E2CGE = E2CGE + EEX
      E2CG(1) = E2CG(1) + E1*E1
  640 DO 650 I=1,8
      K = K + 1
      NCOUNT = NCOUNT + 1
  650 ITAB(NCOUNT) = ITAB(K)
      K = K + 1
  660 IF (K.LT.KK .AND. NCOUNT.LT.NN) GOTO 610
      IF (IBIG .EQ. MCT) GOTO 680
      KK = NCOUNT
      NCOUNT = MCT
      K = IBIG + 1
      DO 670 I=K,KK
      NCOUNT = NCOUNT + 1
  670 ITAB(NCOUNT) = ITAB(I)
  680 NCT = NCOUNT - 8
      ICR = 8
      RETURN
      END
      SUBROUTINE DDOP
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      LOGICAL SWIPRI, EXPAND
      EQUIVALENCE   (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (IBINDO, IFILE(13))
      INCLUDE 'Zdifta.inc'
      COMMON /SINCOS/ IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      COMMON /KLAD/ ICODE(4,48), ISHIFT(48)
      DIMENSION IPG1(8), KARR(100), IHKL(3)
      DIMENSION FKLAD(100)
      CHARACTER LITOUT *25
      CHARACTER LETT(5) *2
      DATA LETT / '. ', 'S ', 'R ', 'SR', 'C ' /
      CALL WR24
      CALL BINOFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      EWMIN = ESTART(1) * 0.16 - 0.01
      CALL VALDIS (-1, 0.03, 2. , KARR, 80, MST)
      MR = (NCT-MCT)/ICR + 1
      MSMAX = MIN0 (400, (ISIZ - NCT + MR) / 12)
      WRITE (8, 200) MR
  200 FORMAT (' Number of reflections to be refined: ', I6)
      NR = MR
      NLINPR = 0
      IF (.NOT. SWIPRI) GOTO 240
      WRITE (8, 210)
  210 FORMAT (/' Reflection table (max. 300 refl. printed)', /,
     *        ' R = restricted phase (Fp .gt. Fobs)')
      IF (IICENT .EQ. 1) WRITE (8, 220)
  220 FORMAT (' S = special reflection (two possible phase values)')
      WRITE (8, 230)
  230 FORMAT ( /' ', 5('  H  K  L  E1   P1   W1  ') /)
      CHOUT = '(5A25)'
      CALL LINPRX (8, LITOUT, 25, 5)
  240 MS = 0
      NWZ = 0
      DO 260 K=MCT,NCT,ICR
      IHKL(1) = ITAB(K+1)
      IHKL(2) = ITAB(K+2)
      IHKL(3) = ITAB(K+3)
      E1      = ITAB(K+4)/100.
      E2      = ABS(ITAB(K+5)/100.)
      P1      = ITAB(K+6)
      W1      = ITAB(K+7)/1000.
      IF (W1 .LT. 0.01) NWZ = NWZ + 1
      IT      = ITAB(K+8)
      PHREST  = 180.
      IF (ITAB(K+5) .LT. 0) PHREST = 57.296 *
     *                    ASIN ((E2-E1) / (E2+E1))
      EW = E1 * W1
      IF (EW .GE. 0.03) CALL VALDIS (0, EW, 0., KARR, 80, MST)
      IF (E1.LT.ESTART(1) .OR. W1.LT.0.16) GOTO 250
      EW = EW + 10.
      MS = MS + 1
  250 LET = 0
      IF (IICENT .NE. 1) LET = -1
      IF (IT .NE. 1) LET = LET + 2
      IF (ITAB(K+5) .LT. 0) LET = LET + 2
      CALL KERI2F (IHKL, FITDOP(1), 3)
      FITDOP(4) = E1
      FITDOP(5) = E2
      FITDOP(6) = P1
      FITDOP(7) = W1
      FITDOP(8) = FLOAT(IT)
      FITDOP(9) = PHREST
      CALL BINOFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (SWIPRI .AND. NLINPR.LT.300) THEN
         NLINPR = NLINPR + 1
         IP1 = NINT(P1)
         LET = MAX0 (1, LET)
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, E1, IP1, LETT(LET), W1
         CALL LINPRX (0, LITOUT, 25, 5)
      ENDIF
      ITAB(K+5) = EW*1000. + .5
  260 CONTINUE
      IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5)
      CALL BINOFF (-1,IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (MS.LE.MSMAX .AND. MS.GE.MSMAX/4) GOTO 280
      MSMAXT = MSMAX
      IF (MS .LE. MSMAX) MSMAXT = MSMAX / 4
      CALL VALDIS (MSMAXT, EW, 0., KARR, 80, MST)
      WRITE (8, 270) EW
  270 FORMAT (/' New starting set limitations;' /
     *        '     minimum E1 * W1 is: ', F6.3)
      EWMIN = EW - 0.001
      MST = 0
  280 CONTINUE
      NCOUNT = MCT
      MS = 0
      DO 290 K=MCT,NCT,ICR
      ITAB(NCOUNT+1) = ITAB(K+1)
      ITAB(NCOUNT+2) = ITAB(K+2)
      ITAB(NCOUNT+3) = ITAB(K+3)
      ITAB(NCOUNT+4) = ITAB(K+4)
      EW = ITAB(K+5) / 1000.
      ITAB(NCOUNT+5) = ITAB(K+8)
      ITAB(NCOUNT+6) = ITAB(K+6)
      ITAB(NCOUNT+7) = ITAB(K+7)
      IF (MST.GT.0 .AND. EW.LT.10.) GOTO 290
      IF (MST.EQ.0 .AND. EW.GT.10.) EW = EW - 10.
      IF (EW .LT. EWMIN) GOTO 290
      ITAB(NCOUNT+5) = -ITAB(NCOUNT+5)
      MS = MS + 1
  290 NCOUNT = NCOUNT + 7
      ICR = 7
      NCT = NCOUNT - ICR
      INCA4 = 4
      MARKA4 = NCOUNT - INCA4
      MAXA4 = ISIZ - INCA4
      ISTO4 = MARKA4
      MSMAX = MIN0 (MS, MSMAX+10)
      WRITE (8, 300) MSMAX
  300 FORMAT (' Number of reflections in starting set: ', I4)
      IF (.NOT. SWIPRI) GOTO 320
      WRITE (8, FMT='(/'' Starting set (max. 200 refl. printed)'')')
      NLINPR = 0
      WRITE (8, 230)
  320 DO 330 I=1,MCT
  330 ITAB(I) = 0
      CALL KERNZI (0, IPG1, 8)
      CALL KERNZI (0, IPG2, 8)
      IILAUE = ILAUE
      IF (EXPAND) ILAUE = 1
      LET = 1
      MS = 0
      MR = 0
      MITAB = 0
      E1MIN = 0.9
      E1MAX = 3.0
      CALL VALDIS (-1, E1MIN, E1MAX, KARR, 100, NRE1)
      DO 370 NCOUNT=MCT,NCT,ICR
      MR = MR + 1
      IHKL(1) = ITAB(NCOUNT+1)
      IHKL(2) = ITAB(NCOUNT+2)
      IHKL(3) = ITAB(NCOUNT+3)
      W1      = ITAB(NCOUNT+7) / 1000.
      ITAB(NCOUNT+1) = INPACK(IHKL)
      ITAB(NCOUNT+2) = W1 * ITAB(NCOUNT+4) +.5
      ITAB(NCOUNT+3) = ITAB(NCOUNT+6)
      ITAB(NCOUNT+7) = ITAB(NCOUNT+4)
      E1 = ITAB(NCOUNT+4) / 100.
      CALL VALDIS (0, E1, 0., KARR, 100, NRE1)
      I = IGROUP (IHKL)
      IPG2(I) = IPG2(I) + 1
      IP1 = ITAB(NCOUNT+6)
      IF (ITAB(NCOUNT+5) .GT. 0) GOTO 340
      IF (MS .GE. MSMAX) GOTO 350
      IF (SWIPRI .AND. NLINPR.LT.200) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, E1, IP1, LETT(LET), W1
         CALL LINPRX (0, LITOUT, 25, 5)
      ENDIF
      CALL IITAB4 (IHKL, NCOUNT)
      IPG1(I) = IPG1(I) + 1
      ITAB(NCOUNT+2) = -ITAB(NCOUNT+2)
      MS = MS + 1
      GOTO 350
  340 ITAB(NCOUNT+5) = -ITAB(NCOUNT+5)
  350 ITAB(NCOUNT+6) = I
      NE = 1
      CALL SYMEQ (IHKL, NE)
      ITAB(NCOUNT+4) = NE
      DO 360 I=1,NE
      IADR = ICODE(4,I)
      ISIG = ISIGN(1,IADR)
      IADR = IABS(IADR)
      JSI  = ISHIFT(I) - 1
      ITAB(IADR) = ISIG*(4096*JSI+MR)
      MITAB = MITAB + 1
  360 CONTINUE
  370 CONTINUE
      ILAUE = IILAUE
      IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5)
      WRITE (8, 400) IPG1, IPG2
  400 FORMAT(/' Distribution of reflections in parity groups or equiva',
     *       'lent.', /, ' Group 1 is the seminvariant group', /
     *        16X, '    1    2    3    4    5    6    7    8', /
     *        16X, '   ggg  ugg  gug  uug  ggu  ugu  guu  uuu', /
     *       ' in starting set ', 8I5, /, ' in entire table ', 8I5)
      NPG1 = 0
      NPG2 = 0
      ISIG = 1
      IF (MS .LT. 20) ISIG = 0
      DO 410 IPG=1,8
      IF (IPG2(IPG) .GT. ISIG) NPG2 = NPG2 + 1
      IPG2(IPG) = 0
      IF (IPG1(IPG).LE.ISIG) GOTO 410
      IPG2(IPG) = -1
      NPG1 = NPG1 + 1
  410 CONTINUE
      IF (FLOAT(NPG2)/NPG1 .GT. 1.65) IDC = IDC + 2*IICENT
      NWZ = 100 * NWZ / MR
      IF (IDC.LE.1 .AND. NWZ.GT.40) IDC = IDC + 2*IICENT
      PSQMAX = 0.15
      IF (IPSQ .LT. 0) PSQMAX = 0.0
      IF (IDC.EQ.0 .AND. PSQ.LT.PSQMAX) THEN
         IDC = IICENT*2
         IPSQ = 1
         MAXE1 = MIN0 (NRE1, 1000)
      ENDIF
      IF (IPSQ .EQ. 0) GOTO 470
      MAXE5 = MIN0 (500, NRE1)
      CALL VALDIS (MAXE5, E500, 0., KARR, 100, NRE1)
      MAXE1 = MIN0 (1000, NRE1)
      CALL VALDIS (MAXE1, E1000, 0., KARR, 100, NRE1)
      WRITE (8, 420) NRE1, MAXE5, E500, MAXE1, E1000, E1MAX
  420 FORMAT (' Total number of refl.:           ', I5, /,
     *        ' E1min for', I5, ' strongest refl.:  ', F5.3, /
     *        ' E1min for', I5, ' strongest refl.:  ', F5.3, /
     *        ' E1max:                           ', F5.3)
      VINC = (E1MAX - E1MIN) / 98.
      VSUB = E1MIN - 2.*VINC
      WRITE (8, FMT='(/'' Distribution of E1:''/)')
      DO 425 I= 1, 96, 12
      DO 422 LUTZ = I , I+11
      FKLAD(LUTZ) = VSUB + VINC * FLOAT (LUTZ)
  422 CONTINUE
      WRITE (8, FMT='('' E1 '', 12F5.2)') (FKLAD(J), J=I,I+11)
  425 WRITE (8, FMT='('' NR'', 12I5/)') (KARR(J), J=I,I+11)
      CALL VALDIS (MAXE1, E1MIN, 0., KARR, 100, NRE1)
      WRITE (8, FMT='('' E1min for FOMs for '', I5,
     *                   '' strongest refl.: '', F5.3)') MAXE1, E1MIN
      I100 = MIN0 (MAXE1, 100)
      CALL VALDIS (I100, E1100, 0., KARR, 100, NRE1)
      WRITE (8, FMT='('' E1min for FOMs for '', I5,
     *                   '' strongest refl.: '', F5.3)') I100, E1100
  470 CONTINUE
      IF (IDC .GT. 1) GOTO 490
      DO 480 NCOUNT=MCT,NCT,ICR
      ITAB(NCOUNT+4) = 0
      ITAB(NCOUNT+5) = 0
      ITAB(NCOUNT+6) = 0
  480 IF (ITAB(NCOUNT+2).LT.0) ITAB(NCOUNT+2) = -ITAB(NCOUNT+2)
  490 E2AGE   = (E2AGE   + E2ALE)/(MAX0(1,NGN))
      E2CGE   = (E2CGE   + E2CLE)/(MAX0(1,NSP))
      E2AG(1) = (E2AG(1) + E2ALE)/(MAX0(1,NGN))
      E2CG(1) = (E2CG(1) + E2CLE)/(MAX0(1,NSP))
      CALL DD38
      IF (IDC.LE.1 .OR. IPSQ.EQ.1) RETURN
      WRITE(24, 500)
      WRITE (8, 500)
  500 FORMAT (/, ' ***** Origin fixation *****', /)
      RETURN
      END
      SUBROUTINE DDTAN
      INCLUDE 'Zaaaa.inc'
      LOGICAL SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      EQUIVALENCE (IBINDI, IFILE(15)), (IBINDO, IFILE(13))
      EQUIVALENCE (NBINDU, KEYS(14))
      EQUIVALENCE (ICENT, KEYS(19))
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zbuff.inc'
      EQUIVALENCE (FITDIF(1), HCODE), (FITDIF(2), EL), (FITDIF(3), PL),
     *            (FITDIF(4), WL)
      DIMENSION IHKL(3), HKL(3), E2TOT(7)
      CHARACTER LITOUT *25
      CHARACTER LETT(5) *2
      DATA LETT / '. ', '* ', 'R ', '*R', 'C ' /
      DATA NLINPR / 0 /
      CALL WR24
      WRITE(24, FMT='(/'' Tangent refinement:''/)')
      call wr24
      NC = NC + 1
      DO 200 ICYC=2,NC
      CALL GENER
      CALL STARTS (ICYC)
      E2AG(ICYC) = (E2AG(ICYC) + E2ALE) / (MAX0(1,NGN))
  200 E2CG(ICYC) = (E2CG(ICYC) + E2CLE) / (MAX0(1,NSP))
      CALL FILCLO (IBINDO, 'DELETE')
      CALL BINOFF (1, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      NBINDI = 0
      IF (KORIS .NE. 1) GOTO 220
      DO 210 I=1,3
  210 TO(I) = -TO(I)
      KORIS = 2
      CALL PSEUDO (TO)
  220 IF (SWIPRI) THEN
         WRITE (8, 230)
  230 FORMAT (/ ' The following table gives the final result of the',
     *           ' program PHASEX.', /,
     *     ' The reflections are marked (max. 300 refl. printed):' /
     *     '  *  =  refl. with total phase shift of 90 degrees or more',
     *    /'  R  =  refl. with WS.lt.0.9 (unreliable)', /,
     *      ' ', 5('  H  K  L  EL   PL   WL  ') /)
         NLINPR = 0
         CHOUT = '(5A25)'
         CALL LINPRX (8, LITOUT, 25, 5)
      ENDIF
      IPMIN = 0
      NPMIN = 0
      NCOUNT = MCT - ICR
  240 NCOUNT = NCOUNT + ICR
      IPACK = ITAB(NCOUNT+1)
      CALL XUNPAK (IPACK, IHKL)
      CALL KERI2F (IHKL, HKL, 3)
      LET = 1
      IP1 = ITAB(NCOUNT+4)
      IPS = ITAB(NCOUNT+3)
      EL  = ITAB(NCOUNT+7)/100.
      WS  = ABS (ITAB(NCOUNT+2) * 0.01/EL)
      IF (WS .GT. 1.0) WS = 1.0
      PL = IPS
      IF (IDC .NE. 1) GOTO 260
      PL  = PL / 57.29
      AEL = EL * COS(PL)
      BEL = EL * SIN(PL) * 2.00
      EL  = SQRT(AEL**2 + BEL**2)
      PL  = ATAN2(BEL,AEL) * 57.29
      IF (PL .LT. 0.) PL = PL + 360.
  260 WL = WS
      IF (KORIS .EQ. 2) CALL ORSHIF (HKL, TO, 0., 0., PL, KORIS)
      IF (WS .LT. 0.9) LET = 3
      IF (ITAB(NCOUNT+5) .GE. 0) GOTO 270
      LET = 5
      GOTO 280
  270 IDIF = IABS(IPS-IP1)
      IDIF = MIN0(IDIF, 360-IDIF)
      IF (IDIF .GT. 89) LET = LET + 1
  280 IPS = INT(PL)
      IPMIN = IPMIN + MIN0(IABS(IPS), IABS(IABS(IPS)-180))
      NPMIN = NPMIN + 1
      NBINDI = NBINDI + 1
      CALL HKLC1 (HKL, HCODE)
      CALL BINOFF (0, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      IF (.NOT. SWIPRI) GOTO 290
      IF (SWIPRI .AND. NLINPR.LT.300) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, EL, IPS, LETT(LET), WL
         CALL LINPRX (0, LITOUT, 25, 5)
         ENDIF
  290 IF (NCOUNT .LT. NCT) GOTO 240
      CALL BINOFF (-1, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF)
      IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5)
      call wr24
      WRITE (8, 291) NBINDI
  291 FORMAT (' Number of reflections output to  file BINDIF:', I6)
      IPMIN = IPMIN / NPMIN
      IF (ICENT .EQ. 1) WRITE(8, FMT = '(/
     * '' Average deviation from 0 degrees (or 180 degrees)'' /
     * '' for phases used in PHASEX '', I3  , '' degrees '')')  IPMIN
      NBINDI = NBINDU - NBINDI
      IF (NBINDI .NE. 0) WRITE (8, 292) NBINDI
  292 FORMAT (' Number of reflections skipped by PHASEX:     ', I6)
      IF (KORIS .EQ. 2) write(24, 310)
      IF (KORIS .EQ. 2) WRITE (8, 310)
  310 FORMAT (' ----- Origin shifted back ----'/)
      NTOT  = NGN + NSP
      ANGN  = FLOAT (MAX0(1,NGN))
      ANSP  = FLOAT (MAX0(1,NSP))
      ANTOT = FLOAT (NTOT)
      E2TOTE = (E2AGE*ANGN + E2CGE*ANSP) / ANTOT
      DO 320 I=1,7
  320 E2TOT(I) = (E2AG(I)*ANGN + E2CG(I)*ANSP) / ANTOT
      IF (IDC .EQ. 0) THEN
          write(24, 330) E2TOTE, (I, E2TOT(I), I=1,NC-1)
  330 FORMAT(' Values for average E**2', /
     *       ' a priori expectation values   ', F8.3, /,
     *      (' calculated before cycle', I5, 6X, F13.3))
          WRITE (8, 335) NTOT, E2TOTE, (I, E2TOT(I), I=1,NC-1)
  335 FORMAT(' Values for average E**2 for all (', I5, ') reflections'/
     *       ' a priori expectation values   ', F7.3, /,
     *      (' calculated before cycle', I5, 6X, F13.3))
          IF (IICENT .EQ. 1)
     *    WRITE (8, 340) NGN, NSP, E2AGE, E2CGE,
     *                    (I, E2AG(I), E2CG(I), I=1,NC-1)
  340 FORMAT(' Values for average E**2 for', I5, ' general refl. and',
     *   I4, ' special refl.:' /
     *       ' a priori expectation values   ', F7.3, 19X, F5.3 /
     *      (' calculated before cycle', I5, 6X, F13.3, 12X, F12.3))
        ELSE
          write(24, 350) E2TOTE, E2TOT(1), E2TOT(7),
     *                     (I, E2TOT(I), I=2,NC-1)
  350 FORMAT(' Values for average E**2' /
     *       ' a priori expectation values   ', F7.3 /
     *       ' calculated at start    ',    11X, F13.3 /
     *       ' calculated after symbols',   10X, F13.3 /
     *      (' calculated before cycle', I5, 6X, F13.3))
          WRITE (8, 355) NTOT, E2TOTE, E2TOT(1), E2TOT(7),
     *                     (I, E2TOT(I), I=2,NC-1)
  355 FORMAT(/' Values for average E**2 for all (', I5, ') reflections'/
     *       ' a priori expectation values   ', F7.3 /
     *       ' calculated at start    ',    11X, F13.3 /
     *       ' calculated after symbols',   10X, F13.3 /
     *      (' calculated before cycle', I5, 6X, F13.3))
          IF (IICENT .EQ. 1)
     *    WRITE (8, 360) NGN, NSP, E2AGE, E2CGE, E2AG(1), E2CG(1),
     *           E2AG(7), E2CG(7), (I, E2AG(I), E2CG(I), I=2,NC-1)
  360 FORMAT(' Values for average E**2 for general refl. (', I5,
     *      ') and special refl. (', I4, ')'  /
     *       ' a priori expectation values   ', F7.3, 19X, F5.3 /
     *       ' calculated at start    ',    11X, F13.3, 12X, F12.3 /
     *       ' calculated after symbols',   10X, F13.3, 12X, F12.3 /
     *      (' calculated before cycle', I5, 6X, F13.3, 12X, F12.3))
      ENDIF
      write(24, 370) NC-1, E2TOT(NC)
  370 FORMAT(' calculated after  cycle', I5, 6X, F13.3)
      WRITE (8, 370) NC-1, E2TOT(NC)
      IF (IICENT .EQ. 1) WRITE (8, 380) NC-1, E2AG(NC), E2CG(NC)
  380 FORMAT(' calculated after  cycle', I5, 6X, F13.3, 12X, F12.3)
      call wr24
      RETURN
      END
      SUBROUTINE GENER
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      COMMON /KLAD/ ICODE(4,48), ISHIFT(48)
      COMMON /SINCOS/ IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      DIMENSION  IHKL(3), IHKL3(3),  LHIT(48)
      EQUIVALENCE (IHKL3(1), JJH1), (IHKL3(2), JJH2), (IHKL3(3), JJH3),
     *            (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      DATA K,KTEST / 0, 0/
      ISTR1 = MARKA4 + INCA4 + INCA4
      ISTR2 = MARKA4 + INCA4
      DO 280 I41=ISTR1,ISTO4,INCA4
      IR1 = ITAB(I41+4) + MCT
      IEW1 = ITAB(IR1+2)
      IPH1 = ITAB(IR1+3)
      DO 200 I=1,3
  200 IHKL(I) = ITAB(I41+I)
      NEQ = 2
      CALL SYMEQ (IHKL, NEQ)
      DO 210 I=1,NEQ
      IS2 = ISHIFT(I)
      ISHIFT(I) = IPH1 + IDEG(IS2)
  210 ISHIFT(I+NEQ) = -ISHIFT(I)
      ISTOP = I41 - INCA4
      NEQ2 = NEQ * 2
      DO 270 I42=ISTR2,ISTOP,INCA4
      JH1 = ITAB(I42+1)
      JH2 = ITAB(I42+2)
      JH3 = ITAB(I42+3)
      IR2 = ITAB(I42+4) + MCT
      IPH2 = ITAB(IR2+3)
      IWEE = IEW1 * ITAB(IR2+2)
      J = ITAB(IR2+1)
      NHIT = 0
      DO 260 I11=1,NEQ2
      IF (MCTLAT .GT. 1) GOTO 220
      I = ICODE (4, I11)
      KTEST = I + J
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 260
      IF (K .GT. MCT) GOTO 260
      IF (ITAB(K) .EQ. 0) GOTO 260
  220 JJH1 = ICODE(1,I11) + JH1
      IF (IABS(JJH1) .GT. MAXH) GOTO 260
      JJH2 = ICODE(2,I11) + JH2
      IF (IABS(JJH2) .GT. MAXK) GOTO 260
      JJH3 = ICODE(3,I11) + JH3
      IF (IABS(JJH3) .GT. MAXL) GOTO 260
      IF (MCTLAT .EQ. 1) GOTO 230
      KTEST = INPACK(IHKL3)
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 260
      IF (ITAB(K) .EQ. 0) GOTO 260
  230 K = ITAB(K)
      LTEST = IABS(K)
      L = LTEST / 4096
      IR3 = (LTEST-L*4096-1)*ICR + MCT
      IF (IR3.EQ.IR2 .OR. IR3.EQ.IR1) GOTO 260
      IF (NHIT .EQ. 0) GOTO 250
      DO 240 IHIT=1,NHIT
      IF (IR3 .EQ. LHIT(IHIT)) GOTO 260
  240 CONTINUE
  250 NHIT = NHIT + 1
      LHIT(NHIT) = IR3
      L = L + 1
      IPH3 = ISIGN(1,K)*ISIGN(1,KTEST)*(ISHIFT(I11)+IPH2) - IDEG(L)
      IPH3 = MOD(IPH3,360)
      IF (IPH3 .LE. 0) IPH3 = IPH3 + 360
      IF (ITAB(IR3+6) .GT. 32000) GOTO 260
      ITAB(IR3+4) = ITAB(IR3+4) + IWEE*ISCT(450-IPH3)/1000000
      ITAB(IR3+5) = ITAB(IR3+5) + IWEE*ISCT(IPH3)/1000000
      ITAB(IR3+6) = ITAB(IR3+6) + IWEE/1000
  260 CONTINUE
  270 CONTINUE
  280 CONTINUE
      RETURN
      END
      SUBROUTINE STARTS (ICYC)
      INCLUDE 'Zaaaa.inc'
      LOGICAL SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      EQUIVALENCE (IBINDO, IFILE(13))
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zbuff.inc'
      CHARACTER LITOUT *38
      DIMENSION  IHKL(3)
      COMMON /EPWCO/ IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE
      DATA NLINPR / 0 /
      CALL WR24
      NITDOP = 9
      CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      ISTO4 = MARKA4
      LLMAX = MAXA4 - INCA4
      NSPEC = 0
      NGEN = 0
      NFLIP = 0
      NSHIFT = 0
      XNUM = 0.0
      XDEN = 0.0
      IIASUM = 0
      IISSUM = 0
      IIASN = 0
      JCYC = ICYC - 1
      IF (.NOT. SWIPRI) GOTO 210
      WRITE (8, 200) JCYC
  200 FORMAT (/, ' In cycle ', I2, ' the following reflections had',
     *           ' shifts of more than 45 degress',
     *           ' (max. 100 refl. printed):', //
     *        3 ('  H  K  L Eold Enew Pold Pnew  Wnew   '), /)
      NLINPR = 0
      CHOUT = '(3A38)'
      CALL LINPRX (8, LITOUT, 38, 3)
  210 DO 310 NCOUNT=MCT,NCT,ICR
      CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (KENDOP .LT. 0) GOTO 320
      CALL KERF2I (FITDOP(1), IHKL(1), 3)
      E1 = FITDOP(4)
      EL = E1
      E2 = FITDOP(5)
      IP1 = NINT(FITDOP(6))
      IPHS = IP1
      W1 = FITDOP(7)
      IT = NINT(FITDOP(8))
      IREST = NINT(FITDOP(9))
      EOLD = ITAB(NCOUNT+7) / 100.0
      EWOLD = ITAB(NCOUNT+2) / 100.0
      WOLD = EWOLD / EOLD
      IPHO = ITAB(NCOUNT+3)
      ICS4 = ITAB(NCOUNT+4)
      ICS5 = ITAB(NCOUNT+5)
      ICS6 = ITAB(NCOUNT+6)
      IF (ICS4.EQ.0 .AND. ICS5.EQ.0 .AND. ICS6.EQ.0) THEN
          IDABS = 0
          EL = EOLD
          WS = WOLD
          IPHS = IPHO
          GOTO 265
      ENDIF
      XEE = EOLD / 10.
      AEE = ITAB(NCOUNT+4) * XEE
      BEE = ITAB(NCOUNT+5) * XEE
      FEE = ITAB(NCOUNT+6) * XEE
      EEE = SQRT(AEE*AEE + BEE*BEE)
      XNUM = XNUM + EEE
      XDEN = XDEN + FEE
      WS = (TANH(EEE/E000R))**2
      IF (EEE.LT.0.01 .OR. WS.LT.0.01) GOTO 260
      PHS = 57.29 * ATAN2(BEE,AEE)
      IF (PHS .LT. 0.) PHS = PHS + 360.
      IPHS = PHS + 0.5
      IF (IT.GT.1 .OR. WOLD.LT.0.1) GOTO 250
      IF (IDC3.EQ.1 .OR. (180-IPHO)*(180-IPHS).GT.0)  GOTO 220
      IF (MIN0(IPHS, 360-IPHS, IABS(180-IPHS)).GT.30) GOTO 250
      IPHS = 180 * MOD((IPHS+90)/180, 2)
      IF (IPHS.EQ.0 .AND. IPHO.GT.180) IPHS = 358
  220 CALL PHDIF (IPHS, IPHO, II, IIA)
      IF (PSQ .LT. 0.20)
     * IPHS=MOD(360+IPHO+ISIGN(MIN0(IIA,MAX1(47.,80.-10.*WOLD)),II),360)
      IF (IDC3 .EQ. 1) GOTO 250
      IIS = MIN0 (IPHS, 360-IPHS)
      IF (IDC3 .EQ. 2) IIS = MIN0 (IIS, IABS(180-IPHS))
      IIA = MIN0 (IPHO, 360-IPHO)
      IF (IDC3 .EQ. 2) IIA = MIN0 (IIA, IABS(180-IPHO))
      IIASUM = IIASUM + IIA
      IISSUM = IISSUM + IIS
      IIASN = IIASN + 1
      IF (IIS.GE.IIA .OR. IIS.GE.45) GOTO 250
      IF (IISSUM/IIASN .LT. 35) IPHS = ((IPHS+IPHO)/180) * 90 + 45
      IF (IIA .GT. 45) GOTO 250
      IF (IIA .LT. 20) GOTO 240
      IPHS = (IPHO+IPHS) / 2
      GOTO 250
  240 IPHS = IPHO + ISIGN(15, 90 - MOD(IPHO,180))
  250 CALL EPW
  260 CALL PHDIF (IPHS, IPHO, IDIF, IDABS)
      IF (WOLD .LT. 0.1) IDABS = 0
  265 IF (IT .GT. 1) GOTO 270
      NGEN = NGEN + 1
      NSHIFT = NSHIFT + IDABS
      E2AG(ICYC) = E2AG(ICYC) + EL*EL
      GOTO 280
  270 IF (IDABS .GT. 90) NFLIP = NFLIP + 1
      NSPEC = NSPEC + 1
      E2CG(ICYC) = E2CG(ICYC) + EL*EL
  280 IF (IDABS.LT.45 .OR. .NOT.SWIPRI) GOTO 290
      IF (SWIPRI .AND. NLINPR.LT.100) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, 2F5.2, 2(I4,''.''), F6.3, 2X)')
     *                        IHKL, EOLD, EL, IPHO, IPHS, WS
         CALL LINPRX (0, LITOUT, 38, 3)
      ENDIF
  290 ITAB(NCOUNT+2) = 100.0*EL*AMAX1(W1,WS) + 0.5
      ITAB(NCOUNT+3) = IPHS
      ITAB(NCOUNT+4) = 0
      ITAB(NCOUNT+5) = 0
      ITAB(NCOUNT+6) = 0
      ITAB(NCOUNT+7) = 100.*EL + 0.5
      IF (ICYC .LT. NC) GOTO 300
      ITAB(NCOUNT+4) = IP1
      ITAB(NCOUNT+5) = IREST
  300 IF (EL .LT. ESTART(ICYC)) GOTO 310
      IF (ISTO4 .GT. LLMAX) GOTO 310
      CALL IITAB4 (IHKL, NCOUNT)
  310 CONTINUE
  320 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 38, 3)
      IF (ISTO4 .GT. LLMAX) WRITE(24, 330) ICYC
  330 FORMAT(' **** WARNING: the basic set for cycle', I2,
     *       ' is not complete; table ITAB is too small')
      MS = (ISTO4-MARKA4) / INCA4
      IF (NGEN .GT. 0) NSHIFT = FLOAT(NSHIFT)/NGEN + .5
      IF (IICENT .EQ. 1) THEN
         WRITE (8, 340) JCYC, NGEN, NSHIFT, NFLIP, NSPEC
  340    FORMAT (' Statistics for cycle ', I3, ':', /,
     *        I5, ' general reflections gave average phase shift of ',
     *        I4, ' degrees', /, I5, ' special reflections out of',
     *        ' a total of', I5, '  shifted by 180 degrees')
      ELSE
         WRITE (8, 342) JCYC, NFLIP, NSPEC
  342    FORMAT (' Statistics for cycle ', I3, ':', /,
     *         I5, ' reflections out of a total of',
     *         I5, '  gave a phase shift of 180 degrees')
         ENDIF
      IF (XDEN .LT. 0.00001) GOTO 355
      XDEN = XNUM / XDEN
      WRITE(24, FMT='('' Cycle'', I3, '': Sigma2 - consistency  '',
     *                   F6.3)') JCYC, XDEN
      WRITE (8, FMT='('' Sigma2 - consistency: '', F6.3)') XDEN
  355 IF (IDC3 .EQ. 1) GOTO 370
      IIASN  = MAX0 (1, IIASN)
      IIASUM = IIASUM / IIASN
      IISSUM = IISSUM / IIASN
      WRITE (8, 360) IIASUM, IISSUM
  360 FORMAT (/' Average deviation from 0 degrees (or 180 degrees)' /
     *        ' for phases used in the last cycle: ', I3  , ' degrees '/
     *        ' for new phases (before resetting): ', I3  , ' degrees ')
  370 CONTINUE
      IF (ICYC .LT. NC) WRITE (8, 380) MS, ICYC
  380 FORMAT(/' There are', I5, ' reflections in the basic set',
     *             ' for cycle', I3)
      RETURN
      END
      SUBROUTINE ORSHIF (HKL, TO, P1, P2, PL, KORIS)
      DIMENSION HKL(3), TO(3)
      PHT = 0.0
      DO 110 I=1,3
  110 PHT = PHT + TO(I)*HKL(I)
      PHT = AMOD(PHT,1.) * 360.
      IF (PHT .LT. 0.0) PHT = PHT + 360.
      IF (KORIS .NE. 1) GOTO 120
      P1 = P1 - PHT
      P2 = P2 - PHT
      IF (P1 .LT. 0.0) P1 = P1 + 360.
      IF (P2 .LT. 0.0) P2 = P2 + 360.
      GOTO 130
  120 PL = PL - PHT
      IF (PL .LT. 0.0) PL = PL + 360.
  130 RETURN
      END
      SUBROUTINE PSEUDO (TO)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL EXPAND
      EQUIVALENCE   (EXPAND, SWITCH(23))
      DIMENSION  TO(3), RSYMM(3,3,24)
      NNSYMM = NSYMM
      IF (EXPAND) NNSYMM = 1
      CALL KERI2F (IRSYMM, RSYMM, 9*NNSYMM)
      DO 130 K=1,NNSYMM
      DO 130 I=1,3
      TMA = 0.0
      DO 120 J=1,3
  120 TMA = TMA + RSYMM(I,J,K)*TO(J)
  130 TSYMM(I,K) = TMA + TSYMM(I,K) - TO(I)
      RETURN
      END
      SUBROUTINE IITAB4 (IHKL, K)
      DIMENSION IHKL(3)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      ISTO4 = ISTO4 + INCA4
      ITAB(ISTO4+1) = IHKL(1)
      ITAB(ISTO4+2) = IHKL(2)
      ITAB(ISTO4+3) = IHKL(3)
      ITAB(ISTO4+4) = K - MCT
      RETURN
      END
      INTEGER FUNCTION INPACK (I)
      DIMENSION I(3)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      IF (MCTLAT .GT. 1) GOTO 100
      INPACK = MCH*I(1) + MCK*I(2) + I(3)
      RETURN
  100 K2 = I(2)
      K3 = I(3)
      GOTO (1,  2,  2,  4,  2,  6,  7  ), MCTLAT
    2 IF (K3 .NE. 0) K3 = (K3 + ISIGN(1,K3))/2
      GOTO 1
    6 IF (K2 .NE. 0) K2 = (K2 + ISIGN(1,K2))/2
      GOTO 2
    7 IF (K3 .NE. 0) K3 = (K3 + ISIGN(2,K3))/3
      GOTO 1
    4 IF (K2 .NE. 0) K2 = (K2 + ISIGN(1,K2))/2
    1 INPACK = MCH*I(1) + MCK*K2 + K3
      RETURN
      END
      SUBROUTINE XUNPAK (IPACK, IHKL)
      DIMENSION IHKL(3)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      I1 = IPACK + MCT
      I2 = I1 / MCH
      IHKL(1) = I2 - MAXH
      I1 = I1 - I2*MCH
      I2 = I1 / MCK
      IHKL(2) = I2 - I34
      IHKL(3) = I1 - I2*MCK - I35
      GOTO (9,  2,  3,  4,  5,  7,  6  ), MCTLAT
    2 KH = IABS(IHKL(2))
      GOTO 110
    3 KH = IABS(IHKL(1))
      GOTO 110
    5 KH = IABS(IHKL(1)+IHKL(2))
  110 IF (IHKL(3) .NE. 0) IHKL(3) = 2*IHKL(3) - ISIGN(MOD(KH,2),IHKL(3))
      GOTO 9
    7 KH = IHKL(3)*3
      GOTO (120, 9, 130), KH
  120 IHKL(3) = KH + MOD(300+IHKL(1)-IHKL(2),3)
      GOTO 9
  130 IHKL(3) = KH - MOD(300-IHKL(1)+IHKL(2),3)
      GOTO 9
    6 KH = IABS(IHKL(1))
      IF (IHKL(3) .NE. 0) IHKL(3) = 2*IHKL(3) - ISIGN(MOD(KH,2),IHKL(3))
    4 KH = IABS(IHKL(1))
      IF (IHKL(2) .NE. 0) IHKL(2) = 2*IHKL(2) - ISIGN(MOD(KH,2),IHKL(2))
    9 RETURN
      END
      FUNCTION IGROUP (IHKL)
      INCLUDE 'Zcrys.inc'
      DIMENSION IHKL(3), ICODE(24)
      DATA ICODE / 1,2,3,4,3,4,1,2,1,2,3,4,2,1,4,3,1,2,2,1,3,4,4,3 /
      IGROUP = 0
      DO 100 I=1,3
  100 IGROUP = IGROUP + IABS(MOD(IHKL(I),2))*2 **I
      IGROUP = IGROUP/2 +1
      GOTO (3, 3, 3, 2, 2, 5, 5, 4, 4, 4, 4, 4, 5, 5), ILAUE
    2 I = 8*(IUNIQ-1) + IGROUP
      IGROUP = ICODE(I)
    3 RETURN
    4 IGROUP = IABS(MOD(IHKL(IUNIQ),2)) +1
      RETURN
    5 IGROUP = 0
      DO 110 I=1,3
  110 IGROUP = IGROUP + IHKL(I)
      IGROUP = IABS(MOD(IGROUP,2)) + 1
      RETURN
      END
      SUBROUTINE SYMEQ (IHKL, N)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL EXPAND
      EQUIVALENCE   (EXPAND, SWITCH(23))
      INCLUDE 'Zdifta.inc'
      COMMON /KLAD/ IC(4,48), IS(48)
      DIMENSION ICODE(13), IHKL(3), ITEMP(24)
      DATA ICODE / 1, 0, 2, 3, 4, 0, 5, 0, 6, 7, 8, 0, 1 /
      NNSYMM = NSYMM
      IF (EXPAND) NNSYMM = 1
      M = N
      N = 1
      CALL KERNZI (0, ITEMP, 24)
      DO 150 I=1,NNSYMM
      XTEST = 0.0
      DO 120 K=1,3
      IC(K,N) = 0
      DO 110 L=1,3
  110 IC(K,N) = IC(K,N) + IHKL(L)*IRSYMM(L,K,I)
  120 XTEST = XTEST - IHKL(K)*TSYMM(K,I)
      IC(4,N) = INPACK(IC(1,N))
      ITEMP(N) = IABS(IC(4,N))
      IF (N.EQ.1) GOTO 140
      K = N - 1
      DO 130 L=1,K
  130 IF (ITEMP(L) .EQ. ITEMP(N)) GOTO 150
  140 XTEST = XTEST - IFIX(XTEST)
      IF (XTEST .LT. -0.01) XTEST = XTEST + 1.0
      J = IFIX(12.*XTEST+0.01) + 1
      IS(N) = ICODE(J)
      N = N + 1
  150 CONTINUE
      N = N - 1
      IF (M .EQ. 1) GOTO 170
      DO 160 J=1,N
      DO 160 I=1,4
  160 IC(I,J+N) = -IC(I,J)
  170 RETURN
      END
      SUBROUTINE DD38
      COMMON /SINCOS/ IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      IDEG(1) = 0
      IDEG(2) = 60
      IDEG(3) = 90
      IDEG(4) = 120
      IDEG(5) = 180
      IDEG(6) = 240
      IDEG(7) = 270
      IDEG(8) = 300
      P = 0.0
      DO 100 I=1,90
      P = P + 0.0174532925
      IP = SIN(P)*1000. + 0.5
      ISCT(I) = IP
      ISCT(180-I) = IP
      ISCT(180+I) = -IP
      ISCT(360-I) = -IP
      ISCT(360+I) = IP
  100 CONTINUE
      ISCT(360) = 0
      ISCT(180) = 0
      RETURN
      END
      SUBROUTINE PHDIF (IPHS, IP, IDIF, IDABS)
      IDIF = IPHS-IP
      IF (IDIF .LT. -179) IDIF = IDIF + 360
      IF (IDIF .GT.  180) IDIF = IDIF - 360
      IDABS = IABS(IDIF)
      RETURN
      END
      SUBROUTINE EPW
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      COMMON /EPWCO/ IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE
      CALL PHDIF (IPHS, IP1, IDIF, IDABS)
      IF (IREST .LT. 100) GOTO 220
      IF (IT .EQ. 1) GOTO 200
      EEE = ABS (EEE * COS(IDIF/57.29))
      WS = TANH (EEE/E000R)**2
      IDIF = 0
      IF (WS.LT.W1 .OR. EEE.LT.0.01) GOTO 250
      IF (IDABS .LT. 90) GOTO 250
      IDIF = 180
      EL = E2
      GOTO 250
  200 IF (IDIF .EQ. 0) GOTO 250
      IF (W1 .LT. 0.1) GOTO 210
      IF (WS .LT. W1) IDIF = IDIF*WS/W1 + 0.5
  210 COSD = COS(IDIF/57.29) * (E2-E1)
      EL = 0.5 * ABS(COSD - SQRT(COSD**2+4.*E1*E2))
      GOTO 250
  220 IF (IT .NE. 1) GOTO 240
      IF (IDABS .LT. IREST) GOTO 230
      IDIF = ISIGN (IREST,IDIF)
      EEE = ABS (EEE * COS((IDABS-IREST)/57.29))
      WS = TANH (EEE/E000R)**2
      IF (WS.LT.W1 .OR. EEE.LT.0.01) GOTO 240
      EL = SQRT (E1*E2)
      GOTO 250
  230 IF (IDIF .EQ. 0) GOTO 260
      IF (WS .LT. W1) GOTO 240
      COSD = COS (IDIF/57.29) * (E2+E1)
      EL = 0.5 * ABS (COSD - SQRT(COSD**2-4.*E1*E2))
      GOTO 250
  240 IDIF = 0
  250 IPHS = IP1 + IDIF
      IF (IPHS .GE. 360) IPHS = IPHS - 360
      IF (IPHS .LT. 0)   IPHS = IPHS + 360
  260 CONTINUE
      RETURN
      END
      SUBROUTINE LOCCEN (KEY, CENTER)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      DIMENSION CENTER(3)
      LOGICAL EXPAND
      EQUIVALENCE   (EXPAND, SWITCH(23))
      EQUIVALENCE (IATOMS, IFILE(1))
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zatomx.inc'
      COMMON /LOCPC1/
     *          XY(3,400), NIZ(400), NDEL(400), SYMXYZ(3),
     *          DLIM(6), CEN2(3)
      CALL WR24
      IF (KEY .GT. 0) RETURN
      IF (IICENT .EQ. 2) RETURN
      NSLOC = NSYMM
      IF (EXPAND) NSLOC = 1
      IF (NSLOC .NE. NSYMM) THEN
         WRITE (8, 200)
  200    FORMAT (/' Search for LOCCEN in triclinic symmetry:' /
     *       ' Results correct only after execution of program EXPAND')
      ELSE
         WRITE (8, 210)
  210    FORMAT (/' Search for LOCCEN (symm.center in model struct.?))')
         ENDIF
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('No ATOMS file found', 0, 'LOCCEN')
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL FILCLO (IATOMS, 'KEEP')
      N = NAT * NSLOC * NLATT
      IF (N .LE. 400) GOTO 260
      WRITE(24, 240) N
      WRITE (8, 240) N
  240 FORMAT (' No search for LOCCEN: too many atoms in the unit cell'/
     *        ' Allowed: maximum 400 , input (symmetry inluded):', I5  /
     *        ' If enantiomorph problem: do supply a LOCCEN card')
      RETURN
  260 DO 270 I=1,3
      DLIM(I) = 0.20 / CELL(I)
  270 DLIM(I+3) = 1.0 - DLIM(I)
      K = 1
      DO 320 LA=1,NAT
      DO 320 LL=1,NLATT
      DO 320 LS=1,NSLOC
      DO 280  I=1,3
      XY(I,K) = TSYMM(I,LS) + TLATT(I,LL)
      DO 280  J=1,3
  280 XY(I,K) = XY(I,K) + ATXYZ(J,LA)*IRSYMM(I,J,LS)
      DO 310  I=1,3
  290 IF (XY(I,K) .GT. 0.5) GOTO 300
      IF (XY(I,K) .GT. -.5) GOTO 310
      XY(I,K) = XY(I,K) + 1.0
      GOTO 290
  300 XY(I,K) = XY(I,K) - 1.0
      GOTO 290
  310 CONTINUE
      NIZ(K) = IZAT(LA)
  320 K = K + 1
      DO 410 L=1,N
      IF (IABS(NIZ(1)-NIZ(L)) .GT. 2) GOTO 410
      DO 340 I=1,3
      CEN2(I) = XY(I,1) + XY(I,L)
      IF (CEN2(I) .GT. 0.7) CEN2(I) = CEN2(I) - 1.0
      IF (CEN2(I) .LE. -.3) CEN2(I) = CEN2(I) + 1.0
  340 CENTER(I) = CEN2(I)
      J = 2
      CALL KERNZI (0, NDEL, N)
      NDEL(1) = 1
      NDEL(L) = 1
      DO 390 LC=1,N
      IF (NDEL(LC) .EQ. 1) GOTO 390
      DO 350 I=1,3
  350 SYMXYZ(I) = CEN2(I) - XY(I,LC)
      DO 380 LR=1,N
      IF (NDEL(LR) .EQ. 1) GOTO 380
      IF (IABS(NIZ(LR)-NIZ(LC)) .GT. 2) GOTO 380
      DO 360 I=1,3
      DIST = ABS(SYMXYZ(I) - XY(I,LR))
      IF (DIST.GT.DLIM(I) .AND. DIST.LT.DLIM(I+3)) GOTO 380
  360 CONTINUE
      J = J + 2
      DO 370 I = 1,3
      DIST = XY(I,LC) + XY(I,LR)
      IF (DIST-CEN2(I) .LT. -.1) DIST = DIST + 1.0
      IF (DIST-CEN2(I) .GT. 0.1) DIST = DIST - 1.0
  370 CENTER(I) = CENTER(I) + DIST
      NDEL(LC) = 1
      NDEL(LR) = 1
      GOTO 390
  380 CONTINUE
      GOTO 410
  390 CONTINUE
      DO 400 I=1,3
  400 CENTER(I) = CENTER(I) / J
      GOTO 430
  410 CONTINUE
      WRITE (8, 420)
  420 FORMAT (' No center of symmetry found')
      RETURN
  430 WRITE(24, 440) (CENTER(I), I=1,3)
  440 FORMAT (' Center of symmetry found at ', 3F7.4)
      KEY = 1
      RETURN
      END
      SUBROUTINE LINPRX (KEY, LITOUT, LOUT, NIT)
      CHARACTER LITOUT *(*)
      INCLUDE 'Zsyst.inc'
      CHARACTER PRFORM *72
      PARAMETER (MAXLIN = 20, MAXCHA = 100)
      CHARACTER LITLIN(MAXLIN) *100
      DATA LITNIT, NITMAX, IPR / 0, 0, 0/
      CALL WR24
      IF (KEY) 230, 220, 200
  200 IPR = KEY
      PRFORM = CHOUT
      CHOUT = ' '
      NITMAX = NIT
      IF (NITMAX .GT. MAXLIN) CALL KERNER (4, 'LINPRX')
      IF (LOUT .GT. MAXCHA) CALL KERNER (4, 'LINPRX')
  210 CONTINUE
         DO 211 I = 1, NIT
  211    LITLIN(I) = ' '
      LITNIT = 0
      RETURN
  220 IF (LITNIT+1 .GT. NITMAX) THEN
         WRITE (IPR, FMT=PRFORM) (LITLIN(ILIT), ILIT=1,LITNIT)
         DO 221 I = 1, NITMAX
  221    LITLIN(I) = ' '
         LITNIT = 0
         ENDIF
      LITNIT = LITNIT + 1
      LITLIN(LITNIT) = LITOUT
      RETURN
  230 IF (LITNIT .GT. 0)
     *    WRITE (IPR, FMT=PRFORM) (LITLIN(ILIT), ILIT=1,LITNIT)
      GOTO 210
      END
      SUBROUTINE DACOP
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLADC/ CHAR(12)
      CHARACTER CHARR(12) *1, CHAR *1
      DATA CHARR / 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
     *             '-', ' '/
      CALL WR24
      DO 110 I=1,5*ISIZ5
  110 ITAB5(I) = 0
      INCA5 = 5
      DO 120 I=1,12
  120 CHAR(I) = CHARR(I)
      II = (MAXA4-ISTO4) / 50
      I = MS
      IF (IDC.EQ.1 .AND. I.GT.200) I = 100 + I/2
      MAXA4N = MARKA4 + I*INCA4
      I5 = I / 2
      I5 = MIN0(I5,II,MAXT) + 14
      MAXT = MIN0(I5,MAXT)
      IF (MS .LT. 500) I5 = 500 - MS
      MAXA4 = MAXA4N +  I5 * INCA4
      WRITE (8, FMT='('' Limitations:'')')
      IF (IDC .EQ. 1) WRITE (8, 140) I
  140 FORMAT (' New basic set with numeric phases: ', I5)
      WRITE (8, 150) I5, II
  150 FORMAT (' in basic set with symbolic phases: ', I5/
     *        ' maximum number of symbolic phases: ', I5)
      RETURN
      END
      SUBROUTINE DAMAIN
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      DIMENSION KPGE(8), KPG(8), IDUMMY(10)
      CALL WR24
      CALL REDSYM (-1, IDUMMY, 0)
      JSYMB = 0
      JOLD  = 0
      JSMAX = 10
      IF (IPSQ .EQ. 1) JSMAX = 15
      DO 210 K=MCT,NCT,ICR
      IF (ITAB(K+2) .GE. 0) GOTO 200
      ITAB(K+4) = -(1000.*ITAB(K+2)) / ITAB(K+7)
      GOTO 210
  200 WNE = ITAB(K+4)
      ITAB(K+4) = SQRT(WNE) * (ITAB(K+7)-ITAB(K+2))
  210 CONTINUE
      ISTA4 = ISTO4 + INCA4
      ISTO5 = 0
      WRITE (8, 220)
  220 FORMAT (' Ambiguity choices', /, 5X, 'H   K   L    E1  Symbol')
      DO 270 KK=1,2
  230 CALL KERNZI (0, KPGE(1), 8)
      CALL KERNZI (0,  KPG(1), 8)
      KTEST = 0
      DO 240 K=MCT,NCT,ICR
      IF (IPSQ.EQ.1 .AND. IICENT.EQ.1 .AND. ITAB(K+5).NE.-1) GOTO 240
      IF (ITAB(K+2).LT.0 .OR. ITAB(K+6).LT.0) GOTO 240
      IF (IPSQ.EQ.0 .AND. ITAB(K+2).GT.2 .AND. KK.EQ.2) GOTO 240
      IPG = ITAB(K+6)
      IF (IPG2(IPG).LT.0 .AND. KK.EQ.1) GOTO 240
      IF (ITAB(K+4) .LE. KPGE(IPG)) GOTO 240
      KPGE(IPG) = ITAB(K+4)
      KPG(IPG)  = K
      KTEST = KTEST + 1
  240 CONTINUE
      DO 250 IPG=1,8
      IF (KPG(IPG) .LE. 0) GOTO 250
      K = KPG(IPG)
      IF (IICENT.EQ.2 .OR. ITAB(K+5).EQ.-1) CALL DACAS (K)
      IF (ITAB(K+7) .GT. 0) ITAB(K+6) = -1
      IF (JSYMB .EQ. JSMAX) GOTO 280
  250 CONTINUE
      IF (JOLD .EQ. JSYMB) GOTO 260
      JOLD = JSYMB
      GOTO 230
  260 IF (JSYMB .GT. 0) GOTO 280
      IF (KTEST.EQ.0 .AND. KK.EQ.2) GOTO 275
  270 CONTINUE
  275 IF (JSYMB .EQ. 0) GOTO 300
  280 IF (JSYMB .GT. 10) JSYMB = 10
      DO 290 K=MCT,NCT,ICR
      IF (ITAB(K+7) .GT. 0) ITAB(K+6) = 0
      IF (ITAB(K+2) .GT. 0) ITAB(K+4) = 0
  290 CONTINUE
  300 IF (JSYMB .EQ. 0) CALL KERROR ('No symbols', 0, 'DAMAIN')
      WRITE(24, 310) JSYMB
      WRITE (8, 310) JSYMB
  310 FORMAT (' Number of ambiguity symbolic choices (primary',
     *        ' set):', I6)
      RETURN
      END
      SUBROUTINE DACAS (K)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLADC/ CHAR(12)
      CHARACTER CHAR *1
      DIMENSION IHKL(3), ISTOR(10)
      IPACK = ITAB(K+1)
      CALL XUNPAK (IPACK, IHKL)
      E1 = ITAB(K+7) / 100.
      IF (JSYMB .LT. 2) GOTO 200
      CALL GENERB (IHKL, K, ISW)
      IF (ISW .EQ. -1) RETURN
  200 IF (IPSQ .EQ. 0) GOTO 220
      EW = ITAB(K+2) / 100.
      W1 = EW / E1
      DO 210 I7=1,7
  210 ISTOR(I7) = ITAB(K+I7)
      ISTOR(4) = W1
      CALL KERNAI (IHKL, ISTOR(8), 3)
      CALL REDSYM (0, ISTOR, K)
  220 JSYMB = JSYMB + 1
      IF (JSYMB .GT .10) RETURN
      CALL IITAB4 (IHKL, K)
      ITAB(K+7) = -ITAB(K+7)
      ITAB(K+2) =  ITAB(K+7)
      ITAB(K+3) = 0
      ITAB(K+4) = 1000
      ISTO5 = ISTO5 + INCA5
      ITAB(K+6)  = ISTO5 / 5
      ITAB5(ISTO5+1) = 32767
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = JSYMB
      IF (IDC .EQ. 1) GOTO 240
      WRITE (8, 230) IHKL, E1, CHAR(JSYMB)
  230 FORMAT (2X, 3I4, F7.2, 4X, A1, I8)
      RETURN
  240 WRITE (8, 230) IHKL, E1, CHAR(JSYMB), ITAB(K+5)
      RETURN
      END
      SUBROUTINE GENERB (IHKL, IR1, ISW)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLAD/ ICODE(4,48), ISHIFT(48)
      DIMENSION IHKL(3), IHKL3(3)
      EQUIVALENCE (IHKL3(1), JJH1), (IHKL3(2), JJH2), (IHKL3(3), JJH3)
      EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL)
      DATA K / 0 /
      NEQ = 2
      CALL SYMEQ (IHKL, NEQ)
      NEQ2 = NEQ * 2
      DO 240 I42=ISTA4,ISTO4,INCA4
      JH1 = ITAB(I42+1)
      JH2 = ITAB(I42+2)
      JH3 = ITAB(I42+3)
      IR2 = ITAB(I42+4) + MCT
      J = ITAB(IR2+1)
      DO 230 I11=1,NEQ2
      IF (MCTLAT .GT. 1) GOTO 200
      I = ICODE(4,I11)
      KTEST = I + J
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 230
      IF (K .GT. MCT) GOTO 230
      IF (ITAB(K) .EQ. 0) GOTO 230
  200 JJH1 = ICODE(1,I11) + JH1
      IF (IABS(JJH1) .GT. MAXH) GOTO 230
      JJH2 = ICODE(2,I11) + JH2
      IF (IABS(JJH2) .GT. MAXK) GOTO 230
      JJH3 = ICODE(3,I11) + JH3
      IF (IABS(JJH3) .GT. MAXL) GOTO 230
      IF (MCTLAT .EQ. 1) GOTO 210
      KTEST = INPACK(IHKL3)
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 230
      IF (ITAB(K) .EQ. 0) GOTO 230
  210 K = ITAB(K)
      LTEST = IABS(K)
      L = LTEST / 4096
      IR3 = (LTEST-L*4096-1)*ICR + MCT
      IF (IR3 .EQ. IR1) GOTO 250
      IR3 = IR3 - MCT
      DO 220 I=ISTA4,ISTO4,INCA4
      IRB = ITAB(I+4)
      IF(IR3 .EQ. IRB) GOTO 250
  220 CONTINUE
  230 CONTINUE
  240 CONTINUE
      ISW = 0
      RETURN
  250 ISW = -1
      RETURN
      END
      SUBROUTINE DCMAIN
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      LOGICAL SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      EQUIVALENCE (IBINDO, IFILE(13))
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      DIMENSION IHKL(3), KARR(100)
      DIMENSION CC(25), ICC(25), IB(25)
      CHARACTER LITOUT *32
      CALL KERNZA (0., CC, 25)
      CALL KERNZI (0, ICC, 25)
      CALL WR24
      CALL GENER
      NAVG = 0
      CAVG = 0.0
      NAVG2 = 0
      CAVG2 = 0.0
      CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      DO 240 K=MCT,NCT,ICR
      CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (KENDOP .LT. 0) GOTO 250
      E1     = FITDOP(4)
      W1     = FITDOP(7)
      IT     = FITDOP(8)
      PHREST = FITDOP(9)
      AEE = ITAB(K+4)
      BEE = ITAB(K+5)
      SEE = ITAB(K+6)
      ITAB(K+4) = W1 * 1000.
      ITAB(K+5) = 0
      ITAB(K+6) = 0
      IF (IT .GT. 1) GOTO 230
      IF (PHREST.LT.150. .OR. E1.GT.3.999) GOTO 240
      IF (W1 .LT. 0.16) GOTO 200
      IP1 = ITAB(K+3)
      IP1 = MOD(IP1,180)
      CALL PHDIF (IP1, 90, IDIF, IDABS)
      IF (IDABS .GT. 45) GOTO 200
      ITAB(K+4) = ITAB(K+4) + 1000
      GOTO 240
  200 EEE = SQRT(AEE*AEE+BEE*BEE)
      IF (EEE .LT. 1.) EEE = 1.
      QEE = SEE / EEE
      IF (QEE .GT. 5.) QEE = 5.
      C = QEE * E1 * (SEE-EEE)/10.
      NAVG = NAVG + 1
      IF (C .GT. 32767.) C = 32767.
      CAVG = CAVG + C
      IF (C .LT. 1.) GOTO 240
      ITAB(K+5) = C + 0.5
      IF (W1 .GT. 0.9) GOTO 240
      NAVG2 = NAVG2 + 1
      CAVG2 = CAVG2 + C
      C = C * E1
      IF (C .LE. CC(25)) GOTO 240
      II = 25
  210 JJ = II - 1
      IF (C .LE. CC(JJ)) GOTO 220
      CC(II)  = CC(JJ)
      ICC(II) = ICC(JJ)
      II = JJ
      IF (II .GT. 1) GOTO 210
  220 CC(II)  = C
      ICC(II) = K
      GOTO 240
  230 ITAB(K+5) = -IT
  240 CONTINUE
  250 CONTINUE
      CAVG = CAVG / NAVG
      IF (NAVG2 .GT. 0) CAVG2 = CAVG2 / NAVG2
      WRITE (8, 260) CAVG, NAVG, CAVG2, NAVG2
  260 FORMAT(' The averaged value of the enantiomorph discriminator',
     *       ' (C): ', F7.2,/,3X, '(calculated on', I5, ' reflections)',
     *  /,   '                                                     ',
     *       ' (C): ', F7.2,/,3X, '(calculated on', I5,
     * ' unphased reflections)')
      NAVG = CAVG/2.0 + 0.5
      NAVG2 = CAVG2/2.0 + 0.5
      IF (NAVG2 .GT. 0) GOTO 280
      NAVG = 0
      WRITE (8, 270)
  270 FORMAT (/' === C-formula not valid === use: E1/W1**2 ===')
      IDC3 = 3
  280 NREFM = (NCT-MCT) / ICR / 5
      NREFM = MIN0(NREFM,80)
      NREFMA = (MAXA4N - MARKA4) / INCA4
      IW = 990
      IESTR = 80
      NN = 0
      NN2 = 0
      DO 290 K=MCT,NCT,ICR
      IF (ITAB(K+4).LT.500 .OR. ITAB(K+5).GT.NAVG) GOTO 290
      IF (ITAB(K+4) .GE. 990) NN2 = NN2 + 1
      NN = NN + 1
  290 CONTINUE
      IF (NN2 .GT. NREFMA) GOTO 310
      IF (NN2 .GE. NREFM)  GOTO 330
      IW = 500
      IF (NN .LE. NREFM) GOTO 330
      CALL VALDIS (-1, 500., 1000., KARR, 100, NUMA4)
      DO 300 K=MCT,NCT,ICR
      IF (ITAB(K+4).LT.500 .OR. ITAB(K+5).GT.NAVG) GOTO 300
      W1 = ITAB(K+4)
      CALL VALDIS (0, W1, 0., KARR, 100, NUMA4)
  300 CONTINUE
      CALL VALDIS (NREFM, W1, 0., KARR, 100, NUMA4)
      IW = W1 + .5
      GOTO 330
  310 CALL VALDIS (-1, 80., 400., KARR, 100, NUMA4)
      DO 320 K=MCT,NCT,ICR
      IF (ITAB(K+4).LT.990 .OR. ITAB(K+5).GT.NAVG) GOTO 320
      E1 = ITAB(K+7)
      CALL VALDIS (0, E1, 0., KARR, 100, NUMA4)
  320 CONTINUE
      CALL VALDIS (NREFMA, E1, 0., KARR, 100, NUMA4)
      IESTR = E1 + .5
  330 W1 = FLOAT(IW) / 1000.
      E1 = FLOAT(IESTR) / 100.
      WRITE (8, 340) W1, E1
  340 FORMAT (/' Select new basic set, W1min = ',F6.3, ' E1min = ',F5.2)
      IF (SWIPRI) THEN
         WRITE (8, 350)
  350    FORMAT (/' New basic set reflections with numeric phases', /
     *            ' ', 4 ('  H  K  L  E1   P1   W1    C    '), /)
         CHOUT = '(4A32)'
         CALL LINPRX (8, LITOUT, 32, 4)
         ENDIF
      ISTO4 = MARKA4
      DO 360 K=MCT,NCT,ICR
      IF (ITAB(K+7).LT.IESTR .OR. ITAB(K+4).LT.IW
     *                       .OR. ITAB(K+5).GT.NAVG) GOTO 360
      IF (ISTO4 .GE. MAXA4N) GOTO 370
      IP = ITAB(K+1)
      CALL XUNPAK (IP, IHKL)
      CALL IITAB4 (IHKL, K)
      ITAB(K+2) = -ITAB(K+2)
      IF (SWIPRI) THEN
         E1  = ITAB(K+7) / 100.
         IP1 = ITAB(K+3)
         W   = ITAB(K+4) / 1000.
         IF (ITAB(K+4) .GT. 1000) W = W - 1.
         ICX = ITAB(K+5)
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, ''.'', F5.2, I4, 3X)')
     *                        IHKL, E1, IP1, W, ICX
         CALL LINPRX (0, LITOUT, 32, 4)
         ENDIF
  360 CONTINUE
  370 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 32, 4)
      NUMA4 = (ISTO4-MARKA4) / INCA4
      WRITE (8, 380) NUMA4
  380 FORMAT (/' There are ', I5, ' reflections with numeric phases',
     *        ' in the new basic set')
      NIB = 25
      IF (NAVG .GT. 0) GOTO 430
      IE4 = 399
  383 CALL KERNZI (0, IB, 25)
      NIB = 0
      DO 420 K=MCT,NCT,ICR
      IF (ITAB(K+4).GT.IW .OR. ITAB(K+5).LT.0) GOTO 420
      IF (ITAB(K+7) .GT. IE4) GOTO 420
      I = ITAB(K+4)
      I = ITAB(K+7) * 100000 / MAX0(10,I)**2
      IF (I .LE. IB(25)) GOTO 420
      NIB = MIN0 (NIB +1, 25)
      JJ = 25
      DO 390 II=1,25
      IF (I-IB(II)) 390, 390, 410
  390 CONTINUE
  400 IB(JJ)  = IB(JJ-1)
      ICC(JJ) = ICC(JJ-1)
      JJ = JJ - 1
  410 IF (II .LT. JJ) GOTO 400
      IB(II)  = I
      ICC(II) = K
  420 CONTINUE
      IF (NIB .LT. 25) THEN
         WRITE (8, 421) NIB
  421    FORMAT (' Only ', I3, ' enant.discr. refl. accepted:')
         IF (NIB .GT. 0) WRITE (8, 422) IB(NIB)
  422    FORMAT (' the weakest having IE1 / IW1 =', I7)
         IF (NIB .GE. 15) GOTO 430
         IF (IE4 .LT. 500) THEN
            IE4 = IE4 + 200
            IW = IW * 2
            WRITE (8, FMT='('' try again ... ??'')')
            GOTO 383
            ENDIF
         IF (NIB .GE. 1) GOTO 430
         CALL KERROR ('No enant.discr.refl. found', 422, 'DCMAIN')
         ENDIF
  430 DO 440 K=MCT,NCT,ICR
      IF (ITAB(K+4) .GT. 1000) ITAB(K+4) = ITAB(K+4) - 1000
  440 CONTINUE
      ISTA4 = ISTO4 + INCA4
      ISTO5 = 0
      WRITE (8, 450)
  450 FORMAT (/' Enantiomorph discrimination reflections and',
     *        ' assignement of symbols', /, 5X,
     *        'H   K   L    E1  symbol    C')
      JSYMB = 0
      JSMAX = 10
      IF (IPSQ .EQ. 1) JSMAX = 15
      JSMAX = MIN0 (NIB, JSMAX)
      DO 460 I=1,NIB
      IF (JSYMB .EQ. JSMAX) GOTO 470
      K = ICC(I)
      CALL DACAS (K)
  460 CONTINUE
  470 WRITE(24, 480) JSYMB
      WRITE (8, 480) JSYMB
  480 FORMAT (' Number of ambiguity symbolic choices (primary',
     *        ' set):', I6)
      RETURN
      END
      SUBROUTINE DACEND
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      DIMENSION NLET(10), ISOL(10,2)
      CALL WR24
      FAKWS = 1.
      REDUS = .FALSE.
      IF (IPSQ.EQ.1 .AND. JSYMB.GT.3) REDUS = .TRUE.
  200 ISTA42 = ISTA4
      CALL GENERC
      CALL REAR
      CALL KERNZI (0, NLET, 10)
      CALL KERNZI (1, NLET, JSYMB)
      CALL TACCEP (NLET, NTEMP)
      IF (NTEMP .LE. 0) GOTO 211
      IF (REDUS) THEN
         KRED = 0
         CALL REDSYM (1, NLET, KRED)
         IF (KRED .EQ. 1) REDUS = .FALSE.
         GOTO 200
         ENDIF
      CALL REAR2
      CALL GENERC
      CALL REAR
  211 CALL SYMREL (ISOL)
      IF (IPSQ .EQ. 0) GOTO 320
      KBEST = ISOL(1,2)
      DO 260 J=1,JSYMB
      ISOL(J,1) = KB10X(J,KBEST)
  260 ISOL(J,2) = 0
  320 ILINK = 0
      CALL XXLINK (ISOL, ILINK)
      RETURN
      END
      SUBROUTINE REDSYM (KEY, ISTOR, K)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLADC/ CHAR(12)
      CHARACTER CHAR *1
      DIMENSION ISTOR(10), ISTOR1(11,15), IHKL(3)
      LOGICAL   FIRST
      DATA FIRST / .FALSE. /
      DATA NSYMB, KTEST, ISMAX / 0, 0, 0 /
      IF (KEY .EQ. -1) THEN
         FIRST = .FALSE.
         RETURN
         ENDIF
      IF (FIRST) GOTO 200
      ISMAX = 1
      KTEST = 0
      NSYMB = 0
      FIRST = .TRUE.
  200 IF (KEY .EQ. 1) GOTO 210
      NSYMB = NSYMB + 1
      CALL KERNAI (ISTOR(1), ISTOR1(1,NSYMB), 10)
      ISTOR1(11,NSYMB) = K
      RETURN
  210 CONTINUE
      WRITE (8, FMT='('' Reduced ambiguity choices'', //,
     *       5X, ''H   K   L    E1  Symbol'')')
      KTEST = KTEST + 1
      MSYMB = 0
      ISTO4 = ISTA4 - INCA4
      ISTO5 = 0
      DO 250 I=MCT,NCT,ICR
  250 ITAB(I+6) = 0
      DO 270 I=1,JSYMB
      K = ISTOR1(11,I)
      IF (ISTOR(I) .LE. ISMAX) THEN
          ITAB(K+2) = ISTOR1(2,I)
          ITAB(K+3) = ISTOR1(3,I)
          ITAB(K+4) = ISTOR1(4,I)
          IF (ITAB(K+2) .GE. 0) ITAB(K+4) = 0
          ITAB(K+7) = ISTOR1(7,I)
          ISTOR1(11,I) = -1
          GOTO 270
      ENDIF
      MSYMB = MSYMB + 1
      CALL KERNAI (ISTOR1(8,I), IHKL, 3)
      CALL IITAB4 (IHKL,K)
      ITAB(K+3) = 0
      ITAB(K+4) = 1000
      ISTO5 = ISTO5 + INCA5
      ITAB(K+6) = (ISTO5) / 5
      ITAB5(ISTO5+1) = 32767
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = MSYMB
      E1 = FLOAT(ISTOR1(7,I)) / 100.
      WRITE (8, 260) IHKL, E1, CHAR(MSYMB)
  260 FORMAT (2X, 3I4, F7.2, 4X, A1)
  270 CONTINUE
      K = 1
      IF (NSYMB .LE. JSYMB) GOTO 350
      DO 280 I=JSYMB+1,NSYMB
      K = ISTOR1(11,I)
      MSYMB = MSYMB + 1
      CALL KERNAI (ISTOR1(8,I), IHKL, 3)
      CALL IITAB4 (IHKL, K)
      ITAB(K+3) = 0
      ITAB(K+4) = 1000
      ITAB(K+7) = -ITAB(K+7)
      ITAB(K+2) =  ITAB(K+7)
      ISTO5 = ISTO5 + INCA5
      ITAB(K+6) = ISTO5 / 5
      ITAB5(ISTO5+1) = 32767
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = MSYMB
      E1 = FLOAT(ISTOR1(7,I)) / 100.
      WRITE (8, 260) IHKL, E1, CHAR(MSYMB)
  280 IF (MSYMB .EQ. JSYMB) GOTO 290
  290 K = 0
      I = 0
  310 I = I + 1
  320 IF (ISTOR1(11,I) .GT. 0) GOTO 340
      NSYMB = NSYMB - 1
      DO 330 J=I,NSYMB
  330 CALL KERNAI (ISTOR1(1,J+1), ISTOR1(1,J), 11)
      GOTO 320
  340 IF (I .LE. JSYMB) GOTO 310
  350 JSYMB = MSYMB
      DO 360 I=ISTO4+INCA4+1,ISIZ
  360 ITAB(I) = 0
      DO 370 I=ISTO5+INCA5+1,5*ISIZ5
  370 ITAB5(I) = 0
      WRITE(24, 380) JSYMB
      WRITE (8, 380) JSYMB
  380 FORMAT (' Number of ambiguity symb. choices (reduced sec.',
     *         'set):', I5)
      IF (KTEST .EQ. 2) K = 1
      RETURN
      END
      SUBROUTINE SYMREL (ISOL)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLAD/ ICODE(4,48), ISHIFT(48)
      COMMON /KLADC/ CHAR(12)
      CHARACTER CHAR *1
      DIMENSION I2XI(2,10), IXI(10), ISOL(10,2), IXXI(40)
      EQUIVALENCE (IXXI(11), IXI(1)), (IXXI(21), I2XI(1,1))
      DIMENSION KSY(10), KA(1023), KAA(1024), KAAA(1025)
      EQUIVALENCE (KA(1), KAA(2), KAAA(3))
      DIMENSION KBB(110), LET1(4)
      DATA KBMAX1, KBMAX2 / 0, 0 /
      WRITE(24, 200)
      WRITE (8, 200)
  200 FORMAT (/' Analysis of the symbolic phases  A, B, ....')
      FAK = 2. / E000R
      CALL KERNZI (0,   IXXI,  40)
      CALL KERNZI (0,  KB10X, 15*25)
      CALL KERNZI (0, KB10XX, 15*25)
      IC123 = 0
      KAAA(1) = JSYMB
      KMAX = 2**JSYMB
      KSY(1) = KMAX / 2
      DO 210 I=2,JSYMB
  210 KSY(I) = KSY(I-1) / 2
      CALL KERNZI (0, KAA, KMAX)
      CALL KERNZI (0, KBB, 110)
      DO 370 K=MCT,NCT,ICR
      K51 = ITAB(K+6)
      IF (K51 .EQ. 0) GOTO 370
      IF (IDC .GT. 1) GOTO 220
      ITIP = ITAB(K+5)
      IF (ITIP.GE.0 .OR. ITAB(K+2).LT.0) GOTO 220
      IF (ITIP.GT.-4 .OR. ITIP.LT.-8) GOTO 370
  220 I51 = K51*INCA5
      IF (ITAB(K+2).LT.0 .AND. ITAB(K+7).GT.0) GOTO 320
      GOTO 240
  230 K51 = IITAB5(I51,I51)
  240 IF (IITAB5(I51,I52) .EQ. 0) GOTO 370
      IF (ITAB5(I51+1) .NE. 32767) THEN
          IE1 = ALPS(I51)
          IF (IE1 .LE. 0) GOTO 230
          IP1 = ITAB5(I51+2)
          ELSE
          IP1 = ITAB(K+3)
          IE1 = 32767 * FAK
      ENDIF
      ICOL1 = ITAB5(I51+5)
      CALL DECOL2 (ICOL1, LET1)
      IC1 = IABS(LET1(1))
      IC3 = IABS(LET1(2))
      IADR1 = KSY(IC1)
      IF (IC1 .EQ. IC3) GOTO 230
      IF (IC3.NE.0 .AND. IDC.EQ.1) GOTO 230
      IF (IC3 .GT. 0) IADR1 = IADR1 + KSY(IC3)
      IF (IC3 .NE. 0) GOTO 280
      IP2 = ITAB(K+3)
      CALL PHDIF (IP2, IP1, IP12, IP2)
      I = MIN0(IP2,180-IP2)
      IF (I .LT. 5) GOTO 280
      I = ISIGN(I,IP12)
      Q = ITAB(K+2)
      IF (Q .LT. 2.5) GOTO 280
      I = FLOAT(I * IE1) * SQRT(Q) /100.
      IXXI(IC1) = IXXI(IC1) + ISIGN(1,ICOL1) * I
      GOTO 280
  270 IF (IITAB5(I52,I52) .EQ. 0) GOTO 230
  280 IE2 = ALPS(I52)
      IE2 = IALP(IE1,IE2)
      IF (IE2 .LE. 0) GOTO 270
      IP2 = ITAB5(I52+2)
      ICOL2 = ITAB5(I52+5)
      CALL DECOL2 (ICOL2, LET1)
      IC2 = IABS(LET1(1))
      IC4 = IABS(LET1(2))
      IADR2 = KSY(IC2)
      IF (IC3.NE.0 .AND. IC4.NE.0) GOTO 270
      IF (IC4 .GT. 0) IADR2 = IADR2 + KSY(IC4)
      IF (IC2 .EQ. IC4) GOTO 270
      CALL PHDIF (IP1, IP2, IP12, IP2)
      IE2 = IE2 * (90-IP2)
      IF (ICOL1+ICOL2 .EQ. 0) GOTO 310
      IADR = IADR1 + IADR2
      IF (IC3.EQ.0 .AND. IC4.EQ.0) GOTO 300
      IC123 = IC123 + 1
      IF (IC4 .EQ. 0) GOTO 290
      IF (IC2.EQ.IC1 .OR. IC4.EQ.IC1) IADR = IADR - 2*KSY(IC1)
      GOTO 300
  290 IF (IC1.EQ.IC2 .OR. IC3.EQ.IC2) IADR = IADR - 2*KSY(IC2)
  300 KA(IADR) = KA(IADR) + IE2
      IF (IDC .EQ. 4) GOTO 270
      IF (IC3.NE.0 .OR. IC4.NE.0) GOTO 270
      IF (ICOL1*ICOL2 .LT. 0) IE2 = -IE2
      I = 10*IC1 + IC2
      KBB(I) = KBB(I) + IE2
      GOTO 270
  310 I2XI(2,IC1) = I2XI(2,IC1) + IABS(IE2)
      I2XI(1,IC1) = I2XI(1,IC1) + IE2
      GOTO 270
  320 IP1 = ITAB(K+3)
      GOTO 340
  330 IF (IITAB5(I51,I51) .EQ. 0) GOTO 370
  340 IP2 = ITAB5(I51+2)
      ICOL1 = ITAB5(I51+5)
      IC1 = IABS(ICOL1)
      EI2 = ALPS(I51) * 0.25
      IF (EI2 .LT. 0.) GOTO 330
      CALL PHDIF (IP1, IP2, IP12, IP2)
      IE2 = EI2 * (90.-FLOAT(IP2))
      IF (IC1 .GT. 10) GOTO 350
      IXI(IC1) = IXI(IC1) + IE2
      I = MIN0(IP2,180-IP2)
      IF (I .LT. 5) GOTO 330
      Q = ISIGN(I,IP12)
      IE2 = EI2 * Q
      IXXI(IC1) = IXXI(IC1) + ISIGN(1,ICOL1) * IE2
      GOTO 330
  350 CALL DECOL2 (ICOL1, LET1)
      IC1 = IABS(LET1(1))
      IC2 = IABS(LET1(2))
      IF (LET1(1) .EQ. LET1(2)) GOTO 360
      IADR = KSY(IC1) + KSY(IC2)
      KA(IADR) = KA(IADR) + IE2
      IF (IDC .EQ. 4) GOTO 330
      IF (LET1(1)* LET1(2).GT.0) IE2 = -IE2
      I = 10*IC1 + IC2
      KBB(I) = KBB(I) + IE2
      GOTO 330
  360 I2XI(2,IC1) = I2XI(2,IC1) + IABS(IE2)
      I2XI(1,IC1) = I2XI(1,IC1) + IE2
      GOTO 330
  370 CONTINUE
      IF (IDC .EQ. 1) GOTO 400
      WRITE (8, 380) IC123
  380 FORMAT (' ', I5, ' 3-letter-relations used')
      CALL SYMANA (0, IXI, KAAA, KSY, KB10X, KBMAX1)
      IF (IPSQ .EQ. 0) WRITE(24, 390)
      IF (IPSQ .EQ. 0) WRITE (8, 390)
  390 FORMAT (' ***** Origin fixed *****')
  400 IF (IDC .EQ. 4) GOTO 430
      CALL KERNZI (0, KAA, KMAX)
      DO 410 I=1,JSYMB
      DO 410 J=1,JSYMB
      IF (I .EQ. J) GOTO 410
      IC1 = 10*I + J
      IADR = KSY(I) + KSY(J)
      KA(IADR) = KA(IADR) + KBB(IC1)
  410 CONTINUE
      CALL SYMANA (90, IXXI, KAAA, KSY, KB10XX, KBMAX2)
      IF (IDC.EQ.2 .OR. IPSQ.EQ.0) GOTO 425
      WRITE (8, 420)
  420 FORMAT (' ***** Enantiomorph fixed *****')
  425 IF (IDC .GT. 1)  ESTAR1 = ESTART(1) - 0.1
  430 IF (IPSQ .EQ. 0) GOTO 460
      KBMAX1 = MAX0 (KBMAX1, 1)
      KBMAX2 = MAX0 (KBMAX2, 1)
      KBMAX = KBMAX1 * KBMAX2
      KBMAX = MIN0 (KBMAX, 25)
      ILDUMP = 0
      CALL DAFOMS (KBMAX, E1100, NR, 0., 0., 0, ILDUMP)
      IF (IDC .NE. 1) GOTO 450
      DO 440 I=1,KBMAX2
  440 CALL KERNAI (KB10XX(1,I), KB10X(1,I), 12)
  450 CALL SOLCOM (KBMAX1, KBMAX2, KB10X, KB10XX, IDC, JSYMB)
      ILINK = 0
      ELDAF = 0.0
      IPHDAF = 0
      CALL DAFOMS (0, ELDAF, IPHDAF, 0., 0., 0, ILINK)
      ILINK = MAX0 (ILINK, 1)
      ISOL(1,2) = ILINK
      DO 455 I=1,JSYMB
  455 ISOL(I,1) = KB10X(I,ILINK)
      GOTO 600
  460 DO 470 I=1,JSYMB
      IXI(I) = KB10X(I,1)
  470 IXXI(I) = KB10XX(I,1)
      IF (IDC .EQ. 1) CALL KERNAI (IXXI, IXI, 10)
      IF (IDC .EQ. 4) CALL KERNAI (IXI, IXXI, 10)
      J = IDC - 1
      DO 480 I=1,JSYMB
      IF (IXI(I).EQ.0 .AND. IXXI(I).EQ.270) IXI(I) = 360
  480 ISOL(I,1) = (IXI(I) + J * IXXI(I)) / IDC
  600 IF (IPSQ .EQ. 0) THEN
         WRITE(24, 610)
         WRITE (8, 610)
  610    FORMAT (' Results of the symbolic addition method for',
     *           ' the symbolic phases:')
      ELSE
         WRITE(24, 620)
         WRITE (8, 620)
  620    FORMAT(' Results of the PSI0 and negative quartet FOMs',
     *           ' for the symbolic phases:')
         ENDIF
      WRITE(24, 630) (CHAR(I), ISOL(I,1), I=1,JSYMB)
      WRITE (8, 630) (CHAR(I), ISOL(I,1), I=1,JSYMB)
  630 FORMAT (3X, 10(A1,'=',I3,2X))
      RETURN
      END
      SUBROUTINE SYMANA (KEY, KB, KAAA, KSY, KB10, KBMAXX)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLAD/  ICODE(4,48), ISHIFT(48)
      DIMENSION KB(10), KAAA(1025), KSY(10), K10(2,200)
      DIMENSION KB10(15,25)
      DATA KADR / 0 /
      CALL KERNZI (0,    K10, 2*200)
      CALL KERNZI (0,   KB10, 15*25)
      K5 = 1
      IF (IPSQ .EQ. 1) K5 = 25
      KBMAXX = 0
      KX = 2**JSYMB + 1
      DO 200 I=1,JSYMB
      IADR = KSY(I) + 2
  200 KAAA(IADR) = KAAA(IADR) + KB(I)/10
      K = 0
      DO 210 I=2,KX
  210 K = K + IABS(KAAA(I))
      IF (K .GT. 0) GOTO 230
      WRITE(24, 220)
  220 FORMAT (/' ***** ERROR: no symbol relations; rerun PHASEX', /,
     *        ' *****        with lower E-min values   *********' /)
      GOTO 250
  230 Q = 32001. / FLOAT(K)
      DO 240 I=2,KX
  240 KAAA(I) = FLOAT(KAAA(I)) * Q
      CALL SYMAN (KAAA)
  250 KMAX = -32100
      DO 260 J=2,KX
      IF (KAAA(J) .LT. KMAX) GOTO 260
      KMAX = KAAA(J)
      KADR = J
  260 CONTINUE
      MAXR = KMAX * 100 / 32000
      MAXADR = KADR - 2
      KMIN = MIN0 (KMAX, 22400) * 7 / 10
      KBMAX1 = 1
      IF (IPSQ .EQ. 0) THEN
          K10(1,1) = KMAX
          K10(2,1) = KADR
          GOTO 305
      ENDIF
      DO 300 I=2,KX
      IF (KAAA(I) .LE. KMIN) GOTO 300
      DO 270 J=1,KBMAX1
      IF (KAAA(I) .LE. K10(1,J)) GOTO 270
      JJ = J
      GOTO 280
  270 CONTINUE
      GOTO 300
  280 DO 290 K=KBMAX1,JJ+1,-1
      K10(1,K) = K10(1,K-1)
  290 K10(2,K) = K10(2,K-1)
      K10(1,JJ) = KAAA(I)
      K10(2,JJ) = I
      KBMAX1 = KBMAX1 + 1
      IF (KBMAX1 .GT. 200) KBMAX1 = 200
  300 CONTINUE
      IF (KBMAX1 .NE. 200) KBMAX1 = KBMAX1 - 1
  305 DO 360 J=1,KBMAX1
      KADR = K10(2,J)
      MAXADR = KADR - 2
      K = K10(1,J)
      MAXR = K * 100 / 3200
      DO 320 I=1,JSYMB
      JJ = MAXADR / KSY(I)
      IF (JJ .EQ. 0) GOTO 310
      KB(I) = KEY + 180
      MAXADR = MAXADR - KSY(I)
      GOTO 320
  310 KB(I) = KEY
  320 CONTINUE
      JLINK = -J
      IF (IPSQ .EQ. 0) THEN
         JLINK = J
      ELSE
         CALL PHCOM1 (KB, JLINK)
         ENDIF
      IF (JLINK .EQ. J) THEN
         KBMAXX = KBMAXX + 1
         CALL KERNAI (KB, KB10(1,KBMAXX), 10)
         KB10(11,KBMAXX) = J
         KB10(12,KBMAXX) = MAXR
         IF (KBMAXX .EQ. K5) RETURN
         ENDIF
  360 CONTINUE
      RETURN
      END
      SUBROUTINE XXLINK (ISOL, ILINK)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      LOGICAL        SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      EQUIVALENCE (IBINDO, IFILE(13))
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /SINCOS/ IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      DIMENSION IHKL(3), ISOL(10,2)
      COMMON /EPWCO/ IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE
      DIMENSION ITYP(4)
      CHARACTER LETT(4) *2, LITOUT *25
      DATA LETT  / '. ', 'S ', '* ', '*S' /
      DATA NLINPR / 0 /
      EEESUM = 0.
      ABSUM = 0.
      AB1SUM = 0.
      CALL KERNZI (0, ITYP, 4)
      NUMK = 0
      MAXA4 = ISIZ
      ESTAR1 = ESTART(1) + 0.1
      ISTO4 = MARKA4
      IF (ILINK.EQ.0 .AND. MS.LT.700) MAXA4 = MAXA4 + (700-MS)*INCA4
      ISW = 0
      IF (ILINK .NE. 0) ISW = 1
      EB = 100. * E000R
      ISL = 0
      IF (SWIPRI) ISL = 1
      SWIPRI = .FALSE.
      CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (ISL .EQ. 1) SWIPRI = .TRUE.
      IF (.NOT.SWIPRI .OR. ILINK.NE.0) GOTO 230
      WRITE (8, 200) ESTAR1
  200 FORMAT (' Results from DIRDIF.Special (end of PHASEX cycle 0),',
     *        ' max. 300 refl. printed' /
     *     /  ' * = accepted for basic set:  W1.gt.0.16, EL.gt.', F4.2)
      IF (IDC .NE. 4) WRITE (8, 210)
  210 FORMAT (' S = special reflection (two possible phase values)')
      WRITE (8, 220)
  220 FORMAT (/1X, 5('  H  K  L  EL   PL   WS  ') /)
      NLINPR = 0
      CHOUT = '(5A25)'
      CALL LINPRX (8, LITOUT, 25, 5)
  230 IREFL = 0
      DO 320 K=MCT,NCT,ICR
      LET = 1
      CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP)
      IF (KENDOP .LT. 0) GOTO 330
      IREFL = IREFL + 1
      CALL KERF2I (FITDOP(1), IHKL(1), 3)
      E1     = FITDOP(4)
      IF (ILINK.GT.0 .AND. E1.LE.E1MIN) GOTO 320
      E2     = FITDOP(5)
      IP1    = NINT(FITDOP(6))
      W1     = FITDOP(7)
      IT     = FITDOP(8)
      IREST  = NINT(FITDOP(9))
      NUMK = NUMK + 1
      EL = E1
      WS = W1
      IF (IP1 .LE. 0) IP1 = IP1 + 360
      IPHS = IP1
      K51 = ITAB(K+6)
      KEY = 1
      IF (K51 .EQ. 0) GOTO 280
      LIBS = 0
      KEY = 2
      AEE = 0.0
      BEE = 0.0
      I51 = K51*INCA5
      GOTO 245
  240 I51 = K51*INCA5 + I51
  245 IP  = ITAB5(I51+2)
      EEE = ITAB5(I51+1)
      IF (EEE .LT. 32766.) GOTO 250
      EEE = EB
      IP = ITAB(K+3)
  250 ICOL = ITAB5(I51+5)
      I = IABS(ICOL)
      IF (I .GT. JSYMB) GOTO 260
      KEY = 3
      IP = IP + ISIGN(ISOL(I,1),ICOL)
      IP = MOD(IP,360)
      IF (IP .LE. 0) IP = IP + 360
      AEE = AEE + EEE*ISCT(450-IP)/1000.
      BEE = BEE + EEE*ISCT(IP)/1000.
      EEESUM = EEESUM + EEE
      LIBS = LIBS + 1
  260 K51 = ITAB5(I51+4)
      IF (K51 .NE. 0) GOTO 240
      IF (LIBS .EQ. 0) GOTO 280
      ITYP(4) = ITYP(4) + LIBS
      EEE = SQRT(AEE*AEE + BEE*BEE)
      ABSUM = ABSUM + EEE
      WW = W1 / 1000.
      IF (ITAB(K+2).LT.0 .AND. ITAB(K+7).GT.0) GOTO 270
      IF (IT .NE. 1) GOTO 270
      WW = WW*2. / IDC3**2
  270 AEE = (AEE + EEE*ISCT(450-IP1)*WW)/10.
      BEE = (BEE + EEE*ISCT(IP1)*WW)/10.
      EEE = SQRT(AEE*AEE + BEE*BEE)
      IF (EEE .LT. 0.001) AEE = 0.1
      PHS = ATAN2(BEE,AEE) * 57.2958
      IF (PHS .LT. 0.) PHS = PHS + 360.
      IPHS = PHS + 0.5
      WS = TANH(EEE/E000R)**2
      CALL EPW
      AB1SUM = AB1SUM + EEE
      WS = AMAX1 (W1, WS)
  280 IF (IT .EQ. 1) THEN
         E2AG(7) = E2AG(7) + EL*EL
      ELSE
         E2CG(7) = E2CG(7) + EL*EL
         ENDIF
      IF (ILINK .EQ. 0) THEN
         ITAB(K+2) = 100.*EL*WS + 0.5
         ITAB(K+3) = IPHS
         ITAB(K+7) = 100.*EL + 0.5
      ELSE
         CALL PHCOM2 (IPHS, ILINK)
         ENDIF
      ITYP(KEY) = ITYP(KEY) + 1
      IF (EL.LT.ESTAR1 .OR. WS.LT.0.16) GOTO 290
      IF (ISW .EQ. 1) GOTO 290
      IF (ISTO4 .GT. MAXA4) GOTO 300
      IF (ILINK .EQ. 0) CALL IITAB4 (IHKL, K)
      LET = LET + 2
  290 ITAB1 = ITAB(K+1)
      IF (ILINK .EQ. 0) THEN
         ITAB(K+4) = 0
         ITAB(K+5) = 0
         ITAB(K+6) = 0
         IF (ITAB(K+7) .LT. 0) ITAB(K+7) = -ITAB(K+7)
      ELSE
         CALL DAFOMS (ITAB1, EL, IPHS, WS, E1, IREFL, ILINK)
         ENDIF
      IF (.NOT.SWIPRI .OR. ILINK.GT.0) GOTO 320
      IF (IT.NE.1 .AND. IDC.NE.4) LET = LET + 1
      IF (SWIPRI .AND. NLINPR.LT.300) THEN
         NLINPR = NLINPR + 1
         WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)')
     *                        IHKL, EL, IPHS, LETT(LET), WS
         CALL LINPRX (0, LITOUT, 25, 5)
      ENDIF
      GOTO 320
  300 WRITE(24, 310)
  310 FORMAT(' ******** WARNING: the basic set is not complete' )
      ISW = 1
      GOTO 290
  320 CONTINUE
  330 IF (SWIPRI .AND. ILINK.EQ.0) CALL LINPRX (-1, LITOUT, 25, 5)
      E2AG(7) = (E2AG(7) + E2ALE) / MAX0(1,NGN)
      E2CG(7) = (E2CG(7) + E2CLE) / MAX0(1,NSP)
      IF (EEESUM .LT. 0.0001) EEESUM = 1.
      C1EE = 10. * AB1SUM / EEESUM
      IF (ILINK .EQ. 0) GOTO 336
      ISOL(1,2) = NINT(C1EE*1000.)
      I2000 = -2000
      CALL PHCOM2 (IPHS, I2000)
      ILINK = I2000
      RETURN
  336 ITYP(3) = MAX0(1, ITYP(3))
      WW = FLOAT(ITYP(4)) / ITYP(3)
      WRITE (8, 340) (ITYP(I),I=1,3), WW
  340 FORMAT (/' Number of refl. without symbolic phase: ', I11 /
     *        ' Number of refl. without single-letter phase: ', I6 /
     *        ' Number of refl. with N single-letter phases: ', I6 /
     *        ' (N = 1 or more,  average N =  ', F5.2, ' )')
      MAXA4 = ISIZ - INCA4
      MS = (ISTO4-MARKA4) / INCA4
      WRITE (8, 350) MS
  350 FORMAT (/' Number of refl. in new basic set: ', I5 )
      RETURN
      END
      SUBROUTINE SOLCOM (KBMAX1, KBMAX2, KB10X, KB10XX, IDC, JSYMB)
      INCLUDE 'Zsyst.inc'
      PARAMETER (KBMAX = 25)
      DIMENSION KB10X(15,KBMAX), KB10XX(15,KBMAX), IXI(10), IXXI(10),
     *          IX(10,2), KBXX(15,KBMAX)
      COMMON /SOLCPC/ KBTEMP(12,KBMAX*KBMAX), KBORD(12,KBMAX*KBMAX)
      WRITE (8, FMT='(I6, '' solutions for the symmetrical'',
     *                   '' part '')') KBMAX1
      CALL PHCOM2 (0, 0)
      ICONS2 = 0
      CALL KERNZI (0, KBXX, 15*KBMAX)
      IF (IDC.EQ.2 .OR. IDC.EQ.3) GOTO 240
      ICONS1 = KB10X (12,1)
      KBMAX1 = MAX0 (KBMAX1, KBMAX2)
      IACC = 0
      DO 230 I=1,KBMAX1
      DO 210 J=1,JSYMB
  210 IX(J,1) = KB10X(J,I)
      ILINK = I
      CALL XXLINK (IX, ILINK)
      IF (ILINK .NE. I) GOTO 230
      IACC = IACC + 1
      CALL KERNAI (IX(1,1), KBXX(1,IACC), JSYMB)
      KBXX(11,IACC) = I
      CI = FLOAT(KB10X (12,I)) / FLOAT(ICONS1)
      KBXX(12,IACC) = NINT(CI * 1000.)
      KBXX(13,IACC) = IX(1,2)
      ICONS2 = MAX0 (ICONS2, IX(1,2))
  230 CONTINUE
      GOTO 330
  240 WRITE (8, FMT='(I6, '' solutions for the'',
     *       '' antisymmetrical part '')')  KBMAX2
      WRITE (8, FMT='(1X)')
      CALL KERNZI (0, KBTEMP, 12*KBMAX*KBMAX)
      CALL KERNZI (0, KBORD,  12*KBMAX*KBMAX)
      JDC = IDC - 1
      JALL = 0
      CONMAX = FLOAT (KB10X(12,1) + KB10XX(12,1)) / 1000.
      DO 252 I=1,KBMAX1
      CALL KERNAI (KB10X(1,I), IXI(1), JSYMB)
      DO 251 J=1,KBMAX2
      CALL KERNAI (KB10XX(1,J), IXXI(1), JSYMB)
      JALL = JALL + 1
      KBTEMP(11,JALL) = JALL
      CONS = FLOAT (KB10X(12,I) + KB10XX(12,J)) / CONMAX
      KBTEMP(12,JALL) = NINT (CONS)
      DO 250 IN=1,JSYMB
      IXI1 = IXI(IN)
      IF (IXI1.EQ.0 .AND. IXXI(IN).EQ.270) IXI1 = 360
      KBTEMP(IN,JALL) = (IXI1 + JDC*IXXI(IN)) / IDC
  250 CONTINUE
  251 CONTINUE
  252 CONTINUE
      JJ = 1
      DO 300 I=1,JALL
      IF (I .EQ. 1) GOTO 290
      DO 260 J=1,I-1
      IF (KBTEMP(12,I) .LT. KBORD(12,J)) GOTO 260
      JJ = J
      GOTO 270
  260 CONTINUE
      JJ = I
      GOTO 290
  270 DO 280 K=I,JJ+1,-1
  280 CALL KERNAI (KBORD(1,K-1), KBORD(1,K), 12)
  290 CALL KERNAI (KBTEMP(1,I), KBORD(1,JJ), 12)
  300 CONTINUE
      JSOL = 0
      IACC = 0
      DO 320 I=1,JALL
      CALL KERNAI (KBORD(1,I), IX(1,1), JSYMB)
      JSOL = JSOL + 1
      ISOL = JSOL
      CALL XXLINK (IX, ISOL)
      IF (JSOL .EQ. ISOL) THEN
         IACC = IACC + 1
         CALL KERNAI (IX(1,1), KBXX(1,IACC), JSYMB)
         KBXX(11,IACC) = KBORD(11,I)
         KBXX(12,IACC) = KBORD(12,I)
         ELSE
         GOTO 320
         ENDIF
      KBXX(13,IACC) = IX(1,2)
      ICONS2 = MAX0 (ICONS2, IX(1,2))
      IF (IACC .EQ. KBMAX) GOTO 330
  320 CONTINUE
  330 CALL KERNZI (0, KB10X, 15*KBMAX)
      DO 340 I=1,IACC
      CALL KERNAI (KBXX(1,I), KB10X(1,I), 15)
      CI = FLOAT(KB10X(13,I)) / FLOAT(ICONS2)
  340 KB10X(13,I) = NINT(CI * 1000.)
      KBMAX1 = IACC
      IF (IDC.EQ.2 .OR. IDC.EQ.3) THEN
        WRITE (8, FMT='(/I5, '' combined solutions'',
     *       '' (symmetrical and antisymmetrical part)'')') KBMAX1
      ELSE
         WRITE (8, FMT='(1X)')
         ENDIF
      WRITE (8, FMT='(5X, ''    A    B    C    D    E    F    G'',
     *                 ''    H    I    J   No CONS1 CONS2'',/,
     *                  (I3, '') '', 13I5))')
     *                  (I1, (KB10X(I13,I1), I13=1,13), I1=1,KBMAX1)
      RETURN
      END
      SUBROUTINE PHCOM1 (KB, ICOM)
      INCLUDE 'Zaaaa.inc'
      LOGICAL SWIPRI
      EQUIVALENCE (SWIPRI, SWITCH(10))
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLADC/ CHAR(12)
      CHARACTER CHAR *1
      PARAMETER (IACC = 25)
      DIMENSION KB(10), KLET(10), PLET(10), KACC(11,IACC), LET(4)
      LOGICAL FIRST
      DATA FIRST / .FALSE. /
      DATA JACC, PMAX / 0, 0.0 /
      IF (FIRST) GOTO 250
      FIRST = .TRUE.
      CALL KERNZA (0., PLET, 10)
      CALL KERNZI (0, KLET, 10)
      NSYMB = 0
      DO 200 K=MCT,NCT,ICR
      K5 = ITAB(K+6)
      IF (K5 .EQ. 0) GOTO 200
      NSYMB = NSYMB + 1
      I5 = K5 * INCA5
      GOTO 185
  180 I5 = K5*INCA5 + I5
  185 ICOL = ITAB5(I5+5)
      I = IABS(ICOL)
      IF (I .LE. JSYMB) GOTO 186
      CALL DECOL2 (I, LET)
      I = IABS(LET(1))
      KLET(I) = KLET(I) + 1
      I = IABS(LET(2))
      KLET(I) = KLET(I) + 1
      GOTO 190
  186 KLET(I) = KLET(I) + 1
  190 K5 = ITAB5(I5+4)
      IF (K5 .NE. 0) GOTO 180
  200 CONTINUE
      NSUM = 0
      DO 210 I=1,JSYMB
  210 NSUM = NSUM + KLET(I)
      PSUM = 100. / FLOAT(NSUM)
      PMAX = 0.
      DO 220 I=1,JSYMB
      PLET(I) = FLOAT(KLET(I)) * PSUM
  220 PMAX = MAX (PLET(I), PMAX)
      WRITE (8, 230) NSYMB, (CHAR(I),I=1,JSYMB)
  230 FORMAT (' Symbol frequency for ', I5, ' reflections: ', /,
     *          10X, 10(4X,A1))
      WRITE (8, FMT='(11X, 10I5)')   (KLET(I),I=1,JSYMB)
      WRITE (8,FMT='(''   (in %) '', 1X, 10F5.1)')
     *                 (PLET(I), I=1,JSYMB)
      I = INT(PMAX)
      PMAX = FLOAT(I)
      IF (SWIPRI)
     *    WRITE (8, FMT='('' Two solutions are equal, if the symbol''
     *                     ,'' changes'', /, ''    between them are'',
     *                      '' less than '', F5.1, '' %'')') PMAX
  250 IACOM = IABS(ICOM)
      IF (IACOM .EQ. 1) THEN
         CALL KERNZI (0, KACC, 11*IACC)
         JACC = 1
         ICOM = IACOM
         CALL KERNAI (KB(1), KACC(1,JACC), JSYMB)
         KACC(11, JACC) = IACOM
         RETURN
         ENDIF
      DO 280 I=1,JACC
      PSUM = 0.
      DO 260 J=1,JSYMB
      IDIF = IABS(KACC(J,I) - KB(J))
      DIF  = FLOAT (IDIF)
      MULT = MIN (1.0, DIF)
  260 PSUM = PSUM + FLOAT(MULT) * PLET(J)
      IF (PSUM.LT.PMAX) RETURN
  280 CONTINUE
      ICOM = IACOM
      JACC = JACC + 1
      IF (JACC .GT. IACC) CALL KERROR ('Too many solutions',0, 'PHCOM1')
      CALL KERNAI (KB(1), KACC(1,JACC), JSYMB)
      KACC(11, JACC) = IACOM
      RETURN
      END
      SUBROUTINE PHCOM2 (IPHS, ILINK)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      PARAMETER (NIPH = 1000, KBMAX = 25,
     *           MAXD1 = 10,  MAXD2 = 15)
      COMMON /PHC2PC/
     *          IPH(NIPH,KBMAX), IDIF(KBMAX), NDIF(KBMAX)
      DATA JSOL, NPH, JLINK, MAXDIF / 0, 0, 0, 0  /
      IF (ILINK .NE. 0) GOTO 200
      MAXDIF = MAXD2
      IF (ICENT.EQ.1 .OR. EXPAND) MAXDIF = MAXD1
      CALL KERNZI (0, IPH,  NIPH*KBMAX)
      CALL KERNZI (0, IDIF,      KBMAX)
      NPH  = 0
      JSOL = 1
      RETURN
  200 IF (ILINK .EQ. -2000) GOTO 220
      IF (JSOL .GT. KBMAX)
     *    CALL KERROR (' To much solutions stored', 0, 'PHCOM2')
      NPH = NPH + 1
      IF (NPH .GT. NIPH) THEN
          NPH = NIPH
          RETURN
      ENDIF
      JLINK = ILINK
      IPH(NPH,JSOL) = IPHS
      RETURN
  220 IF (JLINK .EQ. 1) GOTO 270
      DO 230 I=1,JSOL-1
      DO 230 J=1,NPH
      IPH12 = IABS (IPH(J,I) - IPH(J,JSOL))
      IF (IPH12 .GT. 180) IPH12 = 360 - IPH12
  230 IDIF(I) = IDIF(I) + IPH12
      ITEST = 0
      DO 260 I=1,JSOL-1
      MDIF = IDIF(I) / NPH
      IF (MDIF .LT. MAXDIF) ITEST = -1
      IF (ITEST .EQ. -1) GOTO 265
  260 CONTINUE
      GOTO 270
  265 ILINK = -ILINK
      ELDAF = 0.0
      IPHDAF = 0
      CALL DAFOMS (0, ELDAF, IPHDAF, 0., 0., 0, -1)
      GOTO 280
  270 NDIF(JSOL) = JLINK
      JSOL = JSOL + 1
      ILINK = JLINK
  280 NPH = 0
      CALL KERNZI (0, IDIF, KBMAX)
      RETURN
      END
      SUBROUTINE GENERC
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /SINCOS/ IDEG(8), ISCT
      COMMON /KLAD/   ICODE(4,48), ISHIFT(48)
      INTEGER*2 ISCT(450)
      DIMENSION IHKL(3), IHKL3(3),  LHIT(48)
      EQUIVALENCE (IHKL3(1),  JJH1), (IHKL3(2),  JJH2), (IHKL3(3),JJH3),
     *            (MAXHKL(1), MAXH), (MAXHKL(2), MAXK), (MAXHKL(3),MAXL)
      DIMENSION LET1(4), LET1R(4), LET2(4)
      DATA K, NUMB, KTEST / 0, 0, 0/
      MAXA5 = ISIZ5*INCA5 - INCA5
      IF (ISTA4 .EQ. ISTA42) NUMB = 0
      NUMBM = MAXA5 / INCA5
      IF (NUMBM .GT. ISIZ5+INCA5) NUMBM = ISIZ5 - INCA5
      ISTR1 = ISTA42
      ISTR2 = MARKA4 + INCA4
      MAX5  = MAXA5  - INCA5
      ICENTR = 2*IICENT - 3
      CALL KERNZI (0,  LET1, 4)
      CALL KERNZI (0, LET1R, 4)
      CALL KERNZI (0,  LET2, 4)
      DO 390 I41=ISTR1,ISTO4,INCA4
      DO 200 I=1,3
  200 IHKL(I) = ITAB(I41+I)
      NEQ = 2
      CALL SYMEQ (IHKL, NEQ)
      IR1  = ITAB(I41+4) + MCT
      IE1  = ITAB(IR1+2)
      IPH1 = ITAB(IR1+3)
      DO 210 I=1,NEQ
      IS2 = ISHIFT(I)
      ISHIFT(I) = IPH1 + IDEG(IS2)
      ISHIFT(I+NEQ) = -ISHIFT(I)
  210 CONTINUE
      K51S = ITAB(IR1+6)*INCA5 + INCA5
      ICOL1 = ITAB5(K51S)
      ICOL1R = ICENTR * ICOL1
      CALL DECOL2 (ICOL1, LET1)
      LET1R(1) = ICENTR * LET1(1)
      LET1R(2) = ICENTR * LET1(2)
      ISTOP = I41 - INCA4
      NEQ2  = NEQ * 2
      DO 380 I42=ISTR2,ISTOP,INCA4
      JH1 = ITAB(I42+1)
      JH2 = ITAB(I42+2)
      JH3 = ITAB(I42+3)
      IR2 = ITAB(I42+4) + MCT
      IF (I42 .LT. ISTA4) GOTO 220
      K52S = ITAB(IR2+6)*INCA5 + INCA5
      ICOL2 = ITAB5(K52S)
      CALL DECOL2 (ICOL2, LET2)
      CALL COLAD  (LET1,  LET2, ICOL,  IICENT)
      CALL COLAD  (LET1R, LET2, ICOLR, IICENT)
      IF (ICOL.EQ.0 .AND. ICOLR.EQ.0) GOTO 380
      GOTO 230
  220 ICOL  = ICOL1
      ICOLR = ICOL1R
  230 IPH2  = ITAB(IR2+3)
      IWEE  = IE1 * ITAB(IR2+2)
      J = ITAB(IR2+1)
      NHIT = 0
      NQQ1 = 1
      NQQ2 = NEQ
      IF (ICOL .EQ. 0) GOTO 370
  240 DO 360 I11 = NQQ1,NQQ2
      IF (MCTLAT .GT. 1) GOTO 250
      I = ICODE(4,I11)
      KTEST = I + J
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 360
      IF (K .GT. MCT) GOTO 360
      IF (ITAB(K) .EQ. 0) GOTO 360
  250 JJH1 = ICODE(1,I11) + JH1
      IF (IABS(JJH1) .GT. MAXH) GOTO 360
      JJH2 = ICODE(2,I11) + JH2
      IF (IABS(JJH2) .GT. MAXK) GOTO 360
      JJH3 = ICODE(3,I11) + JH3
      IF (IABS(JJH3) .GT. MAXL) GOTO 360
      IF (MCTLAT .EQ. 1) GOTO 260
      KTEST = INPACK(IHKL3)
      K = IABS(KTEST)
      IF (K .EQ. 0) GOTO 360
      IF (ITAB(K) .EQ. 0) GOTO 360
  260 K = ITAB(K)
      LTEST = IABS(K)
      L = LTEST / 4096
      IR3 = (LTEST-L*4096-1)*ICR + MCT
      IF (IR3.EQ.IR2 .OR. IR3.EQ.IR1) GOTO 360
      IF (NHIT .EQ. 0) GOTO 280
      DO 270 IHIT=1,NHIT
      IF (IR3 .EQ. LHIT(IHIT)) GOTO 360
  270 CONTINUE
  280 NHIT = NHIT + 1
      LHIT(NHIT) = IR3
      L = L + 1
      ISS  = ISIGN(1,K) * ISIGN(1,KTEST)
      IPH3 = ISS * (ISHIFT(I11)+IPH2)-IDEG(L)
      IF (ISS .EQ. 1) GOTO 290
      ICOL3 = ICENTR * ICOL
      GOTO 300
  290 ICOL3 = ICOL
  300 IPH3 = MOD(IPH3,360)
      IF (IPH3 .LE. 0) IPH3 = IPH3 + 360
      K53 = ITAB(IR3+6)
      IF (K53 .NE. 0) GOTO 310
      IF (NUMB+JSYMB .GE. NUMBM) GOTO 400
      ISTO5 = ISTO5 + INCA5
      ITAB(IR3+6) = ISTO5 / INCA5
      GOTO 340
  310 I53 = K53*INCA5
      IF (ITAB5(I53+5) .NE. ICOL3) GOTO 330
      IF (ITAB5(I53+1) .EQ. 32767) GOTO 360
      GOTO 350
  320 I53 = K53*INCA5 + I53
      IF (ITAB5(I53+5) .EQ. ICOL3) GOTO 350
  330 K53 = ITAB5(I53+4)
      IF (K53 .NE. 0) GOTO 320
      IF (ISTO5.GT.MAX5 .OR. (NUMB+JSYMB).GE.NUMBM) GOTO 400
      ISTO5 = ISTO5 + INCA5
      ITAB5(I53+4)   = (ISTO5 - I53) / 5
  340 ITAB5(ISTO5+1) = IWEE * ISCT(450-IPH3)/1000000
      ITAB5(ISTO5+2) = IWEE * ISCT(IPH3)/1000000
      ITAB5(ISTO5+3) = IWEE / 1000
      ITAB5(ISTO5+4) = 0
      ITAB5(ISTO5+5) = ICOL3
      NUMB = NUMB + 1
      GOTO 360
  350 ITAB5(I53+1) = ITAB5(I53+1) + IWEE*ISCT(450-IPH3)/1000000
      ITAB5(I53+2) = ITAB5(I53+2) + IWEE*ISCT(IPH3)/1000000
      ITAB5(I53+3) = ITAB5(I53+3) + IWEE/1000
  360 CONTINUE
  370 IF (NQQ2.EQ.NEQ2 .OR. ICOLR.EQ.0) GOTO 380
      ICOL = ICOLR
      NQQ1 = NEQ+1
      NQQ2 = NEQ2
      GOTO 240
  380 CONTINUE
  390 CONTINUE
      GOTO 420
  400 WRITE (8, 410) NUMB+JSYMB, NUMBM
  410 FORMAT (/' There is not enough storage (subr. GENERC):', /,
     *        ' Number of relations (', I5, ') .GE. max. number of',
     *        ' relations (', I5, ')')
      WRITE (8, FMT='('' Generation is stopped at reflection : '',
     *       3I4, ''   (='', I4, ''. refl. in secondary set)'')')
     *      (ITAB(I41+I3), I3=1,3), (I41-ISTR1)/4
  420 WRITE(24, 430) NUMB+JSYMB
      WRITE (8, 430) NUMB+JSYMB
  430 FORMAT (' Total number of phases with symbols:', I21)
      RETURN
      END
      SUBROUTINE DECOL2 (ICOL, LET)
      DIMENSION LET(4)
      IF (IABS(ICOL) .LE. 10) GOTO 100
      LET(1) = (ICOL+220) / 21 - 10
      LET(2) = ICOL - LET(1)*21
      RETURN
  100 LET(2) = 0
      LET(1) = ICOL
      RETURN
      END
      SUBROUTINE COLAD (LET1, LET2, ICOL, ICENT)
      DIMENSION LET1(4), LET2(4)
      DATA N / 2 /
      ICOL = 0
      I1 = 1
      I2 = 1
      I = 0
  200 IF (IABS(LET1(I1)) - IABS(LET2(I2))) 210, 240, 230
  210 IF (I .EQ. N) GOTO 250
      ICOL = ICOL * 21 + LET2(I2)
      I2 = I2 + 1
  220 I = I + 1
      GOTO 200
  230 IF (I .EQ. N) GOTO 250
      ICOL = ICOL * 21 + LET1(I1)
      I1 = I1 + 1
      GOTO 220
  240 IF (LET1(I1) .EQ. 0) RETURN
      IF (ICENT.EQ.1 .AND. LET1(I1).EQ.LET2(I2)) GOTO 210
      I1 = I1 + 1
      I2 = I2 + 1
      GOTO 200
  250 ICOL = 0
      RETURN
      END
      SUBROUTINE REAR
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      FAK = 1.
      DO 260 K=MCT,NCT,ICR
      IF (ITAB(K+6) .EQ. 0) GOTO 260
      E1 = ITAB(K+7) / 100.
      IF (E1 .LT. 0.0) E1 = -E1
      J  = ITAB(K+6)*INCA5
      IMAX = J
      II = J
      IF (ITAB5(J+1) .NE. 32767) GOTO 200
      AX = 32767.
      GOTO 230
  200 AX = 0.0
  210 AEE = ITAB5(II+1)
      BEE = ITAB5(II+2)
      EEE = SQRT(AEE*AEE+BEE*BEE) * E1
      IF (EEE .LT. 0.001) AEE = 1.0
      PH3 = ATAN2(BEE,AEE)
      IEE = EEE + 1.0
      IWEE = ITAB5(II+3)*E1 + 0.5
      ITAB5(II+1) = MIN0(IEE,IWEE)
      ITAB5(II+3) = MAX0(1,IWEE)
      EEE = ALPS(II)
      IF (EEE .LE. AX) GOTO 220
      AX = EEE
      IMAX = II
  220 PH3 = PH3 * 57.2958
      IF (PH3 .LT. 0.0) PH3 = PH3 + 360.
      ITAB5(II+2) = PH3 + 0.5
  230 CONTINUE
      IJ = II
      II = ITAB5(II+4)
      IF (II .EQ. 0) GOTO 240
      II = II*INCA5 + IJ
      GOTO 210
  240 IF (J .EQ. IMAX) GOTO 260
      DO 250 I=1,5
      IF (I .EQ. 4) GOTO 250
      II = IMAX + I
      JJ = J + I
      MAX = ITAB5(II)
      ITAB5(II) = ITAB5(JJ)
      ITAB5(JJ) = MAX
  250 CONTINUE
  260 CONTINUE
      RETURN
      END
      FUNCTION ALPS (I51)
      INCLUDE 'Zdiftb.inc'
      A = ITAB5(I51+1)
      B = ITAB5(I51+3)
      ALPS = (2.*A/B - 1.) * A * FAK
      RETURN
      END
      SUBROUTINE TACCEP (NLET, NTEMP)
      INCLUDE 'Zaaaa.inc'
      LOGICAL SWIPRI
      EQUIVALENCE   (SWIPRI, SWITCH(10))
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /KLAD/ ICODE(4,48), ISHIFT(48)
      COMMON /KLADC/ CHAR(12)
      CHARACTER CHAR *1
      DIMENSION IHKL(3), NLET(10), ISYMB(4), LET1(4), KARR(100)
      CHARACTER LITOUT *32
      DATA AEMIN / 0.0 /
      QEETO = QEET
  111 CONTINUE
      CALL KERNZI (0, LET1, 4)
      MAXX = (MAXA4-ISTO4) / INCA4
      IF (MAXT .GT. MAXX) MAXT = MAXX
      ISTA42 = ISTO4 + INCA4
      ISW = 1
      AMIN = 0.1
      AMAX = 5.0
  200 CALL VALDIS (-1, AMIN, AMAX, KARR, 100, NTEMP)
      FAK  = 0.2 / E000R
      FAK1 = FAK / 2.
      FAKA = FAK / 100.
      IQEET = 100. * QEET
      AMINE = 1000.
      AMAXE = 0.
  210 NTEMP = 0
      IF (ISW .NE. 3) GOTO 240
      WRITE (8, 220) AEMIN
  220 FORMAT (' For temporarily accepted reflections:',
     *        ' minimum  Alpha * E1 = ', F6.3)
      IF (.NOT. SWIPRI) GOTO 240
      WRITE (8, 230)
  230 FORMAT (/' Temporarily accepted reflections = secondary set:' /
     *        ' ', 4('  H  K  L  E1  symb.phase  W    ') /)
      CHOUT = '(4A32)'
      CALL LINPRX (8, LITOUT, 32, 4)
  240 DO 300 K=MCT,NCT,ICR
      IEW = ITAB(K+2)
      IF (IEW .LT. 0) GOTO 300
      K5 = ITAB(K+6)
      IF (K5 .EQ. 0) GOTO 300
      I5 = K5*INCA5
      IEEE = ITAB5(I5+1)
      IE = ITAB(K+7)
      IF (IDC .GT. 1) GOTO 250
      ITIP = ITAB(K+5)
      IF (ITIP .GT. -1) GOTO 250
      IF (ITIP.GT.-5 .OR. ITIP.LT.-7) GOTO 300
  250 IF (IE .GT. 399) GOTO 300
      I = IQEET * ITAB5(I5+3)
      IF (I .GT. 100*IEEE) GOTO 300
      AE = IE * IEEE
      AE = AE * FAKA
      IF (ISW .GE. 2) GOTO 260
      CALL VALDIS (0, AE, 0., KARR, 100, NTEMP)
      AMINE = AMIN1 (AMINE, AE)
      AMAXE = AMAX1 (AMAXE, AE)
      GOTO 300
  260 IF (AE .LT. AEMIN) GOTO 300
      ICOL = ITAB5(I5+5)
      CALL DECOL2 (ICOL, LET1)
      LL1 = IABS(LET1(1))
      LL2 = IABS(LET1(2))
      IF (ISW .EQ. 3) GOTO 280
      NTEMP = NTEMP + 1
      NLET(LL1) = NLET(LL1) + 1
      IF (LL2 .NE. 0) NLET(LL2) = NLET(LL2) + 1
      GOTO 300
  280 IF (NLET(LL1) .LT. 1) GOTO 300
      IF (LL2 .EQ. 0) GOTO 290
      IF (NLET(LL2) .LT. 1) GOTO 300
  290 IF (NTEMP .GE. MAXT) GOTO 350
      NTEMP = NTEMP + 1
      NLET(LL1) = NLET(LL1) + 1
      IF (LL2 .GT. 0) NLET(LL2) = NLET(LL2) + 1
      ICHKL = ITAB(K+1)
      CALL XUNPAK (ICHKL, IHKL)
      CALL IITAB4 (IHKL, K)
      W = TANH(IEEE*FAK1)**2
      FAKWS = FAKWS + W
      E1 = IE / 100.
      IE = -IE
      IF (REDUS) GOTO 295
      ITAB(K+7) = IE
      ITAB(K+2) = IE*W - 0.5
      ITAB(K+4) = 1000. * W
      ITAB(K+3) = ITAB5(I5+2)
  295 IF (.NOT. SWIPRI) GOTO 300
      CALL KERNZI (12, ISYMB(1), 4)
      IF (LET1(1) .LT. 0) ISYMB(1) = 11
      ISYMB(2) = LL1
      IF (LET1(2) .LT. 0) ISYMB(3) = 11
      IF (LL2 .GT. 0)     ISYMB(4) = LL2
      IP = ITAB5(I5+2)
      WRITE (LITOUT, FMT='(1X,3I3,F5.2,1X,4A1,'' +'',I3,''.'',F5.2,1X)')
     *               IHKL, E1, CHAR(ISYMB(1)), CHAR(ISYMB(2)),
     *               CHAR(ISYMB(3)), CHAR(ISYMB(4)), IP, W
      CALL LINPRX (0, LITOUT, 32, 4)
  300 CONTINUE
      GOTO (310, 320, 350), ISW
  310 I = MAXT + 10
      IF (KARR(1).GT.I .OR. KARR(100).GT.I) THEN
         AMIN = AMINE - 0.1
         AMAX = AMAXE + 0.1
         GOTO 200
      ENDIF
      ISW = 2
      CALL VALDIS (I, AEMIN, 0., KARR, 100, NTEMP)
      GOTO 210
  320 ISW = 3
      NLETM = 4
      IF (MS .LE. 20) NLETM = 1
      DO 340 I=1,10
      IF (NLET(I) .GE. NLETM) GOTO 330
      IF (NLET(I) .EQ. 0) GOTO 340
      NLET(I) = -1
      GOTO 340
  330 NLET(I) = 1
  340 CONTINUE
      ITEST = 0
      DO 345 I=1,10
  345 IF (NLET(I) .LT. 1) ITEST = 1
      IF (ITEST .EQ. 0) REDUS = .FALSE.
      GOTO 210
  350 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 32, 4)
      WRITE(24, 360) NTEMP
  360 FORMAT (' Number of temporarily accepted refl. (secondary set):',
     *          I4)
      IF (NTEMP .LE. 0) THEN
        WRITE (24,*) 'No temp. acc. refl. found, decrease QEET and try.'
         QEET = 0.5 * QEET -0.01
         IF (QEET .GT. 0.4 * QEETO) GOTO 111
         WRITE (24,*)'Again no temp. acc. refl. found: scaling error?'
         WRITE (24,*) 'Continuation may be unreliable, but we will try!'
         ENDIF
      FAKWS = AMAX1 (2., 0.3 * NTEMP / FAKWS)
      DO 380 I=1,10
      IF (NLET(I) .LT. 0) NLET(I) = 1
  380 CONTINUE
      WRITE (8, 390) (CHAR(I),I=1,JSYMB)
  390 FORMAT (' Symbol frequency in basic set', /, 1X, 10(3X, A1))
      WRITE (8, FMT='(1X, 10I4)') (NLET(I), I=1,JSYMB)
      RETURN
      END
      SUBROUTINE REAR2
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      INCLUDE 'Zdiftb.inc'
      COMMON /SINCOS/ IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      DO 220 K=MCT,NCT,ICR
      K5 = ITAB(K+6)
      IF (K5 .EQ. 0) GOTO 220
      E1 = ITAB(K+7) * 10.
      IF (E1 .LT. 0.0) E1 = -E1
      KK5 = K5 * INCA5
      IF (ITAB5(KK5+1) .EQ. 32767) GOTO 210
  200 EEE = ITAB5(KK5+1) / E1
      IPH = ITAB5(KK5+2)
      IF (IPH .LE. 0) IPH = IPH + 360
      ITAB5(KK5+1) = EEE * ISCT(450-IPH)
      ITAB5(KK5+2) = EEE * ISCT(IPH)
      ITAB5(KK5+3) = ITAB5(KK5+3) / E1*1000.
  210 K5 = ITAB5(KK5+4)
      IF (K5 .EQ. 0) GOTO 220
      KK5 = K5*INCA5 + KK5
      GOTO 200
  220 CONTINUE
      RETURN
      END
      SUBROUTINE SYMAN (A)
      INTEGER A(1025)
      NSY = A(1)
      M = 2**NSY
      KM = M * 2
      DO 100 I = 1, NSY
      KM = KM / 2
      LM = KM / 2
      DO 100 K=1,M,KM
      N = K + LM
      DO 100 L=1,LM
      IA = A(K+L)
      A(K+L) = IA + A(N+L)
  100 A(N+L) = IA - A(N+L)
      RETURN
      END
      INTEGER FUNCTION IITAB5 (I51, I52)
      INCLUDE 'Zdiftb.inc'
      I52 = ITAB5(I51+4)*INCA5 + I51
      IITAB5 = ITAB5(I51+4)
      RETURN
      END
      FUNCTION IALP (IA, IB)
      DIMENSION IK(50)
      DATA IK / 10149, 9510, 8887, 8286, 7711, 7161, 6641, 6151, 5693,
     *           5266, 4871, 4505, 4169, 3863, 3581, 3324, 3090, 2878,
     *           2685, 2510, 2350, 2206, 2075, 1956, 1848, 1749, 1659,
     *           1577, 1502, 1433, 1388, 1332, 1296, 1243, 1190, 1139,
     *           1089, 1056, 1008,  961,  941,  920,  899,  879,  866,
     *            853,  840,  827,  814,  801 /
      IC = MAX0(IA,IB)
      IF (IC .LT. 51) GOTO 200
      IALP = MIN0 (IA, IB, (IA+IB)/4)
      GOTO 240
  200 M = MIN0 (IA, IB)
      IF (M .LT. 3) GOTO 220
      K = IK(IA) + IK(IB)
      IF (K .GT. 10149) GOTO 220
      N = M - 1
      DO 210 I=2,N
      II = M - I
      IF (IK(II) .GT. K) GOTO 230
  210 CONTINUE
  220 IALP = 0
      GOTO 240
  230 IALP = II
  240 RETURN
      END
      SUBROUTINE DAFOMS (INCODE, EL, IPH, WS, E1, IREFL, ILINK)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL SWIPRI, EXPAND
      EQUIVALENCE   (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23))
      EQUIVALENCE (IE100, IFILE(10))
      COMMON /KLAD/ ICODE(4,48), ISHIFT(48)
      COMMON /SINCOS/ IDEG(8), ISCT
      INTEGER*2 ISCT(450)
      PARAMETER (MAXNR = 1000, MAXADR = 4000, IBEMAX = 25)
      COMMON /DAFOPC/
     *          ITAB25(4,MAXNR,IBEMAX), IWEAK(4,100), DIF(4,IBEMAX),
     *          WEAKR(4,100,IBEMAX), ITAD(-1:MAXADR), QEST(3,IBEMAX),
     *          KARR(100),  IH(3), IK(3), IL(3), IHPK(3),
     *          IHKL(3), IHPL(3), IKPL(3), IHML(3), ICODEH(3,48),
     *          P1SOL(IBEMAX),  IP1SOL(IBEMAX), P2SOL(IBEMAX),
     *          IP2SOL(IBEMAX), Q1SOL(IBEMAX),  IQ1SOL(IBEMAX),
     *          Q2SOL(IBEMAX),  IQ2SOL(IBEMAX), IPQSOL(IBEMAX)
      LOGICAL FIRST, LAUEP, PSIZ
      DATA    FIRST, LAUEP, PSIZ / .FALSE., .FALSE., .TRUE. /
      DATA MINTRI / 10 /
      DATA IBEST, IKEND, IREF, IRED, IOLD, NNSYMM / 0, 0, 0, 0, 0, 0/
      DATA J12, IICENT, NREFL, E1100, KBMAX / 0, 0, 0, 0.0, 0/
      IF (KSTAT(5) .EQ. 0) THEN
         KSTAT(5) = 1
         FIRST = .FALSE.
         ENDIF
      IF (FIRST) GOTO 210
      FIRST = .TRUE.
      KBMAX = MIN0 (INCODE, IBEMAX)
      IF (ILAUE.GT.3 .AND. .NOT.EXPAND) LAUEP = .TRUE.
      E1100 = EL
      NREFL = IPH
      IF (NREFL.GT.MAXADR) CALL KERROR
     *   ('Reduce number of reflections to MAXADR (= 4000)', 0,'DAFOMS')
      NNSYMM = NSYMM
      IICENT = ICENT
      IF (EXPAND) THEN
         NNSYMM = 1
         IICENT = 1
      ENDIF
      IBEST = 1
      IOLD = 1
      IKEND = 0
      ITAD(0)  = 0
      ITAD(-1) = 0
      IRED = 0
      CALL KERNZI (0, ITAB25, 4*MAXNR*IBEMAX)
      CALL KERNZA (0., WEAKR, 400*IBEMAX)
      CALL KERNZA (0.,  QEST, 3*IBEMAX)
      CALL KERNZI (0,  ITAD,  MAXADR)
      CALL KERNZI (0,  IWEAK,    400)
      CALL KERNZI (0,   IHKL,      3)
      RETURN
  210 IF (ILINK) 330, 340, 220
  220 IF (IOLD .NE. ILINK) GOTO 270
      IF (IKEND .GE. MAXNR) RETURN
      IF (IKEND .GE. NREFL) THEN
         WRITE (24,*) 'too many symbols. Scaling error ?? Try to go on'
            GOTO 330
         ENDIF
      IKEND = IKEND + 1
      ITAB25(1,IKEND,IBEST) = INCODE
      ITAB25(2,IKEND,IBEST) = NINT(EL*1000.)
      ITAB25(4,IKEND,IBEST) = NINT(WS*1000.)
      ITAB25(3,IKEND,IBEST) = IPH
      IF (IBEST .GT. 1) RETURN
      ITAB25(3,IKEND,1) = IPH + 370*IREFL
      IF (E1.LE.E1100 .OR. IRED.EQ.100) RETURN
      IRED = IRED + 1
      ITAB25(2,IKEND,1) = -ITAB25(2,IKEND,1)
      RETURN
  270 IF (IBEST .GT. 1) GOTO 320
      DO 310 I=1,IKEND
      IADR = ITAB25(3,I,1) / 370
      ITAB25(3,I,1) = ITAB25(3,I,1) - IADR*370
      ITAD(IADR) = I
  310 CONTINUE
      IREF = IKEND
  320 IBEST = IBEST + 1
      IF (IBEST .LE. KBMAX) THEN
          IKEND = 0
          IOLD  = ILINK
          GOTO 210
          ENDIF
      IF (KSTAT(5) .LE. 5) THEN
         KSTAT(5) = KSTAT(5) + 1
         WRITE (8, FMT='(/'' NGUY error ... after quartet problems''/)')
         ENDIF
  330 IOLD  = IOLD  + 1
      IKEND = 0
      RETURN
  340 IF (IKEND .EQ. 0) IBEST = IBEST - 1
      WRITE(24, FMT='('' Psi0 FOM and negative quartet FOM:'')')
      WRITE (8, FMT='(/'' Psi0 FOM and negative quartet FOM:'')')
      WRITE (8, 345) IREF, IRED
  345 FORMAT (' Number of reflections stored in table:  ', I4, /,
     *        ' Number of reflections in reduced table: ', I4,
     *        '  (= strongest refl.)')
      IF (IBEST .EQ. 1) THEN
          ILINK = 1
          RETURN
          ENDIF
      READ (IE100, FMT='(A80)') CHIN
      IF (SWIPRI) WRITE (8, FMT='(A80)') CHIN
      READ (CHIN, FMT='(5X, I3)') N100
      IF (N100 .LE. 10) GOTO 330
      N100 = MIN0 (N100, 100)
      DO 380 I=1,N100
      READ (IE100, FMT='(3I4)') (IWEAK(J,I), J=1,3)
      CALL KERNAI (IWEAK(1,I), IHKL, 3)
  380 IWEAK(4,I) = IGROUP(IHKL) - 1
      IF (.NOT. SWIPRI) GOTO 395
      WRITE (8, FMT='(''    (G = parity group)'')')
      WRITE (8, 385) ((IWEAK(I4,I), I4=1,4), I=1,N100)
  385 FORMAT ('   H  K  L G', / (10(1X,3I3,I2)))
      WRITE (8, 390) IREF, IRED, E1100
  390 FORMAT (' The table of ', I4, ' reflections is reduced to',
     *         I4, ' strongest reflections (min E1 = ', F5.3, ')')
      WRITE (8, FMT='('' The '', I4, '' strongest reflections:'',
     *                     /, ''   No   H  K  L'')') IREF
      DO 394 I=0,IREF-1,12
      DO 391 J=1,12
      IF (I+J .GT. IREF) GOTO 392
      J12 = J
      CALL XUNPAK (ITAB25(1,I+J,1), IHKL)
  391 CALL KERNAI (IHKL, ICODEH(1,J), 3)
  392 WRITE (8, 393) I+1, ((ICODEH(I3,I12), I3=1,3), I12=1,J12)
  393 FORMAT (I5, 12(1X,3I3))
  394 CONTINUE
  395 CALL KERNZI (0, ICODEH, 3*48)
      NREL = 0
      CALL KERNZI (0, KARR, 100)
      DO 431 IJ=1,IREF
      IF (ITAB25(2,IJ,1) .GT. 0) GOTO 431
      ITAB25(2,IJ,1) = IABS (ITAB25(2,IJ,1))
      IF (NREL .GT. 5000) GOTO 435
      CALL XUNPAK (ITAB25(1,IJ,1), IK)
      NEQ = 2
      CALL SYMEQ (IK, NEQ)
      IF (NEQ .NE. NNSYMM) GOTO 431
      NEQ2 = NEQ * 2
      DO 400 INEQ=1,NEQ
      ISHIFT(INEQ) = IDEG(ISHIFT(INEQ))
  400 ISHIFT(INEQ+NEQ) = -ISHIFT(INEQ)
      DO 430 I=1,N100
      CALL KERNAI (IWEAK(1,I), IH, 3)
      IHIT = 0
      CALL KERNZA (0., DIF, 4*IBEMAX)
      DO 410 II=1,NEQ2
      ISK = 1
      IF (II .GT. NEQ) ISK = -1
      CALL KERNAI (ICODE(1,II), IK, 3)
      CALL GENERP (IH, IK, IADR, ISHMK)
      IADR = ITAD(IADR)
      IF (IADR .EQ. 0) GOTO 415
      ISS = ISIGN(1,ISHMK)
      ISHMK = IDEG(IABS(ISHMK))
      IHIT = IHIT + 1
      DO 405 J=1,IBEST
      IPK = ISK * (ITAB25(3,IJ,J) + ISHIFT(II))
      IPHMK = ISS * (ITAB25(3,IADR,J) + ISHMK)
      IPHK = IPHMK + IPK
      IPHK = MOD(IPHK, 360)
      IF (IPHK .LE. 0) IPHK = 360 + IPHK
      EH = FLOAT (ITAB25(2,IJ,J)) / 1000.
      EK = FLOAT (ITAB25(2,IADR,J)) / 1000.
      EHEK = EH * EK
      ICOSHK = ISCT(450-IPHK)
      COSHK = FLOAT(ICOSHK) / 1000.
      EHEKC = EHEK * COSHK
      DIF(1,J) = DIF(1,J) + EHEKC
      IF (IICENT .EQ. 1) THEN
          ISINHK = ISCT(IPHK)
          SINHK = FLOAT(ISINHK) / 1000.
          EHEKS = EHEK * SINHK
          EHEK2 = EHEKC**2 + EHEKS**2
          DIF(2,J) = DIF(2,J) + EHEKS
          DIF(3,J) = DIF(3,J) + SQRT(EHEK2)
          DIF(4,J) = DIF(4,J) + EHEK2
      ELSE
          DIF(3,J) = DIF(3,J) + ABS(EHEKC)
          DIF(4,J) = DIF(4,J) + EHEKC**2
          ENDIF
  405 CONTINUE
  410 CONTINUE
  415 CONTINUE
      IF (IHIT .GT. 0) THEN
          KARR(I) = KARR(I) + IHIT
          NREL = NREL + IHIT
          DO 420 J=1,IBEST
          WEAKR(1,I,J) = WEAKR(1,I,J) + DIF(1,J)
          WEAKR(2,I,J) = WEAKR(2,I,J) + DIF(2,J)
          WEAKR(3,I,J) = WEAKR(3,I,J) + DIF(3,J)
  420     WEAKR(4,I,J) = WEAKR(4,I,J) + SQRT(DIF(4,J))
          ENDIF
  430 CONTINUE
  431 CONTINUE
      GOTO 437
  435 WRITE (8, FMT='('' PSI0 generation is stopped at refl. No.'',
     *                     I3, 2X, 3I4)') IJ, IK
      DO 436 I=IJ,IREF
  436 ITAB25(2,I,1) = IABS (ITAB25(2,I,1))
  437 WRITE(24, 440) N100, NREL
      WRITE (8, 440) N100, NREL
  440 FORMAT (' The ', I3, ' weakest reflections take part in', I5,
     *        ' triplet relationships.')
      IHIT = 0
      JREFL = 0
      CALL KERNZA (0.0001, DIF, 4*IBEMAX)
      DO 460 I=1,N100
      IF (KARR(I) .LT. MINTRI) GOTO 460
      JREFL = JREFL + 1
      IHIT = IHIT + KARR(I)
      DO 450 J=1,IBEST
      WEAKR(1,I,J) = SQRT(WEAKR(1,I,J)**2 + WEAKR(2,I,J)**2)
      DIF(1,J) = DIF(1,J) + WEAKR(1,I,J)
      DIF(2,J) = DIF(2,J) + WEAKR(3,I,J)
      DIF(3,J) = DIF(3,J) + WEAKR(4,I,J)
  450 CONTINUE
  460 CONTINUE
      IF (IHIT .EQ. 0) THEN
          WRITE (8, 470)
  470     FORMAT (/' Sory, PSIzero FOM not possible, there are not ',
     *            'enough hits (10) per weak refl.')
          NREL = 0
          PSIZ = .FALSE.
          GOTO 530
          ENDIF
      HIT = FLOAT(IHIT) / FLOAT(JREFL)
      WRITE (8, 480) IBEST, JREFL, HIT
  480 FORMAT (/' PSIzero FOM for the ', I2, ' best solutions',
     *        ' (with old solution numbers)', /,
     *        '    (for ',I3, ' weak reflections and number of hits',
     *        ' per reflection is ', F5.1, '):', /,
     *        '    PSIzero(1) = sum |sum(E(K) * E(H-K))| / sum(sum|',
     *        'E(K) * E(H-K)|)', /,
     *        '    PSIzero(2) = sum |sum(E(K) * E(H-K))| / sum(sum|',
     *        'E(K) * E(H-K)|**2)**1/2')
      WRITE (8, FMT='(20X, ''PSI(1)'', 11X, ''PSI(2)'')')
      DO 490 J=1,IBEST
      DIF12    = DIF(1,J) / DIF(2,J)
      DIF13    = DIF(1,J) / DIF(3,J)
      DIF(1,J) = DIF12
      DIF(2,J) = DIF13
      P1SOL(J) = DIF12
  490 P2SOL(J) = DIF13
      CALL ORDTAB (P1SOL, IP1SOL, IBEST)
      CALL ORDTAB (P2SOL, IP2SOL, IBEST)
      P2MIN = P2SOL(1)
      DO 510 J=1,IBEST
      WRITE (8, 500) J, P1SOL(J), IP1SOL(J), P2SOL(J), IP2SOL(J)
  500 FORMAT (1X, I2, '. solution: ', 2(F9.4, ' - ', I2, 3X))
      P1SOL(J) =  P2MIN / DIF(2,J)
  510 CONTINUE
  530 CONTINUE
      E4MIN = 0.0
      NEGQ = 0
      DO 621 I=1,N100-2
      IF (NEGQ .GT. 500) GOTO 630
      CALL KERNAI (IWEAK(1,I), IHPK, 3)
      NEQI = 1
      CALL SYMEQ (IHPK, NEQI)
      IF (NEQI .NE. NNSYMM) GOTO 621
      DO 560 INEQ=1,NEQI
      DO 560 I3=1,3
  560 ICODEH(I3,INEQ) = ICODE(I3,INEQ)
      IPHPK = IWEAK(4,I)
      DO 622 II=I+1,N100-1
      CALL KERNAI (IWEAK(1,II), IHPL, 3)
      NEQII = 1
      CALL SYMEQ (IHPL, NEQII)
      IF (NEQII .NE. NNSYMM) GOTO 622
      IPHPL = IWEAK(4,II)
      IPKPL = IPHPK + IPHPL
      IPKPL = MIN0 (IPKPL, 14-IPKPL)
      IF (IPHPK-IPHPL .EQ. 0) IPKPL = 0
      DO 623 IIN=1,NEQII
      CALL KERNAI (ICODE(1,IIN), IHPL, 3)
      DO 624 III=II+1,N100
      IF (.NOT. LAUEP .AND. IWEAK(4,III).NE.IPKPL) GOTO 624
      CALL KERNAI (IWEAK(1,III), IKPL, 3)
      DO 620 IN=1,NEQI
      DO 570 I3=1,3
      IHPK(I3) = ICODEH(I3,IN)
      IHML(I3) = IHPK(I3) - IKPL(I3)
      IL(I3) = IHPL(I3) - IHML(I3)
      IF (.NOT. LAUEP) GOTO 570
      IF (MOD(IL(I3),2) .NE. 0) GOTO 620
  570 IL(I3) = IL(I3) / 2
      CALL GENERQ (IL, ISHL, IADL)
      IADL = ITAD(IADL)
      IF (IADL .EQ. 0) GOTO 620
      DO 580 I3=1,3
  580 IK(I3) = IKPL(I3) - IL(I3)
      CALL GENERQ (IK, ISHK, IADK)
      IADK = ITAD(IADK)
      IF (IADK .EQ. 0) GOTO 620
      DO 590 I3=1,3
  590 IH(I3) = IHPL(I3) - IL(I3)
      CALL GENERQ (IH, ISHH, IADH)
      IADH = ITAD(IADH)
      IF (IADH .EQ. 0) GOTO 620
      DO 600 I3=1,3
  600 IHKL(I3) = -IHPL(I3) - IK(I3)
      CALL GENERQ (IHKL, ISHHKL, IADHKL)
      IADHKL = ITAD(IADHKL)
      IF (IADHKL .EQ. 0) GOTO 620
      NEGQ = NEGQ + 1
      ISSH = ISIGN(1,ISHH)
      ISHH = IDEG(IABS(ISHH))
      ISSK = ISIGN(1,ISHK)
      ISHK = IDEG(IABS(ISHK))
      ISSL = ISIGN(1,ISHL)
      ISHL = IDEG(IABS(ISHL))
      ISSHKL = ISIGN(1,ISHHKL)
      ISHHKL = IDEG(IABS(ISHHKL))
      DO 610 J=1,IBEST
      EH = FLOAT (ITAB25(2,IADH,J)) / 1000.
      EK = FLOAT (ITAB25(2,IADK,J)) / 1000.
      EL = FLOAT (ITAB25(2,IADL,J)) / 1000.
      EHKL = FLOAT (ITAB25(2,IADHKL,J)) / 1000.
      E4  = EH * EK * EL * EHKL
      IF (E4 .LT. E4MIN) GOTO 610
      IPH = ISSH * (ITAB25(3,IADH,J) + ISHH)
      IPK = ISSK * (ITAB25(3,IADK,J) + ISHK)
      IPL = ISSL * (ITAB25(3,IADL,J) + ISHL)
      IPHKL = ISSHKL * (ITAB25(3,IADHKL,J) + ISHHKL)
      IPH4 = IPH + IPK + IPL + IPHKL
      IPH4 = MOD(IPH4, 360)
      IF (IPH4 .LE. 0) IPH4 = 360 + IPH4
      ICOS4 = ISCT(450-IPH4)
      COS4 = FLOAT(ICOS4) / 1000.
      ISIN4 = ISCT(IPH4)
      SIN4 = FLOAT(ISIN4) / 1000.
      E4 = SQRT((E4*COS4)**2 + (E4*SIN4)**2)
      QEST(1,J) = QEST(1,J) + E4*COS4
      QEST(2,J) = QEST(2,J) + E4
      QEST(3,J) = QEST(3,J) + E4*ABS(180.-FLOAT(IPH4))
  610 CONTINUE
  620 CONTINUE
  624 CONTINUE
  623 CONTINUE
  622 CONTINUE
  621 CONTINUE
      GOTO 631
  630 WRITE (8, FMT='(/'' Negative quartet generation is stopped'',
     *  '' at weak refl. No.'', I3, 2X, 3I4)')  I, (IWEAK(I3,I), I3=1,3)
  631 IF (NEGQ .LT. 5) THEN
          WRITE (8, 640) NEGQ
  640     FORMAT (/' Sorry, Negative Quartet FOM not possible, there',
     *            ' are only ', I1, ' hits ')
          IF (.NOT. PSIZ) RETURN
          CALL KERNZA (0.0, Q1SOL, IBEST)
          GOTO 690
          ENDIF
      WRITE(24, 645) N100, NEGQ
  645 FORMAT (' The ', I3, ' weakest reflections take part in', I5,
     *        ' negative quartets.' )
      WRITE (8, 650) N100, NEGQ
  650 FORMAT (/' The ', I3, ' weakest reflections take part in', I4,
     *        ' negative quartets.' /
     *        ' Negative quartet FOMs (with old solution numbers):', /,
     *        '  Hauptman: NQEST = sum (E4 * cos(PH4)) / sum E4 ',
     *        '   (here: NQEST + 1)', /,
     *        '  Schenk:   NQC   = sum (E4 * |180-PH4|)         ',
     *        '   (here: NQC / sum E4 * 180)', /,
     *        20X, 'NQEST', 11X, 'NQC')
      DO 660 J=1,IBEST
      QEST(1,J) = 1. + QEST(1,J) / QEST(2,J)
      QEST(2,J) = QEST(3,J) / (QEST(2,J) * 180.)
      Q1SOL(J) = QEST(1,J)
  660 Q2SOL(J) = QEST(2,J)
      CALL ORDTAB (Q1SOL, IQ1SOL, IBEST)
      CALL ORDTAB (Q2SOL, IQ2SOL, IBEST)
      Q1MIN = Q1SOL(1)
      Q2MIN = Q2SOL(1)
      DO 680 J=1,IBEST
      WRITE (8, 670) J, Q1SOL(J), IQ1SOL(J), Q2SOL(J), IQ2SOL(J)
  670 FORMAT (I3, '. solution: ', 2(F9.4, ' - ', I2, 3X))
      IF (QEST(1,J) .LE. 0. .OR. QEST(2,J) .LE. 0.) THEN
      WRITE (8, FMT='('' negative quartets: zero QUEST error'')')
          Q1SOL(J) = 0.1111
      ELSE
      Q1SOL(J) = (Q1MIN/QEST(1,J) + Q2MIN/QEST(2,J)) / 2.
         ENDIF
  680 CONTINUE
  690 IPQSOL(1) = NREL
      IPQSOL(2) = NEGQ
      CALL COMFOM (P1SOL, Q1SOL, IPQSOL, IBEST)
      ILINK = IPQSOL(1)
      WRITE (8, FMT='( '' Combined FOM: best solution is solution'',
     *       '' No. '', I3)') ILINK
      FIRST = .FALSE.
      RETURN
      END
      SUBROUTINE GENERP (IH, IK, IADR, ISHMK)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      DIMENSION IH(3), IK(3), IHMK(3)
      IADR = -1
      DO 200 I=1,3
      IHMK(I) = IH(I) - IK(I)
  200 IF (IABS(IHMK(I)) .GT. MAXHKL(I)) GOTO 230
      ICOHMK = INPACK(IHMK)
      KC = IABS(ICOHMK)
      IF (KC.EQ.0 .OR. KC.GT.MCT) GOTO 230
      K = ITAB(KC)
      IF (K .EQ. 0) GOTO 230
      L = IABS(K) / 4096
      ISHMK = (L + 1) * ISIGN(1,K) * ISIGN(1,ICOHMK)
      IADR = IABS(K) - 4096*L
  230 RETURN
      END
      SUBROUTINE GENERQ (IHKL, ISHIFT, IADR)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zdifta.inc'
      DIMENSION IHKL(3)
      IADR = -1
      DO 210 I=1,3
  210 IF (IABS(IHKL(I)) .GT. MAXHKL(I)) GOTO 230
      ICODE = INPACK(IHKL)
      KC = IABS(ICODE)
      IF (KC.EQ.0 .OR. KC.GT.MCT) GOTO 230
      K = ITAB(KC)
      IF (K .EQ. 0) GOTO 230
      L = IABS(K) / 4096
      ISHIFT = (L + 1) * ISIGN(1,K) * ISIGN(1,ICODE)
      IADR = IABS(K) - 4096*L
  230 RETURN
      END
      SUBROUTINE ORDTAB (URD, IORD, IOMAX)
      INCLUDE 'Zsyst.inc'
      PARAMETER (IMAX = 25)
      DIMENSION URD(IMAX), IORD(IMAX), ORD(IMAX)
      IOMAX = MIN0 (IOMAX, MIN0 (IOMAX,IMAX))
      CALL KERNZI (0, IORD, IOMAX)
      CALL KERNZA (0., ORD, IOMAX)
      JJ = 1
      DO 250 I=1,IOMAX
      IF (I .EQ. 1) GOTO 240
      DO 210 J=1,I-1
      IF (URD(I) .GT. ORD(J)) GOTO 210
      JJ = J
      GOTO 220
  210 CONTINUE
      JJ = I
      GOTO 240
  220 DO 230 K=I,JJ+1,-1
      ORD(K)   = ORD(K-1)
  230 IORD(K)  = IORD(K-1)
  240 ORD(JJ)  = URD(I)
      IORD(JJ) = I
  250 CONTINUE
      CALL KERNAB (ORD(1), URD(1), IOMAX)
      RETURN
      END
      SUBROUTINE COMFOM (P1SOL, Q1SOL, IPQSOL, IBEST)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zdiftb.inc'
      PARAMETER (IBEMAX = 25)
      DIMENSION P1SOL(IBEMAX), Q1SOL(IBEMAX), IPQSOL(IBEMAX),
     *          C1SOL(IBEMAX), C2SOL(IBEMAX),  C3SOL(IBEMAX),
     *          CFSOL(IBEMAX)
      DATA WC1, WC2, WPSI, WNEQ / 2., 4., 4., 6. /
      IF (IPQSOL(1) .LT.  20) WPSI = 2.
      IF (IPQSOL(1) .EQ.   0) WPSI = 0.
      IF (IPQSOL(2) .GT. 290) WNEQ = 7.
      IF (IPQSOL(2) .LT.  20) WNEQ = 2.
      IF (IPQSOL(2) .LT.   5) WNEQ = 0.
      WSUM = WC1 + WC2 + WPSI + WNEQ
      WC1  = WC1  / WSUM
      WC2  = WC2  / WSUM
      WPSI = WPSI / WSUM
      WNEQ = WNEQ / WSUM
      CALL KERNZI (0, IPQSOL, IBEST)
      DO 200 I=1,IBEST
      C1SOL(I) = FLOAT(KB10X(12,I)) / 1000.
      C2SOL(I) = FLOAT(KB10X(13,I)) / 1000.
  200 CFSOL(I) = C1SOL(I) * WC1   +  C2SOL(I) * WC2  +
     *           P1SOL(I) * WPSI  +  Q1SOL(I) * WNEQ
      CALL KERNZA (0., C3SOL, IBEST)
      JJ = 1
      DO 250 I=1,IBEST
      IF (I .EQ. 1) GOTO 240
      DO 210 J=1,I-1
      IF (CFSOL(I) .LT. C3SOL(J)) GOTO 210
      JJ = J
      GOTO 220
  210 CONTINUE
      JJ = I
      GOTO 240
  220 DO 230 K=I,JJ+1,-1
      C3SOL(K)  = C3SOL(K-1)
  230 IPQSOL(K) = IPQSOL(K-1)
  240 IPQSOL(JJ) = I
      C3SOL(JJ)  = CFSOL(I)
  250 CONTINUE
      CALL KERNZA (0., C3SOL, IBEST)
      DO 260 I=1,IBEST
  260 C3SOL(IPQSOL(I)) = FLOAT(I)
      CALL KERF2I (C3SOL, IPQSOL, IBEST)
      WRITE (8, FMT = '('' Combined FOM:'', /,
     *  ''                 CONS1   CONS2    PSI0    NEQ ''/
     *  '' Rel.weights '', 4F8.3 /
     *  '' No  orig.No'' , 40X, ''CFOM  Range'')')
     *                      WC1, WC2, WPSI, WNEQ
      IPQMIN = IBEST
      DO 270 J=1,IBEST
      IF (IPQSOL(J) .LT. IPQSOL(IPQMIN)) IPQMIN = J
      N = KB10X(11,J)
  270 WRITE (8, 280) J, N, C1SOL(J), C2SOL(J), P1SOL(J), Q1SOL(J),
     *                 CFSOL(J), IPQSOL(J)
  280 FORMAT (I3, I6, F13.3, 4F8.3, I4)
      IPQSOL(1) = IPQMIN
      RETURN
      END
      SUBROUTINE NUTS
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ICRYS, IFILE(3)), (ICON, IFILE(4))
      EQUIVALENCE (IDOKA, KEYS(10))
      EQUIVALENCE (IRUN, KSTAT(13))
      CHARACTER * 2 ISTAR
      CHARACTER *6 L(20), LL
      CHARACTER *72 FMHELP(4)
      DATA LMAX, LMAXP / 20, 16/
      DATA L    /  'NUTS'  , 'AT2X'  , 'X2AT'  , 'FR2HKL', '$$PTB$',
     *             'BIJVOE', 'SHAT'  , 'EULER' , 'INVERT', '$$PTB$',
     *             '$$PTB$', 'SHELIN', 'SELECT', 'PRIFC' , 'SHELXL',
     *             'FCALG' , '$$PTB$', 'R'     , 'H'     , 'Q'       /
      DATA ISTAR / '**' /
      DATA FMHELP /
     *' AT2X, X2AT : transform ATOMS file to SHELX XYZN file, and v.v.',
     *' SHAT, EULER and INVERT : shift, rotate or invert atomic coords',
     *' PRIFC   : print FC: temp: exit',
     *' BIJVOET : calc. Bijvoet coefficients, find absolute structure'/
      ICONT = 0
      CALL KEPROG ('NUTS')
      LL  = LITJ2
      IF (LL .EQ. 'NUTS') LL = LITJ3
      IF (LL .EQ. ' ') GOTO 107
      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 (9, 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, 4
  114    WRITE (9, FMT = '(A72)') FMHELP(I)
         GOTO 110
         ENDIF
      CALL KEREQ6 (LL, L, LMAX, KEND)
      IF (KEND.LE.1) THEN
         WRITE (9, 202)
  202    FORMAT (' Answer not understood: please, try again:')
         GOTO 110
         ENDIF
  206 PROGNM = LL
      CALL WR24
      WRITE (9, FMT='(1X /'' ============ Program '', A8)') PROGNM
      IF (PROGNM .EQ. 'BIJVOE') PROGNM = 'BIJVOET'
      WRITE (24, 207) (ISTAR, I=1,23), PROGNM, (ISTAR, I=1,23)
  207 FORMAT (/ 1X, 23A2 / ' ****', 38X, '****' / ' ****', 16X, A8,
     +       14X, '****' / ' ****', 38X, '****' / 1X, 23A2 / 1X )
      GOTO (2,2,3,4,5,6,7,8,9, 5,5, 12,13,14,15,16,18,18,19,20), KEND
  2   CALL AT2X
      IF (LITJ2 .EQ. 'NUTS' .OR. LITJ2 .EQ. 'AT2X') GOTO 770
      CALL COMPAT
      GOTO 770
  3   CALL X2AT
      GOTO 770
  4   CALL FR2HKL
      GOTO 770
  5   STOP 501
  6   CALL BIJVOE
      IF (IDOKA .EQ. 17) RETURN
      GOTO 770
  7   CALL SHAT
      GOTO 770
  8   CALL EULER
      GOTO 770
  9   CALL INVERT
      IF (KSTAT(14) .EQ. 1) RETURN
      GOTO 770
  12  CONTINUE
      WRITE (9, 212)
  212 FORMAT (
     *' Various output files with atomic parameters.'/
     *' Note: XYZN = control data + atomic params for SHELXL !'/
     *'       and CCODE.res is a copy of  XYZN  .')
      CALL AT2X
      GOTO 770
  13  CALL SELECT
      GOTO 770
  14  CALL PRIFC
      GOTO 770
  15  CONTINUE
      CALL AT2X
      GOTO 770
  16  CALL FCALG
      GOTO 990
  18  IF (ICONT.EQ.0) GOTO 800
      GOTO 110
  19  IF (ICONT.EQ.0) GOTO 800
      WRITE (9, 719)
  719 FORMAT (' Possible options are:'/
     *  ' AT2X   = convert ATOMS file to eXternal par. file format' /
     *  ' X2AT   = convert SHELX param. file to ATOMS file' /
     *  ' BIJVOET  calc. Bijvoet coefficients, find absolute structure'/
     *  ' etc.  ,  please try again:')
      GOTO 110
  20  IF (ICONT.EQ.0) GOTO 800
      WRITE (9, 720)
  720 FORMAT (' So you quit.')
      GOTO 990
  770 IF (ICONT .EQ. 0) GOTO 990
      WRITE (9, 777)
  777 FORMAT (' DONE'/1X/' Do you wish to run more options? Say Q or:')
      GOTO 110
  800 CALL KERROR ('Illegal parameter', 800, 'NUTS')
  990 WRITE(24, 992) PROGNM
  992 FORMAT (/' End of program ', A8)
      IF (KSTAT(14) .EQ. 1) GOTO 995
         CALL KERASE ('CONDA')
  995 PROGNM = 'NUTS'
      CALL KEPROX
      RETURN
      END
      SUBROUTINE AT2X
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IDDL, IFILE(1)), (ICRIN, IFILE(4))
      EQUIVALENCE (IATOMS, IFILE(2)), (ICRYS, IFILE(3))
      EQUIVALENCE (IATOLD, IFILE(10))
      EQUIVALENCE (ISPEK, IFILE(14)), (ISHEL, IFILE(11))
      EQUIVALENCE (ISCHAK, IFILE(12))
      EQUIVALENCE (IRUN, KSTAT(13))
      EQUIVALENCE (KPROG, KSTAT(18))
      DIMENSION IUNIT(10),LATT(7)
      PARAMETER (MAXAT=2513)
      COMMON /BLANK/ DUMMYF(19630),
     *               ATXYZ(10,MAXAT),IZAT(MAXAT),ITAT(MAXAT), PTBXX(2),
     *               DUMMYT(110212)
      COMMON /ATNAMB/ ATNAME(MAXAT)
      CHARACTER*6   ATNAME
      CHARACTER*1 LRR
      DIMENSION IZTYPA(10)
      PARAMETER (U2B = 8. * 3.141593 **2)
      DATA LATT / 1,5,6,7,2,4,3 /
      DATA TF / 0.06/
      CALL RDCRYS (ICRYS)
      DO 110 I= 1, NTYPE
  110 CALL ATOMIZ (CELATY(I), NLET, IZTYPA(I))
      CALL FILINQ (ISCHAK, 'SCHAKL', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ISCHAK, 217) CCODE
      WRITE (ISCHAK, 219) CELL
      WRITE(24, FMT='(
     *   '' Output SCHAKAL file is denoted  SCHAKL'')')
      WRITE(24, FMT='(
     *   '' Output SHELX file is '', A6, ''.res'')') CCODER
      CALL FILINQ (ISHEL, 'RES' , 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (ISHEL, FMT = '(''TITL file '', A6,''.res = '',
     *   ''= DIRDIF output for SHELX'')') CCODER
      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)
         LRR = '+'
      IF (ICENT .EQ. 1) LRR = '-'
      WRITE (ISHEL, FMT = '(''LATT  '', A1, I1)') LRR, 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 = ' '
      WRITE(24, FMT='('' Output file for PLUTON (Spek) is  '',A6,
     *   ''.spf''/)') CCODER
      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)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found',
     *   221, 'AT2X')
      FVAR = - 999.
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      WRITE (24,*) 'Transform ATOMS parameter file format to: '
      WRITE (24,*) '     SPF, SCHAKAL and RES files'
      IF (NFNUM .LE. 0) GOTO 231
      IF (LIT(NLIT). EQ. 'SC=' .AND. FNUM(NFNUM) .GT. 0.001) THEN
         FVAR = 1. / FNUM(NFNUM)
         WRITE (24,*) '      FVAR = 1 / SCALE from the ATOMS file '
         ENDIF
  231 CALL LOGRD (IDDL, 'MERBSC', KLOG)
      CALL FILCLO (IDDL, 'KEEP')
      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)'
            WRITE(24, FMT = '(A72)') CHOUT
            ENDIF
         TF = FNUM(3) /U2B
         WRITE (24,*) '      MERBIN U(iso) (from the DDLOG file)'
         ENDIF
      IF (FVAR .LT. 0.0) FVAR = 1.
      WRITE(ISHEL, FMT = '(''FVAR  '', F10.5)') FVAR
      CALL ATOMST (1, ATXYZ, NAT, KEYT)
      CALL WR24
      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?)'
      WRITE (9, FMT='(A)') CHOUT
  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 )
      WRITE (ISPEK, 276) ATNAME(I), (ATXYZ(J,I),J=1,3)
  276 FORMAT (A6,2X,3F10.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, 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)))
  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')
         WRITE (ISPEK, 311)
  311    FORMAT ('LABELS OFF'/'BOX OFF'/'EXCL Q'/'STRAW COL'/'PLOT')
         CALL FILCLO (ISPEK, 'KEEP')
      CALL FILCLO (ISCHAK, 'KEEP')
      REWIND ICRYS
      CALL FILCLO (IATOMS, 'KEEP')
      WRITE (9, 412) CCODER
  412 FORMAT (14X,
     *   'Output file for use in SHELX : file ', A6, '.res')
      CALL FILINQ (ISHEL,  'RES',   'FORMATTED', 'INPUT', KINQ)
      CALL FILINQ (ISCHAK, 'MERCUR','FORMATTED', 'OUTPUT', KINQ)
  511 READ  (ISHEL, FMT='(A80)', END=512) CHIN
      WRITE (ISCHAK, FMT='(A80)') CHIN
      GOTO 511
  512 CONTINUE
      CALL FILCLO (ISHEL, 'KEEP')
      CALL FILCLO (ISCHAK, 'KEEP')
      RETURN
      END
      SUBROUTINE X2AT
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IXYZN,  IFILE(1) )
      EQUIVALENCE (IATOMS, IFILE(2) )
      EQUIVALENCE (ICRYS,  IFILE(3) )
      EQUIVALENCE (IATOLD, IFILE(10))
      PARAMETER (MAXAT=2513)
      COMMON /BLANK/ DUMMYF(19630),
     *               ATXYZ(10,MAXAT),IZAT(MAXAT),ITAT(MAXAT), PTBXX(2),
     *               DUMMYT(110212)
      COMMON /ATNAMB/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DIMENSION   B(MAXAT), NLET(10), IZTYPA(10)
      DIMENSION  HU(MAXAT)
      CHARACTER * 1 ISF
      CALL RDCRYS (ICRYS)
      CALL FILCLO (IXYZN, 'KEEP')
      CALL FILINQ (IXYZN, 'INS', 'FORMATTED', 'INPUT', KINQI)
      IF (KINQI .EQ. 0) THEN
         WRITE (9, FMT='('' Input file : '', A6, ''.ins '')') CCODE
         GOTO 100
         ENDIF
      CALL FILCLO (IXYZN, 'KEEP')
      CALL FILINQ (IXYZN, 'RES', 'FORMATTED', 'INPUT', KINQR)
      IF (KINQR .EQ. 0) THEN
         WRITE (9, FMT='(1X/'' Program change March 2008: ''/
     * '' Shelx file ccode.ins should be used as input file,''/
     * '' the file ccode.res is used as an output file.''/
     * '' Sorry for the inconvenience!''/)')
         CALL KERNER ( -2, 'X2AT')
         ENDIF
      CALL FILCLO (IXYZN, 'KEEP')
      CALL FILINQ (IXYZN, 'XYZN', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. 0) THEN
         WRITE (9, FMT='(1X/'' Program change March 2008: ''/
     * '' Parameter file XYZN  is obsolete! ''/
     * '' Shelx file ccode.ins should be used as input file,''/
     * '' the file ccode.res is used as an output file.''/
     * '' Sorry for the inconvenience!''/1X)')
         CALL KERNER ( -2, 'X2AT')
         ENDIF
  100 CONTINUE
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IATOMS, 110) CCODE
  110 FORMAT ('ATOMS', 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 (9, 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(24, 240)  NAT
  240 FORMAT (' AT2X: Number of atoms input is',  I5 )
      RETURN
  250 CALL KERROR ('Input file  incorrect',0,'X2AT')
      RETURN
      END
      SUBROUTINE ATSHEL (IXYZN, ATXYZ, ATNAME, IZAT, MAXAT, NAT)
      DIMENSION ATXYZ (10, MAXAT), IZAT(MAXAT)
      CHARACTER * 6  ATNAME(MAXAT)
      INCLUDE 'Zsyst.inc'
      CHARACTER * 6  L(74)
      DATA  LMAX / 74 /
      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', 'DANG', 'HOPE', 'HTAB', 'NCSY', 'STIR' /
      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)
      DIMENSION ATXYZ (10, MAXAT), IZAT(MAXAT)
      CHARACTER * 6  ATNAME(MAXAT)
      INCLUDE 'Zsyst.inc'
      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
      IF (KELAST.NE.9) GOTO 120
      I1 = 1
  110 I = I + 1
      IF (I .GT. 10) 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
      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 (9,150) MFVAR
  150 FORMAT (' TOO MANY FREE VARIABLES, MAXIMUN ', I2)
      GOTO 200
  160 CONTINUE
      IF (KEY1 .GT. 0) GOTO 100
      KEACT = 0
      IF (NLIT.GT.1) KEACT = NLUSER(NLIT)
      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), 7)
      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. 10) 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)
      INCLUDE 'Zsyst.inc'
      CHARACTER ZZZ *1, ZZZZ *2
      IZ = 0
      IF (NFDOL(1).GE.0) RETURN
      I = NCOLL(1)
      ZZZZ = CHIN(I:I+1)
      CALL ATOMIZ (ZZZZ, 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)
      ZZZZ = CHIN(1:2)
      CALL ATOMIZ (ZZZZ, NLET, I)
      IF (I.NE.IZ) GOTO 150
      I = NLET + 1
      IF (CHIN(I:I).EQ.' ') GOTO 140
      ZZZ = CHIN(I:I)
      CALL KERC2I (ZZZ, 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, 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)
      DIMENSION ATXYZ (10, 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 FR2HKL
      INCLUDE 'Zsyst.inc'
      DIMENSION NHKL(3)
      CHARACTER IE *1
      CHARACTER *6 XHKL(4)
      DATA XHKL / 'FREFB', 'FREFC', 'FREFA', 'FREF' /
      CALL FILCLO (11, 'KEEP')
      DO 110 ID = 1, 4
      CALL FILINQ (11, XHKL(ID), 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. 0) GOTO 120
  110 CONTINUE
      CALL KERROR ('No FREF file found', 0, 'FR2HKL')
  119 CONTINUE
      CALL KERROR(' Empty FREF file', 119, 'FR2HKL')
  120 CONTINUE
      CHIN = ' '
      READ (11, FMT='(A28)', END=119) CHIN(1:28)
      WRITE (9, 140) XHKL(ID), CHIN(1:28)
  140 FORMAT (' Input data file: ', A6, ' Header: ', A28)
      CALL KERINB (LIT, 1)
      IF (LIT(1)(1:4) .NE. 'FREF')
     *   CALL KERROR ('File name and header inconsistent' , 0, 'FR2HKL')
      IF (LIT(2) .NE. CCODE)
     *    CALL KERROR ('Input file has incorrect CCODE', -6, 'FR2HKL')
      CALL FILCLO (12, 'KEEP')
      CALL FILINQ (12, 'HKL', 'FORMATTED', 'OUTPUT', KINQ)
  410 READ (11, 415, END=418) IE, NHKL, JC, FOBS, SIG
  415 FORMAT (A1, 3I3 ,I2, F9.2, F7.2)
      IF (FOBS .LT. 0.001) FOBS = 0.001
      SIG  = AMAX1 (SIG, FOBS / 1000. , 0.001)
      IF (JC .EQ. 2) THEN
         SIG1 = AMAX1(FOBS/6.0, SIG)
         SIG = SIG1 * (2. * FOBS + SIG1)
         IF (FOBS .LT. SIG1) SIG = 10. * SIG1
      ELSE
         SIG = SIG * 2. * FOBS
         ENDIF
      FOBS = FOBS**2
      WRITE (12, 435) NHKL, FOBS, SIG
  435 FORMAT (3I4, 2F8.2)
      IF (IE .NE. 'E') GOTO 410
  417 CALL FILCLO (11, 'KEEP')
      WRITE (9, FMT='('' Output file: '',A6,''.hkl'')')  CCODE
      CALL FILCLO (12, 'KEEP')
      CALL WR24
      RETURN
  418 WRITE (9, FMT='('' Warning: sentinel E missing on FREF file '')')
      GOTO 417
      END
      SUBROUTINE PRIFC
      WRITE (6, FMT='('' PRIFC temp out of order... sorry'')')
      STOP 510
      END
      SUBROUTINE BIJVOE
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IXYZN,  IFILE(1) ), (IATOMS, IFILE(2) )
      EQUIVALENCE (IDOKA,  KEYS(10))
      IF (KSTAT(14) .EQ. 1) GOTO 200
      CALL FILINQ (IXYZN, 'INS', 'FORMATTED', 'INPUT', KINIXI)
      CALL FILCLO (IXYZN, 'KEEP')
      WRITE (9, 113)
  113 FORMAT (1X/' Program change March 2008:'/
     * ' XXX  Use SHELX file ccode.ins as input for BIJVOET. '/
     * ' XXX  File ccode.res is used as output file only in case the'/
     * ' XXX  absolute structure is inverted bij the program BIJVOET.'/
     * ' XXX  If ccode.ins does not exist: use atoms for input.'/1X)
      WRITE (24, 114)
  114 FORMAT (1X/' The program Bijvoet determines the'/
     * ' absolute configuration or "absolute structure" of a crystal,'/
     * ' expressed by the weighted Bijvoet-coefficient B:'/
     * '    B = sum(w * dFc * dFo) / sum(w * abs(dFc * dFo))'/
     * '    where w = 1 / sig(dFo)**2 = variance of dFo, ' /
     * '    dFc = Fc(h)-Fc(-h), dFo = Fo(h)-Fo(-h) [c=calc, o=obs]'/)
      IF (KINIXI .NE. 0 ) THEN
         WRITE (9, *) 'No ccode.ins file present: use atoms file'
         GOTO 200
         ENDIF
      WRITE (9, *) 'Transform ccode.ins file to the atoms file'
      CALL X2AT
  200 CONTINUE
      CALL WR24
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINIA)
      IF (KINIA .NE. 0) CALL KERROR(' ATOMS file missing', 0, 'BIJVOE')
      CALL MERBIB
      IF (IDOKA .EQ. 17) RETURN
      CALL FCALCB
      CALL BIJVOX
      RETURN
      END
      SUBROUTINE MERBIB
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zbinx1.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IDDL,  IFILE(1))
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (IDOKA, KEYS(10))
      PARAMETER (MAXA=6000)
      COMMON /BLANK/ AREF(7, MAXA), DUMMY(118000)
      PARAMETER (FMAXA=6000.)
      DIMENSION HKL(3), HKL2(3), HMAX(3), HMIN(3)
      LOGICAL FRIE
      DATA FRIE /.FALSE./
      CALL WR24
      NITB = 5
      CALL KERNZA (  9999., HMIN, 3)
      CALL KERNZA ( -9999., HMAX, 3)
      STLCON = 0.9
      IF (STLMAX .GT. 0.00001) STLCON = STLMAX
      IF (STLCON .GT. 0.9) STLCON = 0.9
      STLMAX = 0.
      HCODMI = 4.0 * 256.**3
      HCODMA = - HCODMI
      CALL RDCRYS (ICRYS)
      WRITE (24, FMT='(66X, A6)') CCODE
      WRITE (8, FMT='(1X / '' SUBROUTINE MERBIB''/)')
      IF (ICENT.EQ.2) CALL KERROR (' Space group is centrosymmetric, no
     +further calculations', 0, 'MERBIB')
      WRITE (24,FMT='('' Wavelength of radiation'',41X,F7.5)') WAVE
      NREF = 0
      NNREF = 0
      MREF99 = 0
      NJC2 = 0
      SJC2 = 0.
      IEND = 1
  130 CALL MEREAD (HKL, JC, FOBS, SIG, IEND)
      IF (IEND .LT. 0) GOTO 200
      CALL HKLAXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 130
      CALL HKLEXT (HKL, KEND)
      IF (KEND.LT.0) GOTO 130
      IF (ABS (HKL(1)) .GT. 99. .OR. ABS (HKL(2)) .GT. 99. .OR.
     *    ABS (HKL(3)) .GT. 99. ) THEN
         MREF99 = MREF99 + 1
         GOTO 130
         ENDIF
      CALL HKLSTL (HKL, STL, STL2)
      IF (STL .GT. STLCON) 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)
      IF (FOBS .LT. 0.001) FOBS = 0.001
      IF (SIG .LT. 0.001) SIG = 0.001
      IF (SIG .LT. FOBS / 1000. ) SIG = FOBS / 1000.
      IF (JC .EQ. 2) THEN
         NJC2 = NJC2 + 1
         SJC2 = SJC2 + SIG
         SIG = - SIG
      ELSE
         SIG = SIG * 2. * FOBS
         ENDIF
      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))
      STLMAX = AMAX1(STLMAX, STL)
      NNREF = NNREF + 1
      FBINX(1,NNREF) = HCODEX
      FBINX(2,NNREF) = FOBS
      FBINX(3,NNREF) = SIG
      IF (NNREF .EQ. MBINX) STOP 513
      GOTO 130
  200 FBINX(1,NNREF+1) = 0.
      FBINX(2,NNREF+1) = -1.
      FBINX(3,NNREF+1) = 0.
      WRITE (24, 301) NREF
  301 FORMAT(' Number of reflections from input file ', 27X, I6)
      IF (MREF99 .GT. 0) WRITE (24, 303) MREF99
  303 FORMAT (' Number of relections with hkl exceeding 99:  ', I7/
     *        ' WARNING: these reflections are not used in BIJVOET!'/)
      WRITE (24, 302) NNREF, STLMAX
  302 FORMAT(' Number of reflections stored          ', 27X, I6 /
     *       ' Maximum value of sin(th)/lambda)      ', 27X, F6.4)
      CALL WR24
      IF (NJC2 .EQ. 0) GOTO 309
      SJC2 = SJC2 / FLOAT(NJC2)
      WRITE (24, 304) NJC2, SJC2
  304 FORMAT(' For', I4, ' JC=2 -reflections, av SIG =', F6.2)
      SJC2 = 0.5 * SJC2
      SJC4 = ( 0.5 * SJC2 )**2
      DO 307 I = 1, NNREF
      IF (FBINX(3, I) .GT. 0.) GOTO 307
      FBINX(3, I) = - FBINX(3, I)
      IF (FBINX(3, I) .LT. SJC2) FBINX(3, I) = SJC2
      IF (FBINX(2, I) .LT. SJC4) FBINX(2, I) = SJC4
  307 CONTINUE
  309 CONTINUE
      CALL HKLC2I (HMIN, HMAX)
      CALL HKLC1U (HCODMI, HKL)
      CALL HKLC2  (HKL, ACODMI)
      NREW = 0
      NPAIR = 0
      FOBSAB (2, NPAIR+1) = -999.
  310 AF = ACODMI - 1.1
      CALL HKLC2U (ACODMI + FMAXA - 1., HKL)
      CALL HKLC1  (HKL, HCODEL)
      CALL KERNZA (0.0, AREF, 7 * MAXA)
      IREFX = 0
  320 CONTINUE
      IF (IREFX .EQ. NNREF ) GOTO 325
      IREFX = IREFX + 1
      HCODEX = FBINX(1,IREFX)
      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
      FOBS = FBINX(2,IREFX)
      SIG = FBINX(3,IREFX)
      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 CONTINUE
      IF (NREW .GT. 0) GOTO 330
      NREW = NREW + 1
  330 CONTINUE
      WRITE (8, FMT='('' Input refl cycle'', I3)') NREW
      DO 340 I = 1,MAXA
      IF (AREF(2,I) .LE. 0.1 .OR. AREF(5,I).LE.0.1) GOTO 340
      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)
      NPAIR = NPAIR + 1
      FOBSAB (1, NPAIR) = HCODEF
      FOBSAB (2, NPAIR) = FOBSA
      FOBSAB (3, NPAIR) = SIGA
      FOBSAB (4, NPAIR) = FOBSB
      FOBSAB (5, NPAIR) = SIGB
  340 CONTINUE
      IF (HCODEL.GE.HCODMA) GOTO 350
      ACODMI = ACODMI + FMAXA
      CALL HKLC2U (ACODMI, HKL)
      CALL HKLC1 (HKL, HCODMI)
      GOTO 310
  350 FOBSAB (2, NPAIR+1) = -999.
      IF (NPAIR.EQ.0) THEN
         IF (KSTAT(14) .EQ. 1) THEN
            WRITE (9, FMT='(14X, ''The Bijvoet coefficient can'',
     *          '' not be calculated.'' / )')
            IDOKA = 17
            RETURN
         ELSE
            CALL KERROR
     *         (' No Bijvoet pairs found, no further calculations',
     *            0, 'MERBIB')
            ENDIF
         ENDIF
      WRITE (24, 352) NPAIR
  352 FORMAT (35X, 'Number of Bijvoet pairs found: ', I6)
      CALL WR24
      WRITE (25, FMT='(/I6, '' Bijvoet pairs '')') NPAIR
      RETURN
      END
      SUBROUTINE FCALCB
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbinx1.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      EQUIVALENCE (IATOMS, IFILE(2)), (ICRYS, IFILE(3))
      PARAMETER (MAXP=6000)
      COMMON /BLANK/ DUMFC(19630), DUMAT(11918), PAIRS (6,MAXP),
     *               MPAIR, DFCMAX, DUMSCS(5999), DUMMY( 86451)
      DIMENSION  FITB(6)
      CALL KERNZA (0., PAIRS, 6*MAXP)
      WRITE (8, FMT='(/ '' 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 (8, 2, ATXYZ, ATNAME, IZAT, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
      WRITE (24, 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'
      WRITE (24, FMT='(A)') CHOUT
      CALL WR24
      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 (8, FMT='(/,'' Anomalous scattering fraction '',
     * ''of the structure '' , /,
     * 3X, '' sqrt(sum(Df"**2) / sum(Z**2)) ='', 29X, F8.5)') BDF
      NPAIR = 0
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
      MPAIR = 0
      SUMFC = 0.
      SUMFO = 0.
      BQ1 = 0.
      BQ2 = 0.
      DFCMAX = 0.
  200 CONTINUE
      IF (FOBSAB(2, NPAIR+1) .LT. -1.) GOTO 220
      NPAIR = NPAIR + 1
      HCODEF = FOBSAB (1, NPAIR)
      FOBSA = FOBSAB (2, NPAIR)
      SIGA = FOBSAB (3, NPAIR)
      FOBSB = FOBSAB (4, NPAIR)
      SIGB = FOBSAB (5, NPAIR)
      DFO = FOBSA - FOBSB
      SIG2 = SIGA**2 + SIGB**2
      CALL HKLC1U (HCODEF, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      CALL FCALB1 (ATXYZ, ITAT, NAT)
      FPF = PHIP
      DFC = FP - FPF
      IF (ABS(DFC) .GT. DFCMAX) DFCMAX = ABS(DFC)
      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)
      SUMFC = SUMFC + FP + FPF
      SUMFO = SUMFO + FOBSA + FOBSB
      BQ1 = BQ1 + DFC**2
      BQ2 = BQ2 + FITB(6)
      GOTO 200
  220 CONTINUE
      DFCLOW = DFCMAX / 16.
      SC = SUMFC / SUMFO
      BQ = SQRT (BQ1 / BQ2)
      WRITE (8, FMT = '( /
     * '' Anomalous scattering '',
     * ''fraction for the selected Bijvoet pairs'',
     * /,3X, '' sqrt(sum(dFc**2) / sum(Fc)**2) ='', 28X, F8.5)') BQ
      WRITE (8, FMT = '( /,
     * '' Scale factor'', /
     * 4X, ''SC = sumFc / sumFo = '', 39X, F8.4)')  SC
      WRITE (8, FMT = '( /
     * '' Sorting Bijvoet pairs on |Bt|=|dFc*dFo/sig(dFo)**2|'')')
      L = 0
      NLOW = 0
      DO 230 I=1,MPAIR
      IF (ABS(PAIRS(3,I)) .LT. DFCLOW) THEN
         NLOW = NLOW + 1
         GOTO 230
         ENDIF
      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 (8, FMT = '(/, '' Selection of Bijvoet pairs on '',
     * ''dFc = Fc(h) - Fc(-h)'')')
      WRITE (8, FMT='('' Number of Bijvoet pairs with abs(dFc) <'',
     * F7.4, '' rejected:'', 9X, I6)') DFCLOW, NLOW
      WRITE (8, 232) L
  232 FORMAT (' Number of Bijvoet pairs selected:',
     * 32X, I6)
      MPAIR = L
      SOMDFO = 0.
      SOMDFC = 0.
      SOMSIG = 0.
      FMPAIR = FLOAT (MPAIR)
      DO 250 I=1,MPAIR
      IF (PAIRS(3,I) .GT. 0.) THEN
         SOMDFC = SOMDFC + PAIRS(3,I)
         SOMDFO = SOMDFO + PAIRS(4,I)
      ELSE
         SOMDFC = SOMDFC - PAIRS(3,I)
         SOMDFO = SOMDFO - PAIRS(4,I)
         ENDIF
      SOMSIG = SOMSIG + PAIRS(5,I)
  250 CONTINUE
      SOMDFC = SOMDFC / FMPAIR
      SOMDFO = SOMDFO / FMPAIR
      SOMSIG = SQRT (SOMSIG / FMPAIR)
      SOMSG  = SOMSIG / SQRT (FMPAIR)
      WRITE (25, FMT='( I6, '' pairs, '',
     *   '' Av. dFc dFo SIG:'', 3F6.3 )')
     *   MPAIR, SOMDFC, SOMDFO, SOMSIG
      CALL WR24
      WRITE (8, FMT='(1X/'' for '', I6, '' pairs, '',
     *   '' <dFc> <dFo <sig> (su) = '', 3F6.3, ''('', F5.3, '')'' )')
     *   MPAIR, SOMDFC, SOMDFO, SOMSIG, SOMSG
      RETURN
      END
      SUBROUTINE FCALB1 (ATXYZ, ITAT, NAT9)
      DIMENSION ATXYZ(10,NAT9), ITAT(NAT9)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      EQUIVALENCE (PHIP, FPF)
      DIMENSION FFF(10), ADTRIG(24)
      DATA FFF / 10*0.0 /
      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
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      PARAMETER (MAXP=6000)
      COMMON /BLANK/ DUMFC(19630), DUMAT(11918), PAIRS (6,MAXP),
     *               MPAIR, DFCMAX, DUMSCS(5999), DUMMY( 86451)
      DIMENSION TABDFC(9, 15), IIDFC(100), XXDFC(100)
      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. /
      ADFC = 99.999 / DFCMAX
      CALL KERNZI (0, IIDFC, 100)
      CALL KERNZA (0., XXDFC, 100)
      CALL KERNZA (0., TABDFC, 15*9)
      DO 100 I = 1, MPAIR
      ABSDFC  = ABS(PAIRS(3,I))
      K = INT ( ABSDFC * ADFC ) + 1
      IIDFC(K) = IIDFC(K) + 1
      XXDFC(K) = XXDFC(K) + ABSDFC
  100 CONTINUE
      NXTOT = MPAIR / 15
      NXSUM = 0
      NX = 0
      XDFC = 0.
      IDFC = 1
      DO 101 K = 1, 100
      NX = NX + IIDFC(K)
      XDFC = XDFC + XXDFC(K)
      IIDFC(K) = IDFC
      IF (NX .GE. NXTOT .OR. K .EQ. 100) THEN
         TABDFC(1,IDFC) = FLOAT(NX)
         TABDFC(2,IDFC) = XDFC / FLOAT(NX)
         NXSUM = NXSUM + NX
         IDFC  = IDFC + 1
         IF (IDFC .GE. 15) THEN
            NXTOT = MPAIR + 1
         ELSE
            NXTOT = (MPAIR-NXSUM) / (16-IDFC)
            ENDIF
         NX = 0
         XDFC = 0.
         ENDIF
  101 CONTINUE
      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 (8, FMT='(/ '' SUBROUTINE BIJVOX''/)')
      WRITE (8, FMT='('' Bijvoet calculations'' / )')
      WRITE (24, FMT='(/'' Notation:''/
     * ''   dFc = Fc(h) - Fc(-h) is the calulated Bijvoet difference'' /
     * ''   dFo = Fo(h) - Fo(-h) is the observed value'' /
     * ''   w = 1/sig(dFo)**2 with sig from counting statistics''/
     * ''   Bt  = w * |dFc*dFo| is the sorting key'' //
     * ''   B   = sum (w * dFc*dFo) / sum (Bt) ''/
     * ''       is the weighted Bijvoet coefficient,  where sum(-)''/
     * ''       is the summation over the participating Bijvoet pairs.''
     *    /)')
      CALL WR24
      WRITE (8, FMT='('' Values of abs(dFo) if >'',
     * '' abs(dFc) + 3 sig(dFo) are cut off to this value '' )')
      WRITE (8, FMT='('' Values of '',
     * ''|BT|=|dFc*dFo|/sig(dFo)**2 >'', F7.2,
     * '' are cut off to this value'')') BTMIN
      WRITE (8, FMT='(/,'' Table 517.1    Statistics of the first 50 '',
     * '' Bijvoet pairs'' / 44X, ''cut off values are marked x'')')
      WRITE (8, FMT='( ''    H  K  L       <Fc>      dFc      dFo'',
     * ''   sig(dFo)   dd/sig     BT'')')
      II = MIN0(50, MPAIR)
      BTLIM = 0.1 * ABS (PAIRS(1,II-1))
      SLOBT = 0.
      SLOBN = 0.
      DO 109 I = 1, MPAIR
      BT   = PAIRS(1,I)
      DFC  = PAIRS(3,I)
      ABSDFC = ABS(DFC)
      DFO  = PAIRS(4,I)
      ABSDFO = ABS(DFO)
      SIG2 = PAIRS(5,I)
      SIG  = SQRT(SIG2)
      IF (ABSDFO .GT. ABSDFC + 3.* SIG)  THEN
         DFO = (ABSDFC + 3. * SIG) * DFO / ABSDFO
         ABSDFO = ABS(DFO)
         PAIRS(4,I) = DFO
         BT = DFC * DFO / SIG2
         PAIRS(1,I) = BT
         ADFO = 'x'
      ELSE
         ADFO = ' '
         ENDIF
      IF (ABS(BT) .LT. 0.00001) THEN
         MPAIR = I - 1
         WRITE (8, FMT='(/'' Number of pairs limited to'', I5)') MPAIR
         GOTO 1109
         ENDIF
      QQ = ABS(BTMIN/BT)
      IF(QQ .LT. 1.) THEN
         BT = BT * QQ
         PAIRS(1,I) = BT
         ABTAV = 'x'
      ELSE
         ABTAV = ' '
         ENDIF
      K = INT ( ABSDFC * ADFC ) + 1
      IDFC = IIDFC(K)
      IF (DFC .GE. 0.) THEN
         TABDFC(3,IDFC) = TABDFC(3,IDFC) + DFO
         TABDFC(4,IDFC) = TABDFC(4,IDFC) + (TABDFC(2,IDFC)-DFO)**2
         TABDFC(5,IDFC) = TABDFC(5,IDFC) + (TABDFC(2,IDFC)+DFO)**2
      ELSE
         TABDFC(3,IDFC) = TABDFC(3,IDFC) - DFO
         TABDFC(4,IDFC) = TABDFC(4,IDFC) + (TABDFC(2,IDFC)+DFO)**2
         TABDFC(5,IDFC) = TABDFC(5,IDFC) + (TABDFC(2,IDFC)-DFO)**2
         ENDIF
      TABDFC(6,IDFC) = TABDFC(6,IDFC) + DFC * DFO
      TABDFC(7,IDFC) = TABDFC(7,IDFC) + ABSDFC * ABSDFO
      SLOBT = SLOBT + BT
      SLOBN = SLOBN + DFC**2 / SIG2
      IF (I .GT. II) GOTO 109
      DDSIG =  DFC * DFO / SIG
      HCODEF = PAIRS(2,I)
      SQ = SQRT(PAIRS(6,I))
      CALL HKLC1U (HCODEF, HKLT)
      CALL KERF2I (HKLT, IHKL, 3)
      WRITE (8, FMT='(1X, I4, 2I3, 3X, 3F9.4, A1, F8.4, 2F10.4, A1)')
     *    (IHKL(J), J=1,3), SQ, DFC, DFO, ADFO, SIG, DDSIG, BT, ABTAV
  109 CONTINUE
 1109 CONTINUE
      SLOB = SLOBT / SLOBN
      SLOBST = 0.
      SLOBSW = 0.
      SLOBSN = 0.
      DO 2109 I = 1, MPAIR
      DFC  = PAIRS(3,I)
      DFO  = PAIRS(4,I)
      W = 1. / PAIRS(5,I)
      SLOBST = SLOBST + (( DFO - SLOB *  DFC ) * W )**2
      SLOBSW = SLOBSW + W
      SLOBSN = SLOBSN + W * DFC
 2109 CONTINUE
      SLOBSD = SQRT ( SLOBST / ( SLOBSW * SLOBN - SLOBSN**2 ))
      WRITE (9,FMT='(1X/
     *   '' The slope of the function dFo = B * dFc is B^ ='',
     *  F6.3,''('',F5.3,'')'')') SLOB, SLOBSD
      WRITE (9,FMT='(''    [ For error free data, B^ = +1 or -1 ]'')')
      WRITE (25,FMT='('' Slope (dFo=B*dFc) B='',F6.3,''('',F5.3,'')'')')
     *  SLOB, SLOBSD
      CALL WR24
      DO 110 IDFC = 1, 15
      FN = TABDFC(1,IDFC)
      IF (FN .LT. 0.1) GOTO 110
      TABDFC(3,IDFC) = TABDFC(3,IDFC) / FN
      TABDFC(4,IDFC) = SQRT ( TABDFC(4,IDFC) / FN )
      TABDFC(5,IDFC) = SQRT ( TABDFC(5,IDFC) / FN )
      TABDFC(6,IDFC) = TABDFC(6,IDFC) / FN
      TABDFC(7,IDFC) = TABDFC(7,IDFC) / FN
      IF (TABDFC(7,IDFC) .GT. 0.00001)
     *   TABDFC(8,IDFC) = TABDFC(6,IDFC) / TABDFC(7,IDFC)
  110 CONTINUE
      BIJM = 0.
      BIJT = 0.
      BIJN = 0.
      DO 111 IDFC = 15, 9, -1
      FN = TABDFC(1,IDFC)
      IF (FN .LT. 0.1) GOTO 111
      BIJM = BIJM + FN
      TABDFC(9, IDFC-7) = BIJM
      BIJT = BIJT + TABDFC(6,IDFC)
      BIJN = BIJN + TABDFC(7,IDFC)
      IF (BIJN .LT. 0.00001) THEN
         IF (IDFC .EQ. 15) GOTO 111
         TABDFC(9,IDFC) = TABDFC(9,IDFC+1)
            ELSE
         TABDFC(9,IDFC) = BIJT / BIJN
         ENDIF
  111 CONTINUE
      WRITE (8, FMT='(/'' Table TABDFC  = '',
     *   '' Statistics sorted on decreasing |dFc|''//
     *   '' 1: nr of pairs '', 8F7.0 / 23X, 7F7.0 //
     *   '' 2: < |dFc| >   '', 8F7.3 / 23X, 7F7.3 //
     *   '' 3: < S dFo >   '', 8F7.3 / 23X, 7F7.3 )')
     *   (TABDFC(1,I),I=15,1,-1), (TABDFC(2,I),I=15,1,-1),
     *   (TABDFC(3,I),I=15,1,-1)
      WRITE (8, FMT='(/
     *   '' 4: sd(dFo) true'', 8F7.3 / 23X, 7F7.3 //
     *   '' 5: sd -inverted'', 8F7.3 / 23X, 7F7.3 )')
     *   (TABDFC(4,I),I=15,1,-1), (TABDFC(5,I),I=15,1,-1)
      WRITE (8, FMT='(/
     *   '' 6: < dFc.dFo > '', 8F7.4 / 23X, 7F7.4 //
     *   '' 7: <|dFc.dFo|> '', 8F7.4 / 23X, 7F7.4 //
     *   '' 8: B unweighted'', 8F7.3 / 23X, 7F7.3 )')
     *   (TABDFC(6,I),I=15,1,-1), (TABDFC(7,I),I=15,1,-1),
     *   (TABDFC(8,I),I=15,1,-1)
      WRITE (24, FMT='(1X /'' cumulative results for'',
     *   '' decreasing |dFc| ''/
     *   '' 9: nr of pairs '',  7F7.0 /
     *   '' 9: B unweighted'',  7F7.3 )')
     *   (TABDFC(9,I),I=8,2,-1), (TABDFC(9,I),I=15,9,-1)
      FN = 0.
      BIJ9 = 0.
      III = 15
      DO 1111 I = 15,9,-1
      IF (FN .LT. 100. .OR. TABDFC(9,I) .GT. BIJ9 ) THEN
         FN = TABDFC(9,I-7)
         BIJ9 = TABDFC(9,I)
         III = I
         ENDIF
 1111 CONTINUE
      NBIJ9 = NINT(FN)
      WRITE (24, FMT='('' For'', I5,
     *   '' Bijvoet pairs, the unweighted B ='',
     *   F6.3 )') NBIJ9, BIJ9
      WRITE (25, FMT='(I6, '' pairs,  unweighted B ='',
     *   F6.3)') NBIJ9, BIJ9
      CALL WR24
      BIJT = 0.
      BIJN = 0.
      DO 112 IDFC = III, 15
      W  =  TABDFC(1,IDFC) * TABDFC(2,IDFC)
      BIJT = BIJT + TABDFC(8,IDFC) * W
      BIJN = BIJN + W
  112 CONTINUE
      BIJAV = BIJT / BIJN
      BIJM = 0.
      BIJT = 0.
      DO 113 IDFC = III, 15
      BIJM = BIJM + TABDFC(1,IDFC)
      W  =  TABDFC(1,IDFC) * TABDFC(2,IDFC)
      BIJT = BIJT + W * ( TABDFC(8,IDFC) - BIJAV )**2
  113 CONTINUE
      BIJSD = SQRT (BIJT / BIJN / 6. )
      N = NINT (BIJM)
      WRITE (24, FMT='(1X / '' For'', I5,
     *   '' pairs, the <|dFc|>-weighted B ='',
     *   F6.3, ''('', F5.3, '')'' /)') N, BIJAV, BIJSD
      WRITE (25, FMT='(I6, '' pairs,  unweighted B ='',
     *   F6.3, ''('', F5.3, '')'' )') N, BIJAV, BIJSD
      CALL WR24
      WRITE (8, FMT='(/'' Table 517.2    Statistics for'', I5,
     * '' pairs in batches of 25 '', //
     * ''    dFc    average |Fc(h) - Fc(-h)|'',/
     * ''    dFo    average |Fo(h) - Fo(-h)|'',/
     * ''    dF0/s  average |Fo(h) - Fo(-h)| /sig(dFo)'')') MPAIR
      WRITE (8, FMT='(
     * ''    dFc/F  average |dFc| / SQRT (sum dFc**2 / sum Fc**2) '' /
     * ''    |Bt|   average |dFc * dFo| /sig(dFo)**2 '',/
     * ''    %B+    percentage of positive values of Bt'',/
     * ''    Bt/s   average |Bt| /sig(dFo) '')')
      WRITE (8, FMT='(/ ''     ----------individual badges-----------'',
     * ''---------   ---cumulative--- '' /
     * ''      dFc dFo  dFo/s dFc/F  |Bt|    %B+  Bt    Bt/s'',
     * ''     %B+  Bt    Bt/s  '')')
  116 FORMAT (I4, 2F5.2, F6.2, 1X, F4.3, F8.3, 2( F7.1, F6.2, F6.2))
      SUMDFC = 0.
      SUMDFO = 0.
      SUMDS = 0.
      T5T = 0.
      T5N = 0.
      SUMBTA = 0.
      SUMPER = 0.
      SUMBT = 0.
      SUMBTS = 0.
      CUMPER = 0.
      CUMBT = 0.
      CUMBTS = 0.
      FMPAIR = FLOAT(MPAIR)
      DO 117 I = 1, MPAIR
      SUMDFC = SUMDFC + ABS(PAIRS(3,I))
      SUMDFO = SUMDFO + ABS(PAIRS(4,I))
      SUMDS = SUMDS + ABS(PAIRS(4,I)) / SQRT(PAIRS(5,I))
      T5T = T5T + PAIRS(3,I)**2
      T5N = T5N + PAIRS(6,I)
      TBT = PAIRS(3,I) * PAIRS(4,I)
      SUMBTA = SUMBTA + ABS(TBT)
      IF (TBT .GT. 0.) SUMPER = SUMPER + 1.
      SUMBT = SUMBT + TBT
      SUMBTS = SUMBTS + TBT / SQRT(PAIRS(5,I))
      IF (TBT .GT. 0.) CUMPER = CUMPER + 1.
      CUMBT = CUMBT + TBT
      CUMBTS = CUMBTS + TBT / SQRT(PAIRS(5,I))
      IF (I.EQ.MPAIR) GOTO 115
      IF (MOD(I, 25) .NE. 0) GOTO 117
  115 T1  = SUMDFC / 25.
      T2  = SUMDFO / 25.
      T4  = SUMDS  / 25.
      T5 = SQRT (T5T / T5N)
      S1 = SUMBTA / 25
      S2 = 100. * SUMPER / 25
      S3 = SUMBT / 25
      S4 = SUMBTS / 25
      FLI = FLOAT(I)
      CS2 = 100. * CUMPER / FLI
      CS3 = CUMBT / FLI
      CS4 = CUMBTS / FLI
      WRITE (8, 116) I,T1,T2,T4,    T5,    S1, S2,S3,S4, CS2,CS3,CS4
      SUMDFC = 0.
      SUMDFO = 0.
      SUMDS = 0.
      T5T = 0.
      T5N = 0.
      SUMBTA = 0.
      SUMPER = 0.
      SUMBT = 0.
      SUMBTS = 0.
  117 CONTINUE
      WRITE (24, FMT='(1X/'' Calculation of BIJVOET'',
     * '' coefficients (B) and their probabilities (Prob)'')')
      WRITE (24,FMT='(/,'' Table 517.3    Bijvoet results in batches'',
     * '' of 25 pairs'',/ ''        -----cumulative-------------'',
     * ''     ---individual-batches---'')')
      WRITE (24,FMT='('' pairs'', 5X,''B   sig(B)  B/sig(B)'',
     * '' Prob        B   sig(B)  B/sig(B)''/)')
      MFR = 0
      MFR25 = 0
      I25 = 0
      SUMP = 0.0
      SUMQ = 0.0
      SUMR = 0.0
      SUMP25 = 0.0
      SUMQ25 = 0.0
      SUMR25 = 0.0
      LIS = 24
      DO 150 I=1,MPAIR
      MFR  = MFR + 1
      MFR25  = MFR25 + 1
      BT   = PAIRS(1,I)
      DFC  = PAIRS(3,I)
      DFO  = PAIRS(4,I)
      SIG2 = PAIRS(5,I)
      SIG  = SQRT(SIG2)
      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 (I .EQ. MPAIR) GOTO 147
      IF (MOD(MFR, 25) .NE. 0) GOTO 150
  147 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
      BS = B / SIGB
      ARGPA = 0.707107 * ABS(BS)
      PPA = 0.5 + 0.5 * ERFU(ARGPA)
      B25 = SUMP25/SUMQ25
      SIGB25 = (1. - ABS(B25)) * SQRT(SUMR25)/SUMQ25
      IF (SIGB25 .LT. 0.0001) SIGB25 = 0.0001
      BS25 = B25 / SIGB25
      MFR25 = 0
      SUMP25 = 0.0
      SUMQ25 = 0.0
      SUMR25 = 0.0
      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 (LIS, 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 .EQ. 200) THEN
         LIS = 8
         CALL WR24
         ENDIF
      IF (MFR .NE. 100) GOTO 150
      MSEL = 100
      BSEL = B
      SIGSEL = SIGB
      PSEL = PPA
  150 CONTINUE
      WRITE (24,FMT='(1X/'' Table 517.4  Another choice of batches:'')')
      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 (24, 222) NBAT
  222 FORMAT (/ ' ----------cumulative--------------    --------',
     * I2, ' individual batches----' /
     *  ' pairs    B   sig(B)  B/sig(B) Prob ',
     * '  pairs    B   sig(B)  B/sig(B) Prob '/)
      NFINAL = MPAIR / 10
      IF (NFINAL .GT. 100) NFINAL = 100
      IF (NFINAL .LT. 50) NFINAL = 50
      DO 320 I = 1, NBAT
      BSUMP = 0.
      BSUMQ = 0.
      BSUMR = 0.
      KBAT = MODB(I)
      KBBAT = MODC(I)
  310 IPAIR = IPAIR + 1
      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 = 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 = 0.5 + 0.5 * ERFU(ARGPA)
      BBBAT = BSUMP / BSUMQ
      BSIGB = (1. - ABS(BBBAT)) * SQRT (BSUMR) / BSUMQ
      BSIGM = AMAX1(BSIGB, 0.002 * ABS(BBBAT))
      BBBSS = 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 = 0.5 + 0.5 * ERFU(ARGPA)
      WRITE (24, 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. NFINAL) GOTO 320
      MSEL = MPAIR
      BSEL = BBAT
      SIGSEL = SIGB
      PSEL = PA
  320 CONTINUE
      WRITE (24,*) ' '
      CALL WR24
      WRITE (25, 9321) MSEL, BSEL, SIGSEL, PSEL
 9321 FORMAT (I6, ' pairs,  B = ' ,   F6.3,'(', F5.3,')  P = ' , F6.3 )
      WRITE (9, 321) MSEL, BSEL, SIGSEL, PSEL
  321 FORMAT (1X/' The Bijvoet coefficient for the strongest', I4,
     * ' Bijvoet pairs is' / '    B = ' ,   F6.3,'(', F5.3,')  ',
     * ' and its probability is ' ,   F6.3 )
      WRITE (9, FMT='(1X /''    For more statistics, see file LIS1'')')
      BFLACK = ( 1.0 - BSEL ) / 2.
      SFLACK = SIGSEL / 2.
      WRITE(9, 322) BSEL, SIGSEL, BFLACK, SFLACK
  322 FORMAT (1X/
     * '    Conversion of B  to Flack parameter F   (0=OK, 1=wrong):'/
     * '    B = ',F6.3,'(', F5.3,') corresponds to F = ',
     *         F6.3,'(', F5.3,')' /)
      IF (PSEL .GE. 0.999) THEN
         IF (BSEL .GT. 0.0) THEN
            WRITE (9, 325)
  325     FORMAT (' The atomic parameters of the structure are in ',
     *        'agreement with' / ' its absolute configuration.' )
         ELSE
            WRITE (9, 326)
  326     FORMAT (1X/' The atomic parameters of the structure have '
     *        ,'to be inverted' /
     *         ' to be in agreement with its absolute configuration:'/
     *         ' this will be done now!!' )
            CALL INVERT
            ENDIF
         CALL WR24
         RETURN
         ENDIF
      IF (BSEL .GT. 0.0) THEN
         WRITE (9, 327)
  327    FORMAT (1X/' The atomic parameters of the structure are in ',
     *   'agreement with' / ' its absolute configuration, but inspect' /
     *   ' the Bijvoet coefficients (LIS1) to judge the validity.'/1X)
      ELSE
         WRITE (9, 329)
  329    FORMAT (1X/' The atomic parameters of the structure have ',
     *      'to be inverted to be' /
     *   ' in agreement with its absolute configuration, but inspect' /
     *   ' the Bijvoet coefficients (LIS1) to judge the validity.'/1X)
         IF (PSEL .GT. .95) THEN
            WRITE (9,FMT='(A)') ' Inversion will be done now anyhow!'
            CALL INVERT
            ENDIF
         ENDIF
      IF (PSEL .LE. 0.98) THEN
         WRITE (9, 425)
  425    FORMAT (' Be careful !' /1X)
         IF (KSTAT(14) .EQ. 1) WRITE (9, 426)
  426    FORMAT (' After refinement of the structure,',
     *             'you are welcome to recall BIJVOET !')
         ENDIF
      CALL WR24
      RETURN
      END
      SUBROUTINE SHAT
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IATOMS, IFILE(2) )
      EQUIVALENCE (IATOLD, IFILE(10))
      PARAMETER (MAXAT=2513)
      COMMON /BLANK/ DUMMYF(19630),
     *               ATXYZ(10,MAXAT),IZAT(MAXAT),ITAT(MAXAT), PTBXX(2),
     *               DUMMYT(110212)
      COMMON /ATNAMB/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DIMENSION SHIFT (3)
      CALL WR24
      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 ATOMPR (7, 7, ATXYZ, ATNAME, IZAT, NAT)
  120 WRITE (9, 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 (24, FMT = '('' Shift vector applied: '',3F8.4)') SHIFT
      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 (7, 7, ATXYZ, ATNAME, IZAT, NAT)
      CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
      RETURN
      END
      SUBROUTINE EULER
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATMOD, IFILE(1)), (IATOMS, IFILE(2))
      EQUIVALENCE (IATOLD, IFILE(10))
      EQUIVALENCE (ICRYS,  IFILE(3))
      PARAMETER (MAXAT=2513)
      COMMON /BLANK/ DUMMYF(19630),
     *               ATXYZ(10,MAXAT),IZAT(MAXAT),ITAT(MAXAT), PTBXX(2),
     *               DUMMYT(110212)
      COMMON /ATNAMB/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DIMENSION  RR(3,3)
      WRITE(9, 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 (7, 7, ATXYZ, ATNAME, IZAT, NAT)
  260 WRITE (9, 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(24, 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 (8,  FMT = '(3X, A6, 2X,3F8.4, F5.0,2(2X,3F8.4))')
     * ATNAME(I), (ATXYZ(J,I), J=1,10)
      WRITE(24,  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 INVERT
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zch80.inc'
      EQUIVALENCE (IXYZN,  IFILE(1))
      EQUIVALENCE (IATOMS, IFILE(2)), (ICRYS, IFILE(3))
      PARAMETER (MAXAT=2513)
      COMMON /BLANK/ DUMMYF(19630),
     *               ATXYZ(10,MAXAT),IZAT(MAXAT),ITAT(MAXAT), PTBXX(2),
     *               DUMMYT(110212)
      COMMON /ATNAMB/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DIMENSION ZZ(3), AA(3), BB(3), CC(3)
      CHARACTER*6 SPGRIP(7)
      DIMENSION POINTI(3,7)
      INCLUDE 'Zena1.inc'
      DATA NCALL /1/
      DATA SPGRIP /'FDD2','I41','I4122','I41MD','I41CD','I-42D','F4132'/
      DATA POINTI / 0.25, 0.25, 1.00  ,   1.00, 0.50, 1.00  ,
     *              1.00, 0.50, 0.25  ,   1.00, 0.50, 1.00  ,
     *              1.00, 0.50, 1.00  ,   1.00, 0.50, 0.25  ,
     *              0.25, 0.25, 0.50   /
      WRITE (24, FMT='('' INVERT JOB params:'', 6(1X, A6))') LITJ
      CALL RDCRYS (ICRYS)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINIA)
      IF (KINIA .NE. 0) CALL KERROR(' No ATOMS file present',0,'INVERT')
      WRITE (9, 101)
  101    FORMAT (1X/' INVERT operates on input file ATOMS,   but'/
     *   ' inverted atomic parameters are also written to ccode.res'/1X)
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      REWIND IATOMS
      INCLUDE 'Zena2.inc'
  149 FORMAT (/ ' Space group ',A9, ' is the enantiomer of ', A9/
     *    ' and inversion is done by the mirror x,y,z -> x,y,1-z !'/)
      CALL WR24
      IF (KSPGR .EQ. 0) GOTO 9149
      DO 1149 II = 1,NAT
      ATXYZ(3,II) = 1.0 - ATXYZ(3,II)
 1149 CONTINUE
      WRITE (CHOUT, FMT = '('' Atoms mirrored: x,y,z -> x,y,1-z'')')
      CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
      IF (KSTAT(14) .EQ. 1) THEN
         WRITE (9, 2149) SPGROT(I), SPGROT(J)
         WRITE(24, 2149) SPGROT(I), SPGROT(J)
 2149 FORMAT (1X/ ' NOTE !! space group ',A9 /
     *  ' MUST !! be changed to the enantiomorphous space group ', A9/
     *  ' NOTE !! DIRDIF changed the symmetry in CRYSIN and in RES !'/
     *  ' ----------------------------------------------------------'
     *    /1X)
         CALL FILCLO (3, 'KEEP')
         CALL FILINQ (3, 'CRYSIN', 'FORMATTED', 'INPUT', KIDDS)
         NCH = 0
  301    CALL KERINA (3, LIT, 1, LEND)
         IF (LEND .EQ. -1) GOTO 307
         NCH = NCH + 1
         CH80(NCH) = CHIN
         IF (LIT(1) .EQ. 'SPGR') ISPGR = NCH
         GOTO 301
  307    REWIND 3
         DO 308 ICH = 1, NCH
         IF (ICH .EQ. ISPGR) THEN
            WRITE (3, FMT='(''SPGR      '', A9)')  SPGROT(J)
         ELSE
            WRITE (3, FMT = '(A80) ') CH80(ICH)
            ENDIF
  308    CONTINUE
         CALL FILCLO (3, 'KEEP')
         CALL CRYSDA
         CALL RDCRYS (ICRYS)
      ELSE
         WRITE (9, 3149) SPGROT(I), SPGROT(J)
         WRITE(24, 3149) SPGROT(I), SPGROT(J)
 3149 FORMAT (1X/ ' NOTE !! inversion in space group ',A9 /
     *  ' implies a change to the enantiomorphous space group ', A9/
     *  ' but DIRDIF did NOT change CRYSIN or the symmetry in RES !'/,
     *  ' ---------------------------------------------------------'
     *    /1X)
         ENDIF
      GOTO 900
 9149 CONTINUE
      SPGRX = SPGR
      DO 1144 I = 1, 11
      IF (SPGRX(I:I) .EQ. ' ') THEN
         SPGRT(1:16-I) = SPGRX(I+1:16)
         SPGRX(I:15) = SPGRT(1:16-I)
         ENDIF
 1144 CONTINUE
      SPGRX(10:16) = ' '
      DO 1145 I = 1, 7
      IF (SPGRX(1:6) .EQ. SPGRIP(I)) GOTO 1147
 1145 CONTINUE
      GOTO 1148
 1147 CONTINUE
      AA(1) = POINTI(1,I)
      AA(2) = POINTI(2,I)
      AA(3) = POINTI(3,I)
      GOTO 200
 1148 CONTINUE
      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.
      WRITE (9, FMT = '('' Inversion point: '', 3F9.5)') ZZ
      DO 250  I = 1,NAT
      DO 250  J = 1,3
  250 ATXYZ(J,I) = AA(J) - ATXYZ(J,I)
      WRITE (CHOUT, FMT = '('' Inversion point: '', 3F9.5)') ZZ
      CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
  900 CONTINUE
      IF (NRECY .EQ. 0 ) THEN
         WRITE (9, 910)
         WRITE (24, 910)
  910    FORMAT (1X/ ' The output ccode.res file contains' /
     *      ' inverted atomic parameters, however, SHELX control'/
     *      ' information on the file may be lost.'/1X)
         ENDIF
      CALL AT2X
      RETURN
      END
      SUBROUTINE SELECT
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IATOMS, IFILE(2)), (IDDS, IFILE(1))
      EQUIVALENCE (ICON,   IFILE(4)), (IATOLD, IFILE(10))
      PARAMETER (MAXAT=2513)
      COMMON /BLANK/ DUMMYF(19630),
     *               ATXYZ(10,MAXAT),IZAT(MAXAT),ITAT(MAXAT), PTBXX(2),
     *               DUMMYT(110212)
      COMMON /ATNAMB/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      CHARACTER * 80  CHINR
      LOGICAL        SWRUN
      CALL WR24
      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 (9,
     *    FMT = '('' Enter IRUN (run number) to find ATOMS set '')')
      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
         IIRUN = NINT(FNUM(4))
         IF (IIRUN .GT. JRUN) THEN
            WRITE(9, FMT = '('' No success '')')
            RETURN
            ENDIF
         IF (JRUN .NE. IIRUN) GOTO 110
         SWRUN = .TRUE.
         WRITE (9, FMT = '(2X, A70)') CHIN(1:70)
      ENDIF
      GOTO 110
 120  IF (LIT(1) .EQ. 'ATOMS' .OR. LIT(1) .EQ. 'ATMOD') GOTO 125
      GOTO 110
 125  CCODE = LIT(2)
      WRITE (9, FMT = '(2X, A70)') CHIN(1:70)
      READ (IATOLD, FMT = '(A80)') CHINR
      IF (CHINR(1:6) .EQ. 'REMARK') THEN
         WRITE (9, FMT = '(2X,A70)') CHINR(1:70)
      ELSE
      BACKSPACE IATOLD
         CHINR = ' '
      ENDIF
  130 WRITE (9,
     *    FMT = '(1X/, '' 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 (9, FMT = 211)
  211 FORMAT(' Do you want to continue with program: TRACOR, PHASEX, ...
     * ....')
  212 WRITE (9, 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 KERASE ('CONDA')
         ENDIF
      GOTO 400
  300 WRITE (CHOUT, FMT = '('' End of the ATOLD file '')')
  400 CALL FILCLO(IATOLD, 'KEEP')
      RETURN
      END
      SUBROUTINE WRLIS5
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zch80.inc'
      CHARACTER T *8
      I = 1
      WRITE (8, FMT='(/ ''$FINISH'')')
      REWIND 8
  111 READ (8, FMT = '(A80)', END = 119) CHIN
      IF (CHIN(1:8) .EQ. '$FINISH ') GOTO 121
      IF (I .EQ. MCH80) GOTO 111
      IF (CHIN(1:4) .NE. ' $TE') GOTO 111
      CH80(I) = CHIN
      I = I + 1
      GOTO 111
  119 STOP 524
  121 CH80(I) = ' '
      IF (I .EQ. MCH80)
     *    WRITE (4, FMT='(/'' input nr of lines limited to'',I4/)') I
      N = I
      I1 = 1
  200 T = ' '
      DO 225 I = I1, N
      IF (CH80(I)(1:4) .EQ. ' $TE') THEN
         T = CH80(I) (3:10)
         WRITE (4, FMT = '(/'' $'',A8, ''----------------------'')') T
         I2 = I
         GOTO 300
         ENDIF
  225 CONTINUE
      GOTO 900
  300 DO 325 I = I2, N
      IF (CH80(I)(3:10) .EQ. T) THEN
         WRITE (4, FMT = '(A80)') CH80(I)
         CH80(I)(1:4) = '    '
         ENDIF
  325 CONTINUE
      I1 = I2
      GOTO 200
  900 WRITE (4, FMT = '(/'' $ ----------------------------- '')')
      RETURN
      END
      SUBROUTINE COMPAT
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatom7.inc'
      COMMON /BLANK7/
     *                ORGVEC(3, 32), NORIG, DMAX, DMAX2,
     *       NSUM(32), DSUM(32), PSHIF(3,32), ISHIF(32), ZSHIF(32),
     *       ZSUMA, ISC(32, MAXAT), DSC(32, MAXAT),
     *       IP(3), DELXYZ(3, 32, MAXAT), IZXYZ(32, MAXAT),
     *       XR(3,MAXAT), XS(3), XS1(3), XS2(3), XS3(3), XSHIFT(3)
     *     , ZFAMA, ZFAMB
      PARAMETER (MORE = 32 * MAXAT)
      CHARACTER*4 POLAR(8)
      DATA POLAR  / 'x   ',   'y   ',   'x y ',   'z   ',   'x z ',
     *              'y z ',   'xyz ',   '111 ' /
      DATA IATLIT, IATOMS, ICRYS /1, 2, 3/
      DATA NCALL, LIS6 / 0, 26 /
      IF (NCALL .LT. 0) RETURN
      CALL WR24
      CALL FILINQ (IATLIT, 'ATLIT', 'FORMATTED', 'INPUT', KINQ)
      IF (NCALL .EQ. 0) THEN
         IF (KINQ.EQ.-1) THEN
            WRITE (8, FMT='(/'' COMPAT called:''/
     *                       '' No COMPAT:  ATLIT file not found'')')
            NCALL = -1
            RETURN
            ENDIF
         ENDIF
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         WRITE (8, FMT='(/'' COMPAT called:''/
     *                    '' No COMPAT:  ATOMS file not found'')')
         RETURN
         ENDIF
      NCALL = NCALL + 1
      WRITE(24,FMT='(/'' COMPAT called: see file LIS6''/)')
      IF (NCALL .GT. 1) GOTO 107
      CALL FILCLO (LIS6, 'KEEP')
      CALL KERASE ('LIS6')
      OPEN (UNIT = LIS6, FORM = 'FORMATTED', FILE='lis6',STATUS = 'NEW')
      WRITE (LIS6, FMT='(''LIS6 '', A6 /1X/
     *      '' COMPAT: compare files ATLIT and ATOMS''/
     *      '' =====================================''/1X)') CCODE
      CALL RDCRYS (ICRYS)
      WRITE (LIS6, FMT='('' NSYMM, ICENT, NLATT, IPOLA: '', 4I2)')
     *    NSYMM, ICENT, NLATT, IPOLA
      CALL RDCRYB (ICRYS, 'NORIG', KEND)
      IF (KEND .EQ. -1)
     *   CALL KERROR ('No NORIG record on CRYSDA file', 0, 'COMPAT')
      BACKSPACE ICRYS
      READ(ICRYS, FMT = '(10X, I10)') NORIG
      WRITE (LIS6, FMT='('' Nr of origin vectors NORIG: '', I2/)') NORIG
      DO 105 N = 1,NORIG
      READ (ICRYS, FMT = '(10X, 3F10.7)') (ORGVEC(J,N), J= 1,3)
  105 CONTINUE
      CALL FILCLO (ICRYS, 'KEEP')
      IF (IPOLA .EQ. 0) GOTO 107
      IF (IPOLA .GE. 7) THEN
         WRITE (LIS6,FMT='('' COMPAT: present sp.gr. not programmed'')')
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATLIT, 'KEEP')
         NCALL = -1
         RETURN
         ENDIF
      IF (IPOLA .EQ. 3 .OR. IPOLA.GE.5) THEN
         WRITE (LIS6,FMT='('' COMPAT: not completed !!'')')
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATLIT, 'KEEP')
         NCALL = -1
         RETURN
         ENDIF
      CALL KERNZI ( 0, IP, 3)
      IF (IPOLA .EQ. 1 .OR. IPOLA .EQ. 3 .OR. IPOLA .EQ. 5) IP(1) = 1
      IF (IPOLA .EQ. 2 .OR. IPOLA .EQ. 3 .OR. IPOLA .EQ. 6) IP(2) = 1
      IF (IPOLA .EQ. 4 .OR. IPOLA .EQ. 5 .OR. IPOLA .EQ. 6) IP(3) = 1
      WRITE(LIS6, FMT= '('' Polar direction(s): '', A4)') POLAR(IPOLA)
  107 CONTINUE
      REWIND IATLIT
      CALL ATOMIN (IATLIT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL FILCLO (IATLIT, 'KEEP')
      IF (NCALL .GT. 1) WRITE (LIS6,FMT=
     *  '(//'' COMPAT ------------------------- CALL nr'', I3//)') NCALL
      WRITE(LIS6, FMT = '(28X,
     *    '' Number of atoms present    in ATLIT  : '',I4 /)') NAT
      CALL ATOMOC (1, ATXYZ, IZAT, NAT)
      ZSUMA = 0.0
      ZFAMA = 0.0
      ZFAMB = 0.0
      ZSUM1 = 0.0001
      DO 140 I =  1,NAT
      ZSUMA = ZSUMA + ATXYZ(4,I) * FLOAT( IZAT(I)**2 )
      ZSUM1 = ZSUM1 + ATXYZ(4,I)
      ZFAMA = ZFAMA + FLOAT( IZAT(I) )
      ZFAMB = ZFAMB + FLOAT( IZAT(I)**2 )
      CALL KERNAB (ATXYZ(1,I), XR(1,I), 3)
  140 CONTINUE
      ZSUMAV = SQRT ( ZSUMA / ZSUM1 )
      IF (NCALL .EQ. 1) WRITE(LIS6, FMT = '(
     *   '' rms Z from ATLIT is : '', F7.3 )') ZSUMAV
      CALL ATOMIN (IATOMS, OTXYZ, OTNAME, IZOT, MAXAT, NOT, KEYT)
      CALL FILCLO (IATOMS, 'KEEP')
      WRITE(LIS6, FMT = '(28X,
     *   '' Number of atoms in the model (ATOMS) : '',I4 )') NOT
      CALL ATOMOC (1, OTXYZ, IZOT, NOT)
      DMAX = 0.4
      DMAX2 = DMAX * DMAX
      CALL KERNZI (0, ISC, MORE)
      CALL KERNZA (0.0, DSC, MORE)
      CALL KERNZI (0, NSUM, 32)
      IF (IPOLA. EQ. 0) THEN
         CALL COMPOR
      ELSE
         CALL COMPOL
         ENDIF
      WRITE (LIS6,FMT='(/'' COMPAT finished '')')
      RETURN
      END
      SUBROUTINE COMPOR
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatom7.inc'
      COMMON /BLANK7/
     *                ORGVEC(3, 32), NORIG, DMAX, DMAX2,
     *       NSUM(32), DSUM(32), PSHIF(3,32), ISHIF(32), ZSHIF(32),
     *       ZSUMA, ISC(32, MAXAT), DSC(32, MAXAT),
     *       IP(3), DELXYZ(3, 32, MAXAT), IZXYZ(32, MAXAT),
     *       XR(3,MAXAT), XS(3), XS1(3), XS2(3), XS3(3), XSHIFT(3)
     *     , ZFAMA, ZFAMB
      DATA LIS6 / 26 /
      DO 290 IOR = 1, NORIG
      DO 280 IO = 1, NOT
      DO 180  J = 1, 3
  180 XS(J) = OTXYZ(J,IO)
      DO 190 J = 1, 3
  190 XS1(J)= XS(J) + ORGVEC(J,IOR)
      DO 270 IS = 1, NSYMM
      CALL SYMOP1 (IS, XS1, XS2)
      DO 260 IC = 1, 2
      JOR = IOR
      IF (ICENT.EQ.1 .AND. IC.EQ.2) JOR = IOR + NORIG
      DO 250 IL = 1, NLATT
      CALL SYMOP2 (IC, IL, XS2, XS3)
      DO 240 IA = 1, NAT
      CALL DISTSQ (XR(1,IA), XS3, DMAX, XSHIFT, DIST2)
      IF (DIST2 .GT. DMAX2) GOTO 240
      DIST = SQRT (DIST2)
      IF (ISC(JOR, IO) .NE. 0) THEN
         IF (DIST .GT. DSC(JOR, IO)) GOTO 240
      ELSE
         NSUM(JOR) = NSUM(JOR) + 1
         ENDIF
      ISC(JOR, IO) = IA
      DSC(JOR, IO) = DIST
  240 CONTINUE
  250 CONTINUE
  260 CONTINUE
  270 CONTINUE
  280 CONTINUE
  290 CONTINUE
      JORP = 2 * NORIG
      WRITE (LIS6, FMT='(/'' nr of hits for each origin shift:''/
     *     16I3/)') (NSUM(I), I=1,JORP)
      CALL COMPRI (JORP)
      RETURN
      END
      SUBROUTINE COMPRI (JORP)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatom7.inc'
      COMMON /BLANK7/
     *                ORGVEC(3, 32), NORIG, DMAX, DMAX2,
     *       NSUM(32), DSUM(32), PSHIF(3,32), ISHIF(32), ZSHIF(32),
     *       ZSUMA, ISC(32, MAXAT), DSC(32, MAXAT),
     *       IP(3), DELXYZ(3, 32, MAXAT), IZXYZ(32, MAXAT),
     *       XR(3,MAXAT), XS(3), XS1(3), XS2(3), XS3(3), XSHIFT(3)
     *     , ZFAMA, ZFAMB
      DIMENSION IAS(MAXAT)
      CHARACTER * 72 TEXT1, TEXT2, TEXT3
      DATA LIS6 / 26 /
      JBEST = 1
      NBEST = 0
      NBEST3= 0
      WBEST = 0.
      DBEST = 0.
      DISSD = 0.
      ZBEST = 0.
      ZMAX = 0.
      IZ4BES = 0
      ZFOMA = 0.
      ZFOMB = 0.
      DO 320 JOR = 1, JORP
      WSUM = 0.
      DIS2 = 0.
      DISMAX = 0.
      ZSUM = 0.
      IZ4 = 0
      NSUM3 = 0
      IF (NSUM(JOR) .EQ. 0) GOTO 320
      IF (NSUM(JOR) .LT. NBEST) GOTO 320
      DO 310 IO  = 1, NOT
      IF (ISC(JOR, IO) .EQ. 0) GOTO 310
      DIST = DSC(JOR, IO)
      IF (DIST .GT. DISMAX) DISMAX = DIST
      IF (DIST .LE. 0.4) IZ4 = IZ4 + 1
      IF (DIST .LE. 0.3) THEN
         W = 1.0
         NSUM3 = NSUM3 + 1
      ELSEIF (DIST .LE. 0.4) THEN
         W = (0.4 - DIST) * 10.
      ELSE
         W = 0.0
         ENDIF
      IA = ISC(JOR, IO)
      TTT = FLOAT(IZOT(IO)) / FLOAT(IZAT(IA))
      IF (TTT .GT. 1.) TTT = 1. / TTT
      W = W * W
      WSUM = WSUM + W
      DIS2 = DIS2 + DIST * DIST
      ZSUM = ZSUM + W * OTXYZ(4,IO) * FLOAT( IZOT(IO)**2 )
      ZFOMA = ZFOMA + W *  FLOAT( IZOT(IO) )
      ZFOMB = ZFOMB + W *  FLOAT( IZOT(IO)**2 )
  310 CONTINUE
      IF (ZSUM .GT. ZMAX) ZMAX = ZSUM
      IF (NSUM(JOR) .EQ. NBEST .AND. WSUM .LT. WBEST)  GOTO 320
      JBEST = JOR
      WBEST = WSUM
      NBEST = NSUM(JOR)
      DBEST = DISMAX
      ZBEST = ZSUM
      IZ4BES = IZ4
      NBEST3 = NSUM3
      IF (DIS2 . GT. 0.0001) DIS2 = SQRT (DIS2 / FLOAT(NBEST))
      DISSD = DIS2
  320 CONTINUE
      ZBEST = ZBEST / ZSUMA
      ZMAX = ZMAX / ZSUMA
      WRITE(LIS6, FMT = '(
     *     28X, '' Nr of atoms identified within 0.3 A  : '',I4 /
     *          '' Atoms < 0.6 A  : '',I4 ,
     *     ''  Stand. dev. ='', F5.2,
     *     ''  Max. dev. = '', F4.2 /
     *     28X, '' Nr of atoms identified within 0.4 A  : '',I4 )')
     *   NBEST3, NSUM(JBEST), DISSD, DBEST, IZ4BES
      WRITE(LIS6, FMT =
     *   '('' W(dev =0.3-->0.4) = 1-->0 :'' ,
     *     '' Weighted number of hits (< 0.4 A)  :'',F7.2 /
     *     '' FOM based on dev. and Z ==>'' ,
     *     '' Relative SUM (W Z**2) of model ====>'',F7.3 )')
     *   WBEST, ZBEST
      IF (ZMAX .GT. ZBEST+0.01) WRITE (8, FMT =
     *   '(//'' WARNING: the heavy atoms are not so good !!!!!!!!!!!''/
     *   '' Largest Relative SUM (W Z**2) of model found ======>'',F7.3/
     *   '' =======   ''//)')   ZMAX
      IF (NAT .LT. NOT/2) GOTO 500
      N1 = 1
  480 N2 = N1 +  9
      IF (N2 .GT. NOT) N2 = NOT
      TEXT1       = ' '
      TEXT2       = ' '
      TEXT3       = ' '
      IF (N1 .EQ. 1 ) THEN
         TEXT1(1:12) = ' ATOMS atom '
         TEXT2(1:12) = ' ATLIT atom '
         TEXT3(1:12) = ' distance '
         ENDIF
      I1 = 13
      DO 490 IO = N1,N2
      I2 = I1 + 5
      TEXT1(I1:I2) = OTNAME(IO)
      IA = ISC(JBEST, IO)
      IF (IA .GT. 0) THEN
         I3 = I1 -1
         TEXT2(I1:I2) = ATNAME(IA)
         IF (IZAT(IA) .NE. IZOT(IO)) TEXT2(I3:I3) = '*'
         WRITE (TEXT3(I3:I2), FMT = '(F4.2,3X)') DSC(JBEST,IO)
         TEXT3(I3:I3) = ' '
         IF (DSC(JBEST,IO) .GT. 0.2) TEXT3(I3:I3) = 'x'
         IF (DSC(JBEST,IO) .GT. 0.3) TEXT3(I3:I3) = 'X'
      ELSE
         TEXT2(I1:I1) = '?'
         ENDIF
      I1 = I2 + 1
  490 CONTINUE
      WRITE(LIS6, FMT = '(/ A72)') TEXT1
      WRITE(LIS6, FMT = '(A72)') TEXT2
      WRITE(LIS6, FMT = '(A72)') TEXT3
      N1 = N2+1
      IF (N1 .LE. NOT) GOTO 480
  500 CONTINUE
      CALL KERNZI (0, IAS, NAT)
      DO 575 IO  = 1,NOT
      IA = ISC(JBEST, IO)
      IF (IA .GT. 0) IAS(IA) = IO
  575 CONTINUE
      IF (NAT .GT. 2*NOT) GOTO 600
      N1 = 1
  580 N2 = N1 +  9
      IF (N2 .GT. NAT) N2 = NAT
      TEXT1       = ' '
      TEXT2       = ' '
      TEXT3       = ' '
      IF (N1 .EQ. 1 ) THEN
         TEXT1(1:12) = ' ATLIT atom '
         TEXT2(1:12) = ' ATOMS atom '
         TEXT3(1:12) = ' distance '
         ENDIF
      I1 = 13
      DO 590 IA = N1,N2
      I2 = I1 + 5
      TEXT1(I1:I2) = ATNAME(IA)
      IO   =  IAS(IA)
      IF (IO .GT. 0) THEN
         I3 = I1 -1
         TEXT2(I1:I2) = OTNAME(IO)
         IF (IZAT(IA) .NE. IZOT(IO)) TEXT2(I3:I3) = '*'
         WRITE (TEXT3(I3:I2), FMT = '(F4.2,3X)') DSC(JBEST,IO)
         TEXT3(I3:I3) = ' '
         IF (DSC(JBEST,IO) .GT. 0.2) TEXT3(I3:I3) = 'x'
         IF (DSC(JBEST,IO) .GT. 0.3) TEXT3(I3:I3) = 'X'
      ELSE
         TEXT2(I1:I1) = '?'
         ENDIF
      I1 = I2 + 1
  590 CONTINUE
      WRITE(LIS6, FMT = '(/ A72)') TEXT1
      WRITE(LIS6, FMT = '(A72)') TEXT2
      WRITE(LIS6, FMT = '(A72)') TEXT3
      N1 = N2+1
      IF (N1 .LE. NAT) GOTO  580
  600 CONTINUE
      N = 0
      DO 610 IA = 1, NAT
      IO = IAS(IA)
      IF (IO .GT. 0) THEN
         IF (IZAT(IA) .NE. IZOT(IO)) THEN
            IF (N .EQ. 0) WRITE
     *     (LIS6,FMT='(/'' Atom nomination ATLIT - ATOMS changed:''/)')
            N = N + 1
            WRITE (LIS6, 603) IA, ATNAME(IA), IO, OTNAME(IO)
  603       FORMAT (10X, 'nr', I4, 1X, A6, I3, 1X, A6)
            ENDIF
         ENDIF
  610 CONTINUE
      IF (N .EQ. 0) WRITE
     *   (LIS6, FMT='(1X/ '' All atom nominations are correct.''/)')
      WSUM3 = FLOAT(NSUM3)  / FLOAT(NAT) *100.
      WSUM4 = FLOAT(IZ4BES) / FLOAT(NAT) *100.
      IF (ZFAMA .GT. ZFOMA) THEN
         ZFOMA = ZFOMA / ZFAMA * 100.
         ZFOMB = ZFOMB / ZFAMB * 100.
      ELSE
         ZFOMA = ZFAMA / ZFOMA * 100.
         ZFOMB = ZFAMB / ZFOMB * 100.
         ENDIF
      ZBEST = ZBEST * 100.
      ZFOM  = ( WSUM3 + WSUM4 + ZFOMA + ZFOMB + ZBEST)  / 5.
      CALL WR24
  704 FORMAT (1X/' Figures Of Merrit from COMPAT:      (IPAT=',I2,')'//
     *   '  WSUM3  WSUM4  ZFOMA  ZFOMB  ZBEST   CFOM   (%) '/
     *   1X, 6F7.0 //)
      WRITE (8, 704) IPAT, WSUM3, WSUM4, ZFOMA, ZFOMB, ZBEST, ZFOM
      WRITE (LIS6, 704) IPAT, WSUM3, WSUM4, ZFOMA, ZFOMB, ZBEST, ZFOM
      WRITE (25,704) IPAT, WSUM3, WSUM4, ZFOMA, ZFOMB, ZBEST, ZFOM
      WRITE (8, 705) IPAT, WSUM3, WSUM4, ZFOMA, ZFOMB, ZBEST, ZFOM
  705 FORMAT (/' $TE COMPAT  IPAT=',I2,3X,5F5.0, '  FOM=', F5.0 /)
      RETURN
      END
      SUBROUTINE COMPOL
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatom7.inc'
      COMMON /BLANK7/
     *                ORGVEC(3, 32), NORIG, DMAX, DMAX2,
     *       NSUM(32), DSUM(32), PSHIF(3,32), ISHIF(32), ZSHIF(32),
     *       ZSUMA, ISC(32, MAXAT), DSC(32, MAXAT),
     *       IP(3), DELXYZ(3, 32, MAXAT), IZXYZ(32, MAXAT),
     *       XR(3,MAXAT), XS(3), XS1(3), XS2(3), XS3(3), XSHIFT(3)
     *     , ZFAMA, ZFAMB
      PARAMETER (MORE = 32 * MAXAT)
      DIMENSION XS4(3), XS5(3)
      DIMENSION ACELTY(10), NCELTY(10), NCELLZ(10)
      CHARACTER ACELTY *2
      DATA LIS6 / 26 /
      WENDO = 0.0
      DMAXP = 0.3
      DMAXP2 = DMAXP **2
      CALL CELZAT (ACELTY, NCELTY, NCELLZ)
      AVZ = 0.0
      TATOMS= 0.0
      DO 110 N=1,NTYPE
      IF (NCELLZ(N).GE. 2) THEN
         AVZ = AVZ + FLOAT( NCELLZ(N)*NCELTY(N) )
         TATOMS = TATOMS + FLOAT( NCELTY(N) )
         ENDIF
  110 CONTINUE
      ZMAX = NCELLZ(1)
      AVZ =AVZ / TATOMS
      IZMAX =  INT((AVZ + ZMAX)/2.)
      IF (IZMAX .LT. 20) IZMAX = 4
      WRITE(LIS6, FMT= '('' Threshold: Z(min) ='', I3)') IZMAX
      CALL KERNZA (0.0, XS4, 3)
      CALL KERNZA (0.0, XS5, 3)
      CALL KERNZI (0, IZXYZ, MORE)
      CALL KERNZA (0.0, PSHIF, 3*32)
      DO 290 IOR = 1, NORIG
      DO 280 IO = 1, NOT
      IF (IZOT(IO). LT. IZMAX) GOTO 280
      DO 180  J = 1, 3
  180 XS(J) = OTXYZ(J,IO)
      DO 190 J = 1, 3
  190 XS1(J)= XS(J) + ORGVEC(J,IOR)
      DO 270 IS = 1, NSYMM
      CALL SYMOP1 (IS, XS1, XS2)
      DO 260 IC = 1, 2
      JOR = IOR
      IF (IC.EQ.2) JOR = IOR + NORIG
      DO 250 IL = 1, NLATT
      CALL SYMOP2 (IC, IL, XS2, XS3)
      DO 240 IA = 1, NAT
      IF (IZAT(IA). LT. IZMAX) GOTO 240
      DO 195 I = 1,3
      IF (IP(I) .EQ. 1) GOTO 195
      XS4(I) = XS3(I)
      XS5(I) = XR(I,IA)
  195 CONTINUE
      CALL DISTSQ (XS4, XS5, DMAXP, XSHIFT, DIST2)
      IF (DIST2 .GT. DMAXP2) GOTO 240
      DIST = SQRT (DIST2)
      IF (DIST .LE. 0.2) THEN
         W = 1.0
      ELSE
         W = (0.4 - DIST) * 5.
         ENDIF
      IW = NINT (W * ATXYZ(4,IA) * FLOAT( IZAT(IA) * IZOT(IO) ) )
      NSUM(JOR) = NSUM(JOR) + 1
      IOX = NSUM(JOR)
      IZXYZ (JOR, IOX) = IW
      DO 210 I = 1,3
      DELXYZ(I,JOR,IOX) = 0.0
      IF (IP(I) .EQ. 0) GOTO 210
      DELXYZ(I,JOR,IOX) = AMOD (XS3(I) - XR(I,IA) +  3.0 , 1.0)
  210 CONTINUE
  240 CONTINUE
  250 CONTINUE
  260 CONTINUE
  270 CONTINUE
  280 CONTINUE
  290 CONTINUE
      JORBES = 0
      DSUMM = -1.
      DO 350 JOR = 1, 2 * NORIG
      DSUM(JOR) = 0.0
      IF (NSUM(JOR) .EQ. 0) GOTO 350
      IOX = NSUM(JOR)
      DO 330 IX = 1,IOX
      DSUM(JOR) = DSUM(JOR) + FLOAT ( IZXYZ(JOR,IX) )
  330 CONTINUE
      IF (DSUM(JOR) .GT. DSUMM) THEN
         DSUMM = DSUM(JOR)
         JORBES = JOR
         ENDIF
  350 CONTINUE
      IF (DSUMM .LT. 0.) THEN
         WRITE(LIS6,  FMT = '('' Not a single hit ! '')')
         RETURN
         ENDIF
      DSUMM = 0.30 * DSUMM
      JORP = 0
      CALL SHIFTP (JORBES, JORP, WENDO)
      IF (JORP .EQ. 0) THEN
         WRITE(LIS6,  FMT = '('' No suitable shift found ! '')')
         RETURN
         ENDIF
      DO 391 JOR = 1, 2*NORIG
      IF (JOR .EQ. JORBES) GOTO 391
      IF ( DSUM(JOR) .LT. DSUMM) GOTO 391
      CALL SHIFTP (JOR, JORP, WENDO)
  391 CONTINUE
      CALL KERNZI (0, ISC, MORE)
      CALL KERNZA (0.0, DSC, MORE)
      CALL KERNZI (0, NSUM, 32)
      DO 490 IOX = 1, JORP
      JOR = ISHIF(IOX)
      IOR = JOR
      IC = 1
      IF (JOR .GT. NORIG) THEN
         IOR = JOR - NORIG
         IC = 2
         ENDIF
      DO 480 IO = 1, NOT
      DO 408  J = 1, 3
  408 XS(J) = OTXYZ(J,IO)
      DO 409 J = 1, 3
  409 XS1(J)= XS(J) + ORGVEC(J,IOR)
      DO 470 IS = 1, NSYMM
      CALL SYMOP1 (IS, XS1, XS2)
      DO 450 IL = 1, NLATT
      CALL SYMOP2 (IC, IL, XS2, XS3)
      DO 419 J = 1, 3
  419 XS3(J)= XS3(J) - PSHIF(J,IOX)
      DO 440 IA = 1, NAT
      CALL DISTSQ (XR(1,IA), XS3, DMAX, XSHIFT, DIST2)
      IF (DIST2 .GT. DMAX2) GOTO 440
      DIST = SQRT (DIST2)
      IF (ISC(IOX, IO) .NE. 0) THEN
         IF (DIST .GT. DSC(IOX, IO)) GOTO 440
      ELSE
         NSUM(IOX) = NSUM(IOX) + 1
         ENDIF
      ISC(IOX, IO) = IA
      DSC(IOX, IO) = DIST
  440 CONTINUE
  450 CONTINUE
  470 CONTINUE
  480 CONTINUE
  490 CONTINUE
      CALL COMPRI (JORP)
      RETURN
      END
      SUBROUTINE SHIFTP (JOR, JORP, WENDO)
      INCLUDE 'Zcrys.inc'
      IF (IPOLA.LE.2 .OR. IPOLA.EQ.4) THEN
         CALL SHIFT1 (JOR, JORP, WENDO)
      ELSE
         CALL SHIFT2 (JOR, JORP, WENDO)
         ENDIF
      RETURN
      END
      SUBROUTINE SHIFT1 (JOR, JORP, WENDO)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatom7.inc'
      COMMON /BLANK7/
     *                ORGVEC(3, 32), NORIG, DMAX, DMAX2,
     *       NSUM(32), DSUM(32), PSHIF(3,32), ISHIF(32), ZSHIF(32),
     *       ZSUMA, ISC(32, MAXAT), DSC(32, MAXAT),
     *       IP(3), DELXYZ(3, 32, MAXAT), IZXYZ(32, MAXAT),
     *       XR(3,MAXAT), XS(3), XS1(3), XS2(3), XS3(3), XSHIFT(3)
     *     , ZFAMA, ZFAMB
      DIMENSION KMAX(3), XYZINC(3), KSHIF(3), WSHIF(3),
     *       SKARR(3,500), WKARR(3,500), TKARR(3,500), VKARR(3,500)
      IF (JORP .GE. 32) THEN
         WRITE (8, FMT='('' More then 32 shift vectors! reduce..'')')
         RETURN
         ENDIF
      CALL KERNZA (0.0, SKARR, 1500)
      CALL KERNZA (0.0, WKARR, 1500)
      DO 110 I = 1, 3
      T = 0.2 / CELL(I)
      KMAX(I) = NINT (1./ T)
      XYZINC(I) = 1. / FLOAT(KMAX(I))
  110 CONTINUE
      IOX = NSUM(JOR)
      DO 130 IX = 1, IOX
      DO 120 I = 1, 3
      IF (IP(I) .EQ. 0) GOTO 120
      K = INT (DELXYZ(I, JOR, IX) / XYZINC(I) ) + 1
      SKARR(I,K) = SKARR(I,K) + DELXYZ(I,JOR,IX) * IZXYZ(JOR, IX)
      WKARR(I,K) = WKARR(I,K) + FLOAT ( IZXYZ(JOR, IX) )
  120 CONTINUE
  130 CONTINUE
      WEND = 0.0
      DO 150  I = 1,3
      KSHIF(I) = 0
      WSHIF(I) = 0.0
      IF (IP(I) .EQ. 0 ) GOTO 150
      KM = KMAX(I)
      SKARR(I,KM) = SKARR(I,KM) + SKARR(I, KM+1)
      WKARR(I,KM) = WKARR(I,KM) + WKARR(I, KM+1)
      SKARR(I,KM+1) = SKARR(I,1)
      WKARR(I,KM+1) = WKARR(I,1)
      SKARR(I,KM+2) = SKARR(I,2)
      WKARR(I,KM+2) = WKARR(I,2)
      DO 140 K = 1,KM
      TKARR(I,K) = SKARR(I,K) + SKARR(I,K+1) + SKARR(I,K+2)
      VKARR(I,K) = WKARR(I,K) + WKARR(I,K+1) + WKARR(I,K+2)
      IF (VKARR(I,K) .GT. 1.) TKARR(I,K) = TKARR(I,K) / VKARR(I,K)
      IF (VKARR(I,K) .GT. WSHIF(I)) THEN
         WSHIF(I) = VKARR(I,K)
         KSHIF(I) = K
         ENDIF
  140 CONTINUE
      K = KSHIF(I)
      IF (K .EQ. 0) RETURN
      WEND = WSHIF(I)
      IF (WEND .LT. 0.30 * WENDO) RETURN
      JORP = JORP + 1
      IF (JORP .GT. 32) THEN
         WEND = 0.0
         WRITE (8, FMT='('' > 32 shift vectors! out of bonds'')')
         RETURN
         ENDIF
      PSHIF(I, JORP) = TKARR(I,K)
      ZSHIF(JORP) = WEND
      ISHIF(JORP) = JOR
      IF (WEND .GT. WENDO) WENDO = WEND
  150 CONTINUE
  200 WEND = -1.
      DO 250  I = 1,3
      IF (IP(I) .EQ. 0 ) GOTO 250
      K = KSHIF(I)
      KSHIF(I) = 0
      WSHIF(I) = 0.0
      KM = KMAX(I)
      WKARR(I,K) = 0.
      SKARR(I,K) = 0.
      K1 = MOD (K, KM) + 1
      WKARR(I,K1) = 0.
      SKARR(I,K1) = 0.
      K2 = MOD (K1, KM) + 1
      WKARR(I,K2) = 0.
      SKARR(I,K2) = 0.
      WKARR(I,KM+1) = WKARR(I,1)
      SKARR(I,KM+1) = SKARR(I,1)
      WKARR(I,KM+2) = WKARR(I,2)
      SKARR(I,KM+2) = SKARR(I,2)
      DO 240 K = 1,KM
      TKARR(I,K) = SKARR(I,K) + SKARR(I,K+1) + SKARR(I,K+2)
      VKARR(I,K) = WKARR(I,K) + WKARR(I,K+1) + WKARR(I,K+2)
      IF (VKARR(I,K) .GT. 1.) TKARR(I,K) = TKARR(I,K) / VKARR(I,K)
      IF (VKARR(I,K) .GT. WSHIF(I)) THEN
         WSHIF(I) = VKARR(I,K)
         KSHIF(I) = K
         ENDIF
  240 CONTINUE
      K = KSHIF(I)
      IF (K .EQ. 0) RETURN
      WEND = WSHIF(I)
      IF (WEND .LT. 0.30 * WENDO) RETURN
      JORP = JORP + 1
      PSHIF(I, JORP) = TKARR(I,K)
      ZSHIF(JORP) = WEND
      ISHIF(JORP) = JOR
  250 CONTINUE
      IF (JORP .LT. 32) GOTO 200
      RETURN
      END
      SUBROUTINE SHIFT2 (JOR, JORP, WENDO)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatom7.inc'
      COMMON /BLANK7/
     *                ORGVEC(3, 32), NORIG, DMAX, DMAX2,
     *       NSUM(32), DSUM(32), PSHIF(3,32), ISHIF(32), ZSHIF(32),
     *       ZSUMA, ISC(32, MAXAT), DSC(32, MAXAT),
     *       IP(3), DELXYZ(3, 32, MAXAT), IZXYZ(32, MAXAT),
     *       XR(3,MAXAT), XS(3), XS1(3), XS2(3), XS3(3), XSHIFT(3)
     *     , ZFAMA, ZFAMB
      PARAMETER (MQ = 150)
      DIMENSION KMAX(3), XYZINC(3), KSHIF(3), WSHIF(3),
     *       SKARR(MQ,MQ), WKARR(MQ,MQ), TKARR(MQ,MQ), VKARR(MQ,MQ)
      PARAMETER (MQM = MQ - 2, MQMQ = MQ * MQ)
      DATA LIS6 / 26 /
      WRITE (8,FMT='('' TEST start SHIFT2 JOR JORP'',3I4)') JOR, JORP
      CALL KERNZA (0.0, SKARR, MQMQ)
      CALL KERNZA (0.0, WKARR, MQMQ)
      DO 110 I = 1, 3
      T = 0.2 / CELL(I)
      KMAX(I) = NINT (1./ T)
      IF (KMAX(I) .GT. MQM) KMAX(I) = MQM
      XYZINC(I) = 1. / FLOAT(KMAX(I))
  110 CONTINUE
      WRITE (LIS6, FMT='('' Grid increments, KMAX'', 3F7.4, 9X, 3I4)')
      I1 = 1
      I2 = 3
      IF (IUNIQ .EQ. 1) I1 = 2
      IF (IUNIQ .EQ. 3) I2 = 2
      IOX = NSUM(JOR)
      WRITE (LIS6, FMT='('' TEST in SHIFT               '',  3I3)')
      WRITE (LIS6, FMT='('' TEST IOX = NSUM() nr of hits'',  3I3)') IOX
      DO 130 IX = 1, IOX
      K1 = INT (DELXYZ(I1, JOR, IX) / XYZINC(I1) ) + 1
      K2 = INT (DELXYZ(I2, JOR, IX) / XYZINC(I2) ) + 1
      WKARR(K1,K2) = WKARR(K1,K2) + IZXYZ(JOR, IX)
  130 CONTINUE
      WEND = 0.0
      CALL KERNZI (0, KSHIF, 3)
      CALL KERNZA (0.0, WSHIF, 3)
      KM1 = KMAX(I1)
      KM2 = KMAX(I2)
      WRITE (LIS6, FMT='('' TEST samenst.  KM1, KM2 '',3I3)') KM1, KM2
      DO 134 K1 = 1, KM1 + 1
      WKARR(K1,KM2) = WKARR(K1,KM2) + WKARR(K1, KM2+1)
  134 CONTINUE
      DO 135 K2 = 1, KM2
      WKARR(K2,KM1) = WKARR(K2,KM1) + WKARR(K2, KM1+1)
  135 CONTINUE
      DO 136 K1 = 1, KM1
      WKARR(K1,KM2+1) = WKARR(K1,1)
      WKARR(K1,KM2+2) = WKARR(K1,2)
  136 CONTINUE
      DO 137 K2 = 1, KM2 + 2
      WKARR(K2,KM1+1) = WKARR(K2,1)
      WKARR(K2,KM1+2) = WKARR(K2,2)
  137 CONTINUE
      CALL KERROR (' Call PTB !!', 0, 'SHIFT2')
      DO 140 K = 1,KM
      TKARR(I,K) = SKARR(I,K) + SKARR(I,K+1) + SKARR(I,K+2)
      VKARR(I,K) = WKARR(I,K) + WKARR(I,K+1) + WKARR(I,K+2)
      IF (VKARR(I,K) .GT. 1.) TKARR(I,K) = TKARR(I,K) / VKARR(I,K)
      IF (VKARR(I,K) .GT. WSHIF(I)) THEN
         WSHIF(I) = VKARR(I,K)
         KSHIF(I) = K
         ENDIF
  140 CONTINUE
      K = KSHIF(I)
      IF (K .EQ. 0) RETURN
      WEND = WSHIF(I)
      IF (WEND .LT. 0.30 * WENDO) RETURN
      IF (IPOLA.LE.2 .OR. IPOLA.EQ.4) THEN
         JORP = JORP + 1
         PSHIF(I, JORP) = TKARR(I,K)
         ZSHIF(JORP) = WEND
         ISHIF(JORP) = JOR
      IF (WEND .GT. WENDO) WENDO = WEND
         ENDIF
  200 WEND = -1.
      DO 250  I = 1,3
      IF (IP(I) .EQ. 0 ) GOTO 250
      K = KSHIF(I)
      KSHIF(I) = 0
      WSHIF(I) = 0.0
      KM = KMAX(I)
      WKARR(I,K) = 0.
      SKARR(I,K) = 0.
      K1 = MOD (K, KM) + 1
      WKARR(I,K1) = 0.
      SKARR(I,K1) = 0.
      K2 = MOD (K1, KM) + 1
      WKARR(I,K2) = 0.
      SKARR(I,K2) = 0.
      WKARR(I,KM+1) = WKARR(I,1)
      SKARR(I,KM+1) = SKARR(I,1)
      WKARR(I,KM+2) = WKARR(I,2)
      SKARR(I,KM+2) = SKARR(I,2)
      DO 240 K = 1,KM
      TKARR(I,K) = SKARR(I,K) + SKARR(I,K+1) + SKARR(I,K+2)
      VKARR(I,K) = WKARR(I,K) + WKARR(I,K+1) + WKARR(I,K+2)
      IF (VKARR(I,K) .GT. 1.) TKARR(I,K) = TKARR(I,K) / VKARR(I,K)
      IF (VKARR(I,K) .GT. WSHIF(I)) THEN
         WSHIF(I) = VKARR(I,K)
         KSHIF(I) = K
         ENDIF
  240 CONTINUE
      K = KSHIF(I)
      IF (K .EQ. 0) RETURN
      WEND = WSHIF(I)
      IF (WEND .LT. 0.30 * WENDO) RETURN
      JORP = JORP + 1
      PSHIF(I, JORP) = TKARR(I,K)
      ZSHIF(JORP) = WEND
      ISHIF(JORP) = JOR
  250 CONTINUE
      IF (JORP .LT. 32) GOTO 200
      RETURN
      END
CSUBFILE dirdif4.for
C                      contents: progr. PATTY, ORIENT, TRACOR and TRAVEC
C                                and some appendices
C
C=======================================================================
C=======================================================================
CPROGRAM PATTY dd4.C$600.     [major updt 10 Sep. 2006]        Jan. 2008
C$600.
      SUBROUTINE PATTY
      PARAMETER (MXPKS=150, MXPEAK=MXPKS+100)
      DIMENSION XP(5, MXPEAK)
      PARAMETER (MXHEAV=20,MXSTSX=30)
      DIMENSION XZ(5*MXHEAV+5,MXSTSX)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IPDEK, IFILE(14))
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MXPP=128)
      COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      CALL KEPROG ('PATTY')
      CALL PREPRO
      CALL ELEMS
      CALL PATHVY (PFMAPX, PORIGI, SCPAT, PLIM, VP,NVPS, XZ, NSTSXZ)
      IF (NSTSXZ.GE.1 .AND. NCONS.LE.2) GOTO 110
      PATAD = 25.
      CALL PREDEK (PFMAPX, PORIGI, SCPAT, PLIM, SCADEK, PATAD, PATP)
      SC2DEK=SCADEK
      PATADD=PATAD
      CALL PATTIN
      write(24, FMT='('' Patterson origin height:'',12X,F10.1)')
     *   PORIGI
      write(24, FMT='('' Patterson height for a '',A2,''-'',A2,
     *   '' vector:'',F10.1)') ACELTY(1), ACELTY(1),
     *   SCPAT*NCELLZ(1)**2 + PATAD
      IF (LTHEAV .GT. 1)
     *   write(24, FMT='('' Patterson height for a '',A2,''-'',A2,
     *   '' vector:'',F10.1)') ACELTY(LTHEAV), ACELTY(LTHEAV),
     *   SCPAT*NCELLZ(LTHEAV)**2 + PATAD
      CALL REMORI
      CALL GETOVC
      CALL KERNZA (0.0, XP, 5*MXPEAK)
      CALL SYMMPK (XP, NOP)
      IF (NOP.EQ.0) CALL KERROR
     *   ('No peaks found in the symmetry map', 0, 'PATTY')
      CALL PROSPK (XP, NOP, XZ, NSTSXZ)
      IF (NSTSXZ .EQ. 0) THEN
         WRITE (9, 106)
  106 FORMAT(1X/' The results from the symmetry map are not acceptable:'
     *   /' Scaling errors? B too low? Wrong H.A. in CELL contents?'/1X)
         CALL KERROR ('No solution acceptable !', 106, 'PATTY')
         ENDIF
 110  CALL HCOOUT (XZ, NSTSXZ, 1)
      CALL KEPROX
      RETURN
      END
      SUBROUTINE PREPRO
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (KLAUE, KEYS(6))
      EQUIVALENCE (ITPL, KEYS(7))
      EQUIVALENCE (FRACIN, KEYS(25))
      EQUIVALENCE (IATOMS,IFILE(1))
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (IFMAP, IFILE(17))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4)
      COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP),
     *                ASVECT(5,MAXASV),NASV
      CALL KERNZA (0.0, ASVECT, 5*MAXASV)
      CALL RDCRYS( ICRYS )
      P1METH=.FALSE.
      IF (ICENT.EQ.1 .AND. NSYMM.EQ.1) P1METH=.TRUE.
      GOTO
     * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE
  101 KLAUE = 1
      GOTO 105
  102 IF (IUNIQ .EQ. 3) GOTO 104
      KLAUE = -2
      IF (IUNIQ .EQ. 1) GOTO 105
      KLAUE = 2
      GOTO 105
  103 KLAUE = 3
      GOTO 105
  104 KLAUE = 4
  105 CONTINUE
      ITPL = 10
      FRACIN=0.0
      RETURN
      END
      SUBROUTINE TERIVA (VARNAM, VALUE)
      CHARACTER*8        VARNAM
      INCLUDE 'Zsyst.inc'
 101  WRITE(9, FMT ='('' '',A8,'' ='',F10.2)')  VARNAM, VALUE
 102  WRITE(9, FMT ='('' Do you want to change the value of '',
     *                     A8,''?  (Y or N)'')') VARNAM
      CALL KETERM (0, 1, KEND)
      IF (KEND .EQ. 24)  RETURN
      IF (KEND .EQ. 35) THEN
 110       WRITE(9, FMT ='('' Give '',A6)')  VARNAM
           CALL KETERM (1, 0, KEND)
           IF (KEND .GE. 0) THEN
             VALUE = FNUM(1)
           ELSE
             GOTO 110
           ENDIF
           GOTO   101
      ELSE
           WRITE(9, FMT ='('' Answer with Y or N!'')')
           GOTO   102
      ENDIF
      END
      SUBROUTINE ELEMS
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      EQUIVALENCE (ICRYS, IFILE(3))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      CALL CELZAT (ACELTY, NCELTY, NCELLZ)
 100  AVZ = 0.0
      TATOMS= 0.0
      DO 110 N=1,NTYPE
      IF (NCELLZ(N).GT. 1.1) THEN
         AVZ = AVZ + NCELLZ(N)*NCELTY(N)
         TATOMS = TATOMS + NCELTY(N)
         ENDIF
 110  CONTINUE
      ZMAX = NCELLZ(1)
      AVZ =AVZ / TATOMS
      IF (TATOMS/IMULT.GT.8.0 .AND. ZMAX**2.LT.1.25*AVZ**2)
     *   CALL KERROR (' No heavy atom structure. Do not use PATTY',0,
     *   'ELEMS')
      ZHEVY = (AVZ + ZMAX)/2.
      IF (ZHEVY .GT. ZMAX-0.01) ZHEVY=ZMAX-0.01
      write(24,FMT='('' Define heavy atoms:'' /
     *   '' Heavy atoms   number in asym.unit   Z'')')
      IMULTP=IMULT
      IF (P1METH) IMULTP=NLATT
      AMULT = IMULTP
      AVZ=AVZ*TATOMS
      DO 127 NT=1,2
      NHEAVY = 0
      NCELH = 0
      NCELHS= 0
      DO 120 N=1,NTYPE
      NCELSP(N) = MOD(NCELTY(N),IMULTP)
      NASYMP(N) = NCELTY(N)/IMULTP
      IF (NCELSP(N).GT.0) NASYMP(N)=NASYMP(N)+1
      IF (NCELLZ(N) .GT. ZHEVY) THEN
         LTHEAV = N
         IF (ZHEVY**2 .GT. 0.75*NCELLZ(N)**2)  ZHEVY = 0.866*NCELLZ(N)
         NCONST(N) = NASYMP(N)
         NHEAVY = NHEAVY + NCONST(N)
         NCELH = NCELH + NCELTY(N)
         IF (ICENT.EQ.2 .AND. NCELH/NLATT.LT.3 .AND. N.EQ.1)  THEN
            IF (ZHEVY.GT.NCELLZ(2).AND.NCELLZ(2).GT.AVZ.AND.
     *      NCELLZ(1)**2.LT.2*NCELLZ(2)*NCELLZ(1)) ZHEVY=NCELLZ(N+1)-.01
            ENDIF
         AVZ = AVZ - NCELTY(N)*NCELLZ(N)
         NCELHS= NCELHS+ NCELSP(N)
         ENDIF
 120  CONTINUE
      LT1=0
      LTHV=LTHEAV
      NCONS=NHEAVY
      IF (NT.EQ.2) GOTO 127
      IF (TATOMS-NCELH.GT.0.99) AVZ = AVZ/(TATOMS-NCELH)
      IF (TATOMS/IMULTP.GT.8.0 .AND. ZMAX**2 .LT. 2.0*AVZ**2)
     *   CALL KERROR (' No heavy atom structure. Do not use PATTY',0,
     *   'ELEMS')
      IF (NHEAVY.GT.3) GOTO 128
      DO 125  L = LTHEAV+1,NTYPE-1
      IF (NCELLZ(L)**2 .GT. 2.5*AVZ**2) THEN
         IF (.5*NCELLZ(L)**2 .GT. NCELLZ(L+1)**2) THEN
            ZHEVY=NCELLZ(L)-0.1
            GOTO 127
            ENDIF
      ELSE
         GOTO 128
         ENDIF
 125  CONTINUE
      GOTO 128
 127  CONTINUE
 128  CONTINUE
      DO 129 N=1,LTHEAV
      write(24,FMT='(3X,A2, F22.2, I11)')
     *   ACELTY(N), NCELTY(N)/AMULT, NCELLZ(N)
 129  CONTINUE
      HEAVYN = NCELH/AMULT
      IF (.NOT.P1METH .AND.
     *   ICENT.EQ.1 .AND. NSYMM.EQ.2 .AND. ILAUE.LE.2) THEN
         NM=0
         DO 210 I=1,3
 210     IF (IRSYMM(I,I,2).EQ.-1) NM=NM+1
         IF (NM.LE.1 .OR. HEAVYN.GT.2.9) P1METH=.TRUE.
         IF (P1METH) GOTO 100
         ENDIF
      NELMS = NTYPE
      CALL FILINQ( ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         WRITE(CHOUT, 130) CCODE
 130     FORMAT (' ERROR no CRYSDA file found for ', A6)
         CALL KERROR( CHOUT, 0, 'ELEMS')
         ENDIF
      DH1H2=2.7
      CALL RDCRYB(ICRYS, 'ELEM ', KEND)
      IF (KEND.EQ.1) THEN
         READ (CHIN,FMT='(14X,I6,20X,3F10.5)') NELECS, RAT1,RAT2,RAT3
         NELEC1 = NELECS
 211     CONTINUE
         IF (NELECS.GT.ZHEVY) DH1H2=AMIN1(DH1H2,2.*RAT1,2.*RAT2,2.*RAT3)
         CALL RDCRYB(ICRYS, 'ELEM ', KEND2)
         IF (KEND2.EQ.1) THEN
            READ (CHIN,FMT='(14X,I6,20X,3F10.5)') NELECS, RAT1,RAT2,RAT3
            IF (NELECS .NE. NELEC1) GOTO 211
            ENDIF
         ENDIF
      DH1H2=(DH1H2-0.2)*0.9
      CALL WR24
      RETURN
      END
      SUBROUTINE PREDEK(PFMAPX, PORIGI,SCPAT, PLIM, SCADEK, PATAD, XXXX)
      DIMENSION  XXXX(8)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IPDEK, IFILE(14))
      EQUIVALENCE (SCAKEY,KEYS(26))
      PARAMETER (PDEKX=254.)
      COMMON /SINGP/ SINGPK, ORIGIN, PATP(8)
      KEYS(27) = SINGPK
      KEYS(28) = ORIGIN
      CALL KERNAB (PATP, XXXX, 8)
      CALL PPROFI (PATP)
      SCADEK = (PDEKX-PATAD)/ PFMAPX
      SCAKEY = SCADEK
      PLIM = 0.25* PLIM * SCADEK + PATAD
      WRITE (8, FMT='(/'' PLIM used for symmetry-map='',F9.2)') PLIM
      PORIGI = PORIGI * SCADEK + PATAD
      SCPAT = SCPAT * SCADEK
      RETURN
      END
      SUBROUTINE PPROFI (PATP)
      DIMENSION PATP(8)
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      DATA IMAX2, DELY, DEL2Y /0, 0.0, 0.0/
      DEL = 0.01
      TAB(1) = 1.
      IXL = 0
      I = 2
   36 RRR = SQRT(FLOAT(I) - 0.9999)
      IX = RRR
      IF (IX.EQ.IXL) GOTO 37
      IXL = IX
      TAB(I) = PATP(IX)
      IF (IX.EQ.7) GOTO 38
      DELY = PATP(IX+1) - PATP(IX)
      DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY )
      GOTO 38
   37 DELX = RRR - FLOAT(IX)
      TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y
   38 IF (TAB(I).GT.0.1) IMAX2 = I - 1
      I = I + 1
      IF (I.LE.50) GOTO 36
      IF (IMAX2.GT.48) IMAX2=48
      RMAX2 = FLOAT(IMAX2) / 100.
      RMAX = SQRT( RMAX2)
      RETURN
      END
      SUBROUTINE PATHVY (PFMAPX, PORIGI, SCPAT, PLIM, VP,NVPS,XZ,NSTSXZ)
      PARAMETER (MXHEAV=20,MXSTSX=30,MXPP=128)
      DIMENSION XZ(5*MXHEAV+5,MXSTSX), VP(4,MXPP)
      DIMENSION INXZ(MXSTSX), X1Z(5*MXHEAV+5)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      EQUIVALENCE (IFMAP, IFILE(17))
      EQUIVALENCE (SCADEK, KEYS(26))
      EQUIVALENCE (ORFMAP, KEYS(28))
      EQUIVALENCE (IMAP, KSTAT(7))
      INTEGER*2 LPAT1
      ZN2 = NCELLZ(1)**2
      SUM = 0.0
      DO 110 IE = 1, NELMS
      ZI2 = NCELLZ(IE)**2
      NI  = NCELTY(IE)/NLATT
      SUM = SUM + NI*ZI2
      IF (IE .LE. LTHEAV) ZN2 = ZI2
 110  CONTINUE
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) CALL KERROR
     *   ('Patterson file (FMAP) not found.', -1, 'PATHVY')
      READ (IFMAP) FFTSC, IMAPX, IHALF
      READ (IFMAP)
      READ (IFMAP) IBSEC, IBJ, IBNX, LPAT1
      CALL FILCLO (IFMAP, 'KEEP')
      ORFMAP = 6000.
      PORIGI = ORFMAP
      SCPAT=ORFMAP/SUM
      PHH = SCPAT * NCELLZ(1)**2
      IF (ICENT.EQ.2 .AND. NCELTY(1).GE.4) PHH=PHH+PHH
      PLIM = SCPAT * ZN2
      PFMAPX = 8.* PHH
      CALL RDVECA (VP,NVPS,DH1H2)
      IF (NVPS.GT.1) PFMAPX= VP(4,2)
      IF (PFMAPX .GT. 0.8*ORFMAP) PFMAPX=0.8*ORFMAP
      NSTSXZ=0
      IF (NSYMM.NE.1 .OR. ICENT.NE.1) RETURN
      ISQ = 5*MXHEAV+3
      X1Z(1)=0.0
      X1Z(2)=0.0
      X1Z(3)=0.0
      X1Z(4)=1.0
      X1Z(5)=NCELLZ(1)
      X1Z(5*MXHEAV-1)=1.0
      X1Z(5*MXHEAV)=X1Z(5)*X1Z(5)
      X1Z(5*MXHEAV+1)=1.0
      X1Z(5*MXHEAV+3)=1.0*X1Z(5*MXHEAV)
      CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NSTSXZ, INXZ)
      NCO2=0
      IF (NCONST(1).GT.1)  NCO2=1
      IF (NCO2.EQ.0 .AND. LTHEAV.GT.1)  NCO2=2
      IF (NCO2.EQ.0)   RETURN
      X1Z(10)=NCELLZ(1)
      IF (NCELTY(1).LE.1) X1Z(10)=NCELLZ(2)
      X1Z(5*MXHEAV)=X1Z(5)**2+2*X1Z(10)*X1Z(5)+X1Z(10)**2
      NMXSTS=MXSTSX+1
      IF (NMXSTS.GT.NVPS) NMXSTS=NVPS
      DO 310 N=2,NMXSTS,1
      X1Z(6)=VP(1,N)
      X1Z(7)=VP(2,N)
      X1Z(8)=VP(3,N)
      X1Z(9)=1.0
      X1Z(10)=NCELLZ(NCO2)
      AMINM = VP(4,N)/(SCPAT*X1Z(10)*X1Z(5))
      X1Z(5*MXHEAV-1)=AMINM
      AM1=AMINM
      AM2=0.0
      IF (AM1.GT.1.3) THEN
         AM1=1.3
         AM2=(AMINM-1.3)*0.1
         ENDIF
      X1Z(5*MXHEAV+1)=2.0
      X1Z(5*MXHEAV+3)= (AM1+AM2) * X1Z(5*MXHEAV)
      CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NSTSXZ, INXZ)
 310  CONTINUE
      MXINXZ=MXSTSX
      CALL SORTIN(INXZ,MXINXZ, NSTSXZ, XZ, 5*MXHEAV+5, MXSTSX)
      RETURN
      END
      SUBROUTINE RDVECA (VEC,NVEC,DH1H2)
      PARAMETER  (MXPP=128)
      DIMENSION          VEC(4,MXPP)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IATOMS,IFILE(1))
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      LOGICAL  READVC
      DIMENSION VECN(3), VEC000(3), DVEC(3)
      CHARACTER*6  LATM(1)
      DATA     LATM, VEC000 / 'ATOM  ', 0.,0.,0./
      READVC=.FALSE.
      NVEC=1
      VEC(1,1)=0.0
      VEC(2,1)=0.0
      VEC(3,1)=0.0
      VEC(4,1)=30254.
      DHAHB = DH1H2*0.8
      DHAHB2=DHAHB**2
      CALL FILINQ( IATOMS,'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR
     *   ('No ATOMS file (with Patterson pieks) found', 0, 'RDVECA')
 111  CALL KERINA (IATOMS, LATM, 1, LEND)
      IF (LEND.NE.0) GOTO  310
      IF (NLUSER(1).GT.0 .AND. NFNUM.GE.5) THEN
         READVC = .TRUE.
         IF (ABS(FNUM(2)).LT.0.01 .AND. ABS(FNUM(3)).LT.0.01 .AND.
     *          ABS(FNUM(4)).LT.0.01 .AND. NVEC.EQ.1 ) THEN
            GOTO 111
         ELSE
            VECN(1)=FNUM(2)
            VECN(2)=FNUM(3)
            VECN(3)=FNUM(4)
            CALL DISTSQ (VEC000, VECN, DHAHB, DVEC, RR2)
            IF (RR2.GT.DHAHB2) THEN
                NVEC=NVEC+1
                CALL KERNAB(VECN,VEC(1,NVEC),3)
                VEC(4,NVEC)=FNUM(5)
                ENDIF
            IF (NVEC.LT.MXPP-1) GOTO 111
            ENDIF
      ELSE
         IF (.NOT. READVC) GOTO 111
         ENDIF
 310  CONTINUE
      RETURN
      END
      SUBROUTINE REMORI
      INCLUDE 'Zcrys.inc'
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3), VDUMMY
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      DIMENSION X(3),XYZL(3),XYZS(3),XORI(3),XOR(3),
     *          IXORI(3),IXOR(3),IXR(3),IXL(3),IX1(3),IT(3)
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      STEPR=0.0
      CALL KERNZA(0.0,XORI,3)
      DO 100 I=1,3
      XYZL(I)=LXYZ(I)/GTXYZ(I)
      XYZS(I)=IS(I)/GTXYZ(I)
      CALL KERNZA(0.0,X, 3)
      X(I) = 1./GTXYZ(I)
      STEP = SQDIST(XORI,X)
      STEPR= STEPR + STEP
      STEP = SQRT(STEP)
      R=DH1H2-0.5*STEP
      IXR(I) = R/STEP
 100  CONTINUE
      STEPR=SQRT(STEPR)
      R = DH1H2-0.5*STEPR
      R2=R*R
      DO 910 NL=1,NLATT
      DO 110 I=1,3
      TLNL=TLATT(I,NL)
      IF (TLNL.LT.XYZS(I)) TLNL=TLNL+INT(0.999+XYZS(I)-TLATT(I,NL))
      IF (TLNL.GT.XYZL(I)) TLNL=TLNL-INT(0.999+TLATT(I,NL)-XYZL(I))
      IXORI(I)=NINT(TLNL*GTXYZ(I))
      XORI(I)=TLNL
 110  CONTINUE
      DO 610 ITX = -1,1,1
      IT(1) = ITX
      DO 610 ITY = -1,1,1
      IT(2) = ITY
      DO 610 ITZ = -1,1,1
      IT(3) = ITZ
      DO 120 I=1,3
      XOR(I)=XORI(I)+IT(I)
      IXOR(I)=IXORI(I)+IT(I)*NUM(I)
      IXL(I)=IXOR(I)+IXR(I)
      IF (IXL(I).LT.IS(I))  GOTO 610
      IX1(I)=IXOR(I)-IXR(I)
      IF (IX1(I).GT.LXYZ(I)) GOTO 610
      IF (IXL(I).GT.LXYZ(I)) IXL(I) = LXYZ(I)
      IF (IX1(I).LT.IS(I))   IX1(I) = IS(I)
 120  CONTINUE
      DO 310 IZ = IX1(3), IXL(3)
      X(3)= IZ/GTXYZ(3)
      DO 310 IY = IX1(2), IXL(2)
      X(2)= IY/GTXYZ(2)
      DO 310 IX = IX1(1), IXL(1)
      X(1)= IX/GTXYZ(1)
      DX2= SQDIST(XOR,X)
      IF (DX2.LT.R2) THEN
         IADR = NUMXY * IZ + NUM(1) * IY + IX - NUMC
         ITAB(IADR) = 0
         ENDIF
 310  CONTINUE
 610  CONTINUE
 910  CONTINUE
      RETURN
      END
      SUBROUTINE GETOVC
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      COMMON /ORIGNS/ NOR, ORIG(3,8), IDDPOL, RVPOL(3)
      CALL RDCRYB(ICRYS, 'NORIG', KEND)
      IF (KEND.EQ.1) THEN
         READ (CHIN,FMT='(10X,I10)') NOR
         DO 210 N=1,NOR
         CALL RDCRYB(ICRYS, 'ORGVEC', KEND2)
         IF (KEND2.EQ.1) THEN
            READ (CHIN,FMT='(10X,3F10.7)') (ORIG(I,N),I=1,3)
         ELSE
            NOR=N-1
            write(24,
     *         FMT='(''  ERROR CRYSDA: NUMBER OF ORIGINS < NORIG'')')
            GOTO 220
            ENDIF
 210     CONTINUE
 220     IDDPOL=1
         IF (IPOLA.EQ.0) IDDPOL=0
         IF (IPOLA.EQ.3 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.6) IDDPOL=2
         IF (IPOLA.EQ.7) IDDPOL=3
         RVPOL(1)=0.0
         IF (IPOLA.EQ.1 .OR. IPOLA.EQ.6 .OR. IPOLA.EQ.8) RVPOL(1)=1.0
         RVPOL(2)=0.0
         IF (IPOLA.EQ.2 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.8) RVPOL(2)=1.0
         RVPOL(3)=0.0
         IF (IPOLA.EQ.3 .OR. IPOLA.EQ.4 .OR. IPOLA.EQ.8) RVPOL(3)=1.0
      ELSE
         CHOUT = ' ERROR: no origins on CRYSDA file !'
         CALL KERROR( CHOUT, 0, 'GETOVC')
         ENDIF
      RETURN
      END
      SUBROUTINE PROSPK (XP, NOP, XZ, NSTSXZ)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION XP(5, NOP), XZ(5*MXHEAV+5,MXSTSX)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ITPL, KEYS(7))
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      PARAMETER (MXPKS=150, MXSTSP=140)
      DIMENSION XP2(5, MXPKS), MULORD(MXPKS), NCOSTA(MXHEAV),
     *          PISET(MXHEAV+3,MXSTSP), X(4*MXHEAV+5,MXSTSX), PLIMF(3)
      LOGICAL READY, SPGP1
      DATA NCOSTA / MXHEAV*-1/
      N = (4*MXHEAV+5) * MXSTSX
      CALL KERNZA (0., X, N)
      NP2 = MIN0(NOP,MXPKS)
      NXP = NP2
      SPGP1 = NSYMM*ICENT .EQ. 1
       CALL OCCUPA (P1METH, XP, XP2, NP2)
      IF (.NOT. P1METH) THEN
         write(24, FMT = '(/ '' Highest peaks of the symmetry map''/
     *      ''  No.      x         y         z        height    '',
     *      ''mult.factor'')')
         NOPRI = MIN0 (10, NOP)
         DO 199 N = 1, NOPRI
         write(24, FMT='('' '',I3,2X,3F10.4,2F10.1)')
     *      N, (XP(I,N),I=1,5)
  199    CONTINUE
         ENDIF
      CALL PATHLI (XP2, NP2, NP3)
      CALL WR24
      NP2=NP3
      WRITE(8,FMT='('' Limit patterson height:'',F6.1)') PLIMS(LTHV)
      WRITE (8, FMT='('' Symmetry-map peaks lower than this value'',
     *'' are ignored'')')
      ITPL = 2
      IF (.NOT.P1METH .AND. IPOLA.NE.0)  ITPL = 4
      PLIM0=PLIMC(LTHEAV,LTHEAV)
      CALL CROS2P( XP2,NP2, PLIM0, MULORD, NPKS2, MAHEAV)
      MIHEAV=2
      DO 100 I = 1, MXHEAV
      IF (I.LT.MIHEAV .OR. I.GT.MAHEAV) THEN
        NCOSTA(I)=-1
      ELSE
        NCOSTA(I)= 1
      ENDIF
      IF (SPGP1 .AND. I.LE.2) NCOSTA(I)=2
 100  CONTINUE
      NEWXZ = 0
 111  CALL EVALUX (XZ,NSTSXZ,NEWXZ, NCOSTA, READY)
      CALL PATHLI (XP2, NP2, NP3)
      IF (.NOT. READY) THEN
         NEWXZ=0
         CALL CROS2S (XP2,MULORD,NCOSTA,PISET,NSETS,XZ,NSTSXZ)
         WRITE (8, FMT='('' Sets of peaks and minimum-value'')')
         WRITE (8, FMT='('' Number of sets found:'',I3)') NSETS
         IF (MAHEAV .GT. 1 .AND. NSETS.GT.0) THEN
            NSETSX=0
            PLIMF(3)=PLIMC(LTHV,LTHV)
            IF (NCONST(LTHV).EQ.1.AND.LTHV.GT.1)
     *         PLIMF(3)=PLIMC(LTHV-1,LTHV)
            IF (LT1.GT.0 .AND. LT1.LT.LTHV)  THEN
               PLIMF(1)=PLIMC(LT1,LT1)
               PLIMF(2)=PLIMC(LT1,LTHV)
            ELSE
               PLIMF(1)=PLIMF(3)
               PLIMF(2)=PLIMF(3)
               ENDIF
            CALL FIXONE (XP2,NPKS2, PISET,NSETS, PLIMF, X,NSETSX)
            CALL DISCRX (X, NSETSX, XZ, NSTSXZ, NEWXZ)
            ENDIF
         WRITE(9, 311) NCONS
  311    FORMAT (' Patty search for',I3,' atoms done')
         CALL WR24
         IF (NSTSXZ.GT.0) CALL HCOOUT (XZ, NSTSXZ, 0)
         GOTO 111
         ENDIF
      IF (NCONS .EQ. 1) THEN
         IF (SPGP1) NXP=1
         CALL POS1S (XP, NXP, X, NSETSX)
         CALL DISCRX (X, NSETSX, XZ, NSTSXZ, NEWXZ)
         ENDIF
      NPMAX=16*NLATT
      CALL DISCAB (XZ,NSTSXZ,NPMAX)
      RETURN
      END
      SUBROUTINE OCCUPA (SPGP1, X1, X2, NX)
      LOGICAL SPGP1
      DIMENSION X1(5,NX), X2(5,NX)
      INCLUDE 'Zsyst.inc'
      DIMENSION XLOCK(3)
      PARAMETER (DMAX=0.7)
      DO 210 N = 1,NX
      IF (.NOT.SPGP1) THEN
         X1(5,N) = OCCUPX( X1(1,N) )
         IF (X1(5,N) .LT. 0.99) THEN
         CALL LOCKIN (X1(1,N), DMAX, XLOCK, DIST, NPOS)
         IF (DIST.GT.0.1) write(24,120) N,DIST,(X1(J,N),J=1,3),XLOCK
  120    FORMAT (' Atom ',I3,' locked in: peak shifted over', F6.2,
     *      ' Angstrom' / ' Peak xyz:',3F9.5, ' LOCKED xyz:',3F9.5)
         CALL KERNAB (XLOCK,X1(1,N),3)
         ENDIF
         ENDIF
 210  CALL KERNAB (X1(1,N), X2(1,N), 5)
      RETURN
      END
      SUBROUTINE PATHLI (XP2, NP2, NP3)
      DIMENSION XP2(5, NP2)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      EQUIVALENCE (FRACIN, KEYS(25))
      DIMENSION ILIMS(10), ILIMC(10,10)
      LOGICAL FIRST
      DATA FIRST, FRAC /.TRUE., 0.0/
      DATA IFRAC / 0 /
      CALL KERNZA (-1. , PLIMC, 100)
      PLIMOL=PLIM
      IF (FIRST) THEN
         CALL KERNZI (0, ILIMS, 10)
         CALL KERNZI (0, ILIMC, 100)
         IF (P1METH) THEN
            PLIMTH= SCPAT * (NCELLZ(1)*NCELLZ(LTHV)) + PATAD
            FRAC=0.40
            ATSMIN=AMAX1((HEAVYN*HEAVYN - HEAVYN)/2.0+1.0, 11.)
         ELSE
            PLIMTH= SCPAT * (NCELLZ(LTHEAV)**2) + PATAD
            FRAC = 0.30
            ATSMIN=4.0*HEAVYN
            ENDIF
         PLIM=AMAX1((PLIMTH-PATAD)*FRAC*1.25 + PATAD, PLIMOL)
         ATOMS = 0.0
         DO 110 N = 1, NP2
         ATOMS = ATOMS + AMIN1( XP2(5,N),1.0 )
         IF (ATSMIN .LT. ATOMS + 0.01) THEN
            IF (PLIM .GT. XP2(4,N)) PLIM=AMAX1(XP2(4,N), PLIMOL)
            GOTO 120
            ENDIF
 110     CONTINUE
 120     FRAC = (PLIM-PATAD)/(PLIMTH-PATAD)
         FRAC = FRAC*0.8
         IF (FRAC.LT.0.3) THEN
            FRAC=0.3
            PLIM=(PLIMTH-PATAD)*FRAC+ PATAD
            ENDIF
         ENDIF
      IF (FRACIN.GT.0.01) FRAC=FRACIN
      IF (FRACIN.LT.0.01) FRACIN=FRAC
      KFRAC = 100.1 * FRAC
      IF (KFRAC .NE. IFRAC) WRITE (8,FMT='
     *   (/'' Limit P(Patterson) ='',F5.2,'' x P(theoretical)'')') FRAC
      IF (KFRAC .NE. IFRAC) IFRAC = KFRAC
      FRACS= FRAC*1.25
      FRACC= FRAC
      FRACHL=0.8
      I1=1
      IF (LT1.NE.0 .AND. LTHV.GT.LT1)  I1=LT1+1
      IF (FIRST) I1=1
      DO 220 I = 1,NELMS
      IF (I.GE.I1) THEN
         IF (P1METH) THEN
            PLIMS(I) = (SCPAT*NCELLZ(1)*NCELLZ(I))*FRACS + PATAD
         ELSE
            PLIMS(I) = (SCPAT*NCELLZ(I)*NCELLZ(I))*FRACS + PATAD
            ENDIF
         IF (PLIM.GT.PLIMS(I))   PLIM=PLIMS(I)
         ENDIF
      II = 100.1 * PLIMS(I)
      IF (II .NE. ILIMS(I)) THEN
         WRITE(8,FMT=
     *      '('' Limit value selfvector  of atoms  '',A2, 3X, F7.1)')
     *      ACELTY(I), PLIMS(I)
         ILIMS(I) = II
         ENDIF
      DO 210 J = I,LTHV
      IF (I.GE.I1 .OR. J.GE.I1) THEN
         FRACCC=FRACC
         IF (J.GT.LTHV) FRACCC=FRACHL
         PLIMC(I,J)=(SCPAT*NCELLZ(I)*NCELLZ(J))*FRACCC+ PATAD
         IF (J.GT.LTHV) GOTO 210
         IF (PLIM.GT.PLIMC(I,J)) PLIM=PLIMC(I,J)
         PLIMC(J,I)=PLIMC(I,J)
         II = 100.1 * PLIMC(I,J)
         IF (II .NE. ILIMC(I,J)) THEN
            WRITE(8,FMT=
     *        '('' Limit value crossvector of atoms  '',A2,1X,A2,F7.1)')
     *        ACELTY(I), ACELTY(J), PLIMC(I,J)
            ILIMC(I,J) = II
            ILIMC(J,I) = II
            ENDIF
         ENDIF
 210  CONTINUE
 220  CONTINUE
      FIRST=.FALSE.
      DO 310 N=2,NP2
      IF (XP2(4,N).LT.PLIMS(LTHV)) THEN
         NP3=N-1
         RETURN
         ENDIF
 310  CONTINUE
      NP3=NP2
      RETURN
      END
      SUBROUTINE CROS2S(XP2,MULORD,NCOSTA,PISET,IPSTS, XZ,NSTSXZ)
      PARAMETER (MXPKS = 150, MXHEAV=20,MXSTSP=140)
      PARAMETER (MXSTSX=30, IXZ=5*MXHEAV+5)
      DIMENSION XP2(5, MXPKS), NCOSTA(MXHEAV), PISET(MXHEAV+3,MXSTSP)
      DIMENSION MULORD(MXPKS), ICANPK(MXPKS), PISET1(MXHEAV+3,MXSTSP),
     *          ICANP1(MXPKS), XZ(IXZ,MXSTSX)
      INCLUDE 'Zsyst.inc'
      PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      DATA     NPI1 /0/
      NPKS=NPCT
      CALL SELCPK(XP2,NPKS, ICANP1)
      MINBRK=NCONS1+1
      IF (MINBRK.GT.NCONS) MINBRK=1
      IF (P1METH .AND. MINBRK.EQ.1 .AND. NCONS.GE.2)  MINBRK=2
      ICP=-1
      IF (MINBRK.EQ.1 .OR. (P1METH.AND.MINBRK.EQ.2)) ICP=0
      IF (ICP.LT.0 .AND. MINBRK.EQ.2)                ICP=1
      IF (ICP.LT.0 .AND. P1METH.AND.MINBRK.EQ.3)     ICP=2
      IF (ICP.LT.0)                                  ICP=3
      NET=0
      NT1=0
      DO 101 L=1,LTHV
      DO 100 N=1,NPKS
      IF (ICANP1(N).NE.L) GOTO 100
      NET=NET+1
      NSET(NET)=N
 100  CONTINUE
      IF ((ICP.EQ.1 .OR. ICP.EQ.2) .AND. L.EQ.LT1)  NT1=NET
 101  CONTINUE
      write(24,FMT='(I4,'' peaks selected for atoms search'')') NET
      WRITE(8,FMT='(I4,'' peaks selected for atoms search'')') NET
      IF (ICP.EQ.0) THEN
         IPSTS=0
         CALL CONSPN (XP2,NPKS,MULORD,ICANP1,PISET,IPSTS)
         GOTO 1000
      ENDIF
      N1=0
      IF (ICP.EQ.3) THEN
           IF (NPI1.EQ.0) THEN
             VALXZM=XZ(5*MXHEAV+3,1)
             DO 110 N=1,NSTSXZ
             IF (XZ(5*MXHEAV+3,N)/VALXZM .LT. 0.666) GOTO 112
             NN=XZ(5*MXHEAV+5,N)
             IF (PISET(MXHEAV,NN).LT.-0.1) THEN
               PISET(MXHEAV,NN)=1.0
               NPI1=NPI1+1
               DO 105 I=1,MINBRK-1
 105           PISET1(I,NPI1)=PISET(I,NN)
             ENDIF
 110         CONTINUE
           ENDIF
 112       N1=NPI1
      ENDIF
      IF (ICP.EQ.1) N1=NT1
      IF (ICP.EQ.2) N1=NT1-1
      IPSTS=0
      DO 510 N=1,N1
      IF (ICP.EQ.3) THEN
         DO 220 I=1,MINBRK-1
         NSET1=NINT(PISET1(I,N))
         DO 210 J=I,NET
         IF (NSET1.NE.NSET(J)) GOTO 210
           NSET(J)=NSET(I)
           NSET(I)=NSET1
           GOTO 220
 210     CONTINUE
         GOTO 510
 220     CONTINUE
      ELSE IF (N.GT.1) THEN
         NSET1=NSET(MINBRK-1)
         DO 310 J=MINBRK,NET
 310     NSET(J-1)=NSET(J)
         NSET(NET)=NSET1
         IF (ICP.EQ.2) THEN
           NP2=NSET(MINBRK-1)
           IF (NINT(XP2(5, NSET1)) .EQ. NINT(XP2(5, NP2)) ) GOTO 510
         ENDIF
      ENDIF
      DO 410 I=1,NET
      I1=NSET(I)
      ICANPK(I1)=ICANP1(I1)
      IF (I.GE.MINBRK .AND. ICANPK(I1).LE.LT1)  ICANPK(I1)=LT1+1
 410  CONTINUE
      CALL CONSPN(XP2,NPKS,MULORD,ICANPK, PISET,IPSTS)
 510  CONTINUE
 1000 CONTINUE
      NCOSTA(NCONS) = 2
      RETURN
      END
      SUBROUTINE CROS2P( XP2,NP, PLIM0, MULORD,NPKS, MAHEAV)
      PARAMETER (MXPKS = 150)
      DIMENSION XP2(5, MXPKS), MULORD(MXPKS)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      EQUIVALENCE (KEYS(7),ITPL)
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION XPNPEQ(3,48), XOUT(5,20), CVEC(3)
      LOGICAL PATSYM, TLATTI, ENANTI
      DATA  PATSYM, TLATTI, ENANTI /.FALSE.,.FALSE.,.TRUE./
      CALL KERNZA( PATAD, P1X2, NMAXP2)
      IF (P1METH) THEN
        NPCT=NP
        NPKS=NP
        MAHEAV=HEAVYN
        CALL KERNZI (1,MULORD,MXPKS)
        NMULN=1
        NMULN2=1
        NOUT=1
        DO 120 N2=1,NPKS
        DO 110 N =N2+1,NPKS
        CALL VMINV(XP2(1,N2),XP2(1,N),CVEC,3)
        CALL GRDOUT (CVEC,FUNF)
        XOUT(4,1)=FUNF
        IF (N2.EQ.1) XP2(4,N)=FUNF
        CALL WRCROS (N,NMULN,N2,NMULN2,XOUT, NOUT,P1X2,NMAXP2,NPCT)
 110    CONTINUE
        FUNF=XP2(4,N2)
        N=N2
        CALL AR2SYM( FUNF,N,N2, NPKS, P1X2, NMAXP2)
 120    CONTINUE
        GOTO 3000
      ENDIF
      CALL CROSPP (XP2,NP, MULORD,PLIM0)
      NPKS = NPCT
      MAHEAV = MXESUM (XP2, NPKS, HEAVYN)
      IF (MAHEAV .EQ. 1) RETURN
      DO 2000 N2 = 1, NPKS
      IF (XP2(5,N2)-0.01 .GT. HEAVYN)  GOTO 2000
      IF (MULORD(N2) .LT. 0) GOTO 2000
      NMULN2 = MULORD(N2)
      DO 1000 N = N2+1, NPKS
      IF (XP2(5,N2)+XP2(5,N)-0.01 .GT. HEAVYN)  GOTO 1000
      IF (MULORD(N) .LT. 0) GOTO 1000
      NMULN = MULORD(N)
      CALL ALLEQP( XP2(1,N), XPNPEQ, 48, PATSYM,TLATTI, NEQPNP)
      NOUT = MAX0( NMULN2, NMULN)
      PXX2 = OCMINF (XP2(1,N2), XPNPEQ, NEQPNP, 1, 0, ENANTI,
     *    PLIM0, XOUT, NOUT)
      IF (NOUT.EQ.0) THEN
         XOUT(4,1)=PXX2
         NOUT=1
         ENDIF
      CALL WRCROS (N,NMULN, N2,NMULN2, XOUT, NOUT, P1X2, NMAXP2, NPCT)
 1000 CONTINUE
 2000 CONTINUE
 3000 CONTINUE
      IP2LST=IPOIN1(NPCT,NPCT,NPCT)
      AVCROS=0.0
      DO 3100 I=1,IP2LST
 3100 AVCROS=AVCROS+P1X2(I)
      AVCROS=AVCROS/IP2LST
      write(24,FMT='(''  Average value of cross-table:'',F8.1)')AVCROS
      WRITE(8,FMT='(''  Average value of cross-table:'',F8.1)')AVCROS
      RETURN
      END
      SUBROUTINE CROSPP (XP2,NPKS, MULORD,PLIM0)
      PARAMETER (MXPKS=150, NMAXP2=(MXPKS*MXPKS+MXPKS)/2 )
      DIMENSION XP2(5, MXPKS), MULORD(MXPKS)
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      PARAMETER (MXHEAV=20)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION INP1X1(MXPKS), PNXN(2), P1X1N(2,MXPKS), IP11SQ(MXPKS),
     *      MULPK(MXPKS), P1X1(MXPKS)
      DIMENSION XPNPEQ(3,48), XOUT(5,20), PXX(5,20)
      EQUIVALENCE (XOUT(1,1), PXX(1,1))
      LOGICAL PATSYM, TLATTI, ENANTI
      DATA  PATSYM, TLATTI, ENANTI /.FALSE.,.FALSE.,.TRUE. /
      NPKSMX=MXPKS
      NPKSL = MIN0 (NPKS, NPKSMX)
      PLIML =AMAX1 (XP2(4,NPKSL),PLIM0)
      F = 0.5
      PLIM2 = PLIML + (PLIML-PATAD)*F
      NPKS11 = 0
      DO 1000 N = 1, NPKSL
      MULPK(N) = 0
      PNXN(1) = N
      PNXN(2) = XP2(4,N)
      CALL EL2AR2 (PNXN,2,2,P1X1N,NPKSMX,NPKS11,IP11SQ)
      IF (XP2(4,N).GT.PLIM2 .AND. 2.0*XP2(5,N)-0.01.LT.HEAVYN)  THEN
         NOUT = NINT( (XP2(4,N)-PLIML)/((PLIML-PATAD)*F) )
         NOUT1= NINT(HEAVYN/XP2(5,N))
         NOUT = MIN0(NOUT,MXHEAV-1,NOUT1)
         CALL ALLEQP( XP2(1,N), XPNPEQ, 48, PATSYM,TLATTI, NEQPNP)
         PXX2 = OCMINF
     *      (XP2(1,N),XPNPEQ,NEQPNP, 1, 0, ENANTI, PLIML, XOUT,NOUT)
         PNXN(1) = N
         DO 110 N1 = 1, NOUT
         IF (XOUT(4,N1).LT.PLIM0) GOTO 1000
         PNXN(2) = XOUT(4,N1)
  110    CALL EL2AR2 (PNXN,2,2,P1X1N,NPKSMX,NPKS11,IP11SQ)
      ENDIF
 1000 CONTINUE
      IPKS11=NPKS11
      CALL SORTIN(IP11SQ,MXPKS, IPKS11, P1X1N, 2, NPKS11)
      DO 1100 M = 1, NPKS11
      N = NINT(P1X1N(1,M))
      MULPK(N)=MULPK(N)+1
 1100 CONTINUE
      INP1X1(1) = 0
      DO 1200 N = 1, NPKS-1
 1200 INP1X1(N+1) = INP1X1(N) + MULPK(N)
      DO 1300 M = 1, NPKS11
      N = NINT(P1X1N(1,M))
      IP = INP1X1(N) + 1
      P1X1(IP) = P1X1N(2,M)
      INP1X1(N) = IP
 1300 CONTINUE
      NI = 0
      DO 1400 N = 1, NPKSL
      IF (MULPK(N) .NE. 0) THEN
         NI = NI +1
         CALL KERNAB(XP2(1,N), XP2(1,NI), 5)
         MULPK(NI) = MULPK(N)
         INP1X1(NI) = INP1X1(N)
      ENDIF
 1400 CONTINUE
      NPKSL = NI
      NPCT=NPKS11
      N1 = NPKS11+1
      DO 2300 N = NPKSL,1,-1
      N11 = N1 - 1
      DO 2100 M = MULPK(N),1,-1
      N1 = N1 - 1
      MULORD(N1) = 1 - M
 2100 CALL KERNAB (XP2(1,N), XP2(1,N1), 5)
      NMULN1 = MULPK(N)
      MULORD(N1) = NMULN1
      NMULN2 = NMULN1
      N2 = N1
      NX = 0
      DO 2200 NP1 = N1, N11
      NX = NX + 1
 2200 PXX(4,NX) = P1X1(NP1)
      CALL WRCROS (N1,NMULN1, N2,NMULN2, PXX, NX, P1X2, NMAXP2, NPCT)
 2300 CONTINUE
      RETURN
      END
      SUBROUTINE HCOOUT (X, NSTSX, KATOUT)
      INCLUDE 'Zsyst.inc'
      PARAMETER (MXHEAV=20, MSTSX=30)
      DIMENSION X(5*MXHEAV+5, MSTSX)
      EQUIVALENCE (IDDL, IFILE(1)), (IATOMS,IFILE(1)), (IATOLD,IFILE(2))
      EQUIVALENCE (IRUN, KSTAT(13))
      DIMENSION ATXYZ(10,MXHEAV)
      CHARACTER*6 ATNAME(MXHEAV)
      CHARACTER*72 REWRCO(25)
      DATA NAT1 /0/
      DO 100 N=1,MXHEAV
      CALL KERNZA (0.0, ATXYZ(1,N), 10)
 100  ATXYZ(4,N)=1.0
      NAT=0
      NXPT = 5*MXHEAV+1
      NXVL = 5*MXHEAV+3
      FMUL = X(NXVL,1)/10000.
      FPVAL= X(NXVL,1)*0.666
      IF (FMUL.LT.1.0) FMUL=1.0
      IF (KATOUT .EQ. 1)
     *    write(24, FMT= '(/'' Set  FOM  MinAv  Min1  Minx  '',
     *    ''  Atom       x        y        z      mult'')')
      MA=0
      DO 210 MX = 1, NSTSX
      ISETVL = NINT(X(NXVL,MX)/FMUL)
      AMINM = X(5*MXHEAV-1,MX)
      CONTHL= X(5*MXHEAV-2,MX)
      AMIM1 = X(5*MXHEAV-3,MX)
      IF (KATOUT .EQ. 1)
     *   write(24,FMT='(I4,I6,3F6.3)') MX,ISETVL,AMINM, AMIM1, CONTHL
      NHEOUT = NINT( X(NXPT,MX))
      CALL AZATNA (X(1,MX), NHEOUT, ATXYZ, ATNAME)
      DO 105 N=1,NHEOUT
      IF (KATOUT .EQ. 1)
     *   write(24,FMT='(33X,A6,3F9.5,F6.2)') ATNAME(N),
     *   (ATXYZ(I,N),I=1,4)
 105  ATXYZ(4,N)=1.0
      NAT = NHEOUT
      IF (MX .EQ. 1) REWIND IATOMS
      WRITE(CHOUT,FMT='('' Model PAT'',I3,'' FOM='',I6)') MX, ISETVL
      CALL ATOMWR(IATOMS, ATXYZ, ATNAME, NAT)
      IF (MX.EQ.1) NAT1=NAT
      MA=MA+1
      IF (X(NXVL,MX) .LT. FPVAL) GOTO 310
 210  CONTINUE
 310  CONTINUE
      IF (KATOUT .EQ. 0) RETURN
      CALL FILCLO (IATOMS, 'KEEP')
      KPROG = 7
      WRITE (CHOUT,FMT='(''RUN '',I3,'' ATOMS NAT= '',I4,
     *    '' KPROG '', I3)') IRUN, NAT1, KPROG
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      WRITE (9, FMT='('' Number of ATOM sets output: '', I3)') MA
      IF (MA .GT. 1) RETURN
      ICON = IDDL
      CALL FILINQ( ICON, 'CONDA', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) RETURN
  400 CALL KERINA (ICON, LIT, 1, LEND)
      IF (LEND .NE. 0) RETURN
      IF (LIT(2) .NE. 'R2CALC' .OR. LIT(4) .NE. 'PATTY') GOTO 400
      IR = 1
  401 READ (ICON, FMT='(A72)', END=411) REWRCO(IR)
      IF (IR.EQ.1 .AND. REWRCO(1)(1:7).NE.'PROGRAM') GOTO 401
      IR = IR + 1
      GOTO 401
  411 REWIND ICON
      WRITE (ICON, FMT='(''CONDA '', A6)') CCODE
      IRL = IR - 1
      DO 437 IR = 1, IRL
  437 WRITE (ICON, FMT='(A72)') REWRCO(IR)
      CALL FILCLO (ICON, 'KEEP')
      IDDS = ICON
      CALL FILINQ( IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDS, FMT='(''DDMAIN''/''PHASEX''/''DDMAIN''/''FOUR'')')
      WRITE (IDDS, FMT='(''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      RETURN
      END
      SUBROUTINE AZATNA (X, N, ATXYZ, ATNAME)
      DIMENSION X(5,N), ATXYZ(10,N)
      CHARACTER*6 ATNAME(N)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /ELEMB/ ACELTY(10)
      CHARACTER*2 ACELTY
      CHARACTER*4 CNANR
      M=0
      DO 210 NE=1,NELMS
      DO 110 N1=1,N
      IZN1 = NINT(X(5,N1))
      IF ( IZN1 .EQ. NCELLZ(NE) ) THEN
          M=M+1
          IL = INDEX(ACELTY(NE), ' ')
          IF (IL.NE.2) IL=3
          ATNAME(M)(1:IL-1) = ACELTY(NE)(1:IL-1)
          NANR=1
          DO 105 NA=1,N1-1
          IF (IZN1 .EQ. NINT(X(5,NA))) NANR=NANR+1
 105      CONTINUE
          WRITE (CNANR, FMT='(I4)') NANR
          IN=0
 111      IN=IN+1
          IF (CNANR(IN:IN) .EQ. ' ') GOTO 111
          ATNAME(M)(IL:) = CNANR(IN:)
          DO 120 I=1,4
 120      ATXYZ(I,M)=X(I,N1)
      ENDIF
 110  CONTINUE
 210  CONTINUE
      RETURN
      END
      SUBROUTINE EVALUX (XZ,NSTSXZ,NEWXZ, NCOSTA, READY)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION XZ(5*MXHEAV+5,MXSTSX), NCOSTA(MXHEAV)
      LOGICAL  READY
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      EQUIVALENCE (FRACIN, KEYS(25))
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      LOGICAL  FIRST
      DATA     FIRST, FRAC, LTFRA /.TRUE., 0.2, 0/
      IF (FIRST) THEN
         FIRST=.FALSE.
         FRAC=FRACIN
         LTFRA=0
         NCONS=0
         I1=2
         IF (NSYMM*ICENT.EQ.1) I1=3
         DO 102 I=MXHEAV,I1,-1
         IF (NCOSTA(I).EQ.1) THEN
           DO 101 J=I1,I
 101       NCOSTA(J)=1
           GOTO 103
         ENDIF
 102     CONTINUE
 103     IF (P1METH .AND. NSYMM*ICENT.NE.1) THEN
             DO 106 J=1,3
             IF (ABS(TSYMM(J,2)).GT.0.1) THEN
               DO 105 I=1,MXHEAV,2
 105           IF (NCOSTA(I).EQ.1) NCOSTA(I)=-1
               GOTO 107
             ENDIF
 106         CONTINUE
         ENDIF
 107     MXHVY=0
         DO 110 I=1,MXHEAV
 110     IF (NCOSTA(I).EQ.1) MXHVY=I
         IF (MXHVY .LE. 1) THEN
            NCONS=1
            NCONST(1)=1
            LTHV=1
            READY=.TRUE.
            GOTO 1000
         ENDIF
         NCONS1=0
         LT1=0
         NHVY=MIN0(NASYMP(1), MXHVY)
          DO 120 I=2,LTHEAV
            IF ((0.6*NCELLZ(I-1)**2 .GT. NCELLZ(I)**2)) THEN
              LT1=I-1
              GOTO 121
            ENDIF
          NHVY=MIN0(NHVY+NASYMP(I), MXHVY)
          IF (NHVY.EQ.MXHVY) GOTO 122
 120      CONTINUE
          IF (.NOT.P1METH) GOTO 122
          NHVY=1
          LT1=1
 121      NCONS1=NHVY
          IF (NHVY.EQ.1) NHVY=MIN0(NHEAVY, MXHVY)
          IF (P1METH .AND. NHVY.EQ.2) NHVY=MIN0(NHEAVY, MXHVY)
 122      CONTINUE
         IF (NHVY.LT.2) NHVY=2
         L=0
         DO 140 I=NHVY,2,-1
         IF (NCOSTA(I).EQ.1) THEN
             NCONS = I
             L=1
             NCONST(1)=0
             DO 130 J=1,NCONS
             NCONST(L)=NCONST(L)+1
             IF (J.EQ.NCONS) GOTO 130
             IF (NCONST(L).EQ.NASYMP(L) .AND. L.LT.LTHEAV) THEN
                L=L+1
                NCONST(L)=0
             ENDIF
 130         CONTINUE
             IF (NCONS.LT.NHVY .AND. NCONS1.GT.NCONS) THEN
                 NCONS1=NCONS
                 LT1=L
             ENDIF
             GOTO 141
         ENDIF
 140     CONTINUE
 141     LTHV=L
         READY=.FALSE.
         NCOSTA(NCONS)=0
         GOTO 1000
      ELSE
        IF (NEWXZ.EQ.0) THEN
         DO 210 J = NCONS,MXHEAV
         IF (NCOSTA(J).NE.2)   NCOSTA(J)=-1
 210     CONTINUE
        ENDIF
        READY = .FALSE.
        MXCDON=0
        MAXC=1
        MINC=MXHEAV+1
        DO 340 J = MXHEAV,1,-1
        IF (NCOSTA(J).EQ.2 .AND. MXCDON.EQ.0) MXCDON=J
        IF (NCOSTA(J).EQ.1 .AND. MAXC.EQ.1) MAXC=J
        IF (NCOSTA(J).EQ.1) MINC=J
        IF (MAXC.NE.1.AND.(NCOSTA(J).EQ.2 .OR. MAXC.LT.MXCDON)) GOTO 400
 340    CONTINUE
        IF (MAXC.EQ.1) NCONS=1
        IF (MAXC.EQ.1) MINC=1
      ENDIF
 400  VALMOX=0.0
      IF (NSTSXZ.GT.0)  VALMOX = XZ(5*MXHEAV+3,1)
      IF (NSTSXZ.GT.0 .AND. NCONS.EQ.1) THEN
          VALMXN=IMULT**2 * NCELLZ(1)**2 * AMI2
          IF (VALMXN.LT.VALMOX) THEN
             NCONS=2
             READY=.TRUE.
             GOTO 1000
          ENDIF
      ENDIF
      IF (READY) RETURN
      NCONS=0
      L=1
      NCONST(1)=0
      DO 430 J=1,MAXC
      NCONS=NCONS+1
      NCONST(L)=NCONST(L)+1
      IF (J.EQ.MAXC) GOTO 430
      IF (NCONST(L).EQ.NASYMP(L)) THEN
        IF (L.EQ.LTHEAV) GOTO 410
        IF (J.LT.MINC .OR. NCONST(L+1)+NASYMP(L+1).LE.MAXC) THEN
            L=L+1
            NCONST(L)=0
            GOTO 430
        ENDIF
 410    IF (J.LT.MINC) GOTO 430
 411     IF (NCOSTA(NCONS).EQ.1)  GOTO 441
         NCONS=NCONS-1
         IF (NCONST(L).EQ.0) L=L-1
         NCONST(L)=NCONST(L)-1
         GOTO 411
      ENDIF
 430  CONTINUE
 441  LTHV=L
      NCOSTA(NCONS)=0
      IF (NCONS.EQ.1) READY=.TRUE.
      IF (NCONS.EQ.1) RETURN
      IF (MXCDON.GT.NCONS) THEN
            IF (NSTSXZ.EQ.0) GOTO 1000
            IF (NCONS .GT. XZ(5*MXHEAV+1,1)) GOTO 1000
          IMULTP=IMULT
          IF (P1METH) IMULTP=NLATT
          NHVYCL=NINT(HEAVYN*IMULTP)
          SUMINW=0.0
          JMSUM=0
          DO 520 M=1,LTHV
          JM=NCONST(M)*IMULTP
          IF (JMSUM+JM .GT. NHVYCL) JM=NHVYCL-JMSUM
          JMSUM=JMSUM+JM
          SUM=0.0
          JNSUM=0
          DO 510 N=1,LTHV
          JN=NCONST(N)*IMULTP
          IF (JNSUM+JN .GT. NHVYCL) JN=NHVYCL-JNSUM
          JNSUM=JNSUM+JN
 510      SUM=SUM + JN * NCELLZ(M)*NCELLZ(N)
          SUMINW=SUMINW + JM*SUM
 520      CONTINUE
          VALMX1=VALMOX
          IF (XZ(5*MXHEAV+1,1)+0.1 .LT. MXHEAV)
     *       VALMX1 = (VALMOX/ XZ(5*MXHEAV-1,1)) * XZ(5*MXHEAV-3,1)
          FRACIN=AMAX1(0.667*VALMX1/SUMINW, FRAC)
          IF (FRACIN.GT. 1.2) FRACIN=1.2
          VALMXN=SUMINW*AMI2
          IF (VALMXN .LT. VALMOX)    READY=.TRUE.
      ENDIF
 1000 CONTINUE
      IF (LTHV.GT.LTFRA) THEN
        LTFRA=LTHV
        IF (NCONS.LE.1) RETURN
        IFPL = 1000
        IF (P1METH) IFPL = 2000
 1111   CALL FRALIM(FRACIN, FRACIN+0.4, IFPL, FRACN)
        IF (FRACIN.GT.0.29 .AND. FRACN.LT.0.001) THEN
          FRACIN=FRACIN-0.1
          GOTO 1111
        ENDIF
        IF (FRACN.GT.0.001) FRACIN = FRACN
        FRAC=FRACIN
      ENDIF
      RETURN
      END
      SUBROUTINE POS1S (XP,NP, X, NSETSX)
      PARAMETER (MXHEAV=20, MXSTSX=30, IX=4*MXHEAV+5,MXPKS=150)
      PARAMETER (MXINX=MXSTSX)
      DIMENSION X(IX,MXSTSX), XP(5, MXPKS)
      DIMENSION XF(IX), INX(MXINX)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      LOGICAL ENUGHA
      PARAMETER (PMAX=30254., D1=0.001)
      DATA   XF /IX*0.0/
      ENUGHA=.FALSE.
      NSETSX=0
      ISQ = 4*MXHEAV+3
      PLIML = PLIM
      DO 210 N = 1, NP
         IF (ENUGHA .AND. XP(4,N) .LT. PLIML) GOTO 220
         IF (XP(5,N).LT.HEAVYN+D1) THEN
           ATOMSX = XP(5,N)
           IF (.NOT.ENUGHA) THEN
            ENUGHA= ATOMSX .GT. HEAVYN-D1 .OR. ATOMSX .GT. 0.99
            IF (ENUGHA) THEN
            PLIMLL = (XP(4,N)-PATAD)*0.50 + PATAD
            IF (PLIMLL .LT. PLIML) PLIML=PLIMLL
            ENDIF
           ENDIF
           CALL KERNAB (XP(1,N), XF, 3)
           XF(4)=XP(5,N)
           XF(4*MXHEAV+1)=1.
           XF(4*MXHEAV+2)=ATOMSX
           XF(4*MXHEAV+3)=XP(4,N) + (PMAX-PLIM)*ATOMSX
           CALL EL2AR2 (XF,IX, ISQ, X, MXSTSX, NSETSX, INX)
         ENDIF
 210     CONTINUE
 220     CONTINUE
      CALL SORTIN(INX,MXINX, NSETSX, X,IX,MXSTSX)
      RETURN
      END
      SUBROUTINE SYMMPK (XP, NOP)
      PARAMETER (MXPKS=150,MXPEAK=MXPKS+100)
      DIMENSION XP(5, MXPEAK)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER  (MXPP=128)
      COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD
      COMMON /ORIGNS/ NOR, ORIG(3,8), IDDPOL, RVPOL(3)
      COMMON /SELFWT/ IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      DIMENSION ASY(6), XPP(3,12)
      LOGICAL PATSYM, TLATTI
      DATA DMAX, PATSYM, TLATTI / 0.05, .TRUE., .FALSE./
      IF (.NOT. P1METH) GOTO 200
         NOP=0
         DO 100 N=1,NVPS
         CALL ALLEQP (VP(1,N), XPP, 12, PATSYM,TLATTI, NEQP)
         DO 95 I=1,NEQP
         NOP=NOP+1
         CALL KERNAB(XPP(1,I),XP(1,NOP),3)
         XP(4,NOP)=VP(4,N)
         XP(5,NOP)=N+0.01
  95     CONTINUE
         IF (N.EQ.NVPS .OR. NOP+NEQP.GT.MXPEAK)
     *      CALL DELIPO (XP, NOP, DMAX)
         IF (NOP+NEQP .GT. MXPEAK) RETURN
  100    CONTINUE
         RETURN
  200 CALL ASYMS (ASY)
      CALL SYSTOP (ASY)
      CALL HAMAWT
      WRITE (8, FMT='(/'' Subroutine HAMAWT'',
     *  '' = symmetry of symmetry map:'' /
     *  '' Rotation matrix         Translation         weight     NSDH''
     *   , 48(/ 3(3I2, 1X), 2X, 3F6.2, F7.1, 5X, 4I4 ) )')
     *   ( ((IRSY1(I,J,N),I=1,3), J=1,3), (TSY1(I,N), I=1,3),
     *   SWGT(N), (NSDH(I,N), I=1,4), N=1, NSSY )
      WRITE (9,*) 'Calculate symmetry map'
      CALL SYMMAP
      WRITE (9,*)  ' ---------------------- and interpret its peaks'
      NPEAKS=MXPEAK
      CALL PEAKHG (NPEAKS, PLIM, NOP, XP)
      IF (NOP.GT.1) CALL DELPKO (XP, NOP, NXYZS)
      RETURN
      END
      SUBROUTINE SYSTOP (ASY)
      DIMENSION ASY(6)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3), VDUMMY
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      DATA  IFUNMX /30254/
      MLEFT = NUMTAB - NUMXYZ
      RES2P = 2.
 101  IF (RES2P .LT. 0.9) CALL KERROR ('Symmetry map storage problems:',
     *   101, 'SYSTOP')
      DO 110 I=1,3
      NXYZS(I) = NINT( RES2P * NXYZ(I))
      GTXYZS(I) = FLOAT(NXYZS(I))
      FSTPSY(I) = 1./GTXYZS(I)
      I2 = I+I
      ISS(I) = INT(ASY(I2-1)* GTXYZS(I) - 0.999 ) - 2
      LXYZS(I) = INT(ASY(I2) * GTXYZS(I) + 0.999 ) + 2
      NUMS(I) = LXYZS(I) - ISS(I) + 1
 110  CONTINUE
      NUSXY = NUMS(1)*NUMS(2)
      NUSXYZ= NUSXY * NUMS(3)
      IF (NUSXYZ .GT. MLEFT) THEN
         RES2P = RES2P - 0.1
         GOTO 101
         ENDIF
      WRITE (8,FMT='(/'' Subroutine SYSTOP''/
     *                   '' Stepsizes of patterson:   '',3F5.2,
     *      '' (Angstrom)'')') (CELL(I)/GTXYZ(I), I=1,3)
      WRITE (8,FMT='( '' Stepsizes of symmetry-map:'',3F5.2,
     *      '' (Angstrom)'')') (CELL(I)/GTXYZS(I),I=1,3)
      IADEOP = NUM(1) * NUM(2) * NUM(3)
      NUMSC = NUSXY * ISS(3) + NUMS(1) * ISS(2) + ISS(1) - 1 - IADEOP
      WRITE (8,FMT='( '' Stored block: NGRID / cell edges :'', 3I4,
     *                 / '' Stored block starting grid points:'', 3I4,
     *                 / '' Stored block: nr of points stored:'', 3I4
     *   )') NXYZS, ISS, NUMS
      WRITE (8,FMT='( '' Address  for symmetry-map:  IADR ='', I7,
     *   '' * IZ +'', I3, '' * IY + IX -'', I7)') NUSXY, NUMS(1), NUMSC
      IADR1 = IADEOP + 1
      IADEND= IADEOP + NUMS(1)*NUMS(2)*NUMS(3)
      DO  210 IADR = IADR1, IADEND
 210  ITAB(IADR) = IFUNMX
      RETURN
      END
      SUBROUTINE SYMMAP
      INCLUDE 'Zcrys.inc'
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /SELFWT/ IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION NUMSS1(3), IX(3), X(3),GX(3)
      SYMAX = 30254.
      DO 500 NSY1= 2, NSSY
      DO 104 I=1,3
      IF (IRSY1(1,I,NSY1).EQ.0 .AND. IRSY1(2,I,NSY1).EQ.0 .AND.
     *    IRSY1(3,I,NSY1).EQ.0) THEN
         NUMSS1(I) = 1
      ELSE
         NUMSS1(I) = NUMS(I)
         ENDIF
 104  CONTINUE
      NUMXS1=NUMSS1(1)
      NUMYS1=NUMSS1(2)
      NUMZS1=NUMSS1(3)
      SYMXNW= 0.0
            GX(3) = ISS(3) - 1
            IX(3) = ISS(3) - 1
      DO 333 JZ = 1, NUMZS1
            IX(3) = IX(3)+1
            GX(3) = GX(3)+1.
            X(3) = GX(3)/GTXYZS(3)
            GX(2) = ISS(2) - 1
            IX(2) = ISS(2) - 1
      DO 222 JY = 1, NUMYS1
            IX(2) = IX(2)+1
            GX(2) = GX(2)+1.
            X(2) = GX(2)/GTXYZS(2)
            GX(1) = ISS(1) - 1
            IX(1) = ISS(1) - 1
      DO 111 JX = 1, NUMXS1
            IX(1) = IX(1)+1
            GX(1) = GX(1)+1.
            X(1) = GX(1)/GTXYZS(1)
      CALL STORSY (X, IX, NSY1, NUMSS1, SYMAX, SYMXNW)
 111  CONTINUE
 222  CONTINUE
 333  CONTINUE
      SYMAX=SYMXNW
 500  CONTINUE
      RETURN
      END
      SUBROUTINE HAMADI(IRSY1, NUMS, NUMXS1)
      DIMENSION IRSY1(3,3), NUMS(3), NUMXS1(3)
      DO 140 I=1,3
      IF (IRSY1(1,I).EQ.0 .AND. IRSY1(2,I).EQ.0
     *      .AND. IRSY1(3,I).EQ.0) THEN
           NUMXS1(I) = 1
      ELSE
           NUMXS1(I) = NUMS(I)
      ENDIF
 140  CONTINUE
      RETURN
      END
      SUBROUTINE HARVEC (IRSY1, TSY1, X, XS)
      DIMENSION IRSY1(3,3), TSY1(3), X(3), XS(3)
      DO 120 I2 = 1,3
      XS(I2) = 0.
      DO 110 I1 = 1,3
      IF (IRSY1(I2,I1) .NE. 0) THEN
            IF (IRSY1(I2,I1) .GT. 0) THEN
            XS(I2) = XS(I2) + X(I1)
            IF (IRSY1(I2,I1) .EQ. 2) XS(I2) = XS(I2) + X(I1)
            ELSE
            XS(I2) = XS(I2) - X(I1)
            ENDIF
      ENDIF
 110  CONTINUE
 120  CONTINUE
      CALL VPLUSV (XS, TSY1, XS, 3)
      RETURN
      END
      SUBROUTINE STORSY (X, IX, NSY1, NUMSS1, SYMAX, SYMXNW)
      DIMENSION X(3),IX(3), NUMSS1(3)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      DIMENSION XGS(3),XG(3),STPX(3)
      LOGICAL FIRST1
      DATA   FUNF  /30254./
      FIRST1=.TRUE.
      DO 101 I=1,3
      XGS(I)= IX(I)/GTXYZS(I)
 101  STPX(I)=1./GTXYZS(I)
      IXL1= IX(1)
      IYL1= IX(2)
      IZL = IX(3)
      XG(3)=XGS(3)
      DO 333 JZ = NUMSS1(3), NUMS(3)
      IYL = IYL1
      XG(2)= XGS(2)
      DO 222 JY = NUMSS1(2), NUMS(2)
      IXL = IXL1
      XG(1)= XGS(1)
      DO 111 JX = NUMSS1(1), NUMS(1)
      IADR = NUSXY * IZL + NUMS(1) * IYL + IXL - NUMSC
      IJX = ITAB(IADR)
      FUNF1 = FLOAT( IJX ) / 99.
         IF (FIRST1) THEN
            FUNF=SSMINF(X,NSY1,.FALSE.,NSMIN)
            KG=1
            CALL HAVWGT(NSY1,XG,KG,FUNF,WFUNF)
            IF (WFUNF .GT. SYMAX-.1) RETURN
            FIRST1=.FALSE.
            ENDIF
         KG=0
         CALL HAVWGT(NSY1,XG,KG,FUNF,WFUNF)
         IFUNF = NINT(WFUNF * 100.)
         IF (IFUNF .LT. 0) IFUNF = 0
         IF (WFUNF .LT. FUNF1) THEN
            ITAB(IADR) = IFUNF
            IF (SYMXNW.LT.WFUNF) SYMXNW = WFUNF
            ENDIF
      IXL = IXL + 1
      XG(1) = XG(1)+STPX(1)
 111  CONTINUE
      IYL = IYL + 1
      XG(2) = XG(2)+STPX(2)
 222  CONTINUE
      IZL = IZL + 1
      XG(3) = XG(3)+STPX(3)
 333  CONTINUE
      RETURN
      END
      SUBROUTINE HAVWGT (NSY1, X, KG, FUNF, WFUNF)
      DIMENSION  X(3)
      INCLUDE 'Zcrys.inc'
      COMMON /SELFWT/ IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION XQ1(3,5), XQL(3), XDUMMY(3)
      LOGICAL FIRST
      DATA    FIRST,ITS,NLT,DMAX /.TRUE.,1,0, 0.3/
      WGTV = SWGT(NSY1)
      WFUNF=FUNF
      IF (WGTV.LT.1.1) RETURN
      IF (KG.EQ.1)  GOTO 300
      N1=1
      CALL KERNAB(X,XQ1(1,1),3)
      NDH=NINT(WGTV)
      DO 120 N = 1,NDH-1
      NSS=NSDH(N,NSY1)
      INVERT=1
      IF (NSS.LT.0) INVERT=-1
      NSS=IABS(NSS)
      N1=N1+1
      CALL SYMEQU(NSS,ITS,NLT,INVERT,FIRST,X,XQ1(1,N1),XDUMMY)
      DO 120 NT=1,NLATT
      CALL VPLUSV (XQ1(1,N1),TLATT(1,NT),XQL,3)
      DO 110 N2=1,N1-1
      IF (ISELFD(XQ1(1,N2),XQL,DMAX).EQ.1) THEN
          WGTV=WGTV-1.
          IF (WGTV .LT. 1.1) RETURN
          N1=N1-1
          GOTO 210
      ENDIF
 110  CONTINUE
 120  CONTINUE
 210  CONTINUE
 300  WGTV = (WGTV-1.)*0.5 + 1.
      WFUNF=(WFUNF-PATAD)/WGTV + PATAD
      RETURN
      END
      SUBROUTINE DELPKO (XP, NP, NXYZ)
      DIMENSION XP(5,NP), NXYZ(3)
      INCLUDE 'Zcrys.inc'
      COMMON /ORIGNS/ NOR, ORIG(3,8), IDDPOL, RVPOL(3)
      LOGICAL ENANTI
      DATA  ENANTI /.TRUE./
      DMAX=SQRT( (CELL(1)/NXYZ(1))**2 +
     *      (CELL(2)/NXYZ(2))**2 +
     *      (CELL(3)/NXYZ(3))**2 )
      CALL DELXEQ (XP, NP, NOR, .FALSE., ENANTI, DMAX)
      RETURN
      END
      SUBROUTINE WRCROS (N,NMULN, N2,NMULN2, XNO,NX, P1X2, NMAXP2, NPKS)
      DIMENSION XNO(5,20),P1X2(NMAXP2)
      DO 2200 J = 0, NMULN-1
      M = N + J
      DO 1100 K = 0, NMULN2-1
      M2= N2+ K
      IF (K.EQ.J) THEN
          PXX2 = XNO(4,1)
      ELSE IF (K.GT.0 .AND. J.GT.0) THEN
         PXX2 = XNO(4,2)
      ELSEIF (K.EQ.0) THEN
         IF (J.LT.NX) THEN
            PXX2 = XNO(4,J+1)
         ELSE
            PXX2 = 0.0
         ENDIF
      ELSE IF (J.EQ.0) THEN
          IF (K.LT.NX) THEN
            PXX2 = XNO(4,K+1)
          ELSE
            PXX2 = 0.0
          ENDIF
      ENDIF
      CALL AR2SYM( PXX2,M,M2, NPKS, P1X2, NMAXP2)
 1100 CONTINUE
 2200 CONTINUE
      RETURN
      END
      SUBROUTINE CONSPN(XP,NPKS,MULORD,ICANPK, PISET,NSTS)
      PARAMETER (MXHEAV=20,MXSTSP=140, MXHEV2=MXHEAV+3)
      DIMENSION XP(5, NPKS),MULORD(NPKS), ICANPK(NPKS),
     *          PISET(MXHEV2,MXSTSP)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      PARAMETER (MXPKS=150, NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      DIMENSION QPSET(MXHEV2), INP2S(MXSTSP), CVEC(3), VEC23(3)
      LOGICAL  COOK, FSTCOM
      PARAMETER (PMAX = 30254.)
      DATA  QPSET, DMAX  /MXHEV2*0.0, 0.35  /
      IF (NCONS1.EQ.NCONS) THEN
         QPSET(MXHEAV)=-1.0
      ELSE
         QPSET(MXHEAV)= 1.0
      ENDIF
      IF (MINBRK.LE.0 .OR. MINBRK.GT.NCONS) MINBRK=1
      QPSET(MXHEV2)=MINBRK-1
      NDIM1 = MXHEV2
      NATM= MXHEAV + 1
      ISQ = MXHEAV + 2
      NH = NCONS
      IF (NET .LT. NH) GOTO 2000
      NEP = NH
      NLVP1 =NSET(2)
      IBRK=1
      IEL(1)=0
      FSTCOM=.TRUE.
 1111 CONTINUE
      CALL UPSETX
      IF (.NOT.FSTCOM .AND. IBRK.LT.MINBRK) GOTO 2000
      FSTCOM=.FALSE.
      IF (P1METH .AND. IBRK.EQ.2) THEN
            N2=NLVP1
            DO 250 M1=2,NPCT
            IF (ICANPK(M1).GT.LTHV) GOTO 250
            DO 240 M2=M1+1,NPCT
            IF (ICANPK(M2).GT.LTHV) GOTO 240
            NCR=IPOIN1(M1,M2,NPCT)
            IF (P1X2(NCR).GT.0.0) THEN
              CALL VMINV(XP(1,M1),XP(1,M2),CVEC,3)
              ISLF=ISELFD(CVEC,XP(1,N2),DMAX)
              IF(ISLF.EQ.1)  P1X2(NCR)=-P1X2(NCR)
            ENDIF
 240        CONTINUE
 250        CONTINUE
         LVI2 = XP(5, NLVP1)
         NVI2 = XP(5, NPSET(2))
         NLVP1=NPSET(2)
         IF (LVI2.EQ.NVI2) GOTO 1111
      ENDIF
      CALL CHCKCO (ICANPK,NPKS,MULORD,XP,PSETVL,ATMSVL, COOK)
      IF (COOK) THEN
        CALL KERI2F (NPSET,QPSET,NH)
        QPSET(NH+1)= 0.0
        QPSET(NATM)= ATMSVL
        QPSET(ISQ) = PSETVL+ AMIN1(ATMSVL,HEAVYN)*(PMAX-PLIM)
        CALL EL2AR2 (QPSET, NDIM1, ISQ, PISET,MXSTSP, NSTS, INP2S)
      ENDIF
      IF (P1METH .AND. IBRK.EQ.3) THEN
          N2=NPSET(2)
          N3=NPSET(3)
          CALL VMINV(XP(1,N2),XP(1,N3), VEC23, 3)
            DO 320 NT=1,NET
            NP=NSET(NT)
            IF (NP.LT.0) GOTO 320
            IF (ISELFD(VEC23, XP(1,NP), DMAX).EQ.1) NSET(NT)=NP-ICD
 320        CONTINUE
      ENDIF
      GOTO 1111
 2000 CONTINUE
      DO 350 N=1,NET
      DO 340 ID=1,NEP
      IF (NSET(N).GT.0) GOTO 350
      NSET(N)=NSET(N)+ICD
 340  CONTINUE
 350  CONTINUE
      IF(NSTS.GT.1) CALL SORTIN(INP2S,MXSTSP,NSTS, PISET,NDIM1,NSTS)
      IF (P1METH) THEN
            DO 410 M1=2,NPCT
            DO 410 M2=M1+1,NPCT
            NCR=IPOIN1(M1,M2,NPCT)
            IF (P1X2(NCR).LT.0.0) P1X2(NCR)=-P1X2(NCR)
 410        CONTINUE
      ENDIF
      RETURN
      END
      FUNCTION TCOMBS(K,N)
      PARAMETER  (TCOMMX=1.0E+30)
      TCOMBS=1.0
      IF (K.GE.N)  THEN
         IF (K.GT.N) TCOMBS=0.0
         RETURN
      ELSE
         FK=K
         FN=N
         TCOMOF=TCOMMX/(FN-FK)
         DO 110 I=1,K
         TCOMBS=TCOMBS*(FN/FK)
         IF (TCOMBS.GT.TCOMOF)  GOTO  210
         FN=FN-1.
         FK=FK-1.
 110     CONTINUE
         RETURN
      ENDIF
 210  TCOMBS=-TCOMMX
      RETURN
      END
      FUNCTION COMBNO(IEL,K,N)
      DIMENSION       IEL(K)
      PARAMETER  (TCOMMX=1.0E+30)
      IF (K.EQ.1) THEN
         COMBNO=IEL(1)
         RETURN
      ENDIF
      J1=1
      N1=0
      COMBNO=0.0
      DO 210 I=1,K-1
      K1=K-I
      IF (J1.LT.IEL(I)) THEN
        N1=N-J1
        TCO=TCOMBS(K1,N1)
        IF (TCO.LT.0.0 .OR. TCO.GT.TCOMMX-COMBNO) THEN
          COMBNO = -TCOMMX
          RETURN
        ENDIF
        COMBNO = COMBNO + TCO
        J1=J1+1
        FN1K1=N1-K1
        FN1=N1
 111    IF (J1.LT.IEL(I)) THEN
          TCO=TCO*FN1K1/FN1
          IF (TCO.GT.TCOMMX-COMBNO) THEN
            COMBNO = -TCOMMX
            RETURN
          ENDIF
          COMBNO = COMBNO + TCO
          FN1K1=FN1K1-1.
          FN1=FN1-1.
          J1=J1+1
          GOTO 111
        ENDIF
      ENDIF
      J1=IEL(I)+1
 210  CONTINUE
      COMBNO=COMBNO+IEL(K)-IEL(K-1)
      RETURN
      END
      SUBROUTINE CHCKCO(ICANPK,NPKS,MULORD,XP,PSETVL,ATMSVL, COOK)
      DIMENSION  ICANPK(NPKS), MULORD(NPKS), XP(5, NPKS)
      LOGICAL COOK
      PARAMETER  (MXPKS=150, MXHEAV=20)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      DIMENSION  ATMSV(MXHEAV), PSETV(MXHEAV)
      COOK=.FALSE.
      IBRK1= MULSET (NPSET, NEP, MULORD, NPKS)
      LT=LTHV
      IF (IBRK1.LE.1) RETURN
      IBRK2= NRATY(LT,NCONST,LTHV, NPSET,IBRK1-1, ICANPK,NPKS)
      IF (IBRK2.EQ.IBRK) RETURN
      HEVYN1 = HEAVYN+0.01
      IBRK3=IBRK2
      DO 130 I = IBRK, IBRK2-1
      II=NPSET(I)
      IF (I.EQ.1) THEN
         ATMSV(1) = AMIN1(XP(5,II),1.0)
         PSETV(1) = XP(4,II)
      ELSE
         ATMSV(I) = ATMSV(I-1) + AMIN1( XP(5,II), 1.0)
         PSETV(I) = AMIN1 (PSETV(I-1), XP(4,II))
      ENDIF
      IF (ATMSV(I).GT.HEVYN1) THEN
        IBRK3=I
        GOTO 200
      ENDIF
      DO 120  J = 1, I-1
      JJ=NPSET(J)
      IJ = IPOIN1(JJ,II, NPCT)
      IF (P1X2(IJ) .LT. PLIM) THEN
        IBRK3=I
        GOTO 200
      ENDIF
      IF (PSETV(I).GT.P1X2(IJ)) PSETV(I) = P1X2(IJ)
 120  CONTINUE
 130  CONTINUE
      IF (IBRK2-1 .EQ. NEP) THEN
        PSETVL=PSETV(NEP)
        ATMSVL=ATMSV(NEP)
      ENDIF
 200  IF (IBRK3 .EQ. IBRK) RETURN
      NP2=IBRK3-1
      CALL TSTPKS(NP2,ICANPK,NPKS, COOK)
      RETURN
      END
      SUBROUTINE SELCPK(XP2,NPKS, ICANPK)
      PARAMETER (MXPKS = 150)
      DIMENSION  XP2(5, MXPKS), ICANPK(MXPKS)
      INCLUDE 'Zcrys.inc'
      PARAMETER                 (NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION  ICCPK(MXPKS)
      CALL KERNZI(0,ICANPK,NPKS)
      DO 330 N=1,NPKS
      DO 320 IT=1,LTHV
      IF (ICANPK(N).LE.IT .AND. XP2(4,N).GT.PLIMS(IT)) THEN
         ICANPK(N)=IT
         GOTO 330
      ENDIF
 320  CONTINUE
      ICANPK(N)=LTHV+1
 330  CONTINUE
      NCYCLE = 0
      DO 350 N=1,NPKS
      IT1=ICANPK(N)
      DO 340 IT=IT1,LTHV
      CALL ATYPKS(N,IT,NPKS,ICANPK,NCYCLE,ICCPK,NHT)
      IF (IT.EQ.NHT) THEN
         ICANPK(N)=IT
         GOTO 350
      ENDIF
 340  CONTINUE
      ICANPK(N)=LTHV+1
 350  CONTINUE
      RETURN
      END
      SUBROUTINE TSTPKS(NP2, ICANPK,NPKS, COOK)
      DIMENSION             ICANPK(NPKS)
      LOGICAL                            COOK
      INCLUDE 'Zsyst.inc'
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      PARAMETER  (MXPKS=150, MXHEAV=20)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      DIMENSION ICCPK(MXPKS), ICAPKL(MXPKS,MXHEAV)
      LOGICAL  OKF
      NCYCLE=1
      IF (IBRK.EQ.1) THEN
        NI1=1
        CALL KERNZI(LTHV+1,ICAPKL(1,1),NPKS)
        DO 102 NR=1,NET
        NO=NSET(NR)
        ICAPKL(NO,1)=ICANPK(NO)
 102    CONTINUE
      ELSE
        NI1=IEL(IBRK-1)+1
      ENDIF
      COOK=.FALSE.
      NP1=IBRK
      DO 210 NN=NP1,NP2
      N=NPSET(NN)
      NI=IEL(NN)
      DO 104 MI=NI1,NI-1
      M=NSET(MI)
 104  IF (M.GT.0) ICAPKL(M,NN)=LTHV+1
      OKF=.FALSE.
      NHT=LTHV+1
      LTN=LTHV
      IF (P1METH .AND. NN.EQ.1) THEN
       LTN=1
      ELSE IF (NN.LE.NCONS1 .AND. LT1.LT.LTHV) THEN
       LTN=LT1
      ENDIF
      DO 150 I = LTN, ICAPKL(N,NN), -1
      IF (I .GT. NHT) GOTO 150
      CALL ATYPKS(N,I,NPKS,ICAPKL(1,NN),NCYCLE,ICCPK,NHT)
      IF (NHT.EQ.0) GOTO 160
      IF (I.GT.NHT) GOTO 150
      IF (NRATY(NHT,NCONST,LTHV,NPSET,NN,ICCPK,NPKS).LE.NN)  GOTO 150
      IF (I .GT. NHT)  GOTO 150
      IF (NN.EQ.NEP) THEN
         COOK=.TRUE.
         RETURN
      ENDIF
      IF (OKF) THEN
        ICAPKL(N,NN+1)=I
      ELSE
        OKF=.TRUE.
        ICAPKL(N,NN+1)=I
        DO 110 M=1,NPKS
 110    IF (M.NE.N) ICAPKL(M,NN+1)=ICCPK(M)
        DO 120 NR=1,NET
        NO=NSET(NR)
        IF (NO.GT.0) THEN
          IF (ICAPKL(NO,NN+1) .LE. LTHV)  GOTO 120
        ENDIF
        NSET(NR)=NO-ICD
 120    CONTINUE
        IBRK=NN+1
      ENDIF
 150  CONTINUE
 160  IF (.NOT.OKF) RETURN
      NI1=NI+1
 210  CONTINUE
      IBRK=NP2+1
      RETURN
      END
      SUBROUTINE ATYPKS(N,I,NPKS,ICANPK,NCYCLE,ICCPK,NHT)
      DIMENSION                  ICANPK(NPKS),ICCPK(NPKS)
      PARAMETER      (MXPKS = 150)
      DIMENSION ICCDY(MXPKS)
      LOGICAL   CHCTYP
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      CALL TSTATY(N,I,NPKS,ICANPK, ICCPK,NHT)
      IF (NHT.NE.I  .OR. NCONS.LT.3 .OR. NCYCLE.EQ.0)  RETURN
      DO 310 NCY=1,NCYCLE
      CHCTYP = .FALSE.
      DO 210 M=1,NPKS
      IF (M.EQ.N .OR. ICCPK(M).GT.LTHV) GOTO 210
      J1=ICCPK(M)
      MHT=LTHV+1
      MJ=MHT
      DO 110 J=LTHV,J1,-1
      IF (J .GT. MHT)  GOTO 110
      CALL TSTATY(M,J,NPKS,ICCPK,ICCDY, MHT)
      IF (J.EQ.MHT) MJ=J
      IF (MHT.EQ.0) THEN
        IF (ICCPK(M) .LT. MJ) THEN
          CHCTYP=.TRUE.
          ICCPK(M)=MJ
        ENDIF
        GOTO 210
      ENDIF
 110  CONTINUE
 210  CONTINUE
      IF (CHCTYP) THEN
          NHT = NATYOK (N,I, ICCPK,NPKS, NCONST,LTHV)
          IF (NHT.EQ.0) RETURN
      ELSE
          RETURN
      ENDIF
 310  CONTINUE
      RETURN
      END
      SUBROUTINE TSTATY (N,I,NP, ICANPK, ICCPK, NHT)
      DIMENSION              ICANPK(NP), ICCPK(NP)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      PARAMETER      (MXPKS=150, NMAXP2 = (MXPKS*MXPKS+MXPKS)/2 )
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      CALL KERNAI (ICANPK,ICCPK,NP)
      DO 210 M=1,NP
      IF (M.EQ.N .OR. ICCPK(M).GT.LTHV) GOTO 210
      NM = IPOIN1(N,M,NPCT)
      DO 110 J=1,LTHV
      IF (P1X2(NM).GT.PLIMC(I,J)) THEN
         IF (ICCPK(M).LT.J) ICCPK(M)=J
         GOTO 210
      ENDIF
 110  CONTINUE
      ICCPK(M)=LTHV+1
 210  CONTINUE
      NHT = NATYOK (N,I, ICCPK,NP, NCONST,LTHV)
      RETURN
      END
      FUNCTION NATYOK (N,I, ICANPK,NP, NCONST,LT)
      DIMENSION  NCONST(LT), ICANPK(NP), NPTY(11), NCTY(11)
      CALL KERNZI (0, NPTY, 11)
      DO 110 M = 1,NP
      IF (M.NE.N) NPTY(ICANPK(M))=NPTY(ICANPK(M)) + 1
 110  CONTINUE
      DO 420 II=I,ICANPK(N),-1
      CALL KERNAI(NPTY,NCTY,11)
      NCTY(II)=NCTY(II)+1
      DO 410 J=1,LT
      IF (NCTY(J).LT.NCONST(J)) GOTO 420
      IF (J.LT.LT) THEN
         NCTY(J+1)=NCTY(J+1) + (NCTY(J)-NCONST(J))
         NCTY(J)=NCONST(J)
      ENDIF
 410  CONTINUE
      NATYOK = II
      RETURN
 420  CONTINUE
      NATYOK = 0
      RETURN
      END
      FUNCTION NRATY (J,NCONST,LT, IPKSET,NPS, ICANPK,NP)
      DIMENSION  NCONST(LT), IPKSET(NPS), ICANPK(NP), NPTY(11)
      CALL KERNZI (0, NPTY, 11)
      DO 210 M = 1,NPS-1
      N=IPKSET(M)
      I=ICANPK(N)
 111  CONTINUE
      IF (NPTY(I).LT.NCONST(I)) THEN
          NPTY(I)=NPTY(I) + 1
      ELSE
          I=I+1
          IF (I.LE.LT) GOTO 111
          NPTY(I-1)=NPTY(I-1)+1
          NRATY=M
          RETURN
      ENDIF
 210  CONTINUE
      N=IPKSET(NPS)
      J1=J
      DO 310 I = J1, ICANPK(N), -1
      IF (NPTY(I).LT.NCONST(I)) THEN
          J=I
          NRATY=NPS+1
          RETURN
      ENDIF
 310  CONTINUE
      NRATY=NPS
      RETURN
      END
      SUBROUTINE UPSETX
      PARAMETER  (MXPKS=150, MXHEAV=20)
      COMMON /CONCOM/ NSET(MXPKS), NET, NEP, IEL(MXHEAV), NPSET(MXHEAV),
     *                IBRK, ICD, MINBRK
      IF (IEL(1) .EQ. 0) THEN
         DO 101 I = 1,NEP
         NPSET(I)=NSET(I)
 101     IEL(I) = I
         IBRK=1
         ICD=0
         DO 102 I = 1,NET
 102     IF (ICD.LT.NSET(I))  ICD=NSET(I)
         ICD=ICD+1
         RETURN
      ENDIF
      IBRKI = IBRK
      DO 500 I = IBRKI,1,-1
      IF (IEL(I) .NE. NET-NEP+I) THEN
        IF (I.LT.IBRK) THEN
          DO 220 N=1,NET
          DO 210 ID=1,IBRK-I
          IF (NSET(N).GT.0) GOTO 220
          NSET(N)=NSET(N)+ICD
 210      CONTINUE
 220      CONTINUE
          IBRK=I
        ENDIF
        NR = IEL(I)
        DO 320 J=I-1, NEP-1
 310    NR = NR + 1
        IF (NR .LE. NET-NEP+J+1) THEN
           IF (NSET(NR).LT.0) GOTO 310
           IEL(J+1)=NR
        ELSE
           GOTO 500
        ENDIF
 320    CONTINUE
         DO 410 J=I,NEP
 410     NPSET(J)=NSET(IEL(J))
         RETURN
      ENDIF
 500  CONTINUE
      IEL(1)=0
      IBRK=0
      RETURN
      END
      FUNCTION MXESUM (X, NX, SUMMX)
      DIMENSION X(5,NX)
      PARAMETER (MXE=100)
      DIMENSION E(MXE)
      SUM = 0.0
      MXESUM=0
      JMAX=1
      DO 510 N = 1,NX
      IF (MXESUM.LT.MXE) THEN
         MXESUM = MXESUM+1
      ELSE
         MXESUM=-MXESUM
         RETURN
         ENDIF
      E(MXESUM) = X(5,N)
      IF (SUM+E(MXESUM).LT.SUMMX+0.0001) THEN
            SUM=SUM+E(MXESUM)
            IF (E(MXESUM).GT.E(JMAX)) JMAX=MXESUM
      ELSE
         IF (E(MXESUM).LT.E(JMAX)) THEN
            SUM=SUM-E(JMAX)
            SUM=SUM+E(MXESUM)
            E(JMAX)=E(MXESUM)
            DO 110 J=1,MXESUM-1
            IF (E(J).GT.E(JMAX)) JMAX=J
 110        CONTINUE
         ENDIF
         MXESUM=MXESUM-1
      ENDIF
 510  CONTINUE
      RETURN
      END
      FUNCTION MULSET (NPSET, NP, NMUL, N)
      DIMENSION NPSET(NP), NMUL(N)
      M=0
      DO 1000 NN = 1, NP
      NPSTNN = NPSET(NN)
      IF (NMUL(NPSTNN) .GT. 0) THEN
            M = NN
            GOTO 1000
      ELSE IF (M.NE.0) THEN
           IF (NPSTNN-NN+M .EQ. NPSET(M)) GOTO 1000
      ENDIF
            MM= NN
            GOTO 1100
 1000 CONTINUE
      MM = NP + 1
 1100 MULSET = MM
      RETURN
      END
      FUNCTION SMINF (X, XS, NEQP,NXS, NXSEQX)
      DIMENSION X(3), XS(3,NEQP,NXS)
      DIMENSION VECS(3,48)
      DATA  NV, VALMAX /48, 30254./
      SMINF=VALMAX
      DO 120 NX = 1,NXS
      IF (NX .EQ. NXSEQX) GOTO 120
      CALL VECXXS( X, XS(1,1,NX), NEQP, VECS, NV, NVECS)
      DO 110 N = 1, NVECS
      CALL GRDOUT(VECS(1,N), FUNF)
      IF (SMINF .GT. FUNF) SMINF = FUNF
 110  CONTINUE
 120  CONTINUE
      RETURN
      END
      FUNCTION SSMINF (X, NREQP, WGTING, NEMIN)
      DIMENSION X(3)
      LOGICAL   WGTING
      INCLUDE 'Zcrys.inc'
      COMMON /SELFWT/ IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      DIMENSION VXYZ(3)
      DIMENSION VXYZT(3)
      DATA  VALMAX /30254./
      SSMINF=VALMAX
      NEMIN=0
      KG=0
      IF (NREQP .GT. 1) THEN
          NE1= NREQP
          NEQP=NREQP
      ELSE
         NE1= 2
         NEQP = NSSY
         ENDIF
      DO 500 NE = NE1, NEQP
      CALL HARVEC (IRSY1(1,1,NE), TSY1(1,NE), X, VXYZ)
      CALL REDFCO (VXYZ, VXYZ, 3)
      DO 125 NL=1,NLATT
      VXYZT(1)=VXYZ(1)+TLATT(1,NL)
      VXYZT(2)=VXYZ(2)+TLATT(2,NL)
      VXYZT(3)=VXYZ(3)+TLATT(3,NL)
      CALL REDFCO (VXYZT, VXYZT, 3)
      DO 120 I=1,3
      IF (ABS(VXYZT(I)) .GT. 1.5*FSTPSY(I)) GOTO 125
 120  CONTINUE
      FUNF = VALMAX
      GOTO 130
 125  CONTINUE
      CALL GRDOUT (VXYZ, FUNF)
      IF (WGTING) THEN
         CALL HAVWGT (NE,X,KG,FUNF,WFUNF)
         FUNF=WFUNF
      ENDIF
 130  IF (SSMINF.GT.FUNF) THEN
          SSMINF=FUNF
          NEMIN=NE
      ENDIF
 500  CONTINUE
      RETURN
      END
      FUNCTION OCMINF (X,XS,NEQP, NXS, NXSEQX, ENANTI, PLIMM, XOUT,NOUT)
      DIMENSION X(3), XS(3,NEQP,NXS), XOUT(5,NOUT)
      LOGICAL ENANTI
      INCLUDE 'Zcrys.inc'
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      COMMON /ORIGNS/ NOR, ORIG(3,8), IDDPOL, RVPOL(3)
      PARAMETER (MXHEAV=20)
      DIMENSION XO(3), XL(3), XOU(5), INXOUT(MXHEAV)
      LOGICAL ONEXT, OSTART, PEAK
      DATA NADDED /0/
      CALL KERNAB (X,XL,3)
      PLIM1=PLIMM-0.1
      OCMINF = 0.0
      IF (NOUT .GT. 1) THEN
         NADDED = 0
         IF (NOUT .GT. MXHEAV) NOUT = MXHEAV
         ENDIF
      ONEXT = .TRUE.
      IF (ENANTI .AND. ICENT.EQ.1) THEN
         NEN = -1
      ELSE
         NEN = 1
         ENDIF
      DO 310 NE = 1,NEN,-2
      DO 210 NO = 1,NOR
      OSTART=.TRUE.
 110  CALL ORSHIX( XL, ORIG(1,NO), XO, ONEXT)
      SMINX = SMINF (XO, XS, NEQP, NXS, NXSEQX)
      IF (OCMINF .LT. SMINX) THEN
         OCMINF = SMINX
         IF (NOUT.EQ.1) THEN
            CALL KERNAB(XO,XOU,3)
            XOU(4)= OCMINF
            IF (ICENT.EQ.2) XOU(4)= (OCMINF-PATAD)/2.00+PATAD
            XOU(5) = NE
            ENDIF
         ENDIF
      IF (NOUT .GT. 1) THEN
         CALL PKS1DF (XO, SMINX, PLIM1, OSTART, ONEXT, XOU,FUNXOU, PEAK)
         IF (PEAK) THEN
            XOU(4) = FUNXOU
            IF (ICENT.EQ.2) XOU(4)= (FUNXOU-PATAD)/2.00 +PATAD
            XOU(5) = NE
            CALL EL2AR2 (XOU,5,4, XOUT,NOUT, NADDED, INXOUT)
            ENDIF
         ENDIF
      IF (.NOT. ONEXT) GOTO 110
 210  CONTINUE
      IF (NEN.EQ.-1) CALL INVAB (X,XL,3)
 310  CONTINUE
      IF (ICENT.EQ.2) OCMINF = (OCMINF-PATAD)/2.00 + PATAD
      IF (NOUT.EQ.1) THEN
         IF (OCMINF .GT. PLIMM) THEN
            CALL KERNAB(XOU, XOUT(1,1), 5)
         ELSE
            NOUT = 0
         ENDIF
      ENDIF
      IF (NOUT.GT.1) THEN
         NOUT = NADDED
         IF (NADDED.GT.1)
     *      CALL SORTIN(INXOUT,MXHEAV,NADDED, XOUT,5,NOUT)
         ENDIF
      RETURN
      END
      SUBROUTINE PKS1DF (X3, FUNX3, FLIM, START, STOP, XPK,FUNPK, PEAK)
      DIMENSION X3(3) , XPK(5)
      LOGICAL START, STOP, PEAK
      DIMENSION X1(3), X2(3), X4(3)
      LOGICAL SECPNT
      PARAMETER (PMAX=30254., FUNMAX=PMAX)
      DATA  FUNX1,FUNX2,FUNX4,FUNX5, SECPNT /0.,0.,0.,0.,.FALSE./
      IF (START .AND. STOP) THEN
         START = .FALSE.
         PEAK = FUNX3.GT.FLIM
         IF (PEAK) THEN
            CALL KERNAB (X3,XPK,3)
            FUNPK=FUNX3
         ENDIF
         RETURN
      ENDIF
      IF (START) THEN
         START = .FALSE.
         SECPNT= .TRUE.
         PEAK = .FALSE.
         FUNX1 = FUNMAX
         CALL KERNAB (X3,X4,3)
         FUNX4 = FUNX3
         CALL KERNAB (X3,X2 ,3)
         FUNX2 = FUNX3
         RETURN
      ENDIF
      PEAK = FUNX2.GT.FLIM .AND. FUNX2.GT.FUNX1 .AND. FUNX2.GE.FUNX3
      IF (PEAK) THEN
          CALL KERNAB (X2,XPK,3)
          FUNPK=FUNX2
          IF (STOP) RETURN
      ENDIF
      IF (STOP) THEN
         PEAK = FUNX3.GT.FLIM .AND. FUNX3.GT.FUNX2 .AND. FUNX3.GE.FUNX4
         IF (PEAK) THEN
            CALL KERNAB (X3,XPK,3)
            FUNPK=FUNX3
            RETURN
         ENDIF
         PEAK = FUNX4.GT.FLIM .AND. FUNX4.GT.FUNX3 .AND. FUNX4.GE.FUNX5
         IF (PEAK) THEN
            CALL KERNAB (X4,XPK,3)
            FUNPK=FUNX4
         ENDIF
         RETURN
      ENDIF
      IF (SECPNT) THEN
          FUNX5 = FUNX3
          SECPNT =.FALSE.
      ENDIF
      CALL KERNAB (X2,X1 ,3)
      FUNX1 = FUNX2
      CALL KERNAB (X3,X2 ,3)
      FUNX2 = FUNX3
      RETURN
      END
      SUBROUTINE ORSHIX (X, ORIG, XO, ONEXT)
      DIMENSION X(3), ORIG(3), XO(3)
      LOGICAL ONEXT
      INCLUDE 'Zcrys.inc'
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3), VDUMMY
      DIMENSION ORSH(3), FRSTEP(3), NGPXYZ(3)
      LOGICAL FIRST, STARTS
      DATA  FIRST /.TRUE./
      DATA NGPXYZ / 1,1,1 /
      DATA NGP / 0 /
      IF (FIRST) THEN
            FIRST = .FALSE.
            ONEXT = .TRUE.
        IF (IPOLA.NE.0) THEN
            DO 101 I=1,3
 101        FRSTEP(I)= 1./GTXYZ(I)
          IF(MOD(IPOLA,2) .EQ.1 ) NGPXYZ(1)=NXYZ(1)
          IF(IPOLA.EQ.3 .OR. IPOLA.EQ.2 .OR. IPOLA.EQ.6 .OR. IPOLA.EQ.7)
     *      NGPXYZ(2)=NXYZ(2)
          IF(IPOLA.GE.4 .AND. IPOLA.LE.7) NGPXYZ(3)=NXYZ(3)
          IF(IPOLA.EQ.8) THEN
            FRSTEP(2)=FRSTEP(1)
            FRSTEP(3)=FRSTEP(1)
            NGPXYZ(1)=NXYZ(1)
            NGPXYZ(2)=NXYZ(1)
            NGPXYZ(3)=NXYZ(1)
          ENDIF
        ENDIF
      ENDIF
      IF (IPOLA.EQ.0) THEN
            CALL KERNAB (ORIG, ORSH, 3)
      ELSE IF (IPOLA.NE.8) THEN
            STARTS = ONEXT
            IF (STARTS) NGP = 0
            CALL SCAN3D (ORIG, ORSH, FRSTEP, NGPXYZ, NGP,STARTS)
            ONEXT = STARTS
      ELSE
            IF (ONEXT) THEN
            ONEXT = .FALSE.
            CALL KERNAB (ORIG, ORSH, 3)
            NGP = 0
            ELSE
            CALL VPLUSV (ORSH, FRSTEP, ORSH, 3)
            NGP=NGP + 1
            IF (NGP .EQ. NGPXYZ(1)) THEN
            ONEXT = .TRUE.
            ENDIF
            ENDIF
      ENDIF
      CALL VMINV (X, ORSH, XO, 3)
      RETURN
      END
      SUBROUTINE GRDOUT (ARG, FUNF)
      DIMENSION ARG(3)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ITPL, KEYS(7))
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3), VDUMMY
      DIMENSION IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)), (IYFAR,IFAR(2)), (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)), (RY,RARG(2)), (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)), (FMY,FM(2)), (FMZ,FM(3))
      IF (ITPL.NE.10) THEN
       CALL RDOUTT(ARG, FUNF)
       RETURN
      ENDIF
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
      CALL SYMM (RX, RY, RZ)
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
  555 F=T-FLOAT(I)
      IF (F) 560,590,570
  560 F=F+1.0
  570 IF (F-0.5) 590,580,580
  580 FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
  590 FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
  599 CONTINUE
      CALL LINPOL(INEAR,IFAR,FM,FUNF)
      RETURN
      END
      SUBROUTINE LINPOL(INEAR,IFAR,FM,FUNF)
      DIMENSION INEAR(3),IFAR(3),FM(3)
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3), VDUMMY
      EQUIVALENCE (NX, NUM(1)), (NXY, NUMXY)
      DIMENSION IXB(3),XB(3),FUN(3)
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      K111 = NXY * INEAR(3)+ NX * INEAR(2) + INEAR(1) - NUMC
      IJX = ITAB(K111)
      FUN2 = FLOAT( IJX ) / 99.
      DO 400 I=1,3
      KFAR = K111-INEAR(I)+IFAR(I)
      IJX = ITAB(KFAR)
      FUN3 = FLOAT( IJX ) / 99.
      FUN(I) = FUN2 + (FUN3-FUN2)*FM(I)
      DO 110 J=1,3
 110  IXB(J)=INEAR(J)
      IXB(I)=INEAR(I)-IFAR(I)+INEAR(I)
      IF (IXB(I).LT.IS(I) .OR. IXB(I).GT.LXYZ(I)) THEN
          DO 120 J=1,3
           XB(J)=IXB(J)/GTXYZ(J)
           XB(J) = AMOD(XB(J),1.0)
           IF (XB(J) .GE. 0.5) XB(J) = XB(J) - 1.0
 120       IF (XB(J) .LT. -.5) XB(J) = XB(J) + 1.0
          CALL SYMM(XB(1),XB(2),XB(3))
          DO 130 J=1,3
           XB(J)=XB(J)*GTXYZ(J)
           IXB(J)=NINT(XB(J))
           IF (ABS(IXB(J)-XB(J)).GT.0.1) THEN
            GOTO 400
          ENDIF
 130     CONTINUE
      ENDIF
      KBEG = NXY*IXB(3)+NX*IXB(2)+IXB(1)-NUMC
      IJX = ITAB(KBEG)
      FUN1 = FLOAT( IJX ) / 99.
      FUN(I)=
     * FUN2+((FUN3-FUN1)*FM(I))/2.-((2.*FUN2-FUN3-FUN1)*FM(I)*FM(I))/2.
 400  CONTINUE
      FUNF = FUN(1) + FUN(2)-FUN2 + FUN(3)-FUN2
      RETURN
      END
      SUBROUTINE SCAN3D (X1, X, STEPX, NGPXYZ, NRGRIP, START)
      LOGICAL START
      DIMENSION X1(3),X(3),STEPX(3),NGPXYZ(3)
      DIMENSION XMAX(3)
      DATA LGRIP / 0 /
      IF (START) THEN
          CALL KERNAB (X1,X,3)
          DO 110 I=1,3
 110        XMAX(I) = X1(I)+ ( (NGPXYZ(I)-1.5) * STEPX(I) )
          LGRIP = NRGRIP-1 + NGPXYZ(1)*NGPXYZ(2)*NGPXYZ(3)
          START =.FALSE.
          RETURN
      ENDIF
      IF(X(1).LT.XMAX(1)) THEN
            X(1)= X(1)+STEPX(1)
      ELSE
            X(1)=X1(1)
            IF(X(2).LT.XMAX(2)) THEN
            X(2)= X(2)+STEPX(2)
            ELSE
            X(2)=X1(2)
            X(3)= X(3)+STEPX(3)
            ENDIF
      ENDIF
      NRGRIP = NRGRIP + 1
      IF (NRGRIP .EQ. LGRIP) START = .TRUE.
      RETURN
      END
      SUBROUTINE VECXXS (X, XS, NEQP, VECS, NV, NVECS)
      DIMENSION X(3), XS(3,NEQP), VECS(3,NV)
      LOGICAL PATSYM,TLATTI
      DATA  PATSYM,TLATTI /.FALSE.,.FALSE./
      IF(NEQP.EQ.1) THEN
          CALL ALLEQP (XS, VECS, NV, PATSYM,TLATTI, NVECS)
          DO 110 M = 1, NVECS
 110      CALL VMINV(X,VECS(1,M),VECS(1,M),3)
      ELSE
          NVECS = NEQP
          DO 120 M = 1, NVECS
 120      CALL VMINV(X, XS(1,M), VECS(1,M),3)
      ENDIF
      RETURN
      END
      SUBROUTINE HAMAWT
      INCLUDE 'Zcrys.inc'
      COMMON /SELFWT/ IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      DIMENSION IRSYEQ(3,3),TM(3),TSM(3)
      DO 100 I=1,3
      TSY1(I,1) = 0.
      DO 100 J=1,3
      IRSY1(I,J,1) = 0
 100  CONTINUE
      CALL KERNZA (1., SWGT, 48)
      SWGT(1) = 0.
      CALL KERNZI (0, NSDH, 192)
      INVEND=1-ICENT
      NSY1=0
      DO 300 INV = 1,INVEND,-2
      DO 200 NS=1,NSYMM
      NSY1=NSY1+1
      IF (NSY1 .EQ. 1) GOTO 200
      DO 120 I=1,3
      DO 110 J=1,3
      IRSY1(I,J,NSY1) = -(INV * IRSYMM(I,J,NS))
 110  CONTINUE
      IRSY1(I,I,NSY1) = IRSY1(I,I,NSY1) + 1
      TSY1(I,NSY1) = -INV*TSYMM(I,NS)
 120  CONTINUE
      DO 150 NP=1,NSYMM
      CALL IMAXMA(IRSYMM(1,1,NP),IRSY1(1,1,NSY1), IRSYEQ)
      DO 140 NSY=2,NSY1-1
      INVNP=IMATEQ(IRSYEQ,IRSY1(1,1,NSY),3)
      IF (INVNP.EQ.0) GOTO 140
      DO 130 I=1,3
      TSYEQ= INVNP*(IRSYMM(I,1,NP)*TSY1(1,NSY1)+
     *   IRSYMM(I,2,NP)*TSY1(2,NSY1)+IRSYMM(I,3,NP)*TSY1(3,NSY1))
      TM(I)=TSYEQ-TSY1(I,NSY)
 130  CONTINUE
      DO 135 NT=1,NLATT
      DO 134 I=1,3
      TMLI=TM(I)+TLATT(I,NT)
      TMLI=TMLI-NINT(TMLI)
      IF (ABS(TMLI).GT.0.01) GOTO 135
 134  CONTINUE
      NSY1=NSY1-1
      GOTO 200
 135  CONTINUE
 140  CONTINUE
 150  CONTINUE
      SWGT(NSY1)=1.
      ND=0
      DO 180 NS1=1,NSYMM
      DO 175 INVER1=1,INVEND,-2
      IF (NS1.NE.1 .OR. INVER1.EQ.-1) THEN
      DO 171 INVER2=1,INVEND,-2
      DO 170 NS2=1,NSYMM
      DO 161 I=1,3
      DO 160 J=1,3
      IRSYIJ=INVER1*IRSYMM(I,J,NS1) - INVER2*IRSYMM(I,J,NS2)
      IF (IRSYIJ .NE. IRSY1(I,J,NSY1)) GOTO 170
 160  CONTINUE
      TSM(I)=INVER1*TSYMM(I,NS1)-INVER2*TSYMM(I,NS2) - TSY1(I,NSY1)
 161  CONTINUE
      DO 165 NT=1,NLATT
      DO 164 I=1,3
      TMLI=TSM(I)+TLATT(I,NT)
      TMLI=TMLI-NINT(TMLI)
      IF (ABS(TMLI).GT.0.01) GOTO 165
 164  CONTINUE
      SWGT(NSY1) = SWGT(NSY1) +1.
      ND=ND+1
      NSDH(ND,NSY1)=INVER1*NS1
      IF (ND.EQ.4) GOTO 200
      GOTO 180
 165  CONTINUE
 170  CONTINUE
 171  CONTINUE
      ENDIF
 175  CONTINUE
 180  CONTINUE
      IF (ND.LT.4) NSDH(ND+1,NSY1)=0
 200  CONTINUE
 300  CONTINUE
      NSSY=NSY1
      RETURN
      END
      SUBROUTINE IMAXMA( IA, IB, IAXIB )
      DIMENSION IA(3,3), IB(3,3), IAXIB(3,3)
      DO 200 L = 1,3
      DO 100 K = 1,3
      IAXIB(L,K) = IA(L,1)*IB(1,K) + IA(L,2)*IB(2,K) + IA(L,3)*IB(3,K)
  100 CONTINUE
  200 CONTINUE
      RETURN
      END
      FUNCTION IMATEQ( IA, IB, N)
      DIMENSION IA(N,N), IB(N,N)
      IMATEQ = 0
      INVERT=1
 110  CONTINUE
      DO 200 J = 1, N
      DO 200 I = 1, N
      IF ( IA(I,J) .NE. INVERT*IB(I,J) ) THEN
        IF (INVERT.EQ.-1) RETURN
        INVERT=-1
        GOTO 110
      ENDIF
  200 CONTINUE
      IMATEQ = INVERT
      RETURN
      END
      SUBROUTINE FIXONE(XP,NX, PISET,NSETS, PLIM, X,NSTSX)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION XP(5, NX), PISET(MXHEAV+3,NSETS), PLIM(3),
     *       X(4*MXHEAV+5,MXSTSX)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2)
      PARAMETER (MXVW=6*(MXHEAV+MXHEAV/10))
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      DIMENSION INXEO(MXHEAV), X1(4,MXHEAV)
      CALL KERNZA (0.0, XF, 4*MXHEAV+5)
      IF (NSTSX .GT. MXSTSX) NSTSX=MXSTSX
      IF (NSTSX .LE. 0) FATSMX=0.0
      MINPTS = FATSMX+0.01
      IF (MINPTS.LT.2) MINPTS=2
      DO 510 M=1,NSETS
      N=1
 111  NP = PISET(N,M)+0.1
      IF (NP.NE.0 .AND. N.LE.MXHEAV) THEN
           CALL KERNAB (XP(1,NP), XEO(1,N), 5)
         N=N+1
         GOTO 111
      ELSE
         N=N-1
      ENDIF
      MAXPTS=N
      NPONT1=NINT(PISET(MXHEAV+3,M))
      IF (P1METH) THEN
          NCM=NQSET(PISET(1,M),MAXPTS)
          VASETM=PISET(MXHEAV+2,M)+0.1
          DO 115 M1=M-1,1,-1
          IF (PISET(MXHEAV+2,M1).GT.VASETM) GOTO 116
          IF (NCM .EQ. NQSET(PISET(1,M1),MAXPTS)) GOTO 510
 115      CONTINUE
 116      CALL SYSRCH(XEO,5,MAXPTS, X1, NX1)
          ATMS=0.0
          DO 120 N1=1,NX1
 120      ATMS=ATMS+X1(4,N1)
          IF (NINT(ATMS*NSYMM*ICENT).NE.MAXPTS) THEN
             PISET(MXHEAV,M)=0.0
             GOTO 510
          ENDIF
          NSTSX=NSTSX+1
          DO 121 N1=1,NX1
 121      CALL KERNAB (X1(1,N1), X(N1*4-3,NSTSX), 4)
          X(4*MXHEAV+1,NSTSX)=NX1
          X(4*MXHEAV+2,NSTSX)=ATMS
          X(4*MXHEAV+3,NSTSX)=PISET(MXHEAV+2,M)
          X(4*MXHEAV+5,NSTSX)=M
          IF (NSTSX.EQ.MXSTSX) RETURN
      ELSE
          CALL DETSEQ( INXEO,N, XEO,5,MAXPTS, 5, 0)
          ATMS=0.0
          DO 210 N=1,MAXPTS
          ATMS=ATMS+XEO(5,INXEO(N))
          IF (ATMS.GT.FATSMX-0.01) THEN
            MINPTS=N
            GOTO 220
          ENDIF
 210      CONTINUE
          GOTO 510
 220      NPONTS=MAXPTS
          IF (MINPTS.LT.2) MINPTS=2
          XF(4*MXHEAV+5) = M
          XF(4*MXHEAV+1) = 0.0
          CALL VIMAGE (PLIM, X, NSTSX)
          IF (XF(4*MXHEAV+1).LT.0.1)  PISET(MXHEAV,M)=0.0
      ENDIF
 510  CONTINUE
      IF (P1METH) RETURN
      MXIN=MXSTSX
      IF (NSTSX.GT.0) CALL SORTIN(INX,MXIN,NSTSX, X,4*MXHEAV+5, MXSTSX)
      RETURN
      END
      SUBROUTINE VIMAGE(PLIM, X, NSTSX)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION X(4*MXHEAV+5,MXSTSX), PLIM(3)
      PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2)
      PARAMETER (MXVW=6*(MXHEAV+MXHEAV/10))
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      DIMENSION XN1Q(3,48), XN2OUT(5,20)
      LOGICAL PATSYM, TLATTI, ENANTI
      DATA  PATSYM,TLATTI,ENANTI /.FALSE.,.FALSE.,.TRUE./
      MX2 = MXVC/((NPONTS*NPONTS - NPONTS)/2)
      IF (MX2 .GT. MXHEAV) MX2=MXHEAV
      NVEC=0
      PLIMF=PLIM(3)
      DO 220 N1 = 1, NPONTS-1
         CALL ALLEQP( XEO(1,N1), XN1Q, 48, PATSYM,TLATTI, NEQP)
      DO 210 N2 = N1+1, NPONTS
        IF(NPONT1.EQ.0) GOTO 101
        IF (N2.LE.NPONT1) THEN
           PLIMF=PLIM(1)
        ELSE IF (N1.LE.NPONT1) THEN
           PLIMF=PLIM(2)
        ELSE
           PLIMF=PLIM(3)
        ENDIF
 101     NOUT = MX2
          PXX2 =
     * OCMINF (XEO(1,N2), XN1Q,NEQP, 1, 0, ENANTI,PLIMF, XN2OUT,NOUT)
       DO 110 K2 = 1, NOUT
       NVEC = NVEC + 1
       CALL VMINV (XN2OUT(1,K2), XEO(1,N1), VEC(1,NVEC), 3)
       VEC(4,NVEC) = XN2OUT(4,K2)
         NP1P2(1,NVEC) = N1
       IF (XN2OUT(5,K2) .GT. 0.0) THEN
         NP1P2(2,NVEC) = N2
       ELSE
         NP1P2(2,NVEC) =-N2
       ENDIF
 110   CONTINUE
 210  CONTINUE
 220  CONTINUE
      PLIMF=PLIM(3)
      CALL COIMAG (PLIMF, X, NSTSX)
      RETURN
      END
      SUBROUTINE COIMAG(PLIM, X,NSTSX)
      PARAMETER (MXHEAV=20, MXSTSX=30)
      DIMENSION X(4*MXHEAV+5,MXSTSX)
      PARAMETER (MXVC=(MXHEAV*MXHEAV-MXHEAV)/2)
      PARAMETER (MXVW=6*(MXHEAV+MXHEAV/10))
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      PARAMETER (NXFVAL=4*MXHEAV+3)
      DIMENSION ICOP(MXHEAV)
      LOGICAL RING, BRI, READY
      PARAMETER (PMAX=30254.)
      I=0
      MAXI=NPONTS-1
      NVIEW=0
      NDELP=0
      CALL SELVWP(NVIEW,NDELP, READY)
      IF (READY) RETURN
      CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI)
 211  IF (I.EQ.0) THEN
            NDELP = NVWP
            RETURN
      ENDIF
 311    NVW = ICOP(I)
        IMPNTS(I) = IVWP(NVW)
        J=IABS(IMPNTS(I))
        CALL KERNAB (VECVWP(1,NVW),VECIM(1,I),3)
        PVECVJ = VECVWP(4,NVW)
        PVECJJ = XEO(4,J)
        CALL VECRIN (I, PVECVJ,PVECJJ, VALIM, SUMVIM, RING)
        IF (RING) THEN
          IL=I
          CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI)
          IF (I.GT.IL) GOTO 311
          NP=IL+1
        ELSE
          BRI=.TRUE.
          IL=I
          CALL USET1G (IVP, NPONTS-1, ICOP, I, BRI, MINPTS-1, MAXI)
          IF (I.GE.IL) GOTO 311
          NP=IL
        ENDIF
          IF (NP .EQ. MAXPTS) THEN
            CALL VEC2FP (XEO,MAXPTS,VECIM,NVWP,IMPNTS,NP,XF,ATMS)
            XF(4*MXHEAV+1) = NP
            XF(4*MXHEAV+2) = ATMS
            XF(4*MXHEAV+3) = VALIM + (PMAX-PLIM) * ATMS
            XF(4*MXHEAV+4) = SUMVIM
            DO 510 NX=1,NSTSX
            IX=INX(NX)
            IF (X(NXFVAL,IX).LT. XF(NXFVAL)-0.01) GOTO 520
            IF (X(NXFVAL,IX).GT. XF(NXFVAL)+0.01) GOTO 510
            IF (X(NXFVAL+1,IX) .GT. SUMVIM-0.10 .AND.
     *          X(NXFVAL+1,IX) .LT. SUMVIM+0.10)  GOTO 530
            IF (ABS(X(NXFVAL+1,IX)-SUMVIM).LT. 0.005*SUMVIM) GOTO 530
 510        CONTINUE
 520        CALL EL2AR2 (XF, 4*MXHEAV+5, NXFVAL, X,MXSTSX, NSTSX, INX)
            IF (FATSMX .LT. ATMS) THEN
            FATSMX = ATMS
            IF (MINPTS.LT.ATMS - 0.01) MINPTS=ATMS+0.01
            ENDIF
 530        CONTINUE
          ENDIF
        GOTO 211
      END
      SUBROUTINE VEC2FP (XEO,NXEO,VECIM,NVWP, IMPNTS,NIP,XF,ATMS)
      DIMENSION XEO(5,NXEO), VECIM(3,NIP-1), IMPNTS(NIP-1),
     *      XF(4,NIP)
      NFP = 0
      ATMS = 0.0
      DO 120 NP=1,NXEO
      IF (NP .EQ. NVWP) THEN
          NFP = NFP+1
          CALL KERNAB( XEO(1,NVWP), XF(1,NFP), 3)
          XF(4,NFP)=XEO(5,NVWP)
          ATMS = ATMS + XF(4,NFP)
          GOTO 120
      ENDIF
        DO 110 N = 1,NIP-1
        IF (NP .EQ. IABS(IMPNTS(N)) ) THEN
            NFP = NFP+1
            CALL VPLUSV( XEO(1,NVWP), VECIM(1,N), XF(1,NFP), 3)
            XF(4,NFP)=XEO(5,NP)
            ATMS = ATMS + XF(4,NFP)
            GOTO 120
        ENDIF
 110    CONTINUE
 120  CONTINUE
      RETURN
      END
      SUBROUTINE SELVWP(NVIEW,NDELP, READY)
      LOGICAL READY
      PARAMETER (MXHEAV=20, MXVC=(MXHEAV*MXHEAV-MXHEAV)/2)
      PARAMETER (MXSTSX=30)
      PARAMETER (MXVW=6*(MXHEAV+MXHEAV/10))
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      READY = .FALSE.
      IF (NDELP.GT.0 .AND. NDELP.LE.NPONTS) THEN
         NPONTS=NPONTS-1
         READY = NPONTS .LT. MINPTS
         IF (READY) RETURN
         XEO(5,NDELP)= 0.0
         ATMS=0.0
         DO 101 N=1,MAXPTS
 101     ATMS=ATMS+XEO(5,N)
         READY=ATMS.LT.FATSMX
         IF (READY) RETURN
         N=0
         DO 100 NVE=1,NVEC
         IF (NP1P2(1,NVE).NE.NDELP .AND. IABS(NP1P2(2,NVE)).NE.NDELP)
     *       THEN
           N=N+1
           CALL KERNAB (VEC(1,NVE),VEC(1,N),4)
           NP1P2(1,N)=NP1P2(1,NVE)
           NP1P2(2,N)=NP1P2(2,NVE)
         ENDIF
 100     CONTINUE
         NVEC=N
      ENDIF
      IF (NVIEW.GT.0 .AND. NVIEW.LE.NPONTS) THEN
         NVWP = NVIEW
      ELSE
         MINVVW = NVEC+1
         DO 210 NVW = 1, NPONTS
          NVECVW = 0
         DO 110 NVE = 1, NVEC
          IF (NP1P2(1,NVE) .EQ. NVW .OR. IABS(NP1P2(2,NVE)) .EQ. NVW)
     *      NVECVW = NVECVW + 1
 110     CONTINUE
         IF (NVECVW .EQ. 0)  GOTO  210
         IF (MINVVW .GT. NVECVW) THEN
            MINVVW = NVECVW
            NVWP = NVW
         ENDIF
 210     CONTINUE
      ENDIF
      NVI = 0
      IPO = 0
      DO  410 IP = 1, NPONTS
      IF (NVWP .EQ. IP) GOTO 410
      DO  310 NVE = 1, NVEC
      IF (NP1P2(1,NVE) .EQ. NVWP .AND. IABS(NP1P2(2,NVE)) .EQ. IP) THEN
          NVI=NVI+1
          CALL KERNAB (VEC(1,NVE), VECVWP(1,NVI), 4)
          IVWP(NVI) = NP1P2(2,NVE)
      ELSE
      IF (NP1P2(1,NVE) .EQ. IP .AND. IABS(NP1P2(2,NVE)) .EQ. NVWP) THEN
          NVI=NVI+1
          IF (NP1P2(2,NVE) .GT. 0) THEN
            CALL INVAB(VEC(1,NVE), VECVWP(1,NVI), 3)
            VECVWP(4,NVI)=VEC(4,NVE)
            IVWP(NVI) = NP1P2(1,NVE)
          ELSE
            CALL KERNAB (VEC(1,NVE), VECVWP(1,NVI), 4)
            IVWP(NVI) = -NP1P2(1,NVE)
          ENDIF
       ENDIF
      ENDIF
 310  CONTINUE
      IPO = IPO + 1
      IVP(IPO) = NVI
 410  CONTINUE
      NVVW = NVI
      RETURN
      END
      SUBROUTINE VECRIN (NI, PVECVJ,PVECJJ, VALUIM, SUMVIM, RING)
      LOGICAL RING
      PARAMETER (MXHEAV=20, MXVC=(MXHEAV*MXHEAV-MXHEAV)/2)
      PARAMETER (MXSTSX=30)
      PARAMETER (MXVW=6*(MXHEAV+MXHEAV/10))
      COMMON /IMAGEV/ FATSMX, MINPTS, MAXPTS, NPONTS, NPONT1,
     *      XEO(5,MXHEAV),
     *      NVEC, VEC(4,MXVC), NP1P2(2,MXVC),
     *      NVWP, NVVW, VECVWP(4,MXVW), IVWP(MXVW), IVP(MXVW),
     *      IMPNTS(MXHEAV),
     *      VECIM(3,MXHEAV), XF(4*MXHEAV+5), INX(MXSTSX)
      DIMENSION VECJI(3), VECNVI(3), VALIMN(MXHEAV), SUMIMN(MXHEAV)
      PARAMETER (VALMIN=0.0)
      NII = NI
      IF (NII.EQ. 1) THEN
          VALUIM = AMIN1(PVECVJ,PVECJJ)
          SUMVIM = PVECVJ+PVECJJ
          SUMIMN(1)= SUMVIM
          VALIMN(1)= VALUIM
          DMAX = 0.80
          GOTO 211
      ENDIF
      J = IMPNTS(NII)
      VALUIM= AMIN1(PVECVJ,PVECJJ,VALIMN(NII-1))
      SUMVIM= PVECVJ+PVECJJ+SUMIMN(NII-1)
      DO  210 I1 = 1, NII-1
      CALL VMINV (VECIM(1,I1), VECIM(1,NII), VECJI, 3)
      I = IMPNTS(I1)
      IRING = 0
      VALJI = VALMIN
      DO  110 NV = 1, NVEC
      IS = 0
      IF (NP1P2(1,NV) .EQ. I .AND. NP1P2(2,NV) .EQ. J) IS = -1
      IF (NP1P2(1,NV) .EQ.-I .AND. NP1P2(2,NV) .EQ.-J) IS = 1
      IF (IS .NE. 0) THEN
        IF (IS .EQ. 1) THEN
            IQUAL = ISELFD(VECJI, VEC(1,NV), DMAX)
        ELSE
            CALL INVAB (VEC(1,NV), VECNVI, 3)
            IQUAL = ISELFD(VECJI, VECNVI, DMAX)
        ENDIF
        IF (IQUAL .EQ. 1 .AND. VEC(4,NV) .GT. VALJI) THEN
            IRING = 1
            VALJI = VEC(4,NV)
        ENDIF
      ENDIF
 110  CONTINUE
      RING = IRING .EQ. 1
      IF (.NOT. RING) RETURN
      IF (VALUIM .GT. VALJI) VALUIM = VALJI
      SUMVIM = SUMVIM + VALJI
 210  CONTINUE
      VALIMN(NI) = VALUIM
      SUMIMN(NI) = SUMVIM
 211  RING = .TRUE.
      RETURN
      END
      SUBROUTINE DISCRX(X, NMODX, XZ, NMODXZ, NEWXZ)
      PARAMETER (MXHEAV=20, MXSTSX=30, IXZ=5*MXHEAV+5)
      PARAMETER (MXINXZ=MXSTSX)
      DIMENSION X(4*MXHEAV+5,MXSTSX), XZ(IXZ,MXSTSX)
      DIMENSION INXZ(MXINXZ), X1Z(IXZ)
      DATA  X1Z /IXZ*0.0/
      ISQ = 5*MXHEAV+3
      NEWXZ=0
      IF (NMODX.LE.0)  RETURN
      IF (NMODXZ .GT. 0) THEN
        NHIGXZ=NMODXZ
        CALL DETSEQ(INXZ,NHIGXZ, XZ, IXZ, NMODXZ, ISQ, 0)
        ENDIF
      DO 120 M=1,NMODX
      NH = NINT( X(4*MXHEAV+1,M) )
      DO 110 I = 1, NH
 110  CALL KERNAB(X(4*I-3,M),X1Z(5*I-4),4)
      CALL ATIFCO(X1Z, NH,VAL1X,AMINMM,AMIM1,CONTHL,SUMIW)
      IF (VAL1X .LT. 0.1) GOTO 120
      NEWXZ=NEWXZ+1
      X1Z(5*MXHEAV+1) = NH
      X1Z(5*MXHEAV+2) = X(4*MXHEAV+2,M)
      X1Z(5*MXHEAV+4) = X(4*MXHEAV+4,M)
      X1Z(5*MXHEAV+5) = X(4*MXHEAV+5,M)
      X1Z(ISQ) = VAL1X
      IF (NH .LT. MXHEAV) THEN
         X1Z(5*MXHEAV-1) = AMINMM
         X1Z(5*MXHEAV-2) = CONTHL
         X1Z(5*MXHEAV-3) = AMIM1
         X1Z(5*MXHEAV) = SUMIW
         ENDIF
      CALL EL2AR2 (X1Z, 5*MXHEAV+5, ISQ, XZ, MXSTSX, NMODXZ, INXZ)
 120  CONTINUE
      CALL SORTIN(INXZ,MXINXZ, NMODXZ, XZ, 5*MXHEAV+5, MXSTSX)
      RETURN
      END
      SUBROUTINE ATIFCO (X, NX, VALX, AMINMM, AMIM1, CONTHL, SUMIW)
      DIMENSION X(5,NX)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MXOVRL=1800)
      PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4)
      COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP),
     *                ASVECT(5,MAXASV),NASV
      LOGICAL READY, COVERF, OVTABL
      DIMENSION OVRLTA(MXOVRL), NOVRLT(3,MXOVRL), IZPOT(2,MXHEAV),
     *          IZCOMB(2,MXHEAV), IZAT(MXHEAV), NZCONS(10), LCONST(10)
      DATA AMINM,AMINM1 / 0.0,0.0 /
      AMI1 = 0.3
      AMI2 = 1.9
      NPMAX=4*NLATT
      CALL VECCHL (X, NX, NPMAX, CONTHL)
      DO 120 M = 1,LTHV
        IZPOT(1,M) = -NCELLZ(M)
 120    IZPOT(2,M) = NCELTY(M)
      NZP = LTHV
      IF (.NOT.P1METH .OR. (NSYMM.EQ.1 .AND. ICENT.EQ.1) ) THEN
          DO 121 M=1,LTHV
 121      LCONST(M)=NCONST(M)
      ELSE
          DO 122 M=1,LTHV
 122      LCONST(M)=(NCONST(M)+1)/2
      ENDIF
      DO 130 N=1,NX
 130  IZCOMB(2,N) = NINT(IMULT * X(4,N))
      MSUM = 0
      OVTABL = .FALSE.
      VALX = -1.
      SUMIW= VALX
      INIT= 0
1111  CALL COMBIS (IZCOMB,NX,INIT, IZPOT,NZP, COVERF, READY)
          IF (READY) RETURN
      IF (LTHV.GT.1) THEN
        CALL KERNZI (0, NZCONS, 10)
        DO 135 N=1,NX
        DO 134 M=1,LTHV
        IF (-IZCOMB(1,N).EQ.NCELLZ(M)) THEN
          NZCONS(M)=NZCONS(M)+1
          GOTO 135
         ENDIF
 134    CONTINUE
 135    CONTINUE
        DO 136 M=1,LTHV-1
        IF (NZCONS(M).LT.LCONST(M)) GOTO 1111
 136    CONTINUE
      ENDIF
      DO 140 N=1,NX
 140  IZAT(N)=-IZCOMB(1,N)
      CALL INTWGT(NAXCEL,NPCELL, IZAT,N, SUMINW)
      IF (SUMINW*AMI2 .LT. VALX) GOTO 1111
      IF (NASV.EQ.0) THEN
         AMINM = AMIN1(AMI2,1.0)
         COMVAL = AMINM * SUMINW  + CONTHL*0.5*SUMINW
      ELSE
        IF (.NOT.OVTABL) THEN
          CALL OVLWGT(ASVECT,NASV,XCELL,NAXCEL,NPCELL,OVRLTA,NT,NOVRLT)
          OVTABL = .TRUE.
        ENDIF
        CALL OVLWBT (ASVECT,NASV, OVRLTA,NT, NOVRLT, IZAT)
        CALL ISFP (ASVECT,NASV, MSUM, AMINM, AMINM1)
        AMINM = AMINM/SCPAT * NLATT
        AMINM1= AMINM1/SCPAT * NLATT
        IF (AMINM1.GT.AMI2) AMINM1=AMI2
        IF (AMINM.GT.AMI2) AMINM=AMI2
        IF (AMINM.GT.AMI1) THEN
          AM1=AMINM
          AM2=0.0
          IF (AM1.GT.1.3) THEN
            AM1=1.3
            AM2=(AMINM-1.3)*0.1
          ENDIF
          COMVAL = (AM1+AM2) * SUMINW  + CONTHL*0.5*SUMINW
        ELSE
           COMVAL =-2.0
        ENDIF
      ENDIF
      IF (COMVAL .GT. VALX) THEN
         SUMIW = SUMINW
         AMINMM= AMINM
         AMIM1 = AMINM1
         VALX = COMVAL
         DO 150 N = 1,NX
 150     X(5,N)= IZAT(N)
         ENDIF
      GOTO 1111
      END
      SUBROUTINE VECCAP (X, NX, ASVECT, NASV, XCELL, NP, NAXCEL)
      PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4)
      DIMENSION X(5, NX), ASVECT(5,MAXASV), XCELL(3,MXNUP),
     *                                     NAXCEL(MXNUP)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL P1METH
      EQUIVALENCE (P1METH, SWITCH(27))
      PARAMETER (MXXEQ=48*3)
      DIMENSION XEQ(3,MXXEQ), XEQT(3)
      LOGICAL PATSYM, TLATTI, PATS, ENANTI
      DATA DMAX, PATSYM,TLATTI,PATS,ENANTI / 0.1,.FALSE.,.FALSE.,.TRUE.,
     *     .FALSE./
      NASV=0
      NP=0
      NP1=0
      DO 310 J = 1, NX
      CALL ALLEQP( X(1,J), XEQ, MXXEQ, PATSYM,TLATTI, NEQP)
      N11=0
      DO 150 N =1,NEQP
      IF (N.EQ.1) GOTO 130
      DO 120 L=1,NLATT
      CALL VPLUSV(XEQ(1,N),TLATT(1,L),XEQT,3)
      DO 110 N1=1,N11
 110  IF (ISELFD(XEQT,XEQ(1,N1),DMAX) .EQ. 1)  GOTO 150
 120  CONTINUE
 130  NP=NP+1
      NAXCEL(NP)=J
      CALL KERNAB(XEQ(1,N),XCELL(1,NP),3)
      N11=N11+1
      IF (N11.NE.1) CALL KERNAB(XEQ(1,N),XEQ(1,N11),3)
 150  CONTINUE
      NEQP=N11
      IF (NASV.EQ.MAXASV) GOTO  310
      J1 = J
      N1 = 2
      DO 220 K = J1, NX
      NASVJ=NASV+1
      NV=0
      DO 210 N = N1, NEQP
      NASV = NASV + 1
      CALL VMINV ( X(1,K), XEQ(1,N), ASVECT(1,NASV), 3)
      IF (NASV.EQ.MAXASV)  GOTO  310
  210 CONTINUE
      IF (J.EQ.K) THEN
         NV=NASV-NASVJ+1
         IF (NV.NE.0)
     *      CALL DELXEQ (ASVECT(1,NASVJ), NV, 0, PATS, ENANTI, DMAX)
         NASV=NASVJ+NV-1
         ENDIF
      N1 = 1
  220 CONTINUE
  310 CONTINUE
      IF (NASV.NE.0)
     *   CALL DELXEQ (ASVECT, NASV, 0, PATS, ENANTI, DMAX)
      NP1=NP
      DO 410 N1=1,NP1
      DO 410 L=2,NLATT
      CALL VPLUSV(XCELL(1,N1),TLATT(1,L),XEQT,3)
      DO 400 N=1,NP
 400  IF (ISELFD(XEQT,XCELL(1,N),DMAX) .EQ. 1)  GOTO 410
      NP=NP+1
      NAXCEL(NP)=NAXCEL(N1)
      CALL KERNAB(XEQT,XCELL(1,NP),3)
 410  CONTINUE
      RETURN
      END
      SUBROUTINE INTWGT(NAXCEL,NP, IZAT,N, SUMINW)
      DIMENSION NAXCEL(NP), IZAT(N)
      SUMINW = 0.0
      DO 210  N1=1,NP
      J1=NAXCEL(N1)
      DO 110  N2=1,NP
      J2=NAXCEL(N2)
 110  SUMINW=SUMINW+IZAT(J1)*IZAT(J2)
 210  CONTINUE
      RETURN
      END
      SUBROUTINE OVLWGT (ASVECT,NASV, XCELL,NAXCEL,NP, OVRLTA, NT,
     *                                                         NOVRLT)
      PARAMETER (MXOVRL=1800)
      DIMENSION ASVECT(5,NASV), XCELL(3,NP), NAXCEL(NP),
     *          OVRLTA(MXOVRL), NOVRLT(3,MXOVRL)
      INCLUDE 'Zcrys.inc'
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      DIMENSION VECN(3), DVEC(3)
      NT=0
      DO 510 N1=1,NP
      J1=NAXCEL(N1)
      DO 410 N2=1,NP
      IF (N1.EQ.N2)  GOTO 410
      CALL VMINV(XCELL(1,N1), XCELL(1,N2), VECN, 3)
      J2=NAXCEL(N2)
      DO 310 I=1,NASV
      CALL DISTSQ (VECN, ASVECT(1,I), RMAX, DVEC, RR2)
      IF (RR2 .LT. RMAX2) THEN
        NT=NT+1
        G = RR2/DEL + 1.
        IG = G
        F = G - FLOAT(IG)
        OVRLTA(NT) = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F
        NOVRLT(1,NT)=I
        NOVRLT(2,NT)=J1
        NOVRLT(3,NT)=J2
        IF (NT .EQ. MXOVRL)  RETURN
      ENDIF
 310  CONTINUE
 410  CONTINUE
 510  CONTINUE
      RETURN
      END
      SUBROUTINE OVLWBT (ASVECT,NASV, OVRLTA,NT, NOVRLT, IZAT)
      PARAMETER (MXHEAV=20, MXOVRL=1800)
      DIMENSION ASVECT(5,NASV), OVRLTA(MXOVRL), NOVRLT(3,MXOVRL),
     *                                                   IZAT(MXHEAV)
      DO 110 NV = 1,NASV
 110  ASVECT(4,NV)=0.0
      IF (NT.EQ.0)   RETURN
      DO 120 N = 1,NT
      NV1= NOVRLT(1,N)
      J1 = NOVRLT(2,N)
      J2 = NOVRLT(3,N)
      ASVECT(4,NV1) = ASVECT(4,NV1) + OVRLTA(N)*IZAT(J1)*IZAT(J2)
 120  CONTINUE
      RETURN
      END
      SUBROUTINE COMBIS (ICOMB,N,IN, IPOT,NP, COVERF, READY)
      DIMENSION ICOMB(2,N), IPOT(2,NP)
      LOGICAL COVERF, READY
      PARAMETER (MXCOM=20)
      LOGICAL CONOTP
      IF (N.GT. MXCOM) THEN
          COVERF = .TRUE.
          RETURN
      ELSE
          COVERF = .FALSE.
      ENDIF
      IF (IN .EQ. 0) THEN
         CALL COMBIM( ICOMB,N, IPOT,NP, 1, CONOTP)
         READY = CONOTP
         IF (.NOT. READY) IN=N
         RETURN
      ENDIF
      DO 530 JJ = N, 1, -1
      DO 520 I= 1, NP
      IF (ICOMB(1,JJ).EQ.IPOT(1,I)) THEN
         IL=I
         DO 510 I1 = I+1,NP
         IF (IPOT(2,I1) .GE. ICOMB(2,JJ)) THEN
            IPOT(2,IL) = IPOT(2,IL) + ICOMB(2,JJ)
            ICOMB(1,JJ)= IPOT(1,I1)
            IPOT(2,I1) = IPOT(2,I1) - ICOMB(2,JJ)
            IL=I1
            CALL COMBIM (ICOMB,N, IPOT,NP, JJ+1, CONOTP)
            IF (CONOTP) GOTO 510
            READY = .FALSE.
            RETURN
         ENDIF
 510     CONTINUE
         IPOT(2,I) = IPOT(2,I) + ICOMB(2,JJ)
         GOTO 530
      ENDIF
 520  CONTINUE
 530  CONTINUE
      READY = .TRUE.
      RETURN
      END
      SUBROUTINE COMBIM (ICOMB,N, IPOT,NP, JJJ, CONOTP)
      DIMENSION ICOMB(2,N), IPOT(2,NP)
      LOGICAL CONOTP
      PARAMETER (MXCOM=20)
      DIMENSION LIP(MXCOM)
      IF (JJJ .GT. N) GOTO 410
       I  = 0
       J1 = JJJ
 111   CONTINUE
            JJ1= J1
            LI = I+1
            DO 310 J=JJ1,N
            DO 210 I=LI,NP
            IF (IPOT(2,I).GE.ICOMB(2,J) )THEN
            ICOMB(1,J) = IPOT(1,I)
            IPOT(2,I) = IPOT(2,I) - ICOMB(2,J)
            LIP(J) = I
            GOTO 309
            ENDIF
 210        CONTINUE
            J1=J-1
            IF (J1.LT.JJJ) THEN
            CONOTP = .TRUE.
            RETURN
            ENDIF
            I = LIP(J1)
            IPOT(2,I) = IPOT(2,I) + ICOMB(2,J1)
       GOTO 111
 309        LI = 1
 310        CONTINUE
 410  CONOTP= .FALSE.
      RETURN
      END
      SUBROUTINE ISFP (ASVECT,NASV, MSUM, AMINM, AMINM1)
      DIMENSION ASVECT(5,NASV)
      PARAMETER (MAXASV=3600, MXMSUM=20)
      DIMENSION PW(MAXASV), IPW(MXMSUM)
      DATA  ISQ, PNCV /1, 0.25/
      MSUML = MSUM
      NCV = NASV
      DO 110 N=1,NASV
      IF (ASVECT(5,N).GT.0.10) THEN
        PW(N) = -ASVECT(5,N)/ASVECT(4,N)
        IF (ASVECT(4,N).LT.0.1) THEN
        ENDIF
      ELSE
        PW(N) = 0.0
      ENDIF
 110  CONTINUE
      IF (MSUM.EQ.0) THEN
          MSUM = NCV * PNCV
          IF (MSUM.LT.1) MSUM=1
          MSUML= MIN0 (MSUM, MXMSUM, NCV)
          MSUM = MSUML
      ENDIF
      CALL DETSEQ(IPW, MSUML, PW, 1, NASV, ISQ, 0)
      AMINM=0.0
      DO 120 I = 1,MSUML
 120  AMINM = AMINM - PW(IPW(I))
      AMINM = AMINM/MSUML
      AMINM1= -PW(IPW(1))
      RETURN
      END
      SUBROUTINE PEAKHG( NPEAKS, PLEVEL, NO, XP)
      PARAMETER (MXPKS=150,MXPEAK=MXPKS+100)
      DIMENSION XP(5, MXPEAK)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      DIMENSION B(19), XX(3), XXMAX(5)
      DIMENSION INDXP(MXPEAK), ISXYZ2(3), LXYZ2(3)
      EQUIVALENCE (ISXYZ2(1), ISX2), (LXYZ2(1), LX2),
     *      (ISXYZ2(2), ISY2), (LXYZ2(2), LY2),
     *      (ISXYZ2(3), ISZ2), (LXYZ2(3), LZ2)
      DIMENSION STEPX(3)
      DATA XXMAX /5*0.0/
      DO 100 I=1,3
 100  STEPX(I)=1./GTXYZS(I)
      NPIEKS = NPEAKS
      IF (NPEAKS.GT.MXPEAK) NPIEKS = MXPEAK
      NO = 0
      IZ1=ISS(3)
      IZ2=ISS(3)+1
      IZ3=ISS(3)+2
      DO 102 I = 1,3
      ISXYZ2(I) = ISS(I)
      LXYZ2(I) = LXYZS(I)
      IF (ISS(I).LT.LXYZS(I)) THEN
         ISXYZ2(I) = ISXYZ2(I) + 1
         LXYZ2(I) = LXYZ2(I) - 1
         ENDIF
 102  CONTINUE
      DO 333 IZ2= ISZ2,LZ2
            IZ1= IZ2-1
            IZ3= IZ2+1
      DO 222 IY = ISY2,LY2
      DO 111 IX = ISX2,LX2
      B(10) = DKMAP (IX,IY,IZ2)
            IF (B(10) .LT.PLEVEL ) GO TO 111
      B(1) = DKMAP (IX-1,IY-1,IZ2)
            IF (B(10) .LT. B(1) ) GO TO 111
      B(2) = DKMAP (IX,IY-1,IZ1)
            IF (B(10) .LT. B(2) ) GO TO 111
      B(3) = DKMAP (IX,IY-1,IZ2)
            IF (B(10) .LT. B(3) ) GO TO 111
      B(4) = DKMAP (IX,IY-1,IZ3)
            IF (B(10) .LT. B(4) ) GO TO 111
            IBB = NINT ( (B(10)-B(4)) * 99.)
            IF (IZ3.LE.LZ2 .AND. IBB.EQ.0 ) GO TO 111
      B(5) = DKMAP (IX+1,IY-1,IZ2)
            IF (B(10) .LT. B(5) ) GO TO 111
      B(6) = DKMAP (IX-1,IY,IZ1)
            IF (B(10) .LT. B(6) ) GO TO 111
      B(7) = DKMAP (IX-1,IY,IZ2)
            IF (B(10) .LT. B(7) ) GO TO 111
      B(8) = DKMAP (IX-1,IY,IZ3)
            IF (B(10) .LT. B(8) ) GO TO 111
            IBB = NINT ( (B(10)-B(8)) * 99.)
            IF (IZ3.LE.LZ2 .AND. IBB.EQ.0) GO TO 111
      B(9) = DKMAP (IX,IY,IZ1)
            IF (B(10) .LT. B(9) ) GO TO 111
      B(11) = DKMAP (IX,IY,IZ3)
            IF (B(10) .LT. B(11)) GO TO 111
            IBB = NINT ( (B(10)-B(11)) * 99.)
            IF (IZ3.LE.LZ2 .AND. IBB.EQ.0) GO TO 111
      B(12) = DKMAP (IX+1,IY,IZ1)
            IF (B(10) .LT. B(12)) GO TO 111
      B(13) = DKMAP (IX+1,IY,IZ2)
            IF (B(10) .LT. B(13)) GO TO 111
            IBB = NINT ( (B(10)-B(13)) * 99.)
            IF (IX.LT.LX2 .AND. IBB.EQ.0) GO TO 111
      B(14) = DKMAP (IX+1,IY,IZ3)
            IF (B(10) .LT. B(14)) GO TO 111
            IBB = NINT ( (B(10)-B(14)) * 99.)
            IF ((IX.LT.LX2 .AND. IZ3.LE.LZ2) .AND. IBB.EQ.0) GOTO 111
      B(15) = DKMAP (IX-1,IY+1,IZ2)
            IF (B(10) .LT. B(15)) GO TO 111
            IBB = NINT ( (B(10)-B(15)) * 99.)
            IF (IY.LT.LY2 .AND. IBB.EQ.0) GO TO 111
      B(16) = DKMAP (IX,IY+1,IZ1)
            IF (B(10) .LT. B(16)) GO TO 111
      B(17) = DKMAP (IX,IY+1,IZ2)
            IF (B(10) .LT. B(17)) GO TO 111
            IBB = NINT ( (B(10)-B(17)) * 99.)
            IF (IY.LT.LY2 .AND. IBB.EQ.0) GO TO 111
      B(18) = DKMAP (IX,IY+1,IZ3)
            IF (B(10) .LT. B(18)) GO TO 111
            IBB = NINT ( (B(10)-B(18)) * 99.)
            IF ((IY.LT.LY2 .AND. IZ3.LE.LZ2) .AND. IBB.EQ.0) GOTO 111
      B(19) = DKMAP (IX+1,IY+1,IZ2)
            IF (B(10) .LT. B(19)) GO TO 111
            IBB = NINT ( (B(10)-B(19)) * 99.)
            IF ((IX.LT.LX2 .AND. IY.LT.LY2) .AND. IBB.EQ.0) GOTO 111
      XX(1) = FLOAT(IX)/GTXYZS(1)
      XX(2) = FLOAT(IY)/GTXYZS(2)
      XX(3) = FLOAT(IZ2)/GTXYZS(3)
      CALL SMAXMN (XX, STEPX, XXMAX, SMAX)
      XXMAX(4) = SMAX
      CALL EL2AR2( XXMAX, 5, 4, XP,NPIEKS, NO, INDXP)
 111  CONTINUE
 222  CONTINUE
 333  CONTINUE
      CALL SORTIN (INDXP,MXPEAK,NO, XP, 5, NPIEKS)
      RETURN
      END
      FUNCTION DKMAP(IX,IY,IZ)
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      DKMAP=0.0
      IF (IX.LT.ISS(1) .OR. IX.GT.LXYZS(1)) RETURN
      IF (IY.LT.ISS(2) .OR. IY.GT.LXYZS(2)) RETURN
      IF (IZ.LT.ISS(3) .OR. IZ.GT.LXYZS(3)) RETURN
      IADR = NUSXY * IZ + NUMS(1) * IY + IX - NUMSC
      IJX = ITAB(IADR)
      DKMAP = FLOAT( IJX ) / 99.
      RETURN
      END
      SUBROUTINE SMAXMN (X, STEPX, XMAX, SMAX)
      DIMENSION X(3), STEPX(3), XMAX(5)
      INCLUDE 'Zcrys.inc'
      COMMON /SELFWT/IRSY1(3,3,48),TSY1(3,48),NSSY,SWGT(48),NSDH(4,48)
      DIMENSION DS(48,5,3), XX(3), SO(48), JM(3)
      DATA  PMIN,PMAX /0.0,30254./
      DO 210 NS=2,NSSY
      SO(NS) = SSMINF(X,NS,.TRUE.,NSMIN)
      DO 150 I = 1,3
      CALL KERNAB(X,XX,3)
      XX(I) = X(I)-0.75*STEPX(I)
      DO 130 J = 1,5
      XX(I)=XX(I)+0.25*STEPX(I)
      IF (J.EQ.3) THEN
         DS(NS,J,I) = 0.0
      ELSE
         DS(NS,J,I) = SSMINF(XX,NS,.TRUE.,NSMIN) - SO(NS)
      ENDIF
 130  CONTINUE
 150  CONTINUE
 210  CONTINUE
      SMAX=PMIN
      DO 3000 J3 = 1, 5
      DO 2000 J2 = 1, 5
      DO 1000 J1 = 1, 5
      SMIN3=PMAX
      DO 300 NS=2,NSSY
      S3 = DS(NS,J1,1) + DS(NS,J2,2) + DS(NS,J3,3) + SO(NS)
      IF (SMIN3.GT.S3) SMIN3=S3
 300  CONTINUE
      IF (SMAX.LT.SMIN3) THEN
          SMAX=SMIN3
          JM(1)=J1
          JM(2)=J2
          JM(3)=J3
          ENDIF
 1000 CONTINUE
 2000 CONTINUE
 3000 CONTINUE
      DO 4000 I=1,3
      XMAX(I) = X(I)+(0.25*JM(I)-0.75)*STEPX(I)
 4000 CONTINUE
      RETURN
      END
      SUBROUTINE USET1G (IP, NP, ISET, I, BRI, MI, MAXI)
      DIMENSION IP(NP), ISET(MAXI)
      LOGICAL BRI
      DATA MXI / 0 /
      IF (I.EQ.0) THEN
        BRI=.FALSE.
        MXI = MAXI
        IF (MXI.GT.NP) MXI = NP
        IF (MI.GT.MXI .OR. MXI.LE.0) RETURN
        I=1
        ISET(1)=1
        IF (MXI.GE.2) ISET(2)=IP(1)
        RETURN
      ENDIF
      IF (BRI) THEN
        BRI=.FALSE.
        I=I-1
      ENDIF
      J1=I+1
      IF (J1.GT.MXI) J1=MXI
      DO 320 J = J1, 1, -1
      N = MIN0(NP+J-MI, NP)
      IF (ISET(J)+1 .LE. IP(N)) THEN
        ISET(J)=ISET(J)+1
        IF (J.LT.MXI) THEN
          DO 310 M=N, 2, -1
          IF (ISET(J) .GT. IP(M-1)) GOTO 315
 310      CONTINUE
          M=1
 315      ISET(J+1) = IP(M)
        ENDIF
        I=J
        RETURN
      ENDIF
 320  CONTINUE
      I=0
      RETURN
      END
      SUBROUTINE DELXEQ ( X, NR, NOR, PATS, ENANTI, DMAX)
      DIMENSION X(5,NR)
      LOGICAL PATS, ENANTI
      LOGICAL PATSYM,TLATTI
      DATA  TLATTI /.TRUE./
      PATSYM=PATS
      N11=1
      NOR1 = NOR
      IF (NOR1.LE.0) NOR1=1
      DO 410 N2= 2, NR
      DO 310 NO= 1, NOR1
      NO1 = NO
      IF (NOR.LE.0) NO1=0
      IF (IEQUX(X(1,N2), X, N11, PATSYM, ENANTI, TLATTI, DMAX, NO1)
     *      .EQ. 1) GOTO 410
 310  CONTINUE
      N11 = N11+1
      CALL KERNAB (X(1,N2), X(1,N11), 5)
 410  CONTINUE
      NR=N11
      RETURN
      END
      FUNCTION IEQUX(X1, X, N1, PATSYM,ENANTI,TLATTI, DMAX, NOR1)
      DIMENSION X1(3), X(5,N1)
      LOGICAL PATSYM,ENANTI,TLATTI
      COMMON /ORIGNS/ NOR, ORIG(3,8), IDDPOL, RVPOL(3)
      DIMENSION X1DATA(4), XEQ(3), XO1(3)
      LOGICAL ALLEQ
      IF (NOR1.GT.NOR) THEN
         IEQUX=0
         RETURN
      ENDIF
      IF (NOR1 .NE. 0) THEN
         CALL VMINV (X1, ORIG(1,NOR1), XO1,3)
         CALL KERNAB(XO1, X1DATA, 3)
      ELSE
         CALL KERNAB(X1, X1DATA, 3)
      ENDIF
 110  CALL SYMOPN (X1DATA, XEQ, PATSYM, ENANTI, TLATTI, ALLEQ)
      DO 210 N= 1, N1
      IF (NOR1.NE.0 .AND. IDDPOL.NE.0)
     *    CALL POLASH(XEQ,X(1,N), IDDPOL, RVPOL, XEQ)
      IEQUX = ISELFD (XEQ, X(1,N), DMAX)
      IF (IEQUX .EQ. 1) THEN
           RETURN
      ENDIF
 210  CONTINUE
      IF (.NOT.ALLEQ) GOTO 110
      RETURN
      END
      SUBROUTINE POLASH (XSH, X, IDD, RV, XSHFD)
      DIMENSION XSH(3),X(3), RV(3), XSHFD(3)
      DIMENSION SHFV(3)
      CALL VMINV (X,XSH, SHFV, 3)
      IF (IDD .EQ. 1) THEN
        IF(RV(1).GT.0.9 .AND. RV(2).GT.0.9 .AND. RV(3).GT.0.9) THEN
          SHFV(1)=(SHFV(1)+SHFV(2)+SHFV(3))/3.
          SHFV(2)=SHFV(1)
          SHFV(3)=SHFV(1)
        ELSE
          DO 110 I =1,3
 110      SHFV(I)=SHFV(I)*RV(I)
        ENDIF
      ELSE IF (IDD.EQ.2) THEN
        DO 120 I =1,3
 120    IF (RV(I).GT.0.9) SHFV(I)=0.0
      ENDIF
      CALL VPLUSV (XSH, SHFV, XSHFD, 3)
      RETURN
      END
      SUBROUTINE SYMEQU (NS, ITS, NLT, INV, FIRST, X, XEQ, XS)
      LOGICAL FIRST
      DIMENSION X(3), XEQ(3), XS(3)
      INCLUDE 'Zcrys.inc'
      IF (FIRST) THEN
         DO 120 I2 = 1,3
         XS(I2) = 0.
         DO 110 I1 = 1,3
         IF (IRSYMM(I2,I1,NS) .NE. 0) THEN
            IF (IRSYMM(I2,I1,NS) .EQ. 1) THEN
            XS(I2) = XS(I2) + X(I1)
            ELSE
            XS(I2) = XS(I2) - X(I1)
            ENDIF
         ENDIF
 110     CONTINUE
 120     CONTINUE
         IF (ITS .EQ. 1) CALL VPLUSV (XS, TSYMM(1,NS), XS, 3)
         CALL KERNAB (XS, XEQ, 3)
      ELSE IF (INV .EQ. -1) THEN
          CALL INVAB ( XEQ, XEQ, 3)
          RETURN
      ENDIF
      IF (NLT .GT. 1) CALL VPLUSV ( XS, TLATT(1,NLT), XEQ, 3)
      IF (INV .EQ. -1) CALL INVAB ( XEQ, XEQ, 3)
      RETURN
      END
      SUBROUTINE NEXSYM (NS, NLT, INV, NSYMM, NLATT, SMOD, ALLSEQ)
      LOGICAL SMOD, ALLSEQ
      IF (INV .EQ. 1) THEN
          INV = -1
          SMOD = .FALSE.
          GOTO 110
      ENDIF
      IF (INV .EQ. -1) INV = 1
      IF    (NLT .NE. 0) THEN
          IF (NLT .GE. NLATT) THEN
            NLT = 1
          ELSE
            NLT = NLT + 1
            SMOD = .FALSE.
            GOTO 110
          ENDIF
      ENDIF
      NS = NS + 1
      SMOD  = .TRUE.
 110  ALLSEQ = NS .GT. NSYMM
      RETURN
      END
      SUBROUTINE SYMOPN (XDATAS, XEQ, PATSYM, ENANTI, TLATTI, ALLSEQ )
      DIMENSION XDATAS(4),XEQ(3)
      LOGICAL PATSYM, ENANTI, TLATTI, ALLSEQ
      INCLUDE 'Zcrys.inc'
      LOGICAL FIRST, SMOD
      DIMENSION X(3), XEQL(3), XINTRM(3)
      IF (XDATAS(1).LT. 100.) THEN
           DO 110 I=3,1,-1
           X(I)=XDATAS(I)
 110       XDATAS(I+1)=XDATAS(I)
           XDATAS(1)=101.
           FIRST= .TRUE.
           NS=1
           ITS=1
           IF (PATSYM) ITS=0
           NLT = 0
           IF (TLATTI .AND. NLATT.GT.1) NLT=1
           INV=0
           IF (ENANTI .OR. ICENT.EQ.2 .OR. PATSYM) INV=1
      ENDIF
      CALL SYMEQU (NS, ITS, NLT, INV, FIRST, X, XEQL, XINTRM)
      CALL NEXSYM (NS, NLT, INV, NSYMM, NLATT, SMOD, ALLSEQ)
      FIRST = SMOD
           CALL KERNAB (XEQL, XEQ, 3)
           IF (ALLSEQ) THEN
            DO 210 I=1,3
 210        XDATAS(I) = XDATAS(I+1)
           ENDIF
      RETURN
      END
      FUNCTION OCCUPX (X)
      DIMENSION X(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION XEQ(3,48), IXSELF(48), XEQM(3)
      LOGICAL PATSYM,TLATTI
      DATA  PATSYM,TLATTI /.FALSE.,.FALSE./
      DATA  DMAX / 0.7/
      OCCUPX = IMULT
      CALL ALLEQP (X, XEQ, 48, PATSYM, TLATTI, NEQP)
      CALL KERNZI (0, IXSELF, NEQP)
      DO 120 N= 1,NEQP
      OCCUPX = OCCUPX - IXSELF(N)*NLATT
      IF (IXSELF(N).EQ.1) GOTO 120
            N1=N+1
      DO 110 M=N1,NEQP
      DO 105 L= 1,NLATT
      IF (IXSELF(M).EQ.1) GOTO 110
      CALL VPLUSV (XEQ(1,M), TLATT(1,L), XEQM, 3)
      IXSELF(M)=ISELFD (XEQ(1,N), XEQM, DMAX)
 105  CONTINUE
 110  CONTINUE
 120  CONTINUE
      OCCUPX = OCCUPX/IMULT
      RETURN
      END
      SUBROUTINE ALLEQP (X, XEQ, NXQ, PATSYM,TLATTI, NEQP)
      DIMENSION X(3), XEQ(3,NXQ)
      LOGICAL PATSYM,TLATTI
      DIMENSION XDATAS(4)
      LOGICAL ALLSEQ, ENANTI
      DATA  ENANTI /.FALSE./
      CALL KERNAB (X,XDATAS,3)
      N=0
 110  CONTINUE
      N = N + 1
      CALL SYMOPN (XDATAS, XEQ(1,N), PATSYM, ENANTI, TLATTI, ALLSEQ)
      IF (.NOT. ALLSEQ .AND. N.LT.NXQ) GOTO 110
      NEQP = N
      RETURN
      END
      SUBROUTINE DELIPO (X, N, DMAX)
      DIMENSION X(5,N)
      N11=1
      DO 410 N2= 2, N
      DO 210 N1= 1, N11
      IF (ISELFD (X(1,N2), X(1,N1), DMAX) .EQ. 1) GOTO 410
 210  CONTINUE
      N11 = N11+1
      CALL KERNAB (X(1,N2), X(1,N11), 5)
 410  CONTINUE
      N=N11
      RETURN
      END
      SUBROUTINE INVAB ( A, B, N)
      DIMENSION A(N), B(N)
      DO 110 I = 1, N
      B(I) = -A(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE VPLUSV (V1, V2, VOUT, N)
      DIMENSION V1(N), V2(N), VOUT(N)
      DO 110 I = 1, N
        VOUT(I) = V1(I) + V2(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE VMINV (V1, V2, VOUT, N)
      DIMENSION V1(N), V2(N), VOUT(N)
      DO 110 I = 1, N
        VOUT(I) = V1(I) - V2(I)
 110  CONTINUE
      RETURN
      END
      SUBROUTINE REDFCO (X, XOUT, N)
      DIMENSION X(N), XOUT(N)
      DO 110 I = 1, N
        XOUT(I) = X(I) - ANINT(X(I))
 110  CONTINUE
      RETURN
      END
      SUBROUTINE AR2SYM (AIJ, I, J, IJMAX, ARRAYS, NMAX)
      DIMENSION ARRAYS(NMAX)
      N = IPOIN1 (I,J, IJMAX)
      ARRAYS(N) = AIJ
      RETURN
      END
      FUNCTION IPOIN1 (I,J, IJMAX)
      IF (I.GE.J) THEN
          IPOIN1 = (J-1) * IJMAX - (J*J - J)/2 + I
      ELSE
          IPOIN1 = (I-1) * IJMAX - (I*I - I)/2 + J
      ENDIF
      RETURN
      END
      FUNCTION SQDIST (X, Y)
      DIMENSION X(3), Y(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION D(3)
      DO 120 I=1, 3
         D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I))
  120 CONTINUE
      SQDIST=0.0
      DO 130 I=1, 3
       SQDIST=SQDIST+
     *      D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3))
  130 CONTINUE
      RETURN
      END
      SUBROUTINE DETSEQ ( INDXHV,NHIGST, ARRAY,NDIM1,NE, ISQ, N1)
      DIMENSION INDXHV(NHIGST), ARRAY(NDIM1,NE)
      IF (N1 .LT. NHIGST) THEN
            NRE = N1
      ELSE
            NRE = NHIGST
      ENDIF
      NRE1 = NRE - 1
            N2 = N1 + 1
      DO 300 N = N2, NE
      IF ( N .GT. NHIGST ) THEN
        IF ( ARRAY( ISQ, N) .LE. ARRAY( ISQ, INDXHV(NRE)) ) GOTO 300
      ENDIF
      IF (N .LE. NHIGST) THEN
            NRE1 = NRE
            NRE = N
      ENDIF
      IF (NRE1.NE.0) THEN
        CALL SRSEQN (INDXHV, NRE1, ARRAY(1,N), ARRAY,NDIM1,NE, ISQ, NR)
          DO 100 I = NRE1, NR, -1
  100       INDXHV(I+1) = INDXHV(I)
            INDXHV(NR) = N
      ELSE
            INDXHV(1) = N
      ENDIF
  300 CONTINUE
      RETURN
      END
      SUBROUTINE SRSEQN (INDX,NX, EL, AR,I1,NE, I, N)
      DIMENSION INDX(NX), EL(I1), AR(I1,NE)
      N  = NX + 1
      NG = 0
  110 IF (NG .EQ. N-1) RETURN
      NLG = NG + (N - NG)/2
      IF (EL(I) .GT. AR(I,INDX(NLG)) ) THEN
         N = NLG
      ELSE
         NG = NLG
         ENDIF
      GOTO 110
      END
      SUBROUTINE EL2AR2 (EL, I1, ISQ, AR2, MAX2, NELS, INDAR2)
      DIMENSION EL(I1), AR2(I1,MAX2), INDAR2( MAX2)
      DATA IND / 0 /
      IF ( NELS .EQ. MAX2 ) THEN
        IF ( EL(ISQ) .LT. AR2(ISQ,INDAR2(NELS)) ) RETURN
        IF (NELS .NE. INDAR2(NELS) ) THEN
           CALL KERNAB (AR2(1,NELS), AR2(1,INDAR2(NELS)), I1)
           DO 110 N = 1, NELS
           IF (INDAR2(N) .EQ. NELS) THEN
            IND = N
            GOTO 111
           ENDIF
  110      CONTINUE
  111      INDAR2(IND) = INDAR2(NELS)
        ENDIF
      ELSE
         NELS = NELS + 1
      ENDIF
      CALL KERNAB (EL, AR2(1,NELS), I1)
      CALL DETSEQ ( INDAR2,NELS, AR2,I1,NELS, ISQ, NELS-1)
      RETURN
      END
      SUBROUTINE SORTIN ( INDXHV,NIND, NHIGST, ARRAY,NDIM1,NE )
      DIMENSION INDXHV(NIND), ARRAY(NDIM1,NE)
      DO 210 N = 1,NHIGST
            NR = INDXHV(N)
         IF (NR .EQ. N) GOTO 210
      DO 110 I = 1,NDIM1
      ELIN = ARRAY(I,N)
      ARRAY(I,N) = ARRAY(I,NR)
      ARRAY(I,NR)= ELIN
 110  CONTINUE
      INDXHV(N) = N
            N1 = N + 1
      DO 120 N2 = N1,NHIGST
      IF (INDXHV(N2) .EQ. N) THEN
            INDXHV(N2)=NR
            GOTO 210
      ENDIF
 120  CONTINUE
 210  CONTINUE
      RETURN
      END
      SUBROUTINE PATTIN
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IFMAP,IFILE(17))
      EQUIVALENCE (KLAUE,  KEYS(6)),  (IPRPAT, KEYS(8))
      EQUIVALENCE (SCADEK, KEYS(26))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI,  SWITCH(10))
      EQUIVALENCE (IMAP, KSTAT(7))
      COMMON /SINGP/ SINGPK, ORIGIN, PATP(8)
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VDUMMY
      EQUIVALENCE (NX,NXYZ(1)), (NY,NXYZ(2)), (NZ,NXYZ(3))
      INTEGER * 2 LPAT(198)
      DIMENSION NXYZM(3)
      EQUIVALENCE (NXM,NXYZM(1)), (NYM,NXYZM(2)), (NZM,NXYZM(3))
      DATA JXYZC, LXYZC / 0, 0 /
      DATA IZ, KXYZC, IXYZC / 0, 0, 0 /
      DO 111 I = 1, NUMTAB
 111  ITAB(I) = 0
      FMAX99 = 30254.
      FUNGR = 0.
      FUNSUM = 0.
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) CALL KERROR
     *   ('Patterson file (FMAP) not found.', -1, 'PATTIN')
      READ (IFMAP) FFTSC, IMAPX, IHALF
      WRITE (8, FMT='('' IMAP, IHALF, FFTSC ='',
     *   2I3, F10.5)') IMAP, IHALF, FFTSC
      IF (IMAP .NE. 2 .AND. IMAP .NE. 6) CALL KERROR
     *   ('No Patteron function (error on file FMAP)', 0 , 'PATTIN' )
      READ (IFMAP) NX, NZ, NYHALF, NY
      WRITE (8,6) NX, NY, NZ
   6  FORMAT (' Fourier grid X * Y * Z = ' , I3, 2(' *',I3) )
      SCAL = 0.2
      IF (PROGNM .EQ. 'PATTY ')     SCAL = SCADEK
      ABSCAL = SCAL * FFTSC * VOLUM
      SINGPK = ORIGIN * ABSCAL * 18. /VOLUM
      IF (SWPRI) WRITE (8, 138) FFTSC
  138 FORMAT (/' Input Patterson scale = ',12X, F10.5,' * volume ')
      WRITE (8, 152) SCAL, ABSCAL, SINGPK
  152 FORMAT (' Input function values will be multiplied by: ', F10.5 /
     *        ' To put the Patterson function on abs.scale *  ', F9.5 /
     *        ' Single C-C :  peak-height is approximately   ' ,F10.2 /)
      K = 0
      DO 12 I=1,3
      L = (NXYZ(I)+1) / 2
      IF (I.NE.2 .AND. KLAUE.LT.0) L=NXYZ(I)-1
      LXYZ(I) = L
   12 IS(I) = 0
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2)
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3)
      DO 14 I=1,3
      NXYZM(I) = NXYZ(I)
      IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1
   14 NUM(I) = LXYZ(I) - IS(I) + 1
      NUMXY = NUM(1) * NUM(2)
      NUMXYZ = NUMXY * NUM(3)
      IF (NUMXYZ .GT. NUMTAB) THEN
         write(24, 171) NUMTAB, NUMXYZ
  171 FORMAT (' Storage of Patterson, space:', I7,', needed:', I7)
         CALL KERROR (' PATTERSON TOO LARGE', 171, 'PATTIN' )
         ENDIF
      DO 217 I = 1,3
  217 GTXYZ(I) = NXYZ(I)
      NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1
      IF (IPRPAT .GT. 0) THEN
         WRITE (24,*) 'Print input Patterson map to printer LIS2'
         WRITE (8,24) (I, I=1, NUM(1)-1)
  24     FORMAT (/' Input Patterson map, file FMAP'//
     *      '  IY  IZ  IX = 0' , 24I4 / (12X, 25I4))
         WRITE (8, FMT='('' '')')
         ENDIF
      IF (NYM .GT. NYHALF) THEN
         WRITE (9,*) 'Please tell PTB: NYM gt NYHALF '
         NYM=NYHALF
         ENDIF
      DO 50 I1=1,NYM
      IY = I1 - 1
      KY = IY - NY
      IXY = NUM(1) * IY
      KXY = NUM(1) * KY
      K = 1
      IF (IS(2).EQ.0) GOTO 26
      IF (IY .GT. LXYZ(2)) K=3
      IF (IY.EQ.LXYZ(2) .OR. IY.EQ.NY/2) K=2
      IF (K.EQ.3) IXY=KXY
   26 DO 48 I2=1,NZ
      IF (I2.GT.NZM) K=0
      IF (K.EQ.0) GOTO 28
      IZ = I2 - 1
      IXYZ = NUMXY * IZ
      IXYZC = IXYZ + IXY - NUMC
      KXYZC = IXYZ + KXY - NUMC
      L = 1
      IF (IS(3).EQ.0) GOTO 28
      KZ = IZ - NZ
      JXYZ = NUMXY * KZ
      JXYZC = JXYZ + IXY - NUMC
      LXYZC = JXYZ + KXY - NUMC
      IF (IZ.GT.LXYZ(3)) L=3
      IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2
      IF (L.EQ.3) IXYZC=JXYZC
      IF (L.EQ.3) KXYZC=LXYZC
   28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX)
      IF (K.EQ.0 .OR. L.EQ.0) GOTO 48
      DO 40 I3=1,NXM
      FUN = LPAT(I3)
      FUN99 = 99. * ( FUN * SCAL + 25.)
      IF (FUN99 .LT. 0.0) FUN99 = 0.0
      IF (FUN99 .GT. FMAX99) FUN99 = FMAX99
      IF (FUN99 .GT. FUNGR) FUNGR = FUN99
      IFUN99 = NINT(FUN99)
      LPAT(I3) = IFUN99
      FUNSUM = FUNSUM + FUN99
      IX = I3 - 1
      IADR = IXYZC + IX
      ITAB(IADR) = IFUN99
      IADR = JXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN99
      IF (K.NE.2) GOTO 40
      IADR = KXYZC + IX
      ITAB(IADR) = IFUN99
      IADR = LXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN99
   40 CONTINUE
      IF (IPRPAT.GT.0) WRITE (8,42) IY,IZ,(LPAT(I3), I3=1,NUM(1))
   42 FORMAT (2I4, 4X, 25I4 / (12X, 25I4))
   48 CONTINUE
   50 CONTINUE
      IF (ILAUE .EQ.1 .AND. ICENT .EQ. 1) THEN
         CALL FILCLO (IFMAP, 'DELETE')
      ELSE
         CALL FILCLO (IFMAP, 'KEEP')
         ENDIF
      FUNSUM = FUNSUM / FLOAT(NUMXYZ)
      WRITE (8,52) FUNGR, FUNSUM
   52 FORMAT (' Largest scaled Patterson value is: ', 13X, F7.0/
     *         20X,    ' averaged value is: ', 9X, F7.0)
      RETURN
      END
      SUBROUTINE RDOUTT(ARG, FUNF)
      DIMENSION ARG(3)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ITPL,  KEYS(7))
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VDUMMY
      EQUIVALENCE (NX, NUM(1)), (NY, NUM(2)), (NXY, NUMXY)
      LOGICAL  SYMM2, SYMM3
      DIMENSION  IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)),  (IYFAR,IFAR(2)),  (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)),     (RY,RARG(2)),     (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)),      (FMY,FM(2)),      (FMZ,FM(3))
      DATA IZD,IYZD / 0, 0/
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
      CALL SYMM (RX, RY, RZ)
      IF (ITPL.EQ.2) GOTO 2000
      IF (ITPL.EQ.3) GOTO 2000
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
  555 F=T-FLOAT(I)
      IF (F) 560,590,570
  560 F=F+1.0
  570 IF (F-0.5) 590,580,580
  580 FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
  590 FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
  599 CONTINUE
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      IJX = ITAB(K111)
      FUNNER = FLOAT( IJX ) / 99.
      K211=K111-IXNEAR+IXFAR
      K121=K111+NX*(IYFAR-IYNEAR)
      K112=K111+NXY*(IZFAR-IZNEAR)
      IJX = ITAB(K211)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K121)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K112)
      FUNZ = FLOAT( IJX ) / 99.
      FUNF = FUNNER * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ
      IF (ITPL .NE. 4) GOTO 610
      FUNF = AMAX1 (FUNF, 0.25 * (FUNNER + FUNX + FUNY + FUNZ) )
      RETURN
  610 I1=IZFAR*NXY
      I2=IYFAR*NX
      K222 = I1 + I2 + IXFAR - NUMC
      K122=K222-IXFAR+IXNEAR
      K212=K222-I2+NX*IYNEAR
      K221=K222+NXY*IZNEAR-I1
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      IJX = ITAB(K122)
      FUNYZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K212)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K221)
      FUNXY = FLOAT( IJX ) / 99.
      FMXY=FMX*FMY
      FMXZ=FMX*FMZ
      FMYZ=FMY*FMZ
      FMXYZ=FMX*FMYZ
      T1=FMYZ-FMXYZ
      T2=FMXZ-FMXYZ
      FUNF = FUNF + FMXYZ*FUNFAR + T1*FUNYZ + T2*FUNXZ +
     1 (FMXY-FMXYZ)*FUNXY + FUNNER*(T1+FMXZ+FMXY) - FUNZ*(T2+FMYZ)
     1 - FUNY*(T1+FMXY) - FUNX*(T2+FMXY)
      RETURN
 2000 FUNF=-100.
      DO 713 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      I = INT(T)
      DT=I-T
      IF (T.LT.0.) THEN
        IFAR(IX)=I
        I=I-1
        IF (DT.GT.0.95) THEN
          I=I-1
        ELSE IF (DT.LT.0.05) THEN
          IFAR(IX)=IFAR(IX)+1
        ENDIF
      ELSE
        IFAR(IX)=I+1
        IF (DT.LT.-0.95) THEN
          IFAR(IX)=IFAR(IX)+1
        ELSE IF (DT.GT.-0.05) THEN
          I=I-1
        ENDIF
      ENDIF
  713 INEAR(IX)=I
      DO 720 IZ=INEAR(3),IFAR(3)
       SYMM3=IZ.LT.IS(3) .OR. IZ.GT.LXYZ(3)
       IF (.NOT.SYMM3)  IZD=NXY*IZ-NUMC
      DO 720 IY=INEAR(2),IFAR(2)
       SYMM2=SYMM3 .OR. IY.LT.IS(2) .OR. IY.GT.LXYZ(2)
       IF (.NOT.SYMM2)  IYZD=IZD+NX*IY
      DO 720 IX=INEAR(1),IFAR(1)
       IF (SYMM2 .OR. IX.LT.IS(1) .OR. IX.GT.LXYZ(1)) THEN
        RX=IX/GTXYZ(1)
        RY=IY/GTXYZ(2)
        RZ=IZ/GTXYZ(3)
        DO 715 J= 1, 3
        RARG(J) = AMOD(RARG(J),1.0)
        IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  715   IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
        CALL SYMM(RX,RY,RZ)
        I1=NINT(RX*GTXYZ(1))
        I2=NINT(RY*GTXYZ(2))
        I3=NINT(RZ*GTXYZ(3))
        IADR = NXY*I3 + NX*I2 + I1 - NUMC
        IJX = ITAB(IADR)
        FUN1 = FLOAT( IJX ) / 99.
       ELSE
        K111=IYZD+IX
        IJX = ITAB(K111)
        FUN1 = FLOAT( IJX ) / 99.
        ENDIF
       IF (FUN1.GT.FUNF) FUNF=FUN1
 720  CONTINUE
      RETURN
      END
      SUBROUTINE ASYMS (ASY)
      DIMENSION ASY(6)
      INCLUDE 'Zsyst.inc'
      DIMENSION USX(3), TSV(3,4)
      LOGICAL ASUNIT
      CHARACTER *1 ALATS(7)
      DATA ALATS /'P', 'A', 'B', 'C', 'I', 'F', 'R'/
      CALL UNITCS (USX, TSV, NT, ILATS)
      WRITE (8, FMT='(/'' Subroutine ASYMS''/
     *   '' Symmetry map, unit cell:'', 3F8.3)') USX
      WRITE (8, FMT='('' Centering:    '', A1)') ALATS(ILATS)
      WRITE (8, FMT='('' Translations: '', 4(''/'',3F4.1))')
     *   ((TSV(I,II), I=1,3), II=1, NT)
      CALL ASYMPP (ILATS, ASY, ASUNIT)
      WRITE (8,FMT='('' Asymmetric part:'',3X,3(''/'',2F8.3))') ASY
      ASY(2)=USX(1)*ASY(2)
      ASY(4)=USX(2)*ASY(4)
      ASY(6)=USX(3)*ASY(6)
      WRITE (8,FMT='('' - for symm. map:'',3X,3(''/'',2F8.3)/)') ASY
      RETURN
      END
      SUBROUTINE UNITCS (USX, TSV, NT, ILATS)
      DIMENSION USX(3), TSV(3,4)
      INCLUDE 'Zcrys.inc'
      COMMON /ORIGNS/ NOR, ORIG(3,8), IDDPOL, RVPOL(3)
      DIMENSION IFREE(3)
      CALL KERNZA (0.0, USX, 3)
      NT=1
      CALL KERNZA (0.0, TSV(1,1), 3)
      ILATS = 1
      IF (IDDPOL.EQ.3) RETURN
      CALL KERNZI (0, IFREE, 3)
      I2=2
      I3=3
      DO 101 I=1,3
      IF (IDDPOL.EQ.1) THEN
         IF(RVPOL(I).GT.0.01 .AND.
     *      RVPOL(I2).LT.0.01 .AND. RVPOL(I3).LT.0.01 ) THEN
            IFREE(I)=1
            GOTO 100
            ENDIF
      ELSE IF (IDDPOL.EQ.2) THEN
         IF( RVPOL(I).LT.0.01 .AND.
     *      (RVPOL(I2).GT.0.01 .OR. RVPOL(I3).GT.0.01) ) THEN
            IFREE(I)=1
            GOTO 100
            ENDIF
         ENDIF
 100  IF (I2.EQ.1) I3=2
      I2=1
 101  CONTINUE
      I2=2
      I3=3
      DO 210 I=1,3
      USX(I)=1.0
      IF (IFREE(I).EQ.1) USX(I)=0.0
      DO 115 LT=1,NLATT
      N1=1
      IF (LT.EQ.1) N1=2
      DO 110 N=N1,NOR
      IF ( (AMOD(ORIG(I2,N)+TLATT(I2,LT)+8.,1.0).LT.0.01  .OR.
     *     IFREE(I2).EQ.1 )  .AND.
     *     (AMOD(ORIG(I3,N)+TLATT(I3,LT)+8.,1.0).LT.0.01  .OR.
     *     IFREE(I3).EQ.1 )  )  THEN
              IF (AMOD(ORIG(I,N)+TLATT(I,LT)+8.,1.0).LT.USX(I))
     *           USX(I)=AMOD(ORIG(I,N)+TLATT(I,LT)+8.,1.0)
         ENDIF
 110  CONTINUE
 115  CONTINUE
      IF (I2.EQ.1) I3=2
      I2=1
 210  CONTINUE
      DO 315 LT=1,NLATT
      N1=1
      IF (LT.EQ.1) N1=2
      DO 310 N=N1,NOR
      NC=0
      ND=0
      NT=NT+1
      DO 305 J=1,3
      TSV(J,NT)= AMOD(ORIG(1,N)+TLATT(1,LT)+8.,1.0)
      IF (TSV(J,NT).LT.0.001) NC=NC+1
      IF (NC.GT.1) GOTO 306
      IF (USX(J).GT.0.01) THEN
         IF (TSV(J,NT).GT.USX(J)-0.0001)  GOTO 306
      ELSE
         IF (TSV(J,NT).GT.USX(J)+0.0001)  GOTO 306
         ENDIF
      DO 302 MT=1,NT-1
 302  IF (ABS(TSV(J,NT)-TSV(J,MT)).LT.0.01)  ND=ND+1
 305  CONTINUE
      IF (ND.LT.3) GOTO 310
 306  NT=NT-1
 310  CONTINUE
 315  CONTINUE
      IF (NT.EQ.1) RETURN
      IF (NT.EQ.2) THEN
         I3=0
         IF (ABS(TSV(1,2)) .LT. 0.0001) THEN
             ILATS=2
             I1=2
             I2=3
         ELSE IF (ABS(TSV(2,2)) .LT. 0.0001) THEN
             ILATS=3
             I1=1
             I2=3
         ELSE IF (ABS(TSV(3,2)) .LT. 0.0001) THEN
             ILATS=4
             I1=1
             I2=2
         ELSE
             ILATS=5
             I1=1
             I2=2
             I3=3
             ENDIF
         IF (I3.EQ.0) I3=I1
         IF (AMOD(TSV(I1,2)/USX(I1)-0.5, 1.0) .GT. 0.001) ILATS=1
         IF (AMOD(TSV(I2,2)/USX(I2)-0.5, 1.0) .GT. 0.001) ILATS=1
         IF (AMOD(TSV(I3,2)/USX(I3)-0.5, 1.0) .GT. 0.001) ILATS=1
         RETURN
         ENDIF
      IF (NT.EQ.4) THEN
         DO 420 I=1,3
         I1=I+1
         IF (I1.GT.3) I1=1
         I2=I-1
         IF (I2.LT.1) I2=3
         DO 410 N=2,NT
         IF (AMOD(TSV(I,N),1.0) .LT. 0.0001) THEN
            IF (AMOD(TSV(I1,N)/USX(I1)-0.5, 1.0) .GT. 0.001) RETURN
            IF (AMOD(TSV(I2,N)/USX(I2)-0.5, 1.0) .GT. 0.001) RETURN
            GOTO 420
            ENDIF
 410     CONTINUE
         RETURN
 420     CONTINUE
         ENDIF
      IF (NT.EQ.3) THEN
         I1=0
         DO 510 N=2,NT
         IF (I1.NE.23 .AND.
     *      AMOD(TSV(1,N)/USX(1)-0.666667, 1.0) .LT. 0.001) THEN
            IF (AMOD(TSV(2,N)/USX(2)-0.333333,1.0) .GT. 0.001) RETURN
            IF (AMOD(TSV(3,N)/USX(3)-0.333333,1.0) .GT. 0.001) RETURN
            I1=23
            GOTO 510
         ELSE IF (I1.NE.13 .AND.
     *      AMOD(TSV(1,N)/USX(1)-0.33333, 1.0) .LT. 0.001) THEN
            IF (AMOD(TSV(2,N)/USX(2)-0.666667,1.0) .GT. 0.001) RETURN
            IF (AMOD(TSV(3,N)/USX(3)-0.666667,1.0) .GT. 0.001) RETURN
            I1=13
            GOTO 510
         ENDIF
         RETURN
 510     CONTINUE
         ILATS=7
         ENDIF
      RETURN
      END
      SUBROUTINE ASYMPP (ILATS, ASY, ASUNIT)
      DIMENSION ASY(6)
      LOGICAL ASUNIT
      INCLUDE 'Zcrys.inc'
      ASUNIT = .TRUE.
      ASY(1)=0.0
      ASY(3)=0.0
      ASY(5)=0.0
      GOTO(100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,1400)
     *   ILAUE
 100  ASY(2)=0.5
      ASY(4)=1.0
      ASY(6)=1.0
      RETURN
 200  CONTINUE
      ASY(2)=0.5
      ASY(4)=0.5
      ASY(6)=1.0
      IF (IUNIQ.EQ.2 .AND.(ILATS.EQ.2 .OR. ILATS.EQ.4 .OR. ILATS.EQ.5))
     *   ASY(4)=0.25
      IF (IUNIQ.EQ.3) THEN
         ASY(2)=1.0
         ASY(6)=0.5
         IF (ILATS.EQ.2 .OR. ILATS.EQ.3 .OR. ILATS.EQ.5)  ASY(6)=0.25
      ELSEIF (IUNIQ.EQ.1) THEN
         ASY(4)=1.0
         ASY(6)=0.5
         ENDIF
      RETURN
 300  CONTINUE
 400  CONTINUE
 500  ASY(2)=0.5
      ASY(4)=0.5
      ASY(6)=0.5
      IF (ILAUE .GE. 4) THEN
         IF (ILATS .EQ. 5)  ASY(6)=0.25
         GOTO 1220
      ELSE
         IF (ILATS.EQ.4 .OR. ILATS.EQ.5 .OR. ILATS.EQ.6)  ASY(2)=0.25
         IF (ILATS.EQ.6)  ASY(4)=0.25
         ENDIF
      RETURN
 600  CONTINUE
 700  CONTINUE
      ASY(2)=1.0
      ASY(4)=1.0
      ASY(6)=0.5
      GOTO 1220
 800  ASY(2)=2./3.
      IF (ILATS.EQ.7) GOTO 1110
      ASY(4)=2./3.
      ASY(6)=0.5
      GOTO 1220
 900  ASY(2)=2./3.
      IF (ILATS.EQ.7) GOTO 1110
      ASY(4)=1./3.
      ASY(6)=1.0
      GOTO 1220
 1000 CONTINUE
 1100 ASY(2)=2./3.
      IF (ILATS.EQ.7) GOTO 1110
      ASY(4)=0.5
      ASY(6)=0.5
      GOTO  1220
 1110 ASY(4)=2./3.
      ASY(6)=1./6.
      GOTO  1220
 1200 ASY(2)=2./3.
      ASY(4)=1./3.
      ASY(6)=0.5
 1220 ASUNIT = IUNIQ.EQ.3
      IF (.NOT. ASUNIT)  GOTO 100
      RETURN
 1300 CONTINUE
 1400 ASY(2)=0.5
      ASY(4)=0.5
      ASY(6)=0.5
      IF (ILATS.EQ.6) ASY(6)=0.25
      IF (ILATS.EQ.6 .AND. ILAUE.EQ.14)  ASY(4)=0.25
      IF (ILATS.EQ.5 .AND. ILAUE.EQ.14)  ASY(6)=0.25
      RETURN
      END
      FUNCTION NQSET (RSET, N)
      DIMENSION RSET(N)
      NQSET=0
      DO 110 M=1,N
      JC=NINT(RSET(M))
      IF (JC.GT.10)  JC=10*JC
      IF (JC.GT.100) JC=100*JC
 110  NQSET = NQSET + JC
      RETURN
      END
      SUBROUTINE XHELIV (X,NHX, ASVXX,NASV, AMINHL, UX, NUX)
      PARAMETER  (MXPKS=150, MXHH=16, MXPP=128, MXUX=MXPP/4)
      DIMENSION X(3,NHX), ASVXX(5,NASV), UX(MXHH+6,MXUX)
      INCLUDE 'Zcrys.inc'
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATPKS/ VP(4,MXPP), NVPS, SC2DEK, PATADD
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT,AMI1,AMI2,PLIM,PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MXVHL=8*MXUX)
      DIMENSION V(5,4*MXPKS+1),VVP(MXPKS), VVP1(MXPKS),
     *    R1(3), UUX(MXHH+6), INDX(MXUX), INDXV(MXVHL),
     *    VEQ(3,48), R1EQ(3,MXHH), VML(3,4)
      LOGICAL PATSYM,TLATTI, L2L, FIRST, PATSR1
      DATA DMAX,DMAXP,PLIMHL,P1,NEQV,NV,LL,NUXM /0.8,0.2,.0,.0,1,0,0,0/
      DATA SUMIW /0.0/
      DATA PATSR1,PATSYM,TLATTI,FIRST /.FALSE.,.TRUE.,.FALSE.,.TRUE./
      NUX=0
      AMINHL=0.0
      NX=NHX/NLATT
      IF (NHEAVY.GT.2)                                   GOTO 2000
      IF (LTHEAV.EQ.NELMS)                               GOTO 2000
      IF (LTHEAV.NE.LTHV .OR. NHX.LT.NINT(HEAVYN*IMULT)) GOTO 2000
      IF (NX.LE.1 .OR. NX.GT.MXHH .OR. NVPS.LE.0)        GOTO 2000
      IF (0.7*NCELLZ(1)**2 .GT. NCELLZ(LTHV)**2)         GOTO 2000
      L2L = NHX.LT.IMULT
      ISQ=MXHH+6
      NDIM1=ISQ
      NP=NVPS
      IF (FIRST) THEN
         FIRST=.FALSE.
         CALL KERNZA (0., UUX, NDIM1)
         IF (ABS(SC2DEK-1.).GT.0.0001) THEN
            DO 100 N=2,NVPS
 100        VP(4,N)=SC2DEK*VP(4,N) + PATADD
            SC2DEK=1.0
            ENDIF
         DO 110  L=LTHEAV+1,NELMS
         IF (0.7*NCELLZ(LTHEAV+1) .LT. NCELLZ(L)) THEN
            LL=L
            NUXM=NUXM+NCELTY(L)
            ENDIF
 110      CONTINUE
       NUXM=NUXM/NLATT
       IF (NUXM.GT.MXVHL) NUXM=MXVHL
       NUXM=NUXM/(NSYMM*ICENT)
       IF (NUXM.GT.MXUX) NUXM=MXUX
       PLIMHL=(PLIMC(LTHEAV,LL)-PATAD)*ICENT
       NV=0
       NVQ=4*MXPKS
       NEQV=1
       DO 150 M=2,NP
       IF (VP(4,M).LT.PLIMHL+PATAD)  GOTO 140
       CALL ALLEQP (VP(1,M), VEQ, 48, PATSYM,TLATTI, NEQV)
       NVQ=NVQ-NEQV
       DO 130 N=1,NEQV
       NV=NV+1
       V(5,NV)=0.001
       CALL KERNAB (VEQ(1,N),V(1,NV),3)
 121   IF (V(1,NV).GT. 0.00001) GOTO 130
        V(1,NV)=V(1,NV)+1.0
        GOTO 121
 130   V(4,NV)=M+0.01
 140   IF (M.EQ.NP .OR. NVQ.LT.NEQV) THEN
          CALL DELIP2 (V, NV, VVP1, NP, DMAXP)
          NVQ=4*MXPKS-NV
          IF (NVQ.LT.NEQV) GOTO 160
       ENDIF
 150   CONTINUE
 160   V(4,NV+1)=0.001
       VVP1(1)=1.0
       DO 170 M=1,NP
 170   VVP1(M)=VVP1(M)/NEQV
       ISUMH=0
       IH=0
       DO 180 I=1,LTHV
       ICELH=NCELTY(I)/NLATT
       IF (IH+ICELH.GT.NX) ICELH=NX-IH
       IF (ICELH.EQ.0) GOTO 185
       IH=IH+ICELH
       ISUMH = ISUMH + ICELH*NCELLZ(I)
 180   CONTINUE
 185   ILMAX=(NV*ICENT)/IH
       IF (ILMAX.GT.NUXM*ICENT*NSYMM) ILMAX=NUXM*ICENT*NSYMM
       IL=NX-IH
       ISUML=IL*NCELLZ(LTHV)
       DO 190 I=LTHV+1,LL
       ICELL=NCELTY(I)/NLATT
       IF (IL+ICELL.GT.ILMAX) ICELL=ILMAX-IL
       IF (ICELL.EQ.0) GOTO 195
       IL=IL+ICELL
 190   ISUML=ISUML+ (ICELL * NCELLZ(I))
 195   SUMIW=ISUML*ISUMH
      ENDIF
      DO 210 M=1,NP
 210  VVP(M)=(VP(4,M)-PATADD)*VVP1(M)
      PHT= ICENT*(PLIMC(LTHV,LTHV)-PATAD)
      DO 240 NA=1,NASV
      DO 230 N =1,NV
      M=V(4,N)
      IF (VVP(M).LT.PLIMHL) GOTO 230
      IF (ISELFD(V(1,N),ASVXX(1,NA),DMAXP) .EQ. 1)  THEN
         PH=ASVXX(5,NA)*VVP1(M)
         IF (PH.GT.PHT) PH=PHT
         VVP(M)=VVP(M)-PH
         GOTO 240
      ENDIF
 230  CONTINUE
 240  CONTINUE
      L2L=L2L .OR. NCELLZ(LL).GE.20
      NHIGV=0
      DO 310 N=1,NV
      I=V(4,N)
      V(5,N)=-100.
      IF (VVP(I).GT.PLIMHL) THEN
        CALL VMINV(X(1,1),V(1,N),R1,3)
        PR1=SMINF(R1,X,NX,1,0)-PATAD
        IF (L2L) THEN
         SPM= SSMINF (R1,0,.TRUE.,NEMIN)
         SPM=((SPM-PATAD) * NCELLZ(1)) / NCELLZ(LL)
         PR1=AMIN1(PR1,SPM)
        ENDIF
        V(5,N)=PR1
        IF (V(5,N).GT.0.3*PLIMHL .AND. NHIGV.LT.MXUX) NHIGV=NHIGV+1
      ENDIF
 310  CONTINUE
      IF (NHIGV.EQ.0) GOTO 2000
      ISQV=5
      CALL DETSEQ (INDXV, NHIGV, V, 5, NV, ISQV, 0)
      NV1=NHIGV
      DO 710 IN=1,NV1
      N=INDXV(IN)
      I=V(4,N)
      IF (V(1,N).GT.0.0) THEN
        CALL VMINV(X(1,1),V(1,N),R1,3)
        PR1=V(5,N)
        UUX(1)=N+0.1
        UUX(ISQ)=-100.
        NOV2R1=0
        DO 530 M=2,NX
        CALL VMINV(X(1,M),R1,VML(1,1),3)
        DO 510 L=2,NLATT
 510    CALL VPLUSV(VML(1,1),TLATT(1,L),VML(1,L),3)
          DO 520 K=1,NV
          KI=V(4,K)
          IF (VVP(KI).GT.PLIMHL) THEN
            DO 515 L=1,NLATT
            IF (ISELFD(V(1,K),VML(1,L),DMAX) .EQ. 1) THEN
              UUX(M)=K+0.1
              GOTO 530
            ENDIF
 515        CONTINUE
          ENDIF
 520      CONTINUE
          UUX(M)=0.1
          NOV2R1=NOV2R1+1
          IF (PR1.LT.PLIMHL .OR. FLOAT(NOV2R1)/NX .GT. 0.15) GOTO 701
 530    CONTINUE
        UUX(ISQ-1)=30254.
        PMIN=UUX(ISQ-1)
        DO 550 M=1,NX
        NI=UUX(M)
        IF (NI.EQ.0) GOTO 550
        NI=V(4,NI)
        IF (PMIN.GT.VVP(NI)) PMIN=VVP(NI)
 550    CONTINUE
        IF (PMIN.LT.PR1) PMIN=PR1
        PMIN = ((NX-NOV2R1)*PMIN + NOV2R1*PR1)/NX
        IF (PMIN.LT.PLIMHL) GOTO 701
        UUX(ISQ)=PMIN
        CALL ALLEQP (R1, R1EQ, MXHH, PATSR1, TLATTI, NEQR)
        DO 630 I=1,NEQR
        DO 590 J=1,3
        R1EQ(J,I)=R1EQ(J,I)-ANINT(R1EQ(J,I))
 590    IF (R1EQ(J,I).LT.0.0) R1EQ(J,I)=R1EQ(J,I)+1.0
        IF (I.NE.1) THEN
         DO 595 J=1,3
         IF (R1(J).LT.R1EQ(J,I)-0.0000001) GOTO 597
         IF (R1(J) .GT. R1EQ(J,I)+0.0000001) GOTO 596
 595     CONTINUE
        ENDIF
 596    CALL KERNAB(R1EQ(1,I),R1,3)
 597    IF (I.EQ.1) GOTO 630
        CALL VMINV (X(1,1), R1EQ(1,I), VML(1,1), 3)
        DO 602 L=2,NLATT
 602    CALL VPLUSV(VML(1,1),TLATT(1,L),VML(1,L),3)
        DO 610 IK=IN+1,NV1
        K=INDXV(IK)
        IF (V(1,K).LT.0.0) GOTO 610
        DO 603 L=1,NLATT
        IF (ISELFD(V(1,K),VML(1,L),DMAX) .EQ. 1) THEN
 601      IF (V(1,K).LT.0.0) GOTO 610
          V(1,K)=V(1,K)-1.0
          GOTO 601
        ENDIF
 603    CONTINUE
 610    CONTINUE
 630    CONTINUE
        CALL KERNAB (R1, UUX(MXHH+1), 3)
        UUX(ISQ-2)=PR1
        IF (UUX(ISQ).GT.PLIMHL)
     *      CALL EL2AR2 (UUX, NDIM1, ISQ, UX,MXUX, NUX, INDX)
      ENDIF
 701  IF (V(1,N).GT. 0.00001) GOTO 710
        V(1,N)=V(1,N)+1.0
        GOTO 701
 710  CONTINUE
      IF (NUX.EQ.0) GOTO 2000
      SUM=0.0
      IF (NUX.GT.NUXM) NUX=NUXM
      DO 930 IJ=1,NUX
      J=INDX(IJ)
      PMINJ= UX(ISQ,J)
      DO 920 I=1,NX
      M=UX(I,J)
      IF (M.EQ.0) GOTO 920
      M=V(4,M)
      P1=AMAX1(VVP(M),0.0)
      IF (PMINJ.LT.P1) P1=PMINJ
      VVP(M)=VVP(M)-PMINJ
      SUM=SUM+P1
 920  CONTINUE
 930  CONTINUE
      SUM=(IMULT*SUM)/(NLATT*SCPAT)
      IF (ICENT.EQ.1) SUM=2.0*SUM
      AMINHL = SUM/SUMIW
 2000 CONTINUE
      IF (AMINHL.LT.0.0001) AMINHL=0.0001
      RETURN
      END
      SUBROUTINE DELIP2 (V, NV, VVP, NAV, DMAX)
      DIMENSION V(5,NV), VVP(NAV)
      CALL KERNZA(0.0, VVP, NAV)
      N11=1
      M2=V(4,1)
      VVP(M2)=VVP(M2)+1.0
      DO 410 N2= 2, NV
      M2=V(4,N2)
      DO 210 N1= 1, N11
      M1=V(4,N1)
      IF (M1.NE.M2) GOTO 210
      IF (ISELFD (V(1,N2), V(1,N1), DMAX) .EQ. 1) THEN
         GOTO 410
      ENDIF
 210  CONTINUE
      N11 = N11+1
      CALL KERNAB (V(1,N2), V(1,N11), 5)
      VVP(M2)=VVP(M2)+1.0
 410  CONTINUE
      NV=N11
      RETURN
      END
      SUBROUTINE FRALIM (F1,F2,IFPL, FRAC)
      PARAMETER (MXPKS=150, NMAXP2=(MXPKS*MXPKS+MXPKS)/2 )
      INCLUDE 'Zsyst.inc'
      COMMON /CROS2/ IP2LST, NPCT, P1X2(NMAXP2)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      DIMENSION FPT(10), IPT(10)
      FRAC=0.0
      L=LTHV
      NCO=NCONS
      IF (NCO.LE.1) RETURN
      IFPLL=IFPL
      DF = (F2-F1)/8.0
      NCRH=(NCO*NCO-NCO)/2
      PT = SCPAT * NCELLZ(L)**2
      F=F1-DF
      FPT(1)=0.0
      DO 110 N=2,10
      F=F+DF
 110  FPT(N) = F*PT + PATAD
      CALL KERNZI(0,IPT,10)
      DO 230 J=1,NPCT-1
      DO 220 I=J+1,NPCT
      IJ=IPOIN1(I,J,NPCT)
      DO 210 N=1,10
      IF (P1X2(IJ).LT.FPT(N)) GOTO 220
 210  IPT(N)=IPT(N)+1
 220  CONTINUE
 230  CONTINUE
      IF (IPT(2).LT.NCRH)  RETURN
      FRAC=F1
      IF (IFPLL.GT.IPT(2)) GOTO 400
      F=F1
      DO 310 N=3,10
      IF (IPT(N).LT.IFPLL) THEN
        FRAC=F + (DF*(IPT(N-1)-IFPLL))/(IPT(N-1)-IPT(N))
        IF (FRAC.GT.F2) FRAC=F2
        IF (FRAC.LT.F1) FRAC=F1
        GOTO 400
      ENDIF
      F=F+DF
 310  CONTINUE
      FRAC=F2
 400  CONTINUE
      WRITE (8, FMT='(''       F      FPT      IPT'')')
      F=0.0
      DO 240 N=1,10
      WRITE (8, FMT='(F10.3, F10.3, I10)')  F, FPT(N), IPT(N)
      IF (N.EQ.1) F=F1-DF
 240  F=F+DF
      WRITE (8, FMT='(''       NCRH     IFPL   '')')
      WRITE (8, FMT='(I10, I10)')  NCRH, IFPL
      WRITE (8, FMT='(''       F1       F2      FRAC  '')')
      WRITE (8, FMT='(F10.3, F10.3, F10.3)')  F1, F2, FRAC
      RETURN
      END
      SUBROUTINE VECCHL (X, NX, NPMAX, CONTHL)
      DIMENSION X(5,NX)
      COMMON /PATDAT/ SCADEK,PATAD, SCPAT, AMI1, AMI2, PLIM, PATP(8),
     *                PLIMS(10),PLIMC(10,10)
      PARAMETER (MAXASV=3600, MXHEAV=20, MXNUP=48*MXHEAV*4,
     *           MXHH=16, MXPP=128, MXUX=MXPP/4)
      COMMON /MOVECS/ XCELL(3,MXNUP),NPCELL, NAXCEL(MXNUP),
     *                ASVECT(5,MAXASV),NASV
      DIMENSION UX(MXHH+6,MXUX)
      CALL VECCAP (X, NX, ASVECT, NASV, XCELL, NPCELL, NAXCEL)
      DO 110 NV = 1, NASV
      CALL GRDOUT (ASVECT(1,NV), FUNF)
      ASVECT(5,NV) = FUNF-PATAD
 110  CONTINUE
      CONTHL=0.0
      IF (NPCELL.LE.NPMAX)
     * CALL XHELIV(XCELL,NPCELL,ASVECT,NASV,CONTHL, UX, NUX)
      RETURN
      END
      SUBROUTINE DISCAB(XZ,NSTSXZ, NPMAX)
      PARAMETER (MXHEAV=20, MXSTSX=30, IXZ=5*MXHEAV+5, MXINXZ=MXSTSX)
      DIMENSION XZ(IXZ,MXSTSX), INXZ(MXINXZ)
      COMMON /ELEMA/ NCELTY(10),NCELSP(10), NCELLZ(10), NELMS, LTHEAV,
     * NHEAVY,HEAVYN, DH1H2, NASYMP(10),NCONST(10),NCONS,NCONS1,LT1,LTHV
      LOGICAL M1DONE
      DATA FOM1, NH1 /0.0, 0/
      IF (NSTSXZ.LE.0)  RETURN
      IF (NHEAVY.GT.2)  RETURN
      IHL =5*MXHEAV-2
      IFOM=5*MXHEAV+3
      ISW =5*MXHEAV
      M1DONE=.FALSE.
      LTHVV=LTHV
      DO 310 N=1,NSTSXZ
      NH=XZ(5*MXHEAV+1,N)
      ATOMS=0.0
      DO 110  J=1,NH
 110  ATOMS=ATOMS+XZ(5*J-1,N)
      IF (N.EQ.1) THEN
        IF (ATOMS.LT.HEAVYN-0.01) RETURN
        IF (XZ(IHL,1).GT. 0.00005)    RETURN
        LTHV=LTHEAV
        FOM1=XZ(IFOM,1)
        NH1=NH
      ELSE
        FOM = XZ(IFOM,N)
        IF (FOM.GT.0.8*FOM1 .AND. ATOMS.GT.HEAVYN-0.01 .AND.
     *                                 XZ(IHL,N).LT. 0.00005)  THEN
 211      IF (M1DONE) THEN
              M=N
              MH=NH
          ELSE
              M=1
              MH=NH1
              ENDIF
          CALL VECCHL (XZ(1,M), MH, NPMAX, CONTHL)
          IF (M.EQ.1 .AND. CONTHL.LT. 0.00005) GOTO 410
          XZ(IHL,M)=CONTHL
          XZ(IFOM,M)=XZ(IFOM,M)+CONTHL*0.5*XZ(ISW,M)
          M1DONE=.TRUE.
          IF (M.EQ.1) GOTO 211
        ENDIF
      ENDIF
 310  CONTINUE
      NHIGXZ=NSTSXZ
      CALL DETSEQ(INXZ,NHIGXZ, XZ, IXZ, NSTSXZ, IFOM, 0)
      CALL SORTIN(INXZ,MXINXZ, NSTSXZ, XZ, 5*MXHEAV+5, MXSTSX)
 410  LTHV=LTHVV
      RETURN
      END
      SUBROUTINE SYSRCH(X,IP,N,XX,NX)
      PARAMETER (MXHEAV=20)
      DIMENSION X(IP,MXHEAV), XX(4,MXHEAV)
      INCLUDE 'Zcrys.inc'
      DIMENSION AA(3),A(3), S(3), AVS(3), DMAX(3), X2(3), X1(3,MXHEAV),
     *      KSEQ(MXHEAV), ISEQ(MXHEAV), LA(MXHEAV), RSYMM2(3),TSYMM2(3)
      DATA  DMAX, DMAXA / 0.02, 0.02, 0.02, 0.35/
      NEQMAX=0
      IF (NSYMM.EQ.1 .AND. ICENT.EQ.1) THEN
         DO 105 I=1,N
         CALL KERNAB(X(1,I),XX(1,I),3)
         XX(4,I)=1.0
 105     CONTINUE
         NX=N
         RETURN
      ENDIF
      IF (ICENT.EQ.2) THEN
        DO 106 K=1,3
        RSYMM2(K)=-1.
 106    TSYMM2(K)=0.0
      ELSE
        DO 107 K=1,3
        RSYMM2(K)=IRSYMM(K,K,2)
 107    TSYMM2(K)=TSYMM(K,2)
      ENDIF
      DO 610 I=1,N
      MXNEQ= N-I+1
      IF (MXNEQ.LE.NEQMAX) RETURN
      DO 520 L=1,NLATT
      DO 110 K=1,3
 110  AA(K)=RSYMM2(K) * X(K,I) + TSYMM2(K) + TLATT(K,L)
      DO 510 J=I,N
      DO 210 K=1,3
      A(K)=AA(K)-X(K,J)
      IF (ABS(1.-RSYMM2(K)) .GT. 0.001) THEN
         S(K)=A(K)/(1.-RSYMM2(K))
      ELSE
         IF (ABS(AMOD(A(K),1.0)) .GT. DMAX(K)) GOTO 510
         S(K)=0.0
      ENDIF
 210  CONTINUE
      DO 310 M=I,N
      DO 310 K=1,3
 310  X1(K,M) = X(K,M)+S(K)
      CALL KERNZI (0, KSEQ,N)
      CALL KERNZI (1, LA,N)
      LA(I)=L
      KSEQ(I)=J
      NEQ=1
      KSEQ(J)=I
      IF (J.NE.I) NEQ=NEQ+1
      DO 410 I1=I+1,N
      DO 405 L1=1,NLATT
      IF (KSEQ(I1).NE.0)  GOTO 410
      DO 320 K=1,3
 320  X2(K)=RSYMM2(K) * X1(K,I1) + TSYMM2(K) + TLATT(K,L1)
      DO 400 J1=I1,N
      IF (KSEQ(J1).NE.0)  GOTO 400
      IF (ISELFD(X1(1,J1), X2, DMAXA) .NE. 1)  GOTO 400
      LA(I1)=L1
      KSEQ(J1)=I1
      NEQ=NEQ+1
      KSEQ(I1)=J1
      IF (J1.NE.I1) NEQ=NEQ+1
      GOTO 410
 400  CONTINUE
 405  CONTINUE
 410  CONTINUE
      IF (NEQ.LE.NEQMAX) GOTO 510
        NEQMAX=NEQ
        CALL KERNAI (KSEQ,ISEQ,N)
        NSUM=0
        AVS(1)=0.0
        AVS(2)=0.0
        AVS(3)=0.0
        DO 440 I1=I,N
        IF (KSEQ(I1).EQ.0) GOTO 440
        L1 = LA(I1)
        J1 = KSEQ(I1)
        DO 430 K=1,3
        A(K)=RSYMM2(K)*X1(K,I1)+TSYMM2(K)+TLATT(K,L1) - X1(K,J1)
        IF (ABS(1.-RSYMM2(K)) .GT. 0.001) THEN
            S(K)=A(K)/(1.-RSYMM2(K))
        ELSE
            S(K)=0.0
        ENDIF
        AVS(K)=AVS(K)+S(K)
 430    CONTINUE
        NSUM=NSUM+1
        KSEQ(I1)=0
        KSEQ(J1)=0
 440    CONTINUE
        DO 445 K=1,3
 445    AVS(K)=AVS(K)/NSUM
      NX=0
      DO 480 I1=I,N
      IF (ISEQ(I1).EQ.0) GOTO 480
      NX=NX+1
      J1=ISEQ(I1)
      L1=LA(I1)
      DO 450 K=1,3
      IF (I1.NE.J1) X1(K,I1) = X1(K,I1)+AVS(K)
 450                X1(K,J1) = X1(K,J1)+AVS(K)
      DO 460 K=1,3
      X2(K)=RSYMM2(K) * X1(K,I1) + TSYMM2(K) + TLATT(K,L1)
      X2(K)=X2(K)-NINT(X2(K)-X1(K,J1))
      X2(K)=X2(K)+X1(K,J1)
      X2(K)=X2(K)/2.
      XX(K,NX)=X2(K)
 460  CONTINUE
      XX(4,NX)=1.0
      IF (I1.EQ.J1) XX(4,NX)=0.5
      ISEQ(I1)=0
      ISEQ(J1)=0
 480  CONTINUE
 510  CONTINUE
 520  CONTINUE
 610  CONTINUE
      RETURN
      END
      SUBROUTINE SYMPRI
      INCLUDE 'Zsyst.inc'
      COMMON /SYMDEK/ NXYZS(3), ISS(3), NUMS(3), NUSXY, NUSXYZ, NUMSC
     *      ,GTXYZS(3), LXYZS(3), FSTPSY(3)
      COMMON /DEKDAT/ NXYZ(3), IS(3), NUM(3), NUMXY, NUMXYZ, NUMC,
     *      GTXYZ(3), LXYZ(3), VDUMMY
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      DIMENSION FLINE(100)
      WRITE (8, FMT='(''NUM , NUMS'', 3I5,3X, 3I5/)') NUM, NUMS
      DO 333 JZ = ISS(3), NUMS(3)
      WRITE (8, FMT='(/''JZ='', I5, '' ---------------------''/)') JZ
      DO 222 JY = ISS(2), NUMS(2)
      WRITE (8, FMT='(''JZ, JY, JX = '',3I5,'' ....'')') JZ,JY,ISS(1)
      L = 0
      DO 111 JX = ISS(1), NUMS(1)
         IADR = NUSXY * JZ + NUMS(1) * JY + JX - NUMSC
         IJX = ITAB(IADR)
         FUNF = FLOAT( IJX ) / 99.
      L = L + 1
      FLINE(L) = FUNF
 111  CONTINUE
      WRITE (8, FMT='( 10F7.1)') (FLINE(LL), LL=1,L)
 222  CONTINUE
 333  CONTINUE
      RETURN
      END
      SUBROUTINE ORIENT
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IMFUN, IFILE(13)), (IPDEK, IFILE(14))
      EQUIVALENCE (NRUNS, KEYS(4)), (NRUN, KEYS(5))
      EQUIVALENCE (MFLEX, KSTAT(10)), (IFLEX, KSTAT(12))
      CALL KEPROG ('ORIENT')
      CALL KERASE ('ATORI')
      CALL KERASE ('ATTRA')
      CALL KERASE ('ATVEC')
      CALL ORVIN (MPARIN)
  100 CALL READAT
      IF (KEYS(1) .EQ. -1 .OR. KEYS(1) .GE. 5) THEN
         MFLEX = IFLEX
         GOTO 300
         ENDIF
      IFLEX = IFLEX + 1
      NRUNS = 0
      NRUN = 0
      CALL ORVEC
      CALL ORDEK
      CALL MORV
      CALL MAPSIG
      IF (MPARIN.GT.0) GOTO 200
      CALL REGION
      CALL MORV
      CALL MAPSIG
  200 CALL SIGSEL (DELC)
      IF (DELC .LT. 0.35) GOTO 222
      DO 220 I = 1,2
      CALL MORV
      CALL MAPSIG
      CALL SIGSEL (DELC)
      IF (DELC .LT. 0.35) GOTO 222
  220 CONTINUE
  222 CALL EULOUT
      CALL WR24
      WRITE (8, 224)
  224 FORMAT (1X/1X/' --------------------------------')
      WRITE (9, 225) IFLEX, MFLEX
  225 FORMAT (' Model', I4, ' (out of', I4, ') completed')
      CALL WR24
      WRITE (8, 226)
  226 FORMAT (' --------------------------------'/1X)
      IF (IFLEX .LT. MFLEX) GOTO 100
  300 CONTINUE
      CALL FILCLO (IMFUN, 'DELETE')
      CALL KEPROX
      RETURN
      END
      SUBROUTINE ORVIN (MPARIX)
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ICRYS, IFILE(3)),  (ICON,  IFILE(4))
      EQUIVALENCE (KLAUE, KEYS(6)) ,  (IPRPAT,  KEYS(8))
      EQUIVALENCE (IPRDEK,  KEYS(9)), (IPRSIG,  KEYS(10))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      CHARACTER *6 PRIMAP(3)
      PARAMETER (LITAM = 7)
      CHARACTER *6 LITA(LITAM)
      DATA LITA   /'ORIENT',  'VMAX',  'PARAMS',  'MIN',  '$PTB$',
     *             'PRIMAP',  ' ' /
      DATA PRIMAP / 'PATIN', 'DEK', 'MAPSIG' /
      D2R = ATAN(1.0) / 45.0
      FVMIN = -1.
      KWVLEN = 0
      MPAR = 0
      DELC = 0.
      MININ = 0
      NCONIN = 0
      CALL KERNZI (0, MM, 3)
      CALL KERNZI (0, MINM, 3)
      CALL KERNZI (0, MIN4, 4)
      CALL RDCRYS (ICRYS)
      GOTO
     * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE
  101 KLAUE = 1
      GOTO 177
  102 IF (IUNIQ .EQ. 1) GOTO 101
      IF (IUNIQ .EQ. 3) GOTO 104
      KLAUE = 2
      GOTO 177
  103 KLAUE = 3
      GOTO 177
  104 KLAUE = 4
  177 CALL RDCOND (ICON, LITA, LITAM, KEND)
      IF (KEND .EQ. -1) THEN
         write(24, FMT='('' No CONDA file: default run'')')
         GOTO 910
         ENDIF
      IF (KEND .EQ. 0) GOTO 900
      NCONIN = NCONIN + 1
      IF (NCONIN .EQ. 2) write(24, FMT='('' CONDA control data:'')')
      GOTO (177, 200, 300, 400, 177, 600, 177), KEND
  200 VMAXIN = FNUM(1)
      IF (VMAXIN.LE.0.0 .AND. NFNUM.GT.1) GOTO 202
      write(24, FMT ='( '' VMAX input ='', F7.2)' ) VMAXIN
      IF (VMAXIN .LT. 1.1) CALL KERROR (' Error: No value for VMAX ',
     * -1, ' ORVIN' )
  202 IF (NFNUM .GT. 1) THEN
         KWVLEN = NINT(FNUM(2))
         IF (KWVLEN .EQ. 1) write(24, FMT='(
     *      '' Sorting of vectors on Weight * SQRT(Vector-length)'')')
         IF (KWVLEN .GT. 1) write(24, FMT='(
     *      '' Sorting of vectors on Weight * Vector-length'')')
         ENDIF
      GOTO 177
  300 MPAR = MPAR + 1
      IF (MPAR .EQ. 1) write(24, FMT='('' Set nr.  '',
     *   ''   Abeg  Ainc Nr.     Bbeg  Binc Nr.     Cbeg  Cinc Nr.'')')
      I =0
      DO 310 J=1,3
      PAR1(J,MPAR) = FNUM(I+1)
      PAR2(J,MPAR) = FNUM(I+2)
      NPAR(J,MPAR) = NINT(FNUM(I+3))
      IF (NPAR(J,MPAR).LE.0) GOTO 800
  310 I = I + 3
      write(24,312) MPAR,
     *   (PAR1(J,MPAR), PAR2(J,MPAR), NPAR(J,MPAR), J=1,3)
  312 FORMAT (' Set', I3, 3(F10.1, F6.1, I3))
      IF (NFNUM .NE . 9) GOTO 800
      DO 314 J=1,3
      IF (NPAR(J,MPAR).LE.0) GOTO 800
      IF (NPAR(J,MPAR).GT.1 .AND. PAR2(J,MPAR).LT.0.01) GOTO 800
  314 CONTINUE
      DELC = DELC + PAR2(3,MPAR)
      GOTO 177
  400 IF (NFNUM .EQ. 4) GOTO 440
      IF (FNUM(1).GT.0.05 .AND. FNUM(1).LT.0.95) GOTO 460
      CALL KERF2I (FNUM, MINM, 3)
      write(24, FMT =
     * '('' MIN values: M = '' , 6I3)' ) (MINM(I), I =1,NFNUM)
      IF (NFNUM.GT.3 .OR. NFNUM.LT.1) GOTO 800
      IF (NFNUM.EQ.1 .AND. MINM(1).LE.0) GOTO 800
      IF (NFNUM.EQ.2 .AND. MINM(2).LE.MINM(1)) GOTO 800
      IF (NFNUM.EQ.3 .AND. MINM(3).LE.MINM(2)) GOTO 800
      MININ = NFNUM
      GOTO 177
  440 CALL KERF2I (FNUM, MIN4, 4)
      IF (MIN4(1).LE.0 .OR. MIN4(2).LT.MIN4(1) .OR.
     *    MIN4(3).LT.MIN4(2) .OR. MIN4(4).LT.MIN4(3) )
     *    CALL KERROR('Incorrect MIN - parameters...', 440, 'ORVIN')
      GOTO 177
  460 FVMIN = FNUM(1)
      GOTO 177
  600 CONTINUE
      DO 610 I = 2, NLIT
      CALL KEREQ6 (LIT(I), PRIMAP, 3, LEND)
      GOTO (601, 602, 603), LEND
      WRITE (9, FMT='('' Incorrect PRIMAP parameters '')')
      GOTO 800
  601 IPRPAT = 8
      GOTO 610
  602 IPRDEK = 8
      GOTO 610
  603 IPRSIG = 8
  610 CONTINUE
      WRITE (24, FMT='('' Print'', A66)') CHIN(7:72)
      GOTO 177
  800 CALL KERROR (' Input for ORIENT not correct ', -6 ,'ORVIN')
  900 IF (MPAR .GT. 0) DELC = AMIN1 (10., DELC / FLOAT(MPAR))
  910 IF (DELC .LT. 0.1) DELC=10.
      IF (MPAR .GT. 0) write(24, FMT='(
     *   '' Starting value of DELC (aver. increment C):'',F6.2)') DELC
      CALL FILCLO (ICON, 'KEEP')
      MPARIN = MPAR
      MPARIX = MPAR
      RETURN
      END
      SUBROUTINE READAT
       INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IATMOD, IFILE(2))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI,  SWITCH(10))
      INCLUDE 'Zatomx.inc'
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DATA NCALL / 0 /
      IF (NCALL .NE. 0) GOTO 100
      NCALL = NCALL + 1
      CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('Error on file ATMOD', -1,'READAT')
  100 CONTINUE
      READ (IATMOD, FMT='(A80)') CHIN
      IF (CHIN.EQ.' ') GOTO 100
      BACKSPACE IATMOD
      CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      IF (NAT .LE. 1) CALL KERROR ('Only one atom' , -1, 'READAT')
      CMAX = 360.
      ISM = 0
      IF (LIT(NLIT) .EQ. 'SYMX') ISM = NINT(FNUM(NFNUM))
      IF (ISM .GE. 2) CMAX = CMAX / FLOAT(ISM)
      WRITE (24, 406)
  406 FORMAT (' Starting Cartesian coordinates for rotation search'/
     *        ' (model with angles A B C = 0 0 0  from file ATMOD)'/
     *        '   Nr  atomnm',5X,'x',7X,'y',7X,'z      Z(At.nr.)' )
      DO 420 I = 1,NAT
      ATXYZ(4,I) = FLOAT(IZAT(I))
      WRITE (24, 410) I, ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I)
  410 FORMAT (I5, 2X, A6, 3F8.3, I5)
  420 CONTINUE
      CALL WR24
      RETURN
      END
      SUBROUTINE ORVEC
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (LDPU,  IFILE(2))
      LOGICAL NIJM, SWPRI
      EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(10))
      INCLUDE 'Zatomx.inc'
      PARAMETER (MAXVE = 2000)
      COMMON /XKLADX/
     *             VEX(MAXVE), VEY(MAXVE), VEZ(MAXVE),   VLEN(MAXVE),
     *             WI(MAXVE),  W(MAXVE),   KFLAG(MAXVE), IW(MAXVE)
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      PARAMETER (VVMAX = 12.)
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      COMMON /SINGP/ SINGPK, ORIGIN, PATP(8)
      DATA IMAX2 / 0 /
      DATA NCALL / 0 /
      WRITE (8, 110)
  110 FORMAT (/' ORVEC: Generate, weight and select vectors')
      IF (NCALL .NE. 0) GOTO 200
      NCALL = NCALL + 1
      KEYS(27) = SINGPK
      KEYS(28) = ORIGIN
      CALL PPROFI (PATP)
      IF (PATP(1) .GT. -.1) GOTO 200
      TAB(1) = 1.
      IXL = 0
      I = 2
  136 RRR = SQRT(FLOAT(I) - 0.9999)
      IX = RRR
      IF (IX.EQ.IXL) GOTO 137
      IXL = IX
      TAB(I) = PATP(IX)
      IF (IX.EQ.7) GOTO 138
      DELY = PATP(IX+1) - PATP(IX)
      DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY )
      GOTO 138
  137 DELX = RRR - FLOAT(IX)
      TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y
  138 IF (TAB(I).GT.0.1) IMAX2 = I - 1
      I = I + 1
      IF (I.LE.50) GOTO 136
      IF (IMAX2.GT.48) IMAX2=48
      RMAX2 = FLOAT(IMAX2) / 100.
  200 CONTINUE
      VMAX = VVMAX + 1.
      V2MAX = VMAX**2
      VMIN = 0.7
      IF (NAT.GT.40) VMIN=1.7
      V2MIN = VMIN**2
      NMAXVE = 0
      NVMAX = 0
      NVE = 0
      VMAXAT = 0.1
      DO 350  J = 1, NAT-1
      DO 350 K = J+1, NAT
      IF (NVE .EQ. MAXVE) THEN
         NMAXVE = NMAXVE + 1
         GOTO 350
         ENDIF
      VLEN2 = (ATXYZ(1,K) - ATXYZ(1,J))**2
     *     + (ATXYZ(2,K) - ATXYZ(2,J))**2
     *     + (ATXYZ(3,K) - ATXYZ(3,J))**2
      IF (VLEN2 .GT. VMAXAT) VMAXAT = VLEN2
      IF (VLEN2 .LT. V2MIN) GOTO 350
      IF (VLEN2 .GT. V2MAX) THEN
         NVMAX = NVMAX + 1
         GOTO 350
         ENDIF
          NVE=NVE+1
          VEX(NVE) = ATXYZ(1,K) - ATXYZ(1,J)
          VEY(NVE) = ATXYZ(2,K) - ATXYZ(2,J)
          VEZ(NVE) = ATXYZ(3,K) - ATXYZ(3,J)
          WI(NVE) = ATXYZ(4,J) * ATXYZ(4,K)
          W(NVE) = WI(NVE)
          VLEN(NVE) = SQRT(VLEN2)
      IF (NVE .EQ. 1) GOTO 350
      DO 340 I = 1, NVE-1
      IF (ABS (VLEN(NVE)-VLEN(I)) .GT. 0.1) GOTO 340
      IF (ABS (VEX(NVE)-VEX(I)) .GT. 0.1) GOTO 335
      IF (ABS (VEY(NVE)-VEY(I)) .GT. 0.1) GOTO 335
      IF (    (VEX(NVE)-VEX(I))**2 +
     *        (VEY(NVE)-VEY(I))**2 +
     *        (VEZ(NVE)-VEZ(I))**2 .LE. 0.01) GOTO 338
  335 IF (ABS (VEX(NVE)+VEX(I)) .GT. 0.1) GOTO 340
      IF (ABS (VEY(NVE)+VEY(I)) .GT. 0.1) GOTO 340
      IF (    (VEX(NVE)+VEX(I))**2 +
     *        (VEY(NVE)+VEY(I))**2 +
     *        (VEZ(NVE)+VEZ(I))**2 .GT. 0.01) GOTO 340
  338 WI(I) = WI(I) + WI(NVE)
      W(I) = WI(I)
      NVE = NVE-1
      GOTO 350
  340 CONTINUE
  350 CONTINUE
      IF (NMAXVE .GT. 0) write(24, '(
     * '' Storage problems: nr of vectors skipped:'', I6)') NMAXVE
      IF (NVMAX .GT. 0) write(24, '(
     * '' Number of very large vectors skipped:   '', I4)') NVMAX
      write(24, FMT = '(
     * '' Number of different vectors generated:  '', I4)') NVE
      VMAXAT = SQRT (VMAXAT)
      write(24, 354) VMAXAT
  354 FORMAT (' Longest vector in the model is:',16X, F8.2)
      MF = NVE - 1
      IF (MF.LE.0) GOTO 521
      RMAX1 = SQRT (RMAX2)
      DO 520 MVEC = 1,MF
      DO 520 NVEC = MVEC+1, NVE
      IF (ABS (VLEN(NVEC) - VLEN(MVEC)) .GT. 0.7) GOTO 520
      IF (ABS (VEX(NVEC) - VEX(MVEC)) .GT. RMAX1) GOTO 515
      IF (ABS (VEY(NVEC) - VEY(MVEC)) .GT. RMAX1) GOTO 515
      RR = (VEX(NVEC) - VEX(MVEC))**2
     *   + (VEY(NVEC) - VEY(MVEC))**2
     *   + (VEZ(NVEC) - VEZ(MVEC))**2
      IF (RR .LE. RMAX2) GOTO 518
  515 IF (ABS (VEX(NVEC) + VEX(MVEC)) .GT. RMAX1) GOTO 520
      IF (ABS (VEY(NVEC) + VEY(MVEC)) .GT. RMAX1) GOTO 520
      RR = (VEX(NVEC) + VEX(MVEC))**2
     *   + (VEY(NVEC) + VEY(MVEC))**2
     *   + (VEZ(NVEC) + VEZ(MVEC))**2
      IF (RR .GT. RMAX2) GOTO 520
  518 G = RR/DEL + 1.
      IG = G
      F = G - FLOAT(IG)
      OVRLAP = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F
      W(MVEC) = W(MVEC) + OVRLAP * WI(NVEC)
      W(NVEC) = W(NVEC) + OVRLAP * WI(MVEC)
  520 CONTINUE
  521 WTCUT = 3.6
      VMAX = VMAX - 1.
      VMIN = 1.7
      IF (NAT.LT.7) VMIN=0.7
      JMAX = NVE
      NVE = 0
      DO 620 J=1,JMAX
      IF (W(J).LE.WTCUT) GOTO 620
      IF (VLEN(J).GT.VMAX) GOTO 620
      IF (VLEN(J).LT.VMIN) GOTO 620
      NVE = NVE + 1
      VEX(NVE) = VEX(J)
      VEY(NVE) = VEY(J)
      VEZ(NVE)  =VEZ(J)
      W(NVE)=W(J)
      WI(NVE)=WI(J)
      VLEN(NVE)=VLEN(J)
      IF(KWVLEN .GT. 1) W(J) = W(J) * VLEN(J)
      IF(KWVLEN .EQ. 1) W(J) = W(J) * SQRT(VLEN(J))
      IW(NVE) = W(J) * 30.
 620  CONTINUE
      IF (NIJM) write(24, FMT = '(
     * '' Number of independent vectors generated:'', I4)') NVE
      IF (NIJM) write(24, 622) VMIN, VMAX
  622 FORMAT (' Vector length program limitations:  ' , 7X,
     *   F6.2, '-', F5.2 )
      IF (NVE .LE. 0) CALL KERNER (622, 'ORVEC')
      CALL BSORT5 (IW, VEX, VEY, VEZ, VLEN, NVE)
      DO 630 J=1,NVE
      W(J) = FLOAT(IW(J)) / 30.
      IF(KWVLEN .GT. 1) W(J) = W(J) / VLEN(J)
      IF(KWVLEN .EQ. 1) W(J) = W(J) / SQRT(VLEN(J))
  630 CONTINUE
      IF (.NOT. SWPRI) GOTO 650
      WRITE (8, 632)
  632 FORMAT (' List of VECTORS IN DESCENDING ORDER OF WEIGHTS')
      WRITE (8, 670)
      DO 640 KDES=1,NVE
      K = NVE-KDES+1
  640 WRITE (8, 710) KDES, VEX(K), VEY(K), VEZ(K), W(K), VLEN(K)
  650 SEPN = 0.4
      SEPN2 = 0.16
      IF (SWPRI) WRITE (8, 660) SEPN
  660 FORMAT (' Minimum vector separation is:        ' ,F7.3)
      IF (SWPRI) WRITE (8, 670)
  670 FORMAT (/15X, 4HVECX,4X,4HVECY,4X, 22HVECZ    WEIGHT  LENGTH )
      CALL KERNZI (0, KFLAG, NVE)
      VMAXAT = 0.1
      N = NVE
      MAXV2 = MAXV
      NV = 0
  700 IF (KFLAG(N) .NE. 0) GOTO 800
      NV = NV + 1
      VECTA(1, NV) = VEX(N)
      VECTA(2, NV) = VEY(N)
      VECTA(3, NV) = VEZ(N)
      VECTA(4, NV) = W(N)
      VECTA(5, NV) = VLEN(N)
      IF (VLEN(N).GT.VMAXAT) VMAXAT=VLEN(N)
      IF (SWPRI)
     *   WRITE (8, 710) NV, VEX(N), VEY(N), VEZ(N), W(N), VLEN(N)
  710 FORMAT (' VECTOR', I4, 3F8.3, 2X, 2F8.3)
      IF (NV .EQ. MAXV2) GOTO 810
      J=N-1
      IF (J .EQ. 0) GOTO 810
  720 IF (KFLAG(J).NE.0) GOTO 770
      IF (ABS(VLEN(J) - VLEN(N)) .GE. SEPN) GOTO 770
      IF ( (VEX(J)-VEX(N))**2 + (VEY(J)-VEY(N))**2 + (VEZ(J)-VEZ(N))**2
     *   .LT. SEPN2) GOTO 750
      IF ( (VEX(J)+VEX(N))**2 + (VEY(J)+VEY(N))**2 + (VEZ(J)+VEZ(N))**2
     *   .GE. SEPN2) GOTO 770
  750 KFLAG(J)=1
  770 J=J-1
      IF (J .NE. 0) GOTO 720
  800 N=N-1
      IF (N .GT. 0) GOTO 700
  810 CONTINUE
      IF (NIJM) write(24, 953) NV
  953 FORMAT (' Number of accepted vectors is:' , I14)
      NVECA = NV
      write(24, 954) VMAXAT
  954 FORMAT (' Longest accepted vector is:', 20X, F8.2)
      VMAXAT = VMAXAT + 0.001
      RETURN
      END
      SUBROUTINE BSORT5 (A, B, C, D, E, N)
      DIMENSION A(N),B(N),C(N),D(N),E(N)
      INTEGER A
      INTEGER DEL, BE, DE
      IF (N.LE.1) RETURN
      NA=N-1
      DO 10 I=1,NA
      IF (A(I).LE.A(I+1)) GOTO 10
      T=A(I)
      A(I)=A(I+1)
      A(I+1)=T
      T=B(I)
      B(I)=B(I+1)
      B(I+1)=T
      T=C(I)
      C(I)=C(I+1)
      C(I+1)=T
      T=D(I)
      D(I)=D(I+1)
      D(I+1)=T
      T=E(I)
      E(I)=E(I+1)
      E(I+1)=T
 10   CONTINUE
      DEL=1
 20   IF (DEL.GE.A(N)) GOTO 30
      DEL=DEL+DEL
      GOTO 20
 30   DEL=DEL/2
      IF (DEL.EQ.0) RETURN
      BE=0
      I=1
      DE=DEL
 50   IF (I.GE.N) GOTO 60
      DO 70 L=I,N
      IF (A(L).GE.(DE+DEL)) GOTO 800
 70   CONTINUE
      L=N
      GOTO 800
 60   IF (BE.EQ.0) RETURN
      GOTO 30
 800  IF (L.LE.(I+1)) GOTO 90
      BE=1
      J=L-1
 85   IF (A(J)-DE) 100,110,110
 90   I=L
      DE=DE+2*DEL
      GOTO 50
 100  I=I+1
      IF (I.GT.J) GOTO 90
      IF (A(I-1).LT.DE) GOTO 100
      T=A(I-1)
      A(I-1)=A(J)
      A(J)=T
      T=B(I-1)
      B(I-1)=B(J)
      B(J)=T
      T=C(I-1)
      C(I-1)=C(J)
      C(J)=T
      T=D(I-1)
      D(I-1)=D(J)
      D(J)=T
      T=E(I-1)
      E(I-1)=E(J)
      E(J)=T
 110  J=J-1
      IF (I-J) 85,90,85
      END
      SUBROUTINE EULOUT
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATOMS,IFILE(1)), (IATMOD, IFILE(2))
      EQUIVALENCE (IATOLD,IFILE(10))
      EQUIVALENCE (MFLEX, KSTAT(10)), (IFLEX, KSTAT(12))
      EQUIVALENCE (IRUN, KSTAT(13))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      INCLUDE 'Zatomx.inc'
      PARAMETER (M25 = 98)
      DIMENSION RR(3,3), VL(M25), SIG(M25), XMIN(3), RSYMM(3,3,24)
      LOGICAL LARGE
      DATA KSET / 0 /
      CALL WR24
      WRITE (24, 140)
  140 FORMAT (1X/' Final list of Eulerian angles       FOM=ISIG=100.pe',
     * 'ak/sigma'/ ' Set No.     A         B         C       ISIG '/)
      ISIGT = ISIG(1) * 5 / 10 - 1
      DO 144 I = 1,NPKS
      IF (I .EQ. 25) ISIGT = ISIG(1) * 7 / 10 - 1
      IF (ISIG(I) .GT. ISIGT) KSET = I
  144 WRITE (24, 145) I, APIK(I), BPIK(I), CPIK(I), ISIG(I)
  145 FORMAT (I6, 3F10.2, I8)
      IF (KSET .EQ. 0) STOP 706
      WRITE (24, 148) CCODE
  148 FORMAT (1X/' Output sets of atomic parameters for ', A6,
     *       ' to file ATOMS')
      IF (IFLEX .EQ. 1)
     *    CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      NIP = 1
      WRITE (IATOMS, 149) CCODE, IRUN, IFLEX, NIP, ISIG(NIP)
  149 FORMAT ('ATOMS ', A6, ' < ORIENT ',
     *      ' RUN', I4, ' MOD=', I4, ' OR=', I3, ' ISIG=', I5)
      WRITE(IATOMS,150)IFLEX,NIP,APIK(NIP),BPIK(NIP),CPIK(NIP),ISIG(NIP)
  150 FORMAT ('REMARK MOD=',I3,' OR=',I3, ' : ABC =',3F7.2,' ISIG =',I5)
      KSETM = 37
      IF ( MORIE .LT. KSETM ) KSETM = MORIE
      KSET = NPKS
      IF ( KSETM .LT. KSET ) KSET = KSETM
      WRITE (24, 160) KSET
  160 FORMAT (' Atom calculation will be called for the following',
     *   I3, ' ABC peaks,'/
     *   ' accepted sets are output, numbering notation: OR=...'/1X)
      LARGE = .FALSE.
      IF (NAT .GT. M25) LARGE = .TRUE.
      IF (LARGE) GOTO 200
      DO 180 I = 1, NAT
  180 VL(I) = SQRT (ATXYZ(1,I)**2 + ATXYZ(2,I)**2 + ATXYZ(3,I)**2)
      CALL KERI2F (IRSYMM, RSYMM, 9 * NSYMM)
  200 KAL = 0
      NIDEN = 0
      DO 500 IP = 1, KSET
      IF (NAT + KAL * NAT + NAT .GT. MAXAT) THEN
         WRITE (24, 201)
  201    FORMAT (1X/' Remaining possible orientations rejected...'/1X)
         GOTO 501
         ENDIF
      IF (ISIG(IP) .LT. ISIGT) WRITE (24, FMT='(60X, '' too low? '')')
      CALL MATABC (APIK(IP), BPIK(IP), CPIK(IP), RR)
      DO 210 I = 1,NAT
      CALL MATXV3 (RR, ATXYZ(1,I), ATXYZ(5,I))
  210 CALL MAT6XV (CART2F, ATXYZ(5,I), ATXYZ(8,I))
      IF (LARGE) GOTO 400
      SIGT = 1.05 * ISIG(IP)
      IF (KAL .EQ. 0) GOTO 400
      DO 350 ISYMM = 1, NSYMM
      L = NAT + KAL * NAT + 1
      DO 240 I = 1, NAT
      CALL MATXV3 (RSYMM(1,1,ISYMM), ATXYZ(8,I), ATXYZ(1,L))
  240 L = L + 1
      DO 300 KA = 1, KAL
      IF (SIG(KA) .GT. SIGT) GOTO 300
      L = NAT + KAL * NAT + 1
      ESD = 0.0001
      ESDM = 0.0001
      NESD = 0
      DO 270 I = 1, NAT
      K = KA * NAT + 1
      DO 260 J = 1, NAT
      IF (IZAT(I) .NE. IZAT(J)) GOTO 260
      IF (ABS (VL(I) - VL(J)) .GT. 0.3) GOTO 260
      DMAX = 0.3
      CALL DISTSQ (ATXYZ(1,K), ATXYZ(1,L), DMAX, XMIN, DIST2)
      IF (DIST2 .GT. 99.) GOTO 260
      ESDM = AMAX1 (ESDM, DIST2)
      NESD = NESD + 1
      ESD = ESD + DIST2
      GOTO 270
  260 K = K + 1
      GOTO 300
  270 L = L + 1
      ESD = SQRT (ESD / NAT)
      ESDM = SQRT (ESDM)
      IF (NESD .NE. NAT) CALL KERROR ('MOD 95 fout !', 0, 'EULOUT')
      NIDEN = NIDEN + 1
      IF (NIDEN .EQ. 1) WRITE (24, 272) IP, KA, ESD, ESDM
  272 FORMAT (1X/ 12X,
     * 'Set No.',I3,' gives the same atoms as set No.', I3/
     * 11X, ' with esd of interatomic distances =' , F5.2, ' Angstrom'/
     * 11X, ' and largest interatomic deviation =' , F5.2, ' Angstrom'/
     * 11X, ' --->' / 1X)
      WRITE (24, FMT='('' Set No.'',I3, 8X,''[= set'', I3,''  esd:''
     *  ,F5.2,'' , max:'',F5.2, ''] ISIG='', I4 )')
     *  IP, KA, ESD, ESDM, ISIG(IP)
      GOTO 500
  300 CONTINUE
  350 CONTINUE
  400 KAL = KAL + 1
      SIG(KAL) = ISIG(IP)
      WRITE (24, 402) IP, KAL, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP)
  402 FORMAT (' Set No.', I3,' OR=', I3,
     *         ' (ABC =',3F7.2,') with ISIG=',I4)
      IF (KAL .EQ. 1) THEN
         CALL WR24
         WRITE (8, 417)
  417    FORMAT (1X/' Atomic coordinates (x,y,z)',
     *       ' written to ATOMS file:'/
     *       '   nr.   at.name', 9X, 'x', 8X, 'y', 8X, 'z' )
         DO 420 I = 1, NAT
         WRITE (8, 422) I, ATNAME(I), (ATXYZ(J,I), J = 8,10)
  420    WRITE (IATOMS, 423)  ATNAME(I), (ATXYZ(J,I), J = 8,10)
  422    FORMAT (I6, 3X, A6, 2X, 3F9.5)
  423    FORMAT ('ATOM', 3X, A6, 2X, 3F9.5)
         WRITE (IATOMS, FMT='(''END'')')
         CALL WR24
         IF (MORIE .EQ. 1) GOTO 600
         ENDIF
      CALL WR24
      L = KAL * NAT + 1
      WRITE (8, 426)
  426 FORMAT (/ 8X, 'atom', 8X, 'Cartesian', 15X, 'fractional' /
     *  8X, 'name', 8X,'X',6X,'Y',6X,'Z',9X,'X',8X,'Y',8X,'Z')
      IF (KAL .GE. 2 .AND. .NOT. LARGE) THEN
         NIP = NIP + 1
         WRITE (IATOMS, 149) CCODE, IRUN, IFLEX, NIP, ISIG(IP)
         WRITE(IATOMS, 150)IFLEX,NIP,APIK(IP),BPIK(IP),CPIK(IP),ISIG(IP)
         ENDIF
      DO 430 I = 1, NAT
      IF (.NOT. LARGE) CALL KERNAB (ATXYZ(8,I), ATXYZ(1,L), 3)
      WRITE (8, 428) ATNAME(I), (ATXYZ(J,I), J = 5, 10)
  428 FORMAT (' ATOM', 2X, A6, 2X, 3F7.3, 4X, 3F9.5)
      IF (KAL .GE. 2 .AND. .NOT. LARGE)
     *   WRITE (IATOMS, 423)  ATNAME(I), (ATXYZ(J,I), J = 8,10)
  430 L = L + 1
      IF (KAL .GE. 2 .AND. .NOT. LARGE) WRITE (IATOMS, FMT='(''END'')')
  500 CONTINUE
  501 CONTINUE
      IF (KAL .EQ. 1) THEN
         WRITE (24, 503)
  503 FORMAT (/ ' Atom set 1 is the only acceptable result of ORIENT.'/
     * ' The  parameter set is transferred to TRACOR' )
      ELSE
         WRITE (24, 510) KAL
  510    FORMAT (/ ' All', I3,
     *     ' accepted parameter sets (OR=..) are transferred to TRACOR')
         ENDIF
  600 CONTINUE
      CALL WR24
      KSET = 0
      IF (IFLEX .LT. MFLEX) RETURN
      CALL KERASE ('ATORI')
      CALL COPY80 (IATOMS, 'ATOMS', 10, 'ATORI')
      RETURN
      END
      SUBROUTINE MORV
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (IMFUN, IFILE(13))
      EQUIVALENCE (NRUN,  KEYS(5)),   (ITPL,  KEYS(7))
      EQUIVALENCE (MFLEX, KSTAT(10))
      LOGICAL NIJM
      EQUIVALENCE (NIJM, SWITCH(1))
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DATA FACM / 1.0/
      DATA NCALL / 0 /
      NCALL = NCALL + 1
      L9 = 9
      L7 = 24
      IF (NCALL .GT. 4) THEN
         L9 = 24
         L7 = 8
         ENDIF
      NRUN = NRUN + 1
      WRITE (L7, FMT = '(60X,''MORV Cycle'', I2)') NRUN
      CALL KERNZA (0., AAA, 3)
      CALL KERNZA (0., SSS, 3)
      NPOINT = 0
      IF (NRUN .EQ. 1) THEN
         CALL FILINQ (IMFUN, 'MFUN', 'UNFORMATTED', 'OUTPUT', KINQ)
         IF (MFLEX .GE. 2) MPAR = 0
         ITPL=1
         IF (MPAR.GT.0) ITPL=2
         ENDIF
      ITPL = MIN0 (8, ITPL * 2)
      IF (ITPL .NE. 2) THEN
         WRITE (L9, FMT = '('' Patterson function retrieval:'',
     *       I2, ''-point interpolation'') ') ITPL
      ELSE
         WRITE (L9, FMT = '('' Patterson function retrieval:'',
     *       '' max.  of 8 neighbours'') ')
         ENDIF
      CALL WR24
      VMAXXX = 0.
      YZMAX= 0.
      VECMAX = VMAXDE
      IF (VMAXIN .GT. 0.1) THEN
         VMAXIN = AMIN1 (VMAXIN, VMAXDE)
         VECMAX = AMIN1 (VMAXIN, VECMAX)
         ENDIF
      IF (MPARIN .LE. 0) THEN
         IF (NRUN .EQ. 1) VECMAX = AMIN1 (4.6, VECMAX)
         IF (NRUN .EQ. 2) VECMAX = AMIN1 (6.2, VECMAX)
         IF (NRUN .EQ. 3 .AND. VECMAX .GT. 7.5)
     *      VECMAX = AMAX1 (7.5, 0.5* (6.2 + VECMAX))
         ENDIF
      IF (VMAXAT .GT. VECMAX) WRITE (8, FMT = '(
     * '' Max. vector length to be used:'', 9X, F5.2 ) ' ) VECMAX
      NVECB = 0
      DO 205 N = 1, NVECA
      IF (VECTA(5,N) .GT. VECMAX) GOTO 205
      IF (VECTA(5,N) .GT. VMAXXX) VMAXXX = VECTA(5,N)
      YZ = VECTA(2,N)**2 + VECTA(3,N)**2
      IF (YZ .GT. YZMAX) YZMAX = YZ
      NVECB = NVECB + 1
      CALL KERNAB (VECTA(1,N), VECTB(1,NVECB), 4)
  205 CONTINUE
      IF (NVECB .EQ. 0) CALL KERROR
     * ('All vectors too long; use larger VMAX', 205, 'MORV')
      WRITE (L7, FMT = '('' Nr of vectors and Max vector length:'',
     *  5X, I3, F11.2 ) ' ) NVECB, VMAXXX
      YZMAX = SQRT(YZMAX)
      IF (NVECB .LT. NVECA) WRITE (8, FMT =
     *   '('' Selected number of vectors:'', I17 ) ') NVECB
      IF (VMAXXX .LT. VECMAX -0.001) THEN
         WRITE (8, FMT =
     *      '('' Longest vector selected ='', 13X, F6.2) ') VMAXXX
         IF (YZMAX .GT. 0.00001) WRITE(8, FMT = '(
     *        '' Longest yz-component ='', 16X, F6.2)' ) YZMAX
         ENDIF
      IF (NRUN .EQ. 1 .AND. MININ .GT. 0)
     *   FACM = AMIN1(1.8, FLOAT(MINM(MININ))/(0.5 * FLOAT(NVECB)) )
      IF (MININ .GT. 0) CALL KERNAI (MINM, MM, MININ)
      IF (NRUN .GT. 1 .AND. MININ .GT. 0) THEN
         MM(MININ) = NINT (FACM * 0.5 * FLOAT(NVECB) +1. )
         IF (MININ .GT. 1) MM(1) = NINT (FACM * 0.4 * FLOAT(NVECB) +1. )
         IF (MININ .EQ. 3) MM(2) = NINT (FACM * 0.45* FLOAT(NVECB) +1. )
         ENDIF
      IF (NRUN .EQ. 2 .AND. MININ .GT. 0) THEN
         MM(MININ) = MIN0 (MM(MININ), 2*MINM(MININ))
         IF (MININ .GT. 1) MM(1) = MIN0 (MM(1), 2*MINM(1))
         IF (MININ .EQ. 3) MM(2) = MIN0 (MM(2), 2*MINM(2))
         ENDIF
      IF (MM(1).GT.0 .AND. MININ.GT.0) GOTO 122
      IF (MIN4(1) .GT. 0) THEN
         MM(1) = MIN4(NRUN)
         GOTO 122
         ENDIF
      IF (FVMIN .GT. 0.) THEN
         MM(1) = FVMIN * FLOAT(NVECB) + 1.0
         GOTO 122
         ENDIF
      MM(1) = 1 + NVECB/4
      MM(2) = 2 + (NVECB-1)/3 + IABS(NVECB-6)/6
      MM(3) = 2 + (NVECB-1)/2
      IF (NVECB .EQ. 1) MM(2) = 0
      IF (NVECB .LE. 4) MM(3) = 0
      IF (NVECB .GT. 15) MM(2) = (MM(1) + MM(3)) / 2
  122 CONTINUE
      MMM = 0
      DO 158 J=1, 3
      IF (MM(J).LE.0) GOTO 159
      MMM = MMM + 1
      IF (MM(J) .LE. NVECB) GOTO 154
      WRITE (8,153)
  153 FORMAT (' MIN(M): M GREATER THEN NUMBER OF VECTORS. RESET.' /)
      MM(J) = NVECB
  154 IF (MM(J) .EQ. NVECB) GOTO 159
  158 CONTINUE
  159 WRITE (8,160) NRUN, (MM(J),J=1,MMM)
  160 FORMAT (/' Cycle', I2, '.  Calculation of MIN(M), where M =' ,3I4)
      WRITE (8, 160) NRUN, (MM(J),J=1,MMM)
      IF (MPAR.EQ.0) CALL PARAMS
      WRITE (8, 202) MPAR
  202 FORMAT (' Number of sets of parameters generated (MPAR):', I5)
      WRITE (8,
     *   FMT='('' Number of ABS-scans: MPAR='', I3)') MPAR
      IF (MPAR.GE.20) THEN
         WRITE (L9, FMT='('' Number of ABS-scans: MPAR='', I3)') MPAR
         ENDIF
      DO 300 IPAR = 1, MPAR
      I = MOD(IPAR, 20)
      IF (I .EQ. 0) THEN
         WRITE (L9, FMT='('' ... next: ABS-scan number:'', I3)') IPAR
         CALL WR24
         ENDIF
  300 CALL ORV (IPAR)
      TEMP = 0.
      DO 500 I=1, MMM
      AAA(I) = AAA(I) / FLOAT(NPOINT)
      TEMP = TEMP + AAA(I)
      SSS(I) = SSS(I) / FLOAT(NPOINT)
      SSS(I)= SQRT(SSS(I) - AAA(I)**2)
  500 IF (SSS(I) .LE. 1.0) SSS(I) = 1.0
         WRITE (8, FMT ='('' Averages and sigmas for this cycle'' /
     * '' Min(m) average    sigma    for'', I6, '' points:'') ') NPOINT
         WRITE (8, 504) (MM(J), AAA(J), SSS(J), J = 1,MMM)
  504    FORMAT (I6, 2F9.2)
      IF (TEMP.LE.0.001) CALL KERROR (' Min fun map all zeros',
     *  500, 'MORV')
      CALL WR24
      IF (MPARIN .EQ. 0 .AND. NRUN .LE. 2) RETURN
      DO 600 I = 1, MMM
      SSS(I) = AAA(I) / 3.
  600 AAA(I) = 0.
      RETURN
      END
      SUBROUTINE ORV (IPAR)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IMFUN, IFILE(13))
      EQUIVALENCE (NRUN,  KEYS(5))
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (IJK = 10 * MAXV + 1)
      DIMENSION CAX(IJK), CAY(IJK), CAZ(IJK), W(IJK),
     *          ABX(IJK), ABY(IJK), ABZ(IJK), WVEPAT(IJK), VEPAT(IJK)
      EQUIVALENCE (CAX(1),VECTB(1,1)), (CAY(1),CAX(2)), (CAZ(1),CAX(3)),
     *            (W(1),VECTB(4,1)),
     *            (ABX(1),VECTB(6,1)), (ABY(1),ABX(2)), (ABZ(1),ABX(3)),
     *            (WVEPAT(1),VECTB(9,1)), (VEPAT(1),VECTB(10,1))
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DIMENSION ARG(3)
      DIMENSION RTM(3,3), XCRM(3,3), ABM(3,3), ROTM(3,3)
      DATA NVC  /0/
      IF (IPAR .EQ. 1) THEN
         REWIND IMFUN
         NVC = NVECB * 10 -9
         ENDIF
      AI = PAR1(1,IPAR)
      BI = PAR1(2,IPAR)
      CI = PAR1(3,IPAR)
      AD = PAR2(1,IPAR)
      BD = PAR2(2,IPAR)
      CD = PAR2(3,IPAR)
      NA = NPAR(1,IPAR)
      NB = NPAR(2,IPAR)
      NC = NPAR(3,IPAR)
      IF (NC .GT. 65) CALL KERROR ('Nr.points C rot > 65 ', 0, 'ORV')
      NPOINT = NPOINT + NA * NB * NC
      WRITE (IMFUN) IPAR, MM, MMM, AI,AD,NA,BI,BD,NB,CI,CD,NC
      AI = PAR1(1,IPAR) * D2R
      BI = PAR1(2,IPAR) * D2R
      CI = PAR1(3,IPAR) * D2R
      AD = PAR2(1,IPAR) * D2R
      BD = PAR2(2,IPAR) * D2R
      CD = PAR2(3,IPAR) * D2R
      A=AI
      N1 = 1
      GOTO 200
  190 A=A+AD
      N1 = N1 + 1
      IF (N1 .GT. NA) RETURN
  200 SINA=SIN(A)
      COSA=COS(A)
      B=BI
      N2 = 1
      GOTO 300
  290 B=B+BD
      N2 = N2 + 1
      IF (N2 .GT. NB) GOTO 190
  300 SINB=SIN(B)
      COSB=COS(B)
      N3C = 1
      C = CI
      SINC = SIN(C -CD)
      COSC = COS(C -CD)
      CALL MATEUL (COSA, COSB, COSC, SINA, SINB, SINC, ROTM)
      CALL MATMPY (CART2F, ROTM, ABM)
      DO 310 I = 1, NVECB
  310 CALL MATXV3 (ABM, VECTB(1,I), VECTB(6,I))
      CALL ROTMTX (CD, COSB, SINB*SINA, SINB*COSA, ROTM)
      CALL MATMPY (ROTM, FRAC2C, XCRM)
      CALL MATMPY (CART2F, XCRM, RTM)
      GOTO 400
  390 C=C+CD
      N3C = N3C + 1
      IF (N3C .GT. NC) GOTO 700
  400 IVEC = 0
      DO 480 IVE=1,NVC,10
      IVEC = IVEC + 1
      CALL MATXV3 (RTM, VECTB(6,IVEC), ARG)
      CALL KERNAB (ARG, VECTB(6,IVEC), 3)
      CALL RDOUT(ARG,PATF)
      WVEPAT (IVE)=PATF/W(IVE)
      VEPAT(IVE)=PATF
  480 CONTINUE
      CALL ISF (NVC, N3C)
      GOTO 390
  700 WRITE (IMFUN) NC, MMM, ((LMINC(K,N),K=1,NC), N=1,MMM)
      DO 795 J = 1, MMM
      ITOTAL = 0
      ISUMSQ = 0
      DO 792 K=1,NC
      ITOTAL = ITOTAL + LMINC(K,J)
  792 ISUMSQ = ISUMSQ + LMINC(K,J)**2
      AAA(J) = AAA(J) + FLOAT(ITOTAL)
  795 SSS(J) = SSS(J) + FLOAT(ISUMSQ)
      GOTO 290
      END
      SUBROUTINE ISF (NVEC, N3C)
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (IJK = 10 * MAXV + 1)
      DIMENSION W(IJK), WVEPAT(IJK), VEPAT(IJK)
      EQUIVALENCE (W(1),VECTB(4,1)),
     *            (WVEPAT(1),VECTB(9,1)), (VEPAT(1),VECTB(10,1))
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DIMENSION LOW(MAXV), SAVP(MAXV)
      DATA  LO  /0/
      SUMP=0.
      SUMW=0.
      MLARGE = MM(MMM)
      DO 770 J=1,MLARGE
      WPLOW=999999.
      DO 760 K=1,NVEC,10
      IF (WVEPAT(K).GE.WPLOW) GOTO 760
      LO=K
      WPLOW=WVEPAT(K)
 760  CONTINUE
      SAVP(J)=WPLOW
      LOW(J)=LO
  770 WVEPAT(LO)=999999.
      K=1
      DO 800 J=1,MLARGE
      L=LOW(J)
      WVEPAT(L)=SAVP(J)
      SUMP=SUMP+VEPAT(L)
      SUMW=SUMW+W(L)
      IF (J .NE. MM(K)) GOTO 800
      LMINC(N3C,K) = 1800. * SUMP / SUMW
      K=K+1
 800  CONTINUE
      RETURN
      END
      SUBROUTINE PARAMS
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (KLAUE,  KEYS(6))
      PARAMETER (MAXV = 234)
      COMMON /VECDAT/ NVECA, VECTA(5,MAXV), NVECB, VECTB(10,MAXV),
     *                VDUMM(10), VMAXIN, VMAXAT, D2R
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      WRITE (8, FMT = '('' Generate scan params. for ORV'' ) ')
      ISPAR = 0
      CI = 5.
      CD = 10.
      NC = CMAX / 9.9
      IF (NVECA .EQ. 1) NC = 1
      BI = 0.
      NB = 1
      IF (KLAUE.EQ.1) NB=2
      AI = 0.
      AD = 60.
      NA = 1
      I = 1
  100 BD = 180. - BI - BI
  111 ISPAR = ISPAR + 1
      MPAR = I
      PAR1(1,I) = AI
      PAR2(1,I) = AD
      NPAR(1,I) = NA
      PAR1(2,I) = BI
      PAR2(2,I) = BD
      NPAR(2,I) = NB
      PAR1(3,I) = CI
      PAR2(3,I) = CD
      NPAR(3,I) = NC
      I = I + 1
      GOTO (100 ,2, 3, 33, 4, 5, 6, 7, 8, 9), I
  2   BI = 9.
      AI = 30.
      NA = 6
      IF (KLAUE.EQ.3) NA = 3
      GOTO 100
  3   BI = 16.
      AI = 0.
      GOTO 100
  33  BI = 22.
      AI = 30.
      GOTO 100
  4   BI = 26.
      AI = 15.
      AD = 30.
      NA = NA * 2
      GOTO 100
  5   BI = 33.
      AI = 0.
      GOTO 100
  6   BI = 40.
      AI = 7.5
      AD = 15.
      NA = NA * 2
      GOTO 100
  7   BI = 50.
      AI = 0.
      GOTO 100
  8   AI = 5.
      AD = 10.
      NA = (NA * 3) / 2
      BI = 60
      NB = 4
      IF (KLAUE.EQ.1) NB=7
      BD = 10.
      GOTO 111
  9   RETURN
      END
      SUBROUTINE ROTMTX (ROT, DCOS1, DCOS2, DCOS3, ROTM)
      DIMENSION ROTM(3,3)
      COSR = COS(ROT)
      COS1 = COSR-1.
      SINR = SIN(ROT)
      T = DCOS1 * COS1
      ROTM(1,1) = COSR - DCOS1 * T
      T1 = DCOS2*SINR
      T2 = DCOS3*SINR
      T3 = -DCOS2*T
      ROTM(1,2) = T3 + T2
      ROTM(2,1) = T3 - T2
      T3 = -T * DCOS3
      ROTM(3,1) = T3 + T1
      ROTM(1,3) = T3 - T1
      ROTM(2,2) = COSR - DCOS2 * DCOS2 * COS1
      T1 = DCOS1 * SINR
      T3 = -DCOS2 * COS1 * DCOS3
      ROTM(2,3) = T3 + T1
      ROTM(3,2) = T3 - T1
      ROTM(3,3) = COSR - DCOS3 * DCOS3 * COS1
      RETURN
      END
      SUBROUTINE MATMPY (RM1,RM2,RM3)
      DIMENSION RM1(3,3),RM2(3,3),RM3(3,3)
      DO 150 J=1,3
      DO 150 K=1,3
      RM3(J,K)=0.
      DO 150 L=1,3
 150  RM3(J,K)=RM3(J,K)+RM1(J,L)*RM2(L,K)
      RETURN
      END
      SUBROUTINE MAPSIG
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IMFUN,  IFILE(13)), (IPRSIG, KEYS(10))
      EQUIVALENCE (LMINCM, KEYS(17))
      EQUIVALENCE (NRUN,  KEYS(5))
      LOGICAL NIJM, SWPRI
      EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(10))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DIMENSION CLABL(65), LISIG(65,3)
      EQUIVALENCE (LISIG(1,1), LMINC(1,1))
      LOGICAL NIJA, BLOK
      BLOK = .FALSE.
      NIJA = NIJM .AND. NRUN.GE.4 .AND. .NOT.SWPRI .AND. IPRSIG.LE.0
      INIT65 = 0
      REWIND IMFUN
      IF (IPRSIG .GT. 0) THEN
         WRITE (24, FMT='('' Write MAPSIG min fun to printer LIS2'')')
         WRITE (8, 102) NRUN
  102 FORMAT (' MAPSIG MIN. FUNCTIONS  cycle', I2,  /)
         ENDIF
      IMIN = 0
      IF (NRUN.GT.1) GOTO 135
      IF (MPARIN.LE.0) THEN
         IMIN = 200
         ENDIF
      IF (NPOINT .LT. 1000) IMIN = NPOINT / 20
      SIGOUT = FLOAT (IMIN) / 100.
      WRITE (8, 131) SIGOUT, IMIN
  131 FORMAT (' Output ABC points:' /
     * ' Function values of the minimun function are output' /
     * ' if SIGOUT (= function value / sigma)  is at least:', F6.2 /
     * ' ISIG (= 100 * SIGOUT) is used as a figure of merit'  /
     * ' The minimum value (=ISIGmin) for the first run is:', I6 )
      IF (IPRSIG .GT. 0) WRITE (24, 132)
  132 FORMAT (' Printing of min fun maps (skip insignificant lines)'/)
  135 CONTINUE
      ISIGM = 0
      NPKS = 0
      DO 990 KPAR = 1, MPAR
      VMINCH = 0.
      READ (IMFUN, END=990) IPAR, MM, MMM, AI,AD,NA,BI,BD,NB,CI,CD,NC
      IPARAV(IPAR) = 0
      IF (KPAR .NE. IPAR) write(24, FMT='('' ??? KPAR/IPAR ???'')')
      MMM3 = MMM
      IF (IPAR .EQ. 1 .AND. SWPRI) THEN
         WRITE (8, FMT = '(/'' Scan parameters'' /
     *                        '' Set No.    Ainit  Aincr     N'', 5X,
     *         ''Binit  Bincr     N'', 5X,''Cinit  Cincr     N'' /)')
         ENDIF
      IF (SWPRI) WRITE (8, FMT = '(I5, 5X, 3(2F7.2, I6, 3X) )')
     *   IPAR, AI, AD, NA, BI, BD, NB, CI, CD, NC
      IF (IPRSIG .GT. 0) THEN
         CC = CI - CD
         DO 700 I=1, NC
         CC = CC + CD
  700    CLABL(I) = CC
         WRITE (8, 748) IPAR, (CLABL(I), I=1,NC)
  748    FORMAT (' Parameter set no. ', I3 /
     *        '   A     B   MIN(M)  MAX    C=',1 9F5.0 / (30X, 19F5.0))
         ENDIF
      IF (NRUN .GE. 3) BLOK = .TRUE.
      IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) BLOK = .FALSE.
      IF (NC.NE.4 .OR. NA.NE.4 .OR. NB.NE.4) NIJA = .FALSE.
      IF (NIJA) THEN
         CC2 = CI + CD
         CC3 = CC2 + CD
         CC4 = CC3 + CD
         write(24, '(/'' parameter set no.'', I3, ''    C='',
     *      4F6.1 )') KPAR, CI, CC2, CC3, CC4
         ENDIF
      AA = AI - AD
      DO 980 IA=1,NA
      AA = AA + AD
      IF (NIJA) write(24, FMT='(/'' A='',F5.1,
     *   3(6X, ''MIN(M): M='',I3)  )') AA, (MM(J),J=1,MMM)
      BB = BI - BD
      DO 980 IB=1,NB
      BB = BB + BD
      READ (IMFUN) NC, MMM, ((LMINC(K,J), K=1,NC), J=1,MMM)
      IF (NIJA) write(24, FMT='(''  B='',F5.1, 3 (3X,4I4))')
     *   BB, ((LMINC(K,J), K=1,NC), J=1,MMM)
      IF (BLOK) THEN
         IPARAV(IPAR) = IPARAV(IPAR) +
     *       LMINC(1,1) + LMINC(2,1) + LMINC(3,1) + LMINC(4,1)
         IF (IA.EQ.4 .AND. IB.EQ.4) IPARAV(IPAR) = IPARAV(IPAR)/64
         IF (NIJM .AND. IA.EQ.4 .AND. IB.EQ.4) write(24, FMT='(
     *      '' TEMP NIJM average LMINC for IPAR:'', 2I6)')
     *       IPARAV(IPAR), IPAR
         ENDIF
      IMAXJ = 0
      DO 800 J=1, MMM
      DO 800 I=1, NC
      V = LMINC(I,J)
      IV = 100.1 * (V - AAA(J)) / SSS(J)
      LISIG(I,J) = MAX0 (0, IV)
      IF (J .EQ. 1) THEN
         VMINCH = AMAX1(VMINCH, V)
         KEYS(18) = NINT (VMINCH)
         IMAXJ = MAX0 (IMAXJ, IV)
         ENDIF
  800 CONTINUE
      IF (IMAXJ .LT. IMIN) GOTO 980
      IF (IMAXJ .LT. ISIGM) GOTO 862
      ISIGM = IMAXJ
      IMIN = MAX0 (IMIN, ISIGM / 2)
  862 IF (IPRSIG .LE. 0) GOTO 950
      DO 909 J=1,MMM
  907 FORMAT (2F6.1, 2I6, 6X, 19I5 / (30X, 19I5))
  909 WRITE (8, 907) AA, BB, MM(J), IMAXJ, (LISIG(I,J), I=1,NC)
  950 CC = CI - CD
      DO 974 IC = 1, NC
      CC = CC + CD
      IF (LISIG(IC,1) .LT. IMIN) GOTO 974
      NPKS = NPKS + 1
      APIK(NPKS) = AA
      BPIK(NPKS) = BB
      CPIK(NPKS) = CC
      ISIG(NPKS) = LISIG(IC,1)
      DO 972 JSIG = 1, MMM
  972 ISIG3(NPKS,JSIG) = LISIG(IC,JSIG)
      NPIK(NPKS) = IPAR
      IF (NRUN .EQ. 4) THEN
         IJ = NINT ( AAA(MMM) + SSS(MMM) * FLOAT(LISIG(IC,MMM))/ 100.1 )
         IF (IJ .GT. LMINCM) LMINCM = IJ
         ENDIF
  974 CONTINUE
      IF (NPKS .LT. MAXPK-65) GOTO 980
      INIT65 = 0
      IF (NIJM) write(24, FMT=
     *  '('' $$$7 TEMP increase IMIN? Old value:'', I5)') IMIN
  975 INIT65 = INIT65 + 1
      IF (INIT65 .GE. 2) IMIN = 11*IMIN/10
      IF (INIT65 .GE. 2 .AND. NIJM) write(24, FMT=
     *  '('' $$$7 TEMP increase IMIN: new value='', I5)') IMIN
      N = 0
      DO 978 I = 1, NPKS
      IF (ISIG(I) .LT. IMIN) GOTO 978
      N = N + 1
      APIK(N) = APIK(I)
      BPIK(N) = BPIK(I)
      CPIK(N) = CPIK(I)
      ISIG(N) = ISIG(I)
      DO 977 JSIG = 1, MMM
  977 ISIG3(N,JSIG) = ISIG3(I,JSIG)
      NPIK(N) = NPIK(I)
  978 CONTINUE
      NPKS = N
      IF (NPKS .GE. MAXPK-65) GOTO 975
  980 CONTINUE
  990 CONTINUE
      WRITE (8, 992) NPKS, NPOINT
  992 FORMAT (' Nr of ABC min-fun points selected:', I4,
     *   ' (out of', I5, ' points)')
      IF (NIJM) write(24, 992) NPKS, NPOINT
      MPAR = 0
      IF (NIJA) write(24, '(
     *   /'' parameter sets to be printed will be reordered !'')')
      RETURN
      END
      SUBROUTINE REGION
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (KLAUE, KEYS(6))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      DIMENSION LFL(MAXPK)
      EQUIVALENCE (LFL(1),NPIK(1))
      PARAMETER (MXPA = 100)
      DIMENSION
     *      AF(MXPA), BF(MXPA), CF(MXPA), AT(MXPA), BT(MXPA), CT(MXPA),
     *      NPT(MXPA), MAXSIG(MXPA), NUMA(MXPA), NUMB(MXPA), NUMC(MXPA)
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DATA DEA,DEB,DEC /10.,10.,10./
      DATA MSIGFR /4/
      DATA ISAVE /0/
      WRITE (8, FMT = '('' REGION'')')
         DELAB = 9.
         DELCA = 9.
         DELC  = 7.
      CALL RDMAPS (MSIGFR, NP)
      AMAX = 360.
      IF (KLAUE.EQ.3) AMAX = 180.
      NP2 = 0
      DO 10 I=1,NP
      IF (ABS(BPIK(I)).GT.23. .AND. ABS(180.-BPIK(I)).GT.23.) GOTO 10
      ISIG(I) = ISIG(I) - 9999
      NP2 = NP2 + 1
   10 CONTINUE
      IF (NP2.GT.0) CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP)
      NP = NP - NP2
      CALL KERNZI (0, MAXSIG, MXPA)
      CALL KERNZI (0, NPT, MXPA)
      CALL KERNZI (0, LFL, MAXPK)
      IF (NP.EQ.0) GOTO 830
      NR=0
      NPTOT = 0
      CALL NEBOR (0, NP, DELAB, DELCA, IANSW)
      DO 800 IP=1,NP
      IF(LFL(IP).NE.0) GOTO 800
      IF (NR.GE.50) GOTO 805
      IF (NR.GE.20 .AND. NPTOT.GT.400) GOTO 805
      NR=NR+1
      LFL(IP)=NR
      NPT(NR)=1
      AF(NR)=APIK(IP)
      AT(NR)=APIK(IP)
      BF(NR)=BPIK(IP)
      BT(NR)=BPIK(IP)
      CF(NR)=CPIK(IP)
      CT(NR)=CPIK(IP)
      MAXSIG(NR)=ISIG(IP)
      IF(IP.EQ.NP) GOTO 800
      L=IP+1
      ISW = 1
      DO 700 I=IP,NP
      IF (LFL(I).NE.NR) GOTO 700
      DO 300 NB=L,NP
      IF (NB.EQ.I) GOTO 300
      IF (LFL(NB).NE.0) GOTO 300
      CALL NEBOR (I, NB, DELAB, DELCA, IANSW)
      IF(IANSW.EQ.0) GOTO 300
      LFL(NB) = ISW * NR
      IF (APIK(NB).GT.AT(NR)) AT(NR)=APIK(NB)
      IF (APIK(NB).LT.AF(NR)) AF(NR)=APIK(NB)
      IF (BPIK(NB).GT.BT(NR)) BT(NR)=BPIK(NB)
      IF (BPIK(NB).LT.BF(NR)) BF(NR)=BPIK(NB)
      IF (CPIK(NB).GT.CT(NR)) CT(NR)=CPIK(NB)
      IF (CPIK(NB).LT.CF(NR)) CF(NR)=CPIK(NB)
      NPT(NR) = NPT(NR)+1
      NPTOT = NPTOT + 1
 300  CONTINUE
 700  ISW = -1
      DO 740 I=L,NP
      IF (LFL(I).LT.0) LFL(I)=-LFL(I)
      IF (LFL(I).NE.0) GOTO 740
      IF (APIK(I).LT.AF(NR) .OR. APIK(I).GT.AT(NR)) GOTO 740
      IF (BPIK(I).LT.BF(NR) .OR. BPIK(I).GT.BT(NR)) GOTO 740
      IF (CPIK(I).LT.CF(NR) .OR. CPIK(I).GT.CT(NR)) GOTO 740
      LFL(I) = NR
      NPT(NR) = NPT(NR)+1
      NPTOT = NPTOT + 1
  740 CONTINUE
  800 CONTINUE
  805 CONTINUE
      DELA=DEA/2.
      DELB=DEB/2.
      DELC=DEC/2.
      WRITE (8, 808) DELA,DELB,DELC
  808 FORMAT (/' Prepare new scan parameters for next cycle'/
     *        ' ABC-increments for regions:', 3F6.2)
      IF (SWPRI) WRITE (8, FMT = '(/'' Nr.  max.  Nr.points to be''/
     *   '' pts  ISIG  searched for in this region''/
     *   '' ---- ----  ---'')')
      DO 810 IR=1,NR
      AF(IR)=AF(IR)-DELA
      BF(IR)=BF(IR)-DELB
      CF(IR)=CF(IR)-DELC
      NUMA(IR)=ABS(AT(IR)-AF(IR))/DELA+2.1
      NUMB(IR)=ABS(BT(IR)-BF(IR))/DELB+2.1
      NUMC(IR)=ABS(CT(IR)-CF(IR))/DELC+2.1
      I = NUMA(IR) * NUMB(IR) * NUMC(IR)
      CALL STOPAR (AF(IR), BF(IR), CF(IR),
     *   NUMA(IR), NUMB(IR), NUMC(IR), MAXSIG(IR))
  810 IF (SWPRI) WRITE (8, 820) NPT(IR), MAXSIG(IR), I
  820 FORMAT (3I5)
      WRITE (8, 822) (MAXSIG(IR), IR = 1, NR)
  822 FORMAT (' Maximum ISIG found in regions: ', 10I4 / (32X, 10I4))
  830 IF (NP2.EQ.0) GOTO 950
      IF (NP .EQ. 0) THEN
         WRITE (8, 822)
         WRITE (8, FMT='('' ... only polar regions found:'')')
      ELSE
         WRITE (8, FMT='('' ... and for polar regions... '')')
         ENDIF
      NPTOT = 0
      DELB = 2.
      DELC = 4.
      DO 849 I=1,NP2
      IF (NP .EQ. MAXPA) GOTO 920
      NP = NP + 1
      NPT(I) = 1
      MAXSIG(I) = ISIG(NP) + 9999
      IF (I.EQ.1) ISAVE = MAXSIG(I)
      NUMA(I) = 1
      NUMB(I) = 3
      NUMC(I) = 3
      IF (ABS(BPIK(NP)).GT.3. .AND. ABS(180.-BPIK(NP)).GT.3.) GOTO 842
      II = 6
      IF (KLAUE.EQ.3) II=3
      AF(I) = APIK(NP)
      DELA = 60.
      BF(I) = 1.
      IF (ABS(BPIK(NP)).GT.3.) BF(I)=175.
      CF(I) = CPIK(NP) - DELC
      GOTO 843
  842 II = 5
      DELA = 12.5
      AF(I) = APIK(NP) - 2. * DELA
      BF(I) = BPIK(NP) - DELB
      CF(I) = CPIK(NP) - DELC + 2. * DELA
      IF (ABS(BPIK(NP)).GT.12. .AND.ABS(180.-BPIK(NP)).GT.123.) GOTO 843
      BF(I) = BF(I) - 1.
      NUMB(I) = 4
  843 DO 844 J=1,II
      IF (MPAR .EQ. MAXPA) GOTO 920
      CALL STOPAR (AF(I), BF(I), CF(I),
     *   NUMA(I), NUMB(I), NUMC(I), MAXSIG(I))
      NPTOT = NPTOT + NUMA(I) * NUMB(I) * NUMC(I)
      AF(I) = AF(I) + DELA
      CF(I) = CF(I) - DELA
      IF (AF(I).GT.AMAX+5.) THEN
         AF(I) = AF(I) - AMAX
         CF(I) = CF(I) + AMAX
         IF (CF(I) .GT. CMAX+5.) CF(I) = CF(I) - CMAX
         ENDIF
      IF (CF(I) .LT. -5.) CF(I) = CF(I) + CMAX
  844 CONTINUE
  849 CONTINUE
  920 IF (SWPRI) WRITE (8, 820) NP2, ISAVE, NPTOT
      WRITE (8, 922) ISAVE
  922 FORMAT (' Largest value in polar region :', I4)
  950 DELC = DEC / 2.
      RETURN
      END
      SUBROUTINE SIGSEL (DELCX)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (NRUNS, KEYS(4))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      DATA MSIGFR /4/
      DATA DELABC /0.0/
      IF (NRUNS .EQ. 0) IRUN = 0
      IF (NRUNS .EQ. 0) NRUNS = NRUNS + 1
      IRUN = IRUN + 1
      WRITE (8, FMT = '(/'' SIGSEL'', I2)') IRUN
      IF (IRUN .GT. 1) GOTO 106
      DELABC = 2.
         DELAB  = 7.
         DELCA  = 7.
      IF (MPARIN.LE.0) GOTO 110
      DELABC = 0.4 * DELC
      DELAB = 1.5 * DELC
      DELCA = DELAB
      GOTO 110
  106 MSIGFR = MSIGFR + 1
      MSIGFR = MIN0 (MSIGFR, 5)
      DELABC = DELABC * 0.4
      DELAB = DELAB * .75
      DELCA = AMAX1(DELAB, DELCA * .65)
  110 CALL RDMAPS (MSIGFR, NP)
      IF (DELABC.GT.1.9) THEN
         CALL NEBOR  (0, NP, DELAB, DELCA, IANSW)
      ELSE
         CALL NEBORS (0, NP, DELAB, DELCA, CMAX, IANSW)
         ENDIF
      MP = 0
      DO 150 IP = 1,NP
      IF (ISIG(IP).EQ.0) GOTO 150
      MP = MP + 1
      N = IP + 1
      IF (N.GT.NP) GOTO 150
      DO 140 L = N,NP
      IF (ISIG(L).EQ.0) GOTO 140
      IF (DELABC.GT.1.9) THEN
         CALL NEBOR  (IP, L, DELAB, DELCA, IANSW)
      ELSE
         CALL NEBORS (IP, L, DELAB, DELCA, CMAX, IANSW)
         ENDIF
      IF (IANSW.EQ.0) GOTO 140
      ISIG(L) = 0
  140 CONTINUE
  150 CONTINUE
      IF (MP.EQ.NP) GOTO 170
      WRITE (8, 160) MP
  160 FORMAT (' After rejecting neighbors', I4, ' points left')
      CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP)
      NP = MP
      GOTO 180
  170 WRITE (8, 172)
  172 FORMAT (/' No neighbors rejected')
  180 IF (NP .LE. 5)  GOTO 201
      NPMAX = 53
      IF (NP .GT. NPMAX) NP = NPMAX
      IRUNNP = 2*NP + 10*IRUN + 20
      ISMAX = (MIN0 (IRUNNP, 55) * ISIG(1)) / 100
      DO 184 IP = 2,NP
      IF (ISIG(IP) .LT. ISMAX) GOTO 190
  184 CONTINUE
      GOTO 201
  190 NP = IP - 1
  201 WRITE (8, FMT = '(I6,'' Highest points selected'')')  NP
      WRITE (8, FMT = '(/'' Set No.    A      B      C      ISIG'')')
      DO 213 IP = 1,NP
  213 WRITE (8, 214) IP, APIK(IP), BPIK(IP), CPIK(IP), ISIG(IP)
  214 FORMAT (I4, 5X, 3F7.2, I7)
      DELA = DELABC
      DELB = DELABC
      DELC = DELABC
      DELCX = DELC
      IF (DELC.LT.0.35 .OR. IRUN.GE.3) THEN
         WRITE (8,FMT='(///'' DELC, IRUN ='',F6.3, I3/)') DELC, IRUN
         NPKS = NP
         RETURN
         ENDIF
      WRITE (8,32) NP, DELABC
 32   FORMAT (/' New ABC params,',
     * I4, ' sets, size 4*4*4, step-increments  ', F5.2 )
      NUMA = 4
      NUMB = 4
      NUMC = 4
      DO 900 I=1,NP
      AF = APIK(I) - 1.5 * DELA
      BF = BPIK(I) - 1.5 * DELB
      CF = CPIK(I) - 1.5 * DELC
  900 CALL STOPAR (AF, BF, CF, NUMA, NUMB, NUMC, ISIG(IP))
      RETURN
      END
      SUBROUTINE RDMAPS (MSIGFR, NP)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (NRUN,  KEYS(5))
      LOGICAL SWPRI, NIJM
      EQUIVALENCE (NIJM, SWITCH(1)), (SWPRI, SWITCH(10))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      DIMENSION KARR(22)
      DATA MAXPKL / 501 /
      MFR = MAX0 (5, MSIGFR)
      MFR = MIN0 (8, MFR)
      WRITE (8, 108) MFR
  108 FORMAT (/' Subr. RDMAPS:  ISIG-minimum = maximum *',I2 , '/10')
      ISIGM = 0
      ISIGT = 0
      TSIG = 0.
      DO 150 II = 1, 2
      CALL VALDIS (-1, TSIG, 2000., KARR, 22, KEND)
      N = 0
      LSET = 0
      DO 125 I = 1, NPKS
      IF (ISIG3(I,1) .LT. IMIN) THEN
         IF (NRUN .LE. 2) ISIG(I) = 0
         GOTO 125
         ENDIF
      IF (MMM3 .EQ. 3) THEN
         ISIG(I) = (10*ISIG3(I,1) + 3*ISIG3(I,2) + ISIG3(I,3)) / 14
      ELSEIF (MMM3 .EQ. 2) THEN
         ISIG(I) = (2*ISIG3(I,1) + ISIG3(I,2)) / 3
      ELSE
         ISIG(I) =  ISIG3(I,1)
         ENDIF
      IF (ISIG(I).LT.ISIGT) GOTO 125
      IF (NRUN.LE.2) GOTO 24
      IF (NPIK(I).NE.LSET) GOTO 23
      IF (ISIG(I) .LT. ISIG(N)) GOTO 125
      IF (ISIG(I).GT.ISIG(I-1)) GOTO 22
      APIK(N) = (APIK(N) + APIK(I)) / 2.
      BPIK(N) = (BPIK(N) + BPIK(I)) / 2.
      CPIK(N) = (CPIK(N) + CPIK(I)) / 2.
      GOTO 125
   22 ISIG(N) = ISIG(I)
      APIK(N) = APIK(I)
      BPIK(N) = BPIK(I)
      CPIK(N) = CPIK(I)
      GOTO 125
   23 LSET = NPIK(I)
  24  N = N + 1
      ISIG(N) = ISIG(I)
      APIK(N) = APIK(I)
      BPIK(N) = BPIK(I)
      CPIK(N) = CPIK(I)
      TSIG = ISIG(I)
      CALL VALDIS (0, TSIG, DUMM, KARR, 22, KEND)
      IF (ISIG(I).LE.ISIGM) GOTO 125
      ISIGM = ISIG(I)
      ISIGT = MAX0 (ISIGT, (ISIGM*MFR)/10)
  125 CONTINUE
      NPTS = N
      IF (NPTS .LT. MAXPKL) GOTO 200
      WRITE (8,35) NPTS
   35 FORMAT (' Number of ABC points sent by MAPSIG =', I5)
      IF (II .GT. 1) GOTO 200
      IF (NRUN.GE.3) THEN
         I = 7*ISIGM/10
         IF (I .LT. ISIGT) I = 8*ISIGM/10
         IF (I .GT. ISIGT) THEN
            ISIGT = I
            GOTO 30
            ENDIF
         ENDIF
      CALL VALDIS (MAXPKL-50, TSIG, DUMM, KARR, 22, KEND)
      I = TSIG
      ISIGT = MAX0 (I, ISIGT+1)
      IF (ISIGT.LE.ISIGM) GOTO 30
      ISIGT = ISIGM
   30 WRITE (8,36) ISIGT
   36 FORMAT (' Reset min. value for ISIG to ', I5 )
  150 CONTINUE
  200 NP = N
      CALL SORT4 (ISIG, APIK, BPIK, CPIK, NP)
      ISIGTL = MIN0 (6* ISIG(1) / 10 + 1, ISIGT)
      IF (NIJM) write(24, FMT='('' NIJM result from RDMAPS:'',
     *   '' ISIGmax, ISIGlim: '', 2I4)') ISIG(1), ISIGTL
      DO 2 I = 1, NP
      IF (ISIG(I).LT.ISIGTL) GOTO 3
   2  CONTINUE
      GOTO 4
   3  NP = I - 1
   4  IF (NP .GT. MAXPKL) THEN
         ISIGT = ISIG(MAXPKL)
         NP = MAXPKL
         ENDIF
      NPKS = NP
      ISIGTL = ISIG(NP)
      IF (NIJM) write(24, FMT='('' NIJM result from RDMAPS:'',
     *   '' ISIGmax, ISIGmin: '', 2I4)') ISIG(1), ISIGTL
      IF (NIJM) write(24,37) NP, ISIGT
      WRITE (8,37) NP, ISIGT
   37 FORMAT (I4, ' ABC points selected: new ISIGmin = ', I5)
      IF (.NOT. SWPRI) RETURN
      WRITE (8,37) NP, ISIGT
      DO 40 I=1,NP
   40 WRITE (8,41) I,APIK(I),BPIK(I),CPIK(I), ISIG(I)
   41 FORMAT (I5, 7H  ABC = ,3F7.2, 8H  ISIG =, I5)
      RETURN
      END
      SUBROUTINE  NEBOR (IP, NB, DELAB, DELCA, ISW)
      INCLUDE 'Zsyst.inc'
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      IF (IP .GT. 0) GOTO 20
      NP = NB
      WRITE (8, 5) DELAB, DELCA
    5 FORMAT (' Step size for neighbors:    delAB =', F6.2,
     *        '  delCA =', F6.2)
      DO 10 I = 1,NP
      B1 = BPIK(I) * 0.017453
      ASINB(I) = 0.5 * ABS(SIN(B1))
   10 CPLUSA(I) = CPIK(I) + APIK(I)
      GOTO 100
   20 ISW=0
      IF (ABS(BPIK(IP)-BPIK(NB)).GT.DELAB) GOTO 100
      T = ABS(CPLUSA(IP)-CPLUSA(NB))
      IF (T.GT.DELCA) GOTO 100
      T = ASINB(IP) + ASINB(NB)
      IF (ABS (APIK(IP)-APIK(NB))*T.GT.DELAB) GOTO 100
      ISW=1
 100  RETURN
      END
      SUBROUTINE NEBORS (IP, NB, DELAB, DELCA, CMAX, ISW)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (KLAUE, KEYS(6))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      DATA AMAX, CAMAX, AMAX2, CAMAX2 / 4 * 0.0/
      IF (IP .GT. 0) GOTO 20
      NP = NB
      WRITE (8, 5) DELAB, DELCA
    5 FORMAT (' Step size for neighbors:    delAB =', F6.2,
     *                                   '  delCA =', F6.2)
      DO 10 I = 1,NP
      B1 = BPIK(I) * 0.017453
      ASINB(I) = 0.5 * ABS(SIN(B1))
   10 CPLUSA(I) = CPIK(I) + APIK(I)
      AMAX = 360.
      IF (KLAUE.EQ.3) AMAX = 180.
      CAMAX = AMIN1(CMAX, AMAX)
      CAMAX2 = CAMAX / 2.
      AMAX2 = AMAX / 2.
      GOTO 100
   20 ISW=0
      KSYM = 0
      IF (ABS(BPIK(IP)-BPIK(NB)).LE.DELAB) KSYM = 1
      IF (ABS(BPIK(IP)+BPIK(NB)).LE.DELAB .OR.
     *    ABS(BPIK(IP)+BPIK(NB) - 360.).LE.DELAB) KSYM = KSYM + 2
      IF (KSYM.EQ.0) GOTO 100
      T = AMOD (ABS(CPLUSA(IP)-CPLUSA(NB)), CAMAX)
      IF (T.GT.CAMAX2) T=ABS(CAMAX-T)
      IF (T.GT.DELCA) GOTO 100
      IF (KSYM.EQ.2) GOTO 50
      TT = ASINB(IP) + ASINB(NB)
      T = AMOD (ABS(APIK(IP)-APIK(NB)), AMAX)
      IF (T.GT.AMAX2) T=ABS(AMAX-T)
      IF (T * TT .LE.DELAB) GOTO 90
 50   IF (KSYM.EQ.1) GOTO 100
      TT = ABS(ASINB(IP) - ASINB(NB))
      T = AMOD (ABS(APIK(IP)-APIK(NB) + 180.), AMAX)
      IF (T.GT.AMAX2) T=ABS(AMAX-T)
      IF (T * TT .GT.DELAB) GOTO 100
  90  ISW=1
 100  RETURN
      END
      SUBROUTINE STOPAR (AI, BI, CI, NA, NB, NC, ISIG)
      INCLUDE 'Zsyst.inc'
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      PARAMETER (MAXPA = 100)
      COMMON /SCANDA/ MPARIN, DELAB, DELCA, DELA, DELB, DELC, CMAX,
     *                MPAR, PAR1(3,MAXPA), PAR2(3,MAXPA), NPAR(3,MAXPA),
     *                MININ, MINM(3), MMM, MM(3), LMINC(65,3), NPOINT,
     *           AAA(3), SSS(3), KWVLEN, FVMIN, MIN4(4), IPARAV(MAXPA)
      MPAR = MPAR + 1
      PAR1(1,MPAR) = AI
      PAR1(2,MPAR) = BI
      PAR1(3,MPAR) = CI
      PAR2(1,MPAR) = DELA
      PAR2(2,MPAR) = DELB
      PAR2(3,MPAR) = DELC
      NPAR(1,MPAR) = NA
      NPAR(2,MPAR) = NB
      NPAR(3,MPAR) = NC
      IF (SWPRI .AND. MPAR.EQ.1)
     *   WRITE (8, FMT='(16X, ''New ABC parameters''/ 16X,
     *  ''Set   Ast  Ainc NA    Bst  Binc NB    Cst  Cinc NC  ISIG'')')
      IF (SWPRI) WRITE (8, 101)
     *  MPAR, AI, DELA, NA, BI, DELB, NB, CI, DELC, NC, ISIG
  101 FORMAT (I19, 3(F7.2, F6.2, I3), I5)
      RETURN
      END
      SUBROUTINE SORT4 (IX, A, B, C, N)
      DIMENSION IX(N), A(N), B(N), C(N)
      IF (N.LE.1)  RETURN
      K = 2
   10 K = K + K
      IF (K.LT.N) GOTO 10
      K = MIN0 (N, (3*K)/4 - 1)
   20 K = K/2
      L = N-K
      DO 200 II=1,L
      I = II
      J = I+K
      IF (IX(I).GE.IX(J)) GOTO 200
      IT = IX(J)
      AT = A(J)
      BT = B(J)
      CT = C(J)
   80 IX(J)= IX(I)
      A(J) = A(I)
      B(J) = B(I)
      C(J) = C(I)
      J = I
      I = I-K
      IF (I) 140,140,120
  120 IF (IX(I).LT.IT) GOTO 80
  140 IX(J)= IT
      A(J) = AT
      B(J) = BT
      C(J) = CT
  200 CONTINUE
      IF (K.NE.1) GOTO 20
      RETURN
      END
      SUBROUTINE ORDEK
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IFMAP, IFILE(17))
      EQUIVALENCE (KLAUE, KEYS(6)),  (IPRPAT, KEYS(8))
      EQUIVALENCE (SCADEK, KEYS(26))
      EQUIVALENCE (SINGPK, KEYS(27)), (ORIGIN, KEYS(28))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (IMAP, KSTAT(7))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      EQUIVALENCE (NX,NXYZ(1)), (NY,NXYZ(2)), (NZ,NXYZ(3))
      INTEGER * 2 LPAT(198)
      DIMENSION NXYZM(3)
      EQUIVALENCE (NXM,NXYZM(1)), (NYM,NXYZM(2)), (NZM,NXYZM(3))
      DATA JXYZC, LXYZC / 0, 0 /
      DATA IZ, KXYZC, IXYZC / 0, 0, 0 /
      DATA NCALL / 0 /
      IF (NCALL .GT. 0) RETURN
      NCALL = NCALL + 1
      ILMAX = 49
      DO 111 I = 1, NUMTAB
 111  ITAB(I) = 0
      MAXFUN = 30254
      N254 = 0
      MIFUN = 0
      FUNSUM = 0.
      ILMA = ILMAX
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) CALL KERROR
     *   ('Patterson file (FMAP) not found.', -1, 'PATIN')
      READ (IFMAP) FFTSC, IMAPX, IHALF
      WRITE (8, FMT='('' IMAP, IHALF, FFTSC ='',
     *   2I3, F10.5)') IMAP, IHALF, FFTSC
      IF (IMAP .NE. 2 .AND. IMAP .NE. 6) CALL KERROR
     *   ('No Patteron function (error on file FMAP)', 0 , 'PATIN' )
      READ (IFMAP) NX, NZ, NYHALF, NY
      WRITE (8,6) NX, NY, NZ
   6  FORMAT (' Fourier grid X * Y * Z = ' , I3, 2(' *',I3) )
      SCAL = 0.2
      ABSCAL = SCAL * FFTSC * VOLUM
      SINGPK = ORIGIN * ABSCAL * 18. /VOLUM
      IF (SWPRI) WRITE (8, 138) FFTSC
  138 FORMAT (/' Input Patterson scale = ',12X, F10.5,' * volume ')
      WRITE (8,1138) FFTSC
 1138 FORMAT (' $TE ORDEK Input SCALE: SCALOR = 3000 / sumF2 =' , F9.5)
      WRITE (8, 152) SCAL, ABSCAL, SINGPK
  152 FORMAT (' Input function values will be multiplied by: ', F10.5 /
     *        ' To put the Patterson function on abs.scale *  ', F9.5 /
     *        ' Single-vector peak-height is approximately   ' ,F10.2 /)
      K = 0
   10 DO 12 I=1,3
      L = (NXYZ(I)+1) / 2
      IF (L.GT.ILMAX) K=1
      LXYZ(I) = MIN0 (L, ILMAX)
   12 IS(I) = 0
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2)
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3)
      DO 14 I=1,3
      NXYZM(I) = NXYZ(I)
      IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1
   14 NUM(I) = LXYZ(I) - IS(I) + 1
      NUMXY = NUM(1) * NUM(2)
      NUMXYZ = NUMXY * NUM(3)
      IF (NUMXYZ .LE. NUMTAB) GOTO 15
          ILMAX = ILMAX - 1
          GOTO 10
   15 IF (ILMA .NE. ILMAX) THEN
         WRITE (24,16) ILMAX
   16    FORMAT (' STORAGE PROBLEMS: ILMAX = ',I3, ' POINTS. ')
         ENDIF
      DO 217 I = 1,3
  217 GTXYZ(I) = NXYZ(I)
      VMAXDE = 9999.
      DO 18 I=1,3
      VV = (FLOAT(ILMAX) / FLOAT(NXYZ(I))) / RCELL(I)
   18 IF (VV .LT. VMAXDE) VMAXDE = VV
      IF (K .EQ. 1) WRITE (8, 20) VMAXDE
   20    FORMAT (' DEK-storage limitations: max vector length:', F6.2)
      NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1
      IF (IPRPAT .GT. 0) THEN
         WRITE (24, FMT=
     *      '('' Print input Patterson map to printer LIS2'')')
         WRITE (8,24) (I, I=1, NUM(1)-1)
  24     FORMAT (/' Input Patterson map, file FMAP'//
     *      '  IY  IZ  IX = 0' , 24I4 / (12X, 25I4))
         WRITE (8, FMT='('' '')')
         ENDIF
      IF (NYM .GT. NYHALF) THEN
         WRITE (9,*)' Please tell PTB: NYM gt NYHALF '
         NYM=NYHALF
         ENDIF
      DO 50 I1=1,NYM
      IY = I1 - 1
      KY = IY - NY
      IXY = NUM(1) * IY
      KXY = NUM(1) * KY
      K = 1
      IF (IS(2).EQ.0) GOTO 26
      IF (IY .GT. LXYZ(2)) K=3
      IF (IY.EQ.LXYZ(2) .OR. IY.EQ.NY/2) K=2
      IF (K.EQ.2 .AND. IY.GT.ILMAX) K=3
      IF (K.EQ.2 .AND. KY+ILMAX.LT.0) K=1
      IF (K.EQ.1 .AND. IY.GT.ILMAX) K=0
      IF (K.EQ.3 .AND. KY+ILMAX.LT.0) K=0
      IF (K.EQ.3) IXY=KXY
   26 DO 48 I2=1,NZ
      IF (I2.GT.NZM) K=0
      IF (K.EQ.0) GOTO 28
      IZ = I2 - 1
      IXYZ = NUMXY * IZ
      IXYZC = IXYZ + IXY - NUMC
      KXYZC = IXYZ + KXY - NUMC
      L = 1
      IF (IS(3).EQ.0) GOTO 28
      KZ = IZ - NZ
      JXYZ = NUMXY * KZ
      JXYZC = JXYZ + IXY - NUMC
      LXYZC = JXYZ + KXY - NUMC
      IF (IZ.GT.LXYZ(3)) L=3
      IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2
      IF (L.EQ.2 .AND. IZ.GT.ILMAX) L=3
      IF (L.EQ.2 .AND. KZ+ILMAX.LT.0) L=1
      IF (L.EQ.1 .AND. IZ.GT.ILMAX) L=0
      IF (L.EQ.3 .AND. KZ+ILMAX.LT.0) L=0
      IF (L.EQ.3) IXYZC=JXYZC
      IF (L.EQ.3) KXYZC=LXYZC
   28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX)
      IF (K.EQ.0 .OR. L.EQ.0) GOTO 48
      DO 40 I3=1,NXM
      FUN = LPAT(I3)
      FUN = 99. * ( FUN * SCAL + 25. )
      IFUN = NINT(FUN)
      IF (IFUN) 32, 32, 30
   30 IF (IFUN.GT.MIFUN) MIFUN=IFUN
      IF (IFUN .LE. MAXFUN) GOTO 36
      IFUN = MAXFUN
      N254 = N254 + 1
      GOTO 36
   32 IFUN = 0
   36 LPAT(I3) = IFUN
      FUNSUM = FUNSUM + FLOAT(IFUN)
      IX = I3 - 1
      IADR = IXYZC + IX
      ITAB(IADR) = IFUN
      IADR = JXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN
      IF (K.NE.2) GOTO 40
      IADR = KXYZC + IX
      ITAB(IADR) = IFUN
      IADR = LXYZC + IX
      IF (L.EQ.2) ITAB(IADR) = IFUN
   40 CONTINUE
      IF (IPRPAT.GT.0) WRITE (8,42) IY,IZ, (LPAT(I3), I3=1,NUM(1))
   42 FORMAT (2I4, 4X, 25I4 / (12X, 25I4))
   48 CONTINUE
   50 CONTINUE
         CALL FILCLO (IFMAP, 'KEEP')
      FUNSUM = FUNSUM / FLOAT(NUMXYZ)
      IFUN = FUNSUM
      WRITE (8,52) MIFUN, N254, MAXFUN, IFUN
   52 FORMAT (' Largest scaled Patterson value is: ', 15X, I5, /
     *         15X, I5,' values exceeded: '  , 13X, I5, /
     *         20X,    ' averaged value is: ', 11X, I5, /)
      CALL PATMOD
      RETURN
      END
      SUBROUTINE PATMOD
      INCLUDE 'Zsyst.inc'
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (KLAUE,  KEYS(6))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      EQUIVALENCE (NUMX, NUM(1)), (NUMY,NUM(2)), (NUMZ,NUM(3))
      IF (KLAUE.EQ.1) RETURN
      IF (SWPRI) WRITE (8, FMT = '(
     * ''0Reduce Patterson values of mirror faces'' )')
      GOTO (2,2,3,4), KLAUE
   2  CONTINUE
      DO 22 K = 1,2
      DO 22 L = 1,3
      FF = .85
      IF (K.EQ.1 .OR. L.EQ.2) FF = .75
      IF (K.EQ.1 .AND.L.EQ.2) FF = .5
      IX = K - 1
      IZ = L - 2
      IY = IS(2) - 1
      DO 22 I = 1, NUMY
      IY = IY + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  22  CONTINUE
      GOTO 3
   4  CONTINUE
      DO 440 K = 1,2
      DO 440 L = 1,3
      FF = .85
      IF (K.EQ.1 .OR. L.EQ.2) FF = .75
      IF (K.EQ.1 .AND.L.EQ.2) FF = .5
      IX = K - 1
      IY = L - 2
      IZ = IS(3) - 1
      DO 440 I = 1, NUMZ
      IZ = IZ + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  440 CONTINUE
  3   CONTINUE
      GOTO (20,20,30,40) , KLAUE
  30  DO 31 K=1,2
      IX = K - 1
      FF = .5
      IF (IX.EQ.1) FF=.75
      IY = IS(2) - 1
      DO 31 I = 1, NUMY
      IY = IY + 1
      IZ = IS(3) - 1
      DO 31 J = 1, NUMZ
      IZ = IZ + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  31  CONTINUE
  20  DO 21 K=1,2
      IY = K - 1
      FF = .5
      IF (IY.EQ.1) FF=.75
      IX = IS(1) - 1
      DO 21 I = 1, NUMX
      IX = IX+ 1
      IZ = IS(3) - 1
      DO 21 J = 1, NUMZ
      IZ = IZ + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  21  CONTINUE
      IF (KLAUE.EQ.2) RETURN
  40  DO 41 K=1,2
      IZ = K - 1
      FF = .5
      IF (IZ.EQ.1) FF=.75
      IX = IS(1) - 1
      DO 41 I = 1, NUMX
      IX = IX+ 1
      IY = IS(2) - 1
      DO 41 J = 1, NUMY
      IY = IY + 1
      IADR = NUMXY * IZ + NUMX * IY + IX - NUMC
      IJX = ITAB(IADR)
      FFF = FLOAT( IJX )
      IFUN = NINT (FFF * FF)
      ITAB(IADR) = IFUN
  41  CONTINUE
      RETURN
      END
      SUBROUTINE RDOUT (ARG, FUNF)
      DIMENSION ARG(3)
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (ITPL,  KEYS(7))
      PARAMETER (MAXPK = 1234, NUMTAB = 200000)
      COMMON /BLANK/ NPIK(MAXPK), APIK(MAXPK), BPIK(MAXPK), CPIK(MAXPK),
     *               ISIG(MAXPK), ASINB(MAXPK), CPLUSA(MAXPK), NPKS,
     *               ISIG3(MAXPK,3), MMM3, IMIN, ITAB, DUMMY(47657)
      INTEGER *2 ITAB(NUMTAB)
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VMAXDE
      EQUIVALENCE (NX, NUM(1)), (NXY, NUMXY)
      DIMENSION  IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)),  (IYFAR,IFAR(2)),  (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)),     (RY,RARG(2)),     (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)),      (FMY,FM(2)),      (FMZ,FM(3))
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
  301 IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
      CALL SYMM (RX, RY, RZ)
      IF (ITPL.EQ.2) GOTO 1000
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
  555 F=T-FLOAT(I)
      IF (F) 560,590,570
  560 F=F+1.0
  570 IF (F-0.5) 590,580,580
  580 FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
  590 FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
  599 CONTINUE
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      IJX = ITAB(K111)
      FUNNER = FLOAT( IJX ) / 99.
      K211=K111-IXNEAR+IXFAR
      K121=K111+NX*(IYFAR-IYNEAR)
      K112=K111+NXY*(IZFAR-IZNEAR)
      IJX = ITAB(K211)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K121)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K112)
      FUNZ = FLOAT( IJX ) / 99.
      FUNF = FUNNER * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ
      IF (ITPL .NE. 4) GOTO 610
      FUNF = AMAX1 (FUNF, 0.25 * (FUNNER + FUNX + FUNY + FUNZ) )
      RETURN
  610 I1=IZFAR*NXY
      I2=IYFAR*NX
      K222 = I1 + I2 + IXFAR - NUMC
      K122=K222-IXFAR+IXNEAR
      K212=K222-I2+NX*IYNEAR
      K221=K222+NXY*IZNEAR-I1
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      IJX = ITAB(K122)
      FUNYZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K212)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K221)
      FUNXY = FLOAT( IJX ) / 99.
      FMXY=FMX*FMY
      FMXZ=FMX*FMZ
      FMYZ=FMY*FMZ
      FMXYZ=FMX*FMYZ
      T1=FMYZ-FMXYZ
      T2=FMXZ-FMXYZ
      FUNF = FUNF + FMXYZ*FUNFAR + T1*FUNYZ + T2*FUNXZ +
     1 (FMXY-FMXYZ)*FUNXY + FUNNER*(T1+FMXZ+FMXY) - FUNZ*(T2+FMYZ)
     1 - FUNY*(T1+FMXY) - FUNX*(T2+FMXY)
      RETURN
 1000 DO 712 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      I = IFIX(T)
      IF (T.GE.0.) GOTO 711
      I = I - 1
      IF (I.LT.-LXYZ(IX)) I=I+1
      GOTO 712
  711 IF (I.EQ.LXYZ(IX)) I=I-1
  712 INEAR(IX) = I
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      K222 = K111 + 1 + NX + NXY
      IJX = ITAB(K111)
      FUNNER = FLOAT( IJX ) / 99.
      IJX = ITAB(K111 + 1)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K111 + NX)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K111 + NXY)
      FUNZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      IJX = ITAB(K222 - 1)
      FUNYZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K222 - NX)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K222 - NXY)
      FUNXY = FLOAT( IJX ) / 99.
      FUNF= AMAX1(FUNNER, FUNX, FUNY, FUNZ, FUNFAR, FUNYZ, FUNXZ, FUNXY)
      RETURN
      END
      SUBROUTINE TRACOR
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATOMS, IFILE(1)), (IATTRA, IFILE(2))
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (IR2MIN, KSTAT(15)), (IFOMAX, KSTAT(16))
      DIMENSION KARR(20)
      DIMENSION SEDEL2(50,2)
      CHARACTER*6 CALLI
      INCLUDE 'Zena1.inc'
      DATA NCALL /0/
      IF (NCALL .EQ. 0) CALLI  = LITJ2
      CALL KEPROG('TRACOR')
  100 NCALL = NCALL + 1
      IF (CALLI .EQ. 'ORIENT') THEN
         IORIE = IORIE + 1
         write(24, 133) IORIE
  133    FORMAT (50X, 'input atoms set nr:', I3)
      ELSE
         IORIE = 0
         CALL KERASE ('ATTRA')
         CALL KERASE ('ATVEC')
         ENDIF
      KEY = IORIE
      CALL WR24
      CALL RDCRYS (ICRYS)
      IF (IPOLA .EQ. 7) CALL KERROR
     *      ('TRACOR not applicable to space group P1' , 0, 'TRACOR')
      INCLUDE 'Zena2.inc'
  149 FORMAT (/ ' Space groups ',A9, ' and ', A9,
     * ' are identical for ORIENT' /
     * ' therefore TRACOR also analyses the inverted results of ORIENT!'
     * /' Note: you must change the space groep in case program BIJVOET'
     * /'       calculates a reliable negative BIJVOET coefficient.'//)
  200 CONTINUE
      CALL WR24
      CALL FCALIN (KEY, KSPGR)
      CALL FCALCX
      CALL TRACIN
      CALL COTRA1
      IF (IPOLA .LE. 0) THEN
         CALL D3FOUR
         CALL FILCLO (IBINFF, 'DELETE')
      ELSE
         CALL D12FOU
         ENDIF
      CALL COTRA3
      CALL R2TRAC (SEDEL2)
      CALL SHIFTR (SEDEL2)
      IF (KSPGR .EQ. 1) ISPGR = ISPGR + 1
      IF (ISPGR .NE. 1) GOTO 300
      CALL FILCLO (12, 'KEEP')
      write(24,FMT='('' Rerun TRACOR for enantiomorphous partner''/)')
      WRITE(8,FMT='('' Rerun TRACOR for enantiomorphous partner''/)')
      KEY = -1
      GOTO 200
  300 CONTINUE
      IF (CALLI .NE. 'ORIENT') GOTO 600
      KEY = IORIE
      CALL ORSETS (MERK)
      IF (MERK .EQ. -1) GOTO 400
      WRITE (8, FMT='(/)')
      write(24, 105)
  105 FORMAT (//' ============ Program TRACOR'/
     *          ' ==========================='/)
      CALL WR24
      GOTO 100
  400 CONTINUE
      NRMOD = 0
      R2MIN = FLOAT(IR2MIN) / 1000.
      write(24, FMT='(/'' Table 801-1''/
     *  '' Summary of all TRACOR results    '',
     *  ''R2MIN ='', F7.3, ''     IFOMAX ='', I4 /
     *  34X, ''FOM= corrected for CBOTS by -X %''/
     *  34X, ''FOMQ= FOM * SQRT(Q2) = combined fom''/ /
     *  '' ####  MOD= OR= TR=   R2=   Q2=   FOM=  FOMQ=  CBOTS''/)')
     *    R2MIN, IFOMAX
      FOMAX = FLOAT(IFOMAX)
      FOMIN = 90.
      Call VALDIS (-1, FOMIN, FOMAX, KARR, 20, KEND)
      CALL FILCLO (IATTRA, 'KEEP')
      CALL FILINQ (IATTRA, 'ATTRA', 'FORMATTED', 'INPUT', KINQ)
      XXFRAC = 0.90
      XXXADD = (1.-R2MIN) * XXFRAC
      XXX = R2MIN + XXXADD
  501 CONTINUE
      CALL KERINA (IATTRA, LIT, 1, LEND)
      IF (LEND .EQ. -1) GOTO 511
      IF (LIT(1) .NE. 'ATOMS ') GOTO 501
      IF (NFNUM .LE. 0) STOP  501
      NRMOD = NRMOD +1
      NMOD = NINT (FNUM(1))
      NOR = NINT (FNUM(2))
      NTR = NINT (FNUM(3))
      R2 = FNUM(4)
      IFOM = NINT (FNUM(5))
      Q2 = ( XXX - R2 ) / XXXADD
      IF (Q2 .LE. 0.) THEN
         IFOMQ = 0
      ELSE
         IFOMQ = NINT (SQRT(Q2) * FNUM(5))
         ENDIF
      write(24, FMT='(I5, I6, 2I4, 2F6.3, 2I7, 3X, A5)')
     *   NRMOD, NMOD, NOR, NTR, R2, Q2, IFOM, IFOMQ, CHIN(66:70)
      FFOMQ = FLOAT (IFOMQ)
      Call VALDIS (0, FFOMQ, DUMMY, KARR, 20, KEND)
      GOTO 501
  511 CONTINUE
      IF (NRMOD .LE. 197) IFOMAX = 0
      IF (NRMOD .LE. 197) GOTO 600
      Call VALDIS (180, FOLIM, DUMMY, KARR, 20, KEND)
      write(24, FMT='(/'' For about 180 sets, FOMQ limit is'',
     *   F6.0 /)') FOLIM
      write(24, FMT='(/'' Table 801-2''/
     *  '' Summary of top TRACOR results (unsorted) '' /
     *  34X, ''FOM= corrected for CBOTS by -X%''/
     *  40X, ''FOMQ= FOM * SQRT(Q2) = combined fom''/
     *  '' ####  MOD= OR= TR=   R2=   Q2=   FOM=  FOMQ=  CBOTS''/)')
      IFOMAX = NINT(FOLIM)
      REWIND IATTRA
      NRMOD = 0
      IFOLIM = NINT(FOLIM)
      XXFRAC = 0.90
      XXXADD = (1.-R2MIN) * XXFRAC
      XXX = R2MIN + XXXADD
  521 CALL KERINA (IATTRA, LIT, 1, LEND)
      IF (LEND .EQ. -1) GOTO 531
      IF (LIT(1) .NE. 'ATOMS ') GOTO 521
      IFOM = NINT (FNUM(5))
      NRMOD = NRMOD +1
      NMOD = NINT (FNUM(1))
      NOR = NINT (FNUM(2))
      NTR = NINT (FNUM(3))
      R2 = FNUM(4)
       Q2 = ( XXX - R2 ) / XXXADD
      IF (Q2 .LE. 0.) THEN
         IFOMQ = 0
      ELSE
         IFOMQ = NINT (SQRT(Q2) * FNUM(5))
         ENDIF
      IF (IFOMQ .LT. IFOLIM) GOTO 521
      write(24, FMT='(I5, I6, 2I4, 2F6.3, 2I7, 3X, A5)')
     *   NRMOD, NMOD, NOR, NTR, R2, Q2, IFOM, IFOMQ, CHIN(66:70)
      GOTO 521
  531 CONTINUE
  600 CONTINUE
      CALL KEPROX
      RETURN
      END
      SUBROUTINE FCALIN (KEY, KSPGR)
      INCLUDE  'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zotra.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      EQUIVALENCE (IATOMS, IFILE(2))
      EQUIVALENCE (ICRYS,IFILE(3))
      EQUIVALENCE (ICON, IFILE(4))
      EQUIVALENCE (IATTEM, IFILE(10))
      EQUIVALENCE (NORIE, KEYS(9))
      EQUIVALENCE (IFLEX, KSTAT(12))
      DIMENSION TEMP(10)
      PARAMETER (LCMAX = 15)
      CHARACTER * 6 LCONDA(LCMAX)
      DATA LCONDA / 'TRACOR', 'EMIN'  , 'SCSG'  , 'BHSG'  , 'DAMP'  ,
     *              'SCALE' , 'BBB'   , 'STLMAX', 'SMM'   , 'MAXHKL',
     *              'PRIMAP', 'PSQMAX', 'XXXXXX', 'WILSON', 'PRINT' /
      CALL WR24
      IF (KEY .EQ. -1 ) THEN
         CALL FILCLO (IATOMS, 'KEEP')
         CALL FILCLO (IATTEM, 'KEEP')
         CALL KERASE ('ATOMS')
         CALL COPY80 (IATTEM, 'ATTEM', IATOMS, 'ATOMS')
         GOTO 1140
         ENDIF
      IFLEX = 0
      WRITE (8, 101)
  101 FORMAT (/' Structure factor calculation for TRACOR:'
     *     / ' EXPAND data to P1 symmetry (or centered equivalent)'/)
      DO 110 I=1,NTYPE
  110 TEMP(I) = CELALL(I) / ZET
      I = NTYPE
      J = NINT(ZET)
      WRITE (8, 114) J, (CELATY(K), TEMP(K), K=1,I)
  114 FORMAT (' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) /
     *                           ( 8X, 6(2X,A2,F6.1)))
      SCALE = SCAMER
      BOV = BOVMER
      BP = BOV
      BR = BOV
      WRITE (8, 116) SCALE, BOV
  116 FORMAT (' Data from MERBIN: Scale =', F9.5, ' Bov:', F6.3)
      CALL KERF2I (HKLMAX, MAXHKL, 3)
      EMIN = 0.0
      SCX = SCALE
      BOVX = BOV
      DAMPX = BP
      SMM  = 0.00001
      IOMAPS = 0
      SMAX = STLMAX
  120 CALL RDCOND (ICON, LCONDA, LCMAX, KEND)
      GOTO (120, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 120, 120,120), KEND
      IF (KEND.LE.0) GOTO 140
  2   EMIN = FNUM(1)
      write(24, FMT = '('' Input value for Emin: '', F10.2)') EMIN
      GOTO 120
  3   SCSG = FNUM(1)
      IF(SCSG .LT. 0.001) SCSG = 1.0000
      SCX = SCALE * SCSG
      write(24, FMT = '('' SCALE '', F10.5,'' = SCALE '', F10.5,
     * '' multiplied by extra scale: '', F10.5)') SCX, SCALE, SCSG
      GOTO 120
  4   BHSG=FNUM(1)
      BOVX = BOV + BHSG
      write(24, FMT = '('' Input: additional Bp'', F10.5 )') BHSG
      write(24, FMT = '('' Now to be used:  Bov'', F10.5 )') BOVX
      GOTO 120
  5   DAMP = 0.5 * FNUM(1)
      DAMPX = DAMPX - DAMP
      write(24, FMT = '('' Supplied: damping parameter '', F10.5)')
     * FNUM(1)
      GOTO 120
  6    GOTO 120
  7    GOTO 120
  8    GOTO 120
  9   SMM =FNUM(1)
      IF(SMM.LT.0.0001) SMM=0.000001
      write(24, 129) SMM
  129 FORMAT (' Input factor (for testruns) SMM =     ', F8.4)
      GOTO 120
  10    GOTO 120
  11  IOMAPS = 1
      GOTO 120
  12  CONTINUE
      WRITE (9, *) '   PSQMAX in TRACOR obsolete: ignored'
      GOTO 120
  140 CALL FILCLO (ICON, 'KEEP')
 1140 CONTINUE
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found',
     *   140, 'FCALIN')
      CALL KERINA (IATOMS, LIT, 1, LEND)
      IF (LIT(1) .NE. 'ATOMS') CALL KERROR
     *   (' Incorrect header on ATOMS file', 143, 'FCALIN')
      IF (LIT(4) .EQ. 'ORIENT') THEN
         IFLEX = NINT (FNUM(2))
         NORIE = NINT (FNUM(3))
         write(24, 141) IFLEX, NORIE
         WRITE (8, 141) IFLEX, NORIE
  141 FORMAT (44X, 'input ORIENT MOD=', I4, ' OR=', I3)
         ENDIF
      BACKSPACE IATOMS
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      IF (KEYT .GT. 1) write(24, FMT='(
     *  '' Temperature factors present in ATOMS file ignored'')')
      KEYT = 1
      NATQ = NAT
      NATH = 0
      N = 1
  143 CONTINUE
      IF (ATNAME(N)(1:1).EQ.'H' .AND. IZAT(N).EQ.1) NATH = NATH + 1
      IF (ATNAME(N)(1:1).EQ.'H' .OR.  IZAT(N).EQ.1 .OR.
     *      ATNAME(N)(1:1) .EQ. 'Q') THEN
         IF (N .EQ. NAT) GOTO 148
         DO 146 N1 = N, NAT - 1
         CALL KERNAB (ATXYZ(1,N1+1), ATXYZ(1,N1), 4)
         ATNAME(N1) = ATNAME(N1+1)
  146    IZAT(N1) = IZAT(N1+1)
  148    NAT = NAT - 1
         N = N - 1
         ENDIF
      CALL KERNZA (0.0, ATXYZ(5,N), 6)
      N = N + 1
      IF (N .LE. NAT) GOTO 143
      IF (NATH .NE. 0) write(24, FMT=
     *  '('' Number of H atoms rejected:'', I3)') NATH
      N = NATQ - NAT - NATH
      IF (N .GT. 0) write(24, FMT=
     *  '('' Nr of Q-atoms (= peaks) rejected:'', I3)') N
      IF (NAT .LE. 0) CALL KERROR ('.... No atoms left!', 0, 'FCALIN')
      CALL WR24
      CALL ATOMPR (7, 5, ATXYZ, ATNAME, IZAT, NAT)
      CALL ATOMPR (8, 2, ATXYZ, ATNAME, IZAT, NAT)
      IF (KEY .NE. -1 .AND. KSPGR .EQ. 1) THEN
         REWIND IATOMS
         CALL FILINQ (IATTEM, 'ATTEM', 'FORMATTED', 'OUTPUT', KINQ)
         CALL KERINA (IATOMS, LIT, 1, LEND)
         WRITE (IATTEM, FMT='(A)') CHIN
         CALL KERINA (IATOMS, LIT, 1, LEND)
         WRITE (IATTEM, FMT='(A)') CHIN
         DO 200 I = 1, NAT
         AX = 1.0 - ATXYZ(1, I)
         AY = 1.0 - ATXYZ(2, I)
         AZ = 1.0 - ATXYZ(3, I)
         WRITE (IATTEM, 199) ATNAME(I), AX, AY, AZ
  199       FORMAT ('ATOM   ', A6, 3F9.5)
  200    CONTINUE
         WRITE (IATTEM, FMT='(''END '')')
         CALL FILCLO (IATTEM, 'KEEP')
         ENDIF
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
      RETURN
      END
      SUBROUTINE FCALCX
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IBINFC, IFILE(12))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zddif.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      NITFC2 = 3 + 2 * NSYMM
      WRITE (24, FMT='('' Calculate structure factors'')')
      WRITE (24, 183) P1SQ
  183 FORMAT (' Scattering fraction of known part:'/
     *   '    excluding symmetry related molecules: P1**2 =', F6.3)
      CALL BINOFF (1, IBINFC,'BINFC2', FITFC2, NITFC2, BUFFC, KENDFC)
      IREFL  = 0
      SUMNR2 = 0.
      R2SUMA = 0.
      R2SUMB = 0.
      ALATT2 = NLATT * NLATT
      IREFX = 0
  200 CONTINUE
      IREFX = IREFX + 1
      HCODE = FBINX(1,IREFX)
      FOBS = FBINX(2,IREFX)
      IF (FOBS .LT. 0.) GOTO 220
      SIG = FBINX(3,IREFX)
      CALL HKLC1U (HCODE, HKLX)
      CALL HKLSTL (HKLX, STL, STL2)
      IF (STL.GT.STLMAX .OR. HKLX(1,1).GT.HKLMAX(1) .OR.
     *      HKLX(2,1).GT.HKLMAX(2) .OR. HKLX(3,1).GT.HKLMAX(3)) THEN
         FITFC2(1) = -999.
         GOTO 215
         ENDIF
      CALL FCALX1 (ATXYZ, ITAT, NAT)
      SUMNR2 = SUMNR2 + ASYMM / EPSIL2
      SF2 = SUMF2 (ISS)
      SF2P= SUMF2P(ISS)
      IREFL = IREFL + 1
      G2 =  EXPBR(ISS) * EXPBR(ISS) * SUMF2(ISS) * ALATT2
      IF (ABS (G2) .LT. 0.00001) THEN
         write(24, FMT='('' G2, SF2, iss, NREFL'', 2F10.3, 2I3)' )
     *      G2, SF2, ISS, IREFL
         STOP 803
         ENDIF
      EO2 = ( SCALE * FOBS ) **2 / G2
      EO4 = EO2 * EO2
      DO 207 I = 1, NSYMM
      IF (FPEXP(1,I) .LT. 0.) GOTO 207
      R2SUMA = R2SUMA + (EO2 - FPEXP(1,I)*FPEXP(1,I)/G2)**2
      R2SUMB = R2SUMB + EO4
  207 CONTINUE
  215 CONTINUE
         FITFC2(1) = EPSIL2
         FITFC2(2) = SF2
         FITFC2(3) = SF2P
         CALL KERNAB (FPEXP, FITFC2(4), NITFC2-3)
      CALL BINOFF (0, IBINFC, 'BINFC2',FITFC2, NITFC2, BUFFC, KENDFC)
      GOTO 200
  220 CONTINUE
      CALL BINOFF (-1, IBINFC, 'BINFC2',FITFC2, NITFC2, BUFFC, KENDFC)
      IF (IREFL.NE.NREFL) write(24, 242) IREFL
  242 FORMAT (' Note:', I6,' input reflections accepted ')
      WRITE (24, 254) NINT(SUMNR2)
  254 FORMAT (' Number of reflections after expansion:', I12)
      WRITE (24, 258)
  258 FORMAT (' Structure factor calculation finished')
      R2 = R2SUMA / R2SUMB
      R2E = 1. - P1SQ
      WRITE (24, FMT='(/'' R2 for the model in SpGr P1:'', F5.2,
     *  ''   ( expected:'', F5.2, '' )''/ 34(''-'')/ )') R2, R2E
      CALL WR24
      RETURN
      END
      SUBROUTINE FCALX1  (ATXYZ, ITAT, NAT77)
      DIMENSION ATXYZ(10,NAT77), ITAT(NAT77)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      DIMENSION FFF(10)
      S = STL * 400. + 1.
      IS = IFIX(S)
      STLDEL = S - FLOAT(IS)
      ISS = NINT(S)
      DO 110 J=1,NTYPE
      FFF(J) = 0.0
      IF (CELPAR(J).LE.0.0) GOTO 110
      FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL
  110 CONTINUE
      CALL HKLEX1 (HKLX, HKLX)
      CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2)
      EPSIL = IEPS
      EPSIL2 = IEPS2
      DO 600 J=1,NSYMM
      IF (IDHKL(J).EQ.0) GOTO 200
      K = IABS(IDHKL(J))
      FPEXP(1,J) = -K
      FPEXP(2,J) = FPEXP(2,K)
      IF (FPEXP(2,J).LT.0.0001) FPEXP(2,J)=0.0001
      IF (IDHKL(J).LT.0) FPEXP(2,J)=-FPEXP(2,J)
      GOTO 600
  200 FAP = 0.0
      FBP = 0.0
      DO 400 I=1,NAT
      TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) +
     *       HKLX(3,J)*ATXYZ(3,I)
      IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010
      ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000)
      IF (ITRIG.LE.0) ITRIG = ITRIG + 10000
      IJ = ITAT(I)
      FAP = FAP + SICO(ITRIG + 2500) * FFF(IJ)
      FBP = FBP + SICO(ITRIG)        * FFF(IJ)
  400 CONTINUE
         FP = ALATT * SQRT (FAP*FAP + FBP*FBP) * EXPBP(ISS)
      PHIP = 0.0
      IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925
      IF (PHIP.LT.0.0) PHIP = PHIP + 360.
      FPEXP(1,J) = FP
      FPEXP(2,J) = PHIP
  600 CONTINUE
      RETURN
      END
      SUBROUTINE TRACIN
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zotra.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zbuff.inc'
      EQUIVALENCE (IBINFC, IFILE(12))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (IMAP, KSTAT(7))
      PARAMETER (KFA=20671)
      COMMON /BLANK/ FA(KFA), FB(KFA), DUMMY(118658)
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), SH(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      DIMENSION IRP(3,3)
      DIMENSION EO2A(4,2)
      DATA EO2A /1.000,1.250,2.000,3.250,1.000,1.5705,2.5251,3.9080/
      D2R = ATAN(1.0) / 45.0
      R2D = 1.0 / D2R
      CALL KERNZA(0.0, RHO, MXP1)
      CALL KERNZA(0.0, SH, 3*MXP1)
      NPK   = 0
      CALL BINIFF (1,IBINFC,'BINFC2',FITFC2,NITFC2,BUFFC,KENDFC)
      IMAP = 5
      IEMIN = IFIX (EMIN * 2. + 1.5)
      IF (IEMIN.GT.4) IEMIN=4
      EMINX = FLOAT(IEMIN)/2. -0.5
      IF (ABS(EMINX - EMIN) .GT. 0.01) THEN
         EMIN = EMINX
         WRITE (9, FMT = '('' Reset value for Emin: '', F10.2)') EMIN
         ENDIF
      EO2AV = EO2A(IEMIN,ICENT)
      BBB = EO2AV * (1. - PSQ * P1SQ) - (PSQ - PSQ * P1SQ)
      WRITE (8, 334) P1SQ, PSQ, EMIN, EO2AV, BBB
  334 FORMAT (4X, 'P1SQ       PSQ       EMIN   ',
     +       '   EO2AV      BBB' /  5F10.5  )
      WRITE (8, 336) SCX, BOVX, DAMPX, SMM
  336 FORMAT (3X,'Scale',6X,'BH',6X,'  Damp-F',6X,
     *      'SMM  sharpening params' / 6F10.5 )
      DO 402 I=1,NSYMM
      L=I+NSYMM
      DO 402 J=1,3
      TT(J,I)=TSYMM(J,I)
      IF(ICENT.EQ.2) THEN
         TTJL=AMOD(1.0-TT(J,I),1.0)
         TT(J,L)=TTJL
         ENDIF
      DO 402 K=1,3
      IF(ICENT.EQ.2) IRR(K,J,L) = -IRSYMM(K,J,I)
  402 IRR(K,J,I) = IRSYMM(K,J,I)
      WRITE (8, FMT='('' Symmetry operations for sp.gr. '', A16)')
     *   SPGR
      DO 419 I=1,NSYMC
      WRITE (8, 407) I, ((IRR(L,M,I),M=1,3), TT(L,I), L=1,3)
  407 FORMAT (I4, ' :', 3('  / ', 3I3, F8.3))
      DO 419 J=1,NSYMC
      CALL MATAXI (IRR(1,1,I), IRR(1,1,J), IRP)
      DO 418 M=1,NSYMC
      IFIT=0
      DO 415 K=1,3
      DO 415 L=1,3
      IF (IRR(K,L,M) .EQ. IRP(K,L)) IFIT=IFIT+1
  415 CONTINUE
      IF (IFIT .NE. 9) GOTO 418
      MULS(I,J)=M
      GOTO 419
  418 CONTINUE
      CALL KERROR ('Symmetry error' , 0, 'SYTRA')
  419 CONTINUE
      IF (SWPRI)  THEN
         WRITE (8,722) (I,I=1,NSYMC)
  722    FORMAT('0Multiplication table for symmetry operations'/
     +       (5X,24I3/))
         DO 730 I=1,NSYMC
  730    WRITE (8, 732) I, (MULS(I,J),J=1,NSYMC)
  732    FORMAT(I3, 2X, 24I3)
         ENDIF
      RETURN
      END
      SUBROUTINE COTRA1
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zotra.inc'
      EQUIVALENCE (IBINFC, IFILE(12))
      EQUIVALENCE (ITS14,  IFILE(14)), (ITS15,  IFILE(15))
      EQUIVALENCE (IBINFF, IFILE(16))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      PARAMETER (KFA=20671)
      COMMON /BLANK/ FA(KFA), FB(KFA), DUMMY(118658)
      DIMENSION  BUF(2,24)
      EQUIVALENCE (EPSIL2, FITFC2(1)), (SFTOT2,  FITFC2(2)),
     +            (SFPAR2, FITFC2(3)), (BUF(1,1),FITFC2(4))
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), X1(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      DIMENSION SHKL(3,24), ISHKL(3,48), LHK(3), M3D(3), IORGX(14)
      DIMENSION MHKL(3), M2HKL(3), KM3D(3)
      LOGICAL SWHKL, SWHKL2
      DIMENSION MSS(4)
      LOGICAL  LMSS(4), LMSS4, LMSS5, LMSS6, LMSS7
      EQUIVALENCE (LMSS(1), LMSS4), (LMSS(2), LMSS5),
     *            (LMSS(3), LMSS6), (LMSS(4), LMSS7)
      EQUIVALENCE (MSS(1), MSS4), (MSS(2), MSS5),
     *            (MSS(3), MSS6), (MSS(4), MSS7)
      DATA ZERO  /0.0 / , IZRO, NNN / 0, 999/
      DATA IORGX /1,1,1,2,    2, 5,  5,  3,  3,  3,    3,    3,  4,  4/
      DATA I1, I2 / 0, 0/
      IORG = IORGX(ILAUE)
      CALL KERNZI (0, INDX, 9)
      CALL KERNZI (0, KM3D, 3)
      CALL KERNZI (0, M2HKL, 3)
      CALL KERNAI (MAXHKL, MHKL, 3)
      CALL KERNZI (0, MAXHKL, 3)
      IF (IPOLA .NE. 8) GOTO 102
      DO 101 I = 1, 3
      CELLN(I) = 1.4 * CELL(I)
      CELLN(I+3) = 90.
      M2HKL(I) = 2 * MHKL(I)
  101 M3D(I) = 6. * SMAX * CELL(I)
      CELLN(6) = 120.
      GOTO 110
  102 DO 103 I=1,3
      M3D(I) = SMAX * 2.31 * CELL(I)
      M2HKL(I) = MHKL(I)
      IF (ILAUE .EQ. 3) M3D(I) = SMAX * 2.0 * CELL(I)
      IF (IUNIQ .EQ. I) M3D(I) = SMAX * 2.0 * CELL(I)
      CELLN(I+3)= CELL(I+3)
  103 CELLN(I)  = CELL(I)/2.0
      GOTO (110,104,108,104,104), IORG
  104 CELLN(1)  = CELL(1)
      CELLN(2)  = CELLN(1)
      M3D(1) = SMAX * 4.0 * CELL(1)
      M3D(2) = M3D(1)
      M3DMMM = INT ( SQRT ( 0.5 * FLOAT( KFA - 300) ) )
      KM3D(1) = MIN0 (M3D(1), M3DMMM)
      KM3D(2) = KM3D(1)
      KM3D(3) = MHKL(3)
      M2HKL(1) = 2 * MHKL(1)
      M2HKL(2) = 2 * MHKL(1)
      IF (IORG .EQ. 2) GOTO 110
      CELLN(3)  = CELL(1)
      M3D(3) = M3D(1)
      M2HKL(3) = MHKL(1)
      IF (IORG .EQ. 4) GOTO 110
      M3D(1) = SMAX * 4.62 * CELL(1)
      M3D(2) = M3D(1)
      M3D(3) = M3D(1)
      M2HKL(1) = 2 * MHKL(1)
      M2HKL(2) = 2 * MHKL(1)
      M2HKL(3) = 2 * MHKL(1)
      GOTO 110
  108 CELLN(1)  = CELL(1)
      CELLN(2)  = CELLN(1)
      M3D(1) = SMAX * 4.62 * CELL(1)
      M3DMMM = int ( SQRT ( 0.5 * FLOAT( KFA - 300) ) )
      M3D(1) = MIN0 (M3D(1), M3DMMM)
      M3D(2) = M3D(1)
      M2HKL(1) = 2 * MHKL(1)
      M2HKL(2) = 2 * MHKL(1)
      M2HKL(3) = 2 * MHKL(1)
  110 WRITE (8, 112) CELL, VOLUM, CELLN, IORG, M3D, M2HKL, KM3D
  112 FORMAT (/' CELL: ', 3F8.3, 3F7.2, ' VOLUME:' ,F9.2/
     *         ' CELLN:', 3F8.3, 3F7.2, ' transformed cell'/
     *         ' (Origin keys: IORG =',I2, ')' /
     *         ' (Expected maximum transformed indices:  ', 3I3,' )'/
     *         ' ( [ TEMP: M2HKL=',3I3,'    TEMP: KM3D=', 3I3,' )' /)
      IF (IPOLA .EQ. 0) THEN
         IDIMF=3
         CALL BINOFF (1, IBINFF, 'BINFFT', FITFFT, 5, BUFFFT, KENDFF)
         GOTO 130
         ENDIF
      WRITE (8, 119)
  119 FORMAT(' POLAR SPACE GROUP - NO 3-D SEARCH')
      IDIMF=2
      IF (IPOLA.EQ.3 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.6) IDIMF=1
      CALL FILINQ (ITS15, 'SCRA15', 'UNFORMATTED', 'SCRATCH', KINQ)
      GOTO (122, 120, 123, 121, 122, 121, 120, 121), IPOLA
  120 INDX(1,1) = 1
      INDX(2,3) = 1
      INDX(3,2) =-1
      M3D(2)=0
      GOTO 130
  121 I=1
      GOTO 125
  122 I=2
      GOTO 125
  123 I=3
  125 J=MOD(I,3)+1
      K=6-I-J
      INDX(1,I) = 1
      INDX(2,J) = 1
      INDX(3,K) = 1
      M3D(K)=0
      IF(IDIMF.EQ.1) M3D(J)=0
  130 CONTINUE
      CALL KERNZA (0.0, FA, KFA)
      CALL KERNZA (0.0, FB, KFA)
      KLAAR = 0
  131 M2 = 2 * M3D(3) + 1
      M1 = M2 * (2 * M3D(2) + 1)
      M3 = M3D(2) * M2
      NEED = M3D(1) * M1 + M3D(2) * M2 + M3D(3)
      WRITE (8, 132) M3D,NEED
  132 FORMAT(' Max indices and storage for general scan: ',3I3,I8)
      M5 = 2 * M3D(2) + 1
      MS1 = (M3D(2) + 1) * M2
      MS2 = (M3D(1) + 1) * M2
      MS3 = (M3D(1) + 1) * M5
      MS12= MS1 + MS2
      MS123= MS12 + MS3
      KFA1 = KFA - 100
      IF (MS123 .GT. KFA1)
     *   WRITE (8, 133)  MS1, MS2, MS3, MS123, KFA1
  133    FORMAT(/' Storage 2D scans:    BC    AC    AB    Sum   LIMIT:'/
     *           ' -----------------', 3I6, I7, I8 /)
      KLAAR = KLAAR + 1
      IF (MS123 .GT. KFA1 .AND. KLAAR .LE. 4) THEN
         KLA = NINT ( 100. * SQRT ( FLOAT( MS123) / FLOAT( KFA1 ) ) )
         DO 134 I = 1, 3
         M3D(I) = 100 * M3D(I) / KLA
  134    CONTINUE
         GOTO 131
         ENDIF
      IF (MS123 .GT. KFA1) THEN
         write(24, 133)  MS1, MS2, MS3, MS123, KFA1
         write(24, FMT='(/'' Rerun TRACOR with lower sinth/lam'')')
         CALL KERROR ('Storage problems: KFA1.', 133, 'COTRA1')
         ENDIF
      MSTOT = MS123
      NKFA = MIN0 (NEED, KFA)
      IDIMFX = IDIMF
      IF (ILAUE .EQ. 1) IDIMFX = 4
      IF (NEED.LE.KFA .AND. IDIMFX.EQ.3) IDIMFX = 5
      MSS4 = MS123 + MS2
      MSS5 = MSS4  + MS2
      MSS6 = MSS5  + MS2
      MSS7 = MSS6  + MS2
      DO 135 M = 1,4
      LMSS(M) = .TRUE.
      IF (MSS(M) .LE. KFA - 100) THEN
         LMSS(M) = .FALSE.
         MSTOT = MSS(M)
         ENDIF
  135 CONTINUE
      NFOUR = 0
      KBOT = 1
      KTOP = NEED
      NPASS = 1
      IPASS = 0
      IF (NEED .LE. KFA .OR. ILAUE .EQ. 1) GOTO 140
      CALL FILINQ (ITS14, 'SCRA14', 'UNFORMATTED', 'SCRATCH', KINQ)
      KTOP = KFA - MSTOT
      NPASS = (NEED - 1 + MSTOT) / KFA + 1
  140 NACC  = 0
      NRIN  = 0
      NRINP = 0
      SEOBS = 0.0
      SES2  = 0.0
      TOTREF= 0.0
      NUNOBS = 0
      IADDM = -9999
      NREF14  =  0
      SWHKL = .FALSE.
      SWHKL2 = .FALSE.
      IF (.NOT. SWPRI) SWHKL2 = .TRUE.
      ITREF = 0
      ITREFE = 0
      ITREFS = 0
      IF (SWPRI) WRITE (8, 150)
  150   FORMAT('0  h   k   l   Eobs  eps   SF2   SF2P',
     *  '   Fp   phase   Fp   phase   .....')
  160 CALL BINIFF (0,IBINFC,'BINFC2',FITFC2,NITFC2,BUFFC,KENDFC)
      IF (KENDFC .LT. 0) GOTO 500
         EPSIL2 = FITFC2(1)
         SFTOT2 = FITFC2(2)
         SFPAR2 = FITFC2(3)
         CALL KERNAB (FITFC2(4), BUF, NITFC2-3)
      NSREF = NSYMM / NINT (EPSIL2)
      NRIN = NRIN + NSREF
      NRINP = NRINP + 1
      IF (FITFC2(1) .LT. 0.) THEN
         ITREFS = ITREFS + 1
         GOTO 160
         ENDIF
      FITFO(1) = FBINX(1,NRINP)
      FITFO(2) = FBINX(2,NRINP)
      FITFO(3) = FBINX(3,NRINP)
      IF (FITFO(2) .LT. 0.) CALL KERNER(-2, 'COTRA1')
      CALL HKLC1U (FITFO(1), SHKL)
      CALL HKLSTL (SHKL, STL, STL2)
      IF (STL .GT. SMAX) GOTO 160
      IF (FITFO(2) .LE. 6.01*FITFO(3)) THEN
         NUNOBS = NUNOBS + 1
         FITFO(2) = FITFO(2) / 4.
         ENDIF
      EF = SCX * FITFO(2) * EXP(BOVX * STL2) / SQRT(SFTOT2 * ALATT)
      IF (EF.GT.3.0) EF=3.0
      IF (EF.LT.EMIN) THEN
            ITREFE = ITREFE + 1
            GOTO 160
            ENDIF
      NACC = NACC + NSREF
      SXX=STL/SMM
      IF(SXX.GT.SMM) SXX=1.0
      SXX = SQRT(SXX) * EXP(DAMPX * STL2) / SQRT(SFPAR2 * ALATT)
      CALL HKLEX1 (SHKL,  SHKL)
      CALL HKLEX2 (SHKL, ISHKL, IEPS, IEPS2)
      EPSIL = IEPS
      CALL KERF2I (SHKL, ISHKL, 3*NSYMM)
      IF (SWHKL2) GOTO 172
      IF (SWHKL) THEN
         SWHKL2 = .TRUE.
         SWHKL = .FALSE.
         GOTO 172
         ENDIF
      IF (ISHKL(1,1).EQ.0 .OR. ISHKL(2,1).EQ.0 .OR.
     *    ISHKL(3,1).EQ.0) GOTO 172
      IF (ISHKL(1,1).EQ.ISHKL(2,1) .OR. ISHKL(2,1).EQ.ISHKL(3,1) .OR.
     *    ISHKL(3,1).EQ.ISHKL(1,1)) GOTO 172
      IF (ISHKL(1,1).EQ.-ISHKL(2,1) .OR. ISHKL(2,1).EQ.-ISHKL(3,1) .OR.
     *    ISHKL(3,1).EQ.-ISHKL(1,1)) GOTO 172
      SWHKL = .TRUE.
  172 IF (SWPRI .AND. (SWHKL .OR. NRINP.LT.22)) WRITE
     *   (8,180) (ISHKL(IJJ,1),IJJ=1,3), EF, (FITFC2(I),I=1,NITFC2)
  180 FORMAT (3I4, F5.2, F3.0, 2F7.0, 1X, 7(F7.2,F6.1)
     *        / 35X, 7(F7.2,F6.1))
      SUMES=0.0
      DO 190 IS=1,NSYMM
      PHST(IS) = BUF(2,IS)
      IF (PHST(IS) .LT. 0.0) PHST(IS) = 360. + PHST(IS)
      IF (BUF(1,IS) .GE. 0.0) THEN
         EFST(IS) = BUF(1,IS) * SXX
         SUMES = SUMES + EFST(IS)**2
      ELSE
         ISK = NINT (-BUF(1,IS))
         EFST(IS) = EFST(ISK)
         ENDIF
  190 CONTINUE
      IF (ICENT.EQ.1) GOTO 196
      DO 195 IS = NSYMM+1 , NSYMC
      DO 194 I=1,3
  194 ISHKL(I,IS)= - ISHKL(I,IS-NSYMM)
      EFST(IS) = EFST(IS-NSYMM)
  195 PHST(IS) = 360. - PHST(IS-NSYMM)
  196 CONTINUE
      TOTREF = TOTREF + 1.
      SUMES = SUMES / FLOAT(NSREF)
      SES2 = SES2 + SUMES
      EF2 = EF**2
      SEOBS = SEOBS + EF2
      EF2 = EF2 - PSQ * SUMES - BBB
      DO 400 I=2,NSYMC
      DO 390 II=1,NSYMM
      PTRA = SHKL(1,II)*TT(1,I)+ SHKL(2,II)*TT(2,I)+ SHKL(3,II)*TT(3,I)
      IJ = MULS(II,I)
      PTRA = PHST(II) - PHST(IJ) - 360.*PTRA
      EFTRA = EF2 * EFST(II) * EFST(IJ) / EPSIL
      IF (EFTRA .LT. 0.) THEN
         EFTRA = ABS(EFTRA)
         PTRA = PTRA + 180.
         ENDIF
      PTRA = AMOD(-PTRA, 360.)
      DO 301 J=1,3
  301 LHK(J) = ISHKL(J,II) - ISHKL(J,IJ)
      GOTO (302, 303, 303, 305, 304), IORG
  302 LHK(1)=LHK(1)/2
      LHK(2)=LHK(2)/2
  303 LHK(3)=LHK(3)/2
      GOTO 305
  304 IF (IPOLA .NE. 8) GOTO 305
      LHK(1) = LHK(1) - LHK(2)
      LHK(2) = LHK(2) - LHK(3)
      LHK(3) = 0
  305 DO 306 J=1,3
      IF (IABS(LHK(J)) .LE. M3D(J)) GOTO 306
      ITREF = ITREF + 1
      GOTO 390
  306 CONTINUE
      DO 308 J=1,3
  308 MAXHKL(J) = MAX0 (MAXHKL(J), IABS(LHK(J)))
      IF(LHK(1)) 320, 310, 330
  310 IF(LHK(2)) 320, 315, 330
  315 IF(LHK(3)) 320, 390, 330
  320 DO 322 J=1,3
  322 LHK(J)=-LHK(J)
      PTRA = - PTRA
  330 IADD = LHK(3) + LHK(2) * M2 + LHK(1) * M1
      IF (PTRA .LT. 0.) PTRA = PTRA + 360.
      IF (SWHKL) WRITE (8, 331) (ISHKL(L,I),L=1,3),
     *   (ISHKL(L,II),L=1,3), (ISHKL(L,IJ),L=1,3), LHK, IADD
  331 FORMAT (' HKL for: I,II,IJ,M; IADD: ', 4(3I3,2X), I6)
      GOTO (338, 338, 343, 341, 338), IDIMFX
      CALL KERROR ('Impossible ...', 338, 'COTRA1')
  338 FA(IADD) = FA(IADD) + EFTRA * COS(PTRA * D2R)
      FB(IADD) = FB(IADD) + EFTRA * SIN(PTRA * D2R)
      GOTO 390
  341 FITFFT(1) = LHK(1)
      FITFFT(2) = LHK(2)
      FITFFT(3) = LHK(3)
      FITFFT(4) = EFTRA
      FITFFT(5) = PTRA
      CALL BINOFF(0, IBINFF, 'BINFFT', FITFFT, 5, BUFFFT, KENDFF)
      GOTO 390
  343 CONTINUE
      IF (LHK(1) .EQ. 0) THEN
         IADD  = LHK(2) * M2 + LHK(3)
         GOTO 338
         ENDIF
      IF (LHK(2) .EQ. 0) THEN
         IADD = MS1 + LHK(1) * M2 + LHK(3)
         GOTO 338
         ENDIF
      IF (LHK(3) .EQ. 0) THEN
         IADD = MS12 + LHK(1) * M5 + LHK(2)
         GOTO 338
         ENDIF
      IF (ILAUE .LE. 3) GOTO 341
      IF (LMSS4) GOTO 345
      IF (LHK(1) .EQ. LHK(2)) THEN
         IADD = MS123 + LHK(1) * M2 + LHK(3)
         GOTO 338
         ENDIF
      IF (LMSS5) GOTO 345
      IF (LHK(1) .EQ. -LHK(2)) THEN
         IADD = MSS4  + LHK(1) * M2 + LHK(3)
         GOTO 338
         ENDIF
      IF (LMSS6) GOTO 345
      IF (LHK(2) .EQ. -2 * LHK(1)) THEN
         IADD = MSS5  + LHK(1) * M2 + LHK(3)
         GOTO 338
         ENDIF
      IF (LMSS7) GOTO 345
      IF (2 * LHK(2) .EQ. -LHK(1)) THEN
         IADD = MSS6  - LHK(2) * M2 + LHK(3)
         GOTO 338
         ENDIF
  345 IF (IADD .GT. KTOP) GOTO 380
      IADD = IADD + MSTOT
      GOTO 338
  380 WRITE (ITS14) IADD, EFTRA, PTRA
      IADDM = MAX0(IADDM,IADD)
      NREF14 = NREF14 + 1
  390 CONTINUE
  400 CONTINUE
      GOTO 160
  500 IF (ITREF .GT. 0) write(24, FMT='(
     *   '' Nr of refl. bypassed (HKL > M3D)'', I6)') ITREF
      IF (ITREFE .GT. 0) write(24, FMT='(
     *   '' Nr of refl. bypassed (E < EMIN) '', I6)') ITREFE
      IF (ITREFS .GT. 0) write(24, FMT='(
     *   '' Nr of refl. bypassed (S > SMAX) '', I6)') ITREFS
      IF (NREF14 .GT. 0) THEN
         WRITE(8, FMT = '('' max. indices-address      : '', I10,
     *        '' (calc:'',I10,'')'',/,
     *        '' Nr. of refl. to file ITS14: '', I10,/)')
     *        IADDM, NEED, NREF14
         NEED = IADDM
         write(24, FMT='('' Max. transformed hkl: '', 3I3)') MAXHKL
         ENDIF
      WRITE(8, FMT = '('' Nr. of weak reflections  : '', I10)')
     *   NUNOBS
      WRITE (8, FMT='('' Max. transformed hkl: '', 3I3)') MAXHKL
      IF (NPASS .GT. 1) WRITE (24, FMT= '('' Approximately'', I3,
     *   '' passes needed for output/input scratch file: '')') NPASS
      ITREF = 0
      GOTO 630
  600 IDIMFX = 6
      KBOT=KTOP+1
      KTOP = MIN0 (KTOP + KFA, NEED)
      NKFA = KTOP - KBOT + 1
      MSTOT = 0
      CALL KERNZA (0.0, FA, NKFA)
      CALL KERNZA (0.0, FB, NKFA)
      REWIND ITS14
      NREFFI = 0
      NREFFO = 0
  620 READ (ITS14) IADD, F, P
      NREFFI = NREFFI + 1
      IF (IADD.LT.1) GOTO 625
      IF (IADD.LT.KBOT .OR. IADD.GT.KTOP) GOTO 620
      NREFFO = NREFFO + 1
      J = IADD - KBOT + 1
      FA(J) = FA(J) + F * COS(P * D2R)
      FB(J) = FB(J) + F * SIN(P * D2R)
      GOTO 620
  625 CONTINUE
      IF (IPASS .EQ. 0) WRITE(8, FMT =
     *   '('' Nr. of refl. from file ITS14:'',I9 )') NREFFI
      WRITE(8, FMT =
     *   '('' Nr. of reflections stored   :'',I9 )') NREFFO
  630 IF (IDIMFX .EQ. 4) GOTO 650
      DO 640 K = 1, NKFA
      J = K + KBOT - 1
      F = SQRT (FA(K)**2 + FB(K)**2)
      IF (F .LT. 0.000001) GOTO 640
      IF (F .LT. 0.01) THEN
         ITREF = ITREF + 1
         GOTO 640
         ENDIF
      NFOUR = NFOUR + 1
      GOTO (632, 632, 635,  631, 632, 632), IDIMFX
  631 CALL KERROR ('Impossible ...', 631, 'COTRA1')
  632 IADD = J
  633 I1 = (IADD + M3 + M3D(3)) / M1
      IADD  = IADD - I1 * M1
      I2 = (IADD + M3 + M3D(3)) / M2 - M3D(2)
      I3 = IADD - I2 * M2
      IF (IDIMF.EQ.3) GOTO 639
      I = I1 * INDX(1,1) + I2 * INDX(1,2) + I3 * INDX(1,3)
      I2= I1 * INDX(2,1) + I2 * INDX(2,2) + I3 * INDX(2,3)
      I1=I
      IF (IDIMF.EQ.1) WRITE(ITS15) I1,FA(K),FB(K)
      IF (IDIMF.EQ.2) WRITE(ITS15) I1,I2,FA(K),FB(K)
      GOTO 640
  635 IF (J. GT. MSTOT) GOTO 638
      IF (J .LE. MS1) GOTO 632
      IF (J .LE. MS12) THEN
         I1 = (J - MS1 + M3D(3)) / M2
         I2 = 0
         I3 = J - MS1 - I1 * M2
         GOTO 639
         ENDIF
      IF (J .LE. MS123) THEN
         I1 = (J - MS12 + M3D(2)) / M5
         I2 = J - MS12 - I1 * M5
         I3 = 0
         GOTO 639
         ENDIF
      IF (ILAUE .LE. 3) CALL KERROR (' Kan niet ', 635, 'COTRA')
      IF (J .LE. MSS4) THEN
         I1 = (J - MS123 + M3D(3)) / M2
         I2 = I1
         I3 =  J - MS123 - I1 * M2
         GOTO 639
         ENDIF
      IF (J .LE. MSS5) THEN
         I1 = (J - MSS4 + M3D(3)) / M2
         I2 = -I1
         I3 = J - MSS4 - I1 * M2
         GOTO 639
         ENDIF
      IF (J .LE. MSS6) THEN
         I1 = (J - MSS5 + M3D(3)) / M2
         I2 = -2 * I1
         I3 = J - MSS5 - I1 * M2
         GOTO 639
         ENDIF
      IF (J .LE. MSS7) THEN
         I2 = (J - MSS6 + M3D(3)) / M2
         I1 = 2 * I2
         I3 = J - MSS6 - I2 * M2
         I2 = - I2
         GOTO 639
         ENDIF
      CALL KERROR (' Kan niet ', 635, 'COTRA')
  638 IADD = J - MSTOT
      GOTO 633
  639 FITFFT(1) = I1
      FITFFT(2) = I2
      FITFFT(3) = I3
      FITFFT(4) = F
      P = ATAN2(FB(K),FA(K)) * R2D
      IF (P .LT. 0.0) P = P + 360.
      FITFFT(5) = P
      CALL BINOFF(0, IBINFF, 'BINFFT', FITFFT, 5, BUFFFT, KENDFF)
  640 CONTINUE
      IF (NREF14 .EQ. 0) GOTO 650
      IPASS = IPASS + 1
      IF (NPASS .GT. 1) THEN
         IF (IPASS .EQ. 1) WRITE (ITS14) IZRO,ZERO,ZERO
         WRITE (9, FMT='('' Pass'', I3, '' completed'')') IPASS
         WRITE (8, FMT='('' Pass'', I3, '' completed'')') IPASS
         IF (KTOP .LT. NEED) GOTO 600
         ENDIF
  650 IF (IDIMF.EQ.1) WRITE(ITS15) NNN,ZERO,ZERO
      IF (IDIMF.EQ.2) WRITE(ITS15) NNN,IZRO,ZERO,ZERO
      IF (IDIMF.NE.3) THEN
         REWIND ITS15
      ELSE
         CALL BINOFF(-1, IBINFF, 'BINFFT', FITFFT, 5, BUFFFT, KENDFF)
         ENDIF
      IF (ITREF .GT. 0) write(24, FMT='(
     *   '' Nr of refl. bypassed (F < 0.01) '', I6)') ITREF
      IF (SWPRI) THEN
         WRITE (8, 902) NRIN,NACC, NINT(TOTREF), NFOUR
  902    FORMAT (' Nr of reflections input:', I9 /
     *   ' Nr of reflections accepted:', I6,' with', I6, ' independent.'
     *  /' Nr of terms that contributed to the Fourier map:', I8)
         WRITE (8, 903) MAXHKL
  903    FORMAT (' Maximum indices for Fourier synthesis: ', 3I3)
         ENDIF
      CALL FILCLO (ITS14, 'DELETE')
      SEOBS = SEOBS / TOTREF
      SES2 = SES2 / TOTREF
      PPES = P1SQ * EO2AV + (1.-P1SQ)
      EOOR = EO2AV - PSQ * PPES - BBB
      ENUL = SEOBS - PSQ * SES2 - BBB
      WRITE (8, 910) EO2AV,SEOBS,PPES,SES2,EOOR,ENUL
  910 FORMAT (/' Average of        theory       observed' /
     +' EOBS**2       ',F10.4,5X,F10.4 /
     +' ES**2         ',F10.4,5X,F10.4 /
     +' EO2-IMV-OR    ',F10.4,5X,F10.4 //)
      RETURN
      END
      SUBROUTINE D12FOU
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ITS15, IFILE(15))
      PARAMETER (NPKM2=100, MNGR2=163, MNGR1=200, LC24=24)
      COMMON /BLANK/ SICO(1250),  RHOSUM(MNGR2,MNGR2),   RHOMAX(NPKM2),
     *               IC1(MNGR1),  IC2(MNGR1), IMAX(NPKM2), JMAX(NPKM2),
     *               XMAX(NPKM2), YMAX(NPKM2), RHOP(NPKM2), IRHO(LC24),
     *               DUMMY(131157)
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), SH(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      INCLUDE 'Zotra.inc'
      DIMENSION AL(3)
      CALL SICOT (SICO, 1250)
      IF (IPOLA .EQ. 8) THEN
         CALL KERNAB (CELLN, AL, 3)
         ANGLE = 120.
         GOTO 135
         ENDIF
      DO 112 L=1,2
      AL(L)=0.
      DO 110 I=1,3
      X=0.
      DO 108 J=1,3
  108 X = X + INDX(L,J) * RRMAT(I,J)
  110 AL(L) = AL(L) + X * INDX(L,I)
  112 AL(L)=SQRT(AL(L))
      AL(3)=0.
      DO 122 I=1,3
      X=0.
      DO 121 J=1,3
  121 X = X + (INDX(1,J) - INDX(2,J)) * RRMAT(I,J)
  122 AL(3) = AL(3) + X * (INDX(1,I) - INDX(2,I))
      AL(3)=(AL(1)*AL(1)+AL(2)*AL(2)-AL(3))/AL(1)/AL(2)
      ANGLE = ACOS(0.5 * AL(3)) * R2D
      IF (IDIMF .NE. 1) GOTO 135
      NGR1=AL(1)/0.21
      IF (NGR1.GT.200) NGR1=200
      write(24, 127) AL(1),NGR1
  127 FORMAT(/' FOURIER IS CALCULATED ALONG AXIS OF',F8.3,' A' /
     +' NUMBER OF GRID POINTS IN THIS DIRECTION (QX):',I5 )
      CALL D1FOUR (IOMAPS,NGR1,SCALEQ)
      GOTO 137
  135 NGR1=AL(1)/0.25
      IF (NGR1.GT.163) NGR1=163
      NGR2=AL(2)/0.25
      IF (NGR2.GT.163) NGR2=163
      write(24, 136) AL(1), AL(2), ANGLE, NGR1, NGR2
  136 FORMAT(/' FOURIER IS CALCULATED IN PLANE OF AXES OF', /, 6X,
     +F8.3,' AND',F8.3,' A, ANGLE = ',F8.3 /
     +' NUMBER OF GRID POINTS IN FIRST  DIRECTION (QX):',I5/
     +' NUMBER OF GRID POINTS IN SECOND DIRECTION (QY):',I5)
      CALL D2FOUR (IOMAPS,NGR1,NGR2,SCALEQ)
  137 write(24, 138) SCALEQ
  138 FORMAT(' FOURIER SCALEFACTOR = ',F10.4)
      CALL FILCLO (ITS15, 'DELETE')
      CALL KERNZA (0.0, SH, 3 * MXP1)
      RHOMIN = 0.5 * RHOP(1)
      DO 206 I=1,NPK
      RHO(I) = RHOP(I)
      IF (RHO(I) .LT. RHOMIN) THEN
         NPK=I-1
         RETURN
         ENDIF
      DO 204 K=1,3
      IF (INDX(1,K) .NE. 0) SH(K,I) = XMAX(I)
  204 CONTINUE
      IF (IDIMF .EQ. 1) GOTO 206
      DO 205 K=1,3
      IF (INDX(2,K) .NE. 0) SH(K,I) = YMAX(I)
  205 CONTINUE
  206 CONTINUE
      RETURN
      END
      SUBROUTINE COTRA3
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zatomx.inc'
      EQUIVALENCE (ICRYS, IFILE(3)),  (ITS15, IFILE(15))
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), SH(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      DIMENSION ISAME(MXP)
      INCLUDE 'Zotra.inc'
      DIMENSION ORGVEC(3,8), SHD(3), SHDT(3), SHDTX(3), PLATT(3,4)
      LOGICAL SWORG
      DATA NORIG, SWORG /1 , .FALSE. /
      DO 238 I=1,NPK
      IF (IPOLA .EQ. 8) THEN
         SH(3,I) = - SH(2,I)
         SH(2,I) = SH(2,I) - SH(1,I)
         SH(3,I) = SH(3,I) - SH(1,I)
         SH(2,I) = SH(2,I) - SH(1,I)
         SH(1,I) = 0.0000001
         CALL KERNZA (0., PLATT, 3)
         CALL KERNZA (0., ORGVEC, 3)
         ENDIF
      DO 211 J=1,3
      SHJI = AMOD(2.0+SH(J,I),1.0)
  211 SH(J,I) = SHJI
      GOTO (212,220,215,230,230), IORG
  212 SH(1,I)=SH(1,I)/2.0
      SH(2,I)=SH(2,I)/2.0
  215 SH(3,I)=SH(3,I)/2.0
      GOTO 238
  220 IF (SH(1,I).LT.0.5) GOTO 215
      SH(1,I)=SH(1,I)-0.5
      SH2I = AMOD(SH(2,I)+0.5, 1.0)
      SH(2,I) = SH2I
      GOTO 215
  230 IF (SH(1,I).LT.0.5) GOTO 238
      DO 235 J=1,3
      SHJI = AMOD(SH(J,I)+0.5, 1.0)
      SH(J,I) = SHJI
  235 CONTINUE
  238 CONTINUE
      IF (IPOLA .EQ. 8) GOTO 242
      CALL RDCRYB (ICRYS, 'NORIG', KEND)
      IF (KEND .EQ. -1)
     *   CALL KERROR (' No NORIG record on CRYSDA file', 238, 'COTRA3')
      READ(CHIN, FMT = '(10X, I10)') NORIG
      DO 239 N = 1,NORIG
  239 READ (ICRYS, FMT = '(10X, 3F10.7)') (ORGVEC(J,N), J= 1,3)
      IF (NORIG * NLATT .EQ. 1) GOTO 248
      DO 241 N = 1, NLATT
      PLATT(1,N) = TLATT(1,N)
      PLATT(2,N) = TLATT(2,N)
      PLATT(3,N) = TLATT(3,N)
      IF (IPOLA.EQ.1 .OR. IPOLA.EQ.3 .OR. IPOLA.EQ.5) PLATT(1,N) = 0.
      IF (IPOLA.EQ.2 .OR. IPOLA.EQ.3 .OR. IPOLA.EQ.6) PLATT(2,N) = 0.
      IF (IPOLA.EQ.4 .OR. IPOLA.EQ.5 .OR. IPOLA.EQ.6) PLATT(3,N) = 0.
  241 CONTINUE
  242 DO 246 N1 = 1,NPK-1
      IF (RHO(N1) .LT. 0.0) GOTO 246
      DO 245 N2 = N1+1, NPK
      IF (RHO(N2) .LT. 0.0) GOTO 245
      DO 243 J = 1,3
  243 SHD(J) = SH(J,N1) - SH(J,N2)
      DO 244 IL = 1, NLATT
      SHDT(1) = SHD(1) + PLATT(1,IL)
      SHDT(2) = SHD(2) + PLATT(2,IL)
      SHDT(3) = SHD(3) + PLATT(3,IL)
      DO 244 N = 1,NORIG
      CALL DISTSQ (SHDT, ORGVEC(1,N), 0.4, SHDTX, DIST2)
      IF (DIST2 .LT. 0.16) THEN
         IF (.NOT. SWORG)
     *      WRITE (8, FMT = '('' TEMP: Removed (close contact):'')')
         WRITE (8,FMT='('' shiftvector'',I3,'' ='',3F8.4,'' ='',I3)')
     *      N2, (SH(J,N2),J=1,3), N1
         RHO(N2) = -9999.
         SWORG = .TRUE.
         GOTO 245
         ENDIF
  244 CONTINUE
  245 CONTINUE
  246 CONTINUE
      IF (.NOT. SWORG) GOTO 248
      NPK1 = 0
      DO 247 I = 1,NPK
      IF (RHO(I) .LT. 0.0) GOTO 247
      NPK1 = NPK1 + 1
      CALL KERNAB (SH(1,I), SH(1,NPK1), 3)
      RHO(NPK1) = RHO(I)
  247 CONTINUE
      NPK = NPK1
  248 CONTINUE
      CALL DISCHK (ISAME, MXP)
      NBOTS = 0
      NBOTSP = 0
      DO 270 I=1,NPK
      IF (IBOTS(I) .NE. 0) NBOTS = NBOTS + 1
      IF (BOTS(I) .LE. 3.00) NBOTSP = NBOTSP + 1
  270 CONTINUE
      IF (NBOTS .EQ. 0) write(24, FMT='(/'' No close contacts''/)')
      IF (NBOTS .GT. 0) write(24, 275) NBOTS
  275 FORMAT (I4, ' of the shift vectors lead to bad contacts.'/
     *    '   Number of contacts (nr)  and shortests distance:'/
     *    42X, 'nr   dist')
      IF (NBOTS .EQ. 0 .AND. NBOTSP .GT. 0) write(24, FMT='(
     *    33X, ''Shortest distance:'')')
      RHOX = RHO(1) * .5
      write(24, FMT='('' Possible shift vectors:''/
     *  '' TR=   FOM    Tx       Ty       Tz'' )')
      NPKXX = NPK
      DMAX=2.999
      MSAME = NAT / 3
      DO 280 I = 1, NPKXX
      IF (I .LE. 2 .OR. RHO(I) .GT. RHOX) NPK = I
      IF (IBOTS(I) .GT. 0) THEN
         IF (I .LE. 2 .OR. RHO(I) .GT. RHOX)
     *      write(24,276) I,RHO(I),(SH(J,I),J=1,3), IBOTS(I), BOTS(I)
  276    FORMAT (I4, F7.0, 3F9.5, I6, F7.2)
      ELSEIF (BOTS(I) .GT. DMAX) THEN
         IF (I .LE. 2 .OR. RHO(I) .GT. RHOX)
     *      write(24, 276) I, RHO(I), (SH(J,I),J=1,3)
      ELSE
         IF (I .LE. 2 .OR. RHO(I) .GT. RHOX)
     *      write(24, 277) I, RHO(I), (SH(J,I),J=1,3), BOTS(I)
  277    FORMAT (I4, F7.0, 3F9.5, 6X, F7.2)
         ENDIF
      IF (ISAME(I).GT.MSAME)
     *   write(24,FMT='('' Symmetry ?? shift nr. '', I3)') I
      IBOTS(I) = MIN0 ( IBOTS(I), 79)
  280 CONTINUE
      RHO(NPK+1)=-9999.0
      RETURN
      END
      SUBROUTINE R2TRAC (SEDEL2)
      DIMENSION SEDEL2(50,2)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zbinx.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IBINFC, IFILE(12))
      DIMENSION  BUF(2,24)
      EQUIVALENCE (SFTOT2,  FITFC2(2)),
     +            (SFPAR2, FITFC2(3)), (BUF(1,1),FITFC2(4))
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), X1(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      INCLUDE 'Zotra.inc'
      DIMENSION SHKL(3,24), SORTR2(50)
      write(24, 120)
  120 FORMAT (/' Calculate  R2  values for all  shift vectors'/
     *         ' (ignore possible overlap between molecules)')
      CALL BINIFF (1, IBINFC, 'BINFC2',FITFC2,NITFC2,BUFFC,KENDFC)
      NRINP = 0
      TOTREF = 0.
      SEOBS2 = 0.
      SEFS2 = 0.
      SEOBS4 = 0.
      CALL KERNZA (0.0, SEDEL2, 100)
      MPK = MIN0 (50, NPK)
  160 CALL BINIFF (0,IBINFC,'BINFC2',FITFC2,NITFC2,BUFFC,KENDFC)
      IF (KENDFC .LT. 0) GOTO 500
      NRINP = NRINP + 1
      IF (FITFC2(1) .LT. 0.) GOTO 160
      FITFO(1) = FBINX(1,NRINP)
      FITFO(2) = FBINX(2,NRINP)
      FITFO(3) = FBINX(3,NRINP)
      IF (FITFO(2) .LT. 0.) CALL KERNER(-2, 'R2TRAC')
      CALL HKLC1U (FITFO(1), SHKL)
      CALL HKLSTL (SHKL, STL, STL2)
      IF (STL .GT. SMAX) GOTO 160
      FNORM = EXP(BOVX * STL2) / SQRT(SFTOT2 * ALATT)
      EF = SCX * FITFO(2) * FNORM
      IF (EF.GT.3.0) EF=3.0
      IF (EF.LT.EMIN) GOTO 160
      EF2 = EF**2
      SEOBS2 = SEOBS2 + EF2
      SEOBS4 = SEOBS4 + EF2**2
      CALL HKLEX1 (SHKL,  SHKL)
      DO 190 IS=1,NSYMM
      PHST(IS) = BUF(2,IS)
      IF (BUF(1,IS) .GE. -0.01) THEN
         EFST(IS) = BUF(1,IS)
      ELSE
         ISK = NINT (-BUF(1,IS))
         EFST(IS) = EFST(ISK)
         ENDIF
      PTRA = SHKL(1,1)*TT(1,IS)+ SHKL(2,1)*TT(2,IS)+ SHKL(3,1)*TT(3,IS)
      PHSTX    = PHST(IS) + 360. * PTRA
      PHST(IS) = AMOD (PHSTX, 360.)
  190 CONTINUE
      IF (ICENT.EQ.1) GOTO 196
      DO 195 IS = NSYMM+1 , NSYMC
      EFST(IS) = EFST(IS-NSYMM)
  195 PHST(IS) = 360. - PHST(IS-NSYMM)
  196 CONTINUE
      TOTREF = TOTREF + 1.
      DO 215 I = 1, MPK
      FA1 = 0.
      FB1 = 0.
      DO 210 IS=1,NSYMM
      PTRA =SHKL(1,IS)*X1(1,I)+ SHKL(2,IS)*X1(2,I)+ SHKL(3,IS)*X1(3,I)
      PTRA = 360.*PTRA + PHST(IS)
      PTRA = AMOD(PTRA, 360.)
      IF (PTRA .LT. 0.) PTRA = PTRA + 360.
                      FA1 = FA1 + EFST(IS) * COS(PTRA * D2R)
      IF (ICENT.EQ.1) FB1 = FB1 + EFST(IS) * SIN(PTRA * D2R)
  210 CONTINUE
      IF (ICENT.EQ.2) FA1 = FA1 + FA1
      EFS2 =(FA1**2 + FB1**2) * FNORM * FNORM
      IF (EFS2.GT.9.0) EFS2=9.0
      SEDEL2(I,1) = SEDEL2(I,1) + ( EF2 - EFS2 ) **2
      IF (I .EQ. 1) SEFS2 = SEFS2 + EFS2
  215 CONTINUE
      GOTO 160
  500 CONTINUE
      CALL FILCLO (IBINFC,'DELETE')
      SEOBS2 = SEOBS2 / TOTREF
      SEFS2 = SEFS2 / TOTREF
      WRITE (8, 910) SEOBS2,SEFS2
  910 FORMAT (/' Average of    observed' /
     +' EOBS**2     ',F10.4 /
     +' EFS**2      ',F10.4 ,' for first shift only')
      DO 919 I = 1, MPK
      SEDEL2(I,1) = SEDEL2(I,1) / SEOBS4
  919 CONTINUE
      write(24, 923) (I, SEDEL2(I,1), I=1, MPK)
      WRITE (8, 923) (I, SEDEL2(I,1), I=1, MPK)
  923 FORMAT (/' R2 for all shift vectors '/
     *   '  nr  R2    nr  R2    ......'/
     *   5(I4, F6.3) )
      write(24, FMT='( '' R2 used for output selection.'' )')
      CALL KERNZA (0.0, SORTR2, 50)
      SORTR2(1) = SEDEL2(1,1)
      DO 933 I = 2, MPK
      DO 930 L = I, 2, -1
      IF (SEDEL2(I,1) .LT. SORTR2(L-1)) THEN
         SORTR2(L) = SORTR2(L-1)
         IF (L .EQ. 2) SORTR2(L-1) = SEDEL2(I,1)
      ELSE
         SORTR2(L) = SEDEL2(I,1)
         GOTO 933
         ENDIF
  930 CONTINUE
  933 CONTINUE
      WRITE (8, 943) ( SORTR2(I), I=1, MPK)
  943 FORMAT (/' R2 sorted increasing ... '/
     *   '      R2        R2        R2        R2        R2'/
     *   5(4X, F6.3) )
      R2MIN = SORTR2(1)
      IR2MIN = NINT (1000. * R2MIN)
      IF (KSTAT(15) .LE. 0) KSTAT(15) = IR2MIN
      IF (KSTAT(15) .GT. IR2MIN) KSTAT(15) = IR2MIN
      XXFRAC = 0.9
      XXXADD = (1.-R2MIN) * XXFRAC
      XXX = R2MIN + XXXADD
      DO 950 I = 1, MPK
      SEDEL2(I,2) = ( XXX - SEDEL2(I,1) ) / XXXADD
      IF (SEDEL2(I,2) .LT. -9.99) SEDEL2(I,2) = -9.99
  950 CONTINUE
      IF (MPK .LE. 9) RETURN
      R2MAX = 0.
      DO 951 I = 1, 9
      R2MAX = R2MAX + SORTR2(I)
  951 CONTINUE
      R2MAX =R2MAX / 9.
      QQQ = 0.
      DO 952 I = 1, 9
      QQQ = QQQ + (R2MAX - SORTR2(I))**2
  952 CONTINUE
      R2MAX = SORTR2(9) + 2. * SQRT ( QQQ / 9.)
      write(24, FMT='(/'' Limitation for R2: max ='', F6.3/)') R2MAX
      DO 953 I = 1, MPK
      IF (SEDEL2(I,1) .GT. R2MAX) SEDEL2(I,1) = 999. + SEDEL2(I,1)
  953 CONTINUE
      RETURN
      END
      SUBROUTINE SHIFTR (SEDEL2)
      DIMENSION SEDEL2(50,2)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zatomx.inc'
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (IATOMS, IFILE(2)), (IATOLD, IFILE(10))
      EQUIVALENCE (IFOMAX, KSTAT(16))
      PARAMETER (KUSER2=30000)
      PARAMETER (IP160=160000, IPDUM=IP160-KUSER2)
      COMMON /BLANK/ XX(KUSER2), DUMMY(IPDUM)
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), SH(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      DIMENSION XLOCK(3)
      DATA DMAXTR / 0.431 /
      DATA NCALL /0/
      DATA INEW, MOUT /0, 30/
      IF (MORIE .EQ. 1 .OR. MORIE .EQ. 2) MOUT = 2 * MORIE +1
      IF (MORIE .EQ. 3 .OR. MORIE .EQ. 4) MOUT = 2 * MORIE
      IF (MORIE .EQ. 5) MOuT = 9
      IF (MORIE .GE. 6) MOUT = 10
      IF (MORIE .GE. 11) MOUT = MORIE
      IF (MORIE .GT. 20) MOUT = 20
      IF (SWPRI) WRITE (8, FMT = ' ('' The new coordinates are: '' /
     *      '' Atom name      x         y         z'' /)')
      DO 123 N = 1,NAT
      ATXYZ(8,N) = ATXYZ(1,N)
      ATXYZ(9,N) = ATXYZ(2,N)
  123 ATXYZ(10,N) = ATXYZ(3,N)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      NOTR2 = 0
      MBOTS = 0
      DO 540 I = 1, NPK
      INEW = I - NOTR2
      DO 330 N = 1,NAT
      ATXYZ(1,N) = ATXYZ(8,N) + SH(1,I)
      ATXYZ(2,N) = ATXYZ(9,N) + SH(2,I)
      ATXYZ(3,N) = ATXYZ(10,N) + SH(3,I)
      CALL LOCKIN (ATXYZ(1,N), DMAXTR, XLOCK, DISTTR, NPOSTR)
      IF (NPOSTR .GT. 1) THEN
         write(24, 226) I, N, ATNAME(N)
  226    FORMAT (' Shift nr', I3, ' Atom', I4,' = ', A6,
     *      ' lies on a special position')
         CALL KERNAB (XLOCK, ATXYZ(1,N), 3)
         IF (DISTTR .GT. 0.2) write(24, FMT ='
     *      ('' Atom locked-in: dist ='', F5.2, '' ang.'')') DISTTR
         IF (DISTTR .GT. 0.2) WRITE (8, FMT ='
     *      ('' Atom locked-in: dist ='', F5.2, '' ang.'')') DISTTR
         ENDIF
      IF (SWPRI) WRITE (8, FMT = ' (4X, A6, 3F10.5)' )
     *      ATNAME(N), (ATXYZ(J,N), J=1,3)
  330 CONTINUE
      R299 = SEDEL2(I,1)
      IF (R299 .GT. 999.) R299 = R299 - 999.
      IF (SEDEL2(I,2) .LE. 0.) THEN
         NOTR2 = NOTR2 + 1
         write(24, 332) I, R299, SEDEL2(I,2)
         GOTO 540
      ELSEIF (SEDEL2(I,1) .LT. 99.) THEN
         write(24, 331) I, R299, SEDEL2(I,2), INEW
  331    FORMAT ( ' TRACOR shift #',I2, '  R2 =', F6.3,
     *            '   Q2=',F5.2, '   accepted:  TR=', I2)
      ELSEIF (I .LT. 9) THEN
         write(24, 1332) I, R299, SEDEL2(I,2), INEW
 1332    FORMAT ( ' TRACOR shift #',I2, '  R2 =', F6.3,
     *       '   Q2=',F5.2, '   accepted:  TR=',I2, '  R2=BIG !')
      ELSE
         NOTR2 = NOTR2 + 1
         write(24, 332) I, R299, SEDEL2(I,2)
  332    FORMAT ( ' TRACOR shift #',I2, '  R2 =', F6.3,
     *       '   Q2=',F5.2, '   rejected          R2=BIG')
         GOTO 540
         ENDIF
      IF (IBOTS(I) .GT. 0) RHO(I) = RHO(I) * FLOAT (100-IBOTS(I)) /100.
      IF (IBOTS(I) .GT. 0) MBOTS = MBOTS + 1
      IF (SEDEL2(I,1) .GT. 99.) SEDEL2(I,1) = SEDEL2(I,1) - 999.
      IF (INEW .GT. MOUT) GOTO 540
      FOMQ = SQRT ( SEDEL2(I,2) ) * RHO(I)
      RHO(I) = FOMQ
      WRITE (CHOUT, 333) INEW, (SH(J,I),J=1,3),
     *   SEDEL2(I,1), RHO(I), IBOTS(I)
  333 FORMAT ('TR=', I3, ' Shift:', 3F8.4, ' R2= ', F5.3,
     *       ' FOM=', F6.0, ' X= ', I2)
      IFOM = NINT(RHO(I))
      CALL ATOMWT (IATOMS, ATXYZ, ATNAME, NAT, INEW,
     *   SEDEL2(I,1), IFOM, IBOTS(I))
      IF (INEW .EQ. 1 .AND. IFOMAX .LT. IFOM) IFOMAX = IFOM
  540 CONTINUE
      INEW = NPK - NOTR2
      MORIE = INEW
      CALL FILCLO (IATOMS, 'KEEP')
      NCALL = NCALL + 1
      IF (NCALL .EQ. 1) CALL KERASE ('ATTRA')
      CALL FILCLO (10, 'KEEP')
      CALL COPY80 (IATOMS, 'ATOMS', 10 , 'ATTRA')
      WRITE (24, 544) NPK
  544 FORMAT (' Number of shift vectors found by TRACOR :', I3)
      IF (INEW .LT. NPK) WRITE (24, 545) INEW
  545 FORMAT (' Number of vectors accepted after R2 test:', I3)
      CALL WR24
      IF (INEW .GT. MOUT) THEN
         write(24, 547) MORIE, MOUT
  547    FORMAT(' Input param MORIE=',I3,' > output only',I3,' sets !')
         ENDIF
      CALL WR24
      IF (IBOTS(1) .GT. 0) THEN
         WRITE (24, 550)
  550   FORMAT(1X/' NOTE: the first shift vector brings the fragment in'
     *         /'       collision with a symmetry related molecule!'/1X)
         MSAME = NAT / 3
         IF (IBOTS(1) .GT. MSAME) THEN
            WRITE (24, 554)
  554      FORMAT(6X,' The fragment could be on a symmetry element:'
     *           /6X,' check if its internal symmetry is correct.'/1X)
            ENDIF
         ENDIF
      CALL WR24
      IF (INEW .GT. 1) write(24, 120)
  120 FORMAT (/' All shift vectors have been applied and tested. '/
     * ' All accepted parameter sets are written to the ATOMS file,' /
     * ' and transferred to TRAVEC'/
     * ' but TRAVEC is going to reorder the atom sets.'/)
      IF (INEW .GT. 1 .AND. MBOTS .GT. 0) write(24, 121)
  121 FORMAT (' Note:  all shift vectors which lead to collisions'/
     * ' will have FOM recuced by X%, to make them less important'/)
      RETURN
      END
      SUBROUTINE ATOMWT (IATOMS, ATXYZ,ATNAME,N13, NNNN, R2,IFOM,IBOTS)
      DIMENSION ATXYZ(10,N13), ATNAME(N13)
      CHARACTER *6 ATNAME
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (NORIE, KEYS(9))
      EQUIVALENCE (IFLEX, KSTAT(12))
      EQUIVALENCE (IRUN, KSTAT(13))
      CHARACTER *6 CBOTS, TBOTS
      IF (NNNN .EQ. 1) WRITE (8, FMT='(/
     *   '' Output ATOMS   header lines''/)')
      IF (IBOTS .GT. 0) THEN
         CALL KERI2C (IBOTS, TBOTS, 2)
         CBOTS(5:6) = TBOTS(1:2)
         CBOTS(1:4) = ' X= '
      ELSE
         CBOTS = ' '
         ENDIF
      IF (IFLEX .GT. 0) THEN
      WRITE (IATOMS, 103) CCODE, IFLEX, NORIE, NNNN, R2, IFOM, CBOTS
  103 FORMAT (  'ATOMS ', A6, ' < TRACOR MOD=', I4, ' OR=', I3,
     *   ' TR=', I3, ' R2= ', F5.3, ' FOM=', I5, A6)
      WRITE (8, 1103) CCODE, IFLEX, NORIE, NNNN, R2, IFOM, CBOTS
 1103 FORMAT (/' ATOMS ', A6, ' < TRACOR MOD=', I4, ' OR=', I3,
     *   ' TR=', I3, ' R2= ', F5.3, ' FOM=', I5, A6)
      ELSE
      WRITE (IATOMS, 102) CCODE, IRUN, IORIE, NNNN, R2, IFOM, CBOTS
  102 FORMAT (  'ATOMS ', A6, ' < TRACOR  RUN', I4, ' OR=', I3,
     *   ' TR=', I3, ' R2= ', F5.3, ' FOM=', I5, A6)
      WRITE (8, 1102) CCODE, IRUN, IORIE, NNNN, R2, IFOM, CBOTS
 1102 FORMAT (/' ATOMS ', A6, ' < TRACOR  RUN', I4, ' OR=', I3,
     *   ' TR=', I3, ' R2= ', F5.3, ' FOM=', I5, A6)
      ENDIF
      IF (CHOUT .NE. ' ') THEN
         WRITE (IATOMS, FMT = '(''REMARK '', A65)') CHOUT(1:65)
         CHOUT = ' '
         ENDIF
      IF(NNNN.EQ.1) WRITE (IATOMS, FMT='(''REMARK  IRUN='', I4)') IRUN
      DO 109 I = 1, NAT
      WRITE (IATOMS, 104) ATNAME(I), (ATXYZ(J,I), J=1,3)
  104 FORMAT ('ATOM  ', A6, 2X, 3F9.5)
  109 CONTINUE
      WRITE (IATOMS, FMT = '(''END''/)')
      RETURN
      END
      SUBROUTINE D1FOUR (IO,NGR1,SCALE)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ITS15, IFILE(15))
      PARAMETER (MNGR1=200, MNGR2=163, NPKM2=100, LC24=24)
      COMMON /BLANK/ SI(1250),   RHOSUM(MNGR1), JUNK(MNGR2*MNGR2-MNGR1),
     *               RHOMAX(NPKM2), IC1(MNGR1), IC2(MNGR1), IMAX(NPKM2),
     *               JMAX(NPKM2), XMAX(NPKM2), YMAX(NPKM2), RHOP(NPKM2),
     *               IRHO(LC24), DUMMY(131157)
      DIMENSION CO(1000)
      EQUIVALENCE (SI(251),CO(1))
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), TX(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      PARAMETER (NPKM1=50)
      CALL KERNZA (0.,RHOSUM,MNGR1)
      PA = 1000. / FLOAT(NGR1)
      DO 40 I1=1,NGR1
   40 IC1(I1) = FLOAT(I1) * PA + 0.5
   60 READ(ITS15) IH,FA,FB
      IF (IH.EQ.999) GOTO 70
      DO 50 I1=1,NGR1
      II = MOD (IH * IC1(I1), 1000)
      IF (II .LE. 0) II = II + 1000
      RHOSUM(I1)=RHOSUM(I1)+FA*CO(II)+FB*SI(II)
   50 CONTINUE
      GOTO 60
   70 CALL KERNZA (0.,RHOMAX,NPKM1)
      CALL KERNZI (0,IMAX,NPKM1)
      SCALE=0.0
      DO 100 I1=1,NGR1
      SCALE=SCALE+RHOSUM(I1)**2
      DO 110 I3=1,NPKM1
      IF (RHOSUM(I1).GT.RHOMAX(I3)) GOTO 130
  110 CONTINUE
      GOTO 100
  130 DO 120 I4=1,NPKM1
      IF ((NPKM1+1-I4).EQ.I3) GOTO 210
      IMAX(NPKM1+1-I4)=IMAX(NPKM1-I4)
      RHOMAX(NPKM1+1-I4)=RHOMAX(NPKM1-I4)
  120 CONTINUE
  210 IMAX(I3)=I1
      RHOMAX(I3)=RHOSUM(I1)
  100 CONTINUE
      DO 170 I1=1,NPKM1-1
      IF(RHOMAX(I1).LE. 0.01) GOTO 170
      I4=I1+1
      DO 180 I2=I4,NPKM1
      IF (RHOMAX(I2).LE. .01) GOTO 180
      IDIF1=IABS(IMAX(I1)-IMAX(I2))
      IDIF1=MIN0(IDIF1,NGR1-IDIF1)
      IF (IDIF1.LT.3 ) GOTO 200
      GOTO 180
  200 RHOMAX(I2)=0.
  180 CONTINUE
  170 CONTINUE
      SCALE = 100. * SQRT (FLOAT(NGR1) / SCALE)
      IF (IO.LE.0) GOTO 330
      WRITE (8,1003)
 1003 FORMAT ('      ***1D.-FOURIER MAP***  '/)
      ITW2=1
      ITW =1
      WRITE (8,1008)
 1008 FORMAT('  U= 1 ,   2 ,   3....ETC'/)
      GOTO 310
  340 ITW2=ITW2+1
      ITW=LC24*(ITW2-1)+1
  310 NPAG=LC24*ITW2
      IF (NGR1.LT.NPAG) NPAG=NGR1
      I3=0
      DO 1010 I1=ITW,NPAG
      I3=I3+1
      IRHO(I3)=IFIX(RHOSUM(I1)*SCALE+.5)
 1010 CONTINUE
      WRITE (8,1000)  (IRHO(I1),I1=1,I3)
 1000 FORMAT (1X,24I5)
      IF (NGR1.GT.NPAG) GOTO 340
  330 N=0
      DO 250 I1=1,NPKM1
      IF (RHOMAX(I1).LE. .01) GOTO 250
      IX1=IMAX(I1)-1
      IX2=IMAX(I1)
      IX3=IMAX(I1)+1
      IXX3=IX3
      IXX1=IX1
      IF (IX2.EQ.NGR1) IXX3=IX3-NGR1
      IF (IX2.EQ.1) IXX1=IX1+NGR1
      RHO1=RHOSUM(IXX1)
      RHO2=RHOMAX(I1)
      RHO3=RHOSUM(IXX3)
      IF (RHO1.GT.RHO2 .OR. RHO3.GT.RHO2) GOTO 250
      CALL INTPOL(RHO1,RHO2,RHO3,IX1,IX3,X,NGR1)
      XMAX(I1)=AMOD(X,1.0)
      RHOP(I1)=RHO2*SCALE
      N=N+1
      RHOP(N)=RHOP(I1)
      XMAX(N)=XMAX(I1)
      IF (N .EQ. MXP) GOTO 260
  250 CONTINUE
  260 RHOP(N+1)=-9999.
      XMAX(N+1) = 0.
      NPK = N
      RETURN
      END
      SUBROUTINE D2FOUR (IO, NGR1, NGR2, SCALE)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ITS15, IFILE(15))
      PARAMETER (NPKM2=100, MNGR2=163, MNGR1=200, LC24=24)
      COMMON /BLANK/ SICO(1250),  RHOSUM(MNGR2,MNGR2),   RHOMAX(NPKM2),
     *               IC1(MNGR1),  IC2(MNGR1), IMAX(NPKM2), JMAX(NPKM2),
     *               XMAX(NPKM2), YMAX(NPKM2), RHOP(NPKM2), IRHO(LC24),
     *               DUMMY(131157)
      DIMENSION SI(1250)
      EQUIVALENCE (SI(1), SICO(1))
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), TX(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      DIMENSION CO(1000),AH(MNGR1),BH(MNGR1)
      EQUIVALENCE (SI(251),CO(1)),(AH(1),IMAX(1)),(BH(1),XMAX(1))
      CALL KERNZA (0.,RHOSUM,MNGR2*MNGR2)
      PA1 = 1000. / FLOAT(NGR1)
      PA2 = 1000. / FLOAT(NGR2)
      DO 40 I1=1,NGR1
   40 IC1(I1) = FLOAT(I1) * PA1 + 0.5
      DO 42 I2=1,NGR2
   42 IC2(I2) = FLOAT(I2) * PA2 + 0.5
      IHO=-1
   48 READ(ITS15) IH,IK,FA,FB
      IF (IHO.EQ.-1) GOTO 53
      IF (IH.EQ.IHO) GOTO 54
      DO 52 I1=1,NGR1
      IHX = MOD (IHO * IC1(I1), 1000)
      IF (IHX .LE. 0) IHX = IHX + 1000
      DO 52 I2=1,NGR2
   52 RHOSUM(I1,I2)=RHOSUM(I1,I2)+AH(I2)*CO(IHX)+BH(I2)*SI(IHX)
      IF (IH.EQ.999) GOTO 70
   53 CALL KERNZA(0.,AH,MNGR1)
      CALL KERNZA(0.,BH,MNGR1)
      IHO=IH
   54 DO 55 I2=1,NGR2
      KY = MOD (IK * IC2(I2), 1000)
      IF (KY .LE. 0) KY = KY + 1000
      AH(I2)=AH(I2) + FA*CO(KY) + FB*SI(KY)
   55 BH(I2)=BH(I2) + FB*CO(KY) - FA*SI(KY)
      GOTO 48
   70 CONTINUE
      CALL KERNZA (0.,RHOMAX,NPKM2)
      CALL KERNZI (0,IMAX,NPKM2)
      CALL KERNZI (0,JMAX,NPKM2)
      SCALE=0.0
      DO 100 I1=1,NGR1
      DO 100 I2=1,NGR2
      SCALE=SCALE+RHOSUM(I1,I2)**2
      IF (RHOSUM(I1,I2).LE.RHOMAX(NPKM2)) GOTO 100
      DO 110 I3=1,NPKM2
      IF (RHOSUM(I1,I2).GT.RHOMAX(I3)) GOTO 130
  110 CONTINUE
      GOTO 100
  130 DO 120 I4=1,NPKM2
      IF ((NPKM2+1-I4).EQ.I3) GOTO 210
      IMAX(NPKM2+1-I4)=IMAX(NPKM2-I4)
      JMAX(NPKM2+1-I4)=JMAX(NPKM2-I4)
      RHOMAX(NPKM2+1-I4)=RHOMAX(NPKM2-I4)
  120 CONTINUE
  210 IMAX(I3)=I1
      JMAX(I3)=I2
      RHOMAX(I3)=RHOSUM(I1,I2)
  100 CONTINUE
      DO 170 I1=1,NPKM2-1
      IF (RHOMAX(I1) .LE. .01) GOTO 170
      I4=I1+1
      DO 180 I2=I4,NPKM2
      IF (RHOMAX(I2) .LE. .01) GOTO 180
      IDIF1=IABS(IMAX(I1)-IMAX(I2))
      IDIF1=MIN0(IDIF1,NGR1-IDIF1)
      IDIF2=IABS(JMAX(I1)-JMAX(I2))
      IDIF2=MIN0(IDIF2,NGR2-IDIF2)
      IF (IDIF1.GE.3 .OR.  IDIF2.GE.3) GOTO 180
      RHOMAX(I2)=0.
  180 CONTINUE
  170 CONTINUE
      SCALE = 100. * SQRT (FLOAT(NGR1 * NGR2) / SCALE)
      IF (IO.LE.0) GOTO 330
      ITW2=1
      ITW=1
      GOTO 310
  340 ITW2=ITW2+1
      ITW=LC24*(ITW2-1)+1
  310 NPAG=LC24*ITW2
      IF (NGR1.LT.NPAG) NPAG=NGR1
      WRITE (8,1012) (I,I=ITW,NPAG)
 1012 FORMAT ('1',3X,'U=',24(2X,I3))
      WRITE (8,1013)
 1013 FORMAT(' ','V=')
      DO 300 I1=1,NGR2
      I3=0
      DO 302 I2=ITW,NPAG
      I3=I3+1
      IRHO(I3)=IFIX(RHOSUM(I2,I1)*SCALE+.5)
  302 CONTINUE
      WRITE (8,1000) I1,(IRHO(I2),I2=1,I3)
 1000 FORMAT ('0',I3,2X,24I5)
  300 CONTINUE
      IF (NGR1.GT.NPAG) GOTO 340
  330 N=0
      DO 250 I1=1,NPKM2
      IF (RHOMAX(I1).LE. .01) GOTO 250
      IX1=IMAX(I1)-1
      IX2=IMAX(I1)
      IX3=IMAX(I1)+1
      IY1=JMAX(I1)-1
      IY2=JMAX(I1)
      IY3=JMAX(I1)+1
      IXX3=IX3
      IXX1=IX1
      IF (IX2.EQ.NGR1) IXX3=IX3-NGR1
      IF (IX2.EQ.1) IXX1=IX1+NGR1
      RHO1=RHOSUM(IXX1,IY2)
      RHO2=RHOMAX(I1)
      RHO3=RHOSUM(IXX3,IY2)
      IF (RHO1.GT.RHO2 .OR. RHO3.GT.RHO2) GOTO 250
      CALL INTPOL(RHO1,RHO2,RHO3,IX1,IX3,X,NGR1)
      XMAX(I1)=AMOD(X,1.0)
      RHOP(I1)=RHO2
      IYY1=IY1
      IYY3=IY3
      IF (IY2.EQ.NGR2) IYY3=IY3-NGR2
      IF (IY2.EQ.1)    IYY1=IY1+NGR2
      RHO1=RHOSUM(IX2,IYY1)
      RHO2=RHOMAX(I1)
      RHO3=RHOSUM(IX2,IYY3)
      IF (RHO1.GT.RHO2 .OR. RHO3.GT.RHO2) GOTO 250
      CALL INTPOL (RHO1,RHO2,RHO3,IY1,IY3,X,NGR2)
      YMAX(I1)=AMOD(X,1.0)
      RHOP(I1)=(RHOP(I1)+RHO2)/2.*SCALE
      N=N+1
      RHOP(N)=RHOP(I1)
      XMAX(N)=XMAX(I1)
      YMAX(N)=YMAX(I1)
      IF (N .EQ. MXP) GOTO 260
  250 CONTINUE
  260 RHOP(N+1)=-999.
      XMAX(N+1) = 0.
      YMAX(N+1) = 0.
      NPK = N
      IF (NPK .LE. 1) RETURN
      IF (ILAUE .NE. 8) RETURN
      RHM = 0.45 * RHOP(1)
      NPK = 0
      DO 550 I1 = 1, N
      IF (RHOP(I1) .LT. RHM) GOTO 550
      NPK = NPK + 1
      RHOP(NPK) = RHOP(I1)
      XMAX(NPK) = XMAX(I1)
      YMAX(NPK) = YMAX(I1)
      IF (I1 .EQ. N) GOTO 550
      RHM1 = 0.83 * RHOP(I1)
      DO 540 I2 = I1+1, N
      IF (RHOP(I2) .LT. RHM1) GOTO 540
      XM1 = XMAX(I1) - XMAX(I2)
      IF (XM1 .LT. 0.0) XM1 = XM1 + 1.0
      YM1 = YMAX(I1) - YMAX(I2)
      IF (YM1 .LT. 0.0) YM1 = YM1 + 1.0
      IF (ABS(XM1-0.333).LE.0.02 .AND. ABS(YM1-0.667).LE.0.02) GOTO 530
      IF (ABS(XM1-0.667).GT.0.02 .OR.  ABS(YM1-0.333).GT.0.02) GOTO 540
  530 RHOP(I2) = 0.0
  540 CONTINUE
  550 CONTINUE
      RETURN
      END
      SUBROUTINE INTPOL(RHO1,RHO2,RHO3,IX1,IX3,X,IGRID)
      S=1.
      IF (RHO1.LT.RHO3) GOTO 10
      RHO33=RHO1-RHO3
      RHO2=RHO2-RHO3
      IX1=IX3
      S=-1.
      GOTO 20
   10 RHO33=RHO3-RHO1
      RHO2=RHO2-RHO1
   20 TEL=(RHO33/RHO2)-4.
      A=(.5*RHO33)-RHO2
      B=RHO2-A
      DENOM=(2.*RHO33/RHO2)-4.
      X=TEL/DENOM
      RHOM = (A*X+B)*X
      IF (NINT(S) .EQ. -1) GOTO 40
      RHOM=RHOM+RHO1
      GOTO 50
   40 RHOM=RHOM+RHO3
   50 X=(FLOAT(IX1)+S*X)/FLOAT(IGRID)
      RHO2=RHOM
      RETURN
      END
      SUBROUTINE D3FOUR
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (IBINBI, IFILE(18))
      PARAMETER (KUSER2=30000, KUSER1=KUSER2/3)
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1),  X(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      INCLUDE 'Zotra.inc'
      EQUIVALENCE (IMAP, KSTAT(7))
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      CALL KERNAI (MAXHKL, MH, 3)
      CALL KERNAB (CELLN, CELL, 6)
      NSYMM = 1
      IF (ILAUE .EQ. 5) THEN
         NLATT = 2
         IMULT = 2
         TLATT(1,2) = 0.5
         TLATT(2,2) = 0.5
         TLATT(3,2) = 0.
      ELSE
         NLATT = 1
         IMULT = 1
         ENDIF
      ICENT = 1
      ILAUE = 1
      ISYST = 1
      ILATT = 1
      CALL RCELLR (CELL, VOLUM, RCELL)
      CALL CELLRR (CELL, RRMAT)
      CALL MATF2C (CELL, FRAC2C)
      IMAP = 5
      CALL FFTRIN (KUSER1)
      CALL PP1
      CALL SEART
      CALL RDCRYS (ICRYS)
      RETURN
      END
      SUBROUTINE FFTRIN (KUSER1)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IMAP, KSTAT(7))
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (IBINFF, IFILE(16)), (IFMAP,  IFILE(17))
      EQUIVALENCE (ISCRA,  IFILE(18))
      EQUIVALENCE (KEYS(28), IHALF)
      LOGICAL      SWPRI, PRIMAP
      EQUIVALENCE (SWPRI, SWITCH(10)), (PRIMAP, SWITCH(11))
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      COMMON /SEARTA/ D2R, DMPIC, NPIC
      DIMENSION IGM3(3)
      DIMENSION MAXHKL(3)
      FACTOR  = 0.3
      CALL KERNZA (0.0, XLMIN, 3)
      CALL KERNZA (1.0, XLMAX, 3)
      IGM3(1) = 1
      IGM3(2) = 1
      IGM3(3) = 2
      CALL BINIFF (1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, NEND)
      CALL FILINQ (ISCRA, 'BINBIG', 'UNFORMATTED', 'OUTPUT', KINQ)
      CALL FILINQ (IFMAP, 'FMAPT', 'UNFORMATTED', 'OUTPUT', KINQ)
      CALL KERF2I (HKLMAX, MAXHKL, 3)
      CALL KERNAI (MH, MAXHKL, 3)
      DO 105 I=1,3
      MH(I) = MIN0 (MH(I), MAXHKL(I))
      IF (MH(I) .LE. 0) MH(I) = MAXHKL(I)
  105 CONTINUE
      IHALF = 0
      IHALF = 1
      IF (ILATT .EQ. 1 .OR. ILATT .EQ. 3)  IHALF = 0
      FACTOR = 999.
      DO 219 I=1,3
      NPP(I) = 2 * MH(I) + 2
  219 FACTOR = AMIN1 (FACTOR, 0.90 * CELL(I)/NPP(I))
      IF (IHALF.NE.0 .AND. IGM3(3).EQ.1) IGM3(2) = 2
      GOTO 242
  240 DO 241 I=1,3
  241 NPP(I) = CELL(I) / FACTOR + 0.5
  242 DO 280 I=1,3
      ISGG = MOD (NPP(I), IGM3(I))
      IF (ISGG.NE.0) NPP(I) = NPP(I) + IGM3(I) - ISGG
  250 NTEST = NPP(I)
      DO 270 J=2,5
  260 IF (NTEST.NE.(NTEST/J)*J) GOTO 270
      NTEST = NTEST / J
      IF (NTEST.EQ.1) GOTO 280
      GOTO 260
  270 CONTINUE
      NPP(I) = NPP(I) + IGM3(I)
      GOTO 250
  280 CONTINUE
      WRITE (8, 282) FACTOR
  282 FORMAT (' The GRID spacing is approximately', F6.3, ' Angstrom')
      IF (NPP(1) .LE. 250) GOTO 400
      WRITE (8, 320)
  320 FORMAT (/' NX GREATER THAN 250 (SEE SUBR. -OUTPUT-). RESET.'/)
      FACTOR = FACTOR * FLOAT(NPP(1)) / 245.
      GOTO 240
  400 I = (NPP(1)+2) * (NPP(3)+2)
      IF (I.LT.KUSER1) GOTO 406
      FACTOR = FACTOR * 1.02 * SQRT(FLOAT(I)/FLOAT(KUSER1))
      write(24, 405)
      WRITE (8, 405)
  405 FORMAT (' TOO MANY GRID POINTS FOR PEAK SEARCH. RESET.'/)
      GOTO 240
  406 WRITE (8, 407) MH, NPP
  407 FORMAT (/
     + ' Maximum indices allowed   h:', I4, '    k:', I4, '    l:', I4/
     + ' Number of grid points    Nx:', I4, '   Ny:', I4, '   Nz:', I4)
      DO 408 I = 1,3
      IF (NPP(I) .GE. 2 * MH(I) + 2) GOTO 408
      MH(I) = NPP(I) / 2 -1
      WRITE (8, FMT='('' Reset MAXHKL:'')')
      GOTO 406
  408 CONTINUE
      IF (SWPRI .AND. PRIMAP) WRITE (8, 410) XLMAX
  410 FORMAT (' FOURIER MAP TO BE PRINTED FROM:'/' X =  0.0  TO',
     +         F7.3,',  Y =  0.0  TO',F7.3,',  Z =  0.0  TO',F7.3)
      RETURN
      END
      SUBROUTINE SEART
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IFMAP, IFILE(17))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI, SWITCH(10))
      EQUIVALENCE (IMAP, KSTAT(7))
      PARAMETER (KUSER2=30000)
      PARAMETER (MAXAT=1020)
      PARAMETER (MDUMM=160000-KUSER2-4*MAXAT)
      COMMON /BLANK/ NSTORE(KUSER2), X(4,MAXAT), DUMMY(MDUMM)
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), XT(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      COMMON /SEARTA/ D2R, DMPIC, NPIC
      D2R = ATAN(1.0) / 45.0
      DMPIC = 0.5
      REWIND IFMAP
      READ (IFMAP) FFTSC,IMAPX,IHALF
      write(24, 192)
  192 FORMAT(/' FFT PEAK SEARCH FOR TRACOR === VERSION JUN 1987')
      NPIC = MXP
      NAT  = MXP
      CALL PKSRT (X, MAXAT, IHALF, IFMAP)
      CALL FILCLO (IFMAP, 'DELETE')
      IF (SWPRI) WRITE (8, 445)
  445 FORMAT (/' Untransformed peaks from 3D Fourier map'/
     *     '   PEAK',7X,'HEIGHT',13X,'X',9X,'Y',9X,'Z')
      RHOMIN = 0.50 * X(4,1)
      DO 520 I=1,NPIC
      IF (X(4,I) .LT. RHOMIN) GOTO 530
      DO 515 J=1,3
  515 XT(J,I)=X(J,I)
      RHO(I)=X(4,I)
      IF (SWPRI) WRITE (8, 517) I,RHO(I),(XT(J,I),J=1,3)
  517 FORMAT (' ' ,3X,I2,7X,F6.0,10X,F7.4,3X,F7.4,3X,F7.4)
      IF (I .EQ. 50) GOTO 550
  520 CONTINUE
      I = NPIC + 1
  530 I = I - 1
  550 DO 555 J=1,3
  555 XT(J,I+1)=0.
      RHO(I+1)=-9999.
      NPK = I
      RETURN
      END
      SUBROUTINE DISCHK (ISAME, MXP2)
      DIMENSION ISAME(MXP2)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATOMS, IFILE(2))
      INCLUDE 'Zatomx.inc'
      PARAMETER (KUSER2=30000)
      PARAMETER (MDUMM=160000-KUSER2)
      COMMON /BLANK/ XX(KUSER2), DUMMY(MDUMM)
      PARAMETER (KUSER1=KUSER2/3)
      DIMENSION WORK(3,KUSER1)
      EQUIVALENCE (WORK(1,1), XX(1))
      PARAMETER (MXP=50, MXP1=MXP + 1)
      COMMON /PIEK/ RHO(MXP1), SH(3,MXP1), IBOTS(MXP1), BOTS(MXP1), NPK
      INCLUDE 'Zotra.inc'
      DIMENSION TL(3,4)
      DIMENSION COSA(3), SINA(3), Q(3,3), SSH(3), XY(3), XGRAV(3)
      DIMENSION RATIO(MXP)
      CALL KERNZA(0.0, TL, 12)
      GOTO (37,31,31,31,31,34,33),ILATT
   31 DO 32 I=1,3
   32 TL(I,2)=0.5
      IF(ILATT.LT.5) TL(ILATT-1,2)=0.0
      GOTO 37
   33 TL(1,2)=1.0/3.0
      TL(2,2)=2*TL(1,2)
      TL(3,2)=TL(2,2)
      TL(1,3)=TL(2,2)
      TL(2,3)=TL(1,2)
      TL(3,3)=TL(1,2)
      GOTO 37
   34 DO 36 I=2,4
      DO 35 J=1,3
   35 TL(J,I)=0.5
   36 TL(I-1,I)=0.0
   37 CONTINUE
      DMAX=3.0
      DMIN = 2.4
      DO 110 I=1,3
      COSA(I) = COS(CELL(I+3) * D2R)
  110 SINA(I) = SQRT(1.0- COSA(I)**2 )
      COSGS=(COSA(1)*COSA(2)-COSA(3)) / SINA(1)/SINA(2)
      Q(1,1)=CELL(1)*SINA(2)*SQRT(1.0-COSGS**2)
      Q(1,2)=0.0
      Q(1,3)=0.0
      Q(2,1)=-CELL(1)*COSGS*SINA(2)
      Q(2,2)=CELL(2)*SINA(1)
      Q(2,3)=0.0
      Q(3,1)=CELL(1)*COSA(2)
      Q(3,2)=CELL(2)*COSA(1)
      Q(3,3)=CELL(3)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found', 0, 'DISCHK')
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL KERNZA(0.0, XGRAV, 3)
      DO 130 N=1,NAT
      DO 130 I=1,3
  130 XGRAV(I) = XGRAV(I) + ATXYZ(I,N)
      DO 131 I=1,3
  131 XGRAV(I) = XGRAV(I) / FLOAT(NAT)
      DO 140 IS=1,NPK
      DO 140 I=1,3
      IF (XGRAV(I) + SH(I,IS) .GT. 1.0) SH(I,IS) = SH(I,IS) - 1.0
  140 CONTINUE
      WRITE (8, 149)
  149 FORMAT (/' Shifts, with distance check'/ ' Peak height ', 3X,
     *   'Tx',6X,'Ty',6X,'Tz', 8X, 'contacts by symmetry: Angstrom')
      WRITE (8, 150) DMAX
  150 FORMAT (63X, 'max: ', F4.2)
      K=0
      DO 168 ISS=2,NSYMC
      DO 167 IL=1,NLATT
      DO 166 N=1,NAT
      K=K+1
      DO 165 I=1,3
      WORK(I,K)=TL(I,IL)+TT(I,ISS)
      DO 164 J=1,3
  164 WORK(I,K)=WORK(I,K)+ATXYZ(J,N)*IRR(I,J,ISS)
  165 WORK(I,K)=AMOD(4.0+WORK(I,K),1.0)
  166 CONTINUE
  167 CONTINUE
  168 CONTINUE
      RHOMIN = 0.5 * RHO(1)
      NPRINT = 0
      ISAVE = 0
      NBADX = 0
      DO 200 IS=1,NPK
      IBOTS(IS)=0
      BOTS(IS)=999.
      ISAME(IS) = 0
      IF (RHO(IS) .LT. RHOMIN) THEN
         IF (ISAVE .EQ. 0) THEN
            ISAVE = IS - 1
            WRITE (8, FMT='(/
     *        '' The following shift(s) are rejected:'' /)')
            ENDIF
         WRITE (8,2) IS,RHO(IS),(SH(J,IS),J=1,3)
         RHO(IS) = - 1.0
         RHOMIN = RHO(1) + 1.
         GOTO 200
         ENDIF
      RATIO(IS) = 1.
      IF (IS .GT. 1) THEN
         IF (RHO(IS) .GT. RHO(IS-1)) RHO(IS) = RHO(IS-1)
         RATIO(IS) = RHO(IS-1) / RHO(IS)
         IF (RATIO(IS) .GT. 1.25) RHOMIN = RHO(IS) * 0.99
         ENDIF
      RATI2 = 0.0
      IF (IS .GT. 2) RATI2 = RHO(IS-2) / RHO(IS)
      IF (RATI2 .GT. 1.30) RHOMIN = RHO(IS) * 0.99
      RATIO(1) = AMAX1 (RATIO(1), RATIO(IS))
      IF (IS .GE. 5 ) THEN
         TQ = RATIO(IS) + RATIO(IS-1) + RATIO(IS-2) - 3.0
         IF (RATIO(1)-1.0 .GT. 4.0*TQ .AND. RHO(IS) .LT. 0.7*RHO(1)
     *      .AND. IS .LE. 10)  RHOMIN = RHO(IS) * 0.99
         ENDIF
      NPRIN = 0
      DMAX=3.0
      DMAX2 = DMAX * DMAX
      NBAD = 0
      WRITE (8,2) IS,RHO(IS),(SH(J,IS),J=1,3)
    2 FORMAT(I4, F7.0, 3F8.4)
      DO 197 N=1,NAT
      DO 170 I=1,3
  170 XY(I)=ATXYZ(I,N)+SH(I,IS)
      IFI=0
      DO 188 ISS=2,NSYMC
      DO 175 I=1,3
      SSH(I)=0.0
      DO 172 J=1,3
  172 SSH(I)=SSH(I)+SH(J,IS)*IRR(I,J,ISS)
  175 SSH(I)=AMOD(4.5+SSH(I),1.0)-0.5
      DO 186 IL=1,NLATT
      IST=IFI+N
      IFI=IFI+NAT
      DO 184 J=IST,IFI
      D1=WORK(1,J)+SSH(1)-XY(1)
      D1=(AMOD(4.5+D1,1.0)-0.5)
      D4=ABS(D1)*Q(1,1)
      IF (D4.GT.DMAX) GOTO 184
      D2=WORK(2,J)+SSH(2)-XY(2)
      D2=(AMOD(4.5+D2,1.0)-0.5)
      D5=ABS(D2*Q(2,2)+D1*Q(2,1))
      IF (D5.GT.DMAX) GOTO 184
      D3=WORK(3,J)+SSH(3)-XY(3)
      D3=(AMOD(4.5+D3,1.0)-0.5)
      D6=ABS(D3*Q(3,3)+D2*Q(3,2)+D1*Q(3,1))
      IF (D6.GT.DMAX) GOTO 184
      D = D4*D4+D5*D5+D6*D6
      IF (D.GT.DMAX2) GOTO 184
      D = SQRT(D)
      BOTS(IS) = AMIN1(BOTS(IS), D)
      M=MOD(J-1,NAT)+1
      IF ((NPRINT .GT. 50 .AND. NPRIN .EQ. 8) .OR.
     *    (NPRINT .GT. 70 .AND. NPRIN .EQ. 12)) THEN
         DMAX = AMAX1 (BOTS(IS), DMIN)
         DMAX2 = DMAX * DMAX
         WRITE (8, 150) DMAX
         IF (D .GT. DMAX) GOTO 184
         ENDIF
      IF (NPRINT .GT. 99 .AND. NPRIN .EQ. 3) THEN
         DMAX = DMIN
         DMAX2 = DMAX * DMAX
         WRITE (8, 150) DMAX
         IF (D .GT. DMAX) GOTO 184
         ENDIF
      NPRINT = NPRINT + 1
      NPRIN = NPRIN + 1
      IF (NLATT.GT.1) GOTO 180
      WRITE (8,3) ATNAME(N),ATNAME(M),ISS,D
    3 FORMAT(35X, A6, ' ---- ', A6, '  (Sym.', I2, ')  =', F6.2)
      GOTO 182
  180 WRITE (8,4) ATNAME(N),ATNAME(M),ISS,IL,D
    4 FORMAT(35X, A6, ' --- ', A6, ' (Sym.', 2I2, ')  =', F6.2)
  182 CONTINUE
      IF (D .LT. 0.63) ISAME(IS) = ISAME(IS) + 1
      IF (D .GE. 0.43 .AND. D .LE. 0.83) GOTO 193
      IF (N .NE. M) THEN
         IF (MIN0 (IZAT(N), IZAT(M) ) .GE. 7 .AND. D .LE. 2.2) GOTO 193
         IF (D .LE. DMIN) GOTO 193
      ELSE
         WRITE (8, FMT='(63X, ''symmetry?'')')
         ENDIF
  184 CONTINUE
  186 CONTINUE
  188 CONTINUE
      GOTO 197
  193 IBOTS(IS) = IBOTS(IS) + 1
  197 CONTINUE
      IF (IBOTS(IS) .EQ. 0) GOTO 200
      WRITE (8, FMT='(66X, ''? skip'')')
      NBAD = NBAD + 1
      IF (IS .LE. 5) THEN
         NBADX = NBADX + 1
         write(24, 2252) IS, RHO(IS)
 2252    FORMAT (' Warning: shift nr.',I3, ' (pk =', F5.0,
     *   ')  leads to bad contacts')
         IF (ISAME(IS) .GT. 2) write(24, 2253) IS, ISAME(IS)
 2253    FORMAT (' Note for shift nr.',I3, ':', I4,
     *   ' atom pairs coincide by symmetry !')
      ELSE
         IF (NBADX.GT.0) write(24,FMT='(9X,''Also for others ..'')')
         NBADX = -99
         ENDIF
  200 CONTINUE
      IF (ISAVE .GT. 0) NPK = ISAVE
      RETURN
      END
      SUBROUTINE PKSRT (X, MAXAT, IHALF, LIN)
      DIMENSION  X(4, MAXAT)
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zaaaa.inc'
      COMMON /SEARTA/ D2R, DMPIC, NPIC
      PARAMETER (KUSER2=30000)
      COMMON /BLANK/ NR3D, DUMMY(145000)
      INTEGER*2 NR3D(KUSER2)
      DIMENSION   XS(3), X1(3), IDIFF(19), B(19)
      DIMENSION DXYZM(3)
      DATA MAX, E, D / 0, 0.0, 0.0 /
      DO 101 I = 1, 3
  101 DXYZM(I) = DMPIC * RCELL(I)
      READ (LIN) NNX, NNZ, NNY, NNYT
      NNYOLD=NNY
      IF (IHALF.NE.0) NNY=NNY-3
      NNXP2 = NNX + 2
      NXZ = NNXP2 * (NNZ + 2)
      NXZ3 = 3 * NXZ
      IF (NXZ3 .GT. KUSER2) CALL KERNER (940, 'PKSRT')
      DX = 1.0 / FLOAT(NNX)
      DY = 1.0 / FLOAT(NNYT)
      DZ = 1.0 / FLOAT(NNZ)
      LEVEL = 0
      LIMIT = MIN0(MAXAT, 2*NAT)
 1100 IDIFF(1) = -NXZ - 1
      IDIFF(2) = -NXZ - NNXP2
      IDIFF(3) = -NXZ
      IDIFF(4) = -NXZ + NNXP2
      IDIFF(5) = -NXZ + 1
      IDIFF(6) = -NNXP2 - 1
      IDIFF(7) = -1
      IDIFF(8) = NNXP2 - 1
      IDIFF(9) = -NNXP2
      IDIFF(10) = 0
      DO 1120 I=1,9
      J=20-I
      IDIFF(J) = -IDIFF(I)
 1120 CONTINUE
      NO = 0
      IY = -1
      NY = 0
 1200 REWIND LIN
      READ(LIN)
      READ(LIN)
      IF (IY+2.EQ.NNYOLD) GOTO 1400
      MAX=NXZ
      ISKIP = (NNYOLD-1) * NNZ
      DO 1305 I=1,ISKIP
 1305 READ (LIN)
      CALL RDSECT (MAX, NNXP2, NNZ, NXZ3, LIN)
      REWIND LIN
      READ(LIN)
      READ(LIN)
      CALL RDSECT (MAX, NNXP2, NNZ, NXZ3, LIN)
 1400 MX = MAX - NXZ + NNX + 1
      CALL RDSECT (MAX, NNXP2, NNZ, NXZ3, LIN)
      IY = IY + 1
      NY = MOD(NY+2, 3) - 1
      KK = NXZ3
      IF (NY) 1440, 1460, 1500
 1440 KK = -NXZ3
 1460 DO 1480 I=1,5
      IDIFF(I) = IDIFF(I) - KK
 1480 CONTINUE
      IF (NY .EQ. 0) GO TO 1540
 1500 DO 1520 I=15,19
      IDIFF(I) = IDIFF(I) - KK
 1520 CONTINUE
 1540 DO 2000 IZ=1,NNZ
      MN = MX + 3
      MX = MX + NNXP2
      DO 1980 IX=MN,MX
      IF (NR3D(IX) .LT. LEVEL) GO TO 1980
      DO 1560 I=1,9
      J = IDIFF(I) + IX
      IF (NR3D(IX) .LE. NR3D(J)) GO TO 1980
 1560 CONTINUE
      DO 1580 I=11,19
      J = IDIFF(I) + IX
      IF (NR3D(IX) .LT. NR3D(J)) GO TO 1980
 1580 CONTINUE
      DO 1600 I=1,19
      J = IDIFF(I) + IX
      B(I) = NR3D(J)
 1600 CONTINUE
      B1 = B(3) + B(7) + B(9) + B(11) + B(13) + B(17)
      B2 = B(1) + B(2) + B(4) + B(5) + B(6) + B(8) + B(12) + B(14) +
     +  B(15) + B(16) + B(18) + B(19)
      F = (30.0 * B(10) + 11.0 * B1 - 8.0 * B2) / 63.0
      C = (B(5)+B(12)+B(13)+B(14)+B(19)-B(1)-B(6)-B(7)-B(8)-B(15))/10.0
      DELTAX = C / F
      IF (ABS(DELTAX) .GT. 1.0) GO TO 1620
      D = (B(15)+B(16)+B(17)+B(18)+B(19)-B(1)-B(2)-B(3)-B(4)-B(5))/10.0
      DELTAY = D / F
      IF (ABS(DELTAY) .GT. 1.0) GO TO 1620
      E = (B(4)+B(8)+B(11)+B(14)+B(18)-B(2)-B(6)-B(9)-B(12)-B(16))/10.0
      DELTAZ = E / F
      IF (ABS(DELTAZ) .LE. 1.0) GO TO 1640
 1620 DELTAX = 0.0
      DELTAY = 0.0
      DELTAZ = 0.0
 1640 XX = (FLOAT(IX-MN+1) + DELTAX) * DX
      YY = (FLOAT(IY) + DELTAY) * DY
      ZZ = (FLOAT(IZ) + DELTAZ) * DZ
      A = (9.0 * B(10) + 4.0 * B1 - B2) / 21.0
      BINT = A + 0.5 * (C * DELTAX + D * DELTAY + E * DELTAZ)
      IF (BINT .GT. 1.05 * B(10)) BINT = 1.05 * B(10)
      B(10) =  AMAX1(B(10), BINT)
      NOP1 = NO + 1
      IF(NOP1.GT.MAXAT) GOTO 1821
      X(1,NOP1) = XX
      X(2,NOP1) = YY
      X(3,NOP1) = ZZ
      X(4,NOP1) = B(10)
      IF (NO .EQ. 0) GO TO 1820
      IR=0
      DO 1800 K=1, IMULT
      CALL OPER1 (K, XS, X(1,NOP1))
      DO 1780 I=1,NO
      DO 1720 L=1,3
      X1(L) = X(L,I) - XS(L)
 1680 IF (ABS(X1(L)) .LE. 0.5) GO TO 1700
      X1(L) = X1(L) - SIGN(1.0, X1(L))
      GO TO 1680
 1700 IF (ABS(X1(L)) .GT. DXYZM(L)) GO TO 1780
 1720 CONTINUE
      IF (QUAD2 (X1, X1) .GT. DMPIC) GOTO 1780
      IF (IR.GT.0) X(4,IR)=0.0
      IR=0
      IF (B(10) .LE. X(4,I)) GOTO 1980
      X(1,I) = XX
      X(2,I) = YY
      X(3,I) = ZZ
      X(4,I) = B(10)
      IR=I
 1780 CONTINUE
 1800 CONTINUE
      IF(IR.GT.0) GO TO 1980
 1820 NO = NOP1
 1821 IF (NO .LT. LIMIT) GO TO 1980
      CALL SORT (X, MAXAT, NO, 4)
      NO = NPIC
      LEVEL = X(4,NPIC) + 0.5
 1980 CONTINUE
 2000 CONTINUE
      IF (IY .GE. NNY) GO TO 2100
      IF (IY - NNYOLD + 2) 1400, 1200, 1400
 2100 CALL SORT (X, MAXAT, NO, 4)
      NNN = MIN0 (NO, NPIC)
      IF (NNN .EQ. NPIC) RETURN
      LEVEL = LEVEL - 100
      IF(LEVEL.GE.(-200)) GO TO 1100
      NPIC=NO
      RETURN
      END
      SUBROUTINE RDHKLT (X, NY, NZ, NX, HS)
      INTEGER HS
      COMPLEX X(NY,NZ,NX)
      INCLUDE 'Zbuff.inc'
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (IMAP, KSTAT(7))
      COMMON /FFTDA/ SCALEW, MH(3), NPP(3), XLMIN(3), XLMAX(3)
      EQUIVALENCE (FITFFT(4),EI), (FITFFT(5),PHI)
      INTEGER H, HM, HL
      DIMENSION IHKLX(3,24), PHX(24), NSYMEX(24), GRI(2,24), TAB(15)
      DIMENSION IHKLI(3), ITSYMM(3,24), NRCO(5)
      DATA NEX / -1 /
      DATA NPASS / 0 /
      D2R = ATAN(1.0) / 45.0
      NITFFT = 5
      IF (NEX .GE. 0) GOTO 210
      NEX = 0
      SCALEW = 0.0
      CALL KERNZI (0, NRCO, 5)
      DO 110 I=1,15
  110 TAB(I) = SIN (FLOAT(30*I) * D2R)
      DO 113 J=1,NSYMM
      DO 113 I=1,3
  113 ITSYMM(I,J) = NINT (TSYMM(I,J) * 12.0)
  210 CALL BINIFF (1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, NEND)
      NPASS = NPASS + 1
      HM = HS + NX - 1
      HL = HS
      IDISC = HL * HM
      IHMAX = MAX0 (IABS(HL), IABS(HM))
      IHMIN = MIN0 (IABS(HL), IABS(HM))
      DO 220 H=1,NX
      DO 220 L=1,NZ
      DO 220 K=1,NY
  220 X(K,L,H) = CMPLX(0.0,0.0)
  320 CALL BINIFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, NEND)
      IF (NEND.LT.0) GOTO 500
      IF (NPASS .GT. 1) GOTO 330
      NRCO(1) = NRCO(1) + 1
      IF (EI .LT. 0.0) THEN
         NRCO(2) = NRCO(2) + 1
         GOTO 320
         ENDIF
  330 CALL KERF2I(FITFFT, IHKLI, 3)
      IF (ISYST.GT.4 .AND. ISYST.LT.8) GOTO 360
      INMAX = MAX0 (IABS(IHKLI(1)), IABS(IHKLI(2)), IABS(IHKLI(3)))
      INMIN = MIN0 (IABS(IHKLI(1)), IABS(IHKLI(2)), IABS(IHKLI(3)))
      IF (IDISC.LT.0) GOTO 360
      IF (INMIN.GT.IHMAX .OR. INMAX.LT.IHMIN) GOTO 320
  360 CALL FEXPAN (IHKLI, IHKLX, PHX, NSYMEX, NEXP)
      PHI = PHI * D2R
      EC  = EI * COS(PHI)
      ES  = EI * SIN(PHI)
      DO 380 J=1,NEXP
      H = IHKLX(1,J)
      IF (H.GT.HM .OR. H.LT.HL) GOTO 380
      IF (IABS(H) .GE. NPP(1)/2 .OR. IABS(H) .GT. MH(1)) THEN
         NRCO(3) = NRCO(3) + 1
         GOTO 380
         ENDIF
      K = IHKLX(2,J)
      IF (IABS(K) .GE. NPP(2)/2 .OR. IABS(K) .GT. MH(2)) THEN
         NRCO(4) = NRCO(4) + 1
         GOTO 380
         ENDIF
      L = IHKLX(3,J)
      IF (IABS(L) .GE. NPP(3)/2 .OR. IABS(L) .GT. MH(3)) THEN
         NRCO(5) = NRCO(5) + 1
         GOTO 380
         ENDIF
      NU = 0
      IF (IMAP.LT.3.OR.IMAP.GT.4) GOTO 370
      NSYMX = NSYMEX(J)
      NU = - IHKLI(1)*ITSYMM(1,NSYMX) - IHKLI(2)*ITSYMM(2,NSYMX)
     *     - IHKLI(3)*ITSYMM(3,NSYMX)
      NU = MOD(NU,12)
  370 IF (NU.LE.0) NU = NU + 12
      XS = TAB(NU)
      XC = TAB(NU+3)
      GRI(1,J) =  XC*EC - XS*ES
      GRI(2,J) = (XS*EC + XC*ES) * PHX(J)
      NEX = NEX + 1
      SCALEW = SCALEW + SQRT(GRI(1,J)*GRI(1,J)+GRI(2,J)*GRI(2,J))
      NOKO = 0
      IF (H.EQ.0 .AND. L.EQ.0 .AND. K.NE.0) NOKO = NY - K + 1
      H = H - HS + 1
      IF (K.LT.0) K = NY + K
      K = K + 1
      L = L + 1
      X(K,L,H) = CMPLX(GRI(1,J),GRI(2,J))
      IF (NOKO.NE.0) X(NOKO,L,H) = CONJG(X(K,L,H))
  380 CONTINUE
      GOTO 320
  500 CONTINUE
      IF (NX + HS .LE. MH(1)) RETURN
      CALL FILCLO (IBINFF, 'DELETE')
      WRITE (8, 631) NPASS
  631 FORMAT (' Intermediate transforms required ', I3, ' passes')
      WRITE (8, 690) NRCO(1)
  690 FORMAT (' Number of reflections from input file   =',I7)
      IF (NRCO(2) .GT. 0) WRITE (8, 691) NRCO(2)
  691 FORMAT (' of which',I7,' were rejected'/)
      WRITE (8, 692) NEX
  692 FORMAT (' Number of reflections in one hemisphere =',I7)
      IF (NEX .EQ. 0) CALL KERROR ('No reflections found', 0,'RDHKLT')
      IF (NRCO(3).GT.0 .OR. NRCO(4).GT.0 .OR. NRCO(5).GT.0)
     *    WRITE (8, 693)
  693 FORMAT (' not included in calculations, because: '/)
      IF (NRCO(3).GT.0) WRITE (8, 694) MH(1), NRCO(3)
  694 FORMAT (8X,' having H greater than ',I3,'  were ',I6/)
      IF (NRCO(4).GT.0) WRITE (8, 695) MH(2), NRCO(4)
  695 FORMAT (8X,' having K greater than ',I3,'  were ',I6/)
      IF (NRCO(5).GT.0) WRITE (8, 696) MH(3), NRCO(5)
  696 FORMAT (8X,' having L greater than ',I3,'  were ',I6/)
      RETURN
      END
      SUBROUTINE TRAVEC
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IKLAD,  IFILE(20))
      EQUIVALENCE (IATOLD, IFILE(2))
      EQUIVALENCE (IATTRA, IFILE(4))
      EQUIVALENCE (IFMAP, IFILE(17))
      EQUIVALENCE (IFOLIM, KSTAT(16))
      EQUIVALENCE (IR2MIN, KSTAT(15))
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(7,197), GRIDS1
      PARAMETER (MAXAA=213)
      COMMON /CARATP/  CARXYZ(3,MAXAA), IZATOM(MAXAA), XYZT(3)
      COMMON /TRAVDA/ MM
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      COMMON /SINGP/ SINGPK, ORIGIN, PATP(8)
      DIMENSION   CARXIN(3,MAXAA), XYZTIN(3), INHVAM(197)
      CHARACTER*6    LAT(1)
      DATA LAT /'ATOMS'/
      LLMOD = 0
      CALL KEPROG( 'TRAVEC' )
      IORIE = -999
      CALL FILCLO (10, 'KEEP')
      CALL KERASE ('ATOMS')
      CALL COPY80 (IATTRA, 'ATTRA', IATOMS, 'ATOMS')
      CALL PRETRA
      KEYS(27) = SINGPK
      KEYS(28) = ORIGIN
      CALL PPROFI (PATP)
      CALL CONTRA
      KSTOP = 0
      CALL TRADEK (KSTOP)
      IF (KSTOP .NE. 0) GOTO 1111
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0) CALL KERROR ('Error on file ATOMS', -1,'TRAVEC')
      CALL FILINQ (IKLAD, 'ATOMK', 'FORMATTED', 'SCRATCH', KINQ)
      MMODH=197
      MMMOD=0
      FSUMZ1 = - 1.0
      MASUMZ = 0
      MISUMZ = 99999
      IF (IFOLIM .LE. 50) IFOLIM = 50
      write(24,FMT='('' Limit for acceptance of input sets: IFOLIM =''
     *   , I4/)') IFOLIM
      IFOMM = 2 * IFOLIM
      R2KAP = FLOAT ( IR2MIN  ) / 1000.
      write(24,FMT='('' R2MIN from TRACOR:  R2KAP ='', F6.3)') R2KAP
      XXFRAC = 0.90
      XXXADD = (1.-R2KAP) * XXFRAC
      XXX = R2KAP + XXXADD
      CALL WR24
      WRITE (8, FMT='('' Table 901-1  Input sets''/)')
      WRITE (8, FMT='('' Table 901-1  nog zonder Q2 !''/)')
 111  CALL KERIFF (IATOMS, LAT, 1, LEND)
      IF (LEND.EQ.-1 .OR. LEND.GE.5) GOTO 1000
      IF (NLUSER(1).LE.0) GOTO 111
      NMOD = NINT (FNUM(1))
      NNOR = NINT (FNUM(2))
      NNTR = NINT (FNUM(3))
      R2X  = FNUM(4)
      IBOTS= NINT(FNUM(6))
      Q2 = ( XXX - R2X ) / XXXADD
      IF (Q2 .LE. 0.01) GOTO 111
      IFOM = NINT ( FNUM(5) * SQRT (Q2) )
      IF (IFOM .LT. IFOLIM) GOTO 111
      IF (MMMOD.GT.1 .AND. (IFOM.LT.0 .OR. IFOM.LT.IFOMM/2)) THEN
         WRITE (8,FMT='(/'' skip atoms set'',8X,''MOD='',I4,'' OR='',
     *      I3,'' TR='', I3, '' FOM='', I3)') NMOD, NNOR, NNTR, IFOM
         GOTO 111
         ENDIF
      IF (IFOM .GT. IFOMM)  IFOMM = IFOM
      IFOMX(1,MMMOD+1) = IFOM
      IFOMX(2,MMMOD+1) = IBOTS
      IFOMX(3,MMMOD+1) = NINT (R2X * 1000.)
      IFOMX(4,MMMOD+1) = NMOD
      IFOMX(5,MMMOD+1) = NNOR
      IFOMX(6,MMMOD+1) = NNTR
      JJ = MMMOD+1
      WRITE (8, FMT='('' input: set'', I3, '' ['', 3I3, '' ]'',
     *   '' R2='', F6.3, '' FOM='', I4)')  JJ, IFOMX(4,JJ),
     *    IFOMX(5,JJ), IFOMX(6,JJ), R2X, IFOMX(1,JJ)
      BACKSPACE IATOMS
      CALL MODSIN (IATOMS, NAT, CARXIN, XYZTIN, IZATOM, ISUMZ)
      IF (NAT .LE. 1 .OR. NAT .GT. MAXAA) GOTO 1111
      IF (FSUMZ1 .LT. 0.) FSUMZ1 = FLOAT (ISUMZ)
      IFOMX(7,MMMOD+1) = NINT ( 1000. * FLOAT (ISUMZ) / FSUMZ1 )
      IF (ISUMZ .GT. MASUMZ) MASUMZ = ISUMZ
      IF (ISUMZ .LT. MISUMZ) MISUMZ = ISUMZ
      GRIDS1 = DISPMX/2.
      MM = MMMOD+1
      WRITE (8, FMT='(''        set'', I3, '' ['', 3I3, '' ] R2='',
     *   F6.3, '' FOM='', I4, '' p?='', I6)') MM, IFOMX(4,MM),
     *   IFOMX(5,MM), IFOMX(6,MM), R2X, IFOMX(1,MM), IFOMX(7,MM)
      CALL REFMOD (MM, CARXIN, XYZTIN, LLMOD)
      IF (MM .LT. 0) GOTO 1111
      MMMOD=MMMOD+1
      IF (MMMOD .LT. MMODH) GOTO 111
      WRITE (9, FMT='(
     *    '' TRAVEC on last  set ..='',I3, '' completed'')') MMMOD
 121  CALL KERIFF (IATOMS, LAT, 1, LEND)
      IF (LEND.EQ.-1 .OR. LEND.GE.5) GOTO 1000
      IF (NLUSER(1).LE.0) GOTO 121
      write(24, FMT='(/
     *   '' Remaining atoms sets on input ATOMS file ignored''/)')
 1000 CONTINUE
      IF (MMMOD .NE. LLMOD) WRITE (9, FMT='(
     *    '' TRAVEC on atom set ..='',I3, '' completed'')') MMMOD
      CALL WR24
      WRITE(24, FMT='(/'' Nr of input models:'', I4/)') MMMOD
      CALL WR24
      IF (MMMOD .LE. 0) GOTO 1111
      CALL SQMODL (INHVAM, MMMOD)
      SUMZQX = SQRT ( FLOAT (MASUMZ) / FLOAT (IFOMX(7,1) ) )
      WRITE (24, FMT='(/ '' MISUMZ, MASUMZ, SUMZQX ='', 2I6, F6.3/)')
     *    MISUMZ, MASUMZ, SUMZQX
      GOTO 9999
 1111 CONTINUE
      WRITE(24, FMT='('' File ATTRA copied to ATVEC and ATOMS''/)')
      CALL FILCLO (IATOMS, 'KEEP')
      CALL COPY80 (IATTRA, 'ATTRA', IATOMS, 'ATVEC')
      CALL COPY80 (IATTRA, 'ATTRA', IATOMS, 'ATOMS')
      MORIE = 20
 9999 CONTINUE
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (20, 'DELETE')
      CALL WR24
      CALL KEPROX
      RETURN
      END
      SUBROUTINE PRETRA
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (KLAUE,  KEYS(6))
      COMMON /IMSEFU/  MSUM, AMINMN, AMINMX
      CHARACTER*6 LITA(1)
      DATA LITA(1) / 'TRAVEC' /
      DATA ICRYS, ICOND /3, 4/
      CALL FILCLO (ICOND, 'KEEP')
   91 CALL RDCOND (ICOND, LITA, 1, KEND)
      IF (KEND .LE. 0) GOTO 92
      GOTO 91
   92 CONTINUE
      CALL FILCLO (ICOND, 'KEEP')
      CALL RDCRYS( ICRYS )
      GOTO
     * (101,102,103,104,103,101,101,101,101,101,104,104,103,103), ILAUE
  101 KLAUE = 1
      GOTO 105
  102 IF (IUNIQ .EQ. 3) GOTO 104
      KLAUE = 2
      GOTO 105
  103 KLAUE = 3
      GOTO 105
  104 KLAUE = 4
105   CONTINUE
      MSUM = 200
      RETURN
      END
      SUBROUTINE PRETAB
      INCLUDE 'Zsyst.inc'
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      COMMON /SINGP/ SINGPK, ORIGIN, PATP(8)
      KEYS(27) = SINGPK
      KEYS(28) = ORIGIN
      CALL PPROFI (PATP)
      IF (PATP(1) .LT. -1.) GOTO 1111
      TAB(1) = 1.
      IMAX2=0
      IXL = 0
      I = 2
   36 RRR = SQRT(FLOAT(I) - 0.9999)
      IX = RRR
      IF (IX .LE. 0) THEN
         write(24, FMT='('' Important error = IX = tell PTB'')')
         IX = 1
         ENDIF
      IF (IX.EQ.IXL) GOTO 37
      IXL = IX
      TAB(I) = PATP(IX)
      IF (IX.EQ.7) GOTO 38
      DELY = PATP(IX+1) - PATP(IX)
      DEL2Y = 0.5 * ( PATP(IX+2) - PATP(IX+1) - DELY )
      GOTO 38
   37 DELX = RRR - FLOAT(IX)
      TAB(I) = PATP(IX) + DELX * DELY + DELX * (DELX-1.) * DEL2Y
   38 IF (TAB(I).GT.0.1) IMAX2 = I - 1
      I = I + 1
      IF (I.LE.50) GOTO 36
      IF (IMAX2.GT.48) IMAX2=48
      RMAX2 = FLOAT(IMAX2) / 100.
      RMAX = SQRT( RMAX2)
 1111 CONTINUE
      RETURN
      END
      SUBROUTINE CONTRA
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (SCADEK, KEYS(26))
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(7,197), GRIDS1
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      WRITE (8, FMT='
     * ('' TRAVEC calculates AMINM for all input models,''/
     *  '' AMINM = maximum of image seeking function (ISFT) ''/
     *  /'' Values and effects of control variables:''/)')
      SCADEK=0.2
      DISPMX = 0.32
      IF ( DISPMX .GT. RMAX ) DISPMX = RMAX
      DISPMX = DISPMX/2.
      VMIN = 0.7
      VMAX = 10.
      WRITE (8, FMT='('' Intra-model vectors with length > than'',
     *    '' VMAX ='',F5.1, /'' do not contribute to ISFT.'',
     *    '' Minimum length is VMIN ='',F5.1 )') VMAX, VMIN
      FRACM = 0.30
      WRITE (8, FMT='('' Fraction of search-vectors which contributes
     * to minM is'',F5.2)') FRACM
      RETURN
      END
      SUBROUTINE TRADEK (KSTOP)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IFMAP, IFILE(17))
      EQUIVALENCE (KLAUE,  KEYS(6))
      EQUIVALENCE (SCADEK, KEYS(26))
      EQUIVALENCE (SINGPK, KEYS(27)), (ORIGIN, KEYS(28))
      LOGICAL SWPRI
      EQUIVALENCE (SWPRI,  SWITCH(10))
      EQUIVALENCE (IMAP, KSTAT(7))
      PARAMETER (NUMTAB=300000)
      COMMON /BLANK/ ITAB, DUMMY(10000)
      INTEGER*2 ITAB(NUMTAB)
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VDUMMY
      EQUIVALENCE (NX,NXYZ(1)), (NY,NXYZ(2)), (NZ,NXYZ(3))
      INTEGER * 2 LPAT(198)
      DIMENSION NXYZM(3)
      EQUIVALENCE (NXM,NXYZM(1)), (NYM,NXYZM(2)), (NZM,NXYZM(3))
      DATA JXYZC, LXYZC / 0, 0 /
      DATA IZ, KXYZC, IXYZC / 0, 0, 0 /
      ILMAX = 100000
      DO 111 I = 1, NUMTAB
 111  ITAB (I) = 0
      MAXFUN = 30254
      MIFUN = 0
      FUNSUM = 0.
      CALL FILINQ (IFMAP, 'FMAP', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ.NE.0) THEN
         write(24, FMT='(
     *    '' Patterson file (FMAP, output ORIENT) not found:''/
     *    '' TRAVEC is bypassed.'')')
         KSTOP = 1
         RETURN
         ENDIF
      READ (IFMAP) FFTSC, IMAPX, IHALF
      WRITE (8, FMT='('' IHALF, FFTSC ='',
     *   I3, F10.5)')  IHALF, FFTSC
      READ (IFMAP) NX, NZ, NYHALF, NY
      WRITE (8,6) NX, NY, NZ
   6  FORMAT (' Patterson grid X * Y * Z = ' , I3, 2(' *',I3) )
      SCAL = SCADEK
      ABSCAL = SCAL * FFTSC * VOLUM
      SINGPK = ORIGIN * ABSCAL * 18. /VOLUM
      WRITE (8, 138) FFTSC
  138 FORMAT (/' Input Patterson scale = ',12X, F10.5,' * volume ')
      WRITE (8,1138) FFTSC
 1138 FORMAT (' PTB TEMP Input SCALE: SCALOR = 3000 / sumF2 =' , F10.5/)
      WRITE (8, 152) SCAL, ABSCAL, SINGPK
  152 FORMAT (' Input function values will be multiplied by: ', F10.5 /
     *        ' To put the Patterson function on abs.scale *  ', F9.5 /
     *        ' Single-vector peak-height is approximately   ' ,F10.2 /)
      K = 0
      DO 12 I=1,3
      L = (NXYZ(I)+1) / 2
      IF (I.NE.2 .AND. KLAUE.LT.0) L=NXYZ(I)-1
      IF (L.GT.ILMAX) CALL KERROR ('KANNIET', 12, 'TRADEK')
      LXYZ(I) = MIN0 (L, ILMAX)
   12 IS(I) = 0
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.4) IS(2)=-LXYZ(2)
      IF (KLAUE.EQ.1 .OR. KLAUE.EQ.2) IS(3)=-LXYZ(3)
      DO 14 I=1,3
      NXYZM(I) = NXYZ(I)
      IF (IS(I) .EQ. 0) NXYZM(I) = LXYZ(I) + 1
   14 NUM(I) = LXYZ(I) - IS(I) + 1
      NUMXY = NUM(1) * NUM(2)
      NUMXYZ = NUMXY * NUM(3)
      IF (NUMXYZ .GT. NUMTAB) THEN
         write(24, FMT='(
     *    '' Storage problems in TRADEK: Patterson map is too large :''/
     *    '' TRAVEC is impossible: full STOP.'')')
         KSTOP = 1
         RETURN
         ENDIF
      DO 217 I = 1,3
  217 GTXYZ(I) = NXYZ(I)
      NUMC = NUMXY * IS(3) + NUM(1) * IS(2) + IS(1) - 1
      IF (NYM .GT. NYHALF) THEN
         WRITE (9,*) 'Please tell PTB: NYM gt NYHALF '
         NYM=NYHALF
         ENDIF
      DO 50 I1=1,NYM
      IY = I1 - 1
      KY = IY - NY
      IXY = NUM(1) * IY
      KXY = NUM(1) * KY
      K = 1
      IF (IS(2).EQ.0) GOTO 26
      IF (IY .GT. LXYZ(2)) K=3
      IF (IY.EQ.LXYZ(2) .OR. IY.EQ.NY/2) K=2
      IF (K.EQ.2 .AND. IY.GT.ILMAX) K=3
      IF (K.EQ.2 .AND. KY+ILMAX.LT.0) K=1
      IF (K.EQ.1 .AND. IY.GT.ILMAX) K=0
      IF (K.EQ.3 .AND. KY+ILMAX.LT.0) K=0
      IF (K.EQ.3) IXY=KXY
   26 DO 48 I2=1,NZ
      IF (I2.GT.NZM) K=0
      IF (K.EQ.0) GOTO 28
      IZ = I2 - 1
      IXYZ = NUMXY * IZ
      IXYZC = IXYZ + IXY - NUMC
      KXYZC = IXYZ + KXY - NUMC
      L = 1
      IF (IS(3).EQ.0) GOTO 28
      KZ = IZ - NZ
      JXYZ = NUMXY * KZ
      JXYZC = JXYZ + IXY - NUMC
      LXYZC = JXYZ + KXY - NUMC
      IF (IZ.GT.LXYZ(3)) L=3
      IF (IZ.EQ.LXYZ(3) .OR. IZ.EQ.NZ/2) L=2
      IF (L.EQ.2 .AND. IZ.GT.ILMAX) L=3
      IF (L.EQ.2 .AND. KZ+ILMAX.LT.0) L=1
      IF (L.EQ.1 .AND. IZ.GT.ILMAX) L=0
      IF (L.EQ.3 .AND. KZ+ILMAX.LT.0) L=0
      IF (L.EQ.3) IXYZC=JXYZC
      IF (L.EQ.3) KXYZC=LXYZC
   28 READ (IFMAP) IBSEC, IBJ, IBNX,(LPAT(I),I=1,IBNX)
      IF (K.EQ.0 .OR. L.EQ.0) GOTO 48
      DO 40 I3=1,NXM
      FUN = LPAT(I3)
      FUN = 99. * (FUN * SCAL + 25.)
      IFUN = NINT(FUN)
      IF (IFUN) 32, 32, 30
   30 IF (IFUN.GT.MIFUN) MIFUN=IFUN
      IF (IFUN .LE. MAXFUN) GOTO 36
      IFUN = MAXFUN
      GOTO 36
   32 IFUN = 0
   36 LPAT(I3) = IFUN
      FUNSUM = FUNSUM + FLOAT(IFUN)
      IX = I3 - 1
      IADR = IXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=1=',-4,'TRADEK')
      ITAB(IADR) = IFUN
      IF (L.NE.2) GOTO 39
      IADR = JXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=2=',-4,'TRADEK')
      ITAB(IADR) = IFUN
   39 IF (K.NE.2) GOTO 40
      IADR = KXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=3=',-4,'TRADEK')
      ITAB(IADR) = IFUN
      IF (L.NE.2) GOTO 40
      IADR = LXYZC + IX
      IF (IADR.LT.1 .OR. IADR.GT.NUMXYZ) CALL KERROR('=4=',-4,'TRADEK')
      ITAB(IADR) = IFUN
   40 CONTINUE
   48 CONTINUE
   50 CONTINUE
      CALL FILCLO (IFMAP, 'DELETE')
      FUNSUM = FUNSUM / FLOAT(NUMXYZ)
      IFUN = FUNSUM
      WRITE (8,52) MIFUN, IFUN
   52 FORMAT (' Largest scaled Patterson value is: ', 10X, I10 /
     *         20X,    ' averaged value is: ', 10X, I6 /)
      RETURN
      END
      SUBROUTINE MODSIN (IATOMS, NAT7, CARXIN, XYZTIN, IZATOM, ISUMZ)
      PARAMETER (MAXAA=213)
      DIMENSION CARXIN(3,MAXAA),XYZTIN(3),IZATOM(MAXAA)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATOLD, IFILE(2))
      INCLUDE 'Zatomx.inc'
      DIMENSION XYZT(3)
      DATA NATINP / 0/
      ISUMZ = 0
      IF (NATINP .EQ. 0) THEN
         CALL WR24
         WRITE (8, FMT='('' Input parameter sets from file ATOMS''/)')
         ENDIF
      NATINP = NATINP + 1
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      NAT7 = NAT
      IF (NAT.LE.0) CALL KERROR('No atoms on ATOMS file',-1,'ATREAD')
      IF (NAT .LE. 1 .OR. NAT .GT. MAXAA) THEN
         IF (NAT .LE. 1) write(24, FMT='(/
     *      '' The input ATOMS file contains only one atom:'')')
         IF (NAT .GT. MAXAA) write(24, FMT='( //'' Hold it .......''/
     *      '' The input ATOMS file contains too many atoms:''/
     *      '' ( max: '', I4, '') : '')') MAXAA
         write(24, FMT=
     *      '('' TRAVEC is bypassed'')')
         RETURN
         ENDIF
      CALL KERNZA (0., XYZT, 3)
      DO 10 I = 1, NAT
   10 CALL VPLUSV (XYZT, ATXYZ(1,I), XYZT, 3)
      DO 11 J = 1, 3
   11 XYZT(J) = - XYZT(J) / FLOAT(NAT)
      DO 20 I = 1, NAT
      CALL VPLUSV (ATXYZ(1,I), XYZT, ATXYZ(1,I), 3)
  20  CONTINUE
      DO 300 I = 1,NAT
      CALL MAT6XV (FRAC2C, ATXYZ(1,I), ATXYZ(1,I))
  300 CONTINUE
      DO 110 N = 1,NAT
      CALL KERNAB (ATXYZ(1,N), CARXIN(1,N), 3 )
      IZATOM(N) = IZAT(N)
      ISUMZ = ISUMZ + IZAT(N)
  110 CONTINUE
      CALL KERNAB(XYZT, XYZTIN, 3)
      RETURN
      END
      SUBROUTINE REFMOD (NOMODL, CARXIN, XYZTN, LLMOD)
      DIMENSION CARXIN(3,NAT), XYZTN(3)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zvcts.inc'
      EQUIVALENCE (IKLAD, IFILE(20))
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(7,197), GRIDS1
      PARAMETER (MAXAA=213)
      COMMON /CARATP/ CARXYZ(3,MAXAA), IZATOM(MAXAA), XYZT(3)
      PARAMETER (MAXAT = 1020)
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      COMMON /IMSEFU/  MSUM, AMINMN, AMINMX
      DIMENSION ROFXYZ(3,MAXAA), SMINML(48), VALISF(5), VAMI(5), FRMM(5)
      LOGICAL LALLOW(MAXASV)
      LOGICAL ASYMNW
      CHARACTER*8   REMARK(10)
      CHARACTER*80  RMRK80
      EQUIVALENCE  (REMARK(1),RMRK80)
      DATA FRMM, VAMI / 0.1, 0.2, 0.3, 0.5, 0.7, 5*0./
      DATA DMAX, DAVG /0.0, 0.0/
      LLMOD = 0
      CALL KERNZA (0., SMINML, 48)
      DO 100  I = 1, 3
      XYZT(I) = XYZTN(I)
      DO 100  N = 1, NAT
      CARXYZ(I,N) = CARXIN(I,N)
 100  CONTINUE
      DO 120 N = 1, NAT
      CALL MAT6XV (CART2F, CARXYZ(1,N), ROFXYZ(1,N))
      CALL VMINV (ROFXYZ(1,N), XYZT, ROFXYZ(1,N), 3)
  120 CONTINUE
      CALL VECLCO (LALLOW, VMAX)
      IF (VMAX .LT. 0.0) THEN
         NOMODL = -1
         RETURN
         ENDIF
      DEMPT  = 0.6666667
      GRIDSZ = GRIDS1 / DEMPT
      DO 133 I = 1,3
      GRISTP(I) = GRIDSZ / CELL(I)
  133 CONTINUE
      CALL SCADIR
      CALL VECCAL (ROFXYZ, IZATOM, NAT, LALLOW, VMIN, ASYMNW)
          CALL VECSET (ASYMNW)
      CALL CALISF (MSUM, SMINML, VALISF)
              AMINMX = VALISF( 3)
           DO 1010 I=1,5
           MALL=NINT(FRMM(I)*NVV)
           IF (MALL.GT.200) MALL = 200
           CALL ISFT(MALL,VECT,NVV,VAM)
 1010      VAMI(I)=VAM
      MALL=MSUM*NSMAX
      IF (MALL.GT.200) MALL=200
      IFOM = IFOMX(1,NOMODL)
      SUMZQ = FLOAT (IFOMX(7,NOMODL) ) / 1000.
      VAMI(1) = AMINMX
      VAMI(5) = FLOAT(IFOM) / 1000.
      AMINMX = VAMI(1) * VAMI(5) * 10. * SUMZQ
      WRITE (8, FMT= '('' temp'',I4,'' fom   = 1  *5   *sumzq'',4F6.3)')
     *       NOMODL, AMINMX, VAMI(1), VAMI(5), SUMZQ
      WRITE (RMRK80, FMT= '(''REMARK '',I4,F7.3,2F6.2,2I4,I3,5F6.3)')
     *       NOMODL, AMINMX, DMAX,DAVG, NASV, NVV, MALL, (VAMI(I),I=1,5)
      CALL ATMOUT (IKLAD, CCODE, REMARK, ATNAME, NAT, ROFXYZ, NAT)
      IF (NOMODL .EQ. 1) NEXT = 1
      IF (NOMODL .EQ. NEXT) THEN
         WRITE (9, FMT='(
     *    '' TRAVEC on atom set ..='',I3, '' completed'')') NOMODL
         LLMOD = NOMODL
         CALL WR24
         IF (NEXT .GE. 50) NEXT = NEXT + 25
         IF (NEXT .LT. 33) NEXT = 2 * NEXT
         IF (NEXT .EQ. 64) NEXT = 50
         IF (NEXT .GT. 197) NEXT = 197
         ENDIF
      RETURN
      END
      SUBROUTINE VECLCO (LALLOW, VMAX)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zvcts.inc'
      PARAMETER (MAXAA=213)
      COMMON /CARATP/ CARXYZ(3,MAXAA), IZATOM(MAXAA), XYZT(3)
      DIMENSION VECLEN(2,MAXASV)
      EQUIVALENCE ( VECLEN(1,1), ASVECT(1,1) )
      LOGICAL LALLOW(MAXASV)
      NSMXX = NSYMM
      IF (ICENT .NE. 1)  NSMXX = 2 * NSMXX
      NVALLM = MAXASV/NSMXX - NAT
 101  VMAXRE = 1./VMAX
      ACVMAX = 0.
      N = 0
      NVALL = 0
      NATM1 = NAT -1
      DO 120 J =  1, NATM1
      J1 = J + 1
      DO 110 K = J1, NAT
      N = N + 1
      IF (N .GT. MAXASV) THEN
         write(24, FMT='(
     *      '' Dimension of LALLOW in VECLCO is too small!''/
     *      '' TRAVEC is bypassed.'')')
         VMAX  = - 99.
         RETURN
         ENDIF
      NALLOW = ISELFC ( CARXYZ(1,J), CARXYZ(1,K), VMAX, DSTNCE )
      IF (DSTNCE .LT. 0.7) THEN
                              LALLOW(N) = .FALSE.
                              VECLEN(1,N) = 0.1
                              VECLEN(2,N) = 10.
         GOTO 110
         ENDIF
      IF ( NALLOW .EQ. 1 )  THEN
                              NVALL     = NVALL + 1
                              LALLOW(N) = .TRUE.
                              VECLEN(1,N) = DSTNCE
                              VECLEN(2,N) = 1./DSTNCE
                              IF (DSTNCE .GT. ACVMAX)  ACVMAX = DSTNCE
                            ELSE
                              LALLOW(N) = .FALSE.
                              VECLEN(1,N) = VMAX
                              VECLEN(2,N) = VMAXRE
      ENDIF
  110 CONTINUE
  120 CONTINUE
      IF (NVALL .GT. NVALLM) THEN
              NHIG1 = NVALLM+1
              CALL DETSET (INDXHV, NHIG1, VECLEN,2,N, 2, 0)
              VMAX  = VECLEN(1,INDXHV(NHIG1)) - .0001
      IF (VMAX .LT. 9.0) WRITE (8, 346) NVALL, VMAX
  346 FORMAT (' TEMP: VMAX reset: NVALL=',I5,' new VMAX=', F6.2)
              GOTO 101
      ENDIF
      RETURN
      END
      SUBROUTINE DETSET ( INDXHV,NHIGST, ARRAY,NDIM1,NE, ISQ, N1)
      DIMENSION           INDXHV(NHIGST),  ARRAY(NDIM1,NE)
      NRE = 0
      NRE1 = -1
      N2 = 1
      DO 300   N = N2, NE
      IF ( N .GT. NHIGST ) THEN
         IF ( ARRAY( ISQ, N) .LE. ARRAY( ISQ, INDXHV(NRE)) ) GOTO 300
         ENDIF
      IF (N .LE. NHIGST)  THEN
         NRE1 = NRE
         NRE = N
         ENDIF
      IF (NRE1 .LE. 0) THEN
         NR = 1
      ELSE
         CALL SRSEQN (INDXHV, NRE1, ARRAY(1,N), ARRAY,NDIM1,NE, ISQ,NR)
         ENDIF
      DO 100  I = NRE1, NR, -1
  100 INDXHV(I+1) = INDXHV(I)
      INDXHV(NR) = N
  300 CONTINUE
      RETURN
      END
      SUBROUTINE SCADIR
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zvcts.inc'
      COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      DIMENSION ISM(3,3,48)
      EQUIVALENCE ( ISM(1,1,1), D1G2F(1,1,1) )
      IF (ICENT.EQ.1) THEN
         IN2 = 1
      ELSE
         IN2 = -1
         ENDIF
      NS = 0
      DO 130 IN = 1,IN2,-2
      DO 120 NSA= 1,NSYMM
      NS = NS + 1
      DO 110  I = 1,3
      DO 110  J = 1,3
      ISM(I,J,NS) = IRSYMM(I,J,1) - (IRSYMM(I,J,NSA) * IN)
  110 CONTINUE
  120 CONTINUE
  130 CONTINUE
      NSMAX = NS
      CALL EQTRVS ( NSMAX, IQTRVS )
      DO 230 NS = 1,NSMAX
      DO 220 I=1,3
      DO 210 J=1,3
      D1G2F(I,J,NS) = ISM(I,J,NS) * GRISTP(J)
  210 CONTINUE
  220 CONTINUE
  230 CONTINUE
      RETURN
      END
      SUBROUTINE EQTRVS ( NSMAX, IQTRVS )
      PARAMETER (MAXIQ = 360)
      DIMENSION IQTRVS(MAXIQ)
      INCLUDE 'Zcrys.inc'
      COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      DIMENSION ISM(3,3,48), ISMEQ(3,3)
      EQUIVALENCE ( ISM(1,1,1), D1G2F(1,1,1) )
      INQ = 0
      DO 160 NI = 2, NSMAX
      IF ( MAXIQ-INQ .LT. 5 )  GOTO 200
      INQL = INQ + 1
      IQTRVS(INQL) = NI
      DO 140 NIM = 2, NI
      IF (NIM.NE.NI) THEN
         IS1 = 1
      ELSE
         IS1 = 2
         ENDIF
      DO 120 ISIM = IS1, NSYMM
      CALL IMAXMA ( IRSYMM(1,1,ISIM), ISM(1,1,NI), ISMEQ )
      IEQM = IARREQ( ISMEQ, ISM(1,1,NIM), 9 )
      IF (IEQM .EQ. 1  .OR.  IEQM .EQ. -1) THEN
                                   IF ( MAXIQ-INQL .LT. 4 )  GOTO 150
                                   INQL = INQL + 1
                                   IQTRVS(INQL) = NIM
                                   INQL = INQL + 1
                                   IQTRVS(INQL) = ISIM * IEQM
      ENDIF
  120 CONTINUE
  140 CONTINUE
  150 IF (INQL .NE. INQ+1)  THEN
                            INQL = INQL + 1
                            IQTRVS(INQL) = 0
                            INQ  = INQL
      ENDIF
  160 CONTINUE
  200 IQTRVS(INQ+1) = 0
      RETURN
      END
      FUNCTION IARREQ( IA, IB, N)
      DIMENSION IA(N), IB(N)
      DO 200 I = 1, N
      IF ( IA(I) .NE. IB(I) )   THEN
         DO 100 J = 1, N
         IF ( IA(J) .NE. -IB(J) )  THEN
            IARREQ = 0
            RETURN
            ENDIF
  100    CONTINUE
         IARREQ = -1
         RETURN
         ENDIF
  200 CONTINUE
      IARREQ = 1
      RETURN
      END
      SUBROUTINE VECCAL ( FXYZ, IZATOM, NAT, LALLOW, VMIN, ASYMNW )
      DIMENSION FXYZ(3, NAT), IZATOM( NAT)
      LOGICAL LALLOW(3600)
      LOGICAL ASYMNW
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zvcts.inc'
      LOGICAL VMINCH,LPTB
      DIMENSION  RATC(3), ORIGIN(3),             SYQDAT(3)
      DATA ORIGIN / 0.,0.,0. /
      DATA NSBEF  / 0 /
      IF (NSBEF .EQ. 0) THEN
         NSBEF = 1
         CALL KERNZI (0, IPOASV, 48)
         ASYMNW = .TRUE.
         ENDIF
      VMINCH = .TRUE.
      LPTB = .FALSE.
      IF (ICENT.EQ.1) THEN
            IN2 = 1
       ELSE
            IN2 = -1
      ENDIF
      NASV = 0
      NS = 0
      DO 180  IN = 1,IN2,-2
      DO 170  NSA= 1,NSYMM
      NS = NS + 1
      NALL = 0
      DO 160  J = 1, NAT
      CALL SYMEQU (NSA, 1, 0, IN, .TRUE., FXYZ(1,J),  RATC, SYQDAT)
      J1 = J
      IF (NS .EQ. 1)  J1 = J + 1
      DO 130  K = J1, NAT
      IF ( J .NE. K )                  NALL = NALL + 1
      IF (NALL .EQ. 0) THEN
         LPTB = .FALSE.
      ELSE
         LPTB = LALLOW(NALL)
         ENDIF
      IF (LPTB .OR. J .EQ. K)  THEN
         NASV = NASV + 1
         CALL VMINV ( FXYZ(1,K), RATC, ASVECT(1,NASV), 3)
         IF (ISELFG( ASVECT(1,NASV), ORIGIN, VMINCH, VMIN, VOUTSQ )
     *    .EQ.1) THEN
             NASV = NASV - 1
             GOTO 130
             ENDIF
         NA1A2(1,NASV) = J
         NA1A2(2,NASV) = K
         ASVECT(4,NASV) = IZATOM(J) * IZATOM(K)
         IF (K.EQ.J)  ASVECT(4,NASV) = ASVECT(4,NASV) / 2.
         IF (ICENT .EQ. 2) ASVECT(4,NASV) = 2. * ASVECT(4,NASV)
         ENDIF
  130 CONTINUE
  160 CONTINUE
      ASYMNW = ASYMNW .OR. IPOASV(NS).NE.NASV
      IPOASV(NS) = NASV
  170 CONTINUE
  180 CONTINUE
      RETURN
      END
      FUNCTION ISELFG (X, Y, DMINCH, DMIN, DISTSQ)
      LOGICAL DMINCH
      DIMENSION X(3), Y(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION  DM(3), D(3)
      DATA  DMINSQ  /1.0/
      ISELFG=0
      IF ( DMINCH ) THEN
         DO 110 I=1, 3
            DM(I)=ABS (RCELL(I)*DMIN)
  110    CONTINUE
         DMINSQ=DMIN*DMIN
         DMINCH=.FALSE.
      ENDIF
      DO 120 I=1, 3
      D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I))
      IF (ABS (D(I)).GT.DM(I)) RETURN
  120 CONTINUE
      DISTSQ=0.0
      DO 130 I=1, 3
         DISTSQ=DISTSQ+
     *          D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3))
  130 CONTINUE
      IF (DISTSQ.LE.DMINSQ) THEN
         ISELFG=1
      ENDIF
      RETURN
      END
      SUBROUTINE VECSET (ASYMNW)
      LOGICAL            ASYMNW
      INCLUDE 'Zvcts.inc'
      COMMON /TIFMAP/ GRIDSZ, GRISTP(3), D1G2F(3,3,48)
      CALL OVLTAB
      IF ( ASYMNW ) CALL SELVEC
      ASYMNW = .FALSE.
      DO 120  J = 1, NVV
      JA = INDXHV(J)
      DO 110  I = 1,3
      VECT(I,J) = ASVECT(I,JA)
  110 CONTINUE
      VECT(4,J) = ASVECT(5,JA)
  120 CONTINUE
      RETURN
      END
      SUBROUTINE OVLTAB
      INCLUDE 'Zcrys.inc'
      INCLUDE 'Zvcts.inc'
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      LOGICAL FIRST, ALLSEQ
      LOGICAL   CONOVL, EQUIVV
      DIMENSION VEXYZ(3), SYQDAT(3)
      INW = 0
      NVECT1 = 1
      DO 99 NVSET = 1, NSMAX
      IF (1 .LE. IPOASV(NVSET) )  THEN
         NVSET1 = NVSET
         GOTO 100
         ENDIF
  99  CONTINUE
      RETURN
 100  CONTINUE
      DO 101  NV = NVECT1, NASV
          ASVECT(5,NV) = ASVECT(4,NV)
          ASVECT(6,NV) = 0.0
 101  CONTINUE
      DO 1100 NVSET = NVSET1, NSMAX
          IF (NVSET .NE. NVSET1) NVECT1= IPOASV(NVSET-1) + 1
          NVEND = IPOASV(NVSET)
      DO  1000   NV = NVECT1, NVEND
          NVA = NV - 1
      NS = 1
      NLT= 1
      INV= 1
      FIRST = .TRUE.
      ALLSEQ = .FALSE.
 111  CALL SYMEQU (NS,0,NLT,INV, FIRST, ASVECT(1,NV), VEXYZ, SYQDAT)
      INVXNS = INV * NS
      I1 = 1
      DO 130 IVS = 1, NVSET
          CALL GEQTVS (NVSET, IVS, INVXNS, CONOVL)
      IF (.NOT. CONOVL) GOTO 130
         IF (INW .NE. 5) THEN
              INW  =   5
              ENDIF
      IF (IVS .NE.1 ) I1   = IPOASV(IVS-1) + 1
                      IEND = IPOASV(IVS)
      IF (IEND .GT. NVA) IEND = NVA
      DO 120 I = I1,  IEND
      IF ( ISELGG( VEXYZ, ASVECT(1,I), RMAX, RR2 )
     *     .EQ. 1 ) THEN
        EQUIVV = I .EQ. NV
        W1 =ASVECT(INW,NV)
        W2 =ASVECT(INW,I)
        CALL COVERW(ASVECT(4,NV), W1, ASVECT(4,I), W2, EQUIVV, RR2)
        ASVECT(INW,NV) = W1
        ASVECT(INW,I) = W2
         ENDIF
  120 CONTINUE
  130 CONTINUE
      NVA = NV
      CALL NEXSYM (NS,NLT,INV, NSYMM,NLATT, FIRST, ALLSEQ)
      IF (.NOT. ALLSEQ)  GOTO 111
 1000 CONTINUE
 1100 CONTINUE
      RETURN
      END
      SUBROUTINE GEQTVS (NVSET, IVS, INS, CONOVL)
      LOGICAL CONOVL
      INCLUDE 'Zvcts.inc'
      IF (NVSET .EQ. 1) THEN
          CONOVL = .TRUE.
          RETURN
      ENDIF
      IF (NVSET .EQ. IVS .AND. INS .EQ. 1) THEN
          CONOVL = .TRUE.
          RETURN
      ENDIF
      CONOVL = .FALSE.
      INQL = 0
  101 INQ1 = INQL + 1
      IF (IQTRVS(INQ1) .EQ. 0)  THEN
          RETURN
      ENDIF
      IF (IQTRVS(INQ1) .LT. NVSET)  THEN
  102     INQL = INQL + 1
          IF (IQTRVS(INQL) .NE. 0    )  GOTO 102
            GOTO 101
      ENDIF
      IF (IQTRVS(INQ1) .GT. NVSET)         RETURN
      INQ1 = INQ1 + 1
      DO 200 INQ = INQ1, MAXIQ, 2
         IF (IQTRVS(INQ) .EQ. IVS) THEN
             IF (IQTRVS(INQ+1) .EQ. INS) THEN
                 CONOVL = .TRUE.
                 RETURN
             ENDIF
          ELSE
            IF (IQTRVS(INQ) .EQ. 0  .OR. IQTRVS(INQ) .GT. IVS)   RETURN
          ENDIF
 200         CONTINUE
      RETURN
      END
      SUBROUTINE COVERW ( WI1, W1, WI2, W2, EQUIVV, RR2)
      LOGICAL                              EQUIVV
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      IF ( RR2 .LE. RMAX2 )  THEN
         G = RR2/DEL + 1.
         IG = G
         F = G - FLOAT(IG)
         OVRLAP = TAB(IG) + (TAB(IG+1) - TAB(IG)) * F
         W1  = W1 + OVRLAP * WI2
         IF (.NOT. EQUIVV) W2  = W2 + OVRLAP * WI1
         ENDIF
      RETURN
      END
      SUBROUTINE SELVEC
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(7,197), GRIDS1
      INCLUDE 'Zvcts.inc'
      COMMON /IMSEFU/  MSUM, AMINMN, AMINMX
      COMMON /PROFIX/ RMAX, RMAX2, DEL, TAB(50)
      DIMENSION  NDELV(48)
      PARAMETER (IFRAC = 1)
      PARAMETER (MXV = 100)
      PARAMETER (MSUMI = 3)
      DATA  MINASV,MINNV2,MXAV1,MXAV2,MXAV4 /0,0,24, 48, IFRAC*MXV/
      MXAV3 = IFRAC*MXAV2
      IF (MXAV2 .GT. MAXVEC/NSMAX) THEN
          MXAV2=MAXVEC/NSMAX
          IF (MXAV1 .GE. MXAV2) MXAV1=MXAV2-1
          MXAV3=IFRAC*MXAV2
      ENDIF
      MINASV = MAXASV
      MAXXAV = 0
      J1 = 0
      DO 110 NS = 1, NSMAX
      NASVCS = IPOASV(NS) - J1
      IF (MINASV .GT. NASVCS) MINASV = NASVCS
      IF (MAXXAV .LT. NASVCS) MAXXAV = NASVCS
      J1 = IPOASV(NS)
 110  CONTINUE
      IF       (MINASV.GT.MXAV4) THEN
                                     MAXNVS = MXV
      ELSE  IF (MINASV.GT.MXAV3) THEN
                                     MAXNVS = MINASV/IFRAC
      ELSE  IF (MINASV.GT.MXAV2) THEN
                                     MAXNVS = MXAV2
      ELSE  IF (MINASV.GT.MXAV1) THEN
                                     MAXNVS = MINASV
      ELSE
                                     MAXNVS = MAXXAV
              IF (MAXNVS .GT. MXAV1) MAXNVS = MXAV1
      ENDIF
      IF (MAXNVS .GT. MAXVEC/NSMAX)  MAXNVS = MAXVEC/NSMAX
      J1 = 0
      IF ( MINASV .GT. MXAV2)  THEN
                               MINVCS = MXAV2
      ELSE IF ( MINASV .GT. MXAV1) THEN
                               MINVCS = MINASV
      ELSE
                               MINVCS = MXAV1
      ENDIF
      DO 120 NS = 1, NSMAX
      NDELV(NS) = IPOASV(NS) - J1 - MINVCS
      IF (NDELV(NS) .LT. 0) NDELV(NS) = 0
      J1 = IPOASV(NS)
 120  CONTINUE
      MINNVS = MAXNVS
      MINNV2 = MAXNVS
      JA1   = 1
      JVEC1 = 1
      DO 500 NS = 1, NSMAX
      IF (NS .NE. 1)  THEN
          JA1   = IPOASV(NS-1) + 1
          JVEC1 = IPVECT(NS-1) + 1
      ENDIF
      NASVCS = IPOASV(NS) - JA1 + 1
      NHIGST = NASVCS
      CALL DETSET (INDXHV(JVEC1),NHIGST, ASVECT(1,JA1),6,NASVCS, 5,0)
         J = JVEC1
        JJ = JVEC1
      NRESTA = NASVCS
      IF (MINASV .LE. MXAV2) THEN
         NDVMIN = NDELV(NS)
      ELSE
         NDVMIN = NASVCS - MAXNVS
         ENDIF
      NCLOSE = 0
  200 CONTINUE
      IF (NRESTA+NCLOSE .EQ. NDVMIN  .OR.  NRESTA .EQ. 0)   GOTO 401
         JA = INDXHV(JJ) + JA1 - 1
         JJ = JJ + 1
         NRESTA = NRESTA - 1
           INDXHV(J) = JA
           J = J + 1
      GOTO 200
  401 CONTINUE
          IF (MINNVS .GT. J-JVEC1)   MINNVS = J-JVEC1
          IF (NS.GT.1)  THEN
              IF (MINNV2 .GT. J-JVEC1)   MINNV2 = J-JVEC1
          ENDIF
          IPVECT(NS) = J - 1
          IF (NS.EQ.1)     INDVEC(1)= 0
          IF (NS.NE.NSMAX) INDVEC(J)= 0
  500 CONTINUE
      IF (MINASV .GT. MXAV2) THEN
            MAXNVS=MINNVS
            J1 =0
            J2 =0
            JA1=0
            DO  630  NS = 1,NSMAX
               DO  610 J= J1+1, J1+MINNVS
               J2 = J2+1
               INDXHV(J2)=INDXHV(J)
 610           CONTINUE
               J1=IPVECT(NS)
               IPVECT(NS)=J2
               IF(NS.NE.NSMAX) INDVEC(J2+1)= 0
               NDELV(NS) =IPOASV(NS)-JA1 - MINNVS
               JA1=IPOASV(NS)
 630        CONTINUE
      ENDIF
          NVV = IPVECT(NSMAX)
              IF (MSUM .GT. MINNV2*FRACM)  MSUM = MINNV2 * FRACM
              IF (MSUM .LT. MSUMI)   MSUM=MSUMI
              IF (MSUM .GT. MINNV2-2)  MSUM=MINNV2-2
              IF (MSUM .GT. MINNVS)
     *                                 MSUM=MINNVS
              IF (MSUM .LE. 0)         MSUM=1
      RETURN
      END
      SUBROUTINE CALISF (MSUM, SMINML,VALISF)
      DIMENSION SMINML(NSMAX), VALISF(5)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zvcts.inc'
      COMMON /CONVAR/ DISPMX, VMAX,VMIN, FRACM, IFOMX(7,197), GRIDS1
      PARAMETER (MAXAT = 1020)
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      DATA  VALUMN /-1.0E+15 /
      DATA  VALUMX / 1.0E+15 /
      AMNMIN = VALUMN
      INDVEC(1) = 0
      DO 101 NS = 1, NSMAX-1
 101  INDVEC( IPVECT(NS)+1 ) = 0
      TMIM = VALUMX
      TSUM = 0.
      CALL SUPTAM ( AMNMIN, MSUM, VECT, NVV,
     *   IPVECT, NSMAX, INDVEC, SMINML, TMIM)
                       MALL = NSMAX * MSUM
      IF (MALL.GT.200)  MALL = 200
      CALL ISFT( MALL, VECT, NVV, TMINM)
      SUM2= 0.0
      SMIN2= SMINML(2)
      DO 140 NS = 2, NSMAX
      SUM2= SUM2+ SMINML(NS)
      IF (SMIN2 .GT. SMINML(NS))   SMIN2=SMINML(NS)
 140  CONTINUE
                      VALISF(1) = SMIN2
                      VALISF(2) = TMIM
                      VALISF(3) = TMINM
                  VALISF(4) = TSUM
                      VALISF(5) = SUM2
      INDVEC(1) = 0
      DO 111 NS = 1, NSMAX-1
 111  INDVEC( IPVECT(NS)+1 ) = 0
      RETURN
      END
      SUBROUTINE ISFT( M, VECT, NVV, TMINM)
      DIMENSION          VECT(6,NVV), INXLPW(200)
      DO 110 N = 1,NVV
 110  VECT(5,N)=-VECT(5,N)
      CALL DETSET(INXLPW,M, VECT, 6, NVV, 5, 0)
      DO 120 N = 1,NVV
 120  VECT(5,N)=-VECT(5,N)
        TSUMP = 0.0
        TSUMW = 0.0
        DO 210 IN = 1,M
        N = INXLPW(IN)
        TSUMP = TSUMP + VECT(6,N)
        TSUMW = TSUMW + VECT(4,N)
 210    CONTINUE
        TMINM = TSUMP/TSUMW
      RETURN
      END
      SUBROUTINE SUPTAM (AMINMN, MSUM, VECT, NVV,
     *   IPVECT, NSM, INDVEC, SMINML, TMIMAP)
      DIMENSION VECT(6,NVV), IPVECT(NSM), INDVEC(NVV), SMINML(NSM)
      LOGICAL TDONE
      DO 400  NS = 1, NSM
      IF ( TDONE ( AMINMN, TMIMAP) ) THEN
         SMINML(NS) = 0.0
         GOTO 400
         ENDIF
      IF (NS. NE. 1) THEN
                       J1 = IPVECT(NS-1) + 1
                     ELSE
                       J1 = 1
      ENDIF
      NVECS = IPVECT(NS) - J1 + 1
      CALL MINMVS (MSUM, VECT(1,J1),NVECS,INDVEC(J1), SMINML(NS))
                         WSMINM = SMINML(NS)
      IF (WSMINM .LT. TMIMAP) TMIMAP = WSMINM
  400 CONTINUE
      RETURN
      END
      SUBROUTINE MINMVS (MSUM, VECT, NVECS, INDVEC, SMINML)
      DIMENSION VECT(6,NVECS),INDVEC(NVECS)
           DO 110  N = 1, NVECS
  110      INDVEC(N) = N
      SUMP = 0.
      SUMW = 0.
      DO 200  JSEQ = 1, NVECS
         I = INDVEC(JSEQ)
         CALL RDFUN ( VECT(1,I), PFUNF )
         VECT(6,I) =  PFUNF
         VECT( 5,I) =  VECT(6,I) / VECT( 4,I)
         CALL UPISF (SMINML, SUMP, SUMW, JSEQ, MSUM, VECT,
     *                                              INDVEC, NVECS)
  200 CONTINUE
      RETURN
      END
      SUBROUTINE UPISF ( SMINML, SUMP, SUMW, J, M,
     *                   VECT,          INDVEC, NVECS )
      DIMENSION          VECT(6,NVECS), INDVEC( NVECS )
      IJ = INDVEC(J)
      IF (J.GT.M) THEN
         IM = INDVEC(M)
         IF ( VECT(5,IM) .LE. VECT(5,IJ) ) RETURN
            SUMP = SUMP + VECT(6,IJ) - VECT(6,IM)
            SUMW = SUMW + VECT(4,IJ) - VECT(4,IM)
      ELSE
            SUMP = SUMP + VECT(6,IJ)
            SUMW = SUMW + VECT(4,IJ)
         IF (J .LT. M) RETURN
         ENDIF
         SMINML = SUMP/SUMW
      IF (J.GT.M)  THEN
         MC=INDVEC(M)
         INDVEC(M)=INDVEC(J)
         INDVEC(J)=MC
         ENDIF
      PWMAX = VECT( 5,INDVEC(M) )
      IMAX  = M
      MMIN1 = M-1
      DO 100 I = 1,MMIN1
      II = INDVEC(I)
      IF (VECT(5,II) .GT. PWMAX) THEN
         PWMAX = VECT(5,II)
         IMAX  = I
         ENDIF
  100 CONTINUE
      IF (IMAX .EQ. M ) RETURN
      MC = INDVEC(M)
      INDVEC(M) = INDVEC(IMAX)
      INDVEC(IMAX) = MC
      RETURN
      END
      LOGICAL FUNCTION TDONE ( AMINMN, TMMAP)
      TDONE = .FALSE.
      TDONE = TMMAP .LT. AMINMN
      RETURN
      END
      SUBROUTINE RDFUN (ARG, FUNF)
      DIMENSION ARG(3)
      INCLUDE 'Zsyst.inc'
      COMMON /DEKDAT/ NXYZ(3),  IS(3),   NUM(3), NUMXY, NUMXYZ, NUMC,
     *                GTXYZ(3), LXYZ(3), VDUMMY
      EQUIVALENCE (NX, NUM(1)), (NXY, NUMXY)
      PARAMETER (NUMTAB=200000)
      COMMON /BLANK/ ITAB, DUMMY(60000)
      INTEGER*2 ITAB(NUMTAB)
      DIMENSION  IFAR(3), INEAR(3), RARG(3), FM(3)
      EQUIVALENCE (IXFAR,IFAR(1)),  (IYFAR,IFAR(2)),  (IZFAR,IFAR(3))
      EQUIVALENCE (IXNEAR,INEAR(1)),(IYNEAR,INEAR(2)),(IZNEAR,INEAR(3))
      EQUIVALENCE (RX,RARG(1)),     (RY,RARG(2)),     (RZ,RARG(3))
      EQUIVALENCE (FMX,FM(1)),      (FMY,FM(2)),      (FMZ,FM(3))
      DO 301 J= 1, 3
      RARG(J) = AMOD(ARG(J),1.0)
      IF (RARG(J) .GE. 0.5) RARG(J) = RARG(J) - 1.0
      IF (RARG(J) .LT. -.5) RARG(J) = RARG(J) + 1.0
  301 CONTINUE
      CALL SYMMV (RX, RY, RZ)
      DO 599 IX=1,3
      T = RARG(IX) * GTXYZ(IX)
      IF (T) 540, 550, 550
  540 T = T - 1.
  544 I = IFIX(T)
      IF (I.GE.-LXYZ(IX)) GOTO 555
      T = T + 0.01
      GOTO 544
  550 I = IFIX(T)
      IF (I.LT.LXYZ(IX)) GOTO 555
      T = FLOAT(I) - 0.01
      GOTO 550
 555  F=T-FLOAT(I)
      IF (F) 560,590,570
 560       F=F+1.0
 570  IF (F-0.5) 590,580,580
 580  FM(IX) = 1. - F
      IFAR(IX)=I
      INEAR(IX)=I+1
      GOTO 599
 590  FM(IX) = F
      INEAR(IX)=I
      IFAR(IX)=I+1
 599  CONTINUE
      K111 = NXY * IZNEAR + NX * IYNEAR + IXNEAR - NUMC
      IJX = ITAB(K111)
      FUNF = FLOAT( IJX ) / 99.
      FUNNER=FUNF
      K211=K111-IXNEAR+IXFAR
      K121=K111+NX*(IYFAR-IYNEAR)
      K112=K111+NXY*(IZFAR-IZNEAR)
      IJX = ITAB(K211)
      FUNX = FLOAT( IJX ) / 99.
      IJX = ITAB(K121)
      FUNY = FLOAT( IJX ) / 99.
      IJX = ITAB(K112)
      FUNZ = FLOAT( IJX ) / 99.
      FUNF = FUNF * (1.-FMX-FMY-FMZ) + FUNX*FMX + FUNY*FMY + FUNZ*FMZ
      I1=IZFAR*NXY
      I2=IYFAR*NX
      K222 = I1 + I2 + IXFAR - NUMC
      K122=K222-IXFAR+IXNEAR
      K212=K222-I2+NX*IYNEAR
      K221=K222+NXY*IZNEAR-I1
      FMXY=FMX*FMY
      FMXZ=FMX*FMZ
      FMYZ=FMY*FMZ
      FMXYZ=FMX*FMYZ
      IJX = ITAB(K222)
      FUNFAR = FLOAT( IJX ) / 99.
      T1=FMYZ-FMXYZ
      IJX = ITAB(K122)
      FUNYZ = FLOAT( IJX ) / 99.
      T2=FMXZ-FMXYZ
      IJX = ITAB(K212)
      FUNXZ = FLOAT( IJX ) / 99.
      IJX = ITAB(K221)
      FUNXY = FLOAT( IJX ) / 99.
      FUNF=FUNF+ FMXYZ*FUNFAR + T1*FUNYZ + T2*FUNXZ +
     1(FMXY-FMXYZ)*FUNXY+FUNNER*(T1+FMXZ+FMXY) - FUNZ*(T2+FMYZ)
     1 -FUNY*(T1+FMXY) - FUNX*(T2+FMXY)
      RETURN
      END
      SUBROUTINE SYMMV (X, Y, Z)
      INCLUDE 'Zsyst.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (KLAUE,  KEYS(6))
      GOTO (5, 15, 25, 35), KLAUE
   5  IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      Z = -Z
      RETURN
   15 Y = ABS(Y)
      IF (X.GE.0.0) RETURN
      X = -X
      Z = -Z
      RETURN
   25 X = ABS(X)
      Y = ABS(Y)
      Z = ABS(Z)
      RETURN
   35 Z = ABS(Z)
      IF (X.GE.0.0) RETURN
      X = -X
      Y = -Y
      RETURN
      END
      SUBROUTINE SQMODL (INHVAM, MMOD)
      DIMENSION INHVAM(MMOD)
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IATOMS, IFILE(1))
      EQUIVALENCE (IATOLD, IFILE(2)), (IDDSY, IFILE(3))
      EQUIVALENCE (IKLAD, IFILE(20))
      EQUIVALENCE (IRUN, KSTAT(13))
      COMMON /CONVAR/ DISPMX, VMAX, VMIN, FRACM, IFOMX(7,197), GRIDS1
      DIMENSION VAMINM(197), VAMI(5)
      CHARACTER *6  REMARK(1)
      CHARACTER *6 CBOTS, TBOTS
      DATA REMARK /'REMARK'/
      CALL WR24
         write(7,FMT='(/'' Table 925-1''//
     *      '' Results for all input models, sorted'',
     *      '' on CFOM = TRACOR * TRAVEC * 10''//
     *      '' ###   < atoms-sets            FOM    FOM   ''/
     *      '' TV=   MOD= OR= TR=    CFOM TRACOR TRAVEC     R2 ''/)')
         WRITE(8,FMT='(/'' Table 925-2''//
     *      '' Results for all input models, sorted'',
     *      '' on CFOM = TRACOR * TRAVEC * 10''//
     *      '' ##  atoms-sets  CFOM   FOM FOM  '',
     *      ''        Nr of Vectors   Select > MIN:''/
     *      '' TV  MOD OR TR       TRACOR TRAVEC  '',
     *      '' R2    all sel MIN   20%  30%  50%''/)')
      REWIND IKLAD
      REWIND IATOMS
      NRMODL = 0
      DO 510 N = 1, MMOD
 501  CALL KERINA(IKLAD, REMARK, 1, LEND)
      IF (LEND .EQ. -1) GOTO 511
      IF (NLUSER(1).LE.0) GOTO  501
      NRMODL = NRMODL +1
      VAMINM(NRMODL) = FNUM(2)
 510  CONTINUE
 511  N=NRMODL
      CALL DETSET (INHVAM, NRMODL, VAMINM, 1, N, 1, 0)
      IBOX = 0
      R2MIN = 999.
      N2MIN = 0
      CFOMM = 0.
      NFOMM = 0
      DO 531 N=1,NRMODL
      REWIND IKLAD
      DO 521 I=1,INHVAM(N)
 520  CALL KERINA(IKLAD, REMARK, 1, LEND)
      IF (LEND .EQ. -1) GOTO 531
      IF (NLUSER(1).LE.0) GOTO  520
 521  CONTINUE
      READ (CHIN, FMT= '(7X,I4,F7.3,2F6.2,2I4,I3,5F6.2)')
     *       NOMODL, AMINMX, DMAX,DAVG, NASV, NVV, MALL, (VAMI(I),I=1,5)
      R2X = FLOAT(IFOMX(3, NOMODL)) / 1000.
      IF (R2X .LT. R2MIN) THEN
         R2MIN = R2X
         N2MIN = N
         ENDIF
      IF (N .EQ. 1) CFOMM = 0.6 * AMINMX - 0.01
      IF (AMINMX .GT. CFOMM) NFOMM = N
      NNMOD = IFOMX(4, NOMODL)
      NNNOR = IFOMX(5, NOMODL)
      NNNTR = IFOMX(6, NOMODL)
      CALL WR24
      write(7, FMT= '(I4, I6, 2I4, F9.3, 2F7.3, F7.3 )')
     *   N, NNMOD, NNNOR, NNNTR, AMINMX, VAMI(5), VAMI(1), R2X
      WRITE (8, FMT= '(I3,I5,2I3,1X,3F6.3,1X,F6.3,2X,3I4,1X,3F5.2)')
     *   N, NNMOD, NNNOR, NNNTR, AMINMX, VAMI(5), VAMI(1), R2X,
     *   NASV, NVV, MALL, (VAMI(I),I=2,4)
      IFOM = NINT (AMINMX * 1000.)
      IBOTS = IFOMX(2, NOMODL)
      IF (N .EQ. 1) IBOX = IBOTS
      IF (IBOTS .GT. 0) THEN
         CALL KERI2C (IBOTS, TBOTS, 2)
         CBOTS(5:6) = TBOTS(1:2)
         CBOTS(1:4) = ' X= '
      ELSE
         CBOTS = ' '
         ENDIF
      WRITE (IATOMS, 102) CCODE,NNMOD,NNNOR,NNNTR,N,R2X,IFOM,CBOTS
  102 FORMAT ('ATOMS ', A6, ' < TRAVEC MOD=',I4,' OR=',I3,' TR=', I3,
     *     ' TV=', I3,' R2=', F6.3, ' FOM=', I5, A6)
      WRITE(CHIN, FMT='(''REMARK from OR='',I3,'' TR='',I3,'' FOM '',
     * ''based on TRACOR+TRAVEC:'',F6.3, ''  (not R2)'')')
     *   NNNOR, NNNTR, AMINMX
 522  WRITE (IATOMS, FMT='(A80)') CHIN
      CALL KERINA(IKLAD, REMARK, 1, LEND)
      IF (LEND .NE.  4) GOTO 522
      WRITE (IATOMS, FMT='(''END''/)')
 531  CONTINUE
      CALL FILCLO (2, 'KEEP')
      CALL KERASE ('ATVEC')
      CALL COPY80 (IATOMS, 'ATOMS', 2, 'ATVEC')
      CALL FILCLO (IKLAD, 'DELETE')
      IF (IBOX .GT. 0) GOTO 801
  700 CONTINUE
      I = NINT(1000.*CFOMM)
      write(24, 710) I, NFOMM
  710 FORMAT (/' All accepted sets are written to the ATVEC file; ' /
     * ' CFOM limit is', I5, ' leaving', I3, ' sets.')
      IF (MORIE .LT. 55) MORIE = MAX0 (N2MIN, MORIE)
      MORIE = MIN0 (NFOMM, MORIE, 20)
      CALL WR24
      WRITE(9, 727) MORIE
  727 FORMAT (//' Nr of atom sets to be expanded:',I3 /
     *          ' ----------------------------------'/)
      CALL WR24
      RETURN
  801 CONTINUE
      WRITE (9, 810)
  810 FORMAT (1X/
     * ' All parameter sets are written to the  ATOMS file,  sorted.' /
     * ' The first and best  ATOMS  set, however, is not acceptable,' /
     * ' as the molecule collides with symmetry related molecules !!' /
     * ' The search model probably is incorrect.' /
     * ' If the model consists of more than a symmetry - independent' /
     * ' molecular fragment, then part of the molecule may have been' /
     * ' put at a symmetry-related position which may not be too bad.'/
     * ' And maybe we can overcome the collision problem by chance ?' /
     * ' So we try PHASEX recycling for completion of the tructure !' )
      GOTO 700
      END
      FUNCTION  ISELFC( XC1, XC2, DMIN, DOUT )
      DIMENSION  XC1(3), XC2(3), D(3)
      ISELFC = 0
      DOUT = 0.
      DO 100 I = 1,3
      D(I) = ABS( XC1(I) - XC2(I) )
      IF ( D(I) .GT. DMIN )  RETURN
 100  CONTINUE
      DMINSQ = DMIN * DMIN
      DOUT =   D(1)*D(1) + D(2)*D(2) + D(3)*D(3)
      IF (DOUT .GT. DMINSQ)  RETURN
      DOUT = SQRT( DOUT )
      ISELFC = 1
      RETURN
      END
      FUNCTION ISELGG (X, Y, DMAX1, DISTSQ)
      DIMENSION X(3),Y(3)
      INCLUDE 'Zcrys.inc'
      DIMENSION  DM1(3), D(3)
      LOGICAL DMA1CH
      DATA  DMASQ1 /0.0/
      DATA  DMA1CH /.TRUE./
      IF ( DMA1CH) THEN
         DO 110 I=1, 3
            DM1(I)=ABS (RCELL(I)*DMAX1)
  110    CONTINUE
         DMA1CH=.FALSE.
         DMASQ1=DMAX1*DMAX1
         ENDIF
      ISELGG = 0
      DO 130 I=1, 3
         D(I)=X(I)-Y(I)-ANINT (X(I)-Y(I))
            IF ( ABS(D(I)) .GT. DM1(I) ) RETURN
  130 CONTINUE
      DISTSQ=0.0
      DO 140 I=1, 3
         DISTSQ=DISTSQ+
     *          D(I)*(RRMAT(1,I)*D(1)+RRMAT(2,I)*D(2)+RRMAT(3,I)*D(3))
  140 CONTINUE
      IF (DISTSQ .GT. DMASQ1)   RETURN
      ISELGG=1
      RETURN
      END
      SUBROUTINE ATMOUT (IUNIT, CCODE, REMARK, ATNAME, NNAMS, XYZ, NAT)
      CHARACTER*6               CCODE,         ATNAME(NNAMS)
      CHARACTER*8                      REMARK(10)
      DIMENSION  XYZ(3,NAT)
      IF (REMARK(1) .NE. 'REMARK  ') THEN
      WRITE(IUNIT,FMT='(''ATOMS'',5X,A6,6A8)') CCODE,(REMARK(I),I=1,6)
      ELSE
         WRITE(IUNIT,FMT='(''ATOMS'', 5X,A6)' ) CCODE
         WRITE (IUNIT, FMT='(10A8)' ) REMARK
         ENDIF
      NAMI = 1
      DO 110 I = 1,NAT
      IF (I.LE.NNAMS) NAMI=I
      WRITE (IUNIT, FMT='(''ATOM  '', A6, 3F10.5)' )
     *   ATNAME(NAMI), (XYZ(J,I),J=1,3)
  110 CONTINUE
      WRITE (IUNIT, FMT='(''END''/)')
      RETURN
      END
      SUBROUTINE RESTRT (PARM)
      SAVE FIRST, K
      CHARACTER *6 PARM
      CHARACTER *6 FIRST
      INCLUDE 'Zsyst.inc'
      EQUIVALENCE (IDDJ, IFILE(2))
      EQUIVALENCE (MSDOS, KSTAT(1))
      DATA FIRST /'  '/
      DATA K /0/
      IF (PARM .EQ. 'PHASEX') GOTO 100
      IF (PARM .EQ. 'TRACOR') GOTO 100
      K=K+1
      IF (FIRST .EQ. ' ') FIRST = PARM
      IF (FIRST .NE. 'ORBASE') RETURN
      IF (K .GT. 2) RETURN
  100 CONTINUE
      CALL FILCLO (IDDJ, 'KEEP')
      CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IDDJ, FMT='(A6, 1X, A6)') CCODE, PARM
      CALL FILCLO (IDDJ, 'KEEP')
      CALL DDUNIF
      END
      SUBROUTINE ATSETS
      INCLUDE 'Zaaaa.inc'
      EQUIVALENCE (IATOLD, IFILE(2))
      EQUIVALENCE (KEYD, KSTAT(19))
      INCLUDE 'Zatq2.inc'
      DATA MSET /1/
      write(24, FMT='('' DDJOB: '', 3A7)') LITJ1, LITJ2, LITJ3
      IF (LITJ3 .EQ. '#1') MSET = 0
      IF (LITJ3 .EQ. '#2') MSET = 1
      IF (LITJ3 .EQ. '#3') MSET = 2
      IF (LITJ3 .EQ. '#4') MSET = 3
      IF (LITJ3 .EQ. '#5') MSET = 4
      KEYD = 7
      LITJ2 = 'PATTY'
      MSET = MSET + 1
      WRITE (9, 111) MSET
  111 FORMAT (' Run PHASEX for PATTY output ATOMS sets' /
     *   ' Presently PHASEX is started for PATTY set nr', I3)
      CALL FILCLO (IATOLD, 'KEEP')
      CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ.EQ.-1) THEN
         CALL FILCLO (IATOLD, 'KEEP')
         WRITE (9, FMT='('' file ATOLD not found '')')
         GOTO 900
         ENDIF
      NA = 0
      NB = 0
      NFIRST = 0
  120 CONTINUE
      NA = NA + 1
      CALL KERINA (IATOLD,  LIT, 1, LEND)
      IF (LEND .EQ. 5) GOTO 150
      IF (LEND .LT. 0) GOTO 150
      IF (LIT(1) .NE. 'ATOMS') GOTO 120
      IF (LIT(3) .EQ. '<' .AND. LIT(4) .EQ. 'PAT.R2') GOTO 127
      NB = 0
      GOTO 120
  127 CONTINUE
      IF (NB .EQ. 1) GOTO 120
      NFIRST = NA
      NB = 1
      IF (FNUM(1) .GT. 0.9) THEN
         RUN = FNUM(1)
      ELSE
         RUN = FNUM(2)
         ENDIF
      IRUN = NINT(RUN)
      IF (IRUN .LE. 0 .OR. IRUN. GT. 999) IRUN = 0
      GOTO 120
  150 CONTINUE
      IF (NFIRST .LE. 1) THEN
         CALL FILCLO (IATOLD, 'KEEP')
         WRITE (9, FMT='('' PATTY sets not found on file'')')
         GOTO 900
         ENDIF
      REWIND IATOLD
      DO 157 N = 1, NFIRST
  157 READ (IATOLD, FMT='(A)') CHIN
      WRITE (9, FMT='('' --- OK --'')')
      WRITE (9, FMT='(A)') CHIN
      IF (MSET .EQ. 1) GOTO 167
      DO 161 I = 2, MSET
      II = I
  159 CALL KERINA (IATOLD,  LIT, 1, LEND)
      IF (LEND .EQ. 5) GOTO 165
      IF (LEND .LT. 0) GOTO 165
      IF (LIT(1) .NE. 'ATOMS') GOTO 159
  161 CONTINUE
      WRITE (9, FMT='('' --- set '', I3)') II
      WRITE (9, FMT='(A)') CHIN
      write(24, FMT='( / '' ATSETS: ATOMS... '' , A50 / 6 (1X, A6) /)')
     *    CHIN(1:50), (LIT(I), I=1,6)
      IF (LIT(3) .EQ. '<' .AND. LIT(4) .EQ. 'PAT.R2') THEN
         WRITE (9, FMT='(A)') CHIN
         GOTO 167
         ENDIF
  165 CONTINUE
      write(24, FMT='('' einde verhaal '' )')
      GOTO 900
  167 CONTINUE
      BACKSPACE IATOLD
      CALL QFOMR2 (0, 0, 0., 0., CHIN)
      NSET =  0
      CALL ATIN7 (NSET)
      IM = 1
      WRITE (9, FMT='(''AXXMS '', A6, '' < PAT.R2 0 RUN'', I4,
     *   '' PAT='', I3, '' R2='', F6.3, '' FOM='', F6.3)')
     *   CCODE, IRUN, NPATS(IM), R2S(IM), PFOMS(IM)
      CALL FILCLO (IATOLD, 'KEEP')
      IATO = IATOLD
      CALL FILINQ (IATO, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IATO, FMT='(''ATOMS '', A6, '' < PAT.R2 0 RUN'', I4,
     *   '' PAT='', I3, '' R2='', F6.3, '' FOM='', F6.3)')
     *   CCODE, IRUN, NPATS(IM), R2S(IM), PFOMS(IM)
      NAT = NATSS(IM)
      DO 747 I = 1, NAT
      WRITE (IATO, FMT='( ''ATOM   '',A6, 3F9.5, 2F9.4)')
     *   ATNMS(I), (XYZ(J,I), J=1,5)
  747 CONTINUE
      WRITE (IATO, FMT='(''END''/)')
      CALL FILCLO (IATO, 'KEEP')
      CALL WILSIN (999)
      MPAT = 0
      KEYD = 32
      LITJ2 = 'ATSETS'
      KSTAT(13) = KSTAT(13) + 1
      CALL RESTRT ('PHASEX')
  900 CONTINUE
      CALL DDEXIT
      END
      SUBROUTINE ATPATS (KKEY)
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zatq2.inc'
      COMMON /ORFLES/ LASTV, NORFLX (6, 50)
      DATA IATOMS, IATPAT, IATRES /2, 10, 1/
      DATA NFINAL /0/
      IF (NFINAL .NE. 0) CALL DDEXIT
      IF (MORIE .NE. 0 .AND. KKEY .EQ. 0) R2X = 999.
      WRITE (8, FMT='(/'' ***** ATPATS *****''/ 20X, ''MPAT='',I3,
     *   ''   MORIE='',I3, 3X, ''R2 ='', F6.3 / 20X, ''IPAT='',I3 )')
     *   MPAT, MORIE, R2X, IPAT
      IF (MORIE .EQ. 0) THEN
         LASTV = 0
         GOTO 110
         ENDIF
      IF (KKEY .NE. 0) GOTO 103
      MPAT = - MORIE
      IORIE = 1
      IPAT = IORIE
      R2OLD = 999.
      MAXPAT = MORIE
      CALL KERASE ('ATRES')
      IBEST = 0
      CALL FILCLO (IATOMS, 'KEEP')
      CALL KERASE ('ATOMS')
      CALL KERASE ('ATPAT')
      CALL COPY80 (IATOMS, 'ATVEC', IATPAT, 'ATPAT')
      CALL FILCLO (IATOMS, 'KEEP')
      CALL COPY80 (IATPAT, 'ATPAT', IATOMS, 'ATOMS')
      LASTV = 0
      CALL KERNZI (0, NORFLX, 300)
      CALL RESTRT ('PHASEX')
  103 CONTINUE
      IORIE = IORIE + 1
  110 CONTINUE
      IF (KKEY .EQ. 0) THEN
         R2OLD = 999.
         MAXPAT = -MPAT
         IPAT = 0
         CALL KERASE ('ATRES')
         CALL KERASE ('ATPATX')
         IBEST = 0
         GOTO 117
         ENDIF
      CALL FILCLO (IATRES, 'KEEP')
      CALL COPY80 (IATOMS, 'ATOMS', IATPAT, 'ATPATX')
      CALL COMPAT
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ)
      CALL KERINA (IATOMS,  LIT, 1, LEND)
      IF (LEND .NE. 0) CALL KERROR (' ATOMS ??', 111, 'ATPATS')
      IF (LIT(1) .NE. 'ATOMS')
     *                    CALL KERROR (' no ATOMS', 111, 'ATPATS')
      IF (LASTV .GE. 1) THEN
         NORFLX(6, LASTV) = NINT (1000. * R2X)
         WRITE(24, 114) (NORFLX(I, LASTV), I=1,5), R2X
  114    FORMAT (12X,' atoms set MOD= OR= TR= TV= FOM= ', 4I3, I5,
     *      ' R2=', F6.3)
         ENDIF
      CALL WR24
      IF (R2X .GE. R2OLD) GOTO 115
      R2OLD = R2X
      IBEST = IPAT
      WRITE (8, FMT='('' $TE IBEST  R2OLD'', I3, F6.3)') IBEST, R2OLD
      CALL FILINQ (IATPAT, 'ATRES', 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. 0) CALL FILCLO (IATPAT, 'DELETE')
      CALL COPY80 (IATOMS, 'ATOMS', IATPAT, 'ATRES')
  115 CONTINUE
      CALL COPY80 (IATOMS, 'ATOMS', IATPAT, 'ATOLD')
  117 CONTINUE
      CALL FILINQ (IATPAT, 'ATPAT', 'FORMATTED', 'INPUT', KINQ)
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      IPAT = IPAT + 1
      IF (IPAT .GT. MAXPAT) GOTO 900
      NA = 0
      NB = 0
      CALL KERASE ('ATTEM')
  120 CONTINUE
      READ (IATPAT, END=750, FMT='(A)') CHIN
      NA = NA + 1
      IF (CHIN(1:6) .EQ. 'FINISH') GOTO 750
      IF (CHIN(1:6) .NE. 'ATOMS ') GOTO 120
      NB = NB + 1
      IF (NB .LT. IPAT) GOTO 120
  130 CONTINUE
      WRITE (IATOMS, FMT='(A)') CHIN
      IF (CHIN(1:3) .EQ. 'END') GOTO 133
      READ (IATPAT, END=750, FMT='(A)') CHIN
      IF (CHIN(8:13) .EQ. 'BpBr= ') THEN
         READ (CHIN, FMT='(13X, 2F9.4)') BP, BR
         PATBP = BP
         PATBR = BR
         write(24, FMT='(/'' REMARK Bp Br = '', 2F9.4/)') BP, BR
         ENDIF
      IF (CHIN(1:6) .EQ. 'FINISH') GOTO 750
      IF (CHIN(1:6) .NE. 'ATOMS ') GOTO 130
  133 CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATPAT, 'KEEP')
      KSTAT(13) = KSTAT(13) + 1
      CALL RESTRT ('PHASEX')
  750 CONTINUE
      WRITE (24, FMT='(1X/'' (some) PATTY sets not found on file''/)')
      IF (IPAT .EQ. 1) CALL DDEXIT
      MAXPAT = IPAT - 1
      MORIE = MAXPAT
  900 CONTINUE
      IF (LASTV .GE. 1) THEN
         write(24, 904)
  904    FORMAT (// ' ---------------------------------------'/
     *            / ' Summary of expansions of all atoms sets'/
     *            / ' ---------------------------------------'/
     *            / ' AtSET MOD= OR= TR= TV= FOM=   R2[=test]'/)
         DO 906 NTV=1,LASTV
         R2SUM = FLOAT(NORFLX(6, NTV)) / 1000.
         write(24, 905) NTV, (NORFLX(I, NTV), I=1,5), R2SUM
  905    FORMAT (I6, I5, 3I4, I5, F10.3)
  906    CONTINUE
         ENDIF
      CALL WR24
  911 FORMAT(1X/1X/' ========================================',
     *            /' continue with best atoms set = AtSET=', I3,
     *            /' ========================================'/1X)
      WRITE (9, 911) IBEST
      CALL WR24
      CALL FILCLO (IATOMS, 'KEEP')
      CALL KERASE ('ATOMS')
      CALL KERASE ('ATTEM')
      CALL KERASE ('ATPAT')
      CALL COPY80 (IATPAT, 'ATRES', IATOMS, 'ATOMS')
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATPAT, 'KEEP')
      NFINAL = 1
      MPAT = -99
      IPAT = 0
      KSTAT(13) = KSTAT(13) + 1
      CALL RESTRT ('PHASEX')
      CALL DDEXIT
      END
      SUBROUTINE ORSETS (MERK)
      INCLUDE 'Zaaaa.inc'
      DATA IATOMS, IATORI / 2, 10 /
      DATA NCALL /1/
      IF (NCALL .EQ. 1) WRITE (9, FMT='(1X)')
      WRITE (9, FMT='('' TRACOR completed for OR='', I3,
     *   ''   Number of shift vectors:'', I3)') NCALL, MORIE
      IF (NCALL .NE. IORIE) STOP 931
      NCALL = NCALL + 1
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATORI, 'KEEP')
      CALL FILINQ (IATORI, 'ATORI', 'FORMATTED', 'INPUT', KINQ)
      DO 120 I = 1, IORIE
      CHIN = ' '
  105 READ (IATORI, 110, ERR = 140, END = 140 ) CHIN
  110 FORMAT (A)
      IF (CHIN(1:6) .EQ. 'FINISH') GOTO 140
      IF (CHIN(1:6) .EQ. 'END   ') GOTO 120
      GOTO 105
  120 CONTINUE
  125 READ (IATORI, 110, ERR = 140, END = 140 ) CHIN
      IF (CHIN(1:6) .EQ. 'FINISH') GOTO 140
      IF (CHIN(1:6) .EQ. '      ') GOTO 125
      IF (CHIN(1:6) .EQ. 'END   ') GOTO 125
      IF (CHIN(1:6) .EQ. 'REMARK') GOTO 125
      IF (CHIN(1:6) .NE. 'ATOMS') GOTO 140
      CALL KERASE ('ATOMS')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (IATOMS, 110) CHIN
  130 READ (IATORI, 110, ERR = 140, END = 140 ) CHIN
      WRITE (IATOMS, 110) CHIN
      IF (CHIN(1:6) .EQ. 'FINISH') GOTO 135
      IF (CHIN(1:6) .EQ. 'END   ') GOTO 135
      GOTO 130
  135 CONTINUE
      CALL FILCLO (IATOMS, 'KEEP')
      CALL FILCLO (IATORI, 'KEEP')
      WRITE (24, FMT='(/'' Next run TRACOR  for OR='', I3)') NCALL
      WRITE (24, FMT='('' ---------------------------''/1X)')
      MERK = NCALL
      RETURN
  140 CONTINUE
      WRITE (9, FMT='('' ---------------------------''/
     *                   '' ----- call for TRAVEC -----''/1X)')
      M = MORIE
      IF (M .EQ. 1) MORIE = 3
      IF (M .EQ. 2) MORIE = 5
      IF (M .EQ. 3 .OR. M .EQ. 4) MORIE = 2*M
      IF (M .GE. 5 .AND. M .LE. 9) MORIE = 10
      IORIE = 0
      MPAT = 0
      MERK = -1
      RETURN
      END
      SUBROUTINE FCALG
      INCLUDE 'Zaaaa.inc'
      INCLUDE 'Zcrys.inc'
      EQUIVALENCE (IATOMS, IFILE(2) )
      EQUIVALENCE (IDDL,  IFILE(1))
      EQUIVALENCE (ICRYS, IFILE(3))
      INCLUDE 'Zfcala.inc'
      INCLUDE 'Zfcalx.inc'
      INCLUDE 'Zatomx.inc'
      PARAMETER (MAXP=500, MAXSCS=3000)
      COMMON /BLANK/ DUMFC(19630), DUMAT(11918),
     *               PAIRS (6,MAXP), MPAIR, SCS(2,MAXSCS), DUMMY(119451)
      DIMENSION HKL(3)
      EQUIVALENCE (HKL(1), HKLX(1,1))
      DIMENSION SIK(28)
      DATA SIK / 1.005, 1.01 , 0.995, 0.99 , 1.015, 0.985, 0.98,
     *           0.985, 1.02 , 1.005, 1.01 , 0.995, 0.99 , 1.015, 0.98,
     *           1.005, 1.01 , 0.995, 0.99 , 1.015, 0.985, 1.01,  0.99,
     *           1.005, 1.02 , 0.995, 1.005, 0.995 /
      BR = 2.0
      STLMAX = 0.9
      SCALE = 1.2000
      SSC = 2.0
      DO 101 KK = 1,28
      SIK(KK) = (SIK(KK) - 1.)*SSC + 1.
  101 CONTINUE
      CALL RDCRYS (ICRYS)
      WRITE (8, FMT='(1X, ''SUBROUTINE FCALG'')')
      WRITE (24, FMT='(66X, A6)') CCODE
      WRITE (24,FMT='('' Wavelength of radiation'',41X,F7.5)') WAVE
      WRITE (24, FMT='('' CELALL'',  6F6.0)') (CELALL(I),I=1,6)
      WRITE (24, FMT='('' CELCON'',  6F6.0)') (CELALL(I),I=1,6)
      NREF = 0
      MREF99 = 0
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINIA)
      IF (KINIA .NE. 0) CALL KERROR( ' No ATOMS file', 0, 'FCALG')
      CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
      CALL ATOMPR (24, 7, ATXYZ, ATNAME, IZAT, NAT)
      CALL FILCLO (IATOMS, 'KEEP')
      WRITE (24, 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) WRITE (24,*)
     *   '   Atoms have individual isotropic temperature factors'
      CALL WR24
      CALL FCALCI (ATXYZ, IZAT, ITAT, NAT)
      CALL FILINQ (13, 'FREFG', 'FORMATTED', 'OUTPUT', KINQ)
      WRITE (13, FMT='(''FREF  '', A6)') CCODE
      KK = 0
      LL = 5
      IEND = 1
  130 CALL MEREAD (HKL, JC, FOBS, SIG, IEND)
      IF (IEND .LT. 0) 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
      NREF = NREF + 1
      CALL HKLSTL (HKL, STL, STL2)
      IF (STL .GE. STLMAX) GOTO 130
      CALL FCALC1 (ATXYZ, ITAT, NAT)
      K = NINT(HKL(1))
      L = NINT(HKL(2))
      M = NINT(HKL(3))
      KK = KK + 1
      LL = LL - 1
      IF (KK .GT. 28) KK = 1
      IF (LL .LT. 1) LL = 28
      FOBSS = FP * SIK(KK) / SCALE
      IF (FOBSS .GT. 99999.998) FOBSS = 99999.999
      SOBS = FOBSS * ABS ( SIK(LL) - 1.0 )
      IF (SOBS .GT. 999.998) SOBS = 999.999
      IF (SOBS .LT. 0.002) SOBS = .002
      WRITE (13, FMT='(I4,2I3,2X, F9.3, F7.3)') K, L, M, FOBSS, SOBS
      GOTO 130
  200 CALL FILCLO (IFREF, 'KEEP')
      WRITE (13, FMT='(''E'')')
      CALL FILCLO (13, 'KEEP')
      write(24, 301) NREF
      WRITE (8, 301) NREF
  301 FORMAT(' Number of reflections from input file ', 27X, I6)
      MREF99 = MREF99 - NREF
      IF (MREF99 .GT. 0) write(24, 303) MREF99
  303 FORMAT (' Number of relections skipped:  ', I7)
      CALL DDEXIT
      END
