      PROGRAM DDSTART
*********************************************                DDSTART.FOR
******      DDSTART      ********************  Last update: 11 Nov. 1999
*********************************************  Source:     PTB / CS 1988
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICON, IFILE(4)), (IPR1, IFILE(6)), (LIS1, IFILE(7))
      EQUIVALENCE (ICON1, IFILE(1))
      EQUIVALENCE (LIS2, IFILE(8)), (IHELP, IFILE(9))
      LOGICAL BATCH, SEMAUT, FULAUT, SENDBA
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      EQUIVALENCE (BATCH,  SWITCH(8)),  (SENDBA, SWITCH(22))
      EQUIVALENCE (KEYS(23), KPROG1),   (KS2, KEYS(20))
      CHARACTER * 72 DDCON
      CHARACTER * 1  DDC
      CHARACTER * 6  DDCO(33)
      PARAMETER (LITAM = 30)
      CHARACTER * 6  LITA (LITAM)
      CHARACTER LITA8 *8
      DATA LITA   / 'ORIENT', 'TRACOR', 'PHASEX', 'DDMAIN', 'FCALC' ,
     *              'FFT'   , 'PATTY' , 'PATTER', 'FOUR'  , 'DIRP1' ,
     *              'CRYSDA', 'MERBIN', 'FR2BIN', 'BIN2FR', 'BINPRI',
     *              'EULER' , 'AT2X'  , 'X2AT'  , 'METFOU', 'SHAT'  ,
     *              '$$PTB$', 'NUTS'  , 'TRAMOL', 'INVERT', 'BIJVOE',
     *              'SHELIN', 'R2'    , 'NOFREE', 'MISFIT', 'ORBASE'/
      CALL KEPROG ('DDSTART')
      WRITE (LIS2, FMT = '('' Last DDSTART update: 11 Nov. 1999'')')
      IDDOKA = KEYS(10)
      IF (KEYS(10) .EQ. -17) WRITE (LIS1, FMT=
     *   '(/'' Unified version - DDOKA - Test version Nov. 1999 ''/)')
      F = KEYS(17)
      CALL FILINQ (ICON, 'DDLIC', 'FORMATTED', 'INPUT', KINQL)
      IF (KINQL .EQ. 0) THEN
         CALL FILINQ (ICON1, 'DDCONFIG', 'FORMATTED', 'TEST', KINQL1)
         IF (KINQL1 .EQ. 0) THEN
            CALL FILCLO (ICON1, 'KEEP')
            CHOUT = '0File DDLIC has priority, remove DDCONFIG !'
            CALL SHOUT
            ENDIF
      ELSE
         CALL FILINQ (ICON, 'DDCONFIG', 'FORMATTED', 'INPUT', KINQL2)
         IF (KINQL2 .NE. 0) GOTO 112
         KINQL = 0
         ENDIF
  111 READ (ICON, FMT='(A72)', END=117) DDCON
      IF (DDCON(1:9) .NE. 'Licensee:') GOTO 111
      WRITE (IPR1, FMT='('' '')')
      WRITE (LIS1, FMT='('' '')')
      F = F/10.
      CHOUT = ' '
      WRITE (CHOUT, FMT= '('' DIRDIF Version '', F4.1,
     *   '' licenced to:'')') F
      CALL SHOUT
      DDCON(1:9) = ' '
      CHOUT = DDCON(4:72)
      CALL SHOUT
      WRITE (IPR1, FMT='('' '')')
  112 CONTINUE
      IF (CCODE .EQ. 'H' .OR. CCODE .EQ. 'END' .OR. CCODE .EQ. 'HELP'
     *  .OR. CCODE .EQ. 'BATCH' .OR. CCODE .EQ. '?' .OR. CCODE .EQ.
     *  'CCODE' ) GOTO 119
      IF (KINQL .NE. 0) GOTO 114
      READ (ICON, FMT='(27X, A1)', END=117) DDC
      READ (ICON, FMT='(22X, I6)', END=117) KS2
      IF (DDC .EQ. 'G' .OR. DDC .EQ. 'X') GOTO 119
      IF (DDC .NE. 'W') GOTO 117
  114 CONTINUE
      CALL FILINQ (IHELP, 'DDHELP', 'FORMATTED', 'INPUT', KINQ)
  115 READ (IHELP, FMT='(A72)', END=116) DDCON
      IF (DDCON(1:7) .NE. '+102 CC') GOTO 115
      READ (IHELP, FMT='(11A6/11A6/11A6)') DDCO
      CALL FILCLO (IHELP, 'KEEP')
      CALL KEREQ6 (CCODE, DDCO, 33, LEND)
      IF (LEND .GT. 0) GOTO 119
      WRITE (IPR1, FMT=
     *  '('' --------------------------------------------------'')')
      CHOUT = ' Present compound code (        ) not accepted as a'
      CHOUT(26:31) = CCODE
      CALL SHOUT
      CHOUT = ' test structure under the present DIRDIF licence  !'
      CALL SHOUT
      WRITE (IPR1, FMT='('' See LIS1 ''/'' --------'')')
      WRITE (LIS1, FMT='(/'' List of test structures provided'',
     * '' with the distributed DIRDIF system:''//
     * 8(2X,A6))') (DDCO(I), I=1,32)
      WRITE (LIS1, FMT='(/'' For registration, see file DIRDIF.'',
     * ''README''/'' and e-mail to:  ptb@sci.kun.nl''//)')
      CHOUT = '0Now the program continues .... but soon it stops !'
      CALL SHOUT
      WRITE (IPR1, FMT=
     *  '('' --------------------------------------------------'')')
      GOTO 119
  116 CALL KERROR ('file DDHELP incorrect', 0, 'ERROR')
  117 CALL KERROR ('file DDCONFIG or DDLIC incorrect', 0, 'ERROR')
  119 IF (KINQL .EQ. 0) CALL FILCLO (ICON, 'KEEP')
      CALL DDSTIN (LITA, LITAM, KPROG)
      IF (IDDOKA .EQ. 17) GOTO 999
      IF (KINQL .NE. 0) GOTO 122
      K = KEYS(20)/37
      IF (K.EQ.983) GOTO 122
      IF (K.EQ.991 .OR. K.EQ.992) GOTO 122
      GOTO 117
  122 WRITE (ICON, FMT='(''REMARK PROGRAM OR OPTION CALLED: '',
     *       A6)') LITA(KPROG)
      KPROG1 = KPROG
      IF (KPROG .GE. 11) GOTO 240
      IF (FULAUT) GOTO 240
  230 WRITE (IPR1, 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 (IPR1, 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
      IF (KPROG .LE. 7) SENDBA = .TRUE.
      GOTO (1, 2, 3, 4, 5, 6, 7,  8,  9, 10, 11, 12, 93, 93, 93, 93,
     * 93, 93, 19, 93, 21, 93, 23, 93, 93, 30, 27, 93, 30, 30), KPROG
  270 IF (KPROG .EQ. 0) GOTO 400
      IF (KPROG .EQ. KPROG2) GOTO 91
      IF (KPROG .LT. 0) GOTO 900
      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
  11  CONTINUE
  12  CALL DDMERB (KPROG)
  19  CALL DDMETF (KPROG)
      GOTO 270
  21  CONTINUE
      GOTO 270
  23  CALL DDTRAM (KPROG)
      GOTO 270
  27  CALL DDR2   (KPROG)
  30  CALL KERROR ('Kan niet .. ', 30, 'DDSTART')
  91  LITA8 = LITA(KPROG)
      IF (LITA8 .EQ. 'METFOU') LITA8 = 'METFOUR'
      WRITE (ICON, FMT='(''PROGRAM '', A8)') LITA8
      GOTO 400
  93  LITA8 = LITA(KPROG)
      IF (LITA8 .EQ. 'NUTS') LITA8 = ' '
      WRITE (ICON, FMT='(''PROGRAM NUTS '', A8)') LITA8
  400 WRITE (ICON, FMT='(''FINISH'' )')
      CALL DDSTYX
      GOTO 999
  900 WRITE (IPR1,FMT='('' This program has not yet been completed'')')
      CALL KEPROX
      STOP 2
  999 CONTINUE
      WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)')
      STOP 99
      END
      SUBROUTINE DDSTIN (LITA, LITAM, KPROG)
      CHARACTER * 6  LITA (LITAM)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1)), (IDDS, IFILE(2)), (ICRYS, IFILE(3))
      EQUIVALENCE (IATMOD, IFILE(1))
      EQUIVALENCE (ICON, IFILE( 4)), (IPR1, IFILE( 6))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (KIDDJ, KEYS(4)), (KIDDS, KEYS(5)), (IRUN, KEYS(13))
      EQUIVALENCE (KP2, KEYS(21))
      EQUIVALENCE (IBINFO, IFILE(11)), (KBINFO, KEYS(12))
      LOGICAL NIJMEG, BATCH, START0, SEMAUT, FULAUT, FULBAT
      EQUIVALENCE (NIJMEG, SWITCH(1)), (FULBAT, SWITCH(21))
      EQUIVALENCE (BATCH,  SWITCH(8)), (START0, SWITCH(11))
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      LOGICAL SWNOCY, CRYNEW
      EQUIVALENCE (SWNOCY, SWITCH(18)), (CRYNEW, SWITCH(27))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (MAXBUF = 198)
      DIMENSION BUFFO(MAXBUF), FITFO(3)
      CHARACTER LITA8 *8
      CHARACTER *36 CHINJ
      CHARACTER *6 L(6), LBOS(1), LIT1, LIT2, LIT3
      DATA LMAX / 6 /
      DATA L    /  'END', 'H', '?', 'HELP', 'CCODE', 'BATCH' /
      DATA KINQCO /0/
      KPROG = 0
      IF (KIDDJ .NE. 0) CALL KERROR ('No DDJOB  file', 0, 'DDSTIN')
      IF ((LIT(2) .EQ. 'NOFREE' .AND. LIT(3) .EQ. ' ') .OR.
     *      LIT(3) .EQ. 'NOFREE' ) THEN
         CHOUT = ' NOFREE   is interpreted as:   FOUR NORECY NOFREE'
         CALL SHOUT
         CHOUT = ' which is most usefull if you have updated CRYSIN '
         CALL SHOUT
         CHIN = LIT(1)
         CHIN(8:32) = 'FOUR NORECY NOFREE'
         CALL KERINB (LIT(32), 1)
         ENDIF
      LIT1 = LIT(1)
      LIT2 = LIT(2)
      LIT3 = LIT(3)
      CHINJ = ' '
      CHINJ(2:7) = LIT1
      CHINJ(9:14) = LIT2
      CHINJ(16:21) = LIT3
      CHINJ(23:28) = LIT(4)
      CHINJ(30:36) = LIT(5)
      WRITE (LIS1, 101) CHINJ
      WRITE (LIS2, 101) CHINJ
  101 FORMAT (/ ' Call parameters:  ', A /)
      IF (LIT2 .EQ. 'ORIENT') THEN
         CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'TEST', KINQ)
         IF (KINQ .NE. 0) THEN
            CHOUT = ' Calling ORIENT implies automatic mode:'
            CALL SHOUT
            CHOUT = ' an ATMOD file must be present.        '
            CALL SHOUT
            CHOUT = ' To prepare this file, please, enter:'
            CALL SHOUT
            CHOUT = '    DIRDIF CCODE  ATMOD'
            CHOUT(12:17) = CCODE
            CALL SHOUT
            CALL FILCLO (IATMOD, 'DELETE')
            CALL KESTOP
            CALL KEPROZ
            ENDIF
         CALL FILCLO (IATMOD, 'KEEP')
         ENDIF
      IF (LIT2.EQ.'ATMOD' .OR. LIT1.EQ.'ATMOD') THEN
         CHOUT = ' calling ATMOD is synonym for calling ORBASE'
         CALL SHOUT
         CHOUT=' to prepare ATMOD (or to call the ORBASE data base) '
         CALL SHOUT
         IF (LIT1 .EQ. 'ATMOD') LIT1 = 'ORBASE'
         IF (LIT2 .EQ. 'ATMOD') LIT2 = 'ORBASE'
         ENDIF
      IF (LIT2 .EQ. 'BINFO') THEN
         CHOUT = ' calling BINFO is synonym for calling MERBIN'
         CALL SHOUT
         CHOUT = ' to prepare BINFO ( binary reflection date file ) '
         CALL SHOUT
         LIT2 = 'MERBIN'
         ENDIF
      CALL KEREQ6 (LIT1, LITA, LITAM, LEND)
      IF (LIT1 .EQ. 'DIRDIF') THEN
         LITA(30) = 'DIRDIF'
         LEND = 30
         ENDIF
      IF (LEND.GT.0 .AND. LIT1.NE.'ORBASE') THEN
         WRITE (CHOUT, 111) LITA(LEND)
  111    FORMAT ( ' You entered the program name ', A6,
     *            ' as a first parameter,')
         CALL SHOUT
         CHOUT = ' which should have been CCODE (= the compound code).'
         CALL SHOUT
         CALL KERROR ('First param. is not CCODE or H', 111, 'DDSTIN')
         ENDIF
      CALL KEREQ6 (LIT1, L, LMAX, LEND)
      IF (KIDDS .EQ. 1) CALL KERROR ('DDSYST file...', 0, 'DDSTIN')
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KIDDS)
      WRITE (IDDS, FMT='(''STOP'')')
      REWIND IDDS
      IF (LEND .LE. 0) GOTO 180
      IF (BATCH) CALL KERROR ('No help in Batch mode', 0, 'DDSTIN')
      IF (LIT2 .EQ. 'MISFIT') CALL KERROR (
     *   'No Help for MISFIT ... Ask PTB', 0, 'DDSTIN')
      GOTO (1,   2,  4,  4,   5,    6),   LEND
  1   CALL DDHELP (101., 101., 103., L, 1, KEND)
      GOTO 159
  4   CALL DDHELP (104., 102., 105., L, 1, KEND)
  2   IF (LIT2 .EQ. ' ') GOTO 3
      CALL DDHELP (102., 102., 105., L, 1, KEND)
      CALL KERROR ('DIRDIF H with 2nd parameter...', 2, 'DDSTIN')
  3   CALL DDHELP (103., 102., 105., L, 1, KEND)
      GOTO 159
  5   CALL DDHELP (105., 105., 107., L, 1, KEND)
      GOTO 159
  6   CALL DDHELP (106., 106., 107., L, 1, KEND)
  159 CALL KEPROZ
  180 CONTINUE
      IF (LIT2.EQ.'H' .OR. LIT2.EQ.'HELP' .OR. LIT2.EQ.'?') THEN
      CHOUT = ' Second parameter       ignored'
      CHOUT(19:24) = LIT2
      CALL SHOUT
      WRITE (IPR1, 183) LIT1
  183 FORMAT (' Continue interactively for CCODE = ', A6)
      LIT2 = ' '
      ENDIF
      NOCCO = 0
      IF (LIT1 .EQ. 'ORBASE') THEN
         NOCCO = 31
         IF (LIT2 .NE. ' ') THEN
            WRITE (LIS1, 187)
            WRITE (IPR1, 187)
  187       FORMAT (' Sorry, incorrect calling parameters:',
     *     /'    ORBASE alias ATMOD cannot be used as CCODE !',
     *     /' Normal calling sequence: DIRDIF [ CCODE [ PGM [ PARM ]]]',
     *     /' e.g.:  DIRDIF MONOS ATMOD    to generate an  ATMOD file.',
     *     /' But:   DIRDIF ATMOD  is used to generate the ATMOD file,',
     *     /'    in case the ORBASE routine can be used independent of',
     *     /'    compound-code information (e.g. no CRYSDA file used).',
     *     /' So: please, call again !'/)
            GOTO 159
         ELSE
            WRITE (LIS1, 188)
            WRITE (IPR1, 188)
  188       FORMAT (' Warning in calling ORBASE alias ATMOD:',
     *     /' Normal calling sequence: DIRDIF [ CCODE [ PGM [ PARM ]]]',
     *     /' e.g.:  DIRDIF MONOS ATMOD    to generate an  ATMOD file.',
     *     /' But the present call is used to generate the ATMOD file,',
     *     /'    using  the  ORBASE routine,  without reference to any'/
     *     '    compound-code information (e.g. no CRYSDA file used).'/)
            ENDIF
         LIT2 = LIT1
         LIT1 = 'NONAME'
         CCODE ='NONAME'
         ENDIF
            IF (CCODE .EQ. ' ' .OR. CCODE .EQ. 'NONAME') CCODE = LIT1
      IF (LIT1 .NE. CCODE) THEN
         WRITE (LIS1, 189) LIT1, CCODE
  189    FORMAT (' FORMAT 189: LIT1 = ', A6, '  CCODE = ', A6,' !?')
         CALL KERROR ('CCODE incorrect/inconsistent', 189, 'DDSTIN')
         ENDIF
      CALL KEREQ6 (LIT2, LITA, LITAM, KP2)
      IF (LIT2 .EQ. ' ') KP2 = 0
      IF (LIT1 .EQ. 'ORBASE') KP2 = 30
      IF (LIT1 .EQ. 'ORBASE') KPROG = 30
      IF (LIT2 .EQ. 'BATCH') THEN
         KP2 = 0
         FULBAT = .TRUE.
         FULAUT = .TRUE.
         ENDIF
      IF (KP2 .LT. 0) THEN
         CHOUT = ' Second parameter       incorrect ...'
         CHOUT(19:24) = LIT2
         CALL SHOUT
         CALL KERROR ('Calling error', 192, 'DDSTIN')
         ENDIF
      IF (KP2.EQ.4 .OR. KP2.EQ.5 .OR. KP2.EQ.6 .OR. KP2.EQ.8) THEN
         WRITE (LIS1, 192) LIT2
  192    FORMAT (/' Interactive run for program/option ', A8 /)
         KPROG = KP2
         SEMAUT = .TRUE.
         GOTO 194
         ENDIF
      IF (KP2 .GT. 0 .AND. KP2 .LE. 10) THEN
         CHOUT = ' Automatic run'
         CALL SHOUT
         FULAUT = .TRUE.
         SEMAUT = .TRUE.
         KPROG = KP2
         ENDIF
  194 CONTINUE
      CALL KEREQ6 (LIT3, LITA, LITAM, KP3)
      IF (LIT3 .EQ. ' ') KP3 = 0
      IF (LIT3 .EQ. 'NORECY' .OR. LIT3 .EQ. 'BATCH') KP3 = 0
      IF (LIT3 .EQ. 'NORECY') SWNOCY = .TRUE.
      IF (LIT3 .EQ. 'BATCH') FULBAT = .TRUE.
      IF (FULBAT .AND. .NOT. FULAUT) THEN
         WRITE (IPR1, 196) PROGNM, PROGNM
         WRITE (LIS1, 196) PROGNM, PROGNM
  196    FORMAT (' Error in calling DIRDIF: the program ', A8,
     *      ' normally runs online:' /
     *      ' only PATTY, ORIENT, TRACOR, PHASEX, FOUR and DIRP1 can',
     *      ' be used this way.',
     *      ' The BATCH parameter now is rejected: present action:',
     *      ' DIRDIF ', A8 )
         FULBAT = .FALSE.
         KP3 = 0
         ENDIF
      IF (NOCCO .EQ. 31) CALL ORBAX (NOCCO)
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQCR)
      KCROLD = KINQCR
      IF (KINQCR.NE.0 .AND. BATCH) CALL KERROR (
     *  'No CRYSDA file present: it is needed for Batch mode',
     *   0, 'DDSTIN')
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQCO)
      IF (KINQCO.NE.0 .AND. BATCH) CALL KERROR (
     *  'No CONDA file present: it is needed for Batch mode',
     *   0, 'DDSTIN')
      START0 = .TRUE.
      IF (KP2.EQ.29 .OR. KP2.EQ.30) GOTO 320
      IF (KIDDS .EQ. 0) THEN
         START0 = .FALSE.
         LBOS(1) = 'DDSTAR'
         CALL RDCOND (ICON, LBOS, 1, KCOLD)
         IF (KCOLD .NE. 1) CALL KERROR
     *      ('Inconsistent files DDJOB DDSYST CONDA ??', 196, 'DDSTIN')
         CALL KERROR ('Kanniet', 196, 'DDSTIN')
         ENDIF
  320 CONTINUE
      IRUN = IRUN + 1
      WRITE (CHOUT, FMT = '(66X, ''RUN'', I3) ') IRUN
      CALL SHOUT2
      IF (IRUN .GT. 1) WRITE(IPR1, FMT =
     *   '('' Run number assigned for this job: RUN'',I3)') IRUN
      WRITE (CHOUT, FMT='(''RUN '', I3, '' Call DIRDIF '', A36)')
     *  IRUN, CHINJ
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      IF (BATCH) CALL DDSTYX
  327 IF (KP2 .EQ. 11) THEN
         CALL CRYSDA
         CALL KEPROX
         RETURN
         ENDIF
      IF (KINQCR.NE.0) THEN
         CALL CRYSDA
      ELSE
         CALL KERINA (ICRYS, LIT, 1, LENDX)
         IF (LENDX .NE. 0) THEN
            WRITE(IPR1,FMT='('' Existing empty CRYSDA file rejected'')')
         ELSEIF (LIT(NLIT) .NE. 'KEEP') THEN
            WRITE(IPR1,FMT='('' Existing (old) CRYSDA file rejected'')')
            LENDX = -1
            ENDIF
         IF (LENDX .NE. 0) THEN
            WRITE(IPR1,FMT='('' A new CRYSDA file  will be prepared'')')
            KCROLD = -99
            CALL FILCLO (ICRYS, 'DELETE')
            CALL CRYSDA
            ENDIF
         ENDIF
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'TEST', KINQCR)
      IF (KCROLD.NE.0 .AND. KINQCR.EQ.0) CRYNEW = .TRUE.
      IF (KINQCR .EQ. 0) THEN
         CALL RDCRYS (ICRYS)
         CALL FILCLO (ICRYS, 'KEEP')
         ENDIF
      IF (KINQCO.EQ.0 .AND. KP2.GT.0) THEN
         CHOUT = ' Ignore or destroy old CONDA file'
         CALL SHOUT
         ENDIF
      IF (KP2 .EQ. 12) THEN
         WRITE (IDDS, FMT='(''DDMAIN'')')
         WRITE (IDDS, FMT='(''STOP'')')
         REWIND IDDS
         CALL FILCLO (IDDS, 'KEEP')
         CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'OUTPUT', KINQCO)
         WRITE (ICON, 630) CCODE, (ITIME(IT), IT=1,3)
         WRITE (ICON, FMT='(''PROGRAM DDMAIN''/
     *       ''OPTION 9 MERBIN only'' / ''FINISH'')')
         CALL FILCLO (ICON, 'KEEP')
         CALL KEPROX
         RETURN
         ENDIF
      CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'INPUT', KINQ)
      IF (KINQ .EQ. 0) THEN
         CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO)
         KBINFO = NINT (BUFFO(5))
         CHOUT = '0Warning: an old BINFO file is still existing!'
         CALL SHOUT
         IF (KBINFO .GT. 0) THEN
            WRITE (LIS1, 422)
            WRITE (IPR1, 422)
  422       FORMAT (
     *           ' It is incompatible with the present DIRDIF version!'
     *         / ' You must delete the old BINFO manually : conversion'
     *         / ' cannot be done with the present DIRDIF system.')
            CALL KERROR (' Wrong BINFO file ', 422, 'DDSTIN')
            ENDIF
         ENDIF
      IF (KP2 .EQ. 29) THEN
         IF (KINQ .GT. 0) THEN
            CHOUT=' Existing BINFO file wil be deleted !!'
            CALL SHOUT
            CALL FILCLO (IBINFO, 'DELETE')
            ENDIF
         CALL DDSPEC (LITA, LITAM, KP2, KP3)
         RETURN
         ENDIF
      IF (KINQ .EQ. 0) THEN
         CALL FILCLO (IBINFO, 'KEEP')
         CHOUT = '0We continue using it untill you have it deleted.'
         CALL SHOUT
         WRITE (LIS1, 427)
  427    FORMAT ( //' Note about the BINFO file :'/
     *   ' At an automatic run  BINFO is created and removed again.'/
     *   ' After a program crash  an existing BINFO may be deleted.'/
     *   ' However, if you wish to generate a permanent BINFO file,'/
     *   ' =====  to save time at repeated DIRDIF test runs  =====,'/
     *   ' the BINFO file can be generated by: DIRDIF CCODE BINFO .'/
     *   ' Note: a new BINFO file is automatically generated =====,'/
     *   ' ===== if the CRYSDA file is deleted or recreated. =====.'//)
      ELSE
         IF (KCROLD .EQ. 0) THEN
            CHOUT = '0Warning: an old CRYSDA file is still existing!'
            CALL SHOUT
            CHOUT = '0We continue using it untill you have it deleted.'
            CALL SHOUT
            WRITE (LIS1, 429)
  429       FORMAT ( //' Note about the CRYSDA file :'/
     *    ' At an automatic run CRYSDA is created and removed again.'/
     *    ' After a program crash an existing CRYSDA may be deleted.'/
     *    ' However, if you wish to generate a permanent CRYSDA file'/
     *    ' =====  to save time at repeated DIRDIF test runs  =====,'/
     *    ' a permanent CRYSDA file  can be generated  by entering :'/
     *    ' =====> DIRDIF CCODE CRYSDA'//)
            ENDIF
         ENDIF
      IF (KINQCO .NE. 0 .OR. KP2 .GT. 0) GOTO 507
  480 WRITE (IPR1, 485)
  485 FORMAT (' Shall we use the existing CONDA file?  Y/N/Q/H' )
      CALL KETERM (0, 1, LEND)
      IF (LEND.LT.0) GOTO 480
      IF (LIT(1).EQ.'Q') THEN
         WRITE (IPR1, FMT='('' Q = QUIT : now interpreted as STOP.'' /
     *      '' The CONDA file is saved for later use.'' )' )
         IF (START0) CALL KEPROZ
         ENDIF
      IF (LIT(1).EQ.'Y') THEN
         CHOUT = ' Continue with existing CONDA file'
         CALL SHOUT
         CALL DDSTYX
         RETURN
         ENDIF
      IF (LIT(1).EQ.'N') GOTO 507
      WRITE (IPR1, 490)
  490 FORMAT (' Y : YES  : use it, and prepare for execution now' /
     *        ' N : NO   : discard old CONDA file' /
     *        ' Q : QUIT : stop now. The file will be saved.' /
     *        ' H : Help : Inspect listing of old CONDA file:' )
  495 READ (ICON, END=501, FMT='(A72)') CHIN
      WRITE (IPR1, FMT='(1X,A50)') CHIN(1:50)
      GOTO 495
  501 REWIND ICON
      GOTO 480
  507 CONTINUE
      IF (KINQCO .EQ. 0) WRITE (IPR1, 509)
  509 FORMAT (' The existing CONDA file is discarded' )
      IF (IRUN .LE. 1 .OR. FULAUT) GOTO 628
      IF (TITLE .NE. ' ') GOTO 628
  625 WRITE (IPR1, FMT='('' Please give TITLE for printing:'')')
      CALL KETERM (-1, -1, KEND)
      IF (KEND .LT. 0) GOTO 625
      TITLE = CHIN(1:64)
      WRITE (LIS1, FMT='('' RUN TITLE: '', A64)') TITLE
      WRITE (LIS2, FMT='('' RUN TITLE: '', A64)') TITLE
  628 CONTINUE
      IF (KP2 .EQ. 30) CALL ORBAX (KP2)
      CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'OUTPUT', KINQCO)
      WRITE (ICON, 630) CCODE, (ITIME(IT), IT=1,3)
  630 FORMAT ('CONDA ', A6, 1X, I4, 2I3)
      IF (TITLE .NE. ' ') WRITE (ICON, FMT='(''TITLE '', A64)') TITLE
      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 (IPR1, 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. 'METFOU') LITA8 = 'METFOUR'
      IF (LITA8 .EQ. 'CRYSDA') THEN
         WRITE (IPR1, 819) CCODE
  819 FORMAT (' Note: the CRYSDA file for compound ', A6,' is present.'
     *      / ' If you want to update this file, edit CRYSIN ! '
     *      / ' The system now makes a permanent CRYSDA file. ')
         KP2 = 11
         GOTO 327
         ENDIF
      WRITE (CHOUT, FMT='('' The DIRDIF system will be activated'',
     *    '' to execute option/ program '', A8)') LITA8
      CALL SHOUT2
      RETURN
  880 CHOUT = ' No program given. STOP'
      CALL SHOUT
      CALL FILCLO (ICON, 'DELETE')
      IF (CRYNEW) THEN
         WRITE (IPR1, FMT='('' New CRYSDA file rejected.'')')
         CALL FILCLO (ICRYS, 'DELETE')
         ENDIF
      IF (START0) CALL KEPROZ
      END
      SUBROUTINE DDSTYX
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDS, IFILE(2)), (ICON, IFILE(4))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS2, IFILE(8))
      LOGICAL FULAUT, SENDBA, FULBAT
      EQUIVALENCE (FULAUT, SWITCH(12)), (SENDBA, SWITCH(22))
      EQUIVALENCE (FULBAT, SWITCH(21))
      CHARACTER LITA8 *8
      NCRY = -999
      CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ)
      REWIND ICON
      IF (SENDBA .AND. FULBAT) GOTO 190
      IF (.NOT. SENDBA .OR. FULAUT) GOTO 200
  152 WRITE (IPR1, FMT=
     *     '('' Do you wish to run this JOB now, online?  Y/B/Q/H'')')
      CALL KETERM (0, 1, KEND)
      IF (KEND .LE. 0) GOTO 152
      IF (KEND .EQ. 35) GOTO 200
      IF (KEND .EQ. 12) GOTO 190
      IF (KEND .EQ. 27) THEN
         WRITE (IPR1, FMT='('' Quit. The CONDA file is saved. '')')
         CALL KEPROX
         STOP 0
         ENDIF
      IF (KEND .NE. 18)
     *    WRITE (IPR1, FMT='('' Answer not understood:'')')
      WRITE (IPR1, 160)
  160 FORMAT (' Y = Yes: this JOB is meant to run online now'
     *      / ' B = Batch: this JOB is to be sent to Batch'
     *   /' Q = Quit = stop now: the CONDA file is saved for later use'
     *   /' H = Help: we now show you the present CONDA file:')
  162 READ (ICON, END=164, FMT='(A72)') CHIN
      WRITE (IPR1, FMT='(1X,A72)') CHIN
      GOTO 162
  164 REWIND ICON
      GOTO 152
  190 WRITE (IDDS, FMT='(''SENDBA'')')
      REWIND IDDS
      CALL KEPROX
      STOP 0
  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
      IF (LITA8 .EQ. 'METFOU') LITA8 = 'METFOUR'
      WRITE (IDDS, 220)  LITA8
  220 FORMAT (A8)
      GOTO 200
  230 WRITE (IDDS, FMT='(''STOP'')' )
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      IF (NCRY .EQ. 1) THEN
         CALL FILCLO (ICON, 'DELETE')
         CALL KEPROX
         STOP 0
         ENDIF
      REWIND ICON
      WRITE (LIS2, 231)
  231 FORMAT (' Contents of the CONDA file:')
      CHOUT = ' '
  233 READ (ICON, END=234, FMT='(A72)') CHOUT
      WRITE (LIS2, 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
      RETURN
      END
      SUBROUTINE DDHELP (AKEY, AKEYB, AKEYM, LITA, LITAM, KEND)
      CHARACTER * 6  LITA (LITAM)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6)), (IHELP, IFILE(9))
      EQUIVALENCE (LIS1, IFILE(7))
      PARAMETER (NNMAX=96, LLMAX=296)
      DIMENSION NN(NNMAX), NL(NNMAX), NC(NNMAX), NB(NNMAX)
      COMMON /CHELPB/ CH(LLMAX)
      CHARACTER CH*72
      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 /
      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 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 (CHOUT, FMT='('' REQUESTED LABEL:'', F8.3)') FNUM(1)
         CALL SHOUT
         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
      DO 515 LL=L,LM
  515 WRITE (IPR1, 516) CH(LL)
  516 FORMAT (1X, A72)
  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 (IPR1, 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 (IPR1, FMT='('' Question will be repeated:'')')
      GOTO 563
  580 IF (ALIT.NE.'H') GOTO 590
      WRITE (IPR1, FMT =
     * '('' Sorry, help not available. Please try again.'')' )
      GOTO 563
  590 WRITE (IPR1, 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 (IPR1, 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 (IPR1, 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 (IPR1, FMT='('' Your input line is empty; again:'')')
         REWIND IRD
         GOTO 510
         ENDIF
      IF (NFNUM.EQ.0 .AND. NLIT.EQ.0) THEN
         WRITE (IPR1, FMT='('' Blank line; please, try again:'')')
         GOTO 510
         ENDIF
      IF (LIT(1).EQ.'Q') THEN
         WRITE (IPR1, FMT='('' data request rejected. Repeat?'')')
         GOTO 563
         ENDIF
      IF (LIT(1).EQ.'H') THEN
         WRITE (IPR1, 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 (IPR1, 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 (IPR1, FMT='('' (Negative : number not fixed)'' /)')
         GOTO 510
         ENDIF
      KEND = NLUSE
      RETURN
  990 WRITE(IPR1, 991)
  991 FORMAT (' Fatal error occurred in the reading DDHELP file ' )
      GOTO 999
  992 WRITE (IPR1, 993) CHIN
      WRITE (LIS1, 993) CHIN
  993 FORMAT (' Error found in interpretation of HELP record:' // A72
     * // ' Could be an incorrect modification of the HELP file?' / )
  999 CALL KERNER (999, 'DDHELP')
      RETURN
      END
      SUBROUTINE CHINLI (KEND, L3, L4, LEND)
      PARAMETER (M72 = 72)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      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 (IPR1, 995) CHIN
      WRITE (LIS1, 995) CHIN
  995 FORMAT (' Syntax error in the help file. Last input line was:'/
     *  ' ', A72 /
     *  ' Perhaps you can read the original file: DIRDIF.HELP ??')
      CALL KERNER (-4, 'CHINLI')
      END
      SUBROUTINE DDSPEC (LITA, LITAM, KP2, KP3)
      CHARACTER * 6  LITA (LITAM)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDS, IFILE(2)), (ICON, IFILE(4)), (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      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. 23 .OR. KP3 .EQ. 23) CALL KERROR
     *   ('Program TRAMOL not available', 0, 'DDSPEC')
      IF (KP2 .EQ. 22 .AND. KP3 .EQ. 0) GOTO 113
      IF (KP2 .EQ. 22 .AND. KP3 .GT. 0) GOTO 500
      IF (KP2 .EQ. 29) THEN
         WRITE (IPR1, 106)
         WRITE (LIS1, 106)
         WRITE (LIS2, 106)
  106 FORMAT (/' Present procedure for MISFIT structures:' /
     *   ' - Assume two layers, with reflections hkl0 and 0klm '/
     *   ' - Solve layers independently (PATTY, PHASEX, recycle..)'/
     *   ' - Shift layers to the same origin, and '/
     *   ' - Find phases of satellites hklm by direct methods.'/
     *   ' Output file = input for program JANA / FOURIER (Petricek)'/)
         LL = 'MISFIT'
         GOTO 117
         ENDIF
      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'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      CALL KEPROX
      RETURN
  500 CONTINUE
      IF (LLL .EQ. 'BIJVOE')
     *WRITE (IPR1, FMT='('' BIJVOET : here no test for ATOMS file'')')
      IF (LLL .EQ. 'BIJVOE') LLL = 'BIJVOET'
      IF (LLL .EQ. 'METFOU') LLL = 'METFOUR'
      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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      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(IPR1,FMT = '('' Please give atom parameters as follows'')')
      NAT = 1
 130  WRITE(IPR1,FMT = '('' Supply : atom-name   x     y     z'' /
     +                   ''  ( eg. :    C12     0.13  0.14  0.15 )''
     +                ,5X,'' or type Q to quit'')')
 160  WRITE(IPR1,FMT = '('' Enter atom number'',I4,'' :'')') NAT
      CALL KETERM (-1,1,KEND)
      IF (KEND.GE.0) GOTO 180
 170  WRITE(IPR1,FMT = '('' Answer not acceptable''/)')
      GOTO 130
 180  IF (NFNUM.NE.3) GOTO 300
      IF (LIT(1)(1:1) .EQ. 'Q') GOTO 195
      IZ = 0
      CALL ATOMIZ (LIT(1)(1:2), NLET, IZ)
      I = NLET + 1
      CALL KERC2I (LIT(1)(I:I), NEN)
      IF (NEN.EQ.37 .OR. NEN.EQ.38) NEN = 0
      IF (NEN.EQ.45 .OR. NEN.EQ.46) NEN = 0
      IF (NEN.EQ.10) NEN = 0
      IF (NEN.LT.0 .OR. NEN.GT.9) GOTO 195
      IF (IZ .GT. 0) GOTO 240
 195  WRITE(IPR1,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(IPR1,310)
 310     FORMAT(' * No atoms input so far; Q not acceptable * '/)
         GOTO 130
         ENDIF
      NAT = NAT - 1
      WRITE (IATOMS,FMT = '(''END'')')
      WRITE (IPR1, 450) FATOMS
 450  FORMAT(' The ', A7, ' file has been created')
      REWIND IATOMS
      RETURN
      END
      SUBROUTINE DDORIE (KPROG)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL, IFILE(1)), (IATMOD, IFILE(1))
      EQUIVALENCE (ICON, IFILE(4)), (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IATOLD, IFILE(10))
      LOGICAL SEMAUT, FULAUT
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      LOGICAL SWORBA
      EQUIVALENCE (SWORBA, SWITCH(13))
      EQUIVALENCE (ICRYS, IFILE(3))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      DIMENSION ACELTY(10), NCELTY(10), NCELLZ(10)
      CHARACTER ACELTY *2
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT, PTBXX
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME
      CHARACTER *6 ATNAME(MAXAT)
      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)
      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 (IPR1, 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 (LIS2, 27, ATXYZ, ATNAME, IZAT, NAT)
         CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT)
         GOTO 230
         ENDIF
      IF (LIT(1) .EQ. 'N') GOTO 210
      IF (LIT(1) .EQ. 'Q') THEN
         CALL KEPROX
         STOP 0
         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 (IPR1,FMT='('' List ATMOD-file (may be edited later)'')')
         REWIND IATMOD
         DO 130 I= 1, NAT
  130    WRITE (IPR1, 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 SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
      CALL FILCLO (IATMOD, 'DELETE')
      CHIN3 = ' '
      CALL DDHELP (201.41, 201.3, 201.5 , LITA, LITAM, KEND)
      IF (LIT(1) .EQ. 'Q') CALL CONDEL
      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 (IPR1, FMT='('' File ATMOD with '', I4,
     *    '' atoms has been created'')') NAT
      IF (NAT .LE. 1) THEN
         WRITE (IPR1, 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 CONDEL
      IF (LIT(1) .EQ. 'Q') CALL CONDEL
      IF (LIT(1) .NE. 'H') CALL KERROR ('kanniet', 216, 'DDORIE')
      WRITE (IPR1, FMT='('' List ATMOD file (may be edited later)'')')
      REWIND IATMOD
      DO 217 I= 1, NAT
  217 WRITE (IPR1, 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)
      IF ((XYZT(1) .GT. 0.002 .OR. XYZT(2) .GT. 0.002 .OR.
     *    XYZT(3) .GT. 0.002 ) .AND. KINQ .EQ. 0)
     *    CALL SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
      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', 'TEST', KINQCR)
            IF (KINQCR .NE. 0) THEN
               CALL CRYSDA
               CALL FILINQ (ICRYS,'CRYSDA','FORMATTED', 'TEST', KINQCR)
               IF (KINQCR .NE. 0) CALL KERROR ('???', 238, 'DDORIE')
               CALL RDCRYS (ICRYS)
               CALL FILCLO (ICRYS, 'DELETE')
               ENDIF
            ENDIF
         CALL KERNAB (FRAC2C, XC, 9)
         GOTO 245
         ENDIF
      IF (ICELL .NE. -2) GOTO 240
  238 WRITE (IPR1, 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 (LIS1, 8240) LIT(2), CCODE
         WRITE (IPR1, 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 KERNAB (FRAC2C, XC, 9)
      IF (FULAUT) THEN
         WRITE (LIS1, 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 (IPR1, 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', 'TEST', KINQCR)
            IF (KINQCR .NE. 0) THEN
               CALL CRYSDA
               CALL RDCRYS (ICRYS)
               CALL FILCLO (ICRYS, 'DELETE')
               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 (IPR1, FMT='(A)')
     * ' Incorrect cell (in Angstrom/degrees !), please try again.'
      GOTO 242
  244 CALL MATF2C (CELLM, XC)
      WRITE (LIS2, 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 SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
  247 IF (IABS(ICELL) .EQ. 3) GOTO 248
      IF (FULAUT) GOTO 249
      WRITE (IPR1, 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
         CHOUT = ' .... no ATMOD file created ... '
         CALL SHOUT
         CALL FILCLO (IATMOD, 'KEEP')
         ENDIF
      IF (NAT .EQ. 0) CALL CONDEL
      IF (NAT .EQ. 1) CALL KERROR (
     *   'Only one atom left....', 248, 'DDORIE')
      IF (KINQ .EQ. 0) CALL SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
  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 (CHOUT, 2496) ATNAME(I), I
 2496    FORMAT (' Atom ', A6, ' (number ', I3,
     *   ') is not in the CRYSDA file.')
         CALL SHOUT
         CHOUT = ' .... no ATMOD file created ... '
         CALL SHOUT
         CALL FILCLO (IATMOD, 'KEEP')
         CALL KERROR (' Bad ATMOD file', 2496, 'DDORIE')
         ENDIF
      WRITE (IPR1, 2496) ATNAME(I), I
      WRITE (IPR1, 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 (LIS1, FMT=
     *  '('' Nr of Q-atoms rejected:'', I3)') NATQ
      IF (NATH .GT. 0) WRITE (LIS1, FMT=
     *  '('' Nr of H atoms rejected:'', I3)') NATH
      IF (NAT .LE. 1) THEN
         CHOUT = ' .... no ATMOD file created ... '
         CALL SHOUT
         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')
      IF (NATQ + NATH .GT. 0 .AND. KINQ .EQ. 0)
     *   CALL SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
      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
      IF (KINQ .EQ. 0) CALL SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
 4237 ISM = 0
      IF (KINQ .EQ. 0 .AND. ISYMX .EQ. 0) THEN
         WRITE (LIS1, 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 (LIS1, FMT='(A)')
     * ' ...not done: symmetry indicator on ATMOD file accepted !'
         GOTO 3490
         ENDIF
      CALL SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
 3490 CONTINUE
      IF (KINQ .EQ. 0) THEN
         IF (ISM .GT. 0) WRITE (LIS1, FMT='(A)')
     *       ' Symmetry checking for stored atoms finished. NOTE:'
         WRITE (IPR1, 3491)
         WRITE (LIS1, 3491)
 3491 FORMAT(' The original ATMOD file with Cartesian Coordinates' /
     *       ' has not been modified: it is not copied to ATOLD !' )
      ELSEIF (KINQ .EQ. -99) THEN
         WRITE (IPR1, 3492)
         WRITE (LIS1, 3492)
 3492 FORMAT(' The input ATMOD file is saved in ( copied to ) ATOLD :' /
     *       ' a new ATMOD file with Cartesian Coordinates is output.')
      ELSE
         WRITE (IPR1, 3493)
         WRITE (LIS1, 3493)
 3493 FORMAT(' Output ATMOD file with Cartesian Coordinates.')
         ENDIF
      WRITE (LIS1, FMT='('' Number of atoms:'', I4)') NAT
      IF (CHIN3 .NE. ' ') THEN
         CHOUT = CHIN3
         CHOUT(1:6) = 'source'
         ENDIF
      IF (KINQ .NE. 0) CALL ATOMWO (IATMOD, ATXYZ, ATNAME, NAT, 1, ISM)
      CALL FILCLO (IATMOD, 'KEEP')
      IF (KPROG .GE. 30) RETURN
      IRUN = KEYS(13)
      WRITE (CHOUT,FMT='(''RUN '',I3,'' ATMOD NAT= '',I4,
     *    '' KPROG '', I3)') IRUN, NAT, KPROG
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      WRITE (ICON, FMT='(''PROGRAM DDMAIN''/
     *    ''OPTION 4 PATT 0 PATOR'')')
      IF (.NOT. SEMAUT) WRITE (IPR1, 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 (IPR1, 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 (IPR1, 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 (LIS1, 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 (LIS1, 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='(''XBIG'' / ''VMAX  0  1'')')
      KPROG = 2
      RETURN
      END
      SUBROUTINE SAVMOD (IATMOD, IATOLD, CHOUT, KINQ)
      CHARACTER CHOUT *72
      CALL COPY80 (IATMOD, 'ATMOD', IATOLD, 'ATOLD')
      CHOUT = ' New ATMOD file header contains symmetry marker SYMX'
      CALL SHOUT2
      KINQ = -99
      END
      SUBROUTINE SELORB
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IATMOD, IFILE(1)), (IPR1, IFILE(6))
      EQUIVALENCE (IORB,  IFILE(10))
      CHARACTER *6 LTEST, ORB
      LOGICAL SWIF, ASKED
      DATA SWIF, ASKED  / .FALSE., .FALSE. /
      DATA FTEST, ITEST / 0.0, 0 /
      ITRY = 0
  100 ORB = 'ORUSER'
      ASKED = .FALSE.
  101 CALL FILINQ (IORB, ORB, 'FORMATTED', 'INPUT', KINQ)
      IF (KINQ .NE. 0 .AND. ORB .EQ. 'ORUSER') THEN
         ORB = 'ORBASE'
         GOTO 101
         ENDIF
      IF (KINQ .NE.0) CALL KERROR ('File ORBASE not found', 0, 'SELORB')
      IF ( ASKED ) GOTO 140
  120 WRITE (IPR1, 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 (IPR1, 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 CONDEL
      IF (NFNUM .EQ. 1) THEN
         FTEST = FNUM(1) + 0.0003
         ITEST = NINT (FTEST * 1000.)
         IF (ITEST.LE.0 .OR. ITEST.GE.1000000) THEN
            WRITE (IPR1, 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 (IPR1, 153)
  153 FORMAT (' End of file: search unsuccesful')
      IF (ITRY .EQ. 3) CALL KERROR ('Too many trials', 200, 'SELORB')
      WRITE (IPR1, 155)
  155 FORMAT (' Try again??')
      GOTO 100
  200 CHOUT = ' Search model found in  ORBASE.  Header record:'
      CHOUT(25:30) = ORB
      CALL SHOUT
      CHOUT(2:72) = CHIN
      CALL SHOUT
      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') THEN
         CHOUT(2:72) = CHIN
         CALL SHOUT
         ENDIF
      WRITE (IATMOD, 142) CHIN
      GOTO 220
  250 WRITE (IATMOD, FMT='(''END'')')
      REWIND IATMOD
      RETURN
      END
      SUBROUTINE DDTRAC (KPROG)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICON,  IFILE(4)), (IPR1, IFILE(6))
      EQUIVALENCE (KEYS(23), KPROG1)
      EQUIVALENCE (IFMAP, IFILE(17))
      LOGICAL SEMAUT
      EQUIVALENCE (SWITCH(10), SEMAUT)
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER (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', 'TEST', 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 (IPR1, 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   IF (FNUM(1).LT.0.01 .OR. FNUM(1).GT.1.) GOTO 160
      SMAX = FNUM(1)
      GOTO 150
  9   IF (FNUM(1) .LT. 0.01 .OR. FNUM(1).GT.1.) GOTO 160
      PSQMAX = FNUM(1)
      GOTO 150
  160 WRITE (IPR1, 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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICON,  IFILE(4)), (IPR1, IFILE(6))
      EQUIVALENCE (KEYS(23), KPROG1)
      LOGICAL SEMAUT, FULAUT
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      DIMENSION ALOCC(3), MAXHKL(3), ESTART(6), ACC(2)
      PARAMETER (LITAM = 6)
      DIMENSION IDHEL(LITAM)
      CHARACTER * 6 LITA(LITAM)
      DATA LITA / 'STLMAX', 'MAXHKL', 'LOCCEN', 'NCEST', 'ACCEPT',
     *            'PRINT' /
      DATA STLMAX / 0.0 /
      IF(KPROG1 .EQ. 3) KEYS(1) = 99
      WRITE (ICON, FMT='(''PROGRAM DDMAIN'')')
      IF (FULAUT .OR. KPROG1.NE.3) THEN
         WRITE (ICON, FMT='( ''OPTION 1 PHASEX'')')
      ELSE
         WRITE (ICON, FMT='( ''OPTION 1 PHASEX OK'')')
         ENDIF
      IF(KPROG1 .EQ. 10) WRITE (ICON, FMT='(''DIRP1'')')
      IF (SEMAUT) GOTO 142
      IF (KPROG1 .GE. 3) WRITE (IPR1, 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   IF (FNUM(1) .GT. 1.2  .OR.  FNUM(1) .LT. 0.1) GOTO 160
      STLMAX = FNUM(1)
      GOTO 150
  2   IF (NFNUM .NE. 3) GOTO 160
      DO 152 I=1,3
  152 MAXHKL(I) = NINT(FNUM(I))
      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 (IPR1, FMT='('' Unacceptable answer: rejected.'')')
      IDHEL(KEND) = 0
      GOTO 150
  167 FORMAT (A6, 6F7.4)
  168 FORMAT (A6, 3F10.6)
  169 FORMAT (A6, 3I4)
  170 IF (IDHEL(1).NE.0) WRITE (ICON, 168) LITA(1), STLMAX
      IF (IDHEL(2).NE.0) WRITE (ICON, 169) LITA(2), MAXHKL
      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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICON, IFILE(4))
      EQUIVALENCE (KEYS(23), KPROG1)
      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 (CHOUT,FMT='(48X,''option specified: '',A6)') LITF(KEND)
         CALL SHOUT2
         ENDIF
      IF (IOPT1 .EQ. 4) THEN
         CALL DDHELP (204.05, 204., 205., LITP, LITPM, KEND)
         IOPT2 = LITPN(KEND)
         WRITE (CHOUT,FMT='(48X,''option specified: '',A6)') LITP(KEND)
         CALL SHOUT2
         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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDL,   IFILE(1))
      EQUIVALENCE (IATOMS, IFILE(1)),  (ICON, IFILE(4))
      EQUIVALENCE (IPR1,   IFILE(6)),  (IATOLD, IFILE(10))
      EQUIVALENCE (KPROG1, KEYS(23))
      LOGICAL EXPAND
      EQUIVALENCE (EXPAND, SWITCH(23))
      LOGICAL SEMAUT, FULAUT
      EQUIVALENCE (SEMAUT, SWITCH(10)), (FULAUT, SWITCH(12))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME
      CHARACTER * 6 ATNAME(MAXAT)
      PARAMETER (LITAM = 7)
      DIMENSION IDHEL(LITAM), MAXHKL(3), BBB(3)
      CHARACTER * 6 LITA(LITAM)
      CHARACTER * 9 WILS(0:5)
      DATA LITA / 'STLMAX','MAXHKL','SCALE','BBB','WILSON','PRINT',
     *            'EXPAND' /
      DATA WILS / ' ','FIX BP','FIX BR','FIX BP BR','NO','PARTHA' /
      DATA NPROG, LITM / 0, 6 /
      DATA NATQ, NWILS, SCALE, STLMAX / 0, 0, 0.0, 0.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)
      CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD')
      NATQ = NAT
      DO 103 I = 1, NATQ
      IF (ATNAME(I)(1:1) .EQ. 'Q') NAT = NAT - 1
  103 CONTINUE
      IF (FULAUT) GOTO 130
         WRITE (IPR1, 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 CONDEL
         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 (IPR1, FMT='('' List ATOMS-file'')')
            DO 104 I= 1, NAT
  104       WRITE (IPR1, 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 CONDEL
      IF (LIT(1) .EQ. 'Q') CALL CONDEL
      IF (LIT(1) .EQ. 'Y') THEN
         CALL ATTERM (IATOMS, 'ATOMS', NAT)
         CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT)
         WRITE (IPR1, 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 CONDEL
         IF (LIT(1) .EQ. 'Q') CALL CONDEL
         IF (LIT(1) .EQ. 'H') THEN
            WRITE (IPR1, FMT='('' List ATOMS-file'')')
            DO 107 I= 1, NAT
  107       WRITE (IPR1, 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 (CHOUT, FMT='
     *      (I7, '' Q-atoms (peaks) ignored'')') NATQ-NAT
         CALL SHOUT2
         IF (NAT .EQ. 0) CALL KERROR (' Only Q-atoms ', 0, 'DDFCAL')
         ENDIF
      IRUN = KEYS(13)
      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   STLMAX = FNUM(1)
      GOTO 200
  2   CALL KERF2I (FNUM, MAXHKL, 3)
      GOTO 200
  3   SCALE = FNUM(1)
      GOTO 200
  4   CALL KERNAB (FNUM, BBB, 3)
      GOTO 200
  5   NWILS = NINT(FNUM(1))
      IF (NWILS.LT.0 .OR. NWILS.GT.5) THEN
         WRITE (IPR1, FMT=
     *      '('' Sorry wrong KEY given for WILSON plot. Try again.'')')
         IDHEL(KEND) = 0
         ENDIF
      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
      IF (I .EQ. 1) WRITE (ICON, FMT='(''STLMAX'', F7.4)') STLMAX
      IF (I .EQ. 2) WRITE (ICON, FMT='(''MAXHKL'',  3I4)') MAXHKL
      IF (I .EQ. 3) WRITE (ICON, FMT='(''SCALE'', 3F8.4)') SCALE
      IF (I .EQ. 4) WRITE (ICON, FMT='(''BBB'',   3F8.4)') BBB
      IF (I .EQ. 5) WRITE (ICON, FMT='(''WILSON '',  A9)') WILS(NWILS)
      IF (I .EQ. 6) WRITE (ICON, FMT='(''PRINT'')')
  300 CONTINUE
      IF (KPROG .NE. 5) GOTO 360
  350 WRITE (IPR1, 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 (IPR1, 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 (IPR1, FMT = '('' Answer not clear: please try again:'')')
      GOTO 350
  360 CONTINUE
      KPROG = 0
      RETURN
      END
      SUBROUTINE DDFFT  (KPROG)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICON,   IFILE(4)), (IPR1, IFILE(6))
      EQUIVALENCE (IBINFF, IFILE(16))
      EQUIVALENCE (KEYS(23), KPROG1)
      LOGICAL PATTER
      EQUIVALENCE (PATTER, SWITCH(26))
      LOGICAL SEMAUT
      EQUIVALENCE (SWITCH(10), SEMAUT)
      LOGICAL SWNOCY
      EQUIVALENCE (SWNOCY, SWITCH(18))
      DIMENSION XLIM(3), MAXHKL(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', 'TEST', KINQ)
      IF (KINQ .EQ. 0) GOTO 130
      WRITE (IPR1, 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   IF (NFNUM .NE. 3) GOTO 160
      DO 153 I=1,3
  153 MAXHKL(I) = NINT (FNUM(I))
      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 (IPR1, FMT='('' DMAX not useful for a Patterson map'')')
         GOTO 160
         ENDIF
      DMAX = FNUM(1)
      GOTO 150
  160 WRITE (IPR1, 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(3).NE.0) WRITE (ICON, 167) LITA(3), (MAXHKL(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) SWNOCY = .TRUE.
      IF (SWNOCY .AND. .NOT. PATTER) WRITE (ICON, FMT = '(''NORECY'')')
      KPROG = 0
      RETURN
      END
      SUBROUTINE DDPATY (KPROG)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     *               WAVE,     CELALL(10),  AMOLW,      ZET,
     *               NELEC,    F000,        ABSMU,      ICENT,
     *               ILATT,    ISYST,       ILAUE,      IMULT,
     *               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     *         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     *         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      LOGICAL        SWITCH
      EQUIVALENCE (ICON, IFILE(4)), (IPR1, IFILE(6))
      LOGICAL SEMAUT
      EQUIVALENCE (SWITCH(10), SEMAUT)
      LOGICAL SWNOCY
      EQUIVALENCE (SWNOCY, SWITCH(18))
      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 (CHOUT, FMT = '('' Sorry: at present PATTY does not'',
     *   '' operate in rhombohedral setting!'')')
         CALL SHOUT2
         WRITE (CHOUT, FMT = '('' DIRP1 or TRACOR are possible'',
     *   '' alternatives.'')')
         CALL SHOUT2
         WRITE (CHOUT, FMT = '('' Better: transforms data to'',
     *   '' hexagonal setting.'')')
         CALL SHOUT2
         WRITE (CHOUT, FMT = '('' Please write to us: we have an'',
     *   '' updated PATTY version'')')
         CALL SHOUT2
         WRITE (CHOUT, FMT = '('' Sorry for the inconveniance '')')
         CALL SHOUT2
         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 (IPR1, 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 (SWNOCY) 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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (IPR1, IFILE(6))
      WRITE (IPR1, FMT='('' Expand reflection data to space group P1'',
     *                   '' (or centered equivalent)'')')
      KPROG = 3
      RETURN
      END
      SUBROUTINE DDMERB (KPROG)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDS, IFILE(2)), (ICON, IFILE(4))
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      EQUIVALENCE (IBINFO, IFILE(11))
      LOGICAL SEMAUT, CRYNEW
      EQUIVALENCE (SEMAUT, SWITCH(10)), (CRYNEW, SWITCH(27))
      PARAMETER (LITAM = 2)
      DIMENSION IDHEL(LITAM), MAXHKL(3)
      CHARACTER * 6 LITA(LITAM)
      DATA LITA / 'STLMAX', 'MAXHKL' /
      DATA STLMAX / 0.0 /
      CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ)
      IF (KINQ.EQ.0) THEN
         CALL FILCLO (IBINFO,'DELETE')
         WRITE (LIS1, 401)
  401 FORMAT (/' Note: because you requested program MERBIN, '/
     *   ' which normally is run automatically,'/
     *   ' the existing BINFO file will be erased,'/
     *   ' end a new BINFO file will be generated.'/)
         ENDIF
      IF (CRYNEW) WRITE (IPR1, 501)
      IF (CRYNEW) WRITE (LIS1, 501)
  501 FORMAT (/' Note: you requested to execute program MERBIN, '/
     *   ' which normally is run automatically: '/
     *   ' the BINFO file will not be erased at the end of this RUN,'/
     *   ' but it will be as soon as a new CRYSDA file is made.'/
     *   ' To make a permanent BINFO file, either call:'/
     *   '     DIRDIF CCODE BINFO    ( non-interactive) '/
     *   ' or first make a permanent CRYSDA file by calling:'/
     *   '     DIRDIF CCODE CRYSDA '/)
      CALL DDHELP (212., 212., 213., LIT, 1, KEND)
      CALL KERNZI (0, IDHEL, LITAM)
  510 CALL DDHELP (212.1, 212., 213., LITA, LITAM, KEND)
      IF (KEND .EQ. 0) GOTO 520
      IDHEL(KEND) = NFDOL(1)
      GOTO (1, 2) KEND
      CALL KERNER (-5, 'DDMERB')
    1 STLMAX = FNUM(1)
      GOTO 510
    2 CALL KERF2I (FNUM, MAXHKL, 3)
      GOTO 510
  520 REWIND IDDS
      WRITE (IDDS, FMT='(''DDMAIN'' / ''STOP'')')
      REWIND IDDS
      CALL FILCLO (IDDS, 'KEEP')
      WRITE (ICON, FMT='(''PROGRAM DDMAIN''/
     *       ''OPTION 9 MERBIN only'')')
      DO 530 I=1,LITAM
      IF (IDHEL(I) .EQ. 0) GOTO 530
      IF (I .EQ. 1) WRITE (ICON, FMT='(''STLMAX'', F7.4)') STLMAX
      IF (I .EQ. 2) WRITE (ICON, FMT='(''MAXHKL'',  3I4)') MAXHKL
  530 CONTINUE
      WRITE (ICON, FMT='(''FINISH'')')
      CALL FILCLO (ICON, 'KEEP')
      CALL KEPROX
      STOP 0
      END
      SUBROUTINE DDMETF (KPROG)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IATOMS, IDDL, IFILE(1)), (ICON, IFILE(4))
      EQUIVALENCE (IPR1, IFILE(6)),        (IXYZN, IFILE(10))
      CALL KERROR ('TEMP out of order: see DDSTART', 0, 'DDMETF')
      CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'TEST', KINQA)
      CALL FILINQ (IXYZN,  'XYZN',  'FORMATTED', 'TEST', KINQX)
      IF (KINQA.EQ.-1 .AND. KINQX.EQ.-1) THEN
         WRITE (CHOUT,FMT='(''No ATOMS and XYZN file found!'')')
         CALL KERROR (CHOUT, 0, 'METSTART')
         ENDIF
      IF (KINQA.EQ.0 .AND. KINQX.EQ.0) THEN
         WRITE (CHOUT,FMT='('' Both ATOMS and XYZN file present'')')
         CALL SHOUT
         WRITE (CHOUT,FMT='('' Existing ATOMS file will be appended'',
     *                      '' at file ATOMOLD'')')
         CALL SHOUT
         WRITE (CHOUT,FMT='('' XYZN file will be used now'')')
         CALL SHOUT
         ENDIF
      CALL FILCLO (IATOMS, 'KEEP')
  200 WRITE (IPR1, FMT='('' Please give STLMAX for Fourier'',
     *                   '' procedure (suggested 0.4 ?):'')')
      CALL KETERM (1, 0, KEND)
      IF (KEND .LT. 0) GOTO 200
      STLMAX = FNUM(1)
      IF (STLMAX .LT. 0.001) GOTO 200
      CHOUT = 'Call= DD '
      CHOUT(10:15) = CCODE
      CHOUT(16:56) = ': MERBIN DDMAIN(FCALC) METFOUR'
      CALL LOGWR (IDDL)
      CALL FILCLO (IDDL, 'KEEP')
      WRITE (ICON, FMT='(''PROGRAM MERBIN START'', /,
     *                   ''STLMAX'', F7.4)') STLMAX
      IF (KINQX .EQ. 0) WRITE (ICON, FMT='(''PROGRAM NUTS X2AT'')')
      WRITE (ICON, FMT='(''PROGRAM DDMAIN'', /, ''OPTION 0 FCALC'', /,
     *                   ''PROGRAM METFOU'')')
      KPROG = 0
      RETURN
      END
      SUBROUTINE DDTRAM (KPROG)
      KPROG = -1
      RETURN
      END
      SUBROUTINE DDR2 (KPROG)
      KPROG = 4
      RETURN
      END
      SUBROUTINE ORBAX (KP2)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      LOGICAL SWORBA
      EQUIVALENCE (SWORBA, SWITCH(13))
      SWORBA = .TRUE.
      WRITE (IPR1, 101)
  101 FORMAT (' Online preparation of an ATMOD file, '/
     * ' manual input, update ATMOD, or input from the ORBASE file')
      CALL DDORIE (KP2)
      CALL KEPROX
      STOP 0
      END
      SUBROUTINE CONDEL
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICON, IFILE(4))
      LOGICAL START0
      EQUIVALENCE (START0, SWITCH(11))
      CALL FILCLO (ICON, 'DELETE')
      IF (START0) CALL KEPROZ
      CHOUT = '0Interrogation ended by user.'
      CALL SHOUT
      CALL KEPROX
      STOP 0
      END
      SUBROUTINE KEPROZ
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      CALL FILCLO (LIS1, 'DELETE')
      CALL FILCLO (LIS2, 'DELETE')
      STOP 0
      END
      SUBROUTINE COFRED
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      CHARACTER*78  AL15, AL16, AL17
      AL15 =   ' Commands: Del  Repl  Save  Undo  X Y Z  Add  Fuse  Meta
     *  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
      CHOUT = ' Fragment Editor commands applied:'
      CALL SHOUT2
      IF (NAT .LE. 20) CALL BESTVW
      SCALED = .FALSE.
      RINGED = .FALSE.
      METAED = .FALSE.
      CALL CFSAVE
      AL(1) =  ' FRED: simple FRagment EDitor'
   20 AL(15) = AL15
      AL(16) = AL16
      AL(17) = AL17
      AL(18) = ' '
      AL(19) = ' '
      CALL BSCHEM
      CALL SCFRAG
  100 CALL XFLUSH
  101 READ (IRD, 110, END=120) CHIN
  110 FORMAT (A80)
      CALL KERINB (LIT, 1)
      IF ( NLIT .LE. 0 ) GOTO 130
      EDOPT = LIT(1)
      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. MAXAT-6) THEN
            WRITE (IPR1, 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. 'M') THEN
         WRITE (IPR1, FMT='(A)')
     *     'This option is for future expansion; not yet programmed...'
         GOTO 101
         ENDIF
      IF (EDOPT .EQ. 'G') THEN
         CALL CFGEOM
         GOTO 101
         ENDIF
      IF (EDOPT .EQ. 'E  ' .OR. EDOPT .EQ. 'Q') GOTO 9000
      WRITE (IPR1, FMT='('' Illegal EDIT option entered: '',A6)') LIT(1)
  117 WRITE (IPR1, FMT='(A78)') AL15
      WRITE (IPR1, FMT='(A78)') AL16
      GOTO 101
  120 REWIND IRD
  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
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      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
      SCALE = ( (ATXYZ(2,J))**2 + (ATXYZ(3,J))**2 )**0.20
      IF ( SCALE .LT. 0.001 ) GOTO 200
      IF ( ATXYZ(2,J) .GE. 0.0 ) THEN
         XYZM(2) = XYZM(2) + ATXYZ(2,J)/SCALE
         XYZM(3) = XYZM(3) + ATXYZ(3,J)/SCALE
      ELSE
         XYZM(2) = XYZM(2) - ATXYZ(2,J)/SCALE
         XYZM(3) = XYZM(3) - ATXYZ(3,J)/SCALE
      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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      LOGICAL FIRST
      DATA FIRST /.TRUE./
      IF (FIRST) GOTO 9
      IF (AT2 .NE. ' ' .OR. NFNUM .NE. 0) THEN
         WRITE (IPR1, FMT='(A)')
     *       ' Not saved: option S does not take any parameters'
         RETURN
         ENDIF
      WRITE (LIS1, FMT='('' $$$ FRED: '', 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 (IPR1, FMT='(A)')
     *   ' Input fragment saved (it can be retrieved by command U)'
         FIRST = .FALSE.
         RETURN
         ENDIF
      WRITE (IPR1, 20) NAT
   20 FORMAT (' Current fragment saved:', I3, ' atoms.',
     *   ' Previously saved model overwritten')
      RETURN
      END
      SUBROUTINE BSCHEM
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1,  IFILE(7))
      EQUIVALENCE (LIS2, IFILE(8))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (LIS1, 105)
         WRITE (IPR1, 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 (LIS1,125)
         WRITE (IPR1,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 (IPR1,250) I
         WRITE (LIS1,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 (LIS2,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 (LIS2,930)
     *      ATNAME(I), E(IATYP(I)), H(IHTYP(I)), NHADD(I), NBATOM(I)
         IF (NBATOM(I) .NE. 0) WRITE (LIS2,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 (LIS2,940)
  940 FORMAT (/' Table of bonds' /
     * ' Atom    Atom    Dist   Bond-type' )
      DO 950 I = 1, NBONDS
         WRITE (LIS2,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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      DIMENSION NSOL(7), NSOLA(7), ICYCB(M200,2), KYPB(M200,2)
      DIMENSION NCOR(M200), NWT(M200), NATTAK(MAXAT), 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)
            NCOR(NCB) = I
         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
      NTAK2 = NTAK / 2
      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 )
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      DIMENSION       KYPB(M200,2), NWT(M200), NATTAK(MAXAT)
      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    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
         NSOLA(NF) = KYPB(NSOL(I),2)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE PLATST ( NSOLA, NTOT, KEYP )
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      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 )
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      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 ( IAND(I,1) .EQ. 1 ) 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
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      DIMENSION P(MAXAT), Q(MAXAT)
      DATA SCALE /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 ) SCALE  = MIN ( XSCALE, YSCALE )
      DO 130 I = 1, NAT
      IXP =     NINT( P(I)*SCALE ) + 37
      IYP = 8 - NINT( Q(I)*SCALE )
      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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      DATA M, MAL / 0 , 19 /
      IF (M .NE. 0) GOTO 160
      WRITE (IPR1, 110)
  110 FORMAT (' If your terminal does not scroll, then ....'/
     *   ' clear your screen before entering an edit command.')
      M = -1
  160 WRITE (IPR1,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 (IPR1,180) AL(I)
  170 CONTINUE
      DO 175 I = 14, MAL
      IF (AL(I) .NE. ' ') WRITE (IPR1,180) AL(I)
  175 CONTINUE
  180 FORMAT (A78)
      RETURN
      END
      SUBROUTINE CFHELP
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6))
      PARAMETER    (MAXAT = 993)
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      CHARACTER*1    JUNK
      IF (AT2 .NE. ' '.OR. NFNUM .NE. 0 .OR. NLIT .NE. 1) THEN
         WRITE (IPR1, FMT='(A)')
     *      ' Error? Option H does not take any parameters'
         RETURN
         ENDIF
      WRITE (IPR1, 10)
   10 FORMAT (
     * ' FRED  simple  FRagment EDitor  ------------ Commands:'/
     * '       Parameters between brackets () are optional'/
     * '       Leave out the brackets when supplying values!'//
     * ' 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......')
      READ (IRD, 20, END=30) JUNK
   20 FORMAT (A1)
      GOTO 40
   30 REWIND IRD
   40 WRITE (IPR1, 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 .......')
      READ (IRD, 20, END=60) JUNK
      GOTO 70
   60 REWIND IRD
   70 WRITE (IPR1, 80)
   80 FORMAT (/
     * ' 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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      CHARACTER*78  AL18
      NTODEL = 0
      TEMPAT = AT2
      IF (TEMPAT .EQ. ' ' .OR. NFNUM .NE. 0) THEN
         IF ( EDOPT .EQ. 'D  ' ) THEN
            WRITE (IPR1, FMT='(A)')
     *         ' Option D must be followed by a single atom-name'
         ELSE
            WRITE (IPR1, FMT='(A)')
     *         ' Option DEL must be followed by a single atom-name'
            ENDIF
         RETURN
         ENDIF
      IF (AT3 .NE. ' ') THEN
         IF ( EDOPT .EQ. 'D  ' ) THEN
            WRITE (IPR1, FMT='(A)')
     *         ' Option D must be followed by one atom-name only'
         ELSE
            WRITE (IPR1, FMT='(A)')
     *         ' Option DEL must be followed by one atom-name only'
            ENDIF
         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 (IPR1, 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 (IPR1, FMT='(A78)') AL18
         WRITE (IPR1, 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 (IPR1, 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 (IPR1, FMT='(A78)') AL18
      IF ( EDOPT .EQ. 'DEL' ) WRITE (IPR1, FMT='(A)')
     *   ' DEL option was used for deletion. Check your model!'
      RINGED = .FALSE.
      WRITE (LIS1, FMT='('' $$$ FRED: '', A80)') CHIN
      CALL BSCHEM
      CALL SCFRAG
      RETURN
      END
      SUBROUTINE CFREPL
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      CHARACTER CHOUTX*80
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, 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 (IPR1, 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 (IPR1, FMT='(A78)') AL18
  310 WRITE (LIS1, FMT='('' $$$ FRED: '', A80)') CHOUTX
      CALL BSCHEM
      CALL SCFRAG
      RETURN
  500 WRITE (IPR1, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ATCHK (ATN, NLET, IZ)
      CHARACTER*6 ATN
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (IPR1, IFILE(6))
      CHARACTER*78    AL18
      AL18 = ' '
      AL18 (2:7) = ATN
      CALL ATOMIZ (ATN(1:2), NLET, IZ)
      IF (IZ .LE. 0) THEN
         AL18 (8:78) = ': incorrect atomic symbol'
         WRITE (IPR1, FMT='(A78)') AL18
         RETURN
         ENDIF
      I = NLET + 1
      IF (ATN(I:I) .EQ. ' ') RETURN
      CALL KERC2I (ATN(I:I), NEN)
      IF (NEN.EQ.37 .OR. NEN.EQ.38) NEN = 0
      IF (NEN.EQ.45 .OR. NEN.EQ.46) NEN = 0
      IF (NEN.GE.0 .AND. NEN.LE.9) RETURN
      AL18 (8:78) = ': atomic symbol followed by illegal character'
      WRITE (IPR1, 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)
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      IF (AT2 .NE. ' ' .OR. NFNUM .NE. 0) THEN
         WRITE (IPR1, FMT='(A)')
     *           ' Not Undone: Option U does not take any parameters'
         RETURN
         ENDIF
      WRITE (LIS1, FMT='('' $$$ FRED: '', 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 (IPR1, FMT='(A)') ' Previously saved model restored'
      CALL BSCHEM
      CALL SCFRAG
      RETURN
      END
      SUBROUTINE CFROTA (KEYR)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      KEYR = 0
      IF ( NFNUM .NE. 1 .OR. NLIT .NE. 1 ) THEN
         WRITE (IPR1,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 (IPR1, 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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (LIS1, FMT='('' $$$ FRED: '', A80)') CHOUTX
      CALL BSCHEM
      CALL SCFRAG
      RETURN
  500 WRITE (IPR1, FMT='(A78)') AL18
      RETURN
  900 WRITE (IPR1, FMT='(A78)') AL18
  905 WRITE (IPR1, 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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER (MAXAT = 993)
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ADDSP3 ( NATADD, IZT, NADD, AFSTAN )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, 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 (IPR1, 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 (IPR1, 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 (IPR1, FMT='(A)')
     *            ' Undetermined sp3 orientation, no addition'
            ENDIF
         ENDIF
      RINGED = .FALSE.
      RETURN
      END
      SUBROUTINE ADDSP2 ( NATADD, IZT, NADD, AFSTAN )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, 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 (IPR1, 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 (IPR1, 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 (IPR1, FMT='(A)')
     *            ' Undetermined sp2 orientation, no addition'
            ENDIF
         ENDIF
      RINGED = .FALSE.
      RETURN
      END
      SUBROUTINE ADDSP1 ( NATADD, IZT, AFSTAN )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, 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
      CT = ATN
      IF (NAT .LE. 0) GOTO 999
      CALL ATOMIZ (ATN(1:2), 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 )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      CHARACTER*78 AL18
      DCO = 1.23
      IF ( IZAT(NATADD) .NE. 6 ) WRITE (IPR1, 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 (IPR1, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ADDNO2 ( NATADD )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      CHARACTER*78 AL18
      DCN = 1.47
      DNO = 1.22
      IF ( IZAT(NATADD) .NE. 6 ) WRITE (IPR1, 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
      NATORG = NATADD
      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 (IPR1, 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 (IPR1, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE ADDCN ( NATADD )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      CHARACTER*78 AL18
      DATA AL18 /' '/
      DCC = 1.50
      DCN = 1.16
      IF ( IZAT(NATADD) .NE. 6 ) WRITE (IPR1, 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
      NATORG = NATADD
      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 (IPR1, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE CFFUSE
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (LIS1, FMT='('' $$$ FRED: '', 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 (IPR1, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE FUSE5 ( NR1, NR2, DIST )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, 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 (IPR1, FMT='(A)')
     *   ' Warning, at least one atom added with some distance .LT. 0.9'
   30 CONTINUE
      IF ( NADD .NE. 0 ) THEN
         WRITE (IPR1, FMT='('' 5-membered aromatic ring added, '',
     *      ''  new atoms:'' / 6(1X, A6))') (NEWATS(I), I=1,NADD)
      ELSE
         WRITE (IPR1, FMT='(A)')
     *      ' All (new) atoms will overlap, no atoms added'
         ENDIF
      RETURN
      END
      SUBROUTINE FUSE6 ( NR1, NR2, DIST )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, 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 (IPR1, FMT='(A)')
     *   ' Warning, at least one atom added with some distance .LT. 0.9'
   30 CONTINUE
      IF ( NADD .NE. 0 ) THEN
         WRITE (IPR1, FMT='('' 6-membered aromatic ring added, '',
     *      ''  new atoms:'' / 6(1X, A6))') (NEWATS(I), I=1,NADD)
      ELSE
         WRITE (IPR1, FMT='(A)')
     *       ' All (new) atoms will overlap, no atoms added'
         ENDIF
      RETURN
      END
      SUBROUTINE CFGEOM
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (IPR1, FMT='(1X, A6, ''is bonded to: '', 10A6)')
     *   TEMPAT,  (ATNAME(IBON2(NR,I,1)),I=1,NB)
      WRITE (IPR1, 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 (IPR1, FMT='(A78)') AL18
      RETURN
      END
      SUBROUTINE CFEXIT ( KEY )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7))
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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 (LIS1, FMT='('' $$$ FRED: '', A80)') CHIN
         AL(15) = ' '
         AL(16) = ' '
         AL(17) = AL17X
         AL(18) = AL18X
         AL(19) = ' '
      NATDIF = NAT - L
      IF (NATDIF .NE. 0) THEN
         WRITE (IPR1, FMT='(A78)') AL1X
         NAT = L
         CALL SCFRAG
         CALL XFLUSH
      ELSE
         WRITE (IPR1, FMT='(A78/A78)') AL17X, AL18X
         ENDIF
   20 READ (IRD, 30, END=50) CHIN
   30 FORMAT (A80)
      CALL KERINB (LIT, 1)
      IF ( NLIT .LE. 0 ) GOTO 60
      ANSWER = LIT(1)
      IF ( ANSWER .EQ. 'Y') THEN
         WRITE (LIS1, FMT='('' $$$ FRED: Q OK'')')
         RETURN
         ENDIF
   40 IF ( ANSWER .EQ. 'N') GOTO 70
      IF ( ANSWER.EQ.'H' .OR. ANSWER.EQ. ' ') THEN
         IF (ANSWER .EQ. 'H') WRITE (IPR1, FMT='(A)')
     *       ' H: Repaint present fragment:'
         CALL XFLUSH
         GOTO 20
         ENDIF
      WRITE (IPR1, FMT='(A)')
     * ' Illegal answer, please enter Y or N (or H to repaint fragment)'
      WRITE (IPR1, FMT='(A78/A78)') AL17X, AL18X
      GOTO 20
   50 REWIND IRD
   60 ANSWER = ' '
      GOTO 40
   70 WRITE(IPR1, 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')
      READ (IRD, 30, END=90) CHIN
      CALL KERINB (LIT, 1)
      IF (NLIT .EQ. 1) GOTO 120
   90 REWIND IRD
  100 WRITE(IPR1, FMT='(A)')
     * ' Illegal answer, you must answer A B or C :'
      GOTO 70
  120 IF (LIT(1) .EQ. 'C') THEN
         WRITE (LIS1, FMT='('' $$$ FRED: Q=NOTOK CONTINUE'')')
         KEY = 1
         AL18 = ' Okay, continue...'
         GOTO 500
         ENDIF
      AL18 = ' FRED finished with this fragment'
      IF (LIT(1) .EQ. 'B') THEN
         WRITE (LIS1, FMT='('' $$$ FRED: Q=NOTOK BADMODEL STOP'')')
         NAT = 0
         GOTO 500
         ENDIF
      IF (LIT(1) .NE. 'A') GOTO 100
      WRITE (LIS1, FMT='('' $$$ FRED: Q=NOTOK ANOTHER MODEL'')')
      NAT = - NAT
  500 WRITE (IPR1, 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 )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      COMMON /ATNAMA/ ATNAME(MAXAT)
      CHARACTER * 6   ATNAME
      PARAMETER       (M200 = 321)
      COMMON /CFCOM / IBOND(M200,2), NBATOM(MAXAT), IBON2(MAXAT,11,2),
     *                IATYP(MAXAT), IBTYP(M200), IHTYP(MAXAT),
     *                BONDIS(M200), TM(3,3), NATSAV, NHADD(MAXAT),
     *                XYZSAV(3,MAXAT), IZTSAV(MAXAT), NDEL(11), NRING,
     *                NBONDS, RINGAT(8,100), SCALED, RINGED, METAED
      LOGICAL         SCALED, RINGED, METAED
      COMMON /CFCOMC/ EDOPT, ANSWER, AL(19), ATNSAV(MAXAT), AT2, AT3,
     *                AT4, TEMPAT
      CHARACTER       EDOPT*3, ANSWER*1, AL*78, ATNSAV*6, AT2*6, AT3*6,
     *                AT4*6, TEMPAT*6
      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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      PARAMETER    (NSLOT = 10, MAXAT = 993)
      COMMON /  /  DUMMY(1), ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), NAT
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      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
      CHOUT = ' No symmetry found in input model'
      CALL SHOUT2
      ISM = 0
      RETURN
  773 CALL ROT2X (B(1,IVMAX), ATXYZ, R, NAT)
      IF (ISYM(2,IVMAX).EQ.2) THEN
         WRITE (CHOUT, 774) ISYM(2,IVMAX)
  774    FORMAT (' Rotate model to bring' ,I3 ,
     *           '-fold rotation axis to the x-axis' )
      ELSE
         CHOUT =
     *   ' Rotate model to bring normal of mirror plane to the x-axis'
         ENDIF
      CALL SHOUT2
      ISM = 2
      GOTO 884
  800 IF (NV .EQ. 1) THEN
         CHOUT = ' Rotate model to bring vector along the x-axis'
      ELSE
         WRITE (CHOUT, 774) ISM
         ENDIF
      CALL SHOUT2
  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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (LIS1, IFILE(7))
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3))
      WRITE (IATMOD, 102) CCODE, IT, KEYS(13), MOD, ISM
  102 FORMAT ('ATMOD ', A6, ' CART ',
     *        ' date', I7, ' RUN', I4, ' MOD', I3, ' SYMX', I2)
      IF (CHOUT .NE. ' ') THEN
         WRITE (IATMOD, FMT = '(''REMARK '', A65)') CHOUT(1:65)
         CHOUT = ' '
         ENDIF
      WRITE (LIS1, 103) CCODE, IT, KEYS(13), MOD, ISM
  103 FORMAT (/ ' Leading record (header) of output ATMOD file is:'
     *      / ' ATMOD ', A6, ' CART ',
     *        ' date', 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 /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      LOGICAL        NWCRIN
      EQUIVALENCE (NWCRIN, SWITCH(14))
      EQUIVALENCE (LIS2, IFILE(8)), (LIS1, IFILE(7))
      NWCRIN = .FALSE.
      CALL CRINIT
      CALL SPGRIN
      CALL CRCELL
      CALL CRATOM
      CALL CRWRIT
      IF ( NWCRIN ) CALL WRCRIN
      RETURN
      END
      SUBROUTINE CRINIT
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IDDJ,  IFILE(1))
      EQUIVALENCE (ICRYS, IFILE(3)), (ICRIN,IFILE(14))
      EQUIVALENCE (IPR1,  IFILE(6)), (LIS1, IFILE(7))
      EQUIVALENCE (IHELP, IFILE(9)), (IBINFO, IFILE(11))
      EQUIVALENCE (KEYS(21), KP2)
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(24), KICRIN)
      LOGICAL NIJMEG, FULAUT
      EQUIVALENCE (NIJMEG, SWITCH(1)), (FULAUT, SWITCH(12))
      LOGICAL NWCRIN
      EQUIVALENCE (NWCRIN, SWITCH(14))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /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)
      CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ)
      IF (KINQ .EQ. 0)  THEN
         CALL FILCLO (IBINFO, 'DELETE')
         WRITE(CHOUT, FMT = '('' Existing BINFO file discarded'')')
         CALL SHOUT
         IF (KP2 .NE. 12) THEN
            WRITE (IPR1, 101) CCODE
            WRITE (LIS1, 101) CCODE
            ENDIF
  101    FORMAT (/' Note: the CRYSDA file for compound ', A6,
     *        ' is (re)created.' / ' A change of space group requires',
     *        ' a rerun of program MERBIN,' / ' and a change of cell',
     *        ' contents requires an update of scale and B,', /
     *        ' therefore the existing BINFO file cannot be trusted.'/)
         ENDIF
      IF (KEYS(4) .EQ. -1) CALL KERROR ('No  DDJOB file', 3, 'CRINIT')
      IF (CCODE .EQ. 'END') CALL KERROR ('Bad DDJOB file', 3, 'CRINIT')
      IF (LIT(2) .EQ. 'ORIENT' .OR. LIT(2) .EQ. 'TRACOR' .OR.
     *    LIT(2) .EQ. 'PATTY'  .OR.
     *    LIT(2) .EQ. 'PHASEX' .OR. LIT(2) .EQ. 'FOUR') FULAUT = .TRUE.
      KEYCEL = 0
      KEYORI = 0
      SPGR = ' '
      WAVEAT = ' '
      DO 102 I = 1, 10
      CELALL(I) = 0.
  102 CELATY(I) = ' '
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KICRYS)
      IF (KICRYS .NE. 0) GOTO 195
      CALL RDCRYS (ICRYS)
      WRITE (LIS1, 110)
  110 FORMAT (// ' Data as found in the existing CRYSDA file' /)
      KEYCEL = 1
      WRITE (LIS1, 121) CELL
  121 FORMAT (' CELL      ',6F10.5)
      WRITE (LIS1, 131) CELLSD
  131 FORMAT (' CELLSD    ',6F10.5)
      WRITE (LIS1, 140) SPGR
  140 FORMAT (' SPGR      ', A16)
      CALL WAVELN (WAVEAT, NEND)
      IF (NEND .NE. 0) CALL KERROR
     *   ('Incorrect radiation source on CRYSDA file', 0, 'CRINIT')
      WRITE (LIS1, 162) WAVEAT, WAVE
  162 FORMAT (' WAVE      ',A2, 8X, 'lambda(K<alpha>) = ', F10.6)
      DO 170 I = 1, 10
  170 ATCNT(I) = CELALL(I) / ZET
      WRITE (LIS1, 175) (CELATY(I), ATCNT(I), I=1, NTYPE)
  175 FORMAT (' FORMUL    ', 5(A2, F7.2, 2X) / 11X, 5(A2, F7.2, 2X) )
      WRITE (LIS1, 181) ZET
  181 FORMAT (' Z         ', F10.2, 10X,'Number of formula units/cell')
      CALL RDCRYB (ICRYS, 'ORIN', KEYORI)
      IF (KEYORI .LT. 0) GOTO 195
      BACKSPACE ICRYS
      READ (ICRYS, 183) ((RR(J,K), K=1,3), J=1,3)
  183 FORMAT (2(10X, 3F15.6 /), 10X, 3F15.6)
      WRITE (LIS1, 192) ((RR(I,J), J=1,3), I=1,3)
  192 FORMAT (' ORIN      ',3F15.11 / 11X,3F15.11 /  11X,3F15.11)
      KEYORI = 1
  195 CALL RESRD ( KEYCEL )
      CALL CIFCRY ( KEYCEL )
      CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KICRIN)
      IF (KICRIN .EQ. -1) THEN
         NWCRIN = .TRUE.
         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
  290 CALL XHELP (IHELP, IPR1, 160.)
      CALL  KETERM (0, 1, KEND)
      IF (KEND .EQ. 13) GOTO 301
      IF (KEND.EQ.27) THEN
         CALL FILCLO (ICRYS, 'DELETE')
         CALL KERROR('Quit requested by user',290,'CRINIT')
         ENDIF
      WRITE (IPR1, FMT='(A)') ' Please enter Q to Quit or C to Continue'
      GOTO 290
  301 WRITE (IPR1, 302)
  302 FORMAT (' Enter celldimensions A B C Alpha Beta Gamma:')
      CALL  KETERM (6, 0, KEND)
      IF (KEND .LT. 0) THEN
         IF (LIT(1) .EQ. 'Q')
     *      CALL KERROR ('Quit requested by user', 302, 'CRINIT')
         WRITE (IPR1, 302)
         WRITE (IPR1, FMT='('' ...... or Q to Quit:'')')
         GOTO 301
         ENDIF
      CALL KERNAB (FNUM, CELL, 6)
      IF (CELL(1).GT.0.9 .AND. CELL(2).GT.0.9 .AND. CELL(3).GT.0.9 .AND.
     *    CELL(4).GT.40. .AND. CELL(5).GT.40. .AND. CELL(6).GT.40.)
     *    GOTO 304
      WRITE (IPR1, FMT='(A)')
     * ' Incorrect cell (in Angstrom/degrees !), please try again.'
      WRITE (IPR1, FMT='('' Enter   Q   to Quit, or:'')')
      GOTO 301
  304 WRITE (IPR1, 305)
  305 FORMAT (' Enter standard deviations in celldimensions:')
      CALL KETERM (6, 0, KEND)
      IF (KEND .LT. 0) GOTO 304
      CALL KERNAB (FNUM, CELLSD, 6)
      WRITE (LIS1, 307) CELL, CELLSD
  307 FORMAT (' Entered from terminal:'/
     *        ' CELL:   ', 6F10.4 / ' CELLSD  ', 6F10.4)
  310 IF (WAVEAT .NE. '  ') RETURN
  311 WRITE (IPR1, 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)
      CALL WAVELN (WAVEAT, NEND)
      IF (NEND .NE. 0) GOTO 311
      WRITE (CHOUT, 317) WAVEAT
  317 FORMAT (' Entered from terminal: radiation source = ', A2)
      CALL SHOUT2
      RETURN
      END
      SUBROUTINE RDCRIN (ORIN, LINP)
      DIMENSION ORIN(3,3), LINP(9)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (LIS1, IFILE(7)), (ICRIN, IFILE(14))
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(26), IHKLF)
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      LOGICAL NWCRIN
      EQUIVALENCE (NWCRIN, SWITCH(14))
      CHARACTER * 6  L(9)
      DATA L / 'TITLE', 'CELL', 'CELLSD', 'SPGR', 'FORMUL', 'Z',
     *         'WAVE',  'ORIN', 'HKLF' /
      CALL KERNZI (0, LINP, 9)
      JORIN = 0
      CALL KERINA (ICRIN, LIT, 1, LEND)
      IF (LIT(1).NE.'CRYSIN')
     * CALL KERROR ('ERROR on first record of CRYSIN file', 0, 'RDCRIN')
      WRITE (CHOUT, 102) CCODE
  102 FORMAT ('0Input from control data file CRYSIN for compound ', A6)
      CALL SHOUT
      IF (KICRYS .EQ. 0) THEN
         CHOUT = ' (this data has higher priority)'
         CALL SHOUT
         ENDIF
      IF (CCODE .EQ. 'NONAME' .OR. LIT(2) .EQ. 'NONAME') GOTO 107
      IF (CCODE .NE. LIT(2)) THEN
         WRITE (CHOUT, 103) CCODE, LIT(2)
  103    FORMAT ('Error: CCODE = ',A6,' but on CRYSIN file it is ',A6)
         CALL SHOUT
         WRITE (LIS1, FMT='('' Assumedly this is an error in'',
     *      '' your local conversion program:''/'' We omit this test'',
     *      '' if NONAME is used for CCODE in the CRYSIN file. '')')
         CALL KERROR ('Wrong CCODE on CRYSIN', 103, 'RDCRIN')
         ENDIF
  107 NDAT = 1
      LAST = 0
  190 CALL KERIFF (ICRIN, L, 9, LEND)
      IF (LEND .LT. 0 .OR. LEND .GE. 5) THEN
         WRITE (LIS1, FMT=
     *   '('' Incorrect END of CRYSIN file: continue anyhow .... '')')
         NWCRIN = .TRUE.
         GOTO 300
         ENDIF
      IF (LEND .EQ. 4) GOTO 300
      KEND = NLUSER(1)
      WRITE (LIS1, 193) CHIN(1:72)
  193 FORMAT (' Input: ', 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 TITLE = CHIN(7:70)
      WRITE (LIS1, FMT='('' TITLE = '', A64)') TITLE
      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
      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)
      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)
      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 (CHOUT, FMT='('' Empty CRYSIN file: local PGM error?'')')
         CALL SHOUT
         GOTO 800
         ENDIF
      IF (FULAUT) THEN
         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')
         ENDIF
      IF (LINP(2) .NE. LINP(3)) THEN
         CHOUT = ' Both CELL and CELLSD must be given on CRYSIN file'
         CALL SHOUT
         GOTO 800
         ENDIF
      IF (LINP(2) .EQ. 0) THEN
         CHOUT = ' CELL and CELLSD must be given on CRYSIN file'
         CALL SHOUT
         GOTO 800
         ENDIF
      IF (LINP(5) .NE. LINP(6)) THEN
         CHOUT = ' If given, then both FORMUL and Z must be given'
         CALL SHOUT
         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
            CHOUT = ' Radiation source error (only Cu, Mo, Fe, Ag, Cr)'
            CALL SHOUT
            GOTO 800
            ENDIF
         ENDIF
      IF (LINP(8) .EQ. 1 .AND. JORIN .NE. 3) THEN
         CHOUT = ' ORIN matrix must consists of three records ...'
         CALL SHOUT
         GOTO 800
         ENDIF
      DO 500 I = 2, 7
         IF ( LINP(I) .EQ. 0 ) THEN
            NWCRIN = .TRUE.
            WRITE (LIS1, 510) L(I)
         END IF
  500 CONTINUE
  510 FORMAT (' Item ',A6,' missing, write new CRYSIN')
      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
      CHARACTER * 2  RADTN(5)
      DIMENSION RLAM1(5),RLAM2(5),RLAM3(5),RLAM4(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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7))
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(24), KICRIN)
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /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 (IPR1, 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 (CHOUT, 32) SPGR
   32    FORMAT ('0Space-group symbol retained: ', A16)
         CALL SHOUT
         CHIN = SPGR
         GOTO 70
         ENDIF
      IF (LIT(1) .NE. 'N') GOTO 21
      WRITE (CHOUT, 33) SPGR
   33 FORMAT ('0Previous space-group symbol rejected: ', A16)
      CALL SHOUT
   40 WRITE (IPR1, 50)
   50 FORMAT (' Give the space group symbol (30 characters max.)',
     * ' or H (for help)')
      CALL KETERM (-1, -1, KEND)
      IF (KEND .EQ. 18) THEN
         WRITE (IPR1, 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 (LIS1, 53) CHIN
   53 FORMAT (' Space group entered from terminal: ', A30)
   70 CALL SGTEST (IPR1, KEND)
      IF (KEND .GT. 0) GOTO 40
      IF (KEND .EQ. 0) CALL CRSPGR (SPGR, IPR1)
      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 (IPR1, 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 (IPR1, 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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      DIMENSION 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
      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
      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)
      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 (CHOUT, 260) SPGR
  260    FORMAT (' Non-standard space group-symbol changed into ',A16)
         CALL SHOUT
         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)
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      EQUIVALENCE (KEYS(25), KICRYS), (KEYS(24), KICRIN)
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /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 (LIS2, 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 (LIS2, 250) ARHMB, ALPRHM
  250 FORMAT (' The equivalent rhombohedral cell has A =', F8.4,
     * ' and Alpha =', F7.2 /)
      IF (AHEX.GT.0.0) WRITE (LIS2, 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
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (IPR1,  IFILE(6)), (LIS1, IFILE(7))
      EQUIVALENCE (KEYS(24), KICRIN)
      LOGICAL FULAUT
      EQUIVALENCE (FULAUT, SWITCH(12))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      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 (IPR1, 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 (IPR1, 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 (CHOUT, 405)
  405 FORMAT (' Valid molecular formula and Z retained.')
      CALL SHOUT
  403 ISKIP = 1
      DO 406 I = 1, NUMATO
      LIT(I) = CELATY(I)
  406 FNUM(I) = ATCNT(I)
      GOTO 431
  407 WRITE (CHOUT, 408)
  408 FORMAT (' Previous molecular formula and Z rejected.')
      CALL SHOUT
  409 WRITE (IPR1, 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 (IPR1, 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 (IPR1, 435) FNUM(I)
  435    FORMAT (' Error detected, zero or negative number', F8.2)
         GOTO 409
         ENDIF
      IF (LIT(I) (3:3) .NE. ' ') THEN
         WRITE (IPR1, 436) LIT(I)
  436    FORMAT (' Illegal atom symbol: ', A6, ' Please, try again')
         GOTO 409
         ENDIF
      TEMP = LIT(I)
      CALL CDATWT(TEMP, ATWT(I), IATNO(I), RADIUS(I),
     *   COVRAD(I), ATRAD(I), IERR)
      IF (IERR .NE. 0) THEN
         WRITE (IPR1, 436) LIT(I)
         GOTO 409
         ENDIF
  450 CONTINUE
      DO 480 I=1, NUMATO
      CELATY(I) = LIT(I)
      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 (LIS1, 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 (CHOUT, 510) IFO, DCALC
  510 FORMAT (' For',I3,' formula units per cell,  Dcalc is:', F6.3)
      CALL SHOUT
  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 (CHOUT, 541) IMULT
  541 FORMAT (' The multiplicity of the general position is:',I3 )
      CALL SHOUT
      WRITE (CHOUT, 542) ZPRED
  542 FORMAT (' Prediction based on volume considerations',
     *    ' (18 A**3 /atom) is: Z =',F6.2 )
      CALL SHOUT
      WRITE (IPR1, 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 (IPR1, 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
      NTYPS = I-1
      DCALC = AVOGAD*AW/V
      ABSLIN = ABSLIN/AW*DCALC
      AMOLW = AW / FLOAT(IFORM)
      RETURN
      END
      SUBROUTINE CRWRIT
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRYS, IFILE(3))
      EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8))
      EQUIVALENCE (IRUN, KEYS(13)), (KP2, KEYS(21))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      PARAMETER (MAXX=550)
      COMMON / / DUMMY(1), LINPX
      DIMENSION BLACOM(42000)
      EQUIVALENCE (BLACOM(1), DUMMY(1))
      CHARACTER * 80 LINPX(MAXX)
      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,216)
      LOGICAL SKIP
      CHARACTER * 1  NAX(3)
      CHARACTER * 4  POLAR(8)
      CHARACTER * 8  LAUEGR(14)
      CHARACTER * 12 LTYP(7), SYST(8)
      CHARACTER * 4  KEEP
      PARAMETER (LMAX=46)
      CHARACTER * 6  L(LMAX)
      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' /
      DATA L /  'CRYSDA', 'TITLE', 'CELL',  'CELLSD', 'SPGR', 'CELLCO',
     + 'RCELL', 'VOLUM',  'WAVE', 'FORMUL', 'MOLW',   'Z',     'NELEC',
     + 'F000',  'MU',     'DCALC', 'ICENT', 'ILATT',  'ISYST', 'ILAUE',
     + 'EQRHOM', 'EQHEXA', 'IMULT', 'IUNIQ', 'IPOLA', 'NTYPE', 'ELEM' ,
     + 'SFAC',  'NSYMM', 'SYMMAT', 'NLATT', 'CENVEC', 'NSXYZ', 'SYMIT',
     + 'FRAC2C', 'CART2F', 'RRMAT', 'SSMAT', 'ORIN' , 'REMARK',
     + 'CELCON', 'DIRECT', 'SIGDIR', 'NIGGLI', 'NORIG', 'ORGVEC' /
      NDAT = 0
      CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'OUTPUT', KICRYS)
      IF (KICRYS .NE. 0) GOTO 300
      SKIP = .TRUE.
  190 CALL KERIFF (ICRYS, L, LMAX, LEND)
      IF (NFDOL(1) .LE. -7) CALL KERROR
     * ('Bad keyword (> 6 char) in old CRYSDA file', 190, 'CRWRIT')
      IF (LEND .LT. 0 .OR. LEND .GE. 4) GOTO 300
      IF (CHIN(1:1) .EQ. ' ' .AND. SKIP) GOTO 190
      IF (CHIN(1:1) .EQ. ' ') GOTO 193
      IF (NLUSER(1) .LT. 0) GOTO 193
      SKIP = .TRUE.
      GOTO 190
  193 SKIP = .FALSE.
      NDAT = NDAT + 1
      LINPX(NDAT) = CHIN
      GOTO 190
  300 REWIND ICRYS
      KEEP = ' '
      IF (KP2.EQ.11 .OR. KP2.EQ.12) KEEP = 'KEEP'
      WRITE (ICRYS, 571) CCODE, (ITIME(I), I=1,3), IRUN, KEEP
  571 FORMAT ('CRYSDA    ', A6, ' Crystal data file, date: ',
     *   I4, 2I3, ' RUN ', I3, ' ', A4)
      IF (TITLE(1:4) .NE. '    ') WRITE (ICRYS, 573) TITLE
  573 FORMAT ('TITLE     ', A64)
      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 (LIS1 , 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)
      IF (NDAT .EQ. 0) GOTO 1589
      WRITE (ICRYS, 1580)
 1580 FORMAT ('REMARK    Copy of unknown (old) records:')
      DO 1582 N = 1, NDAT
 1582 WRITE (ICRYS, 586) LINPX(N)
 1589 WRITE (ICRYS, 1311)
 1311 FORMAT ('END       ')
      WRITE (LIS1, 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 (LIS1, FMT='(A)')
     *  '                                 : a print is given in LIS2'
      WRITE (LIS2, 585)
  585 FORMAT (/' The following CRYSDA file has been created:' /)
      REWIND ICRYS
  589 READ (ICRYS, 586, END=587) CHIN
  586 FORMAT (A80)
      WRITE (LIS2, 588) CHIN
  588 FORMAT (1X,A80)
      GOTO 589
  587 WRITE (LIS2, 588)
      RETURN
      END
      SUBROUTINE CRSYMM
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRYS, IFILE(3))
      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, IPR1)
      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 (RT(5,1,M2).EQ.RT(5,1,N)) GOTO 2910
        IF (RT(5,1,M2).NE.-RT(5,1,N)) GOTO 2920
        NCENT = 1
2910    CONTINUE
        IF (RT(5,2,N).NE.RT(5,2,M2)) GOTO 2990
        GOTO 3000
2920    CONTINUE
        N = N+1
        IF (N.GT.25 ) IER=14
        IF (IER.GT.0) GOTO 500
2900    CONTINUE
        IDENT = 0
        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 (RT(5,1,N).EQ.RT(5,1,M2)) GOTO 2930
        IF (-RT(5,1,N).NE.RT(5,1,M2)) 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,IPR1)
        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,NAXIS,NCENT,LCENT,NSYM,NPOL,CEN,NCV)
        IF (IERX .EQ. 0) RETURN
      IER = IERX
  500 CALL SGERRS (SPG,IER,IPR1)
      NAXIS = 4
      RETURN
      END
      SUBROUTINE SGPRNT(JRT,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,CEN,NCV)
      CHARACTER * 3  OUTL(3,2,1)
      CHARACTER * 4  XYZ(12), TRA(11)
      DIMENSION JRT(3,4,24),CEN(3,4)
      DIMENSION NCVT(7),CENV(3,6)
      DIMENSION NSYS(14)
      DIMENSION NCEN2(3,4),NCENV2(3,6)
      DATA XYZ   /  '-Z  ',   '-Y  ',   '-X  ',   'X-Y ',   'ERR ',
     *              'Y-X ',   ' X  ',   ' Y  ',   ' Z  ',   '+X  ',
     *              '+Y  ',   '+Z  ' /
      DATA TRA   /  '    ',   'ERR ',   '1/6 ',   '1/4 ',   '1/3 ',
     *              'ERR ',   '1/2 ',   'ERR ',   '2/3 ',   '3/4 ',
     *              '5/6 ' /
      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
     * 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
      NCEN2(1,1)=0
      NCEN2(2,1)=0
      NCEN2(3,1)=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)
      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
        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)
      NAXI=NAXIS
      IF(LSYS.EQ.4.OR.LSYS.EQ.6.OR.LSYS.EQ.7) NAXI=3
      NPOL=NPOL*10000+LSYS*1000+MULT
      NSYM2=NSYM+2
        DO 200 I=1,NSYM
        DO 190 J=1,3
        IJ = 2*JRT(J,1,I)+3*JRT(J,2,I)+4*JRT(J,3,I)+5
        IK = JRT(J,4,I)+1
        IF (IK.GT.1.AND.IJ.GT.6 ) IJ=IJ+3
        OUTL(J,2,1) = XYZ(IJ)
        OUTL(J,1,1) = TRA(IK)
190     CONTINUE
  200 CONTINUE
      RETURN
      END
      SUBROUTINE SGERRS (SGP, IER, LIS1)
      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)
      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 (D(3,3).EQ.0.0) GOTO 210
        D(3,3)=0.0
        D(3,2) = D(3,2)+0.5
        GOTO 210
1407    CONTINUE
        IF (D(2,2).EQ.0.0) GOTO 210
        D(2,2)=0.0
        D(2,1) = D(2,1)+0.5
        GOTO 210
1408    CONTINUE
        IF (D(1,1).EQ.0.0) 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 (D(1,1).EQ.0.0 ) 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, IPRX)
      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 /
        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 (RT(5,1,N)+RT(5,1,M2).EQ.0 ) M2Z=1
        IF (RT(3,3,N)+RT(3,3,M2Z).LE.0 ) 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,216)
      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 )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (IRES, IFILE(2))
      EQUIVALENCE (IPR1, IFILE(6))
      EQUIVALENCE (LIS1, IFILE(7))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      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
      PARAMETER (LMAX = 5)
      CHARACTER*6 LTEXT (LMAX)
      CHARACTER*2 RADTN(5)
      DIMENSION RLAM3(5)
      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, 'RES' , 'FORMATTED', 'INPUT', KINR)
      IF (KINR .EQ. 0) GOTO  99
      CALL FILINQ (IRES, 'INS' , 'FORMATTED', 'INPUT', KINI)
      IF (KINI .NE. 0) RETURN
   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 (IPR1, 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(IPR1, 145)
         WRITE(LIS1, 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
         CALL KERC2I( LIT(N)(2:2), 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(IPR1, 155)
         WRITE(LIS1, 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
      WRITE (LIS1, 205)
  205 FORMAT
     * (' At least some data has been read from the INS/RES file...')
      CALL FILCLO (IRES, 'KEEP')
      RETURN
      END
      SUBROUTINE CIFCRY ( KEYCEL )
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRIN,  IFILE(1)), (ICIF,   IFILE(2))
      EQUIVALENCE (IPR1,   IFILE(6))
      EQUIVALENCE (LIS1,   IFILE(7))
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      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
      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(32), 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 (IPR1, 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
               CALL KERC2I ( LIT(I) (J:J), 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 (LIS1, 205)
  205 FORMAT
     * (' At least some data has been read from the CIF file...')
      RETURN
      END
      SUBROUTINE WRCRIN
      COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4),   KEYS(28),
     *               NFNUM,     NLIT,       NCOLN(32),  NCOLL(32),
     *               NFDOT(32), NFDOL(32),  NLUSER(32), FNUM(32),
     *               SWITCH(28)
      LOGICAL        SWITCH
      COMMON /SYSTB/ PROGNM,    PROSNM,     CCODE,      TITLE,
     *               CHIN,      LIT(32),    CHOUT
      CHARACTER      PROGNM *8, PROSNM *6,  CCODE *6,   TITLE *64,
     *               CHIN *80,  LIT *6,     CHOUT *72
      EQUIVALENCE (ICRIN, IFILE(1)), (LIS1, IFILE(7))
      EQUIVALENCE (KEYS(26), IHKLF)
      COMMON /CRYSA/ CELL(6),  CELLSD(6),   RCELL(6),   VOLUM,
     +               WAVE,     CELALL(10),  AMOLW,      ZET,
     +               NELEC,    F000,        ABSMU,      ICENT,
     +               ILATT,    ISYST,       ILAUE,      IMULT,
     +               IUNIQ,    IPOLA,       NTYPE,      NSYMM,
     +         IRSYMM(3,3,24), TSYMM(3,24), NLATT,      TLATT(3,4),
     +         FRAC2C(3,3),    CART2F(3,3), RRMAT(3,3), SSMAT(3,3)
      COMMON /CRYSB/ SPGR,     WAVEAT,      CELATY(10)
      CHARACTER      SPGR *16, WAVEAT *2,   CELATY *2
      COMMON /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, 20) TITLE
      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)
   20 FORMAT ('TITLE     ', A64)
   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 (LIS1, 100)
  100 FORMAT (///' The following CRYSIN file has been created:' /)
      REWIND ICRIN
  110 READ (ICRIN, 120, END=140) CHIN
  120 FORMAT (A80)
      WRITE (LIS1, 130) CHIN
  130 FORMAT (1X,A80)
      GOTO 110
  140 WRITE (LIS1, 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
